autoslider.core coverage - 87.51%

Files
Source

#' 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 Study-level token values merged into every spec entry. Either
#'   a named `list` (or `NULL`), or a `character(1)` path to a yaml metadata file
#'   (see [read_metadata()] and the example at
#'   `system.file("metadata.yml", package = "autoslider.core")`), which is read
#'   into a list for you. Its elements can be referenced as `{token}`
#'   placeholders in the `titles` and `footnotes` fields of the spec and are
#'   substituted during decoration (see [apply_tokens()]). For example, with
#'   `metadata = list(study = "BP12345")` a spec title of
#'   `"Demographics - Study {study}"` becomes `"Demographics - Study BP12345"`.
#'
#' @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]
#'
#' ## Supply study metadata so that `{token}` placeholders in titles/footnotes
#' ## are filled in during decoration (e.g. a title of "... Study {study}").
#' spec <- read_spec(spec_file, metadata = list(study = "BP12345"))
#'
#' ## The same metadata can be kept in a yaml file and read via `read_spec()`
#' metadata_file <- system.file("metadata.yml", package = "autoslider.core")
#' spec <- read_spec(spec_file, metadata = metadata_file)
#'
read_spec <- function(spec_file = "spec.yml",
                      metadata = NULL) {
  if (is.character(metadata)) {
    metadata <- read_metadata(metadata)
  }
  spec <- yaml::read_yaml(spec_file, eval.expr = TRUE)
  spec_obj <- check_and_flattern_suffix(spec, metadata = metadata)
  as_spec(spec_obj)
}

#' Read a study metadata file
#'
#' Reads a yaml metadata file into a named `list` of study-level values suitable
#' for the `metadata` argument of [read_spec()] and [apply_tokens()]. Each
#' top-level key in the file becomes a `{token}` that can be referenced in the
#' `titles` and `footnotes` fields of a spec. An example file is shipped at
#' `system.file("metadata.yml", package = "autoslider.core")`.
#'
#' @param metadata_file `character(1)`. Path to a yaml metadata file, i.e. a flat
#'   mapping of `key: value` pairs.
#'
#' @return A named `list` of metadata values.
#'
#' @seealso [read_spec()], [apply_tokens()]
#'
#' @export
#'
#' @examples
#' metadata_file <- system.file("metadata.yml", package = "autoslider.core")
#'
#' ## Take a look at the 'raw' content of the metadata file
#' cat(readLines(metadata_file), sep = "\n")
#'
#' ## Read it into a named list of token values
#' read_metadata(metadata_file)
read_metadata <- function(metadata_file = "metadata.yml") {
  checkmate::assert_file_exists(metadata_file, access = "r")
  metadata <- yaml::read_yaml(metadata_file, eval.expr = TRUE)
  checkmate::assert_list(metadata, names = "named", .var.name = "metadata file contents")
  metadata
}

#' Flatten spec entries with multiple suffixes
#'
#' @description
#' Checks each entry of a raw spec (as read from a yaml file). When an entry's
#' `suffix` field is a list/vector of more than one value, the entry is
#' flattened into several entries that share the same `program`, `titles`,
#' `footnotes`, `args`, etc., differing only in their (scalar) `suffix`.
#' Optional `metadata` is appended to each resulting entry.
#'
#' @param spec A `list` of raw spec entries as returned by [yaml::read_yaml()].
#' @param metadata Metadata of study, appended to each flattened entry.
#'
#' @return
#' A flat `list` of spec entries, each with a single `suffix` value.
#'
#' @noRd
check_and_flattern_suffix <- function(spec, metadata = NULL) {
  ret <- lapply(spec, function(s) {
    lapply(s$suffix, function(su) {
      entry <- s
      entry$suffix <- su
      c(entry, metadata)
    })
  })
  unlist(ret, recursive = FALSE)
}

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

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


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

# Null-coalescing helper (base R gains `%||%` only in 4.4.0; package supports 4.1.0)
`%||%` <- function(a, b) if (is.null(a)) b else a


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

#' 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 font_size Deck-wide default table font sizes, a named `list` with any
#'   of `body`, `header`, `footer` (point sizes). Per-slide sizes declared in the
#'   spec (a `font_size:` block on the entry) override these. Applied by wrapping
#'   the slide's `table_format` via [with_font_sizes()]; see Details.
#' @param ... arguments passed to program
#' @return No return value, called for side effects
#' @details
#' ## Per-slide font size
#' Each output carries its spec entry as an attribute (set by
#' [generate_outputs()]). `generate_slides()` reads two optional keys from it:
#' `table_format` (a formatter function) and `font_size` (a named list with
#' `body`/`header`/`footer`). The effective formatter for a slide is
#' `with_font_sizes(table_format, body, header, footer)`, so font sizes can be
#' set per slide directly in the spec, e.g.
#' \preformatted{
#' t_dm_slide_FAS:
#'   program: t_dm_slide
#'   suffix: FAS
#'   table_format: black_format_tb
#'   font_size:
#'     body: 6
#'     header: 6
#'     footer: 5
#' }
#' The `font_size` argument sets deck-wide defaults; per-slide values win.
#' @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,
                            font_size = NULL, ...) {
  if (any(c(
    inherits(outputs, "VTableTree"),
    inherits(outputs, "listing_df")
  ))) {
    if (inherits(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(
    inherits(outputs, "data.frame"),
    inherits(outputs, "ggplot"),
    inherits(outputs, "gtsummary"),
    inherits(outputs, "tbl_roche_summary"),
    inherits(outputs, "dVTableTree"),
    inherits(outputs, "dlisting"),
    inherits(outputs, "grob")
  ))) {
    if (inherits(outputs, "ggplot")) {
      current_title <- outputs$labels$title
      if (is.null(current_title)) {
        current_title <- ""
      }
      outputs <- decorate.ggplot(outputs, titles = current_title)
    } else if (inherits(outputs, "grob")) {
      outputs <- decorate.grob(outputs)
    } else if (
      (inherits(outputs, "gtsummary") || inherits(outputs, "tbl_roche_summary")) &&
      !inherits(outputs, "dgtsummary")
    ) {
      current_title <- tryCatch(outputs$table_styling$caption, error = function(e) NULL)
      if (is.null(current_title) || !nzchar(current_title)) current_title <- ""
      outputs <- decorate(outputs, titles = current_title)
    }

    outputs <- list(outputs)
  }

  assert_that(is.list(outputs))

  # ======== generate slides =======#
  # Arguments forwarded to to_flextable()/table_to_slide(). `table_format` and
  # `font_size` are managed per-slide below, so they are pulled out of the
  # forwarded set to avoid clashing with the values we inject.
  dots <- list(...)
  fwd <- dots
  fwd$table_format <- NULL

  # Deck-wide default font sizes. Accept the tidy `font_size = list(...)` form
  # and, for backwards compatibility, scalar *_font_size passed via `...`.
  deck_fs <- font_size %||% list()
  deck_fs$body <- deck_fs$body %||% dots$body_font_size
  deck_fs$header <- deck_fs$header %||% dots$header_font_size
  deck_fs$footer <- deck_fs$footer %||% dots$footer_font_size
  fwd$body_font_size <- NULL
  fwd$header_font_size <- NULL
  fwd$footer_font_size <- NULL

  # Merge deck defaults with a slide's own spec `font_size` block (slide wins).
  slide_fs <- function(x) {
    sp <- attr(x, "spec")
    modifyList(deck_fs, (sp$font_size) %||% list())
  }
  # Effective formatter for a slide: its spec `table_format` (else the deck-wide
  # one, else `default_fmt`), wrapped so the resolved font sizes are applied.
  resolve_format <- function(x, default_fmt) {
    sp <- attr(x, "spec")
    fs <- slide_fs(x)
    base_fmt <- (sp$table_format) %||% dots$table_format %||% default_fmt
    with_font_sizes(base_fmt, fs$body, fs$header, fs$footer)
  }
  # Arguments that belong to `table_to_slide()` (slide placement / decoration) but
  # are not accepted by `to_flextable()` or its formatter helpers. A spec may set
  # these (e.g. `layout = "08_TitleAndContent"`, `table_loc = ...`); they must reach
  # `call_slide()` but must be dropped before `to_flextable()`, otherwise they leak
  # through the formatter's `...` (e.g. `autoslider_format()`) and error with
  # "unused argument".
  slide_only_args <- c("decor", "layout", "table_loc", "usernotes", "footer_font_size")
  fwd_ft <- fwd[setdiff(names(fwd), slide_only_args)]
  call_ft <- function(x, more) {
    do.call(to_flextable, c(list(x = x), more, fwd_ft))
  }
  call_slide <- function(content, more) {
    do.call(table_to_slide, c(list(ppt = ppt, content = content), more, fwd))
  }

  # 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 (inherits(x, "dVTableTree") || inherits(x, "VTableTree")) {
      tf <- resolve_format(x, orange_format)
      footer_pt <- slide_fs(x)$footer
      y <- call_ft(x, list(lpp = t_lpp, cpp = t_cpp, table_format = tf))
      usernotes <- x@usernotes
      for (tt in y) {
        call_slide(tt, list(
          table_loc = center_table_loc(tt$ft, ppt_width = width, ppt_height = height),
          usernotes = usernotes, footer_font_size = footer_pt
        ))
      }
    } else if (inherits(x, "dlisting")) {
      y <- call_ft(x, list(cpp = l_cpp, lpp = l_lpp))
      for (tt in y) {
        call_slide(tt, list(
          table_loc = center_table_loc(tt$ft, ppt_width = width, ppt_height = height)
        ))
      }
    } else if (inherits(x, "data.frame")) { # this is dedicated for small data frames without pagination
      tf <- resolve_format(x, orange_format)
      y <- call_ft(x, list(table_format = tf))
      call_slide(y, list(decor = FALSE))
    } else if (inherits(x, "dgtsummary")) {
      tf <- resolve_format(x, autoslider_format)
      footer_pt <- slide_fs(x)$footer
      y <- call_ft(x, list(
        lpp = t_lpp, ppt_height = height, ppt_width = width, table_format = tf
      ))
      for (tt in y) {
        call_slide(tt, list(
          table_loc = center_gts_table_loc(tt$ft, ppt_width = width, ppt_height = height),
          footer_font_size = footer_pt
        ))
      }
    } else if (inherits(x, "gtsummary") || inherits(x, "tbl_roche_summary")) {
      tf <- resolve_format(x, autoslider_format)
      y <- call_ft(x, list(table_format = tf))
      call_slide(y, list(decor = FALSE))
    } else {
      if (any(class(x) %in% c("decoratedGrob", "decoratedGrobSet", "ggplot"))) {
        if (inherits(x, "ggplot")) {
          x <- decorate.ggplot(x)
        }

        assertthat::assert_that(inherits(x, "decoratedGrob") || inherits(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 (inherits(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 (inherits(x, "VTableTree")) {
    ret <- to_flextable(paginate_table(x, lpp = 20)[[1]])
  } else if (inherits(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 (inherits(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
}

# Position table in the body area below the title placeholder.
# title_bottom marks where the title area ends; the table is centered
# in the remaining vertical space so it never overlaps the title or
# extends past the slide bottom.
center_gts_table_loc <- function(ft, ppt_width, ppt_height, title_bottom = 1.5) {
  ft_height <- flextable_dim(ft)$heights
  ft_width <- flextable_dim(ft)$widths
  body_height <- ppt_height - title_bottom
  top <- title_bottom + max(0, (body_height - ft_height) / 2)
  left <- max(0, (ppt_width - ft_width) / 2)
  ph_location(left = left, top = top, width = ft_width, height = ft_height)
}

#' 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 layout layout from theme
#' @param footer_font_size Optional point size for the footnote text. `NULL`
#'   keeps the existing footnote size set on the flextable.
#' @param ... additional arguments
#' @return Slide with added content
table_to_slide <- function(ppt, content, decor = TRUE, layout = "Title and Content",
                           table_loc = ph_location_type("body"), usernotes = "",
                           footer_font_size = NULL, ...) {
  layt_summary <- layout_summary(ppt)
  assertthat::assert_that(layout %in% layt_summary$layout)
  ppt_master <- layt_summary$master[1]
  args <- list(...)
  ppt <- layout_default(ppt, layout)

  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 != "") {
      footnote_value <- if (!is.null(footer_font_size)) {
        as_paragraph(as_chunk(content$footnotes, props = fp_text(font.size = footer_font_size)))
      } else {
        as_paragraph(content$footnotes)
      }
      out <- footnote(out,
        i = 1, j = 1,
        value = footnote_value,
        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)
  })

  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 layout theme layout
#' @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,
                            layout = "Title and Content",
                            figure_loc = ph_location_type("body"),
                            fig_editable = FALSE,
                            ...) {
  layt_summary <- layout_summary(ppt)
  assertthat::assert_that(layout %in% layt_summary$layout)
  ppt_master <- layt_summary$master[1]
  ppt <- layout_default(ppt, layout)
  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)
    })
    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)
    }
    ppt
  } else {
    stop("Should not reach here")
  }
}

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

  ft
}

#' convert gtsummary to flextable
#' @param x gtsummary object
#' @param table_format Function applied to the flextable for styling
#' @param ... additional arguments, not used
#' @export
to_flextable.gtsummary <- function(x, table_format = autoslider_format, ...) {
  gtsummary::as_flex_table(x) %>% table_format()
}

#' convert tbl_roche_summary (NEST 2 gtsummary subclass) to flextable
#' @param x tbl_roche_summary object
#' @param ... arguments passed to \code{to_flextable.gtsummary}
#' @export
to_flextable.tbl_roche_summary <- function(x, ...) {
  # gtsummary v2 guards as_flex_table() with check_class(x, "gtsummary").
  # Restore the standard hierarchy if it was stripped.
  if (!inherits(x, "gtsummary")) {
    class(x) <- c(class(x), "tbl_summary", "gtsummary")
  }
  to_flextable.gtsummary(x, ...)
}

#' convert dgtsummary to flextable
#'
#' @param x dgtsummary object
#' @param lpp Lines (rows) per page; overridden when ppt_height is supplied
#' @param ppt_height Slide height in inches; used to auto-compute lpp
#' @param ppt_width Slide width in inches; used to scale table columns
#' @param table_format Function applied to the flextable for styling
#' @param ... additional arguments, not used
#' @export
to_flextable.dgtsummary <- function(x, lpp = 20, ppt_height = NULL, ppt_width = NULL,
                                    table_format = autoslider_format, ...) {
  ft_full <- gtsummary::as_flex_table(x) %>% table_format()

  # Scale columns to fit slide width
  if (!is.null(ppt_width)) {
    total_width <- flextable_dim(ft_full)$widths
    if (total_width > ppt_width) {
      ft_full <- width(ft_full, width = dim(ft_full)$widths * ppt_width / total_width)
    }
  }

  # Compute lpp from actual row heights and available body area on slide.
  # flextable stores rowheights as minimum heights ("atleast" mode); apply a 1.3x
  # safety factor to account for padding expanding rows beyond the stored minimum.
  if (!is.null(ppt_height)) {
    header_height <- sum(ft_full$header$rowheights)
    available_body <- ppt_height - 1.5 - header_height # 1.5in for title + margins
    row_heights_est <- ft_full$body$rowheights * 1.3
    lpp <- max(sum(cumsum(row_heights_est) <= available_body), 1L)
  }

  n_body <- nrow(ft_full$body$dataset)
  header_text <- paste(attr(x, "titles"), collapse = "\n")
  footnotes_text <- paste(attr(x, "footnotes"), collapse = "\n")
  n_pages <- ceiling(n_body / lpp)
  ft_list <- lapply(seq_len(n_pages), function(pg) {
    rows_keep <- seq.int((pg - 1L) * lpp + 1L, min(pg * lpp, n_body))
    rows_delete <- setdiff(seq_len(n_body), rows_keep)
    ft_page <- if (length(rows_delete) > 0L) {
      delete_rows(ft_full, i = rows_delete, part = "body")
    } else {
      ft_full
    }
    list(
      ft = ft_page,
      header = if (pg == 1L) header_text else paste(header_text, "(cont.)"),
      footnotes = footnotes_text
    )
  })
  class(ft_list) <- "dflextable"
  ft_list
}




#' convert data.frame to flextable
#' @export
to_flextable.data.frame <- function(x, col_width = NULL, table_format = orange_format,
                                    dose_template = FALSE, font_size = NULL, ...) {
  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(...)

  # font_size, when supplied, forces a uniform size across the whole table and
  # therefore overrides any sizing done by `table_format`. Left NULL by default
  # so per-slide font sizes injected into `table_format` are preserved.
  if (!is.null(font_size)) {
    ft <- ft %>% fontsize(size = font_size, part = "all")
  }
  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
  }

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

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

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

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

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

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

  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.
#' @param metadata Named `list` (or `NULL`) of token values used to substitute
#'   `{token}` placeholders in `study_id`. See [apply_tokens()].
#'
#' @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,
    metadata = NULL) {
  doc_original <- initialize_doc_original(doc_original, doc_o)

  to_page <- initialize_to_page(doc_original, to_page)

  study_id <- apply_tokens(study_id, metadata)

  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")

  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.
#' @param metadata Named `list` (or `NULL`) of token values used to substitute
#'   `{token}` placeholders in `section_title`. See [apply_tokens()].
#'
#' @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,
    metadata = NULL) {
  doc_original <- initialize_doc_original(doc_original, doc_o)

  to_page <- initialize_to_page(doc_original, to_page)

  section_title <- apply_tokens(section_title, metadata)

  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")

  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.
#' @param metadata Named `list` (or `NULL`) of token values used to substitute
#'   `{token}` placeholders in each slide's text (e.g. `study_id`,
#'   `section_title`). See [apply_tokens()].
#'
#' @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,
    metadata = NULL) {
  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,
        metadata = metadata
      )
    } 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,
        metadata = metadata
      )
    }
  }

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

  doc
}

# AI "story" content slides
# ------------------------------------------------------------------------------
# A post-processing step that complements `get_ai_notes()` (which attaches an
# LLM response as *speaker notes*, easy to miss and never shown in presentation
# mode). Instead, this loads an already-generated deck, sends the underlying
# table data to an LLM asking it to "tell a story", and inserts the narrative as
# REAL content slides (title + bullets on an AI-chosen layout): a short summary
# section at the front of the deck and a conclusions section at the end.
#
# The design keeps the LLM call (`get_ai_story()`) separate from the pure
# `officer` slide insertion (`add_story_slides()`) so the bulk of the logic is
# unit-testable without any network access.

# Layouts the AI is allowed to pick from. Deliberately a small, text-only subset
# so the narrative always renders regardless of the template's design layouts.
.story_safe_layouts <- c("Section Header", "Title and Content", "Title Only")

#' Layouts available for AI story slides
#'
#' Intersects the safe text-only layout subset with the layouts the template
#' actually ships, so every layout offered to the LLM is guaranteed to exist.
#'
#' @param ppt An `officer::rpptx` object.
#'
#' @return A character vector of layout names present in `ppt`.
#'
#' @noRd
story_layout_choices <- function(ppt) {
  available <- officer::layout_summary(ppt)$layout
  choices <- intersect(.story_safe_layouts, available)
  if (length(choices) == 0) {
    # Fall back to whatever the template ships so we never offer an empty set.
    choices <- available
  }
  choices
}

