autoslider.core coverage - 89.49%

Files
Source

#' Medical history table
#'
#' Summarize medical history by system organ class (SOC) and preferred term
#' (PT). ADSL defines both the analysis population and the treatment
#' denominators. ADMH records for subjects not present in ADSL are excluded,
#' and treatment is derived from ADSL. If ADMH also contains `arm`, its
#' non-missing values must agree with ADSL for the same subject.
#'
#' Counts for the overall table and each SOC include the number and percentage
#' of unique subjects with at least one condition and, on a separate row, the
#' non-unique number of condition records. PT rows contain unique subject
#' counts and percentages. SOCs and PTs are sorted by decreasing total unique
#' subject count, with labels used to break ties deterministically. Missing or
#' blank SOC and PT values are displayed as `<Missing>`.
#'
#' @param adsl Subject-level analysis dataset. It must contain one row per
#'   non-missing `USUBJID` and the treatment variable named by `arm`.
#' @param admh Medical history analysis dataset. It must contain `USUBJID`,
#'   `MHBODSYS`, and `MHDECOD`.
#' @param arm Name of the treatment variable in `adsl`, character scalar;
#'   `"TRT01A"` by default.
#' @param add_all_patients_col Logical scalar indicating whether an additional
#'   `All Patients` column is displayed.
#'
#' @return An `rtables::VTableTree` object.
#' @md
#' @inherit gen_notes note
#' @export
#'
#' @references
#' The table structure follows the public MHT01 example in the
#' [TLG Catalog](https://insightsengineering.github.io/tlg-catalog/stable/tables/medical-history/mht01.html).
#'
#' @examples
#' library(dplyr)
#' adsl <- eg_adsl %>%
#'   dplyr::mutate(TRT01A = factor(TRT01A))
#' admh <- eg_admh
#'
#' out <- t_mh_slide(adsl, admh)
#' print(out)
#'
#' out_without_overall <- t_mh_slide(
#'   adsl,
#'   admh,
#'   add_all_patients_col = FALSE
#' )
t_mh_slide <- function(adsl, admh, arm = "TRT01A", add_all_patients_col = TRUE) {
  assertthat::assert_that(is.data.frame(adsl), msg = "`adsl` must be a data frame")
  assertthat::assert_that(is.data.frame(admh), msg = "`admh` must be a data frame")
  assertthat::assert_that(
    is.character(arm) && length(arm) == 1L && !is.na(arm) && nzchar(arm),
    msg = "`arm` must be a non-missing character scalar"
  )
  assertthat::assert_that(
    assertthat::is.flag(add_all_patients_col),
    msg = "`add_all_patients_col` must be TRUE or FALSE"
  )

  required_adsl <- c("USUBJID", arm)
  required_admh <- c("USUBJID", "MHBODSYS", "MHDECOD")
  assertthat::assert_that(
    all(required_adsl %in% names(adsl)),
    msg = paste("`adsl` must contain:", paste(required_adsl, collapse = ", "))
  )
  assertthat::assert_that(
    all(required_admh %in% names(admh)),
    msg = paste("`admh` must contain:", paste(required_admh, collapse = ", "))
  )

  adsl_ids <- as.character(adsl$USUBJID)
  assertthat::assert_that(
    !any(is.na(adsl_ids) | trimws(adsl_ids) == ""),
    msg = "`adsl$USUBJID` must not contain missing or blank values"
  )
  assertthat::assert_that(
    !anyDuplicated(adsl_ids),
    msg = "`adsl` must contain at most one row per `USUBJID`"
  )
  assertthat::assert_that(
    !any(is.na(adsl[[arm]]) | trimws(as.character(adsl[[arm]])) == ""),
    msg = paste0("`adsl$", arm, "` must not contain missing or blank values")
  )

  population <- adsl[, c("USUBJID", arm), drop = FALSE]
  population$USUBJID <- as.character(population$USUBJID)
  if (!is.factor(population[[arm]])) {
    population[[arm]] <- factor(population[[arm]])
  }
  in_population <- as.character(admh$USUBJID) %in% population$USUBJID
  analysis_source <- admh[in_population, , drop = FALSE]
  analysis_source$USUBJID <- as.character(analysis_source$USUBJID)

  if (arm %in% names(analysis_source)) {
    expected_arm <- population[[arm]][match(as.character(analysis_source$USUBJID), population$USUBJID)]
    supplied_arm <- analysis_source[[arm]]
    supplied <- !is.na(supplied_arm) & trimws(as.character(supplied_arm)) != ""
    conflicts <- supplied & as.character(supplied_arm) != as.character(expected_arm)
    assertthat::assert_that(
      !any(conflicts),
      msg = paste0("Non-missing `admh$", arm, "` values must agree with `adsl$", arm, "`")
    )
    analysis_source[[arm]] <- NULL
  }

  analysis <- dplyr::left_join(
    analysis_source,
    population,
    by = "USUBJID"
  )

  normalize_term <- function(x) {
    out <- trimws(as.character(x))
    out[is.na(out) | out == ""] <- "<Missing>"
    out
  }
  analysis$MHBODSYS <- factor(
    normalize_term(analysis$MHBODSYS),
    levels = sort(unique(normalize_term(analysis$MHBODSYS)))
  )
  analysis$MHDECOD <- factor(
    normalize_term(analysis$MHDECOD),
    levels = sort(unique(normalize_term(analysis$MHDECOD)))
  )
  analysis <- formatters::var_relabel(
    analysis,
    MHBODSYS = "MedDRA System Organ Class",
    MHDECOD = "MedDRA Preferred Term"
  )

  if (nrow(analysis) == 0L) {
    result <- autoslider.core::null_report()
    result@main_title <- "Medical History"
    return(result)
  }

  layout <- rtables::basic_table(show_colcounts = TRUE)
  layout <- rtables::split_cols_by(layout, arm)
  if (add_all_patients_col) {
    layout <- rtables::add_overall_col(layout, "All Patients")
  }
  layout <- tern::analyze_num_patients(
    layout,
    "USUBJID",
    .stats = c("unique", "nonunique"),
    .labels = c(
      unique = "Total number of patients with at least one condition",
      nonunique = "Total number of conditions"
    )
  )
  layout <- rtables::split_rows_by(
    layout,
    var = "MHBODSYS",
    split_fun = rtables::drop_split_levels,
    child_labels = "visible",
    label_pos = "topleft",
    split_label = formatters::obj_label(analysis$MHBODSYS)
  )
  layout <- tern::summarize_num_patients(
    layout,
    "USUBJID",
    .stats = c("unique", "nonunique"),
    .labels = c(
      unique = "Total number of patients with at least one condition",
      nonunique = "Total number of conditions"
    )
  )
  layout <- tern::count_occurrences(layout, vars = "MHDECOD", .indent_mods = -1L)
  layout <- tern::append_varlabels(analysis, "MHDECOD", indent = 1L, lyt = layout)

  result <- rtables::build_table(layout, df = analysis, alt_counts_df = population)
  result <- rtables::prune_table(result)
  result <- rtables::sort_at_path(
    result,
    path = c("MHBODSYS"),
    scorefun = rtables::cont_n_allcols,
    decreasing = TRUE
  )
  result <- rtables::sort_at_path(
    result,
    path = c("MHBODSYS", "*", "MHDECOD"),
    scorefun = tern::score_occurrences,
    decreasing = TRUE
  )
  result@main_title <- "Medical History"
  result
}

#' Check if an object is a fully named list
#'
#' @description
#' Determines whether an object is a list where every element has a valid,
#' non-empty name. This is primarily used as an `assertthat` assertion helper
#' for validating metadata configurations.
#'
#' @param x An R object to test.
#'
#' @return A logical scalar.
#'
#' @noRd

is_named_list <- function(x) {
  is.list(x) && !is.null(names(x)) && all(nzchar(names(x)))
}

assertthat::on_failure(is_named_list) <- function(call, env) {
  "metadata file must be a flat mapping of named key: value pairs"
}





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

# Copy slide layouts between PowerPoint templates
# ------------------------------------------------------------------------------
# A study theme often ships only its content layout, while placeholder pages
# (cover, section dividers) use layouts from another template. officer can only
# add slides on layouts that exist in the deck it writes and cannot copy layouts
# between presentations, so `import_layouts()` edits the package XML directly to
# build a mixed template.

pptx_ns <- c(
  p = "http://schemas.openxmlformats.org/presentationml/2006/main",
  r = "http://schemas.openxmlformats.org/officeDocument/2006/relationships",
  pr = "http://schemas.openxmlformats.org/package/2006/relationships",
  a = "http://schemas.openxmlformats.org/drawingml/2006/main",
  ct = "http://schemas.openxmlformats.org/package/2006/content-types"
)

#' Import slide layouts from another PowerPoint template
#'
#' Copies one or more slide layouts, together with the images they use, from
#' `source` into `target` and writes the result to `outfile`. This builds a
#' mixed template: content slides keep the study theme's own layouts, and
#' placeholder pages can use layouts that only exist in another template, such
#' as a corporate theme with cover and divider layouts.
#'
#' Each imported layout is attached to the master in `target` with the same
#' name as its master in `source`, or to `master` when given. The layout keeps its own shapes, placeholders and
#' images; theme colors and fonts come from the target master. Layouts that
#' `target` already has are skipped, so the call is safe to repeat.
#'
#' Masters are not copied: a layout whose master is missing from `target`
#' raises an error unless `master` names a master that `target` does have.
#'
#' @param target Path to the template to extend (it is not modified).
#' @param source Path to the template holding the layouts to copy.
#' @param layouts Character vector of layout names to copy from `source`.
#' @param outfile Path of the `.pptx` to write. Defaults to a temporary file.
#' @param master Optional name of the master in `target` to attach the layouts
#'   to. By default each layout goes to the target master with the same name as
#'   its source master.
#'
#' @return The path to `outfile`, invisibly.
#'
#' @seealso [place_speclayout_placeholders()]
#'
#' @export
#'
#' @examples
#' \donttest{
#' # officer's default template lacks the "Content with Caption" layout that
#' # autoslider.core's basic.pptx has; both use the "Office Theme" master.
#' mixed <- import_layouts(
#'   target = system.file("template/template.pptx", package = "officer"),
#'   source = system.file("theme/basic.pptx", package = "autoslider.core"),
#'   layouts = "Content with Caption"
#' )
#' officer::layout_summary(officer::read_pptx(mixed))
#' }
#' @md
import_layouts <- function(target, source, layouts, outfile = tempfile(fileext = ".pptx"), master = NULL) {
  assert_that(is.string(target), is.readable(target), has_extension(target, "pptx"))
  assert_that(is.string(source), is.readable(source), has_extension(source, "pptx"))
  assert_that(is.character(layouts), length(layouts) > 0, noNA(layouts))
  assert_that(!anyDuplicated(layouts), msg = "`layouts` must not repeat a layout name.")
  assert_that(is.string(outfile), has_extension(outfile, "pptx"), is.writeable(dirname(outfile)))
  assert_that(is.null(master) || is.string(master), msg = "`master` must be NULL or a single string.")

  src <- tempfile("pptx_src_")
  dst <- tempfile("pptx_dst_")
  on.exit(unlink(c(src, dst), recursive = TRUE), add = TRUE)
  utils::unzip(source, exdir = src)
  utils::unzip(target, exdir = dst)

  src_layouts <- pptx_part_names(src, "slideLayouts", "/p:sldLayout/p:cSld")
  dst_layouts <- pptx_part_names(dst, "slideLayouts", "/p:sldLayout/p:cSld")
  dst_masters <- pptx_master_names(dst)

  missing <- setdiff(layouts, names(src_layouts))
  if (length(missing)) {
    stop(
      "Layout(s) ", paste0("\"", missing, "\"", collapse = ", "), " not found in `source`. Available: ",
      paste0("\"", names(src_layouts), "\"", collapse = ", "), ".",
      call. = FALSE
    )
  }
  present <- intersect(layouts, names(dst_layouts))
  if (length(present)) {
    message("Already in `target`, not imported: ", paste(present, collapse = ", "))
  }

  ct_file <- file.path(dst, "[Content_Types].xml")
  ct_doc <- xml2::read_xml(ct_file)
  src_ct <- xml2::read_xml(file.path(src, "[Content_Types].xml"))

  for (lay in setdiff(layouts, present)) {
    dst_master <- pptx_target_master(src, src_layouts[[lay]], dst_masters, master, lay)
    import_one_layout(src, dst, src_layouts[[lay]], dst_master, ct_doc, src_ct)
  }
  xml2::write_xml(ct_doc, ct_file)

  pptx_zip_dir(dst, outfile)
  invisible(outfile)
}

#' Map part names to their `name` attribute for one part folder
#'
#' @return A named character vector: names are layout/master names, values are
#'   package-relative part paths (e.g. `ppt/slideLayouts/slideLayout4.xml`).
#'
#' @noRd
pptx_part_names <- function(dir, sub, xpath) {
  files <- list.files(file.path(dir, "ppt", sub), pattern = "\\.xml$", full.names = TRUE)
  nm <- vapply(files, function(f) {
    xml2::xml_attr(xml2::xml_find_first(xml2::read_xml(f), xpath, pptx_ns), "name")
  }, character(1))
  stats::setNames(file.path("ppt", sub, basename(files)), nm)
}

#' Map master names to their parts, named the way officer names them
#'
#' officer's `layout_summary()` reports a master by the name of the theme it
#' uses (`<a:theme name=...>`), not by the master's own `cSld` name, which is
#' often empty or a leftover such as "simple-light-2". Use the same rule so
#' `master` matches what users see.
#'
#' @noRd
pptx_master_names <- function(dir) {
  files <- list.files(file.path(dir, "ppt", "slideMasters"), pattern = "\\.xml$", full.names = TRUE)
  parts <- file.path("ppt", "slideMasters", basename(files))
  nm <- vapply(parts, function(part) pptx_master_name(dir, part), character(1))
  stats::setNames(parts, nm)
}

#' officer-style name of one master part
#' @noRd
pptx_master_name <- function(dir, master_part) {
  rels <- xml2::read_xml(pptx_rels_path(dir, master_part))
  rel <- xml2::xml_find_first(rels, "//pr:Relationship[contains(@Type, '/theme')]", pptx_ns)
  theme <- normalizePath(file.path(dir, dirname(master_part), xml2::xml_attr(rel, "Target")))
  xml2::xml_attr(xml2::xml_find_first(xml2::read_xml(theme), "/a:theme", pptx_ns), "name")
}

