Skip to contents

Script_Generator

Benoit Falquet

script_generator.Rmd

Introduction

In addition of the embedded run() method to create a tlg, chevron offers a script-based approach that allows the user to quickly edit a chevron workflow without the need for modifying a chevron_tlg object. The script is generated as two separate components:

  • script_args method generates a script for parameters assignment based on the default value of the arguments but can be edit either manually after creation or using the dict argument.

  • script_funs methods expose by default only the script corresponding to the pre processing function in the generated script. However, the main and post processing functions can also be exposed in the script with the details = TRUE argument.

Using a chevron-defined object

The object returned by the script methods are vectors of character with one element per line of the script, that can be easily rendered.

res <- script_args(aet01)
writeLines(res)
#> 
#> # Arguments definition ----
#> 
#> adam_db <- stop("missing value")
#> arm_var <- "ACTARM"
#> anl_vars <- list(safety_var = c("FATAL", "SER", "SERWD", "SERDSM", 
#>     "RELSER", "WD", "DSM", "REL", "RELWD", "RELDSM", "SEV"))
#> anl_lbls <- "Total number of {patient_label} with at least one"
#> prune_0 <- FALSE
res <- script_funs(aet01, adam_db = "syn_data", args = "args_list")
writeLines(res)
#> # Edit Preprocessing Function.
#> pre_fun <- function (adam_db, ...) 
#> {
#>     adam_db$adae <- adam_db$adae %>% filter(.data$ANL01FL == 
#>         "Y") %>% mutate(FATAL = with_label(.data$AESDTH == "Y", 
#>         "AE with fatal outcome"), SER = with_label(.data$AESER == 
#>         "Y", "Serious AE"), SEV = with_label(.data$ASEV == "SEVERE", 
#>         "Severe AE (at greatest intensity)"), REL = with_label(.data$AREL == 
#>         "Y", "Related AE"), WD = with_label(.data$AEACN == "DRUG WITHDRAWN", 
#>         "AE leading to withdrawal from treatment"), DSM = with_label(.data$AEACN %in% 
#>         c("DRUG INTERRUPTED", "DOSE INCREASED", "DOSE REDUCED"), 
#>         "AE leading to dose modification/interruption"), SERWD = with_label(.data$SER & 
#>         .data$WD, "Serious AE leading to withdrawal from treatment"), 
#>         SERDSM = with_label(.data$SER & .data$DSM, "Serious AE leading to dose modification/interruption"), 
#>         RELSER = with_label(.data$SER & .data$REL, "Related Serious AE"), 
#>         RELWD = with_label(.data$REL & .data$WD, "Related AE leading to withdrawal from treatment"), 
#>         RELDSM = with_label(.data$REL & .data$DSM, "Related AE leading to dose modification/interruption"), 
#>         CTC35 = with_label(.data$ATOXGR %in% c("3", "4", "5"), 
#>             "Grade 3-5 AE"), CTC45 = with_label(.data$ATOXGR %in% 
#>             c("4", "5"), "Grade 4/5 AE"))
#>     adam_db$adsl <- adam_db$adsl %>% mutate(DCSREAS = reformat(.data$DCSREAS, 
#>         missing_rule))
#>     adam_db
#> }
#> 
#> # Create TLG
#> syn_data <- rlang::exec(.fn = pre_fun, adam_db = syn_data, !!!args_list)
#> tlg_output <- run(object = aet01, adam_db = syn_data, auto_pre = FALSE, verbose = TRUE, user_args = args_list)

With a modified chevron object

The script generator depends on the functions actually stored in the object. Modifying the chevron_tlg object can lead to a different script.

aet01_custom <- aet01
preprocess(aet01_custom) <- function(adam_db, new_format, ...) {
  reformat(adam_db, new_format)
}

res_args <- script_args(aet01_custom)
res_funs <- script_funs(aet01_custom, adam_db = "syn_data", args = "args_list")

Print the generated scripts. Note that a new argument new_format has been added and the pre processing function has been modified.