#' Build the deck-level story prompt from decorated outputs
#'
#' Collects the rendered text of each decorated table output (reusing
#' `export_as_txt()`, exactly as `integrate_prompt()` does for AI notes) and
#' assembles one instruction asking the LLM to produce a short summary section
#' and a conclusions section, each slide carrying a title, concise bullets and a
#' layout chosen from `allowed_layouts`.
#'
#' Outputs that errored (`autoslider_error`) or that are not tables (no `tbl`
#' slot, e.g. figures/listings) are skipped.
#'
#' @param outputs A named `list` of decorated outputs (as returned by
#'   [decorate_outputs()]).
#' @param allowed_layouts Character vector of permitted slide layouts.
#' @param max_slides Integer cap on the number of slides per section.
#'
#' @return A single character string: the prompt.
#'
#' @noRd
build_story_prompt <- function(outputs, allowed_layouts, max_slides = 4L) {
  tables <- list()
  for (nm in names(outputs)) {
    out <- outputs[[nm]]
    if (is(out, "autoslider_error")) {
      next
    }
    if (!methods::.hasSlot(out, "tbl")) {
      next
    }
    txt <- tryCatch(
      paste(export_as_txt(out@tbl), collapse = "\n"),
      error = function(e) ""
    )
    if (nzchar(txt)) {
      tables[[nm]] <- txt
    }
  }

  tables_block <- paste(
    vapply(
      names(tables),
      function(nm) paste0("### ", nm, "\n", tables[[nm]]),
      character(1)
    ),
    collapse = "\n\n"
  )

  paste0(
    "You are a Clinical data scientist expert preparing a slide deck for a ",
    "study team. Below are the tables from a generated deck.\n\n",
    tables_block,
    "\n\n",
    "Tell the story of these data as presentation slides. Produce two sections:\n",
    "1. `summary`: up to ", max_slides, " slides that open the deck and give the ",
    "audience the key take-aways before they see the detailed tables.\n",
    "2. `conclusions`: up to ", max_slides, " slides that close the deck with the ",
    "main conclusions and any caveats.\n\n",
    "For every slide provide a short title, a handful of concise bullet points, ",
    "and choose a `layout` from exactly this set: ",
    paste(allowed_layouts, collapse = ", "), ". ",
    "Use a section-divider layout (e.g. 'Section Header') for the slide that ",
    "opens each section, and a content layout for slides that carry bullets. ",
    "Keep bullets factual and grounded in the numbers above."
  )
}

#' Fallback: get the story as plain-text JSON and parse it
#'
#' Used when a provider does not support `chat$chat_structured()`. Asks the model
#' to reply with a bare JSON object matching the story schema, strips any
#' reasoning block or markdown fence, extracts the outermost JSON object and
#' parses it. Returns a `list(summary, conclusions)`; missing sections default to
#' empty lists.
#'
#' @param chat An `ellmer` chat object.
#' @param prompt The deck-level story prompt (see [build_story_prompt()]).
#' @param allowed_layouts Character vector of permitted layouts (named in the
#'   JSON instruction so the model stays in range).
#'
#' @return A `list` with `summary` and `conclusions` elements.
#'
#' @noRd
story_via_json <- function(chat, prompt, allowed_layouts) {
  instruction <- paste0(
    prompt, "\n\n",
    "Respond with ONLY a JSON object (no markdown fences, no commentary) of the form:\n",
    '{"summary":[{"layout":"<one of: ', paste(allowed_layouts, collapse = " | "),
    '>","title":"a short title","bullets":["a bullet","another bullet"]}],',
    '"conclusions":[{"layout":"...","title":"...","bullets":["..."]}]}'
  )
  raw <- chat$chat(instruction, echo = "none")
  txt <- sub(".*?</think>\\s*", "", raw) # drop <think>...</think> reasoning blocks
  match <- regmatches(txt, regexpr("(?s)\\{.*\\}", txt, perl = TRUE))
  if (length(match) == 1L) {
    txt <- match
  }
  parsed <- jsonlite::fromJSON(txt, simplifyDataFrame = FALSE)
  list(
    summary = if (is.null(parsed$summary)) list() else parsed$summary,
    conclusions = if (is.null(parsed$conclusions)) list() else parsed$conclusions
  )
}

#' Ask an LLM to tell the story of the decorated outputs
#'
#' Sends the deck's tables to the chosen LLM provider and returns a structured
#' narrative: a `summary` section (for the front of the deck) and a
#' `conclusions` section (for the end). Each section is a list of slides, and
#' each slide has a `layout`, a `title` and a character vector of `bullets`.
#'
#' @param outputs A named `list` of decorated outputs (see [decorate_outputs()]).
#' @param allowed_layouts Character vector of permitted layouts. Any layout the
#'   model returns outside this set is clamped to `"Title and Content"`.
#' @param platform,base_url,api_key,model Passed to [get_ellmer_chat()] to build
#'   the chat connection.
#' @param max_slides Integer cap on slides per section.
#'
#' @return A `list` with two elements, `summary` and `conclusions`, each a list
#'   of slides (`list(layout, title, bullets)`).
#'
#' @export
get_ai_story <- function(outputs,
                         allowed_layouts,
                         platform = "deepseek",
                         base_url = "https://api.deepseek.com",
                         api_key = get_deepseek_key(),
                         model = "deepseek-chat",
                         max_slides = 4L) {
  chat <- get_ellmer_chat(platform, base_url, api_key, model)

  slide_type <- ellmer::type_object(
    layout = ellmer::type_enum(
      allowed_layouts,
      "The slide layout to use; must be one of the allowed layouts."
    ),
    title = ellmer::type_string("A short slide title."),
    bullets = ellmer::type_array(
      ellmer::type_string("A single concise bullet point."),
      "The bullet points shown on the slide body."
    )
  )
  story_type <- ellmer::type_object(
    summary = ellmer::type_array(
      slide_type,
      "Slides that open the deck with the key take-aways."
    ),
    conclusions = ellmer::type_array(
      slide_type,
      "Slides that close the deck with the main conclusions."
    )
  )

  prompt <- build_story_prompt(outputs, allowed_layouts, max_slides)

  # Prefer the provider's native structured output. Not every provider supports
  # it (e.g. DeepSeek returns HTTP 400 for the request `ellmer` emits), so fall
  # back to plain-text JSON mode and parse the response ourselves.
  story <- tryCatch(
    chat$chat_structured(prompt, type = story_type),
    error = function(e) story_via_json(chat, prompt, allowed_layouts)
  )

  # Coerce every slide into a clean `list(layout, title, bullets)` regardless of
  # which path produced it, clamping any layout the model invented back into the
  # allowed set so `add_story_slides()` can always find a matching layout.
  clamp <- function(slides) {
    if (is.null(slides)) {
      return(list())
    }
    lapply(slides, function(s) {
      layout <- if (is.null(s$layout)) "" else as.character(s$layout)[1]
      if (!(layout %in% allowed_layouts)) {
        layout <- "Title and Content"
      }
      list(
        layout = layout,
        title = if (is.null(s$title)) "" else as.character(s$title)[1],
        bullets = if (is.null(s$bullets)) character(0) else as.character(unlist(s$bullets))
      )
    })
  }

  # Drop slides the model left empty (no title and no bullets) so the deck has
  # no blank inserts.
  drop_empty <- function(slides) {
    Filter(function(s) nzchar(s$title) || length(s$bullets) > 0, slides)
  }

  list(
    summary = drop_empty(clamp(story$summary)),
    conclusions = drop_empty(clamp(story$conclusions))
  )
}

#' Insert a single story slide into a deck
#'
#' Adds one slide (title + optional bullets) on the requested layout. If the
#' layout has no body placeholder (e.g. `"Title Only"`) but the slide carries
#' bullets, the layout is coerced to `"Title and Content"` so no content is
#' dropped.
#'
#' @param ppt An `officer::rpptx` object.
#' @param slide A single slide definition (`list(layout, title, bullets)`).
#' @param layouts A `data.frame` from [officer::layout_summary()] mapping each
#'   layout to its master.
#'
#' @return The modified `officer::rpptx` object (slide appended at the end).
#'
#' @noRd
add_one_story_slide <- function(ppt, slide, layouts) {
  layout <- slide$layout
  bullets <- if (is.null(slide$bullets)) character(0) else slide$bullets

  # A layout with no body placeholder cannot hold bullets: promote to a content
  # layout so the narrative survives.
  has_body <- function(lay) {
    props <- officer::layout_properties(ppt, layout = lay)
    any(props$type == "body")
  }
  if (length(bullets) > 0 && !has_body(layout) && "Title and Content" %in% layouts$layout) {
    layout <- "Title and Content"
  }

  master <- layouts$master[match(layout, layouts$layout)][1]
  ppt <- officer::add_slide(ppt, layout = layout, master = master)

  if (!is.null(slide$title) && nzchar(slide$title)) {
    ppt <- officer::ph_with(
      ppt,
      value = slide$title,
      location = officer::ph_location_type(type = "title")
    )
  }
  if (length(bullets) > 0 && has_body(layout)) {
    ppt <- officer::ph_with(
      ppt,
      value = officer::unordered_list(
        str_list = bullets,
        level_list = rep(1L, length(bullets))
      ),
      location = officer::ph_location_type(type = "body")
    )
  }
  ppt
}

#' Insert AI story slides into an open deck
#'
#' Inserts the `summary` slides at the front of the deck (in order) and the
#' `conclusions` slides at the end. This is pure `officer` work with no network
#' access, so it can be unit-tested with a hand-written `story`.
#'
#' @param ppt An `officer::rpptx` object holding the generated content deck.
#' @param story A story `list` with `summary` and `conclusions` elements, each a
#'   list of slides (see [get_ai_story()]).
#'
#' @return The modified `officer::rpptx` object.
#'
#' @export
add_story_slides <- function(ppt, story) {
  layouts <- officer::layout_summary(ppt)

  # Conclusions first: appended to the end, where they stay.
  conclusions <- if (is.null(story$conclusions)) list() else story$conclusions
  for (slide in conclusions) {
    ppt <- add_one_story_slide(ppt, slide, layouts)
  }

  # Summary next: each new slide is appended at the end, then relocated to its
  # target position at the front. Moving them front-to-back in order reproduces
  # the intended summary order ahead of all content slides.
  summary <- if (is.null(story$summary)) list() else story$summary
  for (j in seq_along(summary)) {
    ppt <- add_one_story_slide(ppt, summary[[j]], layouts)
    ppt <- officer::move_slide(ppt, index = length(ppt), to = j)
  }

  ppt
}

#' Add an AI-generated story to a generated deck
#'
#' Post-processes an already-generated `.pptx`: loads it, asks an LLM to tell the
#' story of the decorated outputs (see [get_ai_story()]), and inserts the
#' narrative as real content slides -- a summary section at the front and a
#' conclusions section at the end -- then writes the deck back out.
#'
#' Unlike [get_ai_notes()], which hides the LLM response in speaker notes, this
#' produces slides that are visible in presentation mode.
#'
#' @param outputs A named `list` of decorated outputs (see [decorate_outputs()]),
#'   used as the data the story is told from.
#' @param infile Path to the generated `.pptx` to read.
#' @param outfile Path to write the augmented deck to. Defaults to `infile`
#'   (overwrite in place).
#' @param platform,base_url,api_key,model Passed to [get_ellmer_chat()].
#' @param max_slides Integer cap on slides per section.
#'
#' @return Invisibly, the path written (`outfile`).
#'
#' @export
add_ai_story <- function(outputs,
                         infile,
                         outfile = infile,
                         platform = "deepseek",
                         base_url = "https://api.deepseek.com",
                         api_key = get_deepseek_key(),
                         model = "deepseek-chat",
                         max_slides = 4L) {
  assert_that(is.list(outputs), msg = "`outputs` must be a list of decorated outputs.")
  assert_that(
    is.string(infile) && file.exists(infile),
    msg = "`infile` must be the path to an existing .pptx file."
  )

  ppt <- officer::read_pptx(infile)
  allowed_layouts <- story_layout_choices(ppt)
  story <- get_ai_story(
    outputs,
    allowed_layouts = allowed_layouts,
    platform = platform,
    base_url = base_url,
    api_key = api_key,
    model = model,
    max_slides = max_slides
  )
  ppt <- add_story_slides(ppt, story)
  print(ppt, target = outfile)

  invisible(outfile)
}

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

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

#' decorate generic
#' @param x object to decorate
#' @param ... additional arguments passed to methods
#' @export
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 method for tbl_roche_summary (NEST 2 gtsummary subclass)
#'
#' Handles objects whose class vector is set to just \code{"tbl_roche_summary"}
#' (losing the full gtsummary hierarchy) as well as those with the full
#' \code{c("tbl_roche_summary", "tbl_summary", "gtsummary")} hierarchy.
#'
#' @param x tbl_roche_summary object to decorate
#' @param ... arguments passed to \code{decorate.gtsummary}
#' @method decorate tbl_roche_summary
#' @export
decorate.tbl_roche_summary <- function(x, ...) {
  # gtsummary v2 guards its functions with check_class(x, "gtsummary").
  # When the user sets class(x) <- "tbl_roche_summary" (replacing the full
  # hierarchy), "gtsummary" is absent and those checks fail.  Restore the
  # standard hierarchy before delegating.
  if (!inherits(x, "gtsummary")) {
    class(x) <- c(class(x), "tbl_summary", "gtsummary")
  }
  decorate.gtsummary(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 metadata Named `list` (or `NULL`) of token values used to substitute
#'   `{token}` placeholders in `titles`/`footnotes`. See [apply_tokens()].
#' @param ... Additional arguments passed to the decoration function.
#' @return No return value, called for side effects
#' @method decorate VTableTree
#' @export
decorate.VTableTree <- function(x, titles = "", footnotes = "", paper = "P8", for_test = FALSE, metadata = NULL, ...) {
  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 <- apply_tokens(titles, metadata)
  main_title(x) <- glued_title

  git_fn <- git_footnote(for_test)
  glued_footnotes <- apply_tokens(c(footnotes, git_fn), metadata)
  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 metadata Named `list` (or `NULL`) of token values used to substitute
#'   `{token}` placeholders in `titles`/`footnotes`. See [apply_tokens()].
#' @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, metadata = NULL, ...) {
  glued_title <- apply_tokens(titles, metadata)
  # main_title(x) <- glued_title

  git_fn <- git_footnote(for_test)
  glued_footnotes <- apply_tokens(c(footnotes, git_fn), metadata)
  # 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"
  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 metadata Named `list` (or `NULL`) of token values used to substitute
#'   `{token}` placeholders in `titles`/`footnotes`. See [apply_tokens()].
#' @param ... Additional arguments. not used.
#' @return No return value, called for side effects
#' @method decorate listing_df
#' @export
decorate.listing_df <- function(x, titles = "", footnotes = "", paper = "P8", for_test = FALSE, metadata = NULL, ...) {
  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 <- apply_tokens(titles, metadata)
  main_title(x) <- glued_title

  git_fn <- git_footnote(for_test)
  glued_footnotes <- apply_tokens(c(footnotes, git_fn), metadata)
  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 metadata Named `list` (or `NULL`) of token values used to substitute
#'   `{token}` placeholders in `titles`/`footnotes`. See [apply_tokens()].
#' @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, metadata = NULL, ...) {
    size <- fs(paper)
    grob <- tern::decorate_grob(
      grob = x,
      titles = apply_tokens(titles, metadata),
      footnotes = c(apply_tokens(footnotes, metadata), 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 metadata Named `list` (or `NULL`) of token values used to substitute
#'   `{token}` placeholders in `titles`/`footnotes`. See [apply_tokens()].
#' @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.#'
#' @method decorate gtsummary
#' @export
decorate.gtsummary <-
  function(x, titles = "", footnotes = "", paper = "L11", for_test = FALSE, metadata = NULL, ...) {
    size <- fs(paper)
    glued_title <- apply_tokens(titles, metadata)
    x <- x |> modify_caption(caption = "")
    structure(
      .Data = x,
      titles = glued_title,
      footnotes = footnotes,
      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 metadata Named `list` (or `NULL`) of token values used to substitute
#'   `{token}` placeholders in `titles`/`footnotes`. See [apply_tokens()].
#' @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, metadata = NULL, ...) {
    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 = apply_tokens(titles, metadata),
      footnotes = c(apply_tokens(footnotes, metadata), 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 (inherits(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, metadata = spec)
    } else if ("grob" %in% class(output)) {
      decorate.grob(output, metadata = spec)
    } 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,
          metadata = spec
        ),
        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)
  }
}

#' 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_FAS", "gt_t_dm_slide_FAS")) %>%
#'   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
  })
}

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

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

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") {
  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
    )
  } else if (platform == "anthropic") {
    if (is.null(api_key) || !nzchar(api_key)) {
      api_key <- Sys.getenv("ANTHROPIC_API_KEY")
    }
    chat <- ellmer::chat_anthropic(
      system_prompt = get_system_prompt(),
      api_key = api_key,
      model = model
    )
  }

  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
}

#' 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
#' @param footer_font_size Font size of the table footer, defaults to `body_font_size`
#' @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,
                              footer_font_size = body_font_size) {
  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") %>%
    fontsize(size = footer_font_size, part = "footer") %>%
    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,
                            footer_font_size = body_font_size, ...) {
  ft %>%
    theme_booktabs() %>%
    fontsize(size = body_font_size, part = "body") %>%
    fontsize(size = header_font_size, part = "header") %>%
    fontsize(size = footer_font_size, part = "footer") %>%
    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))
}

#' Wrap a table formatter so it applies fixed font sizes
#'
#' @description
#' Returns a new table-format function that behaves like `table_format` but with
#' the supplied font sizes injected. This is the generic mechanism used by
#' [generate_slides()] to honor per-slide `font_size` settings declared in the
#' spec: a single `table_format` symbol can carry body/header/footer sizes.
#'
#' Sizes are only forwarded to arguments the underlying formatter actually
#' declares. A formatter with an explicit `body_font_size`/`header_font_size`/
#' `footer_font_size` argument (or a `...`) receives the corresponding size;
#' sizes a formatter cannot accept are dropped rather than raising an
#' "unused argument" error. When no sizes are supplied the original formatter is
#' returned unchanged.
#'
#' @param table_format A function taking a flextable as its first argument and
#'   returning a flextable (e.g. [autoslider_format()], [black_format_tb()]).
#' @param body_font_size,header_font_size,footer_font_size Point sizes. `NULL`
#'   (the default) leaves that part to the underlying formatter default.
#'
#' @return A function `function(ft, ...)` returning a styled flextable.
#' @export
#'
#' @examples
#' small <- with_font_sizes(black_format_tb, body_font_size = 6, header_font_size = 6)
#' ft <- flextable::flextable(head(mtcars))
#' small(ft)
with_font_sizes <- function(table_format,
                            body_font_size = NULL,
                            header_font_size = NULL,
                            footer_font_size = NULL) {
  force(table_format)
  sizes <- Filter(Negate(is.null), list(
    body_font_size = body_font_size,
    header_font_size = header_font_size,
    footer_font_size = footer_font_size
  ))
  if (length(sizes) == 0) {
    return(table_format)
  }

  function(ft, ...) {
    fmls <- formalArgs(table_format)
    keep <- if (is.null(fmls) || "..." %in% fmls) {
      sizes
    } else {
      sizes[names(sizes) %in% fmls]
    }
    do.call(table_format, c(list(ft = ft), keep))
  }
}

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

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

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

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

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

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

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

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

