autoslider.core coverage - 86.95%

Files
Source

#' [EXPERIMENTAL] Create new output function based on a template.
#'
#' We have separate templates for listings, tables, and graphs.
#' There is also a template to set up the `run_all` script.
#'
#' @param template Must be one of `list_all_templates(package = "autoslider.core")`.
#' @param function_name Name of the output function you want to create. Defaults to "default".
#' @param save_path Path to save the function. Defaults to "./programs/R".
#' @param overwrite Whether to overwrite an existing file.
#' @param open Whether to open the file after creation.
#' @param package Which package to search for the template file. Defaults to "autoslider.core".
#'
#' @return No return value. Called for side effects (writes a file).
#'
#' @details Use `list_all_templates(package = "autoslider.core")` to discover which templates are available.
#'
#' @export
#'
#' @examples
#' if (interactive()) {
#'   use_template("t_dm_slide", function_name = "my_table", package = "autoslider.core")
#' }
use_template <- function(template = "t_dm_slide",
                         function_name = "default",
                         save_path = "./programs/R",
                         overwrite = FALSE,
                         open = interactive(),
                         package = "autoslider.core") {
  assert_that(assertthat::is.string(template))
  assert_that(assertthat::is.string(package))
  assert_that(assertthat::is.flag(overwrite))
  assert_that(assertthat::is.flag(open))
  assert_that(!is.null(save_path))
  # assert_that(template %in% list_all_templates(package) ||
  #               paste0(system.file("templates", package = package), "/", template) %in%
  #               list_all_templates(package))

  if (!dir.exists(save_path)) {
    dir.create(save_path, recursive = TRUE)
  }

  save_path <- file.path(save_path, paste0(function_name, ".R"))

  # Original validation logic for when save_path is provided
  assertthat::has_extension(save_path, ext = "R")
  assertthat::is.writeable(save_path %>% dirname())


  # Build expected full path
  expected_path <- file.path(system.file("templates", package = package), template)
  expected_core_path <- file.path(system.file("templates", package = "autoslider.core"), template)

  # Validation logic
  valid <- FALSE
  if (package == "autoslider.core") {
    valid <- expected_path %in% list_all_templates(package)
  } else if (package == "autoslideR") {
    valid <- (expected_path %in% list_all_templates(package)) || (expected_core_path %in% list_all_templates(package))
  }

  # Error if invalid
  if (!valid) {
    err_msg <- sprintf(
      "Template '%s' not found in package '%s'. Use list_all_templates('%s') to see available templates.",
      template, package, package
    )
    abort(err_msg)
  }


  if (file.exists(save_path) && !overwrite) {
    err_msg <- paste(
      sprintf("A file named '%s' already exists.", save_path),
      "\u2139 Set `overwrite = TRUE` to force overwriting it.",
      sep = "\n"
    )
    abort(err_msg)
  }

  if (package == "autoslider.core") {
    file_list <- get_template_filepath(package = package, full.names = TRUE)
  } else if (package == "autoslideR") {
    file_list <- c(
      get_template_filepath(package = "autoslideR", full.names = TRUE),
      get_template_filepath(package = "autoslider.core", full.names = TRUE)
    )
  }

  template_file <- file_list[basename(file_list) == paste0(template, ".R")]


  if (file.copy(template_file, save_path, overwrite = TRUE)) {
    rlang::inform(sprintf("\u2713 File '%s' has been created successfully", save_path))
    file_lines <- readLines(save_path)

    file_lines <- file_lines[!grepl("^#'", file_lines)]
    file_lines <- file_lines[nzchar(file_lines)]

    # Replace function name with numbering
    file_lines <- gsub(tolower(template), function_name, file_lines)
    writeLines(file_lines, save_path)
  }

  if (open) {
    file.edit(save_path)
  }

  invisible(TRUE)
}

#' [EXPERIMENTAL] List All Available Templates
#'
#' @param package Which package to search for the template files. Defaults to "autoslider.core".
#'
#' @return A character vector of available template names in the specified package.
#'
#' @export
#'
#' @examples
#' list_all_templates(package = "autoslider.core")
list_all_templates <- function(package = "autoslider.core") {
  if (package == "autoslideR") {
    c(
      get_template_filepath(package = "autoslideR", full.names = TRUE),
      get_template_filepath(package = "autoslider.core", full.names = TRUE)
    ) |>
      stringr::str_remove("\\.R$") |>
      structure(package = package)
  } else if (package == "autoslider.core") {
    get_template_filepath(package = package, full.names = TRUE) |>
      stringr::str_remove("\\.R$") |>
      structure(package = package)
  }
}


#' Retrieve Template File Paths
#'
#' @param package A character string specifying the name of the package to search.
#' @param full.names If `TRUE`, returns the full path to each file.
#'                   If `FALSE`, returns only the file names.
#'
#' @return A character vector of template file names or paths, depending on `full.names`.
#'
#' @export
#'
#' @keywords internal
get_template_filepath <- function(package = "autoslider.core", full.names = FALSE) {
  # Installed-package path
  template_dir <- system.file("templates", package = package)

  pattern <- "^(t_|l_|g_)"
  if (full.names == TRUE) {
    pattern <- paste0(paste0(template_dir, "/"), c("t_", "g_", "l_"),
      collapse = "|"
    )
  }

  list.files(template_dir, pattern = "\\.R$", full.names = full.names) |>
    stringr::str_subset(pattern)
}

#' Read yaml spec file
#'
#' Read yaml spec file and split according to filter lists
#'
#' @param spec_file `character`. Path to a yaml spec file
#' @param metadata Metadata of study
#'
#' @return
#' An object of class `spec` which is a `list` where each element corresponds
#' to one output, e.g. `t_dm_IT`.
#'
#' @author
#' - Liming Li (`Lil128`)
#' - Thomas Neitmann (`neitmant`)
#' - Joe Zhu
#'
#' @export
#'
#' @examples
#' spec_file <- system.file("spec.yml", package = "autoslider.core")
#'
#' ## Take a look at the 'raw' content of the spec file
#' cat(readLines(spec_file)[1:24], sep = "\n")
#'
#' ## This is how it looks once read into R
#' spec <- read_spec(spec_file)
#' spec[1:3]
#'
read_spec <- function(spec_file = "spec.yml",
                      metadata = NULL) {
  spec <- yaml::read_yaml(spec_file, eval.expr = TRUE)
  ret <- lapply(spec, function(s) {
    lapply(s$suffix, function(su) {
      ret <- s
      ret$suffix <- su
      c(ret, metadata)
    })
  })
  spec_obj <- unlist(ret, recursive = FALSE)
  as_spec(spec_obj)
}

#' validate spec file
#' @description not implemented yet
#' @param spec specification
#' @noRd
validate_spec <- function(spec) {
  message <- NULL
  if (is.null(spec$dataset)) {
    message <- c(message, "Spec must not assign dataset argument!")
  }
  if (is.null(spec$func)) {
    message <- c(message, "Spec must include func argument!")
  }
  if (is.null(spec$outpath)) {
    message <- c(message, "Spec must include outpath argument!")
  }
}

#' Filter a spec object
#'
#' @param spec A `spec` object as returned by `read_spec()`
#' @param filter_expr A `logical` expression indicating outputs to keep
#' @param verbose Should a message about the number of outputs matching
#'        `filter_spec` be printed? Defaults to `TRUE`.
#'
#' @return
#' A `spec` object containing only the outputs matching `filter_expr`
#'
#' @author Thomas Neitmann (`neitmant`)
#'
#' @export
#'
#' @examples
#' library(dplyr)
#' spec_file <- system.file("spec.yml", package = "autoslider.core")
#' spec <- spec_file %>% read_spec()
#'
#' ## Keep only the t_dm_IT output
#' filter_spec(spec, output == "t_dm_IT")
#'
#' ## Same as above but more verbose
#' filter_spec(spec, program == "t_dm" && suffix == "IT")
#'
#' ## Keep all t_ae outputs
#' filter_spec(spec, program == "t_ae")
#'
#' ## Keep all output run on safety population
#' filter_spec(spec, "SE" %in% suffix)
#'
#' ## Keep t_dm_CHN_IT and t_dm_CHN_SE
#' filter_spec(spec, program == "t_dm" && suffix %in% c("CHN_IT", "CHN_SE"))
#'
#' ## Keep all tables
#' filter_spec(spec, grepl("^t_", program))
#'
filter_spec <- function(spec, filter_expr, verbose = TRUE) {
  if (is.character(substitute(filter_expr))) {
    warn_about_legacy_filtering(filter_expr)
    condition <- bquote(output == .(filter_expr))
  } else {
    condition <- substitute(filter_expr)
  }
  stopifnot(is_spec(spec), is.language(condition), is.logical(verbose))
  vars <- all.vars(condition)

  filtered_spec <- Filter(function(output) {
    assert_exists_in_spec_or_calling_env(vars, output)
    p <- eval(condition, envir = output)
    assert_is_valid_filter_result(p)
    p
  }, spec)

  if (verbose) {
    log_number_of_matched_records(spec, filtered_spec, condition)
  }

  as_spec(filtered_spec)
}

is_spec <- function(x) {
  "spec" %in% class(x)
}

as_spec <- function(x) {
  spec <- lapply(x, function(elem) {
    if (is.null(elem$suffix)) {
      elem$suffix <- ""
    }

    if (elem$suffix == "") {
      elem$output <- elem$program
    } else {
      elem$output <- paste(elem$program, elem$suffix, sep = "_")
    }

    if (is.null(elem$paper)) {
      elem$paper <- default_paper_size(elem$program)
    } else if (elem$paper == "a4r") {
      warn_about_legacy_paper_size("a4r", "L11")
      elem$paper <- "L11"
    } else if (elem$paper == "a4") {
      warn_about_legacy_paper_size("a4", "P11")
      elem$paper <- "P11"
    } else {
      validate_paper_size(elem$paper)
    }

    elem
  })

  structure(
    .Data = spec,
    names = map_chr(spec, `[[`, "output"),
    class = union("spec", class(x))
  )
}

#' Adverse event summary table
#'
#' @param adsl ADSL dataset, dataframe
#' @param adae ADAE dataset, dataframe
#' @param arm Arm variable, character, "`TRT01A" by default.
#' @param dose_adjust_flags Character or a vector of characters. Each character is a variable
#'  name in adae dataset. These variables are Logical vectors which flag AEs
#'  leading to dose adjustment, such as drug discontinuation, dose interruption
#'  and reduction. The flag can be related to any drug, or a specific drug.
#' @param dose_adjust_labels Character or a vector of characters. Each character represents
#'  a label displayed in the AE summary table (e.g. AE leading to discontinuation
#'  from drug X). The order of the labels should match the order of variable
#'  names in \code{dose_adjust_flags}.
#' @param gr34_highest_grade_only A logical value. Default is TRUE, such that
#'  only patients with the highest AE grade as 3 or 4 are included for the count of the "Grade 3-4 AE" and
#'  "Treatment-related Grade 3-4 AE" ; set it to FALSE if
#'  you want to include patients with the highest AE grade as 5.
#'
#' @return an rtables object
#' @export
#'
#' @examples
#' library(dplyr)
#' ADSL <- eg_adsl
#' ADAE <- eg_adae
#'
#' ADAE <- ADAE %>%
#'   dplyr::mutate(ATOXGR = AETOXGR)
#' t_ae_summ_slide(adsl = ADSL, adae = ADAE)
#'
#' # add flag for ae leading to dose reduction
#' ADAE$reduce_flg <- ifelse(ADAE$AEACN == "DOSE REDUCED", TRUE, FALSE)
#' t_ae_summ_slide(
#'   adsl = ADSL, adae = ADAE,
#'   dose_adjust_flags = c("reduce_flg"),
#'   dose_adjust_labels = c("AE leading to dose reduction of drug X")
#' )
#' # add flgs for ae leading to dose reduction, drug withdraw and drug interruption
#' ADAE$withdraw_flg <- ifelse(ADAE$AEACN == "DRUG WITHDRAWN", TRUE, FALSE)
#' ADAE$interrup_flg <- ifelse(ADAE$AEACN == "DRUG INTERRUPTED", TRUE, FALSE)
#' out <- t_ae_summ_slide(
#'   adsl = ADSL, adae = ADAE, arm = "TRT01A",
#'   dose_adjust_flags = c("withdraw_flg", "reduce_flg", "interrup_flg"),
#'   dose_adjust_labels = c(
#'     "AE leading to discontinuation from drug X",
#'     "AE leading to drug X reduction",
#'     "AE leading to drug X interruption"
#'   )
#' )
#' print(out)
#' generate_slides(out, paste0(tempdir(), "/ae_summary.pptx"))
t_ae_summ_slide <- function(adsl, adae, arm = "TRT01A",
                            dose_adjust_flags = NA,
                            dose_adjust_labels = NA,
                            gr34_highest_grade_only = TRUE) {
  # The gr3-4 only count the patients whose highest ae grade is 3 or 4
  assert_that(has_name(adae, "TRT01A"))
  assert_that(has_name(adae, "AEDECOD"))
  assert_that(has_name(adae, "AEBODSYS"))
  assert_that(has_name(adae, "ATOXGR"))
  assert_that(has_name(adae, "AEREL"))
  assert_that(has_name(adae, "ANL01FL"))
  assert_that(has_name(adae, "SAFFL"))
  assert_that(has_name(adae, "TRTEMFL"))
  assert_that(has_name(adae, "AESER"))
  assert_that(length(dose_adjust_flags) == length(dose_adjust_labels))
  assert_that(assertthat::is.flag(gr34_highest_grade_only))


  if (sum(is.na(dose_adjust_flags)) == 0 & sum(is.na(dose_adjust_labels)) == 0) {
    for (txt in dose_adjust_flags) {
      assert_that(all(unlist(adae[txt]) %in% c(TRUE, FALSE)))
      assert_that(has_name(adae, txt))
    }
  }

  adsl1 <- adsl %>%
    select("STUDYID", "USUBJID", "TRT01A")

  pts_gr5 <- adae %>% filter(ATOXGR %in% c(5))

  anl <- adae %>%
    mutate_at(
      c("AEDECOD", "AEBODSYS"),
      ~ explicit_na(sas_na(.)) # Replace blank arm with <Missing>
    ) %>%
    mutate(
      ATOXGR = sas_na(ATOXGR) %>% as.factor(),
      ATOXGR2 = case_when(
        ATOXGR %in% c(1, 2) ~ "1 - 2",
        ATOXGR %in% c(3, 4) ~ "3 - 4",
        ATOXGR %in% c(5) ~ "5",
      ) %>% as.factor(),
      TRT01A = sas_na(TRT01A) %>% as.factor()
    ) %>%
    semi_join(., adsl1, by = c("STUDYID", "USUBJID")) %>%
    filter(ANL01FL == "Y" & TRTEMFL == "Y" & SAFFL == "Y") %>%
    formatters::var_relabel(
      ATOXGR2 = "AE Grade 3 groups",
      ATOXGR = "AE Grade",
      TRT01A = "Actual Treatment 01"
    ) %>%
    # ---------- ADAE: Treatment related flags ---------
    mutate(
      TMPFL1_REL0 = AEREL == "Y"
    ) %>%
    formatters::var_relabel(
      TMPFL1_REL0 = "Any treatment"
    ) %>%
    # ---------- ADAE: Grade 5 and related flags ---------
    mutate(
      TMPFL1_G5 = ATOXGR %in% c(5),
      TMPFL1_G5_REL = ATOXGR %in% c(5) & AEREL == "Y"
    ) %>%
    formatters::var_relabel(
      TMPFL1_G5 = "Grade 5 AE",
      TMPFL1_G5_REL = "Treatment-related Grade 5 AE"
    ) %>%
    # ---------- ADAE: SAE and related flags ---------
    mutate(
      TMPFL1_SER = AESER == "Y",
      TMPFL1_SER_REL = AESER == "Y" & AEREL == "Y"
    ) %>%
    formatters::var_relabel(
      TMPFL1_SER = "Serious AE",
      TMPFL1_SER_REL = "Treatment-related Serious AE"
    )

  # ---------- ADAE: Grade 3/4 and related flags ---------
  if (gr34_highest_grade_only == TRUE) {
    anl <- anl %>%
      mutate(
        TMPFL1_G34 = ATOXGR %in% c(3, 4) & !(USUBJID %in% pts_gr5$USUBJID), # Only count the highest grade is 3 or 4
        TMPFL1_G34_REL = ATOXGR %in% c(3, 4) & AEREL == "Y" & !(USUBJID %in% pts_gr5$USUBJID)
      ) %>%
      formatters::var_relabel(
        TMPFL1_G34 = "Grade 3-4 AE",
        TMPFL1_G34_REL = "Treatment-related Grade 3-4 AE"
      )
  } else {
    anl <- anl %>%
      mutate(
        TMPFL1_G34 = ATOXGR %in% c(3, 4),
        TMPFL1_G34_REL = ATOXGR %in% c(3, 4) & AEREL == "Y"
      ) %>%
      formatters::var_relabel(
        TMPFL1_G34 = "Grade 3-4 AE",
        TMPFL1_G34_REL = "Treatment-related Grade 3-4 AE"
      )
  }

  if (nrow(anl) == 0) {
    return(null_report())
  } else {
    lyt <- basic_table() %>%
      split_cols_by(arm, split_fun = add_overall_level("All Patients", first = FALSE)) %>%
      add_colcounts() %>%
      count_patients_with_event(
        vars = "USUBJID",
        filters = c("SAFFL" = "Y"),
        denom = "N_col",
        .stats = "count_fraction",
        .labels = c(count_fraction = "All grade AEs, any cause"),
        table_names = "U",
        # .formats = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_REL0 = "Related"),
        denom = "N_col",
        .indent_mods = 1L,
        var_labels = "TMPFL1 Related"
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_G34 = "Grade 3-4 AEs"),
        denom = "N_col",
        .indent_mods = 0L,
        var_labels = "Grade 3-4 AEs"
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_G34_REL = "Related"),
        denom = "N_col",
        .indent_mods = 1L,
        var_labels = "TMPFL1_G34 Related"
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_G5 = "Grade 5 AE"),
        denom = "N_col",
        .indent_mods = 0L,
        var_labels = "Grade 5 AE"
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_G5_REL = "Related"),
        denom = "N_col",
        .indent_mods = 1L,
        var_labels = "TMPFL1_G5 Related"
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_SER = "SAEs"),
        denom = "N_col",
        .indent_mods = 0L,
        var_labels = "SAEs"
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_SER_REL = "Related"),
        denom = "N_col",
        .indent_mods = 1L,
        var_labels = "TMPFL1_SEA Related"
        # .format = list(trim_perc1)
      )

    if (sum(is.na(dose_adjust_flags)) == 0 & sum(is.na(dose_adjust_labels)) == 0) {
      for (i in 1:length(dose_adjust_flags)) {
        text <- paste0(
          '     lyt <- lyt %>%
       count_patients_with_flags(
         "USUBJID",
         flag_variables = c(', dose_adjust_flags[i], "='", dose_adjust_labels[i],
          "'),
          denom = 'N_col',
          var_labels = paste('dose adjust',i),
         .indent_mods = 0L)"
        )
        eval(parse(text = text))
      }
    }

    result <- build_table(
      lyt,
      df = anl,
      alt_counts_df = adsl
    )
    result@main_title <- "AE summary table"
  }

  return(result)
}

#' Discontinue table
#' @param adsl ADSL data
#' @param arm Arm variable, character, "`TRT01P" by default.
#' @param split_by_study Split by study, building structured header for tables
#' @param side_by_side "GlobalAsia" or "GlobalAsiaChina" to define the side by side requirement
#' @inherit gen_notes note
#' @export
#' @examples
#' library(dplyr)
#' adsl <- eg_adsl %>%
#'   mutate(DISTRTFL = sample(c("Y", "N"), size = nrow(eg_adsl), replace = TRUE, prob = c(.1, .9))) %>%
#'   preprocess_t_ds()
#' out1 <- t_ds_slide(adsl, "TRT01P")
#' print(out1)
#' generate_slides(out1, paste0(tempdir(), "/ds.pptx"))
#'
#' out2 <- t_ds_slide(adsl, "TRT01P", split_by_study = TRUE)
#' print(out2)
#'
t_ds_slide <- function(adsl, arm = "TRT01P",
                       split_by_study = FALSE,
                       side_by_side = NULL) {
  assert_that(has_name(adsl, arm))
  assert_that(has_name(adsl, "SAFFL"))
  assert_that(has_name(adsl, "STDONS"),
    msg = "`STDONS` variable is needed for this output, please use `preprocess_t_ds` function to derive."
  )
  assert_that(has_name(adsl, "DCSREAS"))
  assert_that(length(levels(adsl$STDONS)) <= 3)

  adsl1 <- adsl %>%
    mutate(
      STDONS = factor(explicit_na(sas_na(STDONS)),
        levels = c("Alive: On Treatment", "Alive: In Follow-up", "<Missing>"),
        labels = c("On Treatment", "In Follow-up", "<Missing>")
      ),
      DCSREAS = str_to_title(factor(sas_na(DCSREAS))),
      DCSflag = ifelse(is.na(DCSREAS), "N", "Y"),
      STDONSflag = ifelse(STDONS == "<Missing>", "N", "Y")
    ) %>%
    mutate_at(c("STDONS", "DCSREAS"), ~ as.factor(explicit_na(.))) %>%
    formatters::var_relabel(
      STDONS = "On-study Status",
      DCSflag = "Discontinued the study"
    )

  if (!is.null(side_by_side)) {
    adsl1$lvl <- "Global"
  }

  lyt <- build_table_header(adsl1, arm, split_by_study = split_by_study, side_by_side = side_by_side)

  lyt <- lyt %>%
    count_values("SAFFL",
      values = "Y",
      .labels = c(count_fraction = "Received Treatment")
    ) %>%
    split_rows_by(
      "STDONSflag",
      split_fun = keep_split_levels("Y"),
    ) %>%
    summarize_row_groups(label_fstr = "On-study Status") %>%
    analyze_vars(
      "STDONS",
      .stats = "count_fraction",
      denom = "N_col",
      na.rm = TRUE,
      # var_labels =  formatters::var_labels(adsl1)["STDONS"]
    ) %>%
    split_rows_by(
      "DCSflag",
      split_fun = keep_split_levels("Y"),
    ) %>%
    summarize_row_groups(label_fstr = "Discontinued the study") %>%
    analyze_vars(
      "DCSREAS",
      .stats = "count_fraction",
      denom = "N_col"
    )

  result <- lyt_to_side_by_side(lyt, adsl1, side_by_side)
  result@main_title <- "Discontinue table"
  return(result)
}

#' s3 method for to_flextable
#' @param x object to to_flextable
#' @param ... additional arguments passed to methods
to_flextable <- function(x, ...) {
  UseMethod("to_flextable")
}


#' default method to to_flextable
#' @param x object to to_flextable
#' @param ... additional arguments. not used.
#'
#' @export
to_flextable.default <- function(x, ...) {
  stop("default to_flextable function does not exist")
}


#' To flextable
#'
#' @details convert the dataframe object into flextable, and merge the cells
#' that have colspan > 1. align the columns to the middle, and the row.names to
#' the left. indent the row.names by 10 times indention. titles are added in headerlines,
#' footnotes are added in footer lines,
#' The width of the columns are aligned based on autofit() of officer function.
#' For paginated table, the width of the 1st column are set as the widest 1st column among paginated tables
#' @param x Decorated dataframe with title and footnote as attributes
#' @param lpp \{lpp\} from \{paginate_table\}. numeric. Maximum lines per page
#' @param ... arguments passed to program
#'
#' @export
#'
to_flextable.Ddataframe <- function(x, lpp, ...) {
  # paginate VTableTree
  Ddf <- x
  df <- Ddf@df

  page_max <- ceiling(nrow(df) / lpp)
  pag_df <- split(df, rep(1:page_max, each = lpp))

  ft_list <- lapply(1:length(pag_df), function(x) {
    ft <- to_flextable(pag_df[[x]], ...)
    list(
      ft = ft,
      header = ifelse(x == 1, Ddf@titles, paste(Ddf@titles, "(cont.)")),
      footnotes = Ddf@footnotes
    )
  })

  # force the width of the 1st column to be the widest of all paginated table
  ft_list_resize <- set_width_widest(ft_list)
  class(ft_list_resize) <- "dflextable"

  ft_list_resize
}

#' To flextable
#'
#' Convert the dataframe into flextable, and merge the cells
#' that have colspan > 1. align the columns to the middle, and the row.names to
#' the left. indent the row.names by 10 times indention.
#'
#' @param x dataframe
#' @param lpp \{lpp\} from \{paginate_table\}. numeric. Maximum lines per page
#' @param table_format Table format
#' @export
to_flextable.Ddataframe <- function(x, lpp, table_format = table_format, ...) {
  df <- x
  if (all(is.na(formatters::var_labels(df)))) {
    formatters::var_labels(df) <- names(df)
  }
  ft <- flextable(df)
  ft <- set_header_labels(ft, values = as.list(formatters::var_labels(df)))

  # if(!is.null(apply_theme)){
  #   ft <- ft %>%
  #     apply_theme()
  # }

  ft <- ft %>%
    align_text_col(align = "center", header = TRUE) %>%
    align(i = seq_len(nrow(df)), j = 1, align = "left") %>% # row names align to left
    border(border = fp_border(color = border_color, width = 1), part = "all") %>%
    padding(padding.top = 3, padding.bottom = 3, part = "all") %>%
    autofit(add_h = 0) %>%
    table_format()

  ft <- ft %>%
    width(width = c(
      dim(ft)$widths[1],
      dim(ft)$widths[-1] - dim(ft)$widths[-1] + sum(dim(ft)$widths[-1]) / (ncol(df) - 1)
    )) # even the non-label column width

  if (flextable_dim(ft)$widths > 10) {
    pgwidth <- 10.5
    ft <- ft %>%
      width(width = dim(ft)$widths * pgwidth / flextable_dim(ft)$widths)
    # adjust width of each column as percentage of total width
  }

  return(ft)
}

#' convert gtsummary to flextable
#' @export
to_flextable.gtsummary <- function(x, ...) {
  ft <- x %>%
    gtsummary::as_flex_table()

  ft
}

#' convert dgtsummary to flextable
#' @export
to_flextable.dgtsummary <- function(x, ...) {
  ft <- x %>%
    gtsummary::as_flex_table()
}




#' convert data.frame to flextable
#' @export
to_flextable.data.frame <- function(x, col_width = NULL, table_format = orange_format,
                                    dose_template = FALSE, font_size = 9, ...) {
  df <- x
  ft <- do_call(flextable, data = df, ...)

  if (dose_template) {
    ft <- ft %>%
      autofit() %>%
      fit_to_width(10)
  } else {
    if (all(is.na(formatters::var_labels(df)))) {
      formatters::var_labels(df) <- names(df)
    }

    ft <- set_header_labels(ft, values = as.list(formatters::var_labels(df)))
    ft <- ft %>% width(width = col_width)
    if (flextable_dim(ft)$widths > 10) {
      pgwidth <- 10.5
      ft <- ft %>%
        width(width = dim(ft)$widths * pgwidth / flextable_dim(ft)$widths)
      # adjust width of each column as percentage of total width
    }
  }

  ft <- ft %>%
    table_format(...) %>%
    fontsize(size = font_size, part = "all")

  return(ft)
}


old_paginate_listing <- function(lsting,
                                 page_type = "letter",
                                 font_family = "Courier",
                                 font_size = 8,
                                 lineheight = 1,
                                 landscape = FALSE,
                                 pg_width = NULL,
                                 pg_height = NULL,
                                 margins = c(top = .5, bottom = .5, left = .75, right = .75),
                                 lpp = NA_integer_,
                                 cpp = NA_integer_,
                                 colwidths = formatters::propose_column_widths(lsting),
                                 tf_wrap = !is.null(max_width),
                                 max_width = NULL,
                                 verbose = FALSE) {
  checkmate::assert_class(lsting, "listing_df")
  checkmate::assert_numeric(colwidths, lower = 0, len = length(listing_dispcols(lsting)), null.ok = TRUE)
  checkmate::assert_flag(tf_wrap)
  checkmate::assert_count(max_width, null.ok = TRUE)
  checkmate::assert_flag(verbose)

  indx <- formatters::paginate_indices(lsting,
    page_type = page_type,
    font_family = font_family,
    font_size = font_size,
    lineheight = lineheight,
    landscape = landscape,
    pg_width = pg_width,
    pg_height = pg_height,
    margins = margins,
    lpp = lpp,
    cpp = cpp,
    colwidths = colwidths,
    tf_wrap = tf_wrap,
    max_width = max_width,
    rep_cols = length(get_keycols(lsting)),
    verbose = verbose
  )

  vert_pags <- lapply(
    indx$pag_row_indices,
    function(ii) lsting[ii, ]
  )
  dispnames <- listing_dispcols(lsting)
  full_pag <- lapply(
    vert_pags,
    function(onepag) {
      if (!is.null(indx$pag_col_indices)) {
        lapply(
          indx$pag_col_indices,
          function(jj) {
            res <- onepag[, dispnames[jj], drop = FALSE]
            listing_dispcols(res) <- intersect(dispnames, names(res))
            res
          }
        )
      } else {
        list(onepag)
      }
    }
  )

  ret <- unlist(full_pag, recursive = FALSE)
  ret
}


#' convert listing to flextable
#' @export
to_flextable.dlisting <- function(x, cpp, lpp, ...) {
  ddf <- x
  df <- ddf@lst
  col_width <- ddf@width
  pag_df <- old_paginate_listing(df, cpp = cpp, lpp = lpp)
  ft_list <- lapply(1:length(pag_df), function(x) {
    ft <- to_flextable(pag_df[[x]], col_width = col_width, ...)
    if (length(prov_footer(df)) == 0) {
      cat_foot <- main_footer(df)
    } else {
      cat_foot <- paste0(prov_footer(df), "\n", main_footer(df))
    }

    if (length(cat_foot) == 0) {
      cat_foot <- ""
    }
    list(
      ft = ft,
      header = ifelse(x == 1, main_title(df), paste(main_title(df), "(cont.)")),
      footnotes = cat_foot
    )
  })
  # force the width of the 1st column to be the widest of all paginated table
  # ft_list_resize <- set_width_widest(ft_list)
  class(ft_list) <- "dflextable"

  ft_list
}



#' Covert rtables object to flextable
#'
#' @param x rtable(VTableTree) object
#' @param table_format a function that decorate a flextable and return a flextable
#' @export
to_flextable.VTableTree <- function(x, table_format = orange_format, ...) {
  tbl <- x
  mf <- formatters::matrix_form(tbl, indent_rownames = TRUE)
  nr_header <- attr(mf, "nrow_header")
  non_total_coln <- c(TRUE, !grepl("All Patients", names(tbl)))
  df <- as.data.frame(mf$strings[(nr_header + 1):(nrow(mf$strings)), , drop = FALSE])

  header_df <- as.data.frame(mf$strings[1:(nr_header), , drop = FALSE])

  # if(concat_header){
  #   header_df <- lapply(header_df, function(x) {paste0(x, collapse = "\n")}) %>% as.data.frame
  # }

  # if(!total_col){
  #   df <- df[non_total_coln]
  #   header_df <- header_df[non_total_coln]
  # }
  ft <- do_call(flextable, data = df, ...)
  ft <- ft %>%
    delete_part(part = "header") %>%
    add_header(values = header_df)

  # if(!is.null(apply_theme)){
  #   ft <- ft %>%
  #     apply_theme()
  # }

  ft <- do_call(table_format, ft = ft, ...)
  ft <- ft %>%
    merge_at_indice(lst = get_merge_index(mf$spans[(nr_header + 1):nrow(mf$spans), , drop = FALSE]), part = "body") %>%
    merge_at_indice(lst = get_merge_index(mf$spans[1:nr_header, , drop = FALSE]), part = "header") %>%
    align_text_col(align = "center", header = TRUE) %>%
    align(i = seq_len(nrow(tbl)), j = 1, align = "left") %>% # row names align to left
    padding_lst(mf$row_info$indent) %>%
    padding(padding.top = 3, padding.bottom = 3, part = "all") %>%
    autofit(add_h = 0)


  ft <- ft %>%
    width(width = c(
      dim(ft)$widths[1],
      dim(ft)$widths[-1] - dim(ft)$widths[-1] + sum(dim(ft)$widths[-1]) / (ncol(mf$strings) - 1)
    )) # even the non-label column width

  if (flextable_dim(ft)$widths > 10) {
    pgwidth <- 10.5
    ft <- ft %>%
      width(width = dim(ft)$widths * pgwidth / flextable_dim(ft)$widths)
    # adjust width of each column as percentage of total width
  }

  return(ft)
}


#' To flextable
#'
#' @param x decorated rtable(dVTableTree) object
#' @param lpp \{lpp\} from \link[rtables]{paginate_table}. numeric. Maximum lines per page
#' @param ... argument parameters
#' @details convert the VTableTree object into flextable, and merge the cells
#' that have colspan > 1. align the columns to the middle, and the row.names to
#' the left. indent the row.names by 10 times indention. titles are added in headerlines,
#' footnotes are added in footer lines,
#' The width of the columns are aligned based on autofit() of officer function.
#' For paginated table, the width of the 1st column are set as the widest 1st column among paginated tables
to_flextable.dVTableTree <- function(x, lpp, cpp, ...) {
  dtbl <- x
  # paginate VTableTree
  pag_tbl <- paginate_table(dtbl@tbl, lpp = lpp, cpp = cpp)
  ft_list <- lapply(1:length(pag_tbl), function(x) {
    ft <- to_flextable(pag_tbl[[x]], ...)
    if (length(dtbl@tbl@provenance_footer) == 0) {
      cat_foot <- dtbl@footnotes
    } else {
      cat_foot <- paste0(dtbl@tbl@provenance_footer, "\n", dtbl@footnotes)
    }

    list(
      ft = ft,
      header = ifelse(x == 1, dtbl@titles, paste(dtbl@titles, "(cont.)")),
      footnotes = cat_foot
    )
  })
  # force the width of the 1st column to be the widest of all paginated table
  ft_list_resize <- set_width_widest(ft_list)
  class(ft_list_resize) <- "dflextable"

  ft_list_resize
}

g_export <- function(decorated_p) {
  ret <- list()

  ret$dml <- rvg::dml(
    ggobj = ggpubr::as_ggplot(decorated_p$grob),
    bg = "white",
    pointsize = 12,
    editable = TRUE
  )
  ret$footnote <- decorated_p$footnotes
  ret$spec <- attributes(decorated_p)$spec

  ret
}

set_width_widest <- function(ft_list) {
  width1st <- max(unlist(lapply(ft_list, function(x) {
    x$ft$body$colwidths[1]
  })))
  for (i in 1:length(ft_list)) {
    ft_list[[i]]$ft <- width(ft_list[[i]]$ft, 1, width = width1st)
  }

  ft_list
}

get_merge_index_single <- function(span) {
  ret <- list()
  j <- 1
  while (j < length(span)) {
    if (span[j] != 1) {
      ret <- c(ret, list(j:(j + span[j] - 1)))
    }
    j <- j + span[j]
  }

  ret
}

get_merge_index <- function(spans) {
  ret <- lapply(seq_len(nrow(spans)), function(i) {
    ri <- spans[i, ]
    r <- get_merge_index_single(ri)
    lapply(r, function(s) {
      list(j = s, i = i)
    })
  })
  unlist(ret, recursive = FALSE, use.names = FALSE)
}

merge_at_indice <- function(ft, lst, part) {
  Reduce(function(ft, ij) {
    merge_at(ft, i = ij$i, j = ij$j, part = part)
  }, lst, ft)
}

padding_lst <- function(ft, indents) {
  Reduce(function(ft, s) {
    padding(ft, s, 1, padding.left = (indents[s] + 1) * 10)
  }, seq_len(length(indents)), ft)
}

format_xx <- function(str) {
  tern::format_xx(str)
}

#' Assert function to check the cutoff
#'
#' @param data dataframe
#' @param cutoff cutoff threshold
#' @return Set the cutoff value
#' @export
check_and_set_cutoff <- function(data, cutoff) {
  if (is.na(cutoff)) {
    cutoff <- 0
  } else { # check cutoff is the same with the filter
    suffix <- attr(data, "filters")
    cutoff_suffix <- str_extract(string = paste(suffix, collapse = "_"), pattern = "(\\d+)(?=PER)") %>%
      as.numeric()
    if (!is.na(cutoff_suffix)) {
      assert_that(are_equal(cutoff, cutoff_suffix))
    }
  }

  cutoff
}

#' Replace NAs to NA
#'
#' @param table_df Table dataframe
#' @return Input dataframe with both column replaced to NA
#' @export
na_replace <- function(table_df) {
  if (length(colnames(table_df)) == 2) {
    col1_na <- which(is.na(table_df[1]))
    if (length(col1_na) > 0) {
      for (i in 1:length(col1_na)) {
        table_df[col1_na[i], 1] <- table_df[col1_na[i], 2]
        table_df[col1_na[i], 2] <- NA
      }
    }
  }

  table_df
}

#' Concatenate arguments into a string
#'
#' @param ... arguments passed to program
#' @return No return value, called for side effects
#' @export
dec_paste <- function(...) {
  arguments <- list(
    ...
  )

  if (!any(is.na(arguments))) {
    do.call("paste", arguments)
  }
}

#' Convert list of numbers to vectors
#'
#' @param num_list list of numbers
#' @return No return value, called for side effects
#' @export
to_vector <- function(num_list) {
  sapply(num_list, function(x) {
    y <- unlist(x)
    if (is.null(y)) {
      y <- NA
    }
    y
  })
}

#' Founding method
#' @param x number need to be rounded
#' @param digits number of digits
#' @return rounded value
#' @export
new_round <- function(x, digits = 1) {
  posneg <- sign(x)
  z <- abs(x) * 10^digits
  z <- z + 0.5 + sqrt(.Machine$double.eps)
  z <- trunc(z)
  z <- z / 10^digits
  z * posneg
}

#' Format of xx.xx (xx.xx)
#'
#' @param x input array
#' @param output output handle
#' @return formatted values
#' @export
trim_perc1 <- function(x, output) {
  paste0(x[1], " (", new_round(x[2] * 100, 1), ")")
}

#' Format of xx.xx (xx.x)
#'
#' @param x input array
#' @param output output handle
#' @return formatted values
#' @export
trim_perc <- function(x, output) {
  paste0(x[1], " (", new_round(x[2] * 100, 2), ")")
}

#' Format of (xx\%, xx\%)
#'
#' @param x input array
#' @param output output handle
#' @return formatted values
#' @export
perc_perc <- function(x, output) {
  paste0(new_round(x[1] * 100, 0), "% (", new_round(x[2] * 100, 0), "%)")
}

#' Format of xx.xx (xx.xx, xx.xx)
#'
#' @param x input array
#' @param output output handle
#' @return formatted values
#' @export
format_3d <- function(x, output) {
  paste0(new_round(x[1], 2), " (", new_round(x[2], 2), ", ", new_round(x[3], 2), ")")
}


#' survival time afun
#'
#' @param df data
#' @param .var variable of interest
#' @param is_event vector indicating event
#' @param control `control_surv_time()` by default
#' @return A function suitable for use in rtables::analyze() with element selection,
#' reformatting, and relabeling performed automatically.
#' @export
s_surv_time_1 <- function(df, .var, is_event, control = control_surv_time()) {
  # assert_that(is_df_with_variables(df, list(tte = .var, is_event = is_event)),
  #            is.string(.var), is_numeric_vector(df[[.var]]), is_logical_vector(df[[is_event]]))

  conf_type <- control$conf_type
  conf_level <- control$conf_level
  quantiles <- control$quantiles
  formula <- as.formula(paste0(
    "Surv(", .var, ", ", is_event,
    ") ~ 1"
  ))
  srv_fit <- survfit(
    formula = formula, data = df, conf.int = conf_level,
    conf.type = conf_type
  )
  srv_tab <- summary(srv_fit, extend = TRUE)$table
  # srv_qt_tab <- quantile(srv_fit, probs = quantiles)$quantile
  # range_censor <- range_noinf(df[[.var]][!df[[is_event]]],
  #                            na.rm = TRUE)
  # range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)
  # range <- range_noinf(df[[.var]], na.rm = TRUE)
  new_label <- paste0("Median (Months, ", conf_level * 100, "% CI)")

  list(
    median_ci = formatters::with_label(c(
      unname(srv_tab["median"]),
      unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))])
    ), new_label)
  )
}


s_coxph_pairwise_1 <- function(df, .ref_group, .in_ref_col, .var, is_event, strat = NULL,
                               control = control_coxph()) {
  # assert_that(is_df_with_variables(df, list(tte = .var, is_event = is_event)),
  #             is.string(.var), is_numeric_vector(df[[.var]]), is_logical_vector(df[[is_event]]))
  pval_method <- control$pval_method
  ties <- control$ties
  conf_level <- control$conf_level

  strat_type <- ifelse(is.null(strat), "Unstratified", "Stratified")
  if (.in_ref_col) {
    return(
      in_rows(
        rcell(""),
        rcell(""),
        .labels = c(paste0(strat_type, " HR (", conf_level * 100, "% CI)"), paste0("p-value (", pval_method, ")"))
      )
      # list(hr_ci = formatters::with_label("", paste0("Stratified HR (", conf_level*100, "% CI)")),
      #      pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")"))
      #      )
    )
  }
  data <- rbind(.ref_group, df)
  group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))),
    levels = c("ref", "x")
  )
  df_cox <- data.frame(
    tte = data[[.var]], is_event = data[[is_event]],
    arm = group
  )
  if (is.null(strat)) {
    formula_cox <- Surv(tte, is_event) ~ arm
  } else {
    formula_cox <- as.formula(paste0(
      "Surv(tte, is_event) ~ arm + strata(",
      paste(strat, collapse = ","), ")"
    ))
    df_cox <- cbind(df_cox, data[strat])
  }
  cox_fit <- coxph(formula = formula_cox, data = df_cox, ties = ties)
  sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)
  pval <- switch(pval_method,
    wald = sum_cox$waldtest["pvalue"],
    `log-rank` = sum_cox$sctest["pvalue"],
    likelihood = sum_cox$logtest["pvalue"]
  )
  list(
    # hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"),
    # hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),
    hr_ci = formatters::with_label(
      c(sum_cox$conf.int[1, 1], unname(sum_cox$conf.int[1, 3:4])),
      paste0("Stratified HR (", conf_level * 100, "% CI)")
    ),
    pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")"))
  )

  in_rows(
    rcell(c(sum_cox$conf.int[1, 1], unname(sum_cox$conf.int[1, 3:4])), format = format_3d),
    rcell(unname(pval), format = "x.xxxx | (<0.0001)"),
    .labels = c(paste0("Stratified HR (", conf_level * 100, "% CI)"), paste0("p-value (", pval_method, ")"))
  )
}

is_in_repository <- function() {
  system("git status", ignore.stdout = TRUE, ignore.stderr = TRUE) == 0
}

get_remote_url <- function() {
  repos <- system("git remote -v", intern = TRUE)
  str_extract(repos, "(https://|git@).*.git")
}

get_last_gitcommit_sha <- function() {
  system("git rev-parse HEAD", intern = TRUE)
}

get_repo_head_name <- function() {
  system("git rev-parse --abbrev-ref HEAD", intern = TRUE)
}

warn <- function(...) {
  warning(..., call. = FALSE, immediate. = TRUE)
}

git_footnote <- function(for_test = FALSE) {
  if (is_in_repository()) {
    remote_url <- get_remote_url()[1]
    if (grepl("^https", remote_url)) {
      https_url <- gsub("\\.git$", "", remote_url)
    } else {
      https_url <- gsub("^git@", "https://", gsub(":", "/", remote_url))
    }

    repo <- paste("GitHub repository:", https_url)
    commit <- paste(
      "Git hash:",
      get_last_gitcommit_sha()
    )
    ret <- c(repo, commit)
  } else {
    ret <- NULL
  }

  if (for_test == TRUE) {
    ret <- NULL
  }

  ret
}

datetime <- function() {
  # eICE like format, e.g. 23SEP2020 12:40
  toupper(format(Sys.time(), "%d%b%Y %H:%M"))
}

enumerate <- function(x, quote = "`") {
  n <- length(x)
  if (n == 1L) {
    paste0(quote, x, quote)
  } else {
    paste(
      paste(paste0(quote, x[-n], quote), collapse = ", "),
      paste("and", paste0(quote, x[n], quote))
    )
  }
}

map_lgl <- function(x, f, ...) {
  vapply(x, f, logical(1L), ..., USE.NAMES = FALSE)
}

map_num <- function(x, f, ...) {
  vapply(x, f, numeric(1L), ..., USE.NAMES = FALSE)
}

map_chr <- function(x, f, ...) {
  vapply(x, f, character(1L), ..., USE.NAMES = FALSE)
}


on_master_branch <- function() {
  get_repo_head_name() %in% c("master", "main")
}


create_new_reporting_event <- function(name) {
  dir.create(name)
  file.create(file.path(name, "metadata.yml"))
}

create_output_name <- function(program, suffix) {
  ifelse(is.na(suffix) | suffix == "", program, paste(program, suffix, sep = "_"))
}

default_paper_size <- function(program) {
  output_type <- substr(program, 1L, 1L)
  defaults <- c(l = "L8", t = "P8", g = "L11")
  if (output_type %in% names(defaults)) {
    unname(defaults[output_type])
  } else {
    "P8"
  }
}

vbar2newline <- function(x) {
  gsub("\\s*\\|\\s*", "\n", x)
}

munge_spaces <- function(text, wordboundary = "(\\t|\\n|\\x0b|\\x0c|\\r| )") {
  stringr::str_replace_all(text, wordboundary, " ")
}

# split_chunk <- function(text, whitespace = "[\\t\\n\\x0b\\x0c\\r\\ ]") {
#   wordsep_re <- sprintf("(%s+)", whitespace)
#   strsplit(text, split = wordsep_re, perl = TRUE)
# }
split_chunk <- function(text, whitespace = "\\s+") {
  # Split the string by one or more whitespace characters.
  chunks <- strsplit(text, split = whitespace, perl = TRUE)[[1]]
  # Remove any empty strings that result from leading/trailing whitespace.
  chunks[chunks != ""]
}

wrap_chunk <- function(chunks, width) {
  if (length(chunks) == 0) {
    return(list())
  }

  lines <- list()
  current_line <- ""

  while (length(chunks) > 0) {
    word <- chunks[1]
    if (nchar(word) > width) {
      # If there's content on the current line, bank it first.
      if (current_line != "") {
        lines <- append(lines, current_line)
      }

      lines <- append(lines, substr(word, 1, width))
      chunks[1] <- substr(word, width + 1, nchar(word))
      current_line <- ""
      next
    }

    potential_line <- if (current_line == "") word else paste(current_line, word, sep = " ")

    if (nchar(potential_line) <= width) {
      current_line <- potential_line
      chunks <- chunks[-1]
    } else {
      # If it doesn't fit, bank the current line and start a new one with the word.
      lines <- append(lines, current_line)
      current_line <- word
      chunks <- chunks[-1]
    }
  }

  if (current_line != "") {
    lines <- append(lines, current_line)
  }

  lines
}



text_wrap_cut <- function(text, width) {
  width <- as.integer(width)
  if (width <= 0) {
    return("")
  }
  munged_text <- munge_spaces(text)
  chunks <- split_chunk(munged_text)
  wrapped_list <- wrap_chunk(chunks, width = width)
  paste(unlist(wrapped_list), collapse = "\n")
}

text_wrap_cut_keepreturn <- function(text, width) {
  if (is.na(width)) {
    width <- 0
  }
  lines <- strsplit(text, "\n")[[1]]
  wrapped_lines_list <- lapply(lines, function(line) {
    if (line == "") {
      ""
    } else {
      text_wrap_cut(line, width)
    }
  })
  paste(wrapped_lines_list, collapse = "\n")
}


#' @noRd
fs <- function(paper) {
  fontsize <- as.integer(substr(paper, 2, nchar(paper)))
  orientation <- substr(paper, 1, 1)
  list(fontsize = fontsize, orientation = orientation)
}

validate_paper_size <- function(paper) {
  assert_is_character_scalar(paper)
  if (!grepl("^[P|L][1-9][0-9]{0,1}$", paper)) {
    abort(
      "Page size must be starting with `L` or `P` to indicate the orientation of the page, ",
      "followed by an integer to indicate the fontsize"
    )
  }
  fontsize <- as.integer(substr(paper, 2, nchar(paper)))
  if (fontsize > 14) {
    abort("Fontsize should be less or equal than 14")
  }
}

get_output_file_ext <- function(output, file_path) {
  ret <- ""
  if (tools::file_ext(file_path) != "") {
    ret <- file_path
  } else {
    file_ext <- ifelse(is_rtable(output) || "dVTableTree" %in% class(output), "out", "pdf")
    ret <- sprintf("%s.%s", file_path, file_ext)
  }

  ret
}

# make config global so that test-util recognizes it
.autoslider_config <- new.env(parent = emptyenv())

warn_about_legacy_filtering <- function(output) {
  if (.autoslider_config$filter_warning_issued) {
    return(invisible())
  } else {
    .autoslider_config$filter_warning_issued <- TRUE
  }

  msg <- sprintf(
    paste(
      "Filtering based upon a character scalar is deprecated.",
      "Please use `output == '%s'` instead."
    ),
    output
  )
  warn(msg)
}

warn_about_legacy_paper_size <- function(old_paper_size,
                                         new_paper_size) {
  if (.autoslider_config$paper_size_warning_issued[old_paper_size]) {
    return(invisible())
  } else {
    .autoslider_config$paper_size_warning_issued[old_paper_size] <- TRUE
  }

  msg <- sprintf(
    "Paper size '%s' is deprecated. Please use '%s' instead.",
    old_paper_size,
    new_paper_size
  )
  warn(msg)
}



#' Build side by side layout by cbind
#'
#' @param lyt layout object
#' @param anl analysis data object
#' @param side_by_side A logical value indicating whether to display the data side by side.
#' @return An `rtables` layout
#' @export
lyt_to_side_by_side <- function(lyt, anl, side_by_side = NULL) {
  result <- build_table(lyt = lyt, df = anl)

  if (!is.null(side_by_side)) {
    if (grepl("Asia", side_by_side)) {
      tmp_anl <- anl %>% filter(COUNTRY %in% c("CHN", "HKG", "TWN", "KOR", "SGP", "THA", "MYS"))
      tmp_anl$lvl <- "Asia"
      result <- cbind_rtables(
        result,
        build_table(
          lyt = lyt,
          df = tmp_anl
        )
      )
    }

    if (grepl("China", side_by_side)) {
      tmp_anl <- anl %>% filter(COUNTRY == "CHN")
      tmp_anl$lvl <- "China"
      result <- cbind_rtables(result, build_table(lyt = lyt, df = tmp_anl))
    }
  }
  return(result)
}

#' Build side by side layout by cbind
#' @param lyt layout object
#' @param anl analysis data object
#' @param side_by_side A logical value indicating whether to display the data side by side.
#' @param alt_counts_df alternative data frame for counts
#' @return An `rtables` layout
#' @export
lyt_to_side_by_side_two_data <- function(lyt, anl, alt_counts_df, side_by_side = NULL) {
  result <- build_table(lyt = lyt, df = anl, alt_counts_df = alt_counts_df)

  if (!is.null(side_by_side)) {
    if (grepl("Asia", side_by_side)) {
      countries <- c("CHN", "HKG", "TWN", "KOR", "SGP", "THA", "MYS")
      tmp_anl <- anl %>% filter(COUNTRY %in% countries)
      tmp_anl$lvl <- "Asia"
      tmp_alt <- alt_counts_df %>% filter(COUNTRY %in% countries)
      tmp_alt$lvl <- "Asia"

      result <- cbind_rtables(
        result,
        build_table(
          lyt = lyt,
          df = tmp_anl,
          alt_counts_df = tmp_alt
        )
      )
    }

    if (grepl("China", side_by_side)) {
      tmp_anl <- anl %>% filter(COUNTRY == "CHN")
      tmp_anl$lvl <- "China"
      tmp_alt <- alt_counts_df %>% filter(COUNTRY == "CHN")
      tmp_alt$lvl <- "China"
      result <- cbind_rtables(result, build_table(
        lyt = lyt, df = tmp_anl,
        alt_counts_df = tmp_alt
      ))
    }
  }
  return(result)
}


do_call <- function(fun, ...) {
  args <- list(...)
  do.call(fun, args[intersect(names(args), formalArgs(fun))])
}


#' Build table header, a utility function to help with construct structured header for table layout
#' @param anl analysis data object
#' @param arm Arm variable for column split
#' @param split_by_study, if true, construct structured header with the study ID
#' @param side_by_side A logical value indicating whether to display the data side by side.
#' @return A `rtables` layout with desired header.
#' @export
build_table_header <- function(anl,
                               arm,
                               split_by_study,
                               side_by_side) {
  lyt <- basic_table()
  if (is.null(side_by_side)) {
    if (split_by_study) {
      assert_that(length(unique(anl$STUDYID)) > 1)
      lyt <- lyt %>%
        split_cols_by(var = "STUDYID") %>%
        split_cols_by(var = arm)
    } else {
      lyt <- lyt %>%
        split_cols_by(var = arm) %>%
        add_overall_col("All Patients")
    }
  } else {
    if (split_by_study) {
      warning("split_by_study argument will be ignored")
    }
    lyt <- lyt %>%
      split_cols_by(var = "lvl") %>%
      split_cols_by(var = arm) %>%
      add_overall_col("All Patients")
  }

  lyt
}


get_version_label_output <- function() {
  NULL
}


strip_NA <- function(input) {
  input[which(input != "NA")]
}

get_deepseek_key <- function(filename = "DEEPSEEK_KEY") {
  scan(filename, what = "character", sep = NULL)
}

get_portkey_key <- function(filename = "PORTKEY_KEY") {
  scan(filename, what = "character", sep = NULL)
}

get_system_prompt <- function(text = "you are a Clinical data scientist expert") {
  return(text)
}

#' Get an `ellmer` chat API with given platform
#'
#' @param platform Platform provider
#' @param base_url Base url
#' @param api_key API key
#' @param model Model of choice
#'
#' @export
#'
get_ellmer_chat <- function(platform = "deepseek",
                            base_url = "https://api.deepseek.com",
                            api_key = get_deepseek_key(),
                            model = "deepseek-chat") {
  chat <- NULL
  if (platform == "deepseek") {
    chat <- ellmer::chat_deepseek(
      system_prompt = get_system_prompt(),
      base_url = base_url,
      api_key = api_key,
      model = model
    )
  } else if (platform == "galileo") {
    chat <- ellmer::chat_portkey(
      system_prompt = get_system_prompt(),
      base_url = base_url,
      api_key = api_key,
      model = model
    )
  } else if (platform == "openai") {
    chat <- ellmer::chat_openai(
      system_prompt = get_system_prompt(),
      base_url = base_url,
      api_key = api_key,
      model = model
    )
  } else if (platform == "ollama") {
    chat <- ellmer::chat_ollama(
      system_prompt = get_system_prompt(),
      base_url = base_url,
      model = model
    )
  }

  return(chat)
}

#' Read prompt list from yaml file
#'
#' @param filename File name
#'
#' @export
get_prompt_list <- function(filename) {
  prompt <- yaml::read_yaml(filename, eval.expr = TRUE)
  structure(
    .Data = prompt,
    names = map_chr(prompt, `[[`, "output"),
    class = union("spec", class(prompt))
  )
}


integrate_prompt <- function(base_prompt, tlg) {
  # let's do figures in the future
  ret <- paste(
    "As a Clinical data scientist expert, here is a",
    tlg@main_title, ":\n\n"
  )
  ret <- gsub("\\{table_text\\}", export_as_txt(tlg), base_prompt)
  ret
}

#' Update footnote with AI response
#'
#' @param outputs Output objects
#' @param prompt_list List of prompt
#' @param platform Platform provider
#' @param base_url Base url
#' @param api_key API key
#' @param model Model of choice
#'
#' @export
get_ai_notes <- function(outputs, prompt_list, platform, base_url, api_key, model) {
  chat <- get_ellmer_chat(platform, base_url, api_key, model)
  names_outputs <- names(outputs)
  ret <- lapply(names_outputs, function(output_name) {
    output <- outputs[[output_name]]
    if (is(output, "autoslider_error")) {
      return(output)
    }
    if (output_name %in% names(prompt_list)) {
      base_prompt <- prompt_list[[output_name]]$prompt
      current_prompt <- integrate_prompt(base_prompt, output@tbl)
      raw_response <- chat$chat(current_prompt)
      clean_response <- sub(".*?</think>\\s*", "", raw_response)
      output@usernotes <- paste(platform, model, "generated notes:", clean_response)
    }
    output
  })
  names(ret) <- names_outputs
  ret
}

#' generate slides based on output
#'
#' @param outputs List of output
#' @param template Template file path
#' @param outfile Out file path
#' @param fig_width figure width in inch
#' @param fig_height figure height in inch
#' @param t_lpp An integer specifying the table lines per page \cr
#'    Specify this optional argument to modify the length of all of the table displays
#' @param t_cpp An integer specifying the table columns per page\cr
#'    Specify this optional argument to modify the width of all of the table displays
#' @param l_lpp An integer specifying the listing lines per page\cr
#'    Specify this optional argument to modify the length of all of the listings display
#' @param l_cpp An integer specifying the listing columns per page\cr
#'    Specify this optional argument to modify the width of all of the listings display
#' @param fig_editable whether we want the figure to be editable in pptx viewers, defaults to FALSE
#' @param ... arguments passed to program
#' @return No return value, called for side effects
#' @export
#' @examplesIf require(filters)
#'
#' # Example 1. When applying to the whole pipeline
#' library(dplyr)
#' data <- list(
#'   adsl = eg_adsl %>% dplyr::mutate(FASFL = SAFFL),
#'   adae = eg_adae
#' )
#'
#'
#' filters::load_filters(
#'   yaml_file = system.file("filters.yml", package = "autoslider.core"),
#'   overwrite = TRUE
#' )
#'
#'
#' spec_file <- system.file("spec.yml", package = "autoslider.core")
#' spec_file %>%
#'   read_spec() %>%
#'   filter_spec(program %in% c("t_dm_slide")) %>%
#'   generate_outputs(datasets = data) %>%
#'   decorate_outputs() %>%
#'   generate_slides()
#'
#' # Example 2. When applying to an rtable object or an rlisting object
#' adsl <- eg_adsl
#' t_dm_slide(adsl, "TRT01P", c("SEX", "AGE")) %>%
#'   generate_slides()
generate_slides <- function(outputs,
                            outfile = paste0(tempdir(), "/output.pptx"),
                            template = file.path(system.file(package = "autoslider.core"), "theme/basic.pptx"),
                            fig_width = 9, fig_height = 5, t_lpp = 20, t_cpp = 200,
                            l_lpp = 20, l_cpp = 150, fig_editable = FALSE, ...) {
  if (any(c(
    is(outputs, "VTableTree"),
    is(outputs, "listing_df")
  ))) {
    if (is(outputs, "listing_df")) {
      current_title <- main_title(outputs)
    } else {
      current_title <- outputs@main_title
    }
    outputs <- list(
      decorate(outputs, titles = current_title, footnotes = "Confidential and for internal use only")
    )
  } else if (any(c(
    is(outputs, "data.frame"),
    is(outputs, "ggplot"),
    is(outputs, "gtsummary"),
    is(outputs, "dVTableTree"),
    is(outputs, "dlisting"),
    is(outputs, "grob")
  ))) {
    if (is(outputs, "ggplot")) {
      current_title <- outputs$labels$title
      if (is.null(current_title)) {
        current_title <- ""
      }
      outputs <- decorate.ggplot(outputs, titles = current_title)
    } else if (is(outputs, "grob")) {
      outputs <- decorate.grob(outputs)
    }

    outputs <- list(outputs)
  }

  assert_that(is.list(outputs))

  # ======== generate slides =======#
  # set slides layout
  ppt <- read_pptx(path = template)
  location_ <- officer::fortify_location(ph_location_fullsize(), doc = ppt)
  width <- location_$width
  height <- location_$height

  # add content to slides template
  for (x in outputs) {
    if (is(x, "dVTableTree") || is(x, "VTableTree")) {
      y <- to_flextable(x, lpp = t_lpp, cpp = t_cpp, ...)
      usernotes <- x@usernotes
      for (tt in y) {
        table_to_slide(ppt,
          content = tt,
          table_loc = center_table_loc(tt$ft, ppt_width = width, ppt_height = height),
          usernotes = usernotes, ...
        )
      }
    } else if (is(x, "dlisting")) {
      y <- to_flextable(x, cpp = l_cpp, lpp = l_lpp, ...)
      for (tt in y) {
        table_to_slide(ppt,
          content = tt,
          table_loc = center_table_loc(tt$ft, ppt_width = width, ppt_height = height), ...
        )
      }
    } else if (is(x, "data.frame")) { # this is dedicated for small data frames without pagination
      y <- to_flextable(x, ...)
      table_to_slide(ppt, content = y, decor = FALSE, ...)
    } else if (is(x, "gtsummary") || is(x, "dgtsummary")) {
      y <- to_flextable(x, ...)
      table_to_slide(ppt,
        content = y, decor = FALSE, ...
      )
    } else {
      if (any(class(x) %in% c("decoratedGrob", "decoratedGrobSet", "ggplot"))) {
        if (is(x, "ggplot")) {
          x <- decorate.ggplot(x)
        }

        assertthat::assert_that(is(x, "decoratedGrob") || is(x, "decoratedGrobSet"))

        figure_to_slide(ppt,
          content = x, fig_width = fig_width, fig_height = fig_height,
          figure_loc = center_figure_loc(fig_width, fig_height, ppt_width = width, ppt_height = 1.17 * height),
          fig_editable = fig_editable, ...
        )
      } else {
        if (is(x, "autoslider_error")) {
          message(x)
        } else {
          next
        }
      }
    }
  }
  print(ppt, target = outfile)
}

#' Generate flextable for preview first page
#'
#' @param x rtables or data.frame
#' @return A flextable or a ggplot object depending to the input.
#' @export
#' @examples
#' # Example 1. preview table
#' library(dplyr)
#' adsl <- eg_adsl
#' t_dm_slide(adsl, "TRT01P", c("SEX", "AGE")) %>% slides_preview()
slides_preview <- function(x) {
  if (is(x, "VTableTree")) {
    ret <- to_flextable(paginate_table(x, lpp = 20)[[1]])
  } else if (is(x, "listing_df")) {
    new_colwidth <- formatters::propose_column_widths(x)
    ret <- to_flextable(old_paginate_listing(x, cpp = 150, lpp = 20)[[1]],
      col_width = new_colwidth
    )
  } else if (is(x, "ggplot")) {
    ret <- x
  } else {
    stop("Unintended usage!")
  }
  ret
}

get_body_bottom_location <- function(ppt) {
  location_ <- officer::fortify_location(ph_location_fullsize(), doc = ppt)
  width <- location_$width
  height <- location_$height
  top <- 0.7 * height
  left <- 0.1 * width
  ph <- ph_location(left = left, top = top)
  ph
}


#' create location container to center the table
#'
#' @param ft Flextable object
#' @param ppt_width Powerpoint width
#' @param ppt_height Powerpoint height
#' @return Location for a placeholder
center_table_loc <- function(ft, ppt_width, ppt_height) {
  top <- (ppt_height - sum(dim(ft)$heights)) / 2
  left <- (ppt_width - sum(dim(ft)$widths)) / 2
  ph <- ph_location(left = left, top = top)
  ph
}

#' Adjust title line break and font size
#'
#' @param title Character string
#' @param max_char Integer specifying the maximum number of characters in one line
#' @param title_color Title color
get_proper_title <- function(title, max_char = 60, title_color = "#1C2B39") {
  # cat(nchar(title), " ", as.integer(24-nchar(title)/para), "\n")
  title <- gsub("\\n", "\\s", title)
  new_title <- ""

  while (nchar(title) > max_char) {
    spaces <- gregexpr("\\s", title)
    new_title <- paste0(new_title, "\n", substring(title, 1, max(spaces[[1]][spaces[[1]] <= max_char])))
    title <- substring(title, max(spaces[[1]][spaces[[1]] <= max_char]) + 1, nchar(title))
  }

  new_title <- paste0(new_title, "\n", title)

  ftext(
    trimws(new_title),
    fp_text(
      font.size = floor(26 - nchar(title) / max_char),
      color = title_color
    )
  )
}

#' Add decorated flextable to slides
#'
#' @param ppt Slide
#' @param content Content to be added
#' @param table_loc Table location
#' @param usernotes User notes
#' @param decor Should table be decorated
#' @param ... additional arguments
#' @return Slide with added content
table_to_slide <- function(ppt, content, decor = TRUE, table_loc = ph_location_type("body"),
                           usernotes = "", ...) {
  ppt_master <- layout_summary(ppt)$master[1]
  args <- list(...)
  # until officer 0.6.10 ppt <- layout_default(ppt, "Title and Content")

  if (decor) {
    print(content$header)
    out <- content$ft

    if (length(content$footnotes) > 1) {
      content$footnotes <- paste(content$footnotes, collapse = "\n")
    }
    # print(content_footnotes)
    if (content$footnotes != "") {
      out <- footnote(out,
        i = 1, j = 1,
        value = as_paragraph(content$footnotes),
        ref_symbols = " ", part = "header", inline = TRUE
      )
    }

    args$arg_header <- list(
      value = fpar(get_proper_title(content$header)),
      location = ph_location_type("title")
    )
  } else {
    out <- content
    out <- footnote(out,
      i = 1, j = 1,
      value = as_paragraph("Confidential and for internal use only"),
      ref_symbols = " ", part = "header", inline = TRUE
    )
  }

  ppt <- do_call(add_slide, x = ppt, master = ppt_master, ...)
  ppt <- ph_with(ppt, value = out, location = table_loc)
  ppt <- set_notes(ppt, value = usernotes,
                   location = notes_location_type("body"))
  ph_with_args <- args[unlist(lapply(args, function(x) all(c("location", "value") %in% names(x))))]
  res <- lapply(ph_with_args, function(x) {
    ppt <- ph_with(ppt, value = x$value, location = x$location)
  })

  return(res)
}

#' Create location container to center the figure, based on ppt size and
#' user specified figure size
#'
#' @param fig_width Figure width
#' @param fig_height Figure height
#' @param ppt_width Slide width
#' @param ppt_height Slide height
#'
#' @return Location for a placeholder from scratch
center_figure_loc <- function(fig_width, fig_height, ppt_width, ppt_height) {
  # center figure
  top <- (ppt_height - fig_height) / 2
  left <- (ppt_width - fig_width) / 2
  ph_location(top = top, left = left)
}

#' Placeholder for ph_with_img
#'
#' @param ppt power point file
#' @param figure image object
#' @param fig_width width of figure
#' @param fig_height height of figure
#' @param figure_loc location of figure
#' @return Location for a placeholder
#' @export
ph_with_img <- function(ppt, figure, fig_width, fig_height, figure_loc) {
  file_name <- tempfile(fileext = ".svg")
  svg(filename = file_name, width = fig_width, height = fig_height, onefile = TRUE)
  grid.draw(figure$grob)
  dev.off()
  on.exit(unlink(file_name))
  ext_img <- external_img(file_name, width = fig_width, height = fig_height)

  ppt %>% ph_with(value = ext_img, location = figure_loc, use_loc_size = FALSE)
}

#' Add figure to slides
#'
#' @param ppt slide page
#' @param content content to be added
#' @param decor should decoration be added
#' @param fig_width user specified figure width
#' @param fig_height user specified figure height
#' @param figure_loc location of the figure. Defaults to `ph_location_type("body")`
#' @param fig_editable whether we want the figure to be editable in pptx viewers
#' @param ... arguments passed to program
#'
#' @return slide with the added content
figure_to_slide <- function(ppt, content,
                            decor = TRUE,
                            fig_width,
                            fig_height,
                            figure_loc = ph_location_type("body"),
                            fig_editable = FALSE,
                            ...) {
  ppt_master <- layout_summary(ppt)$master[1]
  # until officer 0.6.10 ppt <- layout_default(ppt, "Title and Content")
  args <- list(...)


  if (decor) {
    args$arg_header <- list(
      value = fpar(get_proper_title(content$titles)),
      location = ph_location_type("title")
    )
  }

  if ("decoratedGrob" %in% class(content)) {
    ppt <- do_call(add_slide, x = ppt, master = ppt_master, ...)
    if (fig_editable) {
      content_list <- g_export(content)
      ppt <- ph_with(ppt, content_list$dml, location = ph_location_type(type = "body"))
    } else {
      ppt <- ph_with_img(ppt, content, fig_width, fig_height, figure_loc)
    }

    ph_with_args <- args[unlist(lapply(args, function(x) all(c("location", "value") %in% names(x))))]
    res <- lapply(ph_with_args, function(x) {
      ppt <- ph_with(ppt, value = x$value, location = x$location)
    })
    return(res)
  } else if ("decoratedGrobSet" %in% class(content)) { # for decoratedGrobSet, a list of figures are created and added
    # revisit, to make more efficent
    for (figure in content) {
      ppt <- do_call(add_slide, x = ppt, master = ppt_master, ...)
      ppt <- ph_with_img(ppt, figure, fig_width, fig_height, figure_loc)
    }
    return(ppt)
  } else {
    stop("Should not reach here")
  }
}

#' Plot mean values of LB
#'
#' Wrapper for `g_mean_general()`.
#' Requires filtering of the datasets (e.g. using SUFFIX in spec.yml)
#'
#' @param adsl ADSL data
#' @param adlb ADLB data
#' @param arm `"TRT01P"` by default
#' @param paramcd character scalar. defaults to By default `"PARAM"`
#'  Which variable to use for plotting.
#' @param y character scalar. Variable to plot on the Y axis. By default `"AVAL"`
#' @inheritParams g_mean_general
#' @param ... |
#' Gets forwarded to `tern::g_lineplot()`.
#' This lets you specify additional arguments to `tern::g_lineplot()`
#' @author Stefan Thoma (`thomas7`)
#' @export
#' @examplesIf require('rsvg')
#' library(dplyr)
#'
#' adlb_filtered <- eg_adlb %>% filter(
#'   PARAMCD == "CRP"
#' )
#' plot_lb <- g_lb_slide(
#'   adsl = eg_adsl,
#'   adlb = adlb_filtered,
#'   paramcd = "PARAM",
#'   subtitle_add_unit = FALSE
#' ) +
#'   ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))
#' generate_slides(plot_lb, paste0(tempdir(), "/g_lb.pptx"))
#'
#' # Let's plot change values:
#' plot_lb_chg <- g_lb_slide(
#'   adsl = eg_adsl,
#'   adlb = adlb_filtered,
#'   paramcd = "PARAM",
#'   y = "CHG",
#'   subtitle = "Plot of change from baseline and 95% Confidence Limit by Visit."
#' )
#' generate_slides(plot_lb_chg, paste0(tempdir(), "/g_lb_chg.pptx"))
#'
g_lb_slide <- function(adsl, adlb, arm = "TRT01P", paramcd = "PARAM", y = "AVAL",
                       subtitle = "Plot of Mean and 95% Confidence Limits by Visit.", ...) {
  # tern 0.9.4 added facet_var in control_lineplot_vars
  variables <- control_lineplot_vars(group_var = arm, paramcd = paramcd, y = y) %>%
    strip_NA()

  by_vars <- c("USUBJID", "STUDYID")
  assert_that(is.string(arm))
  assert_that(is.string(paramcd))
  assert_that(is.string(y))
  assert_that(has_name(adlb, c(by_vars, variables) %>% unique()))
  assert_that(has_name(adsl, c(by_vars, arm) %>% unique()))
  assert_that(is.string(subtitle))

  g_mean_general(
    adsl = adsl, data = adlb, variables = variables, by_vars = by_vars,
    subtitle = subtitle, ...
  )
}

#' Adverse event table
#'
#' @param adae ADAE data set, dataframe
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character, "`TRT01A" by default.
#' @param cutoff Cutoff threshold
#' @param prune_by_total Prune according total column
#' @param split_by_study Split by study, building structured header for tables
#' @param side_by_side A logical value indicating whether to display the data side by side.
#' @return rtables object
#' @inherit gen_notes note
#' @export
#' @examples
#'
#' library(dplyr)
#' # Example 1
#' adsl <- eg_adsl %>%
#'   dplyr::mutate(TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")))
#' adae <- eg_adae %>%
#'   dplyr::mutate(
#'     TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")),
#'     ATOXGR = AETOXGR
#'   )
#' out <- t_ae_pt_slide(adsl, adae, "TRT01A", 2)
#' print(out)
#' generate_slides(out, paste0(tempdir(), "/ae.pptx"))
#'
#' # Example 2, prune by total column
#' out2 <- t_ae_pt_slide(adsl, adae, "TRT01A", 25, prune_by_total = TRUE)
#' print(out2)
#' generate_slides(out, paste0(tempdir(), "/ae2.pptx"))
t_ae_pt_slide <- function(adsl, adae, arm = "TRT01A", cutoff = NA, prune_by_total = FALSE,
                          split_by_study = FALSE,
                          side_by_side = NULL) {
  cutoff <- check_and_set_cutoff(adae, cutoff)
  result <- t_ae_pt_core(adsl, adae, arm, cutoff,
    diff = FALSE, soc = "NULL",
    prune_by_total = prune_by_total,
    split_by_study,
    side_by_side
  )
  result@main_title <- "Adverse Events table"

  if (is.null(side_by_side)) {
    # adding "N" attribute
    arm <- col_paths(result)[[1]][1]

    n_r <- data.frame(
      ARM = toupper(names(result@col_info)),
      N = col_counts(result) %>% as.numeric()
    ) %>%
      `colnames<-`(c(paste(arm), "N")) %>%
      arrange(get(arm))

    attr(result, "N") <- n_r
  }
  result
}

abort <- function(...) {
  stop(..., call. = FALSE)
}

assert_is_character_scalar <- function(x) {
  if (length(x) != 1L || is.na(x) || !is.character(x) || x == "") {
    abort("`", deparse(substitute(x)), "` must be a character scalar.")
  }
}

assert_is_valid_version_label <- function(x) {
  if (!(x %in% c("DRAFT", "APPROVED") || is.null(x))) {
    abort("Version label must be 'DRAFT', 'APPROVED' or `NULL` but is '", x, "'.")
  }
}


assert_exists_in_spec_or_calling_env <- function(vars, output, env = parent.frame()) {
  exist_in_spec <- vars %in% names(output)
  # explicitly define env to use, better practice for testing
  exist_in_calling_env <- map_lgl(vars, exists, envir = env)

  non_existing_vars <- vars[!(exist_in_spec | exist_in_calling_env)]


  n <- length(non_existing_vars)
  if (n >= 1L) {
    err_msg <- sprintf(
      paste(
        "Cannot filter based upon the %s %s as %s not contained in",
        "`spec` or the surrounding environment."
      ),
      if (n == 1L) "variable" else "variables",
      enumerate(non_existing_vars),
      if (n == 1L) "it is" else "they are"
    )
    stop(err_msg, call. = FALSE)
  }
}

assert_is_valid_filter_result <- function(x) {
  if (length(x) != 1L || is.na(x) || !is.logical(x)) {
    stop(
      "`filter_expr` must evaluate to a logical scalar but returned `",
      deparse(x), "`.",
      call. = FALSE
    )
  }
}

#' Demographic table
#'
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character, "`TRT01P" by default.
#' @param vars Characters of variables
#' @param stats see `.stats` from [tern::analyze_vars()]
#' @param split_by_study Split by study, building structured header for tables
#' @param side_by_side "GlobalAsia" or "GlobalAsiaChina" to define the side by side requirement
#' @return rtables object
#' @inherit gen_notes note
#' @export
#' @examples
#' library(dplyr)
#' adsl <- eg_adsl
#' out1 <- t_dm_slide(adsl, "TRT01P", c("SEX", "AGE", "RACE", "ETHNIC", "COUNTRY"))
#' print(out1)
#' generate_slides(out1, paste0(tempdir(), "/dm.pptx"))
#'
#' out2 <- t_dm_slide(adsl, "TRT01P", c("SEX", "AGE", "RACE", "ETHNIC", "COUNTRY"),
#'   split_by_study = TRUE
#' )
#' print(out2)
#'
t_dm_slide <- function(adsl,
                       arm = "TRT01P",
                       vars = c("AGE", "SEX", "RACE"),
                       stats = c("median", "range", "count_fraction"),
                       split_by_study = FALSE,
                       side_by_side = NULL) {
  if (is.null(side_by_side)) {
    extra <- NULL
  } else {
    extra <- c("COUNTRY")
  }

  for (v in c(vars, extra)) {
    assert_that(has_name(adsl, v))
  }

  adsl1 <- adsl %>%
    select(all_of(c("STUDYID", "USUBJID", arm, vars, extra)))

  if (!is.null(side_by_side)) {
    adsl1$lvl <- "Global"
  }

  lyt <- build_table_header(adsl1, arm,
    split_by_study = split_by_study,
    side_by_side = side_by_side
  )

  lyt <- lyt %>%
    analyze_vars(
      na.rm = TRUE,
      .stats = stats,
      denom = "n",
      vars = vars,
      .formats = c(mean_sd = "xx.xx (xx.xx)", median = "xx.xx"),
      var_labels = formatters::var_labels(adsl1)[vars]
    )

  result <- lyt_to_side_by_side(lyt, adsl1, side_by_side)

  if (is.null(side_by_side)) {
    # adding "N" attribute
    arm <- col_paths(result)[[1]][1]

    n_r <- data.frame(
      ARM = toupper(names(result@col_info)),
      N = col_counts(result) %>% as.numeric()
    ) %>%
      `colnames<-`(c(paste(arm), "N")) %>%
      dplyr::arrange(get(arm))

    attr(result, "N") <- n_r
  }
  result@main_title <- "Demographic slide"
  result
}

#' Adverse event table
#'
#' @param adae ADAE data set, dataframe
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character, "`TRT01A" by default.
#' @param split_by_study Split by study, building structured header for tables
#' @param side_by_side should table be displayed side by side
#' @return rtables object
#' @inherit gen_notes note
#' @export
#' @examples
#' library(dplyr)
#' adsl <- eg_adsl %>%
#'   dplyr::mutate(TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")))
#' adae <- eg_adae %>%
#'   dplyr::mutate(
#'     TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")),
#'     ATOXGR = AETOXGR
#'   )
#' out <- t_ae_slide(adsl, adae, "TRT01A")
#' print(out)
#' generate_slides(out, paste0(tempdir(), "/ae.pptx"))
t_ae_slide <- function(adsl, adae, arm = "TRT01A",
                       split_by_study = FALSE, side_by_side = NULL) {
  assert_that(has_name(adae, "AEDECOD"))
  assert_that(has_name(adae, "ATOXGR"))
  assert_that(has_name(adae, "AEBODSYS"))

  slref_arm <- sort(unique(adsl[[arm]]))
  anl_arm <- sort(unique(adae[[arm]]))
  assert_that(identical(slref_arm, anl_arm),
    msg = "The adsl and the analysis datasets should have the same treatment arm levels"
  )

  anl <- adae %>%
    mutate_at(
      c("AEDECOD", "AEBODSYS"),
      ~ explicit_na(sas_na(.)) # Replace blank arm with <Missing>
    ) %>%
    semi_join(., adsl, by = c("STUDYID", "USUBJID")) %>%
    mutate(
      AETOXGR = sas_na(AETOXGR) %>% as.factor()
    ) %>%
    formatters::var_relabel(
      AEBODSYS = "MedDRA System Organ Class",
      AEDECOD = "MedDRA Preferred Term"
    )

  if (!is.null(side_by_side)) {
    anl$lvl <- "Global"
  }

  if (nrow(anl) == 0) {
    return(null_report())
  } else {
    lyt <- build_table_header(adsl, arm,
      split_by_study = split_by_study,
      side_by_side = side_by_side
    )

    lyt <- lyt %>%
      split_rows_by(
        "AEBODSYS",
        child_labels = "hidden",
        nested = FALSE,
        indent_mod = 0L,
        split_fun = drop_split_levels,
        label_pos = "topleft",
        split_label = obj_label(anl$AEBODSYS)
      ) %>%
      summarize_num_patients(
        var = "USUBJID",
        .stats = c("unique"),
        .labels = c(
          unique = "Total number of patients"
        ),
        .formats = list(trim_perc1)
      ) %>%
      count_occurrences(
        vars = "AEBODSYS",
        .indent_mods = -1L
        # , .formats = list(trim_perc1)
      ) %>%
      count_occurrences(
        vars = "AEDECOD",
        .indent_mods = 1L
        # , .formats = list(trim_perc1)
      ) %>%
      # append_varlabels(anl, "AEDECOD", indent = TRUE)
      append_topleft(paste("  ", formatters::var_labels(anl["AEDECOD"]), "N (%)"))

    result <- lyt_to_side_by_side_two_data(lyt, anl, adsl, side_by_side)

    result1 <- result %>%
      prune_table() %>%
      sort_at_path(
        path = c("AEBODSYS"),
        scorefun = cont_n_allcols
      ) %>%
      sort_at_path(
        path = c("AEBODSYS", "*", "AEDECOD"),
        scorefun = score_occurrences
      )

    t_aesi_trim_rows <- function(tt) {
      rows <- collect_leaves(tt, TRUE, TRUE)

      tbl <- tt[!grepl("unique", names(rows)), , keep_topleft = TRUE]

      tbl
    }
    result1 <- result1 %>%
      t_aesi_trim_rows()
    result1@main_title <- "AE event table"
    return(result1)
  }
}

#' Adverse event table
#'
#' @param adae ADAE data set, dataframe
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character, "`TRT01A" by default.
#' @param cutoff Cutoff threshold
#' @param split_by_study Split by study, building structured header for tables
#' @param side_by_side "GlobalAsia" or "GlobalAsiaChina" to define the side by side requirement
#' @return rtables object
#' @inherit gen_notes note
#' @export
#' @examples
#' library(dplyr)
#' adsl <- eg_adsl %>%
#'   dplyr::mutate(TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")))
#' adae <- eg_adae %>%
#'   dplyr::mutate(
#'     TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")),
#'     ATOXGR = AETOXGR
#'   )
#' out <- t_ae_pt_diff_slide(adsl, adae, "TRT01A", 2)
#' print(out)
#' generate_slides(out, paste0(tempdir(), "/ae_diff.pptx"))
t_ae_pt_diff_slide <- function(adsl, adae, arm = "TRT01A", cutoff = NA,
                               split_by_study = FALSE, side_by_side = NULL) {
  cutoff <- check_and_set_cutoff(adae, cutoff)
  result <- t_ae_pt_core(adsl, adae, arm, cutoff,
    diff = TRUE, soc = "NULL",
    prune_by_total = FALSE, split_by_study, side_by_side
  )
  result@main_title <- "Adverse Events with Difference"

  if (!all(dim(result@rowspans) == c(0, 0))) {
    if (is.null(side_by_side)) {
      # adding "N" attribute
      arm <- col_paths(result)[[1]][1]

      n_r <- data.frame(
        ARM = toupper(names(result@col_info)),
        N = col_counts(result) %>% as.numeric()
      ) %>%
        `colnames<-`(c(paste(arm), "N")) %>%
        arrange(get(arm))

      attr(result, "N") <- n_r
    }
  }

  result
}


t_ae_pt_core <- function(adsl, adae, arm, cutoff, diff = FALSE, soc = "NULL",
                         prune_by_total = FALSE,
                         split_by_study, side_by_side) {
  assert_that(has_name(adae, "AEDECOD"))
  assert_that(has_name(adae, "ATOXGR"))
  assert_that(has_name(adae, "AEBODSYS"))
  assert_that(has_name(adae, "ANL01FL"))
  assert_that((diff + prune_by_total) < 2)
  assert_that(cutoff <= 100 & cutoff >= 0)

  if (!is.null(side_by_side)) {
    assert_that(has_name(adsl, "RACE"))
    assert_that(has_name(adsl, "COUNTRY"))
  }

  slref_arm <- sort(unique(adsl[[arm]]))
  anl_arm <- sort(unique(adae[[arm]]))
  assert_that(identical(slref_arm, anl_arm),
    msg = "The adsl and the analysis datasets should have the same treatment arm levels"
  )

  if (is.null(side_by_side)) {
    adsl1 <- adsl %>%
      select("STUDYID", "USUBJID", all_of(arm))
  } else if (side_by_side != TRUE) {
    adsl1 <- adsl %>%
      select("STUDYID", "USUBJID", "RACE", "COUNTRY", all_of(arm))
    adsl1$lvl <- "Global"
  } else {
    adsl1 <- adsl %>%
      select("STUDYID", "USUBJID", all_of(arm))
    adsl1$lvl <- "Global"
  }

  anl <- adae %>%
    mutate_at(
      c("AEDECOD", "AEBODSYS"),
      ~ explicit_na(sas_na(.)) # Replace blank arm with <Missing>
    ) %>%
    semi_join(., adsl1, by = c("STUDYID", "USUBJID")) %>%
    mutate(
      ATOXGR = sas_na(ATOXGR) %>% as.factor(),
      ATOXGR2 = case_when(
        ATOXGR %in% c(1, 2) ~ "1 - 2",
        ATOXGR %in% c(3, 4) ~ "3 - 4",
        ATOXGR %in% c(5) ~ "5",
      ) %>% as.factor()
    )

  if (!is.null(side_by_side)) {
    anl$lvl <- "Global"
  }

  if (soc == "soc") {
    anl <- anl %>%
      mutate(
        AEBODSYS = sas_na(AEBODSYS) %>% as.factor()
      )
  }

  anl <- anl %>%
    formatters::var_relabel(
      AEBODSYS = "MedDRA System Organ Class",
      AEDECOD = "MedDRA Preferred Term"
    ) %>%
    filter(ANL01FL == "Y")

  if (nrow(anl) == 0) {
    return(null_report())
  } else {
    lyt <- build_table_header(adsl1, arm, split_by_study = split_by_study, side_by_side = side_by_side)

    # lyt <- basic_table() %>%
    #   split_cols_by(var = arm, split_fun = add_overall_level("All Patients", first = FALSE)) %>%
    #   add_colcounts()

    if (soc == "soc") {
      lyt <- lyt %>%
        split_rows_by(
          "AEBODSYS",
          child_labels = "visible",
          nested = FALSE,
          indent_mod = -1L,
          split_fun = drop_split_levels
        ) %>%
        append_varlabels(anl, "AEBODSYS")
    }

    lyt <- lyt %>%
      count_occurrences(
        vars = "AEDECOD",
        .indent_mods = c(count_fraction = 1L)
        # , .formats = list(trim_perc1)
      ) %>%
      append_topleft(paste("  ", formatters::var_labels(anl["AEDECOD"]), "N (%)"))

    if (soc == "soc") {
      sort_path <- c("AEBODSYS", "*", "AEDECOD")
    } else {
      sort_path <- c("AEDECOD")
    }

    # this is an add hoc test check
    myh_col_indices <- function(table_row, col_names) {
      NULL
    }
    # environment(myh_col_indices) <- asNamespace("tern")
    # assignInNamespace("h_col_indices", myh_col_indices, ns = "tern")
    # result <- build_table(lyt = lyt, df = anl, alt_counts_df = adsl1)

    result <- lyt_to_side_by_side_two_data(lyt, anl, adsl1, side_by_side)

    result <- result %>%
      sort_at_path(
        path = sort_path,
        scorefun = score_occurrences
      )

    # criteria_fun <- function(tr) is(tr, "ContentRow")
    # result <- trim_rows(result, criteria = criteria_fun)

    if (diff) {
      row_condition <- has_fractions_difference(
        atleast = cutoff / 100,
        # col_names = levels(adsl1$TRT01A)
        col_indices = 1:2
      )
      if (length(levels(adsl1[[arm]])) > 2) {
        stop("More than two arms, not implemented yet")
      }
    } else if (prune_by_total) {
      if (is.null(side_by_side)) {
        row_condition <- has_fraction_in_any_col(
          atleast = cutoff / 100,
          col_indices = ncol(result)
        )
      } else if (!is.null(side_by_side)) {
        stop("I am not implemented yet")
      } else {
        row_condition <- has_fraction_in_any_col(
          atleast = cutoff / 100,
          col_indices = ncol(result)
        )
      }
    } else {
      row_condition <- has_fraction_in_any_col(
        atleast = cutoff / 100,
        col_names = levels(adsl1[[arm]])
      )
    }

    result1 <- prune_table(result, keep_rows(row_condition))
    # Viewer(result1)

    if (is.null(result1)) {
      return(null_report())
    } else {
      return(result1)
    }
  }
}

#' Plot mean values of EG
#'
#' Wrapper for `g_mean_general()`.
#' Requires filtering of the datasets (e.g. using SUFFIX in spec.yml)
#'
#' @param adsl ADSL data
#' @param adeg ADVS data
#' @param arm `"TRT01P"` by default
#' @param paramcd Which variable to use for plotting. By default `"PARAM"`
#' @inheritParams g_mean_general
#' @param ... |
#' Gets forwarded to `tern::g_lineplot()`.
#' This lets you specify additional arguments to `tern::g_lineplot()`
#' @author Stefan Thoma (`thomas7`)
#' @importFrom forcats fct_reorder
#' @export
#' @examplesIf require('rsvg')
#' library(dplyr)
#'
#' adeg_filtered <- eg_adeg %>% filter(
#'   PARAMCD == "HR"
#' )
#' plot_eg <- g_eg_slide(
#'   adsl = eg_adsl,
#'   adeg = adeg_filtered,
#'   arm = "TRT01P",
#'   paramcd = "PARAM",
#'   subtitle_add_unit = FALSE
#' ) +
#'   ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))
#'
#' generate_slides(plot_eg, paste0(tempdir(), "/g_eg.pptx"))
g_eg_slide <- function(adsl, adeg, arm = "TRT01P", paramcd = "PARAM",
                       subtitle = "Plot of Mean and 95% Confidence Limits by Visit.", ...) {
  # tern 0.9.4 added facet_var in control_lineplot_vars
  variables <- control_lineplot_vars(group_var = arm, paramcd = paramcd) %>% strip_NA()
  by_vars <- c("USUBJID", "STUDYID")
  assert_that(is.string(arm))
  assert_that(has_name(adeg, c(by_vars, variables) %>% unique()))
  assert_that(has_name(adsl, c(by_vars, arm) %>% unique()))
  assert_that(is.string(subtitle))

  g_mean_general(
    adsl = adsl, data = adeg, variables = variables, by_vars = by_vars,
    subtitle = subtitle, ...
  )
}

#' Determine Slide Insertion Page Number
#'
#' Computes the appropriate page number at which to insert a new slide into the PowerPoint deck.
#' Defaults to appending to the end if no value is provided.
#'
#' @param doc_original An `officer::rpptx` object representing the PowerPoint file.
#' @param to_page Desired slide index to insert the new slide. If `NA`, appends to the last page.
#'
#' @return A single integer value indicating the validated page number for slide insertion.
#'
#' @export
#'
#' @examples
#' tmp <- tempfile(fileext = ".pptx")
#' doc <- officer::read_pptx()
#' doc <- officer::add_slide(doc, layout = "Title Slide", master = "Office Theme")
#' print(doc, target = tmp)
#' doc <- officer::read_pptx(tmp)
#' initialize_to_page(doc, NA) # append to end
#' initialize_to_page(doc, 1) # insert at page 1
initialize_to_page <- function(doc_original, to_page) {
  max_pages <- length(doc_original)
  if (max_pages == 0) {
    max_pages <- 1
  }
  if (is.na(to_page)) {
    to_page <- max_pages
  }

  assert_that((max_pages + 1) >= to_page)
  to_page
}

#' Post-process PowerPoint Document
#'
#' Performs final actions on the PowerPoint object, including optionally saving the updated file.
#' The saved filename includes a suffix indicating the slide type that was appended.
#'
#' @param doc An `officer::rpptx` object to finalize.
#' @param save_file A boolean indicating whether to save the file to disk.
#' @param doc_o Original PowerPoint file path.
#' @param type A string suffix to label the output file, e.g., `"cohort_sec"` or `"safety_sum_sec"`.
#'
#' @return The modified `officer::rpptx` object.
#'
#' @export
#'
#' @examples
#' tmp <- tempfile(fileext = ".pptx")
#' doc <- officer::read_pptx()
#' doc <- officer::add_slide(doc, layout = "Title Slide", master = "Office Theme")
#' print(doc, target = tmp)
#' doc <- officer::read_pptx(tmp)
#' # Call postprocessing_doc to save a modified version of doc
#' postprocessing_doc(doc, TRUE, tmp, type = "final")
postprocessing_doc <- function(doc, save_file, doc_o, type = "") {
  if (save_file) {
    doc_dir <- dirname(doc_o)
    doc_base_name <- tools::file_path_sans_ext(basename(doc_o))

    doc_ext <- tools::file_ext(basename(doc_o))
    outfile_name <- paste0(doc_base_name, "_", type, ".", doc_ext)

    # Combine the directory with the new filename to get the full output path
    outfile_final <- file.path(doc_dir, outfile_name)
    print(doc, outfile_final)
  }

  return(doc)
}


#' Initialize PowerPoint Document Object
#'
#' This function ensures a PowerPoint document (`officer::rpptx` object) is loaded.
#' If a `doc_original` is provided, it is directly returned. Otherwise, the function reads
#' the presentation from the given file path.
#'
#' @param doc_original An existing `officer::rpptx` object, or `NULL` to read from file.
#' @param doc_o Path to a PowerPoint (`.pptx`) file. Used only if `doc_original` is `NULL`.
#'
#' @return An `officer::rpptx` PowerPoint object.
#'
#' @export
#'
#' @examples
#' example <- tempfile(fileext = ".pptx")
#' doc <- officer::read_pptx()
#' doc <- officer::add_slide(doc, layout = "Title and Content")
#' print(doc, target = example)
#' doc <- initialize_doc_original(NULL, example)
initialize_doc_original <- function(doc_original, doc_o) {
  if (is.null(doc_original)) {
    doc_original <- officer::read_pptx(doc_o)
  }
  doc_original
}


#' Append Title Slides to a PowerPoint Document
#'
#' This function adds a new title slide using a "Title and Content" layout
#' from the "Office Theme".
#'
#' @param doc_o Path to a PowerPoint (`.pptx`) file. Used to initialize the document
#'   if `doc_original` is `NULL`.
#' @param study_id A character string that represent your study identifier.
#' @param to_page An integer specifying the page number where the new slide should be moved.
#' @param doc_original An optional existing `officer::rpptx` object. If `NULL`,
#'   the document is initialized from `doc_o`.
#' @param save_file A logical value. If `TRUE`, the modified document is saved to a file
#'   after adding the slide.
#'
#' @return An `officer::rpptx` object with the new title slide appended.
#'
#' @export
#'
#' @examples
#'
#' tmp <- tempfile(fileext = ".pptx")
#' doc <- officer::read_pptx()
#' doc <- officer::add_slide(doc, layout = "Title Slide", master = "Office Theme")
#' print(doc, target = tmp)
#'
#' doc <- append_title_slides(
#'   doc_o = tmp,
#'   study_id = "My Study #13",
#'   to_page = 1,
#'   save_file = TRUE
#' )
append_title_slides <- function(
    doc_o,
    study_id = "XXXX change me",
    to_page = NA,
    doc_original = NULL,
    save_file = FALSE) {
  doc_original <- initialize_doc_original(doc_original, doc_o)

  to_page <- initialize_to_page(doc_original, to_page)

  doc <- doc_original %>%
    officer::add_slide(layout = "Title and Content", master = "Office Theme") %>%
    officer::ph_with(
      value = paste0(study_id, "Meeting"),
      location = officer::ph_location_type(type = "title")
    ) %>%
    officer::ph_with(
      value = paste0("meeting"),
      location = officer::ph_location_type(type = "body")
    ) %>%
    officer::move_slide(to = to_page)

  postprocessing_doc(doc, save_file, doc_o, type = "title")

  return(doc)
}



#' Append Section Header Slides to a PowerPoint Document
#'
#' This function adds a new section header slide to an existing PowerPoint document
#' using a "Section Header" layout from the "Office Theme".
#' It populates the title placeholder with the provided section title.
#'
#' @param doc_o Path to a PowerPoint (`.pptx`) file. Used to initialize the document
#'   if `doc_original` is `NULL`, and for post-processing.
#' @param section_title A character string for the title of the section header slide.
#'   Defaults to "New Section".
#' @param to_page An integer specifying the page number where the new slide should be moved.
#'   If `NA`, the slide is added at the end and `initialize_to_page` determines its final position.
#' @param doc_original An optional existing `officer::rpptx` object. If `NULL`,
#'   the document is initialized from `doc_o`.
#' @param save_file A logical value. If `TRUE`, the modified document is saved to a file
#'   after adding the slide.
#'
#' @return An `officer::rpptx` object with the new section header slide appended.
#'
#' @export
#'
#' @examples
#'
#' tmp <- tempfile(fileext = ".pptx")
#' doc <- officer::read_pptx()
#' print(doc, target = tmp)
#'
#' append_section_header_slides(
#'   doc_o = tmp,
#'   section_title = "My Section",
#'   to_page = 1,
#'   save_file = TRUE
#' )
append_section_header_slides <- function(
    doc_o,
    section_title = "New Section",
    to_page = NA,
    doc_original = NULL,
    save_file = FALSE) {
  doc_original <- initialize_doc_original(doc_original, doc_o)

  to_page <- initialize_to_page(doc_original, to_page)

  doc <- doc_original %>%
    officer::add_slide(layout = "Section Header", master = "Office Theme") %>%
    officer::ph_with(
      value = section_title,
      location = officer::ph_location_type(type = "title")
    ) %>%
    officer::move_slide(to = to_page)

  postprocessing_doc(doc, save_file, doc_o, type = "section_header")

  return(doc)
}

#' Append All Predefined Slides to a PowerPoint Document
#'
#' This function orchestrates the appending of a series of predefined slides
#' (including title and section header slides) to a PowerPoint document based
#' on a provided page list.
#'
#' @param doc_o Path to a PowerPoint (`.pptx`) file. Used to initialize the document
#'   if `doc_original` is `NULL`, and for final post-processing.
#' @param page_list A list of slide definitions. Each element in the list should be
#'   another list containing:
#'   - `type`: A character string indicating the type of slide ("title" or "section").
#'   - `to_page`: An integer specifying the target page number for the slide.
#'   - Other arguments specific to the slide type (e.g., `study_id` for "title" slides,
#'     `section_title` for "section" slides).
#' @param doc_original An optional existing `officer::rpptx` object. If `NULL`,
#'   the document is initialized from `doc_o`.
#' @param save_file A logical value. If `TRUE`, the final modified document is saved
#'   to a file after all slides have been appended.
#'
#' @return An `officer::rpptx` object with all specified slides appended.
#'
#' @export
#' @examples
#' tmp <- tempfile(fileext = ".pptx")
#' doc <- officer::read_pptx()
#' print(doc, target = tmp)
#'
#' my_page_list <- list(
#'   list(type = "title", to_page = 1, study_id = "My Project"),
#'   list(type = "section", to_page = 2, section_title = "Introduction"),
#'   list(type = "title", to_page = 3, study_id = "Mid-Term Review"),
#'   list(type = "section", to_page = 4, section_title = "Key Findings")
#' )
#'
#' # Append all slides using the dynamic page_list
#' doc <- append_all_slides(
#'   doc_o = tmp,
#'   page_list = my_page_list,
#'   save_file = TRUE
#' )
append_all_slides <- function(
    doc_o,
    page_list = list(), # Default to an empty list
    doc_original = NULL,
    save_file = FALSE) {
  doc <- initialize_doc_original(doc_original, doc_o)


  for (page in page_list) {
    current_to_page <- page$to_page


    if (page$type == "title") {
      doc <- append_title_slides(
        doc_o = doc_o,
        doc_original = doc,
        to_page = current_to_page,
        study_id = page$study_id,
        save_file = FALSE
      )
    } else if (page$type == "section") {
      doc <- append_section_header_slides(
        doc_o = doc_o,
        doc_original = doc,
        to_page = current_to_page,
        section_title = page$section_title,
        save_file = FALSE
      )
    }
  }

  postprocessing_doc(doc, save_file, doc_o, type = "final")

  return(doc)
}

#' Generate output and apply filters, titles, and footnotes
#'
#' @param program program name
#' @param datasets list of datasets
#' @param spec spec
#' @param verbose_level Verbose level of messages be displayed. See details for further information.
#' @return No return value, called for side effects
#' @details
#' `verbose_level` is used to control how many messages are printed out.
#' By default, `2` will show all filter messages and show output generation message.
#' `1` will show output generation message only.
#' `0` will display no message.
#' @param ... arguments passed to program
#'
#' @author Liming Li (`Lil128`)
#'
#' @export
#'
#' @examplesIf require(filters)
#' library(dplyr)
#' filters::load_filters(
#'   yaml_file = system.file("filters.yml", package = "autoslider.core"),
#'   overwrite = TRUE
#' )
#'
#' spec_file <- system.file("spec.yml", package = "autoslider.core")
#' spec <- spec_file %>% read_spec()
#'
#' data <- list(
#'   adsl = eg_adsl,
#'   adae = eg_adae
#' )
#' generate_output("t_ae_slide", data, spec$t_ae_slide_SE)
#'
generate_output <-
  function(program,
           datasets,
           spec,
           verbose_level = 2,
           ...) {
    suffix <- spec$suffix
    if (verbose_level > 0) {
      cat_bullet(
        sprintf(
          "Running program `%s` with suffix '%s'.",
          program,
          suffix
        ),
        bullet = "pointer",
        bullet_col = "green"
      )
    }
    func <- tryCatch(
      {
        func_wrapper(
          func = match.fun(program),
          datasets = datasets,
          spec = spec,
          verbose = verbose_level > 1
        )
      },
      error = function(e) {
        info <- e$message
        if (verbose_level > 0) {
          cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red")
        }
        autoslider_error(info, spec = spec, step = "filter dataset")
      }
    )
    if (is(func, "autoslider_error")) {
      return(func)
    }
    ret <- tryCatch(
      {
        func(...)
      },
      error = function(e) {
        info <- e$message
        if (verbose_level > 0) {
          cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red")
        }
        autoslider_error(info, spec = spec, step = "user program")
      }
    )
    return(ret)
  }

#' Generate all outputs from a spec
#'
#' @param spec Specification list generated by `read_spec`
#' @param datasets A `list` of datasets
#' @param verbose_level Verbose level of messages be displayed. See details for further information.
#' @return No return value, called for side effects
#' @details
#' `verbose_level` is used to control how many messages are printed out.
#' By default, `2` will show all filter messages and show output generation message.
#' `1` will show output generation message only.
#' `0` will display no message.
#'
#' @author
#' - Thomas Neitmann (`neitmant`)
#' - Liming Li (`Lil128`)
#'
#' @export
#'
#' @examplesIf require(filters)
#' library(dplyr, warn.conflicts = FALSE)
#' data <- list(
#'   adsl = eg_adsl,
#'   adae = eg_adae
#' )
#' filters::load_filters(
#'   yaml_file = system.file("filters.yml", package = "autoslider.core"),
#'   overwrite = TRUE
#' )
#'
#' spec_file <- system.file("spec.yml", package = "autoslider.core")
#' spec_file %>%
#'   read_spec() %>%
#'   filter_spec(output %in% c("t_dm_slide_IT", "t_ae_slide_SE")) %>%
#'   generate_outputs(datasets = data)
#'
generate_outputs <- function(spec, datasets, verbose_level = 2) {
  lapply(spec, function(s) {
    args <- c(
      list(
        program = s$program,
        spec = s,
        datasets = datasets,
        verbose_level = verbose_level
      ),
      s$args # ... arguments passed onto the output-generating function
    )
    output <- fastDoCall(generate_output, args)
    attr(output, "spec") <- s
    output
  })
}

#' generic function decorate
#' @return No return value, called for side effects
#' @export
setGeneric("decorate", function(x, ...) standardGeneric("decorate"))

#' s3 method for decorate
#' @param x object to decorate
#' @param ... additional arguments passed to methods
decorate <- function(x, ...) {
  UseMethod("decorate")
}

#' default method to decorate
#' @param x object to decorate
#' @param ... additional arguments. not used.
#' @return No return value, called for side effects
#' @export
decorate.default <- function(x, ...) {
  stop("default decorate function does not exist")
}

#' decorate method for autoslider_error class
#' @param x object to decorate
#' @param ... additional arguments. not used.
#' @return No return value, called for side effects
#' @export
decorate.autoslider_error <- function(x, ...) {
  x
}

#' Decorate TableTree
#'
#' @param x A VTableTree object representing the data to be decorated.
#' @param titles Title to be added to the table.
#' @param footnotes Footnote to be added to the table
#' @param paper Orientation and font size as string, e.g. "P8"; "L11"
#' @param for_test `logic` CICD parameter
#' @param ... Additional arguments passed to the decoration function.
#' @return No return value, called for side effects
#' @export
setMethod(
  "decorate", "VTableTree",
  decorate.VTableTree <- function(x, titles = "", footnotes = "", paper = "P8", for_test = FALSE, ...) {
    width_set <- attr(x, "width")
    tmp_x <- formatters::matrix_form(x)

    if (is.null(width_set)) {
      width <- formatters::propose_column_widths(tmp_x)
    } else {
      width <- ifelse(is.na(width_set), formatters::propose_column_widths(tmp_x), width_set)
    }

    glued_title <- glue::glue(paste(titles, collapse = "\n"))
    main_title(x) <- glued_title

    git_fn <- git_footnote(for_test)
    glued_footnotes <- glue::glue(paste(c(footnotes, git_fn), collapse = "\n"))
    main_footer(x) <- glued_footnotes

    new(
      "dVTableTree",
      tbl = x,
      titles = glued_title,
      footnotes = footnotes,
      usernotes = "",
      paper = paper,
      width = width
    )
  }
)


#' Decorate ggplot object
#'
#' @param x An object to decorate
#' @param titles Plot titles
#' @param footnotes Plot footnotes
#' @param paper Paper size, by default "L11"
#' @param for_test `logic` CICD parameter
#' @param ... additional arguments. not used.
#' @return No return value, called for side effects
#' @export
#' @details
#' The paper default paper size, `L11`, indicate that the fontsize is 11.
#' The fontsize of the footnotes, is the fontsize of the titles minus 2.
decorate.ggplot <- function(x, titles = "", footnotes = "", paper = "L11", for_test = FALSE, ...) {
  glued_title <- glue::glue(paste(titles, collapse = "\n"))
  # main_title(x) <- glued_title

  git_fn <- git_footnote(for_test)
  glued_footnotes <- glue::glue(paste(c(footnotes, git_fn), collapse = "\n"))
  # main_footer(x) <- glued_footnotes

  ret <- list(
    grob = ggplot2::ggplotGrob(x),
    titles = glued_title,
    footnotes = footnotes,
    usernotes = "",
    paper = paper,
    for_test = for_test
  )
  class(ret) <- "decoratedGrob"
  return(ret)
}


#' decorate listing
#'
#' @param x A listing_df object representing the data to be decorated.
#' @param titles Title to be added to the table.
#' @param footnotes Footnote to be added to the table
#' @param paper Orientation and font size as string, e.g. "P8"; "L11"
#' @param for_test `logic` CICD parameter
#' @param ... Additional arguments. not used.
#' @return No return value, called for side effects
#' @export
setMethod(
  "decorate", "listing_df",
  decorate.listing_df <- function(x, titles = "", footnotes = "", paper = "P8", for_test = FALSE, ...) {
    width_set <- attr(x, "width")
    tmp_x <- formatters::matrix_form(x)

    if (is.null(width_set)) {
      width <- formatters::propose_column_widths(tmp_x)
    } else {
      width <- ifelse(is.na(width_set), formatters::propose_column_widths(tmp_x), width_set)
    }

    glued_title <- glue::glue(paste(titles, collapse = "\n"))
    main_title(x) <- glued_title

    git_fn <- git_footnote(for_test)
    glued_footnotes <- glue::glue(paste(c(footnotes, git_fn), collapse = "\n"))
    main_footer(x) <- glued_footnotes
    new(
      "dlisting",
      lst = x,
      titles = glued_title,
      footnotes = footnotes,
      usernotes = "",
      paper = paper,
      width = width
    )
  }
)




#' decorate grob
#' @param x object to decorate
#' @param titles graph titles
#' @param footnotes graph footnotes
#' @param paper paper size. default is "L8".
#' @param for_test `logic` CICD parameter
#' @param ... Additional arguments. not used.
#' @return No return value, called for side effects
#' @details
#' The paper default paper size, `L11`, indicate that the fontsize is 11.
#' The fontsize of the footnotes, is the fontsize of the titles minus 2.
#' @export
#'
decorate.grob <-
  function(x, titles = "", footnotes = "", paper = "L11", for_test = FALSE, ...) {
    size <- fs(paper)
    grob <- tern::decorate_grob(
      grob = x,
      titles = glue::glue(paste(titles, collapse = "\n")),
      footnotes = c(glue::glue(paste(footnotes, collapse = "\n")), git_footnote(for_test), datetime()),
      border = FALSE,
      gp_titles = gpar(fontsize = size$fontsize),
      gp_footnotes = gpar(fontsize = size$fontsize - 2)
    )
    attr(grob, "paper") <- ifelse(size$orientation == "P", "a4", "a4r")
    grob
  }

#' decorate gtsummary
#'
#' @param x gtsummary object to decorate
#' @param titles graph titles
#' @param footnotes graph footnotes
#' @param paper paper size. default is "L8".
#' @param for_test `logic` CICD parameter
#' @param ... Additional arguments. not used.
#' @return No return value, called for side effects
#' @details
#' The paper default paper size, `L11`, indicate that the fontsize is 11.
#' The fontsize of the footnotes, is the fontsize of the titles minus 2.#'
#' @export
decorate.gtsummary <-
  function(x, titles = "", footnotes = "", paper = "L11", for_test = FALSE, ...) {
    size <- fs(paper)
    glued_title <- glue::glue(paste(titles, collapse = "\n"))
    x <- x %>% modify_caption(caption = "")
    structure(
      .Data = x,
      titles = glued_title,
      paper = paper,
      class = union("dgtsummary", class(x))
    )
  }
# )

#' decorate list of grobs
#' @param x object to decorate
#' @param titles graph titles
#' @param footnotes graph footnotes
#' @param paper paper size. default is "L11".
#' @param for_test `logic` CICD parameter
#' @param ... additional arguments. not used
#' @details
#' The paper default paper size, `L11`, indicate that the fontsize is 11.
#' The fontsize of the footnotes, is the fontsize of the titles minus 2.
#' @return No return value, called for side effects
#' @export
#'
decorate.list <-
  function(x, titles, footnotes, paper = "L11", for_test = FALSE, ...) {
    stopifnot(all(vapply(x, function(x) {
      "grob" %in% class(x) || "ggplot" %in% class(x)
    }, FUN.VALUE = TRUE)))
    size <- fs(paper)
    x <- lapply(x, function(g) {
      ret <- g
      if ("ggplot" %in% class(g)) {
        ret <- ggplot2::ggplotGrob(g)
      }
      ret
    })
    grobs <- decorate_grob_set(
      grobs = x,
      titles = glue::glue(paste(titles, collapse = "\n")),
      footnotes = c(glue::glue(paste(footnotes, collapse = "\n")), git_footnote(for_test), datetime()),
      border = FALSE,
      gp_titles = gpar(fontsize = size$fontsize),
      gp_footnotes = gpar(fontsize = size$fontsize - 2)
    )
    structure(
      .Data = grobs,
      paper = ifelse(size$orientation == "P", "a4", "a4r"),
      class = union("decoratedGrobSet", class(grobs))
    )
  }

#' Decorate outputs
#'
#' Decorate outputs with titles and footnotes
#'
#' @param outputs `list` of output objects as created by `generate_outputs`
#' @param generic_title `character` vector of titles
#' @param generic_footnote `character` vector of footnotes
#' @param version_label `character`. A version label to be added to the title.
#' @param for_test `logic` CICD parameter
#' @return No return value, called for side effects
#' @details
#' `generic_title` and `generic_footnote` will be added to *all* outputs. The use
#' case is to add information such as protocol number and snapshot date defined
#' in a central place (e.g. metadata.yml) to *every* output.
#'
#' `version_label` must be either `"DRAFT"`, `"APPROVED"` or `NULL`. By default,
#' when outputs are created on the master branch it is set to `NULL`, i.e. no
#' version label will be displayed. Otherwise `"DRAFT"` will be added. To add
#' `"APPROVED"` to the title you will need to explicitly set `version_label = "APPROVED"`.
#'
#' @export
decorate_outputs <- function(outputs,
                             generic_title = NULL,
                             generic_footnote = "Confidential and for internal use only",
                             version_label = get_version_label_output(),
                             for_test = FALSE) {
  assert_is_valid_version_label(version_label)

  lapply(outputs, function(output) {
    if (is(output, "autoslider_error")) {
      return(output)
    }

    spec <- attr(output, "spec")

    filter_titles <- function(...) {
      if (length(c(...)) == 0 || "all" %in% c(...)) {
        r <- vapply(
          filters::get_filters(spec$suffix),
          FUN = `[[`,
          FUN.VALUE = character(1L),
          "title"
        )
      } else {
        r <- vapply(
          Filter(
            f = function(x) any(x$target %in% toupper(c(...))),
            x = filters::get_filters(spec$suffix)
          ),
          FUN = `[[`,
          FUN.VALUE = character(1L),
          "title"
        )
      }
      paste(r, collapse = ", ")
    }

    pattern <- "\\{filter_titles\\(((\"\\w+\")(,\\s*\"\\w+\")*){0,1}\\)\\}"
    if (grepl(pattern, spec$titles)) {
      m <- regmatches(spec$titles, regexpr(pattern, spec$titles))
      full_title <- paste(
        version_label,
        sub(pattern = pattern, eval(parse(text = m)), spec$titles)
      )
    } else {
      full_title <- paste(
        paste(version_label, spec$titles),
        filter_titles("ADSL"),
        sep = ", "
      )
    }

    if ("ggplot" %in% class(output)) {
      decorate.ggplot(output, titles = full_title)
    } else if ("grob" %in% class(output)) {
      decorate.grob(output)
    } else {
      structure(
        .Data = decorate(
          x = output,
          title = c(full_title, generic_title),
          footnotes = c(spec$footnotes, generic_footnote),
          paper = spec$paper,
          for_test = for_test
        ),
        spec = modifyList(spec, list(titles = glue::glue(paste0(c(full_title, generic_title), collapse = "\n"))))
      )
    }
  })
}

#' Print decorated grob
#'
#' @param x An object of class `decoratedGrob`
#' @param ... not used.
#' @return No return value, called for side effects
#' @export
print.decoratedGrob <- function(x, ...) {
  grid::grid.newpage()
  grid::grid.draw(x)
}

#' Print decorated grob set
#'
#' @param x An object of class `decoratedGrobSet`
#' @param ... not used.
#' @return No return value, called for side effects
#' @export
print.decoratedGrobSet <- function(x, ...) {
  for (plot in x) {
    grid::grid.newpage()
    grid::grid.draw(plot)
  }
}

#' Death table
#'
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character, "`TRT01A" by default.
#' @param split_by_study Split by study, building structured header for tables
#' @param side_by_side used for studies in China. "GlobalAsia" or "GlobalAsiaChina" to define
#' the side by side requirement.
#' @return rtables object
#' @inherit gen_notes note
#' @export
#' @examples
#' library(dplyr)
#' adsl <- eg_adsl %>% preprocess_t_dd()
#' out1 <- t_dd_slide(adsl, "TRT01A")
#' print(out1)
#' generate_slides(out1, paste0(tempdir(), "/dd.pptx"))
#'
#' out2 <- t_dd_slide(adsl, "TRT01A", split_by_study = TRUE)
#' print(out2)
t_dd_slide <- function(adsl,
                       arm = "TRT01A",
                       split_by_study = FALSE,
                       side_by_side = NULL) {
  assert_that(has_name(adsl, "DTHCAT"))
  assert_that(has_name(adsl, "DTHFL"))

  anl <- adsl

  if (!is.null(side_by_side)) {
    anl$lvl <- "Global"
  }

  if (nrow(anl) == 0) {
    return(null_report())
  } else {
    lyt <- build_table_header(adsl, arm, split_by_study = split_by_study, side_by_side = side_by_side)

    lyt <- lyt %>%
      count_values(
        "DTHFL",
        values = "Y",
        denom = c("N_col"),
        .labels = c(count_fraction = "All Deaths")
      ) %>%
      analyze_vars(
        vars = "DTHCAT", .stats = "count_fraction",
        na_str = "<Missing>",
        var_labels = " ",
        na.rm = TRUE
      ) %>%
      # count_patients_with_flags(
      #   "USUBJID",
      #   flag_variables = formatters::var_labels(anl[,c("DTHCAT1", "DTHCAT2", "DTHCAT3")]),
      #   .indent_mods = 1L,
      #   .format = list(trim_perc1),
      #   denom = "n"
      # ) %>%
      append_topleft("N (%)")

    result <- lyt_to_side_by_side(lyt, anl, side_by_side)
    result@main_title <- "Death table"
    result
  }
}

#' function wrapper to pass filtered data
#' @param func function name
#' @param datasets list of raw datasets
#' @param spec spec
#' @param verbose whether to show verbose information
#' @return a wrapped function using filtered adam
func_wrapper <-
  function(func, datasets, spec, verbose = TRUE) {
    suffix <- spec$suffix
    function_args <- names(formals(func))
    datasets_filtered <- filters::apply_filter(
      data = datasets,
      id = suffix,
      verbose = verbose
    )

    if ("datasets" %in% function_args) {
      if ("spec" %in% function_args) {
        return({
          function(...) {
            fastDoCall(func, list(datasets_filtered, spec = spec, ...))
          }
        })
      } else {
        return({
          function(...) {
            fastDoCall(func, list(datasets_filtered, ...))
          }
        })
      }
    } else {
      # to keep compatibility with previous version
      data_used <-
        function_args[function_args %in% names(datasets)]
      if ("spec" %in% function_args) {
        return({
          function(...) {
            fastDoCall(func, c(
              datasets_filtered[data_used],
              list(spec = spec),
              list(...)
            ))
          }
        })
      } else {
        return({
          function(...) {
            fastDoCall(func, c(datasets_filtered[data_used], list(...)))
          }
        })
      }
    }
  }

#' Adverse event table
#'
#' @param adae ADAE data set, dataframe
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character, "`TRT01A" by default.
#' @param cutoff Cutoff threshold
#' @param split_by_study Split by study, building structured header for tables
#' @param side_by_side "GlobalAsia" or "GlobalAsiaChina" to define the side by side requirement
#' @return rtables object
#' @inherit gen_notes note
#' @export
#' @examples
#' library(dplyr)
#' adsl <- eg_adsl %>%
#'   dplyr::mutate(TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")))
#' adae <- eg_adae %>%
#'   dplyr::mutate(
#'     TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")),
#'     ATOXGR = AETOXGR
#'   )
#' out <- t_ae_pt_soc_diff_slide(adsl, adae, "TRT01A", 2)
#' print(out)
#' generate_slides(out, paste0(tempdir(), "/ae_diff.pptx"))
t_ae_pt_soc_diff_slide <- function(adsl, adae, arm = "TRT01A", cutoff = NA,
                                   split_by_study = FALSE, side_by_side = NULL) {
  cutoff <- check_and_set_cutoff(adae, cutoff)
  result <- t_ae_pt_core(adsl, adae, arm, cutoff,
    diff = TRUE, soc = "soc",
    prune_by_total = FALSE,
    split_by_study, side_by_side
  )
  result@main_title <- "Adverse Events with Difference"

  if (is.null(side_by_side)) {
    # adding "N" attribute
    arm <- col_paths(result)[[1]][1]

    n_r <- data.frame(
      ARM = toupper(names(result@col_info)),
      N = col_counts(result) %>% as.numeric()
    ) %>%
      `colnames<-`(c(paste(arm), "N")) %>%
      arrange(get(arm))

    attr(result, "N") <- n_r
  }
  result
}

#' Does do.call quicker, and avoids issues with debug mode within do.call
#' @description copied from ms showcase app
#' @param what either a function or a non-empty character string naming the function to be called.
#' @param args a list of arguments to the function call. The names attribute of args gives the argument names.
#' @param quote a logical value indicating whether to quote the arguments.
#' @param envir an environment within which to evaluate the call. This will be most useful if what is a character
#' string and the arguments are symbols or quoted expressions.
#' @return No return value, called for side effects
#' @export
fastDoCall <-
  function(what,
           args,
           quote = FALSE,
           envir = parent.frame()) {
    if (quote) {
      args <- lapply(args, enquote)
    }

    if (is.null(names(args))) {
      argn <- args
      args <- list()
    } else {
      # Add all the named arguments
      argn <- lapply(names(args)[names(args) != ""], as.name)
      names(argn) <- names(args)[names(args) != ""]
      # Add the unnamed arguments
      argn <- c(argn, args[names(args) == ""])
      args <- args[names(args) != ""]
    }

    if (is(what, "character")) {
      if (is.character(what)) {
        fn <- strsplit(what, "[:]{2,3}")[[1]]
        what <- if (length(fn) == 1) {
          get(fn[[1]], envir = envir, mode = "function")
        } else {
          get(fn[[2]], envir = asNamespace(fn[[1]]), mode = "function")
        }
      }
      call <- as.call(c(list(what), argn))
    } else if (is(what, "function")) {
      f_name <- deparse(substitute(what))
      call <- as.call(c(list(as.name(f_name)), argn))
      args[[f_name]] <- what
    } else if (is(what, "name")) {
      call <- as.call(c(list(what, argn)))
    }

    eval(call,
      envir = args,
      enclos = envir
    )
  }

#' Save an Output
#'
#' @param output Output object, e.g. an `rtable` or `grob`
#' @param file_name Full path of the new file *excluding* the extension
#' @param save_rds Saved as an `.rds` files
#' @details
#' Tables are saved as RDS file
#'
#' @return The input `object` invisibly
#' @export
#'
#' @examples
#' library(dplyr)
#' adsl <- eg_adsl %>%
#'   filter(SAFFL == "Y") %>%
#'   mutate(TRT01P = factor(TRT01P, levels = c("A: Drug X", "B: Placebo")))
#' output_dir <- tempdir()
#' t_dm_slide(adsl, "TRT01P", c("SEX", "AGE", "RACE", "ETHNIC", "COUNTRY")) %>%
#'   decorate(
#'     title = "Demographic table",
#'     footnote = ""
#'   ) %>%
#'   save_output(
#'     file_name = file.path(output_dir, "t_dm_SE"),
#'     save_rds = TRUE
#'   )
#'
setGeneric("save_output", function(output, file_name, save_rds) {
  standardGeneric("save_output")
})

#' @rdname save_output
save_output <- function(output, file_name, save_rds = TRUE) {
  UseMethod("save_output")
}

#' @rdname save_output
#' @return No return value, called for side effects
#' @export
save_output.autoslider_error <- function(output,
                                         file_name,
                                         save_rds = TRUE) {
  output
}

#' @rdname save_output
#' @aliases save_output, dVTableTree, dVTableTree-method
setMethod("save_output", "dVTableTree", save_output.dVTableTree <- function(output, file_name, save_rds = TRUE) {
  if (save_rds) {
    saveRDS(output, file = paste0(file_name, ".rds"))
  }

  invisible(output)
})

#' @rdname save_output
#' @return The input `object` invisibly
#' @export
save_output.decoratedGrob <- function(output,
                                      file_name,
                                      save_rds = TRUE) {
  if (save_rds) {
    saveRDS(output, file = paste0(file_name, ".rds"))
  }

  invisible(output)
}

#' @rdname save_output
#' @return The input `object` invisibly
#' @export
save_output.decoratedGrobSet <- function(output, file_name, save_rds = TRUE) {
  if (save_rds) {
    saveRDS(output, file = paste0(file_name, ".rds"))
  }

  invisible(output)
}


#' @rdname save_output
#' @return The input `object` invisibly
#' @export
save_output.dgtsummary <- function(output, file_name, save_rds = TRUE) {
  if (save_rds) {
    saveRDS(output, file = paste0(file_name, ".rds"))
  }

  invisible(output)
}

#' @rdname save_output
#' @return The input `object` invisibly
#' @export
save_output.dlisting <- function(output, file_name, save_rds = TRUE) {
  if (save_rds) {
    saveRDS(output, file = paste0(file_name, ".rds"))
  }

  invisible(output)
}


#' Save a list of outputs
#'
#' @param outputs `list` of outputs as created by `generate_outputs`
#' @param outfolder Folder in which to store the `outputs``
#' @param verbose_level Level of verbose information displayed.
#'        Default set to `1`.
#' @param save_rds Should the input `outputs` be saved as `.rds` files in
#'        in addition to `.out` or `.pdf` files? Defaults to `FALSE`.
#' @param generic_suffix generic suffix. must be length 1 character or NULL.
#' @export
#' @return The input `object` invisibly
#' @examplesIf require(filters)
#' ## As `save_outputs` is the last step in the pipeline we have to run
#' ## the 'whole machinery' in order to show its functionality.
#' library(dplyr, warn.conflicts = FALSE)
#'
#' data <- list(
#'   adsl = eg_adsl,
#'   adae = eg_adae,
#'   adtte = eg_adtte
#' )
#'
#' filters::load_filters(
#'   yaml_file = system.file("filters.yml", package = "autoslider.core"),
#'   overwrite = TRUE
#' )
#'
#' ## For this example the outputs will be saved in a temporary directory. In a
#' ## production run this should be the reporting event's 'output' folder instead.
#' output_dir <- tempdir()
#'
#' spec_file <- system.file("spec.yml", package = "autoslider.core")
#' read_spec(spec_file) %>%
#'   filter_spec(program == "t_dm_slide") %>%
#'   generate_outputs(datasets = data) %>%
#'   decorate_outputs() %>%
#'   save_outputs(outfolder = output_dir)
#'
save_outputs <- function(outputs,
                         outfolder = file.path("output"),
                         generic_suffix = NULL,
                         save_rds = TRUE,
                         verbose_level = 1) {
  stopifnot(is.list(outputs))

  if (!dir.exists(outfolder)) {
    dir.create(outfolder)
  }
  if (!is.null(generic_suffix)) {
    if (!(is.character(generic_suffix) & length(generic_suffix) == 1)) {
      stop("generic suffix must be length 1 character!")
    }
  }
  ret <- lapply(outputs, function(output) {
    spec <- attr(output, "spec")
    file_path <- file.path(outfolder, spec$output)
    file_path <- paste0(c(file_path, generic_suffix), collapse = "_")
    output <- save_output(
      output = output,
      file_name = file_path,
      save_rds = save_rds
    )

    if (verbose_level > 0) {
      if (is(output, "autoslider_error")) {
        cat_bullet(
          "Saving output ",
          attr(output, "spec")$output,
          " failed in step ",
          attr(output, "step"),
          " with error message: ",
          toString(output),
          bullet = "cross",
          bullet_col = "red"
        )
      } else {
        cat_bullet(
          "Output saved in path ",
          file_path,
          bullet = "tick",
          bullet_col = "green"
        )
      }
    }

    attr(output, "outpath") <- get_output_file_ext(output, file_path)
    output
  })

  if (verbose_level > 0) {
    total_number <- length(ret)
    fail_number <- sum(map_lgl(ret, is, class2 = "autoslider_error"))
    log_success_infomation(total_number - fail_number, fail_number)
  }

  ret
}


#' Generate slides from rds files
#' @param filenames List of file names
#' @param template Template file path
#' @param outfile Out file path
#' @return No return value, called for side effects
#'
#' @export
#' @examplesIf require(filters)
#' library(dplyr, warn.conflicts = FALSE)
#'
#' data <- list(
#'   adsl = eg_adsl,
#'   adae = eg_adae,
#'   adtte = eg_adtte
#' )
#'
#' filters::load_filters(
#'   yaml_file = system.file("filters.yml", package = "autoslider.core"),
#'   overwrite = TRUE
#' )
#'
#' ## For this example the outputs will be saved in a temporary directory. In a
#' ## production run this should be the reporting event's 'output' folder instead.
#' output_dir <- tempdir()
#'
#' spec_file <- system.file("spec.yml", package = "autoslider.core")
#' read_spec(spec_file) %>%
#'   filter_spec(program == "t_dm_slide") %>%
#'   generate_outputs(datasets = data) %>%
#'   decorate_outputs() %>%
#'   save_outputs(outfolder = output_dir)
#'
#' slides_from_rds(list.files(file.path(output_dir, "t_dm_slide_FAS.rds")))
slides_from_rds <- function(filenames, outfile = paste0(tempdir(), "/output.pptx"),
                            template = file.path(system.file(package = "autoslider.core"), "theme/basic.pptx")) {
  outputs <- lapply(filenames, readRDS)
  generate_slides(outputs, outfile, template)
}

log_success_infomation <- function(success, failure) {
  total_number <- success + failure
  cat_bullet(
    "Total number of success ",
    success,
    "/",
    total_number,
    bullet = "tick",
    bullet_col = "green"
  )
  if (failure > 0) {
    cat_bullet(
      "Total number of failures ",
      failure,
      "/",
      total_number,
      bullet = "cross",
      bullet_col = "red"
    )
  }
}

log_number_of_matched_records <- function(original_spec,
                                          filtered_spec,
                                          condition) {
  if (length(filtered_spec)) {
    msg <- sprintf(
      "%d/%d outputs matched the filter condition `%s`.",
      length(filtered_spec),
      length(original_spec),
      deparse(condition)
    )
    cat_bullet(msg, bullet = "tick", bullet_col = "green")
  } else {
    msg <- sprintf(
      "No output matched the filter condition `%s`",
      deparse(condition)
    )
    cat_bullet(msg, bullet = "cross", bullet_col = "red")
  }
}

#' Table color and font
#'
#' @description Zebra themed color
#'
#' @name autoslider_format
NULL

#' @describeIn autoslider_format
#'
#' User defined color code and font size
#'
#' @param ft flextable object
#' @param odd_header Hex color code, default to deep sky blue
#' @param odd_body Hex color code, default to alice blue
#' @param even_header Hex color code, default to slate gray
#' @param even_body Hex color code, default to slate gray
#' @param font_name Font name, default to arial
#' @param body_font_size Font size of the table content, default to 12
#' @param header_font_size Font size of the table header, default to 14
#' @return A flextable with applied theme.
#' @export
autoslider_format <- function(ft,
                              odd_header = "#0EAED5", # "deepskyblue2",
                              odd_body = "#EBF5FA", # "aliceblue",
                              even_header = "#0EAED5", # "slategray1",
                              even_body = "#D0E4F2", # "slategray1" # slategray1,
                              font_name = "arial",
                              body_font_size = 12,
                              header_font_size = 14) {
  ft %>%
    theme_zebra(
      odd_header = odd_header,
      odd_body = odd_body,
      even_header = odd_header,
      even_body = even_body
    ) %>%
    font(fontname = font_name, part = "all") %>%
    fontsize(size = body_font_size, part = "body") %>%
    color(color = "white", part = "header") %>%
    fontsize(size = header_font_size, part = "header") %>%
    bold(part = "header")
}


#' @describeIn autoslider_format
#'
#' Blue color theme
#'
#' @param ft flextable object
#' @param ... arguments passed to program
#'
#' @export
blue_format <- function(ft, ...) {
  ft %>% autoslider_format(
    odd_header = "#0B41CD",
    odd_body = "#1482FA",
    even_body = "#BDE3FF",
    ...
  )
}

#' @describeIn autoslider_format
#'
#' Orange color theme
#'
#' @param ft flextable object
#' @param ... arguments passed to program
#'
#' @export
orange_format <- function(ft, ...) {
  ft %>% autoslider_format(
    odd_header = "#ED4A0D",
    odd_body = "#FF7D29",
    even_body = "#FFBD69",
    ...
  )
}

#' @describeIn autoslider_format
#'
#' Red color theme
#'
#' @param ft flextable object
#' @param ... arguments passed to program
#'
#' @export
red_format <- function(ft, ...) {
  ft %>% autoslider_format(
    odd_header = "#C40000",
    odd_body = "#FF1F26",
    even_body = "#FF8782",
    ...
  )
}


#' @describeIn autoslider_format
#'
#' Purple color theme
#'
#' @param ft flextable object
#' @param ... arguments passed to program
#'
#' @export
purple_format <- function(ft, ...) {
  ft %>% autoslider_format(
    odd_header = "#BC36F0",
    odd_body = "#E085FC",
    even_body = "#F2D4FF",
    ...
  )
}

#' @describeIn autoslider_format
#'
#' `AutoslideR` dose formats
#'
#' @param ft flextable object
#' @param header_vals Header
#'
#' @export
autoslider_dose_format <- function(ft, header_vals = names(ft$body$dataset)) {
  # The original implementation used delete_rows and add_header_row, which can be
  # brittle. Using set_header_labels is the idiomatic and more robust way
  # to simply change the text of the header row. This avoids the colwidths error.
  ft %>%
    theme_booktabs() %>%
    # set_header_labels(values = header_vals) %>%
    bold(part = "header") %>%
    border_remove()
}


#' @describeIn autoslider_format
#'
#' Black color theme
#' @author Nina Qi and Jasmina Uzunovic
#' @param ft flextable object
#' @param ... arguments passed to program
#'
#' @export
black_format_tb <- function(ft, body_font_size = 8, header_font_size = 8, ...) {
  ft %>%
    theme_booktabs() %>%
    fontsize(size = body_font_size, part = "body") %>%
    fontsize(size = header_font_size, part = "header") %>%
    bold(part = "header") %>%
    color(color = "blue", part = "header") %>%
    border_inner_h(part = "all", border = fp_border(color = "black")) %>%
    hline_top(part = "all", border = fp_border(color = "black", width = 2)) %>%
    hline_bottom(part = "all", border = fp_border(color = "black", width = 2))
}

#' Plot mean values general function
#' used by wrappers `g_vs_slide`,`g_lb_slide`, & `g_eg_slide`
#'
#' adapted from https://insightsengineering.github.io/tlg-catalog/stable/graphs/other/mng01.html
#'
#' @param adsl ADSL dataset
#' @param data dataset containing the variable of interest in PARAMCD and AVAL
#' @inheritParams tern::g_lineplot
#' @param by_vars variables to merge the two datasets by
#' @param subtitle character scalar forwarded to g_lineplot
#' @param ... additional arguments passed to `tern::g_lineplot`
#' @author Stefan Thoma (`thomas7`)
#' @importFrom forcats fct_reorder
#' @import ggplot2
#' @import dplyr tern assertthat
#' @export
#' @examplesIf require('rsvg')
#' library(dplyr)
#' advs_filtered <- eg_advs %>% filter(
#'   PARAMCD == "SYSBP"
#' )
#' out1 <- g_mean_general(eg_adsl, advs_filtered)
#' generate_slides(out1, paste0(tempdir(), "/g_mean.pptx"))
g_mean_general <- function(adsl,
                           data,
                           variables = control_lineplot_vars(group_var = "TRT01P"),
                           by_vars = c("USUBJID", "STUDYID"),
                           subtitle = "Plot of Mean and 95% Confidence Limits by Visit.",
                           ...) {
  assert_that(is.string(subtitle))
  variables <- variables %>% strip_NA() # tern 0.9.4 added facet_var in control_lineplot_vars
  assert_that(has_name(data, c(by_vars, variables)))
  assert_that(has_name(adsl, c(by_vars, variables["group_var"])))

  adsl_f <- adsl %>%
    df_explicit_na()

  data_f <- data %>%
    mutate(AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min)) %>%
    dplyr::filter(
      AVISIT != "SCREENING"
    ) %>%
    droplevels() %>%
    df_explicit_na() %>%
    semi_join(adsl_f, by_vars)


  plot <- g_lineplot(
    df = data_f,
    alt_counts_df = adsl_f,
    variables = variables,
    title = "",
    subtitle = subtitle,
    ...
  )
  plot
}

#' Refactor active arm
#'
#' @param df Input dataframe
#' @param arm_var Arm variable
#' @param levels factor levels
#' @param labels factor labels
#' @return Dataframe with re-level and re-labelled arm variable.
#' @export
mutate_actarm <- function(df,
                          arm_var = "TRT01A",
                          levels = c(
                            "PLACEBO + PACLITAXEL + CISPLATIN",
                            "ATEZOLIZUMAB + TIRAGOLUMAB + PACLITAXEL + CISPLATIN"
                          ),
                          labels = c("Pbo+Pbo+PC", "Tira+Atezo+PC")) {
  df %>%
    mutate_at(arm_var, ~ factor(explicit_na(sas_na(.)),
      levels = levels,
      labels = labels
    ))
}

#' Preprocess t_dd function
#'
#' @param df Input dataframe
#' @param levels factor levels
#' @param labels factor labels
#' @return dataframe
#' @export
preprocess_t_dd <- function(df,
                            levels = c("PROGRESSIVE DISEASE", "ADVERSE EVENT", "OTHER", "<Missing>"),
                            labels = c("Progressive Disease", "Adverse Events", "Other", "<Missing>")) {
  noNA(levels)
  noNA(labels)
  assert_that(length(levels) >= 3)
  assert_that(length(labels) >= 3)

  df %>%
    mutate(
      DTHCAT1 = DTHCAT == levels[1],
      DTHCAT2 = DTHCAT == levels[2],
      DTHCAT3 = DTHCAT == levels[3],
      DTHCAT = factor(explicit_na(sas_na(DTHCAT)), levels = levels, labels = labels)
    ) %>%
    formatters::var_relabel(
      DTHCAT1 = labels[1],
      DTHCAT2 = labels[2],
      DTHCAT3 = labels[3]
    )
}


#' Preprocess t_ds function
#'
#' @param df Input dataframe
#' @param levels factor levels
#' @param labels factor labels
#' @return dataframe
#' @export
preprocess_t_ds <- function(df,
                            levels = c("Alive: On Treatment", "Alive: In Follow-up", "<Missing>"),
                            labels = c("Alive: On Treatment", "Alive: In Follow-up", "<Missing>")) {
  assert_that(has_name(df, "DISTRTFL"),
    msg = "`DISTRTFL` variable is needed for deriving `STDONS` variable,
              suggest to use `DTRTxxFL` to create `DISTRTFL`."
  )
  noNA(levels)
  noNA(labels)
  assert_that(length(levels) >= 3)
  assert_that(length(labels) >= 3)

  data_adsl <- df %>%
    # Calculate STDONS
    mutate(STDONS = case_when(
      toupper(EOSSTT) == "ONGOING" & DTHFL == "" & DISTRTFL == "N" ~ "Alive: On Treatment",
      toupper(EOSSTT) == "ONGOING" & DISTRTFL == "Y" ~ "Alive: In Follow-up",
      TRUE ~ ""
    )) %>%
    # Process variable
    mutate(STDONS = factor(explicit_na(sas_na(STDONS)), levels = levels, labels = labels))
}

#' Plot mean values of VS
#'
#' Wrapper for `g_mean_general()`.
#' Requires filtering of the datasets (e.g. using SUFFIX in spec.yml)
#'
#' @param adsl ADSL data
#' @param advs ADVS data
#' @param arm `"TRT01P"` by default
#' @inheritParams g_mean_general
#' @param paramcd Which variable to use for plotting. By default `"PARAM"`
#' @param ... |
#' Gets forwarded to `tern::g_lineplot()`.
#' This lets you specify additional arguments to `tern::g_lineplot()`
#' @author Stefan Thoma (`thomas7`)
#' @export
#' @examplesIf require('rsvg')
#' library(dplyr)
#' advs_filtered <- eg_advs %>% filter(
#'   PARAMCD == "SYSBP"
#' )
#' plot_vs <- g_vs_slide(
#'   adsl = eg_adsl,
#'   advs = advs_filtered,
#'   paramcd = "PARAM",
#'   subtitle_add_unit = FALSE
#' ) +
#'   ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))
#' # makes editable plots
#' generate_slides(plot_vs, paste0(tempdir(), "/g_vs.pptx"), fig_editable = TRUE)
#' # not editable plots, which appear as images
#' generate_slides(plot_vs, paste0(tempdir(), "/g_vs.pptx"), fig_editable = FALSE)
g_vs_slide <- function(adsl, advs, arm = "TRT01P", paramcd = "PARAM",
                       subtitle = "Plot of Mean and 95% Confidence Limits by Visit.", ...) {
  # tern 0.9.4 added facet_var in control_lineplot_vars
  variables <- control_lineplot_vars(group_var = arm, paramcd = paramcd) %>% strip_NA()

  by_vars <- c("USUBJID", "STUDYID")
  assert_that(is.string(arm))
  assert_that(has_name(advs, c(by_vars, variables) %>% unique()))
  assert_that(has_name(adsl, c(by_vars, arm) %>% unique()))

  g_mean_general(
    adsl = adsl, data = advs, variables = variables, by_vars = by_vars,
    subtitle = subtitle, ...
  )
}

#' Adverse Events listing
#' adapted from https://insightsengineering.github.io/tlg-catalog/stable/listings/adverse-events/ael02.html
#' @param adsl ADSL data
#' @param adae ADAE data
#' @export
#' @examples
#' library(dplyr)
#' library(rlistings)
#' adsl <- eg_adsl
#' adae <- eg_adae
#'
#' out <- l_ae_slide(adsl = adsl, adae = adae)
#' head(out)
l_ae_slide <- function(adsl, adae) {
  assert_that(has_name(adae, c(
    "SITEID", "SUBJID", "AGE", "SEX", "RACE", "TRTSDTM", "AETOXGR",
    "AENDY", "ASTDY", "AESER", "AEREL", "AEOUT", "AECONTRT", "AEACN"
  )))

  # Preprocess data
  adsl_f <- adsl %>%
    df_explicit_na()

  adae_f <- adae %>%
    semi_join(., adsl_f, by = c("STUDYID", "USUBJID")) %>%
    df_explicit_na() %>%
    mutate(
      CPID = paste(SITEID, SUBJID, sep = "/"),
      ASR = paste(AGE, SEX, RACE, sep = "/"),
      Date_First = toupper(format(as.Date(TRTSDTM), "%d%b%Y")),
      Duration = AENDY - ASTDY + 1,
      Serious = ifelse(AESER == "Y", "Yes", ifelse(AESER == "N", "No", "")),
      Related = ifelse(AEREL == "Y", "Yes", ifelse(AEREL == "N", "No", "")),
      Outcome = case_when(
        AEOUT == "FATAL" ~ 1,
        AEOUT == "NOT RECOVERED/NOT RESOLVED" ~ 2,
        AEOUT == "RECOVERED/RESOLVED" ~ 3,
        AEOUT == "RECOVERED/RESOLVED WITH SEQUELAE" ~ 4,
        AEOUT == "RECOVERING/RESOLVING" ~ 5,
        AEOUT == "UNKNOWN" ~ 6
      ),
      Treated = ifelse(AECONTRT == "Y", "Yes", ifelse(AECONTRT == "N", "No", "")),
      Action = case_when(
        AEACN == "DOSE INCREASED" ~ 1,
        AEACN == "DOSE NOT CHANGED" ~ 2,
        AEACN == "DOSE REDUCED" | AEACN == "DOSE RATE REDUCED" ~ 3,
        AEACN == "DRUG INTERRUPTED" ~ 4,
        AEACN == "DRUG WITHDRAWN" ~ 5,
        AEACN == "NOT APPLICABLE" | AEACN == "NOT EVALUABLE" ~ 6,
        AEACN == "UNKNOWN" ~ 7
      )
    ) %>%
    select(
      CPID,
      # ASR,
      # TRT01A,
      AEDECOD,
      Date_First,
      # ASTDY,
      # Duration,
      Serious,
      # AESEV,
      Related,
      # Outcome,
      # Treated,
      AETOXGR,
      Action
    )


  formatters::var_labels(adae_f) <- c(
    CPID = "Center/Patient ID", # keep
    # ASR = "Age/Sex/Race",
    # TRT01A = "Treatment",                                      #keep
    AEDECOD = "Adverse\nEvent MedDRA\nPreferred Term", # keep
    Date_First = "Date of\nFirst Study\nDrug\nAdministration", # keep
    # ASTDY = "Study\nDay of\nOnset",
    # Duration = "AE\nDuration\nin Days",
    Serious = "Serious", # keep
    # AESEV = "Most\nExtreme\nIntensity",
    Related = "Caused by\nStudy\nDrug", # keep
    # Outcome = "Outcome\n(1)",
    # Treated = "Treatment\nfor AE",
    AETOXGR = "Analysis Toxicity Grade", # keep
    Action = "Action\nTaken\n(2)" # keep
  )

  # Set up listing

  lsting <- as_listing(
    adae_f,
    key_cols = c("CPID"),
    disp_cols = names(adae_f)
  )

  lsting
}

#' Adverse event table
#'
#' @param adae ADAE data set, dataframe
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character
#' @param cutoff Cutoff threshold
#' @param prune_by_total Prune according total column
#' @param split_by_study Split by study, building structured header for tables
#' @param side_by_side "GlobalAsia" or "GlobalAsiaChina" to define the side by side requirement
#' @return rtables object
#'
#' @export
#' @examples
#' library(dplyr)
#' # Example 1
#' adsl <- eg_adsl %>%
#'   dplyr::mutate(TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")))
#' adae <- eg_adae %>%
#'   dplyr::mutate(
#'     TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")),
#'     ATOXGR = AETOXGR
#'   )
#' out <- t_ae_pt_soc_slide(adsl, adae, "TRT01A", 2)
#' print(out)
#' generate_slides(out, paste0(tempdir(), "/ae.pptx"))
#'
#'
#' # Example 2, prune by total column
#' out2 <- t_ae_pt_soc_slide(adsl, adae, "TRT01A", 25, prune_by_total = TRUE)
#' print(out2)
#' generate_slides(out2, paste0(tempdir(), "/ae2.pptx"))
t_ae_pt_soc_slide <- function(adsl, adae, arm, cutoff = NA,
                              prune_by_total = FALSE,
                              split_by_study = FALSE,
                              side_by_side = NULL) {
  cutoff <- check_and_set_cutoff(adae, cutoff)
  result <- t_ae_pt_core(adsl, adae, arm, cutoff,
    diff = FALSE, soc = "soc",
    prune_by_total = prune_by_total,
    split_by_study, side_by_side
  )
  result@main_title <- "Adverse Events table"

  if (is.null(side_by_side)) {
    # adding "N" attribute
    arm <- col_paths(result)[[1]][1]

    n_r <- data.frame(
      ARM = toupper(names(result@col_info)),
      N = col_counts(result) %>% as.numeric()
    ) %>%
      `colnames<-`(c(paste(arm), "N")) %>%
      arrange(get(arm))

    attr(result, "N") <- n_r
  }
  result
}

#' Convert dates from `yyyy-mm-dd` format into 20APR2019 format
#' `Datetime` format removes the time and outputs date in the same way
#' Able to handle truncated dates as well (e.g. just the year or year and month)
#'
#' `dplyr::case_when()` will check all RHS expressions on the input, this means if
#' these expressions return warnings, they will happen even then the input doesn't
#' doesn't satisfy the LHS. For this reason, I had to 'quiet' all `lubridate` functions.
#' This `format_date()` function was tested with the inputs in the examples, all gave the
#' expected returned value, so there should be no issues.
#'
#' @param x vector of dates in character, in `yyyy-mm-dd` format
#' @return A vector.
#'
#' @export
#' @examplesIf require(lubridate)
#' require(lubridate)
#'
#' # expected to return "2019"
#' format_date("2019")
#'
#' # expected to return "20APR2019"
#' format_date("2019-04-20")
#'
#' # expected to return ""
#' format_date("")
#'
#' # expected to return "18JUN2019"
#' format_date("2019-06-18T10:32")
#'
#' # expected to return "APR2019"
#' format_date("2019-04")
#'
format_date <- function(x) {
  x_form <- case_when(
    nchar(x) > 10 ~ toupper(format(lubridate::date(lubridate::ymd_hms(x, truncated = 3, quiet = TRUE)), "%d%b%Y")),
    nchar(x) == 10 ~ toupper(format(lubridate::ymd(x, quiet = TRUE), "%d%b%Y")),
    nchar(x) == 7 ~ substr(toupper(format(lubridate::ymd(x, truncated = 2, quiet = TRUE), "%d%b%Y")), 3, 9),
    nchar(x) == 4 ~ x,
    is.na(x) ~ "",
    TRUE ~ ""
  )

  x_form
}

#' Null report
#'
#' @author Thomas Neitmann (`neitmant`)
#'
#' @details
#' This will create a null report similar as STREAM does. You can use
#' it inside output functions as shown in the example below.
#' @return An empty `rtables` object
#' @examplesIf require(filters)
#' library(dplyr)
#' library(filters)
#' data <- list(
#'   adsl = eg_adsl,
#'   adae = eg_adae %>% mutate(AREL = "")
#' )
#'
#' null_report()
#'
#' ## An example how to use the `null_report()` inside an output function
#' t_ae <- function(datasets) {
#'   trt <- "ACTARM"
#'   anl <- semi_join(
#'     datasets$adae,
#'     datasets$adsl,
#'     by = c("STUDYID", "USUBJID")
#'   )
#'
#'   return(null_report())
#' }
#'
#' data %>%
#'   filters::apply_filter("SER_SE") %>%
#'   t_ae()
#'
#' @export
#'
null_report <- function() {
  rtable(
    header = " ",
    rrow("", "Null Report: No observations met the reporting criteria for inclusion in this output.")
  )
}

#' Demographic table with gtsummary
#'
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character, "`TRT01P" by default.
#' @param vars Characters of variables
#' @return gtsummary object
#' @inherit gen_notes note
#' @export
#' @examples
#' library(dplyr)
#' adsl <- eg_adsl
#' out1 <- gt_t_dm_slide(adsl, "TRT01P", c("SEX", "AGE", "RACE", "ETHNIC", "COUNTRY"))
#' print(out1)
#' generate_slides(out1, paste0(tempdir(), "/dm.pptx"))
#'
gt_t_dm_slide <- function(adsl,
                          arm = "TRT01P",
                          vars = c("AGE", "SEX", "RACE")) {
  adsl |>
    select(all_of(c(vars, arm))) |>
    tbl_summary(by = all_of(arm)) |>
    modify_caption(caption = "Demographic slide") # Set default title
}

#' autoslider_error class
#' @details this function is used to create autoslider_error object.
#' this function is for internal use only to create the autoslider_error object.
#' It enable us for further functionalities, like providing help on easy debugging,
#' e.g. if the error is inside the user function, provide the call and let the user
#' run the code outside the pipeline.
#' @param x character scaler
#' @param spec spec should be a list containing "program" and "suffix"
#' @param step step is a character indicating in which step the pipeline encounter error
#' @return autoslider_error object
#' @export
autoslider_error <- function(x, spec, step) {
  assert_is_character_scalar(x)
  structure(
    .Data = x,
    step = step,
    spec = spec,
    class = "autoslider_error"
  )
}

1		#' [EXPERIMENTAL] Create new output function based on a template.
2		#'
3		#' We have separate templates for listings, tables, and graphs.
4		#' There is also a template to set up the `run_all` script.
5		#'
6		#' @param template Must be one of `list_all_templates(package = "autoslider.core")`.
7		#' @param function_name Name of the output function you want to create. Defaults to "default".
8		#' @param save_path Path to save the function. Defaults to "./programs/R".
9		#' @param overwrite Whether to overwrite an existing file.
10		#' @param open Whether to open the file after creation.
11		#' @param package Which package to search for the template file. Defaults to "autoslider.core".
12		#'
13		#' @return No return value. Called for side effects (writes a file).
14		#'
15		#' @details Use `list_all_templates(package = "autoslider.core")` to discover which templates are available.
16		#'
17		#' @export
18		#'
19		#' @examples
20		#' if (interactive()) {
21		#' use_template("t_dm_slide", function_name = "my_table", package = "autoslider.core")
22		#' }
23		use_template <- function(template = "t_dm_slide",
24		function_name = "default",
25		save_path = "./programs/R",
26		overwrite = FALSE,
27		open = interactive(),
28		package = "autoslider.core") {
29	40x	assert_that(assertthat::is.string(template))
30	40x	assert_that(assertthat::is.string(package))
31	40x	assert_that(assertthat::is.flag(overwrite))
32	40x	assert_that(assertthat::is.flag(open))
33	40x	assert_that(!is.null(save_path))
34		# assert_that(template %in% list_all_templates(package) \|\|
35		# paste0(system.file("templates", package = package), "/", template) %in%
36		# list_all_templates(package))
37
38	40x	if (!dir.exists(save_path)) {
39	2x	dir.create(save_path, recursive = TRUE)
40		}
41
42	40x	save_path <- file.path(save_path, paste0(function_name, ".R"))
43
44		# Original validation logic for when save_path is provided
45	40x	assertthat::has_extension(save_path, ext = "R")
46	40x	assertthat::is.writeable(save_path %>% dirname())
47
48
49		# Build expected full path
50	40x	expected_path <- file.path(system.file("templates", package = package), template)
51	40x	expected_core_path <- file.path(system.file("templates", package = "autoslider.core"), template)
52
53		# Validation logic
54	40x	valid <- FALSE
55	40x	if (package == "autoslider.core") {
56	38x	valid <- expected_path %in% list_all_templates(package)
57	2x	} else if (package == "autoslideR") {
58	2x	valid <- (expected_path %in% list_all_templates(package)) \|\| (expected_core_path %in% list_all_templates(package))
59		}
60
61		# Error if invalid
62	40x	if (!valid) {
63	3x	err_msg <- sprintf(
64	3x	"Template '%s' not found in package '%s'. Use list_all_templates('%s') to see available templates.",
65	3x	template, package, package
66		)
67	3x	abort(err_msg)
68		}
69
70
71	37x	if (file.exists(save_path) && !overwrite) {
72	1x	err_msg <- paste(
73	1x	sprintf("A file named '%s' already exists.", save_path),
74	1x	"\u2139 Set `overwrite = TRUE` to force overwriting it.",
75	1x	sep = "\n"
76		)
77	1x	abort(err_msg)
78		}
79
80	36x	if (package == "autoslider.core") {
81	35x	file_list <- get_template_filepath(package = package, full.names = TRUE)
82	1x	} else if (package == "autoslideR") {
83	1x	file_list <- c(
84	1x	get_template_filepath(package = "autoslideR", full.names = TRUE),
85	1x	get_template_filepath(package = "autoslider.core", full.names = TRUE)
86		)
87		}
88
89	36x	template_file <- file_list[basename(file_list) == paste0(template, ".R")]
90
91
92	36x	if (file.copy(template_file, save_path, overwrite = TRUE)) {
93	36x	rlang::inform(sprintf("\u2713 File '%s' has been created successfully", save_path))
94	36x	file_lines <- readLines(save_path)
95
96	36x	file_lines <- file_lines[!grepl("^#'", file_lines)]
97	36x	file_lines <- file_lines[nzchar(file_lines)]
98
99		# Replace function name with numbering
100	36x	file_lines <- gsub(tolower(template), function_name, file_lines)
101	36x	writeLines(file_lines, save_path)
102		}
103
104	36x	if (open) {
105	!	file.edit(save_path)
106		}
107
108	36x	invisible(TRUE)
109		}
110
111		#' [EXPERIMENTAL] List All Available Templates
112		#'
113		#' @param package Which package to search for the template files. Defaults to "autoslider.core".
114		#'
115		#' @return A character vector of available template names in the specified package.
116		#'
117		#' @export
118		#'
119		#' @examples
120		#' list_all_templates(package = "autoslider.core")
121		list_all_templates <- function(package = "autoslider.core") {
122	45x	if (package == "autoslideR") {
123	4x	c(
124	4x	get_template_filepath(package = "autoslideR", full.names = TRUE),
125	4x	get_template_filepath(package = "autoslider.core", full.names = TRUE)
126		) \|>
127	4x	stringr::str_remove("\\.R$") \|>
128	4x	structure(package = package)
129	41x	} else if (package == "autoslider.core") {
130	41x	get_template_filepath(package = package, full.names = TRUE) \|>
131	41x	stringr::str_remove("\\.R$") \|>
132	41x	structure(package = package)
133		}
134		}
135
136
137		#' Retrieve Template File Paths
138		#'
139		#' @param package A character string specifying the name of the package to search.
140		#' @param full.names If `TRUE`, returns the full path to each file.
141		#' If `FALSE`, returns only the file names.
142		#'
143		#' @return A character vector of template file names or paths, depending on `full.names`.
144		#'
145		#' @export
146		#'
147		#' @keywords internal
148		get_template_filepath <- function(package = "autoslider.core", full.names = FALSE) {
149		# Installed-package path
150	86x	template_dir <- system.file("templates", package = package)
151
152	86x	pattern <- "^(t_\|l_\|g_)"
153	86x	if (full.names == TRUE) {
154	86x	pattern <- paste0(paste0(template_dir, "/"), c("t_", "g_", "l_"),
155	86x	collapse = "\|"
156		)
157		}
158
159	86x	list.files(template_dir, pattern = "\\.R$", full.names = full.names) \|>
160	86x	stringr::str_subset(pattern)
161		}

1		#' Table of AEs of Special Interest
2		#' adapted from https://insightsengineering.github.io/tlg-catalog/stable/tables/adverse-events/aet01_aesi.html
3		#' @param adsl ADSL data set, dataframe
4		#' @param adae ADAE data set, dataframe.
5		#' @param aesi AESI variable which will act as a filter to select the rows required to create the table.
6		#' An example of AESI variable is CQ01NAM.
7		#' @param arm Arm variable, character, `"ACTARM"` by default.
8		#' @param grad_var Grading variable, character, `"AETOXGR"` by default.
9		#'
10		#' @return rtables object
11		#' @export
12		#' @author Kai Xiang Lim (`limk43`)
13		#'
14		#' @examples
15		#' library(dplyr)
16		#' adsl <- eg_adsl
17		#' adae <- eg_adae
18		#' adae_atoxgr <- adae %>% dplyr::mutate(ATOXGR = AETOXGR)
19		#' t_aesi_slide(adsl, adae, aesi = "CQ01NAM")
20		#' t_aesi_slide(adsl, adae, aesi = "CQ01NAM", arm = "ARM", grad_var = "AESEV")
21		#' t_aesi_slide(adsl, adae_atoxgr, aesi = "CQ01NAM", grad_var = "ATOXGR")
22		#'
23		t_aesi_slide <- function(adsl, adae, aesi, arm = "ACTARM", grad_var = "AETOXGR") {
24	6x	assert_that(has_name(adsl, arm))
25	6x	assert_that(has_name(adae, "AEACN"))
26	6x	assert_that(has_name(adae, "AEOUT"))
27	6x	assert_that(has_name(adae, "AECONTRT"))
28	6x	assert_that(has_name(adae, "AESER"))
29	6x	assert_that(has_name(adae, "AEREL"))
30	6x	assert_that(has_name(adae, grad_var))
31	6x	assert_that(has_name(adae, "AECONTRT"))
32
33	6x	aesi_sym <- rlang::sym(aesi)
34
35
36	5x	adae2 <- filter(adae, is.na(!!aesi_sym))
37
38	4x	adsl <- df_explicit_na(adsl)
39	4x	adae2 <- df_explicit_na(adae2)
40
41		# Merge ADAE with ADSL and ensure character variables are converted to factors and empty
42		# strings and NAs are explicit missing levels.
43	4x	adae2 <- adsl %>%
44	4x	inner_join(adae2, by = c("USUBJID", "TRT01A", "TRT01P", "ARM", "ARMCD", "ACTARM", "ACTARMCD")) %>%
45	4x	df_explicit_na()
46
47	4x	not_resolved <- adae2 %>%
48	4x	filter(!(AEOUT %in% c("RECOVERED/RESOLVED", "FATAL", "RECOVERED/RESOLVED WITH SEQUELAE"))) %>%
49	4x	distinct(USUBJID) %>%
50	4x	mutate(NOT_RESOLVED = "Y")
51
52	4x	adae2 <- adae2 %>%
53	4x	left_join(not_resolved, by = c("USUBJID")) %>%
54	4x	mutate(
55	4x	ALL_RESOLVED = formatters::with_label(
56	4x	is.na(NOT_RESOLVED),
57	4x	"Total number of patients with all non-fatal AESIs resolved"
58		),
59	4x	NOT_RESOLVED = formatters::with_label(
60	4x	!is.na(NOT_RESOLVED),
61	4x	"Total number of patients with at least one unresolved or ongoing non-fatal AESI"
62		)
63		)
64
65	4x	adae2 <- adae2 %>%
66	4x	mutate(
67	4x	AEDECOD = as.character(AEDECOD),
68	4x	WD = formatters::with_label(
69	4x	AEACN == "DRUG WITHDRAWN", "Total number of patients with study drug withdrawn due to AESI"
70		),
71	4x	DSM = formatters::with_label(
72	4x	AEACN %in% c("DRUG INTERRUPTED", "DOSE INCREASED", "DOSE REDUCED"),
73	4x	"Total number of patients with dose modified/interrupted due to AESI"
74		),
75	4x	CONTRT = formatters::with_label(AECONTRT == "Y", "Total number of patients with treatment received for AESI"),
76	4x	SER = formatters::with_label(AESER == "Y", "Total number of patients with at least one serious AESI"),
77	4x	REL = formatters::with_label(AEREL == "Y", "Total number of patients with at least one related AESI"),
78	4x	ALL_RESOLVED_WD = formatters::with_label(
79	4x	WD == TRUE & ALL_RESOLVED == TRUE,
80	4x	"No. of patients with study drug withdrawn due to resolved AESI"
81		),
82	4x	ALL_RESOLVED_DSM = formatters::with_label(
83	4x	DSM == TRUE & ALL_RESOLVED == TRUE,
84	4x	"No. of patients with dose modified/interrupted due to resolved AESI"
85		),
86	4x	ALL_RESOLVED_CONTRT = formatters::with_label(
87	4x	CONTRT == TRUE & ALL_RESOLVED == TRUE,
88	4x	"No. of patients with treatment received for resolved AESI"
89		),
90	4x	NOT_RESOLVED_WD = formatters::with_label(
91	4x	WD == TRUE & NOT_RESOLVED == TRUE,
92	4x	"No. of patients with study drug withdrawn due to unresolved or ongoing AESI"
93		),
94	4x	NOT_RESOLVED_DSM = formatters::with_label(
95	4x	DSM == TRUE & NOT_RESOLVED == TRUE,
96	4x	"No. of patients with dose modified/interrupted due to unresolved or ongoing AESI"
97		),
98	4x	NOT_RESOLVED_CONTRT = formatters::with_label(
99	4x	CONTRT == TRUE & NOT_RESOLVED == TRUE,
100	4x	"No. of patients with treatment received for unresolved or ongoing AESI"
101		),
102	4x	SERWD = formatters::with_label(
103	4x	AESER == "Y" & AEACN == "DRUG WITHDRAWN",
104	4x	"No. of patients with study drug withdrawn due to serious AESI"
105		),
106	4x	SERCONTRT = formatters::with_label(
107	4x	AECONTRT == "Y" & AESER == "Y",
108	4x	"No. of patients with dose modified/interrupted due to serious AESI"
109		),
110	4x	SERDSM = formatters::with_label(
111	4x	AESER == "Y" & AEACN %in% c("DRUG INTERRUPTED", "DOSE INCREASED", "DOSE REDUCED"),
112	4x	"No. of patients with treatment received for serious AESI"
113		),
114	4x	RELWD = formatters::with_label(
115	4x	AEREL == "Y" & AEACN == "DRUG WITHDRAWN",
116	4x	"No. of patients with study drug withdrawn due to related AESI"
117		),
118	4x	RELDSM = formatters::with_label(
119	4x	AEREL == "Y" & AEACN %in% c("DRUG INTERRUPTED", "DOSE INCREASED", "DOSE REDUCED"),
120	4x	"No. of patients with dose modified/interrupted due to related AESI"
121		),
122	4x	RELCONTRT = formatters::with_label(
123	4x	AECONTRT == "Y" & AEREL == "Y",
124	4x	"No. of patients with treatment received for related AESI"
125		),
126	4x	RELSER = formatters::with_label(AESER == "Y" & AEREL == "Y", "No. of patients with serious, related AESI")
127		)
128
129	4x	if (grad_var %in% c("AETOXGR", "ATOXGR")) {
130	2x	adae2 <- adae2 %>%
131	2x	mutate(
132	2x	{{ grad_var }} := forcats::fct_recode(get(grad_var),
133	2x	"Grade 1" = "1",
134	2x	"Grade 2" = "2",
135	2x	"Grade 3" = "3",
136	2x	"Grade 4" = "4",
137	2x	"Grade 5 (fatal outcome)" = "5"
138		)
139		)
140	2x	} else if (grad_var %in% c("AESEV", "ASEV")) {
141	1x	adae2 <- adae2 %>%
142	1x	mutate(
143	1x	{{ grad_var }} := forcats::fct_recode(stringr::str_to_title(get(grad_var), locale = "en"))
144		)
145		}
146
147	4x	aesi_vars <- c("WD", "DSM", "CONTRT", "ALL_RESOLVED", "NOT_RESOLVED", "SER", "REL")
148
149	4x	lyt_adae <- basic_table(show_colcounts = TRUE) %>%
150	4x	split_cols_by(arm) %>%
151	4x	count_patients_with_event(
152	4x	vars = "USUBJID",
153	4x	filters = c("ANL01FL" = "Y"),
154	4x	denom = "N_col",
155	4x	.labels = c(count_fraction = "Total number of patients with at least one AESI")
156		) %>%
157	4x	count_values(
158	4x	"ANL01FL",
159	4x	values = "Y",
160	4x	.stats = "count",
161	4x	.labels = c(count = "Total number of AESIs"),
162	4x	table_names = "total_aes"
163		) %>%
164	4x	count_occurrences_by_grade(
165	4x	var = grad_var,
166	4x	var_labels = "Total number of patients with at least one AESI by worst grade",
167	4x	show_labels = "visible"
168		) %>%
169	4x	count_patients_with_flags("USUBJID", flag_variables = aesi_vars, denom = "N_col")
170
171	4x	result <- build_table(lyt_adae, df = adae2, alt_counts_df = adsl)
172
173
174	4x	result
175		}

1		#' DOR table
2		#' @param adsl ADSL dataset
3		#' @param adtte ADTTE dataset
4		#' @param arm Arm variable, character, "`TRT01P" by default.
5		#' @param refgroup Reference group
6		#' @inherit gen_notes note
7		#' @return An `rtables` object
8		#' @export
9		#' @examples
10		#' library(dplyr)
11		#' adsl <- eg_adsl %>%
12		#' dplyr::mutate(TRT01P = factor(TRT01P, levels = c("A: Drug X", "B: Placebo", "C: Combination")))
13		#' adtte <- eg_adtte %>%
14		#' dplyr::filter(PARAMCD == "OS") %>%
15		#' dplyr::mutate(TRT01P = factor(TRT01P, levels = c("A: Drug X", "B: Placebo", "C: Combination")))
16		#' out <- t_dor_slide(adsl, adtte)
17		#' print(out)
18		#' generate_slides(out, paste0(tempdir(), "/dor.pptx"))
19		t_dor_slide <- function(adsl, adtte, arm = "TRT01P", refgroup = NULL) {
20	2x	assert_that(has_name(adsl, arm))
21	2x	assert_that(has_name(adtte, "CNSR"))
22	2x	assert_that(has_name(adtte, "EVNTDESC"))
23	2x	assert_that(has_name(adtte, "AVALU"))
24	2x	assert_that(has_name(adtte, "AVAL"))
25	2x	assert_that(all(!is.na(adtte[["AVALU"]])))
26
27	2x	slref_arm <- sort(unique(adsl[[arm]]))
28	2x	anl_arm <- sort(unique(adtte[[arm]]))
29	2x	assert_that(identical(slref_arm, anl_arm),
30	2x	msg = "The adsl and the analysis datasets should have the same treatment arm levels"
31		)
32
33
34	2x	time_unit <- unique(adtte[["AVALU"]])
35	2x	assert_that(length(time_unit) == 1)
36
37	2x	if (toupper(time_unit) == "DAYS") {
38	1x	adtte <- adtte %>%
39	1x	dplyr::mutate(AVAL = day2month(AVAL))
40	1x	} else if (toupper(time_unit) == "YEARS") {
41	1x	adtte <- adtte %>%
42	1x	dplyr::mutate(AVAL = AVAL * 12)
43		}
44
45	2x	adtte_f <- adtte %>%
46	2x	dplyr::mutate(
47	2x	is_event = CNSR == 0,
48	2x	is_not_event = CNSR == 1,
49	2x	EVNT1 = factor(
50	2x	case_when(
51	2x	is_event == TRUE ~ "Responders with subsequent event (%)",
52	2x	is_event == FALSE ~ "Responders without subsequent event (%)"
53		)
54		),
55	2x	EVNTDESC = factor(EVNTDESC)
56		) %>%
57	2x	semi_join(., adsl, by = c("STUDYID", "USUBJID")) %>%
58	2x	select(STUDYID, USUBJID, {{ arm }}, AVAL, is_event, is_not_event, EVNT1, EVNTDESC) %>%
59	2x	df_explicit_na(char_as_factor = FALSE)
60
61	2x	lyt_02 <- basic_table() %>%
62	2x	split_cols_by(
63	2x	var = arm,
64	2x	ref_group = refgroup
65		) %>%
66	2x	add_colcounts() %>%
67	2x	count_values(
68	2x	vars = "USUBJID",
69	2x	values = unique(adtte$USUBJID),
70	2x	.labels = c(count = "Responders"),
71	2x	.stats = "count"
72		) %>%
73	2x	analyze_vars(
74	2x	vars = "is_event",
75	2x	.stats = "count_fraction",
76	2x	.labels = c(count_fraction = "With subsequent event (%)"),
77	2x	.indent_mods = c(count_fraction = 1L),
78	2x	show_labels = "hidden",
79		) %>%
80	2x	analyze(
81	2x	vars = "AVAL",
82	2x	afun = s_surv_time_1,
83	2x	extra_args = list(is_event = "is_event"),
84	2x	table_names = "est_prop",
85	2x	format = format_xx("xx.x (xx.x, xx.x)"),
86	2x	show_labels = "hidden",
87	2x	indent_mod = 1
88		)
89
90	2x	result <- build_table(lyt_02, df = adtte_f, alt_counts_df = adsl)
91	2x	result@main_title <- "DOR slide"
92	2x	result
93		}

1		#' Read yaml spec file
2		#'
3		#' Read yaml spec file and split according to filter lists
4		#'
5		#' @param spec_file `character`. Path to a yaml spec file
6		#' @param metadata Metadata of study
7		#'
8		#' @return
9		#' An object of class `spec` which is a `list` where each element corresponds
10		#' to one output, e.g. `t_dm_IT`.
11		#'
12		#' @author
13		#' - Liming Li (`Lil128`)
14		#' - Thomas Neitmann (`neitmant`)
15		#' - Joe Zhu
16		#'
17		#' @export
18		#'
19		#' @examples
20		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
21		#'
22		#' ## Take a look at the 'raw' content of the spec file
23		#' cat(readLines(spec_file)[1:24], sep = "\n")
24		#'
25		#' ## This is how it looks once read into R
26		#' spec <- read_spec(spec_file)
27		#' spec[1:3]
28		#'
29		read_spec <- function(spec_file = "spec.yml",
30		metadata = NULL) {
31	4x	spec <- yaml::read_yaml(spec_file, eval.expr = TRUE)
32	4x	ret <- lapply(spec, function(s) {
33	156x	lapply(s$suffix, function(su) {
34	156x	ret <- s
35	156x	ret$suffix <- su
36	156x	c(ret, metadata)
37		})
38		})
39	4x	spec_obj <- unlist(ret, recursive = FALSE)
40	4x	as_spec(spec_obj)
41		}
42
43		#' validate spec file
44		#' @description not implemented yet
45		#' @param spec specification
46		#' @noRd
47		validate_spec <- function(spec) {
48	!	message <- NULL
49	!	if (is.null(spec$dataset)) {
50	!	message <- c(message, "Spec must not assign dataset argument!")
51		}
52	!	if (is.null(spec$func)) {
53	!	message <- c(message, "Spec must include func argument!")
54		}
55	!	if (is.null(spec$outpath)) {
56	!	message <- c(message, "Spec must include outpath argument!")
57		}
58		}
59
60		#' Filter a spec object
61		#'
62		#' @param spec A `spec` object as returned by `read_spec()`
63		#' @param filter_expr A `logical` expression indicating outputs to keep
64		#' @param verbose Should a message about the number of outputs matching
65		#' `filter_spec` be printed? Defaults to `TRUE`.
66		#'
67		#' @return
68		#' A `spec` object containing only the outputs matching `filter_expr`
69		#'
70		#' @author Thomas Neitmann (`neitmant`)
71		#'
72		#' @export
73		#'
74		#' @examples
75		#' library(dplyr)
76		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
77		#' spec <- spec_file %>% read_spec()
78		#'
79		#' ## Keep only the t_dm_IT output
80		#' filter_spec(spec, output == "t_dm_IT")
81		#'
82		#' ## Same as above but more verbose
83		#' filter_spec(spec, program == "t_dm" && suffix == "IT")
84		#'
85		#' ## Keep all t_ae outputs
86		#' filter_spec(spec, program == "t_ae")
87		#'
88		#' ## Keep all output run on safety population
89		#' filter_spec(spec, "SE" %in% suffix)
90		#'
91		#' ## Keep t_dm_CHN_IT and t_dm_CHN_SE
92		#' filter_spec(spec, program == "t_dm" && suffix %in% c("CHN_IT", "CHN_SE"))
93		#'
94		#' ## Keep all tables
95		#' filter_spec(spec, grepl("^t_", program))
96		#'
97		filter_spec <- function(spec, filter_expr, verbose = TRUE) {
98	3x	if (is.character(substitute(filter_expr))) {
99	!	warn_about_legacy_filtering(filter_expr)
100	!	condition <- bquote(output == .(filter_expr))
101		} else {
102	3x	condition <- substitute(filter_expr)
103		}
104	3x	stopifnot(is_spec(spec), is.language(condition), is.logical(verbose))
105	3x	vars <- all.vars(condition)
106
107	3x	filtered_spec <- Filter(function(output) {
108	105x	assert_exists_in_spec_or_calling_env(vars, output)
109	105x	p <- eval(condition, envir = output)
110	105x	assert_is_valid_filter_result(p)
111	105x	p
112	3x	}, spec)
113
114	3x	if (verbose) {
115	3x	log_number_of_matched_records(spec, filtered_spec, condition)
116		}
117
118	3x	as_spec(filtered_spec)
119		}
120
121		is_spec <- function(x) {
122	3x	"spec" %in% class(x)
123		}
124
125		as_spec <- function(x) {
126	7x	spec <- lapply(x, function(elem) {
127	176x	if (is.null(elem$suffix)) {
128	!	elem$suffix <- ""
129		}
130
131	176x	if (elem$suffix == "") {
132	!	elem$output <- elem$program
133		} else {
134	176x	elem$output <- paste(elem$program, elem$suffix, sep = "_")
135		}
136
137	176x	if (is.null(elem$paper)) {
138	12x	elem$paper <- default_paper_size(elem$program)
139	164x	} else if (elem$paper == "a4r") {
140	!	warn_about_legacy_paper_size("a4r", "L11")
141	!	elem$paper <- "L11"
142	164x	} else if (elem$paper == "a4") {
143	!	warn_about_legacy_paper_size("a4", "P11")
144	!	elem$paper <- "P11"
145		} else {
146	164x	validate_paper_size(elem$paper)
147		}
148
149	176x	elem
150		})
151
152	7x	structure(
153	7x	.Data = spec,
154	7x	names = map_chr(spec, `[[`, "output"),
155	7x	class = union("spec", class(x))
156		)
157		}

1		#' Adverse event summary table
2		#'
3		#' @param adsl ADSL dataset, dataframe
4		#' @param adae ADAE dataset, dataframe
5		#' @param arm Arm variable, character, "`TRT01A" by default.
6		#' @param dose_adjust_flags Character or a vector of characters. Each character is a variable
7		#' name in adae dataset. These variables are Logical vectors which flag AEs
8		#' leading to dose adjustment, such as drug discontinuation, dose interruption
9		#' and reduction. The flag can be related to any drug, or a specific drug.
10		#' @param dose_adjust_labels Character or a vector of characters. Each character represents
11		#' a label displayed in the AE summary table (e.g. AE leading to discontinuation
12		#' from drug X). The order of the labels should match the order of variable
13		#' names in \code{dose_adjust_flags}.
14		#' @param gr34_highest_grade_only A logical value. Default is TRUE, such that
15		#' only patients with the highest AE grade as 3 or 4 are included for the count of the "Grade 3-4 AE" and
16		#' "Treatment-related Grade 3-4 AE" ; set it to FALSE if
17		#' you want to include patients with the highest AE grade as 5.
18		#'
19		#' @return an rtables object
20		#' @export
21		#'
22		#' @examples
23		#' library(dplyr)
24		#' ADSL <- eg_adsl
25		#' ADAE <- eg_adae
26		#'
27		#' ADAE <- ADAE %>%
28		#' dplyr::mutate(ATOXGR = AETOXGR)
29		#' t_ae_summ_slide(adsl = ADSL, adae = ADAE)
30		#'
31		#' # add flag for ae leading to dose reduction
32		#' ADAE$reduce_flg <- ifelse(ADAE$AEACN == "DOSE REDUCED", TRUE, FALSE)
33		#' t_ae_summ_slide(
34		#' adsl = ADSL, adae = ADAE,
35		#' dose_adjust_flags = c("reduce_flg"),
36		#' dose_adjust_labels = c("AE leading to dose reduction of drug X")
37		#' )
38		#' # add flgs for ae leading to dose reduction, drug withdraw and drug interruption
39		#' ADAE$withdraw_flg <- ifelse(ADAE$AEACN == "DRUG WITHDRAWN", TRUE, FALSE)
40		#' ADAE$interrup_flg <- ifelse(ADAE$AEACN == "DRUG INTERRUPTED", TRUE, FALSE)
41		#' out <- t_ae_summ_slide(
42		#' adsl = ADSL, adae = ADAE, arm = "TRT01A",
43		#' dose_adjust_flags = c("withdraw_flg", "reduce_flg", "interrup_flg"),
44		#' dose_adjust_labels = c(
45		#' "AE leading to discontinuation from drug X",
46		#' "AE leading to drug X reduction",
47		#' "AE leading to drug X interruption"
48		#' )
49		#' )
50		#' print(out)
51		#' generate_slides(out, paste0(tempdir(), "/ae_summary.pptx"))
52		t_ae_summ_slide <- function(adsl, adae, arm = "TRT01A",
53		dose_adjust_flags = NA,
54		dose_adjust_labels = NA,
55		gr34_highest_grade_only = TRUE) {
56		# The gr3-4 only count the patients whose highest ae grade is 3 or 4
57	5x	assert_that(has_name(adae, "TRT01A"))
58	5x	assert_that(has_name(adae, "AEDECOD"))
59	5x	assert_that(has_name(adae, "AEBODSYS"))
60	5x	assert_that(has_name(adae, "ATOXGR"))
61	5x	assert_that(has_name(adae, "AEREL"))
62	5x	assert_that(has_name(adae, "ANL01FL"))
63	5x	assert_that(has_name(adae, "SAFFL"))
64	5x	assert_that(has_name(adae, "TRTEMFL"))
65	5x	assert_that(has_name(adae, "AESER"))
66	5x	assert_that(length(dose_adjust_flags) == length(dose_adjust_labels))
67	5x	assert_that(assertthat::is.flag(gr34_highest_grade_only))
68
69
70	4x	if (sum(is.na(dose_adjust_flags)) == 0 & sum(is.na(dose_adjust_labels)) == 0) {
71	3x	for (txt in dose_adjust_flags) {
72	9x	assert_that(all(unlist(adae[txt]) %in% c(TRUE, FALSE)))
73	9x	assert_that(has_name(adae, txt))
74		}
75		}
76
77	4x	adsl1 <- adsl %>%
78	4x	select("STUDYID", "USUBJID", "TRT01A")
79
80	4x	pts_gr5 <- adae %>% filter(ATOXGR %in% c(5))
81
82	4x	anl <- adae %>%
83	4x	mutate_at(
84	4x	c("AEDECOD", "AEBODSYS"),
85	4x	~ explicit_na(sas_na(.)) # Replace blank arm with <Missing>
86		) %>%
87	4x	mutate(
88	4x	ATOXGR = sas_na(ATOXGR) %>% as.factor(),
89	4x	ATOXGR2 = case_when(
90	4x	ATOXGR %in% c(1, 2) ~ "1 - 2",
91	4x	ATOXGR %in% c(3, 4) ~ "3 - 4",
92	4x	ATOXGR %in% c(5) ~ "5",
93	4x	) %>% as.factor(),
94	4x	TRT01A = sas_na(TRT01A) %>% as.factor()
95		) %>%
96	4x	semi_join(., adsl1, by = c("STUDYID", "USUBJID")) %>%
97	4x	filter(ANL01FL == "Y" & TRTEMFL == "Y" & SAFFL == "Y") %>%
98	4x	formatters::var_relabel(
99	4x	ATOXGR2 = "AE Grade 3 groups",
100	4x	ATOXGR = "AE Grade",
101	4x	TRT01A = "Actual Treatment 01"
102		) %>%
103		# ---------- ADAE: Treatment related flags ---------
104	4x	mutate(
105	4x	TMPFL1_REL0 = AEREL == "Y"
106		) %>%
107	4x	formatters::var_relabel(
108	4x	TMPFL1_REL0 = "Any treatment"
109		) %>%
110		# ---------- ADAE: Grade 5 and related flags ---------
111	4x	mutate(
112	4x	TMPFL1_G5 = ATOXGR %in% c(5),
113	4x	TMPFL1_G5_REL = ATOXGR %in% c(5) & AEREL == "Y"
114		) %>%
115	4x	formatters::var_relabel(
116	4x	TMPFL1_G5 = "Grade 5 AE",
117	4x	TMPFL1_G5_REL = "Treatment-related Grade 5 AE"
118		) %>%
119		# ---------- ADAE: SAE and related flags ---------
120	4x	mutate(
121	4x	TMPFL1_SER = AESER == "Y",
122	4x	TMPFL1_SER_REL = AESER == "Y" & AEREL == "Y"
123		) %>%
124	4x	formatters::var_relabel(
125	4x	TMPFL1_SER = "Serious AE",
126	4x	TMPFL1_SER_REL = "Treatment-related Serious AE"
127		)
128
129		# ---------- ADAE: Grade 3/4 and related flags ---------
130	4x	if (gr34_highest_grade_only == TRUE) {
131	3x	anl <- anl %>%
132	3x	mutate(
133	3x	TMPFL1_G34 = ATOXGR %in% c(3, 4) & !(USUBJID %in% pts_gr5$USUBJID), # Only count the highest grade is 3 or 4
134	3x	TMPFL1_G34_REL = ATOXGR %in% c(3, 4) & AEREL == "Y" & !(USUBJID %in% pts_gr5$USUBJID)
135		) %>%
136	3x	formatters::var_relabel(
137	3x	TMPFL1_G34 = "Grade 3-4 AE",
138	3x	TMPFL1_G34_REL = "Treatment-related Grade 3-4 AE"
139		)
140		} else {
141	1x	anl <- anl %>%
142	1x	mutate(
143	1x	TMPFL1_G34 = ATOXGR %in% c(3, 4),
144	1x	TMPFL1_G34_REL = ATOXGR %in% c(3, 4) & AEREL == "Y"
145		) %>%
146	1x	formatters::var_relabel(
147	1x	TMPFL1_G34 = "Grade 3-4 AE",
148	1x	TMPFL1_G34_REL = "Treatment-related Grade 3-4 AE"
149		)
150		}
151
152	4x	if (nrow(anl) == 0) {
153	1x	return(null_report())
154		} else {
155	3x	lyt <- basic_table() %>%
156	3x	split_cols_by(arm, split_fun = add_overall_level("All Patients", first = FALSE)) %>%
157	3x	add_colcounts() %>%
158	3x	count_patients_with_event(
159	3x	vars = "USUBJID",
160	3x	filters = c("SAFFL" = "Y"),
161	3x	denom = "N_col",
162	3x	.stats = "count_fraction",
163	3x	.labels = c(count_fraction = "All grade AEs, any cause"),
164	3x	table_names = "U",
165		# .formats = list(trim_perc1)
166		) %>%
167	3x	count_patients_with_flags(
168	3x	"USUBJID",
169	3x	flag_variables = c(TMPFL1_REL0 = "Related"),
170	3x	denom = "N_col",
171	3x	.indent_mods = 1L,
172	3x	var_labels = "TMPFL1 Related"
173		# .format = list(trim_perc1)
174		) %>%
175	3x	count_patients_with_flags(
176	3x	"USUBJID",
177	3x	flag_variables = c(TMPFL1_G34 = "Grade 3-4 AEs"),
178	3x	denom = "N_col",
179	3x	.indent_mods = 0L,
180	3x	var_labels = "Grade 3-4 AEs"
181		# .format = list(trim_perc1)
182		) %>%
183	3x	count_patients_with_flags(
184	3x	"USUBJID",
185	3x	flag_variables = c(TMPFL1_G34_REL = "Related"),
186	3x	denom = "N_col",
187	3x	.indent_mods = 1L,
188	3x	var_labels = "TMPFL1_G34 Related"
189		# .format = list(trim_perc1)
190		) %>%
191	3x	count_patients_with_flags(
192	3x	"USUBJID",
193	3x	flag_variables = c(TMPFL1_G5 = "Grade 5 AE"),
194	3x	denom = "N_col",
195	3x	.indent_mods = 0L,
196	3x	var_labels = "Grade 5 AE"
197		# .format = list(trim_perc1)
198		) %>%
199	3x	count_patients_with_flags(
200	3x	"USUBJID",
201	3x	flag_variables = c(TMPFL1_G5_REL = "Related"),
202	3x	denom = "N_col",
203	3x	.indent_mods = 1L,
204	3x	var_labels = "TMPFL1_G5 Related"
205		# .format = list(trim_perc1)
206		) %>%
207	3x	count_patients_with_flags(
208	3x	"USUBJID",
209	3x	flag_variables = c(TMPFL1_SER = "SAEs"),
210	3x	denom = "N_col",
211	3x	.indent_mods = 0L,
212	3x	var_labels = "SAEs"
213		# .format = list(trim_perc1)
214		) %>%
215	3x	count_patients_with_flags(
216	3x	"USUBJID",
217	3x	flag_variables = c(TMPFL1_SER_REL = "Related"),
218	3x	denom = "N_col",
219	3x	.indent_mods = 1L,
220	3x	var_labels = "TMPFL1_SEA Related"
221		# .format = list(trim_perc1)
222		)
223
224	3x	if (sum(is.na(dose_adjust_flags)) == 0 & sum(is.na(dose_adjust_labels)) == 0) {
225	3x	for (i in 1:length(dose_adjust_flags)) {
226	9x	text <- paste0(
227	9x	' lyt <- lyt %>%
228	9x	count_patients_with_flags(
229	9x	"USUBJID",
230	9x	flag_variables = c(', dose_adjust_flags[i], "='", dose_adjust_labels[i],
231		"'),
232	9x	denom = 'N_col',
233	9x	var_labels = paste('dose adjust',i),
234	9x	.indent_mods = 0L)"
235		)
236	9x	eval(parse(text = text))
237		}
238		}
239
240	3x	result <- build_table(
241	3x	lyt,
242	3x	df = anl,
243	3x	alt_counts_df = adsl
244		)
245	3x	result@main_title <- "AE summary table"
246		}
247
248	3x	return(result)
249		}

1		#' Discontinue table
2		#' @param adsl ADSL data
3		#' @param arm Arm variable, character, "`TRT01P" by default.
4		#' @param split_by_study Split by study, building structured header for tables
5		#' @param side_by_side "GlobalAsia" or "GlobalAsiaChina" to define the side by side requirement
6		#' @inherit gen_notes note
7		#' @export
8		#' @examples
9		#' library(dplyr)
10		#' adsl <- eg_adsl %>%
11		#' mutate(DISTRTFL = sample(c("Y", "N"), size = nrow(eg_adsl), replace = TRUE, prob = c(.1, .9))) %>%
12		#' preprocess_t_ds()
13		#' out1 <- t_ds_slide(adsl, "TRT01P")
14		#' print(out1)
15		#' generate_slides(out1, paste0(tempdir(), "/ds.pptx"))
16		#'
17		#' out2 <- t_ds_slide(adsl, "TRT01P", split_by_study = TRUE)
18		#' print(out2)
19		#'
20		t_ds_slide <- function(adsl, arm = "TRT01P",
21		split_by_study = FALSE,
22		side_by_side = NULL) {
23	8x	assert_that(has_name(adsl, arm))
24	8x	assert_that(has_name(adsl, "SAFFL"))
25	8x	assert_that(has_name(adsl, "STDONS"),
26	8x	msg = "`STDONS` variable is needed for this output, please use `preprocess_t_ds` function to derive."
27		)
28	8x	assert_that(has_name(adsl, "DCSREAS"))
29	8x	assert_that(length(levels(adsl$STDONS)) <= 3)
30
31	8x	adsl1 <- adsl %>%
32	8x	mutate(
33	8x	STDONS = factor(explicit_na(sas_na(STDONS)),
34	8x	levels = c("Alive: On Treatment", "Alive: In Follow-up", "<Missing>"),
35	8x	labels = c("On Treatment", "In Follow-up", "<Missing>")
36		),
37	8x	DCSREAS = str_to_title(factor(sas_na(DCSREAS))),
38	8x	DCSflag = ifelse(is.na(DCSREAS), "N", "Y"),
39	8x	STDONSflag = ifelse(STDONS == "<Missing>", "N", "Y")
40		) %>%
41	8x	mutate_at(c("STDONS", "DCSREAS"), ~ as.factor(explicit_na(.))) %>%
42	8x	formatters::var_relabel(
43	8x	STDONS = "On-study Status",
44	8x	DCSflag = "Discontinued the study"
45		)
46
47	8x	if (!is.null(side_by_side)) {
48	3x	adsl1$lvl <- "Global"
49		}
50
51	8x	lyt <- build_table_header(adsl1, arm, split_by_study = split_by_study, side_by_side = side_by_side)
52
53	8x	lyt <- lyt %>%
54	8x	count_values("SAFFL",
55	8x	values = "Y",
56	8x	.labels = c(count_fraction = "Received Treatment")
57		) %>%
58	8x	split_rows_by(
59	8x	"STDONSflag",
60	8x	split_fun = keep_split_levels("Y"),
61		) %>%
62	8x	summarize_row_groups(label_fstr = "On-study Status") %>%
63	8x	analyze_vars(
64	8x	"STDONS",
65	8x	.stats = "count_fraction",
66	8x	denom = "N_col",
67	8x	na.rm = TRUE,
68		# var_labels = formatters::var_labels(adsl1)["STDONS"]
69		) %>%
70	8x	split_rows_by(
71	8x	"DCSflag",
72	8x	split_fun = keep_split_levels("Y"),
73		) %>%
74	8x	summarize_row_groups(label_fstr = "Discontinued the study") %>%
75	8x	analyze_vars(
76	8x	"DCSREAS",
77	8x	.stats = "count_fraction",
78	8x	denom = "N_col"
79		)
80
81	8x	result <- lyt_to_side_by_side(lyt, adsl1, side_by_side)
82	8x	result@main_title <- "Discontinue table"
83	8x	return(result)
84		}

1		#' s3 method for to_flextable
2		#' @param x object to to_flextable
3		#' @param ... additional arguments passed to methods
4		to_flextable <- function(x, ...) {
5	308x	UseMethod("to_flextable")
6		}
7
8
9		#' default method to to_flextable
10		#' @param x object to to_flextable
11		#' @param ... additional arguments. not used.
12		#'
13		#' @export
14		to_flextable.default <- function(x, ...) {
15	!	stop("default to_flextable function does not exist")
16		}
17
18
19		#' To flextable
20		#'
21		#' @details convert the dataframe object into flextable, and merge the cells
22		#' that have colspan > 1. align the columns to the middle, and the row.names to
23		#' the left. indent the row.names by 10 times indention. titles are added in headerlines,
24		#' footnotes are added in footer lines,
25		#' The width of the columns are aligned based on autofit() of officer function.
26		#' For paginated table, the width of the 1st column are set as the widest 1st column among paginated tables
27		#' @param x Decorated dataframe with title and footnote as attributes
28		#' @param lpp \{lpp\} from \{paginate_table\}. numeric. Maximum lines per page
29		#' @param ... arguments passed to program
30		#'
31		#' @export
32		#'
33		to_flextable.Ddataframe <- function(x, lpp, ...) {
34		# paginate VTableTree
35		Ddf <- x
36		df <- Ddf@df
37
38		page_max <- ceiling(nrow(df) / lpp)
39		pag_df <- split(df, rep(1:page_max, each = lpp))
40
41		ft_list <- lapply(1:length(pag_df), function(x) {
42		ft <- to_flextable(pag_df[[x]], ...)
43		list(
44		ft = ft,
45		header = ifelse(x == 1, Ddf@titles, paste(Ddf@titles, "(cont.)")),
46		footnotes = Ddf@footnotes
47		)
48		})
49
50		# force the width of the 1st column to be the widest of all paginated table
51		ft_list_resize <- set_width_widest(ft_list)
52		class(ft_list_resize) <- "dflextable"
53
54		ft_list_resize
55		}
56
57		#' To flextable
58		#'
59		#' Convert the dataframe into flextable, and merge the cells
60		#' that have colspan > 1. align the columns to the middle, and the row.names to
61		#' the left. indent the row.names by 10 times indention.
62		#'
63		#' @param x dataframe
64		#' @param lpp \{lpp\} from \{paginate_table\}. numeric. Maximum lines per page
65		#' @param table_format Table format
66		#' @export
67		to_flextable.Ddataframe <- function(x, lpp, table_format = table_format, ...) {
68	!	df <- x
69	!	if (all(is.na(formatters::var_labels(df)))) {
70	!	formatters::var_labels(df) <- names(df)
71		}
72	!	ft <- flextable(df)
73	!	ft <- set_header_labels(ft, values = as.list(formatters::var_labels(df)))
74
75		# if(!is.null(apply_theme)){
76		# ft <- ft %>%
77		# apply_theme()
78		# }
79
80	!	ft <- ft %>%
81	!	align_text_col(align = "center", header = TRUE) %>%
82	!	align(i = seq_len(nrow(df)), j = 1, align = "left") %>% # row names align to left
83	!	border(border = fp_border(color = border_color, width = 1), part = "all") %>%
84	!	padding(padding.top = 3, padding.bottom = 3, part = "all") %>%
85	!	autofit(add_h = 0) %>%
86	!	table_format()
87
88	!	ft <- ft %>%
89	!	width(width = c(
90	!	dim(ft)$widths[1],
91	!	dim(ft)$widths[-1] - dim(ft)$widths[-1] + sum(dim(ft)$widths[-1]) / (ncol(df) - 1)
92	!	)) # even the non-label column width
93
94	!	if (flextable_dim(ft)$widths > 10) {
95	!	pgwidth <- 10.5
96	!	ft <- ft %>%
97	!	width(width = dim(ft)$widths * pgwidth / flextable_dim(ft)$widths)
98		# adjust width of each column as percentage of total width
99		}
100
101	!	return(ft)
102		}
103
104		#' convert gtsummary to flextable
105		#' @export
106		to_flextable.gtsummary <- function(x, ...) {
107	!	ft <- x %>%
108	!	gtsummary::as_flex_table()
109
110	!	ft
111		}
112
113		#' convert dgtsummary to flextable
114		#' @export
115		to_flextable.dgtsummary <- function(x, ...) {
116	1x	ft <- x %>%
117	1x	gtsummary::as_flex_table()
118		}
119
120
121
122
123		#' convert data.frame to flextable
124		#' @export
125		to_flextable.data.frame <- function(x, col_width = NULL, table_format = orange_format,
126		dose_template = FALSE, font_size = 9, ...) {
127	272x	df <- x
128	272x	ft <- do_call(flextable, data = df, ...)
129
130	272x	if (dose_template) {
131	!	ft <- ft %>%
132	!	autofit() %>%
133	!	fit_to_width(10)
134		} else {
135	272x	if (all(is.na(formatters::var_labels(df)))) {
136	!	formatters::var_labels(df) <- names(df)
137		}
138
139	272x	ft <- set_header_labels(ft, values = as.list(formatters::var_labels(df)))
140	272x	ft <- ft %>% width(width = col_width)
141	272x	if (flextable_dim(ft)$widths > 10) {
142	272x	pgwidth <- 10.5
143	272x	ft <- ft %>%
144	272x	width(width = dim(ft)$widths * pgwidth / flextable_dim(ft)$widths)
145		# adjust width of each column as percentage of total width
146		}
147		}
148
149	272x	ft <- ft %>%
150	272x	table_format(...) %>%
151	272x	fontsize(size = font_size, part = "all")
152
153	272x	return(ft)
154		}
155
156
157		old_paginate_listing <- function(lsting,
158		page_type = "letter",
159		font_family = "Courier",
160		font_size = 8,
161		lineheight = 1,
162		landscape = FALSE,
163		pg_width = NULL,
164		pg_height = NULL,
165		margins = c(top = .5, bottom = .5, left = .75, right = .75),
166		lpp = NA_integer_,
167		cpp = NA_integer_,
168		colwidths = formatters::propose_column_widths(lsting),
169		tf_wrap = !is.null(max_width),
170		max_width = NULL,
171		verbose = FALSE) {
172	1x	checkmate::assert_class(lsting, "listing_df")
173	1x	checkmate::assert_numeric(colwidths, lower = 0, len = length(listing_dispcols(lsting)), null.ok = TRUE)
174	1x	checkmate::assert_flag(tf_wrap)
175	1x	checkmate::assert_count(max_width, null.ok = TRUE)
176	1x	checkmate::assert_flag(verbose)
177
178	1x	indx <- formatters::paginate_indices(lsting,
179	1x	page_type = page_type,
180	1x	font_family = font_family,
181	1x	font_size = font_size,
182	1x	lineheight = lineheight,
183	1x	landscape = landscape,
184	1x	pg_width = pg_width,
185	1x	pg_height = pg_height,
186	1x	margins = margins,
187	1x	lpp = lpp,
188	1x	cpp = cpp,
189	1x	colwidths = colwidths,
190	1x	tf_wrap = tf_wrap,
191	1x	max_width = max_width,
192	1x	rep_cols = length(get_keycols(lsting)),
193	1x	verbose = verbose
194		)
195
196	1x	vert_pags <- lapply(
197	1x	indx$pag_row_indices,
198	1x	function(ii) lsting[ii, ]
199		)
200	1x	dispnames <- listing_dispcols(lsting)
201	1x	full_pag <- lapply(
202	1x	vert_pags,
203	1x	function(onepag) {
204	272x	if (!is.null(indx$pag_col_indices)) {
205	272x	lapply(
206	272x	indx$pag_col_indices,
207	272x	function(jj) {
208	272x	res <- onepag[, dispnames[jj], drop = FALSE]
209	272x	listing_dispcols(res) <- intersect(dispnames, names(res))
210	272x	res
211		}
212		)
213		} else {
214	!	list(onepag)
215		}
216		}
217		)
218
219	1x	ret <- unlist(full_pag, recursive = FALSE)
220	1x	ret
221		}
222
223
224		#' convert listing to flextable
225		#' @export
226		to_flextable.dlisting <- function(x, cpp, lpp, ...) {
227	1x	ddf <- x
228	1x	df <- ddf@lst
229	1x	col_width <- ddf@width
230	1x	pag_df <- old_paginate_listing(df, cpp = cpp, lpp = lpp)
231	1x	ft_list <- lapply(1:length(pag_df), function(x) {
232	272x	ft <- to_flextable(pag_df[[x]], col_width = col_width, ...)
233	272x	if (length(prov_footer(df)) == 0) {
234	272x	cat_foot <- main_footer(df)
235		} else {
236	!	cat_foot <- paste0(prov_footer(df), "\n", main_footer(df))
237		}
238
239	272x	if (length(cat_foot) == 0) {
240	!	cat_foot <- ""
241		}
242	272x	list(
243	272x	ft = ft,
244	272x	header = ifelse(x == 1, main_title(df), paste(main_title(df), "(cont.)")),
245	272x	footnotes = cat_foot
246		)
247		})
248		# force the width of the 1st column to be the widest of all paginated table
249		# ft_list_resize <- set_width_widest(ft_list)
250	1x	class(ft_list) <- "dflextable"
251
252	1x	ft_list
253		}
254
255
256
257		#' Covert rtables object to flextable
258		#'
259		#' @param x rtable(VTableTree) object
260		#' @param table_format a function that decorate a flextable and return a flextable
261		#' @export
262		to_flextable.VTableTree <- function(x, table_format = orange_format, ...) {
263	18x	tbl <- x
264	18x	mf <- formatters::matrix_form(tbl, indent_rownames = TRUE)
265	18x	nr_header <- attr(mf, "nrow_header")
266	18x	non_total_coln <- c(TRUE, !grepl("All Patients", names(tbl)))
267	18x	df <- as.data.frame(mf$strings[(nr_header + 1):(nrow(mf$strings)), , drop = FALSE])
268
269	18x	header_df <- as.data.frame(mf$strings[1:(nr_header), , drop = FALSE])
270
271		# if(concat_header){
272		# header_df <- lapply(header_df, function(x) {paste0(x, collapse = "\n")}) %>% as.data.frame
273		# }
274
275		# if(!total_col){
276		# df <- df[non_total_coln]
277		# header_df <- header_df[non_total_coln]
278		# }
279	18x	ft <- do_call(flextable, data = df, ...)
280	18x	ft <- ft %>%
281	18x	delete_part(part = "header") %>%
282	18x	add_header(values = header_df)
283
284		# if(!is.null(apply_theme)){
285		# ft <- ft %>%
286		# apply_theme()
287		# }
288
289	18x	ft <- do_call(table_format, ft = ft, ...)
290	18x	ft <- ft %>%
291	18x	merge_at_indice(lst = get_merge_index(mf$spans[(nr_header + 1):nrow(mf$spans), , drop = FALSE]), part = "body") %>%
292	18x	merge_at_indice(lst = get_merge_index(mf$spans[1:nr_header, , drop = FALSE]), part = "header") %>%
293	18x	align_text_col(align = "center", header = TRUE) %>%
294	18x	align(i = seq_len(nrow(tbl)), j = 1, align = "left") %>% # row names align to left
295	18x	padding_lst(mf$row_info$indent) %>%
296	18x	padding(padding.top = 3, padding.bottom = 3, part = "all") %>%
297	18x	autofit(add_h = 0)
298
299
300	18x	ft <- ft %>%
301	18x	width(width = c(
302	18x	dim(ft)$widths[1],
303	18x	dim(ft)$widths[-1] - dim(ft)$widths[-1] + sum(dim(ft)$widths[-1]) / (ncol(mf$strings) - 1)
304	18x	)) # even the non-label column width
305
306	18x	if (flextable_dim(ft)$widths > 10) {
307	9x	pgwidth <- 10.5
308	9x	ft <- ft %>%
309	9x	width(width = dim(ft)$widths * pgwidth / flextable_dim(ft)$widths)
310		# adjust width of each column as percentage of total width
311		}
312
313	18x	return(ft)
314		}
315
316
317		#' To flextable
318		#'
319		#' @param x decorated rtable(dVTableTree) object
320		#' @param lpp \{lpp\} from \link[rtables]{paginate_table}. numeric. Maximum lines per page
321		#' @param ... argument parameters
322		#' @details convert the VTableTree object into flextable, and merge the cells
323		#' that have colspan > 1. align the columns to the middle, and the row.names to
324		#' the left. indent the row.names by 10 times indention. titles are added in headerlines,
325		#' footnotes are added in footer lines,
326		#' The width of the columns are aligned based on autofit() of officer function.
327		#' For paginated table, the width of the 1st column are set as the widest 1st column among paginated tables
328		to_flextable.dVTableTree <- function(x, lpp, cpp, ...) {
329	17x	dtbl <- x
330		# paginate VTableTree
331	17x	pag_tbl <- paginate_table(dtbl@tbl, lpp = lpp, cpp = cpp)
332	17x	ft_list <- lapply(1:length(pag_tbl), function(x) {
333	17x	ft <- to_flextable(pag_tbl[[x]], ...)
334	17x	if (length(dtbl@tbl@provenance_footer) == 0) {
335	17x	cat_foot <- dtbl@footnotes
336		} else {
337	!	cat_foot <- paste0(dtbl@tbl@provenance_footer, "\n", dtbl@footnotes)
338		}
339
340	17x	list(
341	17x	ft = ft,
342	17x	header = ifelse(x == 1, dtbl@titles, paste(dtbl@titles, "(cont.)")),
343	17x	footnotes = cat_foot
344		)
345		})
346		# force the width of the 1st column to be the widest of all paginated table
347	17x	ft_list_resize <- set_width_widest(ft_list)
348	17x	class(ft_list_resize) <- "dflextable"
349
350	17x	ft_list_resize
351		}
352
353		g_export <- function(decorated_p) {
354	4x	ret <- list()
355
356	4x	ret$dml <- rvg::dml(
357	4x	ggobj = ggpubr::as_ggplot(decorated_p$grob),
358	4x	bg = "white",
359	4x	pointsize = 12,
360	4x	editable = TRUE
361		)
362	4x	ret$footnote <- decorated_p$footnotes
363	4x	ret$spec <- attributes(decorated_p)$spec
364
365	4x	ret
366		}
367
368		set_width_widest <- function(ft_list) {
369	17x	width1st <- max(unlist(lapply(ft_list, function(x) {
370	17x	x$ft$body$colwidths[1]
371		})))
372	17x	for (i in 1:length(ft_list)) {
373	17x	ft_list[[i]]$ft <- width(ft_list[[i]]$ft, 1, width = width1st)
374		}
375
376	17x	ft_list
377		}
378
379		get_merge_index_single <- function(span) {
380	253x	ret <- list()
381	253x	j <- 1
382	253x	while (j < length(span)) {
383	999x	if (span[j] != 1) {
384	1x	ret <- c(ret, list(j:(j + span[j] - 1)))
385		}
386	999x	j <- j + span[j]
387		}
388
389	253x	ret
390		}
391
392		get_merge_index <- function(spans) {
393	36x	ret <- lapply(seq_len(nrow(spans)), function(i) {
394	253x	ri <- spans[i, ]
395	253x	r <- get_merge_index_single(ri)
396	253x	lapply(r, function(s) {
397	1x	list(j = s, i = i)
398		})
399		})
400	36x	unlist(ret, recursive = FALSE, use.names = FALSE)
401		}
402
403		merge_at_indice <- function(ft, lst, part) {
404	36x	Reduce(function(ft, ij) {
405	1x	merge_at(ft, i = ij$i, j = ij$j, part = part)
406	36x	}, lst, ft)
407		}
408
409		padding_lst <- function(ft, indents) {
410	18x	Reduce(function(ft, s) {
411	231x	padding(ft, s, 1, padding.left = (indents[s] + 1) * 10)
412	18x	}, seq_len(length(indents)), ft)
413		}

1		format_xx <- function(str) {
2	2x	tern::format_xx(str)
3		}
4
5		#' Assert function to check the cutoff
6		#'
7		#' @param data dataframe
8		#' @param cutoff cutoff threshold
9		#' @return Set the cutoff value
10		#' @export
11		check_and_set_cutoff <- function(data, cutoff) {
12	27x	if (is.na(cutoff)) {
13	5x	cutoff <- 0
14		} else { # check cutoff is the same with the filter
15	22x	suffix <- attr(data, "filters")
16	22x	cutoff_suffix <- str_extract(string = paste(suffix, collapse = "_"), pattern = "(\\d+)(?=PER)") %>%
17	22x	as.numeric()
18	22x	if (!is.na(cutoff_suffix)) {
19	4x	assert_that(are_equal(cutoff, cutoff_suffix))
20		}
21		}
22
23	27x	cutoff
24		}
25
26		#' Replace NAs to NA
27		#'
28		#' @param table_df Table dataframe
29		#' @return Input dataframe with both column replaced to NA
30		#' @export
31		na_replace <- function(table_df) {
32	2x	if (length(colnames(table_df)) == 2) {
33	2x	col1_na <- which(is.na(table_df[1]))
34	2x	if (length(col1_na) > 0) {
35	1x	for (i in 1:length(col1_na)) {
36	1x	table_df[col1_na[i], 1] <- table_df[col1_na[i], 2]
37	1x	table_df[col1_na[i], 2] <- NA
38		}
39		}
40		}
41
42	2x	table_df
43		}
44
45		#' Concatenate arguments into a string
46		#'
47		#' @param ... arguments passed to program
48		#' @return No return value, called for side effects
49		#' @export
50		dec_paste <- function(...) {
51	2x	arguments <- list(
52		...
53		)
54
55	2x	if (!any(is.na(arguments))) {
56	2x	do.call("paste", arguments)
57		}
58		}
59
60		#' Convert list of numbers to vectors
61		#'
62		#' @param num_list list of numbers
63		#' @return No return value, called for side effects
64		#' @export
65		to_vector <- function(num_list) {
66	1x	sapply(num_list, function(x) {
67	2x	y <- unlist(x)
68	2x	if (is.null(y)) {
69	!	y <- NA
70		}
71	2x	y
72		})
73		}
74
75		#' Founding method
76		#' @param x number need to be rounded
77		#' @param digits number of digits
78		#' @return rounded value
79		#' @export
80		new_round <- function(x, digits = 1) {
81	22157x	posneg <- sign(x)
82	22157x	z <- abs(x) * 10^digits
83	22157x	z <- z + 0.5 + sqrt(.Machine$double.eps)
84	22157x	z <- trunc(z)
85	22157x	z <- z / 10^digits
86	22157x	z * posneg
87		}
88
89		#' Format of xx.xx (xx.xx)
90		#'
91		#' @param x input array
92		#' @param output output handle
93		#' @return formatted values
94		#' @export
95		trim_perc1 <- function(x, output) {
96	149x	paste0(x[1], " (", new_round(x[2] * 100, 1), ")")
97		}
98
99		#' Format of xx.xx (xx.x)
100		#'
101		#' @param x input array
102		#' @param output output handle
103		#' @return formatted values
104		#' @export
105		trim_perc <- function(x, output) {
106	1x	paste0(x[1], " (", new_round(x[2] * 100, 2), ")")
107		}
108
109		#' Format of (xx\%, xx\%)
110		#'
111		#' @param x input array
112		#' @param output output handle
113		#' @return formatted values
114		#' @export
115		perc_perc <- function(x, output) {
116	1x	paste0(new_round(x[1] * 100, 0), "% (", new_round(x[2] * 100, 0), "%)")
117		}
118
119		#' Format of xx.xx (xx.xx, xx.xx)
120		#'
121		#' @param x input array
122		#' @param output output handle
123		#' @return formatted values
124		#' @export
125		format_3d <- function(x, output) {
126	1x	paste0(new_round(x[1], 2), " (", new_round(x[2], 2), ", ", new_round(x[3], 2), ")")
127		}
128
129
130		#' survival time afun
131		#'
132		#' @param df data
133		#' @param .var variable of interest
134		#' @param is_event vector indicating event
135		#' @param control `control_surv_time()` by default
136		#' @return A function suitable for use in rtables::analyze() with element selection,
137		#' reformatting, and relabeling performed automatically.
138		#' @export
139		s_surv_time_1 <- function(df, .var, is_event, control = control_surv_time()) {
140		# assert_that(is_df_with_variables(df, list(tte = .var, is_event = is_event)),
141		# is.string(.var), is_numeric_vector(df[[.var]]), is_logical_vector(df[[is_event]]))
142
143	6x	conf_type <- control$conf_type
144	6x	conf_level <- control$conf_level
145	6x	quantiles <- control$quantiles
146	6x	formula <- as.formula(paste0(
147	6x	"Surv(", .var, ", ", is_event,
148	6x	") ~ 1"
149		))
150	6x	srv_fit <- survfit(
151	6x	formula = formula, data = df, conf.int = conf_level,
152	6x	conf.type = conf_type
153		)
154	6x	srv_tab <- summary(srv_fit, extend = TRUE)$table
155		# srv_qt_tab <- quantile(srv_fit, probs = quantiles)$quantile
156		# range_censor <- range_noinf(df[[.var]][!df[[is_event]]],
157		# na.rm = TRUE)
158		# range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)
159		# range <- range_noinf(df[[.var]], na.rm = TRUE)
160	6x	new_label <- paste0("Median (Months, ", conf_level * 100, "% CI)")
161
162	6x	list(
163	6x	median_ci = formatters::with_label(c(
164	6x	unname(srv_tab["median"]),
165	6x	unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))])
166	6x	), new_label)
167		)
168		}
169
170
171		s_coxph_pairwise_1 <- function(df, .ref_group, .in_ref_col, .var, is_event, strat = NULL,
172		control = control_coxph()) {
173		# assert_that(is_df_with_variables(df, list(tte = .var, is_event = is_event)),
174		# is.string(.var), is_numeric_vector(df[[.var]]), is_logical_vector(df[[is_event]]))
175	!	pval_method <- control$pval_method
176	!	ties <- control$ties
177	!	conf_level <- control$conf_level
178
179	!	strat_type <- ifelse(is.null(strat), "Unstratified", "Stratified")
180	!	if (.in_ref_col) {
181	!	return(
182	!	in_rows(
183	!	rcell(""),
184	!	rcell(""),
185	!	.labels = c(paste0(strat_type, " HR (", conf_level * 100, "% CI)"), paste0("p-value (", pval_method, ")"))
186		)
187		# list(hr_ci = formatters::with_label("", paste0("Stratified HR (", conf_level*100, "% CI)")),
188		# pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")"))
189		# )
190		)
191		}
192	!	data <- rbind(.ref_group, df)
193	!	group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))),
194	!	levels = c("ref", "x")
195		)
196	!	df_cox <- data.frame(
197	!	tte = data[[.var]], is_event = data[[is_event]],
198	!	arm = group
199		)
200	!	if (is.null(strat)) {
201	!	formula_cox <- Surv(tte, is_event) ~ arm
202		} else {
203	!	formula_cox <- as.formula(paste0(
204	!	"Surv(tte, is_event) ~ arm + strata(",
205	!	paste(strat, collapse = ","), ")"
206		))
207	!	df_cox <- cbind(df_cox, data[strat])
208		}
209	!	cox_fit <- coxph(formula = formula_cox, data = df_cox, ties = ties)
210	!	sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)
211	!	pval <- switch(pval_method,
212	!	wald = sum_cox$waldtest["pvalue"],
213	!	`log-rank` = sum_cox$sctest["pvalue"],
214	!	likelihood = sum_cox$logtest["pvalue"]
215		)
216	!	list(
217		# hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"),
218		# hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),
219	!	hr_ci = formatters::with_label(
220	!	c(sum_cox$conf.int[1, 1], unname(sum_cox$conf.int[1, 3:4])),
221	!	paste0("Stratified HR (", conf_level * 100, "% CI)")
222		),
223	!	pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")"))
224		)
225
226	!	in_rows(
227	!	rcell(c(sum_cox$conf.int[1, 1], unname(sum_cox$conf.int[1, 3:4])), format = format_3d),
228	!	rcell(unname(pval), format = "x.xxxx \| (<0.0001)"),
229	!	.labels = c(paste0("Stratified HR (", conf_level * 100, "% CI)"), paste0("p-value (", pval_method, ")"))
230		)
231		}
232
233		is_in_repository <- function() {
234	27x	system("git status", ignore.stdout = TRUE, ignore.stderr = TRUE) == 0
235		}
236
237		get_remote_url <- function() {
238	1x	repos <- system("git remote -v", intern = TRUE)
239	1x	str_extract(repos, "(https://\|git@).*.git")
240		}
241
242		get_last_gitcommit_sha <- function() {
243	1x	system("git rev-parse HEAD", intern = TRUE)
244		}
245
246		get_repo_head_name <- function() {
247	1x	system("git rev-parse --abbrev-ref HEAD", intern = TRUE)
248		}
249
250		warn <- function(...) {
251	4x	warning(..., call. = FALSE, immediate. = TRUE)
252		}
253
254		git_footnote <- function(for_test = FALSE) {
255	27x	if (is_in_repository()) {
256	!	remote_url <- get_remote_url()[1]
257	!	if (grepl("^https", remote_url)) {
258	!	https_url <- gsub("\\.git$", "", remote_url)
259		} else {
260	!	https_url <- gsub("^git@", "https://", gsub(":", "/", remote_url))
261		}
262
263	!	repo <- paste("GitHub repository:", https_url)
264	!	commit <- paste(
265	!	"Git hash:",
266	!	get_last_gitcommit_sha()
267		)
268	!	ret <- c(repo, commit)
269		} else {
270	27x	ret <- NULL
271		}
272
273	27x	if (for_test == TRUE) {
274	11x	ret <- NULL
275		}
276
277	27x	ret
278		}
279
280		datetime <- function() {
281		# eICE like format, e.g. 23SEP2020 12:40
282	3x	toupper(format(Sys.time(), "%d%b%Y %H:%M"))
283		}
284
285		enumerate <- function(x, quote = "`") {
286	3x	n <- length(x)
287	3x	if (n == 1L) {
288	2x	paste0(quote, x, quote)
289		} else {
290	1x	paste(
291	1x	paste(paste0(quote, x[-n], quote), collapse = ", "),
292	1x	paste("and", paste0(quote, x[n], quote))
293		)
294		}
295		}
296
297		map_lgl <- function(x, f, ...) {
298	109x	vapply(x, f, logical(1L), ..., USE.NAMES = FALSE)
299		}
300
301		map_num <- function(x, f, ...) {
302	1x	vapply(x, f, numeric(1L), ..., USE.NAMES = FALSE)
303		}
304
305		map_chr <- function(x, f, ...) {
306	7x	vapply(x, f, character(1L), ..., USE.NAMES = FALSE)
307		}
308
309
310		on_master_branch <- function() {
311	!	get_repo_head_name() %in% c("master", "main")
312		}
313
314
315		create_new_reporting_event <- function(name) {
316	1x	dir.create(name)
317	1x	file.create(file.path(name, "metadata.yml"))
318		}
319
320		create_output_name <- function(program, suffix) {
321	4x	ifelse(is.na(suffix) \| suffix == "", program, paste(program, suffix, sep = "_"))
322		}
323
324		default_paper_size <- function(program) {
325	12x	output_type <- substr(program, 1L, 1L)
326	12x	defaults <- c(l = "L8", t = "P8", g = "L11")
327	12x	if (output_type %in% names(defaults)) {
328	12x	unname(defaults[output_type])
329		} else {
330	!	"P8"
331		}
332		}
333
334		vbar2newline <- function(x) {
335	5x	gsub("\\s\\\|\\s", "\n", x)
336		}
337
338		munge_spaces <- function(text, wordboundary = "(\\t\|\\n\|\\x0b\|\\x0c\|\\r\| )") {
339	12x	stringr::str_replace_all(text, wordboundary, " ")
340		}
341
342		# split_chunk <- function(text, whitespace = "[\\t\\n\\x0b\\x0c\\r\\ ]") {
343		# wordsep_re <- sprintf("(%s+)", whitespace)
344		# strsplit(text, split = wordsep_re, perl = TRUE)
345		# }
346		split_chunk <- function(text, whitespace = "\\s+") {
347		# Split the string by one or more whitespace characters.
348	12x	chunks <- strsplit(text, split = whitespace, perl = TRUE)[[1]]
349		# Remove any empty strings that result from leading/trailing whitespace.
350	12x	chunks[chunks != ""]
351		}
352
353		wrap_chunk <- function(chunks, width) {
354	13x	if (length(chunks) == 0) {
355	1x	return(list())
356		}
357
358	12x	lines <- list()
359	12x	current_line <- ""
360
361	12x	while (length(chunks) > 0) {
362	57x	word <- chunks[1]
363	57x	if (nchar(word) > width) {
364		# If there's content on the current line, bank it first.
365	2x	if (current_line != "") {
366	2x	lines <- append(lines, current_line)
367		}
368
369	2x	lines <- append(lines, substr(word, 1, width))
370	2x	chunks[1] <- substr(word, width + 1, nchar(word))
371	2x	current_line <- ""
372	2x	next
373		}
374
375	55x	potential_line <- if (current_line == "") word else paste(current_line, word, sep = " ")
376
377	55x	if (nchar(potential_line) <= width) {
378	39x	current_line <- potential_line
379	39x	chunks <- chunks[-1]
380		} else {
381		# If it doesn't fit, bank the current line and start a new one with the word.
382	16x	lines <- append(lines, current_line)
383	16x	current_line <- word
384	16x	chunks <- chunks[-1]
385		}
386		}
387
388	12x	if (current_line != "") {
389	12x	lines <- append(lines, current_line)
390		}
391
392	12x	lines
393		}
394
395
396
397		text_wrap_cut <- function(text, width) {
398	8x	width <- as.integer(width)
399	8x	if (width <= 0) {
400	1x	return("")
401		}
402	7x	munged_text <- munge_spaces(text)
403	7x	chunks <- split_chunk(munged_text)
404	7x	wrapped_list <- wrap_chunk(chunks, width = width)
405	7x	paste(unlist(wrapped_list), collapse = "\n")
406		}
407
408		text_wrap_cut_keepreturn <- function(text, width) {
409	2x	if (is.na(width)) {
410	!	width <- 0
411		}
412	2x	lines <- strsplit(text, "\n")[[1]]
413	2x	wrapped_lines_list <- lapply(lines, function(line) {
414	5x	if (line == "") {
415		""
416		} else {
417	4x	text_wrap_cut(line, width)
418		}
419		})
420	2x	paste(wrapped_lines_list, collapse = "\n")
421		}
422
423
424		#' @noRd
425		fs <- function(paper) {
426	4x	fontsize <- as.integer(substr(paper, 2, nchar(paper)))
427	4x	orientation <- substr(paper, 1, 1)
428	4x	list(fontsize = fontsize, orientation = orientation)
429		}
430
431		validate_paper_size <- function(paper) {
432	171x	assert_is_character_scalar(paper)
433	171x	if (!grepl("^[P\|L][1-9][0-9]{0,1}$", paper)) {
434	3x	abort(
435	3x	"Page size must be starting with `L` or `P` to indicate the orientation of the page, ",
436	3x	"followed by an integer to indicate the fontsize"
437		)
438		}
439	168x	fontsize <- as.integer(substr(paper, 2, nchar(paper)))
440	168x	if (fontsize > 14) {
441	1x	abort("Fontsize should be less or equal than 14")
442		}
443		}
444
445		get_output_file_ext <- function(output, file_path) {
446	15x	ret <- ""
447	15x	if (tools::file_ext(file_path) != "") {
448	!	ret <- file_path
449		} else {
450	15x	file_ext <- ifelse(is_rtable(output) \|\| "dVTableTree" %in% class(output), "out", "pdf")
451	15x	ret <- sprintf("%s.%s", file_path, file_ext)
452		}
453
454	15x	ret
455		}
456
457		# make config global so that test-util recognizes it
458		.autoslider_config <- new.env(parent = emptyenv())
459
460		warn_about_legacy_filtering <- function(output) {
461	2x	if (.autoslider_config$filter_warning_issued) {
462	1x	return(invisible())
463		} else {
464	1x	.autoslider_config$filter_warning_issued <- TRUE
465		}
466
467	1x	msg <- sprintf(
468	1x	paste(
469	1x	"Filtering based upon a character scalar is deprecated.",
470	1x	"Please use `output == '%s'` instead."
471		),
472	1x	output
473		)
474	1x	warn(msg)
475		}
476
477		warn_about_legacy_paper_size <- function(old_paper_size,
478		new_paper_size) {
479	3x	if (.autoslider_config$paper_size_warning_issued[old_paper_size]) {
480	1x	return(invisible())
481		} else {
482	2x	.autoslider_config$paper_size_warning_issued[old_paper_size] <- TRUE
483		}
484
485	2x	msg <- sprintf(
486	2x	"Paper size '%s' is deprecated. Please use '%s' instead.",
487	2x	old_paper_size,
488	2x	new_paper_size
489		)
490	2x	warn(msg)
491		}
492
493
494
495		#' Build side by side layout by cbind
496		#'
497		#' @param lyt layout object
498		#' @param anl analysis data object
499		#' @param side_by_side A logical value indicating whether to display the data side by side.
500		#' @return An `rtables` layout
501		#' @export
502		lyt_to_side_by_side <- function(lyt, anl, side_by_side = NULL) {
503	27x	result <- build_table(lyt = lyt, df = anl)
504
505	26x	if (!is.null(side_by_side)) {
506	10x	if (grepl("Asia", side_by_side)) {
507	1x	tmp_anl <- anl %>% filter(COUNTRY %in% c("CHN", "HKG", "TWN", "KOR", "SGP", "THA", "MYS"))
508	1x	tmp_anl$lvl <- "Asia"
509	1x	result <- cbind_rtables(
510	1x	result,
511	1x	build_table(
512	1x	lyt = lyt,
513	1x	df = tmp_anl
514		)
515		)
516		}
517
518	10x	if (grepl("China", side_by_side)) {
519	8x	tmp_anl <- anl %>% filter(COUNTRY == "CHN")
520	8x	tmp_anl$lvl <- "China"
521	8x	result <- cbind_rtables(result, build_table(lyt = lyt, df = tmp_anl))
522		}
523		}
524	26x	return(result)
525		}
526
527		#' Build side by side layout by cbind
528		#' @param lyt layout object
529		#' @param anl analysis data object
530		#' @param side_by_side A logical value indicating whether to display the data side by side.
531		#' @param alt_counts_df alternative data frame for counts
532		#' @return An `rtables` layout
533		#' @export
534		lyt_to_side_by_side_two_data <- function(lyt, anl, alt_counts_df, side_by_side = NULL) {
535	28x	result <- build_table(lyt = lyt, df = anl, alt_counts_df = alt_counts_df)
536
537	28x	if (!is.null(side_by_side)) {
538	7x	if (grepl("Asia", side_by_side)) {
539	7x	countries <- c("CHN", "HKG", "TWN", "KOR", "SGP", "THA", "MYS")
540	7x	tmp_anl <- anl %>% filter(COUNTRY %in% countries)
541	7x	tmp_anl$lvl <- "Asia"
542	7x	tmp_alt <- alt_counts_df %>% filter(COUNTRY %in% countries)
543	7x	tmp_alt$lvl <- "Asia"
544
545	7x	result <- cbind_rtables(
546	7x	result,
547	7x	build_table(
548	7x	lyt = lyt,
549	7x	df = tmp_anl,
550	7x	alt_counts_df = tmp_alt
551		)
552		)
553		}
554
555	7x	if (grepl("China", side_by_side)) {
556	!	tmp_anl <- anl %>% filter(COUNTRY == "CHN")
557	!	tmp_anl$lvl <- "China"
558	!	tmp_alt <- alt_counts_df %>% filter(COUNTRY == "CHN")
559	!	tmp_alt$lvl <- "China"
560	!	result <- cbind_rtables(result, build_table(
561	!	lyt = lyt, df = tmp_anl,
562	!	alt_counts_df = tmp_alt
563		))
564		}
565		}
566	28x	return(result)
567		}
568
569
570		do_call <- function(fun, ...) {
571	602x	args <- list(...)
572	602x	do.call(fun, args[intersect(names(args), formalArgs(fun))])
573		}
574
575
576		#' Build table header, a utility function to help with construct structured header for table layout
577		#' @param anl analysis data object
578		#' @param arm Arm variable for column split
579		#' @param split_by_study, if true, construct structured header with the study ID
580		#' @param side_by_side A logical value indicating whether to display the data side by side.
581		#' @return A `rtables` layout with desired header.
582		#' @export
583		build_table_header <- function(anl,
584		arm,
585		split_by_study,
586		side_by_side) {
587	55x	lyt <- basic_table()
588	55x	if (is.null(side_by_side)) {
589	38x	if (split_by_study) {
590	6x	assert_that(length(unique(anl$STUDYID)) > 1)
591	6x	lyt <- lyt %>%
592	6x	split_cols_by(var = "STUDYID") %>%
593	6x	split_cols_by(var = arm)
594		} else {
595	32x	lyt <- lyt %>%
596	32x	split_cols_by(var = arm) %>%
597	32x	add_overall_col("All Patients")
598		}
599		} else {
600	17x	if (split_by_study) {
601	10x	warning("split_by_study argument will be ignored")
602		}
603	17x	lyt <- lyt %>%
604	17x	split_cols_by(var = "lvl") %>%
605	17x	split_cols_by(var = arm) %>%
606	17x	add_overall_col("All Patients")
607		}
608
609	55x	lyt
610		}
611
612
613		get_version_label_output <- function() {
614	1x	NULL
615		}
616
617
618		strip_NA <- function(input) {
619	21x	input[which(input != "NA")]
620		}

1		get_deepseek_key <- function(filename = "DEEPSEEK_KEY") {
2	!	scan(filename, what = "character", sep = NULL)
3		}
4
5		get_portkey_key <- function(filename = "PORTKEY_KEY") {
6	!	scan(filename, what = "character", sep = NULL)
7		}
8
9		get_system_prompt <- function(text = "you are a Clinical data scientist expert") {
10	!	return(text)
11		}
12
13		#' Get an `ellmer` chat API with given platform
14		#'
15		#' @param platform Platform provider
16		#' @param base_url Base url
17		#' @param api_key API key
18		#' @param model Model of choice
19		#'
20		#' @export
21		#'
22		get_ellmer_chat <- function(platform = "deepseek",
23		base_url = "https://api.deepseek.com",
24		api_key = get_deepseek_key(),
25		model = "deepseek-chat") {
26	!	chat <- NULL
27	!	if (platform == "deepseek") {
28	!	chat <- ellmer::chat_deepseek(
29	!	system_prompt = get_system_prompt(),
30	!	base_url = base_url,
31	!	api_key = api_key,
32	!	model = model
33		)
34	!	} else if (platform == "galileo") {
35	!	chat <- ellmer::chat_portkey(
36	!	system_prompt = get_system_prompt(),
37	!	base_url = base_url,
38	!	api_key = api_key,
39	!	model = model
40		)
41	!	} else if (platform == "openai") {
42	!	chat <- ellmer::chat_openai(
43	!	system_prompt = get_system_prompt(),
44	!	base_url = base_url,
45	!	api_key = api_key,
46	!	model = model
47		)
48	!	} else if (platform == "ollama") {
49	!	chat <- ellmer::chat_ollama(
50	!	system_prompt = get_system_prompt(),
51	!	base_url = base_url,
52	!	model = model
53		)
54		}
55
56	!	return(chat)
57		}
58
59		#' Read prompt list from yaml file
60		#'
61		#' @param filename File name
62		#'
63		#' @export
64		get_prompt_list <- function(filename) {
65	!	prompt <- yaml::read_yaml(filename, eval.expr = TRUE)
66	!	structure(
67	!	.Data = prompt,
68	!	names = map_chr(prompt, `[[`, "output"),
69	!	class = union("spec", class(prompt))
70		)
71		}
72
73
74		integrate_prompt <- function(base_prompt, tlg) {
75		# let's do figures in the future
76	!	ret <- paste(
77	!	"As a Clinical data scientist expert, here is a",
78	!	tlg@main_title, ":\n\n"
79		)
80	!	ret <- gsub("\\{table_text\\}", export_as_txt(tlg), base_prompt)
81	!	ret
82		}
83
84		#' Update footnote with AI response
85		#'
86		#' @param outputs Output objects
87		#' @param prompt_list List of prompt
88		#' @param platform Platform provider
89		#' @param base_url Base url
90		#' @param api_key API key
91		#' @param model Model of choice
92		#'
93		#' @export
94		get_ai_notes <- function(outputs, prompt_list, platform, base_url, api_key, model) {
95	!	chat <- get_ellmer_chat(platform, base_url, api_key, model)
96	!	names_outputs <- names(outputs)
97	!	ret <- lapply(names_outputs, function(output_name) {
98	!	output <- outputs[[output_name]]
99	!	if (is(output, "autoslider_error")) {
100	!	return(output)
101		}
102	!	if (output_name %in% names(prompt_list)) {
103	!	base_prompt <- prompt_list[[output_name]]$prompt
104	!	current_prompt <- integrate_prompt(base_prompt, output@tbl)
105	!	raw_response <- chat$chat(current_prompt)
106	!	clean_response <- sub(".?</think>\\s", "", raw_response)
107	!	output@usernotes <- paste(platform, model, "generated notes:", clean_response)
108		}
109	!	output
110		})
111	!	names(ret) <- names_outputs
112	!	ret
113		}

1		#' generate slides based on output
2		#'
3		#' @param outputs List of output
4		#' @param template Template file path
5		#' @param outfile Out file path
6		#' @param fig_width figure width in inch
7		#' @param fig_height figure height in inch
8		#' @param t_lpp An integer specifying the table lines per page \cr
9		#' Specify this optional argument to modify the length of all of the table displays
10		#' @param t_cpp An integer specifying the table columns per page\cr
11		#' Specify this optional argument to modify the width of all of the table displays
12		#' @param l_lpp An integer specifying the listing lines per page\cr
13		#' Specify this optional argument to modify the length of all of the listings display
14		#' @param l_cpp An integer specifying the listing columns per page\cr
15		#' Specify this optional argument to modify the width of all of the listings display
16		#' @param fig_editable whether we want the figure to be editable in pptx viewers, defaults to FALSE
17		#' @param ... arguments passed to program
18		#' @return No return value, called for side effects
19		#' @export
20		#' @examplesIf require(filters)
21		#'
22		#' # Example 1. When applying to the whole pipeline
23		#' library(dplyr)
24		#' data <- list(
25		#' adsl = eg_adsl %>% dplyr::mutate(FASFL = SAFFL),
26		#' adae = eg_adae
27		#' )
28		#'
29		#'
30		#' filters::load_filters(
31		#' yaml_file = system.file("filters.yml", package = "autoslider.core"),
32		#' overwrite = TRUE
33		#' )
34		#'
35		#'
36		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
37		#' spec_file %>%
38		#' read_spec() %>%
39		#' filter_spec(program %in% c("t_dm_slide")) %>%
40		#' generate_outputs(datasets = data) %>%
41		#' decorate_outputs() %>%
42		#' generate_slides()
43		#'
44		#' # Example 2. When applying to an rtable object or an rlisting object
45		#' adsl <- eg_adsl
46		#' t_dm_slide(adsl, "TRT01P", c("SEX", "AGE")) %>%
47		#' generate_slides()
48		generate_slides <- function(outputs,
49		outfile = paste0(tempdir(), "/output.pptx"),
50		template = file.path(system.file(package = "autoslider.core"), "theme/basic.pptx"),
51		fig_width = 9, fig_height = 5, t_lpp = 20, t_cpp = 200,
52		l_lpp = 20, l_cpp = 150, fig_editable = FALSE, ...) {
53	8x	if (any(c(
54	8x	is(outputs, "VTableTree"),
55	8x	is(outputs, "listing_df")
56		))) {
57	!	if (is(outputs, "listing_df")) {
58	!	current_title <- main_title(outputs)
59		} else {
60	!	current_title <- outputs@main_title
61		}
62	!	outputs <- list(
63	!	decorate(outputs, titles = current_title, footnotes = "Confidential and for internal use only")
64		)
65	8x	} else if (any(c(
66	8x	is(outputs, "data.frame"),
67	8x	is(outputs, "ggplot"),
68	8x	is(outputs, "gtsummary"),
69	8x	is(outputs, "dVTableTree"),
70	8x	is(outputs, "dlisting"),
71	8x	is(outputs, "grob")
72		))) {
73	!	if (is(outputs, "ggplot")) {
74	!	current_title <- outputs$labels$title
75	!	if (is.null(current_title)) {
76	!	current_title <- ""
77		}
78	!	outputs <- decorate.ggplot(outputs, titles = current_title)
79	!	} else if (is(outputs, "grob")) {
80	!	outputs <- decorate.grob(outputs)
81		}
82
83	!	outputs <- list(outputs)
84		}
85
86	8x	assert_that(is.list(outputs))
87
88		# ======== generate slides =======#
89		# set slides layout
90	8x	ppt <- read_pptx(path = template)
91	8x	location_ <- officer::fortify_location(ph_location_fullsize(), doc = ppt)
92	8x	width <- location_$width
93	8x	height <- location_$height
94
95		# add content to slides template
96	8x	for (x in outputs) {
97	22x	if (is(x, "dVTableTree") \|\| is(x, "VTableTree")) {
98	16x	y <- to_flextable(x, lpp = t_lpp, cpp = t_cpp, ...)
99	16x	usernotes <- x@usernotes
100	16x	for (tt in y) {
101	16x	table_to_slide(ppt,
102	16x	content = tt,
103	16x	table_loc = center_table_loc(tt$ft, ppt_width = width, ppt_height = height),
104	16x	usernotes = usernotes, ...
105		)
106		}
107	6x	} else if (is(x, "dlisting")) {
108	1x	y <- to_flextable(x, cpp = l_cpp, lpp = l_lpp, ...)
109	1x	for (tt in y) {
110	272x	table_to_slide(ppt,
111	272x	content = tt,
112	272x	table_loc = center_table_loc(tt$ft, ppt_width = width, ppt_height = height), ...
113		)
114		}
115	5x	} else if (is(x, "data.frame")) { # this is dedicated for small data frames without pagination
116	!	y <- to_flextable(x, ...)
117	!	table_to_slide(ppt, content = y, decor = FALSE, ...)
118	5x	} else if (is(x, "gtsummary") \|\| is(x, "dgtsummary")) {
119	1x	y <- to_flextable(x, ...)
120	1x	table_to_slide(ppt,
121	1x	content = y, decor = FALSE, ...
122		)
123		} else {
124	4x	if (any(class(x) %in% c("decoratedGrob", "decoratedGrobSet", "ggplot"))) {
125	4x	if (is(x, "ggplot")) {
126	!	x <- decorate.ggplot(x)
127		}
128
129	4x	assertthat::assert_that(is(x, "decoratedGrob") \|\| is(x, "decoratedGrobSet"))
130
131	4x	figure_to_slide(ppt,
132	4x	content = x, fig_width = fig_width, fig_height = fig_height,
133	4x	figure_loc = center_figure_loc(fig_width, fig_height, ppt_width = width, ppt_height = 1.17 * height),
134	4x	fig_editable = fig_editable, ...
135		)
136		} else {
137	!	if (is(x, "autoslider_error")) {
138	!	message(x)
139		} else {
140	!	next
141		}
142		}
143		}
144		}
145	8x	print(ppt, target = outfile)
146		}
147
148		#' Generate flextable for preview first page
149		#'
150		#' @param x rtables or data.frame
151		#' @return A flextable or a ggplot object depending to the input.
152		#' @export
153		#' @examples
154		#' # Example 1. preview table
155		#' library(dplyr)
156		#' adsl <- eg_adsl
157		#' t_dm_slide(adsl, "TRT01P", c("SEX", "AGE")) %>% slides_preview()
158		slides_preview <- function(x) {
159	1x	if (is(x, "VTableTree")) {
160	1x	ret <- to_flextable(paginate_table(x, lpp = 20)[[1]])
161	!	} else if (is(x, "listing_df")) {
162	!	new_colwidth <- formatters::propose_column_widths(x)
163	!	ret <- to_flextable(old_paginate_listing(x, cpp = 150, lpp = 20)[[1]],
164	!	col_width = new_colwidth
165		)
166	!	} else if (is(x, "ggplot")) {
167	!	ret <- x
168		} else {
169	!	stop("Unintended usage!")
170		}
171	1x	ret
172		}
173
174		get_body_bottom_location <- function(ppt) {
175	!	location_ <- officer::fortify_location(ph_location_fullsize(), doc = ppt)
176	!	width <- location_$width
177	!	height <- location_$height
178	!	top <- 0.7 * height
179	!	left <- 0.1 * width
180	!	ph <- ph_location(left = left, top = top)
181	!	ph
182		}
183
184
185		#' create location container to center the table
186		#'
187		#' @param ft Flextable object
188		#' @param ppt_width Powerpoint width
189		#' @param ppt_height Powerpoint height
190		#' @return Location for a placeholder
191		center_table_loc <- function(ft, ppt_width, ppt_height) {
192	288x	top <- (ppt_height - sum(dim(ft)$heights)) / 2
193	288x	left <- (ppt_width - sum(dim(ft)$widths)) / 2
194	288x	ph <- ph_location(left = left, top = top)
195	288x	ph
196		}
197
198		#' Adjust title line break and font size
199		#'
200		#' @param title Character string
201		#' @param max_char Integer specifying the maximum number of characters in one line
202		#' @param title_color Title color
203		get_proper_title <- function(title, max_char = 60, title_color = "#1C2B39") {
204		# cat(nchar(title), " ", as.integer(24-nchar(title)/para), "\n")
205	292x	title <- gsub("\\n", "\\s", title)
206	292x	new_title <- ""
207
208	292x	while (nchar(title) > max_char) {
209	278x	spaces <- gregexpr("\\s", title)
210	278x	new_title <- paste0(new_title, "\n", substring(title, 1, max(spaces[[1]][spaces[[1]] <= max_char])))
211	278x	title <- substring(title, max(spaces[[1]][spaces[[1]] <= max_char]) + 1, nchar(title))
212		}
213
214	292x	new_title <- paste0(new_title, "\n", title)
215
216	292x	ftext(
217	292x	trimws(new_title),
218	292x	fp_text(
219	292x	font.size = floor(26 - nchar(title) / max_char),
220	292x	color = title_color
221		)
222		)
223		}
224
225		#' Add decorated flextable to slides
226		#'
227		#' @param ppt Slide
228		#' @param content Content to be added
229		#' @param table_loc Table location
230		#' @param usernotes User notes
231		#' @param decor Should table be decorated
232		#' @param ... additional arguments
233		#' @return Slide with added content
234		table_to_slide <- function(ppt, content, decor = TRUE, table_loc = ph_location_type("body"),
235		usernotes = "", ...) {
236	289x	ppt_master <- layout_summary(ppt)$master[1]
237	289x	args <- list(...)
238		# until officer 0.6.10 ppt <- layout_default(ppt, "Title and Content")
239
240	289x	if (decor) {
241	288x	print(content$header)
242	288x	out <- content$ft
243
244	288x	if (length(content$footnotes) > 1) {
245	9x	content$footnotes <- paste(content$footnotes, collapse = "\n")
246		}
247		# print(content_footnotes)
248	288x	if (content$footnotes != "") {
249	281x	out <- footnote(out,
250	281x	i = 1, j = 1,
251	281x	value = as_paragraph(content$footnotes),
252	281x	ref_symbols = " ", part = "header", inline = TRUE
253		)
254		}
255
256	288x	args$arg_header <- list(
257	288x	value = fpar(get_proper_title(content$header)),
258	288x	location = ph_location_type("title")
259		)
260		} else {
261	1x	out <- content
262	1x	out <- footnote(out,
263	1x	i = 1, j = 1,
264	1x	value = as_paragraph("Confidential and for internal use only"),
265	1x	ref_symbols = " ", part = "header", inline = TRUE
266		)
267		}
268
269	289x	ppt <- do_call(add_slide, x = ppt, master = ppt_master, ...)
270	289x	ppt <- ph_with(ppt, value = out, location = table_loc)
271	289x	ppt <- set_notes(ppt, value = usernotes,
272	289x	location = notes_location_type("body"))
273	289x	ph_with_args <- args[unlist(lapply(args, function(x) all(c("location", "value") %in% names(x))))]
274	289x	res <- lapply(ph_with_args, function(x) {
275	288x	ppt <- ph_with(ppt, value = x$value, location = x$location)
276		})
277
278	289x	return(res)
279		}
280
281		#' Create location container to center the figure, based on ppt size and
282		#' user specified figure size
283		#'
284		#' @param fig_width Figure width
285		#' @param fig_height Figure height
286		#' @param ppt_width Slide width
287		#' @param ppt_height Slide height
288		#'
289		#' @return Location for a placeholder from scratch
290		center_figure_loc <- function(fig_width, fig_height, ppt_width, ppt_height) {
291		# center figure
292	1x	top <- (ppt_height - fig_height) / 2
293	1x	left <- (ppt_width - fig_width) / 2
294	1x	ph_location(top = top, left = left)
295		}
296
297		#' Placeholder for ph_with_img
298		#'
299		#' @param ppt power point file
300		#' @param figure image object
301		#' @param fig_width width of figure
302		#' @param fig_height height of figure
303		#' @param figure_loc location of figure
304		#' @return Location for a placeholder
305		#' @export
306		ph_with_img <- function(ppt, figure, fig_width, fig_height, figure_loc) {
307	1x	file_name <- tempfile(fileext = ".svg")
308	1x	svg(filename = file_name, width = fig_width, height = fig_height, onefile = TRUE)
309	1x	grid.draw(figure$grob)
310	1x	dev.off()
311	1x	on.exit(unlink(file_name))
312	1x	ext_img <- external_img(file_name, width = fig_width, height = fig_height)
313
314	1x	ppt %>% ph_with(value = ext_img, location = figure_loc, use_loc_size = FALSE)
315		}
316
317		#' Add figure to slides
318		#'
319		#' @param ppt slide page
320		#' @param content content to be added
321		#' @param decor should decoration be added
322		#' @param fig_width user specified figure width
323		#' @param fig_height user specified figure height
324		#' @param figure_loc location of the figure. Defaults to `ph_location_type("body")`
325		#' @param fig_editable whether we want the figure to be editable in pptx viewers
326		#' @param ... arguments passed to program
327		#'
328		#' @return slide with the added content
329		figure_to_slide <- function(ppt, content,
330		decor = TRUE,
331		fig_width,
332		fig_height,
333		figure_loc = ph_location_type("body"),
334		fig_editable = FALSE,
335		...) {
336	4x	ppt_master <- layout_summary(ppt)$master[1]
337		# until officer 0.6.10 ppt <- layout_default(ppt, "Title and Content")
338	4x	args <- list(...)
339
340
341	4x	if (decor) {
342	4x	args$arg_header <- list(
343	4x	value = fpar(get_proper_title(content$titles)),
344	4x	location = ph_location_type("title")
345		)
346		}
347
348	4x	if ("decoratedGrob" %in% class(content)) {
349	4x	ppt <- do_call(add_slide, x = ppt, master = ppt_master, ...)
350	4x	if (fig_editable) {
351	4x	content_list <- g_export(content)
352	4x	ppt <- ph_with(ppt, content_list$dml, location = ph_location_type(type = "body"))
353		} else {
354	!	ppt <- ph_with_img(ppt, content, fig_width, fig_height, figure_loc)
355		}
356
357	4x	ph_with_args <- args[unlist(lapply(args, function(x) all(c("location", "value") %in% names(x))))]
358	4x	res <- lapply(ph_with_args, function(x) {
359	4x	ppt <- ph_with(ppt, value = x$value, location = x$location)
360		})
361	4x	return(res)
362	!	} else if ("decoratedGrobSet" %in% class(content)) { # for decoratedGrobSet, a list of figures are created and added
363		# revisit, to make more efficent
364	!	for (figure in content) {
365	!	ppt <- do_call(add_slide, x = ppt, master = ppt_master, ...)
366	!	ppt <- ph_with_img(ppt, figure, fig_width, fig_height, figure_loc)
367		}
368	!	return(ppt)
369		} else {
370	!	stop("Should not reach here")
371		}
372		}

1		#' Plot mean values of LB
2		#'
3		#' Wrapper for `g_mean_general()`.
4		#' Requires filtering of the datasets (e.g. using SUFFIX in spec.yml)
5		#'
6		#' @param adsl ADSL data
7		#' @param adlb ADLB data
8		#' @param arm `"TRT01P"` by default
9		#' @param paramcd character scalar. defaults to By default `"PARAM"`
10		#' Which variable to use for plotting.
11		#' @param y character scalar. Variable to plot on the Y axis. By default `"AVAL"`
12		#' @inheritParams g_mean_general
13		#' @param ... \|
14		#' Gets forwarded to `tern::g_lineplot()`.
15		#' This lets you specify additional arguments to `tern::g_lineplot()`
16		#' @author Stefan Thoma (`thomas7`)
17		#' @export
18		#' @examplesIf require('rsvg')
19		#' library(dplyr)
20		#'
21		#' adlb_filtered <- eg_adlb %>% filter(
22		#' PARAMCD == "CRP"
23		#' )
24		#' plot_lb <- g_lb_slide(
25		#' adsl = eg_adsl,
26		#' adlb = adlb_filtered,
27		#' paramcd = "PARAM",
28		#' subtitle_add_unit = FALSE
29		#' ) +
30		#' ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))
31		#' generate_slides(plot_lb, paste0(tempdir(), "/g_lb.pptx"))
32		#'
33		#' # Let's plot change values:
34		#' plot_lb_chg <- g_lb_slide(
35		#' adsl = eg_adsl,
36		#' adlb = adlb_filtered,
37		#' paramcd = "PARAM",
38		#' y = "CHG",
39		#' subtitle = "Plot of change from baseline and 95% Confidence Limit by Visit."
40		#' )
41		#' generate_slides(plot_lb_chg, paste0(tempdir(), "/g_lb_chg.pptx"))
42		#'
43		g_lb_slide <- function(adsl, adlb, arm = "TRT01P", paramcd = "PARAM", y = "AVAL",
44		subtitle = "Plot of Mean and 95% Confidence Limits by Visit.", ...) {
45		# tern 0.9.4 added facet_var in control_lineplot_vars
46	3x	variables <- control_lineplot_vars(group_var = arm, paramcd = paramcd, y = y) %>%
47	3x	strip_NA()
48
49	2x	by_vars <- c("USUBJID", "STUDYID")
50	2x	assert_that(is.string(arm))
51	2x	assert_that(is.string(paramcd))
52	2x	assert_that(is.string(y))
53	2x	assert_that(has_name(adlb, c(by_vars, variables) %>% unique()))
54	2x	assert_that(has_name(adsl, c(by_vars, arm) %>% unique()))
55	2x	assert_that(is.string(subtitle))
56
57	2x	g_mean_general(
58	2x	adsl = adsl, data = adlb, variables = variables, by_vars = by_vars,
59	2x	subtitle = subtitle, ...
60		)
61		}

1		#' Adverse event table
2		#'
3		#' @param adae ADAE data set, dataframe
4		#' @param adsl ADSL data set, dataframe
5		#' @param arm Arm variable, character, "`TRT01A" by default.
6		#' @param cutoff Cutoff threshold
7		#' @param prune_by_total Prune according total column
8		#' @param split_by_study Split by study, building structured header for tables
9		#' @param side_by_side A logical value indicating whether to display the data side by side.
10		#' @return rtables object
11		#' @inherit gen_notes note
12		#' @export
13		#' @examples
14		#'
15		#' library(dplyr)
16		#' # Example 1
17		#' adsl <- eg_adsl %>%
18		#' dplyr::mutate(TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")))
19		#' adae <- eg_adae %>%
20		#' dplyr::mutate(
21		#' TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")),
22		#' ATOXGR = AETOXGR
23		#' )
24		#' out <- t_ae_pt_slide(adsl, adae, "TRT01A", 2)
25		#' print(out)
26		#' generate_slides(out, paste0(tempdir(), "/ae.pptx"))
27		#'
28		#' # Example 2, prune by total column
29		#' out2 <- t_ae_pt_slide(adsl, adae, "TRT01A", 25, prune_by_total = TRUE)
30		#' print(out2)
31		#' generate_slides(out, paste0(tempdir(), "/ae2.pptx"))
32		t_ae_pt_slide <- function(adsl, adae, arm = "TRT01A", cutoff = NA, prune_by_total = FALSE,
33		split_by_study = FALSE,
34		side_by_side = NULL) {
35	6x	cutoff <- check_and_set_cutoff(adae, cutoff)
36	6x	result <- t_ae_pt_core(adsl, adae, arm, cutoff,
37	6x	diff = FALSE, soc = "NULL",
38	6x	prune_by_total = prune_by_total,
39	6x	split_by_study,
40	6x	side_by_side
41		)
42	6x	result@main_title <- "Adverse Events table"
43
44	6x	if (is.null(side_by_side)) {
45		# adding "N" attribute
46	6x	arm <- col_paths(result)[[1]][1]
47
48	6x	n_r <- data.frame(
49	6x	ARM = toupper(names(result@col_info)),
50	6x	N = col_counts(result) %>% as.numeric()
51		) %>%
52	6x	`colnames<-`(c(paste(arm), "N")) %>%
53	6x	arrange(get(arm))
54
55	6x	attr(result, "N") <- n_r
56		}
57	6x	result
58		}

1		abort <- function(...) {
2	13x	stop(..., call. = FALSE)
3		}
4
5		assert_is_character_scalar <- function(x) {
6	178x	if (length(x) != 1L \|\| is.na(x) \|\| !is.character(x) \|\| x == "") {
7	5x	abort("`", deparse(substitute(x)), "` must be a character scalar.")
8		}
9		}
10
11		assert_is_valid_version_label <- function(x) {
12	2x	if (!(x %in% c("DRAFT", "APPROVED") \|\| is.null(x))) {
13	!	abort("Version label must be 'DRAFT', 'APPROVED' or `NULL` but is '", x, "'.")
14		}
15		}
16
17
18		assert_exists_in_spec_or_calling_env <- function(vars, output, env = parent.frame()) {
19	108x	exist_in_spec <- vars %in% names(output)
20		# explicitly define env to use, better practice for testing
21	108x	exist_in_calling_env <- map_lgl(vars, exists, envir = env)
22
23	108x	non_existing_vars <- vars[!(exist_in_spec \| exist_in_calling_env)]
24
25
26	108x	n <- length(non_existing_vars)
27	108x	if (n >= 1L) {
28	1x	err_msg <- sprintf(
29	1x	paste(
30	1x	"Cannot filter based upon the %s %s as %s not contained in",
31	1x	"`spec` or the surrounding environment."
32		),
33	1x	if (n == 1L) "variable" else "variables",
34	1x	enumerate(non_existing_vars),
35	1x	if (n == 1L) "it is" else "they are"
36		)
37	1x	stop(err_msg, call. = FALSE)
38		}
39		}
40
41		assert_is_valid_filter_result <- function(x) {
42	113x	if (length(x) != 1L \|\| is.na(x) \|\| !is.logical(x)) {
43	6x	stop(
44	6x	"`filter_expr` must evaluate to a logical scalar but returned `",
45	6x	deparse(x), "`.",
46	6x	call. = FALSE
47		)
48		}
49		}

1		#' Demographic table
2		#'
3		#' @param adsl ADSL data set, dataframe
4		#' @param arm Arm variable, character, "`TRT01P" by default.
5		#' @param vars Characters of variables
6		#' @param stats see `.stats` from [tern::analyze_vars()]
7		#' @param split_by_study Split by study, building structured header for tables
8		#' @param side_by_side "GlobalAsia" or "GlobalAsiaChina" to define the side by side requirement
9		#' @return rtables object
10		#' @inherit gen_notes note
11		#' @export
12		#' @examples
13		#' library(dplyr)
14		#' adsl <- eg_adsl
15		#' out1 <- t_dm_slide(adsl, "TRT01P", c("SEX", "AGE", "RACE", "ETHNIC", "COUNTRY"))
16		#' print(out1)
17		#' generate_slides(out1, paste0(tempdir(), "/dm.pptx"))
18		#'
19		#' out2 <- t_dm_slide(adsl, "TRT01P", c("SEX", "AGE", "RACE", "ETHNIC", "COUNTRY"),
20		#' split_by_study = TRUE
21		#' )
22		#' print(out2)
23		#'
24		t_dm_slide <- function(adsl,
25		arm = "TRT01P",
26		vars = c("AGE", "SEX", "RACE"),
27		stats = c("median", "range", "count_fraction"),
28		split_by_study = FALSE,
29		side_by_side = NULL) {
30	12x	if (is.null(side_by_side)) {
31	7x	extra <- NULL
32		} else {
33	5x	extra <- c("COUNTRY")
34		}
35
36	12x	for (v in c(vars, extra)) {
37	55x	assert_that(has_name(adsl, v))
38		}
39
40	12x	adsl1 <- adsl %>%
41	12x	select(all_of(c("STUDYID", "USUBJID", arm, vars, extra)))
42
43	12x	if (!is.null(side_by_side)) {
44	5x	adsl1$lvl <- "Global"
45		}
46
47	12x	lyt <- build_table_header(adsl1, arm,
48	12x	split_by_study = split_by_study,
49	12x	side_by_side = side_by_side
50		)
51
52	12x	lyt <- lyt %>%
53	12x	analyze_vars(
54	12x	na.rm = TRUE,
55	12x	.stats = stats,
56	12x	denom = "n",
57	12x	vars = vars,
58	12x	.formats = c(mean_sd = "xx.xx (xx.xx)", median = "xx.xx"),
59	12x	var_labels = formatters::var_labels(adsl1)[vars]
60		)
61
62	12x	result <- lyt_to_side_by_side(lyt, adsl1, side_by_side)
63
64	12x	if (is.null(side_by_side)) {
65		# adding "N" attribute
66	7x	arm <- col_paths(result)[[1]][1]
67
68	7x	n_r <- data.frame(
69	7x	ARM = toupper(names(result@col_info)),
70	7x	N = col_counts(result) %>% as.numeric()
71		) %>%
72	7x	`colnames<-`(c(paste(arm), "N")) %>%
73	7x	dplyr::arrange(get(arm))
74
75	7x	attr(result, "N") <- n_r
76		}
77	12x	result@main_title <- "Demographic slide"
78	12x	result
79		}

1		#' Plot mean values of EG
2		#'
3		#' Wrapper for `g_mean_general()`.
4		#' Requires filtering of the datasets (e.g. using SUFFIX in spec.yml)
5		#'
6		#' @param adsl ADSL data
7		#' @param adeg ADVS data
8		#' @param arm `"TRT01P"` by default
9		#' @param paramcd Which variable to use for plotting. By default `"PARAM"`
10		#' @inheritParams g_mean_general
11		#' @param ... \|
12		#' Gets forwarded to `tern::g_lineplot()`.
13		#' This lets you specify additional arguments to `tern::g_lineplot()`
14		#' @author Stefan Thoma (`thomas7`)
15		#' @importFrom forcats fct_reorder
16		#' @export
17		#' @examplesIf require('rsvg')
18		#' library(dplyr)
19		#'
20		#' adeg_filtered <- eg_adeg %>% filter(
21		#' PARAMCD == "HR"
22		#' )
23		#' plot_eg <- g_eg_slide(
24		#' adsl = eg_adsl,
25		#' adeg = adeg_filtered,
26		#' arm = "TRT01P",
27		#' paramcd = "PARAM",
28		#' subtitle_add_unit = FALSE
29		#' ) +
30		#' ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))
31		#'
32		#' generate_slides(plot_eg, paste0(tempdir(), "/g_eg.pptx"))
33		g_eg_slide <- function(adsl, adeg, arm = "TRT01P", paramcd = "PARAM",
34		subtitle = "Plot of Mean and 95% Confidence Limits by Visit.", ...) {
35		# tern 0.9.4 added facet_var in control_lineplot_vars
36	5x	variables <- control_lineplot_vars(group_var = arm, paramcd = paramcd) %>% strip_NA()
37	3x	by_vars <- c("USUBJID", "STUDYID")
38	3x	assert_that(is.string(arm))
39	3x	assert_that(has_name(adeg, c(by_vars, variables) %>% unique()))
40	3x	assert_that(has_name(adsl, c(by_vars, arm) %>% unique()))
41	3x	assert_that(is.string(subtitle))
42
43	3x	g_mean_general(
44	3x	adsl = adsl, data = adeg, variables = variables, by_vars = by_vars,
45	3x	subtitle = subtitle, ...
46		)
47		}

1		#' Determine Slide Insertion Page Number
2		#'
3		#' Computes the appropriate page number at which to insert a new slide into the PowerPoint deck.
4		#' Defaults to appending to the end if no value is provided.
5		#'
6		#' @param doc_original An `officer::rpptx` object representing the PowerPoint file.
7		#' @param to_page Desired slide index to insert the new slide. If `NA`, appends to the last page.
8		#'
9		#' @return A single integer value indicating the validated page number for slide insertion.
10		#'
11		#' @export
12		#'
13		#' @examples
14		#' tmp <- tempfile(fileext = ".pptx")
15		#' doc <- officer::read_pptx()
16		#' doc <- officer::add_slide(doc, layout = "Title Slide", master = "Office Theme")
17		#' print(doc, target = tmp)
18		#' doc <- officer::read_pptx(tmp)
19		#' initialize_to_page(doc, NA) # append to end
20		#' initialize_to_page(doc, 1) # insert at page 1
21		initialize_to_page <- function(doc_original, to_page) {
22	11x	max_pages <- length(doc_original)
23	11x	if (max_pages == 0) {
24	4x	max_pages <- 1
25		}
26	11x	if (is.na(to_page)) {
27	1x	to_page <- max_pages
28		}
29
30	11x	assert_that((max_pages + 1) >= to_page)
31	9x	to_page
32		}
33
34		#' Post-process PowerPoint Document
35		#'
36		#' Performs final actions on the PowerPoint object, including optionally saving the updated file.
37		#' The saved filename includes a suffix indicating the slide type that was appended.
38		#'
39		#' @param doc An `officer::rpptx` object to finalize.
40		#' @param save_file A boolean indicating whether to save the file to disk.
41		#' @param doc_o Original PowerPoint file path.
42		#' @param type A string suffix to label the output file, e.g., `"cohort_sec"` or `"safety_sum_sec"`.
43		#'
44		#' @return The modified `officer::rpptx` object.
45		#'
46		#' @export
47		#'
48		#' @examples
49		#' tmp <- tempfile(fileext = ".pptx")
50		#' doc <- officer::read_pptx()
51		#' doc <- officer::add_slide(doc, layout = "Title Slide", master = "Office Theme")
52		#' print(doc, target = tmp)
53		#' doc <- officer::read_pptx(tmp)
54		#' # Call postprocessing_doc to save a modified version of doc
55		#' postprocessing_doc(doc, TRUE, tmp, type = "final")
56		postprocessing_doc <- function(doc, save_file, doc_o, type = "") {
57	12x	if (save_file) {
58	4x	doc_dir <- dirname(doc_o)
59	4x	doc_base_name <- tools::file_path_sans_ext(basename(doc_o))
60
61	4x	doc_ext <- tools::file_ext(basename(doc_o))
62	4x	outfile_name <- paste0(doc_base_name, "_", type, ".", doc_ext)
63
64		# Combine the directory with the new filename to get the full output path
65	4x	outfile_final <- file.path(doc_dir, outfile_name)
66	4x	print(doc, outfile_final)
67		}
68
69	11x	return(doc)
70		}
71
72
73		#' Initialize PowerPoint Document Object
74		#'
75		#' This function ensures a PowerPoint document (`officer::rpptx` object) is loaded.
76		#' If a `doc_original` is provided, it is directly returned. Otherwise, the function reads
77		#' the presentation from the given file path.
78		#'
79		#' @param doc_original An existing `officer::rpptx` object, or `NULL` to read from file.
80		#' @param doc_o Path to a PowerPoint (`.pptx`) file. Used only if `doc_original` is `NULL`.
81		#'
82		#' @return An `officer::rpptx` PowerPoint object.
83		#'
84		#' @export
85		#'
86		#' @examples
87		#' example <- tempfile(fileext = ".pptx")
88		#' doc <- officer::read_pptx()
89		#' doc <- officer::add_slide(doc, layout = "Title and Content")
90		#' print(doc, target = example)
91		#' doc <- initialize_doc_original(NULL, example)
92		initialize_doc_original <- function(doc_original, doc_o) {
93	13x	if (is.null(doc_original)) {
94	6x	doc_original <- officer::read_pptx(doc_o)
95		}
96	13x	doc_original
97		}
98
99
100		#' Append Title Slides to a PowerPoint Document
101		#'
102		#' This function adds a new title slide using a "Title and Content" layout
103		#' from the "Office Theme".
104		#'
105		#' @param doc_o Path to a PowerPoint (`.pptx`) file. Used to initialize the document
106		#' if `doc_original` is `NULL`.
107		#' @param study_id A character string that represent your study identifier.
108		#' @param to_page An integer specifying the page number where the new slide should be moved.
109		#' @param doc_original An optional existing `officer::rpptx` object. If `NULL`,
110		#' the document is initialized from `doc_o`.
111		#' @param save_file A logical value. If `TRUE`, the modified document is saved to a file
112		#' after adding the slide.
113		#'
114		#' @return An `officer::rpptx` object with the new title slide appended.
115		#'
116		#' @export
117		#'
118		#' @examples
119		#'
120		#' tmp <- tempfile(fileext = ".pptx")
121		#' doc <- officer::read_pptx()
122		#' doc <- officer::add_slide(doc, layout = "Title Slide", master = "Office Theme")
123		#' print(doc, target = tmp)
124		#'
125		#' doc <- append_title_slides(
126		#' doc_o = tmp,
127		#' study_id = "My Study #13",
128		#' to_page = 1,
129		#' save_file = TRUE
130		#' )
131		append_title_slides <- function(
132		doc_o,
133		study_id = "XXXX change me",
134		to_page = NA,
135		doc_original = NULL,
136		save_file = FALSE) {
137	4x	doc_original <- initialize_doc_original(doc_original, doc_o)
138
139	4x	to_page <- initialize_to_page(doc_original, to_page)
140
141	4x	doc <- doc_original %>%
142	4x	officer::add_slide(layout = "Title and Content", master = "Office Theme") %>%
143	4x	officer::ph_with(
144	4x	value = paste0(study_id, "Meeting"),
145	4x	location = officer::ph_location_type(type = "title")
146		) %>%
147	4x	officer::ph_with(
148	4x	value = paste0("meeting"),
149	4x	location = officer::ph_location_type(type = "body")
150		) %>%
151	4x	officer::move_slide(to = to_page)
152
153	4x	postprocessing_doc(doc, save_file, doc_o, type = "title")
154
155	4x	return(doc)
156		}
157
158
159
160		#' Append Section Header Slides to a PowerPoint Document
161		#'
162		#' This function adds a new section header slide to an existing PowerPoint document
163		#' using a "Section Header" layout from the "Office Theme".
164		#' It populates the title placeholder with the provided section title.
165		#'
166		#' @param doc_o Path to a PowerPoint (`.pptx`) file. Used to initialize the document
167		#' if `doc_original` is `NULL`, and for post-processing.
168		#' @param section_title A character string for the title of the section header slide.
169		#' Defaults to "New Section".
170		#' @param to_page An integer specifying the page number where the new slide should be moved.
171		#' If `NA`, the slide is added at the end and `initialize_to_page` determines its final position.
172		#' @param doc_original An optional existing `officer::rpptx` object. If `NULL`,
173		#' the document is initialized from `doc_o`.
174		#' @param save_file A logical value. If `TRUE`, the modified document is saved to a file
175		#' after adding the slide.
176		#'
177		#' @return An `officer::rpptx` object with the new section header slide appended.
178		#'
179		#' @export
180		#'
181		#' @examples
182		#'
183		#' tmp <- tempfile(fileext = ".pptx")
184		#' doc <- officer::read_pptx()
185		#' print(doc, target = tmp)
186		#'
187		#' append_section_header_slides(
188		#' doc_o = tmp,
189		#' section_title = "My Section",
190		#' to_page = 1,
191		#' save_file = TRUE
192		#' )
193		append_section_header_slides <- function(
194		doc_o,
195		section_title = "New Section",
196		to_page = NA,
197		doc_original = NULL,
198		save_file = FALSE) {
199	4x	doc_original <- initialize_doc_original(doc_original, doc_o)
200
201	4x	to_page <- initialize_to_page(doc_original, to_page)
202
203	3x	doc <- doc_original %>%
204	3x	officer::add_slide(layout = "Section Header", master = "Office Theme") %>%
205	3x	officer::ph_with(
206	3x	value = section_title,
207	3x	location = officer::ph_location_type(type = "title")
208		) %>%
209	3x	officer::move_slide(to = to_page)
210
211	3x	postprocessing_doc(doc, save_file, doc_o, type = "section_header")
212
213	3x	return(doc)
214		}
215
216		#' Append All Predefined Slides to a PowerPoint Document
217		#'
218		#' This function orchestrates the appending of a series of predefined slides
219		#' (including title and section header slides) to a PowerPoint document based
220		#' on a provided page list.
221		#'
222		#' @param doc_o Path to a PowerPoint (`.pptx`) file. Used to initialize the document
223		#' if `doc_original` is `NULL`, and for final post-processing.
224		#' @param page_list A list of slide definitions. Each element in the list should be
225		#' another list containing:
226		#' - `type`: A character string indicating the type of slide ("title" or "section").
227		#' - `to_page`: An integer specifying the target page number for the slide.
228		#' - Other arguments specific to the slide type (e.g., `study_id` for "title" slides,
229		#' `section_title` for "section" slides).
230		#' @param doc_original An optional existing `officer::rpptx` object. If `NULL`,
231		#' the document is initialized from `doc_o`.
232		#' @param save_file A logical value. If `TRUE`, the final modified document is saved
233		#' to a file after all slides have been appended.
234		#'
235		#' @return An `officer::rpptx` object with all specified slides appended.
236		#'
237		#' @export
238		#' @examples
239		#' tmp <- tempfile(fileext = ".pptx")
240		#' doc <- officer::read_pptx()
241		#' print(doc, target = tmp)
242		#'
243		#' my_page_list <- list(
244		#' list(type = "title", to_page = 1, study_id = "My Project"),
245		#' list(type = "section", to_page = 2, section_title = "Introduction"),
246		#' list(type = "title", to_page = 3, study_id = "Mid-Term Review"),
247		#' list(type = "section", to_page = 4, section_title = "Key Findings")
248		#' )
249		#'
250		#' # Append all slides using the dynamic page_list
251		#' doc <- append_all_slides(
252		#' doc_o = tmp,
253		#' page_list = my_page_list,
254		#' save_file = TRUE
255		#' )
256		append_all_slides <- function(
257		doc_o,
258		page_list = list(), # Default to an empty list
259		doc_original = NULL,
260		save_file = FALSE) {
261	3x	doc <- initialize_doc_original(doc_original, doc_o)
262
263
264	3x	for (page in page_list) {
265	6x	current_to_page <- page$to_page
266
267
268	6x	if (page$type == "title") {
269	3x	doc <- append_title_slides(
270	3x	doc_o = doc_o,
271	3x	doc_original = doc,
272	3x	to_page = current_to_page,
273	3x	study_id = page$study_id,
274	3x	save_file = FALSE
275		)
276	3x	} else if (page$type == "section") {
277	3x	doc <- append_section_header_slides(
278	3x	doc_o = doc_o,
279	3x	doc_original = doc,
280	3x	to_page = current_to_page,
281	3x	section_title = page$section_title,
282	3x	save_file = FALSE
283		)
284		}
285		}
286
287	2x	postprocessing_doc(doc, save_file, doc_o, type = "final")
288
289	2x	return(doc)
290		}

1		#' Generate output and apply filters, titles, and footnotes
2		#'
3		#' @param program program name
4		#' @param datasets list of datasets
5		#' @param spec spec
6		#' @param verbose_level Verbose level of messages be displayed. See details for further information.
7		#' @return No return value, called for side effects
8		#' @details
9		#' `verbose_level` is used to control how many messages are printed out.
10		#' By default, `2` will show all filter messages and show output generation message.
11		#' `1` will show output generation message only.
12		#' `0` will display no message.
13		#' @param ... arguments passed to program
14		#'
15		#' @author Liming Li (`Lil128`)
16		#'
17		#' @export
18		#'
19		#' @examplesIf require(filters)
20		#' library(dplyr)
21		#' filters::load_filters(
22		#' yaml_file = system.file("filters.yml", package = "autoslider.core"),
23		#' overwrite = TRUE
24		#' )
25		#'
26		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
27		#' spec <- spec_file %>% read_spec()
28		#'
29		#' data <- list(
30		#' adsl = eg_adsl,
31		#' adae = eg_adae
32		#' )
33		#' generate_output("t_ae_slide", data, spec$t_ae_slide_SE)
34		#'
35		generate_output <-
36		function(program,
37		datasets,
38		spec,
39		verbose_level = 2,
40		...) {
41	18x	suffix <- spec$suffix
42	18x	if (verbose_level > 0) {
43	18x	cat_bullet(
44	18x	sprintf(
45	18x	"Running program `%s` with suffix '%s'.",
46	18x	program,
47	18x	suffix
48		),
49	18x	bullet = "pointer",
50	18x	bullet_col = "green"
51		)
52		}
53	18x	func <- tryCatch(
54		{
55	18x	func_wrapper(
56	18x	func = match.fun(program),
57	18x	datasets = datasets,
58	18x	spec = spec,
59	18x	verbose = verbose_level > 1
60		)
61		},
62	18x	error = function(e) {
63	!	info <- e$message
64	!	if (verbose_level > 0) {
65	!	cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red")
66		}
67	!	autoslider_error(info, spec = spec, step = "filter dataset")
68		}
69		)
70	18x	if (is(func, "autoslider_error")) {
71	!	return(func)
72		}
73	18x	ret <- tryCatch(
74		{
75	18x	func(...)
76		},
77	18x	error = function(e) {
78	!	info <- e$message
79	!	if (verbose_level > 0) {
80	!	cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red")
81		}
82	!	autoslider_error(info, spec = spec, step = "user program")
83		}
84		)
85	18x	return(ret)
86		}
87
88		#' Generate all outputs from a spec
89		#'
90		#' @param spec Specification list generated by `read_spec`
91		#' @param datasets A `list` of datasets
92		#' @param verbose_level Verbose level of messages be displayed. See details for further information.
93		#' @return No return value, called for side effects
94		#' @details
95		#' `verbose_level` is used to control how many messages are printed out.
96		#' By default, `2` will show all filter messages and show output generation message.
97		#' `1` will show output generation message only.
98		#' `0` will display no message.
99		#'
100		#' @author
101		#' - Thomas Neitmann (`neitmant`)
102		#' - Liming Li (`Lil128`)
103		#'
104		#' @export
105		#'
106		#' @examplesIf require(filters)
107		#' library(dplyr, warn.conflicts = FALSE)
108		#' data <- list(
109		#' adsl = eg_adsl,
110		#' adae = eg_adae
111		#' )
112		#' filters::load_filters(
113		#' yaml_file = system.file("filters.yml", package = "autoslider.core"),
114		#' overwrite = TRUE
115		#' )
116		#'
117		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
118		#' spec_file %>%
119		#' read_spec() %>%
120		#' filter_spec(output %in% c("t_dm_slide_IT", "t_ae_slide_SE")) %>%
121		#' generate_outputs(datasets = data)
122		#'
123		generate_outputs <- function(spec, datasets, verbose_level = 2) {
124	2x	lapply(spec, function(s) {
125	18x	args <- c(
126	18x	list(
127	18x	program = s$program,
128	18x	spec = s,
129	18x	datasets = datasets,
130	18x	verbose_level = verbose_level
131		),
132	18x	s$args # ... arguments passed onto the output-generating function
133		)
134	18x	output <- fastDoCall(generate_output, args)
135	18x	attr(output, "spec") <- s
136	18x	output
137		})
138		}

1		#' generic function decorate
2		#' @return No return value, called for side effects
3		#' @export
4		setGeneric("decorate", function(x, ...) standardGeneric("decorate"))
5
6		#' s3 method for decorate
7		#' @param x object to decorate
8		#' @param ... additional arguments passed to methods
9		decorate <- function(x, ...) {
10	1x	UseMethod("decorate")
11		}
12
13		#' default method to decorate
14		#' @param x object to decorate
15		#' @param ... additional arguments. not used.
16		#' @return No return value, called for side effects
17		#' @export
18		decorate.default <- function(x, ...) {
19	1x	stop("default decorate function does not exist")
20		}
21
22		#' decorate method for autoslider_error class
23		#' @param x object to decorate
24		#' @param ... additional arguments. not used.
25		#' @return No return value, called for side effects
26		#' @export
27		decorate.autoslider_error <- function(x, ...) {
28	1x	x
29		}
30
31		#' Decorate TableTree
32		#'
33		#' @param x A VTableTree object representing the data to be decorated.
34		#' @param titles Title to be added to the table.
35		#' @param footnotes Footnote to be added to the table
36		#' @param paper Orientation and font size as string, e.g. "P8"; "L11"
37		#' @param for_test `logic` CICD parameter
38		#' @param ... Additional arguments passed to the decoration function.
39		#' @return No return value, called for side effects
40		#' @export
41		setMethod(
42		"decorate", "VTableTree",
43		decorate.VTableTree <- function(x, titles = "", footnotes = "", paper = "P8", for_test = FALSE, ...) {
44	16x	width_set <- attr(x, "width")
45	16x	tmp_x <- formatters::matrix_form(x)
46
47	16x	if (is.null(width_set)) {
48	16x	width <- formatters::propose_column_widths(tmp_x)
49		} else {
50	!	width <- ifelse(is.na(width_set), formatters::propose_column_widths(tmp_x), width_set)
51		}
52
53	16x	glued_title <- glue::glue(paste(titles, collapse = "\n"))
54	16x	main_title(x) <- glued_title
55
56	16x	git_fn <- git_footnote(for_test)
57	16x	glued_footnotes <- glue::glue(paste(c(footnotes, git_fn), collapse = "\n"))
58	16x	main_footer(x) <- glued_footnotes
59
60	16x	new(
61	16x	"dVTableTree",
62	16x	tbl = x,
63	16x	titles = glued_title,
64	16x	footnotes = footnotes,
65	16x	usernotes = "",
66	16x	paper = paper,
67	16x	width = width
68		)
69		}
70		)
71
72
73		#' Decorate ggplot object
74		#'
75		#' @param x An object to decorate
76		#' @param titles Plot titles
77		#' @param footnotes Plot footnotes
78		#' @param paper Paper size, by default "L11"
79		#' @param for_test `logic` CICD parameter
80		#' @param ... additional arguments. not used.
81		#' @return No return value, called for side effects
82		#' @export
83		#' @details
84		#' The paper default paper size, `L11`, indicate that the fontsize is 11.
85		#' The fontsize of the footnotes, is the fontsize of the titles minus 2.
86		decorate.ggplot <- function(x, titles = "", footnotes = "", paper = "L11", for_test = FALSE, ...) {
87	5x	glued_title <- glue::glue(paste(titles, collapse = "\n"))
88		# main_title(x) <- glued_title
89
90	5x	git_fn <- git_footnote(for_test)
91	5x	glued_footnotes <- glue::glue(paste(c(footnotes, git_fn), collapse = "\n"))
92		# main_footer(x) <- glued_footnotes
93
94	5x	ret <- list(
95	5x	grob = ggplot2::ggplotGrob(x),
96	5x	titles = glued_title,
97	5x	footnotes = footnotes,
98	5x	usernotes = "",
99	5x	paper = paper,
100	5x	for_test = for_test
101		)
102	5x	class(ret) <- "decoratedGrob"
103	5x	return(ret)
104		}
105
106
107		#' decorate listing
108		#'
109		#' @param x A listing_df object representing the data to be decorated.
110		#' @param titles Title to be added to the table.
111		#' @param footnotes Footnote to be added to the table
112		#' @param paper Orientation and font size as string, e.g. "P8"; "L11"
113		#' @param for_test `logic` CICD parameter
114		#' @param ... Additional arguments. not used.
115		#' @return No return value, called for side effects
116		#' @export
117		setMethod(
118		"decorate", "listing_df",
119		decorate.listing_df <- function(x, titles = "", footnotes = "", paper = "P8", for_test = FALSE, ...) {
120	1x	width_set <- attr(x, "width")
121	1x	tmp_x <- formatters::matrix_form(x)
122
123	1x	if (is.null(width_set)) {
124	1x	width <- formatters::propose_column_widths(tmp_x)
125		} else {
126	!	width <- ifelse(is.na(width_set), formatters::propose_column_widths(tmp_x), width_set)
127		}
128
129	1x	glued_title <- glue::glue(paste(titles, collapse = "\n"))
130	1x	main_title(x) <- glued_title
131
132	1x	git_fn <- git_footnote(for_test)
133	1x	glued_footnotes <- glue::glue(paste(c(footnotes, git_fn), collapse = "\n"))
134	1x	main_footer(x) <- glued_footnotes
135	1x	new(
136	1x	"dlisting",
137	1x	lst = x,
138	1x	titles = glued_title,
139	1x	footnotes = footnotes,
140	1x	usernotes = "",
141	1x	paper = paper,
142	1x	width = width
143		)
144		}
145		)
146
147
148
149
150		#' decorate grob
151		#' @param x object to decorate
152		#' @param titles graph titles
153		#' @param footnotes graph footnotes
154		#' @param paper paper size. default is "L8".
155		#' @param for_test `logic` CICD parameter
156		#' @param ... Additional arguments. not used.
157		#' @return No return value, called for side effects
158		#' @details
159		#' The paper default paper size, `L11`, indicate that the fontsize is 11.
160		#' The fontsize of the footnotes, is the fontsize of the titles minus 2.
161		#' @export
162		#'
163		decorate.grob <-
164		function(x, titles = "", footnotes = "", paper = "L11", for_test = FALSE, ...) {
165	2x	size <- fs(paper)
166	2x	grob <- tern::decorate_grob(
167	2x	grob = x,
168	2x	titles = glue::glue(paste(titles, collapse = "\n")),
169	2x	footnotes = c(glue::glue(paste(footnotes, collapse = "\n")), git_footnote(for_test), datetime()),
170	2x	border = FALSE,
171	2x	gp_titles = gpar(fontsize = size$fontsize),
172	2x	gp_footnotes = gpar(fontsize = size$fontsize - 2)
173		)
174	2x	attr(grob, "paper") <- ifelse(size$orientation == "P", "a4", "a4r")
175	2x	grob
176		}
177
178		#' decorate gtsummary
179		#'
180		#' @param x gtsummary object to decorate
181		#' @param titles graph titles
182		#' @param footnotes graph footnotes
183		#' @param paper paper size. default is "L8".
184		#' @param for_test `logic` CICD parameter
185		#' @param ... Additional arguments. not used.
186		#' @return No return value, called for side effects
187		#' @details
188		#' The paper default paper size, `L11`, indicate that the fontsize is 11.
189		#' The fontsize of the footnotes, is the fontsize of the titles minus 2.#'
190		#' @export
191		decorate.gtsummary <-
192		function(x, titles = "", footnotes = "", paper = "L11", for_test = FALSE, ...) {
193	1x	size <- fs(paper)
194	1x	glued_title <- glue::glue(paste(titles, collapse = "\n"))
195	1x	x <- x %>% modify_caption(caption = "")
196	1x	structure(
197	1x	.Data = x,
198	1x	titles = glued_title,
199	1x	paper = paper,
200	1x	class = union("dgtsummary", class(x))
201		)
202		}
203		# )
204
205		#' decorate list of grobs
206		#' @param x object to decorate
207		#' @param titles graph titles
208		#' @param footnotes graph footnotes
209		#' @param paper paper size. default is "L11".
210		#' @param for_test `logic` CICD parameter
211		#' @param ... additional arguments. not used
212		#' @details
213		#' The paper default paper size, `L11`, indicate that the fontsize is 11.
214		#' The fontsize of the footnotes, is the fontsize of the titles minus 2.
215		#' @return No return value, called for side effects
216		#' @export
217		#'
218		decorate.list <-
219		function(x, titles, footnotes, paper = "L11", for_test = FALSE, ...) {
220	1x	stopifnot(all(vapply(x, function(x) {
221	2x	"grob" %in% class(x) \|\| "ggplot" %in% class(x)
222	1x	}, FUN.VALUE = TRUE)))
223	1x	size <- fs(paper)
224	1x	x <- lapply(x, function(g) {
225	2x	ret <- g
226	2x	if ("ggplot" %in% class(g)) {
227	2x	ret <- ggplot2::ggplotGrob(g)
228		}
229	2x	ret
230		})
231	1x	grobs <- decorate_grob_set(
232	1x	grobs = x,
233	1x	titles = glue::glue(paste(titles, collapse = "\n")),
234	1x	footnotes = c(glue::glue(paste(footnotes, collapse = "\n")), git_footnote(for_test), datetime()),
235	1x	border = FALSE,
236	1x	gp_titles = gpar(fontsize = size$fontsize),
237	1x	gp_footnotes = gpar(fontsize = size$fontsize - 2)
238		)
239	1x	structure(
240	1x	.Data = grobs,
241	1x	paper = ifelse(size$orientation == "P", "a4", "a4r"),
242	1x	class = union("decoratedGrobSet", class(grobs))
243		)
244		}
245
246		#' Decorate outputs
247		#'
248		#' Decorate outputs with titles and footnotes
249		#'
250		#' @param outputs `list` of output objects as created by `generate_outputs`
251		#' @param generic_title `character` vector of titles
252		#' @param generic_footnote `character` vector of footnotes
253		#' @param version_label `character`. A version label to be added to the title.
254		#' @param for_test `logic` CICD parameter
255		#' @return No return value, called for side effects
256		#' @details
257		#' `generic_title` and `generic_footnote` will be added to all outputs. The use
258		#' case is to add information such as protocol number and snapshot date defined
259		#' in a central place (e.g. metadata.yml) to every output.
260		#'
261		#' `version_label` must be either `"DRAFT"`, `"APPROVED"` or `NULL`. By default,
262		#' when outputs are created on the master branch it is set to `NULL`, i.e. no
263		#' version label will be displayed. Otherwise `"DRAFT"` will be added. To add
264		#' `"APPROVED"` to the title you will need to explicitly set `version_label = "APPROVED"`.
265		#'
266		#' @export
267		decorate_outputs <- function(outputs,
268		generic_title = NULL,
269		generic_footnote = "Confidential and for internal use only",
270		version_label = get_version_label_output(),
271		for_test = FALSE) {
272	2x	assert_is_valid_version_label(version_label)
273
274	2x	lapply(outputs, function(output) {
275	18x	if (is(output, "autoslider_error")) {
276	!	return(output)
277		}
278
279	18x	spec <- attr(output, "spec")
280
281	18x	filter_titles <- function(...) {
282	18x	if (length(c(...)) == 0 \|\| "all" %in% c(...)) {
283	!	r <- vapply(
284	!	filters::get_filters(spec$suffix),
285	!	FUN = `[[`,
286	!	FUN.VALUE = character(1L),
287	!	"title"
288		)
289		} else {
290	18x	r <- vapply(
291	18x	Filter(
292	18x	f = function(x) any(x$target %in% toupper(c(...))),
293	18x	x = filters::get_filters(spec$suffix)
294		),
295	18x	FUN = `[[`,
296	18x	FUN.VALUE = character(1L),
297	18x	"title"
298		)
299		}
300	18x	paste(r, collapse = ", ")
301		}
302
303	18x	pattern <- "\\{filter_titles\\(((\"\\w+\")(,\\s\"\\w+\")){0,1}\\)\\}"
304	18x	if (grepl(pattern, spec$titles)) {
305	1x	m <- regmatches(spec$titles, regexpr(pattern, spec$titles))
306	1x	full_title <- paste(
307	1x	version_label,
308	1x	sub(pattern = pattern, eval(parse(text = m)), spec$titles)
309		)
310		} else {
311	17x	full_title <- paste(
312	17x	paste(version_label, spec$titles),
313	17x	filter_titles("ADSL"),
314	17x	sep = ", "
315		)
316		}
317
318	18x	if ("ggplot" %in% class(output)) {
319	4x	decorate.ggplot(output, titles = full_title)
320	14x	} else if ("grob" %in% class(output)) {
321	!	decorate.grob(output)
322		} else {
323	14x	structure(
324	14x	.Data = decorate(
325	14x	x = output,
326	14x	title = c(full_title, generic_title),
327	14x	footnotes = c(spec$footnotes, generic_footnote),
328	14x	paper = spec$paper,
329	14x	for_test = for_test
330		),
331	14x	spec = modifyList(spec, list(titles = glue::glue(paste0(c(full_title, generic_title), collapse = "\n"))))
332		)
333		}
334		})
335		}
336
337		#' Print decorated grob
338		#'
339		#' @param x An object of class `decoratedGrob`
340		#' @param ... not used.
341		#' @return No return value, called for side effects
342		#' @export
343		print.decoratedGrob <- function(x, ...) {
344	!	grid::grid.newpage()
345	!	grid::grid.draw(x)
346		}
347
348		#' Print decorated grob set
349		#'
350		#' @param x An object of class `decoratedGrobSet`
351		#' @param ... not used.
352		#' @return No return value, called for side effects
353		#' @export
354		print.decoratedGrobSet <- function(x, ...) {
355	!	for (plot in x) {
356	!	grid::grid.newpage()
357	!	grid::grid.draw(plot)
358		}
359		}

1		#' Death table
2		#'
3		#' @param adsl ADSL data set, dataframe
4		#' @param arm Arm variable, character, "`TRT01A" by default.
5		#' @param split_by_study Split by study, building structured header for tables
6		#' @param side_by_side used for studies in China. "GlobalAsia" or "GlobalAsiaChina" to define
7		#' the side by side requirement.
8		#' @return rtables object
9		#' @inherit gen_notes note
10		#' @export
11		#' @examples
12		#' library(dplyr)
13		#' adsl <- eg_adsl %>% preprocess_t_dd()
14		#' out1 <- t_dd_slide(adsl, "TRT01A")
15		#' print(out1)
16		#' generate_slides(out1, paste0(tempdir(), "/dd.pptx"))
17		#'
18		#' out2 <- t_dd_slide(adsl, "TRT01A", split_by_study = TRUE)
19		#' print(out2)
20		t_dd_slide <- function(adsl,
21		arm = "TRT01A",
22		split_by_study = FALSE,
23		side_by_side = NULL) {
24	8x	assert_that(has_name(adsl, "DTHCAT"))
25	8x	assert_that(has_name(adsl, "DTHFL"))
26
27	8x	anl <- adsl
28
29	8x	if (!is.null(side_by_side)) {
30	2x	anl$lvl <- "Global"
31		}
32
33	8x	if (nrow(anl) == 0) {
34	1x	return(null_report())
35		} else {
36	7x	lyt <- build_table_header(adsl, arm, split_by_study = split_by_study, side_by_side = side_by_side)
37
38	7x	lyt <- lyt %>%
39	7x	count_values(
40	7x	"DTHFL",
41	7x	values = "Y",
42	7x	denom = c("N_col"),
43	7x	.labels = c(count_fraction = "All Deaths")
44		) %>%
45	7x	analyze_vars(
46	7x	vars = "DTHCAT", .stats = "count_fraction",
47	7x	na_str = "<Missing>",
48	7x	var_labels = " ",
49	7x	na.rm = TRUE
50		) %>%
51		# count_patients_with_flags(
52		# "USUBJID",
53		# flag_variables = formatters::var_labels(anl[,c("DTHCAT1", "DTHCAT2", "DTHCAT3")]),
54		# .indent_mods = 1L,
55		# .format = list(trim_perc1),
56		# denom = "n"
57		# ) %>%
58	7x	append_topleft("N (%)")
59
60	7x	result <- lyt_to_side_by_side(lyt, anl, side_by_side)
61	6x	result@main_title <- "Death table"
62	6x	result
63		}
64		}

1		#' function wrapper to pass filtered data
2		#' @param func function name
3		#' @param datasets list of raw datasets
4		#' @param spec spec
5		#' @param verbose whether to show verbose information
6		#' @return a wrapped function using filtered adam
7		func_wrapper <-
8		function(func, datasets, spec, verbose = TRUE) {
9	23x	suffix <- spec$suffix
10	23x	function_args <- names(formals(func))
11	23x	datasets_filtered <- filters::apply_filter(
12	23x	data = datasets,
13	23x	id = suffix,
14	23x	verbose = verbose
15		)
16
17	23x	if ("datasets" %in% function_args) {
18	2x	if ("spec" %in% function_args) {
19	1x	return({
20	1x	function(...) {
21	1x	fastDoCall(func, list(datasets_filtered, spec = spec, ...))
22		}
23		})
24		} else {
25	1x	return({
26	1x	function(...) {
27	1x	fastDoCall(func, list(datasets_filtered, ...))
28		}
29		})
30		}
31		} else {
32		# to keep compatibility with previous version
33	21x	data_used <-
34	21x	function_args[function_args %in% names(datasets)]
35	21x	if ("spec" %in% function_args) {
36	1x	return({
37	1x	function(...) {
38	1x	fastDoCall(func, c(
39	1x	datasets_filtered[data_used],
40	1x	list(spec = spec),
41	1x	list(...)
42		))
43		}
44		})
45		} else {
46	20x	return({
47	20x	function(...) {
48	20x	fastDoCall(func, c(datasets_filtered[data_used], list(...)))
49		}
50		})
51		}
52		}
53		}

1		#' Does do.call quicker, and avoids issues with debug mode within do.call
2		#' @description copied from ms showcase app
3		#' @param what either a function or a non-empty character string naming the function to be called.
4		#' @param args a list of arguments to the function call. The names attribute of args gives the argument names.
5		#' @param quote a logical value indicating whether to quote the arguments.
6		#' @param envir an environment within which to evaluate the call. This will be most useful if what is a character
7		#' string and the arguments are symbols or quoted expressions.
8		#' @return No return value, called for side effects
9		#' @export
10		fastDoCall <-
11		function(what,
12		args,
13		quote = FALSE,
14		envir = parent.frame()) {
15	41x	if (quote) {
16	!	args <- lapply(args, enquote)
17		}
18
19	41x	if (is.null(names(args))) {
20	!	argn <- args
21	!	args <- list()
22		} else {
23		# Add all the named arguments
24	41x	argn <- lapply(names(args)[names(args) != ""], as.name)
25	41x	names(argn) <- names(args)[names(args) != ""]
26		# Add the unnamed arguments
27	41x	argn <- c(argn, args[names(args) == ""])
28	41x	args <- args[names(args) != ""]
29		}
30
31	41x	if (is(what, "character")) {
32	1x	if (is.character(what)) {
33	1x	fn <- strsplit(what, "[:]{2,3}")[[1]]
34	1x	what <- if (length(fn) == 1) {
35	1x	get(fn[[1]], envir = envir, mode = "function")
36		} else {
37	!	get(fn[[2]], envir = asNamespace(fn[[1]]), mode = "function")
38		}
39		}
40	1x	call <- as.call(c(list(what), argn))
41	40x	} else if (is(what, "function")) {
42	40x	f_name <- deparse(substitute(what))
43	40x	call <- as.call(c(list(as.name(f_name)), argn))
44	40x	args[[f_name]] <- what
45	!	} else if (is(what, "name")) {
46	!	call <- as.call(c(list(what, argn)))
47		}
48
49	41x	eval(call,
50	41x	envir = args,
51	41x	enclos = envir
52		)
53		}

1		#' Save an Output
2		#'
3		#' @param output Output object, e.g. an `rtable` or `grob`
4		#' @param file_name Full path of the new file excluding the extension
5		#' @param save_rds Saved as an `.rds` files
6		#' @details
7		#' Tables are saved as RDS file
8		#'
9		#' @return The input `object` invisibly
10		#' @export
11		#'
12		#' @examples
13		#' library(dplyr)
14		#' adsl <- eg_adsl %>%
15		#' filter(SAFFL == "Y") %>%
16		#' mutate(TRT01P = factor(TRT01P, levels = c("A: Drug X", "B: Placebo")))
17		#' output_dir <- tempdir()
18		#' t_dm_slide(adsl, "TRT01P", c("SEX", "AGE", "RACE", "ETHNIC", "COUNTRY")) %>%
19		#' decorate(
20		#' title = "Demographic table",
21		#' footnote = ""
22		#' ) %>%
23		#' save_output(
24		#' file_name = file.path(output_dir, "t_dm_SE"),
25		#' save_rds = TRUE
26		#' )
27		#'
28		setGeneric("save_output", function(output, file_name, save_rds) {
29		standardGeneric("save_output")
30		})
31
32		#' @rdname save_output
33		save_output <- function(output, file_name, save_rds = TRUE) {
34	6x	UseMethod("save_output")
35		}
36
37		#' @rdname save_output
38		#' @return No return value, called for side effects
39		#' @export
40		save_output.autoslider_error <- function(output,
41		file_name,
42		save_rds = TRUE) {
43	!	output
44		}
45
46		#' @rdname save_output
47		#' @aliases save_output, dVTableTree, dVTableTree-method
48		setMethod("save_output", "dVTableTree", save_output.dVTableTree <- function(output, file_name, save_rds = TRUE) {
49	12x	if (save_rds) {
50	12x	saveRDS(output, file = paste0(file_name, ".rds"))
51		}
52
53	12x	invisible(output)
54		})
55
56		#' @rdname save_output
57		#' @return The input `object` invisibly
58		#' @export
59		save_output.decoratedGrob <- function(output,
60		file_name,
61		save_rds = TRUE) {
62	4x	if (save_rds) {
63	4x	saveRDS(output, file = paste0(file_name, ".rds"))
64		}
65
66	4x	invisible(output)
67		}
68
69		#' @rdname save_output
70		#' @return The input `object` invisibly
71		#' @export
72		save_output.decoratedGrobSet <- function(output, file_name, save_rds = TRUE) {
73	!	if (save_rds) {
74	!	saveRDS(output, file = paste0(file_name, ".rds"))
75		}
76
77	!	invisible(output)
78		}
79
80
81		#' @rdname save_output
82		#' @return The input `object` invisibly
83		#' @export
84		save_output.dgtsummary <- function(output, file_name, save_rds = TRUE) {
85	1x	if (save_rds) {
86	1x	saveRDS(output, file = paste0(file_name, ".rds"))
87		}
88
89	1x	invisible(output)
90		}
91
92		#' @rdname save_output
93		#' @return The input `object` invisibly
94		#' @export
95		save_output.dlisting <- function(output, file_name, save_rds = TRUE) {
96	1x	if (save_rds) {
97	1x	saveRDS(output, file = paste0(file_name, ".rds"))
98		}
99
100	1x	invisible(output)
101		}
102
103
104		#' Save a list of outputs
105		#'
106		#' @param outputs `list` of outputs as created by `generate_outputs`
107		#' @param outfolder Folder in which to store the `outputs``
108		#' @param verbose_level Level of verbose information displayed.
109		#' Default set to `1`.
110		#' @param save_rds Should the input `outputs` be saved as `.rds` files in
111		#' in addition to `.out` or `.pdf` files? Defaults to `FALSE`.
112		#' @param generic_suffix generic suffix. must be length 1 character or NULL.
113		#' @export
114		#' @return The input `object` invisibly
115		#' @examplesIf require(filters)
116		#' ## As `save_outputs` is the last step in the pipeline we have to run
117		#' ## the 'whole machinery' in order to show its functionality.
118		#' library(dplyr, warn.conflicts = FALSE)
119		#'
120		#' data <- list(
121		#' adsl = eg_adsl,
122		#' adae = eg_adae,
123		#' adtte = eg_adtte
124		#' )
125		#'
126		#' filters::load_filters(
127		#' yaml_file = system.file("filters.yml", package = "autoslider.core"),
128		#' overwrite = TRUE
129		#' )
130		#'
131		#' ## For this example the outputs will be saved in a temporary directory. In a
132		#' ## production run this should be the reporting event's 'output' folder instead.
133		#' output_dir <- tempdir()
134		#'
135		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
136		#' read_spec(spec_file) %>%
137		#' filter_spec(program == "t_dm_slide") %>%
138		#' generate_outputs(datasets = data) %>%
139		#' decorate_outputs() %>%
140		#' save_outputs(outfolder = output_dir)
141		#'
142		save_outputs <- function(outputs,
143		outfolder = file.path("output"),
144		generic_suffix = NULL,
145		save_rds = TRUE,
146		verbose_level = 1) {
147	1x	stopifnot(is.list(outputs))
148
149	1x	if (!dir.exists(outfolder)) {
150	!	dir.create(outfolder)
151		}
152	1x	if (!is.null(generic_suffix)) {
153	!	if (!(is.character(generic_suffix) & length(generic_suffix) == 1)) {
154	!	stop("generic suffix must be length 1 character!")
155		}
156		}
157	1x	ret <- lapply(outputs, function(output) {
158	15x	spec <- attr(output, "spec")
159	15x	file_path <- file.path(outfolder, spec$output)
160	15x	file_path <- paste0(c(file_path, generic_suffix), collapse = "_")
161	15x	output <- save_output(
162	15x	output = output,
163	15x	file_name = file_path,
164	15x	save_rds = save_rds
165		)
166
167	15x	if (verbose_level > 0) {
168	15x	if (is(output, "autoslider_error")) {
169	!	cat_bullet(
170	!	"Saving output ",
171	!	attr(output, "spec")$output,
172	!	" failed in step ",
173	!	attr(output, "step"),
174	!	" with error message: ",
175	!	toString(output),
176	!	bullet = "cross",
177	!	bullet_col = "red"
178		)
179		} else {
180	15x	cat_bullet(
181	15x	"Output saved in path ",
182	15x	file_path,
183	15x	bullet = "tick",
184	15x	bullet_col = "green"
185		)
186		}
187		}
188
189	15x	attr(output, "outpath") <- get_output_file_ext(output, file_path)
190	15x	output
191		})
192
193	1x	if (verbose_level > 0) {
194	1x	total_number <- length(ret)
195	1x	fail_number <- sum(map_lgl(ret, is, class2 = "autoslider_error"))
196	1x	log_success_infomation(total_number - fail_number, fail_number)
197		}
198
199	1x	ret
200		}
201
202
203		#' Generate slides from rds files
204		#' @param filenames List of file names
205		#' @param template Template file path
206		#' @param outfile Out file path
207		#' @return No return value, called for side effects
208		#'
209		#' @export
210		#' @examplesIf require(filters)
211		#' library(dplyr, warn.conflicts = FALSE)
212		#'
213		#' data <- list(
214		#' adsl = eg_adsl,
215		#' adae = eg_adae,
216		#' adtte = eg_adtte
217		#' )
218		#'
219		#' filters::load_filters(
220		#' yaml_file = system.file("filters.yml", package = "autoslider.core"),
221		#' overwrite = TRUE
222		#' )
223		#'
224		#' ## For this example the outputs will be saved in a temporary directory. In a
225		#' ## production run this should be the reporting event's 'output' folder instead.
226		#' output_dir <- tempdir()
227		#'
228		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
229		#' read_spec(spec_file) %>%
230		#' filter_spec(program == "t_dm_slide") %>%
231		#' generate_outputs(datasets = data) %>%
232		#' decorate_outputs() %>%
233		#' save_outputs(outfolder = output_dir)
234		#'
235		#' slides_from_rds(list.files(file.path(output_dir, "t_dm_slide_FAS.rds")))
236		slides_from_rds <- function(filenames, outfile = paste0(tempdir(), "/output.pptx"),
237		template = file.path(system.file(package = "autoslider.core"), "theme/basic.pptx")) {
238	2x	outputs <- lapply(filenames, readRDS)
239	2x	generate_slides(outputs, outfile, template)
240		}

1		log_success_infomation <- function(success, failure) {
2	3x	total_number <- success + failure
3	3x	cat_bullet(
4	3x	"Total number of success ",
5	3x	success,
6		"/",
7	3x	total_number,
8	3x	bullet = "tick",
9	3x	bullet_col = "green"
10		)
11	3x	if (failure > 0) {
12	1x	cat_bullet(
13	1x	"Total number of failures ",
14	1x	failure,
15		"/",
16	1x	total_number,
17	1x	bullet = "cross",
18	1x	bullet_col = "red"
19		)
20		}
21		}
22
23		log_number_of_matched_records <- function(original_spec,
24		filtered_spec,
25		condition) {
26	3x	if (length(filtered_spec)) {
27	3x	msg <- sprintf(
28	3x	"%d/%d outputs matched the filter condition `%s`.",
29	3x	length(filtered_spec),
30	3x	length(original_spec),
31	3x	deparse(condition)
32		)
33	3x	cat_bullet(msg, bullet = "tick", bullet_col = "green")
34		} else {
35	!	msg <- sprintf(
36	!	"No output matched the filter condition `%s`",
37	!	deparse(condition)
38		)
39	!	cat_bullet(msg, bullet = "cross", bullet_col = "red")
40		}
41		}

1		#' Table color and font
2		#'
3		#' @description Zebra themed color
4		#'
5		#' @name autoslider_format
6		NULL
7
8		#' @describeIn autoslider_format
9		#'
10		#' User defined color code and font size
11		#'
12		#' @param ft flextable object
13		#' @param odd_header Hex color code, default to deep sky blue
14		#' @param odd_body Hex color code, default to alice blue
15		#' @param even_header Hex color code, default to slate gray
16		#' @param even_body Hex color code, default to slate gray
17		#' @param font_name Font name, default to arial
18		#' @param body_font_size Font size of the table content, default to 12
19		#' @param header_font_size Font size of the table header, default to 14
20		#' @return A flextable with applied theme.
21		#' @export
22		autoslider_format <- function(ft,
23		odd_header = "#0EAED5", # "deepskyblue2",
24		odd_body = "#EBF5FA", # "aliceblue",
25		even_header = "#0EAED5", # "slategray1",
26		even_body = "#D0E4F2", # "slategray1" # slategray1,
27		font_name = "arial",
28		body_font_size = 12,
29		header_font_size = 14) {
30	290x	ft %>%
31	290x	theme_zebra(
32	290x	odd_header = odd_header,
33	290x	odd_body = odd_body,
34	290x	even_header = odd_header,
35	290x	even_body = even_body
36		) %>%
37	290x	font(fontname = font_name, part = "all") %>%
38	290x	fontsize(size = body_font_size, part = "body") %>%
39	290x	color(color = "white", part = "header") %>%
40	290x	fontsize(size = header_font_size, part = "header") %>%
41	290x	bold(part = "header")
42		}
43
44
45		#' @describeIn autoslider_format
46		#'
47		#' Blue color theme
48		#'
49		#' @param ft flextable object
50		#' @param ... arguments passed to program
51		#'
52		#' @export
53		blue_format <- function(ft, ...) {
54	1x	ft %>% autoslider_format(
55	1x	odd_header = "#0B41CD",
56	1x	odd_body = "#1482FA",
57	1x	even_body = "#BDE3FF",
58		...
59		)
60		}
61
62		#' @describeIn autoslider_format
63		#'
64		#' Orange color theme
65		#'
66		#' @param ft flextable object
67		#' @param ... arguments passed to program
68		#'
69		#' @export
70		orange_format <- function(ft, ...) {
71	286x	ft %>% autoslider_format(
72	286x	odd_header = "#ED4A0D",
73	286x	odd_body = "#FF7D29",
74	286x	even_body = "#FFBD69",
75		...
76		)
77		}
78
79		#' @describeIn autoslider_format
80		#'
81		#' Red color theme
82		#'
83		#' @param ft flextable object
84		#' @param ... arguments passed to program
85		#'
86		#' @export
87		red_format <- function(ft, ...) {
88	1x	ft %>% autoslider_format(
89	1x	odd_header = "#C40000",
90	1x	odd_body = "#FF1F26",
91	1x	even_body = "#FF8782",
92		...
93		)
94		}
95
96
97		#' @describeIn autoslider_format
98		#'
99		#' Purple color theme
100		#'
101		#' @param ft flextable object
102		#' @param ... arguments passed to program
103		#'
104		#' @export
105		purple_format <- function(ft, ...) {
106	1x	ft %>% autoslider_format(
107	1x	odd_header = "#BC36F0",
108	1x	odd_body = "#E085FC",
109	1x	even_body = "#F2D4FF",
110		...
111		)
112		}
113
114		#' @describeIn autoslider_format
115		#'
116		#' `AutoslideR` dose formats
117		#'
118		#' @param ft flextable object
119		#' @param header_vals Header
120		#'
121		#' @export
122		autoslider_dose_format <- function(ft, header_vals = names(ft$body$dataset)) {
123		# The original implementation used delete_rows and add_header_row, which can be
124		# brittle. Using set_header_labels is the idiomatic and more robust way
125		# to simply change the text of the header row. This avoids the colwidths error.
126	1x	ft %>%
127	1x	theme_booktabs() %>%
128		# set_header_labels(values = header_vals) %>%
129	1x	bold(part = "header") %>%
130	1x	border_remove()
131		}
132
133
134		#' @describeIn autoslider_format
135		#'
136		#' Black color theme
137		#' @author Nina Qi and Jasmina Uzunovic
138		#' @param ft flextable object
139		#' @param ... arguments passed to program
140		#'
141		#' @export
142		black_format_tb <- function(ft, body_font_size = 8, header_font_size = 8, ...) {
143	1x	ft %>%
144	1x	theme_booktabs() %>%
145	1x	fontsize(size = body_font_size, part = "body") %>%
146	1x	fontsize(size = header_font_size, part = "header") %>%
147	1x	bold(part = "header") %>%
148	1x	color(color = "blue", part = "header") %>%
149	1x	border_inner_h(part = "all", border = fp_border(color = "black")) %>%
150	1x	hline_top(part = "all", border = fp_border(color = "black", width = 2)) %>%
151	1x	hline_bottom(part = "all", border = fp_border(color = "black", width = 2))
152		}

1		#' Plot mean values general function
2		#' used by wrappers `g_vs_slide`,`g_lb_slide`, & `g_eg_slide`
3		#'
4		#' adapted from https://insightsengineering.github.io/tlg-catalog/stable/graphs/other/mng01.html
5		#'
6		#' @param adsl ADSL dataset
7		#' @param data dataset containing the variable of interest in PARAMCD and AVAL
8		#' @inheritParams tern::g_lineplot
9		#' @param by_vars variables to merge the two datasets by
10		#' @param subtitle character scalar forwarded to g_lineplot
11		#' @param ... additional arguments passed to `tern::g_lineplot`
12		#' @author Stefan Thoma (`thomas7`)
13		#' @importFrom forcats fct_reorder
14		#' @import ggplot2
15		#' @import dplyr tern assertthat
16		#' @export
17		#' @examplesIf require('rsvg')
18		#' library(dplyr)
19		#' advs_filtered <- eg_advs %>% filter(
20		#' PARAMCD == "SYSBP"
21		#' )
22		#' out1 <- g_mean_general(eg_adsl, advs_filtered)
23		#' generate_slides(out1, paste0(tempdir(), "/g_mean.pptx"))
24		g_mean_general <- function(adsl,
25		data,
26		variables = control_lineplot_vars(group_var = "TRT01P"),
27		by_vars = c("USUBJID", "STUDYID"),
28		subtitle = "Plot of Mean and 95% Confidence Limits by Visit.",
29		...) {
30	9x	assert_that(is.string(subtitle))
31	9x	variables <- variables %>% strip_NA() # tern 0.9.4 added facet_var in control_lineplot_vars
32	9x	assert_that(has_name(data, c(by_vars, variables)))
33	9x	assert_that(has_name(adsl, c(by_vars, variables["group_var"])))
34
35	9x	adsl_f <- adsl %>%
36	9x	df_explicit_na()
37
38	9x	data_f <- data %>%
39	9x	mutate(AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min)) %>%
40	9x	dplyr::filter(
41	9x	AVISIT != "SCREENING"
42		) %>%
43	9x	droplevels() %>%
44	9x	df_explicit_na() %>%
45	9x	semi_join(adsl_f, by_vars)
46
47
48	9x	plot <- g_lineplot(
49	9x	df = data_f,
50	9x	alt_counts_df = adsl_f,
51	9x	variables = variables,
52	9x	title = "",
53	9x	subtitle = subtitle,
54		...
55		)
56	9x	plot
57		}

1		#' Refactor active arm
2		#'
3		#' @param df Input dataframe
4		#' @param arm_var Arm variable
5		#' @param levels factor levels
6		#' @param labels factor labels
7		#' @return Dataframe with re-level and re-labelled arm variable.
8		#' @export
9		mutate_actarm <- function(df,
10		arm_var = "TRT01A",
11		levels = c(
12		"PLACEBO + PACLITAXEL + CISPLATIN",
13		"ATEZOLIZUMAB + TIRAGOLUMAB + PACLITAXEL + CISPLATIN"
14		),
15		labels = c("Pbo+Pbo+PC", "Tira+Atezo+PC")) {
16	2x	df %>%
17	2x	mutate_at(arm_var, ~ factor(explicit_na(sas_na(.)),
18	2x	levels = levels,
19	2x	labels = labels
20		))
21		}
22
23		#' Preprocess t_dd function
24		#'
25		#' @param df Input dataframe
26		#' @param levels factor levels
27		#' @param labels factor labels
28		#' @return dataframe
29		#' @export
30		preprocess_t_dd <- function(df,
31		levels = c("PROGRESSIVE DISEASE", "ADVERSE EVENT", "OTHER", "<Missing>"),
32		labels = c("Progressive Disease", "Adverse Events", "Other", "<Missing>")) {
33	1x	noNA(levels)
34	1x	noNA(labels)
35	1x	assert_that(length(levels) >= 3)
36	1x	assert_that(length(labels) >= 3)
37
38	1x	df %>%
39	1x	mutate(
40	1x	DTHCAT1 = DTHCAT == levels[1],
41	1x	DTHCAT2 = DTHCAT == levels[2],
42	1x	DTHCAT3 = DTHCAT == levels[3],
43	1x	DTHCAT = factor(explicit_na(sas_na(DTHCAT)), levels = levels, labels = labels)
44		) %>%
45	1x	formatters::var_relabel(
46	1x	DTHCAT1 = labels[1],
47	1x	DTHCAT2 = labels[2],
48	1x	DTHCAT3 = labels[3]
49		)
50		}
51
52
53		#' Preprocess t_ds function
54		#'
55		#' @param df Input dataframe
56		#' @param levels factor levels
57		#' @param labels factor labels
58		#' @return dataframe
59		#' @export
60		preprocess_t_ds <- function(df,
61		levels = c("Alive: On Treatment", "Alive: In Follow-up", "<Missing>"),
62		labels = c("Alive: On Treatment", "Alive: In Follow-up", "<Missing>")) {
63	2x	assert_that(has_name(df, "DISTRTFL"),
64	2x	msg = "`DISTRTFL` variable is needed for deriving `STDONS` variable,
65	2x	suggest to use `DTRTxxFL` to create `DISTRTFL`."
66		)
67	2x	noNA(levels)
68	2x	noNA(labels)
69	2x	assert_that(length(levels) >= 3)
70	2x	assert_that(length(labels) >= 3)
71
72	2x	data_adsl <- df %>%
73		# Calculate STDONS
74	2x	mutate(STDONS = case_when(
75	2x	toupper(EOSSTT) == "ONGOING" & DTHFL == "" & DISTRTFL == "N" ~ "Alive: On Treatment",
76	2x	toupper(EOSSTT) == "ONGOING" & DISTRTFL == "Y" ~ "Alive: In Follow-up",
77	2x	TRUE ~ ""
78		)) %>%
79		# Process variable
80	2x	mutate(STDONS = factor(explicit_na(sas_na(STDONS)), levels = levels, labels = labels))
81		}

1		#' Plot mean values of VS
2		#'
3		#' Wrapper for `g_mean_general()`.
4		#' Requires filtering of the datasets (e.g. using SUFFIX in spec.yml)
5		#'
6		#' @param adsl ADSL data
7		#' @param advs ADVS data
8		#' @param arm `"TRT01P"` by default
9		#' @inheritParams g_mean_general
10		#' @param paramcd Which variable to use for plotting. By default `"PARAM"`
11		#' @param ... \|
12		#' Gets forwarded to `tern::g_lineplot()`.
13		#' This lets you specify additional arguments to `tern::g_lineplot()`
14		#' @author Stefan Thoma (`thomas7`)
15		#' @export
16		#' @examplesIf require('rsvg')
17		#' library(dplyr)
18		#' advs_filtered <- eg_advs %>% filter(
19		#' PARAMCD == "SYSBP"
20		#' )
21		#' plot_vs <- g_vs_slide(
22		#' adsl = eg_adsl,
23		#' advs = advs_filtered,
24		#' paramcd = "PARAM",
25		#' subtitle_add_unit = FALSE
26		#' ) +
27		#' ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))
28		#' # makes editable plots
29		#' generate_slides(plot_vs, paste0(tempdir(), "/g_vs.pptx"), fig_editable = TRUE)
30		#' # not editable plots, which appear as images
31		#' generate_slides(plot_vs, paste0(tempdir(), "/g_vs.pptx"), fig_editable = FALSE)
32		g_vs_slide <- function(adsl, advs, arm = "TRT01P", paramcd = "PARAM",
33		subtitle = "Plot of Mean and 95% Confidence Limits by Visit.", ...) {
34		# tern 0.9.4 added facet_var in control_lineplot_vars
35	4x	variables <- control_lineplot_vars(group_var = arm, paramcd = paramcd) %>% strip_NA()
36
37	3x	by_vars <- c("USUBJID", "STUDYID")
38	3x	assert_that(is.string(arm))
39	3x	assert_that(has_name(advs, c(by_vars, variables) %>% unique()))
40	3x	assert_that(has_name(adsl, c(by_vars, arm) %>% unique()))
41
42	3x	g_mean_general(
43	3x	adsl = adsl, data = advs, variables = variables, by_vars = by_vars,
44	3x	subtitle = subtitle, ...
45		)
46		}

1		#' Adverse Events listing
2		#' adapted from https://insightsengineering.github.io/tlg-catalog/stable/listings/adverse-events/ael02.html
3		#' @param adsl ADSL data
4		#' @param adae ADAE data
5		#' @export
6		#' @examples
7		#' library(dplyr)
8		#' library(rlistings)
9		#' adsl <- eg_adsl
10		#' adae <- eg_adae
11		#'
12		#' out <- l_ae_slide(adsl = adsl, adae = adae)
13		#' head(out)
14		l_ae_slide <- function(adsl, adae) {
15	2x	assert_that(has_name(adae, c(
16	2x	"SITEID", "SUBJID", "AGE", "SEX", "RACE", "TRTSDTM", "AETOXGR",
17	2x	"AENDY", "ASTDY", "AESER", "AEREL", "AEOUT", "AECONTRT", "AEACN"
18		)))
19
20		# Preprocess data
21	2x	adsl_f <- adsl %>%
22	2x	df_explicit_na()
23
24	2x	adae_f <- adae %>%
25	2x	semi_join(., adsl_f, by = c("STUDYID", "USUBJID")) %>%
26	2x	df_explicit_na() %>%
27	2x	mutate(
28	2x	CPID = paste(SITEID, SUBJID, sep = "/"),
29	2x	ASR = paste(AGE, SEX, RACE, sep = "/"),
30	2x	Date_First = toupper(format(as.Date(TRTSDTM), "%d%b%Y")),
31	2x	Duration = AENDY - ASTDY + 1,
32	2x	Serious = ifelse(AESER == "Y", "Yes", ifelse(AESER == "N", "No", "")),
33	2x	Related = ifelse(AEREL == "Y", "Yes", ifelse(AEREL == "N", "No", "")),
34	2x	Outcome = case_when(
35	2x	AEOUT == "FATAL" ~ 1,
36	2x	AEOUT == "NOT RECOVERED/NOT RESOLVED" ~ 2,
37	2x	AEOUT == "RECOVERED/RESOLVED" ~ 3,
38	2x	AEOUT == "RECOVERED/RESOLVED WITH SEQUELAE" ~ 4,
39	2x	AEOUT == "RECOVERING/RESOLVING" ~ 5,
40	2x	AEOUT == "UNKNOWN" ~ 6
41		),
42	2x	Treated = ifelse(AECONTRT == "Y", "Yes", ifelse(AECONTRT == "N", "No", "")),
43	2x	Action = case_when(
44	2x	AEACN == "DOSE INCREASED" ~ 1,
45	2x	AEACN == "DOSE NOT CHANGED" ~ 2,
46	2x	AEACN == "DOSE REDUCED" \| AEACN == "DOSE RATE REDUCED" ~ 3,
47	2x	AEACN == "DRUG INTERRUPTED" ~ 4,
48	2x	AEACN == "DRUG WITHDRAWN" ~ 5,
49	2x	AEACN == "NOT APPLICABLE" \| AEACN == "NOT EVALUABLE" ~ 6,
50	2x	AEACN == "UNKNOWN" ~ 7
51		)
52		) %>%
53	2x	select(
54	2x	CPID,
55		# ASR,
56		# TRT01A,
57	2x	AEDECOD,
58	2x	Date_First,
59		# ASTDY,
60		# Duration,
61	2x	Serious,
62		# AESEV,
63	2x	Related,
64		# Outcome,
65		# Treated,
66	2x	AETOXGR,
67	2x	Action
68		)
69
70
71	2x	formatters::var_labels(adae_f) <- c(
72	2x	CPID = "Center/Patient ID", # keep
73		# ASR = "Age/Sex/Race",
74		# TRT01A = "Treatment", #keep
75	2x	AEDECOD = "Adverse\nEvent MedDRA\nPreferred Term", # keep
76	2x	Date_First = "Date of\nFirst Study\nDrug\nAdministration", # keep
77		# ASTDY = "Study\nDay of\nOnset",
78		# Duration = "AE\nDuration\nin Days",
79	2x	Serious = "Serious", # keep
80		# AESEV = "Most\nExtreme\nIntensity",
81	2x	Related = "Caused by\nStudy\nDrug", # keep
82		# Outcome = "Outcome\n(1)",
83		# Treated = "Treatment\nfor AE",
84	2x	AETOXGR = "Analysis Toxicity Grade", # keep
85	2x	Action = "Action\nTaken\n(2)" # keep
86		)
87
88		# Set up listing
89
90	2x	lsting <- as_listing(
91	2x	adae_f,
92	2x	key_cols = c("CPID"),
93	2x	disp_cols = names(adae_f)
94		)
95
96	2x	lsting
97		}

1		#' Convert dates from `yyyy-mm-dd` format into 20APR2019 format
2		#' `Datetime` format removes the time and outputs date in the same way
3		#' Able to handle truncated dates as well (e.g. just the year or year and month)
4		#'
5		#' `dplyr::case_when()` will check all RHS expressions on the input, this means if
6		#' these expressions return warnings, they will happen even then the input doesn't
7		#' doesn't satisfy the LHS. For this reason, I had to 'quiet' all `lubridate` functions.
8		#' This `format_date()` function was tested with the inputs in the examples, all gave the
9		#' expected returned value, so there should be no issues.
10		#'
11		#' @param x vector of dates in character, in `yyyy-mm-dd` format
12		#' @return A vector.
13		#'
14		#' @export
15		#' @examplesIf require(lubridate)
16		#' require(lubridate)
17		#'
18		#' # expected to return "2019"
19		#' format_date("2019")
20		#'
21		#' # expected to return "20APR2019"
22		#' format_date("2019-04-20")
23		#'
24		#' # expected to return ""
25		#' format_date("")
26		#'
27		#' # expected to return "18JUN2019"
28		#' format_date("2019-06-18T10:32")
29		#'
30		#' # expected to return "APR2019"
31		#' format_date("2019-04")
32		#'
33		format_date <- function(x) {
34	5x	x_form <- case_when(
35	5x	nchar(x) > 10 ~ toupper(format(lubridate::date(lubridate::ymd_hms(x, truncated = 3, quiet = TRUE)), "%d%b%Y")),
36	5x	nchar(x) == 10 ~ toupper(format(lubridate::ymd(x, quiet = TRUE), "%d%b%Y")),
37	5x	nchar(x) == 7 ~ substr(toupper(format(lubridate::ymd(x, truncated = 2, quiet = TRUE), "%d%b%Y")), 3, 9),
38	5x	nchar(x) == 4 ~ x,
39	5x	is.na(x) ~ "",
40	5x	TRUE ~ ""
41		)
42
43	5x	x_form
44		}

1		#' Null report
2		#'
3		#' @author Thomas Neitmann (`neitmant`)
4		#'
5		#' @details
6		#' This will create a null report similar as STREAM does. You can use
7		#' it inside output functions as shown in the example below.
8		#' @return An empty `rtables` object
9		#' @examplesIf require(filters)
10		#' library(dplyr)
11		#' library(filters)
12		#' data <- list(
13		#' adsl = eg_adsl,
14		#' adae = eg_adae %>% mutate(AREL = "")
15		#' )
16		#'
17		#' null_report()
18		#'
19		#' ## An example how to use the `null_report()` inside an output function
20		#' t_ae <- function(datasets) {
21		#' trt <- "ACTARM"
22		#' anl <- semi_join(
23		#' datasets$adae,
24		#' datasets$adsl,
25		#' by = c("STUDYID", "USUBJID")
26		#' )
27		#'
28		#' return(null_report())
29		#' }
30		#'
31		#' data %>%
32		#' filters::apply_filter("SER_SE") %>%
33		#' t_ae()
34		#'
35		#' @export
36		#'
37		null_report <- function() {
38	4x	rtable(
39	4x	header = " ",
40	4x	rrow("", "Null Report: No observations met the reporting criteria for inclusion in this output.")
41		)
42		}

1		#' Demographic table with gtsummary
2		#'
3		#' @param adsl ADSL data set, dataframe
4		#' @param arm Arm variable, character, "`TRT01P" by default.
5		#' @param vars Characters of variables
6		#' @return gtsummary object
7		#' @inherit gen_notes note
8		#' @export
9		#' @examples
10		#' library(dplyr)
11		#' adsl <- eg_adsl
12		#' out1 <- gt_t_dm_slide(adsl, "TRT01P", c("SEX", "AGE", "RACE", "ETHNIC", "COUNTRY"))
13		#' print(out1)
14		#' generate_slides(out1, paste0(tempdir(), "/dm.pptx"))
15		#'
16		gt_t_dm_slide <- function(adsl,
17		arm = "TRT01P",
18		vars = c("AGE", "SEX", "RACE")) {
19	1x	adsl \|>
20	1x	select(all_of(c(vars, arm))) \|>
21	1x	tbl_summary(by = all_of(arm)) \|>
22	1x	modify_caption(caption = "Demographic slide") # Set default title
23		}

1		#' autoslider_error class
2		#' @details this function is used to create autoslider_error object.
3		#' this function is for internal use only to create the autoslider_error object.
4		#' It enable us for further functionalities, like providing help on easy debugging,
5		#' e.g. if the error is inside the user function, provide the call and let the user
6		#' run the code outside the pipeline.
7		#' @param x character scaler
8		#' @param spec spec should be a list containing "program" and "suffix"
9		#' @param step step is a character indicating in which step the pipeline encounter error
10		#' @return autoslider_error object
11		#' @export
12		autoslider_error <- function(x, spec, step) {
13	1x	assert_is_character_scalar(x)
14	1x	structure(
15	1x	.Data = x,
16	1x	step = step,
17	1x	spec = spec,
18	1x	class = "autoslider_error"
19		)
20		}