#' Path of the `.rels` file belonging to a package part
#' @noRd
pptx_rels_path <- function(dir, part) {
  file.path(dir, dirname(part), "_rels", paste0(basename(part), ".rels"))
}

#' Resolve which target master a source layout attaches to
#' @noRd
pptx_target_master <- function(src, src_part, dst_masters, master, layout) {
  rels <- xml2::read_xml(pptx_rels_path(src, src_part))
  rel <- xml2::xml_find_first(rels, "//pr:Relationship[contains(@Type, '/slideMaster')]", pptx_ns)
  src_master_part <- file.path("ppt", "slideMasters", basename(xml2::xml_attr(rel, "Target")))
  want <- master %||% pptx_master_name(src, src_master_part)
  if (!want %in% names(dst_masters)) {
    stop(
      "Layout \"", layout, "\" needs master \"", want, "\", which `target` does not have. ",
      "Masters in `target`: ", paste0("\"", names(dst_masters), "\"", collapse = ", "),
      ". Set `master` to attach the layout to one of them.",
      call. = FALSE
    )
  }
  dst_masters[[want]]
}

#' Copy one layout part (and the files it references) into the target package
#'
#' Modifies the extracted target folder `dst` in place and adds content types to
#' `ct_doc` (an xml2 document, modified by reference).
#'
#' @noRd
import_one_layout <- function(src, dst, src_part, dst_master_part, ct_doc, src_ct) {
  rel_layout <- "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout"
  layout_ct <- "application/vnd.openxmlformats-officedocument.presentationml.slideLayout+xml"

  # 1. Copy the layout part under the next free slideLayoutN.xml name.
  existing <- list.files(file.path(dst, "ppt", "slideLayouts"), pattern = "^slideLayout[0-9]+\\.xml$")
  n_next <- max(c(0L, as.integer(gsub("\\D", "", existing)))) + 1L
  new_part <- file.path("ppt", "slideLayouts", paste0("slideLayout", n_next, ".xml"))
  file.copy(file.path(src, src_part), file.path(dst, new_part))

  # 2. Rewrite its relationships: the master link points at the target master,
  #    every other internal file (images, ...) is copied under a unique name so
  #    it cannot overwrite a file of the same name in the target.
  rels <- xml2::read_xml(pptx_rels_path(src, src_part))
  prefix <- paste0("imported_", tools::file_path_sans_ext(basename(new_part)), "_")
  for (rel in xml2::xml_children(rels)) {
    if (identical(xml2::xml_attr(rel, "TargetMode"), "External")) {
      next
    }
    if (grepl("/slideMaster$", xml2::xml_attr(rel, "Type"))) {
      xml2::xml_set_attr(rel, "Target", paste0("../slideMasters/", basename(dst_master_part)))
      next
    }
    from <- normalizePath(file.path(src, dirname(src_part), xml2::xml_attr(rel, "Target")))
    folder <- basename(dirname(from))
    new_name <- paste0(prefix, basename(from))
    dir.create(file.path(dst, "ppt", folder), showWarnings = FALSE)
    file.copy(from, file.path(dst, "ppt", folder, new_name))
    xml2::xml_set_attr(rel, "Target", paste0("../", folder, "/", new_name))
    pptx_ensure_default_ct(ct_doc, src_ct, tools::file_ext(from))
  }
  dir.create(dirname(pptx_rels_path(dst, new_part)), showWarnings = FALSE)
  xml2::write_xml(rels, pptx_rels_path(dst, new_part))

  # 3. Register the layout with the master: a relationship plus a sldLayoutId.
  m_rels_file <- pptx_rels_path(dst, dst_master_part)
  m_rels <- xml2::read_xml(m_rels_file)
  rid_nums <- as.integer(sub("^rId", "", xml2::xml_attr(xml2::xml_children(m_rels), "Id")))
  rid <- paste0("rId", max(c(0L, rid_nums), na.rm = TRUE) + 1L)
  xml2::xml_add_child(m_rels, "Relationship",
    Id = rid, Type = rel_layout, Target = paste0("../slideLayouts/", basename(new_part))
  )
  xml2::write_xml(m_rels, m_rels_file)

  m_file <- file.path(dst, dst_master_part)
  m_doc <- xml2::read_xml(m_file)
  node <- xml2::xml_add_child(
    xml2::xml_find_first(m_doc, "//p:sldLayoutIdLst", pptx_ns),
    "p:sldLayoutId",
    id = sprintf("%.0f", pptx_max_layout_id(dst) + 1)
  )
  xml2::xml_set_attr(node, "r:id", rid)
  xml2::write_xml(m_doc, m_file)

  # 4. Declare the new part's content type.
  xml2::xml_add_child(ct_doc, "Override", PartName = paste0("/", new_part), ContentType = layout_ct)
  invisible(new_part)
}

#' Largest slide master / layout id in an extracted package
#'
#' Master and layout ids share one number space and must be unique, so a new
#' layout takes the largest one plus one.
#'
#' @noRd
pptx_max_layout_id <- function(dir) {
  masters <- list.files(file.path(dir, "ppt", "slideMasters"), pattern = "\\.xml$", full.names = TRUE)
  ids <- unlist(lapply(masters, function(m) {
    xml2::xml_attr(xml2::xml_find_all(xml2::read_xml(m), "//p:sldLayoutId", pptx_ns), "id")
  }))
  pres <- xml2::read_xml(file.path(dir, "ppt", "presentation.xml"))
  ids <- c(ids, xml2::xml_attr(xml2::xml_find_all(pres, "//p:sldMasterId", pptx_ns), "id"))
  max(as.numeric(ids))
}

#' Make sure the target declares a content type for a file extension
#' @noRd
pptx_ensure_default_ct <- function(ct_doc, src_ct, ext) {
  # Extensions are case-insensitive ("png" vs "PNG"), so compare lower-cased.
  lower <- "translate(@Extension, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"
  xpath <- sprintf("//ct:Default[%s='%s']", lower, tolower(ext))
  if (length(xml2::xml_find_all(ct_doc, xpath, pptx_ns))) {
    return(invisible(ct_doc))
  }
  def <- xml2::xml_find_first(src_ct, xpath, pptx_ns)
  if (!inherits(def, "xml_missing")) {
    xml2::xml_add_child(ct_doc, def, .where = 0)
  }
  invisible(ct_doc)
}

#' Zip an extracted package folder back into a .pptx
#'
#' Uses the `zip` package (no external zip program needed) and writes
#' `[Content_Types].xml` first, as Office expects.
#'
#' @noRd
pptx_zip_dir <- function(dir, outfile) {
  files <- list.files(dir, recursive = TRUE, all.files = TRUE, no.. = TRUE)
  files <- c("[Content_Types].xml", setdiff(files, "[Content_Types].xml"))
  out_abs <- file.path(normalizePath(dirname(outfile)), basename(outfile))
  if (file.exists(out_abs)) {
    unlink(out_abs)
  }
  zip::zip(zipfile = out_abs, files = files, root = dir, mode = "mirror")
  invisible(out_abs)
}

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

#' 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") {
  assertthat::assert_that(is.string(metadata_file), assertthat::is.readable(metadata_file))
  metadata <- yaml::read_yaml(metadata_file, eval.expr = TRUE)
  assertthat::assert_that(is.list(metadata), is_named_list(metadata))
  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))
  )
}

#' 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 <- error_info(e)
        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 <- error_info(e)
        if (verbose_level > 0) {
          cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red")
        }
        autoslider_error(info, spec = spec, step = "user program")
      }
    )
    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
  })
}

#' Readable message for a caught error
#'
#' rlang/cli conditions (e.g. from dplyr/tidyselect) often leave `e$message`
#' empty and build the text from bullets, which `conditionMessage()` assembles.
#' Falls back to the condition class so the result is never empty.
#'
#' @param e A condition object.
#' @return A non-empty character scalar.
#' @noRd
error_info <- function(e) {
  info <- paste(conditionMessage(e), collapse = "\n")
  if (is.na(info) || !nzchar(trimws(info))) {
    info <- paste0("Error of class `", class(e)[1], "` with no message.")
  }
  info
}

# Placeholder slides
# ------------------------------------------------------------------------------
# Section dividers, cover pages and other non-TLG slides. Each slide is
# described by a layout *role* (which template layout to use and where its
# placeholders are) plus the text for each placeholder. A speclayout can then
# declare these slides inline, and place_speclayout_placeholders() inserts them
# at pages derived from their position among the TLG entries.
#
# Downstream packages (e.g. autoslideR for the SREP template) supply their own
# roles through `layouts =` and their own slide types through `types =`.

# --- input checks ---------------------------------------------------------------

#' Is `x` a list whose elements all have non-empty names?
#'
#' A `list()` with no elements passes. With `unique = TRUE` the names must also
#' be distinct.
#'
#' @noRd
has_entry_names <- function(x, unique = TRUE) {
  if (!is.list(x)) {
    return(FALSE)
  }
  if (length(x) == 0) {
    return(TRUE)
  }
  nms <- names(x)
  !is.null(nms) && !anyNA(nms) && all(nzchar(nms)) && (!unique || !anyDuplicated(nms))
}
assertthat::on_failure(has_entry_names) <- function(call, env) {
  unique <- if (is.null(call$unique)) TRUE else eval(call$unique, env)
  paste0(
    "`", deparse(call$x), "` must be a list whose elements all have ",
    if (unique) "unique, " else "", "non-empty names."
  )
}

# --- layout roles ---------------------------------------------------------------

#' Default placeholder layout roles
#'
#' Roles for the layouts of `inst/theme/basic.pptx` (and officer's default
#' template). Placeholders are found by their PowerPoint type, which is the same
#' in every Office-based template, rather than by label.
#'
#' @noRd
placeholder_layout_defaults <- function() {
  list(
    section = list(
      layout = "Section Header", master = "Office Theme",
      types = list(title = "title", text = "body"),
      fallbacks = list(subtitle = "text")
    ),
    title_slide = list(
      layout = "Title Slide", master = "Office Theme",
      types = list(title = "ctrTitle", subtitle = "subTitle"),
      fallbacks = list(text = "subtitle")
    ),
    title_content = list(
      layout = "Title and Content", master = "Office Theme",
      types = list(title = "title", content = "body"),
      fallbacks = list(subtitle = "content", text = "content")
    )
  )
}

#' Placeholder layout roles
#'
#' Returns the lookup that maps each layout *role* used by placeholder slides
#' (such as `section`) to a template layout and the placeholders it fills.
#'
#' Each role is a `list` with:
#' * `layout`, `master`: the template layout to add the slide on.
#' * `labels`: field name to placeholder label (`ph_label` in
#'   [officer::layout_properties()]), and/or
#' * `types`: field name to placeholder type (`type` in
#'   [officer::layout_properties()], e.g. `"title"`, `"body"`). A label wins
#'   over a type for the same field.
#' * `fallbacks`: field name to another field. Text for a field the layout has
#'   no placeholder for is added to the other field, before its own text. The
#'   default `section` role (the "Section Header" layout has a title and a text
#'   box, but no subtitle) sends `subtitle` to `text`, so a speclayout written
#'   for a template with a subtitle still renders without losing text.
#'
#' Overrides are merged per role, and `labels`, `types` and `fallbacks` per
#' field, so changing one layout name or one label keeps everything else. New
#' roles can be added the same way.
#'
#' @param overrides A named `list` of role overrides. Defaults to the option
#'   named by `option`.
#' @param defaults The roles to start from.
#' @param option Name of the option holding session-wide overrides.
#'
#' @return A named `list` of roles.
#'
#' @seealso [validate_placeholder_layouts()], [append_section_slides()]
#'
#' @export
#'
#' @examples
#' placeholder_layouts()$section
#'
#' # A template whose divider layout is called "Chapter divider"
#' placeholder_layouts(list(section = list(layout = "Chapter divider")))$section$layout
#' @md
placeholder_layouts <- function(overrides = getOption(option, list()),
                                defaults = placeholder_layout_defaults(),
                                option = "autoslider.core.placeholder_layouts") {
  assert_that(has_entry_names(defaults))
  if (length(overrides) == 0) {
    return(defaults)
  }
  assert_that(has_entry_names(overrides),
    msg = paste0("`", option, "` must be a list whose elements all have unique, non-empty names.")
  )
  nested <- c("labels", "types", "fallbacks")
  for (role in names(overrides)) {
    base <- defaults[[role]] %||% list()
    ov <- overrides[[role]]
    merged <- utils::modifyList(base, ov[setdiff(names(ov), nested)])
    for (part in intersect(nested, names(ov))) {
      merged[[part]] <- utils::modifyList(base[[part]] %||% list(), ov[[part]])
    }
    defaults[[role]] <- merged
  }
  defaults
}

#' Look up one role
#' @noRd
resolve_placeholder_role <- function(role, layouts) {
  spec <- layouts[[role]]
  if (is.null(spec)) {
    stop(
      "Unknown placeholder layout role \"", role, "\". Known roles: ",
      paste(names(layouts), collapse = ", "), ".",
      call. = FALSE
    )
  }
  if (is.null(spec$layout) || is.null(spec$master)) {
    stop("Placeholder layout role \"", role, "\" must supply both `layout` and `master`.", call. = FALSE)
  }
  spec
}

#' Fields a role has a placeholder for
#' @noRd
role_fields <- function(spec) {
  union(names(spec$labels), names(spec$types))
}

#' officer location for one field of a role
#' @noRd
placeholder_location <- function(spec, key) {
  if (!is.null(spec$labels[[key]])) {
    return(officer::ph_location_label(spec$labels[[key]]))
  }
  officer::ph_location_type(type = spec$types[[key]])
}

#' Map text fields onto the placeholders a role has
#'
#' Drops `NULL` fields, sends fields without a placeholder to their fallback
#' (in field order, so `subtitle` lands before `text`), substitutes `{token}`s
#' when `metadata` is given, and flattens YAML lists to character vectors.
#'
#' @noRd
resolve_placeholder_fields <- function(fields, spec, role, metadata = NULL) {
  slots <- role_fields(spec)
  out <- list()
  for (key in names(fields)) {
    value <- fields[[key]]
    if (is.null(value)) {
      next
    }
    value <- as.character(unlist(value))
    if (!is.null(metadata)) {
      value <- vapply(value, apply_tokens, character(1), metadata = metadata, USE.NAMES = FALSE)
    }
    target <- if (key %in% slots) key else spec$fallbacks[[key]]
    if (is.null(target) || !target %in% slots) {
      fallback_note <- if (length(spec$fallbacks)) {
        paste0(" (", paste(names(spec$fallbacks), "goes into", unlist(spec$fallbacks), collapse = ", "), ")")
      } else {
        ""
      }
      stop(
        "Placeholder layout role \"", role, "\" (layout \"", spec$layout, "\") has no placeholder for `",
        key, "`. Available: ", paste0("`", slots, "`", collapse = ", "), fallback_note, ".",
        call. = FALSE
      )
    }
    out[[target]] <- c(out[[target]], value)
  }
  out
}