writeLines(res_args)
#> 
#> # Arguments definition ----
#> 
#> adam_db <- stop("missing value")
#> arm_var <- "ACTARM"
#> anl_vars <- list(safety_var = c("FATAL", "SER", "SERWD", "SERDSM", 
#>     "RELSER", "WD", "DSM", "REL", "RELWD", "RELDSM", "SEV"))
#> anl_lbls <- "Total number of {patient_label} with at least one"
#> new_format <- stop("missing value")
#> prune_0 <- FALSE
writeLines(res_funs)
#> # Edit Preprocessing Function.
#> pre_fun <- function(adam_db, new_format, ...) {
#>   reformat(adam_db, new_format)
#> }
#> 
#> # Create TLG
#> syn_data <- rlang::exec(.fn = pre_fun, adam_db = syn_data, !!!args_list)
#> tlg_output <- run(object = aet01_custom, adam_db = syn_data, auto_pre = FALSE, verbose = TRUE, user_args = args_list)

With custom argument definition

To define the value of an argument in the directly in the script_args method, pass it to a named list. Existing values will be overwritten.

Note: variables (in this case the dm object syn_data), have to be passed as symbol, using for instance rlang::sym.

dict <- list(
  adam_db = rlang::sym("syn_data"),
  some_character = "A",
  some_vector = c("A", "B")
)

res_args <- script_args(mng01, dict = dict)
res_funs <- script_funs(mng01, adam_db = "syn_data", args = "args_list")
writeLines(res_args)
#> 
#> # Arguments definition ----
#> 
#> adam_db <- syn_data
#> some_character <- "A"
#> some_vector <- c("A", "B")
#> dataset <- "adlb"
#> x_var <- "AVISIT"
#> y_var <- "AVAL"
#> y_name <- "PARAM"
#> arm_var <- "ACTARM"
#> center_fun <- "mean"
#> interval_fun <- "mean_ci"
#> show_table <- TRUE
#> jitter <- 0.3
#> show_n <- TRUE
#> show_h_grid <- TRUE
#> show_v_grid <- FALSE
#> legend_pos <- "top"
#> line_col <- nestcolor::color_palette()
writeLines(res_funs)
#> # Edit Preprocessing Function.
#> pre_fun <- function (adam_db, dataset, x_var = "AVISIT", ...) 
#> {
#>     adam_db[[dataset]] <- adam_db[[dataset]] %>% filter(.data$ANL01FL == 
#>         "Y") %>% mutate(AVISIT = reorder(.data$AVISIT, .data$AVISITN), 
#>         AVISIT = with_label(.data$AVISIT, "Visit"))
#>     dunlin::ls_unite(adam_db, dataset, cols = x_var, sep = "_")
#> }
#> 
#> # Create TLG
#> syn_data <- rlang::exec(.fn = pre_fun, adam_db = syn_data, !!!args_list)
#> tlg_output <- run(object = mng01, adam_db = syn_data, auto_pre = FALSE, verbose = TRUE, user_args = args_list)

If saved in a .R file, the generated script can be executed. The result stored in tlg_output can be printed.

tmp_args <- tempfile("my_script_args", fileext = "R")
writeLines(res_args, con = tmp_args)

tmp_funs <- tempfile("my_script_funs", fileext = "R")
writeLines(res_funs, con = tmp_funs)

args_list <- list(
  dataset = "adlb",
  arm_var = "ARM"
)

data(syn_data, package = "chevron")

