autoslider.core coverage - 81.95%

Files
Source

#' 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
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
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 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) {
      if ("ggplot" %in% class(g)) {
        return(ggplot2::ggplotGrob(g))
      } else {
        return(g)
      }
    })
    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 = ", "
      )
    }

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

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

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

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

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

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

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

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

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

  result
}


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

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

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

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

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

#' 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.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
#' @examples
#' ## As `save_outputs` is the last step in the pipeline we have to run
#' ## the 'whole machinery' in order to show its functionality. Also take a look
#' ## at the `AutoslideR-Demo` repo on code.roche.com.
#' 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 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
#' @examples
#'
#' # 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")
  ))) {
    if (is(outputs, "ggplot")) {
      current_title <- outputs$labels$title
      if (is.null(current_title)) {
        current_title <- ""
      }
      outputs <- decorate.ggplot(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 (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")) {
    ret <- to_flextable(old_paginate_listing(x, cpp = 150, lpp = 20)[[1]],
      col_width = formatters::propose_column_widths(x)
    )
  } else if (is(x, "ggplot")) {
    ret <- x
  }
  return(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
  return(ph_location(left = left, top = top))
}


#' 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
  return(ph_location(left = left, top = top))
}

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

#' 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`)
#'
#' @export
#'
#' @examples
#' spec_file <- system.file("spec.yml", package = "autoslider.core")
#'
#' ## Take a look at the 'raw' content of the spec file
#' cat(readLines(spec_file)[1:24], sep = "\n")
#'
#' ## This is how it looks once read into R
#' spec <- read_spec(spec_file)
#' spec[1:3]
#'
read_spec <- function(spec_file = "spec.yml",
                      metadata = NULL) {
  spec <- yaml::read_yaml(spec_file, eval.expr = TRUE)
  ret <- lapply(spec, function(s) {
    lapply(s$suffix, function(su) {
      ret <- s
      ret$suffix <- su
      c(ret, metadata)
    })
  })
  spec_obj <- unlist(ret, recursive = FALSE)
  as_spec(spec_obj)
}

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

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

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

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

  as_spec(filtered_spec)
}

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

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

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

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

    elem
  })

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

#' Adverse event 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 (nrow(anl) == 0) {
    return(null_report())
  } else {
    lyt <- build_table_header(adsl, arm,
      split_by_study = split_by_study,
      side_by_side = side_by_side
    )

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

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

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

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

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

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

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

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

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

  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
}

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))
    }
  }
  return(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
      }
    }
  }
  return(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))) {
    return(NA)
  } else {
    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)
  return(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 = "")
  return(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 = "")
  return(ret)
}

#' @noRd
fs <- function(paper) {
  fontsize <- as.integer(substr(paper, 2, nchar(paper)))
  orientation <- substr(paper, 1, 1)
  return(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) {
  if (tools::file_ext(file_path) != "") {
    return(file_path)
  } else {
    file_ext <- ifelse(is_rtable(output) || "dVTableTree" %in% class(output), "out", "pdf")
    return(sprintf("%s.%s", file_path, file_ext))
  }
}

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)) {
      result <- cbind_rtables(
        result,
        build_table(
          lyt = lyt,
          df = anl %>% filter(COUNTRY %in% c("CHN", "HKG", "TWN", "KOR", "SGP", "THA", "MYS"))
        )
      )
    }

    if (grepl("China", side_by_side)) {
      result <- cbind_rtables(result, build_table(lyt = lyt, df = anl %>% filter(COUNTRY == "CHN")))
    }
  }
  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)) {
      result <- cbind_rtables(
        result,
        build_table(
          lyt = lyt,
          df = anl %>% filter(COUNTRY %in% c("CHN", "HKG", "TWN", "KOR", "SGP", "THA", "MYS")),
          alt_counts_df = alt_counts_df %>% filter(COUNTRY %in% c("CHN", "HKG", "TWN", "KOR", "SGP", "THA", "MYS"))
        )
      )
    }

    if (grepl("China", side_by_side)) {
      result <- cbind_rtables(result, build_table(
        lyt = lyt, df = anl %>% filter(COUNTRY == "CHN"),
        alt_counts_df = alt_counts_df %>% filter(COUNTRY == "CHN")
      ))
    }
  }
  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 = arm) %>%
      add_overall_col("All Patients")
  }
  return(lyt)
}