#' Check that a template has the layouts and placeholders of some roles
#'
#' Confirms every requested role resolves to a layout that exists in the
#' template, and that each placeholder label or type the role writes into exists
#' in that layout. Problems are reported together, with the layouts the
#' template does have, before any slide is added.
#'
#' @param x An `officer::rpptx` object or a path to a `.pptx` file.
#' @param roles Roles to check. Defaults to all roles in `layouts`.
#' @param layouts The role lookup, see [placeholder_layouts()].
#'
#' @return Invisibly `TRUE`; otherwise an error.
#'
#' @export
#'
#' @examples
#' validate_placeholder_layouts(system.file("theme/basic.pptx", package = "autoslider.core"))
#' @md
validate_placeholder_layouts <- function(x, roles = names(layouts), layouts = placeholder_layouts()) {
  doc <- if (inherits(x, "rpptx")) x else officer::read_pptx(x)
  available <- officer::layout_summary(doc)
  problems <- character(0)

  for (role in roles) {
    spec <- resolve_placeholder_role(role, layouts)
    if (!any(available$layout == spec$layout & available$master == spec$master)) {
      problems <- c(problems, sprintf(
        "  - role \"%s\": layout \"%s\" in master \"%s\" is missing", role, spec$layout, spec$master
      ))
      next
    }
    props <- officer::layout_properties(doc, layout = spec$layout, master = spec$master)
    absent_labels <- setdiff(unlist(spec$labels, use.names = FALSE), props$ph_label)
    absent_types <- setdiff(unlist(spec$types, use.names = FALSE), props$type)
    if (length(absent_labels)) {
      problems <- c(problems, sprintf(
        "  - role \"%s\" (layout \"%s\"): no placeholder labelled %s", role, spec$layout,
        paste0("\"", absent_labels, "\"", collapse = ", ")
      ))
    }
    if (length(absent_types)) {
      problems <- c(problems, sprintf(
        "  - role \"%s\" (layout \"%s\"): no placeholder of type %s", role, spec$layout,
        paste0("\"", absent_types, "\"", collapse = ", ")
      ))
    }
  }

  if (length(problems) == 0) {
    return(invisible(TRUE))
  }
  by_master <- split(available$layout, available$master)
  stop(
    "This template does not have the layouts the placeholder slides need:\n",
    paste(problems, collapse = "\n"), "\n\nAvailable layouts:\n",
    paste(sprintf("  [%s] %s", names(by_master), vapply(by_master, paste, "", collapse = " | ")), collapse = "\n"),
    "\n\nPoint the role at an existing layout with `layouts = placeholder_layouts(list(<role> = ",
    "list(layout = ...)))`, or the `autoslider.core.placeholder_layouts` option.",
    call. = FALSE
  )
}

# --- adding slides ----------------------------------------------------------------

#' Describe one placeholder slide
#'
#' Used with [append_placeholder_slides()] to build placeholder slide types.
#'
#' @param role A layout role (see [placeholder_layouts()]).
#' @param ... Text for the role's fields, e.g. `title =`, `subtitle =`,
#'   `text =`. Each value may be a character vector or a list (one paragraph per
#'   element). `NULL` leaves that placeholder empty.
#' @param to_page A fixed page for this slide. `NULL` (the default) places it
#'   after the previous slide described in the same call.
#'
#' @return A `list` describing the slide.
#'
#' @export
#'
#' @examples
#' placeholder_slide("section", title = "Safety", text = "Data cut-off: 01-JAN-2026")
#' @md
placeholder_slide <- function(role, ..., to_page = NULL) {
  assert_that(is.string(role))
  list(role = role, fields = list(...), to_page = to_page)
}

#' Write text into placeholders
#' @param location Function turning a field name into an officer location.
#' @noRd
fill_placeholders <- function(doc, fields, location) {
  for (key in names(fields)) {
    if (!is.null(fields[[key]])) {
      doc <- officer::ph_with(doc, value = as.character(unlist(fields[[key]])), location = location(key))
    }
  }
  doc
}

#' Resolve `to_page` for slides being inserted
#'
#' `NA` means after the last slide. Unlike [initialize_to_page()], which returns
#' the page of the current last slide, the result is where the first new slide
#' ends up.
#'
#' @noRd
placeholder_start_page <- function(doc, to_page) {
  last <- length(doc) + 1L
  if (is.null(to_page) || is.na(to_page)) {
    return(last)
  }
  assert_that(is.count(to_page))
  if (to_page > last) {
    stop("`to_page` is ", to_page, " but the deck has only ", length(doc), " slide(s).", call. = FALSE)
  }
  as.integer(to_page)
}

#' Insert placeholder slides
#'
#' The building block behind every placeholder slide type: checks the template
#' has the layouts the slides use, adds each slide described by
#' [placeholder_slide()], fills its placeholders and moves it into place, then
#' optionally saves the deck.
#'
#' @param doc_o Path to the `.pptx` file. Read when `doc_original` is `NULL`,
#'   and used to name the saved file.
#' @param slides A `list` of [placeholder_slide()] descriptions, inserted in
#'   order.
#' @param to_page Page for the first slide; the others follow it. `NA` appends
#'   after the last slide.
#' @param doc_original An optional `officer::rpptx` object to add to.
#' @param save_file If `TRUE`, the deck is saved next to `doc_o` with a
#'   `_<type>` suffix.
#' @param layouts The role lookup, see [placeholder_layouts()].
#' @param metadata Optional named `list` of values for `{token}`s in the text,
#'   see [apply_tokens()].
#' @param type Suffix for the saved file.
#'
#' @return The modified `officer::rpptx` object.
#'
#' @export
#'
#' @examples
#' deck <- tempfile(fileext = ".pptx")
#' print(officer::read_pptx(system.file("theme/basic.pptx", package = "autoslider.core")), deck)
#'
#' doc <- append_placeholder_slides(deck, list(
#'   placeholder_slide("section", title = "{study} safety", text = "Data cut-off: 01-JAN-2026"),
#'   placeholder_slide("title_content", title = "Key findings", content = c("Point 1", "Point 2"))
#' ), metadata = list(study = "BP12345"))
#' length(doc)
#' @md
append_placeholder_slides <- function(doc_o,
                                      slides,
                                      to_page = NA,
                                      doc_original = NULL,
                                      save_file = FALSE,
                                      layouts = placeholder_layouts(),
                                      metadata = NULL,
                                      type = "placeholder") {
  assert_that(
    is.list(slides) && length(slides) > 0 && all(vapply(slides, is.list, logical(1))),
    msg = "`slides` must be a non-empty list of placeholder_slide() descriptions."
  )
  assert_that(is.flag(save_file), noNA(save_file))
  doc <- initialize_doc_original(doc_original, doc_o)

  roles <- unique(vapply(slides, function(sl) sl$role, character(1)))
  validate_placeholder_layouts(doc, roles = roles, layouts = layouts)
  # Resolve every slide's text before adding any, so a bad field fails cleanly.
  specs <- lapply(slides, function(sl) resolve_placeholder_role(sl$role, layouts))
  fields <- Map(function(sl, spec) resolve_placeholder_fields(sl$fields, spec, sl$role, metadata), slides, specs)
  start <- placeholder_start_page(doc, to_page)

  for (i in seq_along(slides)) {
    spec <- specs[[i]]
    doc <- officer::add_slide(doc, layout = spec$layout, master = spec$master)
    doc <- fill_placeholders(doc, fields[[i]], function(key) placeholder_location(spec, key))
    doc <- officer::move_slide(doc, to = slides[[i]]$to_page %||% (start + i - 1L))
  }

  postprocessing_doc(doc, save_file, doc_o, type = type)
}

#' Append a section divider slide
#'
#' Adds one slide on the `section` layout role ("Section Header" in
#' `basic.pptx`) with a title and text. That layout has no subtitle
#' placeholder: a `subtitle` is placed in the text box, above `text`, so
#' speclayouts written for templates that do have a subtitle keep all their
#' text. This backs the `section` placeholder type:
#'
#' ```yaml
#' sec_safety:
#'   type: section
#'   title: Safety Summary
#'   subtitle: "Data cut-off: {cutoff_date}"
#'   text:
#'     - All treated patients
#' ```
#'
#' @inheritParams append_placeholder_slides
#' @param title,subtitle,text Text for the slide. Each may be a character vector
#'   or a list, one paragraph per element. `NULL` leaves it out.
#' @param section_title Older name for `title`, used when `title` is `NULL`.
#' @param role The layout role to use.
#'
#' @return The modified `officer::rpptx` object.
#'
#' @seealso [append_section_header_slides()] for the older title-only version.
#'
#' @export
#'
#' @examples
#' deck <- tempfile(fileext = ".pptx")
#' print(officer::read_pptx(system.file("theme/basic.pptx", package = "autoslider.core")), deck)
#' doc <- append_section_slides(deck, title = "Safety", subtitle = "Data cut-off: 01-JAN-2026")
#' officer::slide_summary(doc, index = length(doc))$text
#' @md
append_section_slides <- function(doc_o,
                                  title = NULL,
                                  subtitle = NULL,
                                  text = NULL,
                                  section_title = NULL,
                                  to_page = NA,
                                  doc_original = NULL,
                                  save_file = FALSE,
                                  layouts = placeholder_layouts(),
                                  metadata = NULL,
                                  role = "section") {
  slides <- list(placeholder_slide(role, title = title %||% section_title, subtitle = subtitle, text = text))
  append_placeholder_slides(doc_o, slides,
    to_page = to_page, doc_original = doc_original, save_file = save_file,
    layouts = layouts, metadata = metadata, type = "section"
  )
}

#' Append a slide on any layout
#'
#' Adds one slide on `layout` and fills the placeholders named in
#' `placeholders` (by label, the `ph_label` column of
#' [officer::layout_properties()]). This backs the `custom` placeholder type,
#' so a study can add its own slide without writing R code:
#'
#' ```yaml
#' sec_rationale:
#'   type: custom
#'   layout: Section Header
#'   placeholders:
#'     Title 1: Dose Rationale
#'     Text Placeholder 2:
#'       - Cohort 3 opened at 20 mg QW
#' ```
#'
#' @param doc_o Path to the `.pptx` file.
#' @param layout Name of the layout to use.
#' @param master Name of the slide master. Only needed when the layout name
#'   exists in more than one master.
#' @param placeholders A named list mapping placeholder labels to text. Each
#'   value may be a character vector or a list (one paragraph per element).
#' @param to_page Page to move the new slide to. `NA` appends at the end.
#' @param doc_original An optional existing `officer::rpptx` object. If `NULL`,
#'   the document is read from `doc_o`.
#' @param save_file A logical. If `TRUE`, the deck is written next to `doc_o`.
#'
#' @return The modified `officer::rpptx` object.
#'
#' @export
#'
#' @examples
#' deck <- tempfile(fileext = ".pptx")
#' print(officer::read_pptx(system.file("theme/basic.pptx", package = "autoslider.core")), deck)
#' doc <- append_custom_slides(deck,
#'   layout = "Section Header",
#'   placeholders = list("Title 1" = "Dose Rationale", "Text Placeholder 2" = "Cohort 3")
#' )
#' length(doc)
#' @md
append_custom_slides <- function(doc_o,
                                 layout,
                                 master = NULL,
                                 placeholders = list(),
                                 to_page = NA,
                                 doc_original = NULL,
                                 save_file = FALSE) {
  doc <- initialize_doc_original(doc_original, doc_o)
  master <- validate_custom_placeholder(doc, layout, master, placeholders)
  to_page <- placeholder_start_page(doc, to_page)

  doc <- officer::add_slide(doc, layout = layout, master = master)
  doc <- fill_placeholders(doc, placeholders, officer::ph_location_label)
  doc <- officer::move_slide(doc, to = to_page)

  postprocessing_doc(doc, save_file, doc_o, type = "custom")
}

#' Check a custom placeholder definition against the template
#' @return The resolved master name.
#' @noRd
validate_custom_placeholder <- function(doc, layout, master = NULL, placeholders = list(), name = NULL) {
  where <- if (is.null(name)) "custom placeholder" else paste0("custom placeholder '", name, "'")
  if (!is.string(layout) || is.na(layout)) {
    stop("The ", where, " needs a `layout` (the name of a layout in the template).", call. = FALSE)
  }
  if (length(placeholders) && !has_entry_names(placeholders)) {
    stop(
      "`placeholders` in the ", where, " must map placeholder labels to text, ",
      "e.g. `Title 1: My title`.",
      call. = FALSE
    )
  }

  available <- officer::layout_summary(doc)
  masters <- available$master[available$layout == layout]
  if (!is.null(master)) {
    masters <- intersect(masters, master)
  }
  if (length(masters) == 0) {
    by_master <- split(available$layout, available$master)
    stop(
      "Layout \"", layout, "\"", if (!is.null(master)) paste0(" in master \"", master, "\""),
      " used by the ", where, " is not in the template. Available layouts:\n",
      paste(sprintf("  [%s] %s", names(by_master), vapply(by_master, paste, "", collapse = " | ")),
        collapse = "\n"
      ),
      call. = FALSE
    )
  }
  if (length(masters) > 1) {
    stop(
      "Layout \"", layout, "\" used by the ", where, " exists in several masters (",
      paste0("\"", masters, "\"", collapse = ", "), "). Set `master` to choose one.",
      call. = FALSE
    )
  }

  labels <- officer::layout_properties(doc, layout = layout, master = masters)$ph_label
  absent <- setdiff(names(placeholders), labels)
  if (length(absent)) {
    stop(
      "Placeholder label(s) ", paste0("\"", absent, "\"", collapse = ", "),
      " used by the ", where, " are not in layout \"", layout, "\". Available labels: ",
      paste0("\"", labels, "\"", collapse = ", "), ".",
      call. = FALSE
    )
  }

  masters
}

# --- placeholder types and the speclayout engine -----------------------------------

#' Built-in placeholder types
#' @noRd
placeholder_type_defaults <- function() {
  list(
    section = list(fn = append_section_slides, n = 1L, roles = "section"),
    title = list(fn = append_title_slides, n = 1L, roles = character(0)),
    custom = list(fn = append_custom_slides, n = 1L, roles = character(0))
  )
}

