autoslider.core coverage - 79.85%

Files
Source

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

    outputs <- list(outputs)
  }

  assert_that(is.list(outputs))

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

  ppt <- do_call(add_slide, x = ppt, master = ppt_master, ...)
  ppt <- ph_with(ppt, value = out, location = table_loc)

  ph_with_args <- args[unlist(lapply(args, function(x) all(c("location", "value") %in% names(x))))]
  res <- lapply(ph_with_args, function(x) {
    ppt <- ph_with(ppt, value = x$value, location = x$location)
  })

  return(res)
}

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

#' Placeholder for ph_with_img
#'
#' @param ppt power point file
#' @param figure image object
#' @param fig_width width of figure
#' @param fig_height height of figure
#' @param figure_loc location of figure
#' @return Location for a placeholder
#' @export
ph_with_img <- function(ppt, figure, fig_width, fig_height, figure_loc) {
  file_name <- tempfile(fileext = ".svg")
  svg(filename = file_name, width = fig_width * 1.5, height = fig_height * 1.5, onefile = TRUE)
  grid.draw(figure)
  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 ... arguments passed to program
#'
#' @return slide with the added content
figure_to_slide <- function(ppt, content,
                            decor = TRUE,
                            fig_width,
                            fig_height,
                            figure_loc = ph_location_type("body"),
                            ...) {
  ppt_master <- layout_summary(ppt)$master[1]
  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, ...)
    # old
    # ppt <- ph_with_img(ppt, content, fig_width, fig_height, figure_loc)
    content_list <- g_export(content)
    ppt <- ph_with(ppt, content_list$dml, location = ph_location_type(type = "body"))

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

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 <- paste(repo, commit, sep = "\n")
  } 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() == "master"
}

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

wrap_chunk <- function(chunks, width, wrapped_chunk = list(), current_line = "", width_left = width) {
  if (length(chunks) == 0) {
    return(append(wrapped_chunk, current_line))
  }
  next_chunk <- chunks[1]
  next_width <- nchar(next_chunk)
  if (width_left <= 0) {
    wrapped_chunk <- append(wrapped_chunk, current_line)
    return(wrap_chunk(chunks, width, wrapped_chunk, "", width))
  } else if (next_width <= width_left) {
    if (current_line == "") {
      current_line <- next_chunk
    } else {
      current_line <- paste(current_line, next_chunk)
    }
    return(wrap_chunk(chunks[-1], width, wrapped_chunk, current_line, width_left - next_width - 1))
  } else if (next_width > width) {
    next_chunk_sub <- substr(next_chunk, 1, width_left)
    if (current_line == "") {
      current_line <- next_chunk_sub
    } else {
      current_line <- paste(current_line, next_chunk_sub)
    }
    chunks[1] <- substr(next_chunk, width_left + 1, next_width)
    wrapped_chunk <- append(wrapped_chunk, current_line)
    return(wrap_chunk(chunks, width, wrapped_chunk, "", width))
  } else {
    wrapped_chunk <- append(wrapped_chunk, current_line)
    return(wrap_chunk(chunks, width, wrapped_chunk, "", width))
  }
}

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

  ret
}

text_wrap_cut_keepreturn <- function(text, width) {
  if (is.na(width)) {
    width <- 0
  }
  texts <- strsplit(text, "\n")
  ret <- vapply(texts, function(x) {
    r <- text_wrap_cut(x, width)
    paste0(r, collapse = "\n")
  }, FUN.VALUE = "")

  ret
}

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

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

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

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

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



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

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

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

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

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

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

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


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


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

  lyt
}


get_version_label_output <- function() {
  NULL
}


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

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

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

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

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

#' Adverse event table
#'
#' @param adae ADAE data set, dataframe
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character, "`TRT01A" by default.
#' @param cutoff Cutoff threshold
#' @param split_by_study Split by study, building structured header for tables
#' @param side_by_side "GlobalAsia" or "GlobalAsiaChina" to define the side by side requirement
#' @return rtables object
#' @inherit gen_notes note
#' @export
#' @examples
#' library(dplyr)
#' adsl <- eg_adsl %>%
#'   dplyr::mutate(TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")))
#' adae <- eg_adae %>%
#'   dplyr::mutate(
#'     TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")),
#'     ATOXGR = AETOXGR
#'   )
#' out <- t_ae_pt_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)
    }
  }
}

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

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

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

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

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


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

#' Update footnote with AI response
#'
#' @param outputs Output objects
#' @param prompt_list List of prompt
#' @param platform Platform provider
#' @param base_url Base url
#' @param api_key API key
#' @param model Model of choice
#'
#' @export
adding_ai_footnotes <- 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)) {
      current_prompt <- integrate_prompt(prompt_list[[output_name]]$prompt, output@tbl)
      output@footnotes <- c(output@footnotes, chat$chat(current_prompt)) # gather_ai_feedback()
    }
    output
  })
  names(ret) <- names_outputs
  ret
}

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


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


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

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

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

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

  ft_list_resize
}

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

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

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

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

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

  return(ft)
}

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

  ft
}

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




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

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

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

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

  return(ft)
}


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

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

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

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


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

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

  ft_list
}



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

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

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

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

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

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


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

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

  return(ft)
}


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

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

  ft_list_resize
}

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

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

  ret
}

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

  ft_list
}

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

  ret
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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


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

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

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

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




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

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

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

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

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

    spec <- attr(output, "spec")

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

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

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

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

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

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



#' 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
#' @examples
#' 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))
#'
#' generate_slides(plot_vs, paste0(tempdir(), "/g_vs.pptx"))
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, ...
  )
}



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


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

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

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

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

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

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

  as_spec(filtered_spec)
}

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

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

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

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

    elem
  })

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

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

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

#' Adverse event table
#'
#' @param adae ADAE data set, dataframe
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character
#' @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
}

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

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

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

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

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

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

  invisible(output)
})

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

  invisible(output)
}

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

  invisible(output)
}


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

  invisible(output)
}

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

  invisible(output)
}


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

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

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

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

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

  ret
}


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

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

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

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

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) {
  exist_in_spec <- vars %in% names(output)
  exist_in_calling_env <- map_lgl(vars, exists, parent.frame(n = 2L))
  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
    )
  }
}

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

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

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

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

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

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

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

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

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


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

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

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


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