get_version_label_output <- function() {
  NULL
}


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

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

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

  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",
        table_names = "U",
        filters = c("SAFFL" = "Y"),
        denom = "N_col",
        .stats = "count_fraction",
        .labels = c(count_fraction = "All grade AEs, any cause")
        # .formats = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_REL0 = "Related"),
        denom = "N_col",
        .indent_mods = 1L
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_G34 = "Grade 3-4 AEs"),
        denom = "N_col",
        .indent_mods = 0L
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_G34_REL = "Related"),
        denom = "N_col",
        .indent_mods = 1L
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_G5 = "Grade 5 AE"),
        denom = "N_col",
        .indent_mods = 0L
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_G5_REL = "Related"),
        denom = "N_col",
        .indent_mods = 1L
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_SER = "SAEs"),
        denom = "N_col",
        .indent_mods = 0L
        # .format = list(trim_perc1)
      ) %>%
      count_patients_with_flags(
        "USUBJID",
        flag_variables = c(TMPFL1_SER_REL = "Related"),
        denom = "N_col",
        .indent_mods = 1L
        # .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',
         .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)
}

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

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

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

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

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

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

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

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

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

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

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


assert_exists_in_spec_or_calling_env <- function(vars, output) {
  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
    )
  }
}

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

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

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

#' Adverse event table
#'
#' @param adae ADAE data set, dataframe
#' @param adsl ADSL data set, dataframe
#' @param arm Arm variable, character, "`TRT01A" by default.
#' @param cutoff Cutoff threshold
#' @param 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
}

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

#' 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
#' @examples
#'
#' # 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 ~ ""
  )

  return(x_form)
}

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

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

#' 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
#' @examples
#' library(dplyr)
#' library(filters)
#' data <- list(
#'   adsl = eg_adsl,
#'   adae = eg_adae %>% mutate(AREL = "")
#' )
#'
#' null_report()
#'
#' ## An example how to use the `null_report()` inside an output function
#' t_ae <- function(datasets) {
#'   trt <- "ACTARM"
#'   anl <- semi_join(
#'     datasets$adae,
#'     datasets$adsl,
#'     by = c("STUDYID", "USUBJID")
#'   )
#'
#'   return(null_report())
#' }
#'
#' data %>%
#'   filters::apply_filter("SER_SE") %>%
#'   t_ae()
#'
#' @export
#'
null_report <- function() {
  rtable(
    header = " ",
    rrow("", "Null Report: No observations met the reporting criteria for inclusion in this output.")
  )
}