#' Placeholder slide types
#'
#' Maps each placeholder `type:` used in a speclayout to the function that
#' inserts it (`fn`), the number of slides it adds (`n`, used to place later
#' slides) and the layout roles it uses (`roles`, checked before any slide is
#' inserted).
#'
#' Add types for a session through the option named by `option`, or pass them
#' as `extra`. Each entry is a function or `list(fn = , n = , roles = )`;
#' `n` defaults to 1. The function must accept `doc_o`, `doc_original`,
#' `to_page` and `save_file`, and return the `officer::rpptx` object. Other
#' fields of the speclayout entry are passed on when the function has an
#' argument of that name, as are `layouts` and `metadata`. A type with the
#' same name as a built-in one replaces it.
#'
#' @param extra A named `list` of additional types. Defaults to the option
#'   named by `option`.
#' @param builtin The types to start from.
#' @param option Name of the option holding session-wide types.
#'
#' @return A named `list` of types, each `list(fn, n, roles)`.
#'
#' @export
#'
#' @examples
#' names(placeholder_types())
#'
#' # A study type that adds two section slides
#' two_sections <- function(doc_o, label = "Part", to_page = NA, doc_original = NULL, save_file = FALSE) {
#'   append_placeholder_slides(doc_o, list(
#'     placeholder_slide("section", title = paste(label, "A")),
#'     placeholder_slide("section", title = paste(label, "B"))
#'   ), to_page = to_page, doc_original = doc_original, save_file = save_file)
#' }
#' names(placeholder_types(list(two_sections = list(fn = two_sections, n = 2, roles = "section"))))
#' @md
placeholder_types <- function(extra = getOption(option, list()),
                              builtin = placeholder_type_defaults(),
                              option = "autoslider.core.placeholder_types") {
  if (length(extra) == 0) {
    return(builtin)
  }
  assert_that(has_entry_names(extra),
    msg = paste0("`", option, "` must be a list whose elements all have unique, non-empty names.")
  )
  for (type in names(extra)) {
    entry <- extra[[type]]
    if (is.function(entry)) {
      entry <- list(fn = entry)
    }
    if (!is.list(entry) || !is.function(entry$fn)) {
      stop(
        "`", option, "$", type, "` must be a function or a ",
        "list(fn = <function>, n = <slides added>).",
        call. = FALSE
      )
    }
    entry$n <- as.integer(entry$n %||% 1L)
    entry$roles <- entry$roles %||% character(0)
    builtin[[type]] <- entry
  }
  builtin
}

#' Split an ordered speclayout into content and placeholder entries
#'
#' Partitions a speclayout (as read by [yaml::read_yaml()]) into the TLG
#' entries (those with a `program`) and the placeholder entries (those with a
#' `type` and no `program`), keeping file order. Anything else (e.g. a
#' `defaults:` block) is returned under `other`.
#'
#' @param speclayout A named `list` read from a speclayout yaml file.
#'
#' @return A `list` with named-list elements `content`, `placeholders` and
#'   `other`.
#'
#' @export
#'
#' @examples
#' speclayout <- list(
#'   sec_overview = list(type = "section", title = "Overview"),
#'   t_dm_slide_FAS = list(program = "t_dm_slide", suffix = "FAS"),
#'   defaults = list(common = list(layout = "Title and Content"))
#' )
#' split_speclayout(speclayout)
#' @md
split_speclayout <- function(speclayout) {
  assert_that(has_entry_names(speclayout, unique = FALSE))
  is_placeholder <- vapply(
    speclayout,
    function(e) is.list(e) && !is.null(e$type) && is.null(e$program),
    logical(1)
  )
  is_content <- vapply(speclayout, function(e) is.list(e) && !is.null(e$program), logical(1))
  list(
    content = speclayout[is_content],
    placeholders = speclayout[is_placeholder],
    other = speclayout[!is_placeholder & !is_content]
  )
}

#' Derive placeholder pages from speclayout order
#'
#' Walks an ordered speclayout and, for every placeholder entry, computes the
#' page it must be inserted at so its position among the TLG slides matches its
#' position in the file:
#' `content slides so far + placeholder slides already inserted + 1`.
#'
#' @param speclayout A named, ordered `list` read from a speclayout yaml file.
#' @param content_counts Optional named list of the number of slides each TLG
#'   entry produced. When given, entries missing from it count as 0 slides
#'   (not generated); when `NULL`, every TLG entry counts as one slide.
#' @param types The placeholder types, see [placeholder_types()].
#'
#' @return A `list` of placeholder entries in insertion order, each with its
#'   `name` and resolved `to_page`.
#'
#' @export
#'
#' @examples
#' speclayout <- list(
#'   sec_a = list(type = "section", title = "Section A"),
#'   out1 = list(program = "t_dm_slide", suffix = "FAS"),
#'   out2 = list(program = "t_ae_slide", suffix = "SE"),
#'   sec_b = list(type = "section", title = "Section B")
#' )
#' vapply(derive_placeholder_page_list(speclayout), function(p) p$to_page, integer(1))
#' @md
derive_placeholder_page_list <- function(speclayout, content_counts = NULL, types = placeholder_types()) {
  assert_that(has_entry_names(speclayout, unique = FALSE))
  content_slides <- 0L
  placeholder_slides <- 0L
  page_list <- list()

  for (nm in names(speclayout)) {
    entry <- speclayout[[nm]]
    if (!is.list(entry)) {
      next
    }
    if (!is.null(entry$type) && is.null(entry$program)) {
      if (is.null(types[[entry$type]])) {
        stop(
          "Unknown placeholder type '", entry$type, "' in speclayout entry '", nm,
          "'. Known types: ", paste(names(types), collapse = ", "), ".",
          call. = FALSE
        )
      }
      entry$name <- nm
      entry$to_page <- content_slides + placeholder_slides + 1L
      page_list[[length(page_list) + 1L]] <- entry
      placeholder_slides <- placeholder_slides + types[[entry$type]]$n
    } else if (!is.null(entry$program)) {
      # With counts, a missing entry was not generated (0 slides); without
      # counts, each TLG entry is assumed to produce one slide.
      count <- content_counts[[nm]] %||% if (is.null(content_counts)) 1L else 0L
      content_slides <- content_slides + as.integer(count)
    }
  }
  page_list
}

#' Insert one placeholder from the page list
#' @noRd
append_placeholder <- function(doc, doc_o, placeholder, types, layouts, metadata) {
  fn <- types[[placeholder$type]]$fn
  fn_args <- names(formals(fn))

  control_keys <- c("type", "name", "program", "suffix", "to_page")
  forwarded <- placeholder[setdiff(names(placeholder), control_keys)]
  call_args <- forwarded[names(forwarded) %in% fn_args]

  call_args$doc_o <- doc_o
  call_args$doc_original <- doc
  call_args$to_page <- placeholder$to_page
  call_args$save_file <- FALSE
  if ("layouts" %in% fn_args) {
    call_args$layouts <- layouts
  }
  if ("metadata" %in% fn_args && !is.null(metadata)) {
    call_args$metadata <- metadata
  }
  do.call(fn, call_args)
}

#' Place placeholder slides by their order in a speclayout
#'
#' Inserts the placeholder entries of a speclayout (those with a `type:`, such
#' as `section` or `custom`) into an already generated deck, at pages derived
#' from their position among the TLG entries. No page numbers need to be typed.
#'
#' The deck at `doc_o` must hold exactly the TLG slides of the speclayout, in
#' order (the shipped `basic.pptx` theme has one empty slide; remove it or
#' include it in `content_counts`).
#'
#' @param doc_o Path to the `.pptx` holding the generated TLG slides.
#' @param speclayout A named, ordered `list` read from a speclayout yaml file,
#'   with placeholder entries between the TLG entries.
#' @param content_counts Optional slides per TLG entry, see
#'   [derive_placeholder_page_list()].
#' @param doc_original An optional `officer::rpptx` object. If `NULL`, the deck
#'   is read from `doc_o`.
#' @param save_file If `TRUE`, the finished deck is written next to `doc_o`.
#' @param layouts The role lookup, see [placeholder_layouts()].
#' @param types The placeholder types, see [placeholder_types()].
#' @param metadata Optional named `list` of values for `{token}`s, passed to
#'   placeholder functions that accept `metadata`.
#'
#' @return The `officer::rpptx` object with the placeholder slides inserted.
#'
#' @export
#'
#' @examples
#' deck <- officer::read_pptx(system.file("theme/basic.pptx", package = "autoslider.core"))
#' deck <- officer::remove_slide(deck, index = 1)
#' for (i in 1:2) {
#'   deck <- officer::add_slide(deck, layout = "Title and Content", master = "Office Theme")
#' }
#' content <- tempfile(fileext = ".pptx")
#' print(deck, content)
#'
#' speclayout <- list(
#'   sec_dm = list(type = "section", title = "Demographics", subtitle = "{study}"),
#'   t_dm_slide_FAS = list(program = "t_dm_slide", suffix = "FAS"),
#'   sec_ae = list(type = "section", title = "Adverse Events"),
#'   t_ae_slide_SE = list(program = "t_ae_slide", suffix = "SE")
#' )
#' doc <- place_speclayout_placeholders(content, speclayout, metadata = list(study = "BP12345"))
#' length(doc)
#' @md
place_speclayout_placeholders <- function(doc_o,
                                          speclayout,
                                          content_counts = NULL,
                                          doc_original = NULL,
                                          save_file = FALSE,
                                          layouts = placeholder_layouts(),
                                          types = placeholder_types(),
                                          metadata = NULL) {
  assert_that(is.string(doc_o))
  assert_that(has_entry_names(speclayout, unique = FALSE))
  assert_that(is.flag(save_file), noNA(save_file))

  doc <- initialize_doc_original(doc_original, doc_o)
  page_list <- derive_placeholder_page_list(speclayout, content_counts, types = types)

  # Check every layout the placeholders need before inserting any slide.
  needed_roles <- unique(unlist(lapply(page_list, function(p) types[[p$type]]$roles)))
  if (length(needed_roles) > 0) {
    validate_placeholder_layouts(doc, roles = needed_roles, layouts = layouts)
  }
  for (p in page_list) {
    if (identical(p$type, "custom")) {
      validate_custom_placeholder(doc, p$layout, p$master, p$placeholders %||% list(), name = p$name)
    }
  }

  for (placeholder in page_list) {
    doc <- append_placeholder(doc, doc_o, placeholder, types = types, layouts = layouts, metadata = metadata)
  }

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

confidential_footnote <- "Confidential and for internal use only"
default_footer_font_size <- 8L

make_footnote_value <- function(value, font_size = NULL) {
  if (is.null(font_size)) {
    return(as_paragraph(value))
  }

  assertthat::assert_that(
    is.numeric(font_size),
    length(font_size) == 1,
    !is.na(font_size)
  )
  as_paragraph(as_chunk(value, props = fp_text(font.size = font_size)))
}

#' generate slides based on output
#'
#' @param outputs List of output
#' @param template Template file path
#' @param outfile Out file path
#' @param fig_width,fig_height Figure width and height in inches. They set the
#'   figure's shape: the figure is scaled, keeping that shape, to fill the free
#'   area of the slide (below the title, above any footer the slide writes)
#'   inside a margin of `fig_margin`, and centered there. Text in the plot keeps
#'   its point size, because the plot is drawn at the scaled size.
#' @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.
#'    Defaults to `NULL`, which auto-fits the table to the slide height (for rtables,
#'    via [rtables::paginate_table()]; for gtsummary, via a row-height estimate).
#'    Overridden for an individual slide by an \code{lpp} field on its spec entry.
#' @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.
#'    Only honored for rtables output; gtsummary tables do not support column
#'    pagination and are instead scaled down to fit when too wide. Explicitly
#'    setting `t_cpp` also raises a warning for gtsummary tables that need scaling,
#'    since column pagination was requested but cannot be applied.
#'    Overridden for an individual slide by a \code{cpp} field on its spec entry.
#' @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.
#'    Overridden for an individual slide by an \code{lpp} field on its spec entry.
#' @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.
#'    Overridden for an individual slide by a \code{cpp} field on its spec entry.
#' @param fig_editable whether we want the figure to be editable in pptx viewers, defaults to FALSE
#' @param fig_margin Margin in inches kept free on every side of a figure, to
#'   the slide edges and to the title and footer.
#' @param fig_format Image format for figures that are not editable: `"svg"`
#'   (the default) or `"png"`. PNG shows in every viewer, including Google
#'   Slides, which does not display SVG.
#' @param fig_dpi Resolution of PNG figures.
#' @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()]. The footer defaults to
#'   the body size, or 8 pt when no body size is supplied; 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.
#' When no footer size is supplied, the resolved body size is used, falling back
#' to 8 pt. This default is applied to the Confidential footnote on every
#' supported slide path, including `decor = FALSE`.
#'
#' \subsection{Per-slide pagination}{
#' Pagination density is resolved the same way. A spec entry may carry an
#' optional \code{lpp} (lines per page) and \code{cpp} (columns per page). When
#' present they override the deck-wide \code{t_lpp}/\code{t_cpp} (tables) or
#' \code{l_lpp}/\code{l_cpp} (listings) for that slide only, so a short
#' demographics table and a long adverse-event table can use different
#' densities in the same deck:
#' \preformatted{
#' t_dm_slide_FAS:
#'   program: t_dm_slide
#'   suffix: FAS
#'   lpp: 30
#'   cpp: 180
#' }
#' Entries without these fields keep the deck-wide value. Each must be a single
#' positive whole number; anything else is an error naming the offending entry.
#'
#' Note that pagination for \code{gtsummary} tables is recomputed from the
#' slide height, so a spec \code{lpp} does not change their pagination.
#' }
#' @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()
#' @md
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 = NULL, t_cpp = 200,
                            l_lpp = 20, l_cpp = 150, fig_editable = FALSE,
                            font_size = NULL, fig_margin = 0.25, fig_format = c("svg", "png"),
                            fig_dpi = 300, ...) {
  fig_format <- match.arg(fig_format)
  assertthat::assert_that(assertthat::is.number(fig_margin), fig_margin >= 0)
  assertthat::assert_that(assertthat::is.count(fig_dpi))
  # gtsummary tables don't support column pagination; only warn about a too-wide
  # table when the caller explicitly asked for column pagination via `t_cpp`,
  # not for the default value (which is otherwise always forwarded).
  t_cpp_explicit <- !missing(t_cpp)

  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_footnote)
    )
  } 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"),
    # a program that failed in generate_outputs(); reported and skipped below,
    # as it already is when it arrives inside a list
    inherits(outputs, "autoslider_error")
  ))) {
    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
  # `lpp`/`cpp` are resolved per slide (see slide_pag()) and injected into
  # to_flextable(); forwarding them as well gives "formal argument matched by
  # multiple actual arguments". A study script that passes every spec key to
  # generate_slides() hits this as soon as an entry sets `lpp:`.
  call_lpp <- dots$lpp
  call_cpp <- dots$cpp
  fwd$lpp <- NULL
  fwd$cpp <- 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 pagination for a slide: the spec entry's `lpp`/`cpp` when set,
  # otherwise the deck-wide argument. Like the font sizes above, the slide wins.
  # Only spec-supplied values are validated: the arguments keep whatever
  # behaviour they had before, so existing callers are unaffected.
  # An `lpp`/`cpp` passed directly to generate_slides() sits between the two.
  slide_pag <- function(x, lpp, cpp) {
    sp <- attr(x, "spec")
    pick <- function(spec_val, call_val, default, what) {
      if (!is.null(spec_val)) {
        assert_is_valid_pagination(spec_val, what, sp$output)
      } else if (!is.null(call_val)) {
        assert_is_valid_pagination(call_val, what, sp$output)
      } else {
        default
      }
    }
    list(
      lpp = pick(sp$lpp, call_lpp, lpp, "lpp"),
      cpp = pick(sp$cpp, call_cpp, cpp, "cpp")
    )
  }
  resolve_font_sizes <- function(x) {
    fs <- slide_fs(x)
    fs$footer <- fs$footer %||% fs$body %||% default_footer_font_size
    fs
  }
  resolve_footer_font_size <- function(x) {
    resolve_font_sizes(x)$footer
  }
  # 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 <- resolve_font_sizes(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 <- resolve_footer_font_size(x)
      pag <- slide_pag(x, t_lpp, t_cpp)
      y <- call_ft(x, list(lpp = pag$lpp, cpp = pag$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")) {
      footer_pt <- resolve_footer_font_size(x)
      pag <- slide_pag(x, l_lpp, l_cpp)
      y <- call_ft(x, list(cpp = pag$cpp, lpp = pag$lpp))
      for (tt in y) {
        call_slide(tt, list(
          table_loc = center_table_loc(tt$ft, ppt_width = width, ppt_height = height),
          footer_font_size = footer_pt
        ))
      }
    } else if (inherits(x, "data.frame")) { # this is dedicated for small data frames without pagination
      tf <- resolve_format(x, orange_format)
      footer_pt <- resolve_footer_font_size(x)
      y <- call_ft(x, list(table_format = tf))
      call_slide(y, list(decor = FALSE, footer_font_size = footer_pt))
    } else if (inherits(x, "dgtsummary")) {
      tf <- resolve_format(x, autoslider_format)
      footer_pt <- resolve_footer_font_size(x)
      # The `lpp` value is supplied here; `to_flextable.dgtsummary()` currently
      # recomputes `lpp` from `ppt_height`, so a per-slide `lpp` only takes effect
      # once #121 (gtsummary ignores t_lpp) is fixed. gtsummary has no column
      # pagination, so only forward `cpp` when it was explicitly requested -- via
      # the slide's spec `cpp`, or a deck-wide `t_cpp` -- to avoid warning on the
      # default.
      sp <- attr(x, "spec")
      lpp_val <- slide_pag(x, t_lpp, t_cpp)$lpp
      cpp_val <- if (!is.null(sp$cpp) || !is.null(call_cpp)) {
        slide_pag(x, t_lpp, t_cpp)$cpp
      } else if (t_cpp_explicit) {
        t_cpp
      } else {
        NULL
      }
      y <- call_ft(x, list(
        lpp = lpp_val, cpp = cpp_val,
        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)
      footer_pt <- resolve_footer_font_size(x)
      y <- call_ft(x, list(table_format = tf))
      call_slide(y, list(decor = FALSE, footer_font_size = footer_pt))
    } 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,
          fig_editable = fig_editable, fig_margin = fig_margin,
          fig_format = fig_format, fig_dpi = fig_dpi, ...
        )
      } 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 Point size for the footnote text, defaulting to 8.
#'   `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 = 8L, ...) {
  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 <- make_footnote_value(content$footnotes, footer_font_size)
      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 = make_footnote_value(confidential_footnote, footer_font_size),
      ref_symbols = " ", part = "header", inline = TRUE
    )
  }
  # `footnote(inline = TRUE)` adds its own "; " separator chunk with no font size,
  # so it falls back to the table default (e.g. 11pt) next to the smaller note.
  # Sizing the whole footer part keeps every footnote chunk at the same size.
  if (!is.null(footer_font_size) && flextable::nrow_part(out, "footer") > 0) {
    out <- fontsize(out, size = footer_font_size, part = "footer")
  }

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

