chevron coverage - 97.56%

Files
Source

# cmt01a ----

#' @describeIn cmt01a Default labels
#' @export
#'
cmt01_label <- c(
  unique = "Total number of {patient_label} with at least one treatment",
  nonunique = "Total number of treatments"
)

#' @describeIn cmt01a Main TLG function
#'
#' @inheritParams gen_args
#' @param row_split_var (`character`) the variable defining the medication category. By default `ATC2`.
#' @param medname_var (`string`) variable name of medical treatment name.
#' @param summary_labels (`list`) of summarize labels. See details.
#'
#' @details
#'  * Data should be filtered for concomitant medication. `(ATIREL == "CONCOMITANT")`.
#'  * Numbers represent absolute numbers of subjects and fraction of `N`, or absolute numbers when specified.
#'  * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
#'  * Split columns by arm.
#'  * Does not include a total column by default.
#'  * Sort by medication class alphabetically and within medication class by decreasing total number of patients with
#'  the specific medication.
#'  `summary_labels` is used to control the summary for each level. If "all" is used, then each split will have that
#'  summary statistic with the labels. One special case is "TOTAL", this is for the overall population.
#'
#' @note
#'  * `adam_db` object must contain an `adcm` table with the columns specified in `row_split_var` and `medname_var`
#' as well as `"CMSEQ"`.
#'
#' @export
#'
cmt01a_main <- function(adam_db,
                        arm_var = "ARM",
                        lbl_overall = NULL,
                        row_split_var = "ATC2",
                        medname_var = "CMDECOD",
                        summary_labels = setNames(
                          rep(list(cmt01_label), length(row_split_var) + 1L), c("TOTAL", row_split_var)
                        ),
                        ...) {
  assert_all_tablenames(adam_db, "adsl", "adcm")
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_character(row_split_var, null.ok = TRUE)
  assert_list(summary_labels)
  assert_subset(names(summary_labels), c("all", "TOTAL", row_split_var))
  assert_subset(
    unique(unlist(lapply(summary_labels, names))),
    c("unique", "nonunique", "unique_count")
  )
  if ("all" %in% names(summary_labels)) {
    summary_labels <- lapply(
      c(TOTAL = "TOTAL", setNames(row_split_var, row_split_var)),
      function(x) {
        modify_character(summary_labels$all, summary_labels[[x]])
      }
    )
  }
  assert_valid_variable(adam_db$adcm, c(arm_var, row_split_var, medname_var), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adcm, c("USUBJID", "CMSEQ"), empty_ok = TRUE, types = list(c("character", "factor")))
  assert_valid_var_pair(adam_db$adsl, adam_db$adcm, arm_var)

  lbl_overall <- render_safe(lbl_overall)
  lbl_row_split <- var_labels_for(adam_db$adcm, row_split_var)
  lbl_medname_var <- var_labels_for(adam_db$adcm, medname_var)

  lyt <- occurrence_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    row_split_var = row_split_var,
    lbl_row_split = lbl_row_split,
    medname_var = medname_var,
    lbl_medname_var = lbl_medname_var,
    summary_labels = summary_labels,
    count_by = "CMSEQ"
  )

  tbl <- build_table(lyt, adam_db$adcm, alt_counts_df = adam_db$adsl)

  tbl
}

#' @describeIn cmt01a Preprocessing
#'
#' @inheritParams cmt01a_main
#'
#' @export
#'
cmt01a_pre <- function(adam_db, ...) {
  adam_db$adcm <- adam_db$adcm %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(
      CMDECOD = with_label(reformat(.data$CMDECOD, nocoding), "Other Treatment"),
      ATC2 = reformat(.data$ATC2, nocoding),
      CMSEQ = as.character(.data$CMSEQ)
    )
  adam_db
}

#' @describeIn cmt01a Postprocessing
#'
#' @inheritParams cmt01a_main
#' @inheritParams gen_args
#' @param sort_by_freq (`flag`) whether to sort medication class by frequency.
#'
#' @export
#'
cmt01a_post <- function(
    tlg, prune_0 = TRUE,
    sort_by_freq = FALSE, row_split_var = "ATC2",
    medname_var = "CMDECOD", ...) {
  if (sort_by_freq) {
    tlg <- tlg %>%
      tlg_sort_by_var(
        var = row_split_var,
        scorefun = cont_n_allcols
      )
  }
  tlg <- tlg %>%
    tlg_sort_by_var(
      var = c(row_split_var, medname_var),
      scorefun = score_occurrences
    )
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocess(tlg)
}

#' `CMT01A` Concomitant Medication by Medication Class and Preferred Name.
#'
#' A concomitant medication
#' table with the number of subjects and the total number of treatments by medication class.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' library(dplyr)
#'
#' proc_data <- syn_data
#' proc_data$adcm <- proc_data$adcm %>%
#'   filter(ATIREL == "CONCOMITANT")
#'
#' run(cmt01a, proc_data)
cmt01a <- chevron_t(
  main = cmt01a_main,
  preprocess = cmt01a_pre,
  postprocess = cmt01a_post
)

#' @keywords internal
split_and_summ_num_patients <- function(lyt, var, label, stats, summarize_labels, split_indent, ...) {
  assert_string(var)
  assert_string(label)
  lyt <- lyt %>%
    split_rows_by(
      var,
      child_labels = "visible",
      nested = TRUE,
      split_fun = rtables::drop_split_levels,
      label_pos = "topleft",
      split_label = label,
      indent_mod = split_indent
    )
  if (length(stats) > 0) {
    lyt <- lyt %>%
      summarize_num_patients(
        var = "USUBJID",
        .stats = stats,
        .labels = setNames(summarize_labels, stats),
        ...
      )
  }
  lyt
}
#' @keywords internal
get_sort_path <- function(x) {
  assert_character(x, null.ok = TRUE)
  x2 <- as.character(rbind(x, rep("*", length(x))))
  x2[-length(x2)]
}
#' @keywords internal
tlg_sort_by_vars <- function(tlg, vars, scorefun = cont_n_allcols, ...) {
  purrr::reduce(
    .x = lapply(seq_len(length(vars)), function(i) vars[seq_len(i)]),
    .f = tlg_sort_by_var,
    .init = tlg,
    scorefun = scorefun,
    ...
  )
}
#' @keywords internal
tlg_sort_by_var <- function(tlg, var, scorefun = cont_n_allcols, ...) {
  assert_character(var)
  if (length(var) == 0) {
    return(tlg)
  }
  var_path <- get_sort_path(var)
  tlg %>%
    valid_sort_at_path(
      path = var_path,
      scorefun = scorefun,
      ...
    )
}
#' @keywords internal
valid_sort_at_path <- function(tt, path, scorefun, ...) {
  if (valid_row_path(tt, path)) {
    tryCatch(
      sort_at_path(tt, path, scorefun, ...),
      error = function(e) {
        tt
      }
    )
  } else {
    tt
  }
}
#' @keywords internal
valid_row_path <- function(tlg, row_path) {
  if (nrow(tlg) == 0) {
    return(TRUE)
  }
  rpaths <- row_paths(tlg)
  non_star <- which(row_path != "*") + 1
  rpaths_choice <- unique(lapply(rpaths, `[`, non_star))
  any(vapply(rpaths_choice, identical, FUN.VALUE = TRUE, y = row_path[non_star - 1]))
}

#' Count patients recursively
#' @param lyt (`PreDataTableLayouts`) `rtable` layout.
#' @param anl_vars Named (`list`) of analysis variables.
#' @param anl_lbls (`character`) of labels.
#' @param lbl_vars Named (`list`) of analysis labels.
#' @keywords internal
count_patients_recursive <- function(lyt, anl_vars, anl_lbls, lbl_vars) {
  assert_list(anl_vars, names = "unique", types = "character")
  assert_character(anl_lbls, min.chars = 1L, len = length(anl_vars))
  nms <- names(anl_vars)
  for (k in seq_len(length(anl_vars))) {
    lyt <- lyt %>%
      count_patients_with_flags(
        var = "USUBJID",
        flag_variables = setNames(lbl_vars[[k]], anl_vars[[k]]),
        denom = "N_col",
        var_labels = anl_lbls[k],
        show_labels = "visible",
        table_names = nms[k],
        .indent_mods = 0L
      )
  }
  lyt
}
#' @keywords internal
score_all_sum <- function(tt) {
  cleaf <- collect_leaves(tt)[[1]]
  if (NROW(cleaf) == 0) {
    stop("score_all_sum score function used at subtable [", obj_name(tt), "] that has no content.")
  }
  sum(sapply(row_values(cleaf), function(cv) cv[1]))
}
#' @keywords internal
summarize_row <- function(lyt, vars, afun, ...) {
  summarize_row_groups(lyt = lyt, var = vars, cfun = afun, ...)
}

#' Summary factor allowing NA
#' @param x (`factor`) input.
#' @param denom (`string`) denominator choice.
#' @param .N_row (`integer`) number of rows in row-split dataset.
#' @param .N_col (`integer`) number of rows in column-split dataset.
#' @param ... Not used
#' @keywords internal
s_summary_na <- function(x, labelstr, denom = c("n", "N_row", "N_col"), .N_row, .N_col, ...) { # nolint
  denom <- match.arg(denom)
  y <- list()
  y$n <- length(x)
  y$count <- as.list(table(x, useNA = "no"))
  dn <- switch(denom,
    n = length(x),
    N_row = .N_row,
    N_col = .N_col
  )
  y$count_fraction <- lapply(y$count, function(x) {
    c(x, ifelse(dn > 0, x / dn, 0))
  })
  y$n_blq <- sum(grepl("BLQ|LTR|<[1-9]", x))
  y
}
#' Summarize variables allow `NA`
#' @keywords internal
summarize_vars_allow_na <- function(
    lyt, vars, var_labels = vars,
    nested = TRUE, ..., show_labels = "default", table_names = vars,
    section_div = NA_character_, .stats = c("n", "count_fraction"),
    .formats = list(count_fraction = format_count_fraction_fixed_dp), .labels = NULL, .indent_mods = NULL, inclNAs = TRUE) { # nolint
  afun <- make_afun(s_summary_na, .stats, .formats, .labels, .indent_mods, .ungroup_stats = c("count_fraction"))
  analyze(
    lyt = lyt, vars = vars, var_labels = var_labels,
    afun = afun, nested = nested, extra_args = list(...),
    inclNAs = inclNAs, show_labels = show_labels, table_names = table_names,
    section_div = section_div
  )
}

#' Count or summarize by groups
#' @param lyt (`PreDataTableLayouts`) `rtable` layout.
#' @param var (`string`) of analysis variable.
#' @param level (`string`) level to be displayed.
#' @param detail_vars (`character`) of variables for detail information.
#' @keywords internal
count_or_summarize <- function(lyt, var, level, detail_vars, indent_mod = 0L, ...) {
  assert_string(level)
  if (is.null(detail_vars)) {
    lyt <- lyt %>%
      count_values(
        var,
        values = level,
        table_names = paste(var, level, sep = "_"),
        .formats = list(count_fraction = format_count_fraction_fixed_dp),
        .indent_mods = indent_mod,
        ...
      )
  } else {
    lyt <- lyt %>%
      split_rows_by(var, split_fun = keep_split_levels(level), indent_mod = indent_mod) %>%
      summarize_row_groups(
        format = format_count_fraction_fixed_dp
      ) %>%
      split_rows_by_recurive(detail_vars[-length(detail_vars)], split_fun = drop_split_levels) %>%
      summarize_vars(
        detail_vars[length(detail_vars)],
        .stats = "count_fraction",
        denom = "N_col",
        show_labels = "hidden",
        .formats = list(count_fraction = format_count_fraction_fixed_dp),
        ...
      )
  }
  lyt
}

#' Count or summarize by groups
#' @param lyt (`PreDataTableLayouts`) `rtable` layout.
#' @param row_split_var (`character`) variable to split rows by.
#' @param ... Further arguments for `split_rows_by`
#' @keywords internal
split_rows_by_recurive <- function(lyt, row_split_var, ...) {
  args <- list(...)
  for (i in seq_len(length(row_split_var))) {
    args_i <- lapply(args, obtain_value, index = i)
    lyt <- do_call(
      split_rows_by,
      c(
        list(
          lyt = lyt,
          row_split_var
        ),
        args_i
      )
    )
  }
  lyt
}

#' Obtain value from a vector
#' @keywords internal
obtain_value <- function(obj, index) {
  if (is.list(obj)) {
    return(obj[[index]])
  }
  if (is.vector(obj) && length(obj) >= index) {
    return(obj[index])
  }
  return(obj)
}

#' Get page by value
#' @keywords internal
get_page_by <- function(var, vars) {
  assert_character(vars, null.ok = TRUE)
  assert_character(var, null.ok = TRUE, max.len = 1L)
  ret <- rep(FALSE, length(vars))
  if (is.null(var) || length(var) == 0) {
    return(ret)
  }
  index <- match(var, vars)
  assert_int(index, na.ok = TRUE)
  if (is.na(index)) {
    return(ret)
  }
  ret[seq_len(index)] <- TRUE
  return(ret)
}

#' Proportion layout
#'
#' @inheritParams rspt01_main
#' @param lyt layout created by `rtables`
#'
#' @keywords internal
proportion_lyt <- function(lyt, arm_var, methods, strata, conf_level, odds_ratio = TRUE, rsp_var = "IS_RSP") {
  non_stratified <- length(strata) == 0L
  lyt <- lyt %>%
    estimate_proportion_diff(
      vars = rsp_var,
      show_labels = "visible",
      var_labels = if (non_stratified) "Unstratified Analysis" else "Stratified Analysis",
      conf_level = conf_level,
      method = if (non_stratified) {
        methods[["diff_conf_method"]] %||% "waldcc"
      } else {
        methods[["strat_diff_conf_method"]] %||% "cmh"
      },
      variables = list(strata = strata),
      table_names = if (non_stratified) "est_prop_diff" else "est_prop_diff_strat"
    ) %>%
    test_proportion_diff(
      vars = rsp_var,
      method = if (non_stratified) {
        methods[["diff_pval_method"]] %||% "chisq"
      } else {
        methods[["strat_diff_pval_method"]] %||% "cmh"
      },
      variables = list(strata = strata),
      table_names = if (non_stratified) "test_prop_diff" else "test_prop_diff_strat"
    )

  if (odds_ratio) {
    lyt <- lyt %>%
      estimate_odds_ratio(
        vars = rsp_var,
        variables = if (non_stratified) list(strata = strata, arm = arm_var),
        table_names = if (non_stratified) "est_or" else "est_or_strat"
      )
  }

  lyt
}

#' Helper function to add a row split if specified
#'
#' @param lyt (`PreDataTableLayouts`) object.
#' @param var (`string`) the name of the variable initiating a new row split.
#' @param lbl_var (`string`)the label of the variable `var`.
#'
#' @keywords internal
#'
#' @return `PreDataTableLayouts` object.
#'
ifneeded_split_row <- function(lyt, var, lbl_var) {
  if (is.null(var)) {
    lyt
  } else {
    split_rows_by(lyt, var,
      label_pos = "topleft",
      split_label = lbl_var
    )
  }
}

#' Helper function to add a column split if specified
#'
#' @param lyt (`rtables`) object.
#' @param var (`string`) the name of the variable initiating a new column split.
#' @param ... Additional arguments for `split_cols_by`.
#'
#' @keywords internal
#'
#' @return `rtables` object.
#'
ifneeded_split_col <- function(lyt, var, ...) {
  if (is.null(var)) {
    lyt
  } else {
    split_cols_by(
      lyt = lyt,
      var = var,
      ...
    )
  }
}

#' Create a Null Report
#' @rdname report_null
#' @aliases null_report
#' @param tlg (`TableTree`) object.
#' @param ... not used. Important to be used directly as post processing function.
#'
#' @export
#'
#' @return original `TableTree` or a null report if no observation are found in the table.
#'
report_null <- function(tlg, ...) {
  assert_true(is.null(tlg) || rtables::is_rtable(tlg))

  if (is.null(tlg) || nrow(tlg) == 0L) {
    return(null_report)
  }
  if (count_children(tlg) == 0) {
    return(null_report)
  }
  tlg
}

#' Count Children
#' @keywords internal
count_children <- function(x) {
  assert_true(rtables::is_rtable(x))
  if (is(x, "ElementaryTable")) {
    return(length(x@children))
  }
  sum(vapply(
    tree_children(x),
    count_children,
    FUN.VALUE = 0
  ))
}

#' @export
#' @rdname report_null
null_report <- rtables::rtable(
  header = "",
  rrow("", "Null Report: No observations met the reporting criteria for inclusion in this output.")
)

#' @export
#' @rdname report_null
null_listing <- rlistings::as_listing(
  df = data.frame(x = formatters::with_label(
    "Null Report: No observations met the reporting criteria for inclusion in this output.", ""
  ))
)

has_overall_col <- function(lbl_overall) {
  !is.null(lbl_overall) && !identical(lbl_overall, "")
}

ifneeded_add_overall_col <- function(lyt, lbl_overall) {
  if (has_overall_col(lbl_overall)) {
    add_overall_col(lyt, label = lbl_overall)
  } else {
    lyt
  }
}

#' Analyze skip baseline
#' @param x value to analyze
#' @param .var variable name.
#' @param .spl_context split context.
#' @param paramcdvar (`string`) name of parameter code.
#' @param visitvar (`string`) name of the visit variable.
#' @param skip Named (`character`) indicating the pairs to skip in analyze.
#' @param .stats (`character`) See `tern::summarize_variables`.
#' @param .label (`character`) See `tern::summarize_variables`.
#' @param .indent_mods (`integer`) See `tern::summarize_variables`.
#' @param .N_col (`int`) See `tern::summarize_variables`.
#' @param .N_row (`int`) See `tern::summarize_variables`.
#' @param ... additional arguments for `tern::a_summary`.
#' @inheritParams cfbt01_main
#' @keywords internal
afun_skip <- function(
    x, .var, .spl_context, paramcdvar, visitvar, skip,
    precision, .stats, .labels = NULL, .indent_mods = NULL, .N_col, .N_row, ...) { # nolint
  param_val <- .spl_context$value[which(.spl_context$split == paramcdvar)]
  # Identify context
  split_level <- .spl_context$value[which(.spl_context$split == visitvar)]
  pcs <- if (.var %in% names(skip) && split_level %in% skip[[.var]]) {
    NA
  } else {
    precision[[param_val]] %||% precision[["default"]] %||% 2
  }

  fmts <- lapply(.stats, summary_formats, pcs = pcs, FALSE)
  names(fmts) <- .stats
  fmts_na <- lapply(.stats, summary_formats, pcs = pcs, ne = TRUE)
  ret <- tern::a_summary(
    .stats = .stats, .formats = fmts, .labels = .labels, .indent_mods = .indent_mods,
    x = x, .var = .var, .spl_context = .spl_context, .N_col = .N_col, .N_row = .N_row, ...
  )
  for (i in seq_len(length(ret))) {
    attr(ret[[i]], "format_na_str") <- fmts_na[[i]]()
  }
  ret
}

summary_formats <- function(x, pcs, ne = FALSE) {
  assert_int(pcs, lower = 0, na.ok = TRUE)
  switch(x,
    n = h_format_dec(format = "%s", digits = pcs - pcs, ne = ne),
    min = ,
    max = ,
    sum = h_format_dec(format = "%s", digits = pcs, ne = ne),
    mean = ,
    sd = ,
    median = ,
    mad = ,
    iqr = ,
    cv = ,
    geom_mean = ,
    geom_cv = ,
    se = h_format_dec(format = "%s", digits = pcs + 1, ne = ne),
    mean_sd = ,
    mean_se = h_format_dec(format = "%s (%s)", digits = rep(pcs + 1, 2), ne = ne),
    mean_ci = ,
    mean_sei = ,
    median_ci = ,
    mean_sdi = h_format_dec(format = "(%s, %s)", digits = rep(pcs + 1, 2), ne = ne),
    mean_pval = h_format_dec(format = "%s", digits = 2, ne = ne),
    quantiles = h_format_dec(format = "(%s - %s)", digits = rep(pcs + 1, 2), ne = ne),
    range = h_format_dec(format = "%s - %s", digits = rep(pcs, 2), ne = ne),
    median_range = h_format_dec(format = "%s (%s - %s)", digits = c(pcs, pcs + 1, pcs + 1), ne = ne)
  )
}

split_fun_map <- function(map) {
  if (is.null(map)) {
    drop_split_levels
  } else {
    trim_levels_to_map(map = map)
  }
}

infer_mapping <- function(map_df, df) {
  assert_data_frame(df)
  vars <- colnames(map_df)
  assert_names(names(df), must.include = vars)
  for (x in vars) {
    if (!test_subset(map_df[[x]], lvls(df[[x]]))) {
      rlang::abort(
        paste0(
          "Provided map should only contain valid levels in dataset in variable ", x,
          ". Consider convert ", x, " to factor first and add",
          toString(setdiff(map_df[[x]], lvls(df[[x]]))), "levels to it."
        )
      )
    }
  }
  res <- df[vars] %>%
    unique() %>%
    arrange(across(everything())) %>%
    mutate(across(everything(), as.character))
  if (!is.null(map_df)) {
    dplyr::full_join(map_df, res, by = colnames(map_df))[vars]
  } else {
    res
  }
}


#' Occurrence Layout
#'
#' @inheritParams gen_args
#' @inheritParams cmt01a_main
#' @param lbl_medname_var (`string`) label for the variable defining the medication name.
#' @keywords internal
#'
occurrence_lyt <- function(arm_var,
                           lbl_overall,
                           row_split_var,
                           lbl_row_split,
                           medname_var,
                           lbl_medname_var,
                           summary_labels,
                           count_by) {
  split_indent <- vapply(c("TOTAL", row_split_var), function(x) {
    if (length(summary_labels[[x]]) > 0L) -1L else 0L
  }, FUN.VALUE = 0L)
  split_indent[1L] <- 0L
  lyt <- basic_table() %>%
    split_cols_by(var = arm_var) %>%
    add_colcounts() %>%
    ifneeded_add_overall_col(lbl_overall)
  if (length(summary_labels$TOTAL) > 0) {
    lyt <- lyt %>%
      analyze_num_patients(
        vars = "USUBJID",
        count_by = count_by,
        .stats = names(summary_labels$TOTAL),
        show_labels = "hidden",
        .labels = render_safe(summary_labels$TOTAL)
      )
  }
  for (k in seq_len(length(row_split_var))) {
    lyt <- split_and_summ_num_patients(
      lyt = lyt,
      count_by = count_by,
      var = row_split_var[k],
      label = lbl_row_split[k],
      split_indent = split_indent[k],
      stats = names(summary_labels[[row_split_var[k]]]),
      summarize_labels = render_safe(summary_labels[[row_split_var[k]]])
    )
  }
  lyt %>%
    count_occurrences(
      vars = medname_var,
      drop = length(row_split_var) > 0,
      .indent_mods = unname(tail(split_indent, 1L))
    ) %>%
    append_topleft(paste0(stringr::str_dup(" ", 2 * length(row_split_var)), lbl_medname_var))
}

# aet03 ----

#' @describeIn aet03 Main TLG function
#'
#' @inheritParams gen_args
#'
#' @details
#'  * Default Adverse Events by Greatest Intensity table.
#'  * Numbers represent absolute numbers of patients and fraction of `N`.
#'  * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
#'  * Split columns by arm.
#'  * Does not include a total column by default.
#'  * Sort by Body System or Organ Class (`SOC`) and Dictionary-Derived Term (`PT`).
#'
#' @note
#'  * `adam_db` object must contain an `adae` table with the columns `"AEBODSYS"`, `"AEDECOD"` and `"ASEV"`.
#'
#' @export
#'
aet03_main <- function(adam_db,
                       arm_var = "ACTARM",
                       lbl_overall = NULL,
                       ...) {
  assert_all_tablenames(adam_db, "adsl", "adae")
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adae, c(arm_var, "AEBODSYS", "AEDECOD", "ASEV"), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
  assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)

  lbl_overall <- render_safe(lbl_overall)
  lbl_aebodsys <- var_labels_for(adam_db$adae, "AEBODSYS")
  lbl_aedecod <- var_labels_for(adam_db$adae, "AEDECOD")
  intensity_grade <- levels(adam_db$adae[["ASEV"]])

  lyt <- aet03_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_aebodsys = lbl_aebodsys,
    lbl_aedecod = lbl_aedecod,
    intensity_grade = intensity_grade
  )

  tbl <- build_table(lyt, df = adam_db$adae, alt_counts_df = adam_db$adsl)

  tbl
}

#' `aet03` Layout
#'
#' @inheritParams gen_args
#'
#' @param lbl_aebodsys (`string`) text label for `AEBODSYS`.
#' @param lbl_aedecod (`string`) text label for `AEDECOD`.
#' @param intensity_grade (`character`) describing the intensity levels present in the dataset.
#'
#' @keywords internal
#'
aet03_lyt <- function(arm_var,
                      lbl_overall,
                      lbl_aebodsys,
                      lbl_aedecod,
                      intensity_grade) {
  all_grade_groups <- list("- Any Intensity -" = intensity_grade)

  basic_table(show_colcounts = TRUE) %>%
    split_cols_by(var = arm_var) %>%
    ifneeded_add_overall_col(lbl_overall) %>%
    count_occurrences_by_grade(
      var = "ASEV",
      grade_groups = all_grade_groups,
      .formats = c("count_fraction" = format_count_fraction_fixed_dp)
    ) %>%
    split_rows_by(
      "AEBODSYS",
      child_labels = "visible",
      nested = TRUE,
      split_fun = drop_split_levels,
      label_pos = "topleft",
      split_label = lbl_aebodsys
    ) %>%
    summarize_occurrences_by_grade(
      var = "ASEV",
      grade_groups = all_grade_groups,
      .formats = c("count_fraction" = format_count_fraction_fixed_dp)
    ) %>%
    split_rows_by(
      "AEDECOD",
      child_labels = "visible",
      nested = TRUE,
      indent_mod = -1L,
      split_fun = drop_split_levels,
      label_pos = "topleft",
      split_label = lbl_aedecod
    ) %>%
    summarize_num_patients(
      var = "USUBJID",
      .stats = "unique",
      .labels = c("- Any Intensity -")
    ) %>%
    count_occurrences_by_grade(
      var = "ASEV",
      .indent_mods = -1L
    )
}

#' @describeIn aet03 Preprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
aet03_pre <- function(adam_db, ...) {
  asev_lvls <- c("MILD", "MODERATE", "SEVERE")
  adam_db$adae <- adam_db$adae %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(
      AEBODSYS = reformat(.data$AEBODSYS, nocoding),
      AEDECOD = reformat(.data$AEDECOD, nocoding),
      ASEV = factor(.data$ASEV, levels = asev_lvls)
    ) %>%
    filter(!is.na(.data$ASEV))

  adam_db
}

#' @describeIn aet03 Postprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
aet03_post <- function(tlg, prune_0 = TRUE, ...) {
  tlg <- tlg %>%
    tlg_sort_by_vars(
      c("AEBODSYS", "AEDECOD"),
      scorefun = cont_n_allcols
    )
  if (prune_0) tlg <- trim_rows(tlg)
  std_postprocess(tlg)
}

#' `AET03` Table 1 (Default) Advert Events by Greatest Intensity Table 1.
#'
#' An adverse events table categorized by System
#' Organ Class, Dictionary-Derived Term and Greatest intensity.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(aet03, syn_data)
aet03 <- chevron_t(
  main = aet03_main,
  preprocess = aet03_pre,
  postprocess = aet03_post
)

#' @include chevron_tlg-S4class.R

# run ----

#' Run the pipeline
#'
#' Execute the pre-processing, main and post-processing functions in a single run.
#'
#' @inheritParams gen_args
#' @param object (`chevron_tlg`) input.
#' @param auto_pre (`flag`) whether to perform the default pre processing step.
#' @param verbose (`flag`) whether to print argument information.
#' @param ... extra arguments to pass to the pre-processing, main and post-processing functions.
#' @param user_args (`list`) arguments from `...`.
#'
#' @name run
#' @export
setGeneric(
  "run",
  function(object, adam_db, auto_pre = TRUE, verbose = FALSE, ..., user_args = list(...)) standardGeneric("run")
)

#' Run the pipeline
#' @rdname run
#' @export
#' @examples
#' run(mng01, syn_data, auto_pre = TRUE, dataset = "adlb")
setMethod(
  f = "run",
  signature = "chevron_tlg",
  definition = function(object, adam_db, auto_pre = TRUE, verbose = FALSE, ..., user_args = list(...)) {
    assert_list(adam_db, types = "list")
    assert_flag(auto_pre)
    assert_flag(verbose)
    assert_list(user_args, names = "unique")
    if (verbose) {
      cl <- match.call()
      print_args(
        cl,
        user_args,
        args_ls(object, omit = c("...", "adam_db", "tlg")), auto_pre
      )
    }
    proc_data <- if (auto_pre) {
      list(adam_db = do_call(object@preprocess, c(list(adam_db), user_args)))
    } else {
      list(adam_db = adam_db)
    }

    res_tlg <- list(tlg = do_call(object@main, c(proc_data, user_args)))

    do_call(object@postprocess, c(res_tlg, user_args))
  }
)