1		#' 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	3x	assert_that(has_name(adsl, arm))
21	3x	assert_that(has_name(adtte, "CNSR"))
22	3x	assert_that(has_name(adtte, "EVNTDESC"))
23	3x	assert_that(has_name(adtte, "AVALU"))
24	3x	assert_that(has_name(adtte, "AVAL"))
25	3x	assert_that(all(!is.na(adtte[["AVALU"]])))
26
27	3x	slref_arm <- sort(unique(adsl[[arm]]))
28	3x	anl_arm <- sort(unique(adtte[[arm]]))
29	3x	assert_that(identical(slref_arm, anl_arm),
30	3x	msg = "The adsl and the analysis datasets should have the same treatment arm levels"
31		)
32
33
34	3x	time_unit <- unique(adtte[["AVALU"]])
35	3x	assert_that(length(time_unit) == 1)
36
37	3x	if (toupper(time_unit) == "DAYS") {
38	2x	adtte <- adtte %>%
39	2x	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	3x	adtte_f <- adtte %>%
46	3x	dplyr::mutate(
47	3x	is_event = CNSR == 0,
48	3x	is_not_event = CNSR == 1,
49	3x	EVNT1 = factor(
50	3x	case_when(
51	3x	is_event == TRUE ~ "Responders with subsequent event (%)",
52	3x	is_event == FALSE ~ "Responders without subsequent event (%)"
53		)
54		),
55	3x	EVNTDESC = factor(EVNTDESC)
56		) %>%
57	3x	semi_join(., adsl, by = c("STUDYID", "USUBJID")) %>%
58	3x	select(STUDYID, USUBJID, {{ arm }}, AVAL, is_event, is_not_event, EVNT1, EVNTDESC) %>%
59	3x	df_explicit_na(char_as_factor = FALSE)
60
61	3x	lyt_02 <- basic_table() %>%
62	3x	split_cols_by(
63	3x	var = arm,
64	3x	ref_group = refgroup
65		) %>%
66	3x	add_colcounts() %>%
67	3x	count_values(
68	3x	vars = "USUBJID",
69	3x	values = unique(adtte$USUBJID),
70	3x	.labels = "Responders",
71	3x	.stats = "count"
72		) %>%
73	3x	analyze_vars(
74	3x	vars = "is_event",
75	3x	.stats = "count_fraction",
76	3x	.labels = c(count_fraction = "With subsequent event (%)"),
77	3x	.indent_mods = c(count_fraction = 1L),
78	3x	show_labels = "hidden",
79		) %>%
80	3x	analyze(
81	3x	vars = "AVAL",
82	3x	afun = s_surv_time_1,
83	3x	extra_args = list(is_event = "is_event"),
84	3x	table_names = "est_prop",
85	3x	format = format_xx("xx.x (xx.x, xx.x)"),
86	3x	show_labels = "hidden",
87	3x	indent_mod = 1
88		)
89
90	3x	result <- build_table(lyt_02, df = adtte_f, alt_counts_df = adsl)
91	3x	result@main_title <- "DOR slide"
92	3x	result
93		}

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

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

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

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	17x	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	12x	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	11x	if (save_rds) {
50	11x	saveRDS(output, file = paste0(file_name, ".rds"))
51		}
52
53	11x	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.dlisting <- 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
93		#' Save a list of outputs
94		#'
95		#' @param outputs `list` of outputs as created by `generate_outputs`
96		#' @param outfolder Folder in which to store the `outputs``
97		#' @param verbose_level Level of verbose information displayed.
98		#' Default set to `1`.
99		#' @param save_rds Should the input `outputs` be saved as `.rds` files in
100		#' in addition to `.out` or `.pdf` files? Defaults to `FALSE`.
101		#' @param generic_suffix generic suffix. must be length 1 character or NULL.
102		#' @export
103		#' @return The input `object` invisibly
104		#' @examples
105		#' ## As `save_outputs` is the last step in the pipeline we have to run
106		#' ## the 'whole machinery' in order to show its functionality. Also take a look
107		#' ## at the `AutoslideR-Demo` repo on code.roche.com.
108		#' library(dplyr, warn.conflicts = FALSE)
109		#'
110		#' data <- list(
111		#' adsl = eg_adsl,
112		#' adae = eg_adae,
113		#' adtte = eg_adtte
114		#' )
115		#'
116		#' filters::load_filters(
117		#' yaml_file = system.file("filters.yml", package = "autoslider.core"),
118		#' overwrite = TRUE
119		#' )
120		#'
121		#' ## For this example the outputs will be saved in a temporary directory. In a
122		#' ## production run this should be the reporting event's 'output' folder instead.
123		#' output_dir <- tempdir()
124		#'
125		#' spec_file <- system.file("spec.yml", package = "autoslider.core")
126		#' read_spec(spec_file) %>%
127		#' filter_spec(program == "t_dm_slide") %>%
128		#' generate_outputs(datasets = data) %>%
129		#' decorate_outputs() %>%
130		#' save_outputs(outfolder = output_dir)
131		#'
132		save_outputs <- function(outputs,
133		outfolder = file.path("output"),
134		generic_suffix = NULL,
135		save_rds = TRUE,
136		verbose_level = 1) {
137	1x	stopifnot(is.list(outputs))
138
139	1x	if (!dir.exists(outfolder)) {
140	!	dir.create(outfolder)
141		}
142	1x	if (!is.null(generic_suffix)) {
143	!	if (!(is.character(generic_suffix) & length(generic_suffix) == 1)) {
144	!	stop("generic suffix must be length 1 character!")
145		}
146		}
147	1x	ret <- lapply(outputs, function(output) {
148	27x	spec <- attr(output, "spec")
149	27x	file_path <- file.path(outfolder, spec$output)
150	27x	file_path <- paste0(c(file_path, generic_suffix), collapse = "_")
151	27x	output <- save_output(
152	27x	output = output,
153	27x	file_name = file_path,
154	27x	save_rds = save_rds
155		)
156
157	27x	if (verbose_level > 0) {
158	27x	if (is(output, "autoslider_error")) {
159	12x	cat_bullet(
160	12x	"Saving output ",
161	12x	attr(output, "spec")$output,
162	12x	" failed in step ",
163	12x	attr(output, "step"),
164	12x	" with error message: ",
165	12x	toString(output),
166	12x	bullet = "cross",
167	12x	bullet_col = "red"
168		)
169		} else {
170	15x	cat_bullet(
171	15x	"Output saved in path ",
172	15x	file_path,
173	15x	bullet = "tick",
174	15x	bullet_col = "green"
175		)
176		}
177		}
178
179	27x	attr(output, "outpath") <- get_output_file_ext(output, file_path)
180	27x	output
181		})
182
183	1x	if (verbose_level > 0) {
184	1x	total_number <- length(ret)
185	1x	fail_number <- sum(map_lgl(ret, is, class2 = "autoslider_error"))
186	1x	log_success_infomation(total_number - fail_number, fail_number)
187		}
188
189	1x	ret
190		}

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

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

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