#' Fit a figure into the free area of a slide
#'
#' Works out where a figure goes on a slide of `layout`: the free area is the
#' slide inside a margin of `margin` on every side, below the title (and any
#' other placeholder in the top half of the slide that the slide writes, such as
#' a subtitle) and above any placeholder it writes in the bottom half (such as a
#' footer), again with `margin` in between. The figure is scaled to the largest
#' size with the shape of `fig_width` x `fig_height` that fits, and centered in
#' that area. This keeps figures inside the slide, clear of the title, with even
#' margins, whatever the template's size and layout.
#'
#' @param ppt An `officer::rpptx` object.
#' @param layout,master The layout the figure's slide uses.
#' @param fig_width,fig_height The figure's shape (only their ratio matters).
#' @param margin Margin in inches.
#' @param targets Locations of other content written on the slide (officer
#'   `location_type` or `location_label` objects). The title placeholder always
#'   counts.
#'
#' @return A `list` with the figure's `width` and `height` in inches and an
#'   officer `location` for it.
#'
#' @keywords internal
#' @md
figure_fit <- function(ppt, layout, master, fig_width, fig_height, margin = 0.25, targets = list()) {
  size <- officer::slide_size(ppt)
  props <- officer::layout_properties(ppt, layout = layout, master = master)
  props <- props[!is.na(props$offy) & !is.na(props$cy), , drop = FALSE]

  used <- props$type %in% c("title", "ctrTitle")
  for (loc in targets) {
    if (inherits(loc, "location_type")) {
      used <- used | props$type %in% loc$type
    } else if (inherits(loc, "location_label")) {
      used <- used | props$ph_label %in% loc$ph_label
    }
  }
  used <- props[used, , drop = FALSE]
  header <- used[used$offy + used$cy / 2 < size$height / 2, , drop = FALSE]
  footer <- used[used$offy + used$cy / 2 >= size$height / 2, , drop = FALSE]

  top <- max(c(0, header$offy + header$cy)) + margin
  bottom <- min(c(size$height, footer$offy)) - margin
  left <- margin
  right <- size$width - margin
  if (bottom - top < size$height / 4) {
    # The placeholders leave almost no room (an unusual layout): use the whole
    # slide rather than squeezing the figure.
    top <- margin
    bottom <- size$height - margin
  }

  scale <- min((right - left) / fig_width, (bottom - top) / fig_height)
  width <- fig_width * scale
  height <- fig_height * scale
  list(
    width = width,
    height = height,
    location = officer::ph_location(
      left = left + (right - left - width) / 2,
      top = top + (bottom - top - height) / 2,
      width = width,
      height = height
    )
  )
}

#' 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
#' @param fig_format `"svg"` (the default) or `"png"`.
#' @param fig_dpi Resolution of a PNG figure.
#' @return Location for a placeholder
#' @export
#' @md
ph_with_img <- function(ppt, figure, fig_width, fig_height, figure_loc, fig_format = "svg", fig_dpi = 300) {
  file_name <- tempfile(fileext = paste0(".", fig_format))
  if (identical(fig_format, "png")) {
    grDevices::png(filename = file_name, width = fig_width, height = fig_height, units = "in", res = fig_dpi)
  } else {
    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. `NULL` (the default) fits the
#'   figure into the free area of the slide, see [figure_fit()].
#' @param layout theme layout
#' @param fig_editable whether we want the figure to be editable in pptx viewers
#' @param fig_margin,fig_format,fig_dpi See [generate_slides()].
#' @param ... arguments passed to program
#'
#' @return slide with the added content
#' @md
figure_to_slide <- function(ppt, content,
                            decor = TRUE,
                            fig_width,
                            fig_height,
                            layout = "Title and Content",
                            figure_loc = NULL,
                            fig_editable = FALSE,
                            fig_margin = 0.25,
                            fig_format = "svg",
                            fig_dpi = 300,
                            ...) {
  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")
    )
  }

  # Where the image goes: a given `figure_loc` at the given size, or fitted into
  # the area the slide leaves free (title and other placeholders written below).
  fit <- if (is.null(figure_loc)) {
    targets <- lapply(args[vapply(args, function(a) is.list(a) && !is.null(a$location), logical(1))], `[[`, "location")
    figure_fit(ppt, layout, ppt_master, fig_width, fig_height, fig_margin, targets)
  } else {
    list(width = fig_width, height = fig_height, location = figure_loc)
  }
  add_image <- function(ppt, figure) {
    # Pass the format only when it is not the default, so a study's own
    # ph_with_img() replacement with the older five-argument form still works.
    if (identical(fig_format, "svg")) {
      ph_with_img(ppt, figure, fit$width, fit$height, fit$location)
    } else {
      ph_with_img(ppt, figure, fit$width, fit$height, fit$location, fig_format = fig_format, fig_dpi = fig_dpi)
    }
  }

  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 <- add_image(ppt, content)
    }

    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 <- add_image(ppt, figure)
    }
    ppt
  } else {
    stop("Should not reach here")
  }
}

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

  # A template can exist in both autoslideR and autoslider.core (e.g. `t_mh_slide`). `file_list`
  # lists the requested package first, so take the first match: its own template takes
  # precedence over the core one. Without this, `file.copy()` got two `from` files and errored.
  template_file <- file_list[basename(file_list) == paste0(template, ".R")][1]


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

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

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

#' 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. If `NULL` (the default), auto-computed
#'   from `ppt_height`, falling back to a fixed default if that is also `NULL`.
#'   An explicit value always takes precedence over `ppt_height`.
#' @param cpp Columns per page. gtsummary tables do not support column
#'   pagination; this is accepted only so that a warning can be raised when
#'   the table is too wide for `ppt_width` and would otherwise be silently
#'   scaled down instead of split.
#' @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 = NULL, cpp = NULL, ppt_height = NULL, ppt_width = NULL,
                                    table_format = autoslider_format, ...) {
  ft_full <- gtsummary::as_flex_table(x) |> table_format()

  gts_title_reserve_in <- 1.5  # inches reserved above the table for the slide title
  gts_row_height_fudge <- 1.3  # flextable stores "atleast" row heights; padding
                                # expands rendered rows beyond this stored minimum
  gts_default_lpp <- 20L       # fallback when neither lpp nor ppt_height is supplied

  total_width <- flextable_dim(ft_full)$widths

  if (!is.null(ppt_width) && total_width > ppt_width) {
    if (!is.null(cpp)) {
      warning(
        "gtsummary tables do not support column pagination (`t_cpp`/`cpp` is ignored); ",
        "columns are scaled down to fit the slide width instead.",
        call. = FALSE
      )
    }
    ft_full <- width(ft_full, width = dim(ft_full)$widths * ppt_width / total_width)
  }

  if (is.null(lpp)) {
    lpp <- if (!is.null(ppt_height)) {
      header_height <- sum(ft_full$header$rowheights)
      available_body <- ppt_height - gts_title_reserve_in - header_height
      row_heights_est <- ft_full$body$rowheights * gts_row_height_fudge
      max(sum(cumsum(row_heights_est) <= available_body), 1L)
    } else {
      gts_default_lpp
    }
  }

  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) {
  assertthat::assert_that(inherits(lsting, "listing_df"))
  assertthat::assert_that(
    is.null(colwidths) ||
      (is.numeric(colwidths) && all(colwidths >= 0) &&
        length(colwidths) == length(rlistings::listing_dispcols(lsting)))
  )
  assertthat::assert_that(assertthat::is.flag(tf_wrap))
  assertthat::assert_that(is.null(max_width) || (assertthat::is.number(max_width) && max_width >= 0))
  assertthat::assert_that(assertthat::is.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)
}

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

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

#' 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. Additional arguments supplied when the returned
#' function is called are forwarded to the underlying formatter. 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, ...) {
    args <- list(...)
    overridden <- intersect(names(args), names(sizes))
    if (length(overridden) > 0) {
      args[overridden] <- NULL
    }
    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), args, keep))
  }
}

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

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

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

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

assert_is_valid_pagination <- function(x, field, output = NULL) {
  # `is.finite()` covers NA, NaN and both infinities in one go, and `x %% 1`
  # avoids as.integer(), which turns a value beyond .Machine$integer.max into
  # NA and would land the comparison in `if (NA)` instead of reporting it.
  if (length(x) != 1L || !is.numeric(x) || !is.finite(x) || x < 1 || x %% 1 != 0) {
    abort(
      "`", field, "`",
      if (is.null(output)) "" else paste0(" in spec entry '", output, "'"),
      " must be a single positive whole number but is `", deparse(x), "`."
    )
  }
  x
}

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

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

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


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

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

#' Plot mean values of 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, ...
  )
}

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

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

#' 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) {
  assertthat::assert_that(is.character(text))
  assertthat::assert_that(is.null(metadata) || is.list(metadata))

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

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

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

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

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

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

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
}

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

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

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

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

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

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

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

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

  x_form
}

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

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