#' Print Arguments
#' @keywords internal
print_args <- function(run_call, additional_args, args, auto_pre = TRUE) {
  assert_class(run_call, "call")
  assert_list(args)
  assert_flag(auto_pre)
  run_call[[1]] <- NULL
  run_call <- as.list(run_call)
  if (!is.null(additional_args)) {
    run_call <- c(run_call[c("object", "adam_db")], additional_args)
  } else {
    run_call[c("auto_pre", "verbose")] <- NULL
  }
  nms_args <- unique(unlist(lapply(args, names)))
  nms_call <- names(run_call)
  m <- pmatch(nms_call, nms_args)
  nms_call[!is.na(m)] <- nms_args[m[!is.na(m)]]
  names(run_call) <- nms_call
  cat(
    "Using template: ",
    if (is.name(run_call$object)) run_call$object else paste("object of class", class(run_call$object)),
    "\n"
  )
  cat(
    "Using data:     ",
    if (is.name(run_call$adam_db)) run_call$adam_db else paste("object of class", class(run_call$adam_db)),
    "\n"
  )
  if (auto_pre) {
    cat("\nPre args:\n")
    print_list(get_subset(args$preprocess, run_call))
  }
  cat("\nMain args:\n")
  print_list(get_subset(args$main, run_call))
  cat("\nPost args:\n")
  print_list(get_subset(args$postprocess, run_call))
  add_args <- run_call[
    !names(run_call) %in% c(names(args$main), names(args$postprocess), names(args$preprocess), "object", "adam_db")
  ]
  if (length(add_args) > 0) {
    cat("\nAdditional args:\n")
    print_list(add_args)
  }
  cat("\n\n")
}

#' Subset Arguments and Merge
#' @keywords internal
get_subset <- function(x, y) {
  utils::modifyList(
    x,
    y[names(y) %in% names(x)],
    keep.null = TRUE
  )
}

#' Print list
#' @keywords internal
print_list <- function(x, indent = 2L) {
  if (length(x) == 0) {
    cat(paste0(
      stringr::str_dup(" ", indent),
      "No mapped argument.\n"
    ))
    return()
  }
  k <- names(x)
  m_charx <- max(nchar(k), 1)
  for (k in names(x)) {
    cat(
      sprintf(
        paste0("%s%-", m_charx + 2, "s: %s\n"),
        stringr::str_dup(" ", indent), k,
        deparse_print(x[[k]], m_charx + indent + 2)
      )
    )
  }
}

#' Deparse print
#' @keywords internal
deparse_print <- function(x, indent, max_line = getOption("chevron.arg_max_line", 5L)) {
  assert_int(indent)
  assert_int(max_line, lower = 1L)
  ret <- deparse(x)
  sep <- paste0("\n", stringr::str_dup(" ", indent))
  if (length(ret) > max_line) {
    ret[max_line] <- sprintf("... (print of class <%s> truncated)", toString(class(x)))
    ret <- ret[seq_len(max_line)]
  }
  paste(ret, collapse = sep)
}

# args_ls ----

#' Get Arguments List
#'
#' @param x (`chevron_tlg`) input.
#' @param simplify (`flag`) whether to simplify the output, coalescing the values of the parameters. The order of
#'   priority for the value of the parameters is: `main`, `preprocess` and `postprocess`.
#' @param omit (`character`) the names of the argument to omit from the output.
#'
#' @rdname args_ls
#' @export
setGeneric("args_ls", function(x, simplify = FALSE, omit = NULL) standardGeneric("args_ls"))

#' @rdname args_ls
#' @export
setMethod(
  f = "args_ls",
  signature = "chevron_tlg",
  definition = function(x, simplify = FALSE, omit = NULL) {
    assert_flag(simplify)
    assert_character(omit, null.ok = TRUE)

    x_ls <- list(
      main = formals(x@main),
      preprocess = formals(x@preprocess),
      postprocess = formals(x@postprocess)
    )

    x_sel <- lapply(x_ls, function(y) y[!names(y) %in% omit])

    res <- if (simplify) {
      Reduce(fuse_sequentially, x_sel)
    } else {
      x_sel
    }

    res
  }
)

# main ----

#' Main
#'
#' retrieve or set `main` function.
#'
#' @param x (`chevron_tlg`) input.
#'
#' @aliases main
#' @export
setGeneric("main", function(x) standardGeneric("main"))

#' @rdname main
#' @export
setMethod(
  f = "main",
  signature = "chevron_tlg",
  definition = function(x) {
    x@main
  }
)

#' Set Main Function
#'
#' @param x (`chevron_tlg`) input.
#' @param value (`function`) returning a `tlg`. Typically one of the `_main` function of `chevron`.
#'
#' @rdname main
#' @export
setGeneric("main<-", function(x, value) standardGeneric("main<-"))

#' @rdname main
#' @export
setMethod(
  f = "main<-",
  signature = "chevron_tlg",
  definition = function(x, value) {
    x@main <- value
    validObject(x)
    x
  }
)

# preprocess ----

#' Pre process
#'
#' retrieve or set `preprocess` function.
#'
#' @param x (`chevron_tlg`) input.
#'
#' @aliases preprocess
#' @export
setGeneric("preprocess", function(x) standardGeneric("preprocess"))

#' @rdname preprocess
#' @export
setMethod(
  f = "preprocess",
  signature = "chevron_tlg",
  definition = function(x) {
    x@preprocess
  }
)

#' Set Preprocess Function
#'
#' @param x (`chevron_tlg`) input.
#' @param value  (`function`) returning a pre-processed `list` of `data.frames` amenable to `tlg` creation. Typically
#'   one of the `_pre` function of `chevron`.
#'
#' @rdname preprocess
#' @export
setGeneric("preprocess<-", function(x, value) standardGeneric("preprocess<-"))

#' @rdname preprocess
#' @export
setMethod(
  f = "preprocess<-",
  signature = "chevron_tlg",
  definition = function(x, value) {
    x@preprocess <- value
    validObject(x)
    x
  }
)

# postprocess ----

#' Post process
#'
#' retrieve or set `postprocess` function.
#'
#' @param x (`chevron_tlg`) input.
#'
#' @aliases postprocess
#' @export
setGeneric("postprocess", function(x) standardGeneric("postprocess"))

#' @rdname postprocess
#' @export
setMethod(
  f = "postprocess",
  signature = "chevron_tlg",
  definition = function(x) {
    x@postprocess
  }
)

#' Postprocess Assignment Function
#'
#' @param x (`chevron_tlg`) input.
#' @param value (`function`) returning a post-processed `tlg`.
#'
#' @rdname postprocess
#' @export
setGeneric("postprocess<-", function(x, value) standardGeneric("postprocess<-"))

#' @rdname postprocess
#' @export
setMethod(
  f = "postprocess<-",
  signature = "chevron_tlg",
  definition = function(x, value) {
    x@postprocess <- value
    validObject(x)
    x
  }
)

# script ----

#' Create Script for Parameters Assignment
#'
#' @param x (`chevron_tlg`) input.
#' @param adam_db (`string`) the name of the dataset.
#' @param details (`flag`) deprecated. Whether to show the code of all functions.
#' @param args (`string`) the name of argument list.
#'
#' @name script
#' @rdname script
NULL

## script_funs ----

#' Create Script for `TLG` Generation
#'
#' @rdname script
#' @export
setGeneric("script_funs", function(x, adam_db, args, details = FALSE) standardGeneric("script_funs"))

#' @rdname script
#' @export
#'
#' @examples
#' script_funs(aet04, adam_db = "syn_data", args = "args")
setMethod(
  f = "script_funs",
  signature = "chevron_tlg",
  definition = function(x, adam_db, args, details) {
    checkmate::assert_flag(details)
    checkmate::assert_string(adam_db)
    checkmate::assert_string(args)
    if (!missing(details)) lifecycle::deprecate_warn("0.2.2", "chevron::script_funs(details = )")
    tlg_name <- deparse(substitute(x))
    checkmate::assert_string(tlg_name, pattern = "^[a-zA-Z]+\\w+$")
    c(
      "# Edit Preprocessing Function.",
      glue::glue("preprocess({tlg_name}) <- "),
      deparse(preprocess(x), control = c("useSource")),
      "",
      "# Create TLG",
      glue::glue(
        "tlg_output <- run(object = {tlg_name}, adam_db = {adam_db}",
        ", verbose = TRUE, user_args = {args})"
      )
    )
  }
)

# assert_all_tablenames ----

#' Assert that all names are among names of a `list` of `data.frame`.
#'
#' @param db (`list` of `data.frame`) input to check for the presence of tables.
#' @param tab (`character`) the names of the tables to be checked.
#' @param null_ok (`flag`) can `x` be NULL.
#' @param qualifier (`string`) to be returned if the check fails.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' lsd <- list(
#'   mtcars = mtcars,
#'   iris = iris
#' )
#'
#' assert_all_tablenames(lsd, c("mtcars", "iris", "x"), qualifier = "first test:")
#' }
assert_all_tablenames <- function(db, tab, null_ok = TRUE, qualifier = NULL) {
  assert_list(db, types = "data.frame", names = "unique")
  assert_character(tab, null.ok = null_ok)
  assert_string(qualifier, null.ok = TRUE)

  diff <- setdiff(tab, names(db))

  if (length(diff) == 0) {
    invisible(NULL)
  } else {
    stop(
      paste(qualifier, "Expected table names:", toString(diff), "not in", deparse(substitute(db)))
    )
  }
}

# assert_one_tablenames ----

#' Assert that at least one name is among table names of a `list` of `data.frame`.
#'
#' @param db (`list` of `data.frame`) input to check for the presence or tables.
#' @param tab (`character`) the names of the tables to be checked.
#' @param null_ok (`flag`) can `x` be NULL.
#' @param qualifier (`string`) to be returned if the check fails.
#'
#' @keywords internal
#'
#' @examples
#' \dontrun{
#'
#' lsd <- list(
#'   mtcars = mtcars,
#'   iris = iris
#' )
#'
#' assert_one_tablenames(lsd, c("mtcars", "x", "y"), qualifier = "first test:")
#' }
assert_one_tablenames <- function(db, tab, null_ok = TRUE, qualifier = NULL) {
  assert_list(db, types = "data.frame", names = "unique")
  assert_character(tab, null.ok = null_ok)
  assert_string(qualifier, null.ok = TRUE)

  diff <- setdiff(tab, names(db))

  common <- intersect(tab, names(db))

  if (length(common) > 0) {
    invisible(NULL)
  } else {
    stop(
      paste(qualifier, "At least one of:", toString(tab), "is expected to be a table name of", deparse(substitute(db)))
    )
  }
}



# assert_single_value ----

#' Check variable only has one unique value.
#' @param x value vector.
#' @param label (`string`) label of input.
#' @export
assert_single_value <- function(x, label = deparse(substitute(x))) {
  unique_param_val <- unique(x)
  if (length(unique_param_val) > 1) {
    stop(
      quote_str(label),
      " has more than one values ",
      toString(unique_param_val),
      ", only one value is allowed."
    )
  }
}

# assert_valid_var ----

#' @title Check whether var is valid
#' @details
#' This function checks the variable values are valid or not.
#' @param x value of col_split variable
#' @param label (`string`) hints.
#' @param na_ok (`flag`) whether NA value is allowed
#' @param empty_ok (`flag`) whether length 0 value is allowed.
#' @param ... Further arguments to methods.
#' @export
assert_valid_var <- function(x, label, na_ok, empty_ok, ...) {
  UseMethod("assert_valid_var")
}
#' @rdname assert_valid_var
#' @export
#' @param min_chars (`integer`) the minimum length of the characters.
assert_valid_var.character <- function(
    x, label = deparse(substitute(x)),
    na_ok = FALSE, empty_ok = FALSE,
    min_chars = 1L, ...) {
  assert_character(
    x,
    min.chars = min_chars,
    min.len = as.integer(!empty_ok),
    any.missing = na_ok,
    .var.name = label,
    ...
  )
}

#' @rdname assert_valid_var
#' @export
assert_valid_var.factor <- function(
    x, label = deparse(substitute(x)),
    na_ok = FALSE, empty_ok = FALSE,
    min_chars = 1L, ...) {
  assert_character(
    levels(x),
    min.chars = min_chars,
    .var.name = paste("level of", label)
  )
  assert_factor(
    x,
    min.levels = as.integer(!empty_ok),
    any.missing = na_ok,
    .var.name = label,
    ...
  )
}

#' @rdname assert_valid_var
#' @export
assert_valid_var.logical <- function(x, label = deparse(substitute(x)), na_ok = TRUE, empty_ok = FALSE, ...) {
  assert_logical(
    x,
    min.len = as.integer(!empty_ok),
    any.missing = na_ok,
    .var.name = label,
    ...
  )
}
#' @rdname assert_valid_var
#' @param integerish (`flag`) whether the number should be treated as `integerish`.
#' @export
assert_valid_var.numeric <- function(
    x, label = deparse(substitute(x)),
    na_ok = TRUE, empty_ok = FALSE, integerish = FALSE, ...) {
  check_fun <- if (integerish) assert_integerish else assert_numeric
  check_fun(
    x,
    min.len = as.integer(!empty_ok),
    any.missing = na_ok,
    .var.name = label,
    ...
  )
}

#' @rdname assert_valid_var
#' @export
assert_valid_var.default <- function(x, label = deparse(substitute(x)), na_ok = FALSE, empty_ok = FALSE, ...) {
}

# assert_valid_variable ----

#' Check variables in a data frame are valid character or factor.
#' @param df (`data.frame`) input dataset.
#' @param vars (`character`) variables to check.
#' @param label (`string`) labels of the data frame.
#' @param types Named (`list`) of type of the input.
#' @param ... further arguments for `assert_valid_var`. Please note that different methods have different arguments
#' so if provided make sure the variables to check is of the same class.
#'
#' @export
assert_valid_variable <- function(df, vars, label = deparse(substitute(df)), types = NULL, ...) {
  assert_names(colnames(df), must.include = vars, what = "colnames")

  labels <- sprintf("%s$%s", label, vars)
  if (length(types) == 1 && is.null(names(types))) {
    types <- setNames(rep(types, length(vars)), vars)
  }
  if (!is.null(types)) {
    vars_to_check <- which(vars %in% names(types))
    mapply(
      assert_valid_type,
      df[vars[vars_to_check]],
      types = types[vars_to_check],
      label = labels[vars_to_check]
    )
  }
  collection <- makeAssertCollection()
  mapply(assert_valid_var, df[vars], labels, MoreArgs = list(..., add = collection), SIMPLIFY = FALSE)
  reportAssertions(collection)
}

# assert_valid_type ----

#' Check variable is of correct type
#' @param x Object to check the type.
#' @param types (`character`) possible types to check.
#' @param label (`string`) label.
assert_valid_type <- function(x, types, label = deparse(substitute(x))) {
  if (!any(vapply(types, is, object = x, FUN.VALUE = TRUE))) {
    abort(
      paste0(
        quote_str(label),
        " is not of type ",
        toString(types)
      )
    )
  }
}

# assert_valid_var_pair ----

#' Check variables are of same levels
#' @param df1 (`data.frame`) input.
#' @param df2 (`data.frame`) input.
#' @param var (`string`) variable to check.
#' @param lab1 (`string`) label hint for `df1`.
#' @param lab2 (`string`) label hint for `df2`.
assert_valid_var_pair <- function(df1, df2, var, lab1 = deparse(substitute(df1)), lab2 = deparse(substitute(df2))) {
  assert_data_frame(df1)
  assert_data_frame(df2)
  assert_string(var)
  lvl_x <- lvls(df1[[var]])
  lvl_y <- lvls(df2[[var]])
  if (!identical(lvl_x, lvl_y)) {
    abort(
      paste0(
        quote_str(lab1), " and ",
        quote_str(lab2), " should contain the same levels in variable ",
        quote_str(var), "!"
      )
    )
  }
}

# fstg02 ----

#' @describeIn fstg02 Main TLG Function
#'
#' @details
#'  * No overall value.
#'  * Keep zero count rows by default.
#'
#' @inheritParams gen_args
#' @param dataset (`string`) the name of a table in the `adam_db` object.
#' @param arm_var (`string`) the arm variable name used for group splitting.
#' @param subgroups (`character`) the subgroups variable name to list baseline risk factors.
#' @param strata_var (`character`) required if stratified analysis is performed.
#' @param stat_var (`character`) the names of statistics to be reported in `tabulate_survival_subgroups`.
#' @param max_colwidth (`int`) maximum width of columns. Stratification label longer than this will be truncated.
#' @param ... Further arguments passed to `g_forest` and `extract_rsp_subgroups` (a wrapper for
#'  `h_odds_ratio_subgroups_df` and `h_proportion_subgroups_df`). For details, see the documentation in `tern`.
#'  Commonly used arguments include `col_symbol_size`, `col`, `vline`, `groups_lists`, `conf_level`,
#'  `method`, `label_all`, etc.
#'
#' @note
#'  * `adam_db` object must contain the table specified by `dataset` with `"PARAMCD"`, `"ARM"`,
#'  `"AVAL"`, `"AVALU"`, `"CNSR"`, and the columns specified by `subgroups` which is denoted as
#'  `c("SEX", "AGEGR1", "RACE")` by default.
#'  * If the plot is too large to be rendered in the output, please refer to `FSTG01`.
#'
#' @return a `gTree` object.
#'
#' @export
#'
fstg02_main <- function(adam_db,
                        dataset = "adtte",
                        arm_var = "ARM",
                        subgroups = c("SEX", "AGEGR1", "RACE"),
                        strata_var = NULL,
                        stat_var = c("n_tot", "n", "median", "hr", "ci"),
                        max_colwidth = 10,
                        ...) {
  assert_all_tablenames(adam_db, c("adsl", dataset))
  df_lbl <- paste0("adam_db$", dataset)
  assert_string(arm_var)
  assert_int(max_colwidth)
  assert_character(subgroups, null.ok = TRUE)
  assert_character(strata_var, null.ok = TRUE)
  assert_character(stat_var, null.ok = TRUE)
  assert_valid_variable(adam_db[[dataset]], arm_var, types = list("factor"), n.levels = 2, label = df_lbl)
  assert_valid_variable(adam_db[[dataset]], c("USUBJID", "PARAMCD", "AVALU"),
    types = list(c("character", "factor")),
    label = df_lbl
  )
  assert_valid_variable(adam_db[[dataset]], "AVAL", types = list("numeric"), lower = 0, label = df_lbl)
  assert_valid_variable(adam_db[[dataset]], "IS_EVENT", types = list("logical"), label = df_lbl)
  assert_valid_variable(adam_db[[dataset]], c(subgroups, strata_var),
    types = list(c("factor")), na_ok = TRUE,
    label = df_lbl
  )
  assert_single_value(adam_db[[dataset]]$PARAMCD, label = df_lbl)
  assert_single_value(adam_db[[dataset]]$AVALU, label = df_lbl)

  timeunit <- unique(adam_db[[dataset]]$AVALU)

  variables <- list(
    arm = arm_var,
    tte = "AVAL",
    is_event = "IS_EVENT",
    subgroups = subgroups,
    strata_var = strata_var
  )

  df <- execute_with_args(extract_survival_subgroups,
    variables = variables,
    data = adam_db[[dataset]],
    ...
  )
  df$survtime$subgroup <- stringr::str_trunc(df$survtime$subgroup, max_colwidth)
  df$hr$subgroup <- stringr::str_trunc(df$hr$subgroup, max_colwidth)
  result <- basic_table() %>%
    tabulate_survival_subgroups(df, vars = stat_var, time_unit = timeunit)
  cw <- pmin(propose_column_widths(result), max_colwidth + 2)
  final_width <- stringWidth(strrep("x", cw))
  execute_with_args(
    g_forest,
    tbl = result,
    ...,
    width_row_names = final_width[1],
    width_columns = final_width[-1],
    draw = FALSE
  )
}

#' @describeIn fstg02 Preprocessing
#'
#' @inheritParams fstg02_main
#'
#' @export
#'
fstg02_pre <- function(adam_db, ...) {
  adam_db$adtte <- adam_db$adtte %>%
    mutate(
      ARM = droplevels(.data$ARM),
      AVAL = convert_to_month(.data$AVAL, .data$AVALU),
      AVALU = "MONTHS",
      IS_EVENT = .data$CNSR == 0
    )
  adam_db
}

# `fstg02` Pipeline ----

#' `FSTG02` Subgroup Analysis of Survival Duration.
#'
#' The template produces the subgroup analysis of survival duration graphic.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' library(dplyr)
#' library(dunlin)
#'
#' proc_data <- log_filter(
#'   syn_data,
#'   PARAMCD == "OS" & ARM %in% c("A: Drug X", "B: Placebo"), "adtte"
#' )
#' run(fstg02, proc_data,
#'   subgroups = c("SEX", "AGEGR1", "RACE"),
#'   conf_level = 0.90, dataset = "adtte"
#' )
fstg02 <- chevron_g(
  main = fstg02_main,
  preproces = fstg02_pre
)

# lbt14 ----

#' @describeIn lbt14 Main TLG function
#'
#' @inheritParams gen_args
#' @param gr_missing (`string`) how missing baseline grades should be handled. Defaults to `"incl"` to include the
#'   `"Missing"`
#' level. Other options are `"excl"` to exclude patients with missing baseline grades and `"gr_0"` to convert missing
#' baseline grades to grade 0.
#' @param direction (`string`) one of `"high"` or `"low"` indicating which shift direction should be detailed.
#'
#' @details
#'  * This table follows ADaMIG v1.1.
#'  * Only the worst grade recorded for each patient is included in the table.
#'  * If no missing baseline lab results, the "Missing" level of `BTOXGR` is excluded.
#'  * Grading takes value from -4 to 4, negative value means the abnormality direction is low,
#'  positive value means the abnormality direction is high.
#'  * Grades 0, 1, 2, 3, and 4 are counted as `"Not Low"` when `direction = "low"`. Conversely, when `direction =
#'  "high"`, Grades 0, -1, -2, -3, and -4 are counted as `"Not High".
#'  * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
#'  * Split columns by arm, typically `ACTARM`.
#'
#' @note
#'   * `adam_db` object must contain an `adlb` table with columns `"USUBJID"`, `"PARAM"`, `"BTOXGR"`, `"ATOXGR"`,
#'   and the column specified by `arm_var`.
#'
#' @export
#'
lbt14_main <- function(adam_db,
                       arm_var = "ACTARM",
                       lbl_overall = NULL,
                       gr_missing = "incl",
                       page_var = "PARAMCD",
                       ...) {
  assert_all_tablenames(adam_db, c("adsl", "adlb"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_choice(gr_missing, c("incl", "excl", "gr_0"))
  assert_subset(page_var, "PARAMCD")
  assert_valid_variable(adam_db$adlb, c("ATOXGR", "BTOXGR"), types = list("factor"), na_ok = TRUE)
  assert_valid_variable(adam_db$adlb, c("PARAMCD", "PARAM"), types = list(c("character", "factor")), na_ok = FALSE)
  assert_valid_variable(adam_db$adlb, c("USUBJID"), types = list(c("character", "factor")), empty_ok = TRUE)
  assert_valid_variable(adam_db$adsl, c("USUBJID"), types = list(c("character", "factor")))
  assert_valid_var_pair(adam_db$adsl, adam_db$adlb, arm_var)

  lbl_overall <- render_safe(lbl_overall)
  lbl_param <- var_labels_for(adam_db$adlb, "PARAM")
  lbl_btoxgr <- var_labels_for(adam_db$adlb, "BTOXGR")

  lyt <- lbt14_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_param = lbl_param,
    lbl_btoxgr = lbl_btoxgr,
    page_var = page_var
  )

  tbl <- build_table(lyt, adam_db$adlb, alt_counts_df = adam_db$adsl)

  tbl
}

#' `lbt14` Layout
#'
#' @inheritParams lbt14_main
#'
#' @keywords internal
#'
lbt14_lyt <- function(arm_var,
                      lbl_overall,
                      lbl_param,
                      lbl_btoxgr,
                      page_var) {
  page_by <- !is.null(page_var)
  label_pos <- ifelse(page_by, "hidden", "topleft")
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by(arm_var) %>%
    ifneeded_add_overall_col(lbl_overall) %>%
    split_rows_by(
      var = "PARAMCD",
      labels_var = "PARAM",
      split_fun = drop_split_levels,
      label_pos = label_pos,
      split_label = lbl_param,
      page_by = page_by
    ) %>%
    split_rows_by(
      "BTOXGR",
      label_pos = "topleft",
      split_label = lbl_btoxgr
    ) %>%
    summarize_num_patients(var = "USUBJID", .stats = c("unique_count"), unique_count_suffix = FALSE) %>%
    count_occurrences_by_grade("ATOXGR", denom = "n", drop = FALSE, .indent_mods = 3L) %>%
    append_topleft(paste0(stringr::str_dup(" ", 2L * (5L - page_by)), "Post-baseline NCI-CTCAE Grade"))
}

#' @describeIn lbt14 Preprocessing
#'
#' @inheritParams gen_args
#' @inheritParams lbt14_main
#'
#' @export
#'
lbt14_pre <- function(adam_db,
                      gr_missing = "incl",
                      direction = "low",
                      ...) {
  assert_choice(gr_missing, c("incl", "excl", "gr_0"))
  assert_choice(direction, c("low", "high"))

  if (direction == "high") {
    adam_db$adlb <- adam_db$adlb %>%
      filter(.data$WGRHIFL == "Y") %>%
      h_adsl_adlb_merge_using_worst_flag(
        adsl = adam_db$adsl,
        worst_flag = c("WGRHIFL" = "Y")
      )
  } else {
    adam_db$adlb <- adam_db$adlb %>%
      filter(.data$WGRLOFL == "Y") %>%
      h_adsl_adlb_merge_using_worst_flag(
        adsl = adam_db$adsl,
        worst_flag = c("WGRLOFL" = "Y")
      )
  }

  grade_rule <- get_grade_rule(direction, gr_missing)
  adam_db$adlb <- adam_db$adlb %>%
    mutate(
      across(all_of(c("BTOXGR", "ATOXGR")), ~ reformat(.x, grade_rule))
    )

  adam_db
}

#' @describeIn lbt14 Postprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
lbt14_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) tlg <- tlg %>% trim_rows()
  std_postprocess(tlg)
}

#' `LBT14` Laboratory Test Results Shift Table – Highest `NCI-CTCAE` Grade Post-Baseline by
#' Baseline Grade (Low or High Direction).
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(lbt14, syn_data)
lbt14 <- chevron_t(
  main = lbt14_main,
  preprocess = lbt14_pre,
  postprocess = lbt14_post
)

# as we use NSE
globalVariables(c(".", ":="))

#' Retrieve labels for certain variables
#'
#' @param df (`data.frame`) containing columns with label attribute.
#' @param vars (`character`) variable names in `df`.
#'
#' @details
#' The labels will be returned if the column has `label` attribute, otherwise the column name will be returned.
#' Any values between brackets {} will be replaced with `dunlin::render_safe`.
#' @export
var_labels_for <- function(df, vars) {
  assert_names(colnames(df), must.include = vars, what = "colnames")
  render_safe(unname(formatters::var_labels(df, fill = TRUE)[vars]))
}

#' Prune table up to an `ElementaryTable`
#'
#' Avoid returning `NULL` when the `table` is empty.
#'
#' @param tlg (`TableTree`) object.
#'
#' @return pruned `TableTree`.
#'
smart_prune <- function(tlg) {
  res <- prune_table(tlg)

  if (is.null(res)) {
    res <- build_table(rtables::basic_table(), df = data.frame())
    col_info(res) <- col_info(tlg)
  }

  res
}

#' Standard post processing
#'
#' @param tlg (`TableTree`) object.
#' @param ind (`integer`) the indentation of the table.
#' @param ... not used at the moment.
#'
#' @note Standard post processing includes:
#' * `NULL` report creation if necessary
#' * indentation
#'
#' @return a post-processed `tlg`.
#'
#' @keywords internal
#'
std_postprocess <- function(tlg, ind = 2L, ...) {
  assert_int(ind, lower = 0L)

  res <- report_null(tlg)
  table_inset(res) <- ind

  res
}

# Special formats ----

#' Decimal formatting
#'
#' @param digits (`integer`) number of digits.
#' @param format (`string`) describing how the numbers should be formatted following the `sprintf` syntax.
#' @param ne (`flag`) indicator whether to use "NE" to replace the actual value.
#'
#' @return `function` formatting numbers with the defined format.
#'
#' @export
#'
#' @examples
#' fun <- h_format_dec(c(1, 1), "%s - %s")
#' fun(c(123, 567.89))
#'
h_format_dec <- function(digits, format, ne = FALSE) {
  assert_integerish(digits, lower = 0)
  assert_string(format)
  if (any(is.na(digits))) {
    function(x, ...) {
      ""
    }
  } else {
    if (ne) {
      ret <- function(x, ...) {
        do_call(sprintf, c(list(fmt = format), rep("NE", length(digits))))
      }
      return(ret)
    }
    digit_string <- paste0("%", ifelse(is.na(digits), "", paste0(".", digits)), "f")
    new_format <- do_call(sprintf, c(list(fmt = format), digit_string))
    formatters::sprintf_format(new_format)
  }
}