#' @describeIn autoslider_format
#'
#' `AutoslideR` dose formats
#'
#' @param ft flextable object
#' @param header_vals Header
#'
#' @export
autoslider_dose_format <- function(ft, header_vals = names(ft)) {
  ft %>%
    theme_booktabs() %>%
    delete_rows(i = 1, part = "header") %>%
    add_header_row(top = TRUE, values = header_vals, colwidths = rep.int(1, length(header_vals))) %>%
    bold(part = "header") %>%
    border_remove()
}

#' @describeIn autoslider_format
#'
#' Black color theme for AE listing
#' @author Nina Qi and Jasmina Uzunovic
#' @param ft flextable object
#' @param ... arguments passed to program
#'
#' @export
black_format_ae <- function(ft, body_font_size = 8, header_font_size = 8, ...) {
  ft <- do_call(autoslider_dose_format, ft = ft, ...)
  ft %>%
    fontsize(size = body_font_size, part = "body") %>%
    fontsize(size = header_font_size, 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)) %>%
    bg(i = ~ as.character(`Max\nGrade`) == "1", j = 6, bg = "lightskyblue1") %>%
    bg(i = ~ as.character(`Max\nGrade`) == "2", j = 6, bg = "steelblue1") %>%
    bg(i = ~ as.character(`Max\nGrade`) == "3", j = 6, bg = "lightsalmon") %>%
    bg(i = ~ as.character(`Max\nGrade`) == "4", j = 6, bg = "tomato") %>%
    bg(i = ~ as.character(`Max\nGrade`) == "5", j = 6, bg = "darkgrey") %>%
    bg(i = ~ `IMP1\nRelated?` == "Y", j = 7, bg = "lightsalmon") %>%
    bg(i = ~ `IMP2\nRelated?` == "Y", j = 8, bg = "lightsalmon") %>%
    bg(i = ~ grepl("INTERRUPT|REDUC|WITHDRAW", `IMP1\nAction\nTaken?`), j = 9, bg = "lightsalmon") %>%
    bg(i = ~ grepl("INTERRUPT|REDUC|WITHDRAW", `IMP2\nAction\nTaken?`), j = 10, bg = "lightsalmon")
}

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

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

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

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

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

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

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

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	5x	assert_that(has_name(adsl, arm))
25	5x	assert_that(has_name(adae, "AEACN"))
26	5x	assert_that(has_name(adae, "AEOUT"))
27	5x	assert_that(has_name(adae, "AECONTRT"))
28	5x	assert_that(has_name(adae, "AESER"))
29	5x	assert_that(has_name(adae, "AEREL"))
30	5x	assert_that(has_name(adae, grad_var))
31	5x	assert_that(has_name(adae, "AECONTRT"))
32
33	5x	aesi_sym <- rlang::sym(aesi)
34
35
36	4x	adae2 <- filter(adae, is.na(!!aesi_sym))
37
38	3x	adsl <- df_explicit_na(adsl)
39	3x	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	3x	adae2 <- adsl %>%
44	3x	inner_join(adae2, by = c("USUBJID", "TRT01A", "TRT01P", "ARM", "ARMCD", "ACTARM", "ACTARMCD")) %>%
45	3x	df_explicit_na()
46
47	3x	not_resolved <- adae2 %>%
48	3x	filter(!(AEOUT %in% c("RECOVERED/RESOLVED", "FATAL", "RECOVERED/RESOLVED WITH SEQUELAE"))) %>%
49	3x	distinct(USUBJID) %>%
50	3x	mutate(NOT_RESOLVED = "Y")
51
52	3x	adae2 <- adae2 %>%
53	3x	left_join(not_resolved, by = c("USUBJID")) %>%
54	3x	mutate(
55	3x	ALL_RESOLVED = formatters::with_label(
56	3x	is.na(NOT_RESOLVED),
57	3x	"Total number of patients with all non-fatal AESIs resolved"
58		),
59	3x	NOT_RESOLVED = formatters::with_label(
60	3x	!is.na(NOT_RESOLVED),
61	3x	"Total number of patients with at least one unresolved or ongoing non-fatal AESI"
62		)
63		)
64
65	3x	adae2 <- adae2 %>%
66	3x	mutate(
67	3x	AEDECOD = as.character(AEDECOD),
68	3x	WD = formatters::with_label(
69	3x	AEACN == "DRUG WITHDRAWN", "Total number of patients with study drug withdrawn due to AESI"
70		),
71	3x	DSM = formatters::with_label(
72	3x	AEACN %in% c("DRUG INTERRUPTED", "DOSE INCREASED", "DOSE REDUCED"),
73	3x	"Total number of patients with dose modified/interrupted due to AESI"
74		),
75	3x	CONTRT = formatters::with_label(AECONTRT == "Y", "Total number of patients with treatment received for AESI"),
76	3x	SER = formatters::with_label(AESER == "Y", "Total number of patients with at least one serious AESI"),
77	3x	REL = formatters::with_label(AEREL == "Y", "Total number of patients with at least one related AESI"),
78	3x	ALL_RESOLVED_WD = formatters::with_label(
79	3x	WD == TRUE & ALL_RESOLVED == TRUE,
80	3x	"No. of patients with study drug withdrawn due to resolved AESI"
81		),
82	3x	ALL_RESOLVED_DSM = formatters::with_label(
83	3x	DSM == TRUE & ALL_RESOLVED == TRUE,
84	3x	"No. of patients with dose modified/interrupted due to resolved AESI"
85		),
86	3x	ALL_RESOLVED_CONTRT = formatters::with_label(
87	3x	CONTRT == TRUE & ALL_RESOLVED == TRUE,
88	3x	"No. of patients with treatment received for resolved AESI"
89		),
90	3x	NOT_RESOLVED_WD = formatters::with_label(
91	3x	WD == TRUE & NOT_RESOLVED == TRUE,
92	3x	"No. of patients with study drug withdrawn due to unresolved or ongoing AESI"
93		),
94	3x	NOT_RESOLVED_DSM = formatters::with_label(
95	3x	DSM == TRUE & NOT_RESOLVED == TRUE,
96	3x	"No. of patients with dose modified/interrupted due to unresolved or ongoing AESI"
97		),
98	3x	NOT_RESOLVED_CONTRT = formatters::with_label(
99	3x	CONTRT == TRUE & NOT_RESOLVED == TRUE,
100	3x	"No. of patients with treatment received for unresolved or ongoing AESI"
101		),
102	3x	SERWD = formatters::with_label(
103	3x	AESER == "Y" & AEACN == "DRUG WITHDRAWN",
104	3x	"No. of patients with study drug withdrawn due to serious AESI"
105		),
106	3x	SERCONTRT = formatters::with_label(
107	3x	AECONTRT == "Y" & AESER == "Y",
108	3x	"No. of patients with dose modified/interrupted due to serious AESI"
109		),
110	3x	SERDSM = formatters::with_label(
111	3x	AESER == "Y" & AEACN %in% c("DRUG INTERRUPTED", "DOSE INCREASED", "DOSE REDUCED"),
112	3x	"No. of patients with treatment received for serious AESI"
113		),
114	3x	RELWD = formatters::with_label(
115	3x	AEREL == "Y" & AEACN == "DRUG WITHDRAWN",
116	3x	"No. of patients with study drug withdrawn due to related AESI"
117		),
118	3x	RELDSM = formatters::with_label(
119	3x	AEREL == "Y" & AEACN %in% c("DRUG INTERRUPTED", "DOSE INCREASED", "DOSE REDUCED"),
120	3x	"No. of patients with dose modified/interrupted due to related AESI"
121		),
122	3x	RELCONTRT = formatters::with_label(
123	3x	AECONTRT == "Y" & AEREL == "Y",
124	3x	"No. of patients with treatment received for related AESI"
125		),
126	3x	RELSER = formatters::with_label(AESER == "Y" & AEREL == "Y", "No. of patients with serious, related AESI")
127		)
128
129	3x	if (grad_var %in% c("AETOXGR", "ATOXGR")) {
130	1x	adae2 <- adae2 %>%
131	1x	mutate(
132	1x	{{ grad_var }} := forcats::fct_recode(get(grad_var),
133	1x	"Grade 1" = "1",
134	1x	"Grade 2" = "2",
135	1x	"Grade 3" = "3",
136	1x	"Grade 4" = "4",
137	1x	"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	3x	aesi_vars <- c("WD", "DSM", "CONTRT", "ALL_RESOLVED", "NOT_RESOLVED", "SER", "REL")
148
149	3x	lyt_adae <- basic_table(show_colcounts = TRUE) %>%
150	3x	split_cols_by(arm) %>%
151	3x	count_patients_with_event(
152	3x	vars = "USUBJID",
153	3x	filters = c("ANL01FL" = "Y"),
154	3x	denom = "N_col",
155	3x	.labels = c(count_fraction = "Total number of patients with at least one AESI")
156		) %>%
157	3x	count_values(
158	3x	"ANL01FL",
159	3x	values = "Y",
160	3x	.stats = "count",
161	3x	.labels = c(count = "Total number of AESIs"),
162	3x	table_names = "total_aes"
163		) %>%
164	3x	count_occurrences_by_grade(
165	3x	var = grad_var,
166	3x	var_labels = "Total number of patients with at least one AESI by worst grade",
167	3x	show_labels = "visible"
168		) %>%
169	3x	count_patients_with_flags("USUBJID", flag_variables = aesi_vars, denom = "N_col")
170
171	3x	result <- build_table(lyt_adae, df = adae2, alt_counts_df = adsl)
172
173
174	3x	result
175		}

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

1		#' 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 split_by_study Split by study, building structured header for tables
7		#' @param side_by_side should table be displayed side by side
8		#' @return rtables object
9		#' @inherit gen_notes note
10		#' @export
11		#' @examples
12		#' library(dplyr)
13		#' adsl <- eg_adsl %>%
14		#' dplyr::mutate(TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")))
15		#' adae <- eg_adae %>%
16		#' dplyr::mutate(
17		#' TRT01A = factor(TRT01A, levels = c("A: Drug X", "B: Placebo")),
18		#' ATOXGR = AETOXGR
19		#' )
20		#' out <- t_ae_slide(adsl, adae, "TRT01A")
21		#' print(out)
22		#' generate_slides(out, paste0(tempdir(), "/ae.pptx"))
23		t_ae_slide <- function(adsl, adae, arm = "TRT01A",
24		split_by_study = FALSE, side_by_side = NULL) {
25	2x	assert_that(has_name(adae, "AEDECOD"))
26	2x	assert_that(has_name(adae, "ATOXGR"))
27	2x	assert_that(has_name(adae, "AEBODSYS"))
28
29	2x	slref_arm <- sort(unique(adsl[[arm]]))
30	2x	anl_arm <- sort(unique(adae[[arm]]))
31	2x	assert_that(identical(slref_arm, anl_arm),
32	2x	msg = "The adsl and the analysis datasets should have the same treatment arm levels"
33		)
34
35	2x	anl <- adae %>%
36	2x	mutate_at(
37	2x	c("AEDECOD", "AEBODSYS"),
38	2x	~ explicit_na(sas_na(.)) # Replace blank arm with <Missing>
39		) %>%
40	2x	semi_join(., adsl, by = c("STUDYID", "USUBJID")) %>%
41	2x	mutate(
42	2x	AETOXGR = sas_na(AETOXGR) %>% as.factor()
43		) %>%
44	2x	formatters::var_relabel(
45	2x	AEBODSYS = "MedDRA System Organ Class",
46	2x	AEDECOD = "MedDRA Preferred Term"
47		)
48
49	2x	if (!is.null(side_by_side)) {
50	!	anl$lvl <- "Global"
51		}
52
53	2x	if (nrow(anl) == 0) {
54	1x	return(null_report())
55		} else {
56	1x	lyt <- build_table_header(adsl, arm,
57	1x	split_by_study = split_by_study,
58	1x	side_by_side = side_by_side
59		)
60
61	1x	lyt <- lyt %>%
62	1x	split_rows_by(
63	1x	"AEBODSYS",
64	1x	child_labels = "hidden",
65	1x	nested = FALSE,
66	1x	indent_mod = 0L,
67	1x	split_fun = drop_split_levels,
68	1x	label_pos = "topleft",
69	1x	split_label = obj_label(anl$AEBODSYS)
70		) %>%
71	1x	summarize_num_patients(
72	1x	var = "USUBJID",
73	1x	.stats = c("unique"),
74	1x	.labels = c(
75	1x	unique = "Total number of patients"
76		),
77	1x	.formats = list(trim_perc1)
78		) %>%
79	1x	count_occurrences(
80	1x	vars = "AEBODSYS",
81	1x	.indent_mods = -1L
82		# , .formats = list(trim_perc1)
83		) %>%
84	1x	count_occurrences(
85	1x	vars = "AEDECOD",
86	1x	.indent_mods = 1L
87		# , .formats = list(trim_perc1)
88		) %>%
89		# append_varlabels(anl, "AEDECOD", indent = TRUE)
90	1x	append_topleft(paste(" ", formatters::var_labels(anl["AEDECOD"]), "N (%)"))
91
92	1x	result <- lyt_to_side_by_side_two_data(lyt, anl, adsl, side_by_side)
93
94	1x	result1 <- result %>%
95	1x	prune_table() %>%
96	1x	sort_at_path(
97	1x	path = c("AEBODSYS"),
98	1x	scorefun = cont_n_allcols
99		) %>%
100	1x	sort_at_path(
101	1x	path = c("AEBODSYS", "*", "AEDECOD"),
102	1x	scorefun = score_occurrences
103		)
104
105	1x	t_aesi_trim_rows <- function(tt) {
106	1x	rows <- collect_leaves(tt, TRUE, TRUE)
107
108	1x	tbl <- tt[!grepl("unique", names(rows)), , keep_topleft = TRUE]
109
110	1x	tbl
111		}
112	1x	result1 <- result1 %>%
113	1x	t_aesi_trim_rows()
114	1x	result1@main_title <- "AE event table"
115	1x	return(result1)
116		}
117		}

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

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

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	11x	if (is.null(side_by_side)) {
31	6x	extra <- NULL
32		} else {
33	5x	extra <- c("COUNTRY")
34		}
35
36	11x	for (v in c(vars, extra)) {
37	52x	assert_that(has_name(adsl, v))
38		}
39
40	11x	adsl1 <- adsl %>%
41	11x	select(all_of(c("STUDYID", "USUBJID", arm, vars, extra)))
42
43	11x	if (!is.null(side_by_side)) {
44	5x	adsl1$lvl <- "Global"
45		}
46
47	11x	lyt <- build_table_header(adsl1, arm,
48	11x	split_by_study = split_by_study,
49	11x	side_by_side = side_by_side
50		)
51
52	11x	lyt <- lyt %>%
53	11x	analyze_vars(
54	11x	na.rm = TRUE,
55	11x	.stats = stats,
56	11x	denom = "n",
57	11x	vars = vars,
58	11x	.formats = c(mean_sd = "xx.xx (xx.xx)", median = "xx.xx"),
59	11x	var_labels = formatters::var_labels(adsl1)[vars]
60		)
61
62	11x	result <- lyt_to_side_by_side(lyt, adsl1, side_by_side)
63
64	11x	if (is.null(side_by_side)) {
65		# adding "N" attribute
66	6x	arm <- col_paths(result)[[1]][1]
67
68	6x	n_r <- data.frame(
69	6x	ARM = toupper(names(result@col_info)),
70	6x	N = col_counts(result) %>% as.numeric()
71		) %>%
72	6x	`colnames<-`(c(paste(arm), "N")) %>%
73	6x	dplyr::arrange(get(arm))
74
75	6x	attr(result, "N") <- n_r
76		}
77	11x	result@main_title <- "Demographic slide"
78	11x	result
79		}
80
81		#' Demographic table with gtsummary
82		#'
83		#' @param adsl ADSL data set, dataframe
84		#' @param arm Arm variable, character, "`TRT01P" by default.
85		#' @param vars Characters of variables
86		#' @return gtsummary object
87		#' @inherit gen_notes note
88		#' @export
89		#' @examples
90		#' library(dplyr)
91		#' adsl <- eg_adsl
92		#' out1 <- gt_t_dm_slide(adsl, "TRT01P", c("SEX", "AGE", "RACE", "ETHNIC", "COUNTRY"))
93		#' print(out1)
94		#' generate_slides(out1, paste0(tempdir(), "/dm.pptx"))
95		#'
96		gt_t_dm_slide <- function(adsl,
97		arm = "TRT01P",
98		vars = c("AGE", "SEX", "RACE")) {
99	1x	adsl \|>
100	1x	select(all_of(c(vars, arm))) \|>
101	1x	tbl_summary(by = all_of(arm)) \|>
102	1x	modify_caption(caption = "Demographic slide") # Set default title
103		}

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	15x	suffix <- spec$suffix
10	15x	function_args <- names(formals(func))
11	15x	datasets_filtered <- filters::apply_filter(
12	15x	data = datasets,
13	15x	id = suffix,
14	15x	verbose = verbose
15		)
16
17	15x	if ("datasets" %in% function_args) {
18	!	if ("spec" %in% function_args) {
19	!	return({
20	!	function(...) {
21	!	fastDoCall(func, list(datasets_filtered, spec = spec, ...))
22		}
23		})
24		} else {
25	!	return({
26	!	function(...) {
27	!	fastDoCall(func, list(datasets_filtered, ...))
28		}
29		})
30		}
31		} else {
32		# to keep compatibility with previous version
33	15x	data_used <-
34	15x	function_args[function_args %in% names(datasets)]
35	15x	if ("spec" %in% function_args) {
36	!	return({
37	!	function(...) {
38	!	fastDoCall(func, c(
39	!	datasets_filtered[data_used],
40	!	list(spec = spec),
41	!	list(...)
42		))
43		}
44		})
45		} else {
46	15x	return({
47	15x	function(...) {
48	15x	fastDoCall(func, c(datasets_filtered[data_used], list(...)))
49		}
50		})
51		}
52		}
53		}

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

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

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	15x	suffix <- spec$suffix
42	15x	if (verbose_level > 0) {
43	15x	cat_bullet(
44	15x	sprintf(
45	15x	"Running program `%s` with suffix '%s'.",
46	15x	program,
47	15x	suffix
48		),
49	15x	bullet = "pointer",
50	15x	bullet_col = "green"
51		)
52		}
53	15x	func <- tryCatch(
54		{
55	15x	func_wrapper(
56	15x	func = match.fun(program),
57	15x	datasets = datasets,
58	15x	spec = spec,
59	15x	verbose = verbose_level > 1
60		)
61		},
62	15x	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	15x	if (is(func, "autoslider_error")) {
71	!	return(func)
72		}
73	15x	ret <- tryCatch(
74		{
75	15x	func(...)
76		},
77	15x	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	15x	return(ret)
86		}
87
88		#' Generate all outputs from a spec
89		#'
90		#' @param spec Specification list generated by `read_spec`
91		#' @param datasets A `list` of datasets
92		#' @param verbose_level Verbose level of messages be displayed. See details for further information.
93		#' @return No return value, called for side effects
94		#' @details
95		#' `verbose_level` is used to control how many messages are printed out.
96		#' By default, `2` will show all filter messages and show output generation message.
97		#' `1` will show output generation message only.
98		#' `0` will display no message.
99		#'
100		#' @author
101		#' - Thomas Neitmann (`neitmant`)
102		#' - Liming Li (`Lil128`)
103		#'
104		#' @export
105		#'
106		#' @examplesIf require(filters)
107		#' library(dplyr, warn.conflicts = FALSE)
108		#' data <- list(
109		#' adsl = eg_adsl,
110		#' adae = eg_adae
111		#' )
112		#' filters::load_filters(
113		#' yaml_file = system.file("filters.yml", package = "autoslider.core"),
114		#' overwrite = TRUE
115		#' )
116		#'
117		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
118		#' spec_file %>%
119		#' read_spec() %>%
120		#' filter_spec(output %in% c("t_dm_slide_IT", "t_ae_slide_SE")) %>%
121		#' generate_outputs(datasets = data)
122		#'
123		generate_outputs <- function(spec, datasets, verbose_level = 2) {
124	1x	lapply(spec, function(s) {
125	15x	args <- c(
126	15x	list(
127	15x	program = s$program,
128	15x	spec = s,
129	15x	datasets = datasets,
130	15x	verbose_level = verbose_level
131		),
132	15x	s$args # ... arguments passed onto the output-generating function
133		)
134	15x	output <- fastDoCall(generate_output, args)
135	15x	attr(output, "spec") <- s
136	15x	output
137		})
138		}

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	7x	assert_that(has_name(adsl, "DTHCAT"))
25	7x	assert_that(has_name(adsl, "DTHFL"))
26
27	7x	anl <- adsl
28
29	7x	if (!is.null(side_by_side)) {
30	2x	anl$lvl <- "Global"
31		}
32
33	7x	if (nrow(anl) == 0) {
34	1x	return(null_report())
35		} else {
36	6x	lyt <- build_table_header(adsl, arm, split_by_study = split_by_study, side_by_side = side_by_side)
37
38	6x	lyt <- lyt %>%
39	6x	count_values(
40	6x	"DTHFL",
41	6x	values = "Y",
42	6x	denom = c("N_col"),
43	6x	.labels = c(count_fraction = "All Deaths")
44		) %>%
45	6x	analyze_vars(
46	6x	vars = "DTHCAT", .stats = "count_fraction",
47	6x	na_str = "<Missing>",
48	6x	var_labels = " ",
49	6x	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	6x	append_topleft("N (%)")
59
60	6x	result <- lyt_to_side_by_side(lyt, anl, side_by_side)
61	5x	result@main_title <- "Death table"
62	5x	result
63		}
64		}

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

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		#' @examples
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		}
58
59
60
61		#' Plot mean values of VS
62		#'
63		#' Wrapper for `g_mean_general()`.
64		#' Requires filtering of the datasets (e.g. using SUFFIX in spec.yml)
65		#'
66		#' @param adsl ADSL data
67		#' @param advs ADVS data
68		#' @param arm `"TRT01P"` by default
69		#' @inheritParams g_mean_general
70		#' @param paramcd Which variable to use for plotting. By default `"PARAM"`
71		#' @param ... \|
72		#' Gets forwarded to `tern::g_lineplot()`.
73		#' This lets you specify additional arguments to `tern::g_lineplot()`
74		#' @author Stefan Thoma (`thomas7`)
75		#' @export
76		#' @examples
77		#' library(dplyr)
78		#' advs_filtered <- eg_advs %>% filter(
79		#' PARAMCD == "SYSBP"
80		#' )
81		#'
82		#' plot_vs <- g_vs_slide(
83		#' adsl = eg_adsl,
84		#' advs = advs_filtered,
85		#' paramcd = "PARAM",
86		#' subtitle_add_unit = FALSE
87		#' ) +
88		#' ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))
89		#'
90		#' generate_slides(plot_vs, paste0(tempdir(), "/g_vs.pptx"))
91		g_vs_slide <- function(adsl, advs, arm = "TRT01P", paramcd = "PARAM",
92		subtitle = "Plot of Mean and 95% Confidence Limits by Visit.", ...) {
93		# tern 0.9.4 added facet_var in control_lineplot_vars
94	4x	variables <- control_lineplot_vars(group_var = arm, paramcd = paramcd) %>% strip_NA()
95
96	3x	by_vars <- c("USUBJID", "STUDYID")
97	3x	assert_that(is.string(arm))
98	3x	assert_that(has_name(advs, c(by_vars, variables) %>% unique()))
99	3x	assert_that(has_name(adsl, c(by_vars, arm) %>% unique()))
100
101	3x	g_mean_general(
102	3x	adsl = adsl, data = advs, variables = variables, by_vars = by_vars,
103	3x	subtitle = subtitle, ...
104		)
105		}
106
107
108
109		#' Plot mean values of LB
110		#'
111		#' Wrapper for `g_mean_general()`.
112		#' Requires filtering of the datasets (e.g. using SUFFIX in spec.yml)
113		#'
114		#' @param adsl ADSL data
115		#' @param adlb ADLB data
116		#' @param arm `"TRT01P"` by default
117		#' @param paramcd character scalar. defaults to By default `"PARAM"`
118		#' Which variable to use for plotting.
119		#' @param y character scalar. Variable to plot on the Y axis. By default `"AVAL"`
120		#' @inheritParams g_mean_general
121		#' @param ... \|
122		#' Gets forwarded to `tern::g_lineplot()`.
123		#' This lets you specify additional arguments to `tern::g_lineplot()`
124		#' @author Stefan Thoma (`thomas7`)
125		#' @export
126		#' @examples
127		#' library(dplyr)
128		#'
129		#' adlb_filtered <- eg_adlb %>% filter(
130		#' PARAMCD == "CRP"
131		#' )
132		#' plot_lb <- g_lb_slide(
133		#' adsl = eg_adsl,
134		#' adlb = adlb_filtered,
135		#' paramcd = "PARAM",
136		#' subtitle_add_unit = FALSE
137		#' ) +
138		#' ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))
139		#' generate_slides(plot_lb, paste0(tempdir(), "/g_lb.pptx"))
140		#'
141		#' # Let's plot change values:
142		#' plot_lb_chg <- g_lb_slide(
143		#' adsl = eg_adsl,
144		#' adlb = adlb_filtered,
145		#' paramcd = "PARAM",
146		#' y = "CHG",
147		#' subtitle = "Plot of change from baseline and 95% Confidence Limit by Visit."
148		#' )
149		#' generate_slides(plot_lb_chg, paste0(tempdir(), "/g_lb_chg.pptx"))
150		#'
151		g_lb_slide <- function(adsl, adlb, arm = "TRT01P", paramcd = "PARAM", y = "AVAL",
152		subtitle = "Plot of Mean and 95% Confidence Limits by Visit.", ...) {
153		# tern 0.9.4 added facet_var in control_lineplot_vars
154	3x	variables <- control_lineplot_vars(group_var = arm, paramcd = paramcd, y = y) %>%
155	3x	strip_NA()
156
157	2x	by_vars <- c("USUBJID", "STUDYID")
158	2x	assert_that(is.string(arm))
159	2x	assert_that(is.string(paramcd))
160	2x	assert_that(is.string(y))
161	2x	assert_that(has_name(adlb, c(by_vars, variables) %>% unique()))
162	2x	assert_that(has_name(adsl, c(by_vars, arm) %>% unique()))
163	2x	assert_that(is.string(subtitle))
164
165	2x	g_mean_general(
166	2x	adsl = adsl, data = adlb, variables = variables, by_vars = by_vars,
167	2x	subtitle = subtitle, ...
168		)
169		}
170
171
172		#' Plot mean values of EG
173		#'
174		#' Wrapper for `g_mean_general()`.
175		#' Requires filtering of the datasets (e.g. using SUFFIX in spec.yml)
176		#'
177		#' @param adsl ADSL data
178		#' @param adeg ADVS data
179		#' @param arm `"TRT01P"` by default
180		#' @param paramcd Which variable to use for plotting. By default `"PARAM"`
181		#' @inheritParams g_mean_general
182		#' @param ... \|
183		#' Gets forwarded to `tern::g_lineplot()`.
184		#' This lets you specify additional arguments to `tern::g_lineplot()`
185		#' @author Stefan Thoma (`thomas7`)
186		#' @importFrom forcats fct_reorder
187		#' @export
188		#' @examples
189		#' library(dplyr)
190		#'
191		#' adeg_filtered <- eg_adeg %>% filter(
192		#' PARAMCD == "HR"
193		#' )
194		#' plot_eg <- g_eg_slide(
195		#' adsl = eg_adsl,
196		#' adeg = adeg_filtered,
197		#' arm = "TRT01P",
198		#' paramcd = "PARAM",
199		#' subtitle_add_unit = FALSE
200		#' ) +
201		#' ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))
202		#'
203		#' generate_slides(plot_eg, paste0(tempdir(), "/g_eg.pptx"))
204		g_eg_slide <- function(adsl, adeg, arm = "TRT01P", paramcd = "PARAM",
205		subtitle = "Plot of Mean and 95% Confidence Limits by Visit.", ...) {
206		# tern 0.9.4 added facet_var in control_lineplot_vars
207	5x	variables <- control_lineplot_vars(group_var = arm, paramcd = paramcd) %>% strip_NA()
208	3x	by_vars <- c("USUBJID", "STUDYID")
209	3x	assert_that(is.string(arm))
210	3x	assert_that(has_name(adeg, c(by_vars, variables) %>% unique()))
211	3x	assert_that(has_name(adsl, c(by_vars, arm) %>% unique()))
212	3x	assert_that(is.string(subtitle))
213
214	3x	g_mean_general(
215	3x	adsl = adsl, data = adeg, variables = variables, by_vars = by_vars,
216	3x	subtitle = subtitle, ...
217		)
218		}

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

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	30x	if (quote) {
16	!	args <- lapply(args, enquote)
17		}
18
19	30x	if (is.null(names(args))) {
20	!	argn <- args
21	!	args <- list()
22		} else {
23		# Add all the named arguments
24	30x	argn <- lapply(names(args)[names(args) != ""], as.name)
25	30x	names(argn) <- names(args)[names(args) != ""]
26		# Add the unnamed arguments
27	30x	argn <- c(argn, args[names(args) == ""])
28	30x	args <- args[names(args) != ""]
29		}
30
31	30x	if (is(what, "character")) {
32	!	if (is.character(what)) {
33	!	fn <- strsplit(what, "[:]{2,3}")[[1]]
34	!	what <- if (length(fn) == 1) {
35	!	get(fn[[1]], envir = envir, mode = "function")
36		} else {
37	!	get(fn[[2]], envir = asNamespace(fn[[1]]), mode = "function")
38		}
39		}
40	!	call <- as.call(c(list(what), argn))
41	30x	} else if (is(what, "function")) {
42	30x	f_name <- deparse(substitute(what))
43	30x	call <- as.call(c(list(as.name(f_name)), argn))
44	30x	args[[f_name]] <- what
45	!	} else if (is(what, "name")) {
46	!	call <- as.call(c(list(what, argn)))
47		}
48
49	30x	eval(call,
50	30x	envir = args,
51	30x	enclos = envir
52		)
53		}

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