1		#' Medical history table
2		#'
3		#' Summarize medical history by system organ class (SOC) and preferred term
4		#' (PT). ADSL defines both the analysis population and the treatment
5		#' denominators. ADMH records for subjects not present in ADSL are excluded,
6		#' and treatment is derived from ADSL. If ADMH also contains `arm`, its
7		#' non-missing values must agree with ADSL for the same subject.
8		#'
9		#' Counts for the overall table and each SOC include the number and percentage
10		#' of unique subjects with at least one condition and, on a separate row, the
11		#' non-unique number of condition records. PT rows contain unique subject
12		#' counts and percentages. SOCs and PTs are sorted by decreasing total unique
13		#' subject count, with labels used to break ties deterministically. Missing or
14		#' blank SOC and PT values are displayed as `<Missing>`.
15		#'
16		#' @param adsl Subject-level analysis dataset. It must contain one row per
17		#' non-missing `USUBJID` and the treatment variable named by `arm`.
18		#' @param admh Medical history analysis dataset. It must contain `USUBJID`,
19		#' `MHBODSYS`, and `MHDECOD`.
20		#' @param arm Name of the treatment variable in `adsl`, character scalar;
21		#' `"TRT01A"` by default.
22		#' @param add_all_patients_col Logical scalar indicating whether an additional
23		#' `All Patients` column is displayed.
24		#'
25		#' @return An `rtables::VTableTree` object.
26		#' @md
27		#' @inherit gen_notes note
28		#' @export
29		#'
30		#' @references
31		#' The table structure follows the public MHT01 example in the
32		#' [TLG Catalog](https://insightsengineering.github.io/tlg-catalog/stable/tables/medical-history/mht01.html).
33		#'
34		#' @examples
35		#' library(dplyr)
36		#' adsl <- eg_adsl %>%
37		#' dplyr::mutate(TRT01A = factor(TRT01A))
38		#' admh <- eg_admh
39		#'
40		#' out <- t_mh_slide(adsl, admh)
41		#' print(out)
42		#'
43		#' out_without_overall <- t_mh_slide(
44		#' adsl,
45		#' admh,
46		#' add_all_patients_col = FALSE
47		#' )
48		t_mh_slide <- function(adsl, admh, arm = "TRT01A", add_all_patients_col = TRUE) {
49	28x	assertthat::assert_that(is.data.frame(adsl), msg = "`adsl` must be a data frame")
50	28x	assertthat::assert_that(is.data.frame(admh), msg = "`admh` must be a data frame")
51	28x	assertthat::assert_that(
52	28x	is.character(arm) && length(arm) == 1L && !is.na(arm) && nzchar(arm),
53	28x	msg = "`arm` must be a non-missing character scalar"
54		)
55	28x	assertthat::assert_that(
56	28x	assertthat::is.flag(add_all_patients_col),
57	28x	msg = "`add_all_patients_col` must be TRUE or FALSE"
58		)
59
60	28x	required_adsl <- c("USUBJID", arm)
61	28x	required_admh <- c("USUBJID", "MHBODSYS", "MHDECOD")
62	28x	assertthat::assert_that(
63	28x	all(required_adsl %in% names(adsl)),
64	28x	msg = paste("`adsl` must contain:", paste(required_adsl, collapse = ", "))
65		)
66	26x	assertthat::assert_that(
67	26x	all(required_admh %in% names(admh)),
68	26x	msg = paste("`admh` must contain:", paste(required_admh, collapse = ", "))
69		)
70
71	24x	adsl_ids <- as.character(adsl$USUBJID)
72	24x	assertthat::assert_that(
73	24x	!any(is.na(adsl_ids) \| trimws(adsl_ids) == ""),
74	24x	msg = "`adsl$USUBJID` must not contain missing or blank values"
75		)
76	23x	assertthat::assert_that(
77	23x	!anyDuplicated(adsl_ids),
78	23x	msg = "`adsl` must contain at most one row per `USUBJID`"
79		)
80	22x	assertthat::assert_that(
81	22x	!any(is.na(adsl[[arm]]) \| trimws(as.character(adsl[[arm]])) == ""),
82	22x	msg = paste0("`adsl$", arm, "` must not contain missing or blank values")
83		)
84
85	22x	population <- adsl[, c("USUBJID", arm), drop = FALSE]
86	22x	population$USUBJID <- as.character(population$USUBJID)
87	22x	if (!is.factor(population[[arm]])) {
88	2x	population[[arm]] <- factor(population[[arm]])
89		}
90	22x	in_population <- as.character(admh$USUBJID) %in% population$USUBJID
91	22x	analysis_source <- admh[in_population, , drop = FALSE]
92	22x	analysis_source$USUBJID <- as.character(analysis_source$USUBJID)
93
94	22x	if (arm %in% names(analysis_source)) {
95	5x	expected_arm <- population[[arm]][match(as.character(analysis_source$USUBJID), population$USUBJID)]
96	5x	supplied_arm <- analysis_source[[arm]]
97	5x	supplied <- !is.na(supplied_arm) & trimws(as.character(supplied_arm)) != ""
98	5x	conflicts <- supplied & as.character(supplied_arm) != as.character(expected_arm)
99	5x	assertthat::assert_that(
100	5x	!any(conflicts),
101	5x	msg = paste0("Non-missing `admh$", arm, "` values must agree with `adsl$", arm, "`")
102		)
103	4x	analysis_source[[arm]] <- NULL
104		}
105
106	21x	analysis <- dplyr::left_join(
107	21x	analysis_source,
108	21x	population,
109	21x	by = "USUBJID"
110		)
111
112	21x	normalize_term <- function(x) {
113	84x	out <- trimws(as.character(x))
114	84x	out[is.na(out) \| out == ""] <- "<Missing>"
115	84x	out
116		}
117	21x	analysis$MHBODSYS <- factor(
118	21x	normalize_term(analysis$MHBODSYS),
119	21x	levels = sort(unique(normalize_term(analysis$MHBODSYS)))
120		)
121	21x	analysis$MHDECOD <- factor(
122	21x	normalize_term(analysis$MHDECOD),
123	21x	levels = sort(unique(normalize_term(analysis$MHDECOD)))
124		)
125	21x	analysis <- formatters::var_relabel(
126	21x	analysis,
127	21x	MHBODSYS = "MedDRA System Organ Class",
128	21x	MHDECOD = "MedDRA Preferred Term"
129		)
130
131	21x	if (nrow(analysis) == 0L) {
132	2x	result <- autoslider.core::null_report()
133	2x	result@main_title <- "Medical History"
134	2x	return(result)
135		}
136
137	19x	layout <- rtables::basic_table(show_colcounts = TRUE)
138	19x	layout <- rtables::split_cols_by(layout, arm)
139	19x	if (add_all_patients_col) {
140	16x	layout <- rtables::add_overall_col(layout, "All Patients")
141		}
142	18x	layout <- tern::analyze_num_patients(
143	18x	layout,
144	18x	"USUBJID",
145	18x	.stats = c("unique", "nonunique"),
146	18x	.labels = c(
147	18x	unique = "Total number of patients with at least one condition",
148	18x	nonunique = "Total number of conditions"
149		)
150		)
151	18x	layout <- rtables::split_rows_by(
152	18x	layout,
153	18x	var = "MHBODSYS",
154	18x	split_fun = rtables::drop_split_levels,
155	18x	child_labels = "visible",
156	18x	label_pos = "topleft",
157	18x	split_label = formatters::obj_label(analysis$MHBODSYS)
158		)
159	18x	layout <- tern::summarize_num_patients(
160	18x	layout,
161	18x	"USUBJID",
162	18x	.stats = c("unique", "nonunique"),
163	18x	.labels = c(
164	18x	unique = "Total number of patients with at least one condition",
165	18x	nonunique = "Total number of conditions"
166		)
167		)
168	18x	layout <- tern::count_occurrences(layout, vars = "MHDECOD", .indent_mods = -1L)
169	18x	layout <- tern::append_varlabels(analysis, "MHDECOD", indent = 1L, lyt = layout)
170
171	18x	result <- rtables::build_table(layout, df = analysis, alt_counts_df = population)
172	18x	result <- rtables::prune_table(result)
173	18x	result <- rtables::sort_at_path(
174	18x	result,
175	18x	path = c("MHBODSYS"),
176	18x	scorefun = rtables::cont_n_allcols,
177	18x	decreasing = TRUE
178		)
179	18x	result <- rtables::sort_at_path(
180	18x	result,
181	18x	path = c("MHBODSYS", "*", "MHDECOD"),
182	18x	scorefun = tern::score_occurrences,
183	18x	decreasing = TRUE
184		)
185	18x	result@main_title <- "Medical History"
186	18x	result
187		}

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