#' Listing of Vital Signs: Safety-Evaluable Patients
#'
#' This function generates a listing with vital signs of patients.
#' It creates various columns such as patient identifier, age/sex/race, visit,
#' and calculates the range of several vital signs. The output listing includes labels for each column and a main title.
#'
#' @param adsl A dataframe representing the `ADSL` data.
#' Used to propagate filters to `ADVS`
#' @param advs A dataframe representing the ADVS data.
#' @param trt_var Character scalar or `NULL`. `"TRT01A"` by default. Specifies which variable,
#' if any, should be included as the treatment arm.
#'
#' @return A listing object of vital signs of patients
#'
#' @details
#' The function first validates whether the required columns are present in the ADVS dataframe.
#' Then, various calculations and transformations are performed to create additional columns.
#' Finally, the data is formatted into a listing with appropriate column labels.
#'
#' @seealso
#' \href{https://insightsengineering.github.io/tlg-catalog/stable/listings/vital-signs/vsl01.html}{Vital signs Listing}
#'
#' @export
#'
#' @examples
#' require(dplyr)
#' require(rlistings)
#' adsl <- eg_adsl
#' advs <- eg_advs %>% filter(SUBJID %in% c("id-236", "id-65", "id-93"))
#'
#' # Default usage
#' l_vs_slide(adsl = adsl, advs = advs, trt_var = "TRT01A")
#'
#' # Custom treatment variable
#' l_vs_slide(adsl = adsl, advs = advs, trt_var = NULL)
#'
l_vs_slide <- function(adsl, advs, trt_var = "TRT01A") {
  variables <- c("SITEID", "SUBJID", "AGE", "SEX", "RACE", trt_var)
  lapply(variables, function(x) {
    assert_that(has_name(advs, x))
  })

  # Optional treatment column ----
  trt_cols <- if (!is.null(trt_var)) trt_var else character(0)

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

  get_param_unit_range <- function(dataset) {
    u_rng <- lapply(unique(dataset$PARAMCD), function(p) {
      dat <- dataset |> filter(PARAMCD == p)
      list(
        unit = unique(dat$AVALU),
        range = paste0(unique(dat$ANRLO), "-", unique(dat$ANRHI))
      )
    })
    names(u_rng) <- unique(dataset$PARAMCD)
    u_rng
  }

  vs_u_rng <- get_param_unit_range(advs)

  advs_f <- advs |>
    semi_join(adsl_f, by = c("STUDYID", "USUBJID"))

  advs_sub <- advs_f |>
    filter(!is.na(AVAL) & SAFFL == "Y" & ONTRTFL == "Y" & !is.na(VSSEQ)) |>
    mutate(
      CRTNPT = paste(SITEID, sub("^.*-([[:alnum:]]+)$", "\\1", SUBJID), sep = "/"),
      AGSXRC = paste(AGE, SEX, RACE, sep = "/"),
      AVAL = format(round(AVAL, 2), nsmall = 2),
      AVAL_ANRIND = ifelse(ANRIND %in% c("NORMAL", ""), AVAL, paste(AVAL, substr(ANRIND, 1, 1), sep = "/")),
      CHG = format(round(CHG, 2), nsmall = 2)
    )

  id_cols <- c("SUBJID", "CRTNPT", "AGSXRC", trt_cols, "ADY", "AVISIT", "ADTM")

  anl_vs <- advs_sub |>
    select(all_of(id_cols), PARAMCD, AVAL_ANRIND, CHG) |>
    tidyr::pivot_wider(
      id_cols = all_of(id_cols),
      names_from = PARAMCD,
      values_from = c(AVAL_ANRIND, CHG)
    )

  out <- anl_vs |>
    select(
      all_of(c("CRTNPT", "AGSXRC", trt_cols, "AVISIT", "ADY")),
      AVAL_ANRIND_WEIGHT, AVAL_ANRIND_TEMP, AVAL_ANRIND_DIABP,
      AVAL_ANRIND_SYSBP, AVAL_ANRIND_PULSE, AVAL_ANRIND_RESP
    )

  labels <- list(
    CRTNPT = "Center/Subject ID",
    AGSXRC = "Age/Sex/Race",
    AVISIT = "Visit",
    ADY = "Study\nDay",
    AVAL_ANRIND_WEIGHT = paste0(
      "Weight\nResult\n(",
      vs_u_rng$WEIGHT$unit,
      ");\nRange:(",
      vs_u_rng$WEIGHT$range,
      ")"
    ),
    AVAL_ANRIND_TEMP = paste0(
      "Temperature Result\n(",
      vs_u_rng$TEMP$unit,
      ");\nRange:(",
      vs_u_rng$TEMP$range,
      ")"
    ),
    AVAL_ANRIND_DIABP = paste0(
      "Diastolic Blood\nPressure,\nSitting\nResult\n(",
      vs_u_rng$DIABP$unit,
      ");\nRange:(",
      vs_u_rng$DIABP$range,
      ")"
    ),
    AVAL_ANRIND_SYSBP = paste0(
      "Systolic Blood\nPressure,\nSitting\n(",
      vs_u_rng$SYSBP$unit,
      ");\nRange:(",
      vs_u_rng$SYSBP$range,
      ")"
    ),
    AVAL_ANRIND_PULSE = paste0(
      "Pulse Rate Result\n(",
      vs_u_rng$PULSE$unit,
      ");\nRange:(",
      vs_u_rng$PULSE$range,
      ")"
    ),
    AVAL_ANRIND_RESP = paste0(
      "Respiratory Rate\nResult\n(",
      vs_u_rng$RESP$unit,
      ");\nRange:(",
      vs_u_rng$RESP$range,
      ")"
    )
  )
  if (!is.null(trt_var)) {
    labels[[trt_var]] <- "Treatment"
  }

  out <- do.call(formatters::var_relabel, c(list(out), labels))

  lsting <- as_listing(
    out,
    key_cols = c(trt_cols, "CRTNPT", "AGSXRC", "AVISIT"),
    disp_cols = names(out),
    main_title = "Listing of Vital Signs: Safety-Evaluable Patients",
    main_footer = paste(
      "Baseline is the patient's last observation prior to initiation of study drug.",
      "Abnormalities are flagged as high (H) or low (L) if outside the Roche standard reference range."
    )
  )

  lsting
}

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

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