#' Fuse list elements
#'
#' @param x (`list`) to fuse.
#' @param y (`list`) to fuse. Elements with names already existing in `x` are discarded.
#'
#' @keywords internal
#'
fuse_sequentially <- function(x, y) {
  if (missing(y)) {
    return(x)
  }

  names_x <- names(x)
  sel_names_y <- setdiff(names(y), names_x)

  c(x, y[sel_names_y])
}

#' List of `grob` object
#' @param ... (`grob`) objects
#' @export
grob_list <- function(...) {
  ret <- list(...)
  assert_list(ret, types = c("grob"))
  structure(
    ret,
    class = c("grob_list", "list")
  )
}

#' List of `gg` object
#' @param ... (`ggplot`) objects
#' @export
gg_list <- function(...) {
  ret <- list(...)
  assert_list(ret, types = c("ggplot"))
  structure(
    ret,
    class = c("gg_list", "list")
  )
}

#' @export
droplevels.character <- function(x, ...) {
  x
}

#' Obtain levels from vector
#' @param x (`character`) or (`factor`) object to obtain levels.
#' @details
#' For factors, the levels will be returned. For characters, the sorted unique values will be returned.
#' @export
lvls <- function(x) {
  UseMethod("lvls")
}
#' @export
lvls.default <- function(x) {
  NULL
}
#' @export
lvls.character <- function(x) {
  sort(unique(x))
}
#' @export
lvls.factor <- function(x) {
  levels(x)
}

#' @keywords internal
quote_str <- function(x) {
  assert_string(x)
  paste0("`", x, "`")
}

#' @keywords internal
modify_default_args <- function(fun, ...) {
  ret <- fun
  formals(ret) <- utils::modifyList(formals(fun), list(...), keep.null = TRUE)
  return(ret)
}

#' Execute function with given arguments
#' @details If the function has `...`, this function will not pass other arguments to `...`.
#' Only named arguments are passed.
#' @keywords internal
execute_with_args <- function(fun, ...) {
  args <- list(...)
  do_call(fun, args[intersect(names(args), formalArgs(fun))])
}

#' Execute a function call
#' @keywords internal
do_call <- function(what, args) {
  arg_names <- names(args)
  if (is.null(arg_names)) {
    arg_names <- sprintf("var_%s", seq_along(args))
  } else if (any(arg_names == "")) {
    arg_names_random <- sprintf("var_%s", seq_along(args))
    arg_names[arg_names == ""] <- arg_names_random[arg_names == ""]
  }
  args_env <- as.environment(setNames(args, arg_names))
  parent.env(args_env) <- parent.frame()
  new_args <- lapply(arg_names, as.symbol)
  names(new_args) <- names(args)
  do.call(what, new_args, envir = args_env)
}

#' Modify character
#' @keywords internal
modify_character <- function(x, y) {
  assert_character(x, names = "unique", null.ok = TRUE)
  assert_character(y, names = "unique", null.ok = TRUE)
  c(y, x)[unique(c(names(y), names(x)))]
}

#' Helper function to convert to months if needed
#' @param x (`numeric`) time.
#' @param unit (`character`) or (`factor`) time unit.
#'
#' @return A `numeric` vector with the time in months.
#'
#' @export
convert_to_month <- function(x, unit) {
  assert_multi_class(unit, c("character", "factor"))
  assert_numeric(x, len = length(unit))

  unit <- toupper(unit)
  diff <- setdiff(unique(unit), c("DAYS", "MONTHS", "YEARS"))
  if (length(diff) > 0) {
    rlang::warn(
      paste0(
        "Time unit ", toString(diff), " not covered. No unit conversion applied."
      )
    )
  }

  case_when(
    unit == "DAYS" ~ x / 30.4375,
    unit == "MONTHS" ~ x,
    unit == "YEARS" ~ x * 12,
    TRUE ~ x
  )
}

# rspt01 ----

#' @describeIn rspt01 Main TLG function
#'
#' @inheritParams gen_args
#' @param dataset (`string`) the name of a table in the `adam_db` object.
#' @param ref_group (`string`) The name of the reference group, the value should
#'  be identical to the values in `arm_var`, if not specified, it will by default
#'  use the first level or value of `arm_var`.
#' @param odds_ratio (`flag`) should the odds ratio be calculated, default is `TRUE`
#' @param perform_analysis (`string`) option to display statistical comparisons using stratified analyses,
#'  or unstratified analyses, or both, e.g. `c("unstrat", "strat")`. Only unstratified will be displayed by default
#' @param strata (`string`) stratification factors, e.g. `strata = c("STRATA1", "STRATA2")`, by default as NULL
#' @param conf_level (`numeric`) the level of confidence interval, default is 0.95.
#' @param methods (`list`) a named list, use a named list to control, for example:
#' `methods = list(prop_conf_method = "wald",
#'                diff_conf_method = "wald",
#'                strat_diff_conf_method = "ha",
#'                diff_pval_method = "fisher",
#'                strat_diff_pval_method = "schouten")`
#' `prop_conf_method` controls the methods of calculating proportion confidence interval,
#' `diff_conf_method` controls the methods of calculating unstratified difference confidence interval,
#' `strat_diff_conf_method` controls the methods of calculating stratified difference confidence interval,
#' `diff_pval_method` controls the methods of calculating unstratified p-value for odds ratio,
#' `strat_diff_pval_method` controls the methods of calculating stratified p-value for odds ratio,
#' see more details in `tern`
#'
#' @details
#' * No overall value.
#'
#' @export
#'
rspt01_main <- function(adam_db,
                        dataset = "adrs",
                        arm_var = "ARM",
                        ref_group = NULL,
                        odds_ratio = TRUE,
                        perform_analysis = "unstrat",
                        strata = NULL,
                        conf_level = 0.95,
                        methods = list(),
                        ...) {
  assert_string(dataset)
  assert_all_tablenames(adam_db, "adsl", dataset)
  assert_string(arm_var)
  assert_string(ref_group, null.ok = TRUE)
  assert_flag(odds_ratio)
  assert_subset(perform_analysis, c("unstrat", "strat"))
  assert_character(
    strata,
    null.ok = !"strat" %in% perform_analysis,
    min.len = as.integer(!"strat" %in% perform_analysis)
  )
  df_label <- sprintf("adam_db$%s", dataset)
  assert_valid_variable(
    adam_db$adsl, c("USUBJID", arm_var),
    types = list(c("character", "factor"))
  )
  assert_valid_variable(
    adam_db[[dataset]], c("USUBJID", arm_var, "RSP_LAB"),
    types = list(c("character", "factor")), label = df_label
  )
  assert_valid_variable(adam_db[[dataset]], "IS_RSP", types = list("logical"), label = df_label)
  assert_valid_variable(
    adam_db[[dataset]], c("PARAMCD", "PARAM"),
    types = list(c("character", "factor")), label = df_label
  )
  assert_single_value(adam_db[[dataset]]$PARAMCD, label = sprintf("adam_db$%s$PARAMCD", dataset))
  assert_valid_var_pair(adam_db$adsl, adam_db[[dataset]], arm_var)
  assert_subset(ref_group, lvls(adam_db[[dataset]][[arm_var]]))

  ref_group <- ref_group %||% lvls(adam_db[[dataset]][[arm_var]])[1]

  lyt <- rspt01_lyt(
    arm_var = arm_var,
    rsp_var = "IS_RSP",
    ref_group = ref_group,
    odds_ratio = odds_ratio,
    perform_analysis = perform_analysis,
    strata = strata,
    conf_level = conf_level,
    methods = methods
  )

  tbl <- build_table(lyt, adam_db[[dataset]], alt_counts_df = adam_db$adsl)

  tbl
}

#' `rspt01` Layout
#'
#' @inheritParams gen_args
#'
#' @keywords internal
#'
rspt01_lyt <- function(arm_var,
                       rsp_var,
                       ref_group,
                       odds_ratio,
                       perform_analysis,
                       strata,
                       conf_level,
                       methods) {
  lyt01 <- basic_table(show_colcounts = TRUE) %>%
    split_cols_by(var = arm_var, ref_group = ref_group) %>%
    estimate_proportion(
      vars = rsp_var,
      conf_level = conf_level,
      method = methods[["prop_conf_method"]] %||% "waldcc",
      table_names = "est_prop"
    )

  for (perform in perform_analysis) {
    lyt01 <- lyt01 %>%
      proportion_lyt(
        arm_var = arm_var,
        odds_ratio = odds_ratio,
        strata = if (perform == "strat") strata else NULL,
        conf_level = conf_level,
        methods = methods,
        rsp_var = rsp_var
      )
  }

  lyt <- lyt01 %>%
    estimate_multinomial_response(
      var = "RSP_LAB",
      conf_level = conf_level,
      method = methods[["prop_conf_method"]] %||% "waldcc"
    )

  lyt
}

#' @describeIn rspt01 Preprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
rspt01_pre <- function(adam_db, ...) {
  adam_db$adrs <- adam_db$adrs %>%
    mutate(RSP_LAB = tern::d_onco_rsp_label(.data$AVALC)) %>%
    mutate(IS_RSP = .data$AVALC %in% c("CR", "PR"))
  adam_db
}

#' @describeIn rspt01 Postprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
rspt01_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocess(tlg)
}

#' `RSPT01` Binary Outcomes Summary
#'
#' `RSPT01` template may be used to summarize any binary outcome or response variable at
#' a single time point. Typical application for oncology
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' library(dplyr)
#' library(dunlin)
#'
#' proc_data <- log_filter(syn_data, PARAMCD == "BESRSPI", "adrs")
#'
#' run(rspt01, proc_data)
#'
#' run(rspt01, proc_data,
#'   odds_ratio = FALSE, perform_analysis = c("unstrat", "strat"),
#'   strata = c("STRATA1", "STRATA2"), methods = list(diff_pval_method = "fisher")
#' )
rspt01 <- chevron_t(
  main = rspt01_main,
  preprocess = rspt01_pre,
  postprocess = rspt01_post
)

# dtht01 ----

#' @describeIn dtht01 Main TLG function
#'
#' @inheritParams gen_args
#' @param time_since_last_dose (`flag`) should the time to event information be displayed.
#' @param other_category (`flag`) should the breakdown of the `OTHER` category be displayed.
#'
#' @details
#'  * Numbers represent absolute numbers of subjects and fraction of `N`, or absolute numbers when specified.
#'  * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
#'  * Does not include a total column by default.
#'
#' @note
#' * `adam_db` object must contain an `adsl` table with the columns `"DTHFL"`, `"DTHCAT"` as well as `LDDTHGR1` if
#' `time_since_last_dose` is `TRUE`.
#'
#' @export
dtht01_main <- function(adam_db,
                        arm_var = "ACTARM",
                        lbl_overall = NULL,
                        other_category = FALSE,
                        time_since_last_dose = FALSE,
                        ...) {
  assert_all_tablenames(adam_db, "adsl")
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_flag(other_category)
  assert_flag(time_since_last_dose, null.ok = TRUE)
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list("character", "factor"))
  assert_valid_variable(
    adam_db$adsl,
    "DTHFL",
    types = list("character", "factor"), na_ok = TRUE, min_chars = 0L
  )

  lbl_overall <- render_safe(lbl_overall)
  other_var <- if (other_category) "DTHCAUS"
  dose_death_var <- if (time_since_last_dose) "LDDTHGR1"

  assert_valid_variable(
    adam_db$adsl,
    c("DTHCAT", other_var, dose_death_var),
    types = list("character", "factor"), na_ok = TRUE, min_chars = 1L
  )

  if (other_category) {
    death_cause <- lvls(adam_db$adsl$DTHCAT)
    if (length(death_cause) == 0L) {
      stop("other_category specified but could not find any level in `DTHCAT`!")
    }
    other_level <- death_cause[length(death_cause)]
    if (toupper(other_level) != "OTHER") {
      warning(
        "You included detailed information for Other, however the last level of ",
        " `adam_db$adsl$DTHCAT` looks like not `Other`.",
        call. = FALSE
      )
    }
  }

  lyt <- dtht01_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    death_flag = "DTHFL",
    death_var = "DTHCAT",
    other_level = other_level,
    other_var = other_var,
    dose_death_var = dose_death_var
  )

  adsl <- adam_db$adsl %>%
    mutate(TOTAL = "Primary Cause of Death")

  build_table(lyt, adsl)
}

#' `dtht01` Layout
#'
#' @inheritParams dtht01_main
#' @param death_flag (`string`) variable name of death flag.
#' @param detah_var (`string`) variable name of death category.
#' @param other_level (`string`) `"Other"` level in death category.
#' @param other_var (`string`) variable name of death cause under `"Other"`.
#' @param dose_death_var (`string`) variable name of the days from last dose.
#'
#' @keywords internal
#'
dtht01_lyt <- function(arm_var,
                       lbl_overall,
                       death_flag,
                       death_var,
                       other_level,
                       other_var,
                       dose_death_var) {
  if (is.null(dose_death_var) && is.null(other_var)) {
    lyt_block_fun <- analyze
  } else {
    lyt_block_fun <- summarize_row
  }
  lyt <- basic_table(show_colcounts = TRUE) %>%
    split_cols_by(arm_var) %>%
    ifneeded_add_overall_col(lbl_overall) %>%
    count_values(
      death_flag,
      values = "Y",
      .labels = c(count_fraction = "Total number of deaths"),
      .formats = c(count_fraction = format_count_fraction_fixed_dp)
    ) %>%
    split_rows_by("TOTAL", child_labels = "visible", label_pos = "hidden", split_fun = drop_split_levels) %>%
    lyt_block_fun(
      death_var,
      make_afun(
        s_summary_na,
        .stats = c("n", "count_fraction"), .ungroup_stats = "count_fraction",
        .formats = list(n = "xx", count_fraction = format_count_fraction_fixed_dp)
      ),
      indent_mod = 0L
    )
  if (!is.null(other_var)) {
    lyt <- lyt %>%
      split_rows_by(death_var, split_fun = keep_split_levels(other_level), child_labels = "hidden") %>%
      summarize_vars(other_var, .stats = "count_fraction", denom = "N_row")
  }
  if (!is.null(dose_death_var)) {
    lyt <- lyt %>%
      summarize_vars_allow_na(
        vars = dose_death_var,
        var_labels = "Days from last drug administration",
        .formats = list(count_fraction = format_count_fraction_fixed_dp),
        show_labels = "visible",
        nested = FALSE,
        inclNAs = FALSE
      ) %>%
      split_rows_by(
        dose_death_var,
        split_fun = drop_split_levels,
        split_label = "Primary cause by days from last study drug administration",
        label_pos = "visible",
        nested = FALSE
      ) %>%
      summarize_vars_allow_na(
        death_var,
        .formats = list(count_fraction = format_count_fraction_fixed_dp)
      )
  }

  lyt
}

#' @describeIn dtht01 Preprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
dtht01_pre <- function(adam_db, ...) {
  death_format <- rule(
    "Adverse Event" = "ADVERSE EVENT",
    "Progressive Disease" = "PROGRESSIVE DISEASE",
    "Other" = "OTHER"
  )

  adam_db$adsl <- adam_db$adsl %>%
    mutate(
      DTHCAT = reformat(.data$DTHCAT, death_format)
    )

  adam_db
}

#' @describeIn dtht01 Postprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
dtht01_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocess(tlg)
}

#' `DTHT01` Table 1 (Default) Death Table.
#'
#'  A description of the causes of death optionally with the breakdown of the
#' `OTHER` category and/or post-study reporting of death.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(dtht01, syn_data)
#'
#' run(dtht01, syn_data, other_category = TRUE, time_since_last_dose = TRUE)
dtht01 <- chevron_t(
  main = dtht01_main,
  preprocess = dtht01_pre,
  postprocess = dtht01_post
)

# aet02 ----

#' @describeIn aet02 Default labels
#' @export
#'
aet02_label <- c(
  unique = "Total number of {patient_label} with at least one adverse event",
  nonunique = "Total number of events"
)

#' @describeIn aet02 Main TLG function
#'
#' @inheritParams gen_args
#' @param summary_labels (`list`) of summarize labels. See details.
#'
#' @details
#'  * Numbers represent absolute numbers of subject and fraction of `N`, or absolute number of event when specified.
#'  * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
#'  * Split columns by arm.
#'  * Does not include a total column by default.
#'  * Sort Dictionary-Derived Code (`AEDECOD`) by highest overall frequencies.
#'  * Missing values in `AEBODSYS`, and `AEDECOD` are labeled by `No Coding Available`.
#'  `summary_labels` is used to control the summary for each level. If "all" is used, then each split will have that
#'  summary statistic with the labels. One special case is "TOTAL", this is for the overall population.
#'
#' @note
#'  * `adam_db` object must contain an `adae` table with the columns `"AEBODSYS"` and `"AEDECOD"`.
#'
#' @export
#'
aet02_main <- function(adam_db,
                       arm_var = "ACTARM",
                       row_split_var = "AEBODSYS",
                       lbl_overall = NULL,
                       summary_labels = list(
                         all = aet02_label,
                         TOTAL = c(nonunique = "Overall total number of events")
                       ),
                       ...) {
  assert_all_tablenames(adam_db, "adsl", "adae")
  assert_string(arm_var)
  assert_character(row_split_var, null.ok = TRUE)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adae, c(arm_var, row_split_var, "AEDECOD"), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
  assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)
  assert_list(summary_labels, null.ok = TRUE)
  assert_subset(names(summary_labels), c("all", "TOTAL", row_split_var))
  assert_subset(
    unique(unlist(lapply(summary_labels, names))),
    c("unique", "nonunique", "unique_count")
  )
  if ("all" %in% names(summary_labels)) {
    summary_labels <- lapply(
      c(TOTAL = "TOTAL", setNames(row_split_var, row_split_var)),
      function(x) {
        modify_character(summary_labels$all, summary_labels[[x]])
      }
    )
  }

  lbl_overall <- render_safe(lbl_overall)
  lbl_row_split <- var_labels_for(adam_db$adae, row_split_var)
  lbl_aedecod <- var_labels_for(adam_db$adae, "AEDECOD")

  lyt <- occurrence_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    row_split_var = row_split_var,
    lbl_row_split = lbl_row_split,
    medname_var = "AEDECOD",
    lbl_medname_var = lbl_aedecod,
    summary_labels = summary_labels,
    count_by = NULL
  )

  tbl <- build_table(lyt, adam_db$adae, alt_counts_df = adam_db$adsl)

  tbl
}

#' @describeIn aet02 Preprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
aet02_pre <- function(adam_db, row_split_var = "AEBODSYS", ...) {
  adam_db$adae <- adam_db$adae %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(AEDECOD = reformat(.data$AEDECOD, nocoding)) %>%
    mutate(across(all_of(row_split_var), ~ reformat(.x, nocoding)))

  adam_db
}

#' @describeIn aet02 Postprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
aet02_post <- function(tlg, row_split_var = "AEBODSYS", prune_0 = TRUE, ...) {
  tlg <- tlg %>%
    tlg_sort_by_vars(row_split_var, cont_n_allcols) %>%
    valid_sort_at_path(
      path = c(get_sort_path(c(row_split_var, "AEDECOD"))),
      scorefun = score_occurrences
    )
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocess(tlg)
}

#' `AET02` Table 1 (Default) Adverse Events by System Organ Class and Preferred Term Table 1
#'
#' The `AET02` table provides an overview of the number of subjects experiencing adverse events and the number of advert
#' events categorized by Body System and Dictionary-Derived Term.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(aet02, syn_data)
aet02 <- chevron_t(
  main = aet02_main,
  preprocess = aet02_pre,
  postprocess = aet02_post
)

# aet04 ----

#' @describeIn aet04 Main TLG function
#'
#' @inheritParams gen_args
#' @param grade_groups (`list`) putting in correspondence toxicity grades and labels.
#'
#' @details
#'  * Numbers represent absolute numbers of patients and fraction of `N`, or absolute number of event when specified.
#'  * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
#'  * Events with missing grading values are excluded.
#'  * Split columns by arm, typically `ACTARM`.
#'  * Does not include a total column by default.
#'  * Sort Body System or Organ Class and Dictionary-Derived Term by highest overall frequencies. Analysis Toxicity
#'  Grade is sorted by severity.
#'
#' @note
#'  * `adam_db` object must contain an `adae` table with the columns `"AEBODSYS"`, `"AEDECOD"` and `"ATOXGR"`.
#'
#' @export
#'
aet04_main <- function(adam_db,
                       arm_var = "ACTARM",
                       lbl_overall = NULL,
                       grade_groups = NULL,
                       ...) {
  assert_all_tablenames(adam_db, "adsl", "adae")
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_list(grade_groups, types = "character", null.ok = TRUE)
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adae, c(arm_var, "AEBODSYS", "AEDECOD"), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adae, "ATOXGR", na_ok = TRUE, types = list("factor"))
  assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)

  lbl_overall <- render_safe(lbl_overall)
  lbl_aebodsys <- var_labels_for(adam_db$adae, "AEBODSYS")
  lbl_aedecod <- var_labels_for(adam_db$adae, "AEDECOD")

  if (is.null(grade_groups)) {
    grade_groups <- list(
      "Grade 1-2" = c("1", "2"),
      "Grade 3-4" = c("3", "4"),
      "Grade 5" = c("5")
    )
  }

  lyt <- aet04_lyt(
    arm_var = arm_var,
    total_var = "TOTAL_VAR",
    lbl_overall = lbl_overall,
    lbl_aebodsys = lbl_aebodsys,
    lbl_aedecod = lbl_aedecod,
    grade_groups = grade_groups
  )

  adam_db$adae$TOTAL_VAR <- "- Any adverse events - "

  tbl <- build_table(lyt, df = adam_db$adae, alt_counts_df = adam_db$adsl)

  tbl
}

#' `aet04` Layout
#'
#' @inheritParams aet04_main
#'
#' @param total_var (`string`) variable to create summary of all variables.
#' @param lbl_aebodsys (`string`) text label for `AEBODSYS`.
#' @param lbl_aedecod (`string`) text label for `AEDECOD`.
#' @param grade_groups (`list`) putting in correspondence toxicity grades and labels.
#'
#' @keywords internal
#'
aet04_lyt <- function(arm_var,
                      total_var,
                      lbl_overall,
                      lbl_aebodsys,
                      lbl_aedecod,
                      grade_groups) {
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by(var = arm_var) %>%
    ifneeded_add_overall_col(lbl_overall) %>%
    split_rows_by(
      var = total_var,
      label_pos = "hidden",
      child_labels = "visible",
      indent_mod = -1L
    ) %>%
    summarize_num_patients(
      var = "USUBJID",
      .stats = "unique",
      .labels = "- Any Grade -",
      .indent_mods = 7L
    ) %>%
    count_occurrences_by_grade(
      var = "ATOXGR",
      grade_groups = grade_groups,
      .indent_mods = 6L
    ) %>%
    split_rows_by(
      "AEBODSYS",
      child_labels = "visible",
      nested = FALSE,
      split_fun = drop_split_levels,
      label_pos = "topleft",
      split_label = lbl_aebodsys
    ) %>%
    split_rows_by(
      "AEDECOD",
      child_labels = "visible",
      split_fun = add_overall_level("- Overall -", trim = TRUE),
      label_pos = "topleft",
      split_label = lbl_aedecod
    ) %>%
    summarize_num_patients(
      var = "USUBJID",
      .stats = "unique",
      .labels = "- Any Grade -",
      .indent_mods = 6L
    ) %>%
    count_occurrences_by_grade(
      var = "ATOXGR",
      grade_groups = grade_groups,
      .indent_mods = 5L
    ) %>%
    append_topleft("                            Grade")
}

#' @describeIn aet04 Preprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
aet04_pre <- function(adam_db, ...) {
  atoxgr_lvls <- c("1", "2", "3", "4", "5")
  adam_db$adae <- adam_db$adae %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(
      AEBODSYS = reformat(.data$AEBODSYS, nocoding),
      AEDECOD = reformat(.data$AEDECOD, nocoding),
      ATOXGR = factor(.data$ATOXGR, levels = atoxgr_lvls)
    )
  adam_db
}

#' @describeIn aet04 Postprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
aet04_post <- function(tlg, prune_0 = TRUE, ...) {
  tlg <- tlg %>%
    tlg_sort_by_vars(c("AEBODSYS", "AEDECOD"), score_all_sum, decreasing = TRUE)
  if (prune_0) tlg <- trim_rows(tlg)
  std_postprocess(tlg)
}

#' `AET04` Table 1 (Default) Adverse Events by Highest `NCI` `CTACAE` `AE` Grade Table 1.
#'
#' The `AET04` table provides an
#' overview of adverse event with the highest `NCI` `CTCAE` grade per individual.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' grade_groups <- list(
#'   "Grade 1-2" = c("1", "2"),
#'   "Grade 3-4" = c("3", "4"),
#'   "Grade 5" = c("5")
#' )
#' proc_data <- dunlin::log_filter(syn_data, AEBODSYS == "cl A.1", "adae")
#' run(aet04, proc_data, grade_groups = grade_groups)
aet04 <- chevron_t(
  main = aet04_main,
  preprocess = aet04_pre,
  postprocess = aet04_post
)

# lbt04 ----

