autoslider.core coverage - 88.75%

Files
Source

#' Read yaml spec file
#'
#' Read yaml spec file and split according to filter lists
#'
#' @param spec_file `character`. Path to a yaml spec file
#' @param metadata Study-level token values merged into every spec entry. Either
#'   a named `list` (or `NULL`), or a `character(1)` path to a yaml metadata file
#'   (see [read_metadata()] and the example at
#'   `system.file("metadata.yml", package = "autoslider.core")`), which is read
#'   into a list for you. Its elements can be referenced as `\{token\}`
#'   placeholders in the `titles` and `footnotes` fields of the spec and are
#'   substituted during decoration (see [apply_tokens()]). For example, with
#'   `metadata = list(study = "BP12345")` a spec title of
#'   `"Demographics - Study \{study\}"` becomes `"Demographics - Study BP12345"`.
#'
#' @return
#' An object of class `spec` which is a `list` where each element corresponds
#' to one output, e.g. `t_dm_IT`.
#'
#' @author
#' - Liming Li (`Lil128`)
#' - Thomas Neitmann (`neitmant`)
#' - Joe Zhu
#'
#' @export
#'
#' @examples
#' spec_file <- system.file("spec.yml", package = "autoslider.core")
#'
#' ## Take a look at the 'raw' content of the spec file
#' cat(readLines(spec_file)[1:24], sep = "\n")
#'
#' ## This is how it looks once read into R
#' spec <- read_spec(spec_file)
#' spec[1:3]
#'
#' ## Supply study metadata so that `\{token\}` placeholders in titles/footnotes
#' ## are filled in during decoration (e.g. a title of "... Study \{study\}").
#' spec <- read_spec(spec_file, metadata = list(study = "BP12345"))
#'
#' ## The same metadata can be kept in a yaml file and read via `read_spec()`
#' metadata_file <- system.file("metadata.yml", package = "autoslider.core")
#' spec <- read_spec(spec_file, metadata = metadata_file)
#'
read_spec <- function(spec_file = "spec.yml",
                      metadata = NULL) {
  if (is.character(metadata)) {
    metadata <- read_metadata(metadata)
  }
  spec <- yaml::read_yaml(spec_file, eval.expr = TRUE)
  spec_obj <- check_and_flattern_suffix(spec, metadata = metadata)
  as_spec(spec_obj)
}

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

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 figure width in inch
#' @param fig_height figure height in inch
#' @param t_lpp An integer specifying the table lines per page \cr
#'    Specify this optional argument to modify the length of all of the table displays.
#'    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 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()
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, ...) {
  # 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")
  ))) {
    if (inherits(outputs, "ggplot")) {
      current_title <- outputs$labels$title
      if (is.null(current_title)) {
        current_title <- ""
      }
      outputs <- decorate.ggplot(outputs, titles = current_title)
    } else if (inherits(outputs, "grob")) {
      outputs <- decorate.grob(outputs)
    } else if (
      (inherits(outputs, "gtsummary") || inherits(outputs, "tbl_roche_summary")) &&
      !inherits(outputs, "dgtsummary")
    ) {
      current_title <- tryCatch(outputs$table_styling$caption, error = function(e) NULL)
      if (is.null(current_title) || !nzchar(current_title)) current_title <- ""
      outputs <- decorate(outputs, titles = current_title)
    }

    outputs <- list(outputs)
  }

  assert_that(is.list(outputs))

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

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

  # Merge deck defaults with a slide's own spec `font_size` block (slide wins).
  slide_fs <- function(x) {
    sp <- attr(x, "spec")
    modifyList(deck_fs, (sp$font_size) %||% list())
  }
  # Effective 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.
  slide_pag <- function(x, lpp, cpp) {
    sp <- attr(x, "spec")
    list(
      lpp = if (is.null(sp$lpp)) lpp else assert_is_valid_pagination(sp$lpp, "lpp", sp$output),
      cpp = if (is.null(sp$cpp)) cpp else assert_is_valid_pagination(sp$cpp, "cpp", sp$output)
    )
  }
  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)) {
        assert_is_valid_pagination(sp$cpp, "cpp", sp$output)
      } 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,
          figure_loc = center_figure_loc(fig_width, fig_height, ppt_width = width, ppt_height = 1.17 * height),
          fig_editable = fig_editable, ...
        )
      } else {
        if (inherits(x, "autoslider_error")) {
          message(x)
        } else {
          next
        }
      }
    }
  }
  print(ppt, target = outfile)
}

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

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


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

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

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

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

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

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