#' Substitute metadata tokens in text
#'
#' Replaces `glue`-style `{token}` placeholders in a character vector with values
#' taken from a user-controlled `metadata` list. This lets study-level information
#' (e.g. study number, data cut-off date) be injected into slide titles, footnotes
#' and placeholder slides without editing the deck or the spec text directly.
#'
#' Token values are looked up first in `metadata`, then in the calling environment
#' (preserving the existing `glue` behavior used across `decorate` methods).
#' A `{token}` that resolves to neither raises an informative error, so typos are
#' caught early rather than silently producing a broken slide.
#'
#' @param text `character` vector possibly containing `{token}` placeholders.
#' @param metadata Named `list` (or `NULL`) supplying token values. Typically the
#'   spec entry produced by [read_spec()], into which the `metadata` argument has
#'   already been merged.
#'
#' @return A length-one `character` (`glue`) value with tokens substituted and the
#'   input collapsed by newlines, matching the previous `glue::glue()` behavior.
#'
#' @export
#'
#' @examples
#' apply_tokens("Demographics - Study {study}", list(study = "BP12345"))
#' apply_tokens(c("Line 1 {study}", "Line 2"), list(study = "BP12345"))
apply_tokens <- function(text, metadata = NULL) {
  checkmate::assert_character(text, null.ok = FALSE)
  checkmate::assert_list(metadata, null.ok = TRUE)

  if (length(text) == 0) {
    return(text)
  }

  data <- if (is.null(metadata)) list() else as.list(metadata)
  template <- paste(text, collapse = "\n")

  tryCatch(
    glue::glue_data(.x = data, template, .envir = parent.frame()),
    error = function(e) {
      stop(
        "Failed to substitute metadata tokens in text: ", template, "\n",
        "Ensure every {token} has a matching name in `metadata` ",
        "(or the calling environment). Original error: ", conditionMessage(e),
        call. = FALSE
      )
    }
  )
}

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

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

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

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

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

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

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		#' Listing of Vital Signs: Safety-Evaluable Patients
2		#'
3		#' This function generates a listing with vital signs of patients.
4		#' It creates various columns such as patient identifier, age/sex/race, visit,
5		#' and calculates the range of several vital signs. The output listing includes labels for each column and a main title.
6		#'
7		#' @param adsl A dataframe representing the `ADSL` data.
8		#' Used to propagate filters to `ADVS`
9		#' @param advs A dataframe representing the ADVS data.
10		#' @param trt_var Character scalar or `NULL`. `"TRT01A"` by default. Specifies which variable,
11		#' if any, should be included as the treatment arm.
12		#'
13		#' @return A listing object of vital signs of patients
14		#'
15		#' @details
16		#' The function first validates whether the required columns are present in the ADVS dataframe.
17		#' Then, various calculations and transformations are performed to create additional columns.
18		#' Finally, the data is formatted into a listing with appropriate column labels.
19		#'
20		#' @seealso
21		#' \href{https://insightsengineering.github.io/tlg-catalog/stable/listings/vital-signs/vsl01.html}{Vital signs Listing}
22		#'
23		#' @export
24		#'
25		#' @examples
26		#' require(dplyr)
27		#' require(rlistings)
28		#' adsl <- eg_adsl
29		#' advs <- eg_advs %>% filter(SUBJID %in% c("id-236", "id-65", "id-93"))
30		#'
31		#' # Default usage
32		#' l_vs_slide(adsl = adsl, advs = advs, trt_var = "TRT01A")
33		#'
34		#' # Custom treatment variable
35		#' l_vs_slide(adsl = adsl, advs = advs, trt_var = NULL)
36		#'
37		l_vs_slide <- function(adsl, advs, trt_var = "TRT01A") {
38	6x	variables <- c("SITEID", "SUBJID", "AGE", "SEX", "RACE", trt_var)
39	6x	lapply(variables, function(x) {
40	35x	assert_that(has_name(advs, x))
41		})
42
43		# Optional treatment column ----
44	6x	trt_cols <- if (!is.null(trt_var)) trt_var else character(0)
45
46		# Preprocess data ----
47	6x	adsl_f <- adsl \|>
48	6x	df_explicit_na()
49
50	6x	get_param_unit_range <- function(dataset) {
51	6x	u_rng <- lapply(unique(dataset$PARAMCD), function(p) {
52	36x	dat <- dataset \|> filter(PARAMCD == p)
53	36x	list(
54	36x	unit = unique(dat$AVALU),
55	36x	range = paste0(unique(dat$ANRLO), "-", unique(dat$ANRHI))
56		)
57		})
58	6x	names(u_rng) <- unique(dataset$PARAMCD)
59	6x	u_rng
60		}
61
62	6x	vs_u_rng <- get_param_unit_range(advs)
63
64	6x	advs_f <- advs \|>
65	6x	semi_join(adsl_f, by = c("STUDYID", "USUBJID"))
66
67	6x	advs_sub <- advs_f \|>
68	6x	filter(!is.na(AVAL) & SAFFL == "Y" & ONTRTFL == "Y" & !is.na(VSSEQ)) \|>
69	6x	mutate(
70	6x	CRTNPT = paste(SITEID, sub("^.*-([[:alnum:]]+)$", "\\1", SUBJID), sep = "/"),
71	6x	AGSXRC = paste(AGE, SEX, RACE, sep = "/"),
72	6x	AVAL = format(round(AVAL, 2), nsmall = 2),
73	6x	AVAL_ANRIND = ifelse(ANRIND %in% c("NORMAL", ""), AVAL, paste(AVAL, substr(ANRIND, 1, 1), sep = "/")),
74	6x	CHG = format(round(CHG, 2), nsmall = 2)
75		)
76
77	6x	id_cols <- c("SUBJID", "CRTNPT", "AGSXRC", trt_cols, "ADY", "AVISIT", "ADTM")
78
79	6x	anl_vs <- advs_sub \|>
80	6x	select(all_of(id_cols), PARAMCD, AVAL_ANRIND, CHG) \|>
81	6x	tidyr::pivot_wider(
82	6x	id_cols = all_of(id_cols),
83	6x	names_from = PARAMCD,
84	6x	values_from = c(AVAL_ANRIND, CHG)
85		)
86
87	6x	out <- anl_vs \|>
88	6x	select(
89	6x	all_of(c("CRTNPT", "AGSXRC", trt_cols, "AVISIT", "ADY")),
90	6x	AVAL_ANRIND_WEIGHT, AVAL_ANRIND_TEMP, AVAL_ANRIND_DIABP,
91	6x	AVAL_ANRIND_SYSBP, AVAL_ANRIND_PULSE, AVAL_ANRIND_RESP
92		)
93
94	6x	labels <- list(
95	6x	CRTNPT = "Center/Subject ID",
96	6x	AGSXRC = "Age/Sex/Race",
97	6x	AVISIT = "Visit",
98	6x	ADY = "Study\nDay",
99	6x	AVAL_ANRIND_WEIGHT = paste0(
100	6x	"Weight\nResult\n(",
101	6x	vs_u_rng$WEIGHT$unit,
102	6x	");\nRange:(",
103	6x	vs_u_rng$WEIGHT$range,
104		")"
105		),
106	6x	AVAL_ANRIND_TEMP = paste0(
107	6x	"Temperature Result\n(",
108	6x	vs_u_rng$TEMP$unit,
109	6x	");\nRange:(",
110	6x	vs_u_rng$TEMP$range,
111		")"
112		),
113	6x	AVAL_ANRIND_DIABP = paste0(
114	6x	"Diastolic Blood\nPressure,\nSitting\nResult\n(",
115	6x	vs_u_rng$DIABP$unit,
116	6x	");\nRange:(",
117	6x	vs_u_rng$DIABP$range,
118		")"
119		),
120	6x	AVAL_ANRIND_SYSBP = paste0(
121	6x	"Systolic Blood\nPressure,\nSitting\n(",
122	6x	vs_u_rng$SYSBP$unit,
123	6x	");\nRange:(",
124	6x	vs_u_rng$SYSBP$range,
125		")"
126		),
127	6x	AVAL_ANRIND_PULSE = paste0(
128	6x	"Pulse Rate Result\n(",
129	6x	vs_u_rng$PULSE$unit,
130	6x	");\nRange:(",
131	6x	vs_u_rng$PULSE$range,
132		")"
133		),
134	6x	AVAL_ANRIND_RESP = paste0(
135	6x	"Respiratory Rate\nResult\n(",
136	6x	vs_u_rng$RESP$unit,
137	6x	");\nRange:(",
138	6x	vs_u_rng$RESP$range,
139		")"
140		)
141		)
142	6x	if (!is.null(trt_var)) {
143	5x	labels[[trt_var]] <- "Treatment"
144		}
145
146	6x	out <- do.call(formatters::var_relabel, c(list(out), labels))
147
148	6x	lsting <- as_listing(
149	6x	out,
150	6x	key_cols = c(trt_cols, "CRTNPT", "AGSXRC", "AVISIT"),
151	6x	disp_cols = names(out),
152	6x	main_title = "Listing of Vital Signs: Safety-Evaluable Patients",
153	6x	main_footer = paste(
154	6x	"Baseline is the patient's last observation prior to initiation of study drug.",
155	6x	"Abnormalities are flagged as high (H) or low (L) if outside the Roche standard reference range."
156		)
157		)
158
159	6x	lsting
160		}

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 Study-level token values merged into every spec entry. Either
7		#' a named `list` (or `NULL`), or a `character(1)` path to a yaml metadata file
8		#' (see [read_metadata()] and the example at
9		#' `system.file("metadata.yml", package = "autoslider.core")`), which is read
10		#' into a list for you. Its elements can be referenced as `{token}`
11		#' placeholders in the `titles` and `footnotes` fields of the spec and are
12		#' substituted during decoration (see [apply_tokens()]). For example, with
13		#' `metadata = list(study = "BP12345")` a spec title of
14		#' `"Demographics - Study {study}"` becomes `"Demographics - Study BP12345"`.
15		#'
16		#' @return
17		#' An object of class `spec` which is a `list` where each element corresponds
18		#' to one output, e.g. `t_dm_IT`.
19		#'
20		#' @author
21		#' - Liming Li (`Lil128`)
22		#' - Thomas Neitmann (`neitmant`)
23		#' - Joe Zhu
24		#'
25		#' @export
26		#'
27		#' @examples
28		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
29		#'
30		#' ## Take a look at the 'raw' content of the spec file
31		#' cat(readLines(spec_file)[1:24], sep = "\n")
32		#'
33		#' ## This is how it looks once read into R
34		#' spec <- read_spec(spec_file)
35		#' spec[1:3]
36		#'
37		#' ## Supply study metadata so that `{token}` placeholders in titles/footnotes
38		#' ## are filled in during decoration (e.g. a title of "... Study {study}").
39		#' spec <- read_spec(spec_file, metadata = list(study = "BP12345"))
40		#'
41		#' ## The same metadata can be kept in a yaml file and read via `read_spec()`
42		#' metadata_file <- system.file("metadata.yml", package = "autoslider.core")
43		#' spec <- read_spec(spec_file, metadata = metadata_file)
44		#'
45		read_spec <- function(spec_file = "spec.yml",
46		metadata = NULL) {
47	9x	if (is.character(metadata)) {
48	1x	metadata <- read_metadata(metadata)
49		}
50	9x	spec <- yaml::read_yaml(spec_file, eval.expr = TRUE)
51	9x	spec_obj <- check_and_flattern_suffix(spec, metadata = metadata)
52	9x	as_spec(spec_obj)
53		}
54
55		#' Read a study metadata file
56		#'
57		#' Reads a yaml metadata file into a named `list` of study-level values suitable
58		#' for the `metadata` argument of [read_spec()] and [apply_tokens()]. Each
59		#' top-level key in the file becomes a `{token}` that can be referenced in the
60		#' `titles` and `footnotes` fields of a spec. An example file is shipped at
61		#' `system.file("metadata.yml", package = "autoslider.core")`.
62		#'
63		#' @param metadata_file `character(1)`. Path to a yaml metadata file, i.e. a flat
64		#' mapping of `key: value` pairs.
65		#'
66		#' @return A named `list` of metadata values.
67		#'
68		#' @seealso [read_spec()], [apply_tokens()]
69		#'
70		#' @export
71		#'
72		#' @examples
73		#' metadata_file <- system.file("metadata.yml", package = "autoslider.core")
74		#'
75		#' ## Take a look at the 'raw' content of the metadata file
76		#' cat(readLines(metadata_file), sep = "\n")
77		#'
78		#' ## Read it into a named list of token values
79		#' read_metadata(metadata_file)
80		read_metadata <- function(metadata_file = "metadata.yml") {
81	4x	checkmate::assert_file_exists(metadata_file, access = "r")
82	3x	metadata <- yaml::read_yaml(metadata_file, eval.expr = TRUE)
83	3x	checkmate::assert_list(metadata, names = "named", .var.name = "metadata file contents")
84	3x	metadata
85		}
86
87		#' Flatten spec entries with multiple suffixes
88		#'
89		#' @description
90		#' Checks each entry of a raw spec (as read from a yaml file). When an entry's
91		#' `suffix` field is a list/vector of more than one value, the entry is
92		#' flattened into several entries that share the same `program`, `titles`,
93		#' `footnotes`, `args`, etc., differing only in their (scalar) `suffix`.
94		#' Optional `metadata` is appended to each resulting entry.
95		#'
96		#' @param spec A `list` of raw spec entries as returned by [yaml::read_yaml()].
97		#' @param metadata Metadata of study, appended to each flattened entry.
98		#'
99		#' @return
100		#' A flat `list` of spec entries, each with a single `suffix` value.
101		#'
102		#' @noRd
103		check_and_flattern_suffix <- function(spec, metadata = NULL) {
104	9x	ret <- lapply(spec, function(s) {
105	419x	lapply(s$suffix, function(su) {
106	443x	entry <- s
107	443x	entry$suffix <- su
108	443x	c(entry, metadata)
109		})
110		})
111	9x	unlist(ret, recursive = FALSE)
112		}
113
114		#' validate spec file
115		#' @description not implemented yet
116		#' @param spec specification
117		#' @noRd
118		validate_spec <- function(spec) {
119	!	message <- NULL
120	!	if (is.null(spec$dataset)) {
121	!	message <- c(message, "Spec must not assign dataset argument!")
122		}
123	!	if (is.null(spec$func)) {
124	!	message <- c(message, "Spec must include func argument!")
125		}
126	!	if (is.null(spec$outpath)) {
127	!	message <- c(message, "Spec must include outpath argument!")
128		}
129		}
130
131		#' Filter a spec object
132		#'
133		#' @param spec A `spec` object as returned by `read_spec()`
134		#' @param filter_expr A `logical` expression indicating outputs to keep
135		#' @param verbose Should a message about the number of outputs matching
136		#' `filter_spec` be printed? Defaults to `TRUE`.
137		#'
138		#' @return
139		#' A `spec` object containing only the outputs matching `filter_expr`
140		#'
141		#' @author Thomas Neitmann (`neitmant`)
142		#'
143		#' @export
144		#'
145		#' @examples
146		#' library(dplyr)
147		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
148		#' spec <- spec_file %>% read_spec()
149		#'
150		#' ## Keep only the t_dm_IT output
151		#' filter_spec(spec, output == "t_dm_IT")
152		#'
153		#' ## Same as above but more verbose
154		#' filter_spec(spec, program == "t_dm" && suffix == "IT")
155		#'
156		#' ## Keep all t_ae outputs
157		#' filter_spec(spec, program == "t_ae")
158		#'
159		#' ## Keep all output run on safety population
160		#' filter_spec(spec, "SE" %in% suffix)
161		#'
162		#' ## Keep t_dm_CHN_IT and t_dm_CHN_SE
163		#' filter_spec(spec, program == "t_dm" && suffix %in% c("CHN_IT", "CHN_SE"))
164		#'
165		#' ## Keep all tables
166		#' filter_spec(spec, grepl("^t_", program))
167		#'
168		filter_spec <- function(spec, filter_expr, verbose = TRUE) {
169	6x	if (is.character(substitute(filter_expr))) {
170	!	warn_about_legacy_filtering(filter_expr)
171	!	condition <- bquote(output == .(filter_expr))
172		} else {
173	6x	condition <- substitute(filter_expr)
174		}
175	6x	stopifnot(is_spec(spec), is.language(condition), is.logical(verbose))
176	6x	vars <- all.vars(condition)
177
178	6x	filtered_spec <- Filter(function(output) {
179	278x	assert_exists_in_spec_or_calling_env(vars, output)
180	278x	p <- eval(condition, envir = output)
181	278x	assert_is_valid_filter_result(p)
182	278x	p
183	6x	}, spec)
184
185	6x	if (verbose) {
186	6x	log_number_of_matched_records(spec, filtered_spec, condition)
187		}
188
189	6x	as_spec(filtered_spec)
190		}
191
192		is_spec <- function(x) {
193	6x	"spec" %in% class(x)
194		}
195
196		as_spec <- function(x) {
197	15x	spec <- lapply(x, function(elem) {
198	471x	if (is.null(elem$suffix)) {
199	!	elem$suffix <- ""
200		}
201
202	471x	if (elem$suffix == "") {
203	!	elem$output <- elem$program
204		} else {
205	471x	elem$output <- paste(elem$program, elem$suffix, sep = "_")
206		}
207
208	471x	if (is.null(elem$paper)) {
209	32x	elem$paper <- default_paper_size(elem$program)
210	439x	} else if (elem$paper == "a4r") {
211	!	warn_about_legacy_paper_size("a4r", "L11")
212	!	elem$paper <- "L11"
213	439x	} else if (elem$paper == "a4") {
214	!	warn_about_legacy_paper_size("a4", "P11")
215	!	elem$paper <- "P11"
216		} else {
217	439x	validate_paper_size(elem$paper)
218		}
219
220	471x	elem
221		})
222
223	15x	structure(
224	15x	.Data = spec,
225	15x	names = map_chr(spec, `[[`, "output"),
226	15x	class = union("spec", class(x))
227		)
228		}

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	40x	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	40x	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	40x	ret <- NULL
271		}
272
273	40x	if (for_test == TRUE) {
274	15x	ret <- NULL
275		}
276
277	40x	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	284x	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	16x	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	32x	output_type <- substr(program, 1L, 1L)
326	32x	defaults <- c(l = "L8", t = "P8", g = "L11")
327	32x	if (output_type %in% names(defaults)) {
328	32x	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	8x	fontsize <- as.integer(substr(paper, 2, nchar(paper)))
427	8x	orientation <- substr(paper, 1, 1)
428	8x	list(fontsize = fontsize, orientation = orientation)
429		}
430
431		validate_paper_size <- function(paper) {
432	446x	assert_is_character_scalar(paper)
433	446x	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	443x	fontsize <- as.integer(substr(paper, 2, nchar(paper)))
440	443x	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	18x	ret <- ""
447	18x	if (tools::file_ext(file_path) != "") {
448	!	ret <- file_path
449		} else {
450	18x	file_ext <- ifelse(is_rtable(output) \|\| "dVTableTree" %in% class(output), "out", "pdf")
451	18x	ret <- sprintf("%s.%s", file_path, file_ext)
452		}
453
454	18x	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	37x	result <- build_table(lyt = lyt, df = anl)
504
505	36x	if (!is.null(side_by_side)) {
506	12x	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	12x	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	36x	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	result
567		}
568
569
570		do_call <- function(fun, ...) {
571	624x	args <- list(...)
572	624x	do.call(fun, args[intersect(names(args), formalArgs(fun))])
573		}
574
575		# Null-coalescing helper (base R gains `%\|\|%` only in 4.4.0; package supports 4.1.0)
576	132x	`%\|\|%` <- function(a, b) if (is.null(a)) b else a
577
578
579		#' Build table header, a utility function to help with construct structured header for table layout
580		#' @param anl analysis data object
581		#' @param arm Arm variable for column split
582		#' @param split_by_study, if true, construct structured header with the study ID
583		#' @param side_by_side A logical value indicating whether to display the data side by side.
584		#' @return A `rtables` layout with desired header.
585		#' @export
586		build_table_header <- function(anl,
587		arm,
588		split_by_study,
589		side_by_side) {
590	65x	lyt <- basic_table()
591	65x	if (is.null(side_by_side)) {
592	46x	if (split_by_study) {
593	6x	assert_that(length(unique(anl$STUDYID)) > 1)
594	6x	lyt <- lyt %>%
595	6x	split_cols_by(var = "STUDYID") %>%
596	6x	split_cols_by(var = arm)
597		} else {
598	40x	lyt <- lyt %>%
599	40x	split_cols_by(var = arm) %>%
600	40x	add_overall_col("All Patients")
601		}
602		} else {
603	19x	if (split_by_study) {
604	10x	warning("split_by_study argument will be ignored")
605		}
606	19x	lyt <- lyt %>%
607	19x	split_cols_by(var = "lvl") %>%
608	19x	split_cols_by(var = arm) %>%
609	19x	add_overall_col("All Patients")
610		}
611
612	65x	lyt
613		}
614
615
616		get_version_label_output <- function() {
617	1x	NULL
618		}
619
620
621		strip_NA <- function(input) {
622	21x	input[which(input != "NA")]
623		}

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 font_size Deck-wide default table font sizes, a named `list` with any
18		#' of `body`, `header`, `footer` (point sizes). Per-slide sizes declared in the
19		#' spec (a `font_size:` block on the entry) override these. Applied by wrapping
20		#' the slide's `table_format` via [with_font_sizes()]; see Details.
21		#' @param ... arguments passed to program
22		#' @return No return value, called for side effects
23		#' @details
24		#' ## Per-slide font size
25		#' Each output carries its spec entry as an attribute (set by
26		#' [generate_outputs()]). `generate_slides()` reads two optional keys from it:
27		#' `table_format` (a formatter function) and `font_size` (a named list with
28		#' `body`/`header`/`footer`). The effective formatter for a slide is
29		#' `with_font_sizes(table_format, body, header, footer)`, so font sizes can be
30		#' set per slide directly in the spec, e.g.
31		#' \preformatted{
32		#' t_dm_slide_FAS:
33		#' program: t_dm_slide
34		#' suffix: FAS
35		#' table_format: black_format_tb
36		#' font_size:
37		#' body: 6
38		#' header: 6
39		#' footer: 5
40		#' }
41		#' The `font_size` argument sets deck-wide defaults; per-slide values win.
42		#' @export
43		#' @examplesIf require(filters)
44		#'
45		#' # Example 1. When applying to the whole pipeline
46		#' library(dplyr)
47		#' data <- list(
48		#' adsl = eg_adsl %>% dplyr::mutate(FASFL = SAFFL),
49		#' adae = eg_adae
50		#' )
51		#'
52		#'
53		#' filters::load_filters(
54		#' yaml_file = system.file("filters.yml", package = "autoslider.core"),
55		#' overwrite = TRUE
56		#' )
57		#'
58		#'
59		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
60		#' spec_file %>%
61		#' read_spec() %>%
62		#' filter_spec(program %in% c("t_dm_slide")) %>%
63		#' generate_outputs(datasets = data) %>%
64		#' decorate_outputs() %>%
65		#' generate_slides()
66		#'
67		#' # Example 2. When applying to an rtable object or an rlisting object
68		#' adsl <- eg_adsl
69		#' t_dm_slide(adsl, "TRT01P", c("SEX", "AGE")) %>%
70		#' generate_slides()
71		generate_slides <- function(outputs,
72		outfile = paste0(tempdir(), "/output.pptx"),
73		template = file.path(system.file(package = "autoslider.core"), "theme/basic.pptx"),
74		fig_width = 9, fig_height = 5, t_lpp = 20, t_cpp = 200,
75		l_lpp = 20, l_cpp = 150, fig_editable = FALSE,
76		font_size = NULL, ...) {
77	12x	if (any(c(
78	12x	inherits(outputs, "VTableTree"),
79	12x	inherits(outputs, "listing_df")
80		))) {
81	2x	if (inherits(outputs, "listing_df")) {
82	!	current_title <- main_title(outputs)
83		} else {
84	2x	current_title <- outputs@main_title
85		}
86	2x	outputs <- list(
87	2x	decorate(outputs, titles = current_title, footnotes = "Confidential and for internal use only")
88		)
89	10x	} else if (any(c(
90	10x	inherits(outputs, "data.frame"),
91	10x	inherits(outputs, "ggplot"),
92	10x	inherits(outputs, "gtsummary"),
93	10x	inherits(outputs, "tbl_roche_summary"),
94	10x	inherits(outputs, "dVTableTree"),
95	10x	inherits(outputs, "dlisting"),
96	10x	inherits(outputs, "grob")
97		))) {
98	!	if (inherits(outputs, "ggplot")) {
99	!	current_title <- outputs$labels$title
100	!	if (is.null(current_title)) {
101	!	current_title <- ""
102		}
103	!	outputs <- decorate.ggplot(outputs, titles = current_title)
104	!	} else if (inherits(outputs, "grob")) {
105	!	outputs <- decorate.grob(outputs)
106		} else if (
107	!	(inherits(outputs, "gtsummary") \|\| inherits(outputs, "tbl_roche_summary")) &&
108	!	!inherits(outputs, "dgtsummary")
109		) {
110	!	current_title <- tryCatch(outputs$table_styling$caption, error = function(e) NULL)
111	!	if (is.null(current_title) \|\| !nzchar(current_title)) current_title <- ""
112	!	outputs <- decorate(outputs, titles = current_title)
113		}
114
115	!	outputs <- list(outputs)
116		}
117
118	12x	assert_that(is.list(outputs))
119
120		# ======== generate slides =======#
121		# Arguments forwarded to to_flextable()/table_to_slide(). `table_format` and
122		# `font_size` are managed per-slide below, so they are pulled out of the
123		# forwarded set to avoid clashing with the values we inject.
124	12x	dots <- list(...)
125	12x	fwd <- dots
126	12x	fwd$table_format <- NULL
127
128		# Deck-wide default font sizes. Accept the tidy `font_size = list(...)` form
129		# and, for backwards compatibility, scalar *_font_size passed via `...`.
130	12x	deck_fs <- font_size %\|\|% list()
131	12x	deck_fs$body <- deck_fs$body %\|\|% dots$body_font_size
132	12x	deck_fs$header <- deck_fs$header %\|\|% dots$header_font_size
133	12x	deck_fs$footer <- deck_fs$footer %\|\|% dots$footer_font_size
134	12x	fwd$body_font_size <- NULL
135	12x	fwd$header_font_size <- NULL
136	12x	fwd$footer_font_size <- NULL
137
138		# Merge deck defaults with a slide's own spec `font_size` block (slide wins).
139	12x	slide_fs <- function(x) {
140	42x	sp <- attr(x, "spec")
141	42x	modifyList(deck_fs, (sp$font_size) %\|\|% list())
142		}
143		# Effective formatter for a slide: its spec `table_format` (else the deck-wide
144		# one, else `default_fmt`), wrapped so the resolved font sizes are applied.
145	12x	resolve_format <- function(x, default_fmt) {
146	21x	sp <- attr(x, "spec")
147	21x	fs <- slide_fs(x)
148	21x	base_fmt <- (sp$table_format) %\|\|% dots$table_format %\|\|% default_fmt
149	21x	with_font_sizes(base_fmt, fs$body, fs$header, fs$footer)
150		}
151		# Arguments that belong to `table_to_slide()` (slide placement / decoration) but
152		# are not accepted by `to_flextable()` or its formatter helpers. A spec may set
153		# these (e.g. `layout = "08_TitleAndContent"`, `table_loc = ...`); they must reach
154		# `call_slide()` but must be dropped before `to_flextable()`, otherwise they leak
155		# through the formatter's `...` (e.g. `autoslider_format()`) and error with
156		# "unused argument".
157	12x	slide_only_args <- c("decor", "layout", "table_loc", "usernotes", "footer_font_size")
158	12x	fwd_ft <- fwd[setdiff(names(fwd), slide_only_args)]
159	12x	call_ft <- function(x, more) {
160	22x	do.call(to_flextable, c(list(x = x), more, fwd_ft))
161		}
162	12x	call_slide <- function(content, more) {
163	296x	do.call(table_to_slide, c(list(ppt = ppt, content = content), more, fwd))
164		}
165
166		# set slides layout
167	12x	ppt <- read_pptx(path = template)
168	12x	location_ <- officer::fortify_location(ph_location_fullsize(), doc = ppt)
169	12x	width <- location_$width
170	12x	height <- location_$height
171
172		# add content to slides template
173	12x	for (x in outputs) {
174	26x	if (inherits(x, "dVTableTree") \|\| inherits(x, "VTableTree")) {
175	20x	tf <- resolve_format(x, orange_format)
176	20x	footer_pt <- slide_fs(x)$footer
177	20x	y <- call_ft(x, list(lpp = t_lpp, cpp = t_cpp, table_format = tf))
178	20x	usernotes <- x@usernotes
179	20x	for (tt in y) {
180	22x	call_slide(tt, list(
181	22x	table_loc = center_table_loc(tt$ft, ppt_width = width, ppt_height = height),
182	22x	usernotes = usernotes, footer_font_size = footer_pt
183		))
184		}
185	6x	} else if (inherits(x, "dlisting")) {
186	1x	y <- call_ft(x, list(cpp = l_cpp, lpp = l_lpp))
187	1x	for (tt in y) {
188	272x	call_slide(tt, list(
189	272x	table_loc = center_table_loc(tt$ft, ppt_width = width, ppt_height = height)
190		))
191		}
192	5x	} else if (inherits(x, "data.frame")) { # this is dedicated for small data frames without pagination
193	!	tf <- resolve_format(x, orange_format)
194	!	y <- call_ft(x, list(table_format = tf))
195	!	call_slide(y, list(decor = FALSE))
196	5x	} else if (inherits(x, "dgtsummary")) {
197	1x	tf <- resolve_format(x, autoslider_format)
198	1x	footer_pt <- slide_fs(x)$footer
199	1x	y <- call_ft(x, list(
200	1x	lpp = t_lpp, ppt_height = height, ppt_width = width, table_format = tf
201		))
202	1x	for (tt in y) {
203	2x	call_slide(tt, list(
204	2x	table_loc = center_gts_table_loc(tt$ft, ppt_width = width, ppt_height = height),
205	2x	footer_font_size = footer_pt
206		))
207		}
208	4x	} else if (inherits(x, "gtsummary") \|\| inherits(x, "tbl_roche_summary")) {
209	!	tf <- resolve_format(x, autoslider_format)
210	!	y <- call_ft(x, list(table_format = tf))
211	!	call_slide(y, list(decor = FALSE))
212		} else {
213	4x	if (any(class(x) %in% c("decoratedGrob", "decoratedGrobSet", "ggplot"))) {
214	4x	if (inherits(x, "ggplot")) {
215	!	x <- decorate.ggplot(x)
216		}
217
218	4x	assertthat::assert_that(inherits(x, "decoratedGrob") \|\| inherits(x, "decoratedGrobSet"))
219
220	4x	figure_to_slide(ppt,
221	4x	content = x, fig_width = fig_width, fig_height = fig_height,
222	4x	figure_loc = center_figure_loc(fig_width, fig_height, ppt_width = width, ppt_height = 1.17 * height),
223	4x	fig_editable = fig_editable, ...
224		)
225		} else {
226	!	if (inherits(x, "autoslider_error")) {
227	!	message(x)
228		} else {
229	!	next
230		}
231		}
232		}
233		}
234	11x	print(ppt, target = outfile)
235		}
236
237		#' Generate flextable for preview first page
238		#'
239		#' @param x rtables or data.frame
240		#' @return A flextable or a ggplot object depending to the input.
241		#' @export
242		#' @examples
243		#' # Example 1. preview table
244		#' library(dplyr)
245		#' adsl <- eg_adsl
246		#' t_dm_slide(adsl, "TRT01P", c("SEX", "AGE")) %>% slides_preview()
247		slides_preview <- function(x) {
248	1x	if (inherits(x, "VTableTree")) {
249	1x	ret <- to_flextable(paginate_table(x, lpp = 20)[[1]])
250	!	} else if (inherits(x, "listing_df")) {
251	!	new_colwidth <- formatters::propose_column_widths(x)
252	!	ret <- to_flextable(old_paginate_listing(x, cpp = 150, lpp = 20)[[1]],
253	!	col_width = new_colwidth
254		)
255	!	} else if (inherits(x, "ggplot")) {
256	!	ret <- x
257		} else {
258	!	stop("Unintended usage!")
259		}
260	1x	ret
261		}
262
263		get_body_bottom_location <- function(ppt) {
264	!	location_ <- officer::fortify_location(ph_location_fullsize(), doc = ppt)
265	!	width <- location_$width
266	!	height <- location_$height
267	!	top <- 0.7 * height
268	!	left <- 0.1 * width
269	!	ph <- ph_location(left = left, top = top)
270	!	ph
271		}
272
273
274		#' create location container to center the table
275		#'
276		#' @param ft Flextable object
277		#' @param ppt_width Powerpoint width
278		#' @param ppt_height Powerpoint height
279		#' @return Location for a placeholder
280		center_table_loc <- function(ft, ppt_width, ppt_height) {
281	294x	top <- (ppt_height - sum(dim(ft)$heights)) / 2
282	294x	left <- (ppt_width - sum(dim(ft)$widths)) / 2
283	294x	ph <- ph_location(left = left, top = top)
284	294x	ph
285		}
286
287		# Position table in the body area below the title placeholder.
288		# title_bottom marks where the title area ends; the table is centered
289		# in the remaining vertical space so it never overlaps the title or
290		# extends past the slide bottom.
291		center_gts_table_loc <- function(ft, ppt_width, ppt_height, title_bottom = 1.5) {
292	2x	ft_height <- flextable_dim(ft)$heights
293	2x	ft_width <- flextable_dim(ft)$widths
294	2x	body_height <- ppt_height - title_bottom
295	2x	top <- title_bottom + max(0, (body_height - ft_height) / 2)
296	2x	left <- max(0, (ppt_width - ft_width) / 2)
297	2x	ph_location(left = left, top = top, width = ft_width, height = ft_height)
298		}
299
300		#' Adjust title line break and font size
301		#'
302		#' @param title Character string
303		#' @param max_char Integer specifying the maximum number of characters in one line
304		#' @param title_color Title color
305		get_proper_title <- function(title, max_char = 60, title_color = "#1C2B39") {
306		# cat(nchar(title), " ", as.integer(24-nchar(title)/para), "\n")
307	299x	title <- gsub("\\n", "\\s", title)
308	299x	new_title <- ""
309
310	299x	while (nchar(title) > max_char) {
311	280x	spaces <- gregexpr("\\s", title)
312	280x	new_title <- paste0(new_title, "\n", substring(title, 1, max(spaces[[1]][spaces[[1]] <= max_char])))
313	280x	title <- substring(title, max(spaces[[1]][spaces[[1]] <= max_char]) + 1, nchar(title))
314		}
315
316	299x	new_title <- paste0(new_title, "\n", title)
317
318	299x	ftext(
319	299x	trimws(new_title),
320	299x	fp_text(
321	299x	font.size = floor(26 - nchar(title) / max_char),
322	299x	color = title_color
323		)
324		)
325		}
326
327		#' Add decorated flextable to slides
328		#'
329		#' @param ppt Slide
330		#' @param content Content to be added
331		#' @param table_loc Table location
332		#' @param usernotes User notes
333		#' @param decor Should table be decorated
334		#' @param layout layout from theme
335		#' @param footer_font_size Optional point size for the footnote text. `NULL`
336		#' keeps the existing footnote size set on the flextable.
337		#' @param ... additional arguments
338		#' @return Slide with added content
339		table_to_slide <- function(ppt, content, decor = TRUE, layout = "Title and Content",
340		table_loc = ph_location_type("body"), usernotes = "",
341		footer_font_size = NULL, ...) {
342	296x	layt_summary <- layout_summary(ppt)
343	296x	assertthat::assert_that(layout %in% layt_summary$layout)
344	295x	ppt_master <- layt_summary$master[1]
345	295x	args <- list(...)
346	295x	ppt <- layout_default(ppt, layout)
347
348	295x	if (decor) {
349	295x	print(content$header)
350	295x	out <- content$ft
351
352	295x	if (length(content$footnotes) > 1) {
353	9x	content$footnotes <- paste(content$footnotes, collapse = "\n")
354		}
355		# print(content_footnotes)
356	295x	if (content$footnotes != "") {
357	288x	footnote_value <- if (!is.null(footer_font_size)) {
358	1x	as_paragraph(as_chunk(content$footnotes, props = fp_text(font.size = footer_font_size)))
359		} else {
360	287x	as_paragraph(content$footnotes)
361		}
362	288x	out <- footnote(out,
363	288x	i = 1, j = 1,
364	288x	value = footnote_value,
365	288x	ref_symbols = " ", part = "header", inline = TRUE
366		)
367		}
368
369	295x	args$arg_header <- list(
370	295x	value = fpar(get_proper_title(content$header)),
371	295x	location = ph_location_type("title")
372		)
373		} else {
374	!	out <- content
375	!	out <- footnote(out,
376	!	i = 1, j = 1,
377	!	value = as_paragraph("Confidential and for internal use only"),
378	!	ref_symbols = " ", part = "header", inline = TRUE
379		)
380		}
381
382	295x	ppt <- do_call(add_slide, x = ppt, master = ppt_master, ...)
383	295x	ppt <- ph_with(ppt, value = out, location = table_loc)
384	295x	ppt <- set_notes(ppt, value = usernotes,
385	295x	location = notes_location_type("body"))
386	295x	ph_with_args <- args[unlist(lapply(args, function(x) all(c("location", "value") %in% names(x))))]
387	295x	res <- lapply(ph_with_args, function(x) {
388	295x	ppt <- ph_with(ppt, value = x$value, location = x$location)
389		})
390
391	295x	res
392		}
393
394		#' Create location container to center the figure, based on ppt size and
395		#' user specified figure size
396		#'
397		#' @param fig_width Figure width
398		#' @param fig_height Figure height
399		#' @param ppt_width Slide width
400		#' @param ppt_height Slide height
401		#'
402		#' @return Location for a placeholder from scratch
403		center_figure_loc <- function(fig_width, fig_height, ppt_width, ppt_height) {
404		# center figure
405	1x	top <- (ppt_height - fig_height) / 2
406	1x	left <- (ppt_width - fig_width) / 2
407	1x	ph_location(top = top, left = left)
408		}
409
410		#' Placeholder for ph_with_img
411		#'
412		#' @param ppt power point file
413		#' @param figure image object
414		#' @param fig_width width of figure
415		#' @param fig_height height of figure
416		#' @param figure_loc location of figure
417		#' @return Location for a placeholder
418		#' @export
419		ph_with_img <- function(ppt, figure, fig_width, fig_height, figure_loc) {
420	1x	file_name <- tempfile(fileext = ".svg")
421	1x	svg(filename = file_name, width = fig_width, height = fig_height, onefile = TRUE)
422	1x	grid.draw(figure$grob)
423	1x	dev.off()
424	1x	on.exit(unlink(file_name))
425	1x	ext_img <- external_img(file_name, width = fig_width, height = fig_height)
426
427	1x	ppt %>% ph_with(value = ext_img, location = figure_loc, use_loc_size = FALSE)
428		}
429
430		#' Add figure to slides
431		#'
432		#' @param ppt slide page
433		#' @param content content to be added
434		#' @param decor should decoration be added
435		#' @param fig_width user specified figure width
436		#' @param fig_height user specified figure height
437		#' @param figure_loc location of the figure. Defaults to `ph_location_type("body")`
438		#' @param layout theme layout
439		#' @param fig_editable whether we want the figure to be editable in pptx viewers
440		#' @param ... arguments passed to program
441		#'
442		#' @return slide with the added content
443		figure_to_slide <- function(ppt, content,
444		decor = TRUE,
445		fig_width,
446		fig_height,
447		layout = "Title and Content",
448		figure_loc = ph_location_type("body"),
449		fig_editable = FALSE,
450		...) {
451	4x	layt_summary <- layout_summary(ppt)
452	4x	assertthat::assert_that(layout %in% layt_summary$layout)
453	4x	ppt_master <- layt_summary$master[1]
454	4x	ppt <- layout_default(ppt, layout)
455	4x	args <- list(...)
456
457
458	4x	if (decor) {
459	4x	args$arg_header <- list(
460	4x	value = fpar(get_proper_title(content$titles)),
461	4x	location = ph_location_type("title")
462		)
463		}
464
465	4x	if ("decoratedGrob" %in% class(content)) {
466	4x	ppt <- do_call(add_slide, x = ppt, master = ppt_master, ...)
467	4x	if (fig_editable) {
468	4x	content_list <- g_export(content)
469	4x	ppt <- ph_with(ppt, content_list$dml, location = ph_location_type(type = "body"))
470		} else {
471	!	ppt <- ph_with_img(ppt, content, fig_width, fig_height, figure_loc)
472		}
473
474	4x	ph_with_args <- args[unlist(lapply(args, function(x) all(c("location", "value") %in% names(x))))]
475	4x	res <- lapply(ph_with_args, function(x) {
476	4x	ppt <- ph_with(ppt, value = x$value, location = x$location)
477		})
478	4x	res
479	!	} else if ("decoratedGrobSet" %in% class(content)) { # for decoratedGrobSet, a list of figures are created and added
480		# revisit, to make more efficent
481	!	for (figure in content) {
482	!	ppt <- do_call(add_slide, x = ppt, master = ppt_master, ...)
483	!	ppt <- ph_with_img(ppt, figure, fig_width, fig_height, figure_loc)
484		}
485	!	ppt
486		} else {
487	!	stop("Should not reach here")
488		}
489		}

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	321x	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	!	ft
102		}
103
104		#' convert gtsummary to flextable
105		#' @param x gtsummary object
106		#' @param table_format Function applied to the flextable for styling
107		#' @param ... additional arguments, not used
108		#' @export
109		to_flextable.gtsummary <- function(x, table_format = autoslider_format, ...) {
110	!	gtsummary::as_flex_table(x) %>% table_format()
111		}
112
113		#' convert tbl_roche_summary (NEST 2 gtsummary subclass) to flextable
114		#' @param x tbl_roche_summary object
115		#' @param ... arguments passed to \code{to_flextable.gtsummary}
116		#' @export
117		to_flextable.tbl_roche_summary <- function(x, ...) {
118		# gtsummary v2 guards as_flex_table() with check_class(x, "gtsummary").
119		# Restore the standard hierarchy if it was stripped.
120	!	if (!inherits(x, "gtsummary")) {
121	!	class(x) <- c(class(x), "tbl_summary", "gtsummary")
122		}
123	!	to_flextable.gtsummary(x, ...)
124		}
125
126		#' convert dgtsummary to flextable
127		#'
128		#' @param x dgtsummary object
129		#' @param lpp Lines (rows) per page; overridden when ppt_height is supplied
130		#' @param ppt_height Slide height in inches; used to auto-compute lpp
131		#' @param ppt_width Slide width in inches; used to scale table columns
132		#' @param table_format Function applied to the flextable for styling
133		#' @param ... additional arguments, not used
134		#' @export
135		to_flextable.dgtsummary <- function(x, lpp = 20, ppt_height = NULL, ppt_width = NULL,
136		table_format = autoslider_format, ...) {
137	2x	ft_full <- gtsummary::as_flex_table(x) %>% table_format()
138
139		# Scale columns to fit slide width
140	2x	if (!is.null(ppt_width)) {
141	1x	total_width <- flextable_dim(ft_full)$widths
142	1x	if (total_width > ppt_width) {
143	!	ft_full <- width(ft_full, width = dim(ft_full)$widths * ppt_width / total_width)
144		}
145		}
146
147		# Compute lpp from actual row heights and available body area on slide.
148		# flextable stores rowheights as minimum heights ("atleast" mode); apply a 1.3x
149		# safety factor to account for padding expanding rows beyond the stored minimum.
150	2x	if (!is.null(ppt_height)) {
151	1x	header_height <- sum(ft_full$header$rowheights)
152	1x	available_body <- ppt_height - 1.5 - header_height # 1.5in for title + margins
153	1x	row_heights_est <- ft_full$body$rowheights * 1.3
154	1x	lpp <- max(sum(cumsum(row_heights_est) <= available_body), 1L)
155		}
156
157	2x	n_body <- nrow(ft_full$body$dataset)
158	2x	header_text <- paste(attr(x, "titles"), collapse = "\n")
159	2x	footnotes_text <- paste(attr(x, "footnotes"), collapse = "\n")
160	2x	n_pages <- ceiling(n_body / lpp)
161	2x	ft_list <- lapply(seq_len(n_pages), function(pg) {
162	3x	rows_keep <- seq.int((pg - 1L) * lpp + 1L, min(pg * lpp, n_body))
163	3x	rows_delete <- setdiff(seq_len(n_body), rows_keep)
164	3x	ft_page <- if (length(rows_delete) > 0L) {
165	2x	delete_rows(ft_full, i = rows_delete, part = "body")
166		} else {
167	1x	ft_full
168		}
169	3x	list(
170	3x	ft = ft_page,
171	3x	header = if (pg == 1L) header_text else paste(header_text, "(cont.)"),
172	3x	footnotes = footnotes_text
173		)
174		})
175	2x	class(ft_list) <- "dflextable"
176	2x	ft_list
177		}
178
179
180
181
182		#' convert data.frame to flextable
183		#' @export
184		to_flextable.data.frame <- function(x, col_width = NULL, table_format = orange_format,
185		dose_template = FALSE, font_size = NULL, ...) {
186	272x	df <- x
187	272x	ft <- do_call(flextable, data = df, ...)
188
189	272x	if (dose_template) {
190	!	ft <- ft %>%
191	!	autofit() %>%
192	!	fit_to_width(10)
193		} else {
194	272x	if (all(is.na(formatters::var_labels(df)))) {
195	!	formatters::var_labels(df) <- names(df)
196		}
197
198	272x	ft <- set_header_labels(ft, values = as.list(formatters::var_labels(df)))
199	272x	ft <- ft %>% width(width = col_width)
200	272x	if (flextable_dim(ft)$widths > 10) {
201	272x	pgwidth <- 10.5
202	272x	ft <- ft %>%
203	272x	width(width = dim(ft)$widths * pgwidth / flextable_dim(ft)$widths)
204		# adjust width of each column as percentage of total width
205		}
206		}
207
208	272x	ft <- ft %>%
209	272x	table_format(...)
210
211		# font_size, when supplied, forces a uniform size across the whole table and
212		# therefore overrides any sizing done by `table_format`. Left NULL by default
213		# so per-slide font sizes injected into `table_format` are preserved.
214	272x	if (!is.null(font_size)) {
215	!	ft <- ft %>% fontsize(size = font_size, part = "all")
216		}
217	272x	ft
218		}
219
220
221		old_paginate_listing <- function(lsting,
222		page_type = "letter",
223		font_family = "Courier",
224		font_size = 8,
225		lineheight = 1,
226		landscape = FALSE,
227		pg_width = NULL,
228		pg_height = NULL,
229		margins = c(top = .5, bottom = .5, left = .75, right = .75),
230		lpp = NA_integer_,
231		cpp = NA_integer_,
232		colwidths = formatters::propose_column_widths(lsting),
233		tf_wrap = !is.null(max_width),
234		max_width = NULL,
235		verbose = FALSE) {
236	1x	checkmate::assert_class(lsting, "listing_df")
237	1x	checkmate::assert_numeric(colwidths, lower = 0, len = length(listing_dispcols(lsting)), null.ok = TRUE)
238	1x	checkmate::assert_flag(tf_wrap)
239	1x	checkmate::assert_count(max_width, null.ok = TRUE)
240	1x	checkmate::assert_flag(verbose)
241
242	1x	indx <- formatters::paginate_indices(lsting,
243	1x	page_type = page_type,
244	1x	font_family = font_family,
245	1x	font_size = font_size,
246	1x	lineheight = lineheight,
247	1x	landscape = landscape,
248	1x	pg_width = pg_width,
249	1x	pg_height = pg_height,
250	1x	margins = margins,
251	1x	lpp = lpp,
252	1x	cpp = cpp,
253	1x	colwidths = colwidths,
254	1x	tf_wrap = tf_wrap,
255	1x	max_width = max_width,
256	1x	rep_cols = length(get_keycols(lsting)),
257	1x	verbose = verbose
258		)
259
260	1x	vert_pags <- lapply(
261	1x	indx$pag_row_indices,
262	1x	function(ii) lsting[ii, ]
263		)
264	1x	dispnames <- listing_dispcols(lsting)
265	1x	full_pag <- lapply(
266	1x	vert_pags,
267	1x	function(onepag) {
268	272x	if (!is.null(indx$pag_col_indices)) {
269	272x	lapply(
270	272x	indx$pag_col_indices,
271	272x	function(jj) {
272	272x	res <- onepag[, dispnames[jj], drop = FALSE]
273	272x	listing_dispcols(res) <- intersect(dispnames, names(res))
274	272x	res
275		}
276		)
277		} else {
278	!	list(onepag)
279		}
280		}
281		)
282
283	1x	ret <- unlist(full_pag, recursive = FALSE)
284	1x	ret
285		}
286
287
288		#' convert listing to flextable
289		#' @export
290		to_flextable.dlisting <- function(x, cpp, lpp, ...) {
291	1x	ddf <- x
292	1x	df <- ddf@lst
293	1x	col_width <- ddf@width
294	1x	pag_df <- old_paginate_listing(df, cpp = cpp, lpp = lpp)
295	1x	ft_list <- lapply(1:length(pag_df), function(x) {
296	272x	ft <- to_flextable(pag_df[[x]], col_width = col_width, ...)
297	272x	if (length(prov_footer(df)) == 0) {
298	272x	cat_foot <- main_footer(df)
299		} else {
300	!	cat_foot <- paste0(prov_footer(df), "\n", main_footer(df))
301		}
302
303	272x	if (length(cat_foot) == 0) {
304	!	cat_foot <- ""
305		}
306	272x	list(
307	272x	ft = ft,
308	272x	header = ifelse(x == 1, main_title(df), paste(main_title(df), "(cont.)")),
309	272x	footnotes = cat_foot
310		)
311		})
312		# force the width of the 1st column to be the widest of all paginated table
313		# ft_list_resize <- set_width_widest(ft_list)
314	1x	class(ft_list) <- "dflextable"
315
316	1x	ft_list
317		}
318
319
320
321		#' Covert rtables object to flextable
322		#'
323		#' @param x rtable(VTableTree) object
324		#' @param table_format a function that decorate a flextable and return a flextable
325		#' @export
326		to_flextable.VTableTree <- function(x, table_format = orange_format, ...) {
327	26x	tbl <- x
328	26x	mf <- formatters::matrix_form(tbl, indent_rownames = TRUE)
329	26x	nr_header <- attr(mf, "nrow_header")
330	26x	non_total_coln <- c(TRUE, !grepl("All Patients", names(tbl)))
331	26x	df <- as.data.frame(mf$strings[(nr_header + 1):(nrow(mf$strings)), , drop = FALSE])
332
333	26x	header_df <- as.data.frame(mf$strings[1:(nr_header), , drop = FALSE])
334
335		# if(concat_header){
336		# header_df <- lapply(header_df, function(x) {paste0(x, collapse = "\n")}) %>% as.data.frame
337		# }
338
339		# if(!total_col){
340		# df <- df[non_total_coln]
341		# header_df <- header_df[non_total_coln]
342		# }
343	26x	ft <- do_call(flextable, data = df, ...)
344	26x	ft <- ft %>%
345	26x	delete_part(part = "header") %>%
346	26x	add_header(values = header_df)
347
348		# if(!is.null(apply_theme)){
349		# ft <- ft %>%
350		# apply_theme()
351		# }
352
353	26x	ft <- do_call(table_format, ft = ft, ...)
354	26x	ft <- ft %>%
355	26x	merge_at_indice(lst = get_merge_index(mf$spans[(nr_header + 1):nrow(mf$spans), , drop = FALSE]), part = "body") %>%
356	26x	merge_at_indice(lst = get_merge_index(mf$spans[1:nr_header, , drop = FALSE]), part = "header") %>%
357	26x	align_text_col(align = "center", header = TRUE) %>%
358	26x	align(i = seq_len(nrow(tbl)), j = 1, align = "left") %>% # row names align to left
359	26x	padding_lst(mf$row_info$indent) %>%
360	26x	padding(padding.top = 3, padding.bottom = 3, part = "all") %>%
361	26x	autofit(add_h = 0)
362
363
364	26x	ft <- ft %>%
365	26x	width(width = c(
366	26x	dim(ft)$widths[1],
367	26x	dim(ft)$widths[-1] - dim(ft)$widths[-1] + sum(dim(ft)$widths[-1]) / (ncol(mf$strings) - 1)
368	26x	)) # even the non-label column width
369
370	26x	if (flextable_dim(ft)$widths > 10) {
371	11x	pgwidth <- 10.5
372	11x	ft <- ft %>%
373	11x	width(width = dim(ft)$widths * pgwidth / flextable_dim(ft)$widths)
374		# adjust width of each column as percentage of total width
375		}
376
377	26x	ft
378		}
379
380
381		#' To flextable
382		#'
383		#' @param x decorated rtable(dVTableTree) object
384		#' @param lpp \{lpp\} from \link[rtables]{paginate_table}. numeric. Maximum lines per page
385		#' @param ... argument parameters
386		#' @details convert the VTableTree object into flextable, and merge the cells
387		#' that have colspan > 1. align the columns to the middle, and the row.names to
388		#' the left. indent the row.names by 10 times indention. titles are added in headerlines,
389		#' footnotes are added in footer lines,
390		#' The width of the columns are aligned based on autofit() of officer function.
391		#' For paginated table, the width of the 1st column are set as the widest 1st column among paginated tables
392		#' @export
393		to_flextable.dVTableTree <- function(x, lpp, cpp, ...) {
394	21x	dtbl <- x
395		# paginate VTableTree
396	21x	pag_tbl <- paginate_table(dtbl@tbl, lpp = lpp, cpp = cpp)
397	21x	ft_list <- lapply(1:length(pag_tbl), function(x) {
398	25x	ft <- to_flextable(pag_tbl[[x]], ...)
399	25x	if (length(dtbl@tbl@provenance_footer) == 0) {
400	25x	cat_foot <- dtbl@footnotes
401		} else {
402	!	cat_foot <- paste0(dtbl@tbl@provenance_footer, "\n", dtbl@footnotes)
403		}
404
405	25x	list(
406	25x	ft = ft,
407	25x	header = ifelse(x == 1, dtbl@titles, paste(dtbl@titles, "(cont.)")),
408	25x	footnotes = cat_foot
409		)
410		})
411		# force the width of the 1st column to be the widest of all paginated table
412	21x	ft_list_resize <- set_width_widest(ft_list)
413	21x	class(ft_list_resize) <- "dflextable"
414
415	21x	ft_list_resize
416		}
417
418		g_export <- function(decorated_p) {
419	4x	ret <- list()
420
421	4x	ret$dml <- rvg::dml(
422	4x	ggobj = ggpubr::as_ggplot(decorated_p$grob),
423	4x	bg = "white",
424	4x	pointsize = 12,
425	4x	editable = TRUE
426		)
427	4x	ret$footnote <- decorated_p$footnotes
428	4x	ret$spec <- attributes(decorated_p)$spec
429
430	4x	ret
431		}
432
433		set_width_widest <- function(ft_list) {
434	21x	width1st <- max(unlist(lapply(ft_list, function(x) {
435	25x	x$ft$body$colwidths[1]
436		})))
437	21x	for (i in 1:length(ft_list)) {
438	25x	ft_list[[i]]$ft <- width(ft_list[[i]]$ft, 1, width = width1st)
439		}
440
441	21x	ft_list
442		}
443
444		get_merge_index_single <- function(span) {
445	337x	ret <- list()
446	337x	j <- 1
447	337x	while (j < length(span)) {
448	1335x	if (span[j] != 1) {
449	1x	ret <- c(ret, list(j:(j + span[j] - 1)))
450		}
451	1335x	j <- j + span[j]
452		}
453
454	337x	ret
455		}
456
457		get_merge_index <- function(spans) {
458	52x	ret <- lapply(seq_len(nrow(spans)), function(i) {
459	337x	ri <- spans[i, ]
460	337x	r <- get_merge_index_single(ri)
461	337x	lapply(r, function(s) {
462	1x	list(j = s, i = i)
463		})
464		})
465	52x	unlist(ret, recursive = FALSE, use.names = FALSE)
466		}
467
468		merge_at_indice <- function(ft, lst, part) {
469	52x	Reduce(function(ft, ij) {
470	1x	merge_at(ft, i = ij$i, j = ij$j, part = part)
471	52x	}, lst, ft)
472		}
473
474		padding_lst <- function(ft, indents) {
475	26x	Reduce(function(ft, s) {
476	307x	padding(ft, s, 1, padding.left = (indents[s] + 1) * 10)
477	26x	}, seq_len(length(indents)), ft)
478		}

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 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		#' dplyr::mutate(TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")))
16		#' adae <- eg_adae %>%
17		#' dplyr::mutate(
18		#' TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")),
19		#' ATOXGR = AETOXGR
20		#' )
21		#' out <- t_ae_pt_diff_slide(adsl, adae, "TRT01A", 2)
22		#' print(out)
23		#' generate_slides(out, paste0(tempdir(), "/ae_diff.pptx"))
24		t_ae_pt_diff_slide <- function(adsl, adae, arm = "TRT01A", cutoff = NA,
25		split_by_study = FALSE, side_by_side = NULL) {
26	9x	cutoff <- check_and_set_cutoff(adae, cutoff)
27	9x	result <- t_ae_pt_core(adsl, adae, arm, cutoff,
28	9x	diff = TRUE, soc = "NULL",
29	9x	prune_by_total = FALSE, split_by_study, side_by_side
30		)
31	8x	result@main_title <- "Adverse Events with Difference"
32
33	8x	if (!all(dim(result@rowspans) == c(0, 0))) {
34	!	if (is.null(side_by_side)) {
35		# adding "N" attribute
36	!	arm <- col_paths(result)[[1]][1]
37
38	!	n_r <- data.frame(
39	!	ARM = toupper(names(result@col_info)),
40	!	N = col_counts(result) %>% as.numeric()
41		) %>%
42	!	`colnames<-`(c(paste(arm), "N")) %>%
43	!	arrange(get(arm))
44
45	!	attr(result, "N") <- n_r
46		}
47		}
48
49	8x	result
50		}
51
52
53		t_ae_pt_core <- function(adsl, adae, arm, cutoff, diff = FALSE, soc = "NULL",
54		prune_by_total = FALSE,
55		split_by_study, side_by_side) {
56	27x	assert_that(has_name(adae, "AEDECOD"))
57	27x	assert_that(has_name(adae, "ATOXGR"))
58	27x	assert_that(has_name(adae, "AEBODSYS"))
59	27x	assert_that(has_name(adae, "ANL01FL"))
60	27x	assert_that((diff + prune_by_total) < 2)
61	27x	assert_that(cutoff <= 100 & cutoff >= 0)
62
63	27x	if (!is.null(side_by_side)) {
64	7x	assert_that(has_name(adsl, "RACE"))
65	7x	assert_that(has_name(adsl, "COUNTRY"))
66		}
67
68	27x	slref_arm <- sort(unique(adsl[[arm]]))
69	27x	anl_arm <- sort(unique(adae[[arm]]))
70	27x	assert_that(identical(slref_arm, anl_arm),
71	27x	msg = "The adsl and the analysis datasets should have the same treatment arm levels"
72		)
73
74	27x	if (is.null(side_by_side)) {
75	20x	adsl1 <- adsl %>%
76	20x	select("STUDYID", "USUBJID", all_of(arm))
77	7x	} else if (side_by_side != TRUE) {
78	7x	adsl1 <- adsl %>%
79	7x	select("STUDYID", "USUBJID", "RACE", "COUNTRY", all_of(arm))
80	7x	adsl1$lvl <- "Global"
81		} else {
82	!	adsl1 <- adsl %>%
83	!	select("STUDYID", "USUBJID", all_of(arm))
84	!	adsl1$lvl <- "Global"
85		}
86
87	27x	anl <- adae %>%
88	27x	mutate_at(
89	27x	c("AEDECOD", "AEBODSYS"),
90	27x	~ explicit_na(sas_na(.)) # Replace blank arm with <Missing>
91		) %>%
92	27x	semi_join(., adsl1, by = c("STUDYID", "USUBJID")) %>%
93	27x	mutate(
94	27x	ATOXGR = sas_na(ATOXGR) %>% as.factor(),
95	27x	ATOXGR2 = case_when(
96	27x	ATOXGR %in% c(1, 2) ~ "1 - 2",
97	27x	ATOXGR %in% c(3, 4) ~ "3 - 4",
98	27x	ATOXGR %in% c(5) ~ "5",
99	27x	) %>% as.factor()
100		)
101
102	27x	if (!is.null(side_by_side)) {
103	7x	anl$lvl <- "Global"
104		}
105
106	27x	if (soc == "soc") {
107	12x	anl <- anl %>%
108	12x	mutate(
109	12x	AEBODSYS = sas_na(AEBODSYS) %>% as.factor()
110		)
111		}
112
113	27x	anl <- anl %>%
114	27x	formatters::var_relabel(
115	27x	AEBODSYS = "MedDRA System Organ Class",
116	27x	AEDECOD = "MedDRA Preferred Term"
117		) %>%
118	27x	filter(ANL01FL == "Y")
119
120	27x	if (nrow(anl) == 0) {
121	1x	return(null_report())
122		} else {
123	26x	lyt <- build_table_header(adsl1, arm, split_by_study = split_by_study, side_by_side = side_by_side)
124
125		# lyt <- basic_table() %>%
126		# split_cols_by(var = arm, split_fun = add_overall_level("All Patients", first = FALSE)) %>%
127		# add_colcounts()
128
129	26x	if (soc == "soc") {
130	12x	lyt <- lyt %>%
131	12x	split_rows_by(
132	12x	"AEBODSYS",
133	12x	child_labels = "visible",
134	12x	nested = FALSE,
135	12x	indent_mod = -1L,
136	12x	split_fun = drop_split_levels
137		) %>%
138	12x	append_varlabels(anl, "AEBODSYS")
139		}
140
141	26x	lyt <- lyt %>%
142	26x	count_occurrences(
143	26x	vars = "AEDECOD",
144	26x	.indent_mods = c(count_fraction = 1L)
145		# , .formats = list(trim_perc1)
146		) %>%
147	26x	append_topleft(paste(" ", formatters::var_labels(anl["AEDECOD"]), "N (%)"))
148
149	26x	if (soc == "soc") {
150	12x	sort_path <- c("AEBODSYS", "*", "AEDECOD")
151		} else {
152	14x	sort_path <- c("AEDECOD")
153		}
154
155		# this is an add hoc test check
156	26x	myh_col_indices <- function(table_row, col_names) {
157	!	NULL
158		}
159		# environment(myh_col_indices) <- asNamespace("tern")
160		# assignInNamespace("h_col_indices", myh_col_indices, ns = "tern")
161		# result <- build_table(lyt = lyt, df = anl, alt_counts_df = adsl1)
162
163	26x	result <- lyt_to_side_by_side_two_data(lyt, anl, adsl1, side_by_side)
164
165	26x	result <- result %>%
166	26x	sort_at_path(
167	26x	path = sort_path,
168	26x	scorefun = score_occurrences
169		)
170
171		# criteria_fun <- function(tr) is(tr, "ContentRow")
172		# result <- trim_rows(result, criteria = criteria_fun)
173
174	26x	if (diff) {
175	15x	row_condition <- has_fractions_difference(
176	15x	atleast = cutoff / 100,
177		# col_names = levels(adsl1$TRT01A)
178	15x	col_indices = 1:2
179		)
180	15x	if (length(levels(adsl1[[arm]])) > 2) {
181	2x	stop("More than two arms, not implemented yet")
182		}
183	11x	} else if (prune_by_total) {
184	4x	if (is.null(side_by_side)) {
185	4x	row_condition <- has_fraction_in_any_col(
186	4x	atleast = cutoff / 100,
187	4x	col_indices = ncol(result)
188		)
189	!	} else if (!is.null(side_by_side)) {
190	!	stop("I am not implemented yet")
191		} else {
192	!	row_condition <- has_fraction_in_any_col(
193	!	atleast = cutoff / 100,
194	!	col_indices = ncol(result)
195		)
196		}
197		} else {
198	7x	row_condition <- has_fraction_in_any_col(
199	7x	atleast = cutoff / 100,
200	7x	col_names = levels(adsl1[[arm]])
201		)
202		}
203
204	24x	result1 <- prune_table(result, keep_rows(row_condition))
205		# Viewer(result1)
206
207	24x	if (is.null(result1)) {
208	!	return(null_report())
209		} else {
210	24x	return(result1)
211		}
212		}
213		}

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		#' 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	22x	if (is.null(side_by_side)) {
31	15x	extra <- NULL
32		} else {
33	7x	extra <- c("COUNTRY")
34		}
35
36	22x	for (v in c(vars, extra)) {
37	91x	assert_that(has_name(adsl, v))
38		}
39
40	22x	adsl1 <- adsl %>%
41	22x	select(all_of(c("STUDYID", "USUBJID", arm, vars, extra)))
42
43	22x	if (!is.null(side_by_side)) {
44	7x	adsl1$lvl <- "Global"
45		}
46
47	22x	lyt <- build_table_header(adsl1, arm,
48	22x	split_by_study = split_by_study,
49	22x	side_by_side = side_by_side
50		)
51
52	22x	lyt <- lyt %>%
53	22x	analyze_vars(
54	22x	na.rm = TRUE,
55	22x	.stats = stats,
56	22x	denom = "n",
57	22x	vars = vars,
58	22x	.formats = c(mean_sd = "xx.xx (xx.xx)", median = "xx.xx"),
59	22x	var_labels = formatters::var_labels(adsl1)[vars]
60		)
61
62	22x	result <- lyt_to_side_by_side(lyt, adsl1, side_by_side)
63
64	22x	if (is.null(side_by_side)) {
65		# adding "N" attribute
66	15x	arm <- col_paths(result)[[1]][1]
67
68	15x	n_r <- data.frame(
69	15x	ARM = toupper(names(result@col_info)),
70	15x	N = col_counts(result) %>% as.numeric()
71		) %>%
72	15x	`colnames<-`(c(paste(arm), "N")) %>%
73	15x	dplyr::arrange(get(arm))
74
75	15x	attr(result, "N") <- n_r
76		}
77	22x	result@main_title <- "Demographic slide"
78	22x	result
79		}

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	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		#' @param metadata Named `list` (or `NULL`) of token values used to substitute
114		#' `{token}` placeholders in `study_id`. See [apply_tokens()].
115		#'
116		#' @return An `officer::rpptx` object with the new title slide appended.
117		#'
118		#' @export
119		#'
120		#' @examples
121		#'
122		#' tmp <- tempfile(fileext = ".pptx")
123		#' doc <- officer::read_pptx()
124		#' doc <- officer::add_slide(doc, layout = "Title Slide", master = "Office Theme")
125		#' print(doc, target = tmp)
126		#'
127		#' doc <- append_title_slides(
128		#' doc_o = tmp,
129		#' study_id = "My Study #13",
130		#' to_page = 1,
131		#' save_file = TRUE
132		#' )
133		append_title_slides <- function(
134		doc_o,
135		study_id = "XXXX change me",
136		to_page = NA,
137		doc_original = NULL,
138		save_file = FALSE,
139		metadata = NULL) {
140	4x	doc_original <- initialize_doc_original(doc_original, doc_o)
141
142	4x	to_page <- initialize_to_page(doc_original, to_page)
143
144	4x	study_id <- apply_tokens(study_id, metadata)
145
146	4x	doc <- doc_original \|>
147	4x	officer::add_slide(layout = "Title and Content", master = "Office Theme") \|>
148	4x	officer::ph_with(
149	4x	value = paste0(study_id, "Meeting"),
150	4x	location = officer::ph_location_type(type = "title")
151		) \|>
152	4x	officer::ph_with(
153	4x	value = paste0("meeting"),
154	4x	location = officer::ph_location_type(type = "body")
155		) \|>
156	4x	officer::move_slide(to = to_page)
157
158	4x	postprocessing_doc(doc, save_file, doc_o, type = "title")
159
160	4x	doc
161		}
162
163
164
165		#' Append Section Header Slides to a PowerPoint Document
166		#'
167		#' This function adds a new section header slide to an existing PowerPoint document
168		#' using a "Section Header" layout from the "Office Theme".
169		#' It populates the title placeholder with the provided section title.
170		#'
171		#' @param doc_o Path to a PowerPoint (`.pptx`) file. Used to initialize the document
172		#' if `doc_original` is `NULL`, and for post-processing.
173		#' @param section_title A character string for the title of the section header slide.
174		#' Defaults to "New Section".
175		#' @param to_page An integer specifying the page number where the new slide should be moved.
176		#' If `NA`, the slide is added at the end and `initialize_to_page` determines its final position.
177		#' @param doc_original An optional existing `officer::rpptx` object. If `NULL`,
178		#' the document is initialized from `doc_o`.
179		#' @param save_file A logical value. If `TRUE`, the modified document is saved to a file
180		#' after adding the slide.
181		#' @param metadata Named `list` (or `NULL`) of token values used to substitute
182		#' `{token}` placeholders in `section_title`. See [apply_tokens()].
183		#'
184		#' @return An `officer::rpptx` object with the new section header slide appended.
185		#'
186		#' @export
187		#'
188		#' @examples
189		#'
190		#' tmp <- tempfile(fileext = ".pptx")
191		#' doc <- officer::read_pptx()
192		#' print(doc, target = tmp)
193		#'
194		#' append_section_header_slides(
195		#' doc_o = tmp,
196		#' section_title = "My Section",
197		#' to_page = 1,
198		#' save_file = TRUE
199		#' )
200		append_section_header_slides <- function(
201		doc_o,
202		section_title = "New Section",
203		to_page = NA,
204		doc_original = NULL,
205		save_file = FALSE,
206		metadata = NULL) {
207	4x	doc_original <- initialize_doc_original(doc_original, doc_o)
208
209	4x	to_page <- initialize_to_page(doc_original, to_page)
210
211	3x	section_title <- apply_tokens(section_title, metadata)
212
213	3x	doc <- doc_original \|>
214	3x	officer::add_slide(layout = "Section Header", master = "Office Theme") \|>
215	3x	officer::ph_with(
216	3x	value = section_title,
217	3x	location = officer::ph_location_type(type = "title")
218		) \|>
219	3x	officer::move_slide(to = to_page)
220
221	3x	postprocessing_doc(doc, save_file, doc_o, type = "section_header")
222
223	3x	doc
224		}
225
226		#' Append All Predefined Slides to a PowerPoint Document
227		#'
228		#' This function orchestrates the appending of a series of predefined slides
229		#' (including title and section header slides) to a PowerPoint document based
230		#' on a provided page list.
231		#'
232		#' @param doc_o Path to a PowerPoint (`.pptx`) file. Used to initialize the document
233		#' if `doc_original` is `NULL`, and for final post-processing.
234		#' @param page_list A list of slide definitions. Each element in the list should be
235		#' another list containing:
236		#' - `type`: A character string indicating the type of slide ("title" or "section").
237		#' - `to_page`: An integer specifying the target page number for the slide.
238		#' - Other arguments specific to the slide type (e.g., `study_id` for "title" slides,
239		#' `section_title` for "section" slides).
240		#' @param doc_original An optional existing `officer::rpptx` object. If `NULL`,
241		#' the document is initialized from `doc_o`.
242		#' @param save_file A logical value. If `TRUE`, the final modified document is saved
243		#' to a file after all slides have been appended.
244		#' @param metadata Named `list` (or `NULL`) of token values used to substitute
245		#' `{token}` placeholders in each slide's text (e.g. `study_id`,
246		#' `section_title`). See [apply_tokens()].
247		#'
248		#' @return An `officer::rpptx` object with all specified slides appended.
249		#'
250		#' @export
251		#' @examples
252		#' tmp <- tempfile(fileext = ".pptx")
253		#' doc <- officer::read_pptx()
254		#' print(doc, target = tmp)
255		#'
256		#' my_page_list <- list(
257		#' list(type = "title", to_page = 1, study_id = "My Project"),
258		#' list(type = "section", to_page = 2, section_title = "Introduction"),
259		#' list(type = "title", to_page = 3, study_id = "Mid-Term Review"),
260		#' list(type = "section", to_page = 4, section_title = "Key Findings")
261		#' )
262		#'
263		#' # Append all slides using the dynamic page_list
264		#' doc <- append_all_slides(
265		#' doc_o = tmp,
266		#' page_list = my_page_list,
267		#' save_file = TRUE
268		#' )
269		append_all_slides <- function(
270		doc_o,
271		page_list = list(), # Default to an empty list
272		doc_original = NULL,
273		save_file = FALSE,
274		metadata = NULL) {
275	3x	doc <- initialize_doc_original(doc_original, doc_o)
276
277
278	3x	for (page in page_list) {
279	6x	current_to_page <- page$to_page
280
281
282	6x	if (page$type == "title") {
283	3x	doc <- append_title_slides(
284	3x	doc_o = doc_o,
285	3x	doc_original = doc,
286	3x	to_page = current_to_page,
287	3x	study_id = page$study_id,
288	3x	save_file = FALSE,
289	3x	metadata = metadata
290		)
291	3x	} else if (page$type == "section") {
292	3x	doc <- append_section_header_slides(
293	3x	doc_o = doc_o,
294	3x	doc_original = doc,
295	3x	to_page = current_to_page,
296	3x	section_title = page$section_title,
297	3x	save_file = FALSE,
298	3x	metadata = metadata
299		)
300		}
301		}
302
303	2x	postprocessing_doc(doc, save_file, doc_o, type = "final")
304
305	2x	doc
306		}