#' @describeIn lbt04 Main TLG function
#'
#' @inheritParams gen_args
#' @param analysis_abn_var (`string`) column describing anomaly magnitude
#' @param baseline_abn_var (`string`) column describing anomaly at baseline.
#'
#' @details
#'  * Only count LOW or HIGH values.
#'  * Lab test results with missing `analysis_abn_var` values are excluded.
#'  * Split columns by arm, typically `ACTARM`.
#'  * Does not include a total column by default.
#'
#' @note
#'  * `adam_db` object must contain an `adlb` table with columns `"PARCAT1"`, `"PARCAT2"`, `"PARAM"`, `"ANRIND"`,
#'  and column specified by `arm_var`.
#'
#' @export
#'
lbt04_main <- function(adam_db,
                       arm_var = "ACTARM",
                       lbl_overall = NULL,
                       analysis_abn_var = "ANRIND",
                       baseline_abn_var = "BNRIND",
                       row_split_var = "PARCAT1",
                       page_var = tail(row_split_var, 1L),
                       ...) {
  assert_all_tablenames(adam_db, c("adsl", "adlb"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_string(analysis_abn_var)
  assert_string(baseline_abn_var)
  assert_string(row_split_var)
  assert_valid_variable(
    adam_db$adlb, c("PARAMCD", "PARAM", row_split_var),
    types = list("characater", "factor")
  )
  assert_subset(page_var, row_split_var)
  assert_valid_variable(adam_db$adlb, c("USUBJID"), types = list(c("character", "factor")), empty_ok = TRUE)
  assert_valid_variable(adam_db$adsl, c("USUBJID"), types = list(c("character", "factor")))
  assert_valid_variable(
    adam_db$adlb,
    baseline_abn_var,
    types = list(c("character", "factor")),
    na_ok = TRUE, empty_ok = TRUE, min_chars = 0L
  )
  assert_valid_var_pair(adam_db$adsl, adam_db$adlb, arm_var)

  lbl_overall <- render_safe(lbl_overall)
  lbl_param <- var_labels_for(adam_db$adlb, "PARAM")
  lbl_abn_var <- var_labels_for(adam_db$adlb, analysis_abn_var)
  row_split_lbl <- var_labels_for(adam_db$adlb, row_split_var)

  lyt <- lbt04_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_param = lbl_param,
    lbl_abn_var = lbl_abn_var,
    var_parcat = "PARCAT1",
    var_param = "PARAM",
    row_split_var = row_split_var,
    row_split_lbl = row_split_lbl,
    analysis_abn_var = analysis_abn_var,
    variables = list(id = "USUBJID", baseline = baseline_abn_var),
    page_var = page_var
  )

  tbl <- build_table(lyt, adam_db$adlb, alt_counts_df = adam_db$adsl)

  tbl
}

#' `lbt04` Layout
#'
#' @inheritParams gen_args
#'
#' @param lbl_param (`string`) label of the `PARAM` variable.
#' @param lbl_abn_var (`string`) label of the `analysis_abn_var` variable.
#' @param variables (`list`) see [tern::count_abnormal]
#'
#' @keywords internal
#'
lbt04_lyt <- function(arm_var,
                      lbl_overall,
                      lbl_param,
                      lbl_abn_var,
                      var_parcat,
                      var_param,
                      row_split_var,
                      row_split_lbl,
                      analysis_abn_var,
                      variables,
                      page_var) {
  page_by <- get_page_by(page_var, row_split_var)
  label_pos <- ifelse(page_by, "hidden", "topleft")

  basic_table(show_colcounts = TRUE) %>%
    split_cols_by(arm_var) %>%
    ifneeded_add_overall_col(lbl_overall) %>%
    split_rows_by_recurive(
      row_split_var,
      split_label = row_split_lbl,
      label_pos = label_pos,
      page_by = page_by
    ) %>%
    split_rows_by(
      "PARAMCD",
      labels_var = "PARAM",
      split_fun = drop_split_levels,
      label_pos = "topleft",
      split_label = lbl_param,
      indent_mod = 0L
    ) %>%
    count_abnormal(
      var = analysis_abn_var,
      abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH")),
      exclude_base_abn = TRUE,
      variables = variables,
      .formats = list(fraction = format_fraction_fixed_dp)
    ) %>%
    append_topleft(paste("   ", lbl_abn_var))
}

#' @describeIn lbt04 Preprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
lbt04_pre <- function(adam_db, ...) {
  adam_db$adlb <- adam_db$adlb %>%
    filter(
      .data$ONTRTFL == "Y",
      .data$PARCAT2 == "SI",
      !is.na(.data$ANRIND)
    ) %>%
    mutate(
      PARAM = with_label(.data$PARAM, "Laboratory Test"),
      ANRIND = with_label(.data$ANRIND, "Direction of Abnormality")
    ) %>%
    mutate(
      ANRIND = reformat(
        .data$ANRIND,
        rule(
          "HIGH HIGH" = "HIGH HIGH",
          "HIGH" = "HIGH",
          "LOW" = "LOW",
          "LOW LOW" = "LOW LOW",
          "NORMAL" = "NORMAL"
        ),
        .to_NA = NULL
      )
    )

  adam_db
}

#' @describeIn lbt04 Postprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
lbt04_post <- function(tlg, ...) {
  std_postprocess(tlg)
}

#' `LBT04` Laboratory Abnormalities Not Present at Baseline Table.
#'
#' The `LBT04` table provides an
#' overview of laboratory abnormalities not present at baseline.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(lbt04, syn_data)
lbt04 <- chevron_t(
  main = lbt04_main,
  preprocess = lbt04_pre,
  postprocess = lbt04_post
)

# egt02_1 ----

#' @describeIn egt02_1 Main TLG function
#'
#' @inheritParams gen_args
#' @param exclude_base_abn (`flag`) whether baseline abnormality should be excluded.
#'
#' @details
#'   * Only count LOW or HIGH values.
#'   * Results of "LOW LOW" are treated as the same as "LOW", and "HIGH HIGH" the same as "HIGH".
#'   * Does not include a total column by default.
#'   * Does not remove zero-count rows unless overridden with `prune_0 = TRUE`.
#'
#' @note
#'   * `adam_db` object must contain an `adeg` table with the `"PARAM"`, `"ANRIND"` and `"BNRIND"` columns.
#'
#' @export
#'
egt02_1_main <- function(adam_db,
                         arm_var = "ACTARM",
                         lbl_overall = NULL,
                         exclude_base_abn = FALSE,
                         ...) {
  assert_all_tablenames(adam_db, c("adsl", "adeg"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_flag(exclude_base_abn)
  assert_valid_variable(adam_db$adeg, c("PARAM"), types = list(c("character", "factor")), na_ok = FALSE)
  assert_valid_variable(adam_db$adeg, c("ANRIND", "BNRIND"), types = list(c("character", "factor")), na_ok = TRUE)
  assert_valid_var_pair(adam_db$adsl, adam_db$adeg, arm_var)
  assert_valid_variable(adam_db$adeg, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))

  lbl_overall <- render_safe(lbl_overall)

  lyt <- egt02_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_vs_assessment = "Assessment",
    lbl_vs_abnormality = "Abnormality",
    exclude_base_abn = exclude_base_abn
  )

  tbl <- build_table(lyt, adam_db$adeg, alt_counts_df = adam_db$adsl)

  tbl
}

#' `egt02` Layout
#'
#' @inheritParams gen_args
#' @param lbl_vs_assessment (`string`) the label of the assessment variable.
#' @param lbl_vs_abnormality (`string`) the label of the abnormality variable.
#' @param exclude_base_abn (`flag`) whether to exclude subjects with baseline abnormality from numerator and
#'   denominator.
#'
#' @keywords internal
#'
egt02_lyt <- function(arm_var = "ACTARM",
                      lbl_overall,
                      lbl_vs_assessment = "Assessment",
                      lbl_vs_abnormality = "Abnormality",
                      exclude_base_abn) {
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by(var = arm_var) %>%
    ifneeded_add_overall_col(lbl_overall) %>%
    split_rows_by("PARAM", split_fun = drop_split_levels, label_pos = "topleft", split_label = lbl_vs_assessment) %>%
    count_abnormal(
      "ANRIND",
      abnormal = list(Low = "LOW", High = "HIGH"),
      variables = list(id = "USUBJID", baseline = "BNRIND"),
      exclude_base_abn = exclude_base_abn
    ) %>%
    append_topleft(paste0(" ", lbl_vs_abnormality))
}

#' @describeIn egt02_1 Preprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
egt02_pre <- function(adam_db, ...) {
  assert_all_tablenames(adam_db, c("adsl", "adeg"))
  adam_db$adeg <- adam_db$adeg %>%
    mutate(ANRIND = factor(.data$ANRIND, levels = c("LOW", "NORMAL", "HIGH"))) %>%
    filter(!is.na(.data$ANRIND)) %>%
    filter(.data$ONTRTFL == "Y")

  adam_db
}

#' @describeIn egt02_1 Postprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
egt02_post <- function(tlg, ...) {
  std_postprocess(tlg)
}

#' `EGT02` ECG Abnormalities Table.
#'
#' ECG Parameters outside Normal Limits Regardless of Abnormality at Baseline Table.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(egt02_1, syn_data)
egt02_1 <- chevron_t(
  main = egt02_1_main,
  preprocess = egt02_pre,
  postprocess = egt02_post
)

# egt02_2 ----

#' @describeIn egt02_2 Main TLG function
#'
#' @inherit egt02_1_main
#'
#' @export
#'
egt02_2_main <- modify_default_args(egt02_1_main, exclude_base_abn = TRUE)

#' `EGT02_2` ECG Abnormalities Table.
#'
#' ECG Parameters outside Normal Limits Among Patients without Abnormality at Baseline Table.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(egt02_2, syn_data)
egt02_2 <- chevron_t(
  main = egt02_2_main,
  preprocess = egt02_pre,
  postprocess = egt02_post
)

# lbt06 ----

#' @describeIn lbt06 Main TLG function
#'
#' @inheritParams gen_args
#' @param arm_var (`string`) the arm variable used for arm splitting.
#'
#' @details
#'  * Only count `"LOW"` or `"HIGH"` values for `ANRIND` and `BNRIND`.
#'  * Lab test results with missing `ANRIND` values are excluded.
#'  * Split columns by arm, typically `ACTARM`.
#'  * Keep zero count rows by default.
#'
#' @note
#'  * `adam_db` object must contain an `adlb` table with columns `"AVISIT"`, `"ANRIND"`, `"BNRIND"`,
#'  `"ONTRTFL"`, and `"PARCAT2"`, and column specified by `arm_var`.
#'
#' @export
#'
lbt06_main <- function(adam_db,
                       arm_var = "ACTARM",
                       lbl_overall = NULL,
                       page_var = "PARAMCD",
                       ...) {
  assert_all_tablenames(adam_db, c("adsl", "adlb"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_subset(page_var, "PARAMCD")
  assert_valid_variable(adam_db$adlb, c(arm_var, "PARAMCD", "PARAM", "AVISIT"), types = list("characater", "factor"))
  assert_valid_variable(adam_db$adlb, c("ANRIND", "BNRIND"), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adlb, c("USUBJID"), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adsl, c("USUBJID"), types = list(c("character", "factor")))
  assert_valid_var_pair(adam_db$adsl, adam_db$adlb, arm_var)

  lbl_overall <- render_safe(lbl_overall)
  lbl_param <- var_labels_for(adam_db$adlb, "PARAM")
  lbl_visit <- var_labels_for(adam_db$adlb, "AVISIT")
  lbl_anrind <- var_labels_for(adam_db$adlb, "ANRIND")
  lbl_bnrind <- var_labels_for(adam_db$adlb, "BNRIND")

  lyt <- lbt06_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_param = lbl_param,
    lbl_visit = lbl_visit,
    lbl_anrind = lbl_anrind,
    lbl_bnrind = lbl_bnrind,
    visitvar = "AVISIT",
    anrind_var = "ANRIND",
    bnrind_var = "BNRIND",
    page_var = page_var
  )

  tbl <- build_table(lyt, adam_db$adlb, alt_counts_df = adam_db$adsl)

  tbl
}

#' `lbt06` Layout
#'
#' @inheritParams gen_args
#'
#' @param lbl_param (`string`) text label of the `PARAM` variable.
#' @param lbl_visit (`string`) text label of the `AVISIT` variable.
#' @param lbl_anrind (`string`) text label of the `ANRIND` variable.
#' @param lbl_bnrind (`string`) text label of the `BNRIND` variable.
#' @param param (`string`) the variable for parameter code.
#' @param anrind_var (`string`) the variable for analysis reference range indicator.
#' @param bnrind_var (`string`) the variable for baseline reference range indicator.
#'
#' @keywords internal
#'
lbt06_lyt <- function(arm_var,
                      lbl_overall,
                      lbl_param,
                      lbl_visit,
                      lbl_anrind,
                      lbl_bnrind,
                      visitvar,
                      anrind_var,
                      bnrind_var,
                      page_var) {
  page_by <- !is.null(page_var)
  label_pos <- ifelse(page_by, "hidden", "topleft")
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by(arm_var) %>%
    ifneeded_add_overall_col(lbl_overall) %>%
    split_rows_by(
      var = "PARAMCD",
      labels_var = "PARAM",
      split_fun = drop_split_levels,
      label_pos = label_pos,
      split_label = lbl_param,
      page_by = page_by
    ) %>%
    split_rows_by(
      var = visitvar,
      split_fun = drop_split_levels,
      label_pos = "topleft",
      split_label = lbl_visit
    ) %>%
    count_abnormal_by_baseline(
      var = anrind_var,
      abnormal = c(Low = "LOW", High = "HIGH"),
      variables = list(id = "USUBJID", baseline = bnrind_var),
      .indent_mods = 4L
    ) %>%
    append_topleft(paste0(stringr::str_dup(" ", 2L * (2 - page_by)), lbl_anrind)) %>%
    append_topleft(paste0(stringr::str_dup(" ", 2L * (7 - page_by)), lbl_bnrind))
}

#' @describeIn lbt06 Preprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
lbt06_pre <- function(adam_db, ...) {
  missing_rule <- rule("<Missing>" = c("", NA, "<Missing>"))

  adam_db$adlb <- adam_db$adlb %>%
    filter(
      .data$ONTRTFL == "Y",
      .data$PARCAT2 == "SI"
    ) %>%
    mutate(
      across(all_of(c("ANRIND", "BNRIND")), ~ reformat(.x, .env$missing_rule)),
      AVISIT = reorder(.data$AVISIT, .data$AVISITN),
      AVISIT = with_label(.data$AVISIT, "Visit"),
      ANRIND = with_label(.data$ANRIND, "Abnormality at Visit"),
      BNRIND = with_label(.data$BNRIND, "Baseline Status")
    )

  adam_db
}

#' @describeIn lbt06 Postprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
lbt06_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocess(tlg)
}

#' `LBT06` Table 1 (Default) Laboratory Abnormalities by Visit and Baseline Status Table 1.
#'
#' The `LBT06` table produces the standard laboratory abnormalities by visit and
#' baseline status summary.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(lbt06, syn_data)
lbt06 <- chevron_t(
  main = lbt06_main,
  preprocess = lbt06_pre,
  postprocess = lbt06_post
)

# aet01 ----

#' @describeIn aet01 Main TLG function
#'
#' @inheritParams gen_args
#' @param anl_vars Named (`list`) of (`character`) variables the safety variables to be summarized.
#' @param anl_lbls (`character`) of analysis labels.
#'
#' @details
#'  * Does not remove rows with zero counts by default.
#'
#' @note
#'  * `adam_db` object must contain an `adsl` table with the `"DTHFL"` and `"DCSREAS"` columns.
#'  * `adam_db` object must contain an `adae` table with the columns passed to `anl_vars`.
#'
#' @export
#'
aet01_main <- function(adam_db,
                       arm_var = "ACTARM",
                       lbl_overall = NULL,
                       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",
                       ...) {
  assert_all_tablenames(adam_db, "adsl", "adae")
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_list(anl_vars, types = "character", names = "unique")
  assert_character(anl_lbls, min.chars = 1L)
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adsl, c("DTHFL", "DCSREAS"), types = list(c("character", "factor")), min_chars = 0L)
  assert_valid_variable(adam_db$adae, c(arm_var), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adae, unlist(anl_vars), types = list("logical"), na_ok = TRUE, empty_ok = TRUE)
  assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)

  lbl_overall <- render_safe(lbl_overall)
  anl_lbls <- render_safe(anl_lbls)
  if (length(anl_lbls) == 1) {
    anl_lbls <- rep(anl_lbls, length(anl_vars))
  }
  lbl_vars <- lapply(
    anl_vars,
    var_labels_for,
    df = adam_db$adae
  )

  lyts <- aet01_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    anl_vars = anl_vars,
    anl_lbls = anl_lbls,
    lbl_vars = lbl_vars
  )

  rbind(
    build_table(lyts$ae1, adam_db$adae, alt_counts_df = adam_db$adsl),
    build_table(lyts$adsl, adam_db$adsl, alt_counts_df = adam_db$adsl),
    build_table(lyts$ae2, adam_db$adae, alt_counts_df = adam_db$adsl)
  )
}

#' `aet01` Layout
#'
#' @inheritParams aet01_main
#' @param anl_vars Named (`list`) of analysis variables.
#' @param anl_lbls (`character`) of labels.
#' @param lbl_vars Named (`list`) of analysis labels.
#' @keywords internal
#'
aet01_lyt <- function(arm_var,
                      lbl_overall,
                      anl_vars,
                      anl_lbls,
                      lbl_vars) {
  lyt_base <- basic_table(show_colcounts = TRUE) %>%
    split_cols_by(var = arm_var) %>%
    ifneeded_add_overall_col(lbl_overall)
  lyt_ae1 <- lyt_base %>%
    analyze_num_patients(
      vars = "USUBJID",
      .stats = c("unique", "nonunique"),
      .labels = c(
        unique = render_safe("Total number of {patient_label} with at least one AE"),
        nonunique = "Total number of AEs"
      ),
      .formats = list(unique = format_count_fraction_fixed_dp, nonunique = "xx"),
      show_labels = "hidden"
    )
  lyt_adsl <- lyt_base %>%
    count_patients_with_event(
      "USUBJID",
      filters = c("DTHFL" = "Y"),
      denom = "N_col",
      .labels = c(count_fraction = "Total number of deaths"),
      table_names = "TotDeath"
    ) %>%
    count_patients_with_event(
      "USUBJID",
      filters = c("DCSREAS" = "ADVERSE EVENT"),
      denom = "N_col",
      .labels = c(count_fraction = render_safe("Total number of {patient_label} withdrawn from study due to an AE")),
      table_names = "TotWithdrawal"
    )

  lyt_ae2 <- lyt_base %>%
    count_patients_recursive(
      anl_vars = anl_vars,
      anl_lbls = anl_lbls,
      lbl_vars = lbl_vars
    )
  return(list(ae1 = lyt_ae1, ae2 = lyt_ae2, adsl = lyt_adsl))
}

#' @describeIn aet01 Preprocessing
#'
#' @inheritParams aet01_main
#'
#' @export
#'
aet01_pre <- 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
}

#' @describeIn aet01 Postprocessing
#'
#' @inheritParams gen_args
#'
#' @export
#'
aet01_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocess(tlg)


1		# cmt01a ----
2
3		#' @describeIn cmt01a Default labels
4		#' @export
5		#'
6		cmt01_label <- c(
7		unique = "Total number of {patient_label} with at least one treatment",
8		nonunique = "Total number of treatments"
9		)
10
11		#' @describeIn cmt01a Main TLG function
12		#'
13		#' @inheritParams gen_args
14		#' @param row_split_var (`character`) the variable defining the medication category. By default `ATC2`.
15		#' @param medname_var (`string`) variable name of medical treatment name.
16		#' @param summary_labels (`list`) of summarize labels. See details.
17		#'
18		#' @details
19		#' * Data should be filtered for concomitant medication. `(ATIREL == "CONCOMITANT")`.
20		#' * Numbers represent absolute numbers of subjects and fraction of `N`, or absolute numbers when specified.
21		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
22		#' * Split columns by arm.
23		#' * Does not include a total column by default.
24		#' * Sort by medication class alphabetically and within medication class by decreasing total number of patients with
25		#' the specific medication.
26		#' `summary_labels` is used to control the summary for each level. If "all" is used, then each split will have that
27		#' summary statistic with the labels. One special case is "TOTAL", this is for the overall population.
28		#'
29		#' @note
30		#' * `adam_db` object must contain an `adcm` table with the columns specified in `row_split_var` and `medname_var`
31		#' as well as `"CMSEQ"`.
32		#'
33		#' @export
34		#'
35		cmt01a_main <- function(adam_db,
36		arm_var = "ARM",
37		lbl_overall = NULL,
38		row_split_var = "ATC2",
39		medname_var = "CMDECOD",
40		summary_labels = setNames(
41		rep(list(cmt01_label), length(row_split_var) + 1L), c("TOTAL", row_split_var)
42		),
43		...) {
44	3x	assert_all_tablenames(adam_db, "adsl", "adcm")
45	3x	assert_string(arm_var)
46	3x	assert_string(lbl_overall, null.ok = TRUE)
47	3x	assert_character(row_split_var, null.ok = TRUE)
48	3x	assert_list(summary_labels)
49	3x	assert_subset(names(summary_labels), c("all", "TOTAL", row_split_var))
50	3x	assert_subset(
51	3x	unique(unlist(lapply(summary_labels, names))),
52	3x	c("unique", "nonunique", "unique_count")
53		)
54	3x	if ("all" %in% names(summary_labels)) {
55	!	summary_labels <- lapply(
56	!	c(TOTAL = "TOTAL", setNames(row_split_var, row_split_var)),
57	!	function(x) {
58	!	modify_character(summary_labels$all, summary_labels[[x]])
59		}
60		)
61		}
62	3x	assert_valid_variable(adam_db$adcm, c(arm_var, row_split_var, medname_var), types = list(c("character", "factor")))
63	3x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
64	3x	assert_valid_variable(adam_db$adcm, c("USUBJID", "CMSEQ"), empty_ok = TRUE, types = list(c("character", "factor")))
65	3x	assert_valid_var_pair(adam_db$adsl, adam_db$adcm, arm_var)
66
67	3x	lbl_overall <- render_safe(lbl_overall)
68	3x	lbl_row_split <- var_labels_for(adam_db$adcm, row_split_var)
69	3x	lbl_medname_var <- var_labels_for(adam_db$adcm, medname_var)
70
71	3x	lyt <- occurrence_lyt(
72	3x	arm_var = arm_var,
73	3x	lbl_overall = lbl_overall,
74	3x	row_split_var = row_split_var,
75	3x	lbl_row_split = lbl_row_split,
76	3x	medname_var = medname_var,
77	3x	lbl_medname_var = lbl_medname_var,
78	3x	summary_labels = summary_labels,
79	3x	count_by = "CMSEQ"
80		)
81
82	3x	tbl <- build_table(lyt, adam_db$adcm, alt_counts_df = adam_db$adsl)
83
84	3x	tbl
85		}
86
87		#' @describeIn cmt01a Preprocessing
88		#'
89		#' @inheritParams cmt01a_main
90		#'
91		#' @export
92		#'
93		cmt01a_pre <- function(adam_db, ...) {
94	3x	adam_db$adcm <- adam_db$adcm %>%
95	3x	filter(.data$ANL01FL == "Y") %>%
96	3x	mutate(
97	3x	CMDECOD = with_label(reformat(.data$CMDECOD, nocoding), "Other Treatment"),
98	3x	ATC2 = reformat(.data$ATC2, nocoding),
99	3x	CMSEQ = as.character(.data$CMSEQ)
100		)
101	3x	adam_db
102		}
103
104		#' @describeIn cmt01a Postprocessing
105		#'
106		#' @inheritParams cmt01a_main
107		#' @inheritParams gen_args
108		#' @param sort_by_freq (`flag`) whether to sort medication class by frequency.
109		#'
110		#' @export
111		#'
112		cmt01a_post <- function(
113		tlg, prune_0 = TRUE,
114		sort_by_freq = FALSE, row_split_var = "ATC2",
115		medname_var = "CMDECOD", ...) {
116	3x	if (sort_by_freq) {
117	1x	tlg <- tlg %>%
118	1x	tlg_sort_by_var(
119	1x	var = row_split_var,
120	1x	scorefun = cont_n_allcols
121		)
122		}
123	3x	tlg <- tlg %>%
124	3x	tlg_sort_by_var(
125	3x	var = c(row_split_var, medname_var),
126	3x	scorefun = score_occurrences
127		)
128	3x	if (prune_0) {
129	3x	tlg <- smart_prune(tlg)
130		}
131	3x	std_postprocess(tlg)
132		}
133
134		#' `CMT01A` Concomitant Medication by Medication Class and Preferred Name.
135		#'
136		#' A concomitant medication
137		#' table with the number of subjects and the total number of treatments by medication class.
138		#'
139		#' @include chevron_tlg-S4class.R
140		#' @export
141		#'
142		#' @examples
143		#' library(dplyr)
144		#'
145		#' proc_data <- syn_data
146		#' proc_data$adcm <- proc_data$adcm %>%
147		#' filter(ATIREL == "CONCOMITANT")
148		#'
149		#' run(cmt01a, proc_data)
150		cmt01a <- chevron_t(
151		main = cmt01a_main,
152		preprocess = cmt01a_pre,
153		postprocess = cmt01a_post
154		)

1		# aet03 ----
2
3		#' @describeIn aet03 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#'
7		#' @details
8		#' * Default Adverse Events by Greatest Intensity table.
9		#' * Numbers represent absolute numbers of patients and fraction of `N`.
10		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
11		#' * Split columns by arm.
12		#' * Does not include a total column by default.
13		#' * Sort by Body System or Organ Class (`SOC`) and Dictionary-Derived Term (`PT`).
14		#'
15		#' @note
16		#' * `adam_db` object must contain an `adae` table with the columns `"AEBODSYS"`, `"AEDECOD"` and `"ASEV"`.
17		#'
18		#' @export
19		#'
20		aet03_main <- function(adam_db,
21		arm_var = "ACTARM",
22		lbl_overall = NULL,
23		...) {
24	1x	assert_all_tablenames(adam_db, "adsl", "adae")
25	1x	assert_string(arm_var)
26	1x	assert_string(lbl_overall, null.ok = TRUE)
27	1x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
28	1x	assert_valid_variable(adam_db$adae, c(arm_var, "AEBODSYS", "AEDECOD", "ASEV"), types = list(c("character", "factor")))
29	1x	assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
30	1x	assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)
31
32	1x	lbl_overall <- render_safe(lbl_overall)
33	1x	lbl_aebodsys <- var_labels_for(adam_db$adae, "AEBODSYS")
34	1x	lbl_aedecod <- var_labels_for(adam_db$adae, "AEDECOD")
35	1x	intensity_grade <- levels(adam_db$adae[["ASEV"]])
36
37	1x	lyt <- aet03_lyt(
38	1x	arm_var = arm_var,
39	1x	lbl_overall = lbl_overall,
40	1x	lbl_aebodsys = lbl_aebodsys,
41	1x	lbl_aedecod = lbl_aedecod,
42	1x	intensity_grade = intensity_grade
43		)
44
45	1x	tbl <- build_table(lyt, df = adam_db$adae, alt_counts_df = adam_db$adsl)
46
47	1x	tbl
48		}
49
50		#' `aet03` Layout
51		#'
52		#' @inheritParams gen_args
53		#'
54		#' @param lbl_aebodsys (`string`) text label for `AEBODSYS`.
55		#' @param lbl_aedecod (`string`) text label for `AEDECOD`.
56		#' @param intensity_grade (`character`) describing the intensity levels present in the dataset.
57		#'
58		#' @keywords internal
59		#'
60		aet03_lyt <- function(arm_var,
61		lbl_overall,
62		lbl_aebodsys,
63		lbl_aedecod,
64		intensity_grade) {
65	4x	all_grade_groups <- list("- Any Intensity -" = intensity_grade)
66
67	4x	basic_table(show_colcounts = TRUE) %>%
68	4x	split_cols_by(var = arm_var) %>%
69	4x	ifneeded_add_overall_col(lbl_overall) %>%
70	4x	count_occurrences_by_grade(
71	4x	var = "ASEV",
72	4x	grade_groups = all_grade_groups,
73	4x	.formats = c("count_fraction" = format_count_fraction_fixed_dp)
74		) %>%
75	4x	split_rows_by(
76	4x	"AEBODSYS",
77	4x	child_labels = "visible",
78	4x	nested = TRUE,
79	4x	split_fun = drop_split_levels,
80	4x	label_pos = "topleft",
81	4x	split_label = lbl_aebodsys
82		) %>%
83	4x	summarize_occurrences_by_grade(
84	4x	var = "ASEV",
85	4x	grade_groups = all_grade_groups,
86	4x	.formats = c("count_fraction" = format_count_fraction_fixed_dp)
87		) %>%
88	4x	split_rows_by(
89	4x	"AEDECOD",
90	4x	child_labels = "visible",
91	4x	nested = TRUE,
92	4x	indent_mod = -1L,
93	4x	split_fun = drop_split_levels,
94	4x	label_pos = "topleft",
95	4x	split_label = lbl_aedecod
96		) %>%
97	4x	summarize_num_patients(
98	4x	var = "USUBJID",
99	4x	.stats = "unique",
100	4x	.labels = c("- Any Intensity -")
101		) %>%
102	4x	count_occurrences_by_grade(
103	4x	var = "ASEV",
104	4x	.indent_mods = -1L
105		)
106		}
107
108		#' @describeIn aet03 Preprocessing
109		#'
110		#' @inheritParams gen_args
111		#'
112		#' @export
113		#'
114		aet03_pre <- function(adam_db, ...) {
115	1x	asev_lvls <- c("MILD", "MODERATE", "SEVERE")
116	1x	adam_db$adae <- adam_db$adae %>%
117	1x	filter(.data$ANL01FL == "Y") %>%
118	1x	mutate(
119	1x	AEBODSYS = reformat(.data$AEBODSYS, nocoding),
120	1x	AEDECOD = reformat(.data$AEDECOD, nocoding),
121	1x	ASEV = factor(.data$ASEV, levels = asev_lvls)
122		) %>%
123	1x	filter(!is.na(.data$ASEV))
124
125	1x	adam_db
126		}
127
128		#' @describeIn aet03 Postprocessing
129		#'
130		#' @inheritParams gen_args
131		#'
132		#' @export
133		#'
134		aet03_post <- function(tlg, prune_0 = TRUE, ...) {
135	1x	tlg <- tlg %>%
136	1x	tlg_sort_by_vars(
137	1x	c("AEBODSYS", "AEDECOD"),
138	1x	scorefun = cont_n_allcols
139		)
140	1x	if (prune_0) tlg <- trim_rows(tlg)
141	1x	std_postprocess(tlg)
142		}
143
144		#' `AET03` Table 1 (Default) Advert Events by Greatest Intensity Table 1.
145		#'
146		#' An adverse events table categorized by System
147		#' Organ Class, Dictionary-Derived Term and Greatest intensity.
148		#'
149		#' @include chevron_tlg-S4class.R
150		#' @export
151		#'
152		#' @examples
153		#' run(aet03, syn_data)
154		aet03 <- chevron_t(
155		main = aet03_main,
156		preprocess = aet03_pre,
157		postprocess = aet03_post
158		)