1		format_xx <- function(str) {
2	3x	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	26x	if (is.na(cutoff)) {
13	5x	cutoff <- 0
14		} else { # check cutoff is the same with the filter
15	21x	suffix <- attr(data, "filters")
16	21x	cutoff_suffix <- str_extract(string = paste(suffix, collapse = "_"), pattern = "(\\d+)(?=PER)") %>%
17	21x	as.numeric()
18	21x	if (!is.na(cutoff_suffix)) {
19	4x	assert_that(are_equal(cutoff, cutoff_suffix))
20		}
21		}
22	26x	return(cutoff)
23		}
24
25		#' Replace NAs to NA
26		#'
27		#' @param table_df Table dataframe
28		#' @return Input dataframe with both column replaced to NA
29		#' @export
30		na_replace <- function(table_df) {
31	2x	if (length(colnames(table_df)) == 2) {
32	2x	col1_na <- which(is.na(table_df[1]))
33	2x	if (length(col1_na) > 0) {
34	1x	for (i in 1:length(col1_na)) {
35	1x	table_df[col1_na[i], 1] <- table_df[col1_na[i], 2]
36	1x	table_df[col1_na[i], 2] <- NA
37		}
38		}
39		}
40	2x	return(table_df)
41		}
42
43		#' Concatenate arguments into a string
44		#'
45		#' @param ... arguments passed to program
46		#' @return No return value, called for side effects
47		#' @export
48		dec_paste <- function(...) {
49	2x	arguments <- list(
50		...
51		)
52
53	2x	if (any(is.na(arguments))) {
54	!	return(NA)
55		} else {
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	22030x	posneg <- sign(x)
82	22030x	z <- abs(x) * 10^digits
83	22030x	z <- z + 0.5 + sqrt(.Machine$double.eps)
84	22030x	z <- trunc(z)
85	22030x	z <- z / 10^digits
86	22030x	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	22x	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	9x	conf_type <- control$conf_type
144	9x	conf_level <- control$conf_level
145	9x	quantiles <- control$quantiles
146	9x	formula <- as.formula(paste0(
147	9x	"Surv(", .var, ", ", is_event,
148	9x	") ~ 1"
149		))
150	9x	srv_fit <- survfit(
151	9x	formula = formula, data = df, conf.int = conf_level,
152	9x	conf.type = conf_type
153		)
154	9x	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	9x	new_label <- paste0("Median (Months, ", conf_level * 100, "% CI)")
161
162	9x	list(
163	9x	median_ci = formatters::with_label(c(
164	9x	unname(srv_tab["median"]),
165	9x	unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))])
166	9x	), 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	20x	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	return(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	20x	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	20x	ret <- NULL
271		}
272
273	20x	if (for_test == TRUE) {
274	15x	ret <- NULL
275		}
276
277	20x	ret
278		}
279
280		datetime <- function() {
281		# eICE like format, e.g. 23SEP2020 12:40
282	2x	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	101x	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	!	return(ret)
390		}
391
392		text_wrap_cut_keepreturn <- function(text, width) {
393	!	if (is.na(width)) {
394	!	width <- 0
395		}
396	!	texts <- strsplit(text, "\n")
397	!	ret <- vapply(texts, function(x) {
398	!	r <- text_wrap_cut(x, width)
399	!	paste0(r, collapse = "\n")
400	!	}, FUN.VALUE = "")
401	!	return(ret)
402		}
403
404		#' @noRd
405		fs <- function(paper) {
406	2x	fontsize <- as.integer(substr(paper, 2, nchar(paper)))
407	2x	orientation <- substr(paper, 1, 1)
408	2x	return(list(fontsize = fontsize, orientation = orientation))
409		}
410
411		validate_paper_size <- function(paper) {
412	121x	assert_is_character_scalar(paper)
413	121x	if (!grepl("^[P\|L][1-9][0-9]{0,1}$", paper)) {
414	!	abort(
415	!	"Page size must be starting with `L` or `P` to indicate the orientation of the page, ",
416	!	"followed by an integer to indicate the fontsize"
417		)
418		}
419	121x	fontsize <- as.integer(substr(paper, 2, nchar(paper)))
420	121x	if (fontsize > 14) {
421	!	abort("Fontsize should be less or equal than 14")
422		}
423		}
424
425		get_output_file_ext <- function(output, file_path) {
426	27x	if (tools::file_ext(file_path) != "") {
427	!	return(file_path)
428		} else {
429	27x	file_ext <- ifelse(is_rtable(output) \|\| "dVTableTree" %in% class(output), "out", "pdf")
430	27x	return(sprintf("%s.%s", file_path, file_ext))
431		}
432		}
433
434		warn_about_legacy_filtering <- function(output) {
435	!	if (.autoslider_config$filter_warning_issued) {
436	!	return(invisible())
437		} else {
438	!	.autoslider_config$filter_warning_issued <- TRUE
439		}
440
441	!	msg <- sprintf(
442	!	paste(
443	!	"Filtering based upon a character scalar is deprecated.",
444	!	"Please use `output == '%s'` instead."
445		),
446	!	output
447		)
448	!	warn(msg)
449		}
450
451		warn_about_legacy_paper_size <- function(old_paper_size,
452		new_paper_size) {
453	!	if (.autoslider_config$paper_size_warning_issued[old_paper_size]) {
454	!	return(invisible())
455		} else {
456	!	.autoslider_config$paper_size_warning_issued[old_paper_size] <- TRUE
457		}
458
459	!	msg <- sprintf(
460	!	"Paper size '%s' is deprecated. Please use '%s' instead.",
461	!	old_paper_size,
462	!	new_paper_size
463		)
464	!	warn(msg)
465		}
466
467
468
469		#' Build side by side layout by cbind
470		#'
471		#' @param lyt layout object
472		#' @param anl analysis data object
473		#' @param side_by_side A logical value indicating whether to display the data side by side.
474		#' @return An `rtables` layout
475		#' @export
476		lyt_to_side_by_side <- function(lyt, anl, side_by_side = NULL) {
477	22x	result <- build_table(lyt = lyt, df = anl)
478
479	21x	if (!is.null(side_by_side)) {
480	9x	if (grepl("Asia", side_by_side)) {
481	!	result <- cbind_rtables(
482	!	result,
483	!	build_table(
484	!	lyt = lyt,
485	!	df = anl %>% filter(COUNTRY %in% c("CHN", "HKG", "TWN", "KOR", "SGP", "THA", "MYS"))
486		)
487		)
488		}
489
490	9x	if (grepl("China", side_by_side)) {
491	3x	result <- cbind_rtables(result, build_table(lyt = lyt, df = anl %>% filter(COUNTRY == "CHN")))
492		}
493		}
494	21x	return(result)
495		}
496
497		#' Build side by side layout by cbind
498		#' @param lyt layout object
499		#' @param anl analysis data object
500		#' @param side_by_side A logical value indicating whether to display the data side by side.
501		#' @param alt_counts_df alternative data frame for counts
502		#' @return An `rtables` layout
503		#' @export
504		lyt_to_side_by_side_two_data <- function(lyt, anl, alt_counts_df, side_by_side = NULL) {
505	26x	result <- build_table(lyt = lyt, df = anl, alt_counts_df = alt_counts_df)
506
507	26x	if (!is.null(side_by_side)) {
508	7x	if (grepl("Asia", side_by_side)) {
509	6x	result <- cbind_rtables(
510	6x	result,
511	6x	build_table(
512	6x	lyt = lyt,
513	6x	df = anl %>% filter(COUNTRY %in% c("CHN", "HKG", "TWN", "KOR", "SGP", "THA", "MYS")),
514	6x	alt_counts_df = alt_counts_df %>% filter(COUNTRY %in% c("CHN", "HKG", "TWN", "KOR", "SGP", "THA", "MYS"))
515		)
516		)
517		}
518
519	7x	if (grepl("China", side_by_side)) {
520	!	result <- cbind_rtables(result, build_table(
521	!	lyt = lyt, df = anl %>% filter(COUNTRY == "CHN"),
522	!	alt_counts_df = alt_counts_df %>% filter(COUNTRY == "CHN")
523		))
524		}
525		}
526	26x	return(result)
527		}
528
529
530		do_call <- function(fun, ...) {
531	596x	args <- list(...)
532	596x	do.call(fun, args[intersect(names(args), formalArgs(fun))])
533		}
534
535
536		#' Build table header, a utility function to help with construct structured header for table layout
537		#' @param anl analysis data object
538		#' @param arm Arm variable for column split
539		#' @param split_by_study, if true, construct structured header with the study ID
540		#' @param side_by_side A logical value indicating whether to display the data side by side.
541		#' @return A `rtables` layout with desired header.
542		#' @export
543		build_table_header <- function(anl,
544		arm,
545		split_by_study,
546		side_by_side) {
547	48x	lyt <- basic_table()
548	48x	if (is.null(side_by_side)) {
549	32x	if (split_by_study) {
550	5x	assert_that(length(unique(anl$STUDYID)) > 1)
551	5x	lyt <- lyt %>%
552	5x	split_cols_by(var = "STUDYID") %>%
553	5x	split_cols_by(var = arm)
554		} else {
555	27x	lyt <- lyt %>%
556	27x	split_cols_by(var = arm) %>%
557	27x	add_overall_col("All Patients")
558		}
559		} else {
560	16x	if (split_by_study) {
561	10x	warning("split_by_study argument will be ignored")
562		}
563	16x	lyt <- lyt %>%
564	16x	split_cols_by(var = arm) %>%
565	16x	add_overall_col("All Patients")
566		}
567	48x	return(lyt)
568		}
569
570
571		get_version_label_output <- function() {
572	1x	NULL
573		}
574
575
576		strip_NA <- function(input) {
577	21x	return(input[which(input != "NA")])
578		}

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

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	table_names = "U",
161	3x	filters = c("SAFFL" = "Y"),
162	3x	denom = "N_col",
163	3x	.stats = "count_fraction",
164	3x	.labels = c(count_fraction = "All grade AEs, any cause")
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		# .format = list(trim_perc1)
173		) %>%
174	3x	count_patients_with_flags(
175	3x	"USUBJID",
176	3x	flag_variables = c(TMPFL1_G34 = "Grade 3-4 AEs"),
177	3x	denom = "N_col",
178	3x	.indent_mods = 0L
179		# .format = list(trim_perc1)
180		) %>%
181	3x	count_patients_with_flags(
182	3x	"USUBJID",
183	3x	flag_variables = c(TMPFL1_G34_REL = "Related"),
184	3x	denom = "N_col",
185	3x	.indent_mods = 1L
186		# .format = list(trim_perc1)
187		) %>%
188	3x	count_patients_with_flags(
189	3x	"USUBJID",
190	3x	flag_variables = c(TMPFL1_G5 = "Grade 5 AE"),
191	3x	denom = "N_col",
192	3x	.indent_mods = 0L
193		# .format = list(trim_perc1)
194		) %>%
195	3x	count_patients_with_flags(
196	3x	"USUBJID",
197	3x	flag_variables = c(TMPFL1_G5_REL = "Related"),
198	3x	denom = "N_col",
199	3x	.indent_mods = 1L
200		# .format = list(trim_perc1)
201		) %>%
202	3x	count_patients_with_flags(
203	3x	"USUBJID",
204	3x	flag_variables = c(TMPFL1_SER = "SAEs"),
205	3x	denom = "N_col",
206	3x	.indent_mods = 0L
207		# .format = list(trim_perc1)
208		) %>%
209	3x	count_patients_with_flags(
210	3x	"USUBJID",
211	3x	flag_variables = c(TMPFL1_SER_REL = "Related"),
212	3x	denom = "N_col",
213	3x	.indent_mods = 1L
214		# .format = list(trim_perc1)
215		)
216
217	3x	if (sum(is.na(dose_adjust_flags)) == 0 & sum(is.na(dose_adjust_labels)) == 0) {
218	3x	for (i in 1:length(dose_adjust_flags)) {
219	9x	text <- paste0(
220	9x	' lyt <- lyt %>%
221	9x	count_patients_with_flags(
222	9x	"USUBJID",
223	9x	flag_variables = c(', dose_adjust_flags[i], "='", dose_adjust_labels[i],
224		"'),
225	9x	denom = 'N_col',
226	9x	.indent_mods = 0L)"
227		)
228	9x	eval(parse(text = text))
229		}
230		}
231
232	3x	result <- build_table(
233	3x	lyt,
234	3x	df = anl,
235	3x	alt_counts_df = adsl
236		)
237	3x	result@main_title <- "AE summary table"
238		}
239
240	3x	return(result)
241		}

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		#' @examples
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	27x	suffix <- spec$suffix
42	27x	if (verbose_level > 0) {
43	27x	cat_bullet(
44	27x	sprintf(
45	27x	"Running program `%s` with suffix '%s'.",
46	27x	program,
47	27x	suffix
48		),
49	27x	bullet = "pointer",
50	27x	bullet_col = "green"
51		)
52		}
53	27x	func <- tryCatch(
54		{
55	27x	func_wrapper(
56	27x	func = match.fun(program),
57	27x	datasets = datasets,
58	27x	spec = spec,
59	27x	verbose = verbose_level > 1
60		)
61		},
62	27x	error = function(e) {
63	12x	info <- e$message
64	12x	if (verbose_level > 0) {
65	12x	cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red")
66		}
67	12x	autoslider_error(info, spec = spec, step = "filter dataset")
68		}
69		)
70	27x	if (is(func, "autoslider_error")) {
71	12x	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		#' @examples
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	27x	args <- c(
126	27x	list(
127	27x	program = s$program,
128	27x	spec = s,
129	27x	datasets = datasets,
130	27x	verbose_level = verbose_level
131		),
132	27x	s$args # ... arguments passed onto the output-generating function
133		)
134	27x	output <- fastDoCall(generate_output, args)
135	27x	attr(output, "spec") <- s
136	27x	output
137		})
138		}

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		#' 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	27x	suffix <- spec$suffix
10	27x	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		#' 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	42x	if (quote) {
16	!	args <- lapply(args, enquote)
17		}
18
19	42x	if (is.null(names(args))) {
20	!	argn <- args
21	!	args <- list()
22		} else {
23		# Add all the named arguments
24	42x	argn <- lapply(names(args)[names(args) != ""], as.name)
25	42x	names(argn) <- names(args)[names(args) != ""]
26		# Add the unnamed arguments
27	42x	argn <- c(argn, args[names(args) == ""])
28	42x	args <- args[names(args) != ""]
29		}
30
31	42x	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	42x	} else if (is(what, "function")) {
42	42x	f_name <- deparse(substitute(what))
43	42x	call <- as.call(c(list(as.name(f_name)), argn))
44	42x	args[[f_name]] <- what
45	!	} else if (is(what, "name")) {
46	!	call <- as.call(c(list(what, argn)))
47		}
48
49	42x	eval(call,
50	42x	envir = args,
51	42x	enclos = envir
52		)
53		}