1		# AI "story" content slides
2		# ------------------------------------------------------------------------------
3		# A post-processing step that complements `get_ai_notes()` (which attaches an
4		# LLM response as speaker notes, easy to miss and never shown in presentation
5		# mode). Instead, this loads an already-generated deck, sends the underlying
6		# table data to an LLM asking it to "tell a story", and inserts the narrative as
7		# REAL content slides (title + bullets on an AI-chosen layout): a short summary
8		# section at the front of the deck and a conclusions section at the end.
9		#
10		# The design keeps the LLM call (`get_ai_story()`) separate from the pure
11		# `officer` slide insertion (`add_story_slides()`) so the bulk of the logic is
12		# unit-testable without any network access.
13
14		# Layouts the AI is allowed to pick from. Deliberately a small, text-only subset
15		# so the narrative always renders regardless of the template's design layouts.
16		.story_safe_layouts <- c("Section Header", "Title and Content", "Title Only")
17
18		#' Layouts available for AI story slides
19		#'
20		#' Intersects the safe text-only layout subset with the layouts the template
21		#' actually ships, so every layout offered to the LLM is guaranteed to exist.
22		#'
23		#' @param ppt An `officer::rpptx` object.
24		#'
25		#' @return A character vector of layout names present in `ppt`.
26		#'
27		#' @noRd
28		story_layout_choices <- function(ppt) {
29	1x	available <- officer::layout_summary(ppt)$layout
30	1x	choices <- intersect(.story_safe_layouts, available)
31	1x	if (length(choices) == 0) {
32		# Fall back to whatever the template ships so we never offer an empty set.
33	!	choices <- available
34		}
35	1x	choices
36		}
37
38		#' Build the deck-level story prompt from decorated outputs
39		#'
40		#' Collects the rendered text of each decorated table output (reusing
41		#' `export_as_txt()`, exactly as `integrate_prompt()` does for AI notes) and
42		#' assembles one instruction asking the LLM to produce a short summary section
43		#' and a conclusions section, each slide carrying a title, concise bullets and a
44		#' layout chosen from `allowed_layouts`.
45		#'
46		#' Outputs that errored (`autoslider_error`) or that are not tables (no `tbl`
47		#' slot, e.g. figures/listings) are skipped.
48		#'
49		#' @param outputs A named `list` of decorated outputs (as returned by
50		#' [decorate_outputs()]).
51		#' @param allowed_layouts Character vector of permitted slide layouts.
52		#' @param max_slides Integer cap on the number of slides per section.
53		#'
54		#' @return A single character string: the prompt.
55		#'
56		#' @noRd
57		build_story_prompt <- function(outputs, allowed_layouts, max_slides = 4L) {
58	2x	tables <- list()
59	2x	for (nm in names(outputs)) {
60	2x	out <- outputs[[nm]]
61	2x	if (is(out, "autoslider_error")) {
62	1x	next
63		}
64	1x	if (!methods::.hasSlot(out, "tbl")) {
65	!	next
66		}
67	1x	txt <- tryCatch(
68	1x	paste(export_as_txt(out@tbl), collapse = "\n"),
69	1x	error = function(e) ""
70		)
71	1x	if (nzchar(txt)) {
72	1x	tables[[nm]] <- txt
73		}
74		}
75
76	2x	tables_block <- paste(
77	2x	vapply(
78	2x	names(tables),
79	2x	function(nm) paste0("### ", nm, "\n", tables[[nm]]),
80	2x	character(1)
81		),
82	2x	collapse = "\n\n"
83		)
84
85	2x	paste0(
86	2x	"You are a Clinical data scientist expert preparing a slide deck for a ",
87	2x	"study team. Below are the tables from a generated deck.\n\n",
88	2x	tables_block,
89	2x	"\n\n",
90	2x	"Tell the story of these data as presentation slides. Produce two sections:\n",
91	2x	"1. `summary`: up to ", max_slides, " slides that open the deck and give the ",
92	2x	"audience the key take-aways before they see the detailed tables.\n",
93	2x	"2. `conclusions`: up to ", max_slides, " slides that close the deck with the ",
94	2x	"main conclusions and any caveats.\n\n",
95	2x	"For every slide provide a short title, a handful of concise bullet points, ",
96	2x	"and choose a `layout` from exactly this set: ",
97	2x	paste(allowed_layouts, collapse = ", "), ". ",
98	2x	"Use a section-divider layout (e.g. 'Section Header') for the slide that ",
99	2x	"opens each section, and a content layout for slides that carry bullets. ",
100	2x	"Keep bullets factual and grounded in the numbers above."
101		)
102		}
103
104		#' Fallback: get the story as plain-text JSON and parse it
105		#'
106		#' Used when a provider does not support `chat$chat_structured()`. Asks the model
107		#' to reply with a bare JSON object matching the story schema, strips any
108		#' reasoning block or markdown fence, extracts the outermost JSON object and
109		#' parses it. Returns a `list(summary, conclusions)`; missing sections default to
110		#' empty lists.
111		#'
112		#' @param chat An `ellmer` chat object.
113		#' @param prompt The deck-level story prompt (see [build_story_prompt()]).
114		#' @param allowed_layouts Character vector of permitted layouts (named in the
115		#' JSON instruction so the model stays in range).
116		#'
117		#' @return A `list` with `summary` and `conclusions` elements.
118		#'
119		#' @noRd
120		story_via_json <- function(chat, prompt, allowed_layouts) {
121	1x	instruction <- paste0(
122	1x	prompt, "\n\n",
123	1x	"Respond with ONLY a JSON object (no markdown fences, no commentary) of the form:\n",
124	1x	'{"summary":[{"layout":"<one of: ', paste(allowed_layouts, collapse = " \| "),
125	1x	'>","title":"a short title","bullets":["a bullet","another bullet"]}],',
126	1x	'"conclusions":[{"layout":"...","title":"...","bullets":["..."]}]}'
127		)
128	1x	raw <- chat$chat(instruction, echo = "none")
129	1x	txt <- sub(".?</think>\\s", "", raw) # drop <think>...</think> reasoning blocks
130	1x	match <- regmatches(txt, regexpr("(?s)\\{.*\\}", txt, perl = TRUE))
131	1x	if (length(match) == 1L) {
132	1x	txt <- match
133		}
134	1x	parsed <- jsonlite::fromJSON(txt, simplifyDataFrame = FALSE)
135	1x	list(
136	1x	summary = if (is.null(parsed$summary)) list() else parsed$summary,
137	1x	conclusions = if (is.null(parsed$conclusions)) list() else parsed$conclusions
138		)
139		}
140
141		#' Ask an LLM to tell the story of the decorated outputs
142		#'
143		#' Sends the deck's tables to the chosen LLM provider and returns a structured
144		#' narrative: a `summary` section (for the front of the deck) and a
145		#' `conclusions` section (for the end). Each section is a list of slides, and
146		#' each slide has a `layout`, a `title` and a character vector of `bullets`.
147		#'
148		#' @param outputs A named `list` of decorated outputs (see [decorate_outputs()]).
149		#' @param allowed_layouts Character vector of permitted layouts. Any layout the
150		#' model returns outside this set is clamped to `"Title and Content"`.
151		#' @param platform,base_url,api_key,model Passed to [get_ellmer_chat()] to build
152		#' the chat connection.
153		#' @param max_slides Integer cap on slides per section.
154		#'
155		#' @return A `list` with two elements, `summary` and `conclusions`, each a list
156		#' of slides (`list(layout, title, bullets)`).
157		#'
158		#' @export
159		get_ai_story <- function(outputs,
160		allowed_layouts,
161		platform = "deepseek",
162		base_url = "https://api.deepseek.com",
163		api_key = get_deepseek_key(),
164		model = "deepseek-chat",
165		max_slides = 4L) {
166	!	chat <- get_ellmer_chat(platform, base_url, api_key, model)
167
168	!	slide_type <- ellmer::type_object(
169	!	layout = ellmer::type_enum(
170	!	allowed_layouts,
171	!	"The slide layout to use; must be one of the allowed layouts."
172		),
173	!	title = ellmer::type_string("A short slide title."),
174	!	bullets = ellmer::type_array(
175	!	ellmer::type_string("A single concise bullet point."),
176	!	"The bullet points shown on the slide body."
177		)
178		)
179	!	story_type <- ellmer::type_object(
180	!	summary = ellmer::type_array(
181	!	slide_type,
182	!	"Slides that open the deck with the key take-aways."
183		),
184	!	conclusions = ellmer::type_array(
185	!	slide_type,
186	!	"Slides that close the deck with the main conclusions."
187		)
188		)
189
190	!	prompt <- build_story_prompt(outputs, allowed_layouts, max_slides)
191
192		# Prefer the provider's native structured output. Not every provider supports
193		# it (e.g. DeepSeek returns HTTP 400 for the request `ellmer` emits), so fall
194		# back to plain-text JSON mode and parse the response ourselves.
195	!	story <- tryCatch(
196	!	chat$chat_structured(prompt, type = story_type),
197	!	error = function(e) story_via_json(chat, prompt, allowed_layouts)
198		)
199
200		# Coerce every slide into a clean `list(layout, title, bullets)` regardless of
201		# which path produced it, clamping any layout the model invented back into the
202		# allowed set so `add_story_slides()` can always find a matching layout.
203	!	clamp <- function(slides) {
204	!	if (is.null(slides)) {
205	!	return(list())
206		}
207	!	lapply(slides, function(s) {
208	!	layout <- if (is.null(s$layout)) "" else as.character(s$layout)[1]
209	!	if (!(layout %in% allowed_layouts)) {
210	!	layout <- "Title and Content"
211		}
212	!	list(
213	!	layout = layout,
214	!	title = if (is.null(s$title)) "" else as.character(s$title)[1],
215	!	bullets = if (is.null(s$bullets)) character(0) else as.character(unlist(s$bullets))
216		)
217		})
218		}
219
220		# Drop slides the model left empty (no title and no bullets) so the deck has
221		# no blank inserts.
222	!	drop_empty <- function(slides) {
223	!	Filter(function(s) nzchar(s$title) \|\| length(s$bullets) > 0, slides)
224		}
225
226	!	list(
227	!	summary = drop_empty(clamp(story$summary)),
228	!	conclusions = drop_empty(clamp(story$conclusions))
229		)
230		}
231
232		#' Insert a single story slide into a deck
233		#'
234		#' Adds one slide (title + optional bullets) on the requested layout. If the
235		#' layout has no body placeholder (e.g. `"Title Only"`) but the slide carries
236		#' bullets, the layout is coerced to `"Title and Content"` so no content is
237		#' dropped.
238		#'
239		#' @param ppt An `officer::rpptx` object.
240		#' @param slide A single slide definition (`list(layout, title, bullets)`).
241		#' @param layouts A `data.frame` from [officer::layout_summary()] mapping each
242		#' layout to its master.
243		#'
244		#' @return The modified `officer::rpptx` object (slide appended at the end).
245		#'
246		#' @noRd
247		add_one_story_slide <- function(ppt, slide, layouts) {
248	4x	layout <- slide$layout
249	4x	bullets <- if (is.null(slide$bullets)) character(0) else slide$bullets
250
251		# A layout with no body placeholder cannot hold bullets: promote to a content
252		# layout so the narrative survives.
253	4x	has_body <- function(lay) {
254	6x	props <- officer::layout_properties(ppt, layout = lay)
255	6x	any(props$type == "body")
256		}
257	4x	if (length(bullets) > 0 && !has_body(layout) && "Title and Content" %in% layouts$layout) {
258	1x	layout <- "Title and Content"
259		}
260
261	4x	master <- layouts$master[match(layout, layouts$layout)][1]
262	4x	ppt <- officer::add_slide(ppt, layout = layout, master = master)
263
264	4x	if (!is.null(slide$title) && nzchar(slide$title)) {
265	4x	ppt <- officer::ph_with(
266	4x	ppt,
267	4x	value = slide$title,
268	4x	location = officer::ph_location_type(type = "title")
269		)
270		}
271	4x	if (length(bullets) > 0 && has_body(layout)) {
272	3x	ppt <- officer::ph_with(
273	3x	ppt,
274	3x	value = officer::unordered_list(
275	3x	str_list = bullets,
276	3x	level_list = rep(1L, length(bullets))
277		),
278	3x	location = officer::ph_location_type(type = "body")
279		)
280		}
281	4x	ppt
282		}
283
284		#' Insert AI story slides into an open deck
285		#'
286		#' Inserts the `summary` slides at the front of the deck (in order) and the
287		#' `conclusions` slides at the end. This is pure `officer` work with no network
288		#' access, so it can be unit-tested with a hand-written `story`.
289		#'
290		#' @param ppt An `officer::rpptx` object holding the generated content deck.
291		#' @param story A story `list` with `summary` and `conclusions` elements, each a
292		#' list of slides (see [get_ai_story()]).
293		#'
294		#' @return The modified `officer::rpptx` object.
295		#'
296		#' @export
297		add_story_slides <- function(ppt, story) {
298	3x	layouts <- officer::layout_summary(ppt)
299
300		# Conclusions first: appended to the end, where they stay.
301	3x	conclusions <- if (is.null(story$conclusions)) list() else story$conclusions
302	3x	for (slide in conclusions) {
303	2x	ppt <- add_one_story_slide(ppt, slide, layouts)
304		}
305
306		# Summary next: each new slide is appended at the end, then relocated to its
307		# target position at the front. Moving them front-to-back in order reproduces
308		# the intended summary order ahead of all content slides.
309	3x	summary <- if (is.null(story$summary)) list() else story$summary
310	3x	for (j in seq_along(summary)) {
311	2x	ppt <- add_one_story_slide(ppt, summary[[j]], layouts)
312	2x	ppt <- officer::move_slide(ppt, index = length(ppt), to = j)
313		}
314
315	3x	ppt
316		}
317
318		#' Add an AI-generated story to a generated deck
319		#'
320		#' Post-processes an already-generated `.pptx`: loads it, asks an LLM to tell the
321		#' story of the decorated outputs (see [get_ai_story()]), and inserts the
322		#' narrative as real content slides -- a summary section at the front and a
323		#' conclusions section at the end -- then writes the deck back out.
324		#'
325		#' Unlike [get_ai_notes()], which hides the LLM response in speaker notes, this
326		#' produces slides that are visible in presentation mode.
327		#'
328		#' @param outputs A named `list` of decorated outputs (see [decorate_outputs()]),
329		#' used as the data the story is told from.
330		#' @param infile Path to the generated `.pptx` to read.
331		#' @param outfile Path to write the augmented deck to. Defaults to `infile`
332		#' (overwrite in place).
333		#' @param platform,base_url,api_key,model Passed to [get_ellmer_chat()].
334		#' @param max_slides Integer cap on slides per section.
335		#'
336		#' @return Invisibly, the path written (`outfile`).
337		#'
338		#' @export
339		add_ai_story <- function(outputs,
340		infile,
341		outfile = infile,
342		platform = "deepseek",
343		base_url = "https://api.deepseek.com",
344		api_key = get_deepseek_key(),
345		model = "deepseek-chat",
346		max_slides = 4L) {
347	2x	assert_that(is.list(outputs), msg = "`outputs` must be a list of decorated outputs.")
348	1x	assert_that(
349	1x	is.string(infile) && file.exists(infile),
350	1x	msg = "`infile` must be the path to an existing .pptx file."
351		)
352
353	!	ppt <- officer::read_pptx(infile)
354	!	allowed_layouts <- story_layout_choices(ppt)
355	!	story <- get_ai_story(
356	!	outputs,
357	!	allowed_layouts = allowed_layouts,
358	!	platform = platform,
359	!	base_url = base_url,
360	!	api_key = api_key,
361	!	model = model,
362	!	max_slides = max_slides
363		)
364	!	ppt <- add_story_slides(ppt, story)
365	!	print(ppt, target = outfile)
366
367	!	invisible(outfile)
368		}

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

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	26x	suffix <- spec$suffix
42	26x	if (verbose_level > 0) {
43	26x	cat_bullet(
44	26x	sprintf(
45	26x	"Running program `%s` with suffix '%s'.",
46	26x	program,
47	26x	suffix
48		),
49	26x	bullet = "pointer",
50	26x	bullet_col = "green"
51		)
52		}
53	26x	func <- tryCatch(
54		{
55	26x	func_wrapper(
56	26x	func = match.fun(program),
57	26x	datasets = datasets,
58	26x	spec = spec,
59	26x	verbose = verbose_level > 1
60		)
61		},
62	26x	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	26x	if (is(func, "autoslider_error")) {
71	!	return(func)
72		}
73	26x	ret <- tryCatch(
74		{
75	26x	func(...)
76		},
77	26x	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	26x	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_FAS", "gt_t_dm_slide_FAS")) %>%
121		#' generate_outputs(datasets = data)
122		#'
123		generate_outputs <- function(spec, datasets, verbose_level = 2) {
124	5x	lapply(spec, function(s) {
125	26x	args <- c(
126	26x	list(
127	26x	program = s$program,
128	26x	spec = s,
129	26x	datasets = datasets,
130	26x	verbose_level = verbose_level
131		),
132	26x	s$args # ... arguments passed onto the output-generating function
133		)
134	26x	output <- fastDoCall(generate_output, args)
135	26x	attr(output, "spec") <- s
136	26x	output
137		})
138		}

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		#' 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		get_deepseek_key <- function(filename = "DEEPSEEK_KEY") {
2	1x	scan(filename, what = "character", sep = NULL)
3		}
4
5		get_portkey_key <- function(filename = "PORTKEY_KEY") {
6	1x	scan(filename, what = "character", sep = NULL)
7		}
8
9		get_system_prompt <- function(text = "you are a Clinical data scientist expert") {
10	2x	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	3x	chat <- NULL
27	3x	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	3x	} 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	3x	} 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	3x	} 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	3x	} else if (platform == "anthropic") {
55	!	if (is.null(api_key) \|\| !nzchar(api_key)) {
56	!	api_key <- Sys.getenv("ANTHROPIC_API_KEY")
57		}
58	!	chat <- ellmer::chat_anthropic(
59	!	system_prompt = get_system_prompt(),
60	!	api_key = api_key,
61	!	model = model
62		)
63		}
64
65	3x	chat
66		}
67
68		#' Read prompt list from yaml file
69		#'
70		#' @param filename File name
71		#'
72		#' @export
73		get_prompt_list <- function(filename) {
74	1x	prompt <- yaml::read_yaml(filename, eval.expr = TRUE)
75	1x	structure(
76	1x	.Data = prompt,
77	1x	names = map_chr(prompt, `[[`, "output"),
78	1x	class = union("spec", class(prompt))
79		)
80		}
81
82
83		integrate_prompt <- function(base_prompt, tlg) {
84		# let's do figures in the future
85	1x	ret <- paste(
86	1x	"As a Clinical data scientist expert, here is a",
87	1x	tlg@main_title, ":\n\n"
88		)
89	1x	ret <- gsub("\\{table_text\\}", export_as_txt(tlg), base_prompt)
90	1x	ret
91		}
92
93		#' Update footnote with AI response
94		#'
95		#' @param outputs Output objects
96		#' @param prompt_list List of prompt
97		#' @param platform Platform provider
98		#' @param base_url Base url
99		#' @param api_key API key
100		#' @param model Model of choice
101		#'
102		#' @export
103		get_ai_notes <- function(outputs, prompt_list, platform, base_url, api_key, model) {
104	2x	chat <- get_ellmer_chat(platform, base_url, api_key, model)
105	2x	names_outputs <- names(outputs)
106	2x	ret <- lapply(names_outputs, function(output_name) {
107	2x	output <- outputs[[output_name]]
108	2x	if (is(output, "autoslider_error")) {
109	1x	return(output)
110		}
111	1x	if (output_name %in% names(prompt_list)) {
112	!	base_prompt <- prompt_list[[output_name]]$prompt
113	!	current_prompt <- integrate_prompt(base_prompt, output@tbl)
114	!	raw_response <- chat$chat(current_prompt)
115	!	clean_response <- sub(".?</think>\\s", "", raw_response)
116	!	output@usernotes <- paste(platform, model, "generated notes:", clean_response)
117		}
118	1x	output
119		})
120	2x	names(ret) <- names_outputs
121	2x	ret
122		}

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		#' @param footer_font_size Font size of the table footer, defaults to `body_font_size`
21		#' @return A flextable with applied theme.
22		#' @export
23		autoslider_format <- function(ft,
24		odd_header = "#0EAED5", # "deepskyblue2",
25		odd_body = "#EBF5FA", # "aliceblue",
26		even_header = "#0EAED5", # "slategray1",
27		even_body = "#D0E4F2", # "slategray1" # slategray1,
28		font_name = "arial",
29		body_font_size = 12,
30		header_font_size = 14,
31		footer_font_size = body_font_size) {
32	299x	ft %>%
33	299x	theme_zebra(
34	299x	odd_header = odd_header,
35	299x	odd_body = odd_body,
36	299x	even_header = odd_header,
37	299x	even_body = even_body
38		) %>%
39	299x	font(fontname = font_name, part = "all") %>%
40	299x	fontsize(size = body_font_size, part = "body") %>%
41	299x	color(color = "white", part = "header") %>%
42	299x	fontsize(size = header_font_size, part = "header") %>%
43	299x	fontsize(size = footer_font_size, part = "footer") %>%
44	299x	bold(part = "header")
45		}
46
47
48		#' @describeIn autoslider_format
49		#'
50		#' Blue color theme
51		#'
52		#' @param ft flextable object
53		#' @param ... arguments passed to program
54		#'
55		#' @export
56		blue_format <- function(ft, ...) {
57	1x	ft %>% autoslider_format(
58	1x	odd_header = "#0B41CD",
59	1x	odd_body = "#1482FA",
60	1x	even_body = "#BDE3FF",
61		...
62		)
63		}
64
65		#' @describeIn autoslider_format
66		#'
67		#' Orange color theme
68		#'
69		#' @param ft flextable object
70		#' @param ... arguments passed to program
71		#'
72		#' @export
73		orange_format <- function(ft, ...) {
74	292x	ft %>% autoslider_format(
75	292x	odd_header = "#ED4A0D",
76	292x	odd_body = "#FF7D29",
77	292x	even_body = "#FFBD69",
78		...
79		)
80		}
81
82		#' @describeIn autoslider_format
83		#'
84		#' Red color theme
85		#'
86		#' @param ft flextable object
87		#' @param ... arguments passed to program
88		#'
89		#' @export
90		red_format <- function(ft, ...) {
91	1x	ft %>% autoslider_format(
92	1x	odd_header = "#C40000",
93	1x	odd_body = "#FF1F26",
94	1x	even_body = "#FF8782",
95		...
96		)
97		}
98
99
100		#' @describeIn autoslider_format
101		#'
102		#' Purple color theme
103		#'
104		#' @param ft flextable object
105		#' @param ... arguments passed to program
106		#'
107		#' @export
108		purple_format <- function(ft, ...) {
109	1x	ft %>% autoslider_format(
110	1x	odd_header = "#BC36F0",
111	1x	odd_body = "#E085FC",
112	1x	even_body = "#F2D4FF",
113		...
114		)
115		}
116
117		#' @describeIn autoslider_format
118		#'
119		#' `AutoslideR` dose formats
120		#'
121		#' @param ft flextable object
122		#' @param header_vals Header
123		#'
124		#' @export
125		autoslider_dose_format <- function(ft, header_vals = names(ft$body$dataset)) {
126		# The original implementation used delete_rows and add_header_row, which can be
127		# brittle. Using set_header_labels is the idiomatic and more robust way
128		# to simply change the text of the header row. This avoids the colwidths error.
129	1x	ft %>%
130	1x	theme_booktabs() %>%
131		# set_header_labels(values = header_vals) %>%
132	1x	bold(part = "header") %>%
133	1x	border_remove()
134		}
135
136
137		#' @describeIn autoslider_format
138		#'
139		#' Black color theme
140		#' @author Nina Qi and Jasmina Uzunovic
141		#' @param ft flextable object
142		#' @param ... arguments passed to program
143		#'
144		#' @export
145		black_format_tb <- function(ft, body_font_size = 8, header_font_size = 8,
146		footer_font_size = body_font_size, ...) {
147	4x	ft %>%
148	4x	theme_booktabs() %>%
149	4x	fontsize(size = body_font_size, part = "body") %>%
150	4x	fontsize(size = header_font_size, part = "header") %>%
151	4x	fontsize(size = footer_font_size, part = "footer") %>%
152	4x	bold(part = "header") %>%
153	4x	color(color = "blue", part = "header") %>%
154	4x	border_inner_h(part = "all", border = fp_border(color = "black")) %>%
155	4x	hline_top(part = "all", border = fp_border(color = "black", width = 2)) %>%
156	4x	hline_bottom(part = "all", border = fp_border(color = "black", width = 2))
157		}
158
159		#' Wrap a table formatter so it applies fixed font sizes
160		#'
161		#' @description
162		#' Returns a new table-format function that behaves like `table_format` but with
163		#' the supplied font sizes injected. This is the generic mechanism used by
164		#' [generate_slides()] to honor per-slide `font_size` settings declared in the
165		#' spec: a single `table_format` symbol can carry body/header/footer sizes.
166		#'
167		#' Sizes are only forwarded to arguments the underlying formatter actually
168		#' declares. A formatter with an explicit `body_font_size`/`header_font_size`/
169		#' `footer_font_size` argument (or a `...`) receives the corresponding size;
170		#' sizes a formatter cannot accept are dropped rather than raising an
171		#' "unused argument" error. When no sizes are supplied the original formatter is
172		#' returned unchanged.
173		#'
174		#' @param table_format A function taking a flextable as its first argument and
175		#' returning a flextable (e.g. [autoslider_format()], [black_format_tb()]).
176		#' @param body_font_size,header_font_size,footer_font_size Point sizes. `NULL`
177		#' (the default) leaves that part to the underlying formatter default.
178		#'
179		#' @return A function `function(ft, ...)` returning a styled flextable.
180		#' @export
181		#'
182		#' @examples
183		#' small <- with_font_sizes(black_format_tb, body_font_size = 6, header_font_size = 6)
184		#' ft <- flextable::flextable(head(mtcars))
185		#' small(ft)
186		with_font_sizes <- function(table_format,
187		body_font_size = NULL,
188		header_font_size = NULL,
189		footer_font_size = NULL) {
190	25x	force(table_format)
191	25x	sizes <- Filter(Negate(is.null), list(
192	25x	body_font_size = body_font_size,
193	25x	header_font_size = header_font_size,
194	25x	footer_font_size = footer_font_size
195		))
196	25x	if (length(sizes) == 0) {
197	20x	return(table_format)
198		}
199
200	5x	function(ft, ...) {
201	5x	fmls <- formalArgs(table_format)
202	5x	keep <- if (is.null(fmls) \|\| "..." %in% fmls) {
203	4x	sizes
204		} else {
205	1x	sizes[names(sizes) %in% fmls]
206		}
207	5x	do.call(table_format, c(list(ft = ft), keep))
208		}
209		}

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	31x	suffix <- spec$suffix
10	31x	function_args <- names(formals(func))
11	31x	datasets_filtered <- filters::apply_filter(
12	31x	data = datasets,
13	31x	id = suffix,
14	31x	verbose = verbose
15		)
16
17	31x	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	29x	data_used <-
34	29x	function_args[function_args %in% names(datasets)]
35	29x	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	28x	return({
47	28x	function(...) {
48	28x	fastDoCall(func, c(datasets_filtered[data_used], list(...)))
49		}
50		})
51		}
52		}
53		}