#' Add decorated flextable to slides
#'
#' @param ppt Slide
#' @param content Content to be added
#' @param table_loc Table location
#' @param usernotes User notes
#' @param decor Should table be decorated
#' @param layout layout from theme
#' @param footer_font_size 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
    )
  }

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

  res
}

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

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

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

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


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

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

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

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

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

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

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

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

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

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


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

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

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


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

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

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


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

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

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

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

  invisible(TRUE)
}

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


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

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

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

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

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

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

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

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

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

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

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

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

  doc
}


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


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

  to_page <- initialize_to_page(doc_original, to_page)

  study_id <- apply_tokens(study_id, metadata)

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

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

  doc
}



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

  to_page <- initialize_to_page(doc_original, to_page)

  section_title <- apply_tokens(section_title, metadata)

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

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

  doc
}

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


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


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

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

  doc
}

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

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

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

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

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

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

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

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

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

  prompt <- build_story_prompt(outputs, allowed_layouts, max_slides)

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

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

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

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

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

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

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

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

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

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

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

  ppt
}

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

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

  invisible(outfile)
}

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

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

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

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

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

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

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

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

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

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

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

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

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
}

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

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

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

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

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

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

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
}

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

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

  anl <- adsl

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

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

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

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

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

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

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

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

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

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

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

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


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

  # Set up listing

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

  lsting
}

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

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

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

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

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

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

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

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		#' 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	12x	if (is.character(metadata)) {
48	1x	metadata <- read_metadata(metadata)
49		}
50	12x	spec <- yaml::read_yaml(spec_file, eval.expr = TRUE)
51	12x	spec_obj <- check_and_flattern_suffix(spec, metadata = metadata)
52	12x	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	12x	ret <- lapply(spec, function(s) {
105	565x	lapply(s$suffix, function(su) {
106	595x	entry <- s
107	595x	entry$suffix <- su
108	595x	c(entry, metadata)
109		})
110		})
111	12x	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	8x	if (is.character(substitute(filter_expr))) {
170	!	warn_about_legacy_filtering(filter_expr)
171	!	condition <- bquote(output == .(filter_expr))
172		} else {
173	8x	condition <- substitute(filter_expr)
174		}
175	8x	stopifnot(is_spec(spec), is.language(condition), is.logical(verbose))
176	8x	vars <- all.vars(condition)
177
178	8x	filtered_spec <- Filter(function(output) {
179	416x	assert_exists_in_spec_or_calling_env(vars, output)
180	416x	p <- eval(condition, envir = output)
181	416x	assert_is_valid_filter_result(p)
182	416x	p
183	8x	}, spec)
184
185	8x	if (verbose) {
186	8x	log_number_of_matched_records(spec, filtered_spec, condition)
187		}
188
189	8x	as_spec(filtered_spec)
190		}
191
192		is_spec <- function(x) {
193	8x	"spec" %in% class(x)
194		}
195
196		as_spec <- function(x) {
197	20x	spec <- lapply(x, function(elem) {
198	629x	if (is.null(elem$suffix)) {
199	!	elem$suffix <- ""
200		}
201
202	629x	if (elem$suffix == "") {
203	!	elem$output <- elem$program
204		} else {
205	629x	elem$output <- paste(elem$program, elem$suffix, sep = "_")
206		}
207
208	629x	if (is.null(elem$paper)) {
209	40x	elem$paper <- default_paper_size(elem$program)
210	589x	} else if (elem$paper == "a4r") {
211	!	warn_about_legacy_paper_size("a4r", "L11")
212	!	elem$paper <- "L11"
213	589x	} else if (elem$paper == "a4") {
214	!	warn_about_legacy_paper_size("a4", "P11")
215	!	elem$paper <- "P11"
216		} else {
217	589x	validate_paper_size(elem$paper)
218		}
219
220	629x	elem
221		})
222
223	20x	structure(
224	20x	.Data = spec,
225	20x	names = map_chr(spec, `[[`, "output"),
226	20x	class = union("spec", class(x))
227		)
228		}

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	48x	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	48x	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	48x	ret <- NULL
296		}
297
298	48x	if (for_test == TRUE) {
299	18x	ret <- NULL
300		}
301
302	48x	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	422x	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	21x	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	40x	output_type <- substr(program, 1L, 1L)
351	40x	defaults <- c(l = "L8", t = "P8", g = "L11")
352	40x	if (output_type %in% names(defaults)) {
353	40x	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	14x	fontsize <- as.integer(substr(paper, 2, nchar(paper)))
452	14x	orientation <- substr(paper, 1, 1)
453	14x	list(fontsize = fontsize, orientation = orientation)
454		}
455
456		validate_paper_size <- function(paper) {
457	596x	assert_is_character_scalar(paper)
458	596x	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	593x	fontsize <- as.integer(substr(paper, 2, nchar(paper)))
465	593x	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	41x	result <- build_table(lyt = lyt, df = anl)
529
530	40x	if (!is.null(side_by_side)) {
531	12x	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	12x	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	40x	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	769x	args <- list(...)
597	769x	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	605x	`%\|\|%` <- 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	70x	lyt <- basic_table()
616	70x	if (is.null(side_by_side)) {
617	51x	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	45x	lyt <- lyt \|>
624	45x	split_cols_by(var = arm) \|>
625	45x	add_overall_col("All Patients")
626		}
627		} else {
628	19x	if (split_by_study) {
629	10x	warning("split_by_study argument will be ignored")
630		}
631	19x	lyt <- lyt \|>
632	19x	split_cols_by(var = "lvl") \|>
633	19x	split_cols_by(var = arm) \|>
634	19x	add_overall_col("All Patients")
635		}
636
637	70x	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		#' 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	404x	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	10x	ft_full <- gtsummary::as_flex_table(x) \|> table_format()
144
145	10x	gts_title_reserve_in <- 1.5 # inches reserved above the table for the slide title
146	10x	gts_row_height_fudge <- 1.3 # flextable stores "atleast" row heights; padding
147		# expands rendered rows beyond this stored minimum
148	10x	gts_default_lpp <- 20L # fallback when neither lpp nor ppt_height is supplied
149
150	10x	total_width <- flextable_dim(ft_full)$widths
151
152	10x	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	10x	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	10x	n_body <- nrow(ft_full$body$dataset)
175	10x	header_text <- paste(attr(x, "titles"), collapse = "\n")
176	10x	footnotes_text <- paste(attr(x, "footnotes"), collapse = "\n")
177	10x	n_pages <- ceiling(n_body / lpp)
178	10x	ft_list <- lapply(seq_len(n_pages), function(pg) {
179	24x	rows_keep <- seq.int((pg - 1L) * lpp + 1L, min(pg * lpp, n_body))
180	24x	rows_delete <- setdiff(seq_len(n_body), rows_keep)
181	24x	ft_page <- if (length(rows_delete) > 0L) {
182	18x	delete_rows(ft_full, i = rows_delete, part = "body")
183		} else {
184	6x	ft_full
185		}
186	24x	list(
187	24x	ft = ft_page,
188	24x	header = if (pg == 1L) header_text else paste(header_text, "(cont.)"),
189	24x	footnotes = footnotes_text
190		)
191		})
192	10x	class(ft_list) <- "dflextable"
193	10x	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	280x	df <- x
204	280x	ft <- do_call(flextable, data = df, ...)
205
206	280x	if (dose_template) {
207	!	ft <- ft \|>
208	!	autofit() \|>
209	!	fit_to_width(10)
210		} else {
211	280x	if (all(is.na(formatters::var_labels(df)))) {
212	3x	formatters::var_labels(df) <- names(df)
213		}
214
215	280x	ft <- set_header_labels(ft, values = as.list(formatters::var_labels(df)))
216	280x	ft <- ft \|> width(width = col_width)
217	280x	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	280x	ft <- ft \|>
226	280x	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	280x	if (!is.null(font_size)) {
232	!	ft <- ft \|> fontsize(size = font_size, part = "all")
233		}
234	280x	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	67x	tbl <- x
349	67x	mf <- formatters::matrix_form(tbl, indent_rownames = TRUE)
350	67x	nr_header <- attr(mf, "nrow_header")
351	67x	non_total_coln <- c(TRUE, !grepl("All Patients", names(tbl)))
352	67x	df <- as.data.frame(mf$strings[(nr_header + 1):(nrow(mf$strings)), , drop = FALSE])
353
354	67x	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	67x	ft <- do_call(flextable, data = df, ...)
365	67x	ft <- ft \|>
366	67x	delete_part(part = "header") \|>
367	67x	add_header(values = header_df)
368
369		# if(!is.null(apply_theme)){
370		# ft <- ft \|>
371		# apply_theme()
372		# }
373
374	67x	ft <- do_call(table_format, ft = ft, ...)
375	67x	ft <- ft \|>
376	67x	merge_at_indice(lst = get_merge_index(mf$spans[(nr_header + 1):nrow(mf$spans), , drop = FALSE]), part = "body") \|>
377	67x	merge_at_indice(lst = get_merge_index(mf$spans[1:nr_header, , drop = FALSE]), part = "header") \|>
378	67x	align_text_col(align = "center", header = TRUE) \|>
379	67x	align(i = seq_len(nrow(tbl)), j = 1, align = "left") \|> # row names align to left
380	67x	padding_lst(mf$row_info$indent) \|>
381	67x	padding(padding.top = 3, padding.bottom = 3, part = "all") \|>
382	67x	autofit(add_h = 0)
383
384
385	67x	ft <- ft \|>
386	67x	width(width = c(
387	67x	dim(ft)$widths[1],
388	67x	dim(ft)$widths[-1] - dim(ft)$widths[-1] + sum(dim(ft)$widths[-1]) / (ncol(mf$strings) - 1)
389	67x	)) # even the non-label column width
390
391	67x	if (flextable_dim(ft)$widths > 10) {
392	30x	pgwidth <- 10.5
393	30x	ft <- ft \|>
394	30x	width(width = dim(ft)$widths * pgwidth / flextable_dim(ft)$widths)
395		# adjust width of each column as percentage of total width
396		}
397
398	67x	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	45x	dtbl <- x
416		# paginate VTableTree
417	45x	pag_tbl <- paginate_table(dtbl@tbl, lpp = lpp, cpp = cpp)
418	45x	ft_list <- lapply(1:length(pag_tbl), function(x) {
419	65x	ft <- to_flextable(pag_tbl[[x]], ...)
420	65x	if (length(dtbl@tbl@provenance_footer) == 0) {
421	65x	cat_foot <- dtbl@footnotes
422		} else {
423	!	cat_foot <- paste0(dtbl@tbl@provenance_footer, "\n", dtbl@footnotes)
424		}
425
426	65x	list(
427	65x	ft = ft,
428	65x	header = ifelse(x == 1, dtbl@titles, paste(dtbl@titles, "(cont.)")),
429	65x	footnotes = cat_foot
430		)
431		})
432		# force the width of the 1st column to be the widest of all paginated table
433	45x	ft_list_resize <- set_width_widest(ft_list)
434	45x	class(ft_list_resize) <- "dflextable"
435
436	45x	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	45x	width1st <- max(unlist(lapply(ft_list, function(x) {
456	65x	x$ft$body$colwidths[1]
457		})))
458	45x	for (i in 1:length(ft_list)) {
459	65x	ft_list[[i]]$ft <- width(ft_list[[i]]$ft, 1, width = width1st)
460		}
461
462	45x	ft_list
463		}
464
465		get_merge_index_single <- function(span) {
466	1131x	ret <- list()
467	1131x	j <- 1
468	1131x	while (j < length(span)) {
469	4383x	if (span[j] != 1) {
470	1x	ret <- c(ret, list(j:(j + span[j] - 1)))
471		}
472	4383x	j <- j + span[j]
473		}
474
475	1131x	ret
476		}
477
478		get_merge_index <- function(spans) {
479	134x	ret <- lapply(seq_len(nrow(spans)), function(i) {
480	1131x	ri <- spans[i, ]
481	1131x	r <- get_merge_index_single(ri)
482	1131x	lapply(r, function(s) {
483	1x	list(j = s, i = i)
484		})
485		})
486	134x	unlist(ret, recursive = FALSE, use.names = FALSE)
487		}
488
489		merge_at_indice <- function(ft, lst, part) {
490	134x	Reduce(function(ft, ij) {
491	1x	merge_at(ft, i = ij$i, j = ij$j, part = part)
492	134x	}, lst, ft)
493		}
494
495		padding_lst <- function(ft, indents) {
496	67x	Reduce(function(ft, s) {
497	1055x	padding(ft, s, 1, padding.left = (indents[s] + 1) * 10)
498	67x	}, seq_len(length(indents)), ft)
499		}

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

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	39x	template_file <- file_list[basename(file_list) == paste0(template, ".R")]
90
91
92	39x	if (file.copy(template_file, save_path, overwrite = TRUE)) {
93	39x	rlang::inform(sprintf("\u2713 File '%s' has been created successfully", save_path))
94	39x	file_lines <- readLines(save_path)
95
96	39x	file_lines <- file_lines[!grepl("^#'", file_lines)]
97	39x	file_lines <- file_lines[nzchar(file_lines)]
98
99		# Replace function name with numbering
100	39x	file_lines <- gsub(tolower(template), function_name, file_lines)
101	39x	writeLines(file_lines, save_path)
102		}
103
104	39x	if (open) {
105	!	file.edit(save_path)
106		}
107
108	39x	invisible(TRUE)
109		}
110
111		#' [EXPERIMENTAL] List All Available Templates
112		#'
113		#' @param package Which package to search for the template files. Defaults to "autoslider.core".
114		#'
115		#' @return A character vector of available template names in the specified package.
116		#'
117		#' @export
118		#'
119		#' @examples
120		#' list_all_templates(package = "autoslider.core")
121		list_all_templates <- function(package = "autoslider.core") {
122	48x	if (package == "autoslideR") {
123	4x	c(
124	4x	get_template_filepath(package = "autoslideR", full.names = TRUE),
125	4x	get_template_filepath(package = "autoslider.core", full.names = TRUE)
126		) \|>
127	4x	stringr::str_remove("\\.R$") \|>
128	4x	structure(package = package)
129	44x	} else if (package == "autoslider.core") {
130	44x	get_template_filepath(package = package, full.names = TRUE) \|>
131	44x	stringr::str_remove("\\.R$") \|>
132	44x	structure(package = package)
133		}
134		}
135
136
137		#' Retrieve Template File Paths
138		#'
139		#' @param package A character string specifying the name of the package to search.
140		#' @param full.names If `TRUE`, returns the full path to each file.
141		#' If `FALSE`, returns only the file names.
142		#'
143		#' @return A character vector of template file names or paths, depending on `full.names`.
144		#'
145		#' @export
146		#'
147		#' @keywords internal
148		get_template_filepath <- function(package = "autoslider.core", full.names = FALSE) {
149		# Installed-package path
150	92x	template_dir <- system.file("templates", package = package)
151
152	92x	pattern <- "^(t_\|l_\|g_)"
153	92x	if (full.names == TRUE) {
154	92x	pattern <- paste0(paste0(template_dir, "/"), c("t_", "g_", "l_"),
155	92x	collapse = "\|"
156		)
157		}
158
159	92x	list.files(template_dir, pattern = "\\.R$", full.names = full.names) \|>
160	92x	stringr::str_subset(pattern)
161		}

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		#' 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	356x	ft \|>
33	356x	theme_zebra(
34	356x	odd_header = odd_header,
35	356x	odd_body = odd_body,
36	356x	even_header = odd_header,
37	356x	even_body = even_body
38		) \|>
39	356x	font(fontname = font_name, part = "all") \|>
40	356x	fontsize(size = body_font_size, part = "body") \|>
41	356x	color(color = "white", part = "header") \|>
42	356x	fontsize(size = header_font_size, part = "header") \|>
43	356x	fontsize(size = footer_font_size, part = "footer") \|>
44	356x	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	340x	ft \|> autoslider_format(
75	340x	odd_header = "#ED4A0D",
76	340x	odd_body = "#FF7D29",
77	340x	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	59x	force(table_format)
192	59x	sizes <- Filter(Negate(is.null), list(
193	59x	body_font_size = body_font_size,
194	59x	header_font_size = header_font_size,
195	59x	footer_font_size = footer_font_size
196		))
197	59x	if (length(sizes) == 0) {
198	1x	return(table_format)
199		}
200
201	58x	function(ft, ...) {
202	76x	args <- list(...)
203	76x	overridden <- intersect(names(args), names(sizes))
204	76x	if (length(overridden) > 0) {
205	!	args[overridden] <- NULL
206		}
207	76x	fmls <- formalArgs(table_format)
208	76x	keep <- if (is.null(fmls) \|\| "..." %in% fmls) {
209	69x	sizes
210		} else {
211	7x	sizes[names(sizes) %in% fmls]
212		}
213	76x	do.call(table_format, c(list(ft = ft), args, keep))
214		}
215		}

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		#' 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	34x	suffix <- spec$suffix
42	34x	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	34x	func <- tryCatch(
54		{
55	34x	func_wrapper(
56	34x	func = match.fun(program),
57	34x	datasets = datasets,
58	34x	spec = spec,
59	34x	verbose = verbose_level > 1
60		)
61		},
62	34x	error = function(e) {
63	!	info <- e$message
64	!	if (verbose_level > 0) {
65	!	cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red")
66		}
67	!	autoslider_error(info, spec = spec, step = "filter dataset")
68		}
69		)
70	34x	if (is(func, "autoslider_error")) {
71	!	return(func)
72		}
73	34x	ret <- tryCatch(
74		{
75	34x	func(...)
76		},
77	34x	error = function(e) {
78	!	info <- e$message
79	!	if (verbose_level > 0) {
80	!	cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red")
81		}
82	!	autoslider_error(info, spec = spec, step = "user program")
83		}
84		)
85	34x	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	8x	lapply(spec, function(s) {
125	34x	args <- c(
126	34x	list(
127	34x	program = s$program,
128	34x	spec = s,
129	34x	datasets = datasets,
130	34x	verbose_level = verbose_level
131		),
132	34x	s$args # ... arguments passed onto the output-generating function
133		)
134	34x	output <- fastDoCall(generate_output, args)
135	34x	attr(output, "spec") <- s
136	34x	output
137		})
138		}

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

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

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

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

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