1		#' 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	1x	assert_that(has_name(df, "DISTRTFL"),
64	1x	msg = "`DISTRTFL` variable is needed for deriving `STDONS` variable,
65	1x	suggest to use `DTRTxxFL` to create `DISTRTFL`."
66		)
67	1x	noNA(levels)
68	1x	noNA(labels)
69	1x	assert_that(length(levels) >= 3)
70	1x	assert_that(length(labels) >= 3)
71
72	1x	data_adsl <- df %>%
73		# Calculate STDONS
74	1x	mutate(STDONS = case_when(
75	1x	toupper(EOSSTT) == "ONGOING" & DTHFL == "" & DISTRTFL == "N" ~ "Alive: On Treatment",
76	1x	toupper(EOSSTT) == "ONGOING" & DISTRTFL == "Y" ~ "Alive: In Follow-up",
77	1x	TRUE ~ ""
78		)) %>%
79		# Process variable
80	1x	mutate(STDONS = factor(explicit_na(sas_na(STDONS)), levels = levels, labels = labels))
81		}

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

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

1		abort <- function(...) {
2	!	stop(..., call. = FALSE)
3		}
4
5		assert_is_character_scalar <- function(x) {
6	112x	if (length(x) != 1L \|\| is.na(x) \|\| !is.character(x) \|\| x == "") {
7	!	abort("`", deparse(substitute(x)), "` must be a character scalar.")
8		}
9		}
10
11		assert_is_valid_version_label <- function(x) {
12	1x	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) {
19	102x	exist_in_spec <- vars %in% names(output)
20	102x	exist_in_calling_env <- map_lgl(vars, exists, parent.frame(n = 2L))
21	102x	non_existing_vars <- vars[!(exist_in_spec \| exist_in_calling_env)]
22
23
24	102x	n <- length(non_existing_vars)
25	102x	if (n >= 1L) {
26	!	err_msg <- sprintf(
27	!	paste(
28	!	"Cannot filter based upon the %s %s as %s not contained in",
29	!	"`spec` or the surrounding environment."
30		),
31	!	if (n == 1L) "variable" else "variables",
32	!	enumerate(non_existing_vars),
33	!	if (n == 1L) "it is" else "they are"
34		)
35	!	stop(err_msg, call. = FALSE)
36		}
37		}
38
39		assert_is_valid_filter_result <- function(x) {
40	102x	if (length(x) != 1L \|\| is.na(x) \|\| !is.logical(x)) {
41	!	stop(
42	!	"`filter_expr` must evaluate to a logical scalar but returned `",
43	!	deparse(x), "`.",
44	!	call. = FALSE
45		)
46		}
47		}

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	7x	assert_that(has_name(adsl, arm))
24	7x	assert_that(has_name(adsl, "SAFFL"))
25	7x	assert_that(has_name(adsl, "STDONS"),
26	7x	msg = "`STDONS` variable is needed for this output, please use `preprocess_t_ds` function to derive."
27		)
28	7x	assert_that(has_name(adsl, "DCSREAS"))
29	7x	assert_that(length(levels(adsl$STDONS)) <= 3)
30
31	7x	adsl1 <- adsl %>%
32	7x	mutate(
33	7x	STDONS = factor(explicit_na(sas_na(STDONS)),
34	7x	levels = c("Alive: On Treatment", "Alive: In Follow-up", "<Missing>"),
35	7x	labels = c("On Treatment", "In Follow-up", "<Missing>")
36		),
37	7x	DCSREAS = str_to_title(factor(sas_na(DCSREAS))),
38	7x	DCSflag = ifelse(is.na(DCSREAS), "N", "Y"),
39	7x	STDONSflag = ifelse(STDONS == "<Missing>", "N", "Y")
40		) %>%
41	7x	mutate_at(c("STDONS", "DCSREAS"), ~ as.factor(explicit_na(.))) %>%
42	7x	formatters::var_relabel(
43	7x	STDONS = "On-study Status",
44	7x	DCSflag = "Discontinued the study"
45		)
46
47	7x	if (!is.null(side_by_side)) {
48	3x	adsl1$lvl <- "Global"
49		}
50
51	7x	lyt <- build_table_header(adsl1, arm, split_by_study = split_by_study, side_by_side = side_by_side)
52
53	7x	lyt <- lyt %>%
54	7x	count_values("SAFFL",
55	7x	values = "Y",
56	7x	.labels = c(count_fraction = "Received Treatment")
57		) %>%
58	7x	split_rows_by(
59	7x	"STDONSflag",
60	7x	split_fun = keep_split_levels("Y"),
61		) %>%
62	7x	summarize_row_groups(label_fstr = "On-study Status") %>%
63	7x	analyze_vars(
64	7x	"STDONS",
65	7x	.stats = "count_fraction",
66	7x	denom = "N_col",
67	7x	na.rm = TRUE,
68		# var_labels = formatters::var_labels(adsl1)["STDONS"]
69		) %>%
70	7x	split_rows_by(
71	7x	"DCSflag",
72	7x	split_fun = keep_split_levels("Y"),
73		) %>%
74	7x	summarize_row_groups(label_fstr = "Discontinued the study") %>%
75	7x	analyze_vars(
76	7x	"DCSREAS",
77	7x	.stats = "count_fraction",
78	7x	denom = "N_col"
79		)
80
81	7x	result <- lyt_to_side_by_side(lyt, adsl1, side_by_side)
82	7x	result@main_title <- "Discontinue table"
83	7x	return(result)
84		}

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		#' Table color and font
2		#'
3		#' @description Zebra themed color
4		#'
5		#' @name autoslider_format
6		NULL
7
8		#' @describeIn autoslider_format
9		#'
10		#' User defined color code and font size
11		#'
12		#' @param ft flextable object
13		#' @param odd_header Hex color code, default to deep sky blue
14		#' @param odd_body Hex color code, default to alice blue
15		#' @param even_header Hex color code, default to slate gray
16		#' @param even_body Hex color code, default to slate gray
17		#' @param font_name Font name, default to arial
18		#' @param body_font_size Font size of the table content, default to 12
19		#' @param header_font_size Font size of the table header, default to 14
20		#' @return A flextable with applied theme.
21		#' @export
22		autoslider_format <- function(ft,
23		odd_header = "#0EAED5", # "deepskyblue2",
24		odd_body = "#EBF5FA", # "aliceblue",
25		even_header = "#0EAED5", # "slategray1",
26		even_body = "#D0E4F2", # "slategray1" # slategray1,
27		font_name = "arial",
28		body_font_size = 12,
29		header_font_size = 14) {
30	289x	ft %>%
31	289x	theme_zebra(
32	289x	odd_header = odd_header,
33	289x	odd_body = odd_body,
34	289x	even_header = odd_header,
35	289x	even_body = even_body
36		) %>%
37	289x	font(fontname = font_name, part = "all") %>%
38	289x	fontsize(size = body_font_size, part = "body") %>%
39	289x	color(color = "white", part = "header") %>%
40	289x	fontsize(size = header_font_size, part = "header") %>%
41	289x	bold(part = "header")
42		}
43
44
45		#' @describeIn autoslider_format
46		#'
47		#' Blue color theme
48		#'
49		#' @param ft flextable object
50		#' @param ... arguments passed to program
51		#'
52		#' @export
53		blue_format <- function(ft, ...) {
54	1x	ft %>% autoslider_format(
55	1x	odd_header = "#0B41CD",
56	1x	odd_body = "#1482FA",
57	1x	even_body = "#BDE3FF",
58		...
59		)
60		}
61
62		#' @describeIn autoslider_format
63		#'
64		#' Orange color theme
65		#'
66		#' @param ft flextable object
67		#' @param ... arguments passed to program
68		#'
69		#' @export
70		orange_format <- function(ft, ...) {
71	285x	ft %>% autoslider_format(
72	285x	odd_header = "#ED4A0D",
73	285x	odd_body = "#FF7D29",
74	285x	even_body = "#FFBD69",
75		...
76		)
77		}
78
79		#' @describeIn autoslider_format
80		#'
81		#' Red color theme
82		#'
83		#' @param ft flextable object
84		#' @param ... arguments passed to program
85		#'
86		#' @export
87		red_format <- function(ft, ...) {
88	1x	ft %>% autoslider_format(
89	1x	odd_header = "#C40000",
90	1x	odd_body = "#FF1F26",
91	1x	even_body = "#FF8782",
92		...
93		)
94		}
95
96
97		#' @describeIn autoslider_format
98		#'
99		#' Purple color theme
100		#'
101		#' @param ft flextable object
102		#' @param ... arguments passed to program
103		#'
104		#' @export
105		purple_format <- function(ft, ...) {
106	1x	ft %>% autoslider_format(
107	1x	odd_header = "#BC36F0",
108	1x	odd_body = "#E085FC",
109	1x	even_body = "#F2D4FF",
110		...
111		)
112		}
113
114		#' @describeIn autoslider_format
115		#'
116		#' `AutoslideR` dose formats
117		#'
118		#' @param ft flextable object
119		#' @param header_vals Header
120		#'
121		#' @export
122		autoslider_dose_format <- function(ft, header_vals = names(ft)) {
123	!	ft %>%
124	!	theme_booktabs() %>%
125	!	delete_rows(i = 1, part = "header") %>%
126	!	add_header_row(top = TRUE, values = header_vals, colwidths = rep.int(1, length(header_vals))) %>%
127	!	bold(part = "header") %>%
128	!	border_remove()
129		}
130
131		#' @describeIn autoslider_format
132		#'
133		#' Black color theme for AE listing
134		#' @author Nina Qi and Jasmina Uzunovic
135		#' @param ft flextable object
136		#' @param ... arguments passed to program
137		#'
138		#' @export
139		black_format_ae <- function(ft, body_font_size = 8, header_font_size = 8, ...) {
140	!	ft <- do_call(autoslider_dose_format, ft = ft, ...)
141	!	ft %>%
142	!	fontsize(size = body_font_size, part = "body") %>%
143	!	fontsize(size = header_font_size, part = "header") %>%
144	!	color(color = "blue", part = "header") %>%
145	!	border_inner_h(part = "all", border = fp_border(color = "black")) %>%
146	!	hline_top(part = "all", border = fp_border(color = "black", width = 2)) %>%
147	!	hline_bottom(part = "all", border = fp_border(color = "black", width = 2)) %>%
148	!	bg(i = ~ as.character(`Max\nGrade`) == "1", j = 6, bg = "lightskyblue1") %>%
149	!	bg(i = ~ as.character(`Max\nGrade`) == "2", j = 6, bg = "steelblue1") %>%
150	!	bg(i = ~ as.character(`Max\nGrade`) == "3", j = 6, bg = "lightsalmon") %>%
151	!	bg(i = ~ as.character(`Max\nGrade`) == "4", j = 6, bg = "tomato") %>%
152	!	bg(i = ~ as.character(`Max\nGrade`) == "5", j = 6, bg = "darkgrey") %>%
153	!	bg(i = ~ `IMP1\nRelated?` == "Y", j = 7, bg = "lightsalmon") %>%
154	!	bg(i = ~ `IMP2\nRelated?` == "Y", j = 8, bg = "lightsalmon") %>%
155	!	bg(i = ~ grepl("INTERRUPT\|REDUC\|WITHDRAW", `IMP1\nAction\nTaken?`), j = 9, bg = "lightsalmon") %>%
156	!	bg(i = ~ grepl("INTERRUPT\|REDUC\|WITHDRAW", `IMP2\nAction\nTaken?`), j = 10, bg = "lightsalmon")
157		}
158
159		#' @describeIn autoslider_format
160		#'
161		#' Black color theme
162		#' @author Nina Qi and Jasmina Uzunovic
163		#' @param ft flextable object
164		#' @param ... arguments passed to program
165		#'
166		#' @export
167		black_format_tb <- function(ft, body_font_size = 8, header_font_size = 8, ...) {
168	!	ft %>%
169	!	theme_booktabs() %>%
170	!	fontsize(size = body_font_size, part = "body") %>%
171	!	fontsize(size = header_font_size, part = "header") %>%
172	!	bold(part = "header") %>%
173	!	color(color = "blue", part = "header") %>%
174	!	border_inner_h(part = "all", border = fp_border(color = "black")) %>%
175	!	hline_top(part = "all", border = fp_border(color = "black", width = 2)) %>%
176	!	hline_bottom(part = "all", border = fp_border(color = "black", width = 2))
177		}

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

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		}