1		abort <- function(...) {
2	!	stop(..., call. = FALSE)
3		}
4
5		assert_is_character_scalar <- function(x) {
6	134x	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	100x	exist_in_spec <- vars %in% names(output)
20	100x	exist_in_calling_env <- map_lgl(vars, exists, parent.frame(n = 2L))
21	100x	non_existing_vars <- vars[!(exist_in_spec \| exist_in_calling_env)]
22
23
24	100x	n <- length(non_existing_vars)
25	100x	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	100x	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		#' 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 (nrow(anl) == 0) {
30	1x	return(null_report())
31		} else {
32	6x	lyt <- build_table_header(adsl, arm, split_by_study = split_by_study, side_by_side = side_by_side)
33
34	6x	lyt <- lyt %>%
35	6x	count_values(
36	6x	"DTHFL",
37	6x	values = "Y",
38	6x	denom = c("N_col"),
39	6x	.labels = c(count_fraction = "All Deaths")
40		) %>%
41	6x	analyze_vars(
42	6x	vars = "DTHCAT", .stats = "count_fraction",
43	6x	na_str = "<Missing>",
44	6x	var_labels = " ",
45	6x	na.rm = TRUE
46		) %>%
47		# count_patients_with_flags(
48		# "USUBJID",
49		# flag_variables = formatters::var_labels(anl[,c("DTHCAT1", "DTHCAT2", "DTHCAT3")]),
50		# .indent_mods = 1L,
51		# .format = list(trim_perc1),
52		# denom = "n"
53		# ) %>%
54	6x	append_topleft("N (%)")
55
56	6x	result <- lyt_to_side_by_side(lyt, anl, side_by_side)
57	5x	result@main_title <- "Death table"
58	5x	result
59		}
60		}

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	2x	cat_bullet(
13	2x	"Total number of failures ",
14	2x	failure,
15		"/",
16	2x	total_number,
17	2x	bullet = "cross",
18	2x	bullet_col = "red"
19		)
20		}
21		}
22
23		log_number_of_matched_records <- function(original_spec,
24		filtered_spec,
25		condition) {
26	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		#' 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		#' @examples
16		#'
17		#' # expected to return "2019"
18		#' format_date("2019")
19		#'
20		#' # expected to return "20APR2019"
21		#' format_date("2019-04-20")
22		#'
23		#' # expected to return ""
24		#' format_date("")
25		#'
26		#' # expected to return "18JUN2019"
27		#' format_date("2019-06-18T10:32")
28		#'
29		#' # expected to return "APR2019"
30		#' format_date("2019-04")
31		#'
32		format_date <- function(x) {
33	5x	x_form <- case_when(
34	5x	nchar(x) > 10 ~ toupper(format(lubridate::date(lubridate::ymd_hms(x, truncated = 3, quiet = TRUE)), "%d%b%Y")),
35	5x	nchar(x) == 10 ~ toupper(format(lubridate::ymd(x, quiet = TRUE), "%d%b%Y")),
36	5x	nchar(x) == 7 ~ substr(toupper(format(lubridate::ymd(x, truncated = 2, quiet = TRUE), "%d%b%Y")), 3, 9),
37	5x	nchar(x) == 4 ~ x,
38	5x	is.na(x) ~ "",
39	5x	TRUE ~ ""
40		)
41
42	5x	return(x_form)
43		}

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	288x	ft %>%
31	288x	theme_zebra(
32	288x	odd_header = odd_header,
33	288x	odd_body = odd_body,
34	288x	even_header = odd_header,
35	288x	even_body = even_body
36		) %>%
37	288x	font(fontname = font_name, part = "all") %>%
38	288x	fontsize(size = body_font_size, part = "body") %>%
39	288x	color(color = "white", part = "header") %>%
40	288x	fontsize(size = header_font_size, part = "header") %>%
41	288x	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	284x	ft %>% autoslider_format(
72	284x	odd_header = "#ED4A0D",
73	284x	odd_body = "#FF7D29",
74	284x	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	13x	assert_is_character_scalar(x)
14	13x	structure(
15	13x	.Data = x,
16	13x	step = step,
17	13x	spec = spec,
18	13x	class = "autoslider_error"
19		)
20		}

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