1		#' decorate generic
2		#' @param x object to decorate
3		#' @param ... additional arguments passed to methods
4		#' @export
5		decorate <- function(x, ...) {
6	49x	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	36x	width_set <- attr(x, "width")
63	36x	tmp_x <- formatters::matrix_form(x)
64
65	36x	if (is.null(width_set)) {
66	36x	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	36x	glued_title <- apply_tokens(titles, metadata)
72	36x	main_title(x) <- glued_title
73
74	36x	git_fn <- git_footnote(for_test)
75	36x	glued_footnotes <- apply_tokens(c(footnotes, git_fn), metadata)
76	36x	main_footer(x) <- glued_footnotes
77
78	36x	new(
79	36x	"dVTableTree",
80	36x	tbl = x,
81	36x	titles = glued_title,
82	36x	footnotes = footnotes,
83	36x	usernotes = "",
84	36x	paper = paper,
85	36x	width = width
86		)
87		}
88
89
90		#' Decorate ggplot object
91		#'
92		#' @param x An object to decorate
93		#' @param titles Plot titles
94		#' @param footnotes Plot footnotes
95		#' @param paper Paper size, by default "L11"
96		#' @param for_test `logic` CICD parameter
97		#' @param metadata Named `list` (or `NULL`) of token values used to substitute
98		#' `\{token\}` placeholders in `titles`/`footnotes`. See [apply_tokens()].
99		#' @param ... additional arguments. not used.
100		#' @return No return value, called for side effects
101		#' @export
102		#' @details
103		#' The paper default paper size, `L11`, indicate that the fontsize is 11.
104		#' The fontsize of the footnotes, is the fontsize of the titles minus 2.
105		decorate.ggplot <- function(x, titles = "", footnotes = "", paper = "L11", for_test = FALSE, metadata = NULL, ...) {
106	5x	glued_title <- apply_tokens(titles, metadata)
107		# main_title(x) <- glued_title
108
109	5x	git_fn <- git_footnote(for_test)
110	5x	glued_footnotes <- apply_tokens(c(footnotes, git_fn), metadata)
111		# main_footer(x) <- glued_footnotes
112
113	5x	ret <- list(
114	5x	grob = ggplot2::ggplotGrob(x),
115	5x	titles = glued_title,
116	5x	footnotes = footnotes,
117	5x	usernotes = "",
118	5x	paper = paper,
119	5x	for_test = for_test
120		)
121	5x	class(ret) <- "decoratedGrob"
122	5x	ret
123		}
124
125
126		#' decorate listing
127		#'
128		#' @param x A listing_df object representing the data to be decorated.
129		#' @param titles Title to be added to the table.
130		#' @param footnotes Footnote to be added to the table
131		#' @param paper Orientation and font size as string, e.g. "P8"; "L11"
132		#' @param for_test `logic` CICD parameter
133		#' @param metadata Named `list` (or `NULL`) of token values used to substitute
134		#' `\{token\}` placeholders in `titles`/`footnotes`. See [apply_tokens()].
135		#' @param ... Additional arguments. not used.
136		#' @return No return value, called for side effects
137		#' @method decorate listing_df
138		#' @export
139		decorate.listing_df <- function(x, titles = "", footnotes = "", paper = "P8", for_test = FALSE, metadata = NULL, ...) {
140	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	11x	size <- fs(paper)
218	11x	glued_title <- apply_tokens(titles, metadata)
219	11x	x <- x \|> modify_caption(caption = "")
220	11x	structure(
221	11x	.Data = x,
222	11x	titles = glued_title,
223	11x	footnotes = footnotes,
224	11x	paper = paper,
225	11x	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		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		#' 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		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	8x	if (length(filtered_spec)) {
27	8x	msg <- sprintf(
28	8x	"%d/%d outputs matched the filter condition `%s`.",
29	8x	length(filtered_spec),
30	8x	length(original_spec),
31	8x	deparse(condition)
32		)
33	8x	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		#' 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		abort <- function(...) {
2	33x	stop(..., call. = FALSE)
3		}
4
5		assert_is_character_scalar <- function(x) {
6	606x	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	419x	exist_in_spec <- vars %in% names(output)
20		# explicitly define env to use, better practice for testing
21	419x	exist_in_calling_env <- map_lgl(vars, exists, envir = env)
22
23	419x	non_existing_vars <- vars[!(exist_in_spec \| exist_in_calling_env)]
24
25
26	419x	n <- length(non_existing_vars)
27	419x	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	424x	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	35x	if (length(x) != 1L \|\| !is.numeric(x) \|\| !is.finite(x) \|\| x < 1 \|\| x %% 1 != 0) {
56	20x	abort(
57	20x	"`", field, "`",
58	20x	if (is.null(output)) "" else paste0(" in spec entry '", output, "'"),
59	20x	" must be a single positive whole number but is `", deparse(x), "`."
60		)
61		}
62	15x	x
63		}

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

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

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	119x	assertthat::assert_that(is.character(text))
28	118x	assertthat::assert_that(is.null(metadata) \|\| is.list(metadata))
29
30	117x	if (length(text) == 0) {
31	1x	return(text)
32		}
33
34	116x	data <- if (is.null(metadata)) list() else as.list(metadata)
35	116x	template <- paste(text, collapse = "\n")
36
37	116x	tryCatch(
38	116x	glue::glue_data(.x = data, template, .envir = parent.frame()),
39	116x	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		#' 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		#' autoslider_error class
2		#' @details this function is used to create autoslider_error object.
3		#' this function is for internal use only to create the autoslider_error object.
4		#' It enable us for further functionalities, like providing help on easy debugging,
5		#' e.g. if the error is inside the user function, provide the call and let the user
6		#' run the code outside the pipeline.
7		#' @param x character scaler
8		#' @param spec spec should be a list containing "program" and "suffix"
9		#' @param step step is a character indicating in which step the pipeline encounter error
10		#' @return autoslider_error object
11		#' @export
12		autoslider_error <- function(x, spec, step) {
13	4x	assert_is_character_scalar(x)
14	4x	structure(
15	4x	.Data = x,
16	4x	step = step,
17	4x	spec = spec,
18	4x	class = "autoslider_error"
19		)
20		}

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