1		# Copy slide layouts between PowerPoint templates
2		# ------------------------------------------------------------------------------
3		# A study theme often ships only its content layout, while placeholder pages
4		# (cover, section dividers) use layouts from another template. officer can only
5		# add slides on layouts that exist in the deck it writes and cannot copy layouts
6		# between presentations, so `import_layouts()` edits the package XML directly to
7		# build a mixed template.
8
9		pptx_ns <- c(
10		p = "http://schemas.openxmlformats.org/presentationml/2006/main",
11		r = "http://schemas.openxmlformats.org/officeDocument/2006/relationships",
12		pr = "http://schemas.openxmlformats.org/package/2006/relationships",
13		a = "http://schemas.openxmlformats.org/drawingml/2006/main",
14		ct = "http://schemas.openxmlformats.org/package/2006/content-types"
15		)
16
17		#' Import slide layouts from another PowerPoint template
18		#'
19		#' Copies one or more slide layouts, together with the images they use, from
20		#' `source` into `target` and writes the result to `outfile`. This builds a
21		#' mixed template: content slides keep the study theme's own layouts, and
22		#' placeholder pages can use layouts that only exist in another template, such
23		#' as a corporate theme with cover and divider layouts.
24		#'
25		#' Each imported layout is attached to the master in `target` with the same
26		#' name as its master in `source`, or to `master` when given. The layout keeps its own shapes, placeholders and
27		#' images; theme colors and fonts come from the target master. Layouts that
28		#' `target` already has are skipped, so the call is safe to repeat.
29		#'
30		#' Masters are not copied: a layout whose master is missing from `target`
31		#' raises an error unless `master` names a master that `target` does have.
32		#'
33		#' @param target Path to the template to extend (it is not modified).
34		#' @param source Path to the template holding the layouts to copy.
35		#' @param layouts Character vector of layout names to copy from `source`.
36		#' @param outfile Path of the `.pptx` to write. Defaults to a temporary file.
37		#' @param master Optional name of the master in `target` to attach the layouts
38		#' to. By default each layout goes to the target master with the same name as
39		#' its source master.
40		#'
41		#' @return The path to `outfile`, invisibly.
42		#'
43		#' @seealso [place_speclayout_placeholders()]
44		#'
45		#' @export
46		#'
47		#' @examples
48		#' \donttest{
49		#' # officer's default template lacks the "Content with Caption" layout that
50		#' # autoslider.core's basic.pptx has; both use the "Office Theme" master.
51		#' mixed <- import_layouts(
52		#' target = system.file("template/template.pptx", package = "officer"),
53		#' source = system.file("theme/basic.pptx", package = "autoslider.core"),
54		#' layouts = "Content with Caption"
55		#' )
56		#' officer::layout_summary(officer::read_pptx(mixed))
57		#' }
58		#' @md
59		import_layouts <- function(target, source, layouts, outfile = tempfile(fileext = ".pptx"), master = NULL) {
60	6x	assert_that(is.string(target), is.readable(target), has_extension(target, "pptx"))
61	6x	assert_that(is.string(source), is.readable(source), has_extension(source, "pptx"))
62	6x	assert_that(is.character(layouts), length(layouts) > 0, noNA(layouts))
63	6x	assert_that(!anyDuplicated(layouts), msg = "`layouts` must not repeat a layout name.")
64	6x	assert_that(is.string(outfile), has_extension(outfile, "pptx"), is.writeable(dirname(outfile)))
65	6x	assert_that(is.null(master) \|\| is.string(master), msg = "`master` must be NULL or a single string.")
66
67	6x	src <- tempfile("pptx_src_")
68	6x	dst <- tempfile("pptx_dst_")
69	6x	on.exit(unlink(c(src, dst), recursive = TRUE), add = TRUE)
70	6x	utils::unzip(source, exdir = src)
71	6x	utils::unzip(target, exdir = dst)
72
73	6x	src_layouts <- pptx_part_names(src, "slideLayouts", "/p:sldLayout/p:cSld")
74	6x	dst_layouts <- pptx_part_names(dst, "slideLayouts", "/p:sldLayout/p:cSld")
75	6x	dst_masters <- pptx_master_names(dst)
76
77	6x	missing <- setdiff(layouts, names(src_layouts))
78	6x	if (length(missing)) {
79	1x	stop(
80	1x	"Layout(s) ", paste0("\"", missing, "\"", collapse = ", "), " not found in `source`. Available: ",
81	1x	paste0("\"", names(src_layouts), "\"", collapse = ", "), ".",
82	1x	call. = FALSE
83		)
84		}
85	5x	present <- intersect(layouts, names(dst_layouts))
86	5x	if (length(present)) {
87	1x	message("Already in `target`, not imported: ", paste(present, collapse = ", "))
88		}
89
90	5x	ct_file <- file.path(dst, "[Content_Types].xml")
91	5x	ct_doc <- xml2::read_xml(ct_file)
92	5x	src_ct <- xml2::read_xml(file.path(src, "[Content_Types].xml"))
93
94	5x	for (lay in setdiff(layouts, present)) {
95	4x	dst_master <- pptx_target_master(src, src_layouts[[lay]], dst_masters, master, lay)
96	3x	import_one_layout(src, dst, src_layouts[[lay]], dst_master, ct_doc, src_ct)
97		}
98	4x	xml2::write_xml(ct_doc, ct_file)
99
100	4x	pptx_zip_dir(dst, outfile)
101	4x	invisible(outfile)
102		}
103
104		#' Map part names to their `name` attribute for one part folder
105		#'
106		#' @return A named character vector: names are layout/master names, values are
107		#' package-relative part paths (e.g. `ppt/slideLayouts/slideLayout4.xml`).
108		#'
109		#' @noRd
110		pptx_part_names <- function(dir, sub, xpath) {
111	12x	files <- list.files(file.path(dir, "ppt", sub), pattern = "\\.xml$", full.names = TRUE)
112	12x	nm <- vapply(files, function(f) {
113	112x	xml2::xml_attr(xml2::xml_find_first(xml2::read_xml(f), xpath, pptx_ns), "name")
114	12x	}, character(1))
115	12x	stats::setNames(file.path("ppt", sub, basename(files)), nm)
116		}
117
118		#' Map master names to their parts, named the way officer names them
119		#'
120		#' officer's `layout_summary()` reports a master by the name of the theme it
121		#' uses (`<a:theme name=...>`), not by the master's own `cSld` name, which is
122		#' often empty or a leftover such as "simple-light-2". Use the same rule so
123		#' `master` matches what users see.
124		#'
125		#' @noRd
126		pptx_master_names <- function(dir) {
127	6x	files <- list.files(file.path(dir, "ppt", "slideMasters"), pattern = "\\.xml$", full.names = TRUE)
128	6x	parts <- file.path("ppt", "slideMasters", basename(files))
129	6x	nm <- vapply(parts, function(part) pptx_master_name(dir, part), character(1))
130	6x	stats::setNames(parts, nm)
131		}
132
133		#' officer-style name of one master part
134		#' @noRd
135		pptx_master_name <- function(dir, master_part) {
136	9x	rels <- xml2::read_xml(pptx_rels_path(dir, master_part))
137	9x	rel <- xml2::xml_find_first(rels, "//pr:Relationship[contains(@Type, '/theme')]", pptx_ns)
138	9x	theme <- normalizePath(file.path(dir, dirname(master_part), xml2::xml_attr(rel, "Target")))
139	9x	xml2::xml_attr(xml2::xml_find_first(xml2::read_xml(theme), "/a:theme", pptx_ns), "name")
140		}
141
142		#' Path of the `.rels` file belonging to a package part
143		#' @noRd
144		pptx_rels_path <- function(dir, part) {
145	25x	file.path(dir, dirname(part), "_rels", paste0(basename(part), ".rels"))
146		}
147
148		#' Resolve which target master a source layout attaches to
149		#' @noRd
150		pptx_target_master <- function(src, src_part, dst_masters, master, layout) {
151	4x	rels <- xml2::read_xml(pptx_rels_path(src, src_part))
152	4x	rel <- xml2::xml_find_first(rels, "//pr:Relationship[contains(@Type, '/slideMaster')]", pptx_ns)
153	4x	src_master_part <- file.path("ppt", "slideMasters", basename(xml2::xml_attr(rel, "Target")))
154	4x	want <- master %\|\|% pptx_master_name(src, src_master_part)
155	4x	if (!want %in% names(dst_masters)) {
156	1x	stop(
157	1x	"Layout \"", layout, "\" needs master \"", want, "\", which `target` does not have. ",
158	1x	"Masters in `target`: ", paste0("\"", names(dst_masters), "\"", collapse = ", "),
159	1x	". Set `master` to attach the layout to one of them.",
160	1x	call. = FALSE
161		)
162		}
163	3x	dst_masters[[want]]
164		}
165
166		#' Copy one layout part (and the files it references) into the target package
167		#'
168		#' Modifies the extracted target folder `dst` in place and adds content types to
169		#' `ct_doc` (an xml2 document, modified by reference).
170		#'
171		#' @noRd
172		import_one_layout <- function(src, dst, src_part, dst_master_part, ct_doc, src_ct) {
173	3x	rel_layout <- "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout"
174	3x	layout_ct <- "application/vnd.openxmlformats-officedocument.presentationml.slideLayout+xml"
175
176		# 1. Copy the layout part under the next free slideLayoutN.xml name.
177	3x	existing <- list.files(file.path(dst, "ppt", "slideLayouts"), pattern = "^slideLayout[0-9]+\\.xml$")
178	3x	n_next <- max(c(0L, as.integer(gsub("\\D", "", existing)))) + 1L
179	3x	new_part <- file.path("ppt", "slideLayouts", paste0("slideLayout", n_next, ".xml"))
180	3x	file.copy(file.path(src, src_part), file.path(dst, new_part))
181
182		# 2. Rewrite its relationships: the master link points at the target master,
183		# every other internal file (images, ...) is copied under a unique name so
184		# it cannot overwrite a file of the same name in the target.
185	3x	rels <- xml2::read_xml(pptx_rels_path(src, src_part))
186	3x	prefix <- paste0("imported_", tools::file_path_sans_ext(basename(new_part)), "_")
187	3x	for (rel in xml2::xml_children(rels)) {
188	3x	if (identical(xml2::xml_attr(rel, "TargetMode"), "External")) {
189	!	next
190		}
191	3x	if (grepl("/slideMaster$", xml2::xml_attr(rel, "Type"))) {
192	3x	xml2::xml_set_attr(rel, "Target", paste0("../slideMasters/", basename(dst_master_part)))
193	3x	next
194		}
195	!	from <- normalizePath(file.path(src, dirname(src_part), xml2::xml_attr(rel, "Target")))
196	!	folder <- basename(dirname(from))
197	!	new_name <- paste0(prefix, basename(from))
198	!	dir.create(file.path(dst, "ppt", folder), showWarnings = FALSE)
199	!	file.copy(from, file.path(dst, "ppt", folder, new_name))
200	!	xml2::xml_set_attr(rel, "Target", paste0("../", folder, "/", new_name))
201	!	pptx_ensure_default_ct(ct_doc, src_ct, tools::file_ext(from))
202		}
203	3x	dir.create(dirname(pptx_rels_path(dst, new_part)), showWarnings = FALSE)
204	3x	xml2::write_xml(rels, pptx_rels_path(dst, new_part))
205
206		# 3. Register the layout with the master: a relationship plus a sldLayoutId.
207	3x	m_rels_file <- pptx_rels_path(dst, dst_master_part)
208	3x	m_rels <- xml2::read_xml(m_rels_file)
209	3x	rid_nums <- as.integer(sub("^rId", "", xml2::xml_attr(xml2::xml_children(m_rels), "Id")))
210	3x	rid <- paste0("rId", max(c(0L, rid_nums), na.rm = TRUE) + 1L)
211	3x	xml2::xml_add_child(m_rels, "Relationship",
212	3x	Id = rid, Type = rel_layout, Target = paste0("../slideLayouts/", basename(new_part))
213		)
214	3x	xml2::write_xml(m_rels, m_rels_file)
215
216	3x	m_file <- file.path(dst, dst_master_part)
217	3x	m_doc <- xml2::read_xml(m_file)
218	3x	node <- xml2::xml_add_child(
219	3x	xml2::xml_find_first(m_doc, "//p:sldLayoutIdLst", pptx_ns),
220	3x	"p:sldLayoutId",
221	3x	id = sprintf("%.0f", pptx_max_layout_id(dst) + 1)
222		)
223	3x	xml2::xml_set_attr(node, "r:id", rid)
224	3x	xml2::write_xml(m_doc, m_file)
225
226		# 4. Declare the new part's content type.
227	3x	xml2::xml_add_child(ct_doc, "Override", PartName = paste0("/", new_part), ContentType = layout_ct)
228	3x	invisible(new_part)
229		}
230
231		#' Largest slide master / layout id in an extracted package
232		#'
233		#' Master and layout ids share one number space and must be unique, so a new
234		#' layout takes the largest one plus one.
235		#'
236		#' @noRd
237		pptx_max_layout_id <- function(dir) {
238	3x	masters <- list.files(file.path(dir, "ppt", "slideMasters"), pattern = "\\.xml$", full.names = TRUE)
239	3x	ids <- unlist(lapply(masters, function(m) {
240	3x	xml2::xml_attr(xml2::xml_find_all(xml2::read_xml(m), "//p:sldLayoutId", pptx_ns), "id")
241		}))
242	3x	pres <- xml2::read_xml(file.path(dir, "ppt", "presentation.xml"))
243	3x	ids <- c(ids, xml2::xml_attr(xml2::xml_find_all(pres, "//p:sldMasterId", pptx_ns), "id"))
244	3x	max(as.numeric(ids))
245		}
246
247		#' Make sure the target declares a content type for a file extension
248		#' @noRd
249		pptx_ensure_default_ct <- function(ct_doc, src_ct, ext) {
250		# Extensions are case-insensitive ("png" vs "PNG"), so compare lower-cased.
251	!	lower <- "translate(@Extension, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')"
252	!	xpath <- sprintf("//ct:Default[%s='%s']", lower, tolower(ext))
253	!	if (length(xml2::xml_find_all(ct_doc, xpath, pptx_ns))) {
254	!	return(invisible(ct_doc))
255		}
256	!	def <- xml2::xml_find_first(src_ct, xpath, pptx_ns)
257	!	if (!inherits(def, "xml_missing")) {
258	!	xml2::xml_add_child(ct_doc, def, .where = 0)
259		}
260	!	invisible(ct_doc)
261		}
262
263		#' Zip an extracted package folder back into a .pptx
264		#'
265		#' Uses the `zip` package (no external zip program needed) and writes
266		#' `[Content_Types].xml` first, as Office expects.
267		#'
268		#' @noRd
269		pptx_zip_dir <- function(dir, outfile) {
270	4x	files <- list.files(dir, recursive = TRUE, all.files = TRUE, no.. = TRUE)
271	4x	files <- c("[Content_Types].xml", setdiff(files, "[Content_Types].xml"))
272	4x	out_abs <- file.path(normalizePath(dirname(outfile)), basename(outfile))
273	4x	if (file.exists(out_abs)) {
274	!	unlink(out_abs)
275		}
276	4x	zip::zip(zipfile = out_abs, files = files, root = dir, mode = "mirror")
277	4x	invisible(out_abs)
278		}

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	34x	if (save_file) {
58	5x	doc_dir <- dirname(doc_o)
59	5x	doc_base_name <- tools::file_path_sans_ext(basename(doc_o))
60
61	5x	doc_ext <- tools::file_ext(basename(doc_o))
62	5x	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	5x	outfile_final <- file.path(doc_dir, outfile_name)
66	5x	print(doc, outfile_final)
67		}
68
69	33x	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	41x	if (is.null(doc_original)) {
94	29x	doc_original <- officer::read_pptx(doc_o)
95		}
96	41x	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		#' 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	14x	if (is.character(metadata)) {
48	1x	metadata <- read_metadata(metadata)
49		}
50	14x	spec <- yaml::read_yaml(spec_file, eval.expr = TRUE)
51	14x	spec_obj <- check_and_flattern_suffix(spec, metadata = metadata)
52	14x	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	assertthat::assert_that(is.string(metadata_file), assertthat::is.readable(metadata_file))
82	3x	metadata <- yaml::read_yaml(metadata_file, eval.expr = TRUE)
83	3x	assertthat::assert_that(is.list(metadata), is_named_list(metadata))
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	14x	ret <- lapply(spec, function(s) {
105	677x	lapply(s$suffix, function(su) {
106	713x	entry <- s
107	713x	entry$suffix <- su
108	713x	c(entry, metadata)
109		})
110		})
111	14x	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	9x	if (is.character(substitute(filter_expr))) {
170	!	warn_about_legacy_filtering(filter_expr)
171	!	condition <- bquote(output == .(filter_expr))
172		} else {
173	9x	condition <- substitute(filter_expr)
174		}
175	9x	stopifnot(is_spec(spec), is.language(condition), is.logical(verbose))
176	9x	vars <- all.vars(condition)
177
178	9x	filtered_spec <- Filter(function(output) {
179	475x	assert_exists_in_spec_or_calling_env(vars, output)
180	475x	p <- eval(condition, envir = output)
181	475x	assert_is_valid_filter_result(p)
182	475x	p
183	9x	}, spec)
184
185	9x	if (verbose) {
186	9x	log_number_of_matched_records(spec, filtered_spec, condition)
187		}
188
189	9x	as_spec(filtered_spec)
190		}
191
192		is_spec <- function(x) {
193	9x	"spec" %in% class(x)
194		}
195
196		as_spec <- function(x) {
197	23x	spec <- lapply(x, function(elem) {
198	750x	if (is.null(elem$suffix)) {
199	!	elem$suffix <- ""
200		}
201
202	750x	if (elem$suffix == "") {
203	!	elem$output <- elem$program
204		} else {
205	750x	elem$output <- paste(elem$program, elem$suffix, sep = "_")
206		}
207
208	750x	if (is.null(elem$paper)) {
209	48x	elem$paper <- default_paper_size(elem$program)
210	702x	} else if (elem$paper == "a4r") {
211	!	warn_about_legacy_paper_size("a4r", "L11")
212	!	elem$paper <- "L11"
213	702x	} else if (elem$paper == "a4") {
214	!	warn_about_legacy_paper_size("a4", "P11")
215	!	elem$paper <- "P11"
216		} else {
217	702x	validate_paper_size(elem$paper)
218		}
219
220	750x	elem
221		})
222
223	23x	structure(
224	23x	.Data = spec,
225	23x	names = map_chr(spec, `[[`, "output"),
226	23x	class = union("spec", class(x))
227		)
228		}

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	39x	suffix <- spec$suffix
42	39x	if (verbose_level > 0) {
43	32x	cat_bullet(
44	32x	sprintf(
45	32x	"Running program `%s` with suffix '%s'.",
46	32x	program,
47	32x	suffix
48		),
49	32x	bullet = "pointer",
50	32x	bullet_col = "green"
51		)
52		}
53	39x	func <- tryCatch(
54		{
55	39x	func_wrapper(
56	39x	func = match.fun(program),
57	39x	datasets = datasets,
58	39x	spec = spec,
59	39x	verbose = verbose_level > 1
60		)
61		},
62	39x	error = function(e) {
63	!	info <- error_info(e)
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	39x	if (is(func, "autoslider_error")) {
71	!	return(func)
72		}
73	39x	ret <- tryCatch(
74		{
75	39x	func(...)
76		},
77	39x	error = function(e) {
78	3x	info <- error_info(e)
79	3x	if (verbose_level > 0) {
80	!	cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red")
81		}
82	3x	autoslider_error(info, spec = spec, step = "user program")
83		}
84		)
85	39x	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	9x	lapply(spec, function(s) {
125	37x	args <- c(
126	37x	list(
127	37x	program = s$program,
128	37x	spec = s,
129	37x	datasets = datasets,
130	37x	verbose_level = verbose_level
131		),
132	37x	s$args # ... arguments passed onto the output-generating function
133		)
134	37x	output <- fastDoCall(generate_output, args)
135	37x	attr(output, "spec") <- s
136	37x	output
137		})
138		}
139
140		#' Readable message for a caught error
141		#'
142		#' rlang/cli conditions (e.g. from dplyr/tidyselect) often leave `e$message`
143		#' empty and build the text from bullets, which `conditionMessage()` assembles.
144		#' Falls back to the condition class so the result is never empty.
145		#'
146		#' @param e A condition object.
147		#' @return A non-empty character scalar.
148		#' @noRd
149		error_info <- function(e) {
150	3x	info <- paste(conditionMessage(e), collapse = "\n")
151	3x	if (is.na(info) \|\| !nzchar(trimws(info))) {
152	1x	info <- paste0("Error of class `", class(e)[1], "` with no message.")
153		}
154	3x	info
155		}

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	43x	assert_that(assertthat::is.string(template))
30	43x	assert_that(assertthat::is.string(package))
31	43x	assert_that(assertthat::is.flag(overwrite))
32	43x	assert_that(assertthat::is.flag(open))
33	43x	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	43x	if (!dir.exists(save_path)) {
39	2x	dir.create(save_path, recursive = TRUE)
40		}
41
42	43x	save_path <- file.path(save_path, paste0(function_name, ".R"))
43
44		# Original validation logic for when save_path is provided
45	43x	assertthat::has_extension(save_path, ext = "R")
46	43x	assertthat::is.writeable(save_path \|> dirname())
47
48
49		# Build expected full path
50	43x	expected_path <- file.path(system.file("templates", package = package), template)
51	43x	expected_core_path <- file.path(system.file("templates", package = "autoslider.core"), template)
52
53		# Validation logic
54	43x	valid <- FALSE
55	43x	if (package == "autoslider.core") {
56	41x	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	43x	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	40x	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	39x	if (package == "autoslider.core") {
81	38x	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		# A template can exist in both autoslideR and autoslider.core (e.g. `t_mh_slide`). `file_list`
90		# lists the requested package first, so take the first match: its own template takes
91		# precedence over the core one. Without this, `file.copy()` got two `from` files and errored.
92	39x	template_file <- file_list[basename(file_list) == paste0(template, ".R")][1]
93
94
95	39x	if (file.copy(template_file, save_path, overwrite = TRUE)) {
96	39x	rlang::inform(sprintf("\u2713 File '%s' has been created successfully", save_path))
97	39x	file_lines <- readLines(save_path)
98
99	39x	file_lines <- file_lines[!grepl("^#'", file_lines)]
100	39x	file_lines <- file_lines[nzchar(file_lines)]
101
102		# Replace function name with numbering
103	39x	file_lines <- gsub(tolower(template), function_name, file_lines)
104	39x	writeLines(file_lines, save_path)
105		}
106
107	39x	if (open) {
108	!	file.edit(save_path)
109		}
110
111	39x	invisible(TRUE)
112		}
113
114		#' [EXPERIMENTAL] List All Available Templates
115		#'
116		#' @param package Which package to search for the template files. Defaults to "autoslider.core".
117		#'
118		#' @return A character vector of available template names in the specified package.
119		#'
120		#' @export
121		#'
122		#' @examples
123		#' list_all_templates(package = "autoslider.core")
124		list_all_templates <- function(package = "autoslider.core") {
125	48x	if (package == "autoslideR") {
126	4x	c(
127	4x	get_template_filepath(package = "autoslideR", full.names = TRUE),
128	4x	get_template_filepath(package = "autoslider.core", full.names = TRUE)
129		) \|>
130	4x	stringr::str_remove("\\.R$") \|>
131	4x	structure(package = package)
132	44x	} else if (package == "autoslider.core") {
133	44x	get_template_filepath(package = package, full.names = TRUE) \|>
134	44x	stringr::str_remove("\\.R$") \|>
135	44x	structure(package = package)
136		}
137		}
138
139
140		#' Retrieve Template File Paths
141		#'
142		#' @param package A character string specifying the name of the package to search.
143		#' @param full.names If `TRUE`, returns the full path to each file.
144		#' If `FALSE`, returns only the file names.
145		#'
146		#' @return A character vector of template file names or paths, depending on `full.names`.
147		#'
148		#' @export
149		#'
150		#' @keywords internal
151		get_template_filepath <- function(package = "autoslider.core", full.names = FALSE) {
152		# Installed-package path
153	92x	template_dir <- system.file("templates", package = package)
154
155	92x	pattern <- "^(t_\|l_\|g_)"
156	92x	if (full.names == TRUE) {
157	92x	pattern <- paste0(paste0(template_dir, "/"), c("t_", "g_", "l_"),
158	92x	collapse = "\|"
159		)
160		}
161
162	92x	list.files(template_dir, pattern = "\\.R$", full.names = full.names) \|>
163	92x	stringr::str_subset(pattern)
164		}

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

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

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

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	9x	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	16x	if (save_rds) {
50	16x	saveRDS(output, file = paste0(file_name, ".rds"))
51		}
52
53	16x	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	3x	if (save_rds) {
86	3x	saveRDS(output, file = paste0(file_name, ".rds"))
87		}
88
89	3x	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	22x	spec <- attr(output, "spec")
159	22x	file_path <- file.path(outfolder, spec$output)
160	22x	file_path <- paste0(c(file_path, generic_suffix), collapse = "_")
161	22x	output <- save_output(
162	22x	output = output,
163	22x	file_name = file_path,
164	22x	save_rds = save_rds
165		)
166
167	22x	if (verbose_level > 0) {
168	22x	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	21x	cat_bullet(
181	21x	"Output saved in path ",
182	21x	file_path,
183	21x	bullet = "tick",
184	21x	bullet_col = "green"
185		)
186		}
187		}
188
189	22x	attr(output, "outpath") <- get_output_file_ext(output, file_path)
190	22x	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		# 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		#' 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	378x	ft \|>
33	378x	theme_zebra(
34	378x	odd_header = odd_header,
35	378x	odd_body = odd_body,
36	378x	even_header = odd_header,
37	378x	even_body = even_body
38		) \|>
39	378x	font(fontname = font_name, part = "all") \|>
40	378x	fontsize(size = body_font_size, part = "body") \|>
41	378x	color(color = "white", part = "header") \|>
42	378x	fontsize(size = header_font_size, part = "header") \|>
43	378x	fontsize(size = footer_font_size, part = "footer") \|>
44	378x	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	360x	ft \|> autoslider_format(
75	360x	odd_header = "#ED4A0D",
76	360x	odd_body = "#FF7D29",
77	360x	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. Additional arguments supplied when the returned
172		#' function is called are forwarded to the underlying formatter. When no sizes
173		#' are supplied the original formatter is returned unchanged.
174		#'
175		#' @param table_format A function taking a flextable as its first argument and
176		#' returning a flextable (e.g. [autoslider_format()], [black_format_tb()]).
177		#' @param body_font_size,header_font_size,footer_font_size Point sizes. `NULL`
178		#' (the default) leaves that part to the underlying formatter default.
179		#'
180		#' @return A function `function(ft, ...)` returning a styled flextable.
181		#' @export
182		#'
183		#' @examples
184		#' small <- with_font_sizes(black_format_tb, body_font_size = 6, header_font_size = 6)
185		#' ft <- flextable::flextable(head(mtcars))
186		#' small(ft)
187		with_font_sizes <- function(table_format,
188		body_font_size = NULL,
189		header_font_size = NULL,
190		footer_font_size = NULL) {
191	72x	force(table_format)
192	72x	sizes <- Filter(Negate(is.null), list(
193	72x	body_font_size = body_font_size,
194	72x	header_font_size = header_font_size,
195	72x	footer_font_size = footer_font_size
196		))
197	72x	if (length(sizes) == 0) {
198	1x	return(table_format)
199		}
200
201	71x	function(ft, ...) {
202	98x	args <- list(...)
203	98x	overridden <- intersect(names(args), names(sizes))
204	98x	if (length(overridden) > 0) {
205	!	args[overridden] <- NULL
206		}
207	98x	fmls <- formalArgs(table_format)
208	98x	keep <- if (is.null(fmls) \|\| "..." %in% fmls) {
209	89x	sizes
210		} else {
211	9x	sizes[names(sizes) %in% fmls]
212		}
213	98x	do.call(table_format, c(list(ft = ft), args, keep))
214		}
215		}

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

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		abort <- function(...) {
2	34x	stop(..., call. = FALSE)
3		}
4
5		assert_is_character_scalar <- function(x) {
6	723x	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	6x	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	478x	exist_in_spec <- vars %in% names(output)
20		# explicitly define env to use, better practice for testing
21	478x	exist_in_calling_env <- map_lgl(vars, exists, envir = env)
22
23	478x	non_existing_vars <- vars[!(exist_in_spec \| exist_in_calling_env)]
24
25
26	478x	n <- length(non_existing_vars)
27	478x	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	483x	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		}
50
51		assert_is_valid_pagination <- function(x, field, output = NULL) {
52		# `is.finite()` covers NA, NaN and both infinities in one go, and `x %% 1`
53		# avoids as.integer(), which turns a value beyond .Machine$integer.max into
54		# NA and would land the comparison in `if (NA)` instead of reporting it.
55	46x	if (length(x) != 1L \|\| !is.numeric(x) \|\| !is.finite(x) \|\| x < 1 \|\| x %% 1 != 0) {
56	21x	abort(
57	21x	"`", field, "`",
58	21x	if (is.null(output)) "" else paste0(" in spec entry '", output, "'"),
59	21x	" must be a single positive whole number but is `", deparse(x), "`."
60		)
61		}
62	25x	x
63		}

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

1		#' Plot mean values of 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		#' decorate generic
2		#' @param x object to decorate
3		#' @param ... additional arguments passed to methods
4		#' @export
5		decorate <- function(x, ...) {
6	51x	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	37x	width_set <- attr(x, "width")
63	37x	tmp_x <- formatters::matrix_form(x)
64
65	37x	if (is.null(width_set)) {
66	37x	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	37x	glued_title <- apply_tokens(titles, metadata)
72	37x	main_title(x) <- glued_title
73
74	37x	git_fn <- git_footnote(for_test)
75	37x	glued_footnotes <- apply_tokens(c(footnotes, git_fn), metadata)
76	37x	main_footer(x) <- glued_footnotes
77
78	37x	new(
79	37x	"dVTableTree",
80	37x	tbl = x,
81	37x	titles = glued_title,
82	37x	footnotes = footnotes,
83	37x	usernotes = "",
84	37x	paper = paper,
85	37x	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	10x	glued_title <- apply_tokens(titles, metadata)
107		# main_title(x) <- glued_title
108
109	10x	git_fn <- git_footnote(for_test)
110	10x	glued_footnotes <- apply_tokens(c(footnotes, git_fn), metadata)
111		# main_footer(x) <- glued_footnotes
112
113	10x	ret <- list(
114	10x	grob = ggplot2::ggplotGrob(x),
115	10x	titles = glued_title,
116	10x	footnotes = footnotes,
117	10x	usernotes = "",
118	10x	paper = paper,
119	10x	for_test = for_test
120		)
121	10x	class(ret) <- "decoratedGrob"
122	10x	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	2x	width_set <- attr(x, "width")
141	2x	tmp_x <- formatters::matrix_form(x)
142
143	2x	if (is.null(width_set)) {
144	2x	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	2x	glued_title <- apply_tokens(titles, metadata)
150	2x	main_title(x) <- glued_title
151
152	2x	git_fn <- git_footnote(for_test)
153	2x	glued_footnotes <- apply_tokens(c(footnotes, git_fn), metadata)
154	2x	main_footer(x) <- glued_footnotes
155	2x	new(
156	2x	"dlisting",
157	2x	lst = x,
158	2x	titles = glued_title,
159	2x	footnotes = footnotes,
160	2x	usernotes = "",
161	2x	paper = paper,
162	2x	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	12x	size <- fs(paper)
218	12x	glued_title <- apply_tokens(titles, metadata)
219	12x	x <- x \|> modify_caption(caption = "")
220	12x	structure(
221	12x	.Data = x,
222	12x	titles = glued_title,
223	12x	footnotes = footnotes,
224	12x	paper = paper,
225	12x	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	6x	assert_is_valid_version_label(version_label)
300
301	6x	lapply(outputs, function(output) {
302	29x	if (inherits(output, "autoslider_error")) {
303	!	return(output)
304		}
305
306	29x	spec <- attr(output, "spec")
307
308	29x	filter_titles <- function(...) {
309	29x	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	29x	r <- vapply(
318	29x	Filter(
319	29x	f = function(x) any(x$target %in% toupper(c(...))),
320	29x	x = filters::get_filters(spec$suffix)
321		),
322	29x	FUN = `[[`,
323	29x	FUN.VALUE = character(1L),
324	29x	"title"
325		)
326		}
327	29x	paste(r, collapse = ", ")
328		}
329
330	29x	pattern <- "\\{filter_titles\\(((\"\\w+\")(,\\s\"\\w+\")){0,1}\\)\\}"
331	29x	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	28x	full_title <- paste(
339	28x	paste(version_label, spec$titles),
340	28x	filter_titles("ADSL"),
341	28x	sep = ", "
342		)
343		}
344
345	29x	if ("ggplot" %in% class(output)) {
346	4x	decorate.ggplot(output, titles = full_title, metadata = spec)
347	25x	} else if ("grob" %in% class(output)) {
348	!	decorate.grob(output, metadata = spec)
349		} else {
350	25x	structure(
351	25x	.Data = decorate(
352	25x	x = output,
353	25x	title = c(full_title, generic_title),
354	25x	footnotes = c(spec$footnotes, generic_footnote),
355	25x	paper = spec$paper,
356	25x	for_test = for_test,
357	25x	metadata = spec
358		),
359	25x	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		#' 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		#' 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	137x	assertthat::assert_that(is.character(text))
28	136x	assertthat::assert_that(is.null(metadata) \|\| is.list(metadata))
29
30	135x	if (length(text) == 0) {
31	1x	return(text)
32		}
33
34	134x	data <- if (is.null(metadata)) list() else as.list(metadata)
35	134x	template <- paste(text, collapse = "\n")
36
37	134x	tryCatch(
38	134x	glue::glue_data(.x = data, template, .envir = parent.frame()),
39	134x	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		#' 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		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	9x	if (length(filtered_spec)) {
27	9x	msg <- sprintf(
28	9x	"%d/%d outputs matched the filter condition `%s`.",
29	9x	length(filtered_spec),
30	9x	length(original_spec),
31	9x	deparse(condition)
32		)
33	9x	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		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		#' 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	81x	if (quote) {
16	!	args <- lapply(args, enquote)
17		}
18
19	81x	if (is.null(names(args))) {
20	!	argn <- args
21	!	args <- list()
22		} else {
23		# Add all the named arguments
24	81x	argn <- lapply(names(args)[names(args) != ""], as.name)
25	81x	names(argn) <- names(args)[names(args) != ""]
26		# Add the unnamed arguments
27	81x	argn <- c(argn, args[names(args) == ""])
28	81x	args <- args[names(args) != ""]
29		}
30
31	81x	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	80x	} else if (is(what, "function")) {
42	80x	f_name <- deparse(substitute(what))
43	80x	call <- as.call(c(list(as.name(f_name)), argn))
44	80x	args[[f_name]] <- what
45	!	} else if (is(what, "name")) {
46	!	call <- as.call(c(list(what, argn)))
47		}
48
49	81x	eval(call,
50	81x	envir = args,
51	81x	enclos = envir
52		)
53		}

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

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

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

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		}