1		# fstg02 ----
2
3		#' @describeIn fstg02 Main TLG Function
4		#'
5		#' @details
6		#' * No overall value.
7		#' * Keep zero count rows by default.
8		#'
9		#' @inheritParams gen_args
10		#' @param dataset (`string`) the name of a table in the `adam_db` object.
11		#' @param arm_var (`string`) the arm variable name used for group splitting.
12		#' @param subgroups (`character`) the subgroups variable name to list baseline risk factors.
13		#' @param strata_var (`character`) required if stratified analysis is performed.
14		#' @param stat_var (`character`) the names of statistics to be reported in `tabulate_survival_subgroups`.
15		#' @param max_colwidth (`int`) maximum width of columns. Stratification label longer than this will be truncated.
16		#' @param ... Further arguments passed to `g_forest` and `extract_rsp_subgroups` (a wrapper for
17		#' `h_odds_ratio_subgroups_df` and `h_proportion_subgroups_df`). For details, see the documentation in `tern`.
18		#' Commonly used arguments include `col_symbol_size`, `col`, `vline`, `groups_lists`, `conf_level`,
19		#' `method`, `label_all`, etc.
20		#'
21		#' @note
22		#' * `adam_db` object must contain the table specified by `dataset` with `"PARAMCD"`, `"ARM"`,
23		#' `"AVAL"`, `"AVALU"`, `"CNSR"`, and the columns specified by `subgroups` which is denoted as
24		#' `c("SEX", "AGEGR1", "RACE")` by default.
25		#' * If the plot is too large to be rendered in the output, please refer to `FSTG01`.
26		#'
27		#' @return a `gTree` object.
28		#'
29		#' @export
30		#'
31		fstg02_main <- function(adam_db,
32		dataset = "adtte",
33		arm_var = "ARM",
34		subgroups = c("SEX", "AGEGR1", "RACE"),
35		strata_var = NULL,
36		stat_var = c("n_tot", "n", "median", "hr", "ci"),
37		max_colwidth = 10,
38		...) {
39	1x	assert_all_tablenames(adam_db, c("adsl", dataset))
40	1x	df_lbl <- paste0("adam_db$", dataset)
41	1x	assert_string(arm_var)
42	1x	assert_int(max_colwidth)
43	1x	assert_character(subgroups, null.ok = TRUE)
44	1x	assert_character(strata_var, null.ok = TRUE)
45	1x	assert_character(stat_var, null.ok = TRUE)
46	1x	assert_valid_variable(adam_db[[dataset]], arm_var, types = list("factor"), n.levels = 2, label = df_lbl)
47	1x	assert_valid_variable(adam_db[[dataset]], c("USUBJID", "PARAMCD", "AVALU"),
48	1x	types = list(c("character", "factor")),
49	1x	label = df_lbl
50		)
51	1x	assert_valid_variable(adam_db[[dataset]], "AVAL", types = list("numeric"), lower = 0, label = df_lbl)
52	1x	assert_valid_variable(adam_db[[dataset]], "IS_EVENT", types = list("logical"), label = df_lbl)
53	1x	assert_valid_variable(adam_db[[dataset]], c(subgroups, strata_var),
54	1x	types = list(c("factor")), na_ok = TRUE,
55	1x	label = df_lbl
56		)
57	1x	assert_single_value(adam_db[[dataset]]$PARAMCD, label = df_lbl)
58	1x	assert_single_value(adam_db[[dataset]]$AVALU, label = df_lbl)
59
60	1x	timeunit <- unique(adam_db[[dataset]]$AVALU)
61
62	1x	variables <- list(
63	1x	arm = arm_var,
64	1x	tte = "AVAL",
65	1x	is_event = "IS_EVENT",
66	1x	subgroups = subgroups,
67	1x	strata_var = strata_var
68		)
69
70	1x	df <- execute_with_args(extract_survival_subgroups,
71	1x	variables = variables,
72	1x	data = adam_db[[dataset]],
73		...
74		)
75	1x	df$survtime$subgroup <- stringr::str_trunc(df$survtime$subgroup, max_colwidth)
76	1x	df$hr$subgroup <- stringr::str_trunc(df$hr$subgroup, max_colwidth)
77	1x	result <- basic_table() %>%
78	1x	tabulate_survival_subgroups(df, vars = stat_var, time_unit = timeunit)
79	1x	cw <- pmin(propose_column_widths(result), max_colwidth + 2)
80	1x	final_width <- stringWidth(strrep("x", cw))
81	1x	execute_with_args(
82	1x	g_forest,
83	1x	tbl = result,
84		...,
85	1x	width_row_names = final_width[1],
86	1x	width_columns = final_width[-1],
87	1x	draw = FALSE
88		)
89		}
90
91		#' @describeIn fstg02 Preprocessing
92		#'
93		#' @inheritParams fstg02_main
94		#'
95		#' @export
96		#'
97		fstg02_pre <- function(adam_db, ...) {
98	1x	adam_db$adtte <- adam_db$adtte %>%
99	1x	mutate(
100	1x	ARM = droplevels(.data$ARM),
101	1x	AVAL = convert_to_month(.data$AVAL, .data$AVALU),
102	1x	AVALU = "MONTHS",
103	1x	IS_EVENT = .data$CNSR == 0
104		)
105	1x	adam_db
106		}
107
108		# `fstg02` Pipeline ----
109
110		#' `FSTG02` Subgroup Analysis of Survival Duration.
111		#'
112		#' The template produces the subgroup analysis of survival duration graphic.
113		#'
114		#' @include chevron_tlg-S4class.R
115		#' @export
116		#'
117		#' @examples
118		#' library(dplyr)
119		#' library(dunlin)
120		#'
121		#' proc_data <- log_filter(
122		#' syn_data,
123		#' PARAMCD == "OS" & ARM %in% c("A: Drug X", "B: Placebo"), "adtte"
124		#' )
125		#' run(fstg02, proc_data,
126		#' subgroups = c("SEX", "AGEGR1", "RACE"),
127		#' conf_level = 0.90, dataset = "adtte"
128		#' )
129		fstg02 <- chevron_g(
130		main = fstg02_main,
131		preproces = fstg02_pre
132		)

1		# lbt14 ----
2
3		#' @describeIn lbt14 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param gr_missing (`string`) how missing baseline grades should be handled. Defaults to `"incl"` to include the
7		#' `"Missing"`
8		#' level. Other options are `"excl"` to exclude patients with missing baseline grades and `"gr_0"` to convert missing
9		#' baseline grades to grade 0.
10		#' @param direction (`string`) one of `"high"` or `"low"` indicating which shift direction should be detailed.
11		#'
12		#' @details
13		#' * This table follows ADaMIG v1.1.
14		#' * Only the worst grade recorded for each patient is included in the table.
15		#' * If no missing baseline lab results, the "Missing" level of `BTOXGR` is excluded.
16		#' * Grading takes value from -4 to 4, negative value means the abnormality direction is low,
17		#' positive value means the abnormality direction is high.
18		#' * Grades 0, 1, 2, 3, and 4 are counted as `"Not Low"` when `direction = "low"`. Conversely, when `direction =
19		#' "high"`, Grades 0, -1, -2, -3, and -4 are counted as `"Not High".
20		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
21		#' * Split columns by arm, typically `ACTARM`.
22		#'
23		#' @note
24		#' * `adam_db` object must contain an `adlb` table with columns `"USUBJID"`, `"PARAM"`, `"BTOXGR"`, `"ATOXGR"`,
25		#' and the column specified by `arm_var`.
26		#'
27		#' @export
28		#'
29		lbt14_main <- function(adam_db,
30		arm_var = "ACTARM",
31		lbl_overall = NULL,
32		gr_missing = "incl",
33		page_var = "PARAMCD",
34		...) {
35	4x	assert_all_tablenames(adam_db, c("adsl", "adlb"))
36	4x	assert_string(arm_var)
37	4x	assert_string(lbl_overall, null.ok = TRUE)
38	4x	assert_choice(gr_missing, c("incl", "excl", "gr_0"))
39	4x	assert_subset(page_var, "PARAMCD")
40	4x	assert_valid_variable(adam_db$adlb, c("ATOXGR", "BTOXGR"), types = list("factor"), na_ok = TRUE)
41	4x	assert_valid_variable(adam_db$adlb, c("PARAMCD", "PARAM"), types = list(c("character", "factor")), na_ok = FALSE)
42	4x	assert_valid_variable(adam_db$adlb, c("USUBJID"), types = list(c("character", "factor")), empty_ok = TRUE)
43	4x	assert_valid_variable(adam_db$adsl, c("USUBJID"), types = list(c("character", "factor")))
44	4x	assert_valid_var_pair(adam_db$adsl, adam_db$adlb, arm_var)
45
46	4x	lbl_overall <- render_safe(lbl_overall)
47	4x	lbl_param <- var_labels_for(adam_db$adlb, "PARAM")
48	4x	lbl_btoxgr <- var_labels_for(adam_db$adlb, "BTOXGR")
49
50	4x	lyt <- lbt14_lyt(
51	4x	arm_var = arm_var,
52	4x	lbl_overall = lbl_overall,
53	4x	lbl_param = lbl_param,
54	4x	lbl_btoxgr = lbl_btoxgr,
55	4x	page_var = page_var
56		)
57
58	4x	tbl <- build_table(lyt, adam_db$adlb, alt_counts_df = adam_db$adsl)
59
60	4x	tbl
61		}
62
63		#' `lbt14` Layout
64		#'
65		#' @inheritParams lbt14_main
66		#'
67		#' @keywords internal
68		#'
69		lbt14_lyt <- function(arm_var,
70		lbl_overall,
71		lbl_param,
72		lbl_btoxgr,
73		page_var) {
74	14x	page_by <- !is.null(page_var)
75	14x	label_pos <- ifelse(page_by, "hidden", "topleft")
76	14x	basic_table(show_colcounts = TRUE) %>%
77	14x	split_cols_by(arm_var) %>%
78	14x	ifneeded_add_overall_col(lbl_overall) %>%
79	14x	split_rows_by(
80	14x	var = "PARAMCD",
81	14x	labels_var = "PARAM",
82	14x	split_fun = drop_split_levels,
83	14x	label_pos = label_pos,
84	14x	split_label = lbl_param,
85	14x	page_by = page_by
86		) %>%
87	14x	split_rows_by(
88	14x	"BTOXGR",
89	14x	label_pos = "topleft",
90	14x	split_label = lbl_btoxgr
91		) %>%
92	14x	summarize_num_patients(var = "USUBJID", .stats = c("unique_count"), unique_count_suffix = FALSE) %>%
93	14x	count_occurrences_by_grade("ATOXGR", denom = "n", drop = FALSE, .indent_mods = 3L) %>%
94	14x	append_topleft(paste0(stringr::str_dup(" ", 2L * (5L - page_by)), "Post-baseline NCI-CTCAE Grade"))
95		}
96
97		#' @describeIn lbt14 Preprocessing
98		#'
99		#' @inheritParams gen_args
100		#' @inheritParams lbt14_main
101		#'
102		#' @export
103		#'
104		lbt14_pre <- function(adam_db,
105		gr_missing = "incl",
106		direction = "low",
107		...) {
108	4x	assert_choice(gr_missing, c("incl", "excl", "gr_0"))
109	4x	assert_choice(direction, c("low", "high"))
110
111	4x	if (direction == "high") {
112	1x	adam_db$adlb <- adam_db$adlb %>%
113	1x	filter(.data$WGRHIFL == "Y") %>%
114	1x	h_adsl_adlb_merge_using_worst_flag(
115	1x	adsl = adam_db$adsl,
116	1x	worst_flag = c("WGRHIFL" = "Y")
117		)
118		} else {
119	3x	adam_db$adlb <- adam_db$adlb %>%
120	3x	filter(.data$WGRLOFL == "Y") %>%
121	3x	h_adsl_adlb_merge_using_worst_flag(
122	3x	adsl = adam_db$adsl,
123	3x	worst_flag = c("WGRLOFL" = "Y")
124		)
125		}
126
127	4x	grade_rule <- get_grade_rule(direction, gr_missing)
128	4x	adam_db$adlb <- adam_db$adlb %>%
129	4x	mutate(
130	4x	across(all_of(c("BTOXGR", "ATOXGR")), ~ reformat(.x, grade_rule))
131		)
132
133	4x	adam_db
134		}
135
136		#' @describeIn lbt14 Postprocessing
137		#'
138		#' @inheritParams gen_args
139		#'
140		#' @export
141		#'
142		lbt14_post <- function(tlg, prune_0 = TRUE, ...) {
143	4x	if (prune_0) tlg <- tlg %>% trim_rows()
144	4x	std_postprocess(tlg)
145		}
146
147		#' `LBT14` Laboratory Test Results Shift Table – Highest `NCI-CTCAE` Grade Post-Baseline by
148		#' Baseline Grade (Low or High Direction).
149		#'
150		#' @include chevron_tlg-S4class.R
151		#' @export
152		#'
153		#' @examples
154		#' run(lbt14, syn_data)
155		lbt14 <- chevron_t(
156		main = lbt14_main,
157		preprocess = lbt14_pre,
158		postprocess = lbt14_post
159		)

1		# rspt01 ----
2
3		#' @describeIn rspt01 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param dataset (`string`) the name of a table in the `adam_db` object.
7		#' @param ref_group (`string`) The name of the reference group, the value should
8		#' be identical to the values in `arm_var`, if not specified, it will by default
9		#' use the first level or value of `arm_var`.
10		#' @param odds_ratio (`flag`) should the odds ratio be calculated, default is `TRUE`
11		#' @param perform_analysis (`string`) option to display statistical comparisons using stratified analyses,
12		#' or unstratified analyses, or both, e.g. `c("unstrat", "strat")`. Only unstratified will be displayed by default
13		#' @param strata (`string`) stratification factors, e.g. `strata = c("STRATA1", "STRATA2")`, by default as NULL
14		#' @param conf_level (`numeric`) the level of confidence interval, default is 0.95.
15		#' @param methods (`list`) a named list, use a named list to control, for example:
16		#' `methods = list(prop_conf_method = "wald",
17		#' diff_conf_method = "wald",
18		#' strat_diff_conf_method = "ha",
19		#' diff_pval_method = "fisher",
20		#' strat_diff_pval_method = "schouten")`
21		#' `prop_conf_method` controls the methods of calculating proportion confidence interval,
22		#' `diff_conf_method` controls the methods of calculating unstratified difference confidence interval,
23		#' `strat_diff_conf_method` controls the methods of calculating stratified difference confidence interval,
24		#' `diff_pval_method` controls the methods of calculating unstratified p-value for odds ratio,
25		#' `strat_diff_pval_method` controls the methods of calculating stratified p-value for odds ratio,
26		#' see more details in `tern`
27		#'
28		#' @details
29		#' * No overall value.
30		#'
31		#' @export
32		#'
33		rspt01_main <- function(adam_db,
34		dataset = "adrs",
35		arm_var = "ARM",
36		ref_group = NULL,
37		odds_ratio = TRUE,
38		perform_analysis = "unstrat",
39		strata = NULL,
40		conf_level = 0.95,
41		methods = list(),
42		...) {
43	1x	assert_string(dataset)
44	1x	assert_all_tablenames(adam_db, "adsl", dataset)
45	1x	assert_string(arm_var)
46	1x	assert_string(ref_group, null.ok = TRUE)
47	1x	assert_flag(odds_ratio)
48	1x	assert_subset(perform_analysis, c("unstrat", "strat"))
49	1x	assert_character(
50	1x	strata,
51	1x	null.ok = !"strat" %in% perform_analysis,
52	1x	min.len = as.integer(!"strat" %in% perform_analysis)
53		)
54	1x	df_label <- sprintf("adam_db$%s", dataset)
55	1x	assert_valid_variable(
56	1x	adam_db$adsl, c("USUBJID", arm_var),
57	1x	types = list(c("character", "factor"))
58		)
59	1x	assert_valid_variable(
60	1x	adam_db[[dataset]], c("USUBJID", arm_var, "RSP_LAB"),
61	1x	types = list(c("character", "factor")), label = df_label
62		)
63	1x	assert_valid_variable(adam_db[[dataset]], "IS_RSP", types = list("logical"), label = df_label)
64	1x	assert_valid_variable(
65	1x	adam_db[[dataset]], c("PARAMCD", "PARAM"),
66	1x	types = list(c("character", "factor")), label = df_label
67		)
68	1x	assert_single_value(adam_db[[dataset]]$PARAMCD, label = sprintf("adam_db$%s$PARAMCD", dataset))
69	1x	assert_valid_var_pair(adam_db$adsl, adam_db[[dataset]], arm_var)
70	1x	assert_subset(ref_group, lvls(adam_db[[dataset]][[arm_var]]))
71
72	1x	ref_group <- ref_group %\|\|% lvls(adam_db[[dataset]][[arm_var]])[1]
73
74	1x	lyt <- rspt01_lyt(
75	1x	arm_var = arm_var,
76	1x	rsp_var = "IS_RSP",
77	1x	ref_group = ref_group,
78	1x	odds_ratio = odds_ratio,
79	1x	perform_analysis = perform_analysis,
80	1x	strata = strata,
81	1x	conf_level = conf_level,
82	1x	methods = methods
83		)
84
85	1x	tbl <- build_table(lyt, adam_db[[dataset]], alt_counts_df = adam_db$adsl)
86
87	1x	tbl
88		}
89
90		#' `rspt01` Layout
91		#'
92		#' @inheritParams gen_args
93		#'
94		#' @keywords internal
95		#'
96		rspt01_lyt <- function(arm_var,
97		rsp_var,
98		ref_group,
99		odds_ratio,
100		perform_analysis,
101		strata,
102		conf_level,
103		methods) {
104	7x	lyt01 <- basic_table(show_colcounts = TRUE) %>%
105	7x	split_cols_by(var = arm_var, ref_group = ref_group) %>%
106	7x	estimate_proportion(
107	7x	vars = rsp_var,
108	7x	conf_level = conf_level,
109	7x	method = methods[["prop_conf_method"]] %\|\|% "waldcc",
110	7x	table_names = "est_prop"
111		)
112
113	7x	for (perform in perform_analysis) {
114	8x	lyt01 <- lyt01 %>%
115	8x	proportion_lyt(
116	8x	arm_var = arm_var,
117	8x	odds_ratio = odds_ratio,
118	8x	strata = if (perform == "strat") strata else NULL,
119	8x	conf_level = conf_level,
120	8x	methods = methods,
121	8x	rsp_var = rsp_var
122		)
123		}
124
125	7x	lyt <- lyt01 %>%
126	7x	estimate_multinomial_response(
127	7x	var = "RSP_LAB",
128	7x	conf_level = conf_level,
129	7x	method = methods[["prop_conf_method"]] %\|\|% "waldcc"
130		)
131
132	7x	lyt
133		}
134
135		#' @describeIn rspt01 Preprocessing
136		#'
137		#' @inheritParams gen_args
138		#'
139		#' @export
140		#'
141		rspt01_pre <- function(adam_db, ...) {
142	1x	adam_db$adrs <- adam_db$adrs %>%
143	1x	mutate(RSP_LAB = tern::d_onco_rsp_label(.data$AVALC)) %>%
144	1x	mutate(IS_RSP = .data$AVALC %in% c("CR", "PR"))
145	1x	adam_db
146		}
147
148		#' @describeIn rspt01 Postprocessing
149		#'
150		#' @inheritParams gen_args
151		#'
152		#' @export
153		#'
154		rspt01_post <- function(tlg, prune_0 = TRUE, ...) {
155	!	if (prune_0) {
156	!	tlg <- smart_prune(tlg)
157		}
158	!	std_postprocess(tlg)
159		}
160
161		#' `RSPT01` Binary Outcomes Summary
162		#'
163		#' `RSPT01` template may be used to summarize any binary outcome or response variable at
164		#' a single time point. Typical application for oncology
165		#'
166		#' @include chevron_tlg-S4class.R
167		#' @export
168		#'
169		#' @examples
170		#' library(dplyr)
171		#' library(dunlin)
172		#'
173		#' proc_data <- log_filter(syn_data, PARAMCD == "BESRSPI", "adrs")
174		#'
175		#' run(rspt01, proc_data)
176		#'
177		#' run(rspt01, proc_data,
178		#' odds_ratio = FALSE, perform_analysis = c("unstrat", "strat"),
179		#' strata = c("STRATA1", "STRATA2"), methods = list(diff_pval_method = "fisher")
180		#' )
181		rspt01 <- chevron_t(
182		main = rspt01_main,
183		preprocess = rspt01_pre,
184		postprocess = rspt01_post
185		)