1		abort <- function(...) {
2	13x	stop(..., call. = FALSE)
3		}
4
5		assert_is_character_scalar <- function(x) {
6	456x	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	4x	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	281x	exist_in_spec <- vars %in% names(output)
20		# explicitly define env to use, better practice for testing
21	281x	exist_in_calling_env <- map_lgl(vars, exists, envir = env)
22
23	281x	non_existing_vars <- vars[!(exist_in_spec \| exist_in_calling_env)]
24
25
26	281x	n <- length(non_existing_vars)
27	281x	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	286x	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		#' 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	7x	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	1x	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	14x	if (save_rds) {
50	14x	saveRDS(output, file = paste0(file_name, ".rds"))
51		}
52
53	14x	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	4x	stopifnot(is.list(outputs))
148
149	4x	if (!dir.exists(outfolder)) {
150	!	dir.create(outfolder)
151		}
152	4x	if (!is.null(generic_suffix)) {
153	1x	if (!(is.character(generic_suffix) & length(generic_suffix) == 1)) {
154	1x	stop("generic suffix must be length 1 character!")
155		}
156		}
157	3x	ret <- lapply(outputs, function(output) {
158	18x	spec <- attr(output, "spec")
159	18x	file_path <- file.path(outfolder, spec$output)
160	18x	file_path <- paste0(c(file_path, generic_suffix), collapse = "_")
161	18x	output <- save_output(
162	18x	output = output,
163	18x	file_name = file_path,
164	18x	save_rds = save_rds
165		)
166
167	18x	if (verbose_level > 0) {
168	18x	if (inherits(output, "autoslider_error")) {
169	1x	cat_bullet(
170	1x	"Saving output ",
171	1x	attr(output, "spec")$output,
172	1x	" failed in step ",
173	1x	attr(output, "step"),
174	1x	" with error message: ",
175	1x	toString(output),
176	1x	bullet = "cross",
177	1x	bullet_col = "red"
178		)
179		} else {
180	17x	cat_bullet(
181	17x	"Output saved in path ",
182	17x	file_path,
183	17x	bullet = "tick",
184	17x	bullet_col = "green"
185		)
186		}
187		}
188
189	18x	attr(output, "outpath") <- get_output_file_ext(output, file_path)
190	18x	output
191		})
192
193	3x	if (verbose_level > 0) {
194	3x	total_number <- length(ret)
195	3x	fail_number <- sum(map_lgl(ret, is, class2 = "autoslider_error"))
196	3x	log_success_infomation(total_number - fail_number, fail_number)
197		}
198
199	3x	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		#' 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		#' 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		#' 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	57x	if (quote) {
16	!	args <- lapply(args, enquote)
17		}
18
19	57x	if (is.null(names(args))) {
20	!	argn <- args
21	!	args <- list()
22		} else {
23		# Add all the named arguments
24	57x	argn <- lapply(names(args)[names(args) != ""], as.name)
25	57x	names(argn) <- names(args)[names(args) != ""]
26		# Add the unnamed arguments
27	57x	argn <- c(argn, args[names(args) == ""])
28	57x	args <- args[names(args) != ""]
29		}
30
31	57x	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	56x	} else if (is(what, "function")) {
42	56x	f_name <- deparse(substitute(what))
43	56x	call <- as.call(c(list(as.name(f_name)), argn))
44	56x	args[[f_name]] <- what
45	!	} else if (is(what, "name")) {
46	!	call <- as.call(c(list(what, argn)))
47		}
48
49	57x	eval(call,
50	57x	envir = args,
51	57x	enclos = envir
52		)
53		}

