chevron coverage - 97.40%

Files
Source

# cfbt01 ----

#' @describeIn cfbt01 Main TLG function
#'
#' @inheritParams gen_args
#' @param summaryvars (`character`) variables to be analyzed. The label attribute of the corresponding column in
#'   table of `adam_db` is used as label.
#' @param visitvar (`string`) typically one of `"AVISIT"` or user-defined visit incorporating `"ATPT"`.
#' @param precision (named `list` of `integer`) where names are values found in the `PARAMCD` column and the values
#'   indicate the number of digits in statistics. If `default` is set, and parameter precision not specified,
#'   the value for `default` will be used. If `default` is not set, the default precision is 2.
#' @param .stats (`character`) statistics names, see `tern::analyze_vars()`.
#' @param skip Named (`list`) of visit values that need to be inhibited.
#' @param ... additional arguments like `.indent_mods`, `.labels`.
#' @returns the main function returns an `rtables` object.
#'
#' @details
#'  * The `Analysis Value` column, displays the number of patients, the mean, standard deviation, median and range of
#'  the analysis value for each visit.
#'  * The `Change from Baseline` column, displays the number of patient and the mean, standard deviation,
#'  median and range of changes relative to the baseline.
#'  * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
#'  * Split columns by arm, typically `ACTARM`.
#'  * Does not include a total column by default.
#'  * Sorted  based on factor level; first by `PARAM` labels in alphabetic order then by chronological time point given
#'  by `AVISIT`. Re-level to customize order
#'
#' @note
#'  * `adam_db` object must contain table named as `dataset` with the columns specified in `summaryvars`.
#'
#' @export
#'
cfbt01_main <- function(adam_db,
                        dataset,
                        arm_var = "ACTARM",
                        lbl_overall = NULL,
                        row_split_var = NULL,
                        summaryvars = c("AVAL", "CHG"),
                        visitvar = "AVISIT",
                        precision = list(default = 2L),
                        page_var = "PARAMCD",
                        .stats = c("n", "mean_sd", "median", "range"),
                        skip = list(CHG = "BASELINE"),
                        ...) {
  assert_all_tablenames(adam_db, c("adsl", dataset))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_character(summaryvars, max.len = 2L, min.len = 1L)
  assert_character(row_split_var, null.ok = TRUE)
  assert_disjunct(row_split_var, c("PARAMCD", "PARAM", visitvar))
  assert_string(visitvar)
  assert_string(page_var, null.ok = TRUE)
  assert_subset(page_var, c(row_split_var, "PARAMCD"))
  df_lbl <- paste0("adam_db$", dataset)
  assert_valid_variable(adam_db[[dataset]], c(summaryvars), types = list("numeric"), empty_ok = TRUE, label = df_lbl)
  assert_valid_variable(
    adam_db[[dataset]], c(visitvar, row_split_var, "PARAM", "PARAMCD"),
    types = list(c("character", "factor")), label = df_lbl
  )
  assert_valid_variable(
    adam_db[[dataset]], "USUBJID",
    types = list(c("character", "factor")), empty_ok = TRUE, label = df_lbl
  )
  assert_valid_variable(adam_db$adsl, "USUBJID", types = list(c("character", "factor")))
  assert_valid_var_pair(adam_db$adsl, adam_db[[dataset]], arm_var)
  assert_list(precision, types = "integerish", names = "unique")

  vapply(precision, assert_int, FUN.VALUE = numeric(1), lower = 0)
  all_stats <- c(
    "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei",
    "mean_sdi", "mean_pval", "median", "mad", "median_ci", "quantiles", "iqr", "range",
    "cv", "min", "max", "median_range", "geom_mean", "geom_cv"
  )
  assert_subset(.stats, all_stats)

  lbl_overall <- render_safe(lbl_overall)
  lbl_avisit <- var_labels_for(adam_db[[dataset]], visitvar)
  lbl_param <- var_labels_for(adam_db[[dataset]], "PARAM")

  summaryvars_lbls <- var_labels_for(adam_db[[dataset]], summaryvars)
  row_split_lbl <- var_labels_for(adam_db[[dataset]], row_split_var)

  lyt <- cfbt01_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_avisit = lbl_avisit,
    lbl_param = lbl_param,
    summaryvars = summaryvars,
    summaryvars_lbls = summaryvars_lbls,
    row_split_var = row_split_var,
    row_split_lbl = row_split_lbl,
    visitvar = visitvar,
    precision = precision,
    .stats = .stats,
    page_var = page_var,
    skip = skip,
    ...
  )

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

  tbl
}

#' `cfbt01` Layout
#'
#' @inheritParams gen_args
#' @inheritParams cfbt01_main
#'
#' @param lbl_avisit (`string`) label of the `visitvar` variable.
#' @param lbl_param (`string`) label of the `PARAM` variable.
#' @param summaryvars (`character`) the variables to be analyzed. For this table, `AVAL` and `CHG` by default.
#' @param summaryvars_lbls (`character`) the label of the variables to be analyzed.
#' @param row_split_lbl (`character`) label of further row splits.
#' @param visitvar (`string`) typically one of `"AVISIT"` or user-defined visit incorporating `"ATPT"`.
#' @returns a `PreDataTableLayouts` object.
#'
#' @keywords internal
#'
cfbt01_lyt <- function(arm_var,
                       lbl_overall,
                       lbl_avisit,
                       lbl_param,
                       summaryvars,
                       summaryvars_lbls,
                       row_split_var,
                       row_split_lbl,
                       visitvar,
                       precision,
                       page_var,
                       .stats,
                       skip,
                       ...) {
  page_by <- get_page_by(page_var, c(row_split_var, "PARAMCD"))
  label_pos <- ifelse(page_by, "hidden", "topleft")
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    split_rows_by_recursive(
      row_split_var,
      split_label = row_split_lbl,
      label_pos = head(label_pos, -1L), page_by = head(page_by, -1L)
    ) %>%
    split_rows_by(
      var = "PARAMCD",
      labels_var = "PARAM",
      split_fun = drop_split_levels,
      label_pos = tail(label_pos, 1L),
      split_label = lbl_param,
      page_by = tail(page_by, 1L)
    ) %>%
    split_rows_by(
      visitvar,
      split_fun = drop_split_levels,
      label_pos = "topleft",
      split_label = lbl_avisit
    ) %>%
    split_cols_by_multivar(
      vars = summaryvars,
      varlabels = summaryvars_lbls,
      nested = TRUE
    ) %>%
    analyze_colvars(
      afun = afun_skip,
      extra_args = list(
        visitvar = visitvar,
        paramcdvar = "PARAMCD",
        skip = skip,
        precision = precision,
        .stats = .stats,
        ...
      )
    )
}

#' @describeIn cfbt01 Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
cfbt01_pre <- function(adam_db, dataset, ...) {
  adam_db[[dataset]] <- adam_db[[dataset]] %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(
      AVISIT = reorder(.data$AVISIT, .data$AVISITN),
      AVISIT = with_label(.data$AVISIT, "Analysis Visit"),
      AVAL = with_label(.data$AVAL, "Value at Visit"),
      CHG = with_label(.data$CHG, "Change from \nBaseline")
    )

  adam_db
}

#' @describeIn cfbt01 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
cfbt01_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `CFBT01` Change from Baseline By Visit Table.
#'
#' The `CFBT01` table provides an
#' overview of the actual values and its change from baseline of each respective arm
#' over the course of the trial.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' library(dunlin)
#'
#' proc_data <- log_filter(
#'   syn_data,
#'   PARAMCD %in% c("DIABP", "SYSBP"), "advs"
#' )
#' run(cfbt01, proc_data, dataset = "advs")
cfbt01 <- chevron_t(
  main = cfbt01_main,
  preprocess = cfbt01_pre,
  postprocess = cfbt01_post
)

# pdt02 ----

#' @describeIn pdt02 Main TLG function
#'
#' @inheritParams gen_args
#' @param dvreas_var (`string`) the variable defining the reason for deviation. By default `DVREAS`.
#' @param dvterm_var (`string`) the variable defining the protocol deviation term. By default `DVTERM`.
#'
#' @details
#'  * Data should be filtered for major protocol deviations related to epidemic/pandemic.
#'  `(AEPRELFL == "Y" & DVCAT == "MAJOR")`.
#'  * 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 deviation reason alphabetically and within deviation reason by decreasing total number of patients with
#'  the specific deviation term.
#'
#' @note
#'  * `adam_db` object must contain an `addv` table with the columns specified in `dvreas_var` and `dvterm_var`.
#'
#' @export
#'
pdt02_main <- function(adam_db,
                       arm_var = "ARM",
                       lbl_overall = NULL,
                       dvreas_var = "DVREAS",
                       dvterm_var = "DVTERM",
                       ...) {
  assert_all_tablenames(adam_db, c("adsl", "addv"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_string(dvreas_var)
  assert_string(dvterm_var)
  assert_valid_variable(adam_db$addv, c(dvreas_var, dvterm_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$addv, "USUBJID", types = list(c("character", "factor")), empty_ok = TRUE)
  assert_valid_var_pair(adam_db$adsl, adam_db$addv, arm_var)

  lbl_overall <- render_safe(lbl_overall)
  lbl_dvreas_var <- var_labels_for(adam_db$addv, dvreas_var)
  lbl_dvterm_var <- var_labels_for(adam_db$addv, dvterm_var)

  lyt <- pdt02_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_dvreas_var = lbl_dvreas_var,
    lbl_dvterm_var = lbl_dvterm_var,
    dvreas_var = dvreas_var,
    dvterm_var = dvterm_var
  )

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

  tbl
}

#' `pdt02` Layout
#'
#' @inheritParams gen_args
#' @inheritParams pdt02_main
#' @param lbl_dvreas_var (`string`) label for the variable defining the reason for deviation.
#' @param lbl_dvterm_var (`string`) label for the variable defining the protocol deviation term.
#'
#' @keywords internal
#'
pdt02_lyt <- function(arm_var,
                      lbl_overall,
                      lbl_dvreas_var,
                      lbl_dvterm_var,
                      dvreas_var,
                      dvterm_var) {
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    analyze_num_patients(
      vars = "USUBJID",
      .stats = c("unique", "nonunique"),
      .labels = c(
        unique = render_safe(
          "Total number of {patient_label} with at least one major protocol deviation related to epidemic/pandemic"
        ),
        nonunique = "Total number of major protocol deviations related to epidemic/pandemic"
      )
    ) %>%
    split_rows_by(
      dvreas_var,
      nested = FALSE,
      split_fun = drop_split_levels,
      label_pos = "topleft",
      split_label = lbl_dvreas_var
    ) %>%
    summarize_num_patients(
      var = "USUBJID",
      .stats = "unique",
      .labels = NULL
    ) %>%
    count_occurrences(
      vars = dvterm_var,
      id = "USUBJID"
    ) %>%
    append_topleft(paste(" ", lbl_dvterm_var))
}

#' @describeIn pdt02 Preprocessing
#'
#' @inheritParams pdt02_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
pdt02_pre <- function(adam_db,
                      ...) {
  adam_db$addv <- adam_db$addv %>%
    mutate(across(all_of(c("DVCAT", "AEPRELFL")), ~ reformat(.x, missing_rule))) %>%
    filter(.data$DVCAT == "MAJOR" & .data$AEPRELFL == "Y") %>%
    mutate(across(all_of(c("DVREAS", "DVTERM")), ~ reformat(.x, nocoding))) %>%
    mutate(
      DVREAS = with_label(.data$DVREAS, "Primary Reason"),
      DVTERM = with_label(.data$DVTERM, "Description")
    )

  adam_db
}

#' @describeIn pdt02 Postprocessing
#'
#' @inheritParams pdt02_main
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
pdt02_post <- function(tlg, prune_0 = TRUE, dvreas_var = "DVREAS", dvterm_var = "DVTERM", ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }

  tbl_sorted <- tlg %>%
    sort_at_path(
      path = c(dvreas_var, "*", dvterm_var),
      scorefun = score_occurrences
    )

  std_postprocessing(tbl_sorted)
}

#' `pdt02` Major Protocol Deviations Related to Epidemic/Pandemic Table.
#'
#' A major protocol deviations
#' table with the number of subjects and the total number of Major Protocol Deviations Related
#' to Epidemic/Pandemic sorted alphabetically and deviations name sorted by frequencies.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(pdt02, syn_data)
pdt02 <- chevron_t(
  main = pdt02_main,
  preprocess = pdt02_pre,
  postprocess = pdt02_post
)

# ext01 ----

#' @describeIn ext01 Main TLG function
#'
#' @inheritParams gen_args
#' @param summaryvars (`character`) variables to be analyzed. The label attribute of the corresponding column in `adex`
#'   table of `adam_db` is used as label.
#' @param map (`data.frame`) of mapping for split rows.
#' @returns the main function returns an `rtables` object.
#'
#' @details
#'  * Default Exposure table
#'  * The `n` row provides the number of non-missing values. The percentages for categorical variables is based on `n`.
#'  The percentages for `Total number of patients with at least one dose modification` are based on the number of
#'  patients in the corresponding analysis population given by `N`.
#'  * Split columns by arm, typically `ACTARM`.
#'  * Does not include a total column by default.
#'  * Sorted by alphabetic order of the `PARAM` value. Transform to factor and re-level for custom order.
#'  * `ANL01FL` is not relevant subset.
#'
#' @note
#'   * `adam_db` object must contain an `adex` table with columns specified in `summaryvars`.
#'
#' @export
#'
ext01_main <- function(adam_db,
                       arm_var = "ACTARM",
                       lbl_overall = NULL,
                       summaryvars = "AVAL",
                       row_split_var = "PARCAT2",
                       page_var = NULL,
                       map = NULL,
                       ...) {
  assert_all_tablenames(adam_db, c("adsl", "adex"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_character(summaryvars)
  assert_character(row_split_var, null.ok = TRUE)
  assert_string(page_var, null.ok = TRUE)
  assert_data_frame(map, null.ok = TRUE)
  assert_valid_var_pair(adam_db$adsl, adam_db$adex, arm_var)
  assert_valid_variable(adam_db$adex, "USUBJID", empty_ok = TRUE, 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$adex, summaryvars, empty_ok = TRUE, na_ok = TRUE)
  assert_valid_variable(
    adam_db$adex, c(row_split_var, "PARAMCD", "PARAM"),
    types = list(c("character", "factor")), empty_ok = TRUE
  )
  assert_valid_variable(adam_db$adex, colnames(map), types = list(c("character", "factor")))
  if (!is.null(map)) {
    map <- infer_mapping(map, adam_db$adex)
  }
  assert_subset(page_var, c(row_split_var))

  lbl_overall <- render_safe(lbl_overall)
  summaryvars_lbls <- var_labels_for(adam_db$adex, summaryvars)
  row_split_lbl <- var_labels_for(adam_db$adex, row_split_var)

  lyt <- ext01_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    summaryvars = summaryvars,
    summaryvars_lbls = summaryvars_lbls,
    row_split_var = row_split_var,
    row_split_lbl = row_split_lbl,
    page_var = page_var,
    map = map
  )

  tbl <- build_table(lyt, adam_db$adex, adam_db$adsl)

  tbl
}

#' `ext01` Layout
#'
#' @inheritParams gen_args
#'
#' @param summaryvars (`character`) the name of the variable to be analyzed. By default `"AVAL"`.
#' @param summaryvars_lbls (`character`) the label associated with the analyzed variable.
#' @returns a `PreDataTableLayouts` object.
#'
#' @keywords internal
#'
ext01_lyt <- function(arm_var,
                      lbl_overall,
                      summaryvars,
                      summaryvars_lbls,
                      row_split_var,
                      row_split_lbl,
                      page_var,
                      map) {
  page_by <- get_page_by(page_var, c(row_split_var))
  label_pos <- ifelse(page_by, "hidden", "topleft")
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    split_rows_by_recursive(
      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 = split_fun_map(map)
    ) %>%
    analyze_vars(
      vars = summaryvars,
      var_labels = summaryvars_lbls,
      show_labels = "hidden",
      .formats = list(count_fraction = format_count_fraction_fixed_dp)
    )
}

#' @describeIn ext01 Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#'
#' @export
#'
ext01_pre <- function(adam_db,
                      ...) {
  adam_db$adex <- adam_db$adex %>%
    filter(.data$PARCAT1 == "OVERALL") %>%
    filter(.data$PARAMCD %in% c("TDURD", "TDOSE"))

  adam_db
}

#' @describeIn ext01 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
ext01_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) tlg <- smart_prune(tlg)
  std_postprocessing(tlg)
}

#' `EXT01` Exposure Summary Table.
#'
#' The `EXT01` table provides an overview of the of the exposure of the
#' patients in terms of Total dose administered or missed, and treatment duration.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(ext01, syn_data)
#'
#' run(ext01, syn_data, summaryvars = c("AVAL", "AVALCAT1"), prune_0 = FALSE)
#'
#' levels(syn_data$adex$AVALCAT1) <- c(levels(syn_data$adex$AVALCAT1), "12 months")
#' map <- data.frame(
#'   PARAMCD = "TDURD",
#'   AVALCAT1 = c("< 1 month", "1 to <3 months", ">=6 months", "3 to <6 months", "12 months")
#' )
#' run(ext01, syn_data, summaryvars = c("AVAL", "AVALCAT1"), prune_0 = FALSE, map = map)
ext01 <- chevron_t(
  main = ext01_main,
  preprocess = ext01_pre,
  postprocess = ext01_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`.
#' @returns a `character` with replaced placeholders and a `label` attribute.
#'
#' @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.
#' @returns 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 Main Listing Function
#'
#' @inheritParams gen_args
#' @param ... additional arguments passed to [`rlistings::as_listing`].
#' @returns the main function returns an `rlistings` or a `list` object.
#'
#' @keywords internal
std_listing <- function(adam_db,
                        dataset,
                        key_cols,
                        disp_cols,
                        split_into_pages_by_var,
                        unique_rows = FALSE,
                        ...) {
  assert_all_tablenames(adam_db, dataset)
  assert_valid_variable(adam_db[[dataset]], c(key_cols, disp_cols), label = paste0("adam_db$", dataset))

  execute_with_args(
    as_listing,
    df = adam_db[[dataset]],
    key_cols = key_cols,
    disp_cols = disp_cols,
    split_into_pages_by_var = split_into_pages_by_var,
    ...,
    default_formatting = listing_format_chevron(),
    unique_rows = unique_rows
  )
}

# 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 (`string`) that should replace actual value. If `NULL`, no replacement is performed.
#'
#' @returns `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 = NULL) {
  assert_integerish(digits, lower = 0)
  assert_string(format)
  assert_string(ne, null.ok = TRUE)
  if (any(is.na(digits))) {
    function(x, ...) {
      ""
    }
  } else {
    if (!is.null(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])
}

# lvl ----

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

#' Obtain levels from vector
#'
#' @param x (`character`) or (`factor`) object to obtain levels.
#' @returns `character` with unique values.
#' @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(x), names(y)))]
}

#' Expand list to each split
#' @keywords internal
expand_list <- function(lst, split) {
  assert_list(lst, names = "unique")
  assert_character(split)
  if ("all" %in% names(lst)) {
    lst <- lapply(
      setNames(split, split),
      function(x) {
        modify_character(lst$all, lst[[x]])
      }
    )
  }
  lst
}

#' Helper function to convert to months if needed
#'
#' @param x (`numeric`) time.
#' @param unit (`character`) or (`factor`) time unit.
#'
#' @returns 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
  )
}

#' Theme for Chevron Plot
#'
#' @param grid_y (`flag`) should horizontal grid be displayed.
#' @param grid_x (`flag`) should vertical grid be displayed.
#' @param legend_position (`string`) the position of the legend.
#' @param text_axis_x_rot (`numeric`) the x axis text rotation angle.
#'
#' @returns a `theme` object.
#'
#' @export
#'
gg_theme_chevron <- function(grid_y = TRUE,
                             grid_x = FALSE,
                             legend_position = "top",
                             text_axis_x_rot = 45) {
  assert_flag(grid_y)
  assert_flag(grid_x)
  assert_choice(legend_position, c("top", "bottom", "right", "left"))
  assert_numeric(text_axis_x_rot, len = 1, lower = -90, upper = 90)

  ggtheme <- ggplot2::theme_bw() +
    ggplot2::theme(legend.position = legend_position) +
    ggplot2::theme(axis.title.x = ggplot2::element_blank())

  ggtheme <- if (!grid_x) {
    ggtheme + ggplot2::theme(
      panel.grid.major.x = ggplot2::element_blank(),
      panel.grid.minor.x = ggplot2::element_blank()
    )
  } else {
    ggtheme + ggplot2::theme(
      panel.grid.major.x = ggplot2::element_line(linewidth = ggplot2::rel(0.5)),
      panel.grid.minor.x = ggplot2::element_blank()
    )
  }

  ggtheme <- if (!grid_y) {
    ggtheme + ggplot2::theme(
      panel.grid.minor.y = ggplot2::element_blank(),
      panel.grid.major.y = ggplot2::element_blank()
    )
  } else {
    ggtheme + ggplot2::theme(
      panel.grid.minor.y = ggplot2::element_blank(),
      panel.grid.major.y = ggplot2::element_line(linewidth = ggplot2::rel(0.5))
    )
  }

  ggtheme <- ggtheme + ggplot2::theme(
    axis.text.x = ggplot2::element_text(
      angle = text_axis_x_rot,
      hjust = get_x_hjust(text_axis_x_rot),
      vjust = get_x_vjust(text_axis_x_rot)
    )
  )

  ggtheme
}

#' Get a harmonious value of horizontal justification for x axis
#'
#' @param x (`numeric`) angle between -90 and 90 degree.
#' @keywords internal
get_x_hjust <- function(x) {
  assert_numeric(x, upper = 90, lower = -90, len = 1)

  if (x == 0) {
    0.5
  } else if (x > 0) {
    1
  } else {
    0
  }
}

#' Get a harmonious value of vertical justification for x axis
#'
#' @param x (`numeric`) angle between -90 and 90 degree.
#' @keywords internal
get_x_vjust <- function(x) {
  assert_numeric(x, upper = 90, lower = -90, len = 1)

  if (x == 0) {
    0
  } else if (abs(x) == 90) {
    0.5
  } else {
    1
  }
}

#' Get Section dividers
#' @export
#' @returns (`character`) value with section dividers at corresponding section.
get_section_div <- function() {
  x <- getOption("chevron.section_div", integer(0))
  if (!test_integerish(x)) {
    ret <- NA_character_
  } else {
    ret <- rep(NA_character_, max(x, 0))
    ret[x] <- ""
  }
  ret
}

#' Set Section Dividers
#' @export
#' @param x (`integerish`) value of at which the section divider should be added.
#' @details Section dividers are empty lines between sections in tables.
#' E.g. if 1 is used then for the first row split an empty line is added.
#' Currently it only works for `aet02`, `cmt01a` and `mht01` template.
#' @returns invisible `NULL`. Set the `chevron.section_div` option.
#' @export
set_section_div <- function(x) {
  assert_integerish(x, min.len = 0L, any.missing = FALSE, lower = 1L)
  options("chevron.section_div" = x)
  invisible()
}

#' @keywords internal
to_list <- function(x) {
  if (length(x) == 1L) {
    return(x)
  }
  x <- as.list(x)
  lapply(x, to_list)
}

# Deprecated functions ----

#' List of `grob` object
#'
#' `r lifecycle::badge("deprecated")`
#'
#' @param ... (`grob`) objects.
#' @returns a `grob_list` object.
#' @export
grob_list <- function(...) {
  lifecycle::deprecate_warn("0.2.5.9009", "grob_list()", "list()")
  list(...)
}

#' List of `gg` object
#'
#' `r lifecycle::badge("deprecated")`
#'
#' @param ... (`ggplot`) objects.
#' @returns a `gg_list` object.
#' @export
gg_list <- function(...) {
  lifecycle::deprecate_warn("0.2.5.9009", "gg_list()", "list()")
  list(...)
}


#' Format for Chevron Listings
#'
#' @return a `list` of `fmt_config`.
#'
listing_format_chevron <- function() {
  list(
    all = fmt_config(align = "left"),
    numeric = fmt_config(align = "center"),
    Date = fmt_config(format = format_date(), align = "left"),
    POSIXct = fmt_config(format = format_date(), align = "left"),
    POSIXt = fmt_config(format = format_date(), align = "left")
  )
}

#' Formatting of date
#'
#' @param date_format (`string`) the output format.
#'
#' @return a `function` converting a date into `string`.
#'
#' @note The date is extracted at the location of the measure, not at the location of the system.
#'
#' @export
#' @examples
#' format_date("%d%b%Y")(as.Date("2021-01-01"))
#' if ("NZ" %in% OlsonNames()) {
#'   format_date("%d%b%Y")(as.POSIXct("2021-01-01 00:00:01", tz = "NZ"))
#' }
#' if ("US/Pacific" %in% OlsonNames()) {
#'   format_date("%d%b%Y")(as.POSIXct("2021-01-01 00:00:01", tz = "US/Pacific"))
#' }
format_date <- function(date_format = "%d%b%Y") {
  function(x, ...) {
    toupper(
      format(
        # Extract the date at the location of the measure, not at the location of the system.
        lubridate::force_tz(x, tzone = "UTC"),
        date_format,
        tz = "UTC"
      )
    )
  }
}

# listing_id ----

#' Concatenate Site and Subject ID
#'
#' @param site (`string`)
#' @param subject (`string`)
#' @param sep (`string`)
#'
#' @note the `{Patient_label}` whisker placeholder will be used in the label.
#'
#' @export
#' @examples
#' create_id_listings("BRA-1", "xxx-1234")
create_id_listings <- function(site, subject, sep = "/") {
  assert_character(site)
  assert_character(subject)
  assert_string(sep)

  subject_id <- stringr::str_split_i(subject, pattern = "-", i = -1)

  with_label(paste(site, subject_id, sep = sep), render_safe("Center/{Patient_label} ID"))
}

#' @include chevron_tlg-S4class.R

# run ----

#' Run the TLG-generating pipeline
#'
#' Execute sequential the pre-processing, main and post-processing functions.
#'
#' @details
#' The functions stored in the `preprocess`, `main` and `postprocess` slots of the `chevron_tlg` objects are called
#' respectively, `preprocessing`, `main` and `postprocessing` functions.
#'
#' When executing the `run` method on a `chevron_tlg` object, if `auto_pre` is `TRUE`, the `adam_bd` list is first
#' passed to the `preprocessing` function. The resulting list is then passed to the `main` function which produces a
#' table, graph or listings or a list of these objects. This output is then passed to the `postprocessing` function
#' which performed the final modifications before returning the output. Additional arguments specified in `...` or
#' `user_args` are passed to each of the three functions.
#'
#' @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 unwrap (`flag`)  whether to print the preprocessing postprocessing and main function together with the
#'   associated layout function.
#' @param ... extra arguments to pass to the pre-processing, main and post-processing functions.
#' @param user_args (`list`) arguments from `...`.
#' @returns an `rtables` (for `chevron_t`), `rlistings` (for `chevron_l`), `grob` (for `chevron_g`) or `ElementaryTable`
#'   (null report) depending on the class of `chevron_tlg` object passed as `object` argument.
#'
#' @name run
#' @export
setGeneric(
  "run",
  function(object, adam_db, auto_pre = TRUE, verbose = FALSE, unwrap = FALSE, ..., user_args = list(...)) {
    standardGeneric("run")
  }
)

#' Run the TLG-generating 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 = get_arg("chevron.run.verbose", "R_CHEVRON_RUN_VERBOSE", FALSE),
                        unwrap = get_arg("chevron.run.unwrap", "R_CHEVRON_RUN_UNWRAP", verbose),
                        ...,
                        user_args = list(...)) {
    assert_list(adam_db, types = "data.frame", names = "unique")
    assert_flag(auto_pre)
    verbose <- as.logical(verbose)
    assert_flag(verbose)
    unwrap <- as.logical(unwrap)
    assert_flag(unwrap)
    assert_list(user_args, names = "unique")
    args <- list(...)
    assert_list(args, names = "unique", .var.name = "...")
    additional_names <- setdiff(names(user_args), names(args))
    user_args <- modifyList(user_args, args, keep.null = TRUE)

    if (verbose) {
      cl <- match.call()
      print_args(
        run_call = cl,
        additional_args = user_args[additional_names],
        args = args_ls(object, omit = c("...", "adam_db", "tlg")),
        auto_pre = auto_pre
      )
    }

    if (unwrap) {
      if (auto_pre) {
        cat("Preprocessing function:\n")
        cat(paste(deparse(preprocess(object)), collapse = "\n"), "\n")
        cat("\n")
      }

      cat("Main function:\n")
      cat(paste(deparse(main(object)), collapse = "\n"), "\n")
      cat("\n")

      # Show layout function from main if it exists.
      unwrap_layout(main(object))

      cat("Postprocessing function:\n")
      cat(paste(deparse(postprocess(object)), collapse = "\n"), "\n")
    }

    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)

  run_call[c("auto_pre", "verbose", "user_args", "unwrap")] <- NULL
  if (!is.null(additional_args)) {
    run_call <- c(run_call, additional_args)
  }
  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.
#' @returns a `list` of the formal arguments with their default for the functions stored in the `chevron_tlg` object
#'   passed a `x` argument.
#'
#' @rdname args_ls
#' @export
#' @examples
#' args_ls(aet01, simplify = TRUE)
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.
#' @returns the `function` stored in the `main` slot of the `x` argument.
#'
#' @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`.
#' @returns the `function` stored in the `preprocess` slot of the `x` argument.
#'
#' @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.
#' @returns the `function` stored in the `postprocess` slot of the `x` argument.
#'
#' @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 `TLG` Generation
#'
#' @param x (`chevron_tlg`) input.
#' @param adam_db (`string`) the name of the dataset.
#' @param name (`string`) name of the template.
#' @param args (`string`) the name of argument list.
#' @returns `character` that can be integrated into an executable script.
#'
#' @name script
#' @rdname script
NULL

#' @rdname script
#' @export
setGeneric("script_funs", function(x, adam_db, args, name = deparse(substitute(x))) 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, name) {
    checkmate::assert_string(adam_db)
    checkmate::assert_string(args)
    checkmate::assert_string(name)
    c(
      "# Edit Preprocessing Function.",
      glue::glue("preprocess({name}) <- "),
      deparse(preprocess(x)),
      "",
      "# Create TLG",
      glue::glue(
        "tlg_output <- run(object = {name}, adam_db = {adam_db}",
        ", verbose = TRUE, user_args = {args})"
      )
    )
  }
)

#' @rdname script
#' @export
#'
setMethod(
  f = "script_funs",
  signature = "chevron_simple",
  definition = function(x, adam_db, args, name) {
    checkmate::assert_string(adam_db)
    main_body <- body(main(x))
    c(
      "# Create TLG",
      if (!identical(adam_db, "adam_db")) {
        glue::glue("adam_db <- {adam_db}")
      },
      "",
      "tlg_output <- ",
      deparse(main_body)
    )
  }
)

#' @keywords internal
split_and_summ_num_patients <- function(lyt, var, label, stats, summarize_labels, split_indent, section_div, ...) {
  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,
      section_div = section_div
    )
  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 <- lapply(row_paths(tlg), unname)
  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_recursive(detail_vars[-length(detail_vars)], split_fun = drop_split_levels) %>%
      analyze_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_recursive <- 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
#'
#' @returns `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
#'
#' @returns `rtables` object.
ifneeded_split_col <- function(lyt, var, ...) {
  if (is.null(var)) {
    lyt
  } else {
    split_cols_by(
      lyt = lyt,
      var = var,
      ...
    )
  }
}

#' 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
  ))
}

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
  }
}

split_cols_by_with_overall <- function(lyt, col_var, lbl_overall, ref_group = NULL) {
  if (is.null(col_var)) {
    lyt
  } else {
    split_cols_by(
      lyt, col_var,
      split_fun = if (!is.null(lbl_overall) && !identical(lbl_overall, "")) {
        add_overall_level(lbl_overall, first = FALSE)
      },
      ref_group = ref_group
    )
  }
}

#' 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::analyze_variables`.
#' @param .labels (`character`) See `tern::analyze_variables`.
#' @param .indent_mods (`integer`) See `tern::analyze_variables`.
#' @param .N_col (`int`) See `tern::analyze_variables`.
#' @param .N_row (`int`) See `tern::analyze_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, ne = NULL)
  names(fmts) <- .stats
  fmts_na <- lapply(.stats, summary_formats, pcs = pcs, ne = tern::default_na_str())
  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 = NULL) {
  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)
  )
}

#' Analyze with defined precision
#'
#' @param x value to analyze
#' @param .var variable name.
#' @param .spl_context split context.
#' @param precision (named `list` of `integer`) where names of columns found in `.df_row` and the values indicate the
#'   number of digits in statistics for numeric value. If `default` is set, and parameter precision not specified, the
#'   value for `default` will be used. If neither are provided, auto determination is used. See [`tern::format_auto`].
#' @param .stats (named `list` of character)  where names of columns found in `.df_row` and the values indicate the
#'   statistical analysis to perform. If `default` is set, and parameter precision not specified, the
#'   value for `default` will be used.
#' @param .labels (`character`) See `tern::analyze_variables`.
#' @param .indent_mods (`integer`) See `tern::analyze_variables`.
#' @param .N_col (`int`) See `tern::analyze_variables`.
#' @param .N_row (`int`) See `tern::analyze_variables`.
#' @param ... additional arguments for `tern::a_summary`.
#'
#' @keywords internal
afun_p <- function(x,
                   .N_col, # nolint
                   .spl_context,
                   precision,
                   .N_row, # nolint
                   .var = NULL,
                   .df_row = NULL,
                   .stats = NULL,
                   .labels = NULL,
                   .indent_mods = NULL,
                   ...) {
  .stats <- .stats[[.var]] %||% .stats[["default"]] %||% c("n", "mean_sd", "median", "range", "count_fraction")

  # Define precision
  pcs <- precision[[.var]] %||% precision[["default"]]
  fmts <- if (is.null(pcs) && length(x) > 0) {
    lapply(.stats, function(.s) format_auto(dt_var = as.numeric(x), x_stat = .s))
  } else {
    # Define an arbitrary precision if unavailable and unable to compute it.
    pcs <- pcs %||% 2
    lapply(.stats, summary_formats, pcs = pcs, ne = NULL)
  }
  names(fmts) <- .stats

  if ("n" %in% .stats) fmts$n <- "xx"
  if ("count_fraction" %in% .stats) fmts$count_fraction <- format_count_fraction_fixed_dp

  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, ...
  )
}

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(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, 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)
      )
  }
  section_divs <- get_section_div()
  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]]]),
      section_div = section_divs[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))
}

# fstg01 ----

#' @describeIn fstg01 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 rsp_var (`string`) the response variable name to flag whether each subject is a binary response or not.
#' @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_rsp_subgroups`.
#' @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.
#' @returns the main function returns a `grob` object.
#'
#' @note
#'  * `adam_db` object must contain the table specified by `dataset` with `"PARAMCD"`, `"ARM"`,
#'  `"AVALC"`, 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 provide `gp`, `width_row_names`,
#'  `width_columns` and `width_forest` manually to make it fit. See `tern::g_forest` for more details.
#'
#' @returns a `gTree` object.
#'
#' @export
#'
fstg01_main <- function(adam_db,
                        dataset = "adrs",
                        arm_var = "ARM",
                        rsp_var = "IS_RSP",
                        subgroups = c("SEX", "AGEGR1", "RACE"),
                        strata_var = NULL,
                        stat_var = c("n_tot", "n", "n_rsp", "prop", "or", "ci"),
                        ...) {
  assert_all_tablenames(adam_db, c("adsl", dataset))
  df_lbl <- paste0("adam_db$", dataset)
  assert_string(arm_var)
  assert_string(rsp_var)
  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"),
    types = list(c("character", "factor")),
    label = df_lbl
  )
  assert_valid_variable(adam_db[[dataset]], rsp_var, 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)

  variables <- list(
    arm = arm_var,
    rsp = rsp_var,
    subgroups = subgroups,
    strata = strata_var
  )

  df <- execute_with_args(extract_rsp_subgroups,
    variables = variables,
    data = adam_db[[dataset]],
    ...
  )
  result <- basic_table() %>%
    tabulate_rsp_subgroups(df, vars = stat_var)
  execute_with_args(
    g_forest,
    tbl = result,
    ...,
    font_size = 7
  )
}

#' @describeIn fstg01 Preprocessing
#'
#' @inheritParams fstg01_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#'
#' @export
#'
fstg01_pre <- function(adam_db, ...) {
  adam_db$adrs <- adam_db$adrs %>%
    mutate(
      ARM = droplevels(.data$ARM),
      IS_RSP = .data$AVALC %in% c("CR", "PR")
    )

  adam_db
}

# `fstg01` Pipeline ----

#' `FSTG01` Subgroup Analysis of Best Overall Response.
#'
#' The template produces the subgroup analysis of best overall response graphic.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' library(dplyr)
#' library(dunlin)
#'
#' proc_data <- log_filter(
#'   syn_data,
#'   PARAMCD == "BESRSPI" & ARM %in% c("A: Drug X", "B: Placebo"), "adrs"
#' )
#' run(fstg01, proc_data,
#'   subgroups = c("SEX", "AGEGR1", "RACE"),
#'   conf_level = 0.90, dataset = "adrs"
#' )
fstg01 <- chevron_g(
  main = fstg01_main,
  preprocess = fstg01_pre
)

# rmpt06 ----

#' @describeIn rmpt06 Main TLG function
#'
#' @inheritParams gen_args
#' @param method (`string`) the method used to construct the confidence interval. See [`tern::estimate_proportion`].
#' @param conf_level (`proportion`) the confidence level of the interval. See [`tern::estimate_proportion`].
#' @param show_diff (`flag`) whether to show the difference of patient with at least one adverse event  between groups.
#' @param ref_group (`string`) the reference group for the difference.
#' @param method_diff (`string`) the method used to construct the confidence interval for the difference between groups.
#' @param conf_level_diff (`proportion`) the confidence level of the interval for the difference between groups.
#' @param grade_groups (`list`) the grade groups to be displayed.
#' @returns the main function returns an `rtables` object.
#'
#' @export
rmpt06_main <- function(adam_db,
                        arm_var = "ACTARM",
                        lbl_overall = NULL,
                        method = "clopper-pearson",
                        conf_level = 0.95,
                        show_diff = FALSE,
                        ref_group = NULL,
                        method_diff = "wald",
                        conf_level_diff = 0.95,
                        grade_groups = NULL,
                        ...) {
  assert_all_tablenames(adam_db, "adsl", "adae")
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_choice(
    method,
    c("waldcc", "wald", "clopper-pearson", "wilson", "wilsonc", "agresti-coull", "jeffreys")
  )
  assert_numeric(conf_level, lower = 0, upper = 1)
  assert_flag(show_diff)
  assert_choice(
    method_diff,
    c("waldcc", "wald", "cmh", "ha", "newcombe", "newcombecc")
  )
  assert_numeric(conf_level_diff, lower = 0, upper = 1)
  assert_list(grade_groups, null.ok = TRUE)
  assert_valid_variable(adam_db$adsl, "AEFL", types = list("logical"))
  assert_valid_variable(adam_db$adae, "ATOXGR", na_ok = TRUE, types = list("factor"))
  assert_valid_variable(adam_db$adae, "AESER", types = list("character", "factor"))
  assert_valid_variable(adam_db$adae, "AEOUT", na_ok = TRUE, types = list("factor"))
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var))
  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_var_pair(adam_db$adsl, adam_db$adae, arm_var)

  lbl_overall <- render_safe(lbl_overall)

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

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

  lyt <- rmpt06_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    method = method,
    ref_group = ref_group,
    conf_level = conf_level,
    show_diff = show_diff,
    method_diff = method_diff,
    conf_level_diff = conf_level_diff,
    grade_groups = grade_groups
  )

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

  col_info(tbl_adae) <- col_info(tbl_adsl)

  rbind(
    tbl_adsl,
    tbl_adae
  )
}

#' `rmpt06` Layout
#'
#' @inheritParams gen_args
#'
#' @keywords internal
#'
rmpt06_lyt <- function(arm_var,
                       lbl_overall,
                       method,
                       conf_level,
                       show_diff,
                       ref_group,
                       method_diff,
                       conf_level_diff,
                       grade_groups) {
  lyt <- basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall, ref_group = ref_group)

  lyt_adsl <- lyt %>%
    estimate_proportion(
      vars = "AEFL",
      method = method,
      conf_level = conf_level,
      .labels = c(
        n_prop = render_safe("Number of {patient_label} with at least one adverse event"),
        prop_ci = paste0(
          100 * conf_level,
          render_safe("% CI for % of {patient_label} with at least one AE")
        )
      ),
      table_names = "est_prop"
    )

  if (show_diff) {
    lyt_adsl <- lyt_adsl %>%
      estimate_proportion_diff(
        vars = "AEFL",
        method = method_diff,
        conf_level = conf_level_diff,
        .labels = c(
          diff = render_safe("Difference in % of {patient_label} with at least one AE"),
          diff_ci = paste0(
            100 * conf_level_diff,
            "% CI of difference"
          )
        ),
        table_names = "est_diff"
      )
  }

  lyt_adae <- lyt %>%
    analyze_num_patients(
      vars = "USUBJID",
      .stats = c("nonunique"),
      .labels = c(
        nonunique = "Total number of AEs"
      ),
      .formats = list(nonunique = "xx"),
      show_labels = "hidden"
    ) %>%
    count_occurrences_by_grade(
      var = "ATOXGR",
      var_labels = render_safe("Total number of {patient_label} with at least one AE by worst grade"),
      show_labels = "visible",
      grade_groups = grade_groups
    ) %>%
    count_patients_with_event(
      "USUBJID",
      filters = c("AESER" = "Y"),
      .labels = c(count_fraction = render_safe("Number of {patient_label} with at least one serious AE")),
      denom = "N_col",
      .formats = c(count_fraction = format_count_fraction_fixed_dp),
      table_names = "aeser"
    ) %>%
    count_occurrences(
      "AEOUT",
      denom = "n",
      var_labels = render_safe("Number of {patient_label} with at least one AE by outcome"),
      show_labels = "visible",
      drop = FALSE
    )


  list(
    adsl = lyt_adsl,
    adae = lyt_adae
  )
}

#' @describeIn rmpt06 Preprocessing
#'
#' @inheritParams rmpt06_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
rmpt06_pre <- function(adam_db, ...) {
  aeout_rule <- rule(
    "Fatal outcome" = "FATAL",
    "Unresolved" = "NOT RECOVERED/NOT RESOLVED",
    "Recovered/Resolved" = "RECOVERED/RESOLVED",
    "Resolved with sequelae" = "RECOVERED/RESOLVED WITH SEQUELAE",
    "Recovering/Resolving" = "RECOVERING/RESOLVING",
    "Unknown outcome" = "UNKNOWN"
  )

  adam_db$adae <- adam_db$adae %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(AEOUT = reformat(.data$AEOUT, aeout_rule))

  adam_db$adsl <- adam_db$adsl %>%
    mutate(AEFL = .data$USUBJID %in% .env$adam_db$adae$USUBJID)

  adam_db
}

#' @describeIn rmpt06 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
rmpt06_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `RMPT06` Table 1 (Default) Seriousness, Outcomes, Severity, Frequency with 95% CI for Risk Management Plan.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(rmpt06, syn_data)
rmpt06 <- chevron_t(
  main = rmpt06_main,
  preprocess = rmpt06_pre,
  postprocess = rmpt06_post
)

# aet10 ----

#' @describeIn aet10 Main TLG function
#'
#' @inheritParams gen_args
#' @returns the main function returns an `rtables` object
#' @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 `AEDECOD` are labeled by `No Coding Available`.
#'
#' @note
#'  * `adam_db` object must contain an `adae` table with the columns `"AEDECOD"`.
#'
#' @export
#'
aet10_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"), 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_aedecod <- var_labels_for(adam_db$adae, "AEDECOD")

  lyt <- aet10_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_aedecod = lbl_aedecod
  )

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

  tbl
}

#' `aet10` Layout
#'
#' @inheritParams gen_args
#' @param lbl_aedecod (`character`) text label for `AEDECOD`.
#' @returns a `PreDataTableLayouts` object.
#' @keywords internal
#'
aet10_lyt <- function(arm_var,
                      lbl_overall,
                      lbl_aedecod) {
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    count_occurrences(
      vars = "AEDECOD",
      .indent_mods = -1L
    ) %>%
    append_topleft(paste0("\n", lbl_aedecod))
}

#' @describeIn aet10 Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
aet10_pre <- function(adam_db, ...) {
  adam_db$adae <- adam_db$adae %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(AEDECOD = reformat(.data$AEDECOD, nocoding))
  return(adam_db)
}

#' @describeIn aet10 Postprocessing
#'
#' @inheritParams gen_args
#' @param atleast given cut-off in numeric format, default is `0.05`
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
aet10_post <- function(tlg, atleast = 0.05, ...) {
  assert_number(atleast, lower = 0, upper = 1)
  tbl_sorted <- tlg %>%
    sort_at_path(
      path = c("AEDECOD"),
      scorefun = score_occurrences
    )

  tlg_prune <- prune_table(
    tt = tbl_sorted,
    prune_func = keep_rows(
      has_fraction_in_any_col(
        atleast = atleast
      )
    )
  )

  std_postprocessing(tlg_prune)
}

#' `AET10` Table 1 (Default) Most Common (xx%) Adverse Events Preferred Terms Table 1.
#'
#' The `AET10` table Include Adverse Events occurring with user-specified threshold X% in at least
#'  one of the treatment groups. Standard table summarized by preferred term (PT).
#' Order the data by total column frequency from most to least frequently reported PT (regardless of SOC).
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(aet10, syn_data)
aet10 <- chevron_t(
  main = aet10_main,
  preprocess = aet10_pre,
  postprocess = aet10_post
)

#' @include utils.R
#' @include report_null.R

# Chevron_tlg ----

#' `chevron_tlg` class
#'
#' The `chevron_tlg` S4 class associates a `preprocess` function, a main `tlg` function and a `postprocess` function.
#'
#' @slot main (`function`) returning a `tlg`. Typically one of the `*_main` function from `chevron`.
#' @slot preprocess (`function`) returning a pre-processed `list` of `data.frames` amenable to `tlg` creation. Typically
#'   one of the `*_pre` function from `chevron`.
#' @slot postprocess (`function`) returning a post-processed `tlg`. Typically one of the `*_post` function from
#'   `chevron`.
#'
#' @format NULL
#'
#' @note To ensure the correct execution of the workflow, additional validation criteria are:
#' * the first argument of the `main` function must be `adam_db`, the input `list` of `data.frames` to pre-process. The
#' `...` argument is mandatory.
#' * the first argument of the `preprocess` function must be `adam_db`, the input `list` of `data.frames` to create
#' `tlg` output. The `...` argument is mandatory.
#' * the first argument of the `postprocess` function must be `tlg`, the input `TableTree` object to post-process. The
#' `...` argument is mandatory.
#'
#' @name chevron_tlg-class
#' @exportClass chevron_tlg
.chevron_tlg <- setClass(
  "chevron_tlg",
  contains = "VIRTUAL",
  slots = c(
    main = "function",
    preprocess = "function",
    postprocess = "function"
  )
)

# Validation ----

methods::setValidity("chevron_tlg", function(object) {
  coll <- makeAssertCollection()
  assert_function(object@main, args = c("adam_db"), ordered = TRUE, add = coll)
  assert_function(object@main, args = "...", add = coll)
  assert_function(object@preprocess, args = c("adam_db"), ordered = TRUE, add = coll)
  assert_function(object@preprocess, args = "...", add = coll)
  assert_function(object@postprocess, args = c("tlg"), ordered = TRUE, add = coll)
  assert_function(object@postprocess, args = "...", add = coll)
  reportAssertions(coll)
})

# Subclasses ----

## chevron_t ----

#' `chevron_t`
#'
#' `chevron_t`, a subclass of [chevron::chevron_tlg-class] with specific validation criteria to handle table creation
#'
#' @aliases chevron_table
#' @rdname chevron_tlg-class
#' @exportClass chevron_t
.chevron_t <- setClass(
  "chevron_t",
  contains = "chevron_tlg"
)

## chevron_l ----

#' `chevron_l`
#'
#' `chevron_l`, a subclass of [chevron::chevron_tlg-class] with specific validation criteria to handle listing creation
#'
#' @aliases chevron_listing
#' @rdname chevron_tlg-class
#' @exportClass chevron_l
.chevron_l <- setClass(
  "chevron_l",
  contains = "chevron_tlg"
)

## chevron_g ----

#' `chevron_g`
#'
#' `chevron_g`, a subclass of [chevron::chevron_tlg-class] with specific validation criteria to handle graph creation
#'
#' @aliases chevron_graph
#' @rdname chevron_tlg-class
#' @exportClass chevron_g
.chevron_g <- setClass(
  "chevron_g",
  contains = "chevron_tlg"
)

## chevron_simple ----

#' `chevron_simple`
#'
#' `chevron_simple`, a subclass of [chevron::chevron_tlg-class], where main function is a simple call
#'
#' @aliases chevron_simple
#' @rdname chevron_tlg-class
#' @exportClass chevron_simple
.chevron_simple <- setClass(
  "chevron_simple",
  contains = "chevron_tlg"
)


# Validity of class `chevron_simple`
methods::setValidity("chevron_simple", function(object) {
  main_body <- body(object@main)
  if (is.symbol(main_body)) {
    return(invisible(TRUE))
  }
  res <- rapply(to_list(main_body), function(x) {
    identical(x, as.name("return"))
  })
  has_return <- if (any(res)) "Must be a simple expression without `return`" else TRUE
  makeAssertion(object@main, has_return, var.name = "object@main", collection = NULL)
  invisible(TRUE)
})

# Sub Constructor ----

#' `chevron_t` constructor
#'
#' @rdname chevron_tlg-class
#'
#' @inheritParams gen_args
#' @param ... not used
#' @returns a `chevron_t` class object.
#'
#' @export
#'
#' @examples
#' chevron_t_obj <- chevron_t()
#' chevron_t_obj <- chevron_t(postprocess = function(tlg, indent, ...) {
#'   rtables::table_inset(tlg) <- indent
#'   tlg
#' })
#'
chevron_t <- function(main = function(adam_db, ...) build_table(basic_table(), adam_db[[1]]),
                      preprocess = function(adam_db, ...) adam_db,
                      postprocess = std_postprocessing,
                      ...) {
  res <- .chevron_t(
    main = main,
    preprocess = preprocess,
    postprocess = postprocess
  )

  res
}

#' `chevron_l` constructor
#'
#' @rdname chevron_tlg-class
#'
#' @inheritParams gen_args
#' @param ... not used
#' @returns a `chevron_l` class object.
#' @export
#'
#' @examples
#' chevron_l_obj <- chevron_l()
#'
chevron_l <- function(main = function(adam_db, ...) data.frame(),
                      preprocess = function(adam_db, ...) adam_db,
                      postprocess = std_postprocessing,
                      ...) {
  res <- .chevron_l(
    main = main,
    preprocess = preprocess,
    postprocess = postprocess
  )

  res
}

#' `chevron_g` constructor
#'
#' @rdname chevron_tlg-class
#'
#' @inheritParams gen_args
#' @param ... not used
#' @returns a `chevron_g` class object.
#'
#' @export
#'
#' @examples
#' chevron_g_obj <- chevron_g()
#' chevron_g_obj <- chevron_g(
#'   postprocess = function(tlg, title, ...) tlg + ggplot2::labs(main = title)
#' )
#'
chevron_g <- function(main = function(adam_db, ...) ggplot2::ggplot(),
                      preprocess = function(adam_db, ...) adam_db,
                      postprocess = std_postprocessing,
                      ...) {
  res <- .chevron_g(
    main = main,
    preprocess = preprocess,
    postprocess = postprocess
  )

  res
}

#' `chevron_simple` constructor
#'
#' @rdname chevron_tlg-class
#'
#' @inheritParams gen_args
#' @param ... not used
#' @returns a `chevron_simple` class object.
#'
#' @export
#'
#' @examples
#' chevron_simple_obj <- chevron_simple()
chevron_simple <- function() {
  res <- .chevron_simple(
    main = \(adam_db, ...) basic_table() %>% build_table(data.frame()),
    preprocess = \(adam_db, ...) adam_db,
    postprocess = \(tlg, ...) tlg
  )
  res
}

# coxt01 ----

#' @describeIn coxt01 Main TLG function
#'
#' @inheritParams gen_args
#' @param arm_var (`string`) the arm variable used for arm splitting.
#' @param time_var (`string`) the time variable in a Cox proportional hazards regression model.
#' @param event_var (`string`) the event variable in a Cox proportional hazards regression model.
#' @param covariates (`character`) will be fitted and the corresponding effect will be estimated.
#' @param strata (`character`) will be fitted for the stratified analysis.
#' @param lbl_vars (`string`) text label for the a Cox regression model variables.
#' @param multivar (`flag`) indicator of whether multivariate cox regression is conducted.
#' @param ... Further arguments passed to `tern::control_coxreg()`.
#' @returns the main function returns an `rtables` object
#'
#' @details
#'  * The reference arm will always the first level of `arm_var`. Please change the level if you want to
#'  change the reference arms.
#'  * The table allows confidence level to be adjusted, default is two-sided 95%.
#'  * The stratified analysis is with DISCRETE tie handling (equivalent to `tern::control_coxreg(ties = "exact")` in R).
#'  * Model includes treatment plus specified covariate(s) as factor(s) or numeric(s),
#'  with `"SEX"`, `"RACE"` and `"AAGE"` as default candidates.
#'  * The selection of the covariates and whether or not there is a selection process
#'  (vs. a fixed, pre-specified list) needs to be pre-specified.
#'  * For pairwise comparisons using the hazard ratio, the value for the control group is the denominator.
#'  * Keep zero-count rows unless overridden with `prune_0 = TRUE`.
#'
#' @note
#'   * `adam_db` object must contain an `adtte` table with `"PARAMCD"`, `"ARM"`,
#'   `"AVAL"`, `"CNSR`, and the columns specified by `"covariates"` which is denoted as
#'   `c("SEX", "RACE", "AAGE")` by default.
#'
#' @export
#'
coxt01_main <- function(adam_db,
                        arm_var = "ARM",
                        time_var = "AVAL",
                        event_var = "EVENT",
                        covariates = c("SEX", "RACE", "AAGE"),
                        strata = NULL,
                        lbl_vars = "Effect/Covariate Included in the Model",
                        multivar = FALSE,
                        ...) {
  assert_all_tablenames(adam_db, "adtte")
  assert_string(arm_var)
  assert_string(time_var)
  assert_string(event_var)
  assert_character(covariates, null.ok = TRUE)
  assert_character(strata, null.ok = TRUE)
  assert_flag(multivar)
  assert_valid_variable(adam_db$adtte, arm_var, types = list("factor"), n.levels = if (!multivar) 2L)
  assert_valid_variable(adam_db$adtte, c("USUBJID", arm_var, "PARAMCD"), types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adtte, strata, types = list(c("factor", "integer", "character")), na_ok = TRUE)
  assert_valid_variable(adam_db$adtte, covariates, na_ok = TRUE)
  assert_valid_variable(adam_db$adtte, event_var, types = list("numeric"), integerish = TRUE, lower = 0L, upper = 1L)
  assert_valid_variable(adam_db$adtte, time_var, types = list("numeric"), lower = 0)
  assert_single_value(adam_db$adtte$PARAMCD)
  control <- execute_with_args(control_coxreg, ...)

  variables <- list(
    time = time_var,
    event = event_var,
    arm = arm_var,
    covariates = covariates,
    strata = strata
  )

  lyt <- coxt01_lyt(
    variables = variables,
    col_split = if (!multivar) "COL_LABEL",
    lbl_vars = lbl_vars,
    multivar = multivar,
    control = control,
    ...
  )

  col_split <- "Treatment Effect Adjusted for Covariate"
  adam_db$adtte$COL_LABEL <- factor(rep(col_split, nrow(adam_db$adtte)), levels = col_split)

  tbl <- build_table(lyt, adam_db$adtte)

  tbl
}

#' `COXT01` Layout
#'
#' @inheritParams coxt01_main
#' @param variables (`list`) list of variables in a Cox proportional hazards regression model.
#' @returns a `PreDataTableLayouts` object.
#' @keywords internal
#'
coxt01_lyt <- function(variables,
                       col_split,
                       lbl_vars,
                       control,
                       multivar,
                       ...) {
  lyt <- basic_table() %>%
    ifneeded_split_col(col_split)
  lyt <- execute_with_args(
    summarize_coxreg,
    lyt = lyt, variables = variables, control = control, multivar = multivar, ...
  )
  lyt %>%
    append_topleft(lbl_vars)
}

#' @describeIn coxt01 Preprocessing
#'
#' @inheritParams coxt01_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
coxt01_pre <- function(adam_db, arm_var = "ARM", ...) {
  adam_db$adtte <- adam_db$adtte %>%
    mutate(EVENT = 1 - .data$CNSR) %>%
    mutate(!!arm_var := forcats::fct_drop(!!sym(arm_var)))

  adam_db
}

#' @describeIn coxt01 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
coxt01_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `COXT01` (Default) Cox Regression Model Table.
#'
#' Cox models are the most commonly used methods to estimate the magnitude of the effect in survival analyses.
#' It assumes proportional hazards; that is, it assumes that the ratio of the hazards
#' of the two groups (e.g. two arms) is constant over time.
#' This ratio is referred to as the "hazard ratio" and is one of the most commonly reported metrics
#' to describe the effect size in survival analysis.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' library(dunlin)
#'
#' proc_data <- log_filter(syn_data, PARAMCD == "CRSD", "adtte")
#' proc_data <- log_filter(proc_data, ARMCD != "ARM C", "adsl")
#' run(coxt01, proc_data)
#'
#' run(coxt01, proc_data, covariates = c("SEX", "AAGE"), strata = c("RACE"), conf_level = 0.90)
coxt01 <- chevron_t(
  main = coxt01_main,
  preprocess = coxt01_pre,
  postprocess = coxt01_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.
#' @returns the main function returns an `rtables` object.
#'
#' @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 death_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.
#' @returns a `PreDataTableLayouts` object.
#'
#' @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_with_overall(arm_var, 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") %>%
      analyze_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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @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
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
dtht01_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(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
)

# ttet01 ----

#' @describeIn ttet01 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 summarize_event (`flag`) should the event description be displayed, 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 ... Further arguments passed to `control_surv_time()`, `control_coxph()`, `control_survtp()`, and
#'  `surv_timepoint()`. For details, see the documentation in `tern`. Commonly used arguments include `pval_method`,
#'  `conf_level`, `conf_type`, `quantiles`, `ties`, `time_point`, `method`, etc.
#' @returns the main function returns an `rtables` object.
#'
#' @details
#' * No overall value.
#'
#' @export
#'
ttet01_main <- function(adam_db,
                        dataset = "adtte",
                        arm_var = "ARM",
                        ref_group = NULL,
                        summarize_event = TRUE,
                        perform_analysis = "unstrat",
                        strata = NULL,
                        ...) {
  assert_string(dataset)
  assert_all_tablenames(adam_db, "adsl", dataset)
  assert_string(arm_var)
  assert_string(ref_group, null.ok = TRUE)
  assert_flag(summarize_event)
  assert_subset(perform_analysis, c("unstrat", "strat"))
  assert_character(
    strata,
    null.ok = !"strat" %in% perform_analysis,
    min.len = as.integer(!"strat" %in% perform_analysis)
  )
  anl <- adam_db[[dataset]]
  assert_single_value(anl$PARAMCD, label = sprintf("adam_db$%s$PARAMCD", dataset))
  df_label <- sprintf("adam_db$%s", dataset)
  assert_valid_variable(adam_db[[dataset]], c("IS_EVENT", "IS_NOT_EVENT"), types = list("logical"), label = df_label)
  assert_valid_variable(adam_db[[dataset]], "AVAL", types = list("numeric"), lower = 0, label = df_label)
  assert_valid_variable(
    adam_db[[dataset]], c("USUBJID", strata, "EVNT1", "EVNTDESC", "AVALU"),
    types = list(c("character", "factor")), label = df_label
  )
  assert_valid_variable(adam_db[[dataset]], arm_var, types = list("factor"), empty.levels.ok = FALSE, label = df_label)
  assert_subset(ref_group, lvls(adam_db[[dataset]][[arm_var]]))
  ref_group <- ref_group %||% lvls(anl[[arm_var]])[1]
  assert_single_value(anl$AVALU, label = sprintf("adam_db$%s$AVALU", dataset))

  timeunit <- unique(anl[["AVALU"]])
  event_lvls <- lvls(anl$EVNT1)

  control_survt <- execute_with_args(control_surv_time, ...)
  control_cox_ph <- execute_with_args(control_coxph, ...)
  control_survtp <- execute_with_args(control_surv_timepoint, ...)

  lyt <- ttet01_lyt(
    arm_var = arm_var,
    ref_group = ref_group,
    summarize_event = summarize_event,
    perform_analysis = perform_analysis,
    strata = strata,
    timeunit = timeunit,
    event_lvls = event_lvls,
    control_survt = control_survt,
    control_cox_ph = control_cox_ph,
    control_survtp = control_survtp,
    ...
  )

  tbl <- build_table(lyt, anl)

  tbl
}

#' `ttet01` Layout
#'
#' @inheritParams gen_args
#' @param timeunit (`string`) time unit get from `AVALU`, by default is `"Months"`
#'
#' @keywords internal
#'
ttet01_lyt <- function(arm_var,
                       ref_group,
                       summarize_event,
                       perform_analysis,
                       strata,
                       timeunit,
                       event_lvls,
                       control_survt,
                       control_cox_ph,
                       control_survtp,
                       ...) {
  lyt01 <- basic_table(show_colcounts = TRUE) %>%
    split_cols_by(
      var = arm_var, ref_group = ref_group
    ) %>%
    analyze_vars(
      vars = "IS_EVENT",
      .stats = "count_fraction",
      .labels = c(count_fraction = event_lvls[1])
    )

  if (summarize_event) {
    lyt01 <- lyt01 %>%
      split_rows_by(
        "EVNT1",
        split_label = "Earliest contributing event",
        split_fun = keep_split_levels(event_lvls[1]),
        label_pos = "visible",
        child_labels = "hidden",
        indent_mod = 1L,
      ) %>%
      analyze_vars("EVNTDESC", split_fun = drop_split_levels, .stats = "count")
  }

  lyt01 <- lyt01 %>%
    analyze_vars(
      vars = "IS_NOT_EVENT",
      .stats = "count_fraction",
      .labels = c(count_fraction = event_lvls[2]),
      nested = FALSE,
      show_labels = "hidden"
    ) %>%
    surv_time(
      vars = "AVAL",
      var_labels = paste0("Time to Event (", timeunit, ")"),
      is_event = "IS_EVENT",
      control = control_survt,
      table_names = "time_to_event"
    )

  for (perform in perform_analysis) {
    lyt01 <- lyt01 %>%
      coxph_pairwise(
        vars = "AVAL",
        is_event = "IS_EVENT",
        var_labels = if (perform == "strat") "Stratified Analysis" else "Unstratified Analysis",
        strata = if (perform == "strat") strata else NULL,
        control = control_cox_ph,
        table_names = if (perform == "strat") "coxph_stratified" else "coxph_unstratified"
      )
  }

  lyt <- execute_with_args(
    surv_timepoint,
    lyt = lyt01,
    is_event = "IS_EVENT",
    vars = "AVAL",
    var_labels = timeunit,
    control = control_survtp,
    ...,
    method = "both",
    time_point = c(6, 12),
    .labels = c("pt_at_risk" = render_safe("{Patient_label} remaining at risk"))
  )

  lyt
}

#' @describeIn ttet01 Preprocessing
#'
#' @inheritParams gen_args
#' @param dataset (`string`) the name of a table in the `adam_db` object.
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
ttet01_pre <- function(adam_db, dataset = "adtte",
                       ...) {
  adam_db[[dataset]] <- adam_db[[dataset]] %>%
    mutate(
      AVAL = convert_to_month(.data$AVAL, .data$AVALU),
      AVALU = "MONTHS",
      IS_EVENT = .data$CNSR == 0,
      IS_NOT_EVENT = .data$CNSR == 1,
      EVNT1 = factor(
        case_when(
          IS_EVENT == TRUE ~ render_safe("{Patient_label} with event (%)"),
          IS_EVENT == FALSE ~ render_safe("{Patient_label} without event (%)")
        ),
        levels = render_safe(c("{Patient_label} with event (%)", "{Patient_label} without event (%)"))
      ),
      EVNTDESC = factor(.data$EVNTDESC)
    )

  adam_db
}

#' @describeIn ttet01 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
ttet01_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `TTET01` Binary Outcomes Summary.
#'
#' `TTET01` 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 == "PFS", "adtte")
#' run(ttet01, proc_data)
#'
#' run(ttet01, proc_data,
#'   summarize_event = FALSE, perform_analysis = c("unstrat", "strat"),
#'   strata = c("STRATA1", "STRATA2"),
#'   conf_type = "log-log",
#'   time_point = c(6, 12),
#'   method = "both"
#' )
ttet01 <- chevron_t(
  main = ttet01_main,
  preprocess = ttet01_pre,
  postprocess = ttet01_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.
#' @returns the main function returns an `rtables` object.
#'
#' @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(c("character", "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_with_overall(arm_var, lbl_overall) %>%
    split_rows_by_recursive(
      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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @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
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
lbt04_post <- function(tlg, ...) {
  std_postprocessing(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
)

# pdt01 ----

#' @describeIn pdt01 Main TLG function
#'
#' @inheritParams gen_args
#' @param dvcode_var (`string`) the variable defining the protocol deviation coded term. By default `DVDECOD`.
#' @param dvterm_var (`string`) the variable defining the protocol deviation term. By default `DVTERM`.
#' @returns the main function returns an `rtables` object.
#'
#' @details
#'  * Data should be filtered for major protocol deviations. `(DVCAT == "MAJOR")`.
#'  * 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.
#'
#' @note
#'  * `adam_db` object must contain an `addv` table with the columns specified in `dvcode_var` and `dvterm_var` as well
#'  as `"DVSEQ"`.
#'
#' @export
#'
pdt01_main <- function(adam_db,
                       arm_var = "ARM",
                       lbl_overall = NULL,
                       dvcode_var = "DVDECOD",
                       dvterm_var = "DVTERM",
                       ...) {
  assert_all_tablenames(adam_db, c("adsl", "addv"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_string(dvcode_var)
  assert_string(dvterm_var)
  assert_valid_variable(adam_db$addv, c(dvcode_var, dvterm_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$addv, "USUBJID", types = list(c("character", "factor")), empty_ok = TRUE)
  assert_valid_var_pair(adam_db$adsl, adam_db$addv, arm_var)

  lbl_overall <- render_safe(lbl_overall)
  lbl_dvcode_var <- var_labels_for(adam_db$addv, dvcode_var)
  lbl_dvterm_var <- var_labels_for(adam_db$addv, dvterm_var)

  lyt <- pdt01_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    dvcode_var = dvcode_var,
    lbl_dvcode_var = lbl_dvcode_var,
    dvterm_var = dvterm_var,
    lbl_dvterm_var = lbl_dvterm_var
  )

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

  tbl
}

#' `pdt01` Layout
#'
#' @inheritParams gen_args
#' @inheritParams pdt01_main
#' @param lbl_dvcode_var (`string`) label for the variable defining the protocol deviation coded term.
#' @param lbl_dvterm_var (`string`) label for the variable defining the protocol deviation term.
#'
#' @keywords internal
#'
pdt01_lyt <- function(arm_var,
                      lbl_overall,
                      dvcode_var,
                      lbl_dvcode_var,
                      dvterm_var,
                      lbl_dvterm_var) {
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    summarize_num_patients(
      var = "USUBJID",
      .stats = c("unique", "nonunique"),
      .labels = c(
        unique = render_safe("Total number of {patient_label} with at least one major protocol deviation"),
        nonunique = "Total number of major protocol deviations"
      ),
      .formats = list(unique = format_count_fraction_fixed_dp)
    ) %>%
    split_rows_by(
      dvcode_var,
      child_labels = "visible",
      nested = FALSE,
      indent_mod = -1L,
      split_fun = drop_split_levels,
      label_pos = "topleft",
      split_label = lbl_dvterm_var
    ) %>%
    count_occurrences(vars = dvterm_var) %>%
    append_topleft(paste0("  Description"))
}

#' @describeIn pdt01 Preprocessing
#'
#' @inheritParams pdt01_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
pdt01_pre <- function(adam_db, ...) {
  adam_db$addv <- adam_db$addv %>%
    mutate(across(all_of(c("DVDECOD", "DVTERM")), ~ reformat(.x, nocoding))) %>%
    mutate(
      DVDECOD = with_label(.data$DVDECOD, "Protocol Deviation Coded Term"),
      DVTERM = with_label(.data$DVTERM, "Category")
    )

  adam_db %>%
    dunlin::log_filter(.data$DVCAT == "MAJOR", "addv")
}

#' @describeIn pdt01 Postprocessing
#'
#' @inheritParams pdt01_main
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
pdt01_post <- function(tlg, prune_0 = TRUE, dvcode_var = "DVDECOD", dvterm_var = "DVTERM", ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }

  tbl_sorted <- tlg %>%
    sort_at_path(
      path = c(dvcode_var, "*", dvterm_var),
      scorefun = score_occurrences
    )

  std_postprocessing(tbl_sorted)
}

#' `pdt01` Major Protocol Deviations Table.
#'
#' A major protocol deviations
#' table with the number of subjects and the total number of treatments by medication class sorted alphabetically and
#' medication name sorted by frequencies.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(pdt01, syn_data)
pdt01 <- chevron_t(
  main = pdt01_main,
  preprocess = pdt01_pre,
  postprocess = pdt01_post
)

# 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.
#' @returns the main function returns an `rtables` object.
#'
#' @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_with_overall(arm_var, 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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
lbt14_pre <- function(adam_db,
                      gr_missing = "incl",
                      direction = "low",
                      ...) {
  if (identical(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 if (identical(direction, "low")) {
    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
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
lbt14_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) tlg <- tlg %>% trim_rows()
  std_postprocessing(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
)

# lbt05 ----

#' @describeIn lbt05 Main TLG function
#'
#' @inheritParams gen_args
#' @returns the main function returns an `rtables` object.
#'
#' @details
#'  * Does not remove rows with zero counts by default.
#'  * Lab test results with missing `AVAL` values are excluded.
#'  * Split columns by arm, typically `ACTARM`.
#'
#' @note
#'  * `adam_db` object must contain an `adlb` table with columns `"ONTRTFL"`, `"PARCAT2"`, `"PARAM"`, `"ANRIND"`,
#'  `"AVALCAT1"`, and column specified by `arm_var`.
#'
#' @export
#'
lbt05_main <- function(adam_db,
                       arm_var = "ACTARM",
                       lbl_overall = NULL,
                       ...) {
  assert_all_tablenames(adam_db, c("adsl", "adlb"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  # expand.grid steps requires levels later.
  assert_valid_variable(adam_db$adlb, c("PARAM", "AVALCAT1", "ABN_DIR"), types = list("factor"))
  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_anrind <- var_labels_for(adam_db$adlb, "ABN_DIR")
  lbl_param <- var_labels_for(adam_db$adlb, "PARAM")

  map <- expand.grid(
    PARAM = levels(adam_db$adlb$PARAM),
    ABN_DIR = c("Low", "High"),
    stringsAsFactors = FALSE
  ) %>%
    arrange(.data$PARAM, desc(.data$ABN_DIR))

  lyt <- lbt05_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_param = lbl_param,
    lbl_anrind = lbl_anrind,
    map = map
  )

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

  tbl
}

#' `lbt05` Layout
#'
#' @inheritParams gen_args
#'
#' @param lbl_param (`string`) label of the `PARAM` variable.
#' @param lbl_anrind (`string`) label of the `ANRIND` variable.
#' @param map (`data.frame`) mapping of `PARAM`s to directions of abnormality.
#'
#' @keywords internal
#'
lbt05_lyt <- function(arm_var,
                      lbl_overall,
                      lbl_param,
                      lbl_anrind,
                      map) {
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    split_rows_by(
      "PARAM",
      label_pos = "topleft",
      split_label = lbl_param
    ) %>%
    summarize_num_patients(var = "USUBJID", .stats = "unique_count") %>%
    split_rows_by("ABN_DIR", split_fun = trim_levels_to_map(map)) %>%
    count_abnormal_by_marked(
      var = "AVALCAT1",
      variables = list(id = "USUBJID", param = "PARAM", direction = "ABN_DIR"),
      .formats = c("count_fraction" = format_count_fraction_fixed_dp)
    ) %>%
    append_topleft(paste("   ", lbl_anrind))
}

#' @describeIn lbt05 Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
lbt05_pre <- function(adam_db, ...) {
  adam_db$adlb <- adam_db$adlb %>%
    filter(
      .data$ONTRTFL == "Y",
      .data$PARCAT2 == "LS",
      !is.na(.data$AVAL)
    ) %>%
    mutate(ABN_DIR = factor(case_when(
      ANRIND == "LOW LOW" ~ "Low",
      ANRIND == "HIGH HIGH" ~ "High",
      TRUE ~ ""
    ), levels = c("Low", "High"))) %>%
    mutate(
      ABN_DIR = with_label(.data$ABN_DIR, "Direction of Abnormality"),
      PARAM = with_label(.data$PARAM, "Laboratory Test")
    ) %>%
    mutate(
      across(all_of(c("AVALCAT1", "ABN_DIR")), ~ reformat(.x, missing_rule, .drop = FALSE))
    )

  adam_db
}

#' @describeIn lbt05 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
lbt05_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    has_lbl <- function(lbl) CombinationFunction(function(tr) obj_label(tr) == lbl)
    tlg <- prune_table(tlg, keep_rows(has_lbl("Any Abnormality")))

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

  std_postprocessing(tlg)
}

#' `LBT05` Table 1 (Default) Laboratory Abnormalities with Single and Replicated Marked.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(lbt05, syn_data)
lbt05 <- chevron_t(
  main = lbt05_main,
  preprocess = lbt05_pre,
  postprocess = lbt05_post
)

# aet04 ----

#' @describeIn aet04 Main TLG function
#'
#' @inheritParams gen_args
#' @param grade_groups (`list`) putting in correspondence toxicity grades and labels.
#' @returns the main function returns an `rtables` object.
#'
#' @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.
#' @returns a `PreDataTableLayouts` object.
#' @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_with_overall(arm_var, 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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @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
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @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_postprocessing(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
)

# egt02_1 ----

#' @describeIn egt02_1 Main TLG function
#'
#' @inheritParams gen_args
#' @param exclude_base_abn (`flag`) whether baseline abnormality should be excluded.
#' @returns the main function returns an `rtables` object
#'
#' @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.
#' @returns a `PreDataTableLayouts` object.
#'
#' @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_with_overall(arm_var, 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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
egt02_pre <- function(adam_db, ...) {
  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
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
egt02_post <- function(tlg, ...) {
  std_postprocessing(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
)

#' Creates `NULL` Report
#'
#' @param tlg to convert to null report.
#' @param ind (`integer`) indentation for the outputs of class `VTableTree`.
#' @param ... not used.
#'
#' @rdname report_null
#' @name report_null
#'
#' @returns the `tlg` object or a `NULL` report if the `tlg` is `NULL`, is a `TableTree` with 0 rows, is a `listing_df`
#'   with 0 rows or is a `list` with 0 elements.
#'
#' @export
#' @examples
#' report_null(NULL)
setGeneric("report_null", function(tlg, ...) {
  standardGeneric("report_null")
})

#' @rdname report_null
setMethod("report_null", "NULL", function(tlg, ind = 2L, ...) {
  res <- standard_null_report()
  table_inset(res) <- ind
  res
})

#' @rdname report_null
setMethod("report_null", "VTableTree", function(tlg, ind = 2L, ...) {
  res <- if (nrow(tlg) == 0L || count_children(tlg) == 0) {
    standard_null_report()
  } else {
    tlg
  }

  table_inset(res) <- ind
  res
})

#' @rdname report_null
setMethod("report_null", "listing_df", function(tlg, ind = 2L, ...) {
  if (nrow(tlg) == 0L) {
    res <- standard_null_report()
    table_inset(res) <- ind
    res
  } else {
    tlg
  }
})

#' @rdname report_null
setMethod("report_null", "list", function(tlg, ind = 2L, ...) {
  if (length(tlg) == 0) {
    res <- standard_null_report()
    table_inset(res) <- ind
    res
  } else {
    tlg
  }
})

#' @rdname report_null
setMethod("report_null", "ANY", function(tlg, ...) {
  tlg
})

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

#' Standard Post Processing
#'
#' @param tlg to post process.
#' @param ... additional arguments passed to [report_null].
#'
#' @returns a processed `tlg` or a null report.
#' @export
#' @examples
#' library(rtables)
#' std_postprocessing(build_table(basic_table() |> analyze("Species"), iris), ind = 10L)
#'
std_postprocessing <- function(tlg, ...) {
  tlg <- report_null(tlg, ...)
  tlg
}

# kmg01 ----

#' @describeIn kmg01 Main TLG Function
#'
#' @details
#'  * No overall value.
#'
#' @inheritParams gen_args
#' @param dataset (`string`) the name of a table in the `adam_db` object.
#' @param strata (`character`) the variable name of stratification variables.
#' @param strat (`character`) `r lifecycle::badge("deprecated")`; for backwards compatibility only.
#' Use `strata` instead.
#' @param ... Further arguments passed to `g_km` and `control_coxph`. For details, see
#' the documentation in `tern`.
#' Commonly used arguments include `col`, `pval_method`, `ties`, `conf_level`, `conf_type`,
#' `annot_coxph`, `annot_stats`, etc.
#' @returns the main function returns a `gTree` object.
#'
#' @note
#'  * `adam_db` object must contain the table specified by `dataset` with the columns specified by  `arm_var`.
#'
#' @returns a `gTree` object.
#' @export
kmg01_main <- function(adam_db,
                       dataset = "adtte",
                       arm_var = "ARM",
                       strata = NULL,
                       strat = lifecycle::deprecated(),
                       ...) {
  assert_all_tablenames(adam_db, c("adsl", dataset))
  df_lbl <- paste0("adam_db$", dataset)
  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)
  if (lifecycle::is_present(strat)) {
    lifecycle::deprecate_warn(
      when = "0.2.6",
      what = "kmg01_main(strat)",
      with = "km01_main(strata)"
    )
    strata <- strat
  }
  assert_valid_variable(adam_db[[dataset]], strata, types = list(c("character", "factor")), label = df_lbl)
  assert_valid_variable(
    adam_db[[dataset]],
    c("PARAMCD", arm_var),
    types = list(c("character", "factor")),
    na_ok = FALSE,
    label = df_lbl
  )
  assert_single_value(adam_db[[dataset]]$PARAMCD, label = paste0(df_lbl, "$PARAMCD"))
  assert_valid_variable(adam_db[[dataset]], "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
  variables <- list(tte = "AVAL", is_event = "IS_EVENT", arm = arm_var, strata = strata)
  control_cox <- execute_with_args(control_coxph, ...)
  control_surv <- execute_with_args(control_surv_timepoint, ...)
  execute_with_args(
    g_km,
    df = adam_db[[dataset]],
    variables = variables,
    control_surv = control_surv,
    control_coxph_pw = control_cox,
    ...
  )
}

#' @describeIn kmg01 Preprocessing
#'
#' @inheritParams kmg01_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
kmg01_pre <- function(adam_db, dataset = "adtte", ...) {
  adam_db[[dataset]] <- adam_db[[dataset]] %>%
    mutate(IS_EVENT = .data$CNSR == 0)

  adam_db
}

# `kmg01` Pipeline ----

#' `KMG01` Kaplan-Meier Plot 1.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' library(dplyr)
#' library(dunlin)
#'
#' col <- c(
#'   "A: Drug X" = "black",
#'   "B: Placebo" = "blue",
#'   "C: Combination" = "gray"
#' )
#'
#' pre_data <- log_filter(syn_data, PARAMCD == "OS", "adtte")
#' run(kmg01, pre_data, dataset = "adtte", col = col)
kmg01 <- chevron_g(
  main = kmg01_main,
  preprocess = kmg01_pre
)

# egt05_qtcat ----

#' @describeIn egt05_qtcat Main TLG function
#'
#' @inheritParams gen_args
#' @param summaryvars (`character`) variables to be analyzed. The label attribute of the corresponding column in `adeg`
#'   table of `adam_db` is used as name.
#' @returns the main function returns an `rtables` object.
#'
#' @details
#'  * The `Value at Visit` column, displays the categories of the specific `"PARAMCD"` value for patients.
#'  * The `Change from Baseline` column, displays the categories of the specific `"PARAMCD"` value
#'  change from baseline for patients.
#'  * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
#'  * Split columns by arm, typically `"ACTARM"`.
#'  * Does not include a total column by default.
#'  * Sorted based on factor level; by chronological time point given by `"AVISIT"`
#'  or user-defined visit incorporating `"ATPT"`.
#'  Re-level to customize order.
#'  * Please note that it is preferable to convert `summaryvars` to factor.
#'
#' @note
#'  * `adam_db` object must contain an `adeg` table with column specified in `visitvar`.
#'  For `summaryvars`, please make sure `AVALCAT1` and `CHGCAT1` columns existed in input data sets.
#'
#' @export
#'
egt05_qtcat_main <- function(adam_db,
                             arm_var = "ACTARM",
                             lbl_overall = NULL,
                             summaryvars = c("AVALCAT1", "CHGCAT1"),
                             row_split_var = NULL,
                             visitvar = "AVISIT",
                             page_var = NULL,
                             ...) {
  assert_all_tablenames(adam_db, c("adsl", "adeg"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_character(summaryvars)
  assert_character(row_split_var, null.ok = TRUE)
  assert_string(visitvar)
  assert_string(page_var, null.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")))
  assert_valid_variable(adam_db$adeg, c("PARAM", "PARAMCD"), types = list(c("character", "factor")), na_ok = FALSE)
  assert_valid_variable(adam_db$adeg, visitvar, types = list("character", "factor"))
  assert_disjunct(row_split_var, c("PARAMCD", "PARAM", visitvar))
  assert_valid_variable(adam_db$adeg, summaryvars, types = list(c("factor", "character")), na_ok = TRUE)
  assert_subset(page_var, c(row_split_var, "PARAMCD"))

  lbl_overall <- render_safe(lbl_overall)
  lbl_avisit <- var_labels_for(adam_db$adeg, visitvar)
  lbl_param <- var_labels_for(adam_db$adeg, "PARAM")
  summaryvars_lbls <- var_labels_for(adam_db$adeg, summaryvars) # Value at visit / change from baseline
  row_split_lbl <- var_labels_for(adam_db$adeg, row_split_var)

  lyt <- egt05_qtcat_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_avisit = lbl_avisit,
    lbl_param = lbl_param,
    lbl_cat = "Category",
    summaryvars = summaryvars,
    summaryvars_lbls = summaryvars_lbls,
    row_split_var = row_split_var,
    row_split_lbl = row_split_lbl,
    visitvar = visitvar,
    page_var = page_var
  )

  build_table(
    lyt,
    df = adam_db$adeg,
    alt_counts_df = adam_db$adsl
  )
}

#' `EGT05_QTCAT` Layout
#'
#' @inheritParams gen_args
#'
#' @param lbl_avisit (`string`) label of the `visitvar` variable.
#' @param lbl_param (`string`) label of the `PARAM` variable.
#' @param lbl_cat (`string`) label of the Category of `summaryvars` variable. Default as `Category`.
#' @param summaryvars (`character`) the variables to be analyzed. `AVALCAT1` and `CHGCAT1` by default.
#' @param summaryvars_lbls (`character`) the label of the variables to be analyzed.
#' @param visitvar (`string`) typically `"AVISIT"` or user-defined visit incorporating `"ATPT"`.
#' @returns a `PreDataTableLayouts` object.
#'
#' @keywords internal
#'
egt05_qtcat_lyt <- function(arm_var,
                            lbl_overall,
                            lbl_avisit,
                            lbl_param,
                            lbl_cat,
                            summaryvars,
                            summaryvars_lbls,
                            row_split_var,
                            row_split_lbl,
                            visitvar,
                            page_var) {
  page_by <- get_page_by(page_var, c(row_split_var, "PARAMCD"))
  label_pos <- ifelse(page_by, "hidden", "topleft")
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    split_rows_by_recursive(
      row_split_var,
      split_label = row_split_lbl,
      label_pos = head(label_pos, -1L), page_by = head(page_by, -1L)
    ) %>%
    split_rows_by(
      var = "PARAMCD",
      labels_var = "PARAM",
      split_fun = drop_split_levels,
      label_pos = tail(label_pos, 1L),
      split_label = lbl_param,
      page_by = tail(page_by, 1L)
    ) %>%
    split_rows_by(
      visitvar,
      split_fun = drop_split_levels,
      split_label = lbl_avisit,
      label_pos = "topleft"
    ) %>%
    summarize_vars_allow_na(
      vars = summaryvars,
      var_labels = summaryvars_lbls,
      inclNAs = FALSE
    ) %>%
    append_topleft(paste0(stringr::str_dup(" ", sum(!page_by) * 2 + 2), lbl_cat))
}

#' @describeIn egt05_qtcat Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#'
#' @export
#'
egt05_qtcat_pre <- function(adam_db, ...) {
  adam_db$adeg <- adam_db$adeg %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(
      AVALCAT1 = reformat(.data$AVALCAT1, empty_rule),
      CHGCAT1 = reformat(.data$CHGCAT1, empty_rule),
      AVISIT = reorder(.data$AVISIT, .data$AVISITN),
      AVISIT = with_label(.data$AVISIT, "Analysis Visit")
    )
  adam_db
}

#' @describeIn egt05_qtcat Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#'
#' @export
#'
egt05_qtcat_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) tlg <- smart_prune(tlg)
  std_postprocessing(tlg)
}

#' `EGT05_QTCAT` ECG Actual Values and Changes from Baseline by Visit Table.
#'
#' The `EGT05_QTCAT` table summarizes several electrocardiogram parameters and their evolution
#' throughout the study.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(egt05_qtcat, syn_data)
egt05_qtcat <- chevron_t(
  main = egt05_qtcat_main,
  preprocess = egt05_qtcat_pre,
  postprocess = egt05_qtcat_post
)

# dmt01 ----

#' @describeIn dmt01 Main TLG function
#'
#' @inheritParams gen_args
#' @param summaryvars (`character`) variables summarized in demographic table. The label attribute of the corresponding
#'   column in `adsl` table of `adam_db` is used as label.
#' @param stats (named `list` of character)  where names of columns found in `.df_row` and the values indicate the
#'   statistical analysis to perform. If `default` is set, and parameter precision not specified, the
#'   value for `default` will be used.
#' @param precision (named `list` of `integer`) where names are `strings` found in `summaryvars` and the values indicate
#'   the number of digits in statistics for numeric variables. If `default` is set, and parameter precision not
#'   specified, the value for `default` will be used. If neither are provided, auto determination is used. See
#'   [`tern::format_auto`].
#' @returns the main function returns an `rtables` object.
#'
#' @details
#'  * Information from `ADSUB` are generally included into `ADSL` before analysis.
#'  * Default demographic and characteristics table
#'  * If not specified otherwise, numbers represent absolute numbers of patients and fraction of `N`
#'  * Remove zero-count rows
#'  * Split columns by arm (planned or actual / code or description)
#'  * Include a total column by default
#'
#' @note
#'  * `adam_db` object must contain an `adsl` table with the columns specified in `summaryvars`.
#'
#' @export
#'
dmt01_main <- function(adam_db,
                       arm_var = "ARM",
                       lbl_overall = "All {Patient_label}",
                       summaryvars = c(
                         "AAGE",
                         "AGEGR1",
                         "SEX",
                         "ETHNIC",
                         "RACE"
                       ),
                       stats = list(default = c("n", "mean_sd", "median", "range", "count_fraction")),
                       precision = list(),
                       ...) {
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_character(summaryvars, null.ok = TRUE)
  assert_valid_variable(adam_db$adsl, summaryvars, na_ok = TRUE)
  assert_valid_variable(adam_db$adsl, summaryvars, types = list(c("numeric", "factor", "logical")))
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
  assert_list(stats, types = "character")
  assert_list(precision, types = "integerish", names = "unique")

  lbl_overall <- render_safe(lbl_overall)
  summaryvars_lbls <- var_labels_for(adam_db$adsl, summaryvars)

  lyt <- dmt01_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    summaryvars = summaryvars,
    summaryvars_lbls = summaryvars_lbls,
    stats = stats,
    precision = precision
  )

  tbl <- build_table(lyt, adam_db$adsl)

  tbl
}

#' `dmt01` Layout
#' @param summaryvars_lbls (`character`) labels corresponding to the analyzed variables.
#'
#' @inheritParams gen_args
#' @returns a `PreDataTableLayouts` object.
#' @keywords internal
#'
dmt01_lyt <- function(arm_var,
                      lbl_overall,
                      summaryvars,
                      summaryvars_lbls,
                      stats,
                      precision) {
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    analyze(
      vars = summaryvars,
      var_labels = summaryvars_lbls,
      afun = afun_p,
      extra_args = list(
        precision = precision,
        .stats = stats
      ),
      show_labels = "visible"
    )
}

#' @describeIn dmt01 Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
dmt01_pre <- function(adam_db, ...) {
  adam_db$adsl <- adam_db$adsl %>%
    mutate(SEX = reformat(.data$SEX, rule(Male = "M", Female = "F")))
  adam_db
}

#' @describeIn dmt01 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
dmt01_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `DMT01` Table 1 (Default) Demographics and Baseline Characteristics Table 1.
#'
#' For each variable, summary statistics are
#' by default based on the number of patients in the corresponding `n` row.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(dmt01, syn_data)
dmt01 <- chevron_t(
  main = dmt01_main,
  preprocess = dmt01_pre,
  postprocess = dmt01_post
)

# mng01 ----

#' @describeIn mng01 Main TLG Function
#'
#' @details
#'  * No overall value.
#'  * Preprocessing filters for `ANL01FL` in the selected data set.
#'
#' @inheritParams gen_args
#' @param dataset (`string`) the name of a table in the `adam_db` object.
#' @param x_var (`string`) the name of a column in the `dataset` to represent on the x-axis.
#' @param y_var (`string`) the name of the variable to be represented on the y-axis.
#' @param y_name (`string`) the variable name for `y`. Used for plot's subtitle.
#' @param y_unit (`string`) the name of the variable with the units of `y`. Used for plot's subtitle. if `NULL`, only
#'   `y_name` is displayed as subtitle.
#' @param center_fun (`string`) the function to compute the estimate value.
#' @param interval_fun (`string`) the function defining the crossbar range. If `NULL`, no crossbar is displayed.
#' @param jitter (`numeric`) the width of spread for data points on the x-axis; a number from 0 (no `jitter`) to 1 (high
#'   `jitter`), with a default of 0.3 (slight `jitter`).
#' @param line_col (`character`) describing the colors to use for the lines or a named `character` associating values of
#'   `arm_var` with color names.
#' @param line_type (`character`) describing the line type to use for the lines or a named `character` associating
#'   values of `arm_var` with line types.
#' @param ggtheme (`theme`) passed to [tern::g_lineplot()].
#' @param table (`character`) names of the statistics to be displayed in the table. If `NULL`, no table is displayed.
#' @param ... passed to [tern::g_lineplot()].
#' @returns the main function returns a `list` of `ggplot` objects.
#'
#' @note
#'  * `adam_db` object must contain the table specified by `dataset` with the columns specified by `x_var`, `y_var`,
#'  `y_name`, `y_unit` and `arm_var`.
#'
#' @seealso [gg_theme_chevron()], [tern::g_lineplot()].
#'
#' @returns a list of `ggplot` objects.
#'
#' @export
#'
mng01_main <- function(adam_db,
                       dataset = "adlb",
                       x_var = "AVISIT",
                       y_var = "AVAL",
                       y_name = "PARAM",
                       y_unit = NULL,
                       arm_var = "ACTARM",
                       center_fun = "mean",
                       interval_fun = "mean_ci",
                       jitter = 0.3,
                       line_col = nestcolor::color_palette(),
                       line_type = NULL,
                       ggtheme = gg_theme_chevron(),
                       table = c("n", center_fun, interval_fun),
                       ...) {
  center_fun_choice <- c("mean", "median")
  interval_fun_choice <- c("mean_ci", "mean_sei", "mean_sdi", "median_ci", "quantiles", "range")

  assert_all_tablenames(adam_db, c(dataset, "adsl"))
  assert_character(x_var)
  assert_string(y_var)
  assert_string(y_name)
  assert_string(y_unit, null.ok = TRUE)
  assert_string(arm_var)
  assert_string(center_fun)
  assert_string(interval_fun, null.ok = TRUE)
  assert_names(center_fun, subset.of = center_fun_choice)
  assert_choice(interval_fun, interval_fun_choice, null.ok = TRUE)
  assert_number(jitter, lower = 0, upper = 1)
  assert_class(ggtheme, "theme")
  assert_character(line_col, null.ok = TRUE)
  assert_character(line_type, null.ok = TRUE)
  assert_valid_variable(adam_db[[dataset]], x_var)
  assert_valid_variable(adam_db[[dataset]], y_var, types = list(c("numeric")))
  assert_valid_variable(adam_db[[dataset]], y_unit, types = list(c("character", "factor")))
  assert_valid_variable(adam_db[[dataset]], arm_var, types = list(c("character", "factor")), na_ok = FALSE)
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
  assert_valid_variable(adam_db[[dataset]], "USUBJID", types = list(c("character", "factor")), empty_ok = TRUE)
  assert_valid_var_pair(adam_db$adsl, adam_db[[dataset]], arm_var)
  assert_subset(table, c("n", center_fun_choice, interval_fun_choice))

  df <- adam_db[[dataset]]

  data_ls <- split(df, df$PARAM, drop = TRUE)
  x_var <- paste(x_var, collapse = "_")

  whiskers_fun <- if (is.null(interval_fun)) {
    NULL
  } else {
    switch(interval_fun,
      "mean_ci" = c("mean_ci_lwr", "mean_ci_upr"),
      "mean_sei" = c("mean_sei_lwr", "mean_sei_upr"),
      "mean_sdi" = c("mean_sdi_lwr", "mean_sdi_upr"),
      "median_ci" = c("median_ci_lwr", "median_ci_upr"),
      "quantiles" = c("quantiles_0.25", "quantile_0.75"),
      "range" = c("min", "max")
    )
  }


  y_unit <- if (is.null(y_unit)) NA else y_unit
  variables <- tern::control_lineplot_vars(
    x = x_var,
    y = y_var,
    group_var = arm_var,
    paramcd = y_name,
    y_unit = y_unit,
    subject_var = "USUBJID"
  )


  arm_lvl <- sort(unique(df[[arm_var]]))

  col <- if (!is.null(names(line_col))) {
    col_sel <- line_col[as.character(arm_lvl)]

    if (anyNA(col_sel)) {
      missing_col <- setdiff(arm_lvl, names(col_sel))
      stop(paste("Missing color matching for", toString(missing_col)))
    }

    unname(col_sel)
  } else {
    line_col
  }

  line_type <- if (!is.null(names(line_type))) {
    tp <- line_type[as.character(arm_lvl)]

    if (anyNA(tp)) {
      missing_tp <- setdiff(arm_lvl, names(tp))
      stop(paste("Missing line type matching for", toString(missing_tp)))
    }

    unname(tp)
  } else {
    line_type
  }




  lapply(
    data_ls,
    tern::g_lineplot,
    alt_counts_df = adam_db[["adsl"]],
    variables = variables,
    mid = center_fun,
    interval = interval_fun,
    whiskers = whiskers_fun,
    position = ggplot2::position_dodge(width = jitter),
    title = NULL,
    table = table,
    ggtheme = ggtheme,
    col = col,
    linetype = line_type,
    subtitle_add_unit = !is.na(y_unit),
    ...
  )
}

#' @describeIn mng01 Preprocessing
#'
#' @inheritParams mng01_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
mng01_pre <- function(adam_db, dataset, x_var = "AVISIT", ...) {
  assert_character(dataset)
  dunlin::assert_all_tablenames(adam_db, dataset)

  adam_db[[dataset]] <- adam_db[[dataset]] %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(
      AVISIT = reorder(.data$AVISIT, .data$AVISITN),
      AVISIT = with_label(.data$AVISIT, "Visit")
    )

  if (length(x_var) == 1 && is.numeric(adam_db[[dataset]][[x_var]])) {
    adam_db
  } else {
    dunlin::ls_unite(adam_db, dataset, cols = x_var, sep = "_")
  }
}

# `mng01` Pipeline ----

#' `MNG01` Mean Plot Graph.
#'
#' Overview of a summary statistics across time and arm for a selected data set.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' col <- c(
#'   "A: Drug X" = "black",
#'   "B: Placebo" = "blue",
#'   "C: Combination" = "gray"
#' )
#'
#' lt <- c(
#'   "A: Drug X" = "29",
#'   "B: Placebo" = "99",
#'   "C: Combination" = "solid"
#' )
#'
#' run(
#'   mng01,
#'   syn_data,
#'   dataset = "adlb",
#'   x_var = c("AVISIT", "AVISITN"),
#'   line_col = col,
#'   line_type = lt
#' )
mng01 <- chevron_g(
  main = mng01_main,
  preprocess = mng01_pre
)

# assert_single_value ----

#' Check variable only has one unique value.
#' @param x value vector.
#' @param label (`string`) label of input.
#' @returns invisible `NULL` or an error message if the criteria are not fulfilled.
#' @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.
#' @returns invisible `NULL` or an error message if the criteria are not fulfilled.
#' @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
#' @param tzs (`character`) time zones.
#' @export
assert_valid_var.POSIXct <- function(x,
                                     label = deparse(substitute(x)),
                                     na_ok = TRUE,
                                     empty_ok = FALSE,
                                     tzs = OlsonNames(),
                                     ...) {
  assert_posixct(
    x,
    min.len = as.integer(!empty_ok),
    any.missing = na_ok,
    .var.name = label,
    ...
  )

  extra_args <- list(...)

  # Test if time zone of x is in OlsonNames
  if (lubridate::tz(x) %in% tzs) {
    return(invisible(NULL))
  } else if (is(extra_args$add, "AssertCollection")) {
    extra_args$add$push(paste("Non standard timezone detected for", label, "!"))
  } else {
    abort(paste("Non standard timezone detected for", 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.
#' @returns invisible `TRUE` or an error message if the criteria are not fulfilled.
#' @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.
#' @returns invisible `NULL` or an error message if the criteria are not fulfilled.
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`.
#' @returns invisible `NULL` or an error message if the criteria are not fulfilled.
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), "!"
      )
    )
  }
}

# lbt07 ----

#' @describeIn lbt07 Main TLG function
#'
#' @inheritParams gen_args
#' @param param_var (`string`) the name of the column storing the parameters name.
#' @param grad_dir_var  (`string`) the name of the column storing the grade direction variable which  is required in
#'   order to obtain the correct denominators when building the layout as it is used to define row splitting.
#' @param grad_anl_var (`string`)  the name of the column storing toxicity grade variable where all negative values from
#'   `ATOXGR` are replaced by their absolute values.
#' @returns the main function returns an `rtables` object.
#'
#' @details
#'  * Split columns by arm, typically `ACTARM`.
#'
#' @note
#'  * `adam_db` object must contain an `adlb` table with columns `"USUBJID"`, `"ATOXGR"`,
#'  `"ONTRTFL"` and column specified by `arm_var`.
#'
#' @export
#'
lbt07_main <- function(adam_db,
                       arm_var = "ACTARM",
                       lbl_overall = NULL,
                       param_var = "PARAM",
                       grad_dir_var = "GRADE_DIR",
                       grad_anl_var = "GRADE_ANL",
                       ...) {
  assert_all_tablenames(adam_db, c("adsl", "adlb"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_string(param_var)
  assert_string(grad_dir_var)
  assert_string(grad_anl_var)
  assert_valid_variable(
    adam_db$adlb, c("ATOXGR", param_var, grad_dir_var, grad_anl_var),
    types = list(c("character", "factor"))
  )
  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 <- var_labels_for(adam_db$adlb, param_var)
  lbl_grad_dir_var <- var_labels_for(adam_db$adlb, grad_dir_var)

  map <- expand.grid(
    PARAM = levels(adam_db$adlb[[param_var]]),
    GRADE_DIR = c("LOW", "HIGH"),
    GRADE_ANL = as.character(1:4),
    stringsAsFactors = FALSE
  ) %>%
    arrange(.data$PARAM, desc(.data$GRADE_DIR), .data$GRADE_ANL)

  names(map) <- c(param_var, grad_dir_var, grad_anl_var)

  lyt <- lbt07_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    lbl_param_var = lbl_param_var,
    lbl_grad_dir_var = lbl_grad_dir_var,
    param_var = param_var,
    grad_dir_var = grad_dir_var,
    grad_anl_var = grad_anl_var,
    map = map
  )

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

  tbl
}

#' `lbt07` Layout
#'
#' @inheritParams gen_args
#' @inheritParams lbt07_main
#'
#' @param lbl_param_var (`string`) label of the `param_var` variable.
#' @param lbl_grad_dir_var (`string`) label for the `grad_dir_var` variable.
#' @param map (`data.frame`) mapping of `PARAM`s to directions of abnormality.
#'
#' @keywords internal
#'
lbt07_lyt <- function(arm_var,
                      lbl_overall,
                      lbl_param_var,
                      lbl_grad_dir_var,
                      param_var,
                      grad_dir_var,
                      grad_anl_var,
                      map) {
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    split_rows_by(
      param_var,
      label_pos = "topleft",
      split_label = lbl_param_var
    ) %>%
    summarize_num_patients(
      var = "USUBJID",
      required = "ATOXGR",
      .stats = "unique_count"
    ) %>%
    split_rows_by(
      grad_dir_var,
      label_pos = "topleft",
      split_label = lbl_grad_dir_var,
      split_fun = trim_levels_to_map(map)
    ) %>%
    count_abnormal_by_worst_grade(
      var = grad_anl_var,
      variables = list(id = "USUBJID", param = param_var, grade_dir = grad_dir_var),
      .formats = list(count_fraction = tern::format_count_fraction_fixed_dp),
      .indent_mods = 4L
    ) %>%
    append_topleft("            Highest NCI CTCAE Grade")
}

#' @describeIn lbt07 Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
lbt07_pre <- function(adam_db, ...) {
  adam_db$adlb <- adam_db$adlb %>%
    mutate(
      ATOXGR = reformat(.data$ATOXGR, missing_rule)
    ) %>%
    filter(
      .data$ATOXGR != "<Missing>",
      .data$ONTRTFL == "Y",
      .data$WGRLOFL == "Y" | .data$WGRHIFL == "Y"
    ) %>%
    mutate(
      GRADE_DIR = factor(
        case_when(
          ATOXGR %in% c("-1", "-2", "-3", "-4") & .data$WGRLOFL == "Y" ~ "LOW",
          ATOXGR == "0" ~ "ZERO",
          ATOXGR %in% c("1", "2", "3", "4") & .data$WGRHIFL == "Y" ~ "HIGH",
          TRUE ~ "NONE"
        ),
        levels = c("LOW", "ZERO", "HIGH", "NONE")
      ),
      GRADE_ANL = factor(.data$ATOXGR, levels = c(-4:4), labels = abs(c(-4:4))),
      PARAM = as.factor(trimws(stringr::str_remove_all(.data$PARAM, "\\(.+?\\)")))
    )

  adam_db$adlb <- adam_db$adlb %>%
    mutate(
      PARAM = with_label(.data$PARAM, "Parameter"),
      GRADE_DIR = with_label(.data$GRADE_DIR, "Direction of Abnormality"),
      GRADE_ANL = with_label(.data$GRADE_ANL, "Toxicity Grade")
    )

  adam_db
}

#' @describeIn lbt07 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
lbt07_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `LBT07` Table 1 (Default) Laboratory Test Results and Change from Baseline by Visit.
#'
#' The `LBT07` table provides an
#' overview of the analysis values and its change from baseline of each respective arm over the course of the trial.
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(lbt07, syn_data)
lbt07 <- chevron_t(
  main = lbt07_main,
  preprocess = lbt07_pre,
  postprocess = lbt07_post
)

#' Helper Function Extracting Layout Functions
#' @keywords internal
#'
h_unwrap_layout <- function(x, pattern) {
  assert_string(pattern)

  # If x is a list or a call, apply the function on each element
  if (inherits(x, c("list", "call", "<-", "if"))) {
    lapply(x, \(x) h_unwrap_layout(x, pattern))
  } else if (is(x, "name")) {
    # Return if name match pattern.

    if (grepl(pattern, x)) {
      res <- list(x)
      names(res) <- as.character(x)
      res
    } else {
      NULL
    }
  } else {
    NULL
  }
}

#' Extracting Layout Function.
#'
#' @param x (`function`) containing a call to a layout function.
#' @param pattern (`string`) identifying layout functions
#'
#' @returns invisible `NULL` and print the content of the layout functions found in the body of `x`.
#'
#' @export
#' @keywords internal
#' @examples
#' unwrap_layout(aet01_main)
#'
unwrap_layout <- function(x, pattern = "_lyt$") {
  checkmate::assert_function(x)
  checkmate::assert_string(pattern)

  # Identify environment of the parent function.
  env_x <- tryCatch(
    rlang::get_env(x),
    error = function(e) NULL
  )

  # Get the associated layout functions as name objects
  res <- unlist(h_unwrap_layout(body(x)[-1], pattern))

  if (length(res) > 0L) {
    cat("Layout function:")
    purrr::lmap(
      res,
      function(x) {
        # Evaluate layout function symbol in the environment of the parent function.
        tryCatch(
          {
            cat("\n")
            layout_code <- paste(deparse(eval(x[[1]], envir = env_x)), collapse = "\n")
            cat(sprintf("  %s:\n", names(x)))
            cat(layout_code)
          },
          error = function(e) cat("\n  Unable to print layout function!")
        )

        list()
      }
    )
  }
  cat("\n")
  invisible(NULL)
}

# mht01 ----

#' @describeIn mht01 Default labels
#' @export
mht01_label <- c(
  unique = "Total number of {patient_label} with at least one condition",
  nonunique = "Total number of conditions"
)

#' @describeIn mht01 Main TLG function
#'
#' @inheritParams gen_args
#' @param summary_labels (`list`) of summarize labels. See details.
#' @returns the main function returns an `rtables` object.
#'
#' @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`.
#'  * Split columns by arm.
#'  * Does not include a total column by default.
#'  * Order by `row_split_var` alphabetically and medical condition by decreasing total number of
#'  patients with the specific condition.
#'  `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 `admh` table with columns `"MHBODSYS"` and `"MHDECOD"`.
#'
#' @export
#'
mht01_main <- function(adam_db,
                       arm_var = "ARM",
                       row_split_var = "MHBODSYS",
                       lbl_overall = NULL,
                       summary_labels = list(
                         all = mht01_label
                       ),
                       ...) {
  assert_all_tablenames(adam_db, c("admh", "adsl"))
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_valid_variable(
    adam_db$admh,
    c(row_split_var, "MHDECOD"),
    types = list(c("character", "factor")),
    empty_ok = TRUE
  )
  assert_valid_variable(adam_db$admh, "USUBJID", types = list(c("character", "factor")), empty_ok = TRUE)
  assert_valid_variable(adam_db$adsl, "USUBJID", types = list(c("character", "factor")))
  assert_valid_var_pair(adam_db$adsl, adam_db$admh, 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")
  )
  summary_labels <- expand_list(summary_labels, c("TOTAL", row_split_var))

  lbl_overall <- render_safe(lbl_overall)
  lbl_row_split <- var_labels_for(adam_db$admh, row_split_var)
  lbl_mhdecod <- var_labels_for(adam_db$admh, "MHDECOD")

  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 = "MHDECOD",
    lbl_medname_var = lbl_mhdecod,
    summary_labels = summary_labels,
    count_by = "MHSEQ"
  )

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

  tbl
}

#' @describeIn mht01 Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
mht01_pre <- function(adam_db, ...) {
  adam_db$admh <- adam_db$admh %>%
    filter(.data$ANL01FL == "Y")

  adam_db$admh <- adam_db$admh %>%
    mutate(
      across(all_of(c("MHBODSYS", "MHDECOD")), ~ reformat(.x, nocoding))
    ) %>%
    mutate(
      MHBODSYS = with_label(.data$MHBODSYS, "MedDRA System Organ Class"),
      MHDECOD = with_label(.data$MHDECOD, "MedDRA Preferred Term"),
      MHSEQ = as.factor(.data$MHSEQ)
    )

  adam_db
}

#' @describeIn mht01 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
mht01_post <- function(tlg, row_split_var = "MHBODSYS", prune_0 = TRUE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }

  row_split_var <- c(rbind(row_split_var, "*"))

  tbl_sorted <- tlg %>%
    sort_at_path(
      path = c(row_split_var, "MHDECOD"),
      scorefun = score_occurrences
    )

  std_postprocessing(tbl_sorted)
}

#' `MHT01` Medical History Table.
#'
#' The `MHT01` table provides an overview of the subjects medical
#' history by SOC and Preferred Term.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(mht01, syn_data)
mht01 <- chevron_t(
  main = mht01_main,
  preprocess = mht01_pre,
  postprocess = mht01_post
)

# 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.
#' @returns the main function returns an `rtables` object.
#'
#' @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")
  )
  summary_labels <- expand_list(summary_labels, c("TOTAL", row_split_var))
  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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @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.
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @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_postprocessing(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
)

#' Check that all names are among column names
#'
#' @param df (`data.frame`)
#' @param x (`character`) the names of the columns to be checked.
#' @param null_ok (`flag`) can `x` be NULL.
#' @param qualifier (`string`) to be returned if the check fails.
#' @returns invisible `NULL` or a string if the criteria are not fulfilled.
#'
#' @keywords internal
check_all_colnames <- function(df, x, null_ok = TRUE, qualifier = NULL) {
  assert_data_frame(df)
  assert_character(x, null.ok = null_ok)
  assert_string(qualifier, null.ok = TRUE)

  diff <- setdiff(x, colnames(df))

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

#' Check that at least one name is among column names
#'
#' @param df (`data.frame`)
#' @param x (`character`) the names of the columns to be checked.
#' @param null_ok (`flag`) can `x` be NULL.
#' @param qualifier (`string`) to be returned if the check fails.
#' @returns invisible `NULL` or a string if the criteria are not fulfilled.
#'
#' @keywords internal
check_one_colnames <- function(df, x, null_ok = TRUE, qualifier = NULL) {
  assert_data_frame(df)
  assert_character(x, null.ok = null_ok)
  assert_string(qualifier, null.ok = TRUE)

  common <- intersect(x, colnames(df))

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

# rmpt01 ----

#' @describeIn rmpt01 Main TLG function
#'
#' @inheritParams gen_args
#' @param summaryvars (`string`) variables to be analyzed. The label attribute of the corresponding columns in `adex`
#'   table of `adam_db` is used as label.
#' @param show_tot (`flag`) whether to display the cumulative total.
#' @param row_split_var (`string`) the name of the column that containing variable to split exposure by.
#' @param col_split_var (`string`) additional column splitting variable.
#' @param overall_col_lbl (`string`) name of the overall column. If `NULL`, no overall level is added.
#' @returns the main function returns an `rtables` object.
#'
#' @details
#'   * Person time is the sum of exposure across all patients.
#'   * Summary statistics are by default based on the number of patients in the corresponding `N` row
#'   (number of non-missing values).
#'   * Does not remove zero-count rows unless overridden with `prune_0 = TRUE`.
#'
#' @note
#'   * `adam_db` object must contain an `adex` table with `"AVAL"` and the columns specified by `summaryvars`.
#'
#' @export
#'
rmpt01_main <- function(adam_db,
                        summaryvars = "AVALCAT1",
                        show_tot = TRUE,
                        row_split_var = NULL,
                        col_split_var = NULL,
                        overall_col_lbl = NULL,
                        ...) {
  assert_all_tablenames(adam_db, c("adsl", "adex"))
  assert_string(summaryvars)
  assert_flag(show_tot)
  assert_string(row_split_var, null.ok = TRUE)
  assert_string(col_split_var, null.ok = TRUE)
  assert_string(overall_col_lbl, null.ok = TRUE)
  assert_valid_variable(adam_db$adex, summaryvars, types = list(c("factor", "character")), empty_ok = TRUE)
  assert_valid_variable(adam_db$adex, "AVAL", types = list("numeric"), empty_ok = TRUE)
  assert_valid_variable(adam_db$adex, row_split_var, types = list(c("factor", "numeric")), empty_ok = TRUE)
  assert_valid_variable(adam_db$adex, col_split_var, types = list(c("factor", "character")))
  assert_valid_variable(adam_db$adex, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
  assert_valid_variable(adam_db$adsl, "USUBJID", types = list(c("character", "factor")))

  lbl_summaryvars <- var_labels_for(adam_db$adex, summaryvars)

  lyt <- rmpt01_lyt(
    summaryvars = summaryvars,
    lbl_summaryvars = lbl_summaryvars,
    show_tot = show_tot,
    row_split_var = row_split_var,
    col_split_var = col_split_var,
    overall_col_lbl = overall_col_lbl
  )

  build_table(lyt, adam_db$adex, alt_counts_df = adam_db$adsl)
}

#' `rmpt01` Layout
#'
#' @inheritParams gen_args
#' @inheritParams rmpt01_main
#' @param lbl_summaryvars (`character`) label associated with the analyzed variables.
#'
#' @keywords internal
#'
rmpt01_lyt <- function(summaryvars,
                       lbl_summaryvars,
                       show_tot,
                       row_split_var,
                       col_split_var,
                       overall_col_lbl) {
  lyt <- basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(col_split_var, overall_col_lbl) %>%
    split_cols_by_multivar(
      vars = c("AVAL", "AVAL"),
      varlabels = c(n_patients = render_safe("{Patient_label}"), sum_exposure = "Person time"),
      extra_args = list(.stats = c("n_patients", "sum_exposure"))
    ) %>%
    analyze_patients_exposure_in_cols(
      var = summaryvars,
      col_split = FALSE,
      add_total_level = show_tot,
      custom_label = render_safe("Total {patient_label} number/person time")
    )

  if (!is.null(row_split_var)) {
    lyt %>%
      split_rows_by(row_split_var) %>%
      analyze_patients_exposure_in_cols(
        .indent_mods = -1L,
        var = summaryvars,
        col_split = FALSE,
        add_total_level = show_tot,
        custom_label = render_safe("Total {patient_label} number/person time")
      ) %>%
      append_topleft(c("", lbl_summaryvars))
  } else {
    lyt %>%
      append_topleft(c("", lbl_summaryvars))
  }
}

#' @describeIn rmpt01 Preprocessing
#'
#' @inheritParams gen_args
#' @inheritParams rmpt01_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
rmpt01_pre <- function(adam_db,
                       summaryvars = "AVALCAT1",
                       ...) {
  adam_db$adex <- adam_db$adex %>%
    filter(.data$PARAMCD == "TDURD")
  adam_db$adex <- adam_db$adex %>%
    mutate(across(all_of(summaryvars), ~ reformat(.x, missing_rule))) %>%
    mutate(
      AVALCAT1 = with_label(.data$AVALCAT1, "Duration of exposure")
    )
  adam_db
}

#' @describeIn rmpt01 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
rmpt01_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `RMPT01`Duration of Exposure for Risk Management Plan Table.
#'
#' The `RMPT01` table provides an overview of duration of exposure.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(rmpt01, syn_data, col_split_var = "SEX")
rmpt01 <- chevron_t(
  main = rmpt01_main,
  preprocess = rmpt01_pre,
  postprocess = rmpt01_post
)

# egt03 ----
#' @describeIn egt03 Main TLG function
#'
#' @param arm_var (`character`) the arm variables used for row split, typically `"ACTARMCD"`.
#' @param summaryvar (`character`) variables to be analyzed, typically `"BNRIND"`. Labels of the corresponding columns
#'   are used as subtitles.
#' @param splitvar (`character`) variables to be analyzed, typically `"ANRIND"`. Labels of the corresponding columns are
#'   used as subtitles.
#' @returns the main function returns an `rtables` object.
#'
#' @details
#'  * `ADEG` data are subsetted to contain only "POST-BASELINE MINIMUM"/"POST-BASELINE MAXIMUM" visit
#'  according to the preprocessing.
#'  * Percentages are based on the total number of patients in a treatment group.
#'  * Split columns by Analysis Reference Range Indicator, typically `ANRIND`.
#'  * Does not include a total column by default.
#'  * Sorted  based on factor level.
#'
#' @note
#'  * `adam_db` object must contain an `adeg` table with a `"ACTARMCD"` column as well as columns specified in
#'  `summaryvar` and `splitvar`.
#'
#' @export
#'
egt03_main <- function(adam_db,
                       arm_var = "ACTARMCD",
                       summaryvar = "BNRIND",
                       splitvar = "ANRIND",
                       visitvar = "AVISIT",
                       page_var = "PARAMCD",
                       ...) {
  assert_all_tablenames(adam_db, c("adsl", "adeg"))
  assert_string(arm_var)
  assert_string(summaryvar)
  assert_string(splitvar)
  assert_string(visitvar)
  assert_string(page_var, null.ok = TRUE)
  assert_subset(page_var, "PARAMCD")
  assert_valid_variable(adam_db$adeg, summaryvar, types = list("character", "factor"))
  assert_valid_variable(adam_db$adeg, c("PARAMCD", "PARAM", splitvar), types = list("character", "factor"))
  assert_single_value(adam_db$adeg[[visitvar]])
  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_armvar <- var_labels_for(adam_db$adeg, arm_var)
  lbl_summaryvars <- var_labels_for(adam_db$adeg, summaryvar)
  lbl_splitvar <- var_labels_for(adam_db$adeg, splitvar)
  lbl_param <- var_labels_for(adam_db$adeg, "PARAM")

  lyt <- egt03_lyt(
    arm_var = arm_var,
    splitvar = splitvar,
    summaryvar = summaryvar,
    lbl_armvar = lbl_armvar,
    lbl_summaryvars = lbl_summaryvars,
    lbl_param = lbl_param,
    page_var = page_var
  )
  adam_db$adeg$SPLIT_LABEL <- factor(rep(lbl_splitvar, nrow(adam_db$adeg)), levels = lbl_splitvar)

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

  tbl
}

#' `egt03` Layout
#'
#' @inheritParams gen_args
#' @inheritParams egt03_main
#'
#' @param lbl_armvar (`string`) label of the `arm_var` variable.
#' @param lbl_summaryvars (`string`) label of the `summaryvar` variable.
#' @returns a `PreDataTableLayouts` object.
#'
#' @keywords internal
#'
egt03_lyt <- function(arm_var,
                      splitvar,
                      summaryvar,
                      lbl_armvar,
                      lbl_summaryvars,
                      lbl_param,
                      page_var) {
  page_by <- !is.null(page_var)
  indent <- 2L
  space <- stringr::str_dup(" ", indent * (1L + !page_by))
  lbl_summaryvars <- paste0(space, lbl_summaryvars)

  basic_table(show_colcounts = FALSE) %>%
    split_cols_by("SPLIT_LABEL") %>%
    split_cols_by(splitvar) %>%
    split_rows_by(
      "PARAMCD",
      labels_var = "PARAM",
      page_by = page_by,
      split_fun = drop_split_levels,
      split_label = lbl_param,
      label_pos = if (page_by) "hidden" else "topleft"
    ) %>%
    split_rows_by(arm_var,
      split_fun = drop_split_levels,
      label_pos = "topleft",
      split_label = lbl_armvar
    ) %>%
    add_rowcounts() %>%
    analyze_vars(
      summaryvar,
      denom = "N_row", .stats = "count_fraction",
      .formats = list(count_fraction = format_count_fraction_fixed_dp)
    ) %>%
    append_topleft(lbl_summaryvars)
}

#' @describeIn egt03 Preprocessing
#'
#' @inheritParams gen_args
#' @inheritParams egt03_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#'
#' @export
#'
egt03_pre <- function(adam_db, ...) {
  adam_db$adeg <- adam_db$adeg %>%
    filter(
      .data$AVISIT == "POST-BASELINE MINIMUM"
    ) %>%
    mutate(BNRIND = factor(
      .data$BNRIND,
      levels = c("LOW", "NORMAL", "HIGH", "Missing"),
      labels = c("LOW", "NORMAL", "HIGH", "Missing")
    )) %>%
    mutate(ANRIND = factor(
      .data$ANRIND,
      levels = c("LOW", "NORMAL", "HIGH", "Missing"),
      labels = c("LOW", "NORMAL", "HIGH", "Missing")
    )) %>%
    mutate(
      BNRIND = with_label(.data$BNRIND, "Baseline Reference Range Indicator"),
      ANRIND = with_label(.data$ANRIND, "Minimum Post-Baseline Assessment")
    )

  adam_db
}

#' @describeIn egt03 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#'
#' @export
#'
egt03_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) tlg <- smart_prune(tlg)

  std_postprocessing(tlg)
}

#' `EGT03` Shift Table of ECG Interval Data - Baseline versus Minimum or Maximum Post-Baseline.
#'
#' The `EGT03` Table entries provide the number of patients by baseline assessment and minimum or maximum post-baseline
#' assessment. Percentages are based on the total number of patients in a treatment group. Baseline is the patient's
#' last observation prior to initiation of study drug.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' library(dunlin)
#'
#' proc_data <- log_filter(syn_data, PARAMCD == "HR", "adeg")
#' run(egt03, proc_data)
egt03 <- chevron_t(
  main = egt03_main,
  preprocess = egt03_pre,
  postprocess = egt03_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.
#' @returns the main function returns an `rtables` object.
#'
#' @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")
  )
  summary_labels <- expand_list(summary_labels, c("TOTAL", row_split_var))

  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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @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
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @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_postprocessing(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
)

# ael02_main ----

#' @describeIn ael02 Main TLG function
#'
#' @inheritParams gen_args
#' @returns the main function returns an `rlistings` or a `list` object.
#' @export
#'
ael02_main <- modify_default_args(std_listing,
  dataset = "adae",
  key_cols = c("ID", "ASR"),
  disp_cols = c(
    "AEDECOD", "TRTSDTM", "ASTDY", "ADURN", "AESER",
    "ASEV", "AREL", "AEOUT", "AECONTRT", "AEACN"
  ),
  split_into_pages_by_var = "ACTARM"
)

#' @describeIn ael02 Preprocessing
#'
#' @inheritParams ael02_main
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
ael02_pre <- function(adam_db,
                      dataset = "adae",
                      arm_var = "ACTARM",
                      ...) {
  adam_db[[dataset]] <- adam_db[[dataset]] %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(
      across(
        all_of(c(arm_var, "AEDECOD", "ASEV", "AEOUT", "AEACN")),
        ~ reformat(.x, missing_rule)
      )
    ) %>%
    mutate(
      !!arm_var := with_label(.data[[arm_var]], "Treatment"),
      ID = create_id_listings(.data$SITEID, .data$SUBJID),
      ASR = with_label(paste(.data$AGE, .data$SEX, .data$RACE, sep = "/"), "Age/Sex/Race"),
      TRTSDTM = with_label(
        .data$TRTSDTM,
        "Date of\nFirst Study\nDrug\nAdministration"
      ),
      AEDECOD = with_label(reformat(.data$AEDECOD, nocoding), "Adverse\nEvent MedDRA\nPreferred Term"),
      ASTDY = with_label(.data$ASTDY, "Study\nDay of\nOnset"),
      ADURN = with_label(.data$ADURN, "AE\nDuration\nin Days"),
      AESER = with_label(reformat(.data$AESER, yes_no_rule), "Serious"),
      ASEV = with_label(.data$ASEV, "Most\nExtreme\nIntensity"),
      AREL = with_label(reformat(.data$AREL, yes_no_rule), "Caused by\nStudy\nDrug"),
      AEOUT = with_label(reformat(.data$AEOUT, outcome_rule), "Outcome\n(1)"),
      AECONTRT = with_label(reformat(.data$AECONTRT, yes_no_rule), "Treatment\nfor AE"),
      AEACN = with_label(reformat(.data$AEACN, dose_change_rule), "Action\nTaken\n(2)")
    )

  adam_db
}

#' `AEL02` Listing 1 (Default) Listing of Adverse Events.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' res <- run(ael02, syn_data)
ael02 <- chevron_l(
  main = ael02_main,
  preprocess = ael02_pre
)

# aet01 ----

#' @describeIn aet01 Main TLG function
#'
#' @inheritParams gen_args
#' @param anl_vars Named (`list`) of (`character`) variables the safety variables to be summarized.
#' @param show_wd (`flag`) whether to display the number of patients withdrawn from study due to an adverse event and
#'   the number of death.
#' @param anl_lbls (`character`) of analysis labels.
#' @returns the main function returns an `rtables` object.
#'
#' @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",
                       show_wd = TRUE,
                       ...) {
  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_flag(show_wd)
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")), empty_ok = TRUE)
  assert_valid_variable(
    adam_db$adsl,
    c("DTHFL", "DCSREAS"),
    types = list(c("character", "factor")),
    min_chars = 0L, empty_ok = TRUE
  )
  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
  )

  if (show_wd) {
    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)
    )
  } else {
    rbind(
      build_table(lyts$ae1, adam_db$adae, 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.
#' @returns a `PreDataTableLayouts` object.
#' @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_with_overall(arm_var, 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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#'
#' @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
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#'
#' @export
#'
aet01_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `AET01` Table 1 (Default) Overview of Deaths and Adverse Events Summary Table 1.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(aet01, syn_data, arm_var = "ARM")
aet01 <- chevron_t(
  main = aet01_main,
  preprocess = aet01_pre,
  postprocess = aet01_post
)

# aet03 ----

#' @describeIn aet03 Main TLG function
#'
#' @inheritParams gen_args
#' @returns the main function returns an `rtables` object.
#'
#' @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.
#' @returns a `PreDataTableLayouts` object.
#' @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_with_overall(arm_var, 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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @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
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @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_postprocessing(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
)

# vst02_1 ----

#' @describeIn vst02_1 Main TLG function
#'
#' @inheritParams gen_args
#' @param exclude_base_abn (`flag`) whether baseline abnormality should be excluded.
#' @returns the main function returns an `rtables` object.
#'
#' @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 `advs` table with the `"PARAM"`, `"ANRIND"` and `"BNRIND"` columns.
#'
#' @export
#'
vst02_1_main <- function(adam_db,
                         arm_var = "ACTARM",
                         lbl_overall = NULL,
                         exclude_base_abn = FALSE,
                         ...) {
  assert_all_tablenames(adam_db, "adsl", "advs")
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_flag(exclude_base_abn)
  assert_valid_variable(adam_db$advs, c(arm_var, "PARAM", "ANRIND", "BNRIND"), 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$advs, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
  assert_valid_var_pair(adam_db$adsl, adam_db$advs, arm_var)

  lbl_overall <- render_safe(lbl_overall)
  lbl_vs_assessment <- var_labels_for(adam_db$advs, "PARAM")
  lbl_vs_abnormality <- var_labels_for(adam_db$advs, "ANRIND")

  lyt <- vst02_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    exclude_base_abn = exclude_base_abn,
    lbl_vs_assessment = lbl_vs_assessment,
    lbl_vs_abnormality = lbl_vs_abnormality
  )

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

  tbl
}

#' `vst02_1` 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
#'
vst02_lyt <- function(arm_var,
                      lbl_overall,
                      exclude_base_abn,
                      lbl_vs_assessment,
                      lbl_vs_abnormality) {
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, 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 vst02_1 Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
vst02_pre <- function(adam_db, ...) {
  high_low_format <- rule(
    HIGH = c("HIGH HIGH", "HIGH"),
    LOW = c("LOW LOW", "LOW")
  )

  adam_db$advs <- adam_db$advs %>%
    filter(.data$ONTRTFL == "Y") %>%
    mutate(
      PARAM = with_label(.data$PARAM, "Assessment"),
      ANRIND = with_label(reformat(.data$ANRIND, high_low_format), "Abnormality"),
      BNRIND = reformat(.data$BNRIND, high_low_format)
    )

  adam_db
}

#' @describeIn vst02_1 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
vst02_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `VST02` Vital Sign Abnormalities Table.
#'
#' Vital Sign Parameters outside Normal Limits Regardless of Abnormality at Baseline.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(vst02_1, syn_data)
vst02_1 <- chevron_t(
  main = vst02_1_main,
  preprocess = vst02_pre,
  postprocess = vst02_post
)

# vst02_2 ----

#' @describeIn vst02_2 Main TLG function
#'
#' @inherit vst02_1_main
#'
#' @export
#'
vst02_2_main <- modify_default_args(vst02_1_main, exclude_base_abn = TRUE)
#' `VST02` Vital Sign Abnormalities Table.
#'
#' Vital Sign Parameters outside Normal Limits Among Patients without Abnormality at Baseline.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(vst02_2, syn_data)
vst02_2 <- chevron_t(
  main = vst02_2_main,
  preprocess = vst02_pre,
  postprocess = vst02_post
)

# lbt06 ----

#' @describeIn lbt06 Main TLG function
#'
#' @inheritParams gen_args
#' @param arm_var (`string`) the arm variable used for arm splitting.
#' @returns the main function returns an `rtables` object.
#'
#' @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 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_with_overall(arm_var, 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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
lbt06_pre <- function(adam_db, ...) {
  adam_db$adlb <- adam_db$adlb %>%
    filter(
      .data$ONTRTFL == "Y",
      .data$PARCAT2 == "SI"
    ) %>%
    mutate(
      across(all_of(c("ANRIND", "BNRIND")), ~ reformat(.x, 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
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
lbt06_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(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
)

# 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 ... 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 `gp`, `col_symbol_size`, `col`, `vline`, `groups_lists`, `conf_level`,
#'  `method`, `label_all`, etc.
#' @returns the main function returns a `gTree` object.
#'
#' @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`.
#'
#' @returns 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"),
                        ...) {
  assert_all_tablenames(adam_db, c("adsl", dataset))
  df_lbl <- paste0("adam_db$", dataset)
  assert_string(arm_var)
  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 = strata_var
  )

  df <- execute_with_args(extract_survival_subgroups,
    variables = variables,
    data = adam_db[[dataset]],
    ...
  )
  result <- basic_table() %>%
    tabulate_survival_subgroups(df, vars = stat_var, time_unit = timeunit)
  execute_with_args(
    g_forest,
    tbl = result,
    ...,
    font_size = 7
  )
}

#' @describeIn fstg02 Preprocessing
#'
#' @inheritParams fstg02_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#'
#' @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,
  preprocess = fstg02_pre
)

# aet01_aesi ----

#' @describeIn aet01_aesi Main TLG function
#'
#' @inheritParams gen_args
#' @param aesi_vars (`character`) the `AESI` variables to be included in the summary. Defaults to `NA`.
#' @param grade_groups (`list`) the grade groups to be displayed.
#' @returns the main function returns an `rtables` object.
#' @details
#'  * Does not remove rows with zero counts by default.
#'
#' @note
#'  * `adam_db` object must contain an `adae` table with columns `"AEOUT"`, `"AEACN"`, `"AECONTRT"`, `"AESER"`,
#'  `"AREL"`, and the column specified by `arm_var`.
#'  * `aesi_vars` may contain any/all of the following variables to display: `"ALLRESWD"`, `"ALLRESDSM"`,
#'  `"ALLRESCONTRT"`, `"NOTRESWD"`, `"NOTRESDSM"`, `"NOTRESCONTRT"`, `"SERWD"`, `"SERDSM"`, `"SERCONTRT"`,
#'  `"RELWD"`, `"RELDSM"`, `"RELCONTRT"`, `"RELSER"`.
#'  * `aesi_vars` variable prefixes are defined as follows:
#'    * `"ALLRES"` = "all non-fatal adverse events resolved"
#'    * `"NOTRES"` = "at least one unresolved or ongoing non-fatal adverse event"
#'    * `"SER"` = "serious adverse event"
#'    * `"REL"` = "related adverse event"
#'  * `aesi_vars` variable suffixes are defined as follows:
#'    * `"WD"` = "patients with study drug withdrawn"
#'    * `"DSM"` = "patients with dose modified/interrupted"
#'    * `"CONTRT"` = "patients with treatment received"
#'  * Several `aesi_vars` can be added to the table at once:
#'    * `aesi_vars = "ALL"` will include all possible `aesi_vars`.
#'    * Including `"ALL_XXX"` in `aesi_vars` where `XXX` is one of the prefixes listed above will include all
#'    `aesi_vars` with that prefix.
#'
#' @export
#'
aet01_aesi_main <- function(adam_db,
                            arm_var = "ACTARM",
                            lbl_overall = NULL,
                            aesi_vars = NULL,
                            grade_groups = NULL,
                            ...) {
  assert_all_tablenames(adam_db, "adsl", "adae")
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_character(aesi_vars, null.ok = TRUE)
  assert_list(grade_groups, null.ok = TRUE)
  assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var))
  assert_valid_variable(adam_db$adae, c(arm_var))
  assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE)
  assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)

  if (is.null(grade_groups)) {
    grade_groups <- list(
      "Grade 1" = "1",
      "Grade 2" = "2",
      "Grade 3" = "3",
      "Grade 4" = "4",
      "Grade 5 (fatal outcome)" = "5"
    )
  }
  all_aesi_vars <- get_aesi_vars(aesi_vars)
  assert_valid_variable(adam_db$adae, c(all_aesi_vars), empty_ok = TRUE, na_ok = TRUE, types = list("logical"))

  lbl_overall <- render_safe(lbl_overall)
  lbl_aesi_vars <- var_labels_for(adam_db$adae, all_aesi_vars)

  lyt <- aet01_aesi_lyt(
    arm_var = arm_var,
    aesi_vars = all_aesi_vars,
    lbl_overall = lbl_overall,
    lbl_aesi_vars = lbl_aesi_vars,
    grade_groups = grade_groups
  )

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

  tbl
}

#' `aet01_aesi` Layout
#'
#' @inheritParams gen_args
#' @param lbl_aesi_vars (`character`) the labels of the `AESI` variables to be summarized.
#' @returns a `PreDataTableLayouts` object.
#' @keywords internal
#'
aet01_aesi_lyt <- function(arm_var,
                           aesi_vars,
                           lbl_overall,
                           lbl_aesi_vars,
                           grade_groups) {
  names(lbl_aesi_vars) <- aesi_vars
  basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    count_patients_with_event(
      vars = "USUBJID",
      filters = c("ANL01FL" = "Y"),
      denom = "N_col",
      .labels = c(count_fraction = render_safe("Total number of {patient_label} with at least one AE"))
    ) %>%
    count_values(
      "ANL01FL",
      values = "Y",
      .stats = "count",
      .labels = c(count = "Total number of AEs"),
      table_names = "total_aes"
    ) %>%
    count_occurrences_by_grade(
      var = "ATOXGR",
      var_labels = render_safe("Total number of {patient_label} with at least one AE by worst grade"),
      show_labels = "visible",
      grade_groups = grade_groups
    ) %>%
    count_patients_with_flags(
      "USUBJID",
      flag_variables = lbl_aesi_vars,
      denom = "N_col"
    )
}

#' @describeIn aet01_aesi Preprocessing
#'
#' @inheritParams aet01_aesi_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#'
#' @export
#'
aet01_aesi_pre <- function(adam_db,
                           ...) {
  adam_db$adae <- adam_db$adae %>%
    filter(.data$ANL01FL == "Y") %>%
    mutate(
      NOT_RESOLVED = with_label(
        .data$AEOUT %in% c("NOT RECOVERED/NOT RESOLVED", "RECOVERING/RESOLVING", "UNKNOWN"),
        "Total number of {patient_label} with at least one unresolved or ongoing non-fatal AE"
      ),
      ALL_RESOLVED = with_label(
        !.data$AEOUT %in% "FATAL" & !.data$NOT_RESOLVED,
        "Total number of {patient_label} with all non-fatal AEs resolved"
      ),
      WD = with_label(
        .data$AEACN %in% "DRUG WITHDRAWN", "Total number of {patient_label} with study drug withdrawn due to AE"
      ),
      DSM = with_label(
        .data$AEACN %in% c("DRUG INTERRUPTED", "DOSE INCREASED", "DOSE REDUCED"),
        "Total number of {patient_label} with dose modified/interrupted due to AE"
      ),
      CONTRT = with_label(
        .data$AECONTRT %in% "Y", "Total number of {patient_label} with treatment received for AE"
      ),
      SER = with_label(
        .data$AESER %in% "Y", "Total number of {patient_label} with at least one serious AE"
      ),
      REL = with_label(
        .data$AREL %in% "Y", "Total number of {patient_label} with at least one related AE"
      ),
      ALLRESWD = with_label(
        .data$WD & .data$ALL_RESOLVED, "  No. of {patient_label} with study drug withdrawn due to resolved AE"
      ),
      ALLRESDSM = with_label(
        .data$DSM & .data$ALL_RESOLVED, "  No. of {patient_label} with dose modified/interrupted due to resolved AE"
      ),
      ALLRESCONTRT = with_label(
        .data$CONTRT & .data$ALL_RESOLVED, "  No. of {patient_label} with treatment received for resolved AE"
      ),
      NOTRESWD = with_label(
        .data$WD & .data$NOT_RESOLVED,
        "  No. of {patient_label} with study drug withdrawn due to unresolved or ongoing AE"
      ),
      NOTRESDSM = with_label(
        .data$DSM & .data$NOT_RESOLVED,
        "  No. of {patient_label} with dose modified/interrupted due to unresolved or ongoing AE"
      ),
      NOTRESCONTRT = with_label(
        .data$CONTRT & .data$NOT_RESOLVED,
        "  No. of {patient_label} with treatment received for unresolved/ongoing AE"
      ),
      SERWD = with_label(
        .data$SER & .data$WD, "  No. of {patient_label} with study drug withdrawn due to serious AE"
      ),
      SERDSM = with_label(
        .data$SER & .data$DSM, "  No. of {patient_label} with dose modified/interrupted due to serious AE"
      ),
      SERCONTRT = with_label(
        .data$SER & .data$CONTRT, "  No. of {patient_label} with treatment received for serious AE"
      ),
      RELWD = with_label(
        .data$REL & .data$WD, "  No. of {patient_label} with study drug withdrawn due to related AE"
      ),
      RELDSM = with_label(
        .data$REL & .data$DSM, "  No. of {patient_label} with dose modified/interrupted due to related AE"
      ),
      RELCONTRT = with_label(
        .data$REL & .data$CONTRT, "  No. of {patient_label} with treatment received for related AE"
      ),
      RELSER = with_label(
        .data$REL & .data$SER, "  No. of {patient_label} with serious, related AE"
      )
    ) %>%
    mutate(
      ATOXGR = factor(.data$ATOXGR, levels = 1:5)
    )

  adam_db
}

#' @describeIn aet01_aesi Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#'
#' @export
#'
aet01_aesi_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `AET01_AESI` Table 1 (Default) Adverse Event of Special Interest Summary Table.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(aet01_aesi, syn_data)
aet01_aesi <- chevron_t(
  main = aet01_aesi_main,
  preprocess = aet01_aesi_pre,
  postprocess = aet01_aesi_post
)

#' @keywords internal
get_aesi_vars <- function(aesi_vars) {
  if ("ALL" %in% aesi_vars) aesi_vars <- c("ALL_ALLRES", "ALL_NOTRES", "ALL_SER", "ALL_REL")
  if (any(grepl("^ALL_", aesi_vars))) {
    aesi <- c(grep("^ALL_", aesi_vars, value = TRUE, invert = TRUE), sapply(
      c("WD", "DSM", "CONTRT"),
      function(x) sub("^(ALL_)(.*)", paste0("\\2", x), grep("^ALL_", aesi_vars, value = TRUE))
    ))
    if ("ALL_REL" %in% aesi_vars) aesi <- c(aesi, "RELSER")
  } else {
    aesi <- aesi_vars
  }
  all_aesi_vars <- c(
    "WD", "DSM", "CONTRT", "ALL_RESOLVED", grep("^ALLRES", aesi, value = TRUE),
    "NOT_RESOLVED", grep("^NOTRES", aesi, value = TRUE), "SER", grep("^SER", aesi, value = TRUE),
    "REL", grep("^REL", aesi, value = TRUE)
  )
  return(all_aesi_vars)
}

# ael01_nollt ----

#' @describeIn ael01_nollt Main TLG function
#'
#' @inheritParams std_listing
#' @returns the main function returns an `rlistings` or a `list` object.
#'
#' @details
#'  * Removes duplicate rows.
#'  * By default, uses dataset `adae`, sorting by key columns `AEBODSYS` and `AEDECOD`.
#'  * If using with a dataset other than `adae`, be sure to specify the desired labels for variables in
#'    `key_cols` and `disp_cols`, and pre-process missing data.
#'
#' @note
#'  * `adam_db` object must contain the `dataset` table with columns specified by `key_cols` and `disp_cols`.
#'
#' @export
#'
ael01_nollt_main <- modify_default_args(
  std_listing,
  dataset = "adae",
  key_cols = c("AEBODSYS", "AEDECOD"),
  disp_cols = "AETERM",
  split_into_pages_by_var = NULL,
  unique_rows = TRUE
)

#' @describeIn ael01_nollt Preprocessing
#'
#' @inheritParams ael01_nollt_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#'
#' @export
#'
ael01_nollt_pre <- function(adam_db,
                            dataset = "adae",
                            key_cols = c("AEBODSYS", "AEDECOD"),
                            disp_cols = "AETERM",
                            ...) {
  adam_db[[dataset]] <- adam_db[[dataset]] %>%
    mutate(
      across(all_of(c(key_cols, disp_cols)), ~ reformat(.x, nocoding))
    ) %>%
    arrange(pick(all_of(c(key_cols, disp_cols))))

  adam_db
}

#' `AEL01_NOLLT` Listing 1 (Default) Glossary of Preferred Terms and Investigator-Specified Terms.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(ael01_nollt, syn_data)
ael01_nollt <- chevron_l(
  main = ael01_nollt_main,
  preprocess = ael01_nollt_pre
)

# 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`
#' @returns the main function returns an `rtables` object.
#'
#' @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
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @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
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
rspt01_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(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
)

#' No Coding Available rule
#' @export
nocoding <- rule("No Coding Available" = c("", NA))

#' Missing rule
#' @export
missing_rule <- rule("<Missing>" = c("", NA), .drop = TRUE)

#' Empty rule
#' @export
empty_rule <- rule(.to_NA = "")

#' Yes/No rule in title case
#' @export
yes_no_rule <- rule("Yes" = c("Y", "YES", "y", "yes"), "No" = c("N", "NO", "n", "no")) # nolint

#' Outcome Rule
#' @export
outcome_rule <- rule(
  "1" = "FATAL",
  "2" = "NOT RECOVERED/NOT RESOLVED",
  "3" = "RECOVERED/RESOLVED",
  "4" = "RECOVERED/RESOLVED WITH SEQUELAE",
  "5" = "RECOVERING/RESOLVING",
  "6" = "UNKNOWN"
)

#' Dose Change Rule
#' @export
dose_change_rule <- rule(
  "1" = "DOSE INCREASED",
  "2" =  "DOSE NOT CHANGED",
  "3" = c("DOSE REDUCED", "DOSE RATE REDUCED"),
  "4" =  "DRUG INTERRUPTED",
  "5" = "DRUG WITHDRAWN",
  "6" = c("NOT APPLICABLE", "NOT EVALUABLE"),
  "7" = "UNKNOWN"
)

#' Get grade rule
#' @param direction (`string`) of abnormality direction.
#' @param missing (`string`) method to deal with missing
#' @returns a `rule` object.
#' @export
get_grade_rule <- function(direction = "high", missing = "incl") {
  assert_choice(direction, c("high", "low"))
  assert_choice(missing, c("incl", "gr_0", "excl"))
  rule_arg <- list()
  if (direction == "high") {
    rule_arg[["Not High"]] <- c("0", "-1", "-2", "-3", "-4")
    rule_arg[as.character(1:4)] <- as.character(1:4)
  } else {
    rule_arg[["Not Low"]] <- c("0", "1", "2", "3", "4")
    rule_arg[as.character(1:4)] <- as.character(-1:-4)
  }
  if (missing == "incl") {
    rule_arg$Missing <- c(NA, "", "<Missing>")
  } else if (missing == "gr_0") {
    rule_arg[[1]] <- c(rule_arg[[1]], NA, "")
  }
  rule(.lst = rule_arg)
}

# lbt01 ----

#' @describeIn lbt01 Main TLG function
#'
#' @inherit cfbt01_main
#'
#' @include cfbt01.R
#' @returns the main function returns an `rtables` object.
#'
#' @export
#'
lbt01_main <- modify_default_args(cfbt01_main, dataset = "adlb", precision = quote(lab_paramcd_precision()))

#' @describeIn lbt01 Preprocessing
#'
#' @inherit cfbt01_pre
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
lbt01_pre <- modify_default_args(cfbt01_pre, dataset = "adlb")

#' `LBT01` Lab Results and Change from Baseline by Visit Table.
#'
#' The `LBT01` table provides an
#' overview of the Lab values and its change from baseline of each respective arm
#' over the course of the trial.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(lbt01, syn_data)
lbt01 <- chevron_t(
  main = lbt01_main,
  preprocess = lbt01_pre,
  postprocess = cfbt01_post
)



#' @describeIn lbt01
#'
#' @returns a named `list` with the precision of each lab parameter code (default is `2`).
#' @export
#' @examples
#' # example code
#' head(lab_paramcd_precision())
#'
lab_paramcd_precision <- function() {
  no_suffix <- c(
    HCRIT = 2,
    HGB = 0,
    WBC = 1,
    PLATE = 0,
    MCH = 1,
    MCHC = 0,
    MCV = 0,
    RBC = 2,
    BANDS = 2,
    BANDSF = 2,
    BASOS = 2,
    BASOSF = 2,
    LYMPH = 2,
    LYMPHF = 2,
    MONOS = 2,
    MONOSF = 2,
    NEUTR = 2,
    NEUTRF = 2,
    EOSIN = 2,
    EOSINF = 2,
    PTINR = 2,
    APTT = 1,
    FIB = 2,
    AST = 0,
    LDH = 0,
    CPK = 0,
    CPKMB = 0,
    ALKPH = 0,
    ALT = 0,
    TBILI = 1,
    DBILI = 1,
    GGT = 0,
    BUN = 1,
    CREATN = 0,
    T3 = 2,
    T4 = 0,
    T4FREE = 0,
    TSH = 1,
    ALBUM = 1,
    TPROT = 0,
    TRIG = 2,
    CHOLES = 2,
    LDL = 2,
    HDL = 2,
    CHLOR = 0,
    POTAS = 1,
    SODIUM = 0,
    BICARB = 0,
    CALCUM = 2,
    PHOSAT = 2,
    FASTGL = 2,
    URACID = 0,
    USG = 3
  )

  # add suffixes to list name for each lab parameter code
  res <- c()
  for (i in c("SI", "CV", "LS")) {
    res <- c(res, setNames(no_suffix, paste0(names(no_suffix), i)))
  }

  as.list(res)
}

# dst01 ----

#' @describeIn dst01 Main TLG function
#'
#' @inheritParams gen_args
#' @param arm_var (`string`) variable. Usually one of `ARM`, `ACTARM`, `TRT01A`, or `TRT01A`.
#' @param study_status_var (`string`) variable used to define patient status. Default is `EOSSTT`, however can also be a
#'   variable name with the pattern `EOPxxSTT` where `xx` must be substituted by 2 digits referring to the analysis
#'   period.
#' @param detail_vars Named (`list`) of grouped display of `study_status_var`. The names must be subset of unique levels
#' of `study_status_var`.
#' @param trt_status_var (`string`) variable of treatment status.
#' @returns the main function returns an `rtables` object.
#' @details
#'  * Default patient disposition table summarizing the reasons for patients withdrawal.
#'  * Numbers represent absolute numbers of patients and fraction of `N`.
#'  * Remove zero-count rows.
#'  * Split columns by arm.
#'  * Include a total column by default.
#'  * Sort withdrawal reasons by alphabetic order.
#'
#' @note
#'  * `adam_db` object must contain an `adsl` table with the columns specified by `status_var` and `disc_reason_var`.
#'
#' @export
#'
dst01_main <- function(adam_db,
                       arm_var = "ARM",
                       lbl_overall = "All {Patient_label}",
                       study_status_var = "EOSSTT",
                       detail_vars = list(
                         Discontinued = c("DCSREAS")
                       ),
                       trt_status_var = NULL,
                       ...) {
  assert_all_tablenames(adam_db, "adsl")
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  assert_string(study_status_var)
  assert_list(detail_vars, types = "character", names = "unique")
  assert_string(trt_status_var, null.ok = TRUE)
  assert_valid_variable(
    adam_db$adsl,
    arm_var,
    types = list(c("character", "factor")), na_ok = TRUE
  )
  assert_valid_variable(
    adam_db$adsl, study_status_var,
    types = list(c("character", "factor")), na_ok = TRUE,
    empty_ok = FALSE, min_chars = 1L
  )
  status_var_lvls <- lvls(adam_db$adsl[[study_status_var]])
  assert_subset(names(detail_vars), choices = status_var_lvls)
  assert_valid_variable(
    adam_db$adsl,
    unlist(detail_vars),
    types = list(c("character", "factor")),
    na_ok = TRUE,
    empty_ok = TRUE,
    min_chars = 0L
  )
  assert_valid_variable(
    adam_db$adsl, trt_status_var,
    types = list(c("character", "factor")), na_ok = TRUE,
    empty_ok = TRUE, min_chars = 0L
  )

  lbl_overall <- render_safe(lbl_overall)
  detail_vars <- setNames(detail_vars[status_var_lvls], status_var_lvls)

  lyt <- dst01_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    study_status_var = study_status_var,
    detail_vars = detail_vars,
    trt_status_var = trt_status_var
  )
  build_table(lyt, adam_db$adsl)
}

#' `dst01` Layout
#'
#' @inheritParams dst01_main
#' @param study_status_var (`string`) variable used to define patient status. Default is `EOSSTT`, however can also be a
#'   variable name with the pattern `EOPxxSTT` where `xx` must be substituted by 2 digits referring to the analysis
#'   period.
#' @param detail_vars Named (`list`) of grouped display of `study_status_var`.
#' @returns a `PreDataTableLayouts` object.
#' @keywords internal
#'
dst01_lyt <- function(arm_var,
                      lbl_overall,
                      study_status_var,
                      detail_vars,
                      trt_status_var) {
  lyt <- basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall)

  for (n in names(detail_vars)) {
    lyt <- lyt %>%
      count_or_summarize(study_status_var, n, detail_vars[[n]])
  }

  if (!is.null(trt_status_var)) {
    lyt <- lyt %>%
      analyze_vars(
        trt_status_var,
        .stats = "count_fraction",
        denom = "N_col",
        .formats = list(count_fraction = format_count_fraction_fixed_dp),
        show_labels = "hidden",
        nested = FALSE
      )
  }

  lyt
}

#' @describeIn dst01 Preprocessing
#'
#' @inheritParams dst01_main
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
dst01_pre <- function(adam_db,
                      ...) {
  study_status_format <- rule(
    "Completed" = "COMPLETED",
    "Ongoing" = "ONGOING",
    "Discontinued" = "DISCONTINUED"
  )
  trt_status_format <- rule(
    "Completed Treatment" = "COMPLETED",
    "Ongoing Treatment" = "ONGOING",
    "Discontinued Treatment" = "DISCONTINUED"
  )
  dcsreas_grp_format <- rule(
    "Safety" = c("ADVERSE EVENT", "DEATH"),
    "Non-Safety" = c(
      "WITHDRAWAL BY SUBJECT", "LACK OF EFFICACY", "PROTOCOL VIOLATION",
      "WITHDRAWAL BY PARENT/GUARDIAN", "PHYSICIAN DECISION"
    )
  )
  adam_db$adsl <- adam_db$adsl %>%
    mutate(
      EOSSTT = reformat(.data$EOSSTT, study_status_format),
      EOTSTT = reformat(.data$EOTSTT, trt_status_format),
      DCSREASGP = reformat(.data$DCSREAS, dcsreas_grp_format),
      DCSREAS = reformat(.data$DCSREAS, empty_rule),
      STDONS = factor(
        case_when(
          EOTSTT == "Ongoing Treatment" & EOSSTT == "Ongoing" ~ "Alive: Ongoing",
          EOTSTT != "Ongoing Treatment" & EOSSTT == "Ongoing" ~ "Alive: In Follow-up",
          TRUE ~ NA_character_
        ),
        levels = c("Alive: Ongoing", "Alive: In Follow-up")
      )
    )
  adam_db
}

#' @describeIn dst01 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
dst01_post <- function(tlg, prune_0 = TRUE, ...) {
  if (prune_0) {
    tlg <- tlg %>%
      smart_prune()
  }
  std_postprocessing(tlg)
}

#' DST01 Table 1 (Default) Patient Disposition Table 1.
#'
#' The DST01 Disposition Table provides an overview of patients
#' study completion. For patients who discontinued the study a reason is provided.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(dst01, syn_data, detail_vars = list(Ongoing = "STDONS"))
#'
#' run(dst01, syn_data, detail_vars = list(Discontinued = "DCSREAS", Ongoing = "STDONS"))
#'
#' run(
#'   dst01, syn_data,
#'   detail_vars = list(
#'     Discontinued = c("DCSREASGP", "DCSREAS"),
#'     Ongoing = "STDONS"
#'   )
#' )
dst01 <- chevron_t(
  main = dst01_main,
  preprocess = dst01_pre,
  postprocess = dst01_post
)

# aet05 ----

#' @describeIn aet05 Main TLG function
#'
#' @inheritParams gen_args
#' @param dataset (`string`) the name of a table in the `adam_db` object.
#' @param arm_var (`string`) the arm variable used for arm splitting.
#' @param ... Further arguments passed to `tern::control_incidence_rate()`.
#' @returns the main function returns an `rtables` object.
#'
#' @details
#'  * Total patient-years at risk is the sum over all patients of the time intervals (in years).
#'  * Split columns by arm, typically `ACTARM`.
#'  * Split rows by parameter code.
#'  * `AVAL` is patient-years at risk.
#'  * `N_EVENTS` is the number of adverse events observed.
#'  * The table allows confidence level to be adjusted, default is 95%.
#'  * Keep zero count rows by default.
#'
#' @note
#'  * `adam_db` object must contain table named as `dataset` with the columns `"PARAMCD"`, `"PARAM"`,
#'  `"AVAL"`, and `"CNSR"`.
#'
#' @export
#'
aet05_main <- function(adam_db,
                       dataset = "adsaftte",
                       arm_var = "ACTARM",
                       lbl_overall = NULL,
                       ...) {
  assert_string(dataset)
  assert_all_tablenames(adam_db, "adsl", dataset)
  assert_string(arm_var)
  assert_string(lbl_overall, null.ok = TRUE)
  df_lbl <- paste0("adam_db$", 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, "PARAMCD", "PARAM"),
    types = list(c("character", "factor")), label = df_lbl
  )
  assert_valid_variable(adam_db[[dataset]], "AVAL", types = list("numeric"), lower = 0, na_ok = TRUE, label = df_lbl)
  assert_valid_variable(adam_db[[dataset]], "N_EVENTS",
    types = list("numeric"), integerish = TRUE, lower = 0L,
    label = df_lbl
  )
  assert_valid_var_pair(adam_db$adsl, adam_db[[dataset]], arm_var)

  lbl_overall <- render_safe(lbl_overall)
  control <- execute_with_args(control_incidence_rate, ...)

  lyt <- aet05_lyt(
    arm_var = arm_var,
    lbl_overall = lbl_overall,
    param_label = "PARAM",
    vars = "AVAL",
    n_events = "N_EVENTS",
    control = control
  )

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

  tbl
}

#' `aet05` Layout
#'
#' @inheritParams gen_args
#' @param param_label (`string`) variable for parameter code.
#' @param vars (`string`) variable for the primary analysis variable to be iterated over.
#' @param n_events (`string`) variable to count the number of events observed.
#' @param control (`list`) parameters for estimation details, specified by using the helper function
#' control_incidence_rate().
#' @returns a `PreDataTableLayouts` object.
#'
#' @keywords internal
#'
aet05_lyt <- function(arm_var,
                      lbl_overall,
                      param_label,
                      vars,
                      n_events,
                      control) {
  lyt <- basic_table(show_colcounts = TRUE) %>%
    split_cols_by_with_overall(arm_var, lbl_overall) %>%
    split_rows_by(param_label, split_fun = drop_split_levels) %>%
    estimate_incidence_rate(
      vars = vars,
      n_events = n_events,
      control = control
    )
}

#' @describeIn aet05 Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
aet05_pre <- function(adam_db, dataset = "adsaftte", ...) {
  adam_db[[dataset]] <- adam_db[[dataset]] %>%
    filter(grepl("(AE|CQ|SMQ)TTE", .data$PARAMCD)) %>%
    mutate(
      N_EVENTS = as.integer(.data$CNSR == 0)
    )

  adam_db
}

#' @describeIn aet05 Postprocessing
#'
#' @inheritParams gen_args
#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
#' @export
#'
aet05_post <- function(tlg, prune_0 = FALSE, ...) {
  if (prune_0) {
    tlg <- smart_prune(tlg)
  }
  std_postprocessing(tlg)
}

#' `AET05` Table 1 (Default) Adverse Event Rate Adjusted for Patient-Years at Risk - First Occurrence.
#'
#' The `AET05` table produces the standard adverse event rate adjusted for patient-years at risk summary
#' considering first occurrence.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' library(dplyr)
#' library(dunlin)
#'
#' proc_data <- log_filter(syn_data, PARAMCD == "AETTE1", "adsaftte")
#'
#' run(aet05, proc_data)
#'
#' run(aet05, proc_data, conf_level = 0.90, conf_type = "exact")
aet05 <- chevron_t(
  main = aet05_main,
  preprocess = aet05_pre,
  postprocess = aet05_post
)

# aet05_all ----

#' @describeIn aet05_all Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
aet05_all_pre <- function(adam_db, dataset = "adsaftte", ...) {
  anl_tte <- adam_db[[dataset]] %>%
    filter(.data$PARAMCD == "AEREPTTE") %>%
    select(all_of(c("USUBJID", "AVAL")))

  adam_db[[dataset]] <- adam_db[[dataset]] %>%
    filter(grepl("TOT", .data$PARAMCD)) %>%
    mutate(
      N_EVENTS = as.integer(.data$AVAL),
      AVAL = NULL
    ) %>%
    left_join(anl_tte, by = c("USUBJID"))

  adam_db
}

#' `AET05_ALL` Table 1 (Default) Adverse Event Rate Adjusted for Patient-Years at Risk - All Occurrences.
#'
#' The `AET05_ALL` table produces the standard adverse event rate adjusted for patient-years at risk summary
#' considering all occurrences.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' library(dplyr)
#' library(dunlin)
#'
#' proc_data <- log_filter(syn_data, PARAMCD == "AETOT1" | PARAMCD == "AEREPTTE", "adsaftte")
#'
#' run(aet05_all, proc_data)
#'
#' run(aet05_all, proc_data, conf_level = 0.90, conf_type = "exact")
aet05_all <- chevron_t(
  main = aet05_main,
  preprocess = aet05_all_pre,
  postprocess = aet05_post
)

# lbt15 ----

#' @describeIn lbt15 Preprocessing
#'
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#' @export
#'
lbt15_pre <- function(adam_db, ...) {
  format <- rule(
    "LOW" = c("-3", "-4"),
    "MODERATE/NORMAL" = c("-2", "-1", "0", "1", "2"),
    "HIGH" = c("3", "4"),
    .to_NA = NULL
  )

  adam_db$adlb <- adam_db$adlb %>%
    filter(
      .data$ONTRTFL == "Y",
      .data$PARCAT2 == "SI"
    ) %>%
    mutate(
      PARAM = with_label(.data$PARAM, "Laboratory Test"),
      ANRIND = with_label(.data$ANRIND, "Direction of Abnormality")
    ) %>%
    mutate(
      ANRIND = reformat(.data$ATOXGR, .env$format),
      BNRIND = reformat(.data$BTOXGR, .env$format)
    )

  adam_db
}

#' `LBT15` Laboratory Test Shifts to `NCI-CTCAE` Grade 3-4 Post-Baseline Table.
#' @source `lbt04.R`
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(lbt15, syn_data)
lbt15 <- chevron_t(
  main = lbt04_main,
  preprocess = lbt15_pre,
  postprocess = lbt04_post
)

# cml02a_gl_main ----

#' @describeIn cml02a_gl Main TLG function
#'
#' @inheritParams gen_args
#' @returns the main function returns an `rlistings` or a `list` object.
#' @export
#'
cml02a_gl_main <- modify_default_args(std_listing,
  dataset = "adcm",
  key_cols = c("ATC2", "CMDECOD"),
  disp_cols = c("ATC2", "CMDECOD", "CMTRT"),
  split_into_pages_by_var = NULL,
  unique_rows = TRUE
)

#' @describeIn cml02a_gl Preprocessing
#'
#' @inheritParams cml02a_gl_main
#' @inheritParams gen_args
#' @returns the preprocessing function returns a `list` of `data.frame`.
#'
#' @export
#'
cml02a_gl_pre <- function(adam_db,
                          dataset = "adcm",
                          disp_cols = c("ATC2", "CMDECOD", "CMTRT"),
                          ...) {
  adam_db[[dataset]] <- adam_db[[dataset]] %>%
    mutate(across(all_of(disp_cols), ~ reformat(.x, nocoding))) %>%
    mutate(
      ATC2 = with_label(.data$ATC2, "ATC Class Level 2"),
      CMDECOD = with_label(.data$CMDECOD, "WHODrug Preferred Name"),
      CMTRT = with_label(.data$CMTRT, "Investigator-Specified Treatment Term")
    )

  adam_db
}

#' `CML02A_GL` Listing 1 (Default) Concomitant Medication Class Level 2, Preferred Name, and Investigator-Specified
#' Terms.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' run(cml02a_gl, syn_data)
cml02a_gl <- chevron_l(
  main = cml02a_gl_main,
  preprocess = cml02a_gl_pre
)

# ael03_main ----

#' @describeIn ael03 Main TLG function
#'
#' @inheritParams gen_args
#' @returns the main function returns an `rlistings` or a `list` object.
#' @export
#'
ael03_main <- modify_default_args(
  std_listing,
  dataset = "adae",
  key_cols = c("ID", "ASR"),
  disp_cols = c(
    "AEDECOD", "TRTSDTM", "ASTDY", "ADURN", "ASEV",
    "AREL", "AEOUT", "AECONTRT", "AEACN", "SERREAS"
  ),
  split_into_pages_by_var = "ACTARM"
)

#' @describeIn ael03 Preprocessing
#'
#' @inheritParams ael03_main
#' @inheritParams gen_args
#'
#' @export
#'
ael03_pre <- function(adam_db,
                      dataset = "adae",
                      arm_var = "ACTARM",
                      ...) {
  adam_db[[dataset]] <- adam_db[[dataset]] %>%
    filter(.data$ANL01FL == "Y") %>%
    filter(.data$AESER == "Y") %>%
    mutate(
      across(
        all_of(c(arm_var, "AEDECOD", "ASEV", "AEOUT", "AEACN")),
        ~ reformat(.x, missing_rule)
      )
    ) %>%
    mutate(
      !!arm_var := with_label(.data[[arm_var]], "Treatment"),
      ID = create_id_listings(.data$SITEID, .data$SUBJID),
      AEDECOD = with_label(reformat(.data$AEDECOD, nocoding), "Adverse\nEvent MedDRA\nPreferred Term"),
      ASR = with_label(paste(.data$AGE, .data$SEX, .data$RACE, sep = "/"), "Age/Sex/Race"),
      # Datetime of First Exposure to Treatment
      TRTSDTM = with_label(.data$TRTSDTM, "Date of\nFirst Study\nDrug\nAdministration"),
      ASTDY = with_label(.data$ASTDY, "Study\nDay of\nOnset"),
      ADURN = with_label(.data$AENDY - .data$ASTDY + 1, "AE\nDuration\nin Days"),
      AESER = with_label(.data$AESER, "Serious"),
      ASEV = with_label(.data$ASEV, "Most\nExtreme\nIntensity"),
      AREL = with_label(reformat(.data$AREL, yes_no_rule), "Caused by\nStudy\nDrug"), # Analysis Causality
      AEOUT = with_label(reformat(.data$AEOUT, outcome_rule), "Outcome\n(1)"),
      AECONTRT = with_label(reformat(.data$AECONTRT, yes_no_rule), "Treatment\nfor AE"),
      AEACN = with_label(reformat(.data$AEACN, dose_change_rule), "Action\nTaken\n(2)"),
      # New derived column
      SERREAS = with_label(case_when(
        AESDTH == "Y" ~ "1",
        AESLIFE == "Y" ~ "2",
        AESHOSP == "Y" ~ "3",
        AESDISAB == "Y" ~ "4",
        AESCONG == "Y" ~ "5",
        AESMIE == "Y" ~ "6",
        TRUE ~ " "
      ), "Reason\nClassified\nas Serious\n(3)"),
    )

  adam_db
}

#' `AEL03` Listing 1 (Default) Listing of Serious Adverse Events.
#'
#' @include chevron_tlg-S4class.R
#' @export
#'
#' @examples
#' res <- run(ael03, syn_data)
ael03 <- chevron_l(
  main = ael03_main,
  preprocess = ael03_pre
)

1		# pdt02 ----
2
3		#' @describeIn pdt02 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param dvreas_var (`string`) the variable defining the reason for deviation. By default `DVREAS`.
7		#' @param dvterm_var (`string`) the variable defining the protocol deviation term. By default `DVTERM`.
8		#'
9		#' @details
10		#' * Data should be filtered for major protocol deviations related to epidemic/pandemic.
11		#' `(AEPRELFL == "Y" & DVCAT == "MAJOR")`.
12		#' * Numbers represent absolute numbers of subjects and fraction of `N`, or absolute numbers when specified.
13		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
14		#' * Split columns by arm.
15		#' * Does not include a total column by default.
16		#' * Sort by deviation reason alphabetically and within deviation reason by decreasing total number of patients with
17		#' the specific deviation term.
18		#'
19		#' @note
20		#' * `adam_db` object must contain an `addv` table with the columns specified in `dvreas_var` and `dvterm_var`.
21		#'
22		#' @export
23		#'
24		pdt02_main <- function(adam_db,
25		arm_var = "ARM",
26		lbl_overall = NULL,
27		dvreas_var = "DVREAS",
28		dvterm_var = "DVTERM",
29		...) {
30	1x	assert_all_tablenames(adam_db, c("adsl", "addv"))
31	1x	assert_string(arm_var)
32	1x	assert_string(lbl_overall, null.ok = TRUE)
33	1x	assert_string(dvreas_var)
34	1x	assert_string(dvterm_var)
35	1x	assert_valid_variable(adam_db$addv, c(dvreas_var, dvterm_var), types = list(c("character", "factor")))
36	1x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
37	1x	assert_valid_variable(adam_db$addv, "USUBJID", types = list(c("character", "factor")), empty_ok = TRUE)
38	1x	assert_valid_var_pair(adam_db$adsl, adam_db$addv, arm_var)
39
40	1x	lbl_overall <- render_safe(lbl_overall)
41	1x	lbl_dvreas_var <- var_labels_for(adam_db$addv, dvreas_var)
42	1x	lbl_dvterm_var <- var_labels_for(adam_db$addv, dvterm_var)
43
44	1x	lyt <- pdt02_lyt(
45	1x	arm_var = arm_var,
46	1x	lbl_overall = lbl_overall,
47	1x	lbl_dvreas_var = lbl_dvreas_var,
48	1x	lbl_dvterm_var = lbl_dvterm_var,
49	1x	dvreas_var = dvreas_var,
50	1x	dvterm_var = dvterm_var
51		)
52
53	1x	tbl <- build_table(lyt, adam_db$addv, alt_counts_df = adam_db$adsl)
54
55	1x	tbl
56		}
57
58		#' `pdt02` Layout
59		#'
60		#' @inheritParams gen_args
61		#' @inheritParams pdt02_main
62		#' @param lbl_dvreas_var (`string`) label for the variable defining the reason for deviation.
63		#' @param lbl_dvterm_var (`string`) label for the variable defining the protocol deviation term.
64		#'
65		#' @keywords internal
66		#'
67		pdt02_lyt <- function(arm_var,
68		lbl_overall,
69		lbl_dvreas_var,
70		lbl_dvterm_var,
71		dvreas_var,
72		dvterm_var) {
73	3x	basic_table(show_colcounts = TRUE) %>%
74	3x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
75	3x	analyze_num_patients(
76	3x	vars = "USUBJID",
77	3x	.stats = c("unique", "nonunique"),
78	3x	.labels = c(
79	3x	unique = render_safe(
80	3x	"Total number of {patient_label} with at least one major protocol deviation related to epidemic/pandemic"
81		),
82	3x	nonunique = "Total number of major protocol deviations related to epidemic/pandemic"
83		)
84		) %>%
85	3x	split_rows_by(
86	3x	dvreas_var,
87	3x	nested = FALSE,
88	3x	split_fun = drop_split_levels,
89	3x	label_pos = "topleft",
90	3x	split_label = lbl_dvreas_var
91		) %>%
92	3x	summarize_num_patients(
93	3x	var = "USUBJID",
94	3x	.stats = "unique",
95	3x	.labels = NULL
96		) %>%
97	3x	count_occurrences(
98	3x	vars = dvterm_var,
99	3x	id = "USUBJID"
100		) %>%
101	3x	append_topleft(paste(" ", lbl_dvterm_var))
102		}
103
104		#' @describeIn pdt02 Preprocessing
105		#'
106		#' @inheritParams pdt02_main
107		#' @returns the preprocessing function returns a `list` of `data.frame`.
108		#' @export
109		#'
110		pdt02_pre <- function(adam_db,
111		...) {
112	1x	adam_db$addv <- adam_db$addv %>%
113	1x	mutate(across(all_of(c("DVCAT", "AEPRELFL")), ~ reformat(.x, missing_rule))) %>%
114	1x	filter(.data$DVCAT == "MAJOR" & .data$AEPRELFL == "Y") %>%
115	1x	mutate(across(all_of(c("DVREAS", "DVTERM")), ~ reformat(.x, nocoding))) %>%
116	1x	mutate(
117	1x	DVREAS = with_label(.data$DVREAS, "Primary Reason"),
118	1x	DVTERM = with_label(.data$DVTERM, "Description")
119		)
120
121	1x	adam_db
122		}
123
124		#' @describeIn pdt02 Postprocessing
125		#'
126		#' @inheritParams pdt02_main
127		#' @inheritParams gen_args
128		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
129		#' @export
130		#'
131		pdt02_post <- function(tlg, prune_0 = TRUE, dvreas_var = "DVREAS", dvterm_var = "DVTERM", ...) {
132	1x	if (prune_0) {
133	1x	tlg <- smart_prune(tlg)
134		}
135
136	1x	tbl_sorted <- tlg %>%
137	1x	sort_at_path(
138	1x	path = c(dvreas_var, "*", dvterm_var),
139	1x	scorefun = score_occurrences
140		)
141
142	1x	std_postprocessing(tbl_sorted)
143		}
144
145		#' `pdt02` Major Protocol Deviations Related to Epidemic/Pandemic Table.
146		#'
147		#' A major protocol deviations
148		#' table with the number of subjects and the total number of Major Protocol Deviations Related
149		#' to Epidemic/Pandemic sorted alphabetically and deviations name sorted by frequencies.
150		#'
151		#' @include chevron_tlg-S4class.R
152		#' @export
153		#'
154		#' @examples
155		#' run(pdt02, syn_data)
156		pdt02 <- chevron_t(
157		main = pdt02_main,
158		preprocess = pdt02_pre,
159		postprocess = pdt02_post
160		)

1		# ext01 ----
2
3		#' @describeIn ext01 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param summaryvars (`character`) variables to be analyzed. The label attribute of the corresponding column in `adex`
7		#' table of `adam_db` is used as label.
8		#' @param map (`data.frame`) of mapping for split rows.
9		#' @returns the main function returns an `rtables` object.
10		#'
11		#' @details
12		#' * Default Exposure table
13		#' * The `n` row provides the number of non-missing values. The percentages for categorical variables is based on `n`.
14		#' The percentages for `Total number of patients with at least one dose modification` are based on the number of
15		#' patients in the corresponding analysis population given by `N`.
16		#' * Split columns by arm, typically `ACTARM`.
17		#' * Does not include a total column by default.
18		#' * Sorted by alphabetic order of the `PARAM` value. Transform to factor and re-level for custom order.
19		#' * `ANL01FL` is not relevant subset.
20		#'
21		#' @note
22		#' * `adam_db` object must contain an `adex` table with columns specified in `summaryvars`.
23		#'
24		#' @export
25		#'
26		ext01_main <- function(adam_db,
27		arm_var = "ACTARM",
28		lbl_overall = NULL,
29		summaryvars = "AVAL",
30		row_split_var = "PARCAT2",
31		page_var = NULL,
32		map = NULL,
33		...) {
34	2x	assert_all_tablenames(adam_db, c("adsl", "adex"))
35	2x	assert_string(arm_var)
36	2x	assert_string(lbl_overall, null.ok = TRUE)
37	2x	assert_character(summaryvars)
38	2x	assert_character(row_split_var, null.ok = TRUE)
39	2x	assert_string(page_var, null.ok = TRUE)
40	2x	assert_data_frame(map, null.ok = TRUE)
41	2x	assert_valid_var_pair(adam_db$adsl, adam_db$adex, arm_var)
42	2x	assert_valid_variable(adam_db$adex, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
43	2x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
44	2x	assert_valid_variable(adam_db$adex, summaryvars, empty_ok = TRUE, na_ok = TRUE)
45	2x	assert_valid_variable(
46	2x	adam_db$adex, c(row_split_var, "PARAMCD", "PARAM"),
47	2x	types = list(c("character", "factor")), empty_ok = TRUE
48		)
49	2x	assert_valid_variable(adam_db$adex, colnames(map), types = list(c("character", "factor")))
50	2x	if (!is.null(map)) {
51	!	map <- infer_mapping(map, adam_db$adex)
52		}
53	2x	assert_subset(page_var, c(row_split_var))
54
55	2x	lbl_overall <- render_safe(lbl_overall)
56	2x	summaryvars_lbls <- var_labels_for(adam_db$adex, summaryvars)
57	2x	row_split_lbl <- var_labels_for(adam_db$adex, row_split_var)
58
59	2x	lyt <- ext01_lyt(
60	2x	arm_var = arm_var,
61	2x	lbl_overall = lbl_overall,
62	2x	summaryvars = summaryvars,
63	2x	summaryvars_lbls = summaryvars_lbls,
64	2x	row_split_var = row_split_var,
65	2x	row_split_lbl = row_split_lbl,
66	2x	page_var = page_var,
67	2x	map = map
68		)
69
70	2x	tbl <- build_table(lyt, adam_db$adex, adam_db$adsl)
71
72	2x	tbl
73		}
74
75		#' `ext01` Layout
76		#'
77		#' @inheritParams gen_args
78		#'
79		#' @param summaryvars (`character`) the name of the variable to be analyzed. By default `"AVAL"`.
80		#' @param summaryvars_lbls (`character`) the label associated with the analyzed variable.
81		#' @returns a `PreDataTableLayouts` object.
82		#'
83		#' @keywords internal
84		#'
85		ext01_lyt <- function(arm_var,
86		lbl_overall,
87		summaryvars,
88		summaryvars_lbls,
89		row_split_var,
90		row_split_lbl,
91		page_var,
92		map) {
93	10x	page_by <- get_page_by(page_var, c(row_split_var))
94	10x	label_pos <- ifelse(page_by, "hidden", "topleft")
95	10x	basic_table(show_colcounts = TRUE) %>%
96	10x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
97	10x	split_rows_by_recursive(
98	10x	row_split_var,
99	10x	split_label = row_split_lbl, label_pos = label_pos, page_by = page_by
100		) %>%
101	10x	split_rows_by(
102	10x	"PARAMCD",
103	10x	labels_var = "PARAM",
104	10x	split_fun = split_fun_map(map)
105		) %>%
106	10x	analyze_vars(
107	10x	vars = summaryvars,
108	10x	var_labels = summaryvars_lbls,
109	10x	show_labels = "hidden",
110	10x	.formats = list(count_fraction = format_count_fraction_fixed_dp)
111		)
112		}
113
114		#' @describeIn ext01 Preprocessing
115		#'
116		#' @inheritParams gen_args
117		#' @returns the preprocessing function returns a `list` of `data.frame`.
118		#'
119		#' @export
120		#'
121		ext01_pre <- function(adam_db,
122		...) {
123	2x	adam_db$adex <- adam_db$adex %>%
124	2x	filter(.data$PARCAT1 == "OVERALL") %>%
125	2x	filter(.data$PARAMCD %in% c("TDURD", "TDOSE"))
126
127	2x	adam_db
128		}
129
130		#' @describeIn ext01 Postprocessing
131		#'
132		#' @inheritParams gen_args
133		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
134		#' @export
135		#'
136		ext01_post <- function(tlg, prune_0 = TRUE, ...) {
137	2x	if (prune_0) tlg <- smart_prune(tlg)
138	2x	std_postprocessing(tlg)
139		}
140
141		#' `EXT01` Exposure Summary Table.
142		#'
143		#' The `EXT01` table provides an overview of the of the exposure of the
144		#' patients in terms of Total dose administered or missed, and treatment duration.
145		#'
146		#' @include chevron_tlg-S4class.R
147		#' @export
148		#'
149		#' @examples
150		#' run(ext01, syn_data)
151		#'
152		#' run(ext01, syn_data, summaryvars = c("AVAL", "AVALCAT1"), prune_0 = FALSE)
153		#'
154		#' levels(syn_data$adex$AVALCAT1) <- c(levels(syn_data$adex$AVALCAT1), "12 months")
155		#' map <- data.frame(
156		#' PARAMCD = "TDURD",
157		#' AVALCAT1 = c("< 1 month", "1 to <3 months", ">=6 months", "3 to <6 months", "12 months")
158		#' )
159		#' run(ext01, syn_data, summaryvars = c("AVAL", "AVALCAT1"), prune_0 = FALSE, map = map)
160		ext01 <- chevron_t(
161		main = ext01_main,
162		preprocess = ext01_pre,
163		postprocess = ext01_post
164		)

1		# coxt01 ----
2
3		#' @describeIn coxt01 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param arm_var (`string`) the arm variable used for arm splitting.
7		#' @param time_var (`string`) the time variable in a Cox proportional hazards regression model.
8		#' @param event_var (`string`) the event variable in a Cox proportional hazards regression model.
9		#' @param covariates (`character`) will be fitted and the corresponding effect will be estimated.
10		#' @param strata (`character`) will be fitted for the stratified analysis.
11		#' @param lbl_vars (`string`) text label for the a Cox regression model variables.
12		#' @param multivar (`flag`) indicator of whether multivariate cox regression is conducted.
13		#' @param ... Further arguments passed to `tern::control_coxreg()`.
14		#' @returns the main function returns an `rtables` object
15		#'
16		#' @details
17		#' * The reference arm will always the first level of `arm_var`. Please change the level if you want to
18		#' change the reference arms.
19		#' * The table allows confidence level to be adjusted, default is two-sided 95%.
20		#' * The stratified analysis is with DISCRETE tie handling (equivalent to `tern::control_coxreg(ties = "exact")` in R).
21		#' * Model includes treatment plus specified covariate(s) as factor(s) or numeric(s),
22		#' with `"SEX"`, `"RACE"` and `"AAGE"` as default candidates.
23		#' * The selection of the covariates and whether or not there is a selection process
24		#' (vs. a fixed, pre-specified list) needs to be pre-specified.
25		#' * For pairwise comparisons using the hazard ratio, the value for the control group is the denominator.
26		#' * Keep zero-count rows unless overridden with `prune_0 = TRUE`.
27		#'
28		#' @note
29		#' * `adam_db` object must contain an `adtte` table with `"PARAMCD"`, `"ARM"`,
30		#' `"AVAL"`, `"CNSR`, and the columns specified by `"covariates"` which is denoted as
31		#' `c("SEX", "RACE", "AAGE")` by default.
32		#'
33		#' @export
34		#'
35		coxt01_main <- function(adam_db,
36		arm_var = "ARM",
37		time_var = "AVAL",
38		event_var = "EVENT",
39		covariates = c("SEX", "RACE", "AAGE"),
40		strata = NULL,
41		lbl_vars = "Effect/Covariate Included in the Model",
42		multivar = FALSE,
43		...) {
44	2x	assert_all_tablenames(adam_db, "adtte")
45	2x	assert_string(arm_var)
46	2x	assert_string(time_var)
47	2x	assert_string(event_var)
48	2x	assert_character(covariates, null.ok = TRUE)
49	2x	assert_character(strata, null.ok = TRUE)
50	2x	assert_flag(multivar)
51	2x	assert_valid_variable(adam_db$adtte, arm_var, types = list("factor"), n.levels = if (!multivar) 2L)
52	2x	assert_valid_variable(adam_db$adtte, c("USUBJID", arm_var, "PARAMCD"), types = list(c("character", "factor")))
53	2x	assert_valid_variable(adam_db$adtte, strata, types = list(c("factor", "integer", "character")), na_ok = TRUE)
54	2x	assert_valid_variable(adam_db$adtte, covariates, na_ok = TRUE)
55	2x	assert_valid_variable(adam_db$adtte, event_var, types = list("numeric"), integerish = TRUE, lower = 0L, upper = 1L)
56	2x	assert_valid_variable(adam_db$adtte, time_var, types = list("numeric"), lower = 0)
57	2x	assert_single_value(adam_db$adtte$PARAMCD)
58	2x	control <- execute_with_args(control_coxreg, ...)
59
60	2x	variables <- list(
61	2x	time = time_var,
62	2x	event = event_var,
63	2x	arm = arm_var,
64	2x	covariates = covariates,
65	2x	strata = strata
66		)
67
68	2x	lyt <- coxt01_lyt(
69	2x	variables = variables,
70	2x	col_split = if (!multivar) "COL_LABEL",
71	2x	lbl_vars = lbl_vars,
72	2x	multivar = multivar,
73	2x	control = control,
74		...
75		)
76
77	2x	col_split <- "Treatment Effect Adjusted for Covariate"
78	2x	adam_db$adtte$COL_LABEL <- factor(rep(col_split, nrow(adam_db$adtte)), levels = col_split)
79
80	2x	tbl <- build_table(lyt, adam_db$adtte)
81
82	2x	tbl
83		}
84
85		#' `COXT01` Layout
86		#'
87		#' @inheritParams coxt01_main
88		#' @param variables (`list`) list of variables in a Cox proportional hazards regression model.
89		#' @returns a `PreDataTableLayouts` object.
90		#' @keywords internal
91		#'
92		coxt01_lyt <- function(variables,
93		col_split,
94		lbl_vars,
95		control,
96		multivar,
97		...) {
98	10x	lyt <- basic_table() %>%
99	10x	ifneeded_split_col(col_split)
100	10x	lyt <- execute_with_args(
101	10x	summarize_coxreg,
102	10x	lyt = lyt, variables = variables, control = control, multivar = multivar, ...
103		)
104	10x	lyt %>%
105	10x	append_topleft(lbl_vars)
106		}
107
108		#' @describeIn coxt01 Preprocessing
109		#'
110		#' @inheritParams coxt01_main
111		#' @returns the preprocessing function returns a `list` of `data.frame`.
112		#' @export
113		#'
114		coxt01_pre <- function(adam_db, arm_var = "ARM", ...) {
115	2x	adam_db$adtte <- adam_db$adtte %>%
116	2x	mutate(EVENT = 1 - .data$CNSR) %>%
117	2x	mutate(!!arm_var := forcats::fct_drop(!!sym(arm_var)))
118
119	2x	adam_db
120		}
121
122		#' @describeIn coxt01 Postprocessing
123		#'
124		#' @inheritParams gen_args
125		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
126		#' @export
127		#'
128		coxt01_post <- function(tlg, prune_0 = FALSE, ...) {
129	2x	if (prune_0) {
130	!	tlg <- smart_prune(tlg)
131		}
132	2x	std_postprocessing(tlg)
133		}
134
135		#' `COXT01` (Default) Cox Regression Model Table.
136		#'
137		#' Cox models are the most commonly used methods to estimate the magnitude of the effect in survival analyses.
138		#' It assumes proportional hazards; that is, it assumes that the ratio of the hazards
139		#' of the two groups (e.g. two arms) is constant over time.
140		#' This ratio is referred to as the "hazard ratio" and is one of the most commonly reported metrics
141		#' to describe the effect size in survival analysis.
142		#'
143		#' @include chevron_tlg-S4class.R
144		#' @export
145		#'
146		#' @examples
147		#' library(dunlin)
148		#'
149		#' proc_data <- log_filter(syn_data, PARAMCD == "CRSD", "adtte")
150		#' proc_data <- log_filter(proc_data, ARMCD != "ARM C", "adsl")
151		#' run(coxt01, proc_data)
152		#'
153		#' run(coxt01, proc_data, covariates = c("SEX", "AAGE"), strata = c("RACE"), conf_level = 0.90)
154		coxt01 <- chevron_t(
155		main = coxt01_main,
156		preprocess = coxt01_pre,
157		postprocess = coxt01_post
158		)

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		#' @returns the main function returns an `rtables` object.
9		#'
10		#' @details
11		#' * Only count LOW or HIGH values.
12		#' * Lab test results with missing `analysis_abn_var` values are excluded.
13		#' * Split columns by arm, typically `ACTARM`.
14		#' * Does not include a total column by default.
15		#'
16		#' @note
17		#' * `adam_db` object must contain an `adlb` table with columns `"PARCAT1"`, `"PARCAT2"`, `"PARAM"`, `"ANRIND"`,
18		#' and column specified by `arm_var`.
19		#'
20		#' @export
21		#'
22		lbt04_main <- function(adam_db,
23		arm_var = "ACTARM",
24		lbl_overall = NULL,
25		analysis_abn_var = "ANRIND",
26		baseline_abn_var = "BNRIND",
27		row_split_var = "PARCAT1",
28		page_var = tail(row_split_var, 1L),
29		...) {
30	2x	assert_all_tablenames(adam_db, c("adsl", "adlb"))
31	2x	assert_string(arm_var)
32	2x	assert_string(lbl_overall, null.ok = TRUE)
33	2x	assert_string(analysis_abn_var)
34	2x	assert_string(baseline_abn_var)
35	2x	assert_string(row_split_var)
36	2x	assert_valid_variable(
37	2x	adam_db$adlb, c("PARAMCD", "PARAM", row_split_var),
38	2x	types = list(c("character", "factor"))
39		)
40	2x	assert_subset(page_var, row_split_var)
41	2x	assert_valid_variable(adam_db$adlb, c("USUBJID"), types = list(c("character", "factor")), empty_ok = TRUE)
42	2x	assert_valid_variable(adam_db$adsl, c("USUBJID"), types = list(c("character", "factor")))
43	2x	assert_valid_variable(
44	2x	adam_db$adlb,
45	2x	baseline_abn_var,
46	2x	types = list(c("character", "factor")),
47	2x	na_ok = TRUE, empty_ok = TRUE, min_chars = 0L
48		)
49	2x	assert_valid_var_pair(adam_db$adsl, adam_db$adlb, arm_var)
50
51	2x	lbl_overall <- render_safe(lbl_overall)
52	2x	lbl_param <- var_labels_for(adam_db$adlb, "PARAM")
53	2x	lbl_abn_var <- var_labels_for(adam_db$adlb, analysis_abn_var)
54	2x	row_split_lbl <- var_labels_for(adam_db$adlb, row_split_var)
55
56	2x	lyt <- lbt04_lyt(
57	2x	arm_var = arm_var,
58	2x	lbl_overall = lbl_overall,
59	2x	lbl_param = lbl_param,
60	2x	lbl_abn_var = lbl_abn_var,
61	2x	var_parcat = "PARCAT1",
62	2x	var_param = "PARAM",
63	2x	row_split_var = row_split_var,
64	2x	row_split_lbl = row_split_lbl,
65	2x	analysis_abn_var = analysis_abn_var,
66	2x	variables = list(id = "USUBJID", baseline = baseline_abn_var),
67	2x	page_var = page_var
68		)
69
70	2x	tbl <- build_table(lyt, adam_db$adlb, alt_counts_df = adam_db$adsl)
71
72	2x	tbl
73		}
74
75		#' `lbt04` Layout
76		#'
77		#' @inheritParams gen_args
78		#'
79		#' @param lbl_param (`string`) label of the `PARAM` variable.
80		#' @param lbl_abn_var (`string`) label of the `analysis_abn_var` variable.
81		#' @param variables (`list`) see [tern::count_abnormal]
82		#'
83		#' @keywords internal
84		#'
85		lbt04_lyt <- function(arm_var,
86		lbl_overall,
87		lbl_param,
88		lbl_abn_var,
89		var_parcat,
90		var_param,
91		row_split_var,
92		row_split_lbl,
93		analysis_abn_var,
94		variables,
95		page_var) {
96	10x	page_by <- get_page_by(page_var, row_split_var)
97	10x	label_pos <- ifelse(page_by, "hidden", "topleft")
98
99	10x	basic_table(show_colcounts = TRUE) %>%
100	10x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
101	10x	split_rows_by_recursive(
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		#' @returns the preprocessing function returns a `list` of `data.frame`.
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		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
163		#' @export
164		#'
165		lbt04_post <- function(tlg, ...) {
166	2x	std_postprocessing(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		# pdt01 ----
2
3		#' @describeIn pdt01 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param dvcode_var (`string`) the variable defining the protocol deviation coded term. By default `DVDECOD`.
7		#' @param dvterm_var (`string`) the variable defining the protocol deviation term. By default `DVTERM`.
8		#' @returns the main function returns an `rtables` object.
9		#'
10		#' @details
11		#' * Data should be filtered for major protocol deviations. `(DVCAT == "MAJOR")`.
12		#' * Numbers represent absolute numbers of subjects and fraction of `N`, or absolute numbers when specified.
13		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
14		#' * Split columns by arm.
15		#' * Does not include a total column by default.
16		#' * Sort by medication class alphabetically and within medication class by decreasing total number of patients with
17		#' the specific medication.
18		#'
19		#' @note
20		#' * `adam_db` object must contain an `addv` table with the columns specified in `dvcode_var` and `dvterm_var` as well
21		#' as `"DVSEQ"`.
22		#'
23		#' @export
24		#'
25		pdt01_main <- function(adam_db,
26		arm_var = "ARM",
27		lbl_overall = NULL,
28		dvcode_var = "DVDECOD",
29		dvterm_var = "DVTERM",
30		...) {
31	1x	assert_all_tablenames(adam_db, c("adsl", "addv"))
32	1x	assert_string(arm_var)
33	1x	assert_string(lbl_overall, null.ok = TRUE)
34	1x	assert_string(dvcode_var)
35	1x	assert_string(dvterm_var)
36	1x	assert_valid_variable(adam_db$addv, c(dvcode_var, dvterm_var), types = list(c("character", "factor")))
37	1x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
38	1x	assert_valid_variable(adam_db$addv, "USUBJID", types = list(c("character", "factor")), empty_ok = TRUE)
39	1x	assert_valid_var_pair(adam_db$adsl, adam_db$addv, arm_var)
40
41	1x	lbl_overall <- render_safe(lbl_overall)
42	1x	lbl_dvcode_var <- var_labels_for(adam_db$addv, dvcode_var)
43	1x	lbl_dvterm_var <- var_labels_for(adam_db$addv, dvterm_var)
44
45	1x	lyt <- pdt01_lyt(
46	1x	arm_var = arm_var,
47	1x	lbl_overall = lbl_overall,
48	1x	dvcode_var = dvcode_var,
49	1x	lbl_dvcode_var = lbl_dvcode_var,
50	1x	dvterm_var = dvterm_var,
51	1x	lbl_dvterm_var = lbl_dvterm_var
52		)
53
54	1x	tbl <- build_table(lyt, adam_db$addv, alt_counts_df = adam_db$adsl)
55
56	1x	tbl
57		}
58
59		#' `pdt01` Layout
60		#'
61		#' @inheritParams gen_args
62		#' @inheritParams pdt01_main
63		#' @param lbl_dvcode_var (`string`) label for the variable defining the protocol deviation coded term.
64		#' @param lbl_dvterm_var (`string`) label for the variable defining the protocol deviation term.
65		#'
66		#' @keywords internal
67		#'
68		pdt01_lyt <- function(arm_var,
69		lbl_overall,
70		dvcode_var,
71		lbl_dvcode_var,
72		dvterm_var,
73		lbl_dvterm_var) {
74	4x	basic_table(show_colcounts = TRUE) %>%
75	4x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
76	4x	summarize_num_patients(
77	4x	var = "USUBJID",
78	4x	.stats = c("unique", "nonunique"),
79	4x	.labels = c(
80	4x	unique = render_safe("Total number of {patient_label} with at least one major protocol deviation"),
81	4x	nonunique = "Total number of major protocol deviations"
82		),
83	4x	.formats = list(unique = format_count_fraction_fixed_dp)
84		) %>%
85	4x	split_rows_by(
86	4x	dvcode_var,
87	4x	child_labels = "visible",
88	4x	nested = FALSE,
89	4x	indent_mod = -1L,
90	4x	split_fun = drop_split_levels,
91	4x	label_pos = "topleft",
92	4x	split_label = lbl_dvterm_var
93		) %>%
94	4x	count_occurrences(vars = dvterm_var) %>%
95	4x	append_topleft(paste0(" Description"))
96		}
97
98		#' @describeIn pdt01 Preprocessing
99		#'
100		#' @inheritParams pdt01_main
101		#' @returns the preprocessing function returns a `list` of `data.frame`.
102		#' @export
103		#'
104		pdt01_pre <- function(adam_db, ...) {
105	1x	adam_db$addv <- adam_db$addv %>%
106	1x	mutate(across(all_of(c("DVDECOD", "DVTERM")), ~ reformat(.x, nocoding))) %>%
107	1x	mutate(
108	1x	DVDECOD = with_label(.data$DVDECOD, "Protocol Deviation Coded Term"),
109	1x	DVTERM = with_label(.data$DVTERM, "Category")
110		)
111
112	1x	adam_db %>%
113	1x	dunlin::log_filter(.data$DVCAT == "MAJOR", "addv")
114		}
115
116		#' @describeIn pdt01 Postprocessing
117		#'
118		#' @inheritParams pdt01_main
119		#' @inheritParams gen_args
120		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
121		#' @export
122		#'
123		pdt01_post <- function(tlg, prune_0 = TRUE, dvcode_var = "DVDECOD", dvterm_var = "DVTERM", ...) {
124	1x	if (prune_0) {
125	1x	tlg <- smart_prune(tlg)
126		}
127
128	1x	tbl_sorted <- tlg %>%
129	1x	sort_at_path(
130	1x	path = c(dvcode_var, "*", dvterm_var),
131	1x	scorefun = score_occurrences
132		)
133
134	1x	std_postprocessing(tbl_sorted)
135		}
136
137		#' `pdt01` Major Protocol Deviations Table.
138		#'
139		#' A major protocol deviations
140		#' table with the number of subjects and the total number of treatments by medication class sorted alphabetically and
141		#' medication name sorted by frequencies.
142		#'
143		#' @include chevron_tlg-S4class.R
144		#' @export
145		#'
146		#' @examples
147		#' run(pdt01, syn_data)
148		pdt01 <- chevron_t(
149		main = pdt01_main,
150		preprocess = pdt01_pre,
151		postprocess = pdt01_post
152		)

1		# cfbt01 ----
2
3		#' @describeIn cfbt01 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param summaryvars (`character`) variables to be analyzed. The label attribute of the corresponding column in
7		#' table of `adam_db` is used as label.
8		#' @param visitvar (`string`) typically one of `"AVISIT"` or user-defined visit incorporating `"ATPT"`.
9		#' @param precision (named `list` of `integer`) where names are values found in the `PARAMCD` column and the values
10		#' indicate the number of digits in statistics. If `default` is set, and parameter precision not specified,
11		#' the value for `default` will be used. If `default` is not set, the default precision is 2.
12		#' @param .stats (`character`) statistics names, see `tern::analyze_vars()`.
13		#' @param skip Named (`list`) of visit values that need to be inhibited.
14		#' @param ... additional arguments like `.indent_mods`, `.labels`.
15		#' @returns the main function returns an `rtables` object.
16		#'
17		#' @details
18		#' * The `Analysis Value` column, displays the number of patients, the mean, standard deviation, median and range of
19		#' the analysis value for each visit.
20		#' * The `Change from Baseline` column, displays the number of patient and the mean, standard deviation,
21		#' median and range of changes relative to the baseline.
22		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
23		#' * Split columns by arm, typically `ACTARM`.
24		#' * Does not include a total column by default.
25		#' * Sorted based on factor level; first by `PARAM` labels in alphabetic order then by chronological time point given
26		#' by `AVISIT`. Re-level to customize order
27		#'
28		#' @note
29		#' * `adam_db` object must contain table named as `dataset` with the columns specified in `summaryvars`.
30		#'
31		#' @export
32		#'
33		cfbt01_main <- function(adam_db,
34		dataset,
35		arm_var = "ACTARM",
36		lbl_overall = NULL,
37		row_split_var = NULL,
38		summaryvars = c("AVAL", "CHG"),
39		visitvar = "AVISIT",
40		precision = list(default = 2L),
41		page_var = "PARAMCD",
42		.stats = c("n", "mean_sd", "median", "range"),
43		skip = list(CHG = "BASELINE"),
44		...) {
45	5x	assert_all_tablenames(adam_db, c("adsl", dataset))
46	5x	assert_string(arm_var)
47	5x	assert_string(lbl_overall, null.ok = TRUE)
48	5x	assert_character(summaryvars, max.len = 2L, min.len = 1L)
49	5x	assert_character(row_split_var, null.ok = TRUE)
50	5x	assert_disjunct(row_split_var, c("PARAMCD", "PARAM", visitvar))
51	5x	assert_string(visitvar)
52	5x	assert_string(page_var, null.ok = TRUE)
53	5x	assert_subset(page_var, c(row_split_var, "PARAMCD"))
54	5x	df_lbl <- paste0("adam_db$", dataset)
55	5x	assert_valid_variable(adam_db[[dataset]], c(summaryvars), types = list("numeric"), empty_ok = TRUE, label = df_lbl)
56	5x	assert_valid_variable(
57	5x	adam_db[[dataset]], c(visitvar, row_split_var, "PARAM", "PARAMCD"),
58	5x	types = list(c("character", "factor")), label = df_lbl
59		)
60	5x	assert_valid_variable(
61	5x	adam_db[[dataset]], "USUBJID",
62	5x	types = list(c("character", "factor")), empty_ok = TRUE, label = df_lbl
63		)
64	5x	assert_valid_variable(adam_db$adsl, "USUBJID", types = list(c("character", "factor")))
65	5x	assert_valid_var_pair(adam_db$adsl, adam_db[[dataset]], arm_var)
66	5x	assert_list(precision, types = "integerish", names = "unique")
67
68	5x	vapply(precision, assert_int, FUN.VALUE = numeric(1), lower = 0)
69	5x	all_stats <- c(
70	5x	"n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei",
71	5x	"mean_sdi", "mean_pval", "median", "mad", "median_ci", "quantiles", "iqr", "range",
72	5x	"cv", "min", "max", "median_range", "geom_mean", "geom_cv"
73		)
74	5x	assert_subset(.stats, all_stats)
75
76	5x	lbl_overall <- render_safe(lbl_overall)
77	5x	lbl_avisit <- var_labels_for(adam_db[[dataset]], visitvar)
78	5x	lbl_param <- var_labels_for(adam_db[[dataset]], "PARAM")
79
80	5x	summaryvars_lbls <- var_labels_for(adam_db[[dataset]], summaryvars)
81	5x	row_split_lbl <- var_labels_for(adam_db[[dataset]], row_split_var)
82
83	5x	lyt <- cfbt01_lyt(
84	5x	arm_var = arm_var,
85	5x	lbl_overall = lbl_overall,
86	5x	lbl_avisit = lbl_avisit,
87	5x	lbl_param = lbl_param,
88	5x	summaryvars = summaryvars,
89	5x	summaryvars_lbls = summaryvars_lbls,
90	5x	row_split_var = row_split_var,
91	5x	row_split_lbl = row_split_lbl,
92	5x	visitvar = visitvar,
93	5x	precision = precision,
94	5x	.stats = .stats,
95	5x	page_var = page_var,
96	5x	skip = skip,
97		...
98		)
99
100	5x	tbl <- build_table(
101	5x	lyt,
102	5x	df = adam_db[[dataset]],
103	5x	alt_counts_df = adam_db$adsl
104		)
105
106	5x	tbl
107		}
108
109		#' `cfbt01` Layout
110		#'
111		#' @inheritParams gen_args
112		#' @inheritParams cfbt01_main
113		#'
114		#' @param lbl_avisit (`string`) label of the `visitvar` variable.
115		#' @param lbl_param (`string`) label of the `PARAM` variable.
116		#' @param summaryvars (`character`) the variables to be analyzed. For this table, `AVAL` and `CHG` by default.
117		#' @param summaryvars_lbls (`character`) the label of the variables to be analyzed.
118		#' @param row_split_lbl (`character`) label of further row splits.
119		#' @param visitvar (`string`) typically one of `"AVISIT"` or user-defined visit incorporating `"ATPT"`.
120		#' @returns a `PreDataTableLayouts` object.
121		#'
122		#' @keywords internal
123		#'
124		cfbt01_lyt <- function(arm_var,
125		lbl_overall,
126		lbl_avisit,
127		lbl_param,
128		summaryvars,
129		summaryvars_lbls,
130		row_split_var,
131		row_split_lbl,
132		visitvar,
133		precision,
134		page_var,
135		.stats,
136		skip,
137		...) {
138	12x	page_by <- get_page_by(page_var, c(row_split_var, "PARAMCD"))
139	12x	label_pos <- ifelse(page_by, "hidden", "topleft")
140	12x	basic_table(show_colcounts = TRUE) %>%
141	12x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
142	12x	split_rows_by_recursive(
143	12x	row_split_var,
144	12x	split_label = row_split_lbl,
145	12x	label_pos = head(label_pos, -1L), page_by = head(page_by, -1L)
146		) %>%
147	12x	split_rows_by(
148	12x	var = "PARAMCD",
149	12x	labels_var = "PARAM",
150	12x	split_fun = drop_split_levels,
151	12x	label_pos = tail(label_pos, 1L),
152	12x	split_label = lbl_param,
153	12x	page_by = tail(page_by, 1L)
154		) %>%
155	12x	split_rows_by(
156	12x	visitvar,
157	12x	split_fun = drop_split_levels,
158	12x	label_pos = "topleft",
159	12x	split_label = lbl_avisit
160		) %>%
161	12x	split_cols_by_multivar(
162	12x	vars = summaryvars,
163	12x	varlabels = summaryvars_lbls,
164	12x	nested = TRUE
165		) %>%
166	12x	analyze_colvars(
167	12x	afun = afun_skip,
168	12x	extra_args = list(
169	12x	visitvar = visitvar,
170	12x	paramcdvar = "PARAMCD",
171	12x	skip = skip,
172	12x	precision = precision,
173	12x	.stats = .stats,
174		...
175		)
176		)
177		}
178
179		#' @describeIn cfbt01 Preprocessing
180		#'
181		#' @inheritParams gen_args
182		#' @returns the preprocessing function returns a `list` of `data.frame`.
183		#' @export
184		#'
185		cfbt01_pre <- function(adam_db, dataset, ...) {
186	5x	adam_db[[dataset]] <- adam_db[[dataset]] %>%
187	5x	filter(.data$ANL01FL == "Y") %>%
188	5x	mutate(
189	5x	AVISIT = reorder(.data$AVISIT, .data$AVISITN),
190	5x	AVISIT = with_label(.data$AVISIT, "Analysis Visit"),
191	5x	AVAL = with_label(.data$AVAL, "Value at Visit"),
192	5x	CHG = with_label(.data$CHG, "Change from \nBaseline")
193		)
194
195	5x	adam_db
196		}
197
198		#' @describeIn cfbt01 Postprocessing
199		#'
200		#' @inheritParams gen_args
201		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
202		#' @export
203		cfbt01_post <- function(tlg, prune_0 = TRUE, ...) {
204	5x	if (prune_0) {
205	5x	tlg <- smart_prune(tlg)
206		}
207	5x	std_postprocessing(tlg)
208		}
209
210		#' `CFBT01` Change from Baseline By Visit Table.
211		#'
212		#' The `CFBT01` table provides an
213		#' overview of the actual values and its change from baseline of each respective arm
214		#' over the course of the trial.
215		#'
216		#' @include chevron_tlg-S4class.R
217		#' @export
218		#'
219		#' @examples
220		#' library(dunlin)
221		#'
222		#' proc_data <- log_filter(
223		#' syn_data,
224		#' PARAMCD %in% c("DIABP", "SYSBP"), "advs"
225		#' )
226		#' run(cfbt01, proc_data, dataset = "advs")
227		cfbt01 <- chevron_t(
228		main = cfbt01_main,
229		preprocess = cfbt01_pre,
230		postprocess = cfbt01_post
231		)

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		#' @returns a `character` with replaced placeholders and a `label` attribute.
9		#'
10		#' @details
11		#' The labels will be returned if the column has `label` attribute, otherwise the column name will be returned.
12		#' Any values between brackets {} will be replaced with `dunlin::render_safe`.
13		#'
14		#' @export
15		var_labels_for <- function(df, vars) {
16	337x	assert_names(colnames(df), must.include = vars, what = "colnames")
17	337x	render_safe(unname(formatters::var_labels(df, fill = TRUE)[vars]))
18		}
19
20		#' Prune table up to an `ElementaryTable`
21		#'
22		#' Avoid returning `NULL` when the `table` is empty.
23		#'
24		#' @param tlg (`TableTree`) object.
25		#' @returns pruned `TableTree`.
26		smart_prune <- function(tlg) {
27	104x	res <- prune_table(tlg)
28
29	104x	if (is.null(res)) {
30	21x	res <- build_table(rtables::basic_table(), df = data.frame())
31	21x	col_info(res) <- col_info(tlg)
32		}
33
34	104x	res
35		}
36
37		#' Standard Main Listing Function
38		#'
39		#' @inheritParams gen_args
40		#' @param ... additional arguments passed to [`rlistings::as_listing`].
41		#' @returns the main function returns an `rlistings` or a `list` object.
42		#'
43		#' @keywords internal
44		std_listing <- function(adam_db,
45		dataset,
46		key_cols,
47		disp_cols,
48		split_into_pages_by_var,
49		unique_rows = FALSE,
50		...) {
51	4x	assert_all_tablenames(adam_db, dataset)
52	4x	assert_valid_variable(adam_db[[dataset]], c(key_cols, disp_cols), label = paste0("adam_db$", dataset))
53
54	4x	execute_with_args(
55	4x	as_listing,
56	4x	df = adam_db[[dataset]],
57	4x	key_cols = key_cols,
58	4x	disp_cols = disp_cols,
59	4x	split_into_pages_by_var = split_into_pages_by_var,
60		...,
61	4x	default_formatting = listing_format_chevron(),
62	4x	unique_rows = unique_rows
63		)
64		}
65
66		# Special formats ----
67
68		#' Decimal formatting
69		#'
70		#' @param digits (`integer`) number of digits.
71		#' @param format (`string`) describing how the numbers should be formatted following the `sprintf` syntax.
72		#' @param ne (`string`) that should replace actual value. If `NULL`, no replacement is performed.
73		#'
74		#' @returns `function` formatting numbers with the defined format.
75		#'
76		#' @export
77		#'
78		#' @examples
79		#' fun <- h_format_dec(c(1, 1), "%s - %s")
80		#' fun(c(123, 567.89))
81		h_format_dec <- function(digits, format, ne = NULL) {
82	9149x	assert_integerish(digits, lower = 0)
83	9149x	assert_string(format)
84	9149x	assert_string(ne, null.ok = TRUE)
85	9149x	if (any(is.na(digits))) {
86	697x	function(x, ...) {
87		""
88		}
89		} else {
90	8452x	if (!is.null(ne)) {
91	4116x	ret <- function(x, ...) {
92	4116x	do_call(sprintf, c(list(fmt = format), rep(ne, length(digits))))
93		}
94	4116x	return(ret)
95		}
96	4336x	digit_string <- paste0("%", ifelse(is.na(digits), "", paste0(".", digits)), "f")
97	4336x	new_format <- do_call(sprintf, c(list(fmt = format), digit_string))
98	4336x	formatters::sprintf_format(new_format)
99		}
100		}
101
102		#' Fuse list elements
103		#'
104		#' @param x (`list`) to fuse.
105		#' @param y (`list`) to fuse. Elements with names already existing in `x` are discarded.
106		#'
107		#' @keywords internal
108		fuse_sequentially <- function(x, y) {
109	6x	if (missing(y)) {
110	1x	return(x)
111		}
112
113	5x	names_x <- names(x)
114	5x	sel_names_y <- setdiff(names(y), names_x)
115
116	5x	c(x, y[sel_names_y])
117		}
118
119		# lvl ----
120
121		#' @export
122		droplevels.character <- function(x, ...) {
123	1x	x
124		}
125
126		#' Obtain levels from vector
127		#'
128		#' @param x (`character`) or (`factor`) object to obtain levels.
129		#' @returns `character` with unique values.
130		#' @details
131		#' For factors, the levels will be returned. For characters, the sorted unique values will be returned.
132		#'
133		#' @export
134		lvls <- function(x) {
135	408x	UseMethod("lvls")
136		}
137		#' @export
138		lvls.default <- function(x) {
139	1x	NULL
140		}
141		#' @export
142		lvls.character <- function(x) {
143	8x	sort(unique(x))
144		}
145		#' @export
146		lvls.factor <- function(x) {
147	399x	levels(x)
148		}
149
150		#' @keywords internal
151		quote_str <- function(x) {
152	14x	assert_string(x)
153	13x	paste0("`", x, "`")
154		}
155
156		#' @keywords internal
157		modify_default_args <- function(fun, ...) {
158	1x	ret <- fun
159	1x	formals(ret) <- utils::modifyList(formals(fun), list(...), keep.null = TRUE)
160	1x	return(ret)
161		}
162
163		#' Execute function with given arguments
164		#'
165		#' @details If the function has `...`, this function will not pass other arguments to `...`.
166		#' Only named arguments are passed.
167		#'
168		#' @keywords internal
169		execute_with_args <- function(fun, ...) {
170	125x	args <- list(...)
171	125x	do_call(fun, args[intersect(names(args), formalArgs(fun))])
172		}
173
174		#' Execute a function call
175		#'
176		#' @keywords internal
177		do_call <- function(what, args) {
178	9273x	arg_names <- names(args)
179	9273x	if (is.null(arg_names)) {
180	118x	arg_names <- sprintf("var_%s", seq_along(args))
181	9155x	} else if (any(arg_names == "")) {
182	8612x	arg_names_random <- sprintf("var_%s", seq_along(args))
183	8612x	arg_names[arg_names == ""] <- arg_names_random[arg_names == ""]
184		}
185	9273x	args_env <- as.environment(setNames(args, arg_names))
186	9273x	parent.env(args_env) <- parent.frame()
187	9273x	new_args <- lapply(arg_names, as.symbol)
188	9273x	names(new_args) <- names(args)
189	9273x	do.call(what, new_args, envir = args_env)
190		}
191
192		#' Modify character
193		#'
194		#' @keywords internal
195		modify_character <- function(x, y) {
196	36x	assert_character(x, names = "unique", null.ok = TRUE)
197	36x	assert_character(y, names = "unique", null.ok = TRUE)
198	36x	c(y, x)[unique(c(names(x), names(y)))]
199		}
200
201		#' Expand list to each split
202		#' @keywords internal
203		expand_list <- function(lst, split) {
204	27x	assert_list(lst, names = "unique")
205	27x	assert_character(split)
206	27x	if ("all" %in% names(lst)) {
207	17x	lst <- lapply(
208	17x	setNames(split, split),
209	17x	function(x) {
210	34x	modify_character(lst$all, lst[[x]])
211		}
212		)
213		}
214	27x	lst
215		}
216
217		#' Helper function to convert to months if needed
218		#'
219		#' @param x (`numeric`) time.
220		#' @param unit (`character`) or (`factor`) time unit.
221		#'
222		#' @returns A `numeric` vector with the time in months.
223		#'
224		#' @export
225		convert_to_month <- function(x, unit) {
226	20x	assert_multi_class(unit, c("character", "factor"))
227	20x	assert_numeric(x, len = length(unit))
228
229	20x	unit <- toupper(unit)
230	20x	diff <- setdiff(unique(unit), c("DAYS", "MONTHS", "YEARS"))
231	20x	if (length(diff) > 0) {
232	1x	rlang::warn(
233	1x	paste0(
234	1x	"Time unit ", toString(diff), " not covered. No unit conversion applied."
235		)
236		)
237		}
238
239	20x	case_when(
240	20x	unit == "DAYS" ~ x / 30.4375,
241	20x	unit == "MONTHS" ~ x,
242	20x	unit == "YEARS" ~ x * 12,
243	20x	TRUE ~ x
244		)
245		}
246
247		#' Theme for Chevron Plot
248		#'
249		#' @param grid_y (`flag`) should horizontal grid be displayed.
250		#' @param grid_x (`flag`) should vertical grid be displayed.
251		#' @param legend_position (`string`) the position of the legend.
252		#' @param text_axis_x_rot (`numeric`) the x axis text rotation angle.
253		#'
254		#' @returns a `theme` object.
255		#'
256		#' @export
257		#'
258		gg_theme_chevron <- function(grid_y = TRUE,
259		grid_x = FALSE,
260		legend_position = "top",
261		text_axis_x_rot = 45) {
262	15x	assert_flag(grid_y)
263	15x	assert_flag(grid_x)
264	15x	assert_choice(legend_position, c("top", "bottom", "right", "left"))
265	15x	assert_numeric(text_axis_x_rot, len = 1, lower = -90, upper = 90)
266
267	15x	ggtheme <- ggplot2::theme_bw() +
268	15x	ggplot2::theme(legend.position = legend_position) +
269	15x	ggplot2::theme(axis.title.x = ggplot2::element_blank())
270
271	15x	ggtheme <- if (!grid_x) {
272	15x	ggtheme + ggplot2::theme(
273	15x	panel.grid.major.x = ggplot2::element_blank(),
274	15x	panel.grid.minor.x = ggplot2::element_blank()
275		)
276		} else {
277	!	ggtheme + ggplot2::theme(
278	!	panel.grid.major.x = ggplot2::element_line(linewidth = ggplot2::rel(0.5)),
279	!	panel.grid.minor.x = ggplot2::element_blank()
280		)
281		}
282
283	15x	ggtheme <- if (!grid_y) {
284	!	ggtheme + ggplot2::theme(
285	!	panel.grid.minor.y = ggplot2::element_blank(),
286	!	panel.grid.major.y = ggplot2::element_blank()
287		)
288		} else {
289	15x	ggtheme + ggplot2::theme(
290	15x	panel.grid.minor.y = ggplot2::element_blank(),
291	15x	panel.grid.major.y = ggplot2::element_line(linewidth = ggplot2::rel(0.5))
292		)
293		}
294
295	15x	ggtheme <- ggtheme + ggplot2::theme(
296	15x	axis.text.x = ggplot2::element_text(
297	15x	angle = text_axis_x_rot,
298	15x	hjust = get_x_hjust(text_axis_x_rot),
299	15x	vjust = get_x_vjust(text_axis_x_rot)
300		)
301		)
302
303	15x	ggtheme
304		}
305
306		#' Get a harmonious value of horizontal justification for x axis
307		#'
308		#' @param x (`numeric`) angle between -90 and 90 degree.
309		#' @keywords internal
310		get_x_hjust <- function(x) {
311	15x	assert_numeric(x, upper = 90, lower = -90, len = 1)
312
313	15x	if (x == 0) {
314	!	0.5
315	15x	} else if (x > 0) {
316	15x	1
317		} else {
318	!	0
319		}
320		}
321
322		#' Get a harmonious value of vertical justification for x axis
323		#'
324		#' @param x (`numeric`) angle between -90 and 90 degree.
325		#' @keywords internal
326		get_x_vjust <- function(x) {
327	15x	assert_numeric(x, upper = 90, lower = -90, len = 1)
328
329	15x	if (x == 0) {
330	!	0
331	15x	} else if (abs(x) == 90) {
332	!	0.5
333		} else {
334	15x	1
335		}
336		}
337
338		#' Get Section dividers
339		#' @export
340		#' @returns (`character`) value with section dividers at corresponding section.
341		get_section_div <- function() {
342	27x	x <- getOption("chevron.section_div", integer(0))
343	27x	if (!test_integerish(x)) {
344	!	ret <- NA_character_
345		} else {
346	27x	ret <- rep(NA_character_, max(x, 0))
347	27x	ret[x] <- ""
348		}
349	27x	ret
350		}
351
352		#' Set Section Dividers
353		#' @export
354		#' @param x (`integerish`) value of at which the section divider should be added.
355		#' @details Section dividers are empty lines between sections in tables.
356		#' E.g. if 1 is used then for the first row split an empty line is added.
357		#' Currently it only works for `aet02`, `cmt01a` and `mht01` template.
358		#' @returns invisible `NULL`. Set the `chevron.section_div` option.
359		#' @export
360		set_section_div <- function(x) {
361	4x	assert_integerish(x, min.len = 0L, any.missing = FALSE, lower = 1L)
362	2x	options("chevron.section_div" = x)
363	2x	invisible()
364		}
365
366		#' @keywords internal
367		to_list <- function(x) {
368	24x	if (length(x) == 1L) {
369	16x	return(x)
370		}
371	8x	x <- as.list(x)
372	8x	lapply(x, to_list)
373		}
374
375		# Deprecated functions ----
376
377		#' List of `grob` object
378		#'
379		#' `r lifecycle::badge("deprecated")`
380		#'
381		#' @param ... (`grob`) objects.
382		#' @returns a `grob_list` object.
383		#' @export
384		grob_list <- function(...) {
385	1x	lifecycle::deprecate_warn("0.2.5.9009", "grob_list()", "list()")
386	1x	list(...)
387		}
388
389		#' List of `gg` object
390		#'
391		#' `r lifecycle::badge("deprecated")`
392		#'
393		#' @param ... (`ggplot`) objects.
394		#' @returns a `gg_list` object.
395		#' @export
396		gg_list <- function(...) {
397	1x	lifecycle::deprecate_warn("0.2.5.9009", "gg_list()", "list()")
398	1x	list(...)
399		}
400
401
402		#' Format for Chevron Listings
403		#'
404		#' @return a `list` of `fmt_config`.
405		#'
406		listing_format_chevron <- function() {
407	17x	list(
408	17x	all = fmt_config(align = "left"),
409	17x	numeric = fmt_config(align = "center"),
410	17x	Date = fmt_config(format = format_date(), align = "left"),
411	17x	POSIXct = fmt_config(format = format_date(), align = "left"),
412	17x	POSIXt = fmt_config(format = format_date(), align = "left")
413		)
414		}
415
416		#' Formatting of date
417		#'
418		#' @param date_format (`string`) the output format.
419		#'
420		#' @return a `function` converting a date into `string`.
421		#'
422		#' @note The date is extracted at the location of the measure, not at the location of the system.
423		#'
424		#' @export
425		#' @examples
426		#' format_date("%d%b%Y")(as.Date("2021-01-01"))
427		#' if ("NZ" %in% OlsonNames()) {
428		#' format_date("%d%b%Y")(as.POSIXct("2021-01-01 00:00:01", tz = "NZ"))
429		#' }
430		#' if ("US/Pacific" %in% OlsonNames()) {
431		#' format_date("%d%b%Y")(as.POSIXct("2021-01-01 00:00:01", tz = "US/Pacific"))
432		#' }
433		format_date <- function(date_format = "%d%b%Y") {
434	55x	function(x, ...) {
435	1324x	toupper(
436	1324x	format(
437		# Extract the date at the location of the measure, not at the location of the system.
438	1324x	lubridate::force_tz(x, tzone = "UTC"),
439	1324x	date_format,
440	1324x	tz = "UTC"
441		)
442		)
443		}
444		}
445
446		# listing_id ----
447
448		#' Concatenate Site and Subject ID
449		#'
450		#' @param site (`string`)
451		#' @param subject (`string`)
452		#' @param sep (`string`)
453		#'
454		#' @note the `{Patient_label}` whisker placeholder will be used in the label.
455		#'
456		#' @export
457		#' @examples
458		#' create_id_listings("BRA-1", "xxx-1234")
459		create_id_listings <- function(site, subject, sep = "/") {
460	6x	assert_character(site)
461	6x	assert_character(subject)
462	6x	assert_string(sep)
463
464	6x	subject_id <- stringr::str_split_i(subject, pattern = "-", i = -1)
465
466	6x	with_label(paste(site, subject_id, sep = sep), render_safe("Center/{Patient_label} ID"))
467		}

1		#' @include chevron_tlg-S4class.R
2
3		# run ----
4
5		#' Run the TLG-generating pipeline
6		#'
7		#' Execute sequential the pre-processing, main and post-processing functions.
8		#'
9		#' @details
10		#' The functions stored in the `preprocess`, `main` and `postprocess` slots of the `chevron_tlg` objects are called
11		#' respectively, `preprocessing`, `main` and `postprocessing` functions.
12		#'
13		#' When executing the `run` method on a `chevron_tlg` object, if `auto_pre` is `TRUE`, the `adam_bd` list is first
14		#' passed to the `preprocessing` function. The resulting list is then passed to the `main` function which produces a
15		#' table, graph or listings or a list of these objects. This output is then passed to the `postprocessing` function
16		#' which performed the final modifications before returning the output. Additional arguments specified in `...` or
17		#' `user_args` are passed to each of the three functions.
18		#'
19		#' @inheritParams gen_args
20		#' @param object (`chevron_tlg`) input.
21		#' @param auto_pre (`flag`) whether to perform the default pre processing step.
22		#' @param verbose (`flag`) whether to print argument information.
23		#' @param unwrap (`flag`) whether to print the preprocessing postprocessing and main function together with the
24		#' associated layout function.
25		#' @param ... extra arguments to pass to the pre-processing, main and post-processing functions.
26		#' @param user_args (`list`) arguments from `...`.
27		#' @returns an `rtables` (for `chevron_t`), `rlistings` (for `chevron_l`), `grob` (for `chevron_g`) or `ElementaryTable`
28		#' (null report) depending on the class of `chevron_tlg` object passed as `object` argument.
29		#'
30		#' @name run
31		#' @export
32		setGeneric(
33		"run",
34		function(object, adam_db, auto_pre = TRUE, verbose = FALSE, unwrap = FALSE, ..., user_args = list(...)) {
35	236x	standardGeneric("run")
36		}
37		)
38
39		#' Run the TLG-generating pipeline
40		#' @rdname run
41		#' @export
42		#' @examples
43		#' run(mng01, syn_data, auto_pre = TRUE, dataset = "adlb")
44		setMethod(
45		f = "run",
46		signature = "chevron_tlg",
47		definition = function(object,
48		adam_db,
49		auto_pre = TRUE,
50		verbose = get_arg("chevron.run.verbose", "R_CHEVRON_RUN_VERBOSE", FALSE),
51		unwrap = get_arg("chevron.run.unwrap", "R_CHEVRON_RUN_UNWRAP", verbose),
52		...,
53		user_args = list(...)) {
54	236x	assert_list(adam_db, types = "data.frame", names = "unique")
55	236x	assert_flag(auto_pre)
56	236x	verbose <- as.logical(verbose)
57	236x	assert_flag(verbose)
58	236x	unwrap <- as.logical(unwrap)
59	236x	assert_flag(unwrap)
60	236x	assert_list(user_args, names = "unique")
61	236x	args <- list(...)
62	236x	assert_list(args, names = "unique", .var.name = "...")
63	236x	additional_names <- setdiff(names(user_args), names(args))
64	236x	user_args <- modifyList(user_args, args, keep.null = TRUE)
65
66	236x	if (verbose) {
67	9x	cl <- match.call()
68	9x	print_args(
69	9x	run_call = cl,
70	9x	additional_args = user_args[additional_names],
71	9x	args = args_ls(object, omit = c("...", "adam_db", "tlg")),
72	9x	auto_pre = auto_pre
73		)
74		}
75
76	236x	if (unwrap) {
77	5x	if (auto_pre) {
78	4x	cat("Preprocessing function:\n")
79	4x	cat(paste(deparse(preprocess(object)), collapse = "\n"), "\n")
80	4x	cat("\n")
81		}
82
83	5x	cat("Main function:\n")
84	5x	cat(paste(deparse(main(object)), collapse = "\n"), "\n")
85	5x	cat("\n")
86
87		# Show layout function from main if it exists.
88	5x	unwrap_layout(main(object))
89
90	5x	cat("Postprocessing function:\n")
91	5x	cat(paste(deparse(postprocess(object)), collapse = "\n"), "\n")
92		}
93
94	236x	proc_data <- if (auto_pre) {
95	234x	list(adam_db = do_call(object@preprocess, c(list(adam_db), user_args)))
96		} else {
97	2x	list(adam_db = adam_db)
98		}
99
100	223x	res_tlg <- list(tlg = do_call(object@main, c(proc_data, user_args)))
101
102	213x	do_call(object@postprocess, c(res_tlg, user_args))
103		}
104		)
105
106		#' Print Arguments
107		#' @keywords internal
108		print_args <- function(run_call, additional_args, args, auto_pre = TRUE) {
109	9x	assert_class(run_call, "call")
110	9x	assert_list(args)
111	9x	assert_flag(auto_pre)
112
113	9x	run_call[[1]] <- NULL
114	9x	run_call <- as.list(run_call)
115
116	9x	run_call[c("auto_pre", "verbose", "user_args", "unwrap")] <- NULL
117	9x	if (!is.null(additional_args)) {
118	9x	run_call <- c(run_call, additional_args)
119		}
120	9x	nms_args <- unique(unlist(lapply(args, names)))
121	9x	nms_call <- names(run_call)
122	9x	m <- pmatch(nms_call, nms_args)
123	9x	nms_call[!is.na(m)] <- nms_args[m[!is.na(m)]]
124	9x	names(run_call) <- nms_call
125	9x	cat(
126	9x	"Using template: ",
127	9x	if (is.name(run_call$object)) run_call$object else paste("object of class", class(run_call$object)),
128	9x	"\n"
129		)
130	9x	cat(
131	9x	"Using data: ",
132	9x	if (is.name(run_call$adam_db)) run_call$adam_db else paste("object of class", class(run_call$adam_db)),
133	9x	"\n"
134		)
135	9x	if (auto_pre) {
136	9x	cat("\nPre args:\n")
137	9x	print_list(get_subset(args$preprocess, run_call))
138		}
139	9x	cat("\nMain args:\n")
140	9x	print_list(get_subset(args$main, run_call))
141	9x	cat("\nPost args:\n")
142	9x	print_list(get_subset(args$postprocess, run_call))
143	9x	add_args <- run_call[
144	9x	!names(run_call) %in% c(names(args$main), names(args$postprocess), names(args$preprocess), "object", "adam_db")
145		]
146	9x	if (length(add_args) > 0) {
147	3x	cat("\nAdditional args:\n")
148	3x	print_list(add_args)
149		}
150	9x	cat("\n\n")
151		}
152
153		#' Subset Arguments and Merge
154		#' @keywords internal
155		get_subset <- function(x, y) {
156	27x	utils::modifyList(
157	27x	x,
158	27x	y[names(y) %in% names(x)],
159	27x	keep.null = TRUE
160		)
161		}
162
163		#' Print list
164		#' @keywords internal
165		print_list <- function(x, indent = 2L) {
166	32x	if (length(x) == 0) {
167	6x	cat(paste0(
168	6x	stringr::str_dup(" ", indent),
169	6x	"No mapped argument.\n"
170		))
171	6x	return()
172		}
173	26x	k <- names(x)
174	26x	m_charx <- max(nchar(k), 1)
175	26x	for (k in names(x)) {
176	69x	cat(
177	69x	sprintf(
178	69x	paste0("%s%-", m_charx + 2, "s: %s\n"),
179	69x	stringr::str_dup(" ", indent), k,
180	69x	deparse_print(x[[k]], m_charx + indent + 2)
181		)
182		)
183		}
184		}
185
186		#' Deparse print
187		#' @keywords internal
188		deparse_print <- function(x, indent, max_line = getOption("chevron.arg_max_line", 5L)) {
189	69x	assert_int(indent)
190	69x	assert_int(max_line, lower = 1L)
191	69x	ret <- deparse(x)
192	69x	sep <- paste0("\n", stringr::str_dup(" ", indent))
193	69x	if (length(ret) > max_line) {
194	2x	ret[max_line] <- sprintf("... (print of class <%s> truncated)", toString(class(x)))
195	2x	ret <- ret[seq_len(max_line)]
196		}
197	69x	paste(ret, collapse = sep)
198		}
199
200		# args_ls ----
201
202		#' Get Arguments List
203		#'
204		#' @param x (`chevron_tlg`) input.
205		#' @param simplify (`flag`) whether to simplify the output, coalescing the values of the parameters. The order of
206		#' priority for the value of the parameters is: `main`, `preprocess` and `postprocess`.
207		#' @param omit (`character`) the names of the argument to omit from the output.
208		#' @returns a `list` of the formal arguments with their default for the functions stored in the `chevron_tlg` object
209		#' passed a `x` argument.
210		#'
211		#' @rdname args_ls
212		#' @export
213		#' @examples
214		#' args_ls(aet01, simplify = TRUE)
215	12x	setGeneric("args_ls", function(x, simplify = FALSE, omit = NULL) standardGeneric("args_ls"))
216
217		#' @rdname args_ls
218		#' @export
219		setMethod(
220		f = "args_ls",
221		signature = "chevron_tlg",
222		definition = function(x, simplify = FALSE, omit = NULL) {
223	12x	assert_flag(simplify)
224	12x	assert_character(omit, null.ok = TRUE)
225
226	12x	x_ls <- list(
227	12x	main = formals(x@main),
228	12x	preprocess = formals(x@preprocess),
229	12x	postprocess = formals(x@postprocess)
230		)
231
232	12x	x_sel <- lapply(x_ls, function(y) y[!names(y) %in% omit])
233
234	12x	res <- if (simplify) {
235	2x	Reduce(fuse_sequentially, x_sel)
236		} else {
237	10x	x_sel
238		}
239
240	12x	res
241		}
242		)
243
244		# main ----
245
246		#' Main
247		#'
248		#' retrieve or set `main` function.
249		#'
250		#' @param x (`chevron_tlg`) input.
251		#' @returns the `function` stored in the `main` slot of the `x` argument.
252		#'
253		#' @aliases main
254		#' @export
255	11x	setGeneric("main", function(x) standardGeneric("main"))
256
257		#' @rdname main
258		#' @export
259		setMethod(
260		f = "main",
261		signature = "chevron_tlg",
262		definition = function(x) {
263	11x	x@main
264		}
265		)
266
267		#' Set Main Function
268		#'
269		#' @param x (`chevron_tlg`) input.
270		#' @param value (`function`) returning a `tlg`. Typically one of the `_main` function of `chevron`.
271		#'
272		#' @rdname main
273		#' @export
274	5x	setGeneric("main<-", function(x, value) standardGeneric("main<-"))
275
276		#' @rdname main
277		#' @export
278		setMethod(
279		f = "main<-",
280		signature = "chevron_tlg",
281		definition = function(x, value) {
282	5x	x@main <- value
283	5x	validObject(x)
284	3x	x
285		}
286		)
287
288		# preprocess ----
289
290		#' Pre process
291		#'
292		#' retrieve or set `preprocess` function.
293		#'
294		#' @param x (`chevron_tlg`) input.
295		#'
296		#' @aliases preprocess
297		#' @export
298	6x	setGeneric("preprocess", function(x) standardGeneric("preprocess"))
299
300		#' @rdname preprocess
301		#' @export
302		setMethod(
303		f = "preprocess",
304		signature = "chevron_tlg",
305		definition = function(x) {
306	6x	x@preprocess
307		}
308		)
309
310		#' Set Preprocess Function
311		#'
312		#' @param x (`chevron_tlg`) input.
313		#' @param value (`function`) returning a pre-processed `list` of `data.frames` amenable to `tlg` creation. Typically
314		#' one of the `_pre` function of `chevron`.
315		#' @returns the `function` stored in the `preprocess` slot of the `x` argument.
316		#'
317		#' @rdname preprocess
318		#' @export
319	4x	setGeneric("preprocess<-", function(x, value) standardGeneric("preprocess<-"))
320
321		#' @rdname preprocess
322		#' @export
323		setMethod(
324		f = "preprocess<-",
325		signature = "chevron_tlg",
326		definition = function(x, value) {
327	4x	x@preprocess <- value
328	4x	validObject(x)
329	3x	x
330		}
331		)
332
333		# postprocess ----
334
335		#' Post process
336		#'
337		#' retrieve or set `postprocess` function.
338		#'
339		#' @param x (`chevron_tlg`) input.
340		#' @returns the `function` stored in the `postprocess` slot of the `x` argument.
341		#'
342		#' @aliases postprocess
343		#' @export
344	6x	setGeneric("postprocess", function(x) standardGeneric("postprocess"))
345
346		#' @rdname postprocess
347		#' @export
348		setMethod(
349		f = "postprocess",
350		signature = "chevron_tlg",
351		definition = function(x) {
352	6x	x@postprocess
353		}
354		)
355
356		#' Postprocess Assignment Function
357		#'
358		#' @param x (`chevron_tlg`) input.
359		#' @param value (`function`) returning a post-processed `tlg`.
360		#'
361		#' @rdname postprocess
362		#' @export
363	2x	setGeneric("postprocess<-", function(x, value) standardGeneric("postprocess<-"))
364
365		#' @rdname postprocess
366		#' @export
367		setMethod(
368		f = "postprocess<-",
369		signature = "chevron_tlg",
370		definition = function(x, value) {
371	2x	x@postprocess <- value
372	2x	validObject(x)
373	1x	x
374		}
375		)
376
377		# script ----
378
379		#' Create Script for `TLG` Generation
380		#'
381		#' @param x (`chevron_tlg`) input.
382		#' @param adam_db (`string`) the name of the dataset.
383		#' @param name (`string`) name of the template.
384		#' @param args (`string`) the name of argument list.
385		#' @returns `character` that can be integrated into an executable script.
386		#'
387		#' @name script
388		#' @rdname script
389		NULL
390
391		#' @rdname script
392		#' @export
393	3x	setGeneric("script_funs", function(x, adam_db, args, name = deparse(substitute(x))) standardGeneric("script_funs"))
394
395		#' @rdname script
396		#' @export
397		#'
398		#' @examples
399		#' script_funs(aet04, adam_db = "syn_data", args = "args")
400		setMethod(
401		f = "script_funs",
402		signature = "chevron_tlg",
403		definition = function(x, adam_db, args, name) {
404	2x	checkmate::assert_string(adam_db)
405	2x	checkmate::assert_string(args)
406	2x	checkmate::assert_string(name)
407	2x	c(
408	2x	"# Edit Preprocessing Function.",
409	2x	glue::glue("preprocess({name}) <- "),
410	2x	deparse(preprocess(x)),
411		"",
412	2x	"# Create TLG",
413	2x	glue::glue(
414	2x	"tlg_output <- run(object = {name}, adam_db = {adam_db}",
415	2x	", verbose = TRUE, user_args = {args})"
416		)
417		)
418		}
419		)
420
421		#' @rdname script
422		#' @export
423		#'
424		setMethod(
425		f = "script_funs",
426		signature = "chevron_simple",
427		definition = function(x, adam_db, args, name) {
428	1x	checkmate::assert_string(adam_db)
429	1x	main_body <- body(main(x))
430	1x	c(
431	1x	"# Create TLG",
432	1x	if (!identical(adam_db, "adam_db")) {
433	1x	glue::glue("adam_db <- {adam_db}")
434		},
435		"",
436	1x	"tlg_output <- ",
437	1x	deparse(main_body)
438		)
439		}
440		)

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

1		# fstg01 ----
2
3		#' @describeIn fstg01 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 rsp_var (`string`) the response variable name to flag whether each subject is a binary response or not.
13		#' @param subgroups (`character`) the subgroups variable name to list baseline risk factors.
14		#' @param strata_var (`character`) required if stratified analysis is performed.
15		#' @param stat_var (`character`) the names of statistics to be reported in `tabulate_rsp_subgroups`.
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		#' @returns the main function returns a `grob` object.
21		#'
22		#' @note
23		#' * `adam_db` object must contain the table specified by `dataset` with `"PARAMCD"`, `"ARM"`,
24		#' `"AVALC"`, and the columns specified by `subgroups` which is denoted as
25		#' `c("SEX", "AGEGR1", "RACE")` by default.
26		#' * If the plot is too large to be rendered in the output, please provide `gp`, `width_row_names`,
27		#' `width_columns` and `width_forest` manually to make it fit. See `tern::g_forest` for more details.
28		#'
29		#' @returns a `gTree` object.
30		#'
31		#' @export
32		#'
33		fstg01_main <- function(adam_db,
34		dataset = "adrs",
35		arm_var = "ARM",
36		rsp_var = "IS_RSP",
37		subgroups = c("SEX", "AGEGR1", "RACE"),
38		strata_var = NULL,
39		stat_var = c("n_tot", "n", "n_rsp", "prop", "or", "ci"),
40		...) {
41	1x	assert_all_tablenames(adam_db, c("adsl", dataset))
42	1x	df_lbl <- paste0("adam_db$", dataset)
43	1x	assert_string(arm_var)
44	1x	assert_string(rsp_var)
45	1x	assert_character(subgroups, null.ok = TRUE)
46	1x	assert_character(strata_var, null.ok = TRUE)
47	1x	assert_character(stat_var, null.ok = TRUE)
48	1x	assert_valid_variable(adam_db[[dataset]], arm_var, types = list("factor"), n.levels = 2, label = df_lbl)
49	1x	assert_valid_variable(adam_db[[dataset]], c("USUBJID", "PARAMCD"),
50	1x	types = list(c("character", "factor")),
51	1x	label = df_lbl
52		)
53	1x	assert_valid_variable(adam_db[[dataset]], rsp_var, types = list("logical"), label = df_lbl)
54	1x	assert_valid_variable(adam_db[[dataset]], c(subgroups, strata_var),
55	1x	types = list(c("factor")), na_ok = TRUE,
56	1x	label = df_lbl
57		)
58	1x	assert_single_value(adam_db[[dataset]]$PARAMCD, label = df_lbl)
59
60	1x	variables <- list(
61	1x	arm = arm_var,
62	1x	rsp = rsp_var,
63	1x	subgroups = subgroups,
64	1x	strata = strata_var
65		)
66
67	1x	df <- execute_with_args(extract_rsp_subgroups,
68	1x	variables = variables,
69	1x	data = adam_db[[dataset]],
70		...
71		)
72	1x	result <- basic_table() %>%
73	1x	tabulate_rsp_subgroups(df, vars = stat_var)
74	1x	execute_with_args(
75	1x	g_forest,
76	1x	tbl = result,
77		...,
78	1x	font_size = 7
79		)
80		}
81
82		#' @describeIn fstg01 Preprocessing
83		#'
84		#' @inheritParams fstg01_main
85		#' @returns the preprocessing function returns a `list` of `data.frame`.
86		#'
87		#' @export
88		#'
89		fstg01_pre <- function(adam_db, ...) {
90	1x	adam_db$adrs <- adam_db$adrs %>%
91	1x	mutate(
92	1x	ARM = droplevels(.data$ARM),
93	1x	IS_RSP = .data$AVALC %in% c("CR", "PR")
94		)
95
96	1x	adam_db
97		}
98
99		# `fstg01` Pipeline ----
100
101		#' `FSTG01` Subgroup Analysis of Best Overall Response.
102		#'
103		#' The template produces the subgroup analysis of best overall response graphic.
104		#'
105		#' @include chevron_tlg-S4class.R
106		#' @export
107		#'
108		#' @examples
109		#' library(dplyr)
110		#' library(dunlin)
111		#'
112		#' proc_data <- log_filter(
113		#' syn_data,
114		#' PARAMCD == "BESRSPI" & ARM %in% c("A: Drug X", "B: Placebo"), "adrs"
115		#' )
116		#' run(fstg01, proc_data,
117		#' subgroups = c("SEX", "AGEGR1", "RACE"),
118		#' conf_level = 0.90, dataset = "adrs"
119		#' )
120		fstg01 <- chevron_g(
121		main = fstg01_main,
122		preprocess = fstg01_pre
123		)

1		# rmpt06 ----
2
3		#' @describeIn rmpt06 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param method (`string`) the method used to construct the confidence interval. See [`tern::estimate_proportion`].
7		#' @param conf_level (`proportion`) the confidence level of the interval. See [`tern::estimate_proportion`].
8		#' @param show_diff (`flag`) whether to show the difference of patient with at least one adverse event between groups.
9		#' @param ref_group (`string`) the reference group for the difference.
10		#' @param method_diff (`string`) the method used to construct the confidence interval for the difference between groups.
11		#' @param conf_level_diff (`proportion`) the confidence level of the interval for the difference between groups.
12		#' @param grade_groups (`list`) the grade groups to be displayed.
13		#' @returns the main function returns an `rtables` object.
14		#'
15		#' @export
16		rmpt06_main <- function(adam_db,
17		arm_var = "ACTARM",
18		lbl_overall = NULL,
19		method = "clopper-pearson",
20		conf_level = 0.95,
21		show_diff = FALSE,
22		ref_group = NULL,
23		method_diff = "wald",
24		conf_level_diff = 0.95,
25		grade_groups = NULL,
26		...) {
27	2x	assert_all_tablenames(adam_db, "adsl", "adae")
28	2x	assert_string(arm_var)
29	2x	assert_string(lbl_overall, null.ok = TRUE)
30	2x	assert_choice(
31	2x	method,
32	2x	c("waldcc", "wald", "clopper-pearson", "wilson", "wilsonc", "agresti-coull", "jeffreys")
33		)
34	2x	assert_numeric(conf_level, lower = 0, upper = 1)
35	2x	assert_flag(show_diff)
36	2x	assert_choice(
37	2x	method_diff,
38	2x	c("waldcc", "wald", "cmh", "ha", "newcombe", "newcombecc")
39		)
40	2x	assert_numeric(conf_level_diff, lower = 0, upper = 1)
41	2x	assert_list(grade_groups, null.ok = TRUE)
42	2x	assert_valid_variable(adam_db$adsl, "AEFL", types = list("logical"))
43	2x	assert_valid_variable(adam_db$adae, "ATOXGR", na_ok = TRUE, types = list("factor"))
44	2x	assert_valid_variable(adam_db$adae, "AESER", types = list("character", "factor"))
45	2x	assert_valid_variable(adam_db$adae, "AEOUT", na_ok = TRUE, types = list("factor"))
46	2x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var))
47	2x	assert_valid_variable(adam_db$adae, c(arm_var), types = list(c("character", "factor")))
48	2x	assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
49	2x	assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)
50
51	2x	lbl_overall <- render_safe(lbl_overall)
52
53	2x	if (is.null(grade_groups)) {
54	2x	grade_groups <- list(
55	2x	"Grade 1" = "1",
56	2x	"Grade 2" = "2",
57	2x	"Grade 3" = "3",
58	2x	"Grade 4" = "4",
59	2x	"Grade 5 (fatal outcome)" = "5"
60		)
61		}
62
63	2x	ref_group <- ref_group %\|\|% lvls(adam_db$adsl[[arm_var]])[1]
64
65	2x	lyt <- rmpt06_lyt(
66	2x	arm_var = arm_var,
67	2x	lbl_overall = lbl_overall,
68	2x	method = method,
69	2x	ref_group = ref_group,
70	2x	conf_level = conf_level,
71	2x	show_diff = show_diff,
72	2x	method_diff = method_diff,
73	2x	conf_level_diff = conf_level_diff,
74	2x	grade_groups = grade_groups
75		)
76
77	2x	tbl_adsl <- build_table(lyt$adsl, adam_db$adsl)
78	2x	tbl_adae <- build_table(lyt$adae, adam_db$adae, alt_counts_df = adam_db$adsl)
79
80	2x	col_info(tbl_adae) <- col_info(tbl_adsl)
81
82	2x	rbind(
83	2x	tbl_adsl,
84	2x	tbl_adae
85		)
86		}
87
88		#' `rmpt06` Layout
89		#'
90		#' @inheritParams gen_args
91		#'
92		#' @keywords internal
93		#'
94		rmpt06_lyt <- function(arm_var,
95		lbl_overall,
96		method,
97		conf_level,
98		show_diff,
99		ref_group,
100		method_diff,
101		conf_level_diff,
102		grade_groups) {
103	4x	lyt <- basic_table(show_colcounts = TRUE) %>%
104	4x	split_cols_by_with_overall(arm_var, lbl_overall, ref_group = ref_group)
105
106	4x	lyt_adsl <- lyt %>%
107	4x	estimate_proportion(
108	4x	vars = "AEFL",
109	4x	method = method,
110	4x	conf_level = conf_level,
111	4x	.labels = c(
112	4x	n_prop = render_safe("Number of {patient_label} with at least one adverse event"),
113	4x	prop_ci = paste0(
114	4x	100 * conf_level,
115	4x	render_safe("% CI for % of {patient_label} with at least one AE")
116		)
117		),
118	4x	table_names = "est_prop"
119		)
120
121	4x	if (show_diff) {
122	1x	lyt_adsl <- lyt_adsl %>%
123	1x	estimate_proportion_diff(
124	1x	vars = "AEFL",
125	1x	method = method_diff,
126	1x	conf_level = conf_level_diff,
127	1x	.labels = c(
128	1x	diff = render_safe("Difference in % of {patient_label} with at least one AE"),
129	1x	diff_ci = paste0(
130	1x	100 * conf_level_diff,
131	1x	"% CI of difference"
132		)
133		),
134	1x	table_names = "est_diff"
135		)
136		}
137
138	4x	lyt_adae <- lyt %>%
139	4x	analyze_num_patients(
140	4x	vars = "USUBJID",
141	4x	.stats = c("nonunique"),
142	4x	.labels = c(
143	4x	nonunique = "Total number of AEs"
144		),
145	4x	.formats = list(nonunique = "xx"),
146	4x	show_labels = "hidden"
147		) %>%
148	4x	count_occurrences_by_grade(
149	4x	var = "ATOXGR",
150	4x	var_labels = render_safe("Total number of {patient_label} with at least one AE by worst grade"),
151	4x	show_labels = "visible",
152	4x	grade_groups = grade_groups
153		) %>%
154	4x	count_patients_with_event(
155	4x	"USUBJID",
156	4x	filters = c("AESER" = "Y"),
157	4x	.labels = c(count_fraction = render_safe("Number of {patient_label} with at least one serious AE")),
158	4x	denom = "N_col",
159	4x	.formats = c(count_fraction = format_count_fraction_fixed_dp),
160	4x	table_names = "aeser"
161		) %>%
162	4x	count_occurrences(
163	4x	"AEOUT",
164	4x	denom = "n",
165	4x	var_labels = render_safe("Number of {patient_label} with at least one AE by outcome"),
166	4x	show_labels = "visible",
167	4x	drop = FALSE
168		)
169
170
171	4x	list(
172	4x	adsl = lyt_adsl,
173	4x	adae = lyt_adae
174		)
175		}
176
177		#' @describeIn rmpt06 Preprocessing
178		#'
179		#' @inheritParams rmpt06_main
180		#' @returns the preprocessing function returns a `list` of `data.frame`.
181		#' @export
182		rmpt06_pre <- function(adam_db, ...) {
183	2x	aeout_rule <- rule(
184	2x	"Fatal outcome" = "FATAL",
185	2x	"Unresolved" = "NOT RECOVERED/NOT RESOLVED",
186	2x	"Recovered/Resolved" = "RECOVERED/RESOLVED",
187	2x	"Resolved with sequelae" = "RECOVERED/RESOLVED WITH SEQUELAE",
188	2x	"Recovering/Resolving" = "RECOVERING/RESOLVING",
189	2x	"Unknown outcome" = "UNKNOWN"
190		)
191
192	2x	adam_db$adae <- adam_db$adae %>%
193	2x	filter(.data$ANL01FL == "Y") %>%
194	2x	mutate(AEOUT = reformat(.data$AEOUT, aeout_rule))
195
196	2x	adam_db$adsl <- adam_db$adsl %>%
197	2x	mutate(AEFL = .data$USUBJID %in% .env$adam_db$adae$USUBJID)
198
199	2x	adam_db
200		}
201
202		#' @describeIn rmpt06 Postprocessing
203		#'
204		#' @inheritParams gen_args
205		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
206		#' @export
207		#'
208		rmpt06_post <- function(tlg, prune_0 = FALSE, ...) {
209	!	if (prune_0) {
210	!	tlg <- smart_prune(tlg)
211		}
212	!	std_postprocessing(tlg)
213		}
214
215		#' `RMPT06` Table 1 (Default) Seriousness, Outcomes, Severity, Frequency with 95% CI for Risk Management Plan.
216		#'
217		#' @include chevron_tlg-S4class.R
218		#' @export
219		#'
220		#' @examples
221		#' run(rmpt06, syn_data)
222		rmpt06 <- chevron_t(
223		main = rmpt06_main,
224		preprocess = rmpt06_pre,
225		postprocess = rmpt06_post
226		)

1		# aet10 ----
2
3		#' @describeIn aet10 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @returns the main function returns an `rtables` object
7		#' @details
8		#' * Numbers represent absolute numbers of subject and fraction of `N`, or absolute number of event when specified.
9		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
10		#' * Split columns by arm.
11		#' * Does not include a total column by default.
12		#' * Sort Dictionary-Derived Code (`AEDECOD`) by highest overall frequencies.
13		#' * Missing values in `AEDECOD` are labeled by `No Coding Available`.
14		#'
15		#' @note
16		#' * `adam_db` object must contain an `adae` table with the columns `"AEDECOD"`.
17		#'
18		#' @export
19		#'
20		aet10_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"), 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_aedecod <- var_labels_for(adam_db$adae, "AEDECOD")
34
35	1x	lyt <- aet10_lyt(
36	1x	arm_var = arm_var,
37	1x	lbl_overall = lbl_overall,
38	1x	lbl_aedecod = lbl_aedecod
39		)
40
41	1x	tbl <- build_table(lyt, adam_db$adae, alt_counts_df = adam_db$adsl)
42
43	1x	tbl
44		}
45
46		#' `aet10` Layout
47		#'
48		#' @inheritParams gen_args
49		#' @param lbl_aedecod (`character`) text label for `AEDECOD`.
50		#' @returns a `PreDataTableLayouts` object.
51		#' @keywords internal
52		#'
53		aet10_lyt <- function(arm_var,
54		lbl_overall,
55		lbl_aedecod) {
56	3x	basic_table(show_colcounts = TRUE) %>%
57	3x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
58	3x	count_occurrences(
59	3x	vars = "AEDECOD",
60	3x	.indent_mods = -1L
61		) %>%
62	3x	append_topleft(paste0("\n", lbl_aedecod))
63		}
64
65		#' @describeIn aet10 Preprocessing
66		#'
67		#' @inheritParams gen_args
68		#' @returns the preprocessing function returns a `list` of `data.frame`.
69		#' @export
70		#'
71		aet10_pre <- function(adam_db, ...) {
72	1x	adam_db$adae <- adam_db$adae %>%
73	1x	filter(.data$ANL01FL == "Y") %>%
74	1x	mutate(AEDECOD = reformat(.data$AEDECOD, nocoding))
75	1x	return(adam_db)
76		}
77
78		#' @describeIn aet10 Postprocessing
79		#'
80		#' @inheritParams gen_args
81		#' @param atleast given cut-off in numeric format, default is `0.05`
82		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
83		#' @export
84		#'
85		aet10_post <- function(tlg, atleast = 0.05, ...) {
86	1x	assert_number(atleast, lower = 0, upper = 1)
87	1x	tbl_sorted <- tlg %>%
88	1x	sort_at_path(
89	1x	path = c("AEDECOD"),
90	1x	scorefun = score_occurrences
91		)
92
93	1x	tlg_prune <- prune_table(
94	1x	tt = tbl_sorted,
95	1x	prune_func = keep_rows(
96	1x	has_fraction_in_any_col(
97	1x	atleast = atleast
98		)
99		)
100		)
101
102	1x	std_postprocessing(tlg_prune)
103		}
104
105		#' `AET10` Table 1 (Default) Most Common (xx%) Adverse Events Preferred Terms Table 1.
106		#'
107		#' The `AET10` table Include Adverse Events occurring with user-specified threshold X% in at least
108		#' one of the treatment groups. Standard table summarized by preferred term (PT).
109		#' Order the data by total column frequency from most to least frequently reported PT (regardless of SOC).
110		#'
111		#' @include chevron_tlg-S4class.R
112		#' @export
113		#'
114		#' @examples
115		#' run(aet10, syn_data)
116		aet10 <- chevron_t(
117		main = aet10_main,
118		preprocess = aet10_pre,
119		postprocess = aet10_post
120		)

1		#' @include utils.R
2		#' @include report_null.R
3
4		# Chevron_tlg ----
5
6		#' `chevron_tlg` class
7		#'
8		#' The `chevron_tlg` S4 class associates a `preprocess` function, a main `tlg` function and a `postprocess` function.
9		#'
10		#' @slot main (`function`) returning a `tlg`. Typically one of the `*_main` function from `chevron`.
11		#' @slot preprocess (`function`) returning a pre-processed `list` of `data.frames` amenable to `tlg` creation. Typically
12		#' one of the `*_pre` function from `chevron`.
13		#' @slot postprocess (`function`) returning a post-processed `tlg`. Typically one of the `*_post` function from
14		#' `chevron`.
15		#'
16		#' @format NULL
17		#'
18		#' @note To ensure the correct execution of the workflow, additional validation criteria are:
19		#' * the first argument of the `main` function must be `adam_db`, the input `list` of `data.frames` to pre-process. The
20		#' `...` argument is mandatory.
21		#' * the first argument of the `preprocess` function must be `adam_db`, the input `list` of `data.frames` to create
22		#' `tlg` output. The `...` argument is mandatory.
23		#' * the first argument of the `postprocess` function must be `tlg`, the input `TableTree` object to post-process. The
24		#' `...` argument is mandatory.
25		#'
26		#' @name chevron_tlg-class
27		#' @exportClass chevron_tlg
28		.chevron_tlg <- setClass(
29		"chevron_tlg",
30		contains = "VIRTUAL",
31		slots = c(
32		main = "function",
33		preprocess = "function",
34		postprocess = "function"
35		)
36		)
37
38		# Validation ----
39
40		methods::setValidity("chevron_tlg", function(object) {
41		coll <- makeAssertCollection()
42		assert_function(object@main, args = c("adam_db"), ordered = TRUE, add = coll)
43		assert_function(object@main, args = "...", add = coll)
44		assert_function(object@preprocess, args = c("adam_db"), ordered = TRUE, add = coll)
45		assert_function(object@preprocess, args = "...", add = coll)
46		assert_function(object@postprocess, args = c("tlg"), ordered = TRUE, add = coll)
47		assert_function(object@postprocess, args = "...", add = coll)
48		reportAssertions(coll)
49		})
50
51		# Subclasses ----
52
53		## chevron_t ----
54
55		#' `chevron_t`
56		#'
57		#' `chevron_t`, a subclass of [chevron::chevron_tlg-class] with specific validation criteria to handle table creation
58		#'
59		#' @aliases chevron_table
60		#' @rdname chevron_tlg-class
61		#' @exportClass chevron_t
62		.chevron_t <- setClass(
63		"chevron_t",
64		contains = "chevron_tlg"
65		)
66
67		## chevron_l ----
68
69		#' `chevron_l`
70		#'
71		#' `chevron_l`, a subclass of [chevron::chevron_tlg-class] with specific validation criteria to handle listing creation
72		#'
73		#' @aliases chevron_listing
74		#' @rdname chevron_tlg-class
75		#' @exportClass chevron_l
76		.chevron_l <- setClass(
77		"chevron_l",
78		contains = "chevron_tlg"
79		)
80
81		## chevron_g ----
82
83		#' `chevron_g`
84		#'
85		#' `chevron_g`, a subclass of [chevron::chevron_tlg-class] with specific validation criteria to handle graph creation
86		#'
87		#' @aliases chevron_graph
88		#' @rdname chevron_tlg-class
89		#' @exportClass chevron_g
90		.chevron_g <- setClass(
91		"chevron_g",
92		contains = "chevron_tlg"
93		)
94
95		## chevron_simple ----
96
97		#' `chevron_simple`
98		#'
99		#' `chevron_simple`, a subclass of [chevron::chevron_tlg-class], where main function is a simple call
100		#'
101		#' @aliases chevron_simple
102		#' @rdname chevron_tlg-class
103		#' @exportClass chevron_simple
104		.chevron_simple <- setClass(
105		"chevron_simple",
106		contains = "chevron_tlg"
107		)
108
109
110		# Validity of class `chevron_simple`
111		methods::setValidity("chevron_simple", function(object) {
112		main_body <- body(object@main)
113		if (is.symbol(main_body)) {
114		return(invisible(TRUE))
115		}
116		res <- rapply(to_list(main_body), function(x) {
117		identical(x, as.name("return"))
118		})
119		has_return <- if (any(res)) "Must be a simple expression without `return`" else TRUE
120		makeAssertion(object@main, has_return, var.name = "object@main", collection = NULL)
121		invisible(TRUE)
122		})
123
124		# Sub Constructor ----
125
126		#' `chevron_t` constructor
127		#'
128		#' @rdname chevron_tlg-class
129		#'
130		#' @inheritParams gen_args
131		#' @param ... not used
132		#' @returns a `chevron_t` class object.
133		#'
134		#' @export
135		#'
136		#' @examples
137		#' chevron_t_obj <- chevron_t()
138		#' chevron_t_obj <- chevron_t(postprocess = function(tlg, indent, ...) {
139		#' rtables::table_inset(tlg) <- indent
140		#' tlg
141		#' })
142		#'
143		chevron_t <- function(main = function(adam_db, ...) build_table(basic_table(), adam_db[[1]]),
144		preprocess = function(adam_db, ...) adam_db,
145		postprocess = std_postprocessing,
146		...) {
147	4x	res <- .chevron_t(
148	4x	main = main,
149	4x	preprocess = preprocess,
150	4x	postprocess = postprocess
151		)
152
153	4x	res
154		}
155
156		#' `chevron_l` constructor
157		#'
158		#' @rdname chevron_tlg-class
159		#'
160		#' @inheritParams gen_args
161		#' @param ... not used
162		#' @returns a `chevron_l` class object.
163		#' @export
164		#'
165		#' @examples
166		#' chevron_l_obj <- chevron_l()
167		#'
168		chevron_l <- function(main = function(adam_db, ...) data.frame(),
169		preprocess = function(adam_db, ...) adam_db,
170		postprocess = std_postprocessing,
171		...) {
172	1x	res <- .chevron_l(
173	1x	main = main,
174	1x	preprocess = preprocess,
175	1x	postprocess = postprocess
176		)
177
178	1x	res
179		}
180
181		#' `chevron_g` constructor
182		#'
183		#' @rdname chevron_tlg-class
184		#'
185		#' @inheritParams gen_args
186		#' @param ... not used
187		#' @returns a `chevron_g` class object.
188		#'
189		#' @export
190		#'
191		#' @examples
192		#' chevron_g_obj <- chevron_g()
193		#' chevron_g_obj <- chevron_g(
194		#' postprocess = function(tlg, title, ...) tlg + ggplot2::labs(main = title)
195		#' )
196		#'
197		chevron_g <- function(main = function(adam_db, ...) ggplot2::ggplot(),
198		preprocess = function(adam_db, ...) adam_db,
199		postprocess = std_postprocessing,
200		...) {
201	1x	res <- .chevron_g(
202	1x	main = main,
203	1x	preprocess = preprocess,
204	1x	postprocess = postprocess
205		)
206
207	1x	res
208		}
209
210		#' `chevron_simple` constructor
211		#'
212		#' @rdname chevron_tlg-class
213		#'
214		#' @inheritParams gen_args
215		#' @param ... not used
216		#' @returns a `chevron_simple` class object.
217		#'
218		#' @export
219		#'
220		#' @examples
221		#' chevron_simple_obj <- chevron_simple()
222		chevron_simple <- function() {
223	3x	res <- .chevron_simple(
224	3x	main = \(adam_db, ...) basic_table() %>% build_table(data.frame()),
225	3x	preprocess = \(adam_db, ...) adam_db,
226	3x	postprocess = \(tlg, ...) tlg
227		)
228	3x	res
229		}

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

1		# ttet01 ----
2
3		#' @describeIn ttet01 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 summarize_event (`flag`) should the event description be displayed, 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 ... Further arguments passed to `control_surv_time()`, `control_coxph()`, `control_survtp()`, and
15		#' `surv_timepoint()`. For details, see the documentation in `tern`. Commonly used arguments include `pval_method`,
16		#' `conf_level`, `conf_type`, `quantiles`, `ties`, `time_point`, `method`, etc.
17		#' @returns the main function returns an `rtables` object.
18		#'
19		#' @details
20		#' * No overall value.
21		#'
22		#' @export
23		#'
24		ttet01_main <- function(adam_db,
25		dataset = "adtte",
26		arm_var = "ARM",
27		ref_group = NULL,
28		summarize_event = TRUE,
29		perform_analysis = "unstrat",
30		strata = NULL,
31		...) {
32	1x	assert_string(dataset)
33	1x	assert_all_tablenames(adam_db, "adsl", dataset)
34	1x	assert_string(arm_var)
35	1x	assert_string(ref_group, null.ok = TRUE)
36	1x	assert_flag(summarize_event)
37	1x	assert_subset(perform_analysis, c("unstrat", "strat"))
38	1x	assert_character(
39	1x	strata,
40	1x	null.ok = !"strat" %in% perform_analysis,
41	1x	min.len = as.integer(!"strat" %in% perform_analysis)
42		)
43	1x	anl <- adam_db[[dataset]]
44	1x	assert_single_value(anl$PARAMCD, label = sprintf("adam_db$%s$PARAMCD", dataset))
45	1x	df_label <- sprintf("adam_db$%s", dataset)
46	1x	assert_valid_variable(adam_db[[dataset]], c("IS_EVENT", "IS_NOT_EVENT"), types = list("logical"), label = df_label)
47	1x	assert_valid_variable(adam_db[[dataset]], "AVAL", types = list("numeric"), lower = 0, label = df_label)
48	1x	assert_valid_variable(
49	1x	adam_db[[dataset]], c("USUBJID", strata, "EVNT1", "EVNTDESC", "AVALU"),
50	1x	types = list(c("character", "factor")), label = df_label
51		)
52	1x	assert_valid_variable(adam_db[[dataset]], arm_var, types = list("factor"), empty.levels.ok = FALSE, label = df_label)
53	1x	assert_subset(ref_group, lvls(adam_db[[dataset]][[arm_var]]))
54	1x	ref_group <- ref_group %\|\|% lvls(anl[[arm_var]])[1]
55	1x	assert_single_value(anl$AVALU, label = sprintf("adam_db$%s$AVALU", dataset))
56
57	1x	timeunit <- unique(anl[["AVALU"]])
58	1x	event_lvls <- lvls(anl$EVNT1)
59
60	1x	control_survt <- execute_with_args(control_surv_time, ...)
61	1x	control_cox_ph <- execute_with_args(control_coxph, ...)
62	1x	control_survtp <- execute_with_args(control_surv_timepoint, ...)
63
64	1x	lyt <- ttet01_lyt(
65	1x	arm_var = arm_var,
66	1x	ref_group = ref_group,
67	1x	summarize_event = summarize_event,
68	1x	perform_analysis = perform_analysis,
69	1x	strata = strata,
70	1x	timeunit = timeunit,
71	1x	event_lvls = event_lvls,
72	1x	control_survt = control_survt,
73	1x	control_cox_ph = control_cox_ph,
74	1x	control_survtp = control_survtp,
75		...
76		)
77
78	1x	tbl <- build_table(lyt, anl)
79
80	1x	tbl
81		}
82
83		#' `ttet01` Layout
84		#'
85		#' @inheritParams gen_args
86		#' @param timeunit (`string`) time unit get from `AVALU`, by default is `"Months"`
87		#'
88		#' @keywords internal
89		#'
90		ttet01_lyt <- function(arm_var,
91		ref_group,
92		summarize_event,
93		perform_analysis,
94		strata,
95		timeunit,
96		event_lvls,
97		control_survt,
98		control_cox_ph,
99		control_survtp,
100		...) {
101	7x	lyt01 <- basic_table(show_colcounts = TRUE) %>%
102	7x	split_cols_by(
103	7x	var = arm_var, ref_group = ref_group
104		) %>%
105	7x	analyze_vars(
106	7x	vars = "IS_EVENT",
107	7x	.stats = "count_fraction",
108	7x	.labels = c(count_fraction = event_lvls[1])
109		)
110
111	7x	if (summarize_event) {
112	4x	lyt01 <- lyt01 %>%
113	4x	split_rows_by(
114	4x	"EVNT1",
115	4x	split_label = "Earliest contributing event",
116	4x	split_fun = keep_split_levels(event_lvls[1]),
117	4x	label_pos = "visible",
118	4x	child_labels = "hidden",
119	4x	indent_mod = 1L,
120		) %>%
121	4x	analyze_vars("EVNTDESC", split_fun = drop_split_levels, .stats = "count")
122		}
123
124	7x	lyt01 <- lyt01 %>%
125	7x	analyze_vars(
126	7x	vars = "IS_NOT_EVENT",
127	7x	.stats = "count_fraction",
128	7x	.labels = c(count_fraction = event_lvls[2]),
129	7x	nested = FALSE,
130	7x	show_labels = "hidden"
131		) %>%
132	7x	surv_time(
133	7x	vars = "AVAL",
134	7x	var_labels = paste0("Time to Event (", timeunit, ")"),
135	7x	is_event = "IS_EVENT",
136	7x	control = control_survt,
137	7x	table_names = "time_to_event"
138		)
139
140	7x	for (perform in perform_analysis) {
141	9x	lyt01 <- lyt01 %>%
142	9x	coxph_pairwise(
143	9x	vars = "AVAL",
144	9x	is_event = "IS_EVENT",
145	9x	var_labels = if (perform == "strat") "Stratified Analysis" else "Unstratified Analysis",
146	9x	strata = if (perform == "strat") strata else NULL,
147	9x	control = control_cox_ph,
148	9x	table_names = if (perform == "strat") "coxph_stratified" else "coxph_unstratified"
149		)
150		}
151
152	7x	lyt <- execute_with_args(
153	7x	surv_timepoint,
154	7x	lyt = lyt01,
155	7x	is_event = "IS_EVENT",
156	7x	vars = "AVAL",
157	7x	var_labels = timeunit,
158	7x	control = control_survtp,
159		...,
160	7x	method = "both",
161	7x	time_point = c(6, 12),
162	7x	.labels = c("pt_at_risk" = render_safe("{Patient_label} remaining at risk"))
163		)
164
165	7x	lyt
166		}
167
168		#' @describeIn ttet01 Preprocessing
169		#'
170		#' @inheritParams gen_args
171		#' @param dataset (`string`) the name of a table in the `adam_db` object.
172		#' @returns the preprocessing function returns a `list` of `data.frame`.
173		#' @export
174		#'
175		ttet01_pre <- function(adam_db, dataset = "adtte",
176		...) {
177	1x	adam_db[[dataset]] <- adam_db[[dataset]] %>%
178	1x	mutate(
179	1x	AVAL = convert_to_month(.data$AVAL, .data$AVALU),
180	1x	AVALU = "MONTHS",
181	1x	IS_EVENT = .data$CNSR == 0,
182	1x	IS_NOT_EVENT = .data$CNSR == 1,
183	1x	EVNT1 = factor(
184	1x	case_when(
185	1x	IS_EVENT == TRUE ~ render_safe("{Patient_label} with event (%)"),
186	1x	IS_EVENT == FALSE ~ render_safe("{Patient_label} without event (%)")
187		),
188	1x	levels = render_safe(c("{Patient_label} with event (%)", "{Patient_label} without event (%)"))
189		),
190	1x	EVNTDESC = factor(.data$EVNTDESC)
191		)
192
193	1x	adam_db
194		}
195
196		#' @describeIn ttet01 Postprocessing
197		#'
198		#' @inheritParams gen_args
199		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
200		#' @export
201		#'
202		ttet01_post <- function(tlg, prune_0 = TRUE, ...) {
203	!	if (prune_0) {
204	!	tlg <- smart_prune(tlg)
205		}
206	!	std_postprocessing(tlg)
207		}
208
209		#' `TTET01` Binary Outcomes Summary.
210		#'
211		#' `TTET01` template may be used to summarize any binary outcome or response variable at
212		#' a single time point. Typical application for oncology
213		#'
214		#' @include chevron_tlg-S4class.R
215		#' @export
216		#'
217		#' @examples
218		#' library(dplyr)
219		#' library(dunlin)
220		#'
221		#' proc_data <- log_filter(syn_data, PARAMCD == "PFS", "adtte")
222		#' run(ttet01, proc_data)
223		#'
224		#' run(ttet01, proc_data,
225		#' summarize_event = FALSE, perform_analysis = c("unstrat", "strat"),
226		#' strata = c("STRATA1", "STRATA2"),
227		#' conf_type = "log-log",
228		#' time_point = c(6, 12),
229		#' method = "both"
230		#' )
231		ttet01 <- chevron_t(
232		main = ttet01_main,
233		preprocess = ttet01_pre,
234		postprocess = ttet01_post
235		)

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		#' @returns the main function returns an `rtables` object.
12		#'
13		#' @details
14		#' * This table follows ADaMIG v1.1.
15		#' * Only the worst grade recorded for each patient is included in the table.
16		#' * If no missing baseline lab results, the "Missing" level of `BTOXGR` is excluded.
17		#' * Grading takes value from -4 to 4, negative value means the abnormality direction is low,
18		#' positive value means the abnormality direction is high.
19		#' * Grades 0, 1, 2, 3, and 4 are counted as `"Not Low"` when `direction = "low"`. Conversely, when `direction =
20		#' "high"`, Grades 0, -1, -2, -3, and -4 are counted as `"Not High".
21		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
22		#' * Split columns by arm, typically `ACTARM`.
23		#'
24		#' @note
25		#' * `adam_db` object must contain an `adlb` table with columns `"USUBJID"`, `"PARAM"`, `"BTOXGR"`, `"ATOXGR"`,
26		#' and the column specified by `arm_var`.
27		#'
28		#' @export
29		#'
30		lbt14_main <- function(adam_db,
31		arm_var = "ACTARM",
32		lbl_overall = NULL,
33		gr_missing = "incl",
34		page_var = "PARAMCD",
35		...) {
36	4x	assert_all_tablenames(adam_db, c("adsl", "adlb"))
37	4x	assert_string(arm_var)
38	4x	assert_string(lbl_overall, null.ok = TRUE)
39	4x	assert_choice(gr_missing, c("incl", "excl", "gr_0"))
40	4x	assert_subset(page_var, "PARAMCD")
41	4x	assert_valid_variable(adam_db$adlb, c("ATOXGR", "BTOXGR"), types = list("factor"), na_ok = TRUE)
42	4x	assert_valid_variable(adam_db$adlb, c("PARAMCD", "PARAM"), types = list(c("character", "factor")), na_ok = FALSE)
43	4x	assert_valid_variable(adam_db$adlb, c("USUBJID"), types = list(c("character", "factor")), empty_ok = TRUE)
44	4x	assert_valid_variable(adam_db$adsl, c("USUBJID"), types = list(c("character", "factor")))
45	4x	assert_valid_var_pair(adam_db$adsl, adam_db$adlb, arm_var)
46
47	4x	lbl_overall <- render_safe(lbl_overall)
48	4x	lbl_param <- var_labels_for(adam_db$adlb, "PARAM")
49	4x	lbl_btoxgr <- var_labels_for(adam_db$adlb, "BTOXGR")
50
51	4x	lyt <- lbt14_lyt(
52	4x	arm_var = arm_var,
53	4x	lbl_overall = lbl_overall,
54	4x	lbl_param = lbl_param,
55	4x	lbl_btoxgr = lbl_btoxgr,
56	4x	page_var = page_var
57		)
58
59	4x	tbl <- build_table(lyt, adam_db$adlb, alt_counts_df = adam_db$adsl)
60
61	4x	tbl
62		}
63
64		#' `lbt14` Layout
65		#'
66		#' @inheritParams lbt14_main
67		#'
68		#' @keywords internal
69		#'
70		lbt14_lyt <- function(arm_var,
71		lbl_overall,
72		lbl_param,
73		lbl_btoxgr,
74		page_var) {
75	14x	page_by <- !is.null(page_var)
76	14x	label_pos <- ifelse(page_by, "hidden", "topleft")
77	14x	basic_table(show_colcounts = TRUE) %>%
78	14x	split_cols_by_with_overall(arm_var, 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		#' @returns the preprocessing function returns a `list` of `data.frame`.
102		#' @export
103		#'
104		lbt14_pre <- function(adam_db,
105		gr_missing = "incl",
106		direction = "low",
107		...) {
108	4x	if (identical(direction, "high")) {
109	1x	adam_db$adlb <- adam_db$adlb %>%
110	1x	filter(.data$WGRHIFL == "Y") %>%
111	1x	h_adsl_adlb_merge_using_worst_flag(
112	1x	adsl = adam_db$adsl,
113	1x	worst_flag = c("WGRHIFL" = "Y")
114		)
115	3x	} else if (identical(direction, "low")) {
116	3x	adam_db$adlb <- adam_db$adlb %>%
117	3x	filter(.data$WGRLOFL == "Y") %>%
118	3x	h_adsl_adlb_merge_using_worst_flag(
119	3x	adsl = adam_db$adsl,
120	3x	worst_flag = c("WGRLOFL" = "Y")
121		)
122		}
123
124	4x	grade_rule <- get_grade_rule(direction, gr_missing)
125	4x	adam_db$adlb <- adam_db$adlb %>%
126	4x	mutate(
127	4x	across(all_of(c("BTOXGR", "ATOXGR")), ~ reformat(.x, grade_rule))
128		)
129
130	4x	adam_db
131		}
132
133		#' @describeIn lbt14 Postprocessing
134		#'
135		#' @inheritParams gen_args
136		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
137		#' @export
138		#'
139		lbt14_post <- function(tlg, prune_0 = TRUE, ...) {
140	4x	if (prune_0) tlg <- tlg %>% trim_rows()
141	4x	std_postprocessing(tlg)
142		}
143
144		#' `LBT14` Laboratory Test Results Shift Table – Highest `NCI-CTCAE` Grade Post-Baseline by
145		#' Baseline Grade (Low or High Direction).
146		#'
147		#' @include chevron_tlg-S4class.R
148		#' @export
149		#'
150		#' @examples
151		#' run(lbt14, syn_data)
152		lbt14 <- chevron_t(
153		main = lbt14_main,
154		preprocess = lbt14_pre,
155		postprocess = lbt14_post
156		)

1		# lbt05 ----
2
3		#' @describeIn lbt05 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @returns the main function returns an `rtables` object.
7		#'
8		#' @details
9		#' * Does not remove rows with zero counts by default.
10		#' * Lab test results with missing `AVAL` values are excluded.
11		#' * Split columns by arm, typically `ACTARM`.
12		#'
13		#' @note
14		#' * `adam_db` object must contain an `adlb` table with columns `"ONTRTFL"`, `"PARCAT2"`, `"PARAM"`, `"ANRIND"`,
15		#' `"AVALCAT1"`, and column specified by `arm_var`.
16		#'
17		#' @export
18		#'
19		lbt05_main <- function(adam_db,
20		arm_var = "ACTARM",
21		lbl_overall = NULL,
22		...) {
23	1x	assert_all_tablenames(adam_db, c("adsl", "adlb"))
24	1x	assert_string(arm_var)
25	1x	assert_string(lbl_overall, null.ok = TRUE)
26		# expand.grid steps requires levels later.
27	1x	assert_valid_variable(adam_db$adlb, c("PARAM", "AVALCAT1", "ABN_DIR"), types = list("factor"))
28	1x	assert_valid_variable(adam_db$adlb, c("USUBJID"), types = list(c("character", "factor")), empty_ok = TRUE)
29	1x	assert_valid_variable(adam_db$adsl, c("USUBJID"), types = list(c("character", "factor")))
30	1x	assert_valid_var_pair(adam_db$adsl, adam_db$adlb, arm_var)
31
32	1x	lbl_overall <- render_safe(lbl_overall)
33	1x	lbl_anrind <- var_labels_for(adam_db$adlb, "ABN_DIR")
34	1x	lbl_param <- var_labels_for(adam_db$adlb, "PARAM")
35
36	1x	map <- expand.grid(
37	1x	PARAM = levels(adam_db$adlb$PARAM),
38	1x	ABN_DIR = c("Low", "High"),
39	1x	stringsAsFactors = FALSE
40		) %>%
41	1x	arrange(.data$PARAM, desc(.data$ABN_DIR))
42
43	1x	lyt <- lbt05_lyt(
44	1x	arm_var = arm_var,
45	1x	lbl_overall = lbl_overall,
46	1x	lbl_param = lbl_param,
47	1x	lbl_anrind = lbl_anrind,
48	1x	map = map
49		)
50
51	1x	tbl <- build_table(lyt, adam_db$adlb, alt_counts_df = adam_db$adsl)
52
53	1x	tbl
54		}
55
56		#' `lbt05` Layout
57		#'
58		#' @inheritParams gen_args
59		#'
60		#' @param lbl_param (`string`) label of the `PARAM` variable.
61		#' @param lbl_anrind (`string`) label of the `ANRIND` variable.
62		#' @param map (`data.frame`) mapping of `PARAM`s to directions of abnormality.
63		#'
64		#' @keywords internal
65		#'
66		lbt05_lyt <- function(arm_var,
67		lbl_overall,
68		lbl_param,
69		lbl_anrind,
70		map) {
71	5x	basic_table(show_colcounts = TRUE) %>%
72	5x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
73	5x	split_rows_by(
74	5x	"PARAM",
75	5x	label_pos = "topleft",
76	5x	split_label = lbl_param
77		) %>%
78	5x	summarize_num_patients(var = "USUBJID", .stats = "unique_count") %>%
79	5x	split_rows_by("ABN_DIR", split_fun = trim_levels_to_map(map)) %>%
80	5x	count_abnormal_by_marked(
81	5x	var = "AVALCAT1",
82	5x	variables = list(id = "USUBJID", param = "PARAM", direction = "ABN_DIR"),
83	5x	.formats = c("count_fraction" = format_count_fraction_fixed_dp)
84		) %>%
85	5x	append_topleft(paste(" ", lbl_anrind))
86		}
87
88		#' @describeIn lbt05 Preprocessing
89		#'
90		#' @inheritParams gen_args
91		#' @returns the preprocessing function returns a `list` of `data.frame`.
92		#' @export
93		#'
94		lbt05_pre <- function(adam_db, ...) {
95	1x	adam_db$adlb <- adam_db$adlb %>%
96	1x	filter(
97	1x	.data$ONTRTFL == "Y",
98	1x	.data$PARCAT2 == "LS",
99	1x	!is.na(.data$AVAL)
100		) %>%
101	1x	mutate(ABN_DIR = factor(case_when(
102	1x	ANRIND == "LOW LOW" ~ "Low",
103	1x	ANRIND == "HIGH HIGH" ~ "High",
104	1x	TRUE ~ ""
105	1x	), levels = c("Low", "High"))) %>%
106	1x	mutate(
107	1x	ABN_DIR = with_label(.data$ABN_DIR, "Direction of Abnormality"),
108	1x	PARAM = with_label(.data$PARAM, "Laboratory Test")
109		) %>%
110	1x	mutate(
111	1x	across(all_of(c("AVALCAT1", "ABN_DIR")), ~ reformat(.x, missing_rule, .drop = FALSE))
112		)
113
114	1x	adam_db
115		}
116
117		#' @describeIn lbt05 Postprocessing
118		#'
119		#' @inheritParams gen_args
120		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
121		#' @export
122		#'
123		lbt05_post <- function(tlg, prune_0 = FALSE, ...) {
124	2x	if (prune_0) {
125	1x	has_lbl <- function(lbl) CombinationFunction(function(tr) obj_label(tr) == lbl)
126	1x	tlg <- prune_table(tlg, keep_rows(has_lbl("Any Abnormality")))
127
128	1x	if (is.null(prune_table(tlg))) {
129	!	tlg <- build_table(rtables::basic_table(), df = data.frame())
130	!	col_info(tlg) <- col_info(tlg)
131		}
132		}
133
134	2x	std_postprocessing(tlg)
135		}
136
137		#' `LBT05` Table 1 (Default) Laboratory Abnormalities with Single and Replicated Marked.
138		#'
139		#' @include chevron_tlg-S4class.R
140		#' @export
141		#'
142		#' @examples
143		#' run(lbt05, syn_data)
144		lbt05 <- chevron_t(
145		main = lbt05_main,
146		preprocess = lbt05_pre,
147		postprocess = lbt05_post
148		)

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		#' @returns the main function returns an `rtables` object.
8		#'
9		#' @details
10		#' * Numbers represent absolute numbers of patients and fraction of `N`, or absolute number of event when specified.
11		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
12		#' * Events with missing grading values are excluded.
13		#' * Split columns by arm, typically `ACTARM`.
14		#' * Does not include a total column by default.
15		#' * Sort Body System or Organ Class and Dictionary-Derived Term by highest overall frequencies. Analysis Toxicity
16		#' Grade is sorted by severity.
17		#'
18		#' @note
19		#' * `adam_db` object must contain an `adae` table with the columns `"AEBODSYS"`, `"AEDECOD"` and `"ATOXGR"`.
20		#'
21		#' @export
22		#'
23		aet04_main <- function(adam_db,
24		arm_var = "ACTARM",
25		lbl_overall = NULL,
26		grade_groups = NULL,
27		...) {
28	1x	assert_all_tablenames(adam_db, "adsl", "adae")
29	1x	assert_string(arm_var)
30	1x	assert_string(lbl_overall, null.ok = TRUE)
31	1x	assert_list(grade_groups, types = "character", null.ok = TRUE)
32	1x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
33	1x	assert_valid_variable(adam_db$adae, c(arm_var, "AEBODSYS", "AEDECOD"), types = list(c("character", "factor")))
34	1x	assert_valid_variable(adam_db$adae, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
35	1x	assert_valid_variable(adam_db$adae, "ATOXGR", na_ok = TRUE, types = list("factor"))
36	1x	assert_valid_var_pair(adam_db$adsl, adam_db$adae, arm_var)
37
38	1x	lbl_overall <- render_safe(lbl_overall)
39	1x	lbl_aebodsys <- var_labels_for(adam_db$adae, "AEBODSYS")
40	1x	lbl_aedecod <- var_labels_for(adam_db$adae, "AEDECOD")
41
42	1x	if (is.null(grade_groups)) {
43	1x	grade_groups <- list(
44	1x	"Grade 1-2" = c("1", "2"),
45	1x	"Grade 3-4" = c("3", "4"),
46	1x	"Grade 5" = c("5")
47		)
48		}
49
50	1x	lyt <- aet04_lyt(
51	1x	arm_var = arm_var,
52	1x	total_var = "TOTAL_VAR",
53	1x	lbl_overall = lbl_overall,
54	1x	lbl_aebodsys = lbl_aebodsys,
55	1x	lbl_aedecod = lbl_aedecod,
56	1x	grade_groups = grade_groups
57		)
58
59	1x	adam_db$adae$TOTAL_VAR <- "- Any adverse events - "
60
61	1x	tbl <- build_table(lyt, df = adam_db$adae, alt_counts_df = adam_db$adsl)
62
63	1x	tbl
64		}
65
66		#' `aet04` Layout
67		#'
68		#' @inheritParams aet04_main
69		#'
70		#' @param total_var (`string`) variable to create summary of all variables.
71		#' @param lbl_aebodsys (`string`) text label for `AEBODSYS`.
72		#' @param lbl_aedecod (`string`) text label for `AEDECOD`.
73		#' @param grade_groups (`list`) putting in correspondence toxicity grades and labels.
74		#' @returns a `PreDataTableLayouts` object.
75		#' @keywords internal
76		#'
77		aet04_lyt <- function(arm_var,
78		total_var,
79		lbl_overall,
80		lbl_aebodsys,
81		lbl_aedecod,
82		grade_groups) {
83	11x	basic_table(show_colcounts = TRUE) %>%
84	11x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
85	11x	split_rows_by(
86	11x	var = total_var,
87	11x	label_pos = "hidden",
88	11x	child_labels = "visible",
89	11x	indent_mod = -1L
90		) %>%
91	11x	summarize_num_patients(
92	11x	var = "USUBJID",
93	11x	.stats = "unique",
94	11x	.labels = "- Any Grade -",
95	11x	.indent_mods = 7L
96		) %>%
97	11x	count_occurrences_by_grade(
98	11x	var = "ATOXGR",
99	11x	grade_groups = grade_groups,
100	11x	.indent_mods = 6L
101		) %>%
102	11x	split_rows_by(
103	11x	"AEBODSYS",
104	11x	child_labels = "visible",
105	11x	nested = FALSE,
106	11x	split_fun = drop_split_levels,
107	11x	label_pos = "topleft",
108	11x	split_label = lbl_aebodsys
109		) %>%
110	11x	split_rows_by(
111	11x	"AEDECOD",
112	11x	child_labels = "visible",
113	11x	split_fun = add_overall_level("- Overall -", trim = TRUE),
114	11x	label_pos = "topleft",
115	11x	split_label = lbl_aedecod
116		) %>%
117	11x	summarize_num_patients(
118	11x	var = "USUBJID",
119	11x	.stats = "unique",
120	11x	.labels = "- Any Grade -",
121	11x	.indent_mods = 6L
122		) %>%
123	11x	count_occurrences_by_grade(
124	11x	var = "ATOXGR",
125	11x	grade_groups = grade_groups,
126	11x	.indent_mods = 5L
127		) %>%
128	11x	append_topleft(" Grade")
129		}
130
131		#' @describeIn aet04 Preprocessing
132		#'
133		#' @inheritParams gen_args
134		#' @returns the preprocessing function returns a `list` of `data.frame`.
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		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
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_postprocessing(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		# 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		#' @returns the main function returns an `rtables` object
8		#'
9		#' @details
10		#' * Only count LOW or HIGH values.
11		#' * Results of "LOW LOW" are treated as the same as "LOW", and "HIGH HIGH" the same as "HIGH".
12		#' * Does not include a total column by default.
13		#' * Does not remove zero-count rows unless overridden with `prune_0 = TRUE`.
14		#'
15		#' @note
16		#' * `adam_db` object must contain an `adeg` table with the `"PARAM"`, `"ANRIND"` and `"BNRIND"` columns.
17		#'
18		#' @export
19		#'
20		egt02_1_main <- function(adam_db,
21		arm_var = "ACTARM",
22		lbl_overall = NULL,
23		exclude_base_abn = FALSE,
24		...) {
25	2x	assert_all_tablenames(adam_db, c("adsl", "adeg"))
26	2x	assert_string(arm_var)
27	2x	assert_string(lbl_overall, null.ok = TRUE)
28	2x	assert_flag(exclude_base_abn)
29	2x	assert_valid_variable(adam_db$adeg, c("PARAM"), types = list(c("character", "factor")), na_ok = FALSE)
30	2x	assert_valid_variable(adam_db$adeg, c("ANRIND", "BNRIND"), types = list(c("character", "factor")), na_ok = TRUE)
31	2x	assert_valid_var_pair(adam_db$adsl, adam_db$adeg, arm_var)
32	2x	assert_valid_variable(adam_db$adeg, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
33	2x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
34
35	2x	lbl_overall <- render_safe(lbl_overall)
36
37	2x	lyt <- egt02_lyt(
38	2x	arm_var = arm_var,
39	2x	lbl_overall = lbl_overall,
40	2x	lbl_vs_assessment = "Assessment",
41	2x	lbl_vs_abnormality = "Abnormality",
42	2x	exclude_base_abn = exclude_base_abn
43		)
44
45	2x	tbl <- build_table(lyt, adam_db$adeg, alt_counts_df = adam_db$adsl)
46
47	2x	tbl
48		}
49
50		#' `egt02` Layout
51		#'
52		#' @inheritParams gen_args
53		#' @param lbl_vs_assessment (`string`) the label of the assessment variable.
54		#' @param lbl_vs_abnormality (`string`) the label of the abnormality variable.
55		#' @param exclude_base_abn (`flag`) whether to exclude subjects with baseline abnormality from numerator and
56		#' denominator.
57		#' @returns a `PreDataTableLayouts` object.
58		#'
59		#' @keywords internal
60		#'
61		egt02_lyt <- function(arm_var = "ACTARM",
62		lbl_overall,
63		lbl_vs_assessment = "Assessment",
64		lbl_vs_abnormality = "Abnormality",
65		exclude_base_abn) {
66	4x	basic_table(show_colcounts = TRUE) %>%
67	4x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
68	4x	split_rows_by("PARAM", split_fun = drop_split_levels, label_pos = "topleft", split_label = lbl_vs_assessment) %>%
69	4x	count_abnormal(
70	4x	"ANRIND",
71	4x	abnormal = list(Low = "LOW", High = "HIGH"),
72	4x	variables = list(id = "USUBJID", baseline = "BNRIND"),
73	4x	exclude_base_abn = exclude_base_abn
74		) %>%
75	4x	append_topleft(paste0(" ", lbl_vs_abnormality))
76		}
77
78		#' @describeIn egt02_1 Preprocessing
79		#'
80		#' @inheritParams gen_args
81		#' @returns the preprocessing function returns a `list` of `data.frame`.
82		#' @export
83		#'
84		egt02_pre <- function(adam_db, ...) {
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		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
97		#' @export
98		#'
99		egt02_post <- function(tlg, ...) {
100	2x	std_postprocessing(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		#' Creates `NULL` Report
2		#'
3		#' @param tlg to convert to null report.
4		#' @param ind (`integer`) indentation for the outputs of class `VTableTree`.
5		#' @param ... not used.
6		#'
7		#' @rdname report_null
8		#' @name report_null
9		#'
10		#' @returns the `tlg` object or a `NULL` report if the `tlg` is `NULL`, is a `TableTree` with 0 rows, is a `listing_df`
11		#' with 0 rows or is a `list` with 0 elements.
12		#'
13		#' @export
14		#' @examples
15		#' report_null(NULL)
16		setGeneric("report_null", function(tlg, ...) {
17	271x	standardGeneric("report_null")
18		})
19
20		#' @rdname report_null
21		setMethod("report_null", "NULL", function(tlg, ind = 2L, ...) {
22	1x	res <- standard_null_report()
23	1x	table_inset(res) <- ind
24	1x	res
25		})
26
27		#' @rdname report_null
28		setMethod("report_null", "VTableTree", function(tlg, ind = 2L, ...) {
29	221x	res <- if (nrow(tlg) == 0L \|\| count_children(tlg) == 0) {
30	29x	standard_null_report()
31		} else {
32	192x	tlg
33		}
34
35	221x	table_inset(res) <- ind
36	221x	res
37		})
38
39		#' @rdname report_null
40		setMethod("report_null", "listing_df", function(tlg, ind = 2L, ...) {
41	10x	if (nrow(tlg) == 0L) {
42	2x	res <- standard_null_report()
43	2x	table_inset(res) <- ind
44	2x	res
45		} else {
46	8x	tlg
47		}
48		})
49
50		#' @rdname report_null
51		setMethod("report_null", "list", function(tlg, ind = 2L, ...) {
52	19x	if (length(tlg) == 0) {
53	1x	res <- standard_null_report()
54	1x	table_inset(res) <- ind
55	1x	res
56		} else {
57	18x	tlg
58		}
59		})
60
61		#' @rdname report_null
62		setMethod("report_null", "ANY", function(tlg, ...) {
63	20x	tlg
64		})
65
66		#' @export
67		#' @rdname report_null
68		standard_null_report <- function() {
69	37x	rtables::rtable(
70	37x	header = "",
71	37x	rrow("", "Null Report: No observations met the reporting criteria for inclusion in this output."),
72	37x	inset = 2L
73		)
74		}
75
76		#' Standard Post Processing
77		#'
78		#' @param tlg to post process.
79		#' @param ... additional arguments passed to [report_null].
80		#'
81		#' @returns a processed `tlg` or a null report.
82		#' @export
83		#' @examples
84		#' library(rtables)
85		#' std_postprocessing(build_table(basic_table() \|> analyze("Species"), iris), ind = 10L)
86		#'
87		std_postprocessing <- function(tlg, ...) {
88	222x	tlg <- report_null(tlg, ...)
89	222x	tlg
90		}

1		# kmg01 ----
2
3		#' @describeIn kmg01 Main TLG Function
4		#'
5		#' @details
6		#' * No overall value.
7		#'
8		#' @inheritParams gen_args
9		#' @param dataset (`string`) the name of a table in the `adam_db` object.
10		#' @param strata (`character`) the variable name of stratification variables.
11		#' @param strat (`character`) `r lifecycle::badge("deprecated")`; for backwards compatibility only.
12		#' Use `strata` instead.
13		#' @param ... Further arguments passed to `g_km` and `control_coxph`. For details, see
14		#' the documentation in `tern`.
15		#' Commonly used arguments include `col`, `pval_method`, `ties`, `conf_level`, `conf_type`,
16		#' `annot_coxph`, `annot_stats`, etc.
17		#' @returns the main function returns a `gTree` object.
18		#'
19		#' @note
20		#' * `adam_db` object must contain the table specified by `dataset` with the columns specified by `arm_var`.
21		#'
22		#' @returns a `gTree` object.
23		#' @export
24		kmg01_main <- function(adam_db,
25		dataset = "adtte",
26		arm_var = "ARM",
27		strata = NULL,
28		strat = lifecycle::deprecated(),
29		...) {
30	1x	assert_all_tablenames(adam_db, c("adsl", dataset))
31	1x	df_lbl <- paste0("adam_db$", dataset)
32	1x	assert_valid_variable(adam_db[[dataset]], "AVAL", types = list("numeric"), lower = 0, label = df_lbl)
33	1x	assert_valid_variable(adam_db[[dataset]], "IS_EVENT", types = list("logical"), label = df_lbl)
34	1x	if (lifecycle::is_present(strat)) {
35	!	lifecycle::deprecate_warn(
36	!	when = "0.2.6",
37	!	what = "kmg01_main(strat)",
38	!	with = "km01_main(strata)"
39		)
40	!	strata <- strat
41		}
42	1x	assert_valid_variable(adam_db[[dataset]], strata, types = list(c("character", "factor")), label = df_lbl)
43	1x	assert_valid_variable(
44	1x	adam_db[[dataset]],
45	1x	c("PARAMCD", arm_var),
46	1x	types = list(c("character", "factor")),
47	1x	na_ok = FALSE,
48	1x	label = df_lbl
49		)
50	1x	assert_single_value(adam_db[[dataset]]$PARAMCD, label = paste0(df_lbl, "$PARAMCD"))
51	1x	assert_valid_variable(adam_db[[dataset]], "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
52	1x	variables <- list(tte = "AVAL", is_event = "IS_EVENT", arm = arm_var, strata = strata)
53	1x	control_cox <- execute_with_args(control_coxph, ...)
54	1x	control_surv <- execute_with_args(control_surv_timepoint, ...)
55	1x	execute_with_args(
56	1x	g_km,
57	1x	df = adam_db[[dataset]],
58	1x	variables = variables,
59	1x	control_surv = control_surv,
60	1x	control_coxph_pw = control_cox,
61		...
62		)
63		}
64
65		#' @describeIn kmg01 Preprocessing
66		#'
67		#' @inheritParams kmg01_main
68		#' @returns the preprocessing function returns a `list` of `data.frame`.
69		#' @export
70		kmg01_pre <- function(adam_db, dataset = "adtte", ...) {
71	1x	adam_db[[dataset]] <- adam_db[[dataset]] %>%
72	1x	mutate(IS_EVENT = .data$CNSR == 0)
73
74	1x	adam_db
75		}
76
77		# `kmg01` Pipeline ----
78
79		#' `KMG01` Kaplan-Meier Plot 1.
80		#'
81		#' @include chevron_tlg-S4class.R
82		#' @export
83		#'
84		#' @examples
85		#' library(dplyr)
86		#' library(dunlin)
87		#'
88		#' col <- c(
89		#' "A: Drug X" = "black",
90		#' "B: Placebo" = "blue",
91		#' "C: Combination" = "gray"
92		#' )
93		#'
94		#' pre_data <- log_filter(syn_data, PARAMCD == "OS", "adtte")
95		#' run(kmg01, pre_data, dataset = "adtte", col = col)
96		kmg01 <- chevron_g(
97		main = kmg01_main,
98		preprocess = kmg01_pre
99		)

1		# egt05_qtcat ----
2
3		#' @describeIn egt05_qtcat Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param summaryvars (`character`) variables to be analyzed. The label attribute of the corresponding column in `adeg`
7		#' table of `adam_db` is used as name.
8		#' @returns the main function returns an `rtables` object.
9		#'
10		#' @details
11		#' * The `Value at Visit` column, displays the categories of the specific `"PARAMCD"` value for patients.
12		#' * The `Change from Baseline` column, displays the categories of the specific `"PARAMCD"` value
13		#' change from baseline for patients.
14		#' * Remove zero-count rows unless overridden with `prune_0 = FALSE`.
15		#' * Split columns by arm, typically `"ACTARM"`.
16		#' * Does not include a total column by default.
17		#' * Sorted based on factor level; by chronological time point given by `"AVISIT"`
18		#' or user-defined visit incorporating `"ATPT"`.
19		#' Re-level to customize order.
20		#' * Please note that it is preferable to convert `summaryvars` to factor.
21		#'
22		#' @note
23		#' * `adam_db` object must contain an `adeg` table with column specified in `visitvar`.
24		#' For `summaryvars`, please make sure `AVALCAT1` and `CHGCAT1` columns existed in input data sets.
25		#'
26		#' @export
27		#'
28		egt05_qtcat_main <- function(adam_db,
29		arm_var = "ACTARM",
30		lbl_overall = NULL,
31		summaryvars = c("AVALCAT1", "CHGCAT1"),
32		row_split_var = NULL,
33		visitvar = "AVISIT",
34		page_var = NULL,
35		...) {
36	1x	assert_all_tablenames(adam_db, c("adsl", "adeg"))
37	1x	assert_string(arm_var)
38	1x	assert_string(lbl_overall, null.ok = TRUE)
39	1x	assert_character(summaryvars)
40	1x	assert_character(row_split_var, null.ok = TRUE)
41	1x	assert_string(visitvar)
42	1x	assert_string(page_var, null.ok = TRUE)
43	1x	assert_valid_var_pair(adam_db$adsl, adam_db$adeg, arm_var)
44	1x	assert_valid_variable(adam_db$adeg, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
45	1x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
46	1x	assert_valid_variable(adam_db$adeg, c("PARAM", "PARAMCD"), types = list(c("character", "factor")), na_ok = FALSE)
47	1x	assert_valid_variable(adam_db$adeg, visitvar, types = list("character", "factor"))
48	1x	assert_disjunct(row_split_var, c("PARAMCD", "PARAM", visitvar))
49	1x	assert_valid_variable(adam_db$adeg, summaryvars, types = list(c("factor", "character")), na_ok = TRUE)
50	1x	assert_subset(page_var, c(row_split_var, "PARAMCD"))
51
52	1x	lbl_overall <- render_safe(lbl_overall)
53	1x	lbl_avisit <- var_labels_for(adam_db$adeg, visitvar)
54	1x	lbl_param <- var_labels_for(adam_db$adeg, "PARAM")
55	1x	summaryvars_lbls <- var_labels_for(adam_db$adeg, summaryvars) # Value at visit / change from baseline
56	1x	row_split_lbl <- var_labels_for(adam_db$adeg, row_split_var)
57
58	1x	lyt <- egt05_qtcat_lyt(
59	1x	arm_var = arm_var,
60	1x	lbl_overall = lbl_overall,
61	1x	lbl_avisit = lbl_avisit,
62	1x	lbl_param = lbl_param,
63	1x	lbl_cat = "Category",
64	1x	summaryvars = summaryvars,
65	1x	summaryvars_lbls = summaryvars_lbls,
66	1x	row_split_var = row_split_var,
67	1x	row_split_lbl = row_split_lbl,
68	1x	visitvar = visitvar,
69	1x	page_var = page_var
70		)
71
72	1x	build_table(
73	1x	lyt,
74	1x	df = adam_db$adeg,
75	1x	alt_counts_df = adam_db$adsl
76		)
77		}
78
79		#' `EGT05_QTCAT` Layout
80		#'
81		#' @inheritParams gen_args
82		#'
83		#' @param lbl_avisit (`string`) label of the `visitvar` variable.
84		#' @param lbl_param (`string`) label of the `PARAM` variable.
85		#' @param lbl_cat (`string`) label of the Category of `summaryvars` variable. Default as `Category`.
86		#' @param summaryvars (`character`) the variables to be analyzed. `AVALCAT1` and `CHGCAT1` by default.
87		#' @param summaryvars_lbls (`character`) the label of the variables to be analyzed.
88		#' @param visitvar (`string`) typically `"AVISIT"` or user-defined visit incorporating `"ATPT"`.
89		#' @returns a `PreDataTableLayouts` object.
90		#'
91		#' @keywords internal
92		#'
93		egt05_qtcat_lyt <- function(arm_var,
94		lbl_overall,
95		lbl_avisit,
96		lbl_param,
97		lbl_cat,
98		summaryvars,
99		summaryvars_lbls,
100		row_split_var,
101		row_split_lbl,
102		visitvar,
103		page_var) {
104	3x	page_by <- get_page_by(page_var, c(row_split_var, "PARAMCD"))
105	3x	label_pos <- ifelse(page_by, "hidden", "topleft")
106	3x	basic_table(show_colcounts = TRUE) %>%
107	3x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
108	3x	split_rows_by_recursive(
109	3x	row_split_var,
110	3x	split_label = row_split_lbl,
111	3x	label_pos = head(label_pos, -1L), page_by = head(page_by, -1L)
112		) %>%
113	3x	split_rows_by(
114	3x	var = "PARAMCD",
115	3x	labels_var = "PARAM",
116	3x	split_fun = drop_split_levels,
117	3x	label_pos = tail(label_pos, 1L),
118	3x	split_label = lbl_param,
119	3x	page_by = tail(page_by, 1L)
120		) %>%
121	3x	split_rows_by(
122	3x	visitvar,
123	3x	split_fun = drop_split_levels,
124	3x	split_label = lbl_avisit,
125	3x	label_pos = "topleft"
126		) %>%
127	3x	summarize_vars_allow_na(
128	3x	vars = summaryvars,
129	3x	var_labels = summaryvars_lbls,
130	3x	inclNAs = FALSE
131		) %>%
132	3x	append_topleft(paste0(stringr::str_dup(" ", sum(!page_by) * 2 + 2), lbl_cat))
133		}
134
135		#' @describeIn egt05_qtcat Preprocessing
136		#'
137		#' @inheritParams gen_args
138		#' @returns the preprocessing function returns a `list` of `data.frame`.
139		#'
140		#' @export
141		#'
142		egt05_qtcat_pre <- function(adam_db, ...) {
143	1x	adam_db$adeg <- adam_db$adeg %>%
144	1x	filter(.data$ANL01FL == "Y") %>%
145	1x	mutate(
146	1x	AVALCAT1 = reformat(.data$AVALCAT1, empty_rule),
147	1x	CHGCAT1 = reformat(.data$CHGCAT1, empty_rule),
148	1x	AVISIT = reorder(.data$AVISIT, .data$AVISITN),
149	1x	AVISIT = with_label(.data$AVISIT, "Analysis Visit")
150		)
151	1x	adam_db
152		}
153
154		#' @describeIn egt05_qtcat Postprocessing
155		#'
156		#' @inheritParams gen_args
157		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
158		#'
159		#' @export
160		#'
161		egt05_qtcat_post <- function(tlg, prune_0 = TRUE, ...) {
162	1x	if (prune_0) tlg <- smart_prune(tlg)
163	1x	std_postprocessing(tlg)
164		}
165
166		#' `EGT05_QTCAT` ECG Actual Values and Changes from Baseline by Visit Table.
167		#'
168		#' The `EGT05_QTCAT` table summarizes several electrocardiogram parameters and their evolution
169		#' throughout the study.
170		#'
171		#' @include chevron_tlg-S4class.R
172		#' @export
173		#'
174		#' @examples
175		#' run(egt05_qtcat, syn_data)
176		egt05_qtcat <- chevron_t(
177		main = egt05_qtcat_main,
178		preprocess = egt05_qtcat_pre,
179		postprocess = egt05_qtcat_post
180		)

1		# dmt01 ----
2
3		#' @describeIn dmt01 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param summaryvars (`character`) variables summarized in demographic table. The label attribute of the corresponding
7		#' column in `adsl` table of `adam_db` is used as label.
8		#' @param stats (named `list` of character) where names of columns found in `.df_row` and the values indicate the
9		#' statistical analysis to perform. If `default` is set, and parameter precision not specified, the
10		#' value for `default` will be used.
11		#' @param precision (named `list` of `integer`) where names are `strings` found in `summaryvars` and the values indicate
12		#' the number of digits in statistics for numeric variables. If `default` is set, and parameter precision not
13		#' specified, the value for `default` will be used. If neither are provided, auto determination is used. See
14		#' [`tern::format_auto`].
15		#' @returns the main function returns an `rtables` object.
16		#'
17		#' @details
18		#' * Information from `ADSUB` are generally included into `ADSL` before analysis.
19		#' * Default demographic and characteristics table
20		#' * If not specified otherwise, numbers represent absolute numbers of patients and fraction of `N`
21		#' * Remove zero-count rows
22		#' * Split columns by arm (planned or actual / code or description)
23		#' * Include a total column by default
24		#'
25		#' @note
26		#' * `adam_db` object must contain an `adsl` table with the columns specified in `summaryvars`.
27		#'
28		#' @export
29		#'
30		dmt01_main <- function(adam_db,
31		arm_var = "ARM",
32		lbl_overall = "All {Patient_label}",
33		summaryvars = c(
34		"AAGE",
35		"AGEGR1",
36		"SEX",
37		"ETHNIC",
38		"RACE"
39		),
40		stats = list(default = c("n", "mean_sd", "median", "range", "count_fraction")),
41		precision = list(),
42		...) {
43	1x	assert_string(arm_var)
44	1x	assert_string(lbl_overall, null.ok = TRUE)
45	1x	assert_character(summaryvars, null.ok = TRUE)
46	1x	assert_valid_variable(adam_db$adsl, summaryvars, na_ok = TRUE)
47	1x	assert_valid_variable(adam_db$adsl, summaryvars, types = list(c("numeric", "factor", "logical")))
48	1x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
49	1x	assert_list(stats, types = "character")
50	1x	assert_list(precision, types = "integerish", names = "unique")
51
52	1x	lbl_overall <- render_safe(lbl_overall)
53	1x	summaryvars_lbls <- var_labels_for(adam_db$adsl, summaryvars)
54
55	1x	lyt <- dmt01_lyt(
56	1x	arm_var = arm_var,
57	1x	lbl_overall = lbl_overall,
58	1x	summaryvars = summaryvars,
59	1x	summaryvars_lbls = summaryvars_lbls,
60	1x	stats = stats,
61	1x	precision = precision
62		)
63
64	1x	tbl <- build_table(lyt, adam_db$adsl)
65
66	1x	tbl
67		}
68
69		#' `dmt01` Layout
70		#' @param summaryvars_lbls (`character`) labels corresponding to the analyzed variables.
71		#'
72		#' @inheritParams gen_args
73		#' @returns a `PreDataTableLayouts` object.
74		#' @keywords internal
75		#'
76		dmt01_lyt <- function(arm_var,
77		lbl_overall,
78		summaryvars,
79		summaryvars_lbls,
80		stats,
81		precision) {
82	11x	basic_table(show_colcounts = TRUE) %>%
83	11x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
84	11x	analyze(
85	11x	vars = summaryvars,
86	11x	var_labels = summaryvars_lbls,
87	11x	afun = afun_p,
88	11x	extra_args = list(
89	11x	precision = precision,
90	11x	.stats = stats
91		),
92	11x	show_labels = "visible"
93		)
94		}
95
96		#' @describeIn dmt01 Preprocessing
97		#'
98		#' @inheritParams gen_args
99		#' @returns the preprocessing function returns a `list` of `data.frame`.
100		#' @export
101		#'
102		dmt01_pre <- function(adam_db, ...) {
103	1x	adam_db$adsl <- adam_db$adsl %>%
104	1x	mutate(SEX = reformat(.data$SEX, rule(Male = "M", Female = "F")))
105	1x	adam_db
106		}
107
108		#' @describeIn dmt01 Postprocessing
109		#'
110		#' @inheritParams gen_args
111		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
112		#' @export
113		#'
114		dmt01_post <- function(tlg, prune_0 = TRUE, ...) {
115	1x	if (prune_0) {
116	1x	tlg <- smart_prune(tlg)
117		}
118	1x	std_postprocessing(tlg)
119		}
120
121		#' `DMT01` Table 1 (Default) Demographics and Baseline Characteristics Table 1.
122		#'
123		#' For each variable, summary statistics are
124		#' by default based on the number of patients in the corresponding `n` row.
125		#'
126		#' @include chevron_tlg-S4class.R
127		#' @export
128		#'
129		#' @examples
130		#' run(dmt01, syn_data)
131		dmt01 <- chevron_t(
132		main = dmt01_main,
133		preprocess = dmt01_pre,
134		postprocess = dmt01_post
135		)

1		# mng01 ----
2
3		#' @describeIn mng01 Main TLG Function
4		#'
5		#' @details
6		#' * No overall value.
7		#' * Preprocessing filters for `ANL01FL` in the selected data set.
8		#'
9		#' @inheritParams gen_args
10		#' @param dataset (`string`) the name of a table in the `adam_db` object.
11		#' @param x_var (`string`) the name of a column in the `dataset` to represent on the x-axis.
12		#' @param y_var (`string`) the name of the variable to be represented on the y-axis.
13		#' @param y_name (`string`) the variable name for `y`. Used for plot's subtitle.
14		#' @param y_unit (`string`) the name of the variable with the units of `y`. Used for plot's subtitle. if `NULL`, only
15		#' `y_name` is displayed as subtitle.
16		#' @param center_fun (`string`) the function to compute the estimate value.
17		#' @param interval_fun (`string`) the function defining the crossbar range. If `NULL`, no crossbar is displayed.
18		#' @param jitter (`numeric`) the width of spread for data points on the x-axis; a number from 0 (no `jitter`) to 1 (high
19		#' `jitter`), with a default of 0.3 (slight `jitter`).
20		#' @param line_col (`character`) describing the colors to use for the lines or a named `character` associating values of
21		#' `arm_var` with color names.
22		#' @param line_type (`character`) describing the line type to use for the lines or a named `character` associating
23		#' values of `arm_var` with line types.
24		#' @param ggtheme (`theme`) passed to [tern::g_lineplot()].
25		#' @param table (`character`) names of the statistics to be displayed in the table. If `NULL`, no table is displayed.
26		#' @param ... passed to [tern::g_lineplot()].
27		#' @returns the main function returns a `list` of `ggplot` objects.
28		#'
29		#' @note
30		#' * `adam_db` object must contain the table specified by `dataset` with the columns specified by `x_var`, `y_var`,
31		#' `y_name`, `y_unit` and `arm_var`.
32		#'
33		#' @seealso [gg_theme_chevron()], [tern::g_lineplot()].
34		#'
35		#' @returns a list of `ggplot` objects.
36		#'
37		#' @export
38		#'
39		mng01_main <- function(adam_db,
40		dataset = "adlb",
41		x_var = "AVISIT",
42		y_var = "AVAL",
43		y_name = "PARAM",
44		y_unit = NULL,
45		arm_var = "ACTARM",
46		center_fun = "mean",
47		interval_fun = "mean_ci",
48		jitter = 0.3,
49		line_col = nestcolor::color_palette(),
50		line_type = NULL,
51		ggtheme = gg_theme_chevron(),
52		table = c("n", center_fun, interval_fun),
53		...) {
54	3x	center_fun_choice <- c("mean", "median")
55	3x	interval_fun_choice <- c("mean_ci", "mean_sei", "mean_sdi", "median_ci", "quantiles", "range")
56
57	3x	assert_all_tablenames(adam_db, c(dataset, "adsl"))
58	3x	assert_character(x_var)
59	3x	assert_string(y_var)
60	3x	assert_string(y_name)
61	3x	assert_string(y_unit, null.ok = TRUE)
62	3x	assert_string(arm_var)
63	3x	assert_string(center_fun)
64	3x	assert_string(interval_fun, null.ok = TRUE)
65	3x	assert_names(center_fun, subset.of = center_fun_choice)
66	3x	assert_choice(interval_fun, interval_fun_choice, null.ok = TRUE)
67	3x	assert_number(jitter, lower = 0, upper = 1)
68	3x	assert_class(ggtheme, "theme")
69	3x	assert_character(line_col, null.ok = TRUE)
70	3x	assert_character(line_type, null.ok = TRUE)
71	3x	assert_valid_variable(adam_db[[dataset]], x_var)
72	3x	assert_valid_variable(adam_db[[dataset]], y_var, types = list(c("numeric")))
73	3x	assert_valid_variable(adam_db[[dataset]], y_unit, types = list(c("character", "factor")))
74	3x	assert_valid_variable(adam_db[[dataset]], arm_var, types = list(c("character", "factor")), na_ok = FALSE)
75	3x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
76	3x	assert_valid_variable(adam_db[[dataset]], "USUBJID", types = list(c("character", "factor")), empty_ok = TRUE)
77	3x	assert_valid_var_pair(adam_db$adsl, adam_db[[dataset]], arm_var)
78	3x	assert_subset(table, c("n", center_fun_choice, interval_fun_choice))
79
80	3x	df <- adam_db[[dataset]]
81
82	3x	data_ls <- split(df, df$PARAM, drop = TRUE)
83	3x	x_var <- paste(x_var, collapse = "_")
84
85	3x	whiskers_fun <- if (is.null(interval_fun)) {
86	!	NULL
87		} else {
88	3x	switch(interval_fun,
89	3x	"mean_ci" = c("mean_ci_lwr", "mean_ci_upr"),
90	!	"mean_sei" = c("mean_sei_lwr", "mean_sei_upr"),
91	!	"mean_sdi" = c("mean_sdi_lwr", "mean_sdi_upr"),
92	!	"median_ci" = c("median_ci_lwr", "median_ci_upr"),
93	!	"quantiles" = c("quantiles_0.25", "quantile_0.75"),
94	!	"range" = c("min", "max")
95		)
96		}
97
98
99	3x	y_unit <- if (is.null(y_unit)) NA else y_unit
100	3x	variables <- tern::control_lineplot_vars(
101	3x	x = x_var,
102	3x	y = y_var,
103	3x	group_var = arm_var,
104	3x	paramcd = y_name,
105	3x	y_unit = y_unit,
106	3x	subject_var = "USUBJID"
107		)
108
109
110	3x	arm_lvl <- sort(unique(df[[arm_var]]))
111
112	3x	col <- if (!is.null(names(line_col))) {
113	2x	col_sel <- line_col[as.character(arm_lvl)]
114
115	2x	if (anyNA(col_sel)) {
116	1x	missing_col <- setdiff(arm_lvl, names(col_sel))
117	1x	stop(paste("Missing color matching for", toString(missing_col)))
118		}
119
120	1x	unname(col_sel)
121		} else {
122	1x	line_col
123		}
124
125	2x	line_type <- if (!is.null(names(line_type))) {
126	!	tp <- line_type[as.character(arm_lvl)]
127
128	!	if (anyNA(tp)) {
129	!	missing_tp <- setdiff(arm_lvl, names(tp))
130	!	stop(paste("Missing line type matching for", toString(missing_tp)))
131		}
132
133	!	unname(tp)
134		} else {
135	2x	line_type
136		}
137
138
139
140
141	2x	lapply(
142	2x	data_ls,
143	2x	tern::g_lineplot,
144	2x	alt_counts_df = adam_db[["adsl"]],
145	2x	variables = variables,
146	2x	mid = center_fun,
147	2x	interval = interval_fun,
148	2x	whiskers = whiskers_fun,
149	2x	position = ggplot2::position_dodge(width = jitter),
150	2x	title = NULL,
151	2x	table = table,
152	2x	ggtheme = ggtheme,
153	2x	col = col,
154	2x	linetype = line_type,
155	2x	subtitle_add_unit = !is.na(y_unit),
156		...
157		)
158		}
159
160		#' @describeIn mng01 Preprocessing
161		#'
162		#' @inheritParams mng01_main
163		#' @returns the preprocessing function returns a `list` of `data.frame`.
164		#' @export
165		#'
166		mng01_pre <- function(adam_db, dataset, x_var = "AVISIT", ...) {
167	2x	assert_character(dataset)
168	2x	dunlin::assert_all_tablenames(adam_db, dataset)
169
170	2x	adam_db[[dataset]] <- adam_db[[dataset]] %>%
171	2x	filter(.data$ANL01FL == "Y") %>%
172	2x	mutate(
173	2x	AVISIT = reorder(.data$AVISIT, .data$AVISITN),
174	2x	AVISIT = with_label(.data$AVISIT, "Visit")
175		)
176
177	2x	if (length(x_var) == 1 && is.numeric(adam_db[[dataset]][[x_var]])) {
178	!	adam_db
179		} else {
180	2x	dunlin::ls_unite(adam_db, dataset, cols = x_var, sep = "_")
181		}
182		}
183
184		# `mng01` Pipeline ----
185
186		#' `MNG01` Mean Plot Graph.
187		#'
188		#' Overview of a summary statistics across time and arm for a selected data set.
189		#'
190		#' @include chevron_tlg-S4class.R
191		#' @export
192		#'
193		#' @examples
194		#' col <- c(
195		#' "A: Drug X" = "black",
196		#' "B: Placebo" = "blue",
197		#' "C: Combination" = "gray"
198		#' )
199		#'
200		#' lt <- c(
201		#' "A: Drug X" = "29",
202		#' "B: Placebo" = "99",
203		#' "C: Combination" = "solid"
204		#' )
205		#'
206		#' run(
207		#' mng01,
208		#' syn_data,
209		#' dataset = "adlb",
210		#' x_var = c("AVISIT", "AVISITN"),
211		#' line_col = col,
212		#' line_type = lt
213		#' )
214		mng01 <- chevron_g(
215		main = mng01_main,
216		preprocess = mng01_pre
217		)

1		# assert_single_value ----
2
3		#' Check variable only has one unique value.
4		#' @param x value vector.
5		#' @param label (`string`) label of input.
6		#' @returns invisible `NULL` or an error message if the criteria are not fulfilled.
7		#' @export
8		assert_single_value <- function(x, label = deparse(substitute(x))) {
9	69x	unique_param_val <- unique(x)
10	69x	if (length(unique_param_val) > 1) {
11	!	stop(
12	!	quote_str(label),
13	!	" has more than one values ",
14	!	toString(unique_param_val),
15	!	", only one value is allowed."
16		)
17		}
18		}
19
20		# assert_valid_var ----
21
22		#' @title Check whether var is valid
23		#' @details
24		#' This function checks the variable values are valid or not.
25		#' @param x value of col_split variable
26		#' @param label (`string`) hints.
27		#' @param na_ok (`flag`) whether NA value is allowed
28		#' @param empty_ok (`flag`) whether length 0 value is allowed.
29		#' @param ... Further arguments to methods.
30		#' @returns invisible `NULL` or an error message if the criteria are not fulfilled.
31		#' @export
32		assert_valid_var <- function(x, label, na_ok, empty_ok, ...) {
33	1956x	UseMethod("assert_valid_var")
34		}
35		#' @rdname assert_valid_var
36		#' @export
37		#' @param min_chars (`integer`) the minimum length of the characters.
38		assert_valid_var.character <- function(
39		x, label = deparse(substitute(x)),
40		na_ok = FALSE, empty_ok = FALSE,
41		min_chars = 1L, ...) {
42	471x	assert_character(
43	471x	x,
44	471x	min.chars = min_chars,
45	471x	min.len = as.integer(!empty_ok),
46	471x	any.missing = na_ok,
47	471x	.var.name = label,
48		...
49		)
50		}
51
52		#' @rdname assert_valid_var
53		#' @export
54		assert_valid_var.factor <- function(
55		x, label = deparse(substitute(x)),
56		na_ok = FALSE, empty_ok = FALSE,
57		min_chars = 1L, ...) {
58	1092x	assert_character(
59	1092x	levels(x),
60	1092x	min.chars = min_chars,
61	1092x	.var.name = paste("level of", label)
62		)
63	1091x	assert_factor(
64	1091x	x,
65	1091x	min.levels = as.integer(!empty_ok),
66	1091x	any.missing = na_ok,
67	1091x	.var.name = label,
68		...
69		)
70		}
71
72		#' @rdname assert_valid_var
73		#' @export
74		assert_valid_var.logical <- function(x, label = deparse(substitute(x)), na_ok = TRUE, empty_ok = FALSE, ...) {
75	193x	assert_logical(
76	193x	x,
77	193x	min.len = as.integer(!empty_ok),
78	193x	any.missing = na_ok,
79	193x	.var.name = label,
80		...
81		)
82		}
83
84		#' @rdname assert_valid_var
85		#' @param integerish (`flag`) whether the number should be treated as `integerish`.
86		#' @export
87		assert_valid_var.numeric <- function(
88		x, label = deparse(substitute(x)),
89		na_ok = TRUE, empty_ok = FALSE, integerish = FALSE, ...) {
90	192x	check_fun <- if (integerish) assert_integerish else assert_numeric
91	192x	check_fun(
92	192x	x,
93	192x	min.len = as.integer(!empty_ok),
94	192x	any.missing = na_ok,
95	192x	.var.name = label,
96		...
97		)
98		}
99
100		#' @rdname assert_valid_var
101		#' @param tzs (`character`) time zones.
102		#' @export
103		assert_valid_var.POSIXct <- function(x,
104		label = deparse(substitute(x)),
105		na_ok = TRUE,
106		empty_ok = FALSE,
107		tzs = OlsonNames(),
108		...) {
109	8x	assert_posixct(
110	8x	x,
111	8x	min.len = as.integer(!empty_ok),
112	8x	any.missing = na_ok,
113	8x	.var.name = label,
114		...
115		)
116
117	8x	extra_args <- list(...)
118
119		# Test if time zone of x is in OlsonNames
120	8x	if (lubridate::tz(x) %in% tzs) {
121	7x	return(invisible(NULL))
122	1x	} else if (is(extra_args$add, "AssertCollection")) {
123	!	extra_args$add$push(paste("Non standard timezone detected for", label, "!"))
124		} else {
125	1x	abort(paste("Non standard timezone detected for", label, "!"))
126		}
127		}
128
129		#' @rdname assert_valid_var
130		#' @export
131		assert_valid_var.default <- function(x, label = deparse(substitute(x)), na_ok = FALSE, empty_ok = FALSE, ...) {
132		}
133
134		# assert_valid_variable ----
135
136		#' Check variables in a data frame are valid character or factor.
137		#' @param df (`data.frame`) input dataset.
138		#' @param vars (`character`) variables to check.
139		#' @param label (`string`) labels of the data frame.
140		#' @param types Named (`list`) of type of the input.
141		#' @param ... further arguments for `assert_valid_var`. Please note that different methods have different arguments
142		#' so if provided make sure the variables to check is of the same class.
143		#' @returns invisible `TRUE` or an error message if the criteria are not fulfilled.
144		#' @export
145		assert_valid_variable <- function(df, vars, label = deparse(substitute(df)), types = NULL, ...) {
146	1136x	assert_names(colnames(df), must.include = vars, what = "colnames")
147
148	1132x	labels <- sprintf("%s$%s", label, vars)
149	1132x	if (length(types) == 1 && is.null(names(types))) {
150	1012x	types <- setNames(rep(types, length(vars)), vars)
151		}
152	1132x	if (!is.null(types)) {
153	1046x	vars_to_check <- which(vars %in% names(types))
154	1046x	mapply(
155	1046x	assert_valid_type,
156	1046x	df[vars[vars_to_check]],
157	1046x	types = types[vars_to_check],
158	1046x	label = labels[vars_to_check]
159		)
160		}
161	1129x	collection <- makeAssertCollection()
162	1129x	mapply(assert_valid_var, df[vars], labels, MoreArgs = list(..., add = collection), SIMPLIFY = FALSE)
163	1129x	reportAssertions(collection)
164		}
165
166		# assert_valid_type ----
167
168		#' Check variable is of correct type
169		#' @param x Object to check the type.
170		#' @param types (`character`) possible types to check.
171		#' @param label (`string`) label.
172		#' @returns invisible `NULL` or an error message if the criteria are not fulfilled.
173		assert_valid_type <- function(x, types, label = deparse(substitute(x))) {
174	1638x	if (!any(vapply(types, is, object = x, FUN.VALUE = TRUE))) {
175	3x	abort(
176	3x	paste0(
177	3x	quote_str(label),
178	3x	" is not of type ",
179	3x	toString(types)
180		)
181		)
182		}
183		}
184
185		# assert_valid_var_pair ----
186
187		#' Check variables are of same levels
188		#' @param df1 (`data.frame`) input.
189		#' @param df2 (`data.frame`) input.
190		#' @param var (`string`) variable to check.
191		#' @param lab1 (`string`) label hint for `df1`.
192		#' @param lab2 (`string`) label hint for `df2`.
193		#' @returns invisible `NULL` or an error message if the criteria are not fulfilled.
194		assert_valid_var_pair <- function(df1, df2, var, lab1 = deparse(substitute(df1)), lab2 = deparse(substitute(df2))) {
195	178x	assert_data_frame(df1)
196	178x	assert_data_frame(df2)
197	178x	assert_string(var)
198	178x	lvl_x <- lvls(df1[[var]])
199	178x	lvl_y <- lvls(df2[[var]])
200	178x	if (!identical(lvl_x, lvl_y)) {
201	3x	abort(
202	3x	paste0(
203	3x	quote_str(lab1), " and ",
204	3x	quote_str(lab2), " should contain the same levels in variable ",
205	3x	quote_str(var), "!"
206		)
207		)
208		}
209		}

1		# lbt07 ----
2
3		#' @describeIn lbt07 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param param_var (`string`) the name of the column storing the parameters name.
7		#' @param grad_dir_var (`string`) the name of the column storing the grade direction variable which is required in
8		#' order to obtain the correct denominators when building the layout as it is used to define row splitting.
9		#' @param grad_anl_var (`string`) the name of the column storing toxicity grade variable where all negative values from
10		#' `ATOXGR` are replaced by their absolute values.
11		#' @returns the main function returns an `rtables` object.
12		#'
13		#' @details
14		#' * Split columns by arm, typically `ACTARM`.
15		#'
16		#' @note
17		#' * `adam_db` object must contain an `adlb` table with columns `"USUBJID"`, `"ATOXGR"`,
18		#' `"ONTRTFL"` and column specified by `arm_var`.
19		#'
20		#' @export
21		#'
22		lbt07_main <- function(adam_db,
23		arm_var = "ACTARM",
24		lbl_overall = NULL,
25		param_var = "PARAM",
26		grad_dir_var = "GRADE_DIR",
27		grad_anl_var = "GRADE_ANL",
28		...) {
29	1x	assert_all_tablenames(adam_db, c("adsl", "adlb"))
30	1x	assert_string(arm_var)
31	1x	assert_string(lbl_overall, null.ok = TRUE)
32	1x	assert_string(param_var)
33	1x	assert_string(grad_dir_var)
34	1x	assert_string(grad_anl_var)
35	1x	assert_valid_variable(
36	1x	adam_db$adlb, c("ATOXGR", param_var, grad_dir_var, grad_anl_var),
37	1x	types = list(c("character", "factor"))
38		)
39	1x	assert_valid_variable(adam_db$adlb, c("USUBJID"), types = list(c("character", "factor")), empty_ok = TRUE)
40	1x	assert_valid_variable(adam_db$adsl, c("USUBJID"), types = list(c("character", "factor")))
41	1x	assert_valid_var_pair(adam_db$adsl, adam_db$adlb, arm_var)
42
43	1x	lbl_overall <- render_safe(lbl_overall)
44	1x	lbl_param_var <- var_labels_for(adam_db$adlb, param_var)
45	1x	lbl_grad_dir_var <- var_labels_for(adam_db$adlb, grad_dir_var)
46
47	1x	map <- expand.grid(
48	1x	PARAM = levels(adam_db$adlb[[param_var]]),
49	1x	GRADE_DIR = c("LOW", "HIGH"),
50	1x	GRADE_ANL = as.character(1:4),
51	1x	stringsAsFactors = FALSE
52		) %>%
53	1x	arrange(.data$PARAM, desc(.data$GRADE_DIR), .data$GRADE_ANL)
54
55	1x	names(map) <- c(param_var, grad_dir_var, grad_anl_var)
56
57	1x	lyt <- lbt07_lyt(
58	1x	arm_var = arm_var,
59	1x	lbl_overall = lbl_overall,
60	1x	lbl_param_var = lbl_param_var,
61	1x	lbl_grad_dir_var = lbl_grad_dir_var,
62	1x	param_var = param_var,
63	1x	grad_dir_var = grad_dir_var,
64	1x	grad_anl_var = grad_anl_var,
65	1x	map = map
66		)
67
68	1x	tbl <- build_table(lyt, adam_db$adlb, alt_counts_df = adam_db$adsl)
69
70	1x	tbl
71		}
72
73		#' `lbt07` Layout
74		#'
75		#' @inheritParams gen_args
76		#' @inheritParams lbt07_main
77		#'
78		#' @param lbl_param_var (`string`) label of the `param_var` variable.
79		#' @param lbl_grad_dir_var (`string`) label for the `grad_dir_var` variable.
80		#' @param map (`data.frame`) mapping of `PARAM`s to directions of abnormality.
81		#'
82		#' @keywords internal
83		#'
84		lbt07_lyt <- function(arm_var,
85		lbl_overall,
86		lbl_param_var,
87		lbl_grad_dir_var,
88		param_var,
89		grad_dir_var,
90		grad_anl_var,
91		map) {
92	2x	basic_table(show_colcounts = TRUE) %>%
93	2x	split_cols_by_with_overall(arm_var, lbl_overall) %>%
94	2x	split_rows_by(
95	2x	param_var,
96	2x	label_pos = "topleft",
97	2x	split_label = lbl_param_var
98		) %>%
99	2x	summarize_num_patients(
100	2x	var = "USUBJID",
101	2x	required = "ATOXGR",
102	2x	.stats = "unique_count"
103		) %>%
104	2x	split_rows_by(
105	2x	grad_dir_var,
106	2x	label_pos = "topleft",
107	2x	split_label = lbl_grad_dir_var,
108	2x	split_fun = trim_levels_to_map(map)
109		) %>%
110	2x	count_abnormal_by_worst_grade(
111	2x	var = grad_anl_var,
112	2x	variables = list(id = "USUBJID", param = param_var, grade_dir = grad_dir_var),
113	2x	.formats = list(count_fraction = tern::format_count_fraction_fixed_dp),
114	2x	.indent_mods = 4L
115		) %>%
116	2x	append_topleft(" Highest NCI CTCAE Grade")
117		}
118
119		#' @describeIn lbt07 Preprocessing
120		#'
121		#' @inheritParams gen_args
122		#' @returns the preprocessing function returns a `list` of `data.frame`.
123		#' @export
124		#'
125		lbt07_pre <- function(adam_db, ...) {
126	1x	adam_db$adlb <- adam_db$adlb %>%
127	1x	mutate(
128	1x	ATOXGR = reformat(.data$ATOXGR, missing_rule)
129		) %>%
130	1x	filter(
131	1x	.data$ATOXGR != "<Missing>",
132	1x	.data$ONTRTFL == "Y",
133	1x	.data$WGRLOFL == "Y" \| .data$WGRHIFL == "Y"
134		) %>%
135	1x	mutate(
136	1x	GRADE_DIR = factor(
137	1x	case_when(
138	1x	ATOXGR %in% c("-1", "-2", "-3", "-4") & .data$WGRLOFL == "Y" ~ "LOW",
139	1x	ATOXGR == "0" ~ "ZERO",
140	1x	ATOXGR %in% c("1", "2", "3", "4") & .data$WGRHIFL == "Y" ~ "HIGH",
141	1x	TRUE ~ "NONE"
142		),
143	1x	levels = c("LOW", "ZERO", "HIGH", "NONE")
144		),
145	1x	GRADE_ANL = factor(.data$ATOXGR, levels = c(-4:4), labels = abs(c(-4:4))),
146	1x	PARAM = as.factor(trimws(stringr::str_remove_all(.data$PARAM, "\\(.+?\\)")))
147		)
148
149	1x	adam_db$adlb <- adam_db$adlb %>%
150	1x	mutate(
151	1x	PARAM = with_label(.data$PARAM, "Parameter"),
152	1x	GRADE_DIR = with_label(.data$GRADE_DIR, "Direction of Abnormality"),
153	1x	GRADE_ANL = with_label(.data$GRADE_ANL, "Toxicity Grade")
154		)
155
156	1x	adam_db
157		}
158
159		#' @describeIn lbt07 Postprocessing
160		#'
161		#' @inheritParams gen_args
162		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
163		#' @export
164		#'
165		lbt07_post <- function(tlg, prune_0 = TRUE, ...) {
166	1x	if (prune_0) {
167	1x	tlg <- smart_prune(tlg)
168		}
169	1x	std_postprocessing(tlg)
170		}
171
172		#' `LBT07` Table 1 (Default) Laboratory Test Results and Change from Baseline by Visit.
173		#'
174		#' The `LBT07` table provides an
175		#' overview of the analysis values and its change from baseline of each respective arm over the course of the trial.
176		#' @include chevron_tlg-S4class.R
177		#' @export
178		#'
179		#' @examples
180		#' run(lbt07, syn_data)
181		lbt07 <- chevron_t(
182		main = lbt07_main,
183		preprocess = lbt07_pre,
184		postprocess = lbt07_post
185		)

1		#' Helper Function Extracting Layout Functions
2		#' @keywords internal
3		#'
4		h_unwrap_layout <- function(x, pattern) {
5	905x	assert_string(pattern)
6
7		# If x is a list or a call, apply the function on each element
8	905x	if (inherits(x, c("list", "call", "<-", "if"))) {
9	265x	lapply(x, \(x) h_unwrap_layout(x, pattern))
10	640x	} else if (is(x, "name")) {
11		# Return if name match pattern.
12
13	470x	if (grepl(pattern, x)) {
14	6x	res <- list(x)
15	6x	names(res) <- as.character(x)
16	6x	res
17		} else {
18	464x	NULL
19		}
20		} else {
21	170x	NULL
22		}
23		}
24
25		#' Extracting Layout Function.
26		#'
27		#' @param x (`function`) containing a call to a layout function.
28		#' @param pattern (`string`) identifying layout functions
29		#'
30		#' @returns invisible `NULL` and print the content of the layout functions found in the body of `x`.
31		#'
32		#' @export
33		#' @keywords internal
34		#' @examples
35		#' unwrap_layout(aet01_main)
36		#'
37		unwrap_layout <- function(x, pattern = "_lyt$") {
38	11x	checkmate::assert_function(x)
39	11x	checkmate::assert_string(pattern)
40
41		# Identify environment of the parent function.
42	11x	env_x <- tryCatch(
43	11x	rlang::get_env(x),
44	11x	error = function(e) NULL
45		)
46
47		# Get the associated layout functions as name objects
48	11x	res <- unlist(h_unwrap_layout(body(x)[-1], pattern))
49
50	11x	if (length(res) > 0L) {
51	5x	cat("Layout function:")
52	5x	purrr::lmap(
53	5x	res,
54	5x	function(x) {
55		# Evaluate layout function symbol in the environment of the parent function.
56	6x	tryCatch(
57		{
58	6x	cat("\n")
59	6x	layout_code <- paste(deparse(eval(x[[1]], envir = env_x)), collapse = "\n")
60	6x	cat(sprintf(" %s:\n", names(x)))
61	6x	cat(layout_code)
62		},
63	6x	error = function(e) cat("\n Unable to print layout function!")
64		)
65
66	6x	list()
67		}
68		)
69		}
70	11x	cat("\n")
71	11x	invisible(NULL)
72		}

1		# mht01 ----
2
3		#' @describeIn mht01 Default labels
4		#' @export
5		mht01_label <- c(
6		unique = "Total number of {patient_label} with at least one condition",
7		nonunique = "Total number of conditions"
8		)
9
10		#' @describeIn mht01 Main TLG function
11		#'
12		#' @inheritParams gen_args
13		#' @param summary_labels (`list`) of summarize labels. See details.
14		#' @returns the main function returns an `rtables` object.
15		#'
16		#' @details
17		#' * Numbers represent absolute numbers of patients 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		#' * Order by `row_split_var` alphabetically and medical condition by decreasing total number of
22		#' patients with the specific condition.
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 `admh` table with columns `"MHBODSYS"` and `"MHDECOD"`.
28		#'
29		#' @export
30		#'
31		mht01_main <- function(adam_db,
32		arm_var = "ARM",
33		row_split_var = "MHBODSYS",
34		lbl_overall = NULL,
35		summary_labels = list(
36		all = mht01_label
37		),
38		...) {
39	1x	assert_all_tablenames(adam_db, c("admh", "adsl"))
40	1x	assert_string(arm_var)
41	1x	assert_string(lbl_overall, null.ok = TRUE)
42	1x	assert_valid_variable(
43	1x	adam_db$admh,
44	1x	c(row_split_var, "MHDECOD"),
45	1x	types = list(c("character", "factor")),
46	1x	empty_ok = TRUE
47		)
48	1x	assert_valid_variable(adam_db$admh, "USUBJID", types = list(c("character", "factor")), empty_ok = TRUE)
49	1x	assert_valid_variable(adam_db$adsl, "USUBJID", types = list(c("character", "factor")))
50	1x	assert_valid_var_pair(adam_db$adsl, adam_db$admh, arm_var)
51	1x	assert_list(summary_labels, null.ok = TRUE)
52	1x	assert_subset(names(summary_labels), c("all", "TOTAL", row_split_var))
53	1x	assert_subset(
54	1x	unique(unlist(lapply(summary_labels, names))),
55	1x	c("unique", "nonunique", "unique_count")
56		)
57	1x	summary_labels <- expand_list(summary_labels, c("TOTAL", row_split_var))
58
59	1x	lbl_overall <- render_safe(lbl_overall)
60	1x	lbl_row_split <- var_labels_for(adam_db$admh, row_split_var)
61	1x	lbl_mhdecod <- var_labels_for(adam_db$admh, "MHDECOD")
62
63	1x	lyt <- occurrence_lyt(
64	1x	arm_var = arm_var,
65	1x	lbl_overall = lbl_overall,
66	1x	row_split_var = row_split_var,
67	1x	lbl_row_split = lbl_row_split,
68	1x	medname_var = "MHDECOD",
69	1x	lbl_medname_var = lbl_mhdecod,
70	1x	summary_labels = summary_labels,
71	1x	count_by = "MHSEQ"
72		)
73
74	1x	tbl <- build_table(lyt, adam_db$admh, alt_counts_df = adam_db$adsl)
75
76	1x	tbl
77		}
78
79		#' @describeIn mht01 Preprocessing
80		#'
81		#' @inheritParams gen_args
82		#' @returns the preprocessing function returns a `list` of `data.frame`.
83		#' @export
84		#'
85		mht01_pre <- function(adam_db, ...) {
86	1x	adam_db$admh <- adam_db$admh %>%
87	1x	filter(.data$ANL01FL == "Y")
88
89	1x	adam_db$admh <- adam_db$admh %>%
90	1x	mutate(
91	1x	across(all_of(c("MHBODSYS", "MHDECOD")), ~ reformat(.x, nocoding))
92		) %>%
93	1x	mutate(
94	1x	MHBODSYS = with_label(.data$MHBODSYS, "MedDRA System Organ Class"),
95	1x	MHDECOD = with_label(.data$MHDECOD, "MedDRA Preferred Term"),
96	1x	MHSEQ = as.factor(.data$MHSEQ)
97		)
98
99	1x	adam_db
100		}
101
102		#' @describeIn mht01 Postprocessing
103		#'
104		#' @inheritParams gen_args
105		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
106		#' @export
107		#'
108		mht01_post <- function(tlg, row_split_var = "MHBODSYS", prune_0 = TRUE, ...) {
109	1x	if (prune_0) {
110	1x	tlg <- smart_prune(tlg)
111		}
112
113	1x	row_split_var <- c(rbind(row_split_var, "*"))
114
115	1x	tbl_sorted <- tlg %>%
116	1x	sort_at_path(
117	1x	path = c(row_split_var, "MHDECOD"),
118	1x	scorefun = score_occurrences
119		)
120
121	1x	std_postprocessing(tbl_sorted)
122		}
123
124		#' `MHT01` Medical History Table.
125		#'
126		#' The `MHT01` table provides an overview of the subjects medical
127		#' history by SOC and Preferred Term.
128		#'
129		#' @include chevron_tlg-S4class.R
130		#' @export
131		#'
132		#' @examples
133		#' run(mht01, syn_data)
134		mht01 <- chevron_t(
135		main = mht01_main,
136		preprocess = mht01_pre,
137		postprocess = mht01_post
138		)

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

1		#' Check that all names are among column names
2		#'
3		#' @param df (`data.frame`)
4		#' @param x (`character`) the names of the columns to be checked.
5		#' @param null_ok (`flag`) can `x` be NULL.
6		#' @param qualifier (`string`) to be returned if the check fails.
7		#' @returns invisible `NULL` or a string if the criteria are not fulfilled.
8		#'
9		#' @keywords internal
10		check_all_colnames <- function(df, x, null_ok = TRUE, qualifier = NULL) {
11	2x	assert_data_frame(df)
12	2x	assert_character(x, null.ok = null_ok)
13	2x	assert_string(qualifier, null.ok = TRUE)
14
15	2x	diff <- setdiff(x, colnames(df))
16
17	2x	if (length(diff) == 0) {
18	1x	invisible(NULL)
19		} else {
20	1x	paste(qualifier, "Expected column names:", toString(diff), "not in", deparse(substitute(df)))
21		}
22		}
23
24		#' Check that at least one name is among column names
25		#'
26		#' @param df (`data.frame`)
27		#' @param x (`character`) the names of the columns to be checked.
28		#' @param null_ok (`flag`) can `x` be NULL.
29		#' @param qualifier (`string`) to be returned if the check fails.
30		#' @returns invisible `NULL` or a string if the criteria are not fulfilled.
31		#'
32		#' @keywords internal
33		check_one_colnames <- function(df, x, null_ok = TRUE, qualifier = NULL) {
34	2x	assert_data_frame(df)
35	2x	assert_character(x, null.ok = null_ok)
36	2x	assert_string(qualifier, null.ok = TRUE)
37
38	2x	common <- intersect(x, colnames(df))
39
40	2x	if (length(common) > 0) {
41	1x	invisible(NULL)
42		} else {
43	1x	paste(qualifier, "At least one of:", toString(x), "is expected to be a column name of", deparse(substitute(df)))
44		}
45		}

1		# rmpt01 ----
2
3		#' @describeIn rmpt01 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @param summaryvars (`string`) variables to be analyzed. The label attribute of the corresponding columns in `adex`
7		#' table of `adam_db` is used as label.
8		#' @param show_tot (`flag`) whether to display the cumulative total.
9		#' @param row_split_var (`string`) the name of the column that containing variable to split exposure by.
10		#' @param col_split_var (`string`) additional column splitting variable.
11		#' @param overall_col_lbl (`string`) name of the overall column. If `NULL`, no overall level is added.
12		#' @returns the main function returns an `rtables` object.
13		#'
14		#' @details
15		#' * Person time is the sum of exposure across all patients.
16		#' * Summary statistics are by default based on the number of patients in the corresponding `N` row
17		#' (number of non-missing values).
18		#' * Does not remove zero-count rows unless overridden with `prune_0 = TRUE`.
19		#'
20		#' @note
21		#' * `adam_db` object must contain an `adex` table with `"AVAL"` and the columns specified by `summaryvars`.
22		#'
23		#' @export
24		#'
25		rmpt01_main <- function(adam_db,
26		summaryvars = "AVALCAT1",
27		show_tot = TRUE,
28		row_split_var = NULL,
29		col_split_var = NULL,
30		overall_col_lbl = NULL,
31		...) {
32	4x	assert_all_tablenames(adam_db, c("adsl", "adex"))
33	4x	assert_string(summaryvars)
34	4x	assert_flag(show_tot)
35	4x	assert_string(row_split_var, null.ok = TRUE)
36	4x	assert_string(col_split_var, null.ok = TRUE)
37	4x	assert_string(overall_col_lbl, null.ok = TRUE)
38	4x	assert_valid_variable(adam_db$adex, summaryvars, types = list(c("factor", "character")), empty_ok = TRUE)
39	4x	assert_valid_variable(adam_db$adex, "AVAL", types = list("numeric"), empty_ok = TRUE)
40	4x	assert_valid_variable(adam_db$adex, row_split_var, types = list(c("factor", "numeric")), empty_ok = TRUE)
41	4x	assert_valid_variable(adam_db$adex, col_split_var, types = list(c("factor", "character")))
42	4x	assert_valid_variable(adam_db$adex, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
43	4x	assert_valid_variable(adam_db$adsl, "USUBJID", types = list(c("character", "factor")))
44
45	4x	lbl_summaryvars <- var_labels_for(adam_db$adex, summaryvars)
46
47	4x	lyt <- rmpt01_lyt(
48	4x	summaryvars = summaryvars,
49	4x	lbl_summaryvars = lbl_summaryvars,
50	4x	show_tot = show_tot,
51	4x	row_split_var = row_split_var,
52	4x	col_split_var = col_split_var,
53	4x	overall_col_lbl = overall_col_lbl
54		)
55
56	4x	build_table(lyt, adam_db$adex, alt_counts_df = adam_db$adsl)
57		}
58
59		#' `rmpt01` Layout
60		#'
61		#' @inheritParams gen_args
62		#' @inheritParams rmpt01_main
63		#' @param lbl_summaryvars (`character`) label associated with the analyzed variables.
64		#'
65		#' @keywords internal
66		#'
67		rmpt01_lyt <- function(summaryvars,
68		lbl_summaryvars,
69		show_tot,
70		row_split_var,
71		col_split_var,
72		overall_col_lbl) {
73	21x	lyt <- basic_table(show_colcounts = TRUE) %>%
74	21x	split_cols_by_with_overall(col_split_var, overall_col_lbl) %>%
75	21x	split_cols_by_multivar(
76	21x	vars = c("AVAL", "AVAL"),
77	21x	varlabels = c(n_patients = render_safe("{Patient_label}"), sum_exposure = "Person time"),
78	21x	extra_args = list(.stats = c("n_patients", "sum_exposure"))
79		) %>%
80	21x	analyze_patients_exposure_in_cols(
81	21x	var = summaryvars,
82	21x	col_split = FALSE,
83	21x	add_total_level = show_tot,
84	21x	custom_label = render_safe("Total {patient_label} number/person time")
85		)
86
87	21x	if (!is.null(row_split_var)) {
88	4x	lyt %>%
89	4x	split_rows_by(row_split_var) %>%
90	4x	analyze_patients_exposure_in_cols(
91	4x	.indent_mods = -1L,
92	4x	var = summaryvars,
93	4x	col_split = FALSE,
94	4x	add_total_level = show_tot,
95	4x	custom_label = render_safe("Total {patient_label} number/person time")
96		) %>%
97	4x	append_topleft(c("", lbl_summaryvars))
98		} else {
99	17x	lyt %>%
100	17x	append_topleft(c("", lbl_summaryvars))
101		}
102		}
103
104		#' @describeIn rmpt01 Preprocessing
105		#'
106		#' @inheritParams gen_args
107		#' @inheritParams rmpt01_main
108		#' @returns the preprocessing function returns a `list` of `data.frame`.
109		#' @export
110		#'
111		rmpt01_pre <- function(adam_db,
112		summaryvars = "AVALCAT1",
113		...) {
114	4x	adam_db$adex <- adam_db$adex %>%
115	4x	filter(.data$PARAMCD == "TDURD")
116	4x	adam_db$adex <- adam_db$adex %>%
117	4x	mutate(across(all_of(summaryvars), ~ reformat(.x, missing_rule))) %>%
118	4x	mutate(
119	4x	AVALCAT1 = with_label(.data$AVALCAT1, "Duration of exposure")
120		)
121	4x	adam_db
122		}
123
124		#' @describeIn rmpt01 Postprocessing
125		#'
126		#' @inheritParams gen_args
127		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
128		#' @export
129		#'
130		rmpt01_post <- function(tlg, prune_0 = FALSE, ...) {
131	6x	if (prune_0) {
132	!	tlg <- smart_prune(tlg)
133		}
134	6x	std_postprocessing(tlg)
135		}
136
137		#' `RMPT01`Duration of Exposure for Risk Management Plan Table.
138		#'
139		#' The `RMPT01` table provides an overview of duration of exposure.
140		#'
141		#' @include chevron_tlg-S4class.R
142		#' @export
143		#'
144		#' @examples
145		#' run(rmpt01, syn_data, col_split_var = "SEX")
146		rmpt01 <- chevron_t(
147		main = rmpt01_main,
148		preprocess = rmpt01_pre,
149		postprocess = rmpt01_post
150		)

1		# egt03 ----
2		#' @describeIn egt03 Main TLG function
3		#'
4		#' @param arm_var (`character`) the arm variables used for row split, typically `"ACTARMCD"`.
5		#' @param summaryvar (`character`) variables to be analyzed, typically `"BNRIND"`. Labels of the corresponding columns
6		#' are used as subtitles.
7		#' @param splitvar (`character`) variables to be analyzed, typically `"ANRIND"`. Labels of the corresponding columns are
8		#' used as subtitles.
9		#' @returns the main function returns an `rtables` object.
10		#'
11		#' @details
12		#' * `ADEG` data are subsetted to contain only "POST-BASELINE MINIMUM"/"POST-BASELINE MAXIMUM" visit
13		#' according to the preprocessing.
14		#' * Percentages are based on the total number of patients in a treatment group.
15		#' * Split columns by Analysis Reference Range Indicator, typically `ANRIND`.
16		#' * Does not include a total column by default.
17		#' * Sorted based on factor level.
18		#'
19		#' @note
20		#' * `adam_db` object must contain an `adeg` table with a `"ACTARMCD"` column as well as columns specified in
21		#' `summaryvar` and `splitvar`.
22		#'
23		#' @export
24		#'
25		egt03_main <- function(adam_db,
26		arm_var = "ACTARMCD",
27		summaryvar = "BNRIND",
28		splitvar = "ANRIND",
29		visitvar = "AVISIT",
30		page_var = "PARAMCD",
31		...) {
32	1x	assert_all_tablenames(adam_db, c("adsl", "adeg"))
33	1x	assert_string(arm_var)
34	1x	assert_string(summaryvar)
35	1x	assert_string(splitvar)
36	1x	assert_string(visitvar)
37	1x	assert_string(page_var, null.ok = TRUE)
38	1x	assert_subset(page_var, "PARAMCD")
39	1x	assert_valid_variable(adam_db$adeg, summaryvar, types = list("character", "factor"))
40	1x	assert_valid_variable(adam_db$adeg, c("PARAMCD", "PARAM", splitvar), types = list("character", "factor"))
41	1x	assert_single_value(adam_db$adeg[[visitvar]])
42	1x	assert_valid_var_pair(adam_db$adsl, adam_db$adeg, arm_var)
43	1x	assert_valid_variable(adam_db$adeg, "USUBJID", empty_ok = TRUE, types = list(c("character", "factor")))
44	1x	assert_valid_variable(adam_db$adsl, c("USUBJID", arm_var), types = list(c("character", "factor")))
45
46	1x	lbl_armvar <- var_labels_for(adam_db$adeg, arm_var)
47	1x	lbl_summaryvars <- var_labels_for(adam_db$adeg, summaryvar)
48	1x	lbl_splitvar <- var_labels_for(adam_db$adeg, splitvar)
49	1x	lbl_param <- var_labels_for(adam_db$adeg, "PARAM")
50
51	1x	lyt <- egt03_lyt(
52	1x	arm_var = arm_var,
53	1x	splitvar = splitvar,
54	1x	summaryvar = summaryvar,
55	1x	lbl_armvar = lbl_armvar,
56	1x	lbl_summaryvars = lbl_summaryvars,
57	1x	lbl_param = lbl_param,
58	1x	page_var = page_var
59		)
60	1x	adam_db$adeg$SPLIT_LABEL <- factor(rep(lbl_splitvar, nrow(adam_db$adeg)), levels = lbl_splitvar)
61
62	1x	tbl <- build_table(
63	1x	lyt,
64	1x	df = adam_db$adeg
65		)
66
67	1x	tbl
68		}
69
70		#' `egt03` Layout
71		#'
72		#' @inheritParams gen_args
73		#' @inheritParams egt03_main
74		#'
75		#' @param lbl_armvar (`string`) label of the `arm_var` variable.
76		#' @param lbl_summaryvars (`string`) label of the `summaryvar` variable.
77		#' @returns a `PreDataTableLayouts` object.
78		#'
79		#' @keywords internal
80		#'
81		egt03_lyt <- function(arm_var,
82		splitvar,
83		summaryvar,
84		lbl_armvar,
85		lbl_summaryvars,
86		lbl_param,
87		page_var) {
88	3x	page_by <- !is.null(page_var)
89	3x	indent <- 2L
90	3x	space <- stringr::str_dup(" ", indent * (1L + !page_by))
91	3x	lbl_summaryvars <- paste0(space, lbl_summaryvars)
92
93	3x	basic_table(show_colcounts = FALSE) %>%
94	3x	split_cols_by("SPLIT_LABEL") %>%
95	3x	split_cols_by(splitvar) %>%
96	3x	split_rows_by(
97	3x	"PARAMCD",
98	3x	labels_var = "PARAM",
99	3x	page_by = page_by,
100	3x	split_fun = drop_split_levels,
101	3x	split_label = lbl_param,
102	3x	label_pos = if (page_by) "hidden" else "topleft"
103		) %>%
104	3x	split_rows_by(arm_var,
105	3x	split_fun = drop_split_levels,
106	3x	label_pos = "topleft",
107	3x	split_label = lbl_armvar
108		) %>%
109	3x	add_rowcounts() %>%
110	3x	analyze_vars(
111	3x	summaryvar,
112	3x	denom = "N_row", .stats = "count_fraction",
113	3x	.formats = list(count_fraction = format_count_fraction_fixed_dp)
114		) %>%
115	3x	append_topleft(lbl_summaryvars)
116		}
117
118		#' @describeIn egt03 Preprocessing
119		#'
120		#' @inheritParams gen_args
121		#' @inheritParams egt03_main
122		#' @returns the preprocessing function returns a `list` of `data.frame`.
123		#'
124		#' @export
125		#'
126		egt03_pre <- function(adam_db, ...) {
127	1x	adam_db$adeg <- adam_db$adeg %>%
128	1x	filter(
129	1x	.data$AVISIT == "POST-BASELINE MINIMUM"
130		) %>%
131	1x	mutate(BNRIND = factor(
132	1x	.data$BNRIND,
133	1x	levels = c("LOW", "NORMAL", "HIGH", "Missing"),
134	1x	labels = c("LOW", "NORMAL", "HIGH", "Missing")
135		)) %>%
136	1x	mutate(ANRIND = factor(
137	1x	.data$ANRIND,
138	1x	levels = c("LOW", "NORMAL", "HIGH", "Missing"),
139	1x	labels = c("LOW", "NORMAL", "HIGH", "Missing")
140		)) %>%
141	1x	mutate(
142	1x	BNRIND = with_label(.data$BNRIND, "Baseline Reference Range Indicator"),
143	1x	ANRIND = with_label(.data$ANRIND, "Minimum Post-Baseline Assessment")
144		)
145
146	1x	adam_db
147		}
148
149		#' @describeIn egt03 Postprocessing
150		#'
151		#' @inheritParams gen_args
152		#' @returns the postprocessing function returns an `rtables` object or an `ElementaryTable` (null report).
153		#'
154		#' @export
155		#'
156		egt03_post <- function(tlg, prune_0 = FALSE, ...) {
157	!	if (prune_0) tlg <- smart_prune(tlg)
158
159	1x	std_postprocessing(tlg)
160		}
161
162		#' `EGT03` Shift Table of ECG Interval Data - Baseline versus Minimum or Maximum Post-Baseline.
163		#'
164		#' The `EGT03` Table entries provide the number of patients by baseline assessment and minimum or maximum post-baseline
165		#' assessment. Percentages are based on the total number of patients in a treatment group. Baseline is the patient's
166		#' last observation prior to initiation of study drug.
167		#'
168		#' @include chevron_tlg-S4class.R
169		#' @export
170		#'
171		#' @examples
172		#' library(dunlin)
173		#'
174		#' proc_data <- log_filter(syn_data, PARAMCD == "HR", "adeg")
175		#' run(egt03, proc_data)
176		egt03 <- chevron_t(
177		main = egt03_main,
178		preprocess = egt03_pre,
179		postprocess = egt03_post
180		)

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

1		# ael02_main ----
2
3		#' @describeIn ael02 Main TLG function
4		#'
5		#' @inheritParams gen_args
6		#' @returns the main function returns an `rlistings` or a `list` object.
7		#' @export
8		#'
9		ael02_main <- modify_default_args(std_listing,
10		dataset = "adae",
11		key_cols = c("ID", "ASR"),
12		disp_cols = c(
13		"AEDECOD", "TRTSDTM", "ASTDY", "ADURN", "AESER",
14		"ASEV", "AREL", "AEOUT", "AECONTRT", "AEACN"
15		),
16		split_into_pages_by_var = "ACTARM"
17		)
18
19		#' @describeIn ael02 Preprocessing
20		#'
21		#' @inheritParams ael02_main
22		#' @inheritParams gen_args
23		#' @returns the preprocessing function returns a `list` of `data.frame`.
24		#' @export
25		#'
26		ael02_pre <- function(adam_db,
27		dataset = "adae",
28		arm_var = "ACTARM",
29		...) {
30	1x	adam_db[[dataset]] <- adam_db[[dataset]] %>%
31	1x	filter(.data$ANL01FL == "Y") %>%
32	1x	mutate(
33	1x	across(
34	1x	all_of(c(arm_var, "AEDECOD", "ASEV", "AEOUT", "AEACN")),
35	1x	~ reformat(.x, missing_rule)
36		)
37		) %>%
38	1x	mutate(
39	1x	!!arm_var := with_label(.data[[arm_var]], "Treatment"),
40	1x	ID = create_id_listings(.data$SITEID, .data$SUBJID),
41	1x	ASR = with_label(paste(.data$AGE, .data$SEX, .data$RACE, sep = "/"), "Age/Sex/Race"),
42	1x	TRTSDTM = with_label(
43	1x	.data$TRTSDTM,
44	1x	"Date of\nFirst Study\nDrug\nAdministration"
45		),
46	1x	AEDECOD = with_label(reformat(.data$AEDECOD, nocoding), "Adverse\nEvent MedDRA\nPreferred Term"),
47	1x	ASTDY = with_label(.data$ASTDY, "Study\nDay of\nOnset"),
48	1x	ADURN = with_label(.data$ADURN, "AE\nDuration\nin Days"),
49	1x	AESER = with_label(reformat(.data$AESER, yes_no_rule), "Serious"),
50	1x	ASEV = with_label(.data$ASEV, "Most\nExtreme\nIntensity"),
51	1x	AREL = with_label(reformat(.data$AREL, yes_no_rule), "Caused by\nStudy\nDrug"),
52	1x	AEOUT = with_label(reformat(.data$AEOUT, outcome_rule), "Outcome\n(1)"),
53	1x	AECONTRT = with_label(reformat(.data$AECONTRT, yes_no_rule), "Treatment\nfor AE"),
54	1x	AEACN = with_label(reformat(.data$AEACN, dose_change_rule), "Action\nTaken\n(2)")
55		)
56
57	1x	adam_db
58		}
59
60		#' `AEL02` Listing 1 (Default) Listing of Adverse Events.
61		#'
62		#' @include chevron_tlg-S4class.R
63		#' @export
64		#'
65		#' @examples
66		#' res <- run(ael02, syn_data)
67		ael02 <- chevron_l(
68		main = ael02_main,
69		preprocess = ael02_pre
70		)

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