1		#' @keywords internal
2		split_and_summ_num_patients <- function(lyt, var, label, stats, summarize_labels, split_indent, ...) {
3	13x	assert_string(var)
4	13x	assert_string(label)
5	13x	lyt <- lyt %>%
6	13x	split_rows_by(
7	13x	var,
8	13x	child_labels = "visible",
9	13x	nested = TRUE,
10	13x	split_fun = rtables::drop_split_levels,
11	13x	label_pos = "topleft",
12	13x	split_label = label,
13	13x	indent_mod = split_indent
14		)
15	13x	if (length(stats) > 0) {
16	13x	lyt <- lyt %>%
17	13x	summarize_num_patients(
18	13x	var = "USUBJID",
19	13x	.stats = stats,
20	13x	.labels = setNames(summarize_labels, stats),
21		...
22		)
23		}
24	13x	lyt
25		}
26		#' @keywords internal
27		get_sort_path <- function(x) {
28	46x	assert_character(x, null.ok = TRUE)
29	46x	x2 <- as.character(rbind(x, rep("*", length(x))))
30	46x	x2[-length(x2)]
31		}
32		#' @keywords internal
33		tlg_sort_by_vars <- function(tlg, vars, scorefun = cont_n_allcols, ...) {
34	18x	purrr::reduce(
35	18x	.x = lapply(seq_len(length(vars)), function(i) vars[seq_len(i)]),
36	18x	.f = tlg_sort_by_var,
37	18x	.init = tlg,
38	18x	scorefun = scorefun,
39		...
40		)
41		}
42		#' @keywords internal
43		tlg_sort_by_var <- function(tlg, var, scorefun = cont_n_allcols, ...) {
44	38x	assert_character(var)
45	38x	if (length(var) == 0) {
46	!	return(tlg)
47		}
48	38x	var_path <- get_sort_path(var)
49	38x	tlg %>%
50	38x	valid_sort_at_path(
51	38x	path = var_path,
52	38x	scorefun = scorefun,
53		...
54		)
55		}
56		#' @keywords internal
57		valid_sort_at_path <- function(tt, path, scorefun, ...) {
58	46x	if (valid_row_path(tt, path)) {
59	39x	tryCatch(
60	39x	sort_at_path(tt, path, scorefun, ...),
61	39x	error = function(e) {
62	!	tt
63		}
64		)
65		} else {
66	7x	tt
67		}
68		}
69		#' @keywords internal
70		valid_row_path <- function(tlg, row_path) {
71	46x	if (nrow(tlg) == 0) {
72	2x	return(TRUE)
73		}
74	44x	rpaths <- row_paths(tlg)
75	44x	non_star <- which(row_path != "*") + 1
76	44x	rpaths_choice <- unique(lapply(rpaths, `[`, non_star))
77	44x	any(vapply(rpaths_choice, identical, FUN.VALUE = TRUE, y = row_path[non_star - 1]))
78		}
79
80		#' Count patients recursively
81		#' @param lyt (`PreDataTableLayouts`) `rtable` layout.
82		#' @param anl_vars Named (`list`) of analysis variables.
83		#' @param anl_lbls (`character`) of labels.
84		#' @param lbl_vars Named (`list`) of analysis labels.
85		#' @keywords internal
86		count_patients_recursive <- function(lyt, anl_vars, anl_lbls, lbl_vars) {
87	6x	assert_list(anl_vars, names = "unique", types = "character")
88	6x	assert_character(anl_lbls, min.chars = 1L, len = length(anl_vars))
89	6x	nms <- names(anl_vars)
90	6x	for (k in seq_len(length(anl_vars))) {
91	7x	lyt <- lyt %>%
92	7x	count_patients_with_flags(
93	7x	var = "USUBJID",
94	7x	flag_variables = setNames(lbl_vars[[k]], anl_vars[[k]]),
95	7x	denom = "N_col",
96	7x	var_labels = anl_lbls[k],
97	7x	show_labels = "visible",
98	7x	table_names = nms[k],
99	7x	.indent_mods = 0L
100		)
101		}
102	6x	lyt
103		}
104		#' @keywords internal
105		score_all_sum <- function(tt) {
106	102x	cleaf <- collect_leaves(tt)[[1]]
107	102x	if (NROW(cleaf) == 0) {
108	!	stop("score_all_sum score function used at subtable [", obj_name(tt), "] that has no content.")
109		}
110	102x	sum(sapply(row_values(cleaf), function(cv) cv[1]))
111		}
112		#' @keywords internal
113		summarize_row <- function(lyt, vars, afun, ...) {
114	2x	summarize_row_groups(lyt = lyt, var = vars, cfun = afun, ...)
115		}
116
117		#' Summary factor allowing NA
118		#' @param x (`factor`) input.
119		#' @param denom (`string`) denominator choice.
120		#' @param .N_row (`integer`) number of rows in row-split dataset.
121		#' @param .N_col (`integer`) number of rows in column-split dataset.
122		#' @param ... Not used
123		#' @keywords internal
124		s_summary_na <- function(x, labelstr, denom = c("n", "N_row", "N_col"), .N_row, .N_col, ...) { # nolint
125	210x	denom <- match.arg(denom)
126	210x	y <- list()
127	210x	y$n <- length(x)
128	210x	y$count <- as.list(table(x, useNA = "no"))
129	210x	dn <- switch(denom,
130	210x	n = length(x),
131	210x	N_row = .N_row,
132	210x	N_col = .N_col
133		)
134	210x	y$count_fraction <- lapply(y$count, function(x) {
135	714x	c(x, ifelse(dn > 0, x / dn, 0))
136		})
137	210x	y$n_blq <- sum(grepl("BLQ\|LTR\|<[1-9]", x))
138	210x	y
139		}
140		#' Summarize variables allow `NA`
141		#' @keywords internal
142		summarize_vars_allow_na <- function(
143		lyt, vars, var_labels = vars,
144		nested = TRUE, ..., show_labels = "default", table_names = vars,
145		section_div = NA_character_, .stats = c("n", "count_fraction"),
146		.formats = list(count_fraction = format_count_fraction_fixed_dp), .labels = NULL, .indent_mods = NULL, inclNAs = TRUE) { # nolint
147	7x	afun <- make_afun(s_summary_na, .stats, .formats, .labels, .indent_mods, .ungroup_stats = c("count_fraction"))
148	7x	analyze(
149	7x	lyt = lyt, vars = vars, var_labels = var_labels,
150	7x	afun = afun, nested = nested, extra_args = list(...),
151	7x	inclNAs = inclNAs, show_labels = show_labels, table_names = table_names,
152	7x	section_div = section_div
153		)
154		}
155
156		#' Count or summarize by groups
157		#' @param lyt (`PreDataTableLayouts`) `rtable` layout.
158		#' @param var (`string`) of analysis variable.
159		#' @param level (`string`) level to be displayed.
160		#' @param detail_vars (`character`) of variables for detail information.
161		#' @keywords internal
162		count_or_summarize <- function(lyt, var, level, detail_vars, indent_mod = 0L, ...) {
163	27x	assert_string(level)
164	27x	if (is.null(detail_vars)) {
165	20x	lyt <- lyt %>%
166	20x	count_values(
167	20x	var,
168	20x	values = level,
169	20x	table_names = paste(var, level, sep = "_"),
170	20x	.formats = list(count_fraction = format_count_fraction_fixed_dp),
171	20x	.indent_mods = indent_mod,
172		...
173		)
174		} else {
175	7x	lyt <- lyt %>%
176	7x	split_rows_by(var, split_fun = keep_split_levels(level), indent_mod = indent_mod) %>%
177	7x	summarize_row_groups(
178	7x	format = format_count_fraction_fixed_dp
179		) %>%
180	7x	split_rows_by_recurive(detail_vars[-length(detail_vars)], split_fun = drop_split_levels) %>%
181	7x	summarize_vars(
182	7x	detail_vars[length(detail_vars)],
183	7x	.stats = "count_fraction",
184	7x	denom = "N_col",
185	7x	show_labels = "hidden",
186	7x	.formats = list(count_fraction = format_count_fraction_fixed_dp),
187		...
188		)
189		}
190	27x	lyt
191		}
192
193		#' Count or summarize by groups
194		#' @param lyt (`PreDataTableLayouts`) `rtable` layout.
195		#' @param row_split_var (`character`) variable to split rows by.
196		#' @param ... Further arguments for `split_rows_by`
197		#' @keywords internal
198		split_rows_by_recurive <- function(lyt, row_split_var, ...) {
199	41x	args <- list(...)
200	41x	for (i in seq_len(length(row_split_var))) {
201	22x	args_i <- lapply(args, obtain_value, index = i)
202	22x	lyt <- do_call(
203	22x	split_rows_by,
204	22x	c(
205	22x	list(
206	22x	lyt = lyt,
207	22x	row_split_var
208		),
209	22x	args_i
210		)
211		)
212		}
213	41x	lyt
214		}
215
216		#' Obtain value from a vector
217		#' @keywords internal
218		obtain_value <- function(obj, index) {
219	62x	if (is.list(obj)) {
220	!	return(obj[[index]])
221		}
222	62x	if (is.vector(obj) && length(obj) >= index) {
223	60x	return(obj[index])
224		}
225	2x	return(obj)
226		}
227
228		#' Get page by value
229		#' @keywords internal
230		get_page_by <- function(var, vars) {
231	34x	assert_character(vars, null.ok = TRUE)
232	34x	assert_character(var, null.ok = TRUE, max.len = 1L)
233	34x	ret <- rep(FALSE, length(vars))
234	34x	if (is.null(var) \|\| length(var) == 0) {
235	15x	return(ret)
236		}
237	19x	index <- match(var, vars)
238	19x	assert_int(index, na.ok = TRUE)
239	19x	if (is.na(index)) {
240	!	return(ret)
241		}
242	19x	ret[seq_len(index)] <- TRUE
243	19x	return(ret)
244		}
245
246		#' Proportion layout
247		#'
248		#' @inheritParams rspt01_main
249		#' @param lyt layout created by `rtables`
250		#'
251		#' @keywords internal
252		proportion_lyt <- function(lyt, arm_var, methods, strata, conf_level, odds_ratio = TRUE, rsp_var = "IS_RSP") {
253	8x	non_stratified <- length(strata) == 0L
254	8x	lyt <- lyt %>%
255	8x	estimate_proportion_diff(
256	8x	vars = rsp_var,
257	8x	show_labels = "visible",
258	8x	var_labels = if (non_stratified) "Unstratified Analysis" else "Stratified Analysis",
259	8x	conf_level = conf_level,
260	8x	method = if (non_stratified) {
261	6x	methods[["diff_conf_method"]] %\|\|% "waldcc"
262		} else {
263	2x	methods[["strat_diff_conf_method"]] %\|\|% "cmh"
264		},
265	8x	variables = list(strata = strata),
266	8x	table_names = if (non_stratified) "est_prop_diff" else "est_prop_diff_strat"
267		) %>%
268	8x	test_proportion_diff(
269	8x	vars = rsp_var,
270	8x	method = if (non_stratified) {
271	6x	methods[["diff_pval_method"]] %\|\|% "chisq"
272		} else {
273	2x	methods[["strat_diff_pval_method"]] %\|\|% "cmh"
274		},
275	8x	variables = list(strata = strata),
276	8x	table_names = if (non_stratified) "test_prop_diff" else "test_prop_diff_strat"
277		)
278
279	8x	if (odds_ratio) {
280	4x	lyt <- lyt %>%
281	4x	estimate_odds_ratio(
282	4x	vars = rsp_var,
283	4x	variables = if (non_stratified) list(strata = strata, arm = arm_var),
284	4x	table_names = if (non_stratified) "est_or" else "est_or_strat"
285		)
286		}
287
288	8x	lyt
289		}
290
291		#' Helper function to add a row split if specified
292		#'
293		#' @param lyt (`PreDataTableLayouts`) object.
294		#' @param var (`string`) the name of the variable initiating a new row split.
295		#' @param lbl_var (`string`)the label of the variable `var`.
296		#'
297		#' @keywords internal
298		#'
299		#' @return `PreDataTableLayouts` object.
300		#'
301		ifneeded_split_row <- function(lyt, var, lbl_var) {
302	2x	if (is.null(var)) {
303	1x	lyt
304		} else {
305	1x	split_rows_by(lyt, var,
306	1x	label_pos = "topleft",
307	1x	split_label = lbl_var
308		)
309		}
310		}
311
312		#' Helper function to add a column split if specified
313		#'
314		#' @param lyt (`rtables`) object.
315		#' @param var (`string`) the name of the variable initiating a new column split.
316		#' @param ... Additional arguments for `split_cols_by`.
317		#'
318		#' @keywords internal
319		#'
320		#' @return `rtables` object.
321		#'
322		ifneeded_split_col <- function(lyt, var, ...) {
323	16x	if (is.null(var)) {
324	11x	lyt
325		} else {
326	5x	split_cols_by(
327	5x	lyt = lyt,
328	5x	var = var,
329		...
330		)
331		}
332		}
333
334		#' Create a Null Report
335		#' @rdname report_null
336		#' @aliases null_report
337		#' @param tlg (`TableTree`) object.
338		#' @param ... not used. Important to be used directly as post processing function.
339		#'
340		#' @export
341		#'
342		#' @return original `TableTree` or a null report if no observation are found in the table.
343		#'
344		report_null <- function(tlg, ...) {
345	167x	assert_true(is.null(tlg) \|\| rtables::is_rtable(tlg))
346
347	167x	if (is.null(tlg) \|\| nrow(tlg) == 0L) {
348	25x	return(null_report)
349		}
350	142x	if (count_children(tlg) == 0) {
351	1x	return(null_report)
352		}
353	141x	tlg
354		}
355
356		#' Count Children
357		#' @keywords internal
358		count_children <- function(x) {
359	2540x	assert_true(rtables::is_rtable(x))
360	2540x	if (is(x, "ElementaryTable")) {
361	1069x	return(length(x@children))
362		}
363	1471x	sum(vapply(
364	1471x	tree_children(x),
365	1471x	count_children,
366	1471x	FUN.VALUE = 0
367		))
368		}
369
370		#' @export
371		#' @rdname report_null
372		null_report <- rtables::rtable(
373		header = "",
374		rrow("", "Null Report: No observations met the reporting criteria for inclusion in this output.")
375		)
376
377		#' @export
378		#' @rdname report_null
379		null_listing <- rlistings::as_listing(
380		df = data.frame(x = formatters::with_label(
381		"Null Report: No observations met the reporting criteria for inclusion in this output.", ""
382		))
383		)
384
385		has_overall_col <- function(lbl_overall) {
386	128x	!is.null(lbl_overall) && !identical(lbl_overall, "")
387		}
388
389		ifneeded_add_overall_col <- function(lyt, lbl_overall) {
390	128x	if (has_overall_col(lbl_overall)) {
391	14x	add_overall_col(lyt, label = lbl_overall)
392		} else {
393	114x	lyt
394		}
395		}
396
397		#' Analyze skip baseline
398		#' @param x value to analyze
399		#' @param .var variable name.
400		#' @param .spl_context split context.
401		#' @param paramcdvar (`string`) name of parameter code.
402		#' @param visitvar (`string`) name of the visit variable.
403		#' @param skip Named (`character`) indicating the pairs to skip in analyze.
404		#' @param .stats (`character`) See `tern::summarize_variables`.
405		#' @param .label (`character`) See `tern::summarize_variables`.
406		#' @param .indent_mods (`integer`) See `tern::summarize_variables`.
407		#' @param .N_col (`int`) See `tern::summarize_variables`.
408		#' @param .N_row (`int`) See `tern::summarize_variables`.
409		#' @param ... additional arguments for `tern::a_summary`.
410		#' @inheritParams cfbt01_main
411		#' @keywords internal
412		afun_skip <- function(
413		x, .var, .spl_context, paramcdvar, visitvar, skip,
414		precision, .stats, .labels = NULL, .indent_mods = NULL, .N_col, .N_row, ...) { # nolint
415	1452x	param_val <- .spl_context$value[which(.spl_context$split == paramcdvar)]
416		# Identify context
417	1452x	split_level <- .spl_context$value[which(.spl_context$split == visitvar)]
418	1452x	pcs <- if (.var %in% names(skip) && split_level %in% skip[[.var]]) {
419	1452x	NA
420		} else {
421	1341x	precision[[param_val]] %\|\|% precision[["default"]] %\|\|% 2
422		}
423
424	1452x	fmts <- lapply(.stats, summary_formats, pcs = pcs, FALSE)
425	1452x	names(fmts) <- .stats
426	1452x	fmts_na <- lapply(.stats, summary_formats, pcs = pcs, ne = TRUE)
427	1452x	ret <- tern::a_summary(
428	1452x	.stats = .stats, .formats = fmts, .labels = .labels, .indent_mods = .indent_mods,
429	1452x	x = x, .var = .var, .spl_context = .spl_context, .N_col = .N_col, .N_row = .N_row, ...
430		)
431	1452x	for (i in seq_len(length(ret))) {
432	5808x	attr(ret[[i]], "format_na_str") <- fmts_na[[i]]()
433		}
434	1452x	ret
435		}
436
437		summary_formats <- function(x, pcs, ne = FALSE) {
438	11616x	assert_int(pcs, lower = 0, na.ok = TRUE)
439	11616x	switch(x,
440	2904x	n = h_format_dec(format = "%s", digits = pcs - pcs, ne = ne),
441		min = ,
442		max = ,
443	!	sum = h_format_dec(format = "%s", digits = pcs, ne = ne),
444		mean = ,
445		sd = ,
446		median = ,
447		mad = ,
448		iqr = ,
449		cv = ,
450		geom_mean = ,
451		geom_cv = ,
452	2904x	se = h_format_dec(format = "%s", digits = pcs + 1, ne = ne),
453		mean_sd = ,
454	2904x	mean_se = h_format_dec(format = "%s (%s)", digits = rep(pcs + 1, 2), ne = ne),
455		mean_ci = ,
456		mean_sei = ,
457		median_ci = ,
458	!	mean_sdi = h_format_dec(format = "(%s, %s)", digits = rep(pcs + 1, 2), ne = ne),
459	!	mean_pval = h_format_dec(format = "%s", digits = 2, ne = ne),
460	!	quantiles = h_format_dec(format = "(%s - %s)", digits = rep(pcs + 1, 2), ne = ne),
461	2904x	range = h_format_dec(format = "%s - %s", digits = rep(pcs, 2), ne = ne),
462	!	median_range = h_format_dec(format = "%s (%s - %s)", digits = c(pcs, pcs + 1, pcs + 1), ne = ne)
463		)
464		}
465
466		split_fun_map <- function(map) {
467	9x	if (is.null(map)) {
468	6x	drop_split_levels
469		} else {
470	3x	trim_levels_to_map(map = map)
471		}
472		}
473
474		infer_mapping <- function(map_df, df) {
475	3x	assert_data_frame(df)
476	3x	vars <- colnames(map_df)
477	3x	assert_names(names(df), must.include = vars)
478	3x	for (x in vars) {
479	7x	if (!test_subset(map_df[[x]], lvls(df[[x]]))) {
480	!	rlang::abort(
481	!	paste0(
482	!	"Provided map should only contain valid levels in dataset in variable ", x,
483	!	". Consider convert ", x, " to factor first and add",
484	!	toString(setdiff(map_df[[x]], lvls(df[[x]]))), "levels to it."
485		)
486		)
487		}
488		}
489	3x	res <- df[vars] %>%
490	3x	unique() %>%
491	3x	arrange(across(everything())) %>%
492	3x	mutate(across(everything(), as.character))
493	3x	if (!is.null(map_df)) {
494	3x	dplyr::full_join(map_df, res, by = colnames(map_df))[vars]
495		} else {
496	!	res
497		}
498		}
499
500
501		#' Occurrence Layout
502		#'
503		#' @inheritParams gen_args
504		#' @inheritParams cmt01a_main
505		#' @param lbl_medname_var (`string`) label for the variable defining the medication name.
506		#' @keywords internal
507		#'
508		occurrence_lyt <- function(arm_var,
509		lbl_overall,
510		row_split_var,
511		lbl_row_split,
512		medname_var,
513		lbl_medname_var,
514		summary_labels,
515		count_by) {
516	17x	split_indent <- vapply(c("TOTAL", row_split_var), function(x) {
517	!	if (length(summary_labels[[x]]) > 0L) -1L else 0L
518	17x	}, FUN.VALUE = 0L)
519	17x	split_indent[1L] <- 0L
520	17x	lyt <- basic_table() %>%
521	17x	split_cols_by(var = arm_var) %>%
522	17x	add_colcounts() %>%
523	17x	ifneeded_add_overall_col(lbl_overall)
524	17x	if (length(summary_labels$TOTAL) > 0) {
525	17x	lyt <- lyt %>%
526	17x	analyze_num_patients(
527	17x	vars = "USUBJID",
528	17x	count_by = count_by,
529	17x	.stats = names(summary_labels$TOTAL),
530	17x	show_labels = "hidden",
531	17x	.labels = render_safe(summary_labels$TOTAL)
532		)
533		}
534	17x	for (k in seq_len(length(row_split_var))) {
535	13x	lyt <- split_and_summ_num_patients(
536	13x	lyt = lyt,
537	13x	count_by = count_by,
538	13x	var = row_split_var[k],
539	13x	label = lbl_row_split[k],
540	13x	split_indent = split_indent[k],
541	13x	stats = names(summary_labels[[row_split_var[k]]]),
542	13x	summarize_labels = render_safe(summary_labels[[row_split_var[k]]])
543		)
544		}
545	17x	lyt %>%
546	17x	count_occurrences(
547	17x	vars = medname_var,
548	17x	drop = length(row_split_var) > 0,
549	17x	.indent_mods = unname(tail(split_indent, 1L))
550		) %>%
551	17x	append_topleft(paste0(stringr::str_dup(" ", 2 * length(row_split_var)), lbl_medname_var))
552		}

1		#' @include chevron_tlg-S4class.R
2
3		# run ----
4
5		#' Run the pipeline
6		#'
7		#' Execute the pre-processing, main and post-processing functions in a single run.
8		#'
9		#' @inheritParams gen_args
10		#' @param object (`chevron_tlg`) input.
11		#' @param auto_pre (`flag`) whether to perform the default pre processing step.
12		#' @param verbose (`flag`) whether to print argument information.
13		#' @param ... extra arguments to pass to the pre-processing, main and post-processing functions.
14		#' @param user_args (`list`) arguments from `...`.
15		#'
16		#' @name run
17		#' @export
18		setGeneric(
19		"run",
20	169x	function(object, adam_db, auto_pre = TRUE, verbose = FALSE, ..., user_args = list(...)) standardGeneric("run")
21		)
22
23		#' Run the pipeline
24		#' @rdname run
25		#' @export
26		#' @examples
27		#' run(mng01, syn_data, auto_pre = TRUE, dataset = "adlb")
28		setMethod(
29		f = "run",
30		signature = "chevron_tlg",
31		definition = function(object, adam_db, auto_pre = TRUE, verbose = FALSE, ..., user_args = list(...)) {
32	169x	assert_list(adam_db, types = "list")
33	169x	assert_flag(auto_pre)
34	169x	assert_flag(verbose)
35	169x	assert_list(user_args, names = "unique")
36	169x	if (verbose) {
37	4x	cl <- match.call()
38	4x	print_args(
39	4x	cl,
40	4x	user_args,
41	4x	args_ls(object, omit = c("...", "adam_db", "tlg")), auto_pre
42		)
43		}
44	169x	proc_data <- if (auto_pre) {
45	168x	list(adam_db = do_call(object@preprocess, c(list(adam_db), user_args)))
46		} else {
47	1x	list(adam_db = adam_db)
48		}
49
50	158x	res_tlg <- list(tlg = do_call(object@main, c(proc_data, user_args)))
51
52	148x	do_call(object@postprocess, c(res_tlg, user_args))
53		}
54		)
55
56		#' Print Arguments
57		#' @keywords internal
58		print_args <- function(run_call, additional_args, args, auto_pre = TRUE) {
59	4x	assert_class(run_call, "call")
60	4x	assert_list(args)
61	4x	assert_flag(auto_pre)
62	4x	run_call[[1]] <- NULL
63	4x	run_call <- as.list(run_call)
64	4x	if (!is.null(additional_args)) {
65	4x	run_call <- c(run_call[c("object", "adam_db")], additional_args)
66		} else {
67	!	run_call[c("auto_pre", "verbose")] <- NULL
68		}
69	4x	nms_args <- unique(unlist(lapply(args, names)))
70	4x	nms_call <- names(run_call)
71	4x	m <- pmatch(nms_call, nms_args)
72	4x	nms_call[!is.na(m)] <- nms_args[m[!is.na(m)]]
73	4x	names(run_call) <- nms_call
74	4x	cat(
75	4x	"Using template: ",
76	4x	if (is.name(run_call$object)) run_call$object else paste("object of class", class(run_call$object)),
77	4x	"\n"
78		)
79	4x	cat(
80	4x	"Using data: ",
81	4x	if (is.name(run_call$adam_db)) run_call$adam_db else paste("object of class", class(run_call$adam_db)),
82	4x	"\n"
83		)
84	4x	if (auto_pre) {
85	4x	cat("\nPre args:\n")
86	4x	print_list(get_subset(args$preprocess, run_call))
87		}
88	4x	cat("\nMain args:\n")
89	4x	print_list(get_subset(args$main, run_call))
90	4x	cat("\nPost args:\n")
91	4x	print_list(get_subset(args$postprocess, run_call))
92	4x	add_args <- run_call[
93	4x	!names(run_call) %in% c(names(args$main), names(args$postprocess), names(args$preprocess), "object", "adam_db")
94		]
95	4x	if (length(add_args) > 0) {
96	1x	cat("\nAdditional args:\n")
97	1x	print_list(add_args)
98		}
99	4x	cat("\n\n")
100		}
101
102		#' Subset Arguments and Merge
103		#' @keywords internal
104		get_subset <- function(x, y) {
105	12x	utils::modifyList(
106	12x	x,
107	12x	y[names(y) %in% names(x)],
108	12x	keep.null = TRUE
109		)
110		}
111
112		#' Print list
113		#' @keywords internal
114		print_list <- function(x, indent = 2L) {
115	15x	if (length(x) == 0) {
116	2x	cat(paste0(
117	2x	stringr::str_dup(" ", indent),
118	2x	"No mapped argument.\n"
119		))
120	2x	return()
121		}
122	13x	k <- names(x)
123	13x	m_charx <- max(nchar(k), 1)
124	13x	for (k in names(x)) {
125	29x	cat(
126	29x	sprintf(
127	29x	paste0("%s%-", m_charx + 2, "s: %s\n"),
128	29x	stringr::str_dup(" ", indent), k,
129	29x	deparse_print(x[[k]], m_charx + indent + 2)
130		)
131		)
132		}
133		}
134
135		#' Deparse print
136		#' @keywords internal
137		deparse_print <- function(x, indent, max_line = getOption("chevron.arg_max_line", 5L)) {
138	29x	assert_int(indent)
139	29x	assert_int(max_line, lower = 1L)
140	29x	ret <- deparse(x)
141	29x	sep <- paste0("\n", stringr::str_dup(" ", indent))
142	29x	if (length(ret) > max_line) {
143	1x	ret[max_line] <- sprintf("... (print of class <%s> truncated)", toString(class(x)))
144	1x	ret <- ret[seq_len(max_line)]
145		}
146	29x	paste(ret, collapse = sep)
147		}
148
149		# args_ls ----
150
151		#' Get Arguments List
152		#'
153		#' @param x (`chevron_tlg`) input.
154		#' @param simplify (`flag`) whether to simplify the output, coalescing the values of the parameters. The order of
155		#' priority for the value of the parameters is: `main`, `preprocess` and `postprocess`.
156		#' @param omit (`character`) the names of the argument to omit from the output.
157		#'
158		#' @rdname args_ls
159		#' @export
160	7x	setGeneric("args_ls", function(x, simplify = FALSE, omit = NULL) standardGeneric("args_ls"))
161
162		#' @rdname args_ls
163		#' @export
164		setMethod(
165		f = "args_ls",
166		signature = "chevron_tlg",
167		definition = function(x, simplify = FALSE, omit = NULL) {
168	7x	assert_flag(simplify)
169	7x	assert_character(omit, null.ok = TRUE)
170
171	7x	x_ls <- list(
172	7x	main = formals(x@main),
173	7x	preprocess = formals(x@preprocess),
174	7x	postprocess = formals(x@postprocess)
175		)
176
177	7x	x_sel <- lapply(x_ls, function(y) y[!names(y) %in% omit])
178
179	7x	res <- if (simplify) {
180	2x	Reduce(fuse_sequentially, x_sel)
181		} else {
182	5x	x_sel
183		}
184
185	7x	res
186		}
187		)
188
189		# main ----
190
191		#' Main
192		#'
193		#' retrieve or set `main` function.
194		#'
195		#' @param x (`chevron_tlg`) input.
196		#'
197		#' @aliases main
198		#' @export
199	!	setGeneric("main", function(x) standardGeneric("main"))
200
201		#' @rdname main
202		#' @export
203		setMethod(
204		f = "main",
205		signature = "chevron_tlg",
206		definition = function(x) {
207	!	x@main
208		}
209		)
210
211		#' Set Main Function
212		#'
213		#' @param x (`chevron_tlg`) input.
214		#' @param value (`function`) returning a `tlg`. Typically one of the `_main` function of `chevron`.
215		#'
216		#' @rdname main
217		#' @export
218	2x	setGeneric("main<-", function(x, value) standardGeneric("main<-"))
219
220		#' @rdname main
221		#' @export
222		setMethod(
223		f = "main<-",
224		signature = "chevron_tlg",
225		definition = function(x, value) {
226	2x	x@main <- value
227	2x	validObject(x)
228	1x	x
229		}
230		)
231
232		# preprocess ----
233
234		#' Pre process
235		#'
236		#' retrieve or set `preprocess` function.
237		#'
238		#' @param x (`chevron_tlg`) input.
239		#'
240		#' @aliases preprocess
241		#' @export
242	2x	setGeneric("preprocess", function(x) standardGeneric("preprocess"))
243
244		#' @rdname preprocess
245		#' @export
246		setMethod(
247		f = "preprocess",
248		signature = "chevron_tlg",
249		definition = function(x) {
250	2x	x@preprocess
251		}
252		)
253
254		#' Set Preprocess Function
255		#'
256		#' @param x (`chevron_tlg`) input.
257		#' @param value (`function`) returning a pre-processed `list` of `data.frames` amenable to `tlg` creation. Typically
258		#' one of the `_pre` function of `chevron`.
259		#'
260		#' @rdname preprocess
261		#' @export
262	4x	setGeneric("preprocess<-", function(x, value) standardGeneric("preprocess<-"))
263
264		#' @rdname preprocess
265		#' @export
266		setMethod(
267		f = "preprocess<-",
268		signature = "chevron_tlg",
269		definition = function(x, value) {
270	4x	x@preprocess <- value
271	4x	validObject(x)
272	3x	x
273		}
274		)
275
276		# postprocess ----
277
278		#' Post process
279		#'
280		#' retrieve or set `postprocess` function.
281		#'
282		#' @param x (`chevron_tlg`) input.
283		#'
284		#' @aliases postprocess
285		#' @export
286	1x	setGeneric("postprocess", function(x) standardGeneric("postprocess"))
287
288		#' @rdname postprocess
289		#' @export
290		setMethod(
291		f = "postprocess",
292		signature = "chevron_tlg",
293		definition = function(x) {
294	1x	x@postprocess
295		}
296		)
297
298		#' Postprocess Assignment Function
299		#'
300		#' @param x (`chevron_tlg`) input.
301		#' @param value (`function`) returning a post-processed `tlg`.
302		#'
303		#' @rdname postprocess
304		#' @export
305	2x	setGeneric("postprocess<-", function(x, value) standardGeneric("postprocess<-"))
306
307		#' @rdname postprocess
308		#' @export
309		setMethod(
310		f = "postprocess<-",
311		signature = "chevron_tlg",
312		definition = function(x, value) {
313	2x	x@postprocess <- value
314	2x	validObject(x)
315	1x	x
316		}
317		)
318
319		# script ----
320
321		#' Create Script for Parameters Assignment
322		#'
323		#' @param x (`chevron_tlg`) input.
324		#' @param adam_db (`string`) the name of the dataset.
325		#' @param details (`flag`) deprecated. Whether to show the code of all functions.
326		#' @param args (`string`) the name of argument list.
327		#'
328		#' @name script
329		#' @rdname script
330		NULL
331
332		## script_funs ----
333
334		#' Create Script for `TLG` Generation
335		#'
336		#' @rdname script
337		#' @export
338	2x	setGeneric("script_funs", function(x, adam_db, args, details = FALSE) standardGeneric("script_funs"))
339
340		#' @rdname script
341		#' @export
342		#'
343		#' @examples
344		#' script_funs(aet04, adam_db = "syn_data", args = "args")
345		setMethod(
346		f = "script_funs",
347		signature = "chevron_tlg",
348		definition = function(x, adam_db, args, details) {
349	2x	checkmate::assert_flag(details)
350	2x	checkmate::assert_string(adam_db)
351	2x	checkmate::assert_string(args)
352	!	if (!missing(details)) lifecycle::deprecate_warn("0.2.2", "chevron::script_funs(details = )")
353	2x	tlg_name <- deparse(substitute(x))
354	2x	checkmate::assert_string(tlg_name, pattern = "^[a-zA-Z]+\\w+$")
355	2x	c(
356	2x	"# Edit Preprocessing Function.",
357	2x	glue::glue("preprocess({tlg_name}) <- "),
358	2x	deparse(preprocess(x), control = c("useSource")),
359		"",
360	2x	"# Create TLG",
361	2x	glue::glue(
362	2x	"tlg_output <- run(object = {tlg_name}, adam_db = {adam_db}",
363	2x	", verbose = TRUE, user_args = {args})"
364		)
365		)
366		}
367		)

1		# assert_all_tablenames ----
2
3		#' Assert that all names are among names of a `list` of `data.frame`.
4		#'
5		#' @param db (`list` of `data.frame`) input to check for the presence of tables.
6		#' @param tab (`character`) the names of the tables to be checked.
7		#' @param null_ok (`flag`) can `x` be NULL.
8		#' @param qualifier (`string`) to be returned if the check fails.
9		#'
10		#' @export
11		#'
12		#' @examples
13		#' \dontrun{
14		#'
15		#' lsd <- list(
16		#' mtcars = mtcars,
17		#' iris = iris
18		#' )
19		#'
20		#' assert_all_tablenames(lsd, c("mtcars", "iris", "x"), qualifier = "first test:")
21		#' }
22		assert_all_tablenames <- function(db, tab, null_ok = TRUE, qualifier = NULL) {
23	223x	assert_list(db, types = "data.frame", names = "unique")
24	223x	assert_character(tab, null.ok = null_ok)
25	223x	assert_string(qualifier, null.ok = TRUE)
26
27	223x	diff <- setdiff(tab, names(db))
28
29	223x	if (length(diff) == 0) {
30	221x	invisible(NULL)
31		} else {
32	2x	stop(
33	2x	paste(qualifier, "Expected table names:", toString(diff), "not in", deparse(substitute(db)))
34		)
35		}
36		}
37
38		# assert_one_tablenames ----
39
40		#' Assert that at least one name is among table names of a `list` of `data.frame`.
41		#'
42		#' @param db (`list` of `data.frame`) input to check for the presence or tables.
43		#' @param tab (`character`) the names of the tables to be checked.
44		#' @param null_ok (`flag`) can `x` be NULL.
45		#' @param qualifier (`string`) to be returned if the check fails.
46		#'
47		#' @keywords internal
48		#'
49		#' @examples
50		#' \dontrun{
51		#'
52		#' lsd <- list(
53		#' mtcars = mtcars,
54		#' iris = iris
55		#' )
56		#'
57		#' assert_one_tablenames(lsd, c("mtcars", "x", "y"), qualifier = "first test:")
58		#' }
59		assert_one_tablenames <- function(db, tab, null_ok = TRUE, qualifier = NULL) {
60	4x	assert_list(db, types = "data.frame", names = "unique")
61	4x	assert_character(tab, null.ok = null_ok)
62	4x	assert_string(qualifier, null.ok = TRUE)
63
64	4x	diff <- setdiff(tab, names(db))
65
66	4x	common <- intersect(tab, names(db))
67
68	4x	if (length(common) > 0) {
69	2x	invisible(NULL)
70		} else {
71	2x	stop(
72	2x	paste(qualifier, "At least one of:", toString(tab), "is expected to be a table name of", deparse(substitute(db)))
73		)
74		}
75		}
76
77
78
79		# assert_single_value ----
80
81		#' Check variable only has one unique value.
82		#' @param x value vector.
83		#' @param label (`string`) label of input.
84		#' @export
85		assert_single_value <- function(x, label = deparse(substitute(x))) {
86	53x	unique_param_val <- unique(x)
87	53x	if (length(unique_param_val) > 1) {
88	!	stop(
89	!	quote_str(label),
90	!	" has more than one values ",
91	!	toString(unique_param_val),
92	!	", only one value is allowed."
93		)
94		}
95		}
96
97		# assert_valid_var ----
98
99		#' @title Check whether var is valid
100		#' @details
101		#' This function checks the variable values are valid or not.
102		#' @param x value of col_split variable
103		#' @param label (`string`) hints.
104		#' @param na_ok (`flag`) whether NA value is allowed
105		#' @param empty_ok (`flag`) whether length 0 value is allowed.
106		#' @param ... Further arguments to methods.
107		#' @export
108		assert_valid_var <- function(x, label, na_ok, empty_ok, ...) {
109	1404x	UseMethod("assert_valid_var")
110		}
111		#' @rdname assert_valid_var
112		#' @export
113		#' @param min_chars (`integer`) the minimum length of the characters.
114		assert_valid_var.character <- function(
115		x, label = deparse(substitute(x)),
116		na_ok = FALSE, empty_ok = FALSE,
117		min_chars = 1L, ...) {
118	345x	assert_character(
119	345x	x,
120	345x	min.chars = min_chars,
121	345x	min.len = as.integer(!empty_ok),
122	345x	any.missing = na_ok,
123	345x	.var.name = label,
124		...
125		)
126		}
127
128		#' @rdname assert_valid_var
129		#' @export
130		assert_valid_var.factor <- function(
131		x, label = deparse(substitute(x)),
132		na_ok = FALSE, empty_ok = FALSE,
133		min_chars = 1L, ...) {
134	807x	assert_character(
135	807x	levels(x),
136	807x	min.chars = min_chars,
137	807x	.var.name = paste("level of", label)
138		)
139	806x	assert_factor(
140	806x	x,
141	806x	min.levels = as.integer(!empty_ok),
142	806x	any.missing = na_ok,
143	806x	.var.name = label,
144		...
145		)
146		}
147
148		#' @rdname assert_valid_var
149		#' @export
150		assert_valid_var.logical <- function(x, label = deparse(substitute(x)), na_ok = TRUE, empty_ok = FALSE, ...) {
151	143x	assert_logical(
152	143x	x,
153	143x	min.len = as.integer(!empty_ok),
154	143x	any.missing = na_ok,
155	143x	.var.name = label,
156		...
157		)
158		}
159		#' @rdname assert_valid_var
160		#' @param integerish (`flag`) whether the number should be treated as `integerish`.
161		#' @export
162		assert_valid_var.numeric <- function(
163		x, label = deparse(substitute(x)),
164		na_ok = TRUE, empty_ok = FALSE, integerish = FALSE, ...) {
165	109x	check_fun <- if (integerish) assert_integerish else assert_numeric
166	109x	check_fun(
167	109x	x,
168	109x	min.len = as.integer(!empty_ok),
169	109x	any.missing = na_ok,
170	109x	.var.name = label,
171		...
172		)
173		}
174
175		#' @rdname assert_valid_var
176		#' @export
177		assert_valid_var.default <- function(x, label = deparse(substitute(x)), na_ok = FALSE, empty_ok = FALSE, ...) {
178		}
179
180		# assert_valid_variable ----
181
182		#' Check variables in a data frame are valid character or factor.
183		#' @param df (`data.frame`) input dataset.
184		#' @param vars (`character`) variables to check.
185		#' @param label (`string`) labels of the data frame.
186		#' @param types Named (`list`) of type of the input.
187		#' @param ... further arguments for `assert_valid_var`. Please note that different methods have different arguments
188		#' so if provided make sure the variables to check is of the same class.
189		#'
190		#' @export
191		assert_valid_variable <- function(df, vars, label = deparse(substitute(df)), types = NULL, ...) {
192	840x	assert_names(colnames(df), must.include = vars, what = "colnames")
193
194	834x	labels <- sprintf("%s$%s", label, vars)
195	834x	if (length(types) == 1 && is.null(names(types))) {
196	747x	types <- setNames(rep(types, length(vars)), vars)
197		}
198	834x	if (!is.null(types)) {
199	787x	vars_to_check <- which(vars %in% names(types))
200	787x	mapply(
201	787x	assert_valid_type,
202	787x	df[vars[vars_to_check]],
203	787x	types = types[vars_to_check],
204	787x	label = labels[vars_to_check]
205		)
206		}
207	832x	collection <- makeAssertCollection()
208	832x	mapply(assert_valid_var, df[vars], labels, MoreArgs = list(..., add = collection), SIMPLIFY = FALSE)
209	832x	reportAssertions(collection)
210		}
211
212		# assert_valid_type ----
213
214		#' Check variable is of correct type
215		#' @param x Object to check the type.
216		#' @param types (`character`) possible types to check.
217		#' @param label (`string`) label.
218		assert_valid_type <- function(x, types, label = deparse(substitute(x))) {
219	1210x	if (!any(vapply(types, is, object = x, FUN.VALUE = TRUE))) {
220	2x	abort(
221	2x	paste0(
222	2x	quote_str(label),
223	2x	" is not of type ",
224	2x	toString(types)
225		)
226		)
227		}
228		}
229
230		# assert_valid_var_pair ----
231
232		#' Check variables are of same levels
233		#' @param df1 (`data.frame`) input.
234		#' @param df2 (`data.frame`) input.
235		#' @param var (`string`) variable to check.
236		#' @param lab1 (`string`) label hint for `df1`.
237		#' @param lab2 (`string`) label hint for `df2`.
238		assert_valid_var_pair <- function(df1, df2, var, lab1 = deparse(substitute(df1)), lab2 = deparse(substitute(df2))) {
239	146x	assert_data_frame(df1)
240	146x	assert_data_frame(df2)
241	146x	assert_string(var)
242	146x	lvl_x <- lvls(df1[[var]])
243	146x	lvl_y <- lvls(df2[[var]])
244	146x	if (!identical(lvl_x, lvl_y)) {
245	3x	abort(
246	3x	paste0(
247	3x	quote_str(lab1), " and ",
248	3x	quote_str(lab2), " should contain the same levels in variable ",
249	3x	quote_str(var), "!"
250		)
251		)
252		}
253		}