source(tmp_args, local = knitr::knit_global(), echo = TRUE)
#> 
#> > adam_db <- syn_data
#> 
#> > some_character <- "A"
#> 
#> > some_vector <- c("A", "B")
#> 
#> > dataset <- "adlb"
#> 
#> > x_var <- "AVISIT"
#> 
#> > y_var <- "AVAL"
#> 
#> > y_name <- "PARAM"
#> 
#> > arm_var <- "ACTARM"
#> 
#> > center_fun <- "mean"
#> 
#> > interval_fun <- "mean_ci"
#> 
#> > show_table <- TRUE
#> 
#> > jitter <- 0.3
#> 
#> > show_n <- TRUE
#> 
#> > show_h_grid <- TRUE
#> 
#> > show_v_grid <- FALSE
#> 
#> > legend_pos <- "top"
#> 
#> > line_col <- nestcolor::color_palette()
source(tmp_funs, local = knitr::knit_global())
#> Using template:  mng01 
#> Using data:      syn_data 
#> 
#> Main args:
#>   dataset       : "adlb"
#>   x_var         : "AVISIT"
#>   y_var         : "AVAL"
#>   y_name        : "PARAM"
#>   y_unit        : NULL
#>   arm_var       : "ACTARM"
#>   center_fun    : "mean"
#>   interval_fun  : "mean_ci"
#>   show_table    : TRUE
#>   jitter        : 0.3
#>   show_n        : TRUE
#>   show_h_grid   : TRUE
#>   show_v_grid   : FALSE
#>   legend_pos    : "top"
#>   line_col      : nestcolor::color_palette()
#> 
#> Post args:
#>   No mapped argument.
tlg_output
#> $`Alanine Aminotransferase Measurement`

#> 
#> $`C-Reactive Protein Measurement`

#> 
#> $`Immunoglobulin A Measurement`

#> 
#> attr(,"class")
#> [1] "gg_list" "list"

Exploring Main and Post process functions

By specifying details = TRUE the main and post processing functions are also exposed.