1		log_success_infomation <- function(success, failure) {
2	5x	total_number <- success + failure
3	5x	cat_bullet(
4	5x	"Total number of success ",
5	5x	success,
6		"/",
7	5x	total_number,
8	5x	bullet = "tick",
9	5x	bullet_col = "green"
10		)
11	5x	if (failure > 0) {
12	2x	cat_bullet(
13	2x	"Total number of failures ",
14	2x	failure,
15		"/",
16	2x	total_number,
17	2x	bullet = "cross",
18	2x	bullet_col = "red"
19		)
20		}
21		}
22
23		log_number_of_matched_records <- function(original_spec,
24		filtered_spec,
25		condition) {
26	6x	if (length(filtered_spec)) {
27	6x	msg <- sprintf(
28	6x	"%d/%d outputs matched the filter condition `%s`.",
29	6x	length(filtered_spec),
30	6x	length(original_spec),
31	6x	deparse(condition)
32		)
33	6x	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		#' 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 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		#' Substitute metadata tokens in text
2		#'
3		#' Replaces `glue`-style `{token}` placeholders in a character vector with values
4		#' taken from a user-controlled `metadata` list. This lets study-level information
5		#' (e.g. study number, data cut-off date) be injected into slide titles, footnotes
6		#' and placeholder slides without editing the deck or the spec text directly.
7		#'
8		#' Token values are looked up first in `metadata`, then in the calling environment
9		#' (preserving the existing `glue` behavior used across `decorate` methods).
10		#' A `{token}` that resolves to neither raises an informative error, so typos are
11		#' caught early rather than silently producing a broken slide.
12		#'
13		#' @param text `character` vector possibly containing `{token}` placeholders.
14		#' @param metadata Named `list` (or `NULL`) supplying token values. Typically the
15		#' spec entry produced by [read_spec()], into which the `metadata` argument has
16		#' already been merged.
17		#'
18		#' @return A length-one `character` (`glue`) value with tokens substituted and the
19		#' input collapsed by newlines, matching the previous `glue::glue()` behavior.
20		#'
21		#' @export
22		#'
23		#' @examples
24		#' apply_tokens("Demographics - Study {study}", list(study = "BP12345"))
25		#' apply_tokens(c("Line 1 {study}", "Line 2"), list(study = "BP12345"))
26		apply_tokens <- function(text, metadata = NULL) {
27	97x	checkmate::assert_character(text, null.ok = FALSE)
28	96x	checkmate::assert_list(metadata, null.ok = TRUE)
29
30	95x	if (length(text) == 0) {
31	1x	return(text)
32		}
33
34	94x	data <- if (is.null(metadata)) list() else as.list(metadata)
35	94x	template <- paste(text, collapse = "\n")
36
37	94x	tryCatch(
38	94x	glue::glue_data(.x = data, template, .envir = parent.frame()),
39	94x	error = function(e) {
40	1x	stop(
41	1x	"Failed to substitute metadata tokens in text: ", template, "\n",
42	1x	"Ensure every {token} has a matching name in `metadata` ",
43	1x	"(or the calling environment). Original error: ", conditionMessage(e),
44	1x	call. = FALSE
45		)
46		}
47		)
48		}

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	4x	assert_is_character_scalar(x)
14	4x	structure(
15	4x	.Data = x,
16	4x	step = step,
17	4x	spec = spec,
18	4x	class = "autoslider_error"
19		)
20		}

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