1		# as we use NSE
2		globalVariables(c(".", ":="))
3
4		#' Retrieve labels for certain variables
5		#'
6		#' @param df (`data.frame`) containing columns with label attribute.
7		#' @param vars (`character`) variable names in `df`.
8		#'
9		#' @details
10		#' The labels will be returned if the column has `label` attribute, otherwise the column name will be returned.
11		#' Any values between brackets {} will be replaced with `dunlin::render_safe`.
12		#' @export
13		var_labels_for <- function(df, vars) {
14	296x	assert_names(colnames(df), must.include = vars, what = "colnames")
15	296x	render_safe(unname(formatters::var_labels(df, fill = TRUE)[vars]))
16		}
17
18		#' Prune table up to an `ElementaryTable`
19		#'
20		#' Avoid returning `NULL` when the `table` is empty.
21		#'
22		#' @param tlg (`TableTree`) object.
23		#'
24		#' @return pruned `TableTree`.
25		#'
26		smart_prune <- function(tlg) {
27	82x	res <- prune_table(tlg)
28
29	82x	if (is.null(res)) {
30	19x	res <- build_table(rtables::basic_table(), df = data.frame())
31	19x	col_info(res) <- col_info(tlg)
32		}
33
34	82x	res
35		}
36
37		#' Standard post processing
38		#'
39		#' @param tlg (`TableTree`) object.
40		#' @param ind (`integer`) the indentation of the table.
41		#' @param ... not used at the moment.
42		#'
43		#' @note Standard post processing includes:
44		#' * `NULL` report creation if necessary
45		#' * indentation
46		#'
47		#' @return a post-processed `tlg`.
48		#'
49		#' @keywords internal
50		#'
51		std_postprocess <- function(tlg, ind = 2L, ...) {
52	167x	assert_int(ind, lower = 0L)
53
54	167x	res <- report_null(tlg)
55	167x	table_inset(res) <- ind
56
57	167x	res
58		}
59
60		# Special formats ----
61
62		#' Decimal formatting
63		#'
64		#' @param digits (`integer`) number of digits.
65		#' @param format (`string`) describing how the numbers should be formatted following the `sprintf` syntax.
66		#' @param ne (`flag`) indicator whether to use "NE" to replace the actual value.
67		#'
68		#' @return `function` formatting numbers with the defined format.
69		#'
70		#' @export
71		#'
72		#' @examples
73		#' fun <- h_format_dec(c(1, 1), "%s - %s")
74		#' fun(c(123, 567.89))
75		#'
76		h_format_dec <- function(digits, format, ne = FALSE) {
77	11625x	assert_integerish(digits, lower = 0)
78	11625x	assert_string(format)
79	11625x	if (any(is.na(digits))) {
80	889x	function(x, ...) {
81		""
82		}
83		} else {
84	10736x	if (ne) {
85	5364x	ret <- function(x, ...) {
86	5364x	do_call(sprintf, c(list(fmt = format), rep("NE", length(digits))))
87		}
88	5364x	return(ret)
89		}
90	5372x	digit_string <- paste0("%", ifelse(is.na(digits), "", paste0(".", digits)), "f")
91	5372x	new_format <- do_call(sprintf, c(list(fmt = format), digit_string))
92	5372x	formatters::sprintf_format(new_format)
93		}
94		}
95
96		#' Fuse list elements
97		#'
98		#' @param x (`list`) to fuse.
99		#' @param y (`list`) to fuse. Elements with names already existing in `x` are discarded.
100		#'
101		#' @keywords internal
102		#'
103		fuse_sequentially <- function(x, y) {
104	6x	if (missing(y)) {
105	1x	return(x)
106		}
107
108	5x	names_x <- names(x)
109	5x	sel_names_y <- setdiff(names(y), names_x)
110
111	5x	c(x, y[sel_names_y])
112		}
113
114		#' List of `grob` object
115		#' @param ... (`grob`) objects
116		#' @export
117		grob_list <- function(...) {
118	1x	ret <- list(...)
119	1x	assert_list(ret, types = c("grob"))
120	1x	structure(
121	1x	ret,
122	1x	class = c("grob_list", "list")
123		)
124		}
125
126		#' List of `gg` object
127		#' @param ... (`ggplot`) objects
128		#' @export
129		gg_list <- function(...) {
130	7x	ret <- list(...)
131	7x	assert_list(ret, types = c("ggplot"))
132	7x	structure(
133	7x	ret,
134	7x	class = c("gg_list", "list")
135		)
136		}
137
138		#' @export
139		droplevels.character <- function(x, ...) {
140	1x	x
141		}
142
143		#' Obtain levels from vector
144		#' @param x (`character`) or (`factor`) object to obtain levels.
145		#' @details
146		#' For factors, the levels will be returned. For characters, the sorted unique values will be returned.
147		#' @export
148		lvls <- function(x) {
149	328x	UseMethod("lvls")
150		}
151		#' @export
152		lvls.default <- function(x) {
153	1x	NULL
154		}
155		#' @export
156		lvls.character <- function(x) {
157	8x	sort(unique(x))
158		}
159		#' @export
160		lvls.factor <- function(x) {
161	319x	levels(x)
162		}
163
164		#' @keywords internal
165		quote_str <- function(x) {
166	13x	assert_string(x)
167	12x	paste0("`", x, "`")
168		}
169
170		#' @keywords internal
171		modify_default_args <- function(fun, ...) {
172	1x	ret <- fun
173	1x	formals(ret) <- utils::modifyList(formals(fun), list(...), keep.null = TRUE)
174	1x	return(ret)
175		}
176
177		#' Execute function with given arguments
178		#' @details If the function has `...`, this function will not pass other arguments to `...`.
179		#' Only named arguments are passed.
180		#' @keywords internal
181		execute_with_args <- function(fun, ...) {
182	78x	args <- list(...)
183	78x	do_call(fun, args[intersect(names(args), formalArgs(fun))])
184		}
185
186		#' Execute a function call
187		#' @keywords internal
188		do_call <- function(what, args) {
189	11320x	arg_names <- names(args)
190	11320x	if (is.null(arg_names)) {
191	105x	arg_names <- sprintf("var_%s", seq_along(args))
192	11215x	} else if (any(arg_names == "")) {
193	10838x	arg_names_random <- sprintf("var_%s", seq_along(args))
194	10838x	arg_names[arg_names == ""] <- arg_names_random[arg_names == ""]
195		}
196	11320x	args_env <- as.environment(setNames(args, arg_names))
197	11320x	parent.env(args_env) <- parent.frame()
198	11320x	new_args <- lapply(arg_names, as.symbol)
199	11320x	names(new_args) <- names(args)
200	11320x	do.call(what, new_args, envir = args_env)
201		}
202
203		#' Modify character
204		#' @keywords internal
205		modify_character <- function(x, y) {
206	16x	assert_character(x, names = "unique", null.ok = TRUE)
207	16x	assert_character(y, names = "unique", null.ok = TRUE)
208	16x	c(y, x)[unique(c(names(y), names(x)))]
209		}
210
211		#' Helper function to convert to months if needed
212		#' @param x (`numeric`) time.
213		#' @param unit (`character`) or (`factor`) time unit.
214		#'
215		#' @return A `numeric` vector with the time in months.
216		#'
217		#' @export
218		convert_to_month <- function(x, unit) {
219	16x	assert_multi_class(unit, c("character", "factor"))
220	16x	assert_numeric(x, len = length(unit))
221
222	16x	unit <- toupper(unit)
223	16x	diff <- setdiff(unique(unit), c("DAYS", "MONTHS", "YEARS"))
224	16x	if (length(diff) > 0) {
225	2x	rlang::warn(
226	2x	paste0(
227	2x	"Time unit ", toString(diff), " not covered. No unit conversion applied."
228		)
229		)
230		}
231
232	16x	case_when(
233	16x	unit == "DAYS" ~ x / 30.4375,
234	16x	unit == "MONTHS" ~ x,
235	16x	unit == "YEARS" ~ x * 12,
236	16x	TRUE ~ x
237		)
238		}

1		# dtht01 ----
2
3		#' @describeIn dtht01 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param time_since_last_dose (`flag`) should the time to event information be displayed.
7		#' @param other_category (`flag`) should the breakdown of the `OTHER` category be displayed.
8		#'
9		#' @details
10		#' * Numbers represent absolute numbers of subjects and fraction of `N`, or absolute numbers when specified.
11		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
12		#' * Does not include a total column by default.
13		#'
14		#' @note
15		#' * `adam_db` object must contain an `adsl` table with the columns `"DTHFL"`, `"DTHCAT"` as well as `LDDTHGR1` if
16		#' `time_since_last_dose` is `TRUE`.
17		#'
18		#' @export
19		dtht01_main <- function(adam_db,
20		arm_var = "ACTARM",
21		lbl_overall = NULL,
22		other_category = FALSE,
23		time_since_last_dose = FALSE,
24		...) {
25	2x	assert_all_tablenames(adam_db, "adsl")
26	2x	assert_string(arm_var)
27	2x	assert_string(lbl_overall, null.ok = TRUE)
28	2x	assert_flag(other_category)
29	2x	assert_flag(time_since_last_dose, null.ok = TRUE)
30	2x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list("character", "factor"))
31	2x	assert_valid_variable(
32	2x	adam_db$adsl,
33	2x	"DTHFL",
34	2x	types = list("character", "factor"), na_ok = TRUE, min_chars = 0L
35		)
36
37	2x	lbl_overall <- render_safe(lbl_overall)
38	2x	other_var <- if (other_category) "DTHCAUS"
39	2x	dose_death_var <- if (time_since_last_dose) "LDDTHGR1"
40
41	2x	assert_valid_variable(
42	2x	adam_db$adsl,
43	2x	c("DTHCAT", other_var, dose_death_var),
44	2x	types = list("character", "factor"), na_ok = TRUE, min_chars = 1L
45		)
46
47	2x	if (other_category) {
48	1x	death_cause <- lvls(adam_db$adsl$DTHCAT)
49	1x	if (length(death_cause) == 0L) {
50	!	stop("other_category specified but could not find any level in `DTHCAT`!")
51		}
52	1x	other_level <- death_cause[length(death_cause)]
53	1x	if (toupper(other_level) != "OTHER") {
54	!	warning(
55	!	"You included detailed information for Other, however the last level of ",
56	!	" `adam_db$adsl$DTHCAT` looks like not `Other`.",
57	!	call. = FALSE
58		)
59		}
60		}
61
62	2x	lyt <- dtht01_lyt(
63	2x	arm_var = arm_var,
64	2x	lbl_overall = lbl_overall,
65	2x	death_flag = "DTHFL",
66	2x	death_var = "DTHCAT",
67	2x	other_level = other_level,
68	2x	other_var = other_var,
69	2x	dose_death_var = dose_death_var
70		)
71
72	2x	adsl <- adam_db$adsl %>%
73	2x	mutate(TOTAL = "Primary Cause of Death")
74
75	2x	build_table(lyt, adsl)
76		}
77
78		#' `dtht01` Layout
79		#'
80		#' @inheritParams dtht01_main
81		#' @param death_flag (`string`) variable name of death flag.
82		#' @param detah_var (`string`) variable name of death category.
83		#' @param other_level (`string`) `"Other"` level in death category.
84		#' @param other_var (`string`) variable name of death cause under `"Other"`.
85		#' @param dose_death_var (`string`) variable name of the days from last dose.
86		#'
87		#' @keywords internal
88		#'
89		dtht01_lyt <- function(arm_var,
90		lbl_overall,
91		death_flag,
92		death_var,
93		other_level,
94		other_var,
95		dose_death_var) {
96	5x	if (is.null(dose_death_var) && is.null(other_var)) {
97	3x	lyt_block_fun <- analyze
98		} else {
99	2x	lyt_block_fun <- summarize_row
100		}
101	5x	lyt <- basic_table(show_colcounts = TRUE) %>%
102	5x	split_cols_by(arm_var) %>%
103	5x	ifneeded_add_overall_col(lbl_overall) %>%
104	5x	count_values(
105	5x	death_flag,
106	5x	values = "Y",
107	5x	.labels = c(count_fraction = "Total number of deaths"),
108	5x	.formats = c(count_fraction = format_count_fraction_fixed_dp)
109		) %>%
110	5x	split_rows_by("TOTAL", child_labels = "visible", label_pos = "hidden", split_fun = drop_split_levels) %>%
111	5x	lyt_block_fun(
112	5x	death_var,
113	5x	make_afun(
114	5x	s_summary_na,
115	5x	.stats = c("n", "count_fraction"), .ungroup_stats = "count_fraction",
116	5x	.formats = list(n = "xx", count_fraction = format_count_fraction_fixed_dp)
117		),
118	5x	indent_mod = 0L
119		)
120	5x	if (!is.null(other_var)) {
121	2x	lyt <- lyt %>%
122	2x	split_rows_by(death_var, split_fun = keep_split_levels(other_level), child_labels = "hidden") %>%
123	2x	summarize_vars(other_var, .stats = "count_fraction", denom = "N_row")
124		}
125	5x	if (!is.null(dose_death_var)) {
126	2x	lyt <- lyt %>%
127	2x	summarize_vars_allow_na(
128	2x	vars = dose_death_var,
129	2x	var_labels = "Days from last drug administration",
130	2x	.formats = list(count_fraction = format_count_fraction_fixed_dp),
131	2x	show_labels = "visible",
132	2x	nested = FALSE,
133	2x	inclNAs = FALSE
134		) %>%
135	2x	split_rows_by(
136	2x	dose_death_var,
137	2x	split_fun = drop_split_levels,
138	2x	split_label = "Primary cause by days from last study drug administration",
139	2x	label_pos = "visible",
140	2x	nested = FALSE
141		) %>%
142	2x	summarize_vars_allow_na(
143	2x	death_var,
144	2x	.formats = list(count_fraction = format_count_fraction_fixed_dp)
145		)
146		}
147
148	5x	lyt
149		}
150
151		#' @describeIn dtht01 Preprocessing
152		#'
153		#' @inheritParams gen_args
154		#'
155		#' @export
156		#'
157		dtht01_pre <- function(adam_db, ...) {
158	2x	death_format <- rule(
159	2x	"Adverse Event" = "ADVERSE EVENT",
160	2x	"Progressive Disease" = "PROGRESSIVE DISEASE",
161	2x	"Other" = "OTHER"
162		)
163
164	2x	adam_db$adsl <- adam_db$adsl %>%
165	2x	mutate(
166	2x	DTHCAT = reformat(.data$DTHCAT, death_format)
167		)
168
169	2x	adam_db
170		}
171
172		#' @describeIn dtht01 Postprocessing
173		#'
174		#' @inheritParams gen_args
175		#'
176		#' @export
177		#'
178		dtht01_post <- function(tlg, prune_0 = TRUE, ...) {
179	2x	if (prune_0) {
180	2x	tlg <- smart_prune(tlg)
181		}
182	2x	std_postprocess(tlg)
183		}
184
185		#' `DTHT01` Table 1 (Default) Death Table.
186		#'
187		#' A description of the causes of death optionally with the breakdown of the
188		#' `OTHER` category and/or post-study reporting of death.
189		#'
190		#' @include chevron_tlg-S4class.R
191		#' @export
192		#'
193		#' @examples
194		#' run(dtht01, syn_data)
195		#'
196		#' run(dtht01, syn_data, other_category = TRUE, time_since_last_dose = TRUE)
197		dtht01 <- chevron_t(
198		main = dtht01_main,
199		preprocess = dtht01_pre,
200		postprocess = dtht01_post
201		)

1		# aet02 ----
2
3		#' @describeIn aet02 Default labels
4		#' @export
5		#'
6		aet02_label <- c(
7		unique = "Total number of {patient_label} with at least one adverse event",
8		nonunique = "Total number of events"
9		)
10
11		#' @describeIn aet02 Main TLG function
12		#'
13		#' @inheritParams gen_args
14		#' @param summary_labels (`list`) of summarize labels. See details.
15		#'
16		#' @details
17		#' * Numbers represent absolute numbers of subject and fraction of `N`, or absolute number of event when specified.
18		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
19		#' * Split columns by arm.
20		#' * Does not include a total column by default.
21		#' * Sort Dictionary-Derived Code (`AEDECOD`) by highest overall frequencies.
22		#' * Missing values in `AEBODSYS`, and `AEDECOD` are labeled by `No Coding Available`.
23		#' `summary_labels` is used to control the summary for each level. If "all" is used, then each split will have that
24		#' summary statistic with the labels. One special case is "TOTAL", this is for the overall population.
25		#'
26		#' @note
27		#' * `adam_db` object must contain an `adae` table with the columns `"AEBODSYS"` and `"AEDECOD"`.
28		#'
29		#' @export
30		#'
31		aet02_main <- function(adam_db,
32		arm_var = "ACTARM",
33		row_split_var = "AEBODSYS",
34		lbl_overall = NULL,
35		summary_labels = list(
36		all = aet02_label,
37		TOTAL = c(nonunique = "Overall total number of events")
38		),
39		...) {
40	1x	assert_all_tablenames(adam_db, "adsl", "adae")
41	1x	assert_string(arm_var)
42	1x	assert_character(row_split_var, null.ok = TRUE)
43	1x	assert_string(lbl_overall, null.ok = TRUE)
44	1x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
45	1x	assert_valid_variable(adam_db$adae, c(arm_var, row_split_var, "AEDECOD"), types = list(c("character", "factor")))
46	1x	assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
47	1x	assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)
48	1x	assert_list(summary_labels, null.ok = TRUE)
49	1x	assert_subset(names(summary_labels), c("all", "TOTAL", row_split_var))
50	1x	assert_subset(
51	1x	unique(unlist(lapply(summary_labels, names))),
52	1x	c("unique", "nonunique", "unique_count")
53		)
54	1x	if ("all" %in% names(summary_labels)) {
55	1x	summary_labels <- lapply(
56	1x	c(TOTAL = "TOTAL", setNames(row_split_var, row_split_var)),
57	1x	function(x) {
58	2x	modify_character(summary_labels$all, summary_labels[[x]])
59		}
60		)
61		}
62
63	1x	lbl_overall <- render_safe(lbl_overall)
64	1x	lbl_row_split <- var_labels_for(adam_db$adae, row_split_var)
65	1x	lbl_aedecod <- var_labels_for(adam_db$adae, "AEDECOD")
66
67	1x	lyt <- occurrence_lyt(
68	1x	arm_var = arm_var,
69	1x	lbl_overall = lbl_overall,
70	1x	row_split_var = row_split_var,
71	1x	lbl_row_split = lbl_row_split,
72	1x	medname_var = "AEDECOD",
73	1x	lbl_medname_var = lbl_aedecod,
74	1x	summary_labels = summary_labels,
75	1x	count_by = NULL
76		)
77
78	1x	tbl <- build_table(lyt, adam_db$adae, alt_counts_df = adam_db$adsl)
79
80	1x	tbl
81		}
82
83		#' @describeIn aet02 Preprocessing
84		#'
85		#' @inheritParams gen_args
86		#'
87		#' @export
88		#'
89		aet02_pre <- function(adam_db, row_split_var = "AEBODSYS", ...) {
90	1x	adam_db$adae <- adam_db$adae %>%
91	1x	filter(.data$ANL01FL == "Y") %>%
92	1x	mutate(AEDECOD = reformat(.data$AEDECOD, nocoding)) %>%
93	1x	mutate(across(all_of(row_split_var), ~ reformat(.x, nocoding)))
94
95	1x	adam_db
96		}
97
98		#' @describeIn aet02 Postprocessing
99		#'
100		#' @inheritParams gen_args
101		#'
102		#' @export
103		#'
104		aet02_post <- function(tlg, row_split_var = "AEBODSYS", prune_0 = TRUE, ...) {
105	1x	tlg <- tlg %>%
106	1x	tlg_sort_by_vars(row_split_var, cont_n_allcols) %>%
107	1x	valid_sort_at_path(
108	1x	path = c(get_sort_path(c(row_split_var, "AEDECOD"))),
109	1x	scorefun = score_occurrences
110		)
111	1x	if (prune_0) {
112	1x	tlg <- smart_prune(tlg)
113		}
114	1x	std_postprocess(tlg)
115		}
116
117		#' `AET02` Table 1 (Default) Adverse Events by System Organ Class and Preferred Term Table 1
118		#'
119		#' The `AET02` table provides an overview of the number of subjects experiencing adverse events and the number of advert
120		#' events categorized by Body System and Dictionary-Derived Term.
121		#'
122		#' @include chevron_tlg-S4class.R
123		#' @export
124		#'
125		#' @examples
126		#' run(aet02, syn_data)
127		aet02 <- chevron_t(
128		main = aet02_main,
129		preprocess = aet02_pre,
130		postprocess = aet02_post
131		)

1		# aet04 ----
2
3		#' @describeIn aet04 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param grade_groups (`list`) putting in correspondence toxicity grades and labels.
7		#'
8		#' @details
9		#' * Numbers represent absolute numbers of patients and fraction of `N`, or absolute number of event when specified.
10		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
11		#' * Events with missing grading values are excluded.
12		#' * Split columns by arm, typically `ACTARM`.
13		#' * Does not include a total column by default.
14		#' * Sort Body System or Organ Class and Dictionary-Derived Term by highest overall frequencies. Analysis Toxicity
15		#' Grade is sorted by severity.
16		#'
17		#' @note
18		#' * `adam_db` object must contain an `adae` table with the columns `"AEBODSYS"`, `"AEDECOD"` and `"ATOXGR"`.
19		#'
20		#' @export
21		#'
22		aet04_main <- function(adam_db,
23		arm_var = "ACTARM",
24		lbl_overall = NULL,
25		grade_groups = NULL,
26		...) {
27	1x	assert_all_tablenames(adam_db, "adsl", "adae")
28	1x	assert_string(arm_var)
29	1x	assert_string(lbl_overall, null.ok = TRUE)
30	1x	assert_list(grade_groups, types = "character", null.ok = TRUE)
31	1x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
32	1x	assert_valid_variable(adam_db$adae, c(arm_var, "AEBODSYS", "AEDECOD"), types = list(c("character", "factor")))
33	1x	assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
34	1x	assert_valid_variable(adam_db$adae, "ATOXGR", na_ok = TRUE, types = list("factor"))
35	1x	assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)
36
37	1x	lbl_overall <- render_safe(lbl_overall)
38	1x	lbl_aebodsys <- var_labels_for(adam_db$adae, "AEBODSYS")
39	1x	lbl_aedecod <- var_labels_for(adam_db$adae, "AEDECOD")
40
41	1x	if (is.null(grade_groups)) {
42	1x	grade_groups <- list(
43	1x	"Grade 1-2" = c("1", "2"),
44	1x	"Grade 3-4" = c("3", "4"),
45	1x	"Grade 5" = c("5")
46		)
47		}
48
49	1x	lyt <- aet04_lyt(
50	1x	arm_var = arm_var,
51	1x	total_var = "TOTAL_VAR",
52	1x	lbl_overall = lbl_overall,
53	1x	lbl_aebodsys = lbl_aebodsys,
54	1x	lbl_aedecod = lbl_aedecod,
55	1x	grade_groups = grade_groups
56		)
57
58	1x	adam_db$adae$TOTAL_VAR <- "- Any adverse events - "
59
60	1x	tbl <- build_table(lyt, df = adam_db$adae, alt_counts_df = adam_db$adsl)
61
62	1x	tbl
63		}
64
65		#' `aet04` Layout
66		#'
67		#' @inheritParams aet04_main
68		#'
69		#' @param total_var (`string`) variable to create summary of all variables.
70		#' @param lbl_aebodsys (`string`) text label for `AEBODSYS`.
71		#' @param lbl_aedecod (`string`) text label for `AEDECOD`.
72		#' @param grade_groups (`list`) putting in correspondence toxicity grades and labels.
73		#'
74		#' @keywords internal
75		#'
76		aet04_lyt <- function(arm_var,
77		total_var,
78		lbl_overall,
79		lbl_aebodsys,
80		lbl_aedecod,
81		grade_groups) {
82	6x	basic_table(show_colcounts = TRUE) %>%
83	6x	split_cols_by(var = arm_var) %>%
84	6x	ifneeded_add_overall_col(lbl_overall) %>%
85	6x	split_rows_by(
86	6x	var = total_var,
87	6x	label_pos = "hidden",
88	6x	child_labels = "visible",
89	6x	indent_mod = -1L
90		) %>%
91	6x	summarize_num_patients(
92	6x	var = "USUBJID",
93	6x	.stats = "unique",
94	6x	.labels = "- Any Grade -",
95	6x	.indent_mods = 7L
96		) %>%
97	6x	count_occurrences_by_grade(
98	6x	var = "ATOXGR",
99	6x	grade_groups = grade_groups,
100	6x	.indent_mods = 6L
101		) %>%
102	6x	split_rows_by(
103	6x	"AEBODSYS",
104	6x	child_labels = "visible",
105	6x	nested = FALSE,
106	6x	split_fun = drop_split_levels,
107	6x	label_pos = "topleft",
108	6x	split_label = lbl_aebodsys
109		) %>%
110	6x	split_rows_by(
111	6x	"AEDECOD",
112	6x	child_labels = "visible",
113	6x	split_fun = add_overall_level("- Overall -", trim = TRUE),
114	6x	label_pos = "topleft",
115	6x	split_label = lbl_aedecod
116		) %>%
117	6x	summarize_num_patients(
118	6x	var = "USUBJID",
119	6x	.stats = "unique",
120	6x	.labels = "- Any Grade -",
121	6x	.indent_mods = 6L
122		) %>%
123	6x	count_occurrences_by_grade(
124	6x	var = "ATOXGR",
125	6x	grade_groups = grade_groups,
126	6x	.indent_mods = 5L
127		) %>%
128	6x	append_topleft(" Grade")
129		}
130
131		#' @describeIn aet04 Preprocessing
132		#'
133		#' @inheritParams gen_args
134		#'
135		#' @export
136		#'
137		aet04_pre <- function(adam_db, ...) {
138	1x	atoxgr_lvls <- c("1", "2", "3", "4", "5")
139	1x	adam_db$adae <- adam_db$adae %>%
140	1x	filter(.data$ANL01FL == "Y") %>%
141	1x	mutate(
142	1x	AEBODSYS = reformat(.data$AEBODSYS, nocoding),
143	1x	AEDECOD = reformat(.data$AEDECOD, nocoding),
144	1x	ATOXGR = factor(.data$ATOXGR, levels = atoxgr_lvls)
145		)
146	1x	adam_db
147		}
148
149		#' @describeIn aet04 Postprocessing
150		#'
151		#' @inheritParams gen_args
152		#'
153		#' @export
154		#'
155		aet04_post <- function(tlg, prune_0 = TRUE, ...) {
156	1x	tlg <- tlg %>%
157	1x	tlg_sort_by_vars(c("AEBODSYS", "AEDECOD"), score_all_sum, decreasing = TRUE)
158	1x	if (prune_0) tlg <- trim_rows(tlg)
159	1x	std_postprocess(tlg)
160		}
161
162		#' `AET04` Table 1 (Default) Adverse Events by Highest `NCI` `CTACAE` `AE` Grade Table 1.
163		#'
164		#' The `AET04` table provides an
165		#' overview of adverse event with the highest `NCI` `CTCAE` grade per individual.
166		#'
167		#' @include chevron_tlg-S4class.R
168		#' @export
169		#'
170		#' @examples
171		#' grade_groups <- list(
172		#' "Grade 1-2" = c("1", "2"),
173		#' "Grade 3-4" = c("3", "4"),
174		#' "Grade 5" = c("5")
175		#' )
176		#' proc_data <- dunlin::log_filter(syn_data, AEBODSYS == "cl A.1", "adae")
177		#' run(aet04, proc_data, grade_groups = grade_groups)
178		aet04 <- chevron_t(
179		main = aet04_main,
180		preprocess = aet04_pre,
181		postprocess = aet04_post
182		)