res_fun <- script_funs(mng01, adam_db = "syn_data", args = "args_list", details = TRUE)
writeLines(res_fun)
#> # Edit Functions.
#> pre_fun <- function (adam_db, dataset, x_var = "AVISIT", ...) 
#> {
#>     adam_db[[dataset]] <- adam_db[[dataset]] %>% filter(.data$ANL01FL == 
#>         "Y") %>% mutate(AVISIT = reorder(.data$AVISIT, .data$AVISITN), 
#>         AVISIT = with_label(.data$AVISIT, "Visit"))
#>     dunlin::ls_unite(adam_db, dataset, cols = x_var, sep = "_")
#> }
#> 
#> main_fun <- function (adam_db, dataset = "adlb", x_var = "AVISIT", 
#>     y_var = "AVAL", y_name = "PARAM", y_unit = NULL, arm_var = "ACTARM", 
#>     center_fun = "mean", interval_fun = "mean_ci", show_table = TRUE, 
#>     jitter = 0.3, show_n = TRUE, show_h_grid = TRUE, show_v_grid = FALSE, 
#>     legend_pos = "top", line_col = nestcolor::color_palette(), 
#>     ...) 
#> {
#>     assert_all_tablenames(adam_db, c(dataset, "adsl"))
#>     checkmate::assert_character(x_var)
#>     checkmate::assert_string(y_var)
#>     checkmate::assert_string(y_name)
#>     checkmate::assert_string(y_unit, null.ok = TRUE)
#>     checkmate::assert_string(arm_var)
#>     checkmate::assert_string(center_fun)
#>     checkmate::assert_string(interval_fun)
#>     checkmate::assert_names(center_fun, subset.of = c("mean", 
#>         "median"))
#>     checkmate::assert_choice(interval_fun, c("mean_ci", "mean_sei", 
#>         "mean_sdi", "median_ci", "quantiles", "range"))
#>     checkmate::assert_flag(show_table)
#>     checkmate::assert_number(jitter, lower = 0, upper = 1)
#>     checkmate::assert_flag(show_n)
#>     checkmate::assert_flag(show_h_grid)
#>     checkmate::assert_flag(show_v_grid)
#>     checkmate::assert_choice(legend_pos, c("top", "bottom", "right", 
#>         "left"))
#>     checkmate::assert_character(line_col, null.ok = TRUE)
#>     assert_valid_variable(adam_db[[dataset]], x_var)
#>     assert_valid_variable(adam_db[[dataset]], y_var, types = list(c("numeric")))
#>     assert_valid_variable(adam_db[[dataset]], y_unit, types = list(c("character", 
#>         "factor")))
#>     assert_valid_variable(adam_db[[dataset]], arm_var, types = list(c("character", 
#>         "factor")), na_ok = FALSE)
#>     assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), 
#>         types = list(c("character", "factor")))
#>     assert_valid_variable(adam_db[[dataset]], "USUBJID", types = list(c("character", 
#>         "factor")), empty_ok = TRUE)
#>     assert_valid_var_pair(adam_db$adsl, adam_db[[dataset]], arm_var)
#>     df <- adam_db[[dataset]]
#>     line_col <- unlist(line_col)
#>     data_ls <- split(df, df$PARAM, drop = TRUE)
#>     x_var <- paste(x_var, collapse = "_")
#>     whiskers_fun <- switch(interval_fun, mean_ci = c("mean_ci_lwr", 
#>         "mean_ci_upr"), mean_sei = c("mean_sei_lwr", "mean_sei_upr"), 
#>         mean_sdi = c("mean_sdi_lwr", "mean_sdi_upr"), median_ci = c("median_ci_lwr", 
#>             "median_ci_upr"), quantiles = c("quantiles_0.25", 
#>             "quantile_0.75"), range = c("min", "max"))
#>     y_unit <- if (is.null(y_unit)) 
#>         NA
#>     else y_unit
#>     variables <- c(x = x_var, y = y_var, strata = arm_var, paramcd = y_name, 
#>         y_unit = y_unit)
#>     n_func <- if (show_n) 
#>         "n"
#>     else NULL
#>     table <- if (show_table) 
#>         c(n_func, center_fun, interval_fun)
#>     else NULL
#>     ggtheme <- ggplot2::theme_bw() + ggplot2::theme(legend.position = legend_pos) + 
#>         ggplot2::theme(axis.title.x = ggplot2::element_blank())
#>     ggtheme <- if (!show_v_grid) {
#>         ggtheme + ggplot2::theme(panel.grid.major.x = ggplot2::element_blank())
#>     }
#>     else {
#>         ggtheme + ggplot2::theme(panel.grid.major.x = ggplot2::element_line(linewidth = 1))
#>     }
#>     ggtheme <- if (!show_h_grid) {
#>         ggtheme + ggplot2::theme(panel.grid.minor.y = ggplot2::element_blank(), 
#>             panel.grid.major.y = ggplot2::element_blank())
#>     }
#>     else {
#>         ggtheme + ggplot2::theme(panel.grid.minor.y = ggplot2::element_line(linewidth = 1), 
#>             panel.grid.major.y = ggplot2::element_line(linewidth = 1))
#>     }
#>     if (!is.null(names(line_col))) {
#>         color_lvl <- sort(unique(df[[arm_var]]))
#>         col <- line_col[as.character(color_lvl)]
#>         if (anyNA(col)) {
#>             missing_col <- setdiff(color_lvl, names(col))
#>             stop(paste("Missing color matching for", toString(missing_col)))
#>         }
#>         col <- unname(col)
#>     }
#>     else {
#>         col <- line_col
#>     }
#>     ret <- lapply(data_ls, tern::g_lineplot, alt_count = adam_db[["adsl"]], 
#>         variables = variables, mid = center_fun, interval = interval_fun, 
#>         whiskers = whiskers_fun, position = ggplot2::position_dodge(width = jitter), 
#>         title = NULL, table = table, ggtheme = ggtheme, col = col, 
#>         subtitle_add_unit = !is.na(y_unit))
#>     do_call(gg_list, ret)
#> }
#> 
#> post_fun <- function (tlg, ...) 
#> {
#>     tlg
#> }
#> 
#> # Create TLG
#> tlg_output <- rlang::exec(.fn = pre_fun, adam_db = syn_data, !!!args_list) %>% 
#> rlang::exec(.fn = main_fun, !!!args_list) %>% 
#> rlang::exec(.fn = post_fun, !!!args_list)