1		# lbt04 ----
2
3		#' @describeIn lbt04 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param analysis_abn_var (`string`) column describing anomaly magnitude
7		#' @param baseline_abn_var (`string`) column describing anomaly at baseline.
8		#'
9		#' @details
10		#' * Only count LOW or HIGH values.
11		#' * Lab test results with missing `analysis_abn_var` values are excluded.
12		#' * Split columns by arm, typically `ACTARM`.
13		#' * Does not include a total column by default.
14		#'
15		#' @note
16		#' * `adam_db` object must contain an `adlb` table with columns `"PARCAT1"`, `"PARCAT2"`, `"PARAM"`, `"ANRIND"`,
17		#' and column specified by `arm_var`.
18		#'
19		#' @export
20		#'
21		lbt04_main <- function(adam_db,
22		arm_var = "ACTARM",
23		lbl_overall = NULL,
24		analysis_abn_var = "ANRIND",
25		baseline_abn_var = "BNRIND",
26		row_split_var = "PARCAT1",
27		page_var = tail(row_split_var, 1L),
28		...) {
29	2x	assert_all_tablenames(adam_db, c("adsl", "adlb"))
30	2x	assert_string(arm_var)
31	2x	assert_string(lbl_overall, null.ok = TRUE)
32	2x	assert_string(analysis_abn_var)
33	2x	assert_string(baseline_abn_var)
34	2x	assert_string(row_split_var)
35	2x	assert_valid_variable(
36	2x	adam_db$adlb, c("PARAMCD", "PARAM", row_split_var),
37	2x	types = list("characater", "factor")
38		)
39	2x	assert_subset(page_var, row_split_var)
40	2x	assert_valid_variable(adam_db$adlb, c("USUBJID"), types = list(c("character", "factor")), empty_ok = TRUE)
41	2x	assert_valid_variable(adam_db$adsl, c("USUBJID"), types = list(c("character", "factor")))
42	2x	assert_valid_variable(
43	2x	adam_db$adlb,
44	2x	baseline_abn_var,
45	2x	types = list(c("character", "factor")),
46	2x	na_ok = TRUE, empty_ok = TRUE, min_chars = 0L
47		)
48	2x	assert_valid_var_pair(adam_db$adsl, adam_db$adlb, arm_var)
49
50	2x	lbl_overall <- render_safe(lbl_overall)
51	2x	lbl_param <- var_labels_for(adam_db$adlb, "PARAM")
52	2x	lbl_abn_var <- var_labels_for(adam_db$adlb, analysis_abn_var)
53	2x	row_split_lbl <- var_labels_for(adam_db$adlb, row_split_var)
54
55	2x	lyt <- lbt04_lyt(
56	2x	arm_var = arm_var,
57	2x	lbl_overall = lbl_overall,
58	2x	lbl_param = lbl_param,
59	2x	lbl_abn_var = lbl_abn_var,
60	2x	var_parcat = "PARCAT1",
61	2x	var_param = "PARAM",
62	2x	row_split_var = row_split_var,
63	2x	row_split_lbl = row_split_lbl,
64	2x	analysis_abn_var = analysis_abn_var,
65	2x	variables = list(id = "USUBJID", baseline = baseline_abn_var),
66	2x	page_var = page_var
67		)
68
69	2x	tbl <- build_table(lyt, adam_db$adlb, alt_counts_df = adam_db$adsl)
70
71	2x	tbl
72		}
73
74		#' `lbt04` Layout
75		#'
76		#' @inheritParams gen_args
77		#'
78		#' @param lbl_param (`string`) label of the `PARAM` variable.
79		#' @param lbl_abn_var (`string`) label of the `analysis_abn_var` variable.
80		#' @param variables (`list`) see [tern::count_abnormal]
81		#'
82		#' @keywords internal
83		#'
84		lbt04_lyt <- function(arm_var,
85		lbl_overall,
86		lbl_param,
87		lbl_abn_var,
88		var_parcat,
89		var_param,
90		row_split_var,
91		row_split_lbl,
92		analysis_abn_var,
93		variables,
94		page_var) {
95	10x	page_by <- get_page_by(page_var, row_split_var)
96	10x	label_pos <- ifelse(page_by, "hidden", "topleft")
97
98	10x	basic_table(show_colcounts = TRUE) %>%
99	10x	split_cols_by(arm_var) %>%
100	10x	ifneeded_add_overall_col(lbl_overall) %>%
101	10x	split_rows_by_recurive(
102	10x	row_split_var,
103	10x	split_label = row_split_lbl,
104	10x	label_pos = label_pos,
105	10x	page_by = page_by
106		) %>%
107	10x	split_rows_by(
108	10x	"PARAMCD",
109	10x	labels_var = "PARAM",
110	10x	split_fun = drop_split_levels,
111	10x	label_pos = "topleft",
112	10x	split_label = lbl_param,
113	10x	indent_mod = 0L
114		) %>%
115	10x	count_abnormal(
116	10x	var = analysis_abn_var,
117	10x	abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH")),
118	10x	exclude_base_abn = TRUE,
119	10x	variables = variables,
120	10x	.formats = list(fraction = format_fraction_fixed_dp)
121		) %>%
122	10x	append_topleft(paste(" ", lbl_abn_var))
123		}
124
125		#' @describeIn lbt04 Preprocessing
126		#'
127		#' @inheritParams gen_args
128		#'
129		#' @export
130		#'
131		lbt04_pre <- function(adam_db, ...) {
132	1x	adam_db$adlb <- adam_db$adlb %>%
133	1x	filter(
134	1x	.data$ONTRTFL == "Y",
135	1x	.data$PARCAT2 == "SI",
136	1x	!is.na(.data$ANRIND)
137		) %>%
138	1x	mutate(
139	1x	PARAM = with_label(.data$PARAM, "Laboratory Test"),
140	1x	ANRIND = with_label(.data$ANRIND, "Direction of Abnormality")
141		) %>%
142	1x	mutate(
143	1x	ANRIND = reformat(
144	1x	.data$ANRIND,
145	1x	rule(
146	1x	"HIGH HIGH" = "HIGH HIGH",
147	1x	"HIGH" = "HIGH",
148	1x	"LOW" = "LOW",
149	1x	"LOW LOW" = "LOW LOW",
150	1x	"NORMAL" = "NORMAL"
151		),
152	1x	.to_NA = NULL
153		)
154		)
155
156	1x	adam_db
157		}
158
159		#' @describeIn lbt04 Postprocessing
160		#'
161		#' @inheritParams gen_args
162		#'
163		#' @export
164		#'
165		lbt04_post <- function(tlg, ...) {
166	2x	std_postprocess(tlg)
167		}
168
169		#' `LBT04` Laboratory Abnormalities Not Present at Baseline Table.
170		#'
171		#' The `LBT04` table provides an
172		#' overview of laboratory abnormalities not present at baseline.
173		#'
174		#' @include chevron_tlg-S4class.R
175		#' @export
176		#'
177		#' @examples
178		#' run(lbt04, syn_data)
179		lbt04 <- chevron_t(
180		main = lbt04_main,
181		preprocess = lbt04_pre,
182		postprocess = lbt04_post
183		)

1		# egt02_1 ----
2
3		#' @describeIn egt02_1 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param exclude_base_abn (`flag`) whether baseline abnormality should be excluded.
7		#'
8		#' @details
9		#' * Only count LOW or HIGH values.
10		#' * Results of "LOW LOW" are treated as the same as "LOW", and "HIGH HIGH" the same as "HIGH".
11		#' * Does not include a total column by default.
12		#' * Does not remove zero-count rows unless overridden with `prune_0 = TRUE`.
13		#'
14		#' @note
15		#' * `adam_db` object must contain an `adeg` table with the `"PARAM"`, `"ANRIND"` and `"BNRIND"` columns.
16		#'
17		#' @export
18		#'
19		egt02_1_main <- function(adam_db,
20		arm_var = "ACTARM",
21		lbl_overall = NULL,
22		exclude_base_abn = FALSE,
23		...) {
24	2x	assert_all_tablenames(adam_db, c("adsl", "adeg"))
25	2x	assert_string(arm_var)
26	2x	assert_string(lbl_overall, null.ok = TRUE)
27	2x	assert_flag(exclude_base_abn)
28	2x	assert_valid_variable(adam_db$adeg, c("PARAM"), types = list(c("character", "factor")), na_ok = FALSE)
29	2x	assert_valid_variable(adam_db$adeg, c("ANRIND", "BNRIND"), types = list(c("character", "factor")), na_ok = TRUE)
30	2x	assert_valid_var_pair(adam_db$adsl, adam_db$adeg, arm_var)
31	2x	assert_valid_variable(adam_db$adeg, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
32	2x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
33
34	2x	lbl_overall <- render_safe(lbl_overall)
35
36	2x	lyt <- egt02_lyt(
37	2x	arm_var = arm_var,
38	2x	lbl_overall = lbl_overall,
39	2x	lbl_vs_assessment = "Assessment",
40	2x	lbl_vs_abnormality = "Abnormality",
41	2x	exclude_base_abn = exclude_base_abn
42		)
43
44	2x	tbl <- build_table(lyt, adam_db$adeg, alt_counts_df = adam_db$adsl)
45
46	2x	tbl
47		}
48
49		#' `egt02` Layout
50		#'
51		#' @inheritParams gen_args
52		#' @param lbl_vs_assessment (`string`) the label of the assessment variable.
53		#' @param lbl_vs_abnormality (`string`) the label of the abnormality variable.
54		#' @param exclude_base_abn (`flag`) whether to exclude subjects with baseline abnormality from numerator and
55		#' denominator.
56		#'
57		#' @keywords internal
58		#'
59		egt02_lyt <- function(arm_var = "ACTARM",
60		lbl_overall,
61		lbl_vs_assessment = "Assessment",
62		lbl_vs_abnormality = "Abnormality",
63		exclude_base_abn) {
64	4x	basic_table(show_colcounts = TRUE) %>%
65	4x	split_cols_by(var = arm_var) %>%
66	4x	ifneeded_add_overall_col(lbl_overall) %>%
67	4x	split_rows_by("PARAM", split_fun = drop_split_levels, label_pos = "topleft", split_label = lbl_vs_assessment) %>%
68	4x	count_abnormal(
69	4x	"ANRIND",
70	4x	abnormal = list(Low = "LOW", High = "HIGH"),
71	4x	variables = list(id = "USUBJID", baseline = "BNRIND"),
72	4x	exclude_base_abn = exclude_base_abn
73		) %>%
74	4x	append_topleft(paste0(" ", lbl_vs_abnormality))
75		}
76
77		#' @describeIn egt02_1 Preprocessing
78		#'
79		#' @inheritParams gen_args
80		#'
81		#' @export
82		#'
83		egt02_pre <- function(adam_db, ...) {
84	2x	assert_all_tablenames(adam_db, c("adsl", "adeg"))
85	2x	adam_db$adeg <- adam_db$adeg %>%
86	2x	mutate(ANRIND = factor(.data$ANRIND, levels = c("LOW", "NORMAL", "HIGH"))) %>%
87	2x	filter(!is.na(.data$ANRIND)) %>%
88	2x	filter(.data$ONTRTFL == "Y")
89
90	2x	adam_db
91		}
92
93		#' @describeIn egt02_1 Postprocessing
94		#'
95		#' @inheritParams gen_args
96		#'
97		#' @export
98		#'
99		egt02_post <- function(tlg, ...) {
100	2x	std_postprocess(tlg)
101		}
102
103		#' `EGT02` ECG Abnormalities Table.
104		#'
105		#' ECG Parameters outside Normal Limits Regardless of Abnormality at Baseline Table.
106		#'
107		#' @include chevron_tlg-S4class.R
108		#' @export
109		#'
110		#' @examples
111		#' run(egt02_1, syn_data)
112		egt02_1 <- chevron_t(
113		main = egt02_1_main,
114		preprocess = egt02_pre,
115		postprocess = egt02_post
116		)
117
118		# egt02_2 ----
119
120		#' @describeIn egt02_2 Main TLG function
121		#'
122		#' @inherit egt02_1_main
123		#'
124		#' @export
125		#'
126		egt02_2_main <- modify_default_args(egt02_1_main, exclude_base_abn = TRUE)
127
128		#' `EGT02_2` ECG Abnormalities Table.
129		#'
130		#' ECG Parameters outside Normal Limits Among Patients without Abnormality at Baseline Table.
131		#'
132		#' @include chevron_tlg-S4class.R
133		#' @export
134		#'
135		#' @examples
136		#' run(egt02_2, syn_data)
137		egt02_2 <- chevron_t(
138		main = egt02_2_main,
139		preprocess = egt02_pre,
140		postprocess = egt02_post
141		)

1		# lbt06 ----
2
3		#' @describeIn lbt06 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param arm_var (`string`) the arm variable used for arm splitting.
7		#'
8		#' @details
9		#' * Only count `"LOW"` or `"HIGH"` values for `ANRIND` and `BNRIND`.
10		#' * Lab test results with missing `ANRIND` values are excluded.
11		#' * Split columns by arm, typically `ACTARM`.
12		#' * Keep zero count rows by default.
13		#'
14		#' @note
15		#' * `adam_db` object must contain an `adlb` table with columns `"AVISIT"`, `"ANRIND"`, `"BNRIND"`,
16		#' `"ONTRTFL"`, and `"PARCAT2"`, and column specified by `arm_var`.
17		#'
18		#' @export
19		#'
20		lbt06_main <- function(adam_db,
21		arm_var = "ACTARM",
22		lbl_overall = NULL,
23		page_var = "PARAMCD",
24		...) {
25	2x	assert_all_tablenames(adam_db, c("adsl", "adlb"))
26	2x	assert_string(arm_var)
27	2x	assert_string(lbl_overall, null.ok = TRUE)
28	2x	assert_subset(page_var, "PARAMCD")
29	2x	assert_valid_variable(adam_db$adlb, c(arm_var, "PARAMCD", "PARAM", "AVISIT"), types = list("characater", "factor"))
30	2x	assert_valid_variable(adam_db$adlb, c("ANRIND", "BNRIND"), types = list(c("character", "factor")))
31	2x	assert_valid_variable(adam_db$adlb, c("USUBJID"), types = list(c("character", "factor")))
32	2x	assert_valid_variable(adam_db$adsl, c("USUBJID"), types = list(c("character", "factor")))
33	2x	assert_valid_var_pair(adam_db$adsl, adam_db$adlb, arm_var)
34
35	2x	lbl_overall <- render_safe(lbl_overall)
36	2x	lbl_param <- var_labels_for(adam_db$adlb, "PARAM")
37	2x	lbl_visit <- var_labels_for(adam_db$adlb, "AVISIT")
38	2x	lbl_anrind <- var_labels_for(adam_db$adlb, "ANRIND")
39	2x	lbl_bnrind <- var_labels_for(adam_db$adlb, "BNRIND")
40
41	2x	lyt <- lbt06_lyt(
42	2x	arm_var = arm_var,
43	2x	lbl_overall = lbl_overall,
44	2x	lbl_param = lbl_param,
45	2x	lbl_visit = lbl_visit,
46	2x	lbl_anrind = lbl_anrind,
47	2x	lbl_bnrind = lbl_bnrind,
48	2x	visitvar = "AVISIT",
49	2x	anrind_var = "ANRIND",
50	2x	bnrind_var = "BNRIND",
51	2x	page_var = page_var
52		)
53
54	2x	tbl <- build_table(lyt, adam_db$adlb, alt_counts_df = adam_db$adsl)
55
56	2x	tbl
57		}
58
59		#' `lbt06` Layout
60		#'
61		#' @inheritParams gen_args
62		#'
63		#' @param lbl_param (`string`) text label of the `PARAM` variable.
64		#' @param lbl_visit (`string`) text label of the `AVISIT` variable.
65		#' @param lbl_anrind (`string`) text label of the `ANRIND` variable.
66		#' @param lbl_bnrind (`string`) text label of the `BNRIND` variable.
67		#' @param param (`string`) the variable for parameter code.
68		#' @param anrind_var (`string`) the variable for analysis reference range indicator.
69		#' @param bnrind_var (`string`) the variable for baseline reference range indicator.
70		#'
71		#' @keywords internal
72		#'
73		lbt06_lyt <- function(arm_var,
74		lbl_overall,
75		lbl_param,
76		lbl_visit,
77		lbl_anrind,
78		lbl_bnrind,
79		visitvar,
80		anrind_var,
81		bnrind_var,
82		page_var) {
83	2x	page_by <- !is.null(page_var)
84	2x	label_pos <- ifelse(page_by, "hidden", "topleft")
85	2x	basic_table(show_colcounts = TRUE) %>%
86	2x	split_cols_by(arm_var) %>%
87	2x	ifneeded_add_overall_col(lbl_overall) %>%
88	2x	split_rows_by(
89	2x	var = "PARAMCD",
90	2x	labels_var = "PARAM",
91	2x	split_fun = drop_split_levels,
92	2x	label_pos = label_pos,
93	2x	split_label = lbl_param,
94	2x	page_by = page_by
95		) %>%
96	2x	split_rows_by(
97	2x	var = visitvar,
98	2x	split_fun = drop_split_levels,
99	2x	label_pos = "topleft",
100	2x	split_label = lbl_visit
101		) %>%
102	2x	count_abnormal_by_baseline(
103	2x	var = anrind_var,
104	2x	abnormal = c(Low = "LOW", High = "HIGH"),
105	2x	variables = list(id = "USUBJID", baseline = bnrind_var),
106	2x	.indent_mods = 4L
107		) %>%
108	2x	append_topleft(paste0(stringr::str_dup(" ", 2L * (2 - page_by)), lbl_anrind)) %>%
109	2x	append_topleft(paste0(stringr::str_dup(" ", 2L * (7 - page_by)), lbl_bnrind))
110		}
111
112		#' @describeIn lbt06 Preprocessing
113		#'
114		#' @inheritParams gen_args
115		#'
116		#' @export
117		#'
118		lbt06_pre <- function(adam_db, ...) {
119	3x	missing_rule <- rule("<Missing>" = c("", NA, "<Missing>"))
120
121	3x	adam_db$adlb <- adam_db$adlb %>%
122	3x	filter(
123	3x	.data$ONTRTFL == "Y",
124	3x	.data$PARCAT2 == "SI"
125		) %>%
126	3x	mutate(
127	3x	across(all_of(c("ANRIND", "BNRIND")), ~ reformat(.x, .env$missing_rule)),
128	3x	AVISIT = reorder(.data$AVISIT, .data$AVISITN),
129	3x	AVISIT = with_label(.data$AVISIT, "Visit"),
130	3x	ANRIND = with_label(.data$ANRIND, "Abnormality at Visit"),
131	3x	BNRIND = with_label(.data$BNRIND, "Baseline Status")
132		)
133
134	2x	adam_db
135		}
136
137		#' @describeIn lbt06 Postprocessing
138		#'
139		#' @inheritParams gen_args
140		#'
141		#' @export
142		#'
143		lbt06_post <- function(tlg, prune_0 = FALSE, ...) {
144	!	if (prune_0) {
145	!	tlg <- smart_prune(tlg)
146		}
147	!	std_postprocess(tlg)
148		}
149
150		#' `LBT06` Table 1 (Default) Laboratory Abnormalities by Visit and Baseline Status Table 1.
151		#'
152		#' The `LBT06` table produces the standard laboratory abnormalities by visit and
153		#' baseline status summary.
154		#'
155		#' @include chevron_tlg-S4class.R
156		#' @export
157		#'
158		#' @examples
159		#' run(lbt06, syn_data)
160		lbt06 <- chevron_t(
161		main = lbt06_main,
162		preprocess = lbt06_pre,
163		postprocess = lbt06_post
164		)

1		# aet01 ----
2
3		#' @describeIn aet01 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param anl_vars Named (`list`) of (`character`) variables the safety variables to be summarized.
7		#' @param anl_lbls (`character`) of analysis labels.
8		#'
9		#' @details
10		#' * Does not remove rows with zero counts by default.
11		#'
12		#' @note
13		#' * `adam_db` object must contain an `adsl` table with the `"DTHFL"` and `"DCSREAS"` columns.
14		#' * `adam_db` object must contain an `adae` table with the columns passed to `anl_vars`.
15		#'
16		#' @export
17		#'
18		aet01_main <- function(adam_db,
19		arm_var = "ACTARM",
20		lbl_overall = NULL,
21		anl_vars = list(
22		safety_var = c(
23		"FATAL", "SER", "SERWD", "SERDSM",
24		"RELSER", "WD", "DSM", "REL", "RELWD", "RELDSM", "SEV"
25		)
26		),
27		anl_lbls = "Total number of {patient_label} with at least one",
28		...) {
29	1x	assert_all_tablenames(adam_db, "adsl", "adae")
30	1x	assert_string(arm_var)
31	1x	assert_string(lbl_overall, null.ok = TRUE)
32	1x	assert_list(anl_vars, types = "character", names = "unique")
33	1x	assert_character(anl_lbls, min.chars = 1L)
34	1x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
35	1x	assert_valid_variable(adam_db$adsl, c("DTHFL", "DCSREAS"), types = list(c("character", "factor")), min_chars = 0L)
36	1x	assert_valid_variable(adam_db$adae, c(arm_var), types = list(c("character", "factor")))
37	1x	assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
38	1x	assert_valid_variable(adam_db$adae, unlist(anl_vars), types = list("logical"), na_ok = TRUE, empty_ok = TRUE)
39	1x	assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)
40
41	1x	lbl_overall <- render_safe(lbl_overall)
42	1x	anl_lbls <- render_safe(anl_lbls)
43	1x	if (length(anl_lbls) == 1) {
44	1x	anl_lbls <- rep(anl_lbls, length(anl_vars))
45		}
46	1x	lbl_vars <- lapply(
47	1x	anl_vars,
48	1x	var_labels_for,
49	1x	df = adam_db$adae
50		)
51
52	1x	lyts <- aet01_lyt(
53	1x	arm_var = arm_var,
54	1x	lbl_overall = lbl_overall,
55	1x	anl_vars = anl_vars,
56	1x	anl_lbls = anl_lbls,
57	1x	lbl_vars = lbl_vars
58		)
59
60	1x	rbind(
61	1x	build_table(lyts$ae1, adam_db$adae, alt_counts_df = adam_db$adsl),
62	1x	build_table(lyts$adsl, adam_db$adsl, alt_counts_df = adam_db$adsl),
63	1x	build_table(lyts$ae2, adam_db$adae, alt_counts_df = adam_db$adsl)
64		)
65		}
66
67		#' `aet01` Layout
68		#'
69		#' @inheritParams aet01_main
70		#' @param anl_vars Named (`list`) of analysis variables.
71		#' @param anl_lbls (`character`) of labels.
72		#' @param lbl_vars Named (`list`) of analysis labels.
73		#' @keywords internal
74		#'
75		aet01_lyt <- function(arm_var,
76		lbl_overall,
77		anl_vars,
78		anl_lbls,
79		lbl_vars) {
80	6x	lyt_base <- basic_table(show_colcounts = TRUE) %>%
81	6x	split_cols_by(var = arm_var) %>%
82	6x	ifneeded_add_overall_col(lbl_overall)
83	6x	lyt_ae1 <- lyt_base %>%
84	6x	analyze_num_patients(
85	6x	vars = "USUBJID",
86	6x	.stats = c("unique", "nonunique"),
87	6x	.labels = c(
88	6x	unique = render_safe("Total number of {patient_label} with at least one AE"),
89	6x	nonunique = "Total number of AEs"
90		),
91	6x	.formats = list(unique = format_count_fraction_fixed_dp, nonunique = "xx"),
92	6x	show_labels = "hidden"
93		)
94	6x	lyt_adsl <- lyt_base %>%
95	6x	count_patients_with_event(
96	6x	"USUBJID",
97	6x	filters = c("DTHFL" = "Y"),
98	6x	denom = "N_col",
99	6x	.labels = c(count_fraction = "Total number of deaths"),
100	6x	table_names = "TotDeath"
101		) %>%
102	6x	count_patients_with_event(
103	6x	"USUBJID",
104	6x	filters = c("DCSREAS" = "ADVERSE EVENT"),
105	6x	denom = "N_col",
106	6x	.labels = c(count_fraction = render_safe("Total number of {patient_label} withdrawn from study due to an AE")),
107	6x	table_names = "TotWithdrawal"
108		)
109
110	6x	lyt_ae2 <- lyt_base %>%
111	6x	count_patients_recursive(
112	6x	anl_vars = anl_vars,
113	6x	anl_lbls = anl_lbls,
114	6x	lbl_vars = lbl_vars
115		)
116	6x	return(list(ae1 = lyt_ae1, ae2 = lyt_ae2, adsl = lyt_adsl))
117		}
118
119		#' @describeIn aet01 Preprocessing
120		#'
121		#' @inheritParams aet01_main
122		#'
123		#' @export
124		#'
125		aet01_pre <- function(adam_db, ...) {
126	1x	adam_db$adae <- adam_db$adae %>%
127	1x	filter(.data$ANL01FL == "Y") %>%
128	1x	mutate(
129	1x	FATAL = with_label(.data$AESDTH == "Y", "AE with fatal outcome"),
130	1x	SER = with_label(.data$AESER == "Y", "Serious AE"),
131	1x	SEV = with_label(.data$ASEV == "SEVERE", "Severe AE (at greatest intensity)"),
132	1x	REL = with_label(.data$AREL == "Y", "Related AE"),
133	1x	WD = with_label(.data$AEACN == "DRUG WITHDRAWN", "AE leading to withdrawal from treatment"),
134	1x	DSM = with_label(
135	1x	.data$AEACN %in% c("DRUG INTERRUPTED", "DOSE INCREASED", "DOSE REDUCED"),
136	1x	"AE leading to dose modification/interruption"
137		),
138	1x	SERWD = with_label(.data$SER & .data$WD, "Serious AE leading to withdrawal from treatment"),
139	1x	SERDSM = with_label(.data$SER & .data$DSM, "Serious AE leading to dose modification/interruption"),
140	1x	RELSER = with_label(.data$SER & .data$REL, "Related Serious AE"),
141	1x	RELWD = with_label(.data$REL & .data$WD, "Related AE leading to withdrawal from treatment"),
142	1x	RELDSM = with_label(.data$REL & .data$DSM, "Related AE leading to dose modification/interruption"),
143	1x	CTC35 = with_label(.data$ATOXGR %in% c("3", "4", "5"), "Grade 3-5 AE"),
144	1x	CTC45 = with_label(.data$ATOXGR %in% c("4", "5"), "Grade 4/5 AE")
145		)
146
147	1x	adam_db$adsl <- adam_db$adsl %>%
148	1x	mutate(DCSREAS = reformat(.data$DCSREAS, missing_rule))
149
150	1x	adam_db
151		}
152
153		#' @describeIn aet01 Postprocessing
154		#'
155		#' @inheritParams gen_args
156		#'
157		#' @export
158		#'
159		aet01_post <- function(tlg, prune_0 = FALSE, ...) {
160	1x	if (prune_0) {
161	!	tlg <- smart_prune(tlg)
162		}
163	1x	std_postprocess(tlg)
164