osprey coverage - 0.00%

Files
Source

File	Lines	Relevant	Missed	Coverage
R/g_patient_profile.R	960	343	343	0.00%
R/g_ae_sub.R	537	300	300	0.00%
R/g_waterfall.R	507	257	257	0.00%
R/g_events_term_id.R	491	235	235	0.00%
R/g_heat_bygrade.R	372	171	171	0.00%
R/g_butterfly.R	320	165	165	0.00%
R/g_spiderplot.R	346	159	159	0.00%
R/utils.R	363	140	140	0.00%
R/g_swimlane.R	321	124	124	0.00%
R/stream_filter.R	297	120	120	0.00%
R/g_hy_law.R	200	69	69	0.00%
R/g_spiderplot_simple.R	60	19	19	0.00%

#' Events by Term Plot
#'
#' This function plots commonly occurred events by number of unique subjects with events.
#' It creates basic summary of events and compares event occurrences between comparison
#' and reference arms, and can be used for events data such as Adverse Events.
#'
#' @inheritParams argument_convention
#' @param id (`vector`)\cr contains subject identifier. Length of \code{id} must be the
#' same as the length or number of rows of \code{terms}. Usually it is \code{ADAE$USUBJID}.
#' @param term \code{character} or \code{factor} vector, or \code{data.frame} \cr
#' Represents events information. \code{term} can be a \code{data.frame} produced
#' by \code{create_flag_vars}, with each column being a \code{logical} event indicator
#' @param arm_N (\code{numeric} vector)\cr
#' Contains information of the number of patients in the levels of \code{arm}. This is useful
#' if there are patients that have no adverse events can be accounted for with this argument.
#' @param ref \code{character} indicates the name of the reference arm. Default is the first
#' level of \code{arm}.
#' @param trt \code{character} indicates the name of the treatment arm. Default is the second
#' level of \code{arm}.
#' @param sort_by \code{character} indicates how each \code{term} is sorted in the plot.
#' Choose from `"term"` for alphabetic terms, `"riskdiff"` for risk difference, and `"meanrisk"`
#' for mean risk. Default is "term".
#' @param rate_range Numeric \code{vector} of length 2. Range for overall rate display
#' @param diff_range Numeric \code{vector} of length 2. Range for rate difference display
#' @param reversed \code{logical} whether to reverse the sorting by \code{sort_by}.
#' Default is FALSE.
#' @param axis_side \code{character} the side of the axis label, "left" or "right". Default is "left".
#' @param color Color for the plot. \code{vector} of length 2. Color for reference and
#' treatment arms respectively. Default set to \code{c("blue", "red")}.
#' @param shape Shape for the plot. \code{vector} of length 2. Shape for reference and
#' treatment arms respectively. Default set to \code{c(16, 17)} per
#' \code{\link[ggplot2]{scale_shape}}.
#' @details there is no equivalent STREAM output
#'
#' @return grob object
#'
#' @export
#'
#' @author Liming Li (Lil128) \email{liming.li@roche.com}
#' @author Molly He (hey59) \email{hey59@gene.com}
#'
#' @examplesIf require("nestcolor")
#' library(dplyr)
#' library(grid)
#' library(nestcolor)
#'
#' ADSL <- osprey::rADSL
#' ADAE <- osprey::rADAE
#'
#' # add additional dummy causality flags
#' ADAE <- ADAE %>%
#'   mutate(AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X")) %>%
#'   mutate(AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo"))
#' attr(ADAE[["AEREL1"]], "label") <- "AE related to A: Drug X"
#' attr(ADAE[["AEREL2"]], "label") <- "AE related to B: Placebo"
#'
#' term <- ADAE$AEDECOD
#' id <- ADAE$USUBJID
#' arm <- ADAE$ACTARMCD
#' arm_N <- table(ADSL$ACTARMCD)
#' ref <- "ARM A"
#' trt <- "ARM C"
#'
#' # Example 1
#' p1 <- g_events_term_id(
#'   term,
#'   id,
#'   arm,
#'   arm_N
#' )
#' grid::grid.newpage()
#' grid::grid.draw(p1)
#'
#' # Example 2
#' p2 <- g_events_term_id(
#'   term,
#'   id,
#'   arm,
#'   arm_N,
#'   trt = trt,
#'   ref = ref,
#'   sort_by = "riskdiff",
#'   diff_ci_method = "ac",
#'   conf_level = 0.9
#' )
#' grid::grid.newpage()
#' grid::grid.draw(p2)
#'
#' # Example 3
#' p3 <- g_events_term_id(
#'   term,
#'   id,
#'   arm,
#'   arm_N,
#'   sort_by = "meanrisk",
#'   axis_side = "right",
#'   fontsize = 5
#' )
#' grid::grid.newpage()
#' grid::grid.draw(p3)
#'
#' # Example 4
#' term <- create_flag_vars(ADAE)
#' g_events_term_id(
#'   term,
#'   id,
#'   arm,
#'   arm_N,
#'   fontsize = 3
#' )
g_events_term_id <- function(term,
                             id,
                             arm,
                             arm_N, # nolint
                             ref = levels(arm)[1],
                             trt = levels(arm)[2],
                             sort_by = c("term", "riskdiff", "meanrisk"),
                             rate_range = c(0, 1),
                             diff_range = c(-1, 1),
                             reversed = FALSE,
                             conf_level = 0.95,
                             diff_ci_method =
                               c("wald", "waldcc", "ac", "score", "scorecc", "mn", "mee", "blj", "ha", "beal"),
                             axis_side = c("left", "right"),
                             color = c(getOption("ggplot2.discrete.colour"), "blue", "red")[1:2],
                             shape = c(16, 17),
                             fontsize = 4,
                             draw = TRUE) {
  if (is.data.frame(term)) {
    term_levels <- factor(colnames(term), levels = rev(colnames(term)))
    term <- data.frame(t(term))
    term <- lapply(term, function(x) {
      term_levels[x]
    })
    df <- tibble::tibble(id, arm, term) %>%
      tidyr::unnest(term)
  } else {
    term_levels <- `if`(is.factor(term), levels(term), unique(term))
    df <- tibble::tibble(id, arm, term)
  }

  # argument validation
  sort_by <- match.arg(sort_by)
  diff_ci_method <- match.arg(diff_ci_method)
  axis_side <- match.arg(axis_side)

  checkmate::assert_factor(arm, min.levels = 2)
  stopifnot(
    "invalid arguments: check that the length of id, term and arm are identical" =
      length(id) == length(term) && length(term) == length(arm)
  )
  stopifnot("invalid arguments: trt and ref need to be from arm" = all(c(trt, ref) %in% unique(arm)))
  checkmate::assert_numeric(rate_range, len = 2, any.missing = FALSE)
  checkmate::assert_numeric(diff_range, len = 2, any.missing = FALSE)
  checkmate::assert_flag(reversed)
  checkmate::assert_number(conf_level, lower = 0.5, upper = 1)
  checkmate::assert_character(color, len = 2, any.missing = FALSE)
  checkmate::assert_numeric(shape, len = 2, any.missing = FALSE)
  checkmate::assert_numeric(fontsize, lower = 0, any.missing = FALSE)

  # construct calculations
  arms <- c(ref, trt)
  df_n <- data.frame(arm_N)
  names(df_n) <- c("arm", "total")
  df_n <- df_n[df_n$arm %in% arms, ]
  ref_total <- df_n %>%
    filter(arm == ref) %>%
    select("total") %>%
    pull()
  trt_total <- df_n %>%
    filter(arm == trt) %>%
    select("total") %>%
    pull()

  # create full cartesian of (arms) X (term levels) with 0 count to have full list of all possible combination
  # this is done in order to secure further calls
  df_full <- cbind(expand.grid(arm = arms, term = term_levels), N = 0)

  df_reshaped <- df %>%
    distinct() %>%
    filter(arm %in% arms) %>%
    group_by(arm, term) %>%
    summarise(N = n()) %>%
    ungroup() %>%
    rbind(df_full) %>%
    group_by(arm, term) %>%
    summarise(N = sum(.data$N)) %>%
    mutate(arm = ifelse(arm == trt, "trt_count", "ref_count")) %>%
    tidyr::pivot_wider(names_from = arm, values_from = "N", values_fill = list(N = 0))

  df_ci <- df_reshaped %>%
    group_by(term) %>%
    do(
      data.frame(
        t(c(
          DescTools::BinomDiffCI(
            .data$trt_count,
            trt_total,
            .data$ref_count,
            ref_total,
            conf_level,
            method = diff_ci_method
          )[1, ], # wald
          meanrisk = (.data$trt_count + .data$ref_count) / (trt_total + ref_total)
        ))
      )
    ) %>%
    ungroup() %>%
    rename(riskdiff = "est", lower_ci = "lwr.ci", upper_ci = "upr.ci")

  df_risk <- df_reshaped %>%
    group_by(term) %>%
    do(
      data.frame(
        risk = c(.data$trt_count / trt_total, .data$ref_count / ref_total),
        arm = c(trt, ref)
      )
    ) %>%
    ungroup()

  names(color) <- arms
  names(shape) <- arms

  # if diff_range specified, limit terms
  terms_needed <- df_ci %>%
    filter(
      .data$riskdiff > diff_range[1] &
        .data$riskdiff < diff_range[2] &
        .data$meanrisk > rate_range[1] &
        .data$meanrisk < rate_range[2]
    ) %>%
    select(term) %>%
    distinct() %>%
    pull() %>%
    as.character()

  if (length(terms_needed) == 0) {
    ret <- grid::textGrob("All Observations are filtered out")
    if (draw) {
      grid::grid.draw(ret)
    }
    return(invisible(ret))
  }

  # sorting
  if (sort_by == "term") {
    terms_needed <- sort(terms_needed, decreasing = TRUE)
  } else {
    terms_needed <- df_ci %>%
      arrange(.data[[sort_by]]) %>%
      filter(term %in% terms_needed) %>%
      select(term) %>%
      pull()
  }

  if (reversed) {
    terms_needed <- rev(terms_needed)
  }

  df_ci <- df_ci %>%
    filter(term %in% terms_needed) %>%
    mutate(term = factor(term, terms_needed))
  df_risk <- df_risk %>%
    filter(term %in% terms_needed) %>%
    mutate(term = factor(term, terms_needed))
  terms_label <- vapply(
    lapply(terms_needed, strwrap, width = 30),
    paste,
    FUN.VALUE = character(1),
    collapse = "\n"
  )

  mytheme <- theme_osprey(axis_side = axis_side, fontsize = fontsize)

  labels <- stats::setNames(sprintf("%s\n(N = %i)", df_n$arm, df_n$total), df_n$arm)

  y_axis <- scale_y_discrete(
    limits = terms_needed,
    breaks = terms_needed,
    labels = terms_label,
    position = axis_side
  )

  p1 <- ggplot(df_risk) +
    geom_point(
      aes(
        y = term,
        x = .data$risk,
        group = arm,
        color = arm,
        shape = arm
      ),
      size = fontsize * 0.7
    ) +
    mytheme +
    ggtitle("Proportion") +
    scale_color_manual(values = color, labels = labels) +
    scale_shape_manual(values = shape, labels = labels) +
    y_axis

  p2 <- ggplot(df_ci) +
    geom_point(mapping = aes(y = term, x = .data$riskdiff), size = fontsize * 0.7) +
    geom_vline(data = NULL, xintercept = 0, linetype = 2) +
    mytheme +
    geom_errorbarh(mapping = aes(xmax = .data$upper_ci, xmin = .data$lower_ci, y = term), height = 0.4) +
    y_axis +
    ggtitle("Risk Difference")

  axis_name <- sprintf("axis-%s", substr(axis_side, 1, 1))

  p1_parts <- ggplotGrob(p1)
  p2_parts <- ggplotGrob(p2)

  mylegend <- grob_part(grob_part(p1_parts, "guide-box-bottom"), "guides")
  axis <- grob_part(p1_parts, axis_name)

  less_risk <- grid::textGrob(
    "Favor\nTreatment",
    just = "left",
    x = grid::unit(fontsize * .pt, "pt"),
    gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold")
  )
  more_risk <- grid::textGrob(
    "Favor\nControl",
    just = "right",
    x = grid::unit(1, "npc") - grid::unit(fontsize * .pt, "pt"),
    gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold")
  )

  risk_label <- gridExtra::arrangeGrob(less_risk, more_risk, nrow = 1)
  title1 <- grob_part(p1_parts, "title")
  title2 <- grob_part(p2_parts, "title")
  panel1 <- grob_part(p1_parts, "panel")
  panel2 <- grob_part(p2_parts, "panel")
  axis_b1 <- grob_part(p1_parts, "axis-b")
  axis_b2 <- grob_part(p2_parts, "axis-b")

  grobs <- list(
    title1,
    title2,
    axis,
    panel1,
    panel2,
    axis_b1,
    axis_b2,
    mylegend,
    risk_label
  )

  if (axis_side == "left") {
    layout_matrix <- rbind(
      c(NA, 1, NA, 2),
      c(3, 4, NA, 5),
      c(NA, 6, NA, 7),
      c(8, 8, NA, 9)
    )
    widths <- grid::unit.c(grid::grobWidth(axis), grid::unit(c(1, 2 * fontsize, 1), c("null", "pt", "null")))
  } else {
    layout_matrix <- rbind(
      c(1, NA, 2, NA),
      c(4, NA, 5, 3),
      c(6, NA, 7, NA),
      c(8, NA, 9, NA)
    )
    widths <- grid::unit.c(grid::unit(c(1, 10, 1), c("null", "pt", "null")), grid::grobWidth(axis))
  }

  heights <- grid::unit.c(
    grid::grobHeight(title1),
    grid::unit(1, "null"),
    grid::grobHeight(axis_b1),
    max(grid::grobHeight(mylegend), grid::grobHeight(more_risk))
  )

  ret <- gridExtra::arrangeGrob(
    grobs = grobs,
    nrow = 4,
    ncol = 4,
    layout_matrix = layout_matrix,
    heights = heights,
    widths = widths
  )

  ret <- grob_add_padding(ret)

  if (draw) {
    grid::grid.draw(ret)
  }
  invisible(ret)
}


#' create `AE` overview flags
#' @param df data frame of `AE`
#' @param fatal `AE` with fatal outcome derivation
#' @param serious Serious `AE` derivation.
#' @param serious_withdrawl Serious `AE` leading to withdrawal derivation
#' @param serious_modified Serious `AE` leading to dose modification derivation
#' @param serious_related Related Serious `AE` derivation
#' @param withdrawl `AE` leading to withdrawal derivation
#' @param modified `AE` leading to dose modification derivation
#' @param related Related `AE` derivation
#' @param related_withdrawl Related `AE` leading to withdrawal derivation
#' @param related_modified Related `AE` leading to dose modification derivation
#' @param ctc35 Grade 3-5 `AE` derivation
#' @param ... named expressions used to generate categories
#' @details in this function, all flags are expressions calls, for simpler usage.
#' @export
#' @examples
#' library(dplyr)
#'
#' ADAE <- osprey::rADAE
#'
#' # add additional dummy causality flags
#' ADAE <- ADAE %>%
#'   mutate(AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X")) %>%
#'   mutate(AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo"))
#' attr(ADAE[["AEREL1"]], "label") <- "AE related to A: Drug X"
#' attr(ADAE[["AEREL2"]], "label") <- "AE related to B: Placebo"
#'
#' create_flag_vars(ADAE)
#' # create other flags
#' create_flag_vars(ADAE, `AENSER` = AESER != "Y")
#' # remove flags that are not needed
#' create_flag_vars(ADAE, fatal = NULL)
create_flag_vars <- function(df,
                             # nolint start
                             fatal = AESDTH == "Y",
                             serious = AESER == "Y",
                             serious_withdrawl = AESER == "Y" &
                               grepl("DRUG WITHDRAWN", AEACN),
                             serious_modified = AESER == "Y" &
                               grepl("DRUG (INTERRUPTED|INCREASED|REDUCED)", AEACN),
                             serious_related = AESER == "Y" & AEREL == "Y",
                             withdrawl = grepl("DRUG WITHDRAWN", AEACN),
                             modified = grepl("DRUG (INTERRUPTED|INCREASED|REDUCED)", AEACN),
                             related = AEREL == "Y",
                             related_withdrawl = AEREL == "Y" & grepl("DRUG WITHDRAWN", AEACN),
                             related_modified = AEREL == "Y" &
                               grepl("DRUG (INTERRUPTED|INCREASED|REDUCED)", AEACN),
                             ctc35 = AETOXGR %in% c("3", "4", "5"),
                             # nolint end
                             ...) {
  AESDTH <- AESER <- AEACN <- AEREL <- AETOXGR <- NULL # nolint
  args <-
    eval(substitute(
      alist(
        "AE with fatal outcome" = fatal,
        "Serious AE" = serious,
        "Serious AE leading to withdrawal" = serious_withdrawl,
        "Serious AE leading to dose modification" = serious_modified,
        "Related Serious AE" = serious_related,
        "AE leading to withdrawal" = withdrawl,
        "AE leading to dose modification" = modified,
        "Related AE" = related,
        "Related AE leading to withdrawal" = related_withdrawl,
        "Related AE leading to dose modification" = related_modified,
        "Grade 3-5 AE" = ctc35
      )
    ))
  args <- c(args, eval(substitute(alist(...))))
  stopifnot(all(names(args) != "")) # all elements in ... should be named
  argnames <- unique(names(args))
  df <- as.data.frame(df)
  ret <- lapply(argnames, function(t) {
    tryCatch(
      expr = {
        with(df, eval(args[[t]]))
      },
      error = function(w) {
        NULL
      },
      warning = function(w) {
        NULL
      }
    )
  })
  names(ret) <- argnames
  valid <- vapply(argnames, function(x) {
    valid <- length(ret[[x]]) > 0
    if (!valid) {
      warning(sprintf(
        "%s with calculation %s not valid",
        x,
        as.character(as.expression(args[[x]]))
      ))
    }
    valid
  }, FUN.VALUE = TRUE)
  do.call(data.frame, args = list(ret[valid], check.names = FALSE))
}

#' Butterfly Plot
#'
#' The butterfly plot is often used in Early Development (ED) and is an opposed
#' barplot that shows instances of `AE`s or # of patients by category separated by
#' a dichotomization variable. Each bar can be color coded according
#' to a variable of choice and sorted according to either alphabetical order or the
#' maximum count.
#'
#' @param category vector of y values
#' @param right_flag vector of \code{logical} of the same length as \code{category}.
#'   used to filter \code{category} for the right side of the barplot.
#'   to maintain backward compatibility, a vector of 1s and 0s would also work.
#' @param left_flag vector of \code{logical} of the same length as \code{category}.
#'   used to filter \code{category} for the left side of the barplot.
#'   to maintain backward compatibility, a vector of 1s and 0s would also work.
#' @param group_names string vector of length 2 with desired names of dichotomization variables
#' required format : first name corresponds to the name of the right side
#'                   second name corresponds to name of the left side
#' default: will extract column names from group
#' @param block_count string - what to count by (ex: # of `AE`s or # of patients)
#' @param block_color vector - color coding of bar segments
#' @param id unique subject identifier variable.
#' @param facet_rows vector defines what variable is used to split the
#' plot into rows, default here is NULL
#' @param x_label string of text for x axis label, default is block_count
#' @param y_label string of text for y axis label, default is `AE` Derived Terms
#' @param legend_label \code{character} for legend label, default is `"AETOXGR"`
#' @param sort_by character string that defines the ordering of the class and term
#' variables in the output table,
#' options: `"alphabetical"`, `"count"`, `"left"`, `"right"`, default here is set to `"count"`
#' @param show_legend `logical(1)` of whether color coding legend is included,
#' default here is FALSE
#'
#' @details there is no equivalent STREAM output
#'
#' @return `ggplot` object
#'
#' @export
#'
#' @template author_zhanc107
#' @template author_qit3
#'
#' @examplesIf require("nestcolor")
#' library(dplyr)
#' library(nestcolor)
#'
#' ADSL <- osprey::rADSL %>%
#'   select(USUBJID, STUDYID, SEX, ARM, RACE) %>%
#'   dplyr::filter(SEX %in% c("F", "M"))
#' ADAE <- osprey::rADAE %>% select(USUBJID, STUDYID, AEBODSYS, AETOXGR)
#'
#' ANL <- left_join(ADAE, ADSL, by = c("STUDYID", "USUBJID"))
#' ANL <- ANL %>%
#'   dplyr::mutate(flag1 = ifelse(RACE == "ASIAN", 1, 0)) %>%
#'   dplyr::mutate(flag2 = ifelse(SEX == "M", 1, 0))
#' ANL <- na.omit(ANL)
#' # Example 1, # of AEs
#' g_butterfly(
#'   category = ANL$AEBODSYS,
#'   right_flag = ANL$flag1,
#'   left_flag = ANL$flag2,
#'   group_names = c("flag1 Asian", "flag2 M"),
#'   block_count = "# of AEs",
#'   block_color = ANL$AETOXGR,
#'   id = ANL$USUBJID,
#'   x_label = "# of AEs",
#'   y_label = "AE Body System",
#'   legend_label = "AETOXGR",
#'   sort_by = "count",
#'   show_legend = TRUE
#' )
#'
#' # Example 2, # of patients with facet
#' g_butterfly(
#'   category = ANL$AEBODSYS,
#'   right_flag = ANL$flag1,
#'   left_flag = ANL$flag2,
#'   group_names = c("flag1 Asian", "flag2 M"),
#'   block_count = "# of patients",
#'   block_color = ANL$AETOXGR,
#'   facet_rows = ANL$ARM,
#'   id = ANL$USUBJID,
#'   x_label = "# of patients",
#'   y_label = "AE Derived Terms",
#'   legend_label = "AETOXGR",
#'   sort_by = "count",
#'   show_legend = TRUE
#' )
g_butterfly <- function(category,
                        right_flag,
                        left_flag,
                        id = NULL,
                        group_names = NULL,
                        block_count = c("# of patients", "# of AEs"),
                        block_color = NULL,
                        facet_rows = NULL,
                        x_label = block_count,
                        y_label = "AE Derived Terms",
                        legend_label = "AETOXGR",
                        sort_by = c("count", "alphabetical", "right", "left"),
                        show_legend = TRUE) {
  stopifnot(
    "invalid arguments: check that the length of input arguments are identical" =
      length(category) == length(right_flag) && length(right_flag) == length(left_flag)
  )
  stopifnot(
    "invalid arguments: right_flag or left_flag contains values other than 1/TRUE or 0/FALSE" =
      all(union(right_flag, left_flag) %in% c(1, 0))
  )
  stopifnot(
    "invalid arguments: right_flag and left_flag contain only 0/FALSE values" =
      any(union(right_flag, left_flag) == 1)
  )
  stopifnot(
    "invalid arguments: check that the length of block_color is equal as other inputs" =
      is.null(block_color) || length(block_color) == length(category)
  )
  block_count <- match.arg(block_count)
  checkmate::assert_character(id, null.ok = isFALSE(block_count == "# of patients"))

  stopifnot(
    "invalid arguments: check that the length of block_color is equal as other inputs" =
      is.null(id) || length(id) == length(category)
  )
  stopifnot(
    "invalid arguments: check that the length of block_color is equal as other inputs" =
      is.null(facet_rows) ||
        (length(facet_rows) == length(category)) || # nolint: indentation_linter.
        (is.data.frame(facet_rows) && nrow(facet_rows) == length(category))
  )
  checkmate::assert_string(x_label)
  checkmate::assert_string(y_label)
  checkmate::assert_string(legend_label)
  sort_by <- match.arg(sort_by)

  # set up data-------
  dat <- data.frame(y = stringr::str_wrap(category, width = 30), r_flag = right_flag, l_flag = left_flag)

  groups <- "y"

  if (!is.null(id)) {
    dat$id <- id
  }
  if (!is.null(facet_rows)) {
    facet_rows <- interaction(facet_rows)
    dat$f_rows <- facet_rows
    groups <- c(groups, "f_rows")
  }
  if (!is.null(block_color)) {
    dat$bar_color <- block_color
    groups <- c(groups, "bar_color")
  }

  get_counts <- function(.data, block_count) {
    if (block_count == "# of patients") {
      length(unique(.data$id))
    } else if (block_count == "# of AEs") {
      n()
    }
  }
  highest_grade <- function(.data, block_count) {
    if (block_count == "# of patients" && "bar_color" %in% colnames(.data)) {
      .data %>%
        dplyr::group_by(.data$y, .data$id) %>%
        dplyr::filter(.data$bar_color == sort(.data$bar_color, decreasing = TRUE)[1])
    } else {
      .data
    }
  }

  counts_r <- dat %>%
    dplyr::filter(.data$r_flag == 1) %>%
    highest_grade(block_count) %>%
    dplyr::group_by_at(groups) %>%
    dplyr::summarize(n_i = get_counts(.data, block_count)) %>%
    dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
    dplyr::mutate(label_ypos = rev(cumsum(rev(.data$n_i))))

  counts_l <- dat %>%
    filter(.data$l_flag == 1) %>%
    highest_grade(block_count) %>%
    dplyr::group_by_at(groups) %>%
    dplyr::summarize(n_i = get_counts(.data, block_count)) %>%
    dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
    dplyr::mutate(label_ypos = rev(cumsum(rev(.data$n_i))))

  total_label_pos_r <- counts_r %>%
    dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
    dplyr::summarize(label_ypos = max(.data$label_ypos))

  total_label_pos_l <- counts_l %>%
    dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
    dplyr::summarize(label_ypos = max(.data$label_ypos))

  total_text_ann_r <- dat %>%
    dplyr::filter(.data$r_flag == 1) %>%
    dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
    dplyr::summarize(n = get_counts(.data, block_count)) %>%
    dplyr::left_join(total_label_pos_r, by = setdiff(groups, "bar_color"))

  total_text_ann_l <- dat %>%
    dplyr::filter(.data$l_flag == 1) %>%
    dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
    dplyr::summarize(n = get_counts(.data, block_count)) %>%
    dplyr::left_join(total_label_pos_l, by = setdiff(groups, "bar_color"))


  if (sort_by == "alphabetical") {
    levels_all <- unique(sort(as.character(union(counts_l$y, counts_r$y)), decreasing = TRUE))
    counts_r$y <- factor(counts_r$y, levels = levels_all)
    counts_l$y <- factor(counts_l$y, levels = levels_all)
  } else if (sort_by == "count") {
    tot <- dplyr::bind_rows(total_text_ann_r, total_text_ann_l) %>%
      dplyr::group_by(.data$y) %>%
      dplyr::summarize(n = sum(n)) %>%
      dplyr::arrange(n)

    counts_r$y <- factor(counts_r$y, levels = tot$y)
    counts_l$y <- factor(counts_l$y, levels = tot$y)
  } else if (sort_by == "right") {
    tot <- dplyr::full_join(total_text_ann_r, select(total_text_ann_l, -n), by = "y") %>%
      dplyr::group_by(.data$y) %>%
      dplyr::summarize(n = sum(n, na.rm = TRUE)) %>%
      dplyr::arrange(n)

    counts_r$y <- factor(counts_r$y, levels = tot$y)
    counts_l$y <- factor(counts_l$y, levels = tot$y)
  } else if (sort_by == "left") {
    tot <- dplyr::full_join(total_text_ann_l, select(total_text_ann_r, -n), by = "y") %>%
      dplyr::group_by(.data$y) %>%
      dplyr::summarize(n = sum(n, na.rm = TRUE)) %>%
      dplyr::arrange(n)

    counts_r$y <- factor(counts_r$y, levels = tot$y)
    counts_l$y <- factor(counts_l$y, levels = tot$y)
  }

  max_c <- max(c(total_text_ann_r$label_ypos, total_text_ann_l$label_ypos))

  if (is.null(group_names)) {
    g_r <- ""
    g_l <- ""
  } else {
    g_r <- group_names[1]
    g_l <- group_names[2]
  }

  # plot butterfly plot --------------------
  if (!is.null(block_color)) {
    pl <- ggplot(NULL, aes(x = .data$y)) +
      geom_bar(data = counts_r, aes(y = .data$n_i, fill = .data$bar_color), stat = "identity") +
      geom_bar(data = counts_l, aes(y = -.data$n_i, fill = .data$bar_color), stat = "identity") +
      geom_text(data = counts_r, aes(y = .data$label_ypos, label = .data$n_i), hjust = 0.9) +
      geom_text(data = counts_l, aes(y = -.data$label_ypos, label = .data$n_i), hjust = -0.9) +
      geom_text(data = total_text_ann_r, aes(y = .data$label_ypos, label = .data$n), fontface = "bold", hjust = -1) +
      geom_text(
        data = total_text_ann_l, aes(y = -.data$label_ypos - 0.4, label = "n"),
        fontface = "bold", hjust = 0.9
      ) +
      geom_hline(yintercept = 0, colour = "black", lwd = 0.4) +
      coord_flip() +
      scale_y_continuous(labels = abs, limits = (max_c * 1.2) * c(-1, 1)) +
      labs(x = y_label, y = block_count, fill = legend_label)
  } else {
    pl <- ggplot(NULL, aes(x = .data$y)) +
      geom_bar(data = counts_r, aes(y = .data$n_i), stat = "identity") +
      geom_bar(data = counts_l, aes(y = -.data$n_i), stat = "identity") +
      geom_hline(yintercept = 0, colour = "black", lwd = 0.4) +
      geom_text(data = total_text_ann_r, aes(y = .data$label_ypos, label = "n"), fontface = "bold", hjust = -1) +
      geom_text(
        data = total_text_ann_l, aes(y = -.data$label_ypos - 0.4, label = "n"),
        fontface = "bold", hjust = 0.9
      ) +
      coord_flip() +
      scale_y_continuous(labels = abs, limits = (max_c * 1.2) * c(-1, 1)) +
      labs(x = y_label, y = block_count, fill = legend_label)
  }

  if (!is.null(facet_rows)) {
    pl <- pl + facet_wrap(~f_rows, ncol = 1)
  }

  pl <- pl +
    theme_bw() +
    theme(
      strip.background = element_rect(colour = "white", fill = "white"),
      strip.text.x = element_text(color = "black", size = 14),
      title = element_text(size = 9),
      axis.title = element_text(size = 20),
      axis.text = element_text(color = "black", size = 9),
      legend.text = element_text(size = 9),
      legend.title = element_text(size = 9),
      panel.grid.major.y = element_line(colour = "gray", linetype = "dotted"),
      plot.margin = grid::unit(c(1.5, 1, 1, 1), "cm"),
      legend.position = if (show_legend) "right" else "none"
    ) +
    scale_x_discrete(limits = levels(counts_r$y))

  # labs pl <- pl + labs(title = stringr::str_wrap(g2, width = 30))
  g_0 <- ggplotGrob(pl)

  g_1 <- gtable::gtable_add_grob(
    g_0,
    grid::grid.text(
      stringr::str_wrap(g_r, width = 30),
      x = 1, just = "center", hjust = 1, gp = grid::gpar(fontsize = 11)
    ),
    t = 1.5, l = g_0$layout[grep("axis-r", g_0$layout$name)[1], 2], b = 3, name = "right-title", clip = "off"
  )
  g_2 <- gtable::gtable_add_grob(
    g_1,
    grid::grid.text(
      stringr::str_wrap(g_l, width = 30),
      x = 1, just = "center", hjust = 0, gp = grid::gpar(fontsize = 11)
    ),
    t = 1.5, l = g_0$layout[grep("axis-l", g_0$layout$name)[1], 2], b = 3, name = "left-title", clip = "off"
  )
  grid::grid.draw(g_2)
  invisible(g_2)
}

#' Adverse Event Category Plot
#'
#' Draw adverse event category plot.
#' @inheritParams argument_convention
#' @param id (`vector`)\cr contains subject identifier. Usually it is \code{ADAE$USUBJID}.
#' @param arm_sl (`vector`)\cr contains the subject level treatment variable.
#' For example, \code{ADSL$ACTARM}.
#' @param subgroups (`data.frame`)\cr Variables to conduct analysis.
#' @param subgroups_sl (`data.frame`)\cr Subject level variables to conduct analysis.
#' Usually from `ADSL`.
#' @param ref (`character`)\cr indicates the name of the reference arm. Default is the first
#' level of \code{arm}.
#' @param trt (`character`)\cr indicates the name of the treatment arm. Default is the second
#' level of \code{arm}.
#' @param indent (`numeric`)\cr non-negative integer where 0 means that the subgroup levels should not be indented
#' @param subgroups_levels (`list`)\cr A nested named list of variables to conduct analysis.
#' The names of the nested lists are used to show as the label.
#' The children lists should start with "Total" = variable label,
#' followed by labels for each level of said variable. See example for reference.
#' @param xmax (`numeric`)\cr maximum range for the x-axis.
#' x-axis range will be automatically assigned based on risk output when `xmax` is less than or equal to 0.
#' `xmax` is 0 by default
#' @param arm_n (`logical`)\cr whether to display the N in each arm.
#'
#' @author Liming Li (Lil128) \email{liming.li@roche.com}
#'
#' @details there is no equivalent STREAM output
#'
#' @return grob object
#'
#' @export
#'
#' @examples
#' library(grid)
#' ADAE <- osprey::rADAE
#' ADSL <- osprey::rADSL
#'
#' id <- ADAE$USUBJID
#' arm <- ADAE$ACTARMCD
#' arm_sl <- as.character(ADSL$ACTARMCD)
#' subgroups_sl <- ADSL[, c("SEX", "RACE", "STRATA1")]
#' subgroups <- ADAE[, c("SEX", "RACE", "STRATA1")]
#' subgroups_levels <- list(
#'   RACE = list(
#'     "Total" = "Race",
#'     "AMERICAN INDIAN OR ALASKA NATIVE" = "American",
#'     "WHITE" = "White",
#'     "ASIAN" = "Asian",
#'     "BLACK OR AFRICAN AMERICAN" = "African"
#'   ),
#'   STRATA1 = list(
#'     "Total" = "Strata",
#'     "A" = "TypeA",
#'     "B" = "TypeB",
#'     "C" = "Typec"
#'   ),
#'   SEX = list(
#'     "Total" = "Sex",
#'     "M" = "Male",
#'     "F" = "Female"
#'   )
#' )
#' # Example 1
#' p1 <- g_ae_sub(id,
#'   arm,
#'   arm_sl,
#'   subgroups,
#'   subgroups_sl,
#'   trt = "ARM A",
#'   ref = "ARM C",
#'   subgroups_levels = subgroups_levels,
#'   arm_n = FALSE
#' )
#' grid::grid.newpage()
#'
#' # Example 2: display number of patients in each arm
#' p2 <- g_ae_sub(id,
#'   arm,
#'   arm_sl,
#'   subgroups,
#'   subgroups_sl,
#'   trt = "ARM A",
#'   ref = "ARM C",
#'   subgroups_levels = subgroups_levels,
#'   arm_n = TRUE
#' )
#' grid::grid.newpage()
#'
#' # Example 3: preprocess data to only include treatment and control arm patients
#' trt <- "ARM A"
#' ref <- "ARM C"
#' ADAE <- osprey::rADAE
#' ADSL <- osprey::rADSL %>% filter(ACTARMCD %in% c(trt, ref))
#' id <- ADAE$USUBJID
#' arm <- ADAE$ACTARMCD
#' arm_sl <- as.character(ADSL$ACTARMCD)
#' subgroups_sl <- ADSL[, c("SEX", "RACE", "STRATA1")]
#' subgroups <- ADAE[, c("SEX", "RACE", "STRATA1")]
#' subgroups_levels <- list(
#'   RACE = list(
#'     "Total" = "Race",
#'     "AMERICAN INDIAN OR ALASKA NATIVE" = "American",
#'     "WHITE" = "White",
#'     "ASIAN" = "Asian",
#'     "BLACK OR AFRICAN AMERICAN" = "African"
#'   ),
#'   STRATA1 = list(
#'     "Total" = "Strata",
#'     "A" = "TypeA",
#'     "B" = "TypeB",
#'     "C" = "Typec"
#'   ),
#'   SEX = list(
#'     "Total" = "Sex",
#'     "M" = "Male",
#'     "F" = "Female"
#'   )
#' )
#' p3 <- g_ae_sub(id,
#'   arm,
#'   arm_sl,
#'   subgroups,
#'   subgroups_sl,
#'   trt,
#'   ref,
#'   subgroups_levels = subgroups_levels,
#'   arm_n = FALSE
#' )
g_ae_sub <- function(id,
                     arm,
                     arm_sl,
                     subgroups,
                     subgroups_sl,
                     trt = levels(arm)[1],
                     ref = levels(arm)[2],
                     indent = 4,
                     subgroups_levels = NULL,
                     xmax = 0,
                     conf_level = 0.95,
                     diff_ci_method = c(
                       "wald", "waldcc", "ac", "score", "scorecc",
                       "mn", "mee", "blj", "ha", "beal"
                     ),
                     fontsize = 4,
                     arm_n = FALSE,
                     draw = TRUE) {
  diff_ci_method <- match.arg(diff_ci_method)

  if (!is.null(subgroups_levels)) {
    labels <- unlist(subgroups_levels)
    label_df <-
      tibble(
        level = stringr::str_replace_all(names(labels), "\\.", "__"),
        label = labels
      ) %>%
      bind_rows(c(level = "TOTAL__Total", label = "Overall")) %>%
      mutate(
        indents = stringr::str_dup(" ", if_else(
          stringr::str_detect(.data$level, "__Total"), 0, indent
        )),
        # create label with indents if not total
        label = paste0(.data$indents, .data$label)
      )
  }
  stopifnot("invalid arguments: check that the length of id and arm are identical" = length(id) == length(arm))
  checkmate::assert_character(arm_sl, min.len = 2)
  stopifnot("invalid arguments: trt and ref need to be from arm" = all(c(trt, ref) %in% unique(arm)))
  checkmate::assert_number(conf_level, lower = 0.5, upper = 1)
  checkmate::assert_number(fontsize, lower = 0)
  checkmate::assert_data_frame(subgroups)
  stopifnot(
    "invalid argument: subgroups needs to be a data.frame with nrow = length(arm)" =
      nrow(subgroups) == length(arm)
  )
  checkmate::assert_data_frame(subgroups_sl)
  stopifnot(
    "invalid argument: subgroups_sl need to be a data.frame with nrow = length(arm_sl)" =
      nrow(subgroups_sl) == length(arm_sl)
  )
  checkmate::assert_number(indent, lower = 0, finite = TRUE)
  checkmate::assert_number(xmax)
  stopifnot(
    "invalid argument: please only use the subgroups column names as the lists names in subgroups_levels" =
      all(names(subgroups_levels) %in% names(lapply(subgroups, levels)))
  )

  stopifnot(
    "invalid argument: please only include levels in subgroups columns in the nested subgroups_levels" =
      all(unlist(lapply(names(subgroups_levels), function(level_name) {
        all(names(subgroups_levels[[level_name]]) %in% c("Total", levels(subgroups[, level_name] %>% dplyr::pull())))
      })))
  )

  checkmate::assert_flag(arm_n)

  subgroups <- subgroups %>%
    mutate_all(as.character) %>%
    mutate(TOTAL = "Total")

  arms <- c(trt, ref)
  xs <- syms(paste("count", arms, sep = "__"))
  ns <- syms(paste("total", arms, sep = "__"))
  rs <- syms(paste("risk", arms, sep = "__"))

  x1 <- xs[[1]]
  n1 <- ns[[1]]
  x2 <- xs[[2]]
  n2 <- ns[[2]]
  r1 <- rs[[1]]
  r2 <- rs[[2]]

  df_ref <- tibble(arm = c(ref, trt))

  # a wide data frame contains event counts by arm in each subgroup
  df <- cbind(id = id, arm = arm, subgroups) %>%
    filter(arm %in% c(ref, trt)) %>%
    unique() %>%
    tidyr::pivot_longer(
      names_to = "strata",
      cols = colnames(subgroups),
      values_to = "value"
    ) %>%
    group_by(arm, .data$strata, .data$value) %>%
    summarise(n = n()) %>%
    full_join(df_ref, by = "arm") %>%
    tidyr::replace_na(list(n = 0)) %>%
    ungroup() %>%
    tidyr::pivot_wider(
      id_cols = c("strata", "value"),
      names_from = "arm",
      values_from = "n",
      names_prefix = "count__",
      values_fill = list(n = 0)
    )

  # a wide data frame contains total counts by arm in each subgroup
  df_sl <- cbind(arm = arm_sl, subgroups_sl) %>%
    filter(arm %in% c(ref, trt)) %>%
    mutate(TOTAL = "Total") %>%
    tidyr::pivot_longer(
      names_to = "strata",
      cols = c(colnames(subgroups_sl), "TOTAL"),
      values_to = "value"
    ) %>%
    group_by(arm, .data$strata, .data$value) %>%
    summarise(n = n()) %>%
    ungroup() %>%
    tidyr::pivot_wider(
      id_cols = c("strata", "value"),
      names_from = "arm",
      values_from = "n",
      names_prefix = "total__",
      values_fill = list(n = 0)
    )

  # calculate the risk difference and risk difference CI in each subgroup
  df <- df %>%
    left_join(df_sl, by = c("strata", "value")) %>%
    group_by(.data$strata, .data$value) %>%
    mutate(
      !!r1 := !!x1 / !!n1,
      !!r2 := !!x2 / !!n2,
      lower = DescTools::BinomDiffCI(
        !!x1, !!n1, !!x2, !!n2,
        conf_level,
        method = diff_ci_method
      )[2],
      upper = DescTools::BinomDiffCI(
        !!x1, !!n1, !!x2, !!n2,
        conf_level,
        method = diff_ci_method
      )[3],
      riskdiff = !!r1 - !!r2
    ) %>%
    tidyr::pivot_longer(
      matches("__"),
      names_to = c(".value", "arm"),
      names_sep = "__"
    ) %>%
    ungroup() %>%
    tidyr::unite("level", "strata", "value", remove = FALSE, sep = "__")

  # create label for plotting
  level_format_df <- df %>%
    select("strata", "value") %>%
    unique() %>%
    group_by(.data$strata) %>%
    summarise(value = paste(c("Total", .data$value), collapse = ",")) %>%
    tidyr::separate_rows("value", sep = ",") %>%
    unique() %>%
    tidyr::unite("level", "strata", "value", sep = "__", remove = FALSE) %>%
    mutate(order = if_else(.data$strata == "TOTAL", integer(1), -row_number())) %>%
    arrange(order)

  if (is.null(subgroups_levels)) {
    level_format_df <- level_format_df %>%
      mutate(label = if_else(
        .data$strata == "TOTAL",
        "Overall",
        if_else(.data$value == "Total", .data$strata, paste0(stringr::str_c(
          rep(" ", indent),
          collapse = ""
        ), .data$value))
      ))
  } else {
    level_format_df <- level_format_df %>%
      inner_join(label_df, by = "level")
  }

  df <- df %>%
    semi_join(level_format_df, by = "level")

  mytheme <- theme_osprey(fontsize = fontsize, blank = TRUE)

  y_axis <-
    scale_y_discrete(
      limits = level_format_df$level,
      breaks = level_format_df$level,
      labels = level_format_df$label
    )

  df_risk <- df %>%
    select("level", "lower", "upper", "riskdiff") %>%
    unique()
  if (xmax <= 0) {
    xmax <- max(abs(df_risk$upper), abs(df_risk$lower), na.rm = TRUE)
  }
  p1 <-
    ggplot(df_risk) +
    geom_point(
      aes(x = .data$riskdiff, y = .data$level),
      size = fontsize
    ) +
    geom_vline(
      data = NULL,
      xintercept = 0,
      linetype = 1,
      color = "grey"
    ) +
    geom_errorbarh(
      aes(xmin = .data$lower, xmax = .data$upper, y = .data$level),
      height = 0.3
    ) +
    mytheme +
    theme(
      axis.ticks.x = element_line(),
      axis.line.x = element_line()
    ) +
    y_axis +
    coord_cartesian(xlim = c(-xmax, xmax))
  p1_grob <- ggplotGrob(p1)

  df_total <- df %>%
    group_by(.data$level) %>%
    summarise(n = sum(.data$total)) %>%
    mutate(percent = n / length(arm_sl) * 100)

  if (arm_n) {
    df_byarm <- df %>%
      group_by(.data$level, .data$arm) %>%
      summarise(n = sum(.data$total)) %>%
      tidyr::pivot_wider(names_from = arm, values_from = n) %>%
      rename(n_trt = matches(trt), n_ref = matches(ref))

    df_total <- df_total %>%
      left_join(df_byarm, by = "level") %>%
      mutate(
        percent_trt = .data$n_trt / .data$n * 100,
        percent_ref = .data$n_ref / .data$n * 100
      )
  }

  p2 <- ggplot(df_total) +
    geom_text(aes(
      x = "Patients(%)",
      y = .data$level,
      label = sprintf("%i (%.1f)", n, .data$percent)
    ), size = fontsize) +
    mytheme +
    y_axis +
    scale_x_discrete(position = "top")

  p2_grob <- ggplotGrob(p2)

  if (arm_n) {
    p2_trt <- ggplot(df_total) +
      geom_text(aes(
        x = "TRT",
        y = .data$level,
        label = sprintf("%i", .data$n_trt)
      ), size = fontsize) +
      mytheme +
      theme(axis.text.y = element_blank()) +
      y_axis +
      scale_x_discrete(position = "top")

    p2_ref <- ggplot(df_total) +
      geom_text(aes(
        x = "CONT",
        y = .data$level,
        label = sprintf("%i", .data$n_ref)
      ), size = fontsize) +
      mytheme +
      theme(axis.text.y = element_blank()) +
      y_axis +
      scale_x_discrete(position = "top")

    p2_trt_grob <- ggplotGrob(p2_trt)
    p2_ref_grob <- ggplotGrob(p2_ref)
  }

  df_ci <- df %>%
    tidyr::pivot_wider(
      names_from = "arm",
      values_from = "risk",
      id_cols = c("level", "lower", "upper", "riskdiff")
    ) %>%
    tidyr::pivot_longer(
      names_to = "x",
      values_to = "v",
      cols = c("lower", "upper", "riskdiff", matches(trt), matches(ref))
    ) %>%
    mutate(vlabel = sprintf("%.2f", .data$v))


  labels <- c("TRT", "CONT", "Diff", "Lower", "Upper")
  p3 <- ggplot(df_ci) +
    geom_text(aes(x = .data$x, y = .data$level, label = .data$vlabel), size = fontsize) +
    mytheme +
    y_axis +
    scale_x_discrete(
      limits = c(trt, ref, "riskdiff", "lower", "upper"),
      labels = labels,
      position = "top"
    )

  p3_grob <- ggplotGrob(p3)

  grobs <- grob_parts(p1_grob, "axis-l")
  grobs <- append(grobs, grob_parts(p2_grob, c("axis-t", "panel")))
  if (arm_n) {
    grobs <- append(grobs, grob_parts(p2_trt_grob, c("axis-t", "panel")))
    grobs <- append(grobs, grob_parts(p2_ref_grob, c("axis-t", "panel")))
  }
  grobs <- append(grobs, grob_parts(p1_grob, c("panel", "axis-b")))
  grobs <- append(grobs, grob_parts(p3_grob, c("axis-t", "panel")))
  less_risk <- grid::textGrob(
    "Favor\nTreatment",
    just = "centre",
    x = grid::unit(fontsize * .pt, "pt"),
    gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold")
  )
  more_risk <- grid::textGrob(
    "Favor\nControl",
    just = "centre",
    x = grid::unit(1, "npc") - grid::unit(fontsize * .pt, "pt"),
    gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold")
  )
  risk_label <- gridExtra::arrangeGrob(less_risk, more_risk, nrow = 1)
  grobs <- append(grobs, list(
    grid::textGrob(
      "Risk Difference (CI)",
      just = "centre",
      x = grid::unit(0.5, "npc"),
      y = grid::unit(0.5, "npc"),
      gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold")
    ),
    risk_label
  ))

  widths <- if (arm_n) {
    grid::unit.c(
      grid::grobWidth(grobs[[1]]),
      grid::unit(
        c(14 * fontsize, rep(10 * fontsize, 2), 1, 50 * fontsize),
        c(rep("pt", 3), "null", "pt")
      )
    )
  } else {
    grid::unit.c(
      grid::grobWidth(grobs[[1]]),
      grid::unit(
        c(14 * fontsize, 1, 50 * fontsize),
        c("pt", "null", "pt")
      )
    )
  }

  heights <- if (arm_n) {
    grid::unit.c(
      grid::grobHeight(grobs[[10]]),
      grid::unit(1, "null"),
      rep(grid::grobHeight(grobs[[9]]), 3),
      grid::unit(fontsize * .pt, "pt")
    )
  } else {
    grid::unit.c(
      grid::grobHeight(grobs[[6]]),
      grid::unit(1, "null"),
      grid::grobHeight(grobs[[5]]),
      grid::unit(fontsize * .pt * 3, "pt")
    )
  }

  boldfont <- grid::gpar(
    fontsize = fontsize * 4,
    fontface = "bold",
    lineheight = 1
  )
  layout_matrix <- if (arm_n) {
    rbind(
      c(NA, 2, 4, 6, 12, 10),
      c(1, 3, 5, 7, 8, 11),
      c(NA, NA, NA, NA, 9, NA),
      c(NA, NA, NA, NA, 13, NA)
    )
  } else {
    rbind(
      c(NA, 2, 8, 6),
      c(1, 3, 4, 7),
      c(NA, NA, 5, NA),
      c(NA, NA, 9, NA)
    )
  }

  ret <- gridExtra::arrangeGrob(
    grobs = grobs,
    layout_matrix = layout_matrix,
    heights = heights,
    widths = widths,
    clip = "on"
  )
  if (draw) {
    grid::grid.draw(ret)
  }
  invisible(ret)
}

#' Applies STREAM style filtering to datasets
#'
#' One of `slref` or `anl` need to be specified. The conversion from `SAS` code in filters dataset may not work in all
#' cases. In case of failure a sensible error message should be returned.
#'
#' @param slref The subject level data frame (typically `ADSL`)
#' @param anl The analysis data frame
#' @param suffix The suffix to apply in quotes (e.g. `"ITT_PFSINV"`)
#' @param slref_keep Variables to keep from `slref` (e.g. `c("REGION", "SEX")`)
#' @param usubjid The unique subject identifier variable in quotes (e.g. `"USUBJID"`)
#' @param filters The name of the filters dataset
#'
#' @return \code{dataframe} object
#' @author Iain Bennett
#' @export
#' @examples
#' ADSL <- osprey::rADSL
#' ADTTE <- osprey::rADTTE
#' filters <- as.data.frame(rbind(
#'   c(ID = "IT", FLTTARGET = "SLREF", FLTWHERE = "where 1 eq 1"),
#'   c(ID = "BIO", FLTTARGET = "SLREF", FLTWHERE = "where BMRKR1 ge 4.3"),
#'   c(ID = "M", FLTTARGET = "SLREF", FLTWHERE = "where SEX eq 'M'"),
#'   c(ID = "PFS", FLTTARGET = "ANL", FLTWHERE = "where PARAMCD eq 'PFS'"),
#'   c(ID = "OS", FLTTARGET = "ANL", FLTWHERE = "where PARAMCD eq 'OS'")
#' ))
#'
#' ANL <- stream_filter(
#'   slref = ADSL,
#'   anl = ADTTE,
#'   suffix = "IT_PFS_BIO",
#'   filters = filters
#' )
stream_filter <- function(slref = NULL, anl = NULL, filters, suffix, slref_keep = NULL, usubjid = "USUBJID") {
  actual_suffix <- NULL

  if (is.null(anl) && is.null(slref)) {
    stop("At least one of anl= or slref= must be provided")
  }

  if (is.null(anl)) {
    anl <- slref
  }

  if (is.null(slref)) {
    slref <- anl
  }

  asl_out <- slref
  anl_out <- anl

  # step 1 get a list of filters

  filters_to_apply <- strsplit(suffix, split = "_", fixed = TRUE) %>%
    unlist()

  n_filters <- length(filters_to_apply)

  for (i in 1:n_filters) {
    this_filter <- filters_to_apply[i]

    # find filter meta data

    this_filter_df <- unique(dplyr::filter(filters, .data$ID == this_filter))

    if (nrow(this_filter_df) == 0) {
      stop(paste("Filter", this_filter, "not found in filters"))
    }

    if (nrow(this_filter_df) > 1) {
      warning(paste("Filter", this_filter, "is duplicated in filters"))
      this_filter_df <- slice(this_filter_df, 1)
    }

    # try and convert where clause from sas to R
    this_sasclause <- this_filter_df$FLTWHERE
    this_rclause <- stream_filter_convwhere(this_sasclause)

    msg1 <- paste("\nSAS code:", this_sasclause, "\nwas converted to\nR code:", this_rclause)

    # what is the target df?

    if (this_filter_df$FLTTARGET == "ANL") {
      this_df <- anl_out
    }

    if (this_filter_df$FLTTARGET == "SLREF") {
      this_df <- asl_out
    }

    # try and apply the filtering
    new_df <- NULL

    new_df <- try(
      eval(parse(text = sprintf("dplyr::filter(this_df, %s)", this_rclause))),
      silent = TRUE
    )

    if (is(new_df, "try-error")) {
      # failed - retain original dataset
      warning(paste("\nFilter ID=", this_filter, "was NOT applied.", msg1, "\n Error message:", new_df))
      cat(paste("\nFilter ID=", this_filter, "was NOT applied.", msg1, "\n Error message:", new_df))
      new_df <- this_df
    } else {
      # success
      msg2 <- paste0(
        "\n",
        nrow(new_df),
        " of ",
        nrow(this_df),
        " observations selected from ", this_filter_df$FLTTARGET
      )
      cat(paste("\nFilter", this_filter, "applied", msg1, msg2, "\n"))
      actual_suffix <- if (is.null(actual_suffix)) {
        this_filter
      } else {
        paste(actual_suffix, this_filter, sep = "_")
      }
    }

    # update the output data sets
    if (this_filter_df$FLTTARGET == "ANL") {
      anl_out <- new_df
    } else if (this_filter_df$FLTTARGET == "SLREF") {
      asl_out <- new_df
    }
  }

  # finished filtering - combine results data
  # what variables to keep from SLREF?
  slref_keep <- if (is.null(slref_keep)) {
    usubjid
  } else {
    unique(c(slref_keep, usubjid))
  }

  # keep these variables only
  asl_out <- eval(parse(text = sprintf("dplyr::transmute(asl_out, %s)", paste(slref_keep, collapse = ","))))

  # use inner join to apply both slref and anl restrictions
  rc <- inner_join(asl_out, anl_out, by = usubjid)

  # report out what was applied in case of errors
  actual_suffix <- ifelse(is.null(actual_suffix), " ", actual_suffix)

  if (actual_suffix == suffix) {
    cat(paste0("\nSuffix ", suffix, " was applied"))
  } else {
    cat(paste0("\nNot all filters applied. \n", actual_suffix, " was applied instead of ", suffix))
  }
  cat(paste0("\n", nrow(rc), " of ", nrow(anl), " observations selected from ANL\n"))

  # return the filtered dataset
  return(rc)
}

#' Replicates the use of index function in `SAS` for logic options
#'
#' Assumption is that use in filters is to only resolve true vs false
#' Primarily for use with stream_filter and related `stream_filter_convwhere` functions
#' @param string1 The string to search within - can be a vector
#' @param string2 The string to search for - must have length 1
#'
#' @return \code{boolean} indicator
#' @author Iain Bennett
#' @export
#'
#' @examples
#' AEACN <- c("DRUG MODIFIED", "DRUG STOPPED", "DOSE/DRUG MODIFIED")
#' stream_filter_index(AEACN, "DRUG MODIFIED")
stream_filter_index <- function(string1, string2) {
  rc <- regexpr(string2, string1, fixed = TRUE)
  rc <- ifelse(rc == -1, FALSE, TRUE)
  return(rc)
}


#' Convert `SAS` code to R code
#'
#' Will convert following `SAS` operators: `eq, =, le, lt, ge, gt, index`
#' Will convert following logic: and, or, ()
#' Will convert all unquoted values to upper case (assumed to be variable names)
#' All quoted values will be returned with single quotes - may fail if have quotes within quotes
#' @param x a character string of `SAS` code
#'
#' @return a character string of R code
#' @author Iain Bennett
#' @export
#'
#' @examples
#' stream_filter_convwhere(x = "where X in (1 2 3 4) and Y gt 4 ")
#' stream_filter_convwhere(x = "where X = \"fred\" and Y gt 4 ")
stream_filter_convwhere <- function(x) {
  # convert double quotes to single quotes. May fail if quoted values exist.
  this_rclause <- gsub("\"", "'", x, fixed = TRUE)

  # convert non quoted values to upper case

  this_rclause_quotes <- strsplit(paste0(" ", this_rclause, " "), split = "'", fixed = TRUE) %>%
    unlist()

  inquotes <- rep(c(0, 1), length.out = length(this_rclause_quotes))

  for (j in seq_along(inquotes)) {
    # try and convert logic outside quotes
    if (inquotes[j] == 0) {
      this_rclause_quotes[j] <- toupper(this_rclause_quotes[j])
      this_rclause_quotes[j] <- gsub("=", "==", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub(" EQ ", " == ", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub(" NE ", " != ", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub(" LE ", " <= ", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub(" LT ", " < ", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub(" GE ", " >= ", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub(" GT ", " > ", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub(" AND ", " & ", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub(" OR ", " || ", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub(" IN ", " %in% c", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub("WHERE ", " ", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub("INDEX(", " stream_filter_index(", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub("UPCASE(", " toupper(", this_rclause_quotes[j], fixed = TRUE)
      this_rclause_quotes[j] <- gsub("DATEPART(", " as.Date(", this_rclause_quotes[j], fixed = TRUE)
    }
  }

  # collapse back to have quoted
  this_rclause <- paste(this_rclause_quotes, collapse = "'")

  # if contains an in  statement need to ensure commas exist
  if (grepl(" %in% c", this_rclause, fixed = TRUE)) {
    # get the clause (assume only 1 per filter...)
    temp1_str <- strsplit(this_rclause, split = " %in% c(", fixed = TRUE) %>%
      unlist()

    if (length(temp1_str) != 2) {
      stop("ERROR - function can't handle multiple IN operators.")
    } else {
      left_str <- temp1_str[1]
      in_right_str <- temp1_str[2]

      # find quoted items bracket
      temp2_str <- strsplit(in_right_str, split = "'", fixed = TRUE) %>%
        unlist()
      inquotes <- rep(c(0, 1), length.out = length(temp2_str))

      # find first not quoted right bracket

      right_idxv <- which(inquotes == 0 & grepl(")", temp2_str, fixed = TRUE))
      right_idxc <- regexpr(")", temp2_str[right_idxv], fixed = TRUE)

      temp3_str <- temp2_str

      temp3_str[right_idxv] <- substr(temp2_str[right_idxv], right_idxc, nchar(temp2_str[right_idxv]))

      right_str <- temp3_str[right_idxv:length(temp3_str)] %>%
        paste(collapse = "'")

      in_idx <- regexpr(right_str, in_right_str, fixed = TRUE) %>%
        as.numeric()

      in_str <- substr(in_right_str, 1, in_idx - 1)

      # now have left.str, in.str and right.str that contain seperate code parts
      # need to check the list of in and remove any commas to later replace between each element
      # first get any unquoted spaces or commas and split these

      temp4_str <- strsplit(in_str, split = "'", fixed = TRUE) %>%
        unlist()
      inquotes <- rep(c(0, 1), length.out = length(temp4_str))

      unquoted <- temp4_str[which(inquotes == 0)]
      quoted_items <- temp4_str[which(inquotes == 1)]

      # seperate any items unqouted
      temp5_str <- strsplit(unquoted, split = ",", fixed = TRUE) %>%
        unlist() %>%
        strsplit(split = " ", fixed = TRUE) %>%
        unlist()

      unquoted_items <- temp5_str[which(!(temp5_str %in% ""))]

      # should now have two vectors of strings
      # unquoted.items and quoted.items
      # first add the quoted items back in quoted.items <- unquoted.items
      if (length(quoted_items) > 0) {
        quoted_items <- paste0("'", quoted_items, "'")
      }

      # now collapse both strings adding commas

      all_items <- c(quoted_items, unquoted_items) %>%
        paste(collapse = " , ")

      # rebuild the complete code piece
      this_rclause <- paste0(left_str, " %in% c(", all_items, right_str)
    }
  }
  return(this_rclause)
}

#' `Swimlane` Plot
#'
#' `Swimlane` plot is often used in Early Development (ED) and displays individual
#' patient bar plot with markers of events and patient level annotation
#'
#' @param bar_id vector of IDs to identify each bar
#' @param bar_length numeric vector to be plotted as length for each bar
#' @param sort_by vector to sort bars
#' @param col_by vector to color bars
#' @param marker_id vector of IDs to identify markers within each bar. Default is the same as bar_id.
#' @param marker_pos numeric vector to specify position for each marker point
#' @param marker_shape vector to specify shape for markers
#' @param marker_shape_opt aesthetic values to map shape values (named vector to map shape values to each name)
#' @param marker_color vector to specify color for markers
#' @param marker_color_opt aesthetic values to map shape values (named vector to map shape values to each name)
#' @param anno_txt dataframe of subject-level variables to be displayed as annotation on the left
#' @param xref_line numeric vector to plot reference lines
#' @param xtick_at optional break interval of bar length axis
#' @param xlab label for bar length
#' @param title string to be displayed as plot title
#'
#' @template author_qit3
#' @return plot object
#'
#' @export
#'
#' @examplesIf require("nestcolor")
#' # Example 1
#' library(dplyr)
#' library(nestcolor)
#'
#' ADSL <- osprey::rADSL[1:20, ]
#' ADRS <- filter(rADRS, PARAMCD == "OVRINV")
#' ANL <- left_join(ADSL, ADRS, by = c("STUDYID", "USUBJID"), multiple = "all")
#' anno_txt <- ADSL[, c("ARMCD", "SEX")]
#'
#' g_swimlane(
#'   bar_id = ADSL$USUBJID,
#'   bar_length = as.integer(ADSL$TRTEDTM - ADSL$TRTSDTM),
#'   sort_by = ADSL$ARM,
#'   col_by = ADSL$ARM,
#'   marker_id = ANL$USUBJID,
#'   marker_pos = ANL$ADY,
#'   marker_shape = ANL$AVALC,
#'   marker_shape_opt = c("CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "NE" = 4),
#'   marker_color = NULL,
#'   marker_color_opt = NULL,
#'   anno_txt = anno_txt,
#'   xref_line = c(50, 100),
#'   xtick_at = waiver(),
#'   xlab = "Time from First Treatment (Day)",
#'   title = "Swimlane Plot"
#' )
#'
#' # Example 2
#' library(dplyr)
#' library(nestcolor)
#'
#' ADSL <- osprey::rADSL[1:20, ]
#' ADRS <- osprey::rADRS
#'
#' anno_txt_vars <- c("ARMCD", "SEX", "COUNTRY")
#' anno_txt <- ADSL[, anno_txt_vars]
#'
#' # markers from ADRS
#' ADRS <- dplyr::filter(ADRS, PARAMCD == "OVRINV") %>% select(USUBJID, ADY, AVALC)
#'
#' # markers from ADSL - discontinuation
#' ADS <- ADSL %>%
#'   dplyr::filter(EOSSTT == "Discontinued" | DCSREAS != "") %>%
#'   select(USUBJID, EOSDY, DCSREAS) %>%
#'   dplyr::rename(ADY = EOSDY, AVALC = DCSREAS)
#'
#' # combine ADRS with ADS records as one data for markers and join with ADSL
#' ANL <- inner_join(ADSL, rbind(ADRS, ADS), by = "USUBJID", multiple = "all")
#'
#' g_swimlane(
#'   bar_id = sub(".*-", "", ADSL$USUBJID),
#'   bar_length = as.integer(ADSL$TRTEDTM - ADSL$TRTSDTM),
#'   sort_by = NULL,
#'   col_by = ADSL$ARMCD,
#'   marker_id = sub(".*-", "", ANL$USUBJID),
#'   marker_pos = ANL$ADY,
#'   marker_shape = ANL$AVALC,
#'   marker_shape_opt = c(
#'     "CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "NE" = 0,
#'     "Adverse Event" = 7, "Death" = 8, "Physician Decision" = 9, "Progressive Disease" = 10,
#'     "Symptomatic Deterioation" = 11, "Withdrawal by Subject" = 12
#'   ),
#'   marker_color = ANL$AVALC,
#'   marker_color_opt = c(
#'     "CR" = "green", "PR" = "blue", "SD" = "yellow", "PD" = "red",
#'     "NE" = "grey", "Adverse Event" = "orange", "Death" = "black", "Physician Decision" = "navy",
#'     "Progressive Disease" = "purple", "Symptomatic Deterioation" = "cyan",
#'     "Withdrawal by Subject" = "darkred"
#'   ),
#'   anno_txt = anno_txt,
#'   xref_line = c(50, 100),
#'   xtick_at = waiver(),
#'   xlab = "Time from First Treatment (Day)",
#'   title = "Swimlane Plot"
#' )
g_swimlane <- function(bar_id,
                       bar_length,
                       sort_by = NULL,
                       col_by = NULL,
                       marker_id = NULL,
                       marker_pos = NULL,
                       marker_shape = NULL,
                       marker_shape_opt = NULL,
                       marker_color = NULL,
                       marker_color_opt = NULL,
                       anno_txt = NULL,
                       xref_line = NULL,
                       xtick_at = waiver(),
                       xlab,
                       title) {
  # check data
  if (!is.null(sort_by)) {
    check_same_N(bar_id = bar_id, bar_length = bar_length, sort_by = sort_by)
  }
  if (!is.null(col_by)) {
    check_same_N(bar_id = bar_id, bar_length = bar_length, col_by = col_by)
  }

  if (!is.null(marker_id) && length(which(!marker_id %in% bar_id)) > 0) {
    stop("marker_id ", marker_id[which(!marker_id %in% bar_id)], " is not in bar_id")
  }

  if (!is.null(marker_id) && !is.null(marker_pos)) {
    check_same_N(marker_id = marker_id, marker_pos = marker_pos)
  }
  if (!is.null(marker_id) && !is.null(marker_shape)) {
    check_same_N(marker_id = marker_id, marker_shape = marker_shape)
  }
  if (!is.null(marker_id) && !is.null(marker_color)) {
    check_same_N(marker_id = marker_id, marker_color = marker_color)
  }
  if (!is.null(xref_line) && (!is.numeric(xref_line) || length(xref_line) == 0)) {
    stop("xref_line must be a non-empty numeric vector or NULL")
  }

  # data for plot
  bar_data <- data.frame(
    bar_id,
    bar_length,
    sort_by = if (is.null(sort_by)) "x" else to_n(sort_by, length(bar_length)),
    col_by = if (is.null(col_by)) "x" else to_n(col_by, length(bar_length))
  )

  # data for marker
  if (is.null(marker_id)) marker_id <- bar_id
  marker_data <- data.frame(
    marker_id,
    marker_pos = if (is.null(marker_pos)) "x" else to_n(marker_pos, length(marker_id)),
    marker_shape = if (is.null(marker_shape)) "x" else to_n(marker_shape, length(marker_id)),
    marker_color = if (is.null(marker_color)) "x" else to_n(marker_color, length(marker_id))
  )

  # if sort by a variable, reorder bar_id by sort var and then bar length; otherwise sort by bar length
  if (!is.null(sort_by)) {
    bar_data$bar_id <- factor(bar_data$bar_id,
      levels = rev(unique(bar_data$bar_id[order(bar_data$sort_by, -bar_data$bar_length)]))
    )
  } else {
    bar_data$bar_id <- factor(bar_data$bar_id,
      levels = rev(unique(bar_data$bar_id[order(-bar_data$bar_length)]))
    )
  }

  # labeling
  xlabel <- deparse(substitute(bar_length))
  xlab <- if (is.null(xlab)) xlabel else xlab

  # plot bar plot first
  p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_length)) +
    geom_bar(stat = "identity", aes(fill = col_by)) +
    coord_flip(xlim = c(1, length(unique(bar_id)) + 1)) +
    theme_bw() +
    theme(
      panel.background = element_blank(),
      panel.grid = element_blank(),
      axis.line = element_line(colour = "black"),
      axis.text.y = element_blank(),
      axis.title.y = element_blank()
    ) +
    # Note ylab as we have coord_flip above
    ylab(xlab)

  if (is.null(col_by)) {
    p <- p + guides(fill = "none")
  } else {
    p <- p +
      guides(fill = guide_legend("Bar Color", order = 1, ncol = 1)) +
      theme(
        legend.title = element_text(size = 8),
        legend.text = element_text(size = 8),
        legend.key = element_rect(fill = NA),
        legend.key.size = grid::unit(1, "line"),
        legend.spacing.y = grid::unit(0, "cm"),
        legend.key.height = grid::unit(1, "line")
      )
  }

  limits_x <- NULL

  # plot marker
  if (!is.null(marker_pos)) {
    p <- p + geom_point(
      data = marker_data,
      aes(x = marker_id, y = marker_pos, shape = marker_shape, color = marker_color),
      size = 2.5, na.rm = TRUE
    )
    limits_x <- c(0, max(bar_length, marker_pos, na.rm = TRUE) + 5)

    if (!is.null(marker_shape)) {
      p <- p + guides(shape = guide_legend("Marker Shape", order = 2))
    } else {
      p <- p + guides(shape = "none")
    }

    if (!is.null(marker_color)) {
      p <- p + guides(color = guide_legend("Marker Color", order = 3))
    } else {
      p <- p + guides(color = "none")
    }

    p <- p +
      scale_shape_manual(
        name = "Marker Shape",
        breaks = levels(factor(marker_data$marker_shape)),
        values = if (!is.null(marker_shape_opt)) marker_shape_opt else c(15:25, 0:14)
      )

    if (is.null(marker_color_opt)) {
      if (!is.null(getOption("ggplot2.discrete.colour"))) {
        marker_color_opt <- getOption("ggplot2.discrete.colour")[-seq_len(length(unique(col_by)))]
      } else {
        marker_color_opt <- c("x" = "black")
      }
    }

    p <- p + scale_color_manual(
      name = "Marker Color",
      breaks = levels(factor(marker_data$marker_color)),
      values = marker_color_opt
    )
  }

  # plot reference lines
  if (!is.null(xref_line)) {
    x_axis_min <- pmax(ggplot_build(p)$layout$panel_params[[1]]$x.range[1], 0)
    x_axis_max <- pmax(ggplot_build(p)$layout$panel_params[[1]]$x.range[2], 0)
    xref_line_min <- min(xref_line)
    xref_line_max <- max(xref_line)
    min_res <- min(c(limits_x[1], x_axis_min, xref_line_min))
    max_res <- max(c(limits_x[2], x_axis_max, xref_line_max))
    p <- p + geom_hline(yintercept = xref_line, linetype = "dashed", color = "red") +
      scale_y_continuous(
        limits = c(min_res, max_res),
        breaks = xtick_at,
        expand = c(`if`(min_res == xref_line_min, .01, 0), `if`(max_res == xref_line_max, .01, 0))
      )
  } else {
    if (!is.null(limits_x)) {
      p <- p + scale_y_continuous(limits = limits_x, breaks = xtick_at, expand = c(0, 0))
    }
  }

  # plot title and labels
  if (!is.null(title)) {
    p <- p +
      labs(title = title) +
      theme(plot.title = element_text(face = "bold"))
  }


  # create annotation as a separate table plot
  if (is.null(anno_txt)) {
    t <- data.frame(bar_id, bar_length,
      sort_by = if (is.null(sort_by)) "x" else to_n(sort_by, length(bar_length))
    )
  } else {
    t <- data.frame(bar_id, bar_length,
      sort_by = if (is.null(sort_by)) "x" else to_n(sort_by, length(bar_length)),
      anno_txt
    )
  }

  # if sort by a variable, reorder bar_id; otherwise sort by bar length
  if (!is.null(sort_by)) {
    t <- t[with(t, order(sort_by, -bar_length, levels(as.factor(bar_id)))), -c(2, 3)]
  } else {
    t <- t[with(t, order(-bar_length, levels(as.factor(bar_id)))), -c(2, 3)]
  }

  t <- as.data.frame(t)
  colnames(t)[1] <- " "

  my_theme <- gridExtra::ttheme_default(
    core = list(
      bg_params = list(fill = NA, col = NA),
      fg_params = list(cex = 0.8)
    ),
    colhead = list(
      bg_params = list(fill = NA, col = NA),
      fg_params = list(cex = 0.8)
    )
  )
  tb <- gridExtra::tableGrob(t, rows = NULL, theme = my_theme)
  tb$heights <- grid::unit(rep(1 / nrow(tb), nrow(tb)), "null")

  # grab plot and table as one plot
  g0 <- ggplotGrob(p)
  g1 <- gtable::gtable_add_cols(g0, sum(tb$widths), 0)
  g <- gtable::gtable_add_grob(g1, tb, t = g1$layout[g1$layout$name == "panel", 1], l = 1)

  grid::grid.newpage()
  grid::grid.draw(g)
  invisible(g)
}

#' Waterfall Plot
#'
#' Waterfall plot is often used in Early Development (ED) to present each individual patient’s best
#' response to a particular drug based on a parameter.
#'
#' @param bar_id (`vector`)\cr contains IDs to identify each bar
#' @param bar_height numeric vector to be plotted as height of each bar
#' @param sort_by (`vector`)\cr used to sort bars, default is `NULL` in which case bars are ordered
#'   by decreasing height
#' @param col_by (`vector`)\cr used to color bars, default is `NULL` in which case bar_id is taken if
#'   the argument \code{bar_color_opt} is provided
#' @param bar_color_opt (`vector`)\cr
#'   aesthetic values to map color values (named vector to map color values to each name).
#'   If not `NULL`, please make sure this contains all possible values for \code{col_by} values,
#'   otherwise default `ggplot` color will be assigned, please note that `NULL` needs to be specified
#'   in this case
#' @param anno_txt (`dataframe`)\cr
#'   contains subject-level variables to be displayed as annotation below the waterfall plot,
#'   default is `NULL`
#' @param href_line (`numeric vector`)\cr to plot horizontal reference lines, default is `NULL`
#' @param facet_by (`vector`)\cr to facet plot and annotation table, default is `NULL`
#' @param show_datavalue (`boolean`)\cr controls whether value of bar height is shown, default is \code{TRUE}
#' @param add_label (`vector`)\cr of one subject-level variable to be added to each bar except for bar_height,
#'   default is `NULL`
#' @param gap_point (`numeric`)\cr value for adding bar break when some bars are significantly higher than
#'   others, default is `NULL`
#' @param ytick_at (`numeric`)\cr optional bar height axis interval, default is 20
#' @param y_label (`string`)\cr label for bar height axis, default is "Best % Change from Baseline"
#' @param title (`string`)\cr displayed as plot title, default is "Waterfall Plot"
#'
#' @author Xuefeng Hou (houx14) \email{houx14@gene.com}
#' @template author_qit3
#'
#' @return plot object
#'
#' @export
#'
#' @examplesIf require("nestcolor")
#' library(tidyr)
#' library(dplyr)
#' library(nestcolor)
#'
#' g_waterfall(
#'   bar_id = letters[1:3], bar_height = c(3, 5, -1),
#'   bar_color_opt = c("red", "green", "blue")
#' )
#'
#' # Example 1
#' ADSL <- osprey::rADSL[1:15, ]
#' ADRS <- osprey::rADRS %>%
#'   filter(USUBJID %in% ADSL$USUBJID)
#' ADTR <- osprey::rADTR %>%
#'   filter(USUBJID %in% ADSL$USUBJID) %>%
#'   select(USUBJID, PCHG) %>%
#'   group_by(USUBJID) %>%
#'   slice(which.min(PCHG))
#'
#' TR_SL <- inner_join(ADSL, ADTR, by = "USUBJID", multiple = "all")
#'
#' SUB_ADRS <- ADRS %>%
#'   filter(PARAMCD == "BESRSPI" | PARAMCD == "INVET") %>%
#'   select(USUBJID, PARAMCD, AVALC, AVISIT, ADY) %>%
#'   spread(PARAMCD, AVALC)
#'
#' ANL <- TR_SL %>%
#'   left_join(SUB_ADRS, by = "USUBJID", multiple = "all") %>%
#'   mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1)
#'
#' anno_txt_vars <- c("TRTDURD", "BESRSPI", "INVET", "SEX", "BMRKR2")
#'
#' g_waterfall(
#'   bar_height = ANL$PCHG,
#'   bar_id = sub(".*-", "", ANL$USUBJID),
#'   col_by = ANL$SEX,
#'   sort_by = ANL$ARM,
#'   # bar_color_opt = c("F" = "red", "M" = "green", "U" = "blue"),
#'   anno_txt = ANL[, anno_txt_vars],
#'   facet_by = NULL,
#'   href_line = c(-30, 20),
#'   add_label = ANL$BESRSPI,
#'   ytick_at = 20,
#'   gap_point = NULL,
#'   show_datavalue = TRUE,
#'   y_label = "Best % Change from Baseline",
#'   title = "Waterfall Plot"
#' )
#'
#' # Example 2 facetting
#' anno_txt_vars <- c("BESRSPI", "INVET")
#'
#' g_waterfall(
#'   bar_id = sub(".*-", "", ANL$USUBJID),
#'   bar_height = ANL$PCHG,
#'   sort_by = ANL$COUNTRY,
#'   col_by = ANL$SEX,
#'   bar_color_opt = c("F" = "tomato", "M" = "skyblue3", "U" = "darkgreen"),
#'   anno_txt = ANL[, anno_txt_vars],
#'   facet_by = ANL$STRATA2,
#'   href_line = c(-30, 20),
#'   add_label = ANL$BESRSPI,
#'   ytick_at = 20,
#'   gap_point = 260,
#'   y_label = "Best % Change from Baseline",
#'   title = "Waterfall Plot"
#' )
#'
#' # Example 3 extreme value
#' ANL$PCHG[3] <- 99
#' ANL$PCHG[5] <- 199
#' ANL$PCHG[7] <- 599
#' ANL$BESRSPI[3] <- "PD"
#' ANL$BESRSPI[5] <- "PD"
#' ANL$BESRSPI[7] <- "PD"
#'
#' g_waterfall(
#'   bar_id = sub(".*-", "", ANL$USUBJID),
#'   bar_height = ANL$PCHG,
#'   sort_by = ANL$ARM,
#'   col_by = ANL$SEX,
#'   bar_color_opt = c("F" = "tomato", "M" = "skyblue3", "U" = "darkgreen"),
#'   anno_txt = ANL[, anno_txt_vars],
#'   facet_by = NULL,
#'   href_line = c(-30, 20),
#'   add_label = ANL$BESRSPI,
#'   ytick_at = 20,
#'   gap_point = 260,
#'   y_label = "Best % Change from Baseline",
#'   title = "Waterfall Plot"
#' )
#'
g_waterfall <- function(bar_id,
                        bar_height,
                        sort_by = NULL,
                        col_by = NULL,
                        bar_color_opt = NULL,
                        anno_txt = NULL,
                        href_line = NULL,
                        facet_by = NULL,
                        show_datavalue = TRUE,
                        add_label = NULL,
                        gap_point = NULL,
                        ytick_at = 20,
                        y_label = "Best % Change from Baseline",
                        title = "Waterfall Plot") {
  # check data
  check_input_length <- c(nrow(data.frame(bar_id)), nrow(data.frame(bar_height)))

  if (length(unique(check_input_length)) > 1) {
    stop("invalid arguments: check that the length of input arguments are identical")
  }

  if (any(check_input_length == 0)) {
    stop("invalid arguments: check that inputs are not null")
  }

  if (!is.null(bar_color_opt)) {
    if (is.null(col_by)) {
      col_by <- bar_id
    } else {
      ls1 <- levels(factor(col_by))
      ls2 <- names(bar_color_opt)
      if (length(intersect(ls1, ls2)) == 0) {
        stop("invalid argument: check that the col_by and bar_color_opt have overlapping categories")
      } else if (length(ls2) < length(ls1)) {
        stop("invalid argument: More categories in col_by than the ones listed in bar_color_opt")
      }
    }
  }

  if (!is.null(sort_by)) check_same_N(bar_id = bar_id, bar_height = bar_height, sort_by = sort_by)
  if (!is.null(col_by)) check_same_N(bar_id = bar_id, bar_height = bar_height, col_by = col_by)

  facet_plot <- function(bar_id = bar_id,
                         bar_height = bar_height,
                         sort_by = sort_by,
                         col_by = col_by,
                         bar_color_opt = bar_color_opt,
                         anno_txt = anno_txt,
                         href_line = href_line,
                         facet_by = facet_by,
                         show_datavalue = show_datavalue,
                         add_label = add_label,
                         gap_point = gap_point,
                         ytick_at = ytick_at,
                         y_label = y_label,
                         title = title) {
    # Data for plot
    bar_data <- data.frame(
      bar_id,
      bar_height,
      add_label = if (is.null(add_label)) to_n("x", length(bar_height)) else to_n(add_label, length(bar_height)),
      sort_by = if (is.null(sort_by)) to_n("x", length(bar_height)) else to_n(sort_by, length(bar_height)),
      col_by = if (is.null(col_by)) to_n("x", length(bar_height)) else to_n(col_by, length(bar_height))
    )

    # if sort by a variable, reorder bar_id by sort var and then bar length; otherwise sort by bar length
    if (!is.null(sort_by)) {
      bar_data$bar_id <- factor(
        bar_data$bar_id,
        levels = unique(bar_data$bar_id[order(bar_data$sort_by, bar_data$bar_height, decreasing = TRUE)])
      )
    } else {
      bar_data$bar_id <- factor(
        bar_data$bar_id,
        levels = unique(bar_data$bar_id[order(bar_data$bar_height, decreasing = TRUE)])
      )
    }

    # bar_id has already been sorted based on bar_height so keeping the 1st entry is equivalent to keeping
    # the best % change from baseline
    bar_data <- bar_data %>% distinct(bar_id, .keep_all = TRUE)

    # plot bar plot
    if (is.null(gap_point)) {
      ybreaks <- seq(
        ytick_at * floor(min(bar_data$bar_height, na.rm = TRUE) / ytick_at),
        ytick_at * ceiling(max(bar_data$bar_height, na.rm = TRUE) / ytick_at),
        by = ytick_at
      )

      p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_height)) +
        geom_col(position = "identity", aes(fill = col_by)) +
        scale_y_continuous(breaks = ybreaks) +
        scale_x_discrete(expand = expansion(add = 0.5)) +
        geom_hline(yintercept = 0, colour = "black") +
        theme_bw() +
        theme(
          panel.background = element_blank(),
          panel.grid = element_blank(),
          axis.line = element_line(colour = "black"),
          axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5),
          axis.title.x = element_blank()
        ) +
        ylab(y_label)
    } else if (all(is.na(bar_data$bar_height))) {
      ybreaks <- seq(ytick_at * -2, ytick_at * 2, by = ytick_at)

      p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_height)) +
        geom_col(position = "identity", aes(fill = col_by)) +
        scale_y_continuous(breaks = ybreaks) +
        scale_x_discrete(expand = expansion(add = 0.5)) +
        geom_hline(yintercept = 0, colour = "black") +
        theme_bw() +
        theme(
          panel.background = element_blank(),
          panel.grid = element_blank(),
          axis.line = element_line(colour = "black"),
          axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5),
          axis.title.x = element_blank()
        ) +
        ylab(y_label)
    } else if (max(bar_data$bar_height, na.rm = TRUE) <= gap_point) {
      ybreaks <- seq(
        ytick_at * floor(min(bar_data$bar_height, na.rm = TRUE) / ytick_at),
        ytick_at * ceiling(max(bar_data$bar_height, na.rm = TRUE) / ytick_at),
        by = ytick_at
      )

      p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_height)) +
        geom_col(position = "identity", aes(fill = col_by)) +
        scale_y_continuous(breaks = ybreaks) +
        scale_x_discrete(expand = expansion(add = 0.5)) +
        geom_hline(yintercept = 0, colour = "black") +
        theme_bw() +
        theme(
          panel.background = element_blank(),
          panel.grid = element_blank(),
          axis.line = element_line(colour = "black"),
          axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5),
          axis.title.x = element_blank()
        ) +
        ylab(y_label)
    } else {
      length_cut <- ytick_at *
        floor(0.8 * (min(bar_data$bar_height[bar_data$bar_height > gap_point], na.rm = TRUE) - gap_point) / ytick_at)

      cut_fun <- function(x) {
        if (is.na(x)) {
          x <- x
        } else if (x > gap_point) {
          x <- x - length_cut
        } else {
          x <- x
        }
      }

      bar_data$new_bar_height <- sapply(bar_data$bar_height, cut_fun)

      ylabel1 <- seq(
        ytick_at * floor(min(bar_data$bar_height, na.rm = TRUE) / ytick_at),
        ytick_at * floor(gap_point / ytick_at),
        by = ytick_at
      )
      ylabel2 <- seq(
        ytick_at * floor((gap_point + length_cut) / ytick_at),
        ytick_at * ceiling(max(bar_data$bar_height, na.rm = TRUE) / ytick_at),
        by = ytick_at
      )

      ybreaks <- seq(
        ytick_at * floor(min(bar_data$new_bar_height, na.rm = TRUE) / ytick_at),
        ytick_at * ceiling(max(bar_data$new_bar_height, na.rm = TRUE) / ytick_at),
        by = ytick_at
      )

      if (length(ylabel1) + length(ylabel2) == length(ybreaks)) {
        ylabels <- c(ylabel1, ylabel2)
      } else {
        dif <- length(ylabel1) + length(ylabel2) - length(ybreaks)
        ylabel2 <- ylabel2[-(1:dif)] # nolint
        ylabels <- c(ylabel1, ylabel2)
      }

      p <- ggplot(data = bar_data, aes(x = bar_id, y = .data$new_bar_height)) +
        geom_col(position = "identity", aes(fill = col_by)) +
        geom_rect(aes(xmin = 0.5, xmax = length(bar_id), ymin = gap_point, ymax = gap_point + 3), fill = "white") +
        scale_y_continuous(breaks = ybreaks, labels = ylabels) +
        scale_x_discrete(expand = expansion(add = 0.5)) +
        geom_hline(yintercept = 0, colour = "black") +
        theme_bw() +
        theme(
          panel.background = element_blank(),
          panel.grid = element_blank(),
          axis.line = element_line(colour = "black"),
          axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5),
          axis.title.x = element_blank()
        ) +
        ylab(y_label)
    }

    if (show_datavalue == TRUE) {
      p <- p + geom_text(
        label = format(bar_data$bar_height, digits = 1),
        size = 2.5,
        vjust = ifelse(bar_data$bar_height >= 0, -0.5, 1.5)
      )
    }

    if (!is.null(add_label)) {
      p <- p + geom_text(
        aes(x = bar_id, y = 0, label = add_label),
        size = 3,
        vjust = ifelse(bar_data$bar_height >= 0, 1.5, -0.5)
      )
    }

    if (is.null(col_by)) {
      p <- p + guides(fill = "none")
    } else {
      p <- p + guides(fill = guide_legend("Bar Color", order = 1, ncol = 1)) +
        theme(
          legend.title = element_text(size = 9),
          legend.text = element_text(size = 9),
          legend.key = element_rect(fill = NA)
        )
    }

    if (is.null(bar_color_opt) && !is.null(getOption("ggplot2.discrete.colour"))) {
      bar_color_opt <- getOption("ggplot2.discrete.colour")
    }
    if (!is.null(bar_color_opt)) {
      p <- p + scale_fill_manual(values = bar_color_opt)
    }

    # plot reference lines
    if (!is.null(href_line)) {
      p <- p + geom_hline(yintercept = href_line, linetype = "dashed", color = "red")
    }

    # add plot title
    if (is.null(facet_by)) {
      p <- p +
        labs(title = title) +
        theme(plot.title = element_text(face = "bold"))
    } else {
      p <- p +
        labs(title = paste(title, "-", as.character(unique(facet_by)))) +
        theme(plot.title = element_text(face = "bold"))
    }

    if (!is.null(anno_txt)) {
      t_anno <- data.frame(
        bar_id,
        bar_height,
        sort_by = if (is.null(sort_by)) to_n("x", length(bar_height)) else to_n(sort_by, length(bar_height)),
        anno_txt
      )

      # if sort by a variable, reorder bar_id; otherwise sort by bar length
      if (!is.null(sort_by)) {
        t_anno$bar_id <- factor(
          t_anno$bar_id,
          levels = unique(t_anno$bar_id[order(t_anno$sort_by, t_anno$bar_height, decreasing = TRUE)])
        )
      } else {
        t_anno$bar_id <- factor(
          t_anno$bar_id,
          levels = unique(t_anno$bar_id[order(t_anno$bar_height, decreasing = TRUE)])
        )
      }

      # bar_id has already been sorted based on bar_height so keeping the 1st entry is equivalent to keeping
      # the best % change from baseline
      t_anno <- t_anno %>% distinct(bar_id, .keep_all = TRUE)
      t_anno <- t_anno[order(t_anno$bar_id), ]
      t_anno <- t_anno[, -c(1, 2, 3)]

      t_anno <- t(t_anno)

      my_theme <- gridExtra::ttheme_default(
        core = list(bg_params = list(fill = NA, col = NA), fg_params = list(cex = 0.8)),
        rowhead = list(bg_params = list(fill = NA, col = NA), fg_params = list(cex = 0.8)),
        padding = grid::unit(c(0, 4), "mm")
      )

      tb <- gridExtra::tableGrob(
        t_anno,
        rows = NULL,
        cols = NULL,
        theme = my_theme
      )

      tb$widths <- grid::unit(rep(1 / (ncol(tb)), ncol(tb)), "null")
      tb <- gtable::gtable_add_grob(
        tb,
        grobs = grid::rectGrob(gp = grid::gpar(fill = NA, lwd = 2)),
        t = 1, b = nrow(tb), l = 1, r = ncol(tb)
      )

      t_anno_name <- names(anno_txt)
      tb_rowname <- gridExtra::tableGrob(
        t_anno_name,
        rows = NULL,
        cols = NULL,
        theme = gridExtra::ttheme_minimal(
          core = list(bg_params = list(fill = NA, col = NA), fg_params = list(cex = 0.8))
        )
      )

      # grab plot and table as one plot
      g0 <- ggplotGrob(p)
      g1 <- gtable::gtable_add_rows(g0, sum(tb$heights), pos = -1)
      g2 <- gtable::gtable_add_grob(
        g1,
        tb,
        t = -1,
        l = g1$layout[g1$layout$name == "panel", 2],
        r = g1$layout[g1$layout$name == "panel", 4]
      )
      g3 <- gtable::gtable_add_cols(g2, tb_rowname$widths, pos = 0)
      g <- gtable::gtable_add_grob(g3, tb_rowname, t = -1, l = 2)
    } else {
      p <- p +
        theme(axis.title.x = element_text()) +
        labs(x = "Unique Subject ID")
      g <- ggplotGrob(p)
    }
    g
  }

  if (is.null(facet_by)) {
    gt <- facet_plot(
      bar_id = bar_id,
      bar_height = bar_height,
      sort_by = sort_by,
      col_by = col_by,
      bar_color_opt = bar_color_opt,
      anno_txt = anno_txt,
      href_line = href_line,
      facet_by = facet_by,
      show_datavalue = show_datavalue,
      add_label = add_label,
      gap_point = gap_point,
      ytick_at = ytick_at,
      y_label = y_label,
      title = title
    )
  } else {
    facet_by <- factor(facet_by)
    g_list <- rep(list(NA), length(levels(facet_by)))
    for (i in seq_along(levels(facet_by))) {
      facet_level <- levels(facet_by)[i]
      g_list[[i]] <- facet_plot(
        bar_id = bar_id[facet_by == facet_level],
        bar_height = bar_height[facet_by == facet_level],
        sort_by = sort_by[facet_by == facet_level],
        col_by = col_by[facet_by == facet_level],
        bar_color_opt = bar_color_opt,
        anno_txt = anno_txt[facet_by == facet_level, , drop = FALSE],
        href_line = href_line,
        facet_by = facet_by[facet_by == facet_level],
        show_datavalue = show_datavalue,
        add_label = add_label[facet_by == facet_level],
        gap_point = gap_point,
        ytick_at = ytick_at,
        y_label = y_label,
        title = title
      )
    }

    gt <- gridExtra::grid.arrange(grobs = g_list, ncol = 1, nrow = length(levels(facet_by)))
  }

  grid::grid.newpage()
  grid::grid.draw(gt)
  invisible(gt)
}

#' Output decorated grob (`gTree`) objects as PDF
#'
#' This is an utility function to output a decorated grob (`gTree`) object
#'
#' @param grobs a grid grob (`gTree`) object, optionally `NULL` if only a grob with
#'   the decoration should be shown.
#' @param outpath specify full path to output pdf to `BCE` or `BEE`
#' @param pagesize name of `pagesize` (print size) and orientation, accepted values include
#'   \code{"a4.landscape"}, \code{"a4.portrait"}, \code{"letter.portrait"} and
#'   \code{"letter.landscape"} (default)
#'
#' @return a pdf file
#' @seealso [grobs2pdf()]
#' @export
#'
#' @author Chendi Liao (liaoc10) \email{chendi.liao@roche.com}
#'
#' @examples
#' \dontrun{
#' library(ggplot2)
#'
#' g <- list(
#'   ggplotGrob(
#'     ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species)) +
#'       geom_point()
#'   ),
#'   ggplotGrob(
#'     ggplot(iris, aes(x = Sepal.Length, y = Petal.Length, color = Species)) +
#'       geom_point()
#'   ),
#'   ggplotGrob(
#'     ggplot(iris, aes(x = Sepal.Length, y = Petal.Width, color = Species)) +
#'       geom_point()
#'   )
#' )
#'
#' # output to pdf
#' as_pdf(g, "~/example_aspdf1.pdf")
#' }
as_pdf <- function(grobs,
                   outpath,
                   pagesize = "letter.landscape") {
  paper_sizes <- paper_size(pagesize)
  paper_width <- paper_sizes[1]
  paper_height <- paper_sizes[2]

  # Output to PDF
  grDevices::pdf(outpath, width = paper_width, height = paper_height)

  lapply(grobs, function(x) {
    grid::grid.newpage()
    grid::grid.draw(x)
  })

  grDevices::dev.off()
}

paper_size <- function(pagesize) {
  if (pagesize == "a4.landscape") {
    paper_width <- 11.7
    paper_height <- 8.3
  } else if (pagesize == "a4.portrait") {
    paper_width <- 8.3
    paper_height <- 11.7
  } else if (pagesize == "letter.portrait") {
    paper_width <- 8.5
    paper_height <- 11
  } else if (pagesize == "letter.landscape") {
    paper_width <- 11
    paper_height <- 8.5
  } else {
    paper_width <- 11
    paper_height <- 8.5
  }
  return(c(paper_width, paper_height))
}

#' Decorate grob (`gTree`) objects then outputs as `IDM` compatible PDF
#'
#' This is an utility function to decorated grob (`gTree`) object with titles and
#' footnotes in accordance with `IDM` specification and export as PDF file with
#' full path to program and the output for easy tracking and archiving.
#'
#' @param grobs A grid grob (`gTree`) object, optionally `NULL` if only a
#'   grob with the decoration should be shown
#' @param titles Vector of character strings. Vector elements are separated by a
#'   newline and strings are wrapped according to the page with
#' @param footnotes Vector of character string. Same rules as for \code{titles}
#' @param progpath Specify the full path to the R program that generate the
#'   grobs and the PDF
#' @param outpath Specify full path to output pdf to `BCE` or `BEE`
#' @param fontsize Base font size used in pdf, default set to 9. Font size for
#'   title is set to \code{fontsize} + 1 (default = 10) and for footnotes set to
#'   \code{fontsize} - 1 (default = 8)
#' @param pagesize name of paper size and orientation, accepted values include
#'   \code{"a4.landscape"}, \code{"a4.portrait"}, \code{"letter.portrait"} and
#'   \code{"letter.landscape"} (default)
#'
#' @return a pdf file
#'
#' @export
#'
#' @author Chendi Liao (liaoc10) \email{chendi.liao@roche.com}
#'
#' @examples
#' \dontrun{
#' library(ggplot2)
#'
#' g <- list(
#'   ggplotGrob(
#'     ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species)) +
#'       geom_point()
#'   ),
#'   ggplotGrob(
#'     ggplot(iris, aes(x = Sepal.Length, y = Petal.Length, color = Species)) +
#'       geom_point()
#'   ),
#'   ggplotGrob(
#'     ggplot(iris, aes(x = Sepal.Length, y = Petal.Width, color = Species)) +
#'       geom_point()
#'   )
#' )
#'
#' grobs2pdf(
#'   grobs = g,
#'   titles = "Visualization of Iris Data",
#'   footnotes = "This is a footnote",
#'   progpath = "~/example_prog.R",
#'   outpath = "~/example_grobs2pdf.pdf"
#' )
#' }
#'
grobs2pdf <- function(grobs,
                      titles,
                      footnotes,
                      progpath,
                      outpath,
                      fontsize = 9,
                      pagesize = "letter.landscape") {
  if (!requireNamespace("tern", quietly = TRUE)) {
    stop("This function requires the R package tern to be available - please install the package.")
  }

  # Loads rapid.base.settings list and a few other

  # Page type (default is letter.landscape, options=a4.portrait, a4.landscape, letter.portrait, letter.landscape)
  if (pagesize == "a4.landscape") {
    top_margin <- 1.44
    bottom_margin <- 0.83
    left_margin <- 1.3
    right_margin <- 1.32
  } else if (pagesize == "a4.portrait") {
    top_margin <- 1.32
    bottom_margin <- 1.3
    left_margin <- 1.44
    right_margin <- 0.83
  } else if (pagesize == "letter.portrait") {
    top_margin <- 0.95
    bottom_margin <- 0.98
    left_margin <- 1.5
    right_margin <- 1.0
  } else if (pagesize == "letter.landscape") {
    top_margin <- 1.5
    bottom_margin <- 1.0
    left_margin <- 0.98
    right_margin <- 0.95
  } else {
    top_margin <- 1.5
    bottom_margin <- 1.0
    left_margin <- 0.98
    right_margin <- 0.95
  }

  paper_sizes <- paper_size(pagesize)
  paper_width <- paper_sizes[1]
  paper_height <- paper_sizes[2]

  ## Adding log text to footnotes
  log1 <- paste0("Program: ", progpath, "; Output: ", outpath) # nolint
  log2 <- paste0(format(Sys.time(), "%d%b%Y %H:%M %Z"), ", generated by ", Sys.getenv("USER")) # nolint
  logtext <- paste(mget(ls(pattern = "log")), collapse = "\n")

  ## Make the grobs
  if (!is.list(grobs)) {
    grobs <- list(grobs)
  }

  ## Decorate grobs
  dg <- tern::decorate_grob_set(
    grobs = grobs,
    titles = titles,
    footnotes = paste(footnotes, logtext, sep = "\n\n"),
    outer_margins = grid::unit(c(0, 0, 0, 0), "lines"),
    padding = grid::unit(0.5, "lines"),
    gp_titles = grid::gpar(fontsize = fontsize + 1, fontface = 2, lineheight = 1),
    gp_footnotes = grid::gpar(fontsize = fontsize - 1, fontface = 1, lineheight = 1),
    gp = grid::gpar(fontsize = fontsize),
    vp = grid::viewport(
      x = grid::unit(left_margin, "inches"),
      y = grid::unit(bottom_margin, "inches"),
      width = grid::unit(paper_width - left_margin - right_margin, "inches"),
      height = grid::unit(paper_height - top_margin - bottom_margin, "inches"),
      just = c("left", "bottom"),
      name = "OuterMargin"
    )
  )

  # Output as PDF
  as_pdf(
    grobs = dg,
    outpath = outpath,
    pagesize = pagesize
  )
}

#' Add padding to grob
#' @param grob grob object
#' @param pad_v padding to add vertically
#' @param pad_h padding to add horizontally
#' @keywords internal
#'
grob_add_padding <- function(grob, pad_v = grid::unit(5, "pt"), pad_h = grid::unit(5, "pt")) {
  ret <- gtable::gtable(
    heights = grid::unit.c(pad_v, grid::unit(1, "null"), pad_v),
    widths = grid::unit.c(pad_h, grid::unit(1, "null"), pad_h)
  )
  # t, b, l, r, z arguments do not need modification
  # same effect can be achieved by modifying pad_v and pad_h
  ret <- gtable::gtable_add_grob(ret, grob, t = 2, b = 2, l = 2, r = 2, z = 1, name = "panel")
  ret <- gtable::gtable_add_grob(ret, grid::rectGrob(), t = 1, b = 3, l = 1, r = 3, z = 0, name = "background")
  return(ret)
}

#' this theme is used across many figures. can be safely removed if update the theme in each function
#' @param axis_side axis position
#' @param fontsize font size in 'mm'
#' @keywords internal
#'
theme_osprey <- function(axis_side = "left", fontsize = 4) {
  theme(
    panel.background = element_rect(fill = "white", colour = "white"),
    panel.grid.major.y = element_line(colour = "grey50", linetype = 2),
    panel.border = element_rect(colour = "black", fill = NA, linewidth = 1),
    axis.title = element_blank(),
    legend.title = element_blank(),
    legend.position = "bottom",
    axis.ticks.y = element_blank(),
    axis.text = element_text(color = "black", size = fontsize * .pt),
    axis.text.y = element_text(hjust = ifelse(axis_side == "left", 1, 0)),
    text = element_text(size = fontsize * .pt, face = "bold", color = "black"),
    legend.text = element_text(size = fontsize * .pt),
    plot.title = element_text(hjust = 0.5)
  )
}

check_same_N <- function(..., omit_null = TRUE) { # nolint
  dots <- list(...)

  n_list <- Map(
    function(x, name) {
      if (is.null(x)) {
        if (omit_null) {
          NA_integer_
        } else {
          stop("arg", name, "is not supposed to be NULL")
        }
      } else if (is.data.frame(x)) {
        nrow(x)
      } else if (is.atomic(x)) {
        length(x)
      } else {
        stop("data structure for ", name, "is currently not supported")
      }
    },
    dots, names(dots)
  )

  n <- stats::na.omit(unlist(n_list))

  if (length(unique(n)) > 1) {
    sel <- which(n != n[1])
    stop("dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
  }

  TRUE
}

to_n <- function(x, n) {
  if (is.null(x)) {
    NULL
  } else if (length(x) == 1) {
    rep(x, n)
  } else if (length(x) == n) {
    x
  } else {
    stop("dimension mismatch")
  }
}

#' Extract specific part of a `ggplot` or grob
#'
#' @param gplot_grob `ggplot` or grob object
#' @param part name of the part to be extracted. `NA` will return `zeroGrob()`
#' @keywords internal
#'
grob_part <- function(gplot_grob, part) {
  if (is.na(part)) {
    return(zeroGrob())
  }
  stopifnot(length(part) == 1 && is.character(part))
  index <- match(part, gplot_grob$layout$name)
  if (is.na(index)) {
    stop(c(
      part, " not in plot object. Allowed parts are ",
      paste(gplot_grob$layout$name, collapse = ", ")
    ))
  }
  grob <- gplot_grob$grobs[[index]]

  return(grob)
}

#' Extract specific parts of a `ggplot` or grob
#'
#' @param gplot `ggplot` or grob object
#' @param parts names vector of the parts to be extracted.
#' @keywords internal
#'
grob_parts <- function(gplot, parts) {
  stopifnot("gplot must inherit from class 'ggplot' or 'grob'" = inherits(gplot, c("ggplot", "grob")))

  if (is(gplot, "ggplot")) {
    gplot_grob <- ggplotGrob(gplot)
  } else if (is(gplot, "grob")) {
    gplot_grob <- gplot
  }
  ret <- lapply(parts, grob_part, gplot_grob = gplot_grob)
  names(ret) <- parts
  return(ret)
}


#' this theme is used across many figures. can be safely removed if update the theme in each function
#' @param axis_side axis position
#' @param fontsize font size in 'mm'
#' @param blank whether to have blank or background with grids and borders
theme_osprey <- function(axis_side = "left", fontsize = 4, blank = FALSE) {
  theme(
    panel.background = element_rect(fill = "white", colour = "white"),
    panel.grid.major.y = if (blank) element_blank() else element_line(colour = "grey50", linetype = 2),
    panel.border = if (blank) element_blank() else element_rect(colour = "black", fill = NA, linewidth = 1),
    axis.title = element_blank(),
    legend.title = element_blank(),
    legend.position = "bottom",
    axis.ticks.y = element_blank(),
    axis.ticks.x.top = element_blank(),
    axis.text = element_text(color = "black", size = fontsize * .pt),
    axis.text.y = element_text(hjust = ifelse(axis_side == "left", 0, 1)),
    text = element_text(size = fontsize * .pt, face = "bold", color = "black"),
    legend.text = element_text(size = fontsize * .pt),
    plot.title = element_text(hjust = 0.5)
  )
}

#' Patient Domain Profile
#'
#' Patient domain profile provides information for a specific subject that participated in the study.
#' The plot includes relevant data for one subject in a user specified domain, including
#' adverse events (\code{ADAE}), response (\code{ADRS}), concomitant medications
#' (\code{ADCM}), exposure (\code{ADEX}), and laboratory (\code{ADLB}).
#'
#' @param domain string of domain name to be shown as y-axis label, default is `NULL`
#' (no y-axis label shown)
#' @param var_names character vector to identify each lane
#' @param marker_pos Depending on the domain, this can be
#' \itemize{
#' \item marker position numeric vector for domains \code{ADEX}, \code{ADLB}, and \code{ADRS}
#' \item numeric data frame with two columns, start and end time marker position,
#' for domains \code{ADAE} and \code{ADCM}
#' }
#' @param arrow_end numeric value indicates the end of arrow when arrows are requested
#' @param xtick_at numeric vector with the locations of the x-axis tick marks
#' @param line_col_list a list may contain \cr
#' \itemize{
#' \item \code{line_col}: factor vector to specify color for segments , default is `NULL`
#' (no line color is specified)\cr
#' \item \code{line_col_opt} aesthetic values to map color values (named vector to map color values to each name).
#'      If not `NULL`, please make sure this contains all possible values for \code{line_col} values,
#'      otherwise color will be assigned by \code{\link[grDevices]{hcl.colors}}
#' \item \code{line_col_legend}: a string to be displayed as line color legend title when \code{line_col} is specified,
#'  default is `NULL` (no legend title is displayed)
#' }
#' @param line_width numeric value for segment width, default is \code{line_width = 1}
#' @param arrow_size numeric value for arrow size, default is \code{arrow_size = 0.1}
#' @param no_enddate_extention numeric value for extending the arrow when end date is missing for \code{ADAE}
#' or \code{ADCM} domain. Default is \code{no_enddate_extention = 0}.
#' @param marker_col_list a list may contain \cr
#' \itemize{
#' \item \code{marker_col} a factor vector to specify color for markers,
#' default is `NULL` (no color markers is specified)
#' \item \code{marker_col_opt} aesthetic values to map color values (named vector to map color values to each name)
#'      If not `NULL`, please make sure this contains all possible values for \code{marker_col} values,
#'      otherwise color will be assigned by \code{\link[grDevices]{hcl.colors}}
#' \item \code{marker_col_legend} a string to be displayed as marker color legend title, default is `NULL`
#' (no legend title is displayed)
#' }
#' @param marker_shape_list a list may contain \cr
#' \itemize{
#' \item \code{marker_shape} factor vector to specify shape for markers,
#' default is `NULL` (no shape marker is specified)
#' \item  \code{marker_shape_opt} aesthetic values to map shape values (named vector to map shape values to each name).
#'      If not `NULL`, please make sure this contains all possible values for \code{marker_shape} values,
#'      otherwise shape will be assigned by \code{ggplot} default
#' \item \code{marker_shape_legend} string to be displayed as marker shape legend title, default is `NULL`
#' (no legend title is displayed)
#' }
#' @param show_days_label boolean value for showing y-axis label, default is \code{TRUE}
#' @param xlim numeric vector for x-axis limit, default is
#'     \code{xlim = c(-28, max(marker_pos) + 5)}
#' @param xlab string to be shown as x-axis label, default is \code{"Study Day"}
#' @param show_title boolean value for showing title of the plot, default is \code{TRUE}
#' @param title string to be shown as title of the plot, default is `NULL` (no plot title is displayed)
#'
#' @author Xuefeng Hou (houx14) \email{houx14@gene.com}
#' @author Tina Cho (chot) \email{tina.cho@roche.com}
#' @author Molly He (hey59) \email{hey59@gene.com}
#' @template author_qit3
#'
#' @return plot object
#'
#' @export
#'
#' @examples
#' library(dplyr)
#'
#' # ADSL
#' ADSL <- osprey::rADSL %>%
#'   filter(USUBJID == rADSL$USUBJID[1]) %>%
#'   mutate(
#'     TRTSDT = as.Date(TRTSDTM),
#'     max_date = max(as.Date(LSTALVDT), as.Date(DTHDT), na.rm = TRUE),
#'     max_day = as.numeric(as.Date(max_date) - as.Date(TRTSDT)) + 1
#'   ) %>%
#'   select(USUBJID, STUDYID, TRTSDT, max_day)
#'
#'
#'
#' # Example 1 Exposure "ADEX"
#' ADEX <- osprey::rADEX %>%
#'   select(USUBJID, STUDYID, ASTDTM, PARCAT2, AVAL, AVALU, PARAMCD)
#' ADEX <- left_join(ADSL, ADEX, by = c("USUBJID", "STUDYID"))
#' ADEX <- ADEX %>%
#'   filter(PARAMCD == "DOSE") %>%
#'   arrange(PARCAT2, PARAMCD) %>%
#'   mutate(diff = c(0, diff(AVAL, lag = 1))) %>%
#'   mutate(
#'     Modification = case_when(
#'       diff < 0 ~ "Decrease",
#'       diff > 0 ~ "Increase",
#'       diff == 0 ~ "None"
#'     )
#'   ) %>%
#'   mutate(
#'     ASTDT_dur = as.numeric(
#'       as.Date(
#'         substr(as.character(ASTDTM), 1, 10)
#'       ) - as.Date(TRTSDT) + 1
#'     )
#'   )
#'
#' p1 <- patient_domain_profile(
#'   domain = "Exposure (ADEX)",
#'   var_names = ADEX$PARCAT2,
#'   marker_pos = ADEX$ASTDT_dur,
#'   arrow_end = ADSL$max_day,
#'   xtick_at = waiver(),
#'   line_col_list = NULL,
#'   line_width = 1,
#'   arrow_size = 0.1,
#'   no_enddate_extention = 0,
#'   marker_col_list = list(
#'     marker_col = factor(ADEX$Modification),
#'     marker_col_opt = c("Increase" = "red", "Decrease" = "green", "None" = "blue"),
#'     marker_col_legend = NULL
#'   ),
#'   marker_shape_list = list(
#'     marker_shape = factor(ADEX$Modification),
#'     marker_shape_opt = c("Increase" = 24, "Decrease" = 25, "None" = 23),
#'     marker_shape_legend = "Dose Modification"
#'   ),
#'   show_days_label = TRUE,
#'   xlim = c(-28, ADSL$max_day),
#'   xlab = "Study Day",
#'   title = paste("Patient Profile: ", ADSL$USUBJID)
#' )
#' p1
#'
#' # Example 2 Adverse Event "ADAE"
#' # Note that ASTDY is represented by a circle and AENDY is represented by a square.
#' # If AENDY and ASTDY occur on the same day only AENDY will be shown.
#'
#' # Adverse Event ADAE
#' ADAE <- osprey::rADAE %>%
#'   select(USUBJID, STUDYID, AESOC, AEDECOD, AESER, AETOXGR, AEREL, ASTDY, AENDY)
#' ADAE <- left_join(ADSL, ADAE, by = c("USUBJID", "STUDYID"))
#'
#' p2 <- patient_domain_profile(
#'   domain = "Adverse Event (ADAE)",
#'   var_names = ADAE$AEDECOD,
#'   marker_pos = ADAE[, c("ASTDY", "AENDY")],
#'   arrow_end = ADSL$max_day,
#'   xtick_at = waiver(),
#'   line_col_list = list(
#'     line_col = ADAE$AESER,
#'     line_col_legend = "Serious",
#'     line_col_opt = c("blue", "green")
#'   ),
#'   line_width = 1,
#'   arrow_size = 0.1,
#'   no_enddate_extention = 0,
#'   marker_col_list = list(
#'     marker_col = factor(ADAE$AETOXGR),
#'     marker_col_opt = c("3" = "yellow", "4" = "red"),
#'     marker_col_legend = NULL
#'   ),
#'   marker_shape_list = list(
#'     marker_shape = NULL,
#'     marker_shape_opt = NULL,
#'     marker_shape_legend = "Grade"
#'   ),
#'   show_days_label = TRUE,
#'   xlim = c(-28, ADSL$max_day),
#'   xlab = "Study Day",
#'   title = paste("Patient Profile: ", ADSL$USUBJID)
#' )
#' p2
#'
#' # Example 3 Tumor Response "ADRS"
#' ADRS <- osprey::rADRS %>%
#'   select(USUBJID, STUDYID, PARAMCD, PARAM, AVALC, AVAL, ADY, ADTM)
#' ADRS <- left_join(ADSL, ADRS, by = c("USUBJID", "STUDYID"))
#' p3 <- patient_domain_profile(
#'   domain = "Tumor Response (ADRS)",
#'   var_names = ADRS$PARAMCD,
#'   marker_pos = ADRS$ADY,
#'   arrow_end = ADSL$max_day,
#'   xtick_at = waiver(),
#'   line_col_list = NULL,
#'   line_width = 1,
#'   arrow_size = 0.1,
#'   no_enddate_extention = 0,
#'   marker_col_list = list(
#'     marker_col = factor(ADRS$AVALC),
#'     marker_col_opt = c(
#'       "CR" = "green", "PR" = "blue",
#'       "SD" = "yellow", "PD" = "red", "NE" = "pink",
#'       "Y" = "lightblue", "N" = "darkred"
#'     ),
#'     marker_col_legend = NULL
#'   ),
#'   marker_shape_list = list(
#'     marker_shape = factor(ADRS$AVALC),
#'     marker_shape_opt = c(
#'       "CR" = 21, "PR" = 24,
#'       "SD" = 23, "PD" = 22, "NE" = 14,
#'       "Y" = 11, "N" = 8
#'     ),
#'     marker_shape_legend = "Response"
#'   ),
#'   show_days_label = TRUE,
#'   xlim = c(-28, ADSL$max_day),
#'   xlab = "Study Day",
#'   title = paste("Patient Profile: ", ADSL$USUBJID)
#' )
#' p3
#'
#' # Example 4 Concomitant Med "ADCM"
#' ADCM <- osprey::rADCM %>%
#'   select(USUBJID, STUDYID, ASTDTM, AENDTM, CMDECOD, ASTDY, AENDY)
#' ADCM <- left_join(ADSL, ADCM, by = c("USUBJID", "STUDYID"))
#' p4 <- patient_domain_profile(
#'   domain = "Concomitant Med (ADCM)",
#'   var_names = ADCM$CMDECOD,
#'   marker_pos = ADCM[, c("ASTDY", "AENDY")],
#'   arrow_end = ADSL$max_day,
#'   xtick_at = waiver(),
#'   line_col_list = list(line_col_opt = "orange"),
#'   line_width = 1,
#'   arrow_size = 0.1,
#'   no_enddate_extention = 50,
#'   marker_col_list = list(marker_col_opt = "orange"),
#'   marker_shape_list = NULL,
#'   show_days_label = TRUE,
#'   xlim = c(-28, ADSL$max_day),
#'   xlab = "Study Day",
#'   title = paste("Patient Profile: ", ADSL$USUBJID)
#' )
#' p4
#'
#' # Example 5 Laboratory "ADLB"
#' ADLB <- osprey::rADLB %>%
#'   select(
#'     USUBJID, STUDYID, LBSEQ, PARAMCD, BASETYPE,
#'     ADTM, ADY, ATPTN, AVISITN, LBTESTCD, ANRIND
#'   )
#' ADLB <- left_join(ADSL, ADLB, by = c("USUBJID", "STUDYID"))
#'
#' ADLB <- ADLB %>%
#'   group_by(USUBJID) %>%
#'   mutate(ANRIND = factor(ANRIND, levels = c("LOW", "NORMAL", "HIGH")))
#'
#' p5 <- patient_domain_profile(
#'   domain = "Laboratory (ADLB)",
#'   var_names = ADLB$LBTESTCD,
#'   marker_pos = ADLB$ADY,
#'   arrow_end = ADSL$max_day,
#'   xtick_at = waiver(),
#'   line_col_list = NULL,
#'   line_width = 1,
#'   arrow_size = 0.1,
#'   no_enddate_extention = 0,
#'   marker_col_list = list(
#'     marker_col = factor(ADLB$ANRIND),
#'     marker_col_opt = c(
#'       "HIGH" = "red", "LOW" = "blue",
#'       "NORMAL" = "green", "NA" = "green"
#'     )
#'   ),
#'   marker_shape_list = list(
#'     marker_shape = factor(ADLB$ANRIND),
#'     marker_shape_opt = c(
#'       "HIGH" = 24, "LOW" = 25,
#'       "NORMAL" = 23, "NA" = 23
#'     ),
#'     marker_shape_legend = "Labs Abnormality"
#'   ),
#'   show_days_label = TRUE,
#'   xlim = c(-30, ADSL$max_day),
#'   xlab = "Study Day",
#'   title = paste("Patient Profile: ", ADSL$USUBJID)
#' )
#' p5
patient_domain_profile <- function(domain = NULL,
                                   var_names,
                                   marker_pos,
                                   arrow_end,
                                   xtick_at = waiver(),
                                   line_col_list = NULL,
                                   line_width = 1,
                                   arrow_size = 0.1,
                                   no_enddate_extention = 0,
                                   marker_col_list = NULL,
                                   marker_shape_list = NULL,
                                   show_days_label = TRUE,
                                   xlim = c(-28, max(marker_pos) + 5),
                                   xlab = NULL,
                                   show_title = TRUE,
                                   title = NULL) {
  line_col <- line_col_list[["line_col"]]
  line_col_opt <- line_col_list[["line_col_opt"]]
  line_col_legend <- line_col_list[["line_col_legend"]]

  marker_col <- marker_col_list[["marker_col"]]
  marker_col_opt <- marker_col_list[["marker_col_opt"]]
  marker_col_legend <- marker_col_list[["marker_col_legend"]]

  marker_shape <- marker_shape_list[["marker_shape"]]
  marker_shape_opt <- marker_shape_list[["marker_shape_opt"]]
  marker_shape_legend <- marker_shape_list[["marker_shape_legend"]]

  # check user input
  stopifnot(
    "invalid arguments: check that the length of input arguments are identical" =
      length(unique(nrow(data.frame(var_names)), nrow(data.frame(marker_pos)), nrow(data.frame(arrow_end)))) == 1
  )
  stopifnot(
    "invalid argument: check that marker_pos is either a vector or a data frame with two columns" =
      ncol(data.frame(marker_pos)) <= 2
  )
  stopifnot(
    "invalid arguments: check that the length of line_col is equal as other inputs" =
      is.null(line_col) || length(line_col) == length(var_names)
  )
  stopifnot(
    "invalid arguments: check that the length of marker_col is equal as other inputs" =
      is.null(marker_col) || length(marker_col) == length(var_names)
  )
  stopifnot(
    "invalid arguments: check that the length of marker_shape is equal as other inputs" =
      is.null(marker_shape) || length(marker_shape) == length(var_names)
  )
  checkmate::assert_numeric(xlim, len = 2)

  marker_data <- data.frame(
    var_names,
    marker_pos = if (is.null(marker_pos)) to_n("x", length(var_names)) else marker_pos,
    marker_shape = if (is.null(marker_shape)) to_n("x", length(var_names)) else marker_shape,
    marker_col = if (is.null(marker_col)) to_n("x", length(var_names)) else marker_col
  )

  # plot lines
  if (length(dim(marker_pos)) == 2) {
    line_data <- data.frame(
      var_names,
      line_col = if (is.null(line_col)) to_n("x", length(var_names)) else line_col,
      line_start = unname(dplyr::pull(marker_pos, 1)),
      line_end = unname(dplyr::pull(marker_pos, 2)),
      line_min = rep(xlim[1], length(var_names)),
      line_max = rep(arrow_end + no_enddate_extention, length(var_names))
    )
    names(line_data) <- c("var_names", "line_col", "line_start", "line_end", "line_min", "line_max")

    p <- ggplot() +
      geom_segment(
        data = line_data[!is.na(line_data$line_end), ],
        aes(
          x = var_names,
          y = line_start,
          xend = var_names,
          yend = line_end,
          color = line_col
        ),
        lineend = "round",
        linejoin = "round",
        linewidth = line_width,
        arrow = NULL,
        show.legend = NA,
        na.rm = TRUE
      ) +
      scale_y_continuous(limits = xlim, breaks = xtick_at, expand = c(0, 0)) +
      coord_flip(xlim = c(1, length(unique(var_names)))) +
      geom_segment(
        data = line_data[is.na(line_data$line_end) == TRUE, ],
        aes(
          x = var_names,
          y = pmax(line_start, line_min, na.rm = TRUE),
          xend = var_names,
          yend = line_max,
          color = line_col
        ),
        lineend = "round",
        linejoin = "round",
        linewidth = line_width,
        show.legend = FALSE,
        arrow = arrow(length = grid::unit(arrow_size, "inches")),
        na.rm = TRUE
      )

    if (is.null(line_col_opt)) {
      line_col_opt <- if (!is.null(getOption("ggplot2.discrete.colour"))) {
        getOption("ggplot2.discrete.colour")
      } else {
        grDevices::hcl.colors(length(levels(line_data$line_col)))
      }
    }

    p <- p +
      scale_color_manual(
        breaks = line_data$line_col,
        values = line_col_opt,
        limits = levels(line_data$line_col)
      )

    if (!is.null(line_col)) {
      p <- p + guides(color = guide_legend(line_col_legend, order = 1))
    } else {
      p <- p + guides(color = "none")
    }

    # plot markers
    p <- p +
      geom_point(
        data = marker_data,
        aes(x = var_names, y = marker_data[, 2], fill = factor(marker_col)),
        shape = 21,
        size = 5,
        na.rm = TRUE
      ) +
      geom_point(
        data = marker_data,
        aes(x = var_names, y = marker_data[, 3], fill = factor(marker_col)),
        shape = 22,
        size = 3,
        na.rm = TRUE
      )

    if (is.null(marker_col_opt)) {
      marker_col_opt <- if (!is.null(getOption("ggplot2.discrete.colour"))) {
        getOption("ggplot2.discrete.colour")
      } else {
        grDevices::hcl.colors(length(levels(marker_data$marker_col)))
      }
    }
    p <- p +
      scale_fill_manual(
        breaks = marker_data$marker_col,
        values = marker_col_opt
      )


    p <- p + theme_bw() +
      theme(
        panel.background = element_blank(),
        panel.grid = element_blank(),
        axis.line = element_line(colour = "black")
      ) +
      ylab(xlab) + xlab(domain)

    if (!is.null(marker_col)) {
      p <- p + guides(fill = guide_legend(marker_col_legend, order = 2))
    } else {
      p <- p + guides(fill = "none")
    }

    p <- p + guides(shape = guide_legend("Shape", order = 3))

    p <- p + scale_shape_manual(values = c(21, 22)) +
      guides(shape = guide_legend(title = "Shape", override.aes = list(label = c("Start", "End")), order = 3))

    if (!is.null(marker_shape)) {
      p <- p + guides(shape = guide_legend(marker_shape_legend, order = 3))
    } else {
      p <- p + guides(shape = "none")
    }
  } else {
    p <- ggplot() +
      geom_point(
        data = marker_data,
        aes(
          x = var_names,
          y = marker_pos,
          shape = marker_shape,
          fill = marker_col
        ),
        size = 3, na.rm = TRUE
      ) +
      scale_y_continuous(limits = xlim, breaks = xtick_at, expand = c(0, 0)) +
      coord_flip(xlim = c(1, length(unique(var_names)))) +
      theme_bw() +
      theme(
        panel.background = element_blank(),
        panel.grid = element_blank(),
        axis.line = element_line(colour = "black")
      ) +
      ylab(xlab) +
      xlab(domain)

    if (is.null(marker_col_legend)) {
      if (length(setdiff(marker_col, marker_shape)) == 0) {
        marker_col_legend <- marker_shape_legend
      }
    }

    if (is.null(marker_shape_legend)) {
      if (length(setdiff(marker_col, marker_shape)) == 0) {
        marker_shape_legend <- marker_col_legend
      }
    }

    if (is.null(marker_col_opt)) {
      if (!is.null(getOption("ggplot2.discrete.colour"))) {
        marker_col_opt <- getOption("ggplot2.discrete.colour")
      } else {
        marker_col_opt <- grDevices::hcl.colors(length(levels(marker_data$marker_col)))
      }
    }
    p <- p +
      scale_fill_manual(
        name = marker_col_legend,
        breaks = marker_data$marker_col,
        values = marker_col_opt
      )

    if (is.null(marker_shape_opt)) marker_shape_opt <- 1:25
    p <- p + scale_shape_manual(
      name = marker_shape_legend,
      breaks = marker_data$marker_shape,
      values = marker_shape_opt
    )
  }

  # plot title and labels
  if (show_title) {
    p <- p +
      labs(title = title) +
      theme(plot.title = element_text(face = "bold"))
  }

  # Plot y axis label
  if (show_days_label == FALSE) {
    p <- p + theme_bw() +
      theme(
        panel.background = element_blank(),
        panel.grid = element_blank(),
        axis.line = element_line(colour = "black"),
        axis.text.x = element_blank(),
        axis.title.x = element_blank(),
        axis.title.y = element_text(size = rel(0.8)),
        legend.title = element_text(size = 10),
        legend.spacing.y = grid::unit(0, "cm"),
        legend.key.height = grid::unit(1, "line"),
        legend.margin = margin(t = 0, b = 0, r = 0.5, l = 0, unit = "cm"),
        plot.margin = margin(t = 0, b = 0, r = 0.5, l = 0.5, unit = "cm")
      )
  } else {
    p <- p + theme_bw() +
      theme(
        panel.background = element_blank(),
        panel.grid = element_blank(),
        axis.line = element_line(colour = "black"),
        legend.title = element_text(size = 10),
        legend.spacing.y = grid::unit(0, "cm"),
        legend.key.height = grid::unit(1, "line"),
        legend.margin = margin(t = 0, b = 0, r = 0.5, l = 0, unit = "cm"),
        plot.margin = margin(t = 0, b = 0, l = 0.5, r = 0.5, unit = "cm")
      )
  }

  p
}

#' Patient Profile Plot
#'
#' Patient profile plot provides detailed information for a specific subject participating in the study.
#' The plot includes relevant data for one subject that can help correlate adverse events, response,
#' concomitant medications, exposure, and laboratory. The plotting of patient profile is modularized, with
#' each domain plot generated by function \code{\link{patient_domain_profile}}. This \code{\link{g_patient_profile}}
#' function assembles all requested domain plots into one patient profile.
#' \code{ADSL}, \code{ADEX}, \code{ADAE}, \code{ADRS}, \code{ADCM} and \code{ADLB} data must be provided.
#' The plot output will not include domains with data unspecified
#'
#' @param ex list may contain
#' \itemize{
#' \item \code{data} dataframe for \code{ADEX} domain dataset
#' \item \code{var} vector to identify each lane of \code{ADEX} domain plot
#' }
#' @param ae list may contain
#' \itemize{
#' \item \code{data} dataframe for \code{ADAE} domain dataset
#' \item \code{var} vector to identify each lane of \code{ADAE} plot
#' \item \code{line_col} factor vector to specify color for segments of \code{ADAE} plot
#' \item \code{line_col_legend} string to be displayed as line color legend title of \code{ADAE} plot
#' \item \code{line_col_opt} aesthetic values to map line color values of \code{ADAE} plot
#'      (named vector to map color values to each name).
#'      If not `NULL`, please make sure this contains all possible values for \code{line_col} values,
#'      otherwise color will be assigned by \code{ggplot} default, please note that `NULL` needs to be
#'      specified
#' }
#' @param rs list may contain
#' \itemize{
#' \item \code{data} dataframe for \code{ADRS} domain dataset
#' \item \code{var} vector to identify each lane of \code{ADRS} domain plot
#' }
#' @param cm list may contain
#' \itemize{
#' \item \code{data} dataframe for \code{ADCM} domain dataset
#' \item \code{var} vector to identify each lane of \code{ADCM} domain plot
#' }
#' @param lb list may contain
#' \itemize{
#' \item \code{data} dataframe for \code{ADLB} domain dataset
#' \item \code{var} vector to identify each lane of \code{ADLB} domain plot
#' }
#' @param arrow_end_day numeric value indicates the end of arrow when arrows are requested
#' @param xlim numeric vector for x-axis limit that will be shared by all domain plots, default is
#'      \code{xlim = c(-28, 365)}
#' @param xlab string to be shown as x-axis label, default is \code{"Study Day"}
#' @param title string to be shown as title of the plot, default is \code{"Patient Profile"}
#'
#' @author Xuefeng Hou (houx14) \email{houx14@gene.com}
#' @author Molly He (hey59) \email{hey59@gene.com}
#' @template author_qit3
#'
#' @return plot object
#'
#' @export
#'
#' @seealso \code{\link{patient_domain_profile}}
#'
#' @examplesIf require("nestcolor")
#' library(dplyr)
#' library(nestcolor)
#'
#' # ADSL
#' ADSL <- osprey::rADSL %>%
#'   filter(USUBJID == rADSL$USUBJID[1]) %>%
#'   mutate(
#'     TRTSDT = as.Date(TRTSDTM),
#'     max_date = max(as.Date(LSTALVDT), as.Date(DTHDT), na.rm = TRUE),
#'     max_day = as.numeric(as.Date(max_date) - as.Date(TRTSDT)) + 1
#'   ) %>%
#'   select(USUBJID, STUDYID, TRTSDT, max_day)
#'
#'
#' # ADEX
#' ADEX <- osprey::rADEX %>%
#'   select(USUBJID, STUDYID, ASTDTM, PARCAT2, AVAL, AVALU, PARAMCD)
#' ADEX <- left_join(ADSL, ADEX, by = c("USUBJID", "STUDYID"))
#'
#' ADEX <- ADEX %>%
#'   filter(PARAMCD == "DOSE") %>%
#'   arrange(PARCAT2, PARAMCD) %>%
#'   mutate(diff = c(0, diff(AVAL, lag = 1))) %>%
#'   mutate(Modification = case_when(
#'     diff < 0 ~ "Decrease",
#'     diff > 0 ~ "Increase",
#'     diff == 0 ~ "None"
#'   )) %>%
#'   mutate(ASTDT_dur = as.numeric(
#'     as.Date(substr(as.character(ASTDTM), 1, 10)) -
#'       as.Date(TRTSDT) + 1
#'   ))
#'
#' # ADAE
#' ADAE <- osprey::rADAE %>%
#'   select(USUBJID, STUDYID, AESOC, AEDECOD, AESER, AETOXGR, AEREL, ASTDY, AENDY)
#' ADAE <- left_join(ADSL, ADAE, by = c("USUBJID", "STUDYID"))
#'
#' # ADRS
#' ADRS <- osprey::rADRS %>%
#'   select(USUBJID, STUDYID, PARAMCD, PARAM, AVALC, AVAL, ADY, ADTM)
#' ADRS <- left_join(ADSL, ADRS, by = c("USUBJID", "STUDYID"))
#'
#' # ADCM
#' ADCM <- osprey::rADCM %>%
#'   select(USUBJID, STUDYID, ASTDTM, AENDTM, CMDECOD, ASTDY, AENDY)
#' ADCM <- left_join(ADSL, ADCM, by = c("USUBJID", "STUDYID"))
#'
#' # ADLB
#' ADLB <- osprey::rADLB %>%
#'   select(
#'     USUBJID, STUDYID, LBSEQ, PARAMCD, BASETYPE, ADTM,
#'     ADY, ATPTN, AVISITN, LBTESTCD, ANRIND
#'   )
#' ADLB <- left_join(ADSL, ADLB, by = c("USUBJID", "STUDYID"))
#'
#' ADLB <- ADLB %>%
#'   group_by(USUBJID) %>%
#'   mutate(ANRIND = factor(ANRIND, levels = c("LOW", "NORMAL", "HIGH")))
#'
#' # Example Patient Profile plot 5 domains
#' g_patient_profile(
#'   ex = list(
#'     data = ADEX,
#'     var = ADEX$PARCAT2
#'   ),
#'   ae = list(
#'     data = ADAE,
#'     var = ADAE$AEDECOD,
#'     line_col = factor(ADAE$AESER),
#'     line_col_legend = "Serious",
#'     line_col_opt = c("Y" = "red", "N" = "blue")
#'   ),
#'   rs = list(
#'     data = ADRS,
#'     var = ADRS$PARAMCD
#'   ),
#'   cm = list(
#'     data = ADCM,
#'     var = ADCM$CMDECOD
#'   ),
#'   lb = list(
#'     data = ADLB,
#'     var = ADLB$LBTESTCD
#'   ),
#'   arrow_end_day = ADSL$max_day,
#'   xlim = c(-28, ADSL$max_day),
#'   xlab = "Study Day",
#'   title = paste("Patient Profile: ", ADSL$USUBJID)
#' )
#'
#' # Example Patient Profile plot without ADCM and ADLB
#' g_patient_profile(
#'   ex = list(
#'     data = ADEX,
#'     var = ADEX$PARCAT2
#'   ),
#'   ae = list(
#'     data = ADAE,
#'     var = ADAE$AEDECOD,
#'     line_col = factor(ADAE$AESER),
#'     line_col_legend = "Serious",
#'     line_col_opt = c("Y" = "red", "N" = "blue")
#'   ),
#'   rs = list(
#'     data = ADRS,
#'     var = ADRS$PARAMCD
#'   ),
#'   arrow_end_day = ADSL$max_day,
#'   xlim = c(-28, ADSL$max_day),
#'   xlab = "Study Day",
#'   title = paste("Patient Profile: ", ADSL$USUBJID)
#' )
g_patient_profile <- function(ex = NULL,
                              ae = NULL,
                              rs = NULL,
                              cm = NULL,
                              lb = NULL,
                              arrow_end_day,
                              xlim = c(-28, 365),
                              xlab = "Study Day",
                              title = "Patient Profile") {
  domains <- list(ex = ex, ae = ae, rs = rs, cm = cm, lb = lb)
  select <- mapply(domain_check, domains, names(domains))
  names(select) <- names(domains)

  show_days_label <- c(FALSE, FALSE, FALSE, FALSE, FALSE)
  show_days_label[max(which(select == TRUE))] <- TRUE

  show_title <- c(FALSE, FALSE, FALSE, FALSE, FALSE)
  show_title[min(which(select == TRUE))] <- TRUE

  if (!is.null(getOption("ggplot2.discrete.colour"))) {
    cols <- getOption("ggplot2.discrete.colour")
  } else {
    cols <- NULL
  }

  # Domain "ADEX"
  if (select["ex"]) {
    p1 <- patient_domain_profile(
      domain = "Exposure (ADEX)",
      var_names = ex$var,
      marker_pos = ex$data$ASTDT_dur,
      arrow_end = arrow_end_day,
      xtick_at = waiver(),
      line_col_list = NULL,
      line_width = 1,
      arrow_size = 0.1,
      no_enddate_extention = 0,
      marker_col_list = list(
        marker_col = factor(ex$data$Modification),
        marker_col_opt = if (!is.null(cols)) cols else c("Increase" = "red", "Decrease" = "green", "None" = "blue")
      ),
      marker_shape_list = list(
        marker_shape = factor(ex$data$Modification),
        marker_shape_opt = c("Increase" = 24, "Decrease" = 25, "None" = 23),
        marker_shape_legend = "Dose Modification"
      ),
      show_days_label = show_days_label[1],
      xlim = xlim,
      xlab = xlab,
      show_title = show_title[1],
      title = title
    )
  } else {
    p1 <- NULL
  }
  # Domain "ADAE"
  if (select["ae"]) {
    p2 <- patient_domain_profile(
      domain = "Adverse Event (ADAE)",
      var_names = ae$var,
      marker_pos = ae$data[, c("ASTDY", "AENDY")],
      arrow_end = arrow_end_day,
      xtick_at = waiver(),
      line_col_list = list(
        line_col = ae$line_col,
        line_col_legend = ae$line_col_legend,
        line_col_opt = ae$line_col_opt
      ),
      line_width = 1,
      arrow_size = 0.1,
      no_enddate_extention = 0.1,
      marker_col_list = list(
        marker_col = factor(ae$data$AETOXGR),
        marker_col_opt = if (!is.null(cols)) {
          cols
        } else {
          c(
            "1" = "green", "2" = "blue", "3" = "yellow", "4" = "orange", "5" = "red"
          )
        },
        marker_col_legend = "Grade"
      ),
      marker_shape_list = NULL,
      show_days_label = show_days_label[2],
      xlim = xlim,
      xlab = xlab,
      show_title = show_title[2],
      title = title
    )
  } else {
    p2 <- NULL
  }


  # Domain "ADRS"
  if (select["rs"]) {
    p3 <- patient_domain_profile(
      domain = "Response (ADRS)",
      var_names = rs$var,
      marker_pos = rs$data$ADY,
      arrow_end = arrow_end_day,
      xtick_at = waiver(),
      line_col_list = NULL,
      line_width = 1,
      arrow_size = 0.1,
      no_enddate_extention = 0,
      marker_col_list = list(
        marker_col = factor(rs$data$AVALC),
        marker_col_opt = if (!is.null(cols)) {
          cols
        } else {
          c(
            "CR" = "green", "PR" = "blue", "SD" = "yellow", "PD" = "red",
            "NE" = "pink", "Y" = "lightblue", "N" = "darkred"
          )
        }
      ),
      marker_shape_list = list(
        marker_shape = factor(rs$data$AVALC),
        marker_shape_opt = c("CR" = 21, "PR" = 24, "SD" = 23, "PD" = 22, "NE" = 14, "Y" = 11, "N" = 8),
        marker_shape_legend = "Response"
      ),
      show_days_label = show_days_label[3],
      xlim = xlim,
      xlab = xlab,
      show_title = show_title[3],
      title = title
    )
  } else {
    p3 <- NULL
  }


  # Domain "ADCM"
  if (select["cm"]) {
    p4 <- patient_domain_profile(
      domain = "Conmed (ADCM)",
      var_names = cm$var,
      marker_pos = cm$data[, c("ASTDY", "AENDY")],
      arrow_end = arrow_end_day,
      xtick_at = waiver(),
      line_col_list = list(line_col_opt = if (!is.null(cols)) cols else "orange"),
      line_width = 1,
      arrow_size = 0.1,
      no_enddate_extention = 0.1,
      marker_col_list = list(marker_col_opt = if (!is.null(cols)) cols else "orange"),
      marker_shape_list = NULL,
      show_days_label = show_days_label[4],
      xlim = xlim,
      xlab = xlab,
      show_title = show_title[4],
      title = title
    )
  } else {
    p4 <- NULL
  }

  # Domain "ADLB"
  if (select["lb"]) {
    p5 <- patient_domain_profile(
      domain = "Laboratory (ADLB)",
      var_names = lb$var,
      marker_pos = lb$data$ADY,
      arrow_end = arrow_end_day,
      xtick_at = waiver(),
      line_col_list = NULL,
      line_width = 1,
      arrow_size = 0.1,
      no_enddate_extention = 0,
      marker_col_list = list(
        marker_col = factor(lb$data$ANRIND),
        marker_col_opt = if (!is.null(cols)) cols else c("HIGH" = "red", "LOW" = "blue", "NORMAL" = "green")
      ),
      marker_shape_list = list(
        marker_shape = factor(lb$data$ANRIND),
        marker_shape_opt = c("HIGH" = 24, "LOW" = 25, "NORMAL" = 23),
        marker_shape_legend = "Labs Abnormality"
      ),
      show_days_label = show_days_label[5],
      xlim = xlim,
      xlab = xlab,
      show_title = show_title[5],
      title = title
    )
  } else {
    p5 <- NULL
  }

  # Assemble domain plots into patient profile plot
  plot_list <- list(p1, p2, p3, p4, p5)

  plot_list <- plot_list[select]
  # distribute space by number of levels in each domain
  var_list <- list(ex$var, ae$var, rs$var, cm$var, lb$var)
  var_list <- var_list %>%
    lapply(unique) %>%
    lapply(length) %>%
    unlist() %>%
    cbind(.data, select) %>%
    as.data.frame() %>%
    # keep the selected domains
    dplyr::filter(select == TRUE) %>%
    dplyr::mutate(nline_dat = ifelse(. <= 10 & . > 0, 10, .)) %>%
    # relative height
    dplyr::mutate(sbplt_ht = unlist(nline_dat) / sum(unlist(nline_dat)))

  cowplot::plot_grid(
    plotlist = plot_list,
    nrow = nrow(var_list),
    align = "v",
    axis = "lr",
    rel_heights = var_list$sbplt_ht
  )
}

#' a helper function for g_patient_profile to check whether the domain has data available
#' @param domain domain input from g_patient_profile
#' @param name domain names
#' @keywords internal
domain_check <- function(domain, name) {
  if (is.null(domain)) {
    select <- FALSE
  } else {
    select <- TRUE
    if (dim(domain$data)[1] == 0 || is.null(domain$data)) {
      warning(paste("No", name, "data for this subject"))
      select <- FALSE
    }
  }
  return(select)
}

#' Heatmap by Grade
#'
#' This function plots heatmap
#'
#' @param id_var (`character`)\cr name of the column that contains the unique subject identifier shared by all data
#' Usually it is \code{"USUBJID"}.
#' @param exp_data (`data.frame`)\cr exposure data. Usually it is \code{ADEX}.
#' @param visit_var (`character`)\cr name of the column that contains the analysis visit. Usually it is \code{"AVISIT"}
#' @param ongo_var (`character`)\cr name of the column in \code{exp_data} that contains the logical variable
#' indicating whether the treatment is still ongoing.
#' Usually it can be derived from \code{EOSSTT}
#' @param anno_data (`data.frame`)\cr annotation data that contains subject level characteristics.
#' Usually it is \code{ADSL}
#' @param anno_var (`character`) a vector of columns name(s) to include for the annotation
#' @param heat_data (`data.frame`)\cr data frame that contains the information needed for the text over heatmap
#' Usually it is \code{ADCM}.
#' @param heat_color_var (`character`)\cr name of the column that contains the heat grade
#' @param heat_color_opt optional, (`character`)\cr a named vector that maps the names to heat colors
#' @param conmed_data optional, (`data.frame`)\cr concomitant medicine data. Usually it is \code{ADCM}
#' default is `NULL` (no `conmed` plotted)
#' @param conmed_var optional, (`character`)\cr concomitant medicine variable name. Must be a column name in
#' `conmed_data` when `conmed_data` is provided. default is `NULL` (no `conmed` plotted)
#' @param conmed_color_opt optional, (`character`)\cr vector of color name(s) to `conmed_data`
#' @param xlab optional, (`character`)\cr string to be shown as x-axis label, default is \code{"Visit"}
#' @param title (`character`)\cr string to be shown as title of the plot.
#' default is `NULL` (no plot title is displayed)
#'
#' @export
#'
#' @author Nina Qi (qit3) \email{qit3@gene.com}
#' @author Molly He (hey59) \email{hey59@gene.com}
#'
#' @examples
#' library(dplyr)
#'
#' ADSL <- osprey::rADSL %>% slice(1:30)
#' ADEX <- osprey::rADEX %>% filter(USUBJID %in% ADSL$USUBJID)
#' ADAE <- osprey::rADAE %>% filter(USUBJID %in% ADSL$USUBJID)
#' ADCM <- osprey::rADCM %>% filter(USUBJID %in% ADSL$USUBJID)
#' # function to derive AVISIT from ADEX
#' add_visit <- function(data_need_visit) {
#'   visit_dates <- ADEX %>%
#'     filter(PARAMCD == "DOSE") %>%
#'     distinct(USUBJID, AVISIT, ASTDTM) %>%
#'     group_by(USUBJID) %>%
#'     arrange(ASTDTM) %>%
#'     mutate(next_vis = lead(ASTDTM), is_last = ifelse(is.na(next_vis), TRUE, FALSE)) %>%
#'     rename(this_vis = ASTDTM)
#'   data_visit <- data_need_visit %>%
#'     select(USUBJID, ASTDTM) %>%
#'     left_join(visit_dates, by = "USUBJID", relationship = "many-to-many") %>%
#'     filter(ASTDTM > this_vis & (ASTDTM < next_vis | is_last == TRUE)) %>%
#'     left_join(data_need_visit, relationship = "many-to-many")
#'   return(data_visit)
#' }
#' # add AVISIT in ADAE and ADCM
#' ADAE <- add_visit(ADAE)
#' ADCM <- add_visit(ADCM)
#' exp_data <- ADEX %>%
#'   filter(PARCAT1 == "INDIVIDUAL") %>%
#'   group_by(USUBJID) %>%
#'   # create a shorter subject identifier
#'   mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1)) %>%
#'   mutate(ongo_var = (EOSSTT == "ONGOING")) %>%
#'   ungroup()
#' anno_data <- ADSL %>%
#'   select(SEX, COUNTRY, USUBJID) %>%
#'   group_by(USUBJID) %>%
#'   mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1)) %>%
#'   ungroup() %>%
#'   select(-USUBJID)
#' heat_data <- ADAE %>%
#'   select(USUBJID, AVISIT, AETOXGR) %>%
#'   group_by(USUBJID) %>%
#'   mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1)) %>%
#'   ungroup() %>%
#'   select(-USUBJID)
#' heat_color_opt <- c(
#'   "No Event" = "gray90",
#'   "1" = "lightsteelblue1",
#'   "2" = "steelblue1",
#'   "3" = "steelblue4",
#'   "4" = "maroon",
#'   "5" = "brown4"
#' )
#' cmdecod_label <- attr(ADCM[["CMDECOD"]], "label")
#' ADCM <- ADCM %>%
#'   filter(
#'     CMDECOD == "medname A_1/3" | CMDECOD == "medname A_2/3" | CMDECOD == "medname A_3/3"
#'   ) %>%
#'   mutate(CMDECOD = factor(CMDECOD, levels = unique(CMDECOD)))
#' attr(ADCM[["CMDECOD"]], "label") <- cmdecod_label
#' conmed_data <- ADCM %>%
#'   group_by(USUBJID) %>%
#'   mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1))
#' # example plotting conmed
#' g_heat_bygrade(
#'   id_var = "SUBJ",
#'   exp_data,
#'   visit_var = "AVISIT",
#'   ongo_var = "ongo_var",
#'   anno_data,
#'   anno_var = c("SEX", "COUNTRY"),
#'   heat_data,
#'   heat_color_var = "AETOXGR",
#'   heat_color_opt,
#'   conmed_data,
#'   conmed_var = "CMDECOD",
#'   conmed_color_opt = c("green", "green3", "green4")
#' )
#' # example not plotting conmed
#' g_heat_bygrade(
#'   id_var = "SUBJ",
#'   exp_data,
#'   visit_var = "AVISIT",
#'   ongo_var = "ongo_var",
#'   anno_data,
#'   anno_var = c("SEX", "COUNTRY"),
#'   heat_data,
#'   heat_color_var = "AETOXGR",
#'   heat_color_opt
#' )
#'
g_heat_bygrade <- function(id_var,
                           exp_data,
                           visit_var,
                           ongo_var,
                           anno_data,
                           anno_var,
                           heat_data,
                           heat_color_var,
                           heat_color_opt = NULL,
                           conmed_data = NULL,
                           conmed_var = NULL,
                           conmed_color_opt = NULL,
                           xlab = "Visit",
                           title = NULL) {
  # check if all PARCAT1 in exp_data is "individual"
  checkmate::assert_string(id_var)
  checkmate::assert_data_frame(exp_data)
  stopifnot(
    "invalid argument: please only include 'INDIVIDUAL' record in exp_data" = !is.na(exp_data[[visit_var]])
  )
  checkmate::assert_string(visit_var)
  checkmate::assert_string(ongo_var)
  checkmate::assert(
    combine = "and",
    checkmate::check_choice(ongo_var, names(exp_data)),
    checkmate::check_logical(exp_data[[ongo_var]])
  )
  checkmate::assert_data_frame(anno_data)
  stopifnot(
    "invalid argument: anno_data can only contain 3 or less columns including subject ID" = length(anno_var) <= 2
  )
  checkmate::assert_data_frame(heat_data)
  checkmate::assert_choice(heat_color_var, names(heat_data))
  stopifnot(
    "invalid argument: need to provide conmed_data and conmed_var" =
      any(is.null(conmed_data), is.null(conmed_data) == is.null(conmed_var))
  )
  checkmate::assert_choice(conmed_var, names(conmed_data), null.ok = TRUE)
  stopifnot(
    "invalid argument: please only include no more than three conmeds for plotting" =
      is.null(conmed_var) || length(levels(conmed_data[[conmed_var]])) <= 3
  )
  stopifnot(
    "invalid argument: please specify conmed_color_opt for all unique conmed_var" =
      is.null(conmed_data) ||
        is.null(conmed_color_opt) || # nolint indentation_linter
        length(conmed_color_opt) == length(unique(conmed_data[[conmed_var]]))
  )

  if (
    !(
      (is.null(conmed_data) || id_var %in% names(conmed_data)) &&
        id_var %in% names(exp_data) && id_var %in% names(anno_data) && id_var %in% names(heat_data)
    )
  ) {
    stop(
      paste(
        "exp_data, anno_data, heat_data, and conmed_data (if plotting conmed) must include a column named",
        id_var,
        sep = " "
      )
    )
  }
  if (
    !(
      (is.null(conmed_data) || visit_var %in% names(conmed_data)) &&
        visit_var %in% names(exp_data) && visit_var %in% names(heat_data)
    )
  ) {
    stop(
      paste(
        "exp_data, heat_data, and conmed_data (if plotting conmed) must include a column named",
        visit_var,
        sep = " "
      )
    )
  }

  anl_data <- exp_data %>%
    select(!!id_var, !!sym(visit_var)) %>%
    left_join(heat_data, by = c(id_var, visit_var)) %>%
    distinct() %>%
    mutate(heat_color_num = tidyr::replace_na(as.numeric(.data[[heat_color_var]]), 0)) %>%
    group_by(!!sym(id_var), !!sym(visit_var)) %>%
    arrange(!!sym(visit_var)) %>%
    mutate(heat_color_max = factor(max(.data$heat_color_num), levels = 0:5)) %>%
    select(-(!!heat_color_var), -"heat_color_num") %>% # nolint
    distinct() %>%
    left_join(anno_data, by = id_var)

  # dose reduction data
  ex_red <- exp_data %>%
    filter(.data$PARAMCD == "DOSE") %>%
    group_by(!!sym(id_var)) %>%
    arrange(.data$ASTDTM) %>%
    mutate(
      RANK = order(.data$ASTDTM),
      LASTDOSE = lag(.data$AVAL),
      DOSERED = ifelse(.data$RANK != 1 & .data$AVAL < .data$LASTDOSE, TRUE, FALSE)
    ) %>%
    select(!!sym(id_var), !!sym(visit_var), "RANK", "AVAL", "LASTDOSE", "DOSERED") %>%
    filter(.data$DOSERED == TRUE)
  # does ongoing data
  exp_lst <- exp_data %>%
    filter(.data$PARAMCD == "DOSE") %>%
    filter(!!sym(ongo_var) == TRUE) %>%
    group_by(!!sym(id_var)) %>%
    arrange(!!sym(visit_var)) %>%
    slice_tail() %>%
    select(!!sym(id_var), !!sym(visit_var))
  visit_levels <- unique(anl_data[[visit_var]])
  if (!is.null(conmed_data) && !is.null(conmed_var)) {
    conmed_data <- conmed_data %>%
      left_join(anl_data, by = c(id_var, visit_var)) %>%
      ungroup() %>%
      mutate(
        conmed_num = as.numeric(.data[[conmed_var]]),
        conmed_num_m = stats::median(unique(.data$conmed_num), na.rm = TRUE)
      ) %>%
      mutate(
        distance = (ifelse(
          .data$conmed_num <= .data$conmed_num_m,
          .data$conmed_num - 1,
          .data$conmed_num + 1
        ) - .data$conmed_num_m) / 5,
        conmed_x = as.numeric(!!sym(visit_var)) + .data$distance
      )
  }
  subj_levels <- unique(anl_data[[id_var]])
  levels(anl_data$heat_color_max)[levels(anl_data$heat_color_max) == "0"] <- "No Event"
  p <- ggplot(
    data = anl_data,
    aes(x = !!sym(visit_var), y = factor(!!sym(id_var), levels = c(rev(subj_levels), "")))
  ) +
    geom_tile(aes(fill = .data$heat_color_max)) +
    scale_y_discrete(drop = FALSE) +
    scale_fill_discrete(
      name = "Highest grade of\nindividual events",
      type = if (!is.null(heat_color_opt)) {
        heat_color_opt
      } else {
        if (!is.null(getOption("ggplot2.discrete.colour"))) {
          rev(grDevices::hcl.colors(6, palette = "peach"))
        } else {
          rev(grDevices::terrain.colors(6))
        }
      }
    ) +
    # plot dose reduction
    geom_segment(
      data = ex_red,
      aes(
        y = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))) + 0.3,
        x = as.numeric(factor(!!sym(visit_var), levels = visit_levels)),
        yend = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))) - 0.3,
        xend = as.numeric(factor(!!sym(visit_var), levels = visit_levels))
      ),
      arrow = arrow(length = grid::unit(0.1, "cm")),
      linewidth = .5,
      color = "black"
    ) +
    # plot ongoing
    geom_segment(
      data = exp_lst,
      aes(
        x = as.numeric(factor(!!sym(visit_var), levels = visit_levels)) + 0.5,
        xend = as.numeric(factor(!!sym(visit_var), levels = visit_levels)) + 0.65,
        y = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))),
        yend = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels)))
      ),
      arrow = arrow(length = grid::unit(0.1, "cm")),
      linewidth = .5,
      color = "black"
    )
  if (!is.null(conmed_data) && !is.null(conmed_var)) {
    p <- p +
      geom_point(
        data = conmed_data,
        aes(
          x = .data$conmed_x,
          y = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))),
          shape = .data[[conmed_var]],
          color = .data[[conmed_var]]
        ),
        size = 2
      ) +
      scale_colour_manual(
        name = attr(conmed_data[[conmed_var]], "label"),
        values = if (!is.null(conmed_color_opt)) {
          conmed_color_opt
        } else {
          if (!is.null(getOption("ggplot2.discrete.colour"))) {
            getOption("ggplot2.discrete.colour")[-2]
          } else {
            rep("black", 5)
          }
        }
      ) +
      scale_shape_manual(
        name = attr(conmed_data[[conmed_var]], "label"),
        values = c(15:17)
      )
  }

  p <- p +
    theme_bw() +
    theme(
      panel.background = element_blank(),
      panel.grid = element_blank(),
      axis.line = element_line(colour = "black"),
      axis.text.x = element_text(angle = 90),
      axis.text.y = element_blank(),
      axis.title.y = element_blank()
    ) +
    labs(x = xlab, y = "ylab")
  # plot title and labels
  if (!is.null(title)) {
    p <- p +
      labs(title = title) +
      theme(plot.title = element_text(face = "bold"))
  }

  # plot left legend
  t <- anl_data %>%
    as.data.frame() %>%
    select((!!anno_var), (!!id_var)) %>%
    distinct()
  my_theme <- gridExtra::ttheme_default(
    core = list(
      bg_params = list(fill = NA, col = NA),
      fg_params = list(cex = 0.8)
    ),
    colhead = list(
      bg_params = list(fill = NA, col = NA),
      fg_params = list(cex = 0.8)
    )
  )
  tb <- gridExtra::tableGrob(t, rows = NULL, theme = my_theme)
  tb$heights <- grid::unit(rep(1 / nrow(tb), nrow(tb)), "null")

  # grab plot and table as one plot
  g0 <- ggplotGrob(p)
  g1 <- gtable::gtable_add_cols(g0, sum(tb$widths), 0)
  g <- gtable::gtable_add_grob(g1, tb, t = g1$layout[g1$layout$name == "panel", 1], l = 1)

  grid::grid.newpage()
  grid::grid.draw(g)
  invisible(g)
}

#' Spider Plot
#'
#' Spider plot is often used in Early Development (ED) and displays individual
#' patient plot of an endpoint over time by group.
#'
#'
#' @param marker_x vector of x values (must be in sorted order)
#' @param marker_id vector to group the points together (default
#' should be `USUBJID`)
#' @param marker_y vector of y values
#' @param line_colby vector defines by what variable plot is color coded,
#' default here is `NULL`
#' @param line_color_opt vector defines line color, default here is `NULL`
#' @param marker_size size of markers in plot, default here is `NULL`
#' @param marker_shape vector defines by what variable points are shape coded,
#' , default here is `NULL`
#' @param marker_shape_opt vector defines marker shape code, default here is `NULL`
#' @param datalabel_txt list defines text (at last time point) and flag for an arrow annotation:
#' - (per defined variable) elements must be labeled `txt_ann`/`mrkr_all`/`mrkr_ann`.
#' - `txt_ann` text annotation next to final data point (for text annotation)
#' - `mrkr_all` vector of ID's (for annotation marker)
#' - `mrkr_ann` vector of ID's (subset of `mrkr_all`) where arrow is desired to
#' indicate any study interim points. Default here is `NULL`.
#' @param facet_rows dataframe defines what variable is used to split the
#' plot into rows, default here is `NULL`.
#' @param facet_columns dataframe defines what variable is used to split the
#' plot into columns, default here is `NULL`.
#' @param vref_line value defines vertical line overlay
#' (can be a vector), default here is `NULL`.
#' @param href_line value defines horizontal line overlay
#' (can be a vector), default here is `NULL`.
#' @param x_label string of text for x axis label, default is time.
#' @param y_label string of text for y axis label, default is % change.
#' @param show_legend boolean of whether marker legend is included, default here is `FALSE`.
#'
#' @return `ggplot` object
#'
#' @details there is no equivalent STREAM output
#'
#' @export
#'
#' @template author_zhanc107
#'
#' @examplesIf require("nestcolor")
#' # simple example
#' library(dplyr)
#' library(nestcolor)
#'
#' ADTR <- osprey::rADTR %>% select(STUDYID, USUBJID, ADY, AVISIT, CHG, PCHG, PARAMCD)
#' ADSL <- osprey::rADSL %>% select(STUDYID, USUBJID, RACE, SEX, ARM)
#' ANL <- left_join(ADTR, ADSL, by = c("STUDYID", "USUBJID"))
#' ANL <- ANL %>%
#'   dplyr::filter(PARAMCD == "SLDINV" & AVISIT != "POST-BASELINE MINIMUM") %>%
#'   dplyr::filter(RACE %in% c("WHITE", "ASIAN")) %>%
#'   group_by(USUBJID) %>%
#'   dplyr::arrange(ADY) %>%
#'   dplyr::mutate(
#'     CHG = ifelse(AVISIT == "Screening", 0, CHG),
#'     PCHG = ifelse(AVISIT == "Screening", 0, PCHG)
#'   )
#' ANL$USUBJID <- substr(ANL$USUBJID, 14, 18)
#'
#' # Plot 1 - default color and shape mapping
#' g_spiderplot(
#'   marker_x = ANL$ADY,
#'   marker_id = ANL$USUBJID,
#'   marker_y = ANL$PCHG,
#'   line_colby = ANL$USUBJID,
#'   marker_shape = ANL$USUBJID,
#'   # marker_size = 5,
#'   datalabel_txt = list(txt_ann = ANL$USUBJID),
#'   # facet_rows = data.frame(sex = ANL$SEX),
#'   # facet_columns = data.frame(arm = ANL$ARM),
#'   vref_line = c(42, 86),
#'   href_line = c(-20, 20),
#'   x_label = "Time (Days)",
#'   y_label = "Change (%) from Baseline",
#'   show_legend = TRUE
#' )
#'
#' # Plot 2 - with line color mapping
#' g_spiderplot(
#'   marker_x = ANL$AVISIT,
#'   marker_id = ANL$USUBJID,
#'   marker_y = ANL$CHG,
#'   line_colby = ANL$RACE,
#'   line_color_opt = c("WHITE" = "red", "ASIAN" = "blue"),
#'   marker_shape = ANL$USUBJID,
#'   x_label = "Visit",
#'   y_label = "Change from Baseline",
#'   show_legend = TRUE
#' )
g_spiderplot <- function(marker_x,
                         marker_id,
                         marker_y,
                         line_colby = NULL,
                         line_color_opt = NULL,
                         marker_shape = NULL,
                         marker_shape_opt = NULL,
                         marker_size = 3,
                         datalabel_txt = NULL, # USUBJID default
                         facet_rows = NULL,
                         facet_columns = NULL,
                         vref_line = NULL,
                         href_line = NULL,
                         x_label = "Time (Days)",
                         y_label = "Change (%) from Baseline",
                         show_legend = FALSE) {
  check_input_length <- c(nrow(data.frame(marker_x)), nrow(data.frame(marker_id)), nrow(data.frame(marker_y)))

  if (length(unique(check_input_length)) > 1) {
    stop("invalid arguments: check that the length of input arguments are identical")
  }
  if (any(check_input_length == 0)) {
    stop("invalid arguments: check that inputs are not null")
  }

  # set up data-------
  dat <- data.frame(x = marker_x, y = marker_y, group = marker_id)

  if (!is.null(marker_shape)) {
    if (length(unique(c(nrow(data.frame(marker_shape)), check_input_length))) != 1) {
      stop("invalid arguments: check that the length of input arguments are identical")
    }
    dat$sh <- marker_shape
  }
  if (!is.null(facet_rows)) {
    if (length(unique(c(nrow(facet_rows), check_input_length))) != 1) {
      stop("invalid arguments: check that the length of input arguments are identical")
    }
    dat$f_rows <- interaction(facet_rows)
  }
  if (!is.null(facet_columns)) {
    if (length(unique(c(nrow(facet_columns), check_input_length))) != 1) {
      stop("invalid arguments: check that the length of input arguments are identical")
    }
    dat$f_columns <- interaction(facet_columns)
  }
  if (!is.null(line_colby)) {
    if (length(unique(c(nrow(data.frame(line_colby)), check_input_length))) != 1) {
      stop("invalid arguments: check that the length of input arguments are identical")
    }
    dat$l_col <- line_colby
  }
  if (!is.null(datalabel_txt$txt_ann)) {
    dat$lbl_all <- datalabel_txt$txt_ann

    dat <- dat %>%
      group_by(.data$lbl_all) %>%
      dplyr::mutate(lab = ifelse(.data$x == last(.data$x), as.character(.data$lbl_all), " "))
  }
  if (!is.null(datalabel_txt$mrkr_all) && !is.null(datalabel_txt$mrkr_ann)) {
    if (length(unique(c(nrow(datalabel_txt$mrkr_all), check_input_length))) != 1) {
      stop("invalid arguments: check that the length of input arguments are identical")
    }
    dat$id <- datalabel_txt$mrkr_all
  }

  dat <- dat %>% as.data.frame()

  # plot spider plot----------------- this section can be condensed later
  pl <- ggplot(data = dat, aes(x = .data$x, y = .data$y, group = .data$group)) +
    xlab(x_label) +
    ylab(y_label) +
    theme(legend.position = "top", legend.title = element_blank())

  pl <- pl + geom_hline(yintercept = 0, linetype = "solid", color = "gray", linewidth = 1)


  pl <- pl +
    geom_line(
      mapping = if (!is.null(line_colby)) {
        aes(color = .data$l_col)
      } else {
        NULL
      },
      linewidth = 1,
      alpha = 0.5,
      show.legend = show_legend
    )

  # marker shape------------ this section can be condensed later
  if (!is.null(marker_shape)) {
    pl <- pl +
      geom_point(mapping = if (!is.null(line_colby)) {
        aes(shape = .data$sh, color = .data$l_col)
      } else {
        aes(shape = .data$sh)
      }, size = marker_size, show.legend = show_legend)
  } else if (is.null(marker_shape)) {
    pl <- pl +
      geom_point(mapping = if (!is.null(line_colby)) {
        aes(color = .data$l_col)
      } else {
        NULL
      }, size = 3, show.legend = show_legend)
  }

  # label at last data point---------
  if (!is.null(datalabel_txt)) {
    if (!is.null(datalabel_txt$txt_ann) && is.null(datalabel_txt$mrkr_all) && is.null(datalabel_txt$mrkr_ann)) {
      pl <- pl +
        geom_text(
          data = dat,
          aes(x = .data$x, y = .data$y, label = .data$lab), hjust = -0.3,
          size = 4,
          show.legend = FALSE
        )
    } else if (is.null(datalabel_txt$txt_ann) && !is.null(datalabel_txt$mrkr_all) && !is.null(datalabel_txt$mrkr_ann)) {
      dat_arrow <- dat %>%
        dplyr::filter(id %in% datalabel_txt$mrkr_ann) %>%
        group_by(.data$id) %>%
        dplyr::filter(.data$x == last(.data$x))
      pl <- pl +
        geom_segment(
          data = dat_arrow,
          mapping = aes(x = .data$x, y = .data$y, xend = .data$x, yend = .data$y),
          arrow = arrow(length = grid::unit(0.15, "inches"), ends = "first", type = "closed"),
          linewidth = 0.4,
          color = "black",
          show.legend = FALSE
        )
    } else if (
      !is.null(datalabel_txt$txt_ann) &&
        !is.null(datalabel_txt$mrkr_all) &&
        !is.null(datalabel_txt$mrkr_ann)
    ) {
      pl <- pl +
        geom_text(
          data = dat,
          aes(x = .data$x, y = .data$y, label = .data$lab),
          hjust = -0.45,
          size = 4,
          show.legend = FALSE
        )

      dat_arrow <- dat %>%
        dplyr::filter(id %in% datalabel_txt$mrkr_ann) %>%
        group_by(.data$id) %>%
        dplyr::filter(.data$x == last(.data$x))

      pl <- pl +
        geom_segment(
          data = dat_arrow,
          mapping = aes(x = .data$x, y = .data$y, xend = .data$x, yend = .data$y),
          arrow = arrow(length = grid::unit(0.15, "inches"), ends = "first", type = "closed"),
          linewidth = 0.4,
          color = "black",
          show.legend = FALSE
        )
    }
  }

  # vertical and horizontal reference lines
  if (!is.null(href_line)) {
    pl <- pl + geom_hline(yintercept = href_line, linetype = "dotted", color = "black")
  }

  if (!is.null(vref_line)) {
    for (i in seq_along(vref_line)) {
      pl <- pl +
        annotate("segment",
          x = vref_line[i],
          y = -Inf,
          xend = vref_line[i],
          yend = Inf,
          linetype = "dotted",
          color = "black"
        )
    }
  }

  # facets---------------
  if (is.null(facet_rows) && is.null(facet_columns)) {
    pl
  } else if (is.null(facet_rows) && !is.null(facet_columns)) {
    pl <- pl + facet_grid(. ~ f_columns)
  } else if (is.null(facet_columns) && !is.null(facet_rows)) {
    pl <- pl + facet_grid(f_rows ~ .)
  } else {
    pl <- pl + facet_grid(f_rows ~ f_columns)
  }

  # simple function to call a vector of color values
  call_color <- function(len) {
    dat_col <- data.frame(color_opt = grDevices::colors())
    dat_col <- dat_col %>%
      dplyr::filter(!grepl("white", .data$color_opt)) %>%
      droplevels()

    return(dat_col[1:len, 1])
  }

  # remove marker from color legend
  if (!is.null(line_colby)) {
    if (!is.null(line_color_opt)) {
      pl <- pl + scale_color_manual(
        name = "Color",
        breaks = dat$l_col,
        values = line_color_opt
      )
    }
  }

  if (!is.null(marker_shape) && is.null(marker_shape_opt)) {
    symbol_val <- c(15:18, 1:14)
    len <- length(unique(dat$sh))
    symbol_val <- rep(symbol_val, ceiling(len / 26))

    pl <- pl + scale_shape_manual(
      values = symbol_val[1:len]
    )
  }

  if (!is.null(marker_shape_opt)) {
    pl <- pl + scale_shape_manual(
      name = "Shape",
      breaks = dat$sh,
      values = marker_shape_opt
    )
  }

  # modify background color
  pl <- pl + annotate("segment", x = -Inf, xend = Inf, y = -Inf, yend = -Inf) +
    annotate("segment", x = -Inf, xend = -Inf, y = -Inf, yend = Inf) +
    theme_bw() +
    theme(
      strip.background = element_rect(linetype = "blank", fill = "white"),
      text = element_text(size = 16),
      axis.text = element_text(color = "black"),
      legend.text = element_text(size = 7),
      legend.title = element_text(size = 7)
    ) +
    labs(shape = "Shape", color = "Color") # +

  if (is.numeric(marker_x)) {
    pl <- pl + xlim(min(marker_x), max(marker_x) * 1.3)
  } else {
    pl <- pl +
      scale_x_discrete(expand = c(0.3, 0)) +
      theme(axis.text.x = element_text(angle = 90))
  }

  grid::grid.draw(pl)
  invisible(pl)
}

#' Hy's Law Plot
#'
#' A scatter plot typically used to display maximum total bilirubin values (`TBL`)
#' versus maximum alanine transaminase (`ALT`) values.
#'
#' @param id unique subject identifier.
#' @param term the term of the observation.
#' @param aval analysis value.
#' @param arm treatment arm. Used as fill color in the plot.
#' @param term_selected string vector of length 2 - the two terms selected to be
#'   used in the plot. First value corresponds to parameter plotted on the
#'   x-axis. Second value corresponds to that plotted on the y-axis.
#' @param anrhi the high limit of normal range.
#' @param folds numeric vector of length two. Indicates the position of the
#'   reference lines to be drawn. Default c(3, 2) corresponds to a line at
#'   position 3 on the x-axis and 2 on the y-axis.
#' @param text string vector of length four with the label to be shown on each
#'   quadrant. First value corresponds to label shown in the bottom left
#'   quadrant. Subsequent values move through the graph clockwise.
#' @param caption string of text for footnote. Details of methodology can be
#'   shown here.
#' @param title string of text for plot title.
#' @param xlab string of text for x axis label.
#' @param ylab string of text for y axis label.
#'
#' @details
#' This graphic is based upon the `eDISH` (evaluation of Drug Induced Serious
#' Hepatotoxicity) plot of Watkins et. al. in a 2008 publication from Hepatology.
#' Maximum values are defined as the maximum post-baseline value at any time
#' during the entire length of the observation period. Both axes are in log
#' scale to control for the dispersion of the data. The values are plotted in
#' 'times upper limit of normal' where a value of 1 would mean that the result
#' was normal. Any value above or below 1 would be considered above the upper
#' limit or normal or below the upper limit of normal respectively. For
#' instance, a value of 3 would be read as '3 times the upper limit of normal'.
#' Reference lines are included to determine various states, based upon clinical
#' interpretation of the values and includes the following:
#'
#' * Hyperbilirubinemia `TBL` at least 2 `xULN` and `ALT` less than 3 `xULN`
#' * Normal Range `TBL` <= 1 `xULN` and `ALT` <= 1 `xULN`
#' * Temple’s Corollary `TBL` <= 1 `xULN` and `ALT` at least 3 `xULN`
#' * Possible Hy's Law `TBL` at least 2 `xULN` and `ALT` at least 3 `xULN`
#'
#' This plot can easily be adjusted for other lab parameters and reference
#' ranges as needed. Consultation with a clinical expert to determine which
#' associations would be clinically meaningful and how to interpret those
#' associations is recommended.
#'
#' There is no equivalent STREAM output.
#'
#' @return plot object
#'
#' @export
#'
#' @template author_withycok
#' @template author_frankla4
#' @template author_holmesw
#'
#' @examplesIf require("nestcolor")
#' library(dplyr)
#' library(nestcolor)
#'
#' # Note: CRP is being used in place of Bilirubin here because this is the only available data
#' adsl <- osprey::rADSL
#' adlb <- osprey::rADLB %>% mutate(ANRHI = 50)
#'
#' # Example 1, - Hy's law template (3 and 2 X ULN)
#' g_hy_law(
#'   id = adlb$USUBJID,
#'   term = adlb$PARAMCD,
#'   aval = adlb$AVAL,
#'   arm = adlb$ARM,
#'   term_selected = c("ALT", "CRP"),
#'   anrhi = adlb$ANRHI,
#'   folds = c(3, 2),
#'   text = c("Normal Range", "Hyperbilirubinemia", "Possible Hy's Law Range", "Temple's Corollary"),
#'   caption = paste(
#'     "Maximum values are those maximum values that occur",
#'     "post-baseline (no time constraints and not necessarily concurrent events)."
#'   ),
#'   title = "Max. Total Bilirubin vs. Max. Alanine Aminotransferase",
#'   xlab = "Maximum Alanine Aminotransferase (/ULN)",
#'   ylab = "Maximum Total Bilirubin (/ULN)"
#' )
#'
#' # Example 2, - change the quadrant lines and labels
#' g_hy_law(
#'   id = adlb$USUBJID,
#'   term = adlb$PARAMCD,
#'   aval = adlb$AVAL,
#'   arm = adlb$ARM,
#'   term_selected = c("ALT", "CRP"),
#'   anrhi = adlb$ANRHI,
#'   folds = c(10, 15),
#'   text = c("Quadrant 1", "Quadrant 2", "Quadrant 3", "Quadrant 4"),
#'   caption = paste(
#'     "Maximum values are those maximum values that occur",
#'     "post-baseline (no time constraints and not necessarily concurrent events)."
#'   ),
#'   title = "Max. Total Bilirubin vs. Max. Alanine Aminotransferase",
#'   xlab = "Maximum Alanine Aminotransferase (/ULN)",
#'   ylab = "Maximum Total Bilirubin (/ULN)"
#' )
g_hy_law <- function(id,
                     term,
                     aval,
                     arm,
                     term_selected,
                     anrhi,
                     folds = c(3, 2),
                     text = c("Normal Range", "Hyperbilirubinemia", "Possible Hy's Law Range", "Temple's Corollary"),
                     caption = paste(
                       "Maximum values are those maximum values that occur post-baseline",
                       "(no time constraints and not necessarily concurrent events)."
                     ),
                     title = "Max. Total Bilirubin vs. Max. Alanine Aminotransferase",
                     xlab = "Maximum Alanine Aminotransferase (/ULN)",
                     ylab = "Maximum Total Bilirubin (/ULN)") {
  checkmate::assert_character(term_selected, len = 2, any.missing = FALSE)
  checkmate::assert_numeric(folds, len = 2, any.missing = FALSE)
  checkmate::assert_character(text, len = 4, any.missing = FALSE)
  checkmate::assert_string(title)
  checkmate::assert_string(caption)
  checkmate::assert_string(xlab)
  checkmate::assert_string(ylab)

  anl <- data.frame(id, term, aval, arm, anrhi)

  anl <- anl %>%
    dplyr::filter(term %in% term_selected) %>%
    dplyr::group_by(id, term) %>%
    dplyr::mutate(MAX = max(aval)) %>%
    dplyr::slice(1) %>%
    dplyr::mutate(ULN = .data$MAX / anrhi) %>%
    tidyr::pivot_wider(id_cols = c(id, arm), names_from = term, values_from = "ULN")

  p <- ggplot(data = anl) +
    scale_x_continuous(
      name = xlab,
      breaks = log10(c(seq(0.1, 1, 0.1), seq(2, 10, 1), seq(20, 100, 10))),
      limits = c(-1, 2),
      labels = c(0.1, rep(" ", 8), 1, rep(" ", 8), 10, rep(" ", 8), 100),
      expand = c(0.01, 0.01)
    ) +
    scale_y_continuous(
      name = ylab,
      breaks = log10(c(seq(0.1, 1, 0.1), seq(2, 10, 1), seq(20, 100, 10))),
      limits = c(-1, 2),
      labels = c(0.1, rep(" ", 8), 1, rep(" ", 8), 10, rep(" ", 8), 100),
      expand = c(0.01, 0.01)
    ) +
    labs(title = title, caption = caption) +
    theme_bw(base_size = 14) +
    theme(
      plot.title = element_text(hjust = 0.5),
      plot.title.position = "plot",
      plot.caption = element_text(hjust = 0),
      plot.caption.position = "plot",
      legend.title = element_blank(),
      panel.grid = element_blank()
    ) +
    geom_segment(
      aes(x = log10(folds[1]), y = log10(0), xend = log10(folds[1]), yend = log10(75)),
      linewidth = 0.25,
      color = "grey"
    ) +
    geom_segment(
      aes(x = log10(0), y = log10(folds[2]), xend = log10(65), yend = log10(folds[2])),
      linewidth = 0.25,
      color = "grey"
    ) +
    geom_segment(
      aes(x = log10(1), y = log10(0), xend = log10(1), yend = log10(1)),
      linewidth = 0.25,
      color = "black"
    ) +
    geom_segment(
      aes(x = log10(0), y = log10(1), xend = log10(1), yend = log10(1)),
      linewidth = 0.25,
      color = "black"
    ) +
    annotate("text", label = paste0(folds[1], "XULN"), x = log10(folds[1]), y = log10(90)) +
    annotate("text", label = paste0(folds[2], "XULN"), x = log10(85), y = log10(folds[2])) +
    annotate("text", label = text[1], x = log10(0.2), y = log10(0.12)) +
    annotate("text", label = text[2], x = log10(0.2), y = log10(80)) +
    annotate("text", label = text[3], x = log10(40), y = log10(80)) +
    annotate("text", label = text[4], x = log10(40), y = log10(0.12)) +
    geom_point(aes(
      x = log10(.data[[term_selected[1]]]),
      y = log10(.data[[term_selected[2]]]),
      shape = arm,
      color = arm
    )) +
    scale_shape_manual(values = c(1:n_distinct(arm)))

  g <- ggplotGrob(p)
  grid::grid.newpage()
  grid::grid.draw(g)
  invisible(g)
}

#' Simple spider plot
#'
#' Description of this plot
#'
#' @param anl The analysis data frame
#' @param byvar Analysis dataset
#' @param days Variable with time in days
#' @param mes_value Variable with measurement
#' @param group_col Variable to color the individual lines and id in plot
#' @param baseday Numeric Value, points with only smaller values will be cut out
#'
#'
#' @return `ggplot` object
#'
#' @export
#'
#' @author Mika Maekinen
#'
#' @examplesIf require("nestcolor")
#' library(dplyr)
#' library(nestcolor)
#'
#' ADSL <- osprey::rADSL[1:15, ]
#' ADTR <- osprey::rADTR
#' ANL <- left_join(ADSL, ADTR)
#'
#' ANL %>%
#'   dplyr::filter(ANL01FL == "Y" & PARAMCD == "SLDINV") %>%
#'   spiderplot_simple(group_col = "SEX", days = "ADY", mes_value = "AVAL")
spiderplot_simple <- function(anl,
                              byvar = "USUBJID",
                              days = "TRTDURD",
                              mes_value = "PARAM",
                              group_col = "USUBJID",
                              baseday = 0) {
  ### remove patients without post baseline measurement
  anl <- anl %>%
    group_by(!!byvar) %>%
    dplyr::mutate(morebase = ifelse(max(!!days, na.rm = TRUE) > baseday, TRUE, FALSE)) %>%
    dplyr::filter(.data$morebase == TRUE) %>%
    ungroup()
  ### find the last measurement
  last_obs <- anl %>%
    group_by(!!as.symbol(byvar)) %>%
    slice(which.max(!!as.symbol(days)))

  # plotr
  ggplot(
    data = anl,
    mapping = aes(x = !!days, y = !!mes_value, group = !!byvar, colour = !!group_col),
    size = 2,
    alpha = 1
  ) +
    geom_point(size = 3) +
    geom_line(linewidth = 2, alpha = 0.7) +
    geom_text(aes(x = !!days, y = !!mes_value, label = !!byvar), data = last_obs, hjust = 0) +
    geom_hline(aes(yintercept = 0), linetype = "dotted", color = "black") +
    xlab("Time (Days)") +
    ylab("Change(%) from Baseline")
}

1		#' Events by Term Plot
2		#'
3		#' This function plots commonly occurred events by number of unique subjects with events.
4		#' It creates basic summary of events and compares event occurrences between comparison
5		#' and reference arms, and can be used for events data such as Adverse Events.
6		#'
7		#' @inheritParams argument_convention
8		#' @param id (`vector`)\cr contains subject identifier. Length of \code{id} must be the
9		#' same as the length or number of rows of \code{terms}. Usually it is \code{ADAE$USUBJID}.
10		#' @param term \code{character} or \code{factor} vector, or \code{data.frame} \cr
11		#' Represents events information. \code{term} can be a \code{data.frame} produced
12		#' by \code{create_flag_vars}, with each column being a \code{logical} event indicator
13		#' @param arm_N (\code{numeric} vector)\cr
14		#' Contains information of the number of patients in the levels of \code{arm}. This is useful
15		#' if there are patients that have no adverse events can be accounted for with this argument.
16		#' @param ref \code{character} indicates the name of the reference arm. Default is the first
17		#' level of \code{arm}.
18		#' @param trt \code{character} indicates the name of the treatment arm. Default is the second
19		#' level of \code{arm}.
20		#' @param sort_by \code{character} indicates how each \code{term} is sorted in the plot.
21		#' Choose from `"term"` for alphabetic terms, `"riskdiff"` for risk difference, and `"meanrisk"`
22		#' for mean risk. Default is "term".
23		#' @param rate_range Numeric \code{vector} of length 2. Range for overall rate display
24		#' @param diff_range Numeric \code{vector} of length 2. Range for rate difference display
25		#' @param reversed \code{logical} whether to reverse the sorting by \code{sort_by}.
26		#' Default is FALSE.
27		#' @param axis_side \code{character} the side of the axis label, "left" or "right". Default is "left".
28		#' @param color Color for the plot. \code{vector} of length 2. Color for reference and
29		#' treatment arms respectively. Default set to \code{c("blue", "red")}.
30		#' @param shape Shape for the plot. \code{vector} of length 2. Shape for reference and
31		#' treatment arms respectively. Default set to \code{c(16, 17)} per
32		#' \code{\link[ggplot2]{scale_shape}}.
33		#' @details there is no equivalent STREAM output
34		#'
35		#' @return grob object
36		#'
37		#' @export
38		#'
39		#' @author Liming Li (Lil128) \email{liming.li@roche.com}
40		#' @author Molly He (hey59) \email{hey59@gene.com}
41		#'
42		#' @examplesIf require("nestcolor")
43		#' library(dplyr)
44		#' library(grid)
45		#' library(nestcolor)
46		#'
47		#' ADSL <- osprey::rADSL
48		#' ADAE <- osprey::rADAE
49		#'
50		#' # add additional dummy causality flags
51		#' ADAE <- ADAE %>%
52		#' mutate(AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X")) %>%
53		#' mutate(AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo"))
54		#' attr(ADAE[["AEREL1"]], "label") <- "AE related to A: Drug X"
55		#' attr(ADAE[["AEREL2"]], "label") <- "AE related to B: Placebo"
56		#'
57		#' term <- ADAE$AEDECOD
58		#' id <- ADAE$USUBJID
59		#' arm <- ADAE$ACTARMCD
60		#' arm_N <- table(ADSL$ACTARMCD)
61		#' ref <- "ARM A"
62		#' trt <- "ARM C"
63		#'
64		#' # Example 1
65		#' p1 <- g_events_term_id(
66		#' term,
67		#' id,
68		#' arm,
69		#' arm_N
70		#' )
71		#' grid::grid.newpage()
72		#' grid::grid.draw(p1)
73		#'
74		#' # Example 2
75		#' p2 <- g_events_term_id(
76		#' term,
77		#' id,
78		#' arm,
79		#' arm_N,
80		#' trt = trt,
81		#' ref = ref,
82		#' sort_by = "riskdiff",
83		#' diff_ci_method = "ac",
84		#' conf_level = 0.9
85		#' )
86		#' grid::grid.newpage()
87		#' grid::grid.draw(p2)
88		#'
89		#' # Example 3
90		#' p3 <- g_events_term_id(
91		#' term,
92		#' id,
93		#' arm,
94		#' arm_N,
95		#' sort_by = "meanrisk",
96		#' axis_side = "right",
97		#' fontsize = 5
98		#' )
99		#' grid::grid.newpage()
100		#' grid::grid.draw(p3)
101		#'
102		#' # Example 4
103		#' term <- create_flag_vars(ADAE)
104		#' g_events_term_id(
105		#' term,
106		#' id,
107		#' arm,
108		#' arm_N,
109		#' fontsize = 3
110		#' )
111		g_events_term_id <- function(term,
112		id,
113		arm,
114		arm_N, # nolint
115		ref = levels(arm)[1],
116		trt = levels(arm)[2],
117		sort_by = c("term", "riskdiff", "meanrisk"),
118		rate_range = c(0, 1),
119		diff_range = c(-1, 1),
120		reversed = FALSE,
121		conf_level = 0.95,
122		diff_ci_method =
123		c("wald", "waldcc", "ac", "score", "scorecc", "mn", "mee", "blj", "ha", "beal"),
124		axis_side = c("left", "right"),
125		color = c(getOption("ggplot2.discrete.colour"), "blue", "red")[1:2],
126		shape = c(16, 17),
127		fontsize = 4,
128		draw = TRUE) {
129	!	if (is.data.frame(term)) {
130	!	term_levels <- factor(colnames(term), levels = rev(colnames(term)))
131	!	term <- data.frame(t(term))
132	!	term <- lapply(term, function(x) {
133	!	term_levels[x]
134		})
135	!	df <- tibble::tibble(id, arm, term) %>%
136	!	tidyr::unnest(term)
137		} else {
138	!	term_levels <- `if`(is.factor(term), levels(term), unique(term))
139	!	df <- tibble::tibble(id, arm, term)
140		}
141
142		# argument validation
143	!	sort_by <- match.arg(sort_by)
144	!	diff_ci_method <- match.arg(diff_ci_method)
145	!	axis_side <- match.arg(axis_side)
146
147	!	checkmate::assert_factor(arm, min.levels = 2)
148	!	stopifnot(
149	!	"invalid arguments: check that the length of id, term and arm are identical" =
150	!	length(id) == length(term) && length(term) == length(arm)
151		)
152	!	stopifnot("invalid arguments: trt and ref need to be from arm" = all(c(trt, ref) %in% unique(arm)))
153	!	checkmate::assert_numeric(rate_range, len = 2, any.missing = FALSE)
154	!	checkmate::assert_numeric(diff_range, len = 2, any.missing = FALSE)
155	!	checkmate::assert_flag(reversed)
156	!	checkmate::assert_number(conf_level, lower = 0.5, upper = 1)
157	!	checkmate::assert_character(color, len = 2, any.missing = FALSE)
158	!	checkmate::assert_numeric(shape, len = 2, any.missing = FALSE)
159	!	checkmate::assert_numeric(fontsize, lower = 0, any.missing = FALSE)
160
161		# construct calculations
162	!	arms <- c(ref, trt)
163	!	df_n <- data.frame(arm_N)
164	!	names(df_n) <- c("arm", "total")
165	!	df_n <- df_n[df_n$arm %in% arms, ]
166	!	ref_total <- df_n %>%
167	!	filter(arm == ref) %>%
168	!	select("total") %>%
169	!	pull()
170	!	trt_total <- df_n %>%
171	!	filter(arm == trt) %>%
172	!	select("total") %>%
173	!	pull()
174
175		# create full cartesian of (arms) X (term levels) with 0 count to have full list of all possible combination
176		# this is done in order to secure further calls
177	!	df_full <- cbind(expand.grid(arm = arms, term = term_levels), N = 0)
178
179	!	df_reshaped <- df %>%
180	!	distinct() %>%
181	!	filter(arm %in% arms) %>%
182	!	group_by(arm, term) %>%
183	!	summarise(N = n()) %>%
184	!	ungroup() %>%
185	!	rbind(df_full) %>%
186	!	group_by(arm, term) %>%
187	!	summarise(N = sum(.data$N)) %>%
188	!	mutate(arm = ifelse(arm == trt, "trt_count", "ref_count")) %>%
189	!	tidyr::pivot_wider(names_from = arm, values_from = "N", values_fill = list(N = 0))
190
191	!	df_ci <- df_reshaped %>%
192	!	group_by(term) %>%
193	!	do(
194	!	data.frame(
195	!	t(c(
196	!	DescTools::BinomDiffCI(
197	!	.data$trt_count,
198	!	trt_total,
199	!	.data$ref_count,
200	!	ref_total,
201	!	conf_level,
202	!	method = diff_ci_method
203	!	)[1, ], # wald
204	!	meanrisk = (.data$trt_count + .data$ref_count) / (trt_total + ref_total)
205		))
206		)
207		) %>%
208	!	ungroup() %>%
209	!	rename(riskdiff = "est", lower_ci = "lwr.ci", upper_ci = "upr.ci")
210
211	!	df_risk <- df_reshaped %>%
212	!	group_by(term) %>%
213	!	do(
214	!	data.frame(
215	!	risk = c(.data$trt_count / trt_total, .data$ref_count / ref_total),
216	!	arm = c(trt, ref)
217		)
218		) %>%
219	!	ungroup()
220
221	!	names(color) <- arms
222	!	names(shape) <- arms
223
224		# if diff_range specified, limit terms
225	!	terms_needed <- df_ci %>%
226	!	filter(
227	!	.data$riskdiff > diff_range[1] &
228	!	.data$riskdiff < diff_range[2] &
229	!	.data$meanrisk > rate_range[1] &
230	!	.data$meanrisk < rate_range[2]
231		) %>%
232	!	select(term) %>%
233	!	distinct() %>%
234	!	pull() %>%
235	!	as.character()
236
237	!	if (length(terms_needed) == 0) {
238	!	ret <- grid::textGrob("All Observations are filtered out")
239	!	if (draw) {
240	!	grid::grid.draw(ret)
241		}
242	!	return(invisible(ret))
243		}
244
245		# sorting
246	!	if (sort_by == "term") {
247	!	terms_needed <- sort(terms_needed, decreasing = TRUE)
248		} else {
249	!	terms_needed <- df_ci %>%
250	!	arrange(.data[[sort_by]]) %>%
251	!	filter(term %in% terms_needed) %>%
252	!	select(term) %>%
253	!	pull()
254		}
255
256	!	if (reversed) {
257	!	terms_needed <- rev(terms_needed)
258		}
259
260	!	df_ci <- df_ci %>%
261	!	filter(term %in% terms_needed) %>%
262	!	mutate(term = factor(term, terms_needed))
263	!	df_risk <- df_risk %>%
264	!	filter(term %in% terms_needed) %>%
265	!	mutate(term = factor(term, terms_needed))
266	!	terms_label <- vapply(
267	!	lapply(terms_needed, strwrap, width = 30),
268	!	paste,
269	!	FUN.VALUE = character(1),
270	!	collapse = "\n"
271		)
272
273	!	mytheme <- theme_osprey(axis_side = axis_side, fontsize = fontsize)
274
275	!	labels <- stats::setNames(sprintf("%s\n(N = %i)", df_n$arm, df_n$total), df_n$arm)
276
277	!	y_axis <- scale_y_discrete(
278	!	limits = terms_needed,
279	!	breaks = terms_needed,
280	!	labels = terms_label,
281	!	position = axis_side
282		)
283
284	!	p1 <- ggplot(df_risk) +
285	!	geom_point(
286	!	aes(
287	!	y = term,
288	!	x = .data$risk,
289	!	group = arm,
290	!	color = arm,
291	!	shape = arm
292		),
293	!	size = fontsize * 0.7
294		) +
295	!	mytheme +
296	!	ggtitle("Proportion") +
297	!	scale_color_manual(values = color, labels = labels) +
298	!	scale_shape_manual(values = shape, labels = labels) +
299	!	y_axis
300
301	!	p2 <- ggplot(df_ci) +
302	!	geom_point(mapping = aes(y = term, x = .data$riskdiff), size = fontsize * 0.7) +
303	!	geom_vline(data = NULL, xintercept = 0, linetype = 2) +
304	!	mytheme +
305	!	geom_errorbarh(mapping = aes(xmax = .data$upper_ci, xmin = .data$lower_ci, y = term), height = 0.4) +
306	!	y_axis +
307	!	ggtitle("Risk Difference")
308
309	!	axis_name <- sprintf("axis-%s", substr(axis_side, 1, 1))
310
311	!	p1_parts <- ggplotGrob(p1)
312	!	p2_parts <- ggplotGrob(p2)
313
314	!	mylegend <- grob_part(grob_part(p1_parts, "guide-box-bottom"), "guides")
315	!	axis <- grob_part(p1_parts, axis_name)
316
317	!	less_risk <- grid::textGrob(
318	!	"Favor\nTreatment",
319	!	just = "left",
320	!	x = grid::unit(fontsize * .pt, "pt"),
321	!	gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold")
322		)
323	!	more_risk <- grid::textGrob(
324	!	"Favor\nControl",
325	!	just = "right",
326	!	x = grid::unit(1, "npc") - grid::unit(fontsize * .pt, "pt"),
327	!	gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold")
328		)
329
330	!	risk_label <- gridExtra::arrangeGrob(less_risk, more_risk, nrow = 1)
331	!	title1 <- grob_part(p1_parts, "title")
332	!	title2 <- grob_part(p2_parts, "title")
333	!	panel1 <- grob_part(p1_parts, "panel")
334	!	panel2 <- grob_part(p2_parts, "panel")
335	!	axis_b1 <- grob_part(p1_parts, "axis-b")
336	!	axis_b2 <- grob_part(p2_parts, "axis-b")
337
338	!	grobs <- list(
339	!	title1,
340	!	title2,
341	!	axis,
342	!	panel1,
343	!	panel2,
344	!	axis_b1,
345	!	axis_b2,
346	!	mylegend,
347	!	risk_label
348		)
349
350	!	if (axis_side == "left") {
351	!	layout_matrix <- rbind(
352	!	c(NA, 1, NA, 2),
353	!	c(3, 4, NA, 5),
354	!	c(NA, 6, NA, 7),
355	!	c(8, 8, NA, 9)
356		)
357	!	widths <- grid::unit.c(grid::grobWidth(axis), grid::unit(c(1, 2 * fontsize, 1), c("null", "pt", "null")))
358		} else {
359	!	layout_matrix <- rbind(
360	!	c(1, NA, 2, NA),
361	!	c(4, NA, 5, 3),
362	!	c(6, NA, 7, NA),
363	!	c(8, NA, 9, NA)
364		)
365	!	widths <- grid::unit.c(grid::unit(c(1, 10, 1), c("null", "pt", "null")), grid::grobWidth(axis))
366		}
367
368	!	heights <- grid::unit.c(
369	!	grid::grobHeight(title1),
370	!	grid::unit(1, "null"),
371	!	grid::grobHeight(axis_b1),
372	!	max(grid::grobHeight(mylegend), grid::grobHeight(more_risk))
373		)
374
375	!	ret <- gridExtra::arrangeGrob(
376	!	grobs = grobs,
377	!	nrow = 4,
378	!	ncol = 4,
379	!	layout_matrix = layout_matrix,
380	!	heights = heights,
381	!	widths = widths
382		)
383
384	!	ret <- grob_add_padding(ret)
385
386	!	if (draw) {
387	!	grid::grid.draw(ret)
388		}
389	!	invisible(ret)
390		}
391
392
393		#' create `AE` overview flags
394		#' @param df data frame of `AE`
395		#' @param fatal `AE` with fatal outcome derivation
396		#' @param serious Serious `AE` derivation.
397		#' @param serious_withdrawl Serious `AE` leading to withdrawal derivation
398		#' @param serious_modified Serious `AE` leading to dose modification derivation
399		#' @param serious_related Related Serious `AE` derivation
400		#' @param withdrawl `AE` leading to withdrawal derivation
401		#' @param modified `AE` leading to dose modification derivation
402		#' @param related Related `AE` derivation
403		#' @param related_withdrawl Related `AE` leading to withdrawal derivation
404		#' @param related_modified Related `AE` leading to dose modification derivation
405		#' @param ctc35 Grade 3-5 `AE` derivation
406		#' @param ... named expressions used to generate categories
407		#' @details in this function, all flags are expressions calls, for simpler usage.
408		#' @export
409		#' @examples
410		#' library(dplyr)
411		#'
412		#' ADAE <- osprey::rADAE
413		#'
414		#' # add additional dummy causality flags
415		#' ADAE <- ADAE %>%
416		#' mutate(AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X")) %>%
417		#' mutate(AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo"))
418		#' attr(ADAE[["AEREL1"]], "label") <- "AE related to A: Drug X"
419		#' attr(ADAE[["AEREL2"]], "label") <- "AE related to B: Placebo"
420		#'
421		#' create_flag_vars(ADAE)
422		#' # create other flags
423		#' create_flag_vars(ADAE, `AENSER` = AESER != "Y")
424		#' # remove flags that are not needed
425		#' create_flag_vars(ADAE, fatal = NULL)
426		create_flag_vars <- function(df,
427		# nolint start
428		fatal = AESDTH == "Y",
429		serious = AESER == "Y",
430		serious_withdrawl = AESER == "Y" &
431		grepl("DRUG WITHDRAWN", AEACN),
432		serious_modified = AESER == "Y" &
433		grepl("DRUG (INTERRUPTED\|INCREASED\|REDUCED)", AEACN),
434		serious_related = AESER == "Y" & AEREL == "Y",
435		withdrawl = grepl("DRUG WITHDRAWN", AEACN),
436		modified = grepl("DRUG (INTERRUPTED\|INCREASED\|REDUCED)", AEACN),
437		related = AEREL == "Y",
438		related_withdrawl = AEREL == "Y" & grepl("DRUG WITHDRAWN", AEACN),
439		related_modified = AEREL == "Y" &
440		grepl("DRUG (INTERRUPTED\|INCREASED\|REDUCED)", AEACN),
441		ctc35 = AETOXGR %in% c("3", "4", "5"),
442		# nolint end
443		...) {
444	!	AESDTH <- AESER <- AEACN <- AEREL <- AETOXGR <- NULL # nolint
445	!	args <-
446	!	eval(substitute(
447	!	alist(
448	!	"AE with fatal outcome" = fatal,
449	!	"Serious AE" = serious,
450	!	"Serious AE leading to withdrawal" = serious_withdrawl,
451	!	"Serious AE leading to dose modification" = serious_modified,
452	!	"Related Serious AE" = serious_related,
453	!	"AE leading to withdrawal" = withdrawl,
454	!	"AE leading to dose modification" = modified,
455	!	"Related AE" = related,
456	!	"Related AE leading to withdrawal" = related_withdrawl,
457	!	"Related AE leading to dose modification" = related_modified,
458	!	"Grade 3-5 AE" = ctc35
459		)
460		))
461	!	args <- c(args, eval(substitute(alist(...))))
462	!	stopifnot(all(names(args) != "")) # all elements in ... should be named
463	!	argnames <- unique(names(args))
464	!	df <- as.data.frame(df)
465	!	ret <- lapply(argnames, function(t) {
466	!	tryCatch(
467	!	expr = {
468	!	with(df, eval(args[[t]]))
469		},
470	!	error = function(w) {
471	!	NULL
472		},
473	!	warning = function(w) {
474	!	NULL
475		}
476		)
477		})
478	!	names(ret) <- argnames
479	!	valid <- vapply(argnames, function(x) {
480	!	valid <- length(ret[[x]]) > 0
481	!	if (!valid) {
482	!	warning(sprintf(
483	!	"%s with calculation %s not valid",
484	!	x,
485	!	as.character(as.expression(args[[x]]))
486		))
487		}
488	!	valid
489	!	}, FUN.VALUE = TRUE)
490	!	do.call(data.frame, args = list(ret[valid], check.names = FALSE))
491		}

1		#' Butterfly Plot
2		#'
3		#' The butterfly plot is often used in Early Development (ED) and is an opposed
4		#' barplot that shows instances of `AE`s or # of patients by category separated by
5		#' a dichotomization variable. Each bar can be color coded according
6		#' to a variable of choice and sorted according to either alphabetical order or the
7		#' maximum count.
8		#'
9		#' @param category vector of y values
10		#' @param right_flag vector of \code{logical} of the same length as \code{category}.
11		#' used to filter \code{category} for the right side of the barplot.
12		#' to maintain backward compatibility, a vector of 1s and 0s would also work.
13		#' @param left_flag vector of \code{logical} of the same length as \code{category}.
14		#' used to filter \code{category} for the left side of the barplot.
15		#' to maintain backward compatibility, a vector of 1s and 0s would also work.
16		#' @param group_names string vector of length 2 with desired names of dichotomization variables
17		#' required format : first name corresponds to the name of the right side
18		#' second name corresponds to name of the left side
19		#' default: will extract column names from group
20		#' @param block_count string - what to count by (ex: # of `AE`s or # of patients)
21		#' @param block_color vector - color coding of bar segments
22		#' @param id unique subject identifier variable.
23		#' @param facet_rows vector defines what variable is used to split the
24		#' plot into rows, default here is NULL
25		#' @param x_label string of text for x axis label, default is block_count
26		#' @param y_label string of text for y axis label, default is `AE` Derived Terms
27		#' @param legend_label \code{character} for legend label, default is `"AETOXGR"`
28		#' @param sort_by character string that defines the ordering of the class and term
29		#' variables in the output table,
30		#' options: `"alphabetical"`, `"count"`, `"left"`, `"right"`, default here is set to `"count"`
31		#' @param show_legend `logical(1)` of whether color coding legend is included,
32		#' default here is FALSE
33		#'
34		#' @details there is no equivalent STREAM output
35		#'
36		#' @return `ggplot` object
37		#'
38		#' @export
39		#'
40		#' @template author_zhanc107
41		#' @template author_qit3
42		#'
43		#' @examplesIf require("nestcolor")
44		#' library(dplyr)
45		#' library(nestcolor)
46		#'
47		#' ADSL <- osprey::rADSL %>%
48		#' select(USUBJID, STUDYID, SEX, ARM, RACE) %>%
49		#' dplyr::filter(SEX %in% c("F", "M"))
50		#' ADAE <- osprey::rADAE %>% select(USUBJID, STUDYID, AEBODSYS, AETOXGR)
51		#'
52		#' ANL <- left_join(ADAE, ADSL, by = c("STUDYID", "USUBJID"))
53		#' ANL <- ANL %>%
54		#' dplyr::mutate(flag1 = ifelse(RACE == "ASIAN", 1, 0)) %>%
55		#' dplyr::mutate(flag2 = ifelse(SEX == "M", 1, 0))
56		#' ANL <- na.omit(ANL)
57		#' # Example 1, # of AEs
58		#' g_butterfly(
59		#' category = ANL$AEBODSYS,
60		#' right_flag = ANL$flag1,
61		#' left_flag = ANL$flag2,
62		#' group_names = c("flag1 Asian", "flag2 M"),
63		#' block_count = "# of AEs",
64		#' block_color = ANL$AETOXGR,
65		#' id = ANL$USUBJID,
66		#' x_label = "# of AEs",
67		#' y_label = "AE Body System",
68		#' legend_label = "AETOXGR",
69		#' sort_by = "count",
70		#' show_legend = TRUE
71		#' )
72		#'
73		#' # Example 2, # of patients with facet
74		#' g_butterfly(
75		#' category = ANL$AEBODSYS,
76		#' right_flag = ANL$flag1,
77		#' left_flag = ANL$flag2,
78		#' group_names = c("flag1 Asian", "flag2 M"),
79		#' block_count = "# of patients",
80		#' block_color = ANL$AETOXGR,
81		#' facet_rows = ANL$ARM,
82		#' id = ANL$USUBJID,
83		#' x_label = "# of patients",
84		#' y_label = "AE Derived Terms",
85		#' legend_label = "AETOXGR",
86		#' sort_by = "count",
87		#' show_legend = TRUE
88		#' )
89		g_butterfly <- function(category,
90		right_flag,
91		left_flag,
92		id = NULL,
93		group_names = NULL,
94		block_count = c("# of patients", "# of AEs"),
95		block_color = NULL,
96		facet_rows = NULL,
97		x_label = block_count,
98		y_label = "AE Derived Terms",
99		legend_label = "AETOXGR",
100		sort_by = c("count", "alphabetical", "right", "left"),
101		show_legend = TRUE) {
102	!	stopifnot(
103	!	"invalid arguments: check that the length of input arguments are identical" =
104	!	length(category) == length(right_flag) && length(right_flag) == length(left_flag)
105		)
106	!	stopifnot(
107	!	"invalid arguments: right_flag or left_flag contains values other than 1/TRUE or 0/FALSE" =
108	!	all(union(right_flag, left_flag) %in% c(1, 0))
109		)
110	!	stopifnot(
111	!	"invalid arguments: right_flag and left_flag contain only 0/FALSE values" =
112	!	any(union(right_flag, left_flag) == 1)
113		)
114	!	stopifnot(
115	!	"invalid arguments: check that the length of block_color is equal as other inputs" =
116	!	is.null(block_color) \|\| length(block_color) == length(category)
117		)
118	!	block_count <- match.arg(block_count)
119	!	checkmate::assert_character(id, null.ok = isFALSE(block_count == "# of patients"))
120
121	!	stopifnot(
122	!	"invalid arguments: check that the length of block_color is equal as other inputs" =
123	!	is.null(id) \|\| length(id) == length(category)
124		)
125	!	stopifnot(
126	!	"invalid arguments: check that the length of block_color is equal as other inputs" =
127	!	is.null(facet_rows) \|\|
128	!	(length(facet_rows) == length(category)) \|\| # nolint: indentation_linter.
129	!	(is.data.frame(facet_rows) && nrow(facet_rows) == length(category))
130		)
131	!	checkmate::assert_string(x_label)
132	!	checkmate::assert_string(y_label)
133	!	checkmate::assert_string(legend_label)
134	!	sort_by <- match.arg(sort_by)
135
136		# set up data-------
137	!	dat <- data.frame(y = stringr::str_wrap(category, width = 30), r_flag = right_flag, l_flag = left_flag)
138
139	!	groups <- "y"
140
141	!	if (!is.null(id)) {
142	!	dat$id <- id
143		}
144	!	if (!is.null(facet_rows)) {
145	!	facet_rows <- interaction(facet_rows)
146	!	dat$f_rows <- facet_rows
147	!	groups <- c(groups, "f_rows")
148		}
149	!	if (!is.null(block_color)) {
150	!	dat$bar_color <- block_color
151	!	groups <- c(groups, "bar_color")
152		}
153
154	!	get_counts <- function(.data, block_count) {
155	!	if (block_count == "# of patients") {
156	!	length(unique(.data$id))
157	!	} else if (block_count == "# of AEs") {
158	!	n()
159		}
160		}
161	!	highest_grade <- function(.data, block_count) {
162	!	if (block_count == "# of patients" && "bar_color" %in% colnames(.data)) {
163	!	.data %>%
164	!	dplyr::group_by(.data$y, .data$id) %>%
165	!	dplyr::filter(.data$bar_color == sort(.data$bar_color, decreasing = TRUE)[1])
166		} else {
167	!	.data
168		}
169		}
170
171	!	counts_r <- dat %>%
172	!	dplyr::filter(.data$r_flag == 1) %>%
173	!	highest_grade(block_count) %>%
174	!	dplyr::group_by_at(groups) %>%
175	!	dplyr::summarize(n_i = get_counts(.data, block_count)) %>%
176	!	dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
177	!	dplyr::mutate(label_ypos = rev(cumsum(rev(.data$n_i))))
178
179	!	counts_l <- dat %>%
180	!	filter(.data$l_flag == 1) %>%
181	!	highest_grade(block_count) %>%
182	!	dplyr::group_by_at(groups) %>%
183	!	dplyr::summarize(n_i = get_counts(.data, block_count)) %>%
184	!	dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
185	!	dplyr::mutate(label_ypos = rev(cumsum(rev(.data$n_i))))
186
187	!	total_label_pos_r <- counts_r %>%
188	!	dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
189	!	dplyr::summarize(label_ypos = max(.data$label_ypos))
190
191	!	total_label_pos_l <- counts_l %>%
192	!	dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
193	!	dplyr::summarize(label_ypos = max(.data$label_ypos))
194
195	!	total_text_ann_r <- dat %>%
196	!	dplyr::filter(.data$r_flag == 1) %>%
197	!	dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
198	!	dplyr::summarize(n = get_counts(.data, block_count)) %>%
199	!	dplyr::left_join(total_label_pos_r, by = setdiff(groups, "bar_color"))
200
201	!	total_text_ann_l <- dat %>%
202	!	dplyr::filter(.data$l_flag == 1) %>%
203	!	dplyr::group_by_at(setdiff(groups, "bar_color")) %>%
204	!	dplyr::summarize(n = get_counts(.data, block_count)) %>%
205	!	dplyr::left_join(total_label_pos_l, by = setdiff(groups, "bar_color"))
206
207
208	!	if (sort_by == "alphabetical") {
209	!	levels_all <- unique(sort(as.character(union(counts_l$y, counts_r$y)), decreasing = TRUE))
210	!	counts_r$y <- factor(counts_r$y, levels = levels_all)
211	!	counts_l$y <- factor(counts_l$y, levels = levels_all)
212	!	} else if (sort_by == "count") {
213	!	tot <- dplyr::bind_rows(total_text_ann_r, total_text_ann_l) %>%
214	!	dplyr::group_by(.data$y) %>%
215	!	dplyr::summarize(n = sum(n)) %>%
216	!	dplyr::arrange(n)
217
218	!	counts_r$y <- factor(counts_r$y, levels = tot$y)
219	!	counts_l$y <- factor(counts_l$y, levels = tot$y)
220	!	} else if (sort_by == "right") {
221	!	tot <- dplyr::full_join(total_text_ann_r, select(total_text_ann_l, -n), by = "y") %>%
222	!	dplyr::group_by(.data$y) %>%
223	!	dplyr::summarize(n = sum(n, na.rm = TRUE)) %>%
224	!	dplyr::arrange(n)
225
226	!	counts_r$y <- factor(counts_r$y, levels = tot$y)
227	!	counts_l$y <- factor(counts_l$y, levels = tot$y)
228	!	} else if (sort_by == "left") {
229	!	tot <- dplyr::full_join(total_text_ann_l, select(total_text_ann_r, -n), by = "y") %>%
230	!	dplyr::group_by(.data$y) %>%
231	!	dplyr::summarize(n = sum(n, na.rm = TRUE)) %>%
232	!	dplyr::arrange(n)
233
234	!	counts_r$y <- factor(counts_r$y, levels = tot$y)
235	!	counts_l$y <- factor(counts_l$y, levels = tot$y)
236		}
237
238	!	max_c <- max(c(total_text_ann_r$label_ypos, total_text_ann_l$label_ypos))
239
240	!	if (is.null(group_names)) {
241	!	g_r <- ""
242	!	g_l <- ""
243		} else {
244	!	g_r <- group_names[1]
245	!	g_l <- group_names[2]
246		}
247
248		# plot butterfly plot --------------------
249	!	if (!is.null(block_color)) {
250	!	pl <- ggplot(NULL, aes(x = .data$y)) +
251	!	geom_bar(data = counts_r, aes(y = .data$n_i, fill = .data$bar_color), stat = "identity") +
252	!	geom_bar(data = counts_l, aes(y = -.data$n_i, fill = .data$bar_color), stat = "identity") +
253	!	geom_text(data = counts_r, aes(y = .data$label_ypos, label = .data$n_i), hjust = 0.9) +
254	!	geom_text(data = counts_l, aes(y = -.data$label_ypos, label = .data$n_i), hjust = -0.9) +
255	!	geom_text(data = total_text_ann_r, aes(y = .data$label_ypos, label = .data$n), fontface = "bold", hjust = -1) +
256	!	geom_text(
257	!	data = total_text_ann_l, aes(y = -.data$label_ypos - 0.4, label = "n"),
258	!	fontface = "bold", hjust = 0.9
259		) +
260	!	geom_hline(yintercept = 0, colour = "black", lwd = 0.4) +
261	!	coord_flip() +
262	!	scale_y_continuous(labels = abs, limits = (max_c * 1.2) * c(-1, 1)) +
263	!	labs(x = y_label, y = block_count, fill = legend_label)
264		} else {
265	!	pl <- ggplot(NULL, aes(x = .data$y)) +
266	!	geom_bar(data = counts_r, aes(y = .data$n_i), stat = "identity") +
267	!	geom_bar(data = counts_l, aes(y = -.data$n_i), stat = "identity") +
268	!	geom_hline(yintercept = 0, colour = "black", lwd = 0.4) +
269	!	geom_text(data = total_text_ann_r, aes(y = .data$label_ypos, label = "n"), fontface = "bold", hjust = -1) +
270	!	geom_text(
271	!	data = total_text_ann_l, aes(y = -.data$label_ypos - 0.4, label = "n"),
272	!	fontface = "bold", hjust = 0.9
273		) +
274	!	coord_flip() +
275	!	scale_y_continuous(labels = abs, limits = (max_c * 1.2) * c(-1, 1)) +
276	!	labs(x = y_label, y = block_count, fill = legend_label)
277		}
278
279	!	if (!is.null(facet_rows)) {
280	!	pl <- pl + facet_wrap(~f_rows, ncol = 1)
281		}
282
283	!	pl <- pl +
284	!	theme_bw() +
285	!	theme(
286	!	strip.background = element_rect(colour = "white", fill = "white"),
287	!	strip.text.x = element_text(color = "black", size = 14),
288	!	title = element_text(size = 9),
289	!	axis.title = element_text(size = 20),
290	!	axis.text = element_text(color = "black", size = 9),
291	!	legend.text = element_text(size = 9),
292	!	legend.title = element_text(size = 9),
293	!	panel.grid.major.y = element_line(colour = "gray", linetype = "dotted"),
294	!	plot.margin = grid::unit(c(1.5, 1, 1, 1), "cm"),
295	!	legend.position = if (show_legend) "right" else "none"
296		) +
297	!	scale_x_discrete(limits = levels(counts_r$y))
298
299		# labs pl <- pl + labs(title = stringr::str_wrap(g2, width = 30))
300	!	g_0 <- ggplotGrob(pl)
301
302	!	g_1 <- gtable::gtable_add_grob(
303	!	g_0,
304	!	grid::grid.text(
305	!	stringr::str_wrap(g_r, width = 30),
306	!	x = 1, just = "center", hjust = 1, gp = grid::gpar(fontsize = 11)
307		),
308	!	t = 1.5, l = g_0$layout[grep("axis-r", g_0$layout$name)[1], 2], b = 3, name = "right-title", clip = "off"
309		)
310	!	g_2 <- gtable::gtable_add_grob(
311	!	g_1,
312	!	grid::grid.text(
313	!	stringr::str_wrap(g_l, width = 30),
314	!	x = 1, just = "center", hjust = 0, gp = grid::gpar(fontsize = 11)
315		),
316	!	t = 1.5, l = g_0$layout[grep("axis-l", g_0$layout$name)[1], 2], b = 3, name = "left-title", clip = "off"
317		)
318	!	grid::grid.draw(g_2)
319	!	invisible(g_2)
320		}

1		#' Adverse Event Category Plot
2		#'
3		#' Draw adverse event category plot.
4		#' @inheritParams argument_convention
5		#' @param id (`vector`)\cr contains subject identifier. Usually it is \code{ADAE$USUBJID}.
6		#' @param arm_sl (`vector`)\cr contains the subject level treatment variable.
7		#' For example, \code{ADSL$ACTARM}.
8		#' @param subgroups (`data.frame`)\cr Variables to conduct analysis.
9		#' @param subgroups_sl (`data.frame`)\cr Subject level variables to conduct analysis.
10		#' Usually from `ADSL`.
11		#' @param ref (`character`)\cr indicates the name of the reference arm. Default is the first
12		#' level of \code{arm}.
13		#' @param trt (`character`)\cr indicates the name of the treatment arm. Default is the second
14		#' level of \code{arm}.
15		#' @param indent (`numeric`)\cr non-negative integer where 0 means that the subgroup levels should not be indented
16		#' @param subgroups_levels (`list`)\cr A nested named list of variables to conduct analysis.
17		#' The names of the nested lists are used to show as the label.
18		#' The children lists should start with "Total" = variable label,
19		#' followed by labels for each level of said variable. See example for reference.
20		#' @param xmax (`numeric`)\cr maximum range for the x-axis.
21		#' x-axis range will be automatically assigned based on risk output when `xmax` is less than or equal to 0.
22		#' `xmax` is 0 by default
23		#' @param arm_n (`logical`)\cr whether to display the N in each arm.
24		#'
25		#' @author Liming Li (Lil128) \email{liming.li@roche.com}
26		#'
27		#' @details there is no equivalent STREAM output
28		#'
29		#' @return grob object
30		#'
31		#' @export
32		#'
33		#' @examples
34		#' library(grid)
35		#' ADAE <- osprey::rADAE
36		#' ADSL <- osprey::rADSL
37		#'
38		#' id <- ADAE$USUBJID
39		#' arm <- ADAE$ACTARMCD
40		#' arm_sl <- as.character(ADSL$ACTARMCD)
41		#' subgroups_sl <- ADSL[, c("SEX", "RACE", "STRATA1")]
42		#' subgroups <- ADAE[, c("SEX", "RACE", "STRATA1")]
43		#' subgroups_levels <- list(
44		#' RACE = list(
45		#' "Total" = "Race",
46		#' "AMERICAN INDIAN OR ALASKA NATIVE" = "American",
47		#' "WHITE" = "White",
48		#' "ASIAN" = "Asian",
49		#' "BLACK OR AFRICAN AMERICAN" = "African"
50		#' ),
51		#' STRATA1 = list(
52		#' "Total" = "Strata",
53		#' "A" = "TypeA",
54		#' "B" = "TypeB",
55		#' "C" = "Typec"
56		#' ),
57		#' SEX = list(
58		#' "Total" = "Sex",
59		#' "M" = "Male",
60		#' "F" = "Female"
61		#' )
62		#' )
63		#' # Example 1
64		#' p1 <- g_ae_sub(id,
65		#' arm,
66		#' arm_sl,
67		#' subgroups,
68		#' subgroups_sl,
69		#' trt = "ARM A",
70		#' ref = "ARM C",
71		#' subgroups_levels = subgroups_levels,
72		#' arm_n = FALSE
73		#' )
74		#' grid::grid.newpage()
75		#'
76		#' # Example 2: display number of patients in each arm
77		#' p2 <- g_ae_sub(id,
78		#' arm,
79		#' arm_sl,
80		#' subgroups,
81		#' subgroups_sl,
82		#' trt = "ARM A",
83		#' ref = "ARM C",
84		#' subgroups_levels = subgroups_levels,
85		#' arm_n = TRUE
86		#' )
87		#' grid::grid.newpage()
88		#'
89		#' # Example 3: preprocess data to only include treatment and control arm patients
90		#' trt <- "ARM A"
91		#' ref <- "ARM C"
92		#' ADAE <- osprey::rADAE
93		#' ADSL <- osprey::rADSL %>% filter(ACTARMCD %in% c(trt, ref))
94		#' id <- ADAE$USUBJID
95		#' arm <- ADAE$ACTARMCD
96		#' arm_sl <- as.character(ADSL$ACTARMCD)
97		#' subgroups_sl <- ADSL[, c("SEX", "RACE", "STRATA1")]
98		#' subgroups <- ADAE[, c("SEX", "RACE", "STRATA1")]
99		#' subgroups_levels <- list(
100		#' RACE = list(
101		#' "Total" = "Race",
102		#' "AMERICAN INDIAN OR ALASKA NATIVE" = "American",
103		#' "WHITE" = "White",
104		#' "ASIAN" = "Asian",
105		#' "BLACK OR AFRICAN AMERICAN" = "African"
106		#' ),
107		#' STRATA1 = list(
108		#' "Total" = "Strata",
109		#' "A" = "TypeA",
110		#' "B" = "TypeB",
111		#' "C" = "Typec"
112		#' ),
113		#' SEX = list(
114		#' "Total" = "Sex",
115		#' "M" = "Male",
116		#' "F" = "Female"
117		#' )
118		#' )
119		#' p3 <- g_ae_sub(id,
120		#' arm,
121		#' arm_sl,
122		#' subgroups,
123		#' subgroups_sl,
124		#' trt,
125		#' ref,
126		#' subgroups_levels = subgroups_levels,
127		#' arm_n = FALSE
128		#' )
129		g_ae_sub <- function(id,
130		arm,
131		arm_sl,
132		subgroups,
133		subgroups_sl,
134		trt = levels(arm)[1],
135		ref = levels(arm)[2],
136		indent = 4,
137		subgroups_levels = NULL,
138		xmax = 0,
139		conf_level = 0.95,
140		diff_ci_method = c(
141		"wald", "waldcc", "ac", "score", "scorecc",
142		"mn", "mee", "blj", "ha", "beal"
143		),
144		fontsize = 4,
145		arm_n = FALSE,
146		draw = TRUE) {
147	!	diff_ci_method <- match.arg(diff_ci_method)
148
149	!	if (!is.null(subgroups_levels)) {
150	!	labels <- unlist(subgroups_levels)
151	!	label_df <-
152	!	tibble(
153	!	level = stringr::str_replace_all(names(labels), "\\.", "__"),
154	!	label = labels
155		) %>%
156	!	bind_rows(c(level = "TOTAL__Total", label = "Overall")) %>%
157	!	mutate(
158	!	indents = stringr::str_dup(" ", if_else(
159	!	stringr::str_detect(.data$level, "__Total"), 0, indent
160		)),
161		# create label with indents if not total
162	!	label = paste0(.data$indents, .data$label)
163		)
164		}
165	!	stopifnot("invalid arguments: check that the length of id and arm are identical" = length(id) == length(arm))
166	!	checkmate::assert_character(arm_sl, min.len = 2)
167	!	stopifnot("invalid arguments: trt and ref need to be from arm" = all(c(trt, ref) %in% unique(arm)))
168	!	checkmate::assert_number(conf_level, lower = 0.5, upper = 1)
169	!	checkmate::assert_number(fontsize, lower = 0)
170	!	checkmate::assert_data_frame(subgroups)
171	!	stopifnot(
172	!	"invalid argument: subgroups needs to be a data.frame with nrow = length(arm)" =
173	!	nrow(subgroups) == length(arm)
174		)
175	!	checkmate::assert_data_frame(subgroups_sl)
176	!	stopifnot(
177	!	"invalid argument: subgroups_sl need to be a data.frame with nrow = length(arm_sl)" =
178	!	nrow(subgroups_sl) == length(arm_sl)
179		)
180	!	checkmate::assert_number(indent, lower = 0, finite = TRUE)
181	!	checkmate::assert_number(xmax)
182	!	stopifnot(
183	!	"invalid argument: please only use the subgroups column names as the lists names in subgroups_levels" =
184	!	all(names(subgroups_levels) %in% names(lapply(subgroups, levels)))
185		)
186
187	!	stopifnot(
188	!	"invalid argument: please only include levels in subgroups columns in the nested subgroups_levels" =
189	!	all(unlist(lapply(names(subgroups_levels), function(level_name) {
190	!	all(names(subgroups_levels[[level_name]]) %in% c("Total", levels(subgroups[, level_name] %>% dplyr::pull())))
191		})))
192		)
193
194	!	checkmate::assert_flag(arm_n)
195
196	!	subgroups <- subgroups %>%
197	!	mutate_all(as.character) %>%
198	!	mutate(TOTAL = "Total")
199
200	!	arms <- c(trt, ref)
201	!	xs <- syms(paste("count", arms, sep = "__"))
202	!	ns <- syms(paste("total", arms, sep = "__"))
203	!	rs <- syms(paste("risk", arms, sep = "__"))
204
205	!	x1 <- xs[[1]]
206	!	n1 <- ns[[1]]
207	!	x2 <- xs[[2]]
208	!	n2 <- ns[[2]]
209	!	r1 <- rs[[1]]
210	!	r2 <- rs[[2]]
211
212	!	df_ref <- tibble(arm = c(ref, trt))
213
214		# a wide data frame contains event counts by arm in each subgroup
215	!	df <- cbind(id = id, arm = arm, subgroups) %>%
216	!	filter(arm %in% c(ref, trt)) %>%
217	!	unique() %>%
218	!	tidyr::pivot_longer(
219	!	names_to = "strata",
220	!	cols = colnames(subgroups),
221	!	values_to = "value"
222		) %>%
223	!	group_by(arm, .data$strata, .data$value) %>%
224	!	summarise(n = n()) %>%
225	!	full_join(df_ref, by = "arm") %>%
226	!	tidyr::replace_na(list(n = 0)) %>%
227	!	ungroup() %>%
228	!	tidyr::pivot_wider(
229	!	id_cols = c("strata", "value"),
230	!	names_from = "arm",
231	!	values_from = "n",
232	!	names_prefix = "count__",
233	!	values_fill = list(n = 0)
234		)
235
236		# a wide data frame contains total counts by arm in each subgroup
237	!	df_sl <- cbind(arm = arm_sl, subgroups_sl) %>%
238	!	filter(arm %in% c(ref, trt)) %>%
239	!	mutate(TOTAL = "Total") %>%
240	!	tidyr::pivot_longer(
241	!	names_to = "strata",
242	!	cols = c(colnames(subgroups_sl), "TOTAL"),
243	!	values_to = "value"
244		) %>%
245	!	group_by(arm, .data$strata, .data$value) %>%
246	!	summarise(n = n()) %>%
247	!	ungroup() %>%
248	!	tidyr::pivot_wider(
249	!	id_cols = c("strata", "value"),
250	!	names_from = "arm",
251	!	values_from = "n",
252	!	names_prefix = "total__",
253	!	values_fill = list(n = 0)
254		)
255
256		# calculate the risk difference and risk difference CI in each subgroup
257	!	df <- df %>%
258	!	left_join(df_sl, by = c("strata", "value")) %>%
259	!	group_by(.data$strata, .data$value) %>%
260	!	mutate(
261	!	!!r1 := !!x1 / !!n1,
262	!	!!r2 := !!x2 / !!n2,
263	!	lower = DescTools::BinomDiffCI(
264	!	!!x1, !!n1, !!x2, !!n2,
265	!	conf_level,
266	!	method = diff_ci_method
267	!	)[2],
268	!	upper = DescTools::BinomDiffCI(
269	!	!!x1, !!n1, !!x2, !!n2,
270	!	conf_level,
271	!	method = diff_ci_method
272	!	)[3],
273	!	riskdiff = !!r1 - !!r2
274		) %>%
275	!	tidyr::pivot_longer(
276	!	matches("__"),
277	!	names_to = c(".value", "arm"),
278	!	names_sep = "__"
279		) %>%
280	!	ungroup() %>%
281	!	tidyr::unite("level", "strata", "value", remove = FALSE, sep = "__")
282
283		# create label for plotting
284	!	level_format_df <- df %>%
285	!	select("strata", "value") %>%
286	!	unique() %>%
287	!	group_by(.data$strata) %>%
288	!	summarise(value = paste(c("Total", .data$value), collapse = ",")) %>%
289	!	tidyr::separate_rows("value", sep = ",") %>%
290	!	unique() %>%
291	!	tidyr::unite("level", "strata", "value", sep = "__", remove = FALSE) %>%
292	!	mutate(order = if_else(.data$strata == "TOTAL", integer(1), -row_number())) %>%
293	!	arrange(order)
294
295	!	if (is.null(subgroups_levels)) {
296	!	level_format_df <- level_format_df %>%
297	!	mutate(label = if_else(
298	!	.data$strata == "TOTAL",
299	!	"Overall",
300	!	if_else(.data$value == "Total", .data$strata, paste0(stringr::str_c(
301	!	rep(" ", indent),
302	!	collapse = ""
303	!	), .data$value))
304		))
305		} else {
306	!	level_format_df <- level_format_df %>%
307	!	inner_join(label_df, by = "level")
308		}
309
310	!	df <- df %>%
311	!	semi_join(level_format_df, by = "level")
312
313	!	mytheme <- theme_osprey(fontsize = fontsize, blank = TRUE)
314
315	!	y_axis <-
316	!	scale_y_discrete(
317	!	limits = level_format_df$level,
318	!	breaks = level_format_df$level,
319	!	labels = level_format_df$label
320		)
321
322	!	df_risk <- df %>%
323	!	select("level", "lower", "upper", "riskdiff") %>%
324	!	unique()
325	!	if (xmax <= 0) {
326	!	xmax <- max(abs(df_risk$upper), abs(df_risk$lower), na.rm = TRUE)
327		}
328	!	p1 <-
329	!	ggplot(df_risk) +
330	!	geom_point(
331	!	aes(x = .data$riskdiff, y = .data$level),
332	!	size = fontsize
333		) +
334	!	geom_vline(
335	!	data = NULL,
336	!	xintercept = 0,
337	!	linetype = 1,
338	!	color = "grey"
339		) +
340	!	geom_errorbarh(
341	!	aes(xmin = .data$lower, xmax = .data$upper, y = .data$level),
342	!	height = 0.3
343		) +
344	!	mytheme +
345	!	theme(
346	!	axis.ticks.x = element_line(),
347	!	axis.line.x = element_line()
348		) +
349	!	y_axis +
350	!	coord_cartesian(xlim = c(-xmax, xmax))
351	!	p1_grob <- ggplotGrob(p1)
352
353	!	df_total <- df %>%
354	!	group_by(.data$level) %>%
355	!	summarise(n = sum(.data$total)) %>%
356	!	mutate(percent = n / length(arm_sl) * 100)
357
358	!	if (arm_n) {
359	!	df_byarm <- df %>%
360	!	group_by(.data$level, .data$arm) %>%
361	!	summarise(n = sum(.data$total)) %>%
362	!	tidyr::pivot_wider(names_from = arm, values_from = n) %>%
363	!	rename(n_trt = matches(trt), n_ref = matches(ref))
364
365	!	df_total <- df_total %>%
366	!	left_join(df_byarm, by = "level") %>%
367	!	mutate(
368	!	percent_trt = .data$n_trt / .data$n * 100,
369	!	percent_ref = .data$n_ref / .data$n * 100
370		)
371		}
372
373	!	p2 <- ggplot(df_total) +
374	!	geom_text(aes(
375	!	x = "Patients(%)",
376	!	y = .data$level,
377	!	label = sprintf("%i (%.1f)", n, .data$percent)
378	!	), size = fontsize) +
379	!	mytheme +
380	!	y_axis +
381	!	scale_x_discrete(position = "top")
382
383	!	p2_grob <- ggplotGrob(p2)
384
385	!	if (arm_n) {
386	!	p2_trt <- ggplot(df_total) +
387	!	geom_text(aes(
388	!	x = "TRT",
389	!	y = .data$level,
390	!	label = sprintf("%i", .data$n_trt)
391	!	), size = fontsize) +
392	!	mytheme +
393	!	theme(axis.text.y = element_blank()) +
394	!	y_axis +
395	!	scale_x_discrete(position = "top")
396
397	!	p2_ref <- ggplot(df_total) +
398	!	geom_text(aes(
399	!	x = "CONT",
400	!	y = .data$level,
401	!	label = sprintf("%i", .data$n_ref)
402	!	), size = fontsize) +
403	!	mytheme +
404	!	theme(axis.text.y = element_blank()) +
405	!	y_axis +
406	!	scale_x_discrete(position = "top")
407
408	!	p2_trt_grob <- ggplotGrob(p2_trt)
409	!	p2_ref_grob <- ggplotGrob(p2_ref)
410		}
411
412	!	df_ci <- df %>%
413	!	tidyr::pivot_wider(
414	!	names_from = "arm",
415	!	values_from = "risk",
416	!	id_cols = c("level", "lower", "upper", "riskdiff")
417		) %>%
418	!	tidyr::pivot_longer(
419	!	names_to = "x",
420	!	values_to = "v",
421	!	cols = c("lower", "upper", "riskdiff", matches(trt), matches(ref))
422		) %>%
423	!	mutate(vlabel = sprintf("%.2f", .data$v))
424
425
426	!	labels <- c("TRT", "CONT", "Diff", "Lower", "Upper")
427	!	p3 <- ggplot(df_ci) +
428	!	geom_text(aes(x = .data$x, y = .data$level, label = .data$vlabel), size = fontsize) +
429	!	mytheme +
430	!	y_axis +
431	!	scale_x_discrete(
432	!	limits = c(trt, ref, "riskdiff", "lower", "upper"),
433	!	labels = labels,
434	!	position = "top"
435		)
436
437	!	p3_grob <- ggplotGrob(p3)
438
439	!	grobs <- grob_parts(p1_grob, "axis-l")
440	!	grobs <- append(grobs, grob_parts(p2_grob, c("axis-t", "panel")))
441	!	if (arm_n) {
442	!	grobs <- append(grobs, grob_parts(p2_trt_grob, c("axis-t", "panel")))
443	!	grobs <- append(grobs, grob_parts(p2_ref_grob, c("axis-t", "panel")))
444		}
445	!	grobs <- append(grobs, grob_parts(p1_grob, c("panel", "axis-b")))
446	!	grobs <- append(grobs, grob_parts(p3_grob, c("axis-t", "panel")))
447	!	less_risk <- grid::textGrob(
448	!	"Favor\nTreatment",
449	!	just = "centre",
450	!	x = grid::unit(fontsize * .pt, "pt"),
451	!	gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold")
452		)
453	!	more_risk <- grid::textGrob(
454	!	"Favor\nControl",
455	!	just = "centre",
456	!	x = grid::unit(1, "npc") - grid::unit(fontsize * .pt, "pt"),
457	!	gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold")
458		)
459	!	risk_label <- gridExtra::arrangeGrob(less_risk, more_risk, nrow = 1)
460	!	grobs <- append(grobs, list(
461	!	grid::textGrob(
462	!	"Risk Difference (CI)",
463	!	just = "centre",
464	!	x = grid::unit(0.5, "npc"),
465	!	y = grid::unit(0.5, "npc"),
466	!	gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold")
467		),
468	!	risk_label
469		))
470
471	!	widths <- if (arm_n) {
472	!	grid::unit.c(
473	!	grid::grobWidth(grobs[[1]]),
474	!	grid::unit(
475	!	c(14 * fontsize, rep(10 * fontsize, 2), 1, 50 * fontsize),
476	!	c(rep("pt", 3), "null", "pt")
477		)
478		)
479		} else {
480	!	grid::unit.c(
481	!	grid::grobWidth(grobs[[1]]),
482	!	grid::unit(
483	!	c(14 * fontsize, 1, 50 * fontsize),
484	!	c("pt", "null", "pt")
485		)
486		)
487		}
488
489	!	heights <- if (arm_n) {
490	!	grid::unit.c(
491	!	grid::grobHeight(grobs[[10]]),
492	!	grid::unit(1, "null"),
493	!	rep(grid::grobHeight(grobs[[9]]), 3),
494	!	grid::unit(fontsize * .pt, "pt")
495		)
496		} else {
497	!	grid::unit.c(
498	!	grid::grobHeight(grobs[[6]]),
499	!	grid::unit(1, "null"),
500	!	grid::grobHeight(grobs[[5]]),
501	!	grid::unit(fontsize * .pt * 3, "pt")
502		)
503		}
504
505	!	boldfont <- grid::gpar(
506	!	fontsize = fontsize * 4,
507	!	fontface = "bold",
508	!	lineheight = 1
509		)
510	!	layout_matrix <- if (arm_n) {
511	!	rbind(
512	!	c(NA, 2, 4, 6, 12, 10),
513	!	c(1, 3, 5, 7, 8, 11),
514	!	c(NA, NA, NA, NA, 9, NA),
515	!	c(NA, NA, NA, NA, 13, NA)
516		)
517		} else {
518	!	rbind(
519	!	c(NA, 2, 8, 6),
520	!	c(1, 3, 4, 7),
521	!	c(NA, NA, 5, NA),
522	!	c(NA, NA, 9, NA)
523		)
524		}
525
526	!	ret <- gridExtra::arrangeGrob(
527	!	grobs = grobs,
528	!	layout_matrix = layout_matrix,
529	!	heights = heights,
530	!	widths = widths,
531	!	clip = "on"
532		)
533	!	if (draw) {
534	!	grid::grid.draw(ret)
535		}
536	!	invisible(ret)
537		}

1		#' Applies STREAM style filtering to datasets
2		#'
3		#' One of `slref` or `anl` need to be specified. The conversion from `SAS` code in filters dataset may not work in all
4		#' cases. In case of failure a sensible error message should be returned.
5		#'
6		#' @param slref The subject level data frame (typically `ADSL`)
7		#' @param anl The analysis data frame
8		#' @param suffix The suffix to apply in quotes (e.g. `"ITT_PFSINV"`)
9		#' @param slref_keep Variables to keep from `slref` (e.g. `c("REGION", "SEX")`)
10		#' @param usubjid The unique subject identifier variable in quotes (e.g. `"USUBJID"`)
11		#' @param filters The name of the filters dataset
12		#'
13		#' @return \code{dataframe} object
14		#' @author Iain Bennett
15		#' @export
16		#' @examples
17		#' ADSL <- osprey::rADSL
18		#' ADTTE <- osprey::rADTTE
19		#' filters <- as.data.frame(rbind(
20		#' c(ID = "IT", FLTTARGET = "SLREF", FLTWHERE = "where 1 eq 1"),
21		#' c(ID = "BIO", FLTTARGET = "SLREF", FLTWHERE = "where BMRKR1 ge 4.3"),
22		#' c(ID = "M", FLTTARGET = "SLREF", FLTWHERE = "where SEX eq 'M'"),
23		#' c(ID = "PFS", FLTTARGET = "ANL", FLTWHERE = "where PARAMCD eq 'PFS'"),
24		#' c(ID = "OS", FLTTARGET = "ANL", FLTWHERE = "where PARAMCD eq 'OS'")
25		#' ))
26		#'
27		#' ANL <- stream_filter(
28		#' slref = ADSL,
29		#' anl = ADTTE,
30		#' suffix = "IT_PFS_BIO",
31		#' filters = filters
32		#' )
33		stream_filter <- function(slref = NULL, anl = NULL, filters, suffix, slref_keep = NULL, usubjid = "USUBJID") {
34	!	actual_suffix <- NULL
35
36	!	if (is.null(anl) && is.null(slref)) {
37	!	stop("At least one of anl= or slref= must be provided")
38		}
39
40	!	if (is.null(anl)) {
41	!	anl <- slref
42		}
43
44	!	if (is.null(slref)) {
45	!	slref <- anl
46		}
47
48	!	asl_out <- slref
49	!	anl_out <- anl
50
51		# step 1 get a list of filters
52
53	!	filters_to_apply <- strsplit(suffix, split = "_", fixed = TRUE) %>%
54	!	unlist()
55
56	!	n_filters <- length(filters_to_apply)
57
58	!	for (i in 1:n_filters) {
59	!	this_filter <- filters_to_apply[i]
60
61		# find filter meta data
62
63	!	this_filter_df <- unique(dplyr::filter(filters, .data$ID == this_filter))
64
65	!	if (nrow(this_filter_df) == 0) {
66	!	stop(paste("Filter", this_filter, "not found in filters"))
67		}
68
69	!	if (nrow(this_filter_df) > 1) {
70	!	warning(paste("Filter", this_filter, "is duplicated in filters"))
71	!	this_filter_df <- slice(this_filter_df, 1)
72		}
73
74		# try and convert where clause from sas to R
75	!	this_sasclause <- this_filter_df$FLTWHERE
76	!	this_rclause <- stream_filter_convwhere(this_sasclause)
77
78	!	msg1 <- paste("\nSAS code:", this_sasclause, "\nwas converted to\nR code:", this_rclause)
79
80		# what is the target df?
81
82	!	if (this_filter_df$FLTTARGET == "ANL") {
83	!	this_df <- anl_out
84		}
85
86	!	if (this_filter_df$FLTTARGET == "SLREF") {
87	!	this_df <- asl_out
88		}
89
90		# try and apply the filtering
91	!	new_df <- NULL
92
93	!	new_df <- try(
94	!	eval(parse(text = sprintf("dplyr::filter(this_df, %s)", this_rclause))),
95	!	silent = TRUE
96		)
97
98	!	if (is(new_df, "try-error")) {
99		# failed - retain original dataset
100	!	warning(paste("\nFilter ID=", this_filter, "was NOT applied.", msg1, "\n Error message:", new_df))
101	!	cat(paste("\nFilter ID=", this_filter, "was NOT applied.", msg1, "\n Error message:", new_df))
102	!	new_df <- this_df
103		} else {
104		# success
105	!	msg2 <- paste0(
106	!	"\n",
107	!	nrow(new_df),
108	!	" of ",
109	!	nrow(this_df),
110	!	" observations selected from ", this_filter_df$FLTTARGET
111		)
112	!	cat(paste("\nFilter", this_filter, "applied", msg1, msg2, "\n"))
113	!	actual_suffix <- if (is.null(actual_suffix)) {
114	!	this_filter
115		} else {
116	!	paste(actual_suffix, this_filter, sep = "_")
117		}
118		}
119
120		# update the output data sets
121	!	if (this_filter_df$FLTTARGET == "ANL") {
122	!	anl_out <- new_df
123	!	} else if (this_filter_df$FLTTARGET == "SLREF") {
124	!	asl_out <- new_df
125		}
126		}
127
128		# finished filtering - combine results data
129		# what variables to keep from SLREF?
130	!	slref_keep <- if (is.null(slref_keep)) {
131	!	usubjid
132		} else {
133	!	unique(c(slref_keep, usubjid))
134		}
135
136		# keep these variables only
137	!	asl_out <- eval(parse(text = sprintf("dplyr::transmute(asl_out, %s)", paste(slref_keep, collapse = ","))))
138
139		# use inner join to apply both slref and anl restrictions
140	!	rc <- inner_join(asl_out, anl_out, by = usubjid)
141
142		# report out what was applied in case of errors
143	!	actual_suffix <- ifelse(is.null(actual_suffix), " ", actual_suffix)
144
145	!	if (actual_suffix == suffix) {
146	!	cat(paste0("\nSuffix ", suffix, " was applied"))
147		} else {
148	!	cat(paste0("\nNot all filters applied. \n", actual_suffix, " was applied instead of ", suffix))
149		}
150	!	cat(paste0("\n", nrow(rc), " of ", nrow(anl), " observations selected from ANL\n"))
151
152		# return the filtered dataset
153	!	return(rc)
154		}
155
156		#' Replicates the use of index function in `SAS` for logic options
157		#'
158		#' Assumption is that use in filters is to only resolve true vs false
159		#' Primarily for use with stream_filter and related `stream_filter_convwhere` functions
160		#' @param string1 The string to search within - can be a vector
161		#' @param string2 The string to search for - must have length 1
162		#'
163		#' @return \code{boolean} indicator
164		#' @author Iain Bennett
165		#' @export
166		#'
167		#' @examples
168		#' AEACN <- c("DRUG MODIFIED", "DRUG STOPPED", "DOSE/DRUG MODIFIED")
169		#' stream_filter_index(AEACN, "DRUG MODIFIED")
170		stream_filter_index <- function(string1, string2) {
171	!	rc <- regexpr(string2, string1, fixed = TRUE)
172	!	rc <- ifelse(rc == -1, FALSE, TRUE)
173	!	return(rc)
174		}
175
176
177		#' Convert `SAS` code to R code
178		#'
179		#' Will convert following `SAS` operators: `eq, =, le, lt, ge, gt, index`
180		#' Will convert following logic: and, or, ()
181		#' Will convert all unquoted values to upper case (assumed to be variable names)
182		#' All quoted values will be returned with single quotes - may fail if have quotes within quotes
183		#' @param x a character string of `SAS` code
184		#'
185		#' @return a character string of R code
186		#' @author Iain Bennett
187		#' @export
188		#'
189		#' @examples
190		#' stream_filter_convwhere(x = "where X in (1 2 3 4) and Y gt 4 ")
191		#' stream_filter_convwhere(x = "where X = \"fred\" and Y gt 4 ")
192		stream_filter_convwhere <- function(x) {
193		# convert double quotes to single quotes. May fail if quoted values exist.
194	!	this_rclause <- gsub("\"", "'", x, fixed = TRUE)
195
196		# convert non quoted values to upper case
197
198	!	this_rclause_quotes <- strsplit(paste0(" ", this_rclause, " "), split = "'", fixed = TRUE) %>%
199	!	unlist()
200
201	!	inquotes <- rep(c(0, 1), length.out = length(this_rclause_quotes))
202
203	!	for (j in seq_along(inquotes)) {
204		# try and convert logic outside quotes
205	!	if (inquotes[j] == 0) {
206	!	this_rclause_quotes[j] <- toupper(this_rclause_quotes[j])
207	!	this_rclause_quotes[j] <- gsub("=", "==", this_rclause_quotes[j], fixed = TRUE)
208	!	this_rclause_quotes[j] <- gsub(" EQ ", " == ", this_rclause_quotes[j], fixed = TRUE)
209	!	this_rclause_quotes[j] <- gsub(" NE ", " != ", this_rclause_quotes[j], fixed = TRUE)
210	!	this_rclause_quotes[j] <- gsub(" LE ", " <= ", this_rclause_quotes[j], fixed = TRUE)
211	!	this_rclause_quotes[j] <- gsub(" LT ", " < ", this_rclause_quotes[j], fixed = TRUE)
212	!	this_rclause_quotes[j] <- gsub(" GE ", " >= ", this_rclause_quotes[j], fixed = TRUE)
213	!	this_rclause_quotes[j] <- gsub(" GT ", " > ", this_rclause_quotes[j], fixed = TRUE)
214	!	this_rclause_quotes[j] <- gsub(" AND ", " & ", this_rclause_quotes[j], fixed = TRUE)
215	!	this_rclause_quotes[j] <- gsub(" OR ", " \|\| ", this_rclause_quotes[j], fixed = TRUE)
216	!	this_rclause_quotes[j] <- gsub(" IN ", " %in% c", this_rclause_quotes[j], fixed = TRUE)
217	!	this_rclause_quotes[j] <- gsub("WHERE ", " ", this_rclause_quotes[j], fixed = TRUE)
218	!	this_rclause_quotes[j] <- gsub("INDEX(", " stream_filter_index(", this_rclause_quotes[j], fixed = TRUE)
219	!	this_rclause_quotes[j] <- gsub("UPCASE(", " toupper(", this_rclause_quotes[j], fixed = TRUE)
220	!	this_rclause_quotes[j] <- gsub("DATEPART(", " as.Date(", this_rclause_quotes[j], fixed = TRUE)
221		}
222		}
223
224		# collapse back to have quoted
225	!	this_rclause <- paste(this_rclause_quotes, collapse = "'")
226
227		# if contains an in statement need to ensure commas exist
228	!	if (grepl(" %in% c", this_rclause, fixed = TRUE)) {
229		# get the clause (assume only 1 per filter...)
230	!	temp1_str <- strsplit(this_rclause, split = " %in% c(", fixed = TRUE) %>%
231	!	unlist()
232
233	!	if (length(temp1_str) != 2) {
234	!	stop("ERROR - function can't handle multiple IN operators.")
235		} else {
236	!	left_str <- temp1_str[1]
237	!	in_right_str <- temp1_str[2]
238
239		# find quoted items bracket
240	!	temp2_str <- strsplit(in_right_str, split = "'", fixed = TRUE) %>%
241	!	unlist()
242	!	inquotes <- rep(c(0, 1), length.out = length(temp2_str))
243
244		# find first not quoted right bracket
245
246	!	right_idxv <- which(inquotes == 0 & grepl(")", temp2_str, fixed = TRUE))
247	!	right_idxc <- regexpr(")", temp2_str[right_idxv], fixed = TRUE)
248
249	!	temp3_str <- temp2_str
250
251	!	temp3_str[right_idxv] <- substr(temp2_str[right_idxv], right_idxc, nchar(temp2_str[right_idxv]))
252
253	!	right_str <- temp3_str[right_idxv:length(temp3_str)] %>%
254	!	paste(collapse = "'")
255
256	!	in_idx <- regexpr(right_str, in_right_str, fixed = TRUE) %>%
257	!	as.numeric()
258
259	!	in_str <- substr(in_right_str, 1, in_idx - 1)
260
261		# now have left.str, in.str and right.str that contain seperate code parts
262		# need to check the list of in and remove any commas to later replace between each element
263		# first get any unquoted spaces or commas and split these
264
265	!	temp4_str <- strsplit(in_str, split = "'", fixed = TRUE) %>%
266	!	unlist()
267	!	inquotes <- rep(c(0, 1), length.out = length(temp4_str))
268
269	!	unquoted <- temp4_str[which(inquotes == 0)]
270	!	quoted_items <- temp4_str[which(inquotes == 1)]
271
272		# seperate any items unqouted
273	!	temp5_str <- strsplit(unquoted, split = ",", fixed = TRUE) %>%
274	!	unlist() %>%
275	!	strsplit(split = " ", fixed = TRUE) %>%
276	!	unlist()
277
278	!	unquoted_items <- temp5_str[which(!(temp5_str %in% ""))]
279
280		# should now have two vectors of strings
281		# unquoted.items and quoted.items
282		# first add the quoted items back in quoted.items <- unquoted.items
283	!	if (length(quoted_items) > 0) {
284	!	quoted_items <- paste0("'", quoted_items, "'")
285		}
286
287		# now collapse both strings adding commas
288
289	!	all_items <- c(quoted_items, unquoted_items) %>%
290	!	paste(collapse = " , ")
291
292		# rebuild the complete code piece
293	!	this_rclause <- paste0(left_str, " %in% c(", all_items, right_str)
294		}
295		}
296	!	return(this_rclause)
297		}

1		#' `Swimlane` Plot
2		#'
3		#' `Swimlane` plot is often used in Early Development (ED) and displays individual
4		#' patient bar plot with markers of events and patient level annotation
5		#'
6		#' @param bar_id vector of IDs to identify each bar
7		#' @param bar_length numeric vector to be plotted as length for each bar
8		#' @param sort_by vector to sort bars
9		#' @param col_by vector to color bars
10		#' @param marker_id vector of IDs to identify markers within each bar. Default is the same as bar_id.
11		#' @param marker_pos numeric vector to specify position for each marker point
12		#' @param marker_shape vector to specify shape for markers
13		#' @param marker_shape_opt aesthetic values to map shape values (named vector to map shape values to each name)
14		#' @param marker_color vector to specify color for markers
15		#' @param marker_color_opt aesthetic values to map shape values (named vector to map shape values to each name)
16		#' @param anno_txt dataframe of subject-level variables to be displayed as annotation on the left
17		#' @param xref_line numeric vector to plot reference lines
18		#' @param xtick_at optional break interval of bar length axis
19		#' @param xlab label for bar length
20		#' @param title string to be displayed as plot title
21		#'
22		#' @template author_qit3
23		#' @return plot object
24		#'
25		#' @export
26		#'
27		#' @examplesIf require("nestcolor")
28		#' # Example 1
29		#' library(dplyr)
30		#' library(nestcolor)
31		#'
32		#' ADSL <- osprey::rADSL[1:20, ]
33		#' ADRS <- filter(rADRS, PARAMCD == "OVRINV")
34		#' ANL <- left_join(ADSL, ADRS, by = c("STUDYID", "USUBJID"), multiple = "all")
35		#' anno_txt <- ADSL[, c("ARMCD", "SEX")]
36		#'
37		#' g_swimlane(
38		#' bar_id = ADSL$USUBJID,
39		#' bar_length = as.integer(ADSL$TRTEDTM - ADSL$TRTSDTM),
40		#' sort_by = ADSL$ARM,
41		#' col_by = ADSL$ARM,
42		#' marker_id = ANL$USUBJID,
43		#' marker_pos = ANL$ADY,
44		#' marker_shape = ANL$AVALC,
45		#' marker_shape_opt = c("CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "NE" = 4),
46		#' marker_color = NULL,
47		#' marker_color_opt = NULL,
48		#' anno_txt = anno_txt,
49		#' xref_line = c(50, 100),
50		#' xtick_at = waiver(),
51		#' xlab = "Time from First Treatment (Day)",
52		#' title = "Swimlane Plot"
53		#' )
54		#'
55		#' # Example 2
56		#' library(dplyr)
57		#' library(nestcolor)
58		#'
59		#' ADSL <- osprey::rADSL[1:20, ]
60		#' ADRS <- osprey::rADRS
61		#'
62		#' anno_txt_vars <- c("ARMCD", "SEX", "COUNTRY")
63		#' anno_txt <- ADSL[, anno_txt_vars]
64		#'
65		#' # markers from ADRS
66		#' ADRS <- dplyr::filter(ADRS, PARAMCD == "OVRINV") %>% select(USUBJID, ADY, AVALC)
67		#'
68		#' # markers from ADSL - discontinuation
69		#' ADS <- ADSL %>%
70		#' dplyr::filter(EOSSTT == "Discontinued" \| DCSREAS != "") %>%
71		#' select(USUBJID, EOSDY, DCSREAS) %>%
72		#' dplyr::rename(ADY = EOSDY, AVALC = DCSREAS)
73		#'
74		#' # combine ADRS with ADS records as one data for markers and join with ADSL
75		#' ANL <- inner_join(ADSL, rbind(ADRS, ADS), by = "USUBJID", multiple = "all")
76		#'
77		#' g_swimlane(
78		#' bar_id = sub(".*-", "", ADSL$USUBJID),
79		#' bar_length = as.integer(ADSL$TRTEDTM - ADSL$TRTSDTM),
80		#' sort_by = NULL,
81		#' col_by = ADSL$ARMCD,
82		#' marker_id = sub(".*-", "", ANL$USUBJID),
83		#' marker_pos = ANL$ADY,
84		#' marker_shape = ANL$AVALC,
85		#' marker_shape_opt = c(
86		#' "CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "NE" = 0,
87		#' "Adverse Event" = 7, "Death" = 8, "Physician Decision" = 9, "Progressive Disease" = 10,
88		#' "Symptomatic Deterioation" = 11, "Withdrawal by Subject" = 12
89		#' ),
90		#' marker_color = ANL$AVALC,
91		#' marker_color_opt = c(
92		#' "CR" = "green", "PR" = "blue", "SD" = "yellow", "PD" = "red",
93		#' "NE" = "grey", "Adverse Event" = "orange", "Death" = "black", "Physician Decision" = "navy",
94		#' "Progressive Disease" = "purple", "Symptomatic Deterioation" = "cyan",
95		#' "Withdrawal by Subject" = "darkred"
96		#' ),
97		#' anno_txt = anno_txt,
98		#' xref_line = c(50, 100),
99		#' xtick_at = waiver(),
100		#' xlab = "Time from First Treatment (Day)",
101		#' title = "Swimlane Plot"
102		#' )
103		g_swimlane <- function(bar_id,
104		bar_length,
105		sort_by = NULL,
106		col_by = NULL,
107		marker_id = NULL,
108		marker_pos = NULL,
109		marker_shape = NULL,
110		marker_shape_opt = NULL,
111		marker_color = NULL,
112		marker_color_opt = NULL,
113		anno_txt = NULL,
114		xref_line = NULL,
115		xtick_at = waiver(),
116		xlab,
117		title) {
118		# check data
119	!	if (!is.null(sort_by)) {
120	!	check_same_N(bar_id = bar_id, bar_length = bar_length, sort_by = sort_by)
121		}
122	!	if (!is.null(col_by)) {
123	!	check_same_N(bar_id = bar_id, bar_length = bar_length, col_by = col_by)
124		}
125
126	!	if (!is.null(marker_id) && length(which(!marker_id %in% bar_id)) > 0) {
127	!	stop("marker_id ", marker_id[which(!marker_id %in% bar_id)], " is not in bar_id")
128		}
129
130	!	if (!is.null(marker_id) && !is.null(marker_pos)) {
131	!	check_same_N(marker_id = marker_id, marker_pos = marker_pos)
132		}
133	!	if (!is.null(marker_id) && !is.null(marker_shape)) {
134	!	check_same_N(marker_id = marker_id, marker_shape = marker_shape)
135		}
136	!	if (!is.null(marker_id) && !is.null(marker_color)) {
137	!	check_same_N(marker_id = marker_id, marker_color = marker_color)
138		}
139	!	if (!is.null(xref_line) && (!is.numeric(xref_line) \|\| length(xref_line) == 0)) {
140	!	stop("xref_line must be a non-empty numeric vector or NULL")
141		}
142
143		# data for plot
144	!	bar_data <- data.frame(
145	!	bar_id,
146	!	bar_length,
147	!	sort_by = if (is.null(sort_by)) "x" else to_n(sort_by, length(bar_length)),
148	!	col_by = if (is.null(col_by)) "x" else to_n(col_by, length(bar_length))
149		)
150
151		# data for marker
152	!	if (is.null(marker_id)) marker_id <- bar_id
153	!	marker_data <- data.frame(
154	!	marker_id,
155	!	marker_pos = if (is.null(marker_pos)) "x" else to_n(marker_pos, length(marker_id)),
156	!	marker_shape = if (is.null(marker_shape)) "x" else to_n(marker_shape, length(marker_id)),
157	!	marker_color = if (is.null(marker_color)) "x" else to_n(marker_color, length(marker_id))
158		)
159
160		# if sort by a variable, reorder bar_id by sort var and then bar length; otherwise sort by bar length
161	!	if (!is.null(sort_by)) {
162	!	bar_data$bar_id <- factor(bar_data$bar_id,
163	!	levels = rev(unique(bar_data$bar_id[order(bar_data$sort_by, -bar_data$bar_length)]))
164		)
165		} else {
166	!	bar_data$bar_id <- factor(bar_data$bar_id,
167	!	levels = rev(unique(bar_data$bar_id[order(-bar_data$bar_length)]))
168		)
169		}
170
171		# labeling
172	!	xlabel <- deparse(substitute(bar_length))
173	!	xlab <- if (is.null(xlab)) xlabel else xlab
174
175		# plot bar plot first
176	!	p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_length)) +
177	!	geom_bar(stat = "identity", aes(fill = col_by)) +
178	!	coord_flip(xlim = c(1, length(unique(bar_id)) + 1)) +
179	!	theme_bw() +
180	!	theme(
181	!	panel.background = element_blank(),
182	!	panel.grid = element_blank(),
183	!	axis.line = element_line(colour = "black"),
184	!	axis.text.y = element_blank(),
185	!	axis.title.y = element_blank()
186		) +
187		# Note ylab as we have coord_flip above
188	!	ylab(xlab)
189
190	!	if (is.null(col_by)) {
191	!	p <- p + guides(fill = "none")
192		} else {
193	!	p <- p +
194	!	guides(fill = guide_legend("Bar Color", order = 1, ncol = 1)) +
195	!	theme(
196	!	legend.title = element_text(size = 8),
197	!	legend.text = element_text(size = 8),
198	!	legend.key = element_rect(fill = NA),
199	!	legend.key.size = grid::unit(1, "line"),
200	!	legend.spacing.y = grid::unit(0, "cm"),
201	!	legend.key.height = grid::unit(1, "line")
202		)
203		}
204
205	!	limits_x <- NULL
206
207		# plot marker
208	!	if (!is.null(marker_pos)) {
209	!	p <- p + geom_point(
210	!	data = marker_data,
211	!	aes(x = marker_id, y = marker_pos, shape = marker_shape, color = marker_color),
212	!	size = 2.5, na.rm = TRUE
213		)
214	!	limits_x <- c(0, max(bar_length, marker_pos, na.rm = TRUE) + 5)
215
216	!	if (!is.null(marker_shape)) {
217	!	p <- p + guides(shape = guide_legend("Marker Shape", order = 2))
218		} else {
219	!	p <- p + guides(shape = "none")
220		}
221
222	!	if (!is.null(marker_color)) {
223	!	p <- p + guides(color = guide_legend("Marker Color", order = 3))
224		} else {
225	!	p <- p + guides(color = "none")
226		}
227
228	!	p <- p +
229	!	scale_shape_manual(
230	!	name = "Marker Shape",
231	!	breaks = levels(factor(marker_data$marker_shape)),
232	!	values = if (!is.null(marker_shape_opt)) marker_shape_opt else c(15:25, 0:14)
233		)
234
235	!	if (is.null(marker_color_opt)) {
236	!	if (!is.null(getOption("ggplot2.discrete.colour"))) {
237	!	marker_color_opt <- getOption("ggplot2.discrete.colour")[-seq_len(length(unique(col_by)))]
238		} else {
239	!	marker_color_opt <- c("x" = "black")
240		}
241		}
242
243	!	p <- p + scale_color_manual(
244	!	name = "Marker Color",
245	!	breaks = levels(factor(marker_data$marker_color)),
246	!	values = marker_color_opt
247		)
248		}
249
250		# plot reference lines
251	!	if (!is.null(xref_line)) {
252	!	x_axis_min <- pmax(ggplot_build(p)$layout$panel_params[[1]]$x.range[1], 0)
253	!	x_axis_max <- pmax(ggplot_build(p)$layout$panel_params[[1]]$x.range[2], 0)
254	!	xref_line_min <- min(xref_line)
255	!	xref_line_max <- max(xref_line)
256	!	min_res <- min(c(limits_x[1], x_axis_min, xref_line_min))
257	!	max_res <- max(c(limits_x[2], x_axis_max, xref_line_max))
258	!	p <- p + geom_hline(yintercept = xref_line, linetype = "dashed", color = "red") +
259	!	scale_y_continuous(
260	!	limits = c(min_res, max_res),
261	!	breaks = xtick_at,
262	!	expand = c(`if`(min_res == xref_line_min, .01, 0), `if`(max_res == xref_line_max, .01, 0))
263		)
264		} else {
265	!	if (!is.null(limits_x)) {
266	!	p <- p + scale_y_continuous(limits = limits_x, breaks = xtick_at, expand = c(0, 0))
267		}
268		}
269
270		# plot title and labels
271	!	if (!is.null(title)) {
272	!	p <- p +
273	!	labs(title = title) +
274	!	theme(plot.title = element_text(face = "bold"))
275		}
276
277
278		# create annotation as a separate table plot
279	!	if (is.null(anno_txt)) {
280	!	t <- data.frame(bar_id, bar_length,
281	!	sort_by = if (is.null(sort_by)) "x" else to_n(sort_by, length(bar_length))
282		)
283		} else {
284	!	t <- data.frame(bar_id, bar_length,
285	!	sort_by = if (is.null(sort_by)) "x" else to_n(sort_by, length(bar_length)),
286	!	anno_txt
287		)
288		}
289
290		# if sort by a variable, reorder bar_id; otherwise sort by bar length
291	!	if (!is.null(sort_by)) {
292	!	t <- t[with(t, order(sort_by, -bar_length, levels(as.factor(bar_id)))), -c(2, 3)]
293		} else {
294	!	t <- t[with(t, order(-bar_length, levels(as.factor(bar_id)))), -c(2, 3)]
295		}
296
297	!	t <- as.data.frame(t)
298	!	colnames(t)[1] <- " "
299
300	!	my_theme <- gridExtra::ttheme_default(
301	!	core = list(
302	!	bg_params = list(fill = NA, col = NA),
303	!	fg_params = list(cex = 0.8)
304		),
305	!	colhead = list(
306	!	bg_params = list(fill = NA, col = NA),
307	!	fg_params = list(cex = 0.8)
308		)
309		)
310	!	tb <- gridExtra::tableGrob(t, rows = NULL, theme = my_theme)
311	!	tb$heights <- grid::unit(rep(1 / nrow(tb), nrow(tb)), "null")
312
313		# grab plot and table as one plot
314	!	g0 <- ggplotGrob(p)
315	!	g1 <- gtable::gtable_add_cols(g0, sum(tb$widths), 0)
316	!	g <- gtable::gtable_add_grob(g1, tb, t = g1$layout[g1$layout$name == "panel", 1], l = 1)
317
318	!	grid::grid.newpage()
319	!	grid::grid.draw(g)
320	!	invisible(g)
321		}

1		#' Waterfall Plot
2		#'
3		#' Waterfall plot is often used in Early Development (ED) to present each individual patient’s best
4		#' response to a particular drug based on a parameter.
5		#'
6		#' @param bar_id (`vector`)\cr contains IDs to identify each bar
7		#' @param bar_height numeric vector to be plotted as height of each bar
8		#' @param sort_by (`vector`)\cr used to sort bars, default is `NULL` in which case bars are ordered
9		#' by decreasing height
10		#' @param col_by (`vector`)\cr used to color bars, default is `NULL` in which case bar_id is taken if
11		#' the argument \code{bar_color_opt} is provided
12		#' @param bar_color_opt (`vector`)\cr
13		#' aesthetic values to map color values (named vector to map color values to each name).
14		#' If not `NULL`, please make sure this contains all possible values for \code{col_by} values,
15		#' otherwise default `ggplot` color will be assigned, please note that `NULL` needs to be specified
16		#' in this case
17		#' @param anno_txt (`dataframe`)\cr
18		#' contains subject-level variables to be displayed as annotation below the waterfall plot,
19		#' default is `NULL`
20		#' @param href_line (`numeric vector`)\cr to plot horizontal reference lines, default is `NULL`
21		#' @param facet_by (`vector`)\cr to facet plot and annotation table, default is `NULL`
22		#' @param show_datavalue (`boolean`)\cr controls whether value of bar height is shown, default is \code{TRUE}
23		#' @param add_label (`vector`)\cr of one subject-level variable to be added to each bar except for bar_height,
24		#' default is `NULL`
25		#' @param gap_point (`numeric`)\cr value for adding bar break when some bars are significantly higher than
26		#' others, default is `NULL`
27		#' @param ytick_at (`numeric`)\cr optional bar height axis interval, default is 20
28		#' @param y_label (`string`)\cr label for bar height axis, default is "Best % Change from Baseline"
29		#' @param title (`string`)\cr displayed as plot title, default is "Waterfall Plot"
30		#'
31		#' @author Xuefeng Hou (houx14) \email{houx14@gene.com}
32		#' @template author_qit3
33		#'
34		#' @return plot object
35		#'
36		#' @export
37		#'
38		#' @examplesIf require("nestcolor")
39		#' library(tidyr)
40		#' library(dplyr)
41		#' library(nestcolor)
42		#'
43		#' g_waterfall(
44		#' bar_id = letters[1:3], bar_height = c(3, 5, -1),
45		#' bar_color_opt = c("red", "green", "blue")
46		#' )
47		#'
48		#' # Example 1
49		#' ADSL <- osprey::rADSL[1:15, ]
50		#' ADRS <- osprey::rADRS %>%
51		#' filter(USUBJID %in% ADSL$USUBJID)
52		#' ADTR <- osprey::rADTR %>%
53		#' filter(USUBJID %in% ADSL$USUBJID) %>%
54		#' select(USUBJID, PCHG) %>%
55		#' group_by(USUBJID) %>%
56		#' slice(which.min(PCHG))
57		#'
58		#' TR_SL <- inner_join(ADSL, ADTR, by = "USUBJID", multiple = "all")
59		#'
60		#' SUB_ADRS <- ADRS %>%
61		#' filter(PARAMCD == "BESRSPI" \| PARAMCD == "INVET") %>%
62		#' select(USUBJID, PARAMCD, AVALC, AVISIT, ADY) %>%
63		#' spread(PARAMCD, AVALC)
64		#'
65		#' ANL <- TR_SL %>%
66		#' left_join(SUB_ADRS, by = "USUBJID", multiple = "all") %>%
67		#' mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1)
68		#'
69		#' anno_txt_vars <- c("TRTDURD", "BESRSPI", "INVET", "SEX", "BMRKR2")
70		#'
71		#' g_waterfall(
72		#' bar_height = ANL$PCHG,
73		#' bar_id = sub(".*-", "", ANL$USUBJID),
74		#' col_by = ANL$SEX,
75		#' sort_by = ANL$ARM,
76		#' # bar_color_opt = c("F" = "red", "M" = "green", "U" = "blue"),
77		#' anno_txt = ANL[, anno_txt_vars],
78		#' facet_by = NULL,
79		#' href_line = c(-30, 20),
80		#' add_label = ANL$BESRSPI,
81		#' ytick_at = 20,
82		#' gap_point = NULL,
83		#' show_datavalue = TRUE,
84		#' y_label = "Best % Change from Baseline",
85		#' title = "Waterfall Plot"
86		#' )
87		#'
88		#' # Example 2 facetting
89		#' anno_txt_vars <- c("BESRSPI", "INVET")
90		#'
91		#' g_waterfall(
92		#' bar_id = sub(".*-", "", ANL$USUBJID),
93		#' bar_height = ANL$PCHG,
94		#' sort_by = ANL$COUNTRY,
95		#' col_by = ANL$SEX,
96		#' bar_color_opt = c("F" = "tomato", "M" = "skyblue3", "U" = "darkgreen"),
97		#' anno_txt = ANL[, anno_txt_vars],
98		#' facet_by = ANL$STRATA2,
99		#' href_line = c(-30, 20),
100		#' add_label = ANL$BESRSPI,
101		#' ytick_at = 20,
102		#' gap_point = 260,
103		#' y_label = "Best % Change from Baseline",
104		#' title = "Waterfall Plot"
105		#' )
106		#'
107		#' # Example 3 extreme value
108		#' ANL$PCHG[3] <- 99
109		#' ANL$PCHG[5] <- 199
110		#' ANL$PCHG[7] <- 599
111		#' ANL$BESRSPI[3] <- "PD"
112		#' ANL$BESRSPI[5] <- "PD"
113		#' ANL$BESRSPI[7] <- "PD"
114		#'
115		#' g_waterfall(
116		#' bar_id = sub(".*-", "", ANL$USUBJID),
117		#' bar_height = ANL$PCHG,
118		#' sort_by = ANL$ARM,
119		#' col_by = ANL$SEX,
120		#' bar_color_opt = c("F" = "tomato", "M" = "skyblue3", "U" = "darkgreen"),
121		#' anno_txt = ANL[, anno_txt_vars],
122		#' facet_by = NULL,
123		#' href_line = c(-30, 20),
124		#' add_label = ANL$BESRSPI,
125		#' ytick_at = 20,
126		#' gap_point = 260,
127		#' y_label = "Best % Change from Baseline",
128		#' title = "Waterfall Plot"
129		#' )
130		#'
131		g_waterfall <- function(bar_id,
132		bar_height,
133		sort_by = NULL,
134		col_by = NULL,
135		bar_color_opt = NULL,
136		anno_txt = NULL,
137		href_line = NULL,
138		facet_by = NULL,
139		show_datavalue = TRUE,
140		add_label = NULL,
141		gap_point = NULL,
142		ytick_at = 20,
143		y_label = "Best % Change from Baseline",
144		title = "Waterfall Plot") {
145		# check data
146	!	check_input_length <- c(nrow(data.frame(bar_id)), nrow(data.frame(bar_height)))
147
148	!	if (length(unique(check_input_length)) > 1) {
149	!	stop("invalid arguments: check that the length of input arguments are identical")
150		}
151
152	!	if (any(check_input_length == 0)) {
153	!	stop("invalid arguments: check that inputs are not null")
154		}
155
156	!	if (!is.null(bar_color_opt)) {
157	!	if (is.null(col_by)) {
158	!	col_by <- bar_id
159		} else {
160	!	ls1 <- levels(factor(col_by))
161	!	ls2 <- names(bar_color_opt)
162	!	if (length(intersect(ls1, ls2)) == 0) {
163	!	stop("invalid argument: check that the col_by and bar_color_opt have overlapping categories")
164	!	} else if (length(ls2) < length(ls1)) {
165	!	stop("invalid argument: More categories in col_by than the ones listed in bar_color_opt")
166		}
167		}
168		}
169
170	!	if (!is.null(sort_by)) check_same_N(bar_id = bar_id, bar_height = bar_height, sort_by = sort_by)
171	!	if (!is.null(col_by)) check_same_N(bar_id = bar_id, bar_height = bar_height, col_by = col_by)
172
173	!	facet_plot <- function(bar_id = bar_id,
174	!	bar_height = bar_height,
175	!	sort_by = sort_by,
176	!	col_by = col_by,
177	!	bar_color_opt = bar_color_opt,
178	!	anno_txt = anno_txt,
179	!	href_line = href_line,
180	!	facet_by = facet_by,
181	!	show_datavalue = show_datavalue,
182	!	add_label = add_label,
183	!	gap_point = gap_point,
184	!	ytick_at = ytick_at,
185	!	y_label = y_label,
186	!	title = title) {
187		# Data for plot
188	!	bar_data <- data.frame(
189	!	bar_id,
190	!	bar_height,
191	!	add_label = if (is.null(add_label)) to_n("x", length(bar_height)) else to_n(add_label, length(bar_height)),
192	!	sort_by = if (is.null(sort_by)) to_n("x", length(bar_height)) else to_n(sort_by, length(bar_height)),
193	!	col_by = if (is.null(col_by)) to_n("x", length(bar_height)) else to_n(col_by, length(bar_height))
194		)
195
196		# if sort by a variable, reorder bar_id by sort var and then bar length; otherwise sort by bar length
197	!	if (!is.null(sort_by)) {
198	!	bar_data$bar_id <- factor(
199	!	bar_data$bar_id,
200	!	levels = unique(bar_data$bar_id[order(bar_data$sort_by, bar_data$bar_height, decreasing = TRUE)])
201		)
202		} else {
203	!	bar_data$bar_id <- factor(
204	!	bar_data$bar_id,
205	!	levels = unique(bar_data$bar_id[order(bar_data$bar_height, decreasing = TRUE)])
206		)
207		}
208
209		# bar_id has already been sorted based on bar_height so keeping the 1st entry is equivalent to keeping
210		# the best % change from baseline
211	!	bar_data <- bar_data %>% distinct(bar_id, .keep_all = TRUE)
212
213		# plot bar plot
214	!	if (is.null(gap_point)) {
215	!	ybreaks <- seq(
216	!	ytick_at * floor(min(bar_data$bar_height, na.rm = TRUE) / ytick_at),
217	!	ytick_at * ceiling(max(bar_data$bar_height, na.rm = TRUE) / ytick_at),
218	!	by = ytick_at
219		)
220
221	!	p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_height)) +
222	!	geom_col(position = "identity", aes(fill = col_by)) +
223	!	scale_y_continuous(breaks = ybreaks) +
224	!	scale_x_discrete(expand = expansion(add = 0.5)) +
225	!	geom_hline(yintercept = 0, colour = "black") +
226	!	theme_bw() +
227	!	theme(
228	!	panel.background = element_blank(),
229	!	panel.grid = element_blank(),
230	!	axis.line = element_line(colour = "black"),
231	!	axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5),
232	!	axis.title.x = element_blank()
233		) +
234	!	ylab(y_label)
235	!	} else if (all(is.na(bar_data$bar_height))) {
236	!	ybreaks <- seq(ytick_at * -2, ytick_at * 2, by = ytick_at)
237
238	!	p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_height)) +
239	!	geom_col(position = "identity", aes(fill = col_by)) +
240	!	scale_y_continuous(breaks = ybreaks) +
241	!	scale_x_discrete(expand = expansion(add = 0.5)) +
242	!	geom_hline(yintercept = 0, colour = "black") +
243	!	theme_bw() +
244	!	theme(
245	!	panel.background = element_blank(),
246	!	panel.grid = element_blank(),
247	!	axis.line = element_line(colour = "black"),
248	!	axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5),
249	!	axis.title.x = element_blank()
250		) +
251	!	ylab(y_label)
252	!	} else if (max(bar_data$bar_height, na.rm = TRUE) <= gap_point) {
253	!	ybreaks <- seq(
254	!	ytick_at * floor(min(bar_data$bar_height, na.rm = TRUE) / ytick_at),
255	!	ytick_at * ceiling(max(bar_data$bar_height, na.rm = TRUE) / ytick_at),
256	!	by = ytick_at
257		)
258
259	!	p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_height)) +
260	!	geom_col(position = "identity", aes(fill = col_by)) +
261	!	scale_y_continuous(breaks = ybreaks) +
262	!	scale_x_discrete(expand = expansion(add = 0.5)) +
263	!	geom_hline(yintercept = 0, colour = "black") +
264	!	theme_bw() +
265	!	theme(
266	!	panel.background = element_blank(),
267	!	panel.grid = element_blank(),
268	!	axis.line = element_line(colour = "black"),
269	!	axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5),
270	!	axis.title.x = element_blank()
271		) +
272	!	ylab(y_label)
273		} else {
274	!	length_cut <- ytick_at *
275	!	floor(0.8 * (min(bar_data$bar_height[bar_data$bar_height > gap_point], na.rm = TRUE) - gap_point) / ytick_at)
276
277	!	cut_fun <- function(x) {
278	!	if (is.na(x)) {
279	!	x <- x
280	!	} else if (x > gap_point) {
281	!	x <- x - length_cut
282		} else {
283	!	x <- x
284		}
285		}
286
287	!	bar_data$new_bar_height <- sapply(bar_data$bar_height, cut_fun)
288
289	!	ylabel1 <- seq(
290	!	ytick_at * floor(min(bar_data$bar_height, na.rm = TRUE) / ytick_at),
291	!	ytick_at * floor(gap_point / ytick_at),
292	!	by = ytick_at
293		)
294	!	ylabel2 <- seq(
295	!	ytick_at * floor((gap_point + length_cut) / ytick_at),
296	!	ytick_at * ceiling(max(bar_data$bar_height, na.rm = TRUE) / ytick_at),
297	!	by = ytick_at
298		)
299
300	!	ybreaks <- seq(
301	!	ytick_at * floor(min(bar_data$new_bar_height, na.rm = TRUE) / ytick_at),
302	!	ytick_at * ceiling(max(bar_data$new_bar_height, na.rm = TRUE) / ytick_at),
303	!	by = ytick_at
304		)
305
306	!	if (length(ylabel1) + length(ylabel2) == length(ybreaks)) {
307	!	ylabels <- c(ylabel1, ylabel2)
308		} else {
309	!	dif <- length(ylabel1) + length(ylabel2) - length(ybreaks)
310	!	ylabel2 <- ylabel2[-(1:dif)] # nolint
311	!	ylabels <- c(ylabel1, ylabel2)
312		}
313
314	!	p <- ggplot(data = bar_data, aes(x = bar_id, y = .data$new_bar_height)) +
315	!	geom_col(position = "identity", aes(fill = col_by)) +
316	!	geom_rect(aes(xmin = 0.5, xmax = length(bar_id), ymin = gap_point, ymax = gap_point + 3), fill = "white") +
317	!	scale_y_continuous(breaks = ybreaks, labels = ylabels) +
318	!	scale_x_discrete(expand = expansion(add = 0.5)) +
319	!	geom_hline(yintercept = 0, colour = "black") +
320	!	theme_bw() +
321	!	theme(
322	!	panel.background = element_blank(),
323	!	panel.grid = element_blank(),
324	!	axis.line = element_line(colour = "black"),
325	!	axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5),
326	!	axis.title.x = element_blank()
327		) +
328	!	ylab(y_label)
329		}
330
331	!	if (show_datavalue == TRUE) {
332	!	p <- p + geom_text(
333	!	label = format(bar_data$bar_height, digits = 1),
334	!	size = 2.5,
335	!	vjust = ifelse(bar_data$bar_height >= 0, -0.5, 1.5)
336		)
337		}
338
339	!	if (!is.null(add_label)) {
340	!	p <- p + geom_text(
341	!	aes(x = bar_id, y = 0, label = add_label),
342	!	size = 3,
343	!	vjust = ifelse(bar_data$bar_height >= 0, 1.5, -0.5)
344		)
345		}
346
347	!	if (is.null(col_by)) {
348	!	p <- p + guides(fill = "none")
349		} else {
350	!	p <- p + guides(fill = guide_legend("Bar Color", order = 1, ncol = 1)) +
351	!	theme(
352	!	legend.title = element_text(size = 9),
353	!	legend.text = element_text(size = 9),
354	!	legend.key = element_rect(fill = NA)
355		)
356		}
357
358	!	if (is.null(bar_color_opt) && !is.null(getOption("ggplot2.discrete.colour"))) {
359	!	bar_color_opt <- getOption("ggplot2.discrete.colour")
360		}
361	!	if (!is.null(bar_color_opt)) {
362	!	p <- p + scale_fill_manual(values = bar_color_opt)
363		}
364
365		# plot reference lines
366	!	if (!is.null(href_line)) {
367	!	p <- p + geom_hline(yintercept = href_line, linetype = "dashed", color = "red")
368		}
369
370		# add plot title
371	!	if (is.null(facet_by)) {
372	!	p <- p +
373	!	labs(title = title) +
374	!	theme(plot.title = element_text(face = "bold"))
375		} else {
376	!	p <- p +
377	!	labs(title = paste(title, "-", as.character(unique(facet_by)))) +
378	!	theme(plot.title = element_text(face = "bold"))
379		}
380
381	!	if (!is.null(anno_txt)) {
382	!	t_anno <- data.frame(
383	!	bar_id,
384	!	bar_height,
385	!	sort_by = if (is.null(sort_by)) to_n("x", length(bar_height)) else to_n(sort_by, length(bar_height)),
386	!	anno_txt
387		)
388
389		# if sort by a variable, reorder bar_id; otherwise sort by bar length
390	!	if (!is.null(sort_by)) {
391	!	t_anno$bar_id <- factor(
392	!	t_anno$bar_id,
393	!	levels = unique(t_anno$bar_id[order(t_anno$sort_by, t_anno$bar_height, decreasing = TRUE)])
394		)
395		} else {
396	!	t_anno$bar_id <- factor(
397	!	t_anno$bar_id,
398	!	levels = unique(t_anno$bar_id[order(t_anno$bar_height, decreasing = TRUE)])
399		)
400		}
401
402		# bar_id has already been sorted based on bar_height so keeping the 1st entry is equivalent to keeping
403		# the best % change from baseline
404	!	t_anno <- t_anno %>% distinct(bar_id, .keep_all = TRUE)
405	!	t_anno <- t_anno[order(t_anno$bar_id), ]
406	!	t_anno <- t_anno[, -c(1, 2, 3)]
407
408	!	t_anno <- t(t_anno)
409
410	!	my_theme <- gridExtra::ttheme_default(
411	!	core = list(bg_params = list(fill = NA, col = NA), fg_params = list(cex = 0.8)),
412	!	rowhead = list(bg_params = list(fill = NA, col = NA), fg_params = list(cex = 0.8)),
413	!	padding = grid::unit(c(0, 4), "mm")
414		)
415
416	!	tb <- gridExtra::tableGrob(
417	!	t_anno,
418	!	rows = NULL,
419	!	cols = NULL,
420	!	theme = my_theme
421		)
422
423	!	tb$widths <- grid::unit(rep(1 / (ncol(tb)), ncol(tb)), "null")
424	!	tb <- gtable::gtable_add_grob(
425	!	tb,
426	!	grobs = grid::rectGrob(gp = grid::gpar(fill = NA, lwd = 2)),
427	!	t = 1, b = nrow(tb), l = 1, r = ncol(tb)
428		)
429
430	!	t_anno_name <- names(anno_txt)
431	!	tb_rowname <- gridExtra::tableGrob(
432	!	t_anno_name,
433	!	rows = NULL,
434	!	cols = NULL,
435	!	theme = gridExtra::ttheme_minimal(
436	!	core = list(bg_params = list(fill = NA, col = NA), fg_params = list(cex = 0.8))
437		)
438		)
439
440		# grab plot and table as one plot
441	!	g0 <- ggplotGrob(p)
442	!	g1 <- gtable::gtable_add_rows(g0, sum(tb$heights), pos = -1)
443	!	g2 <- gtable::gtable_add_grob(
444	!	g1,
445	!	tb,
446	!	t = -1,
447	!	l = g1$layout[g1$layout$name == "panel", 2],
448	!	r = g1$layout[g1$layout$name == "panel", 4]
449		)
450	!	g3 <- gtable::gtable_add_cols(g2, tb_rowname$widths, pos = 0)
451	!	g <- gtable::gtable_add_grob(g3, tb_rowname, t = -1, l = 2)
452		} else {
453	!	p <- p +
454	!	theme(axis.title.x = element_text()) +
455	!	labs(x = "Unique Subject ID")
456	!	g <- ggplotGrob(p)
457		}
458	!	g
459		}
460
461	!	if (is.null(facet_by)) {
462	!	gt <- facet_plot(
463	!	bar_id = bar_id,
464	!	bar_height = bar_height,
465	!	sort_by = sort_by,
466	!	col_by = col_by,
467	!	bar_color_opt = bar_color_opt,
468	!	anno_txt = anno_txt,
469	!	href_line = href_line,
470	!	facet_by = facet_by,
471	!	show_datavalue = show_datavalue,
472	!	add_label = add_label,
473	!	gap_point = gap_point,
474	!	ytick_at = ytick_at,
475	!	y_label = y_label,
476	!	title = title
477		)
478		} else {
479	!	facet_by <- factor(facet_by)
480	!	g_list <- rep(list(NA), length(levels(facet_by)))
481	!	for (i in seq_along(levels(facet_by))) {
482	!	facet_level <- levels(facet_by)[i]
483	!	g_list[[i]] <- facet_plot(
484	!	bar_id = bar_id[facet_by == facet_level],
485	!	bar_height = bar_height[facet_by == facet_level],
486	!	sort_by = sort_by[facet_by == facet_level],
487	!	col_by = col_by[facet_by == facet_level],
488	!	bar_color_opt = bar_color_opt,
489	!	anno_txt = anno_txt[facet_by == facet_level, , drop = FALSE],
490	!	href_line = href_line,
491	!	facet_by = facet_by[facet_by == facet_level],
492	!	show_datavalue = show_datavalue,
493	!	add_label = add_label[facet_by == facet_level],
494	!	gap_point = gap_point,
495	!	ytick_at = ytick_at,
496	!	y_label = y_label,
497	!	title = title
498		)
499		}
500
501	!	gt <- gridExtra::grid.arrange(grobs = g_list, ncol = 1, nrow = length(levels(facet_by)))
502		}
503
504	!	grid::grid.newpage()
505	!	grid::grid.draw(gt)
506	!	invisible(gt)
507		}

1		#' Output decorated grob (`gTree`) objects as PDF
2		#'
3		#' This is an utility function to output a decorated grob (`gTree`) object
4		#'
5		#' @param grobs a grid grob (`gTree`) object, optionally `NULL` if only a grob with
6		#' the decoration should be shown.
7		#' @param outpath specify full path to output pdf to `BCE` or `BEE`
8		#' @param pagesize name of `pagesize` (print size) and orientation, accepted values include
9		#' \code{"a4.landscape"}, \code{"a4.portrait"}, \code{"letter.portrait"} and
10		#' \code{"letter.landscape"} (default)
11		#'
12		#' @return a pdf file
13		#' @seealso [grobs2pdf()]
14		#' @export
15		#'
16		#' @author Chendi Liao (liaoc10) \email{chendi.liao@roche.com}
17		#'
18		#' @examples
19		#' \dontrun{
20		#' library(ggplot2)
21		#'
22		#' g <- list(
23		#' ggplotGrob(
24		#' ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species)) +
25		#' geom_point()
26		#' ),
27		#' ggplotGrob(
28		#' ggplot(iris, aes(x = Sepal.Length, y = Petal.Length, color = Species)) +
29		#' geom_point()
30		#' ),
31		#' ggplotGrob(
32		#' ggplot(iris, aes(x = Sepal.Length, y = Petal.Width, color = Species)) +
33		#' geom_point()
34		#' )
35		#' )
36		#'
37		#' # output to pdf
38		#' as_pdf(g, "~/example_aspdf1.pdf")
39		#' }
40		as_pdf <- function(grobs,
41		outpath,
42		pagesize = "letter.landscape") {
43	!	paper_sizes <- paper_size(pagesize)
44	!	paper_width <- paper_sizes[1]
45	!	paper_height <- paper_sizes[2]
46
47		# Output to PDF
48	!	grDevices::pdf(outpath, width = paper_width, height = paper_height)
49
50	!	lapply(grobs, function(x) {
51	!	grid::grid.newpage()
52	!	grid::grid.draw(x)
53		})
54
55	!	grDevices::dev.off()
56		}
57
58		paper_size <- function(pagesize) {
59	!	if (pagesize == "a4.landscape") {
60	!	paper_width <- 11.7
61	!	paper_height <- 8.3
62	!	} else if (pagesize == "a4.portrait") {
63	!	paper_width <- 8.3
64	!	paper_height <- 11.7
65	!	} else if (pagesize == "letter.portrait") {
66	!	paper_width <- 8.5
67	!	paper_height <- 11
68	!	} else if (pagesize == "letter.landscape") {
69	!	paper_width <- 11
70	!	paper_height <- 8.5
71		} else {
72	!	paper_width <- 11
73	!	paper_height <- 8.5
74		}
75	!	return(c(paper_width, paper_height))
76		}
77
78		#' Decorate grob (`gTree`) objects then outputs as `IDM` compatible PDF
79		#'
80		#' This is an utility function to decorated grob (`gTree`) object with titles and
81		#' footnotes in accordance with `IDM` specification and export as PDF file with
82		#' full path to program and the output for easy tracking and archiving.
83		#'
84		#' @param grobs A grid grob (`gTree`) object, optionally `NULL` if only a
85		#' grob with the decoration should be shown
86		#' @param titles Vector of character strings. Vector elements are separated by a
87		#' newline and strings are wrapped according to the page with
88		#' @param footnotes Vector of character string. Same rules as for \code{titles}
89		#' @param progpath Specify the full path to the R program that generate the
90		#' grobs and the PDF
91		#' @param outpath Specify full path to output pdf to `BCE` or `BEE`
92		#' @param fontsize Base font size used in pdf, default set to 9. Font size for
93		#' title is set to \code{fontsize} + 1 (default = 10) and for footnotes set to
94		#' \code{fontsize} - 1 (default = 8)
95		#' @param pagesize name of paper size and orientation, accepted values include
96		#' \code{"a4.landscape"}, \code{"a4.portrait"}, \code{"letter.portrait"} and
97		#' \code{"letter.landscape"} (default)
98		#'
99		#' @return a pdf file
100		#'
101		#' @export
102		#'
103		#' @author Chendi Liao (liaoc10) \email{chendi.liao@roche.com}
104		#'
105		#' @examples
106		#' \dontrun{
107		#' library(ggplot2)
108		#'
109		#' g <- list(
110		#' ggplotGrob(
111		#' ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species)) +
112		#' geom_point()
113		#' ),
114		#' ggplotGrob(
115		#' ggplot(iris, aes(x = Sepal.Length, y = Petal.Length, color = Species)) +
116		#' geom_point()
117		#' ),
118		#' ggplotGrob(
119		#' ggplot(iris, aes(x = Sepal.Length, y = Petal.Width, color = Species)) +
120		#' geom_point()
121		#' )
122		#' )
123		#'
124		#' grobs2pdf(
125		#' grobs = g,
126		#' titles = "Visualization of Iris Data",
127		#' footnotes = "This is a footnote",
128		#' progpath = "~/example_prog.R",
129		#' outpath = "~/example_grobs2pdf.pdf"
130		#' )
131		#' }
132		#'
133		grobs2pdf <- function(grobs,
134		titles,
135		footnotes,
136		progpath,
137		outpath,
138		fontsize = 9,
139		pagesize = "letter.landscape") {
140	!	if (!requireNamespace("tern", quietly = TRUE)) {
141	!	stop("This function requires the R package tern to be available - please install the package.")
142		}
143
144		# Loads rapid.base.settings list and a few other
145
146		# Page type (default is letter.landscape, options=a4.portrait, a4.landscape, letter.portrait, letter.landscape)
147	!	if (pagesize == "a4.landscape") {
148	!	top_margin <- 1.44
149	!	bottom_margin <- 0.83
150	!	left_margin <- 1.3
151	!	right_margin <- 1.32
152	!	} else if (pagesize == "a4.portrait") {
153	!	top_margin <- 1.32
154	!	bottom_margin <- 1.3
155	!	left_margin <- 1.44
156	!	right_margin <- 0.83
157	!	} else if (pagesize == "letter.portrait") {
158	!	top_margin <- 0.95
159	!	bottom_margin <- 0.98
160	!	left_margin <- 1.5
161	!	right_margin <- 1.0
162	!	} else if (pagesize == "letter.landscape") {
163	!	top_margin <- 1.5
164	!	bottom_margin <- 1.0
165	!	left_margin <- 0.98
166	!	right_margin <- 0.95
167		} else {
168	!	top_margin <- 1.5
169	!	bottom_margin <- 1.0
170	!	left_margin <- 0.98
171	!	right_margin <- 0.95
172		}
173
174	!	paper_sizes <- paper_size(pagesize)
175	!	paper_width <- paper_sizes[1]
176	!	paper_height <- paper_sizes[2]
177
178		## Adding log text to footnotes
179	!	log1 <- paste0("Program: ", progpath, "; Output: ", outpath) # nolint
180	!	log2 <- paste0(format(Sys.time(), "%d%b%Y %H:%M %Z"), ", generated by ", Sys.getenv("USER")) # nolint
181	!	logtext <- paste(mget(ls(pattern = "log")), collapse = "\n")
182
183		## Make the grobs
184	!	if (!is.list(grobs)) {
185	!	grobs <- list(grobs)
186		}
187
188		## Decorate grobs
189	!	dg <- tern::decorate_grob_set(
190	!	grobs = grobs,
191	!	titles = titles,
192	!	footnotes = paste(footnotes, logtext, sep = "\n\n"),
193	!	outer_margins = grid::unit(c(0, 0, 0, 0), "lines"),
194	!	padding = grid::unit(0.5, "lines"),
195	!	gp_titles = grid::gpar(fontsize = fontsize + 1, fontface = 2, lineheight = 1),
196	!	gp_footnotes = grid::gpar(fontsize = fontsize - 1, fontface = 1, lineheight = 1),
197	!	gp = grid::gpar(fontsize = fontsize),
198	!	vp = grid::viewport(
199	!	x = grid::unit(left_margin, "inches"),
200	!	y = grid::unit(bottom_margin, "inches"),
201	!	width = grid::unit(paper_width - left_margin - right_margin, "inches"),
202	!	height = grid::unit(paper_height - top_margin - bottom_margin, "inches"),
203	!	just = c("left", "bottom"),
204	!	name = "OuterMargin"
205		)
206		)
207
208		# Output as PDF
209	!	as_pdf(
210	!	grobs = dg,
211	!	outpath = outpath,
212	!	pagesize = pagesize
213		)
214		}
215
216		#' Add padding to grob
217		#' @param grob grob object
218		#' @param pad_v padding to add vertically
219		#' @param pad_h padding to add horizontally
220		#' @keywords internal
221		#'
222		grob_add_padding <- function(grob, pad_v = grid::unit(5, "pt"), pad_h = grid::unit(5, "pt")) {
223	!	ret <- gtable::gtable(
224	!	heights = grid::unit.c(pad_v, grid::unit(1, "null"), pad_v),
225	!	widths = grid::unit.c(pad_h, grid::unit(1, "null"), pad_h)
226		)
227		# t, b, l, r, z arguments do not need modification
228		# same effect can be achieved by modifying pad_v and pad_h
229	!	ret <- gtable::gtable_add_grob(ret, grob, t = 2, b = 2, l = 2, r = 2, z = 1, name = "panel")
230	!	ret <- gtable::gtable_add_grob(ret, grid::rectGrob(), t = 1, b = 3, l = 1, r = 3, z = 0, name = "background")
231	!	return(ret)
232		}
233
234		#' this theme is used across many figures. can be safely removed if update the theme in each function
235		#' @param axis_side axis position
236		#' @param fontsize font size in 'mm'
237		#' @keywords internal
238		#'
239		theme_osprey <- function(axis_side = "left", fontsize = 4) {
240		theme(
241		panel.background = element_rect(fill = "white", colour = "white"),
242		panel.grid.major.y = element_line(colour = "grey50", linetype = 2),
243		panel.border = element_rect(colour = "black", fill = NA, linewidth = 1),
244		axis.title = element_blank(),
245		legend.title = element_blank(),
246		legend.position = "bottom",
247		axis.ticks.y = element_blank(),
248		axis.text = element_text(color = "black", size = fontsize * .pt),
249		axis.text.y = element_text(hjust = ifelse(axis_side == "left", 1, 0)),
250		text = element_text(size = fontsize * .pt, face = "bold", color = "black"),
251		legend.text = element_text(size = fontsize * .pt),
252		plot.title = element_text(hjust = 0.5)
253		)
254		}
255
256		check_same_N <- function(..., omit_null = TRUE) { # nolint
257	!	dots <- list(...)
258
259	!	n_list <- Map(
260	!	function(x, name) {
261	!	if (is.null(x)) {
262	!	if (omit_null) {
263	!	NA_integer_
264		} else {
265	!	stop("arg", name, "is not supposed to be NULL")
266		}
267	!	} else if (is.data.frame(x)) {
268	!	nrow(x)
269	!	} else if (is.atomic(x)) {
270	!	length(x)
271		} else {
272	!	stop("data structure for ", name, "is currently not supported")
273		}
274		},
275	!	dots, names(dots)
276		)
277
278	!	n <- stats::na.omit(unlist(n_list))
279
280	!	if (length(unique(n)) > 1) {
281	!	sel <- which(n != n[1])
282	!	stop("dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
283		}
284
285	!	TRUE
286		}
287
288		to_n <- function(x, n) {
289	!	if (is.null(x)) {
290	!	NULL
291	!	} else if (length(x) == 1) {
292	!	rep(x, n)
293	!	} else if (length(x) == n) {
294	!	x
295		} else {
296	!	stop("dimension mismatch")
297		}
298		}
299
300		#' Extract specific part of a `ggplot` or grob
301		#'
302		#' @param gplot_grob `ggplot` or grob object
303		#' @param part name of the part to be extracted. `NA` will return `zeroGrob()`
304		#' @keywords internal
305		#'
306		grob_part <- function(gplot_grob, part) {
307	!	if (is.na(part)) {
308	!	return(zeroGrob())
309		}
310	!	stopifnot(length(part) == 1 && is.character(part))
311	!	index <- match(part, gplot_grob$layout$name)
312	!	if (is.na(index)) {
313	!	stop(c(
314	!	part, " not in plot object. Allowed parts are ",
315	!	paste(gplot_grob$layout$name, collapse = ", ")
316		))
317		}
318	!	grob <- gplot_grob$grobs[[index]]
319
320	!	return(grob)
321		}
322
323		#' Extract specific parts of a `ggplot` or grob
324		#'
325		#' @param gplot `ggplot` or grob object
326		#' @param parts names vector of the parts to be extracted.
327		#' @keywords internal
328		#'
329		grob_parts <- function(gplot, parts) {
330	!	stopifnot("gplot must inherit from class 'ggplot' or 'grob'" = inherits(gplot, c("ggplot", "grob")))
331
332	!	if (is(gplot, "ggplot")) {
333	!	gplot_grob <- ggplotGrob(gplot)
334	!	} else if (is(gplot, "grob")) {
335	!	gplot_grob <- gplot
336		}
337	!	ret <- lapply(parts, grob_part, gplot_grob = gplot_grob)
338	!	names(ret) <- parts
339	!	return(ret)
340		}
341
342
343		#' this theme is used across many figures. can be safely removed if update the theme in each function
344		#' @param axis_side axis position
345		#' @param fontsize font size in 'mm'
346		#' @param blank whether to have blank or background with grids and borders
347		theme_osprey <- function(axis_side = "left", fontsize = 4, blank = FALSE) {
348	!	theme(
349	!	panel.background = element_rect(fill = "white", colour = "white"),
350	!	panel.grid.major.y = if (blank) element_blank() else element_line(colour = "grey50", linetype = 2),
351	!	panel.border = if (blank) element_blank() else element_rect(colour = "black", fill = NA, linewidth = 1),
352	!	axis.title = element_blank(),
353	!	legend.title = element_blank(),
354	!	legend.position = "bottom",
355	!	axis.ticks.y = element_blank(),
356	!	axis.ticks.x.top = element_blank(),
357	!	axis.text = element_text(color = "black", size = fontsize * .pt),
358	!	axis.text.y = element_text(hjust = ifelse(axis_side == "left", 0, 1)),
359	!	text = element_text(size = fontsize * .pt, face = "bold", color = "black"),
360	!	legend.text = element_text(size = fontsize * .pt),
361	!	plot.title = element_text(hjust = 0.5)
362		)
363		}

1		#' Heatmap by Grade
2		#'
3		#' This function plots heatmap
4		#'
5		#' @param id_var (`character`)\cr name of the column that contains the unique subject identifier shared by all data
6		#' Usually it is \code{"USUBJID"}.
7		#' @param exp_data (`data.frame`)\cr exposure data. Usually it is \code{ADEX}.
8		#' @param visit_var (`character`)\cr name of the column that contains the analysis visit. Usually it is \code{"AVISIT"}
9		#' @param ongo_var (`character`)\cr name of the column in \code{exp_data} that contains the logical variable
10		#' indicating whether the treatment is still ongoing.
11		#' Usually it can be derived from \code{EOSSTT}
12		#' @param anno_data (`data.frame`)\cr annotation data that contains subject level characteristics.
13		#' Usually it is \code{ADSL}
14		#' @param anno_var (`character`) a vector of columns name(s) to include for the annotation
15		#' @param heat_data (`data.frame`)\cr data frame that contains the information needed for the text over heatmap
16		#' Usually it is \code{ADCM}.
17		#' @param heat_color_var (`character`)\cr name of the column that contains the heat grade
18		#' @param heat_color_opt optional, (`character`)\cr a named vector that maps the names to heat colors
19		#' @param conmed_data optional, (`data.frame`)\cr concomitant medicine data. Usually it is \code{ADCM}
20		#' default is `NULL` (no `conmed` plotted)
21		#' @param conmed_var optional, (`character`)\cr concomitant medicine variable name. Must be a column name in
22		#' `conmed_data` when `conmed_data` is provided. default is `NULL` (no `conmed` plotted)
23		#' @param conmed_color_opt optional, (`character`)\cr vector of color name(s) to `conmed_data`
24		#' @param xlab optional, (`character`)\cr string to be shown as x-axis label, default is \code{"Visit"}
25		#' @param title (`character`)\cr string to be shown as title of the plot.
26		#' default is `NULL` (no plot title is displayed)
27		#'
28		#' @export
29		#'
30		#' @author Nina Qi (qit3) \email{qit3@gene.com}
31		#' @author Molly He (hey59) \email{hey59@gene.com}
32		#'
33		#' @examples
34		#' library(dplyr)
35		#'
36		#' ADSL <- osprey::rADSL %>% slice(1:30)
37		#' ADEX <- osprey::rADEX %>% filter(USUBJID %in% ADSL$USUBJID)
38		#' ADAE <- osprey::rADAE %>% filter(USUBJID %in% ADSL$USUBJID)
39		#' ADCM <- osprey::rADCM %>% filter(USUBJID %in% ADSL$USUBJID)
40		#' # function to derive AVISIT from ADEX
41		#' add_visit <- function(data_need_visit) {
42		#' visit_dates <- ADEX %>%
43		#' filter(PARAMCD == "DOSE") %>%
44		#' distinct(USUBJID, AVISIT, ASTDTM) %>%
45		#' group_by(USUBJID) %>%
46		#' arrange(ASTDTM) %>%
47		#' mutate(next_vis = lead(ASTDTM), is_last = ifelse(is.na(next_vis), TRUE, FALSE)) %>%
48		#' rename(this_vis = ASTDTM)
49		#' data_visit <- data_need_visit %>%
50		#' select(USUBJID, ASTDTM) %>%
51		#' left_join(visit_dates, by = "USUBJID", relationship = "many-to-many") %>%
52		#' filter(ASTDTM > this_vis & (ASTDTM < next_vis \| is_last == TRUE)) %>%
53		#' left_join(data_need_visit, relationship = "many-to-many")
54		#' return(data_visit)
55		#' }
56		#' # add AVISIT in ADAE and ADCM
57		#' ADAE <- add_visit(ADAE)
58		#' ADCM <- add_visit(ADCM)
59		#' exp_data <- ADEX %>%
60		#' filter(PARCAT1 == "INDIVIDUAL") %>%
61		#' group_by(USUBJID) %>%
62		#' # create a shorter subject identifier
63		#' mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1)) %>%
64		#' mutate(ongo_var = (EOSSTT == "ONGOING")) %>%
65		#' ungroup()
66		#' anno_data <- ADSL %>%
67		#' select(SEX, COUNTRY, USUBJID) %>%
68		#' group_by(USUBJID) %>%
69		#' mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1)) %>%
70		#' ungroup() %>%
71		#' select(-USUBJID)
72		#' heat_data <- ADAE %>%
73		#' select(USUBJID, AVISIT, AETOXGR) %>%
74		#' group_by(USUBJID) %>%
75		#' mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1)) %>%
76		#' ungroup() %>%
77		#' select(-USUBJID)
78		#' heat_color_opt <- c(
79		#' "No Event" = "gray90",
80		#' "1" = "lightsteelblue1",
81		#' "2" = "steelblue1",
82		#' "3" = "steelblue4",
83		#' "4" = "maroon",
84		#' "5" = "brown4"
85		#' )
86		#' cmdecod_label <- attr(ADCM[["CMDECOD"]], "label")
87		#' ADCM <- ADCM %>%
88		#' filter(
89		#' CMDECOD == "medname A_1/3" \| CMDECOD == "medname A_2/3" \| CMDECOD == "medname A_3/3"
90		#' ) %>%
91		#' mutate(CMDECOD = factor(CMDECOD, levels = unique(CMDECOD)))
92		#' attr(ADCM[["CMDECOD"]], "label") <- cmdecod_label
93		#' conmed_data <- ADCM %>%
94		#' group_by(USUBJID) %>%
95		#' mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1))
96		#' # example plotting conmed
97		#' g_heat_bygrade(
98		#' id_var = "SUBJ",
99		#' exp_data,
100		#' visit_var = "AVISIT",
101		#' ongo_var = "ongo_var",
102		#' anno_data,
103		#' anno_var = c("SEX", "COUNTRY"),
104		#' heat_data,
105		#' heat_color_var = "AETOXGR",
106		#' heat_color_opt,
107		#' conmed_data,
108		#' conmed_var = "CMDECOD",
109		#' conmed_color_opt = c("green", "green3", "green4")
110		#' )
111		#' # example not plotting conmed
112		#' g_heat_bygrade(
113		#' id_var = "SUBJ",
114		#' exp_data,
115		#' visit_var = "AVISIT",
116		#' ongo_var = "ongo_var",
117		#' anno_data,
118		#' anno_var = c("SEX", "COUNTRY"),
119		#' heat_data,
120		#' heat_color_var = "AETOXGR",
121		#' heat_color_opt
122		#' )
123		#'
124		g_heat_bygrade <- function(id_var,
125		exp_data,
126		visit_var,
127		ongo_var,
128		anno_data,
129		anno_var,
130		heat_data,
131		heat_color_var,
132		heat_color_opt = NULL,
133		conmed_data = NULL,
134		conmed_var = NULL,
135		conmed_color_opt = NULL,
136		xlab = "Visit",
137		title = NULL) {
138		# check if all PARCAT1 in exp_data is "individual"
139	!	checkmate::assert_string(id_var)
140	!	checkmate::assert_data_frame(exp_data)
141	!	stopifnot(
142	!	"invalid argument: please only include 'INDIVIDUAL' record in exp_data" = !is.na(exp_data[[visit_var]])
143		)
144	!	checkmate::assert_string(visit_var)
145	!	checkmate::assert_string(ongo_var)
146	!	checkmate::assert(
147	!	combine = "and",
148	!	checkmate::check_choice(ongo_var, names(exp_data)),
149	!	checkmate::check_logical(exp_data[[ongo_var]])
150		)
151	!	checkmate::assert_data_frame(anno_data)
152	!	stopifnot(
153	!	"invalid argument: anno_data can only contain 3 or less columns including subject ID" = length(anno_var) <= 2
154		)
155	!	checkmate::assert_data_frame(heat_data)
156	!	checkmate::assert_choice(heat_color_var, names(heat_data))
157	!	stopifnot(
158	!	"invalid argument: need to provide conmed_data and conmed_var" =
159	!	any(is.null(conmed_data), is.null(conmed_data) == is.null(conmed_var))
160		)
161	!	checkmate::assert_choice(conmed_var, names(conmed_data), null.ok = TRUE)
162	!	stopifnot(
163	!	"invalid argument: please only include no more than three conmeds for plotting" =
164	!	is.null(conmed_var) \|\| length(levels(conmed_data[[conmed_var]])) <= 3
165		)
166	!	stopifnot(
167	!	"invalid argument: please specify conmed_color_opt for all unique conmed_var" =
168	!	is.null(conmed_data) \|\|
169	!	is.null(conmed_color_opt) \|\| # nolint indentation_linter
170	!	length(conmed_color_opt) == length(unique(conmed_data[[conmed_var]]))
171		)
172
173		if (
174		!(
175	!	(is.null(conmed_data) \|\| id_var %in% names(conmed_data)) &&
176	!	id_var %in% names(exp_data) && id_var %in% names(anno_data) && id_var %in% names(heat_data)
177		)
178		) {
179	!	stop(
180	!	paste(
181	!	"exp_data, anno_data, heat_data, and conmed_data (if plotting conmed) must include a column named",
182	!	id_var,
183	!	sep = " "
184		)
185		)
186		}
187		if (
188		!(
189	!	(is.null(conmed_data) \|\| visit_var %in% names(conmed_data)) &&
190	!	visit_var %in% names(exp_data) && visit_var %in% names(heat_data)
191		)
192		) {
193	!	stop(
194	!	paste(
195	!	"exp_data, heat_data, and conmed_data (if plotting conmed) must include a column named",
196	!	visit_var,
197	!	sep = " "
198		)
199		)
200		}
201
202	!	anl_data <- exp_data %>%
203	!	select(!!id_var, !!sym(visit_var)) %>%
204	!	left_join(heat_data, by = c(id_var, visit_var)) %>%
205	!	distinct() %>%
206	!	mutate(heat_color_num = tidyr::replace_na(as.numeric(.data[[heat_color_var]]), 0)) %>%
207	!	group_by(!!sym(id_var), !!sym(visit_var)) %>%
208	!	arrange(!!sym(visit_var)) %>%
209	!	mutate(heat_color_max = factor(max(.data$heat_color_num), levels = 0:5)) %>%
210	!	select(-(!!heat_color_var), -"heat_color_num") %>% # nolint
211	!	distinct() %>%
212	!	left_join(anno_data, by = id_var)
213
214		# dose reduction data
215	!	ex_red <- exp_data %>%
216	!	filter(.data$PARAMCD == "DOSE") %>%
217	!	group_by(!!sym(id_var)) %>%
218	!	arrange(.data$ASTDTM) %>%
219	!	mutate(
220	!	RANK = order(.data$ASTDTM),
221	!	LASTDOSE = lag(.data$AVAL),
222	!	DOSERED = ifelse(.data$RANK != 1 & .data$AVAL < .data$LASTDOSE, TRUE, FALSE)
223		) %>%
224	!	select(!!sym(id_var), !!sym(visit_var), "RANK", "AVAL", "LASTDOSE", "DOSERED") %>%
225	!	filter(.data$DOSERED == TRUE)
226		# does ongoing data
227	!	exp_lst <- exp_data %>%
228	!	filter(.data$PARAMCD == "DOSE") %>%
229	!	filter(!!sym(ongo_var) == TRUE) %>%
230	!	group_by(!!sym(id_var)) %>%
231	!	arrange(!!sym(visit_var)) %>%
232	!	slice_tail() %>%
233	!	select(!!sym(id_var), !!sym(visit_var))
234	!	visit_levels <- unique(anl_data[[visit_var]])
235	!	if (!is.null(conmed_data) && !is.null(conmed_var)) {
236	!	conmed_data <- conmed_data %>%
237	!	left_join(anl_data, by = c(id_var, visit_var)) %>%
238	!	ungroup() %>%
239	!	mutate(
240	!	conmed_num = as.numeric(.data[[conmed_var]]),
241	!	conmed_num_m = stats::median(unique(.data$conmed_num), na.rm = TRUE)
242		) %>%
243	!	mutate(
244	!	distance = (ifelse(
245	!	.data$conmed_num <= .data$conmed_num_m,
246	!	.data$conmed_num - 1,
247	!	.data$conmed_num + 1
248	!	) - .data$conmed_num_m) / 5,
249	!	conmed_x = as.numeric(!!sym(visit_var)) + .data$distance
250		)
251		}
252	!	subj_levels <- unique(anl_data[[id_var]])
253	!	levels(anl_data$heat_color_max)[levels(anl_data$heat_color_max) == "0"] <- "No Event"
254	!	p <- ggplot(
255	!	data = anl_data,
256	!	aes(x = !!sym(visit_var), y = factor(!!sym(id_var), levels = c(rev(subj_levels), "")))
257		) +
258	!	geom_tile(aes(fill = .data$heat_color_max)) +
259	!	scale_y_discrete(drop = FALSE) +
260	!	scale_fill_discrete(
261	!	name = "Highest grade of\nindividual events",
262	!	type = if (!is.null(heat_color_opt)) {
263	!	heat_color_opt
264		} else {
265	!	if (!is.null(getOption("ggplot2.discrete.colour"))) {
266	!	rev(grDevices::hcl.colors(6, palette = "peach"))
267		} else {
268	!	rev(grDevices::terrain.colors(6))
269		}
270		}
271		) +
272		# plot dose reduction
273	!	geom_segment(
274	!	data = ex_red,
275	!	aes(
276	!	y = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))) + 0.3,
277	!	x = as.numeric(factor(!!sym(visit_var), levels = visit_levels)),
278	!	yend = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))) - 0.3,
279	!	xend = as.numeric(factor(!!sym(visit_var), levels = visit_levels))
280		),
281	!	arrow = arrow(length = grid::unit(0.1, "cm")),
282	!	linewidth = .5,
283	!	color = "black"
284		) +
285		# plot ongoing
286	!	geom_segment(
287	!	data = exp_lst,
288	!	aes(
289	!	x = as.numeric(factor(!!sym(visit_var), levels = visit_levels)) + 0.5,
290	!	xend = as.numeric(factor(!!sym(visit_var), levels = visit_levels)) + 0.65,
291	!	y = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))),
292	!	yend = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels)))
293		),
294	!	arrow = arrow(length = grid::unit(0.1, "cm")),
295	!	linewidth = .5,
296	!	color = "black"
297		)
298	!	if (!is.null(conmed_data) && !is.null(conmed_var)) {
299	!	p <- p +
300	!	geom_point(
301	!	data = conmed_data,
302	!	aes(
303	!	x = .data$conmed_x,
304	!	y = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))),
305	!	shape = .data[[conmed_var]],
306	!	color = .data[[conmed_var]]
307		),
308	!	size = 2
309		) +
310	!	scale_colour_manual(
311	!	name = attr(conmed_data[[conmed_var]], "label"),
312	!	values = if (!is.null(conmed_color_opt)) {
313	!	conmed_color_opt
314		} else {
315	!	if (!is.null(getOption("ggplot2.discrete.colour"))) {
316	!	getOption("ggplot2.discrete.colour")[-2]
317		} else {
318	!	rep("black", 5)
319		}
320		}
321		) +
322	!	scale_shape_manual(
323	!	name = attr(conmed_data[[conmed_var]], "label"),
324	!	values = c(15:17)
325		)
326		}
327
328	!	p <- p +
329	!	theme_bw() +
330	!	theme(
331	!	panel.background = element_blank(),
332	!	panel.grid = element_blank(),
333	!	axis.line = element_line(colour = "black"),
334	!	axis.text.x = element_text(angle = 90),
335	!	axis.text.y = element_blank(),
336	!	axis.title.y = element_blank()
337		) +
338	!	labs(x = xlab, y = "ylab")
339		# plot title and labels
340	!	if (!is.null(title)) {
341	!	p <- p +
342	!	labs(title = title) +
343	!	theme(plot.title = element_text(face = "bold"))
344		}
345
346		# plot left legend
347	!	t <- anl_data %>%
348	!	as.data.frame() %>%
349	!	select((!!anno_var), (!!id_var)) %>%
350	!	distinct()
351	!	my_theme <- gridExtra::ttheme_default(
352	!	core = list(
353	!	bg_params = list(fill = NA, col = NA),
354	!	fg_params = list(cex = 0.8)
355		),
356	!	colhead = list(
357	!	bg_params = list(fill = NA, col = NA),
358	!	fg_params = list(cex = 0.8)
359		)
360		)
361	!	tb <- gridExtra::tableGrob(t, rows = NULL, theme = my_theme)
362	!	tb$heights <- grid::unit(rep(1 / nrow(tb), nrow(tb)), "null")
363
364		# grab plot and table as one plot
365	!	g0 <- ggplotGrob(p)
366	!	g1 <- gtable::gtable_add_cols(g0, sum(tb$widths), 0)
367	!	g <- gtable::gtable_add_grob(g1, tb, t = g1$layout[g1$layout$name == "panel", 1], l = 1)
368
369	!	grid::grid.newpage()
370	!	grid::grid.draw(g)
371	!	invisible(g)
372		}

1		#' Spider Plot
2		#'
3		#' Spider plot is often used in Early Development (ED) and displays individual
4		#' patient plot of an endpoint over time by group.
5		#'
6		#'
7		#' @param marker_x vector of x values (must be in sorted order)
8		#' @param marker_id vector to group the points together (default
9		#' should be `USUBJID`)
10		#' @param marker_y vector of y values
11		#' @param line_colby vector defines by what variable plot is color coded,
12		#' default here is `NULL`
13		#' @param line_color_opt vector defines line color, default here is `NULL`
14		#' @param marker_size size of markers in plot, default here is `NULL`
15		#' @param marker_shape vector defines by what variable points are shape coded,
16		#' , default here is `NULL`
17		#' @param marker_shape_opt vector defines marker shape code, default here is `NULL`
18		#' @param datalabel_txt list defines text (at last time point) and flag for an arrow annotation:
19		#' - (per defined variable) elements must be labeled `txt_ann`/`mrkr_all`/`mrkr_ann`.
20		#' - `txt_ann` text annotation next to final data point (for text annotation)
21		#' - `mrkr_all` vector of ID's (for annotation marker)
22		#' - `mrkr_ann` vector of ID's (subset of `mrkr_all`) where arrow is desired to
23		#' indicate any study interim points. Default here is `NULL`.
24		#' @param facet_rows dataframe defines what variable is used to split the
25		#' plot into rows, default here is `NULL`.
26		#' @param facet_columns dataframe defines what variable is used to split the
27		#' plot into columns, default here is `NULL`.
28		#' @param vref_line value defines vertical line overlay
29		#' (can be a vector), default here is `NULL`.
30		#' @param href_line value defines horizontal line overlay
31		#' (can be a vector), default here is `NULL`.
32		#' @param x_label string of text for x axis label, default is time.
33		#' @param y_label string of text for y axis label, default is % change.
34		#' @param show_legend boolean of whether marker legend is included, default here is `FALSE`.
35		#'
36		#' @return `ggplot` object
37		#'
38		#' @details there is no equivalent STREAM output
39		#'
40		#' @export
41		#'
42		#' @template author_zhanc107
43		#'
44		#' @examplesIf require("nestcolor")
45		#' # simple example
46		#' library(dplyr)
47		#' library(nestcolor)
48		#'
49		#' ADTR <- osprey::rADTR %>% select(STUDYID, USUBJID, ADY, AVISIT, CHG, PCHG, PARAMCD)
50		#' ADSL <- osprey::rADSL %>% select(STUDYID, USUBJID, RACE, SEX, ARM)
51		#' ANL <- left_join(ADTR, ADSL, by = c("STUDYID", "USUBJID"))
52		#' ANL <- ANL %>%
53		#' dplyr::filter(PARAMCD == "SLDINV" & AVISIT != "POST-BASELINE MINIMUM") %>%
54		#' dplyr::filter(RACE %in% c("WHITE", "ASIAN")) %>%
55		#' group_by(USUBJID) %>%
56		#' dplyr::arrange(ADY) %>%
57		#' dplyr::mutate(
58		#' CHG = ifelse(AVISIT == "Screening", 0, CHG),
59		#' PCHG = ifelse(AVISIT == "Screening", 0, PCHG)
60		#' )
61		#' ANL$USUBJID <- substr(ANL$USUBJID, 14, 18)
62		#'
63		#' # Plot 1 - default color and shape mapping
64		#' g_spiderplot(
65		#' marker_x = ANL$ADY,
66		#' marker_id = ANL$USUBJID,
67		#' marker_y = ANL$PCHG,
68		#' line_colby = ANL$USUBJID,
69		#' marker_shape = ANL$USUBJID,
70		#' # marker_size = 5,
71		#' datalabel_txt = list(txt_ann = ANL$USUBJID),
72		#' # facet_rows = data.frame(sex = ANL$SEX),
73		#' # facet_columns = data.frame(arm = ANL$ARM),
74		#' vref_line = c(42, 86),
75		#' href_line = c(-20, 20),
76		#' x_label = "Time (Days)",
77		#' y_label = "Change (%) from Baseline",
78		#' show_legend = TRUE
79		#' )
80		#'
81		#' # Plot 2 - with line color mapping
82		#' g_spiderplot(
83		#' marker_x = ANL$AVISIT,
84		#' marker_id = ANL$USUBJID,
85		#' marker_y = ANL$CHG,
86		#' line_colby = ANL$RACE,
87		#' line_color_opt = c("WHITE" = "red", "ASIAN" = "blue"),
88		#' marker_shape = ANL$USUBJID,
89		#' x_label = "Visit",
90		#' y_label = "Change from Baseline",
91		#' show_legend = TRUE
92		#' )
93		g_spiderplot <- function(marker_x,
94		marker_id,
95		marker_y,
96		line_colby = NULL,
97		line_color_opt = NULL,
98		marker_shape = NULL,
99		marker_shape_opt = NULL,
100		marker_size = 3,
101		datalabel_txt = NULL, # USUBJID default
102		facet_rows = NULL,
103		facet_columns = NULL,
104		vref_line = NULL,
105		href_line = NULL,
106		x_label = "Time (Days)",
107		y_label = "Change (%) from Baseline",
108		show_legend = FALSE) {
109	!	check_input_length <- c(nrow(data.frame(marker_x)), nrow(data.frame(marker_id)), nrow(data.frame(marker_y)))
110
111	!	if (length(unique(check_input_length)) > 1) {
112	!	stop("invalid arguments: check that the length of input arguments are identical")
113		}
114	!	if (any(check_input_length == 0)) {
115	!	stop("invalid arguments: check that inputs are not null")
116		}
117
118		# set up data-------
119	!	dat <- data.frame(x = marker_x, y = marker_y, group = marker_id)
120
121	!	if (!is.null(marker_shape)) {
122	!	if (length(unique(c(nrow(data.frame(marker_shape)), check_input_length))) != 1) {
123	!	stop("invalid arguments: check that the length of input arguments are identical")
124		}
125	!	dat$sh <- marker_shape
126		}
127	!	if (!is.null(facet_rows)) {
128	!	if (length(unique(c(nrow(facet_rows), check_input_length))) != 1) {
129	!	stop("invalid arguments: check that the length of input arguments are identical")
130		}
131	!	dat$f_rows <- interaction(facet_rows)
132		}
133	!	if (!is.null(facet_columns)) {
134	!	if (length(unique(c(nrow(facet_columns), check_input_length))) != 1) {
135	!	stop("invalid arguments: check that the length of input arguments are identical")
136		}
137	!	dat$f_columns <- interaction(facet_columns)
138		}
139	!	if (!is.null(line_colby)) {
140	!	if (length(unique(c(nrow(data.frame(line_colby)), check_input_length))) != 1) {
141	!	stop("invalid arguments: check that the length of input arguments are identical")
142		}
143	!	dat$l_col <- line_colby
144		}
145	!	if (!is.null(datalabel_txt$txt_ann)) {
146	!	dat$lbl_all <- datalabel_txt$txt_ann
147
148	!	dat <- dat %>%
149	!	group_by(.data$lbl_all) %>%
150	!	dplyr::mutate(lab = ifelse(.data$x == last(.data$x), as.character(.data$lbl_all), " "))
151		}
152	!	if (!is.null(datalabel_txt$mrkr_all) && !is.null(datalabel_txt$mrkr_ann)) {
153	!	if (length(unique(c(nrow(datalabel_txt$mrkr_all), check_input_length))) != 1) {
154	!	stop("invalid arguments: check that the length of input arguments are identical")
155		}
156	!	dat$id <- datalabel_txt$mrkr_all
157		}
158
159	!	dat <- dat %>% as.data.frame()
160
161		# plot spider plot----------------- this section can be condensed later
162	!	pl <- ggplot(data = dat, aes(x = .data$x, y = .data$y, group = .data$group)) +
163	!	xlab(x_label) +
164	!	ylab(y_label) +
165	!	theme(legend.position = "top", legend.title = element_blank())
166
167	!	pl <- pl + geom_hline(yintercept = 0, linetype = "solid", color = "gray", linewidth = 1)
168
169
170	!	pl <- pl +
171	!	geom_line(
172	!	mapping = if (!is.null(line_colby)) {
173	!	aes(color = .data$l_col)
174		} else {
175	!	NULL
176		},
177	!	linewidth = 1,
178	!	alpha = 0.5,
179	!	show.legend = show_legend
180		)
181
182		# marker shape------------ this section can be condensed later
183	!	if (!is.null(marker_shape)) {
184	!	pl <- pl +
185	!	geom_point(mapping = if (!is.null(line_colby)) {
186	!	aes(shape = .data$sh, color = .data$l_col)
187		} else {
188	!	aes(shape = .data$sh)
189	!	}, size = marker_size, show.legend = show_legend)
190	!	} else if (is.null(marker_shape)) {
191	!	pl <- pl +
192	!	geom_point(mapping = if (!is.null(line_colby)) {
193	!	aes(color = .data$l_col)
194		} else {
195	!	NULL
196	!	}, size = 3, show.legend = show_legend)
197		}
198
199		# label at last data point---------
200	!	if (!is.null(datalabel_txt)) {
201	!	if (!is.null(datalabel_txt$txt_ann) && is.null(datalabel_txt$mrkr_all) && is.null(datalabel_txt$mrkr_ann)) {
202	!	pl <- pl +
203	!	geom_text(
204	!	data = dat,
205	!	aes(x = .data$x, y = .data$y, label = .data$lab), hjust = -0.3,
206	!	size = 4,
207	!	show.legend = FALSE
208		)
209	!	} else if (is.null(datalabel_txt$txt_ann) && !is.null(datalabel_txt$mrkr_all) && !is.null(datalabel_txt$mrkr_ann)) {
210	!	dat_arrow <- dat %>%
211	!	dplyr::filter(id %in% datalabel_txt$mrkr_ann) %>%
212	!	group_by(.data$id) %>%
213	!	dplyr::filter(.data$x == last(.data$x))
214	!	pl <- pl +
215	!	geom_segment(
216	!	data = dat_arrow,
217	!	mapping = aes(x = .data$x, y = .data$y, xend = .data$x, yend = .data$y),
218	!	arrow = arrow(length = grid::unit(0.15, "inches"), ends = "first", type = "closed"),
219	!	linewidth = 0.4,
220	!	color = "black",
221	!	show.legend = FALSE
222		)
223		} else if (
224	!	!is.null(datalabel_txt$txt_ann) &&
225	!	!is.null(datalabel_txt$mrkr_all) &&
226	!	!is.null(datalabel_txt$mrkr_ann)
227		) {
228	!	pl <- pl +
229	!	geom_text(
230	!	data = dat,
231	!	aes(x = .data$x, y = .data$y, label = .data$lab),
232	!	hjust = -0.45,
233	!	size = 4,
234	!	show.legend = FALSE
235		)
236
237	!	dat_arrow <- dat %>%
238	!	dplyr::filter(id %in% datalabel_txt$mrkr_ann) %>%
239	!	group_by(.data$id) %>%
240	!	dplyr::filter(.data$x == last(.data$x))
241
242	!	pl <- pl +
243	!	geom_segment(
244	!	data = dat_arrow,
245	!	mapping = aes(x = .data$x, y = .data$y, xend = .data$x, yend = .data$y),
246	!	arrow = arrow(length = grid::unit(0.15, "inches"), ends = "first", type = "closed"),
247	!	linewidth = 0.4,
248	!	color = "black",
249	!	show.legend = FALSE
250		)
251		}
252		}
253
254		# vertical and horizontal reference lines
255	!	if (!is.null(href_line)) {
256	!	pl <- pl + geom_hline(yintercept = href_line, linetype = "dotted", color = "black")
257		}
258
259	!	if (!is.null(vref_line)) {
260	!	for (i in seq_along(vref_line)) {
261	!	pl <- pl +
262	!	annotate("segment",
263	!	x = vref_line[i],
264	!	y = -Inf,
265	!	xend = vref_line[i],
266	!	yend = Inf,
267	!	linetype = "dotted",
268	!	color = "black"
269		)
270		}
271		}
272
273		# facets---------------
274	!	if (is.null(facet_rows) && is.null(facet_columns)) {
275	!	pl
276	!	} else if (is.null(facet_rows) && !is.null(facet_columns)) {
277	!	pl <- pl + facet_grid(. ~ f_columns)
278	!	} else if (is.null(facet_columns) && !is.null(facet_rows)) {
279	!	pl <- pl + facet_grid(f_rows ~ .)
280		} else {
281	!	pl <- pl + facet_grid(f_rows ~ f_columns)
282		}
283
284		# simple function to call a vector of color values
285	!	call_color <- function(len) {
286	!	dat_col <- data.frame(color_opt = grDevices::colors())
287	!	dat_col <- dat_col %>%
288	!	dplyr::filter(!grepl("white", .data$color_opt)) %>%
289	!	droplevels()
290
291	!	return(dat_col[1:len, 1])
292		}
293
294		# remove marker from color legend
295	!	if (!is.null(line_colby)) {
296	!	if (!is.null(line_color_opt)) {
297	!	pl <- pl + scale_color_manual(
298	!	name = "Color",
299	!	breaks = dat$l_col,
300	!	values = line_color_opt
301		)
302		}
303		}
304
305	!	if (!is.null(marker_shape) && is.null(marker_shape_opt)) {
306	!	symbol_val <- c(15:18, 1:14)
307	!	len <- length(unique(dat$sh))
308	!	symbol_val <- rep(symbol_val, ceiling(len / 26))
309
310	!	pl <- pl + scale_shape_manual(
311	!	values = symbol_val[1:len]
312		)
313		}
314
315	!	if (!is.null(marker_shape_opt)) {
316	!	pl <- pl + scale_shape_manual(
317	!	name = "Shape",
318	!	breaks = dat$sh,
319	!	values = marker_shape_opt
320		)
321		}
322
323		# modify background color
324	!	pl <- pl + annotate("segment", x = -Inf, xend = Inf, y = -Inf, yend = -Inf) +
325	!	annotate("segment", x = -Inf, xend = -Inf, y = -Inf, yend = Inf) +
326	!	theme_bw() +
327	!	theme(
328	!	strip.background = element_rect(linetype = "blank", fill = "white"),
329	!	text = element_text(size = 16),
330	!	axis.text = element_text(color = "black"),
331	!	legend.text = element_text(size = 7),
332	!	legend.title = element_text(size = 7)
333		) +
334	!	labs(shape = "Shape", color = "Color") # +
335
336	!	if (is.numeric(marker_x)) {
337	!	pl <- pl + xlim(min(marker_x), max(marker_x) * 1.3)
338		} else {
339	!	pl <- pl +
340	!	scale_x_discrete(expand = c(0.3, 0)) +
341	!	theme(axis.text.x = element_text(angle = 90))
342		}
343
344	!	grid::grid.draw(pl)
345	!	invisible(pl)
346		}

1		#' Hy's Law Plot
2		#'
3		#' A scatter plot typically used to display maximum total bilirubin values (`TBL`)
4		#' versus maximum alanine transaminase (`ALT`) values.
5		#'
6		#' @param id unique subject identifier.
7		#' @param term the term of the observation.
8		#' @param aval analysis value.
9		#' @param arm treatment arm. Used as fill color in the plot.
10		#' @param term_selected string vector of length 2 - the two terms selected to be
11		#' used in the plot. First value corresponds to parameter plotted on the
12		#' x-axis. Second value corresponds to that plotted on the y-axis.
13		#' @param anrhi the high limit of normal range.
14		#' @param folds numeric vector of length two. Indicates the position of the
15		#' reference lines to be drawn. Default c(3, 2) corresponds to a line at
16		#' position 3 on the x-axis and 2 on the y-axis.
17		#' @param text string vector of length four with the label to be shown on each
18		#' quadrant. First value corresponds to label shown in the bottom left
19		#' quadrant. Subsequent values move through the graph clockwise.
20		#' @param caption string of text for footnote. Details of methodology can be
21		#' shown here.
22		#' @param title string of text for plot title.
23		#' @param xlab string of text for x axis label.
24		#' @param ylab string of text for y axis label.
25		#'
26		#' @details
27		#' This graphic is based upon the `eDISH` (evaluation of Drug Induced Serious
28		#' Hepatotoxicity) plot of Watkins et. al. in a 2008 publication from Hepatology.
29		#' Maximum values are defined as the maximum post-baseline value at any time
30		#' during the entire length of the observation period. Both axes are in log
31		#' scale to control for the dispersion of the data. The values are plotted in
32		#' 'times upper limit of normal' where a value of 1 would mean that the result
33		#' was normal. Any value above or below 1 would be considered above the upper
34		#' limit or normal or below the upper limit of normal respectively. For
35		#' instance, a value of 3 would be read as '3 times the upper limit of normal'.
36		#' Reference lines are included to determine various states, based upon clinical
37		#' interpretation of the values and includes the following:
38		#'
39		#' * Hyperbilirubinemia `TBL` at least 2 `xULN` and `ALT` less than 3 `xULN`
40		#' * Normal Range `TBL` <= 1 `xULN` and `ALT` <= 1 `xULN`
41		#' * Temple’s Corollary `TBL` <= 1 `xULN` and `ALT` at least 3 `xULN`
42		#' * Possible Hy's Law `TBL` at least 2 `xULN` and `ALT` at least 3 `xULN`
43		#'
44		#' This plot can easily be adjusted for other lab parameters and reference
45		#' ranges as needed. Consultation with a clinical expert to determine which
46		#' associations would be clinically meaningful and how to interpret those
47		#' associations is recommended.
48		#'
49		#' There is no equivalent STREAM output.
50		#'
51		#' @return plot object
52		#'
53		#' @export
54		#'
55		#' @template author_withycok
56		#' @template author_frankla4
57		#' @template author_holmesw
58		#'
59		#' @examplesIf require("nestcolor")
60		#' library(dplyr)
61		#' library(nestcolor)
62		#'
63		#' # Note: CRP is being used in place of Bilirubin here because this is the only available data
64		#' adsl <- osprey::rADSL
65		#' adlb <- osprey::rADLB %>% mutate(ANRHI = 50)
66		#'
67		#' # Example 1, - Hy's law template (3 and 2 X ULN)
68		#' g_hy_law(
69		#' id = adlb$USUBJID,
70		#' term = adlb$PARAMCD,
71		#' aval = adlb$AVAL,
72		#' arm = adlb$ARM,
73		#' term_selected = c("ALT", "CRP"),
74		#' anrhi = adlb$ANRHI,
75		#' folds = c(3, 2),
76		#' text = c("Normal Range", "Hyperbilirubinemia", "Possible Hy's Law Range", "Temple's Corollary"),
77		#' caption = paste(
78		#' "Maximum values are those maximum values that occur",
79		#' "post-baseline (no time constraints and not necessarily concurrent events)."
80		#' ),
81		#' title = "Max. Total Bilirubin vs. Max. Alanine Aminotransferase",
82		#' xlab = "Maximum Alanine Aminotransferase (/ULN)",
83		#' ylab = "Maximum Total Bilirubin (/ULN)"
84		#' )
85		#'
86		#' # Example 2, - change the quadrant lines and labels
87		#' g_hy_law(
88		#' id = adlb$USUBJID,
89		#' term = adlb$PARAMCD,
90		#' aval = adlb$AVAL,
91		#' arm = adlb$ARM,
92		#' term_selected = c("ALT", "CRP"),
93		#' anrhi = adlb$ANRHI,
94		#' folds = c(10, 15),
95		#' text = c("Quadrant 1", "Quadrant 2", "Quadrant 3", "Quadrant 4"),
96		#' caption = paste(
97		#' "Maximum values are those maximum values that occur",
98		#' "post-baseline (no time constraints and not necessarily concurrent events)."
99		#' ),
100		#' title = "Max. Total Bilirubin vs. Max. Alanine Aminotransferase",
101		#' xlab = "Maximum Alanine Aminotransferase (/ULN)",
102		#' ylab = "Maximum Total Bilirubin (/ULN)"
103		#' )
104		g_hy_law <- function(id,
105		term,
106		aval,
107		arm,
108		term_selected,
109		anrhi,
110		folds = c(3, 2),
111		text = c("Normal Range", "Hyperbilirubinemia", "Possible Hy's Law Range", "Temple's Corollary"),
112		caption = paste(
113		"Maximum values are those maximum values that occur post-baseline",
114		"(no time constraints and not necessarily concurrent events)."
115		),
116		title = "Max. Total Bilirubin vs. Max. Alanine Aminotransferase",
117		xlab = "Maximum Alanine Aminotransferase (/ULN)",
118		ylab = "Maximum Total Bilirubin (/ULN)") {
119	!	checkmate::assert_character(term_selected, len = 2, any.missing = FALSE)
120	!	checkmate::assert_numeric(folds, len = 2, any.missing = FALSE)
121	!	checkmate::assert_character(text, len = 4, any.missing = FALSE)
122	!	checkmate::assert_string(title)
123	!	checkmate::assert_string(caption)
124	!	checkmate::assert_string(xlab)
125	!	checkmate::assert_string(ylab)
126
127	!	anl <- data.frame(id, term, aval, arm, anrhi)
128
129	!	anl <- anl %>%
130	!	dplyr::filter(term %in% term_selected) %>%
131	!	dplyr::group_by(id, term) %>%
132	!	dplyr::mutate(MAX = max(aval)) %>%
133	!	dplyr::slice(1) %>%
134	!	dplyr::mutate(ULN = .data$MAX / anrhi) %>%
135	!	tidyr::pivot_wider(id_cols = c(id, arm), names_from = term, values_from = "ULN")
136
137	!	p <- ggplot(data = anl) +
138	!	scale_x_continuous(
139	!	name = xlab,
140	!	breaks = log10(c(seq(0.1, 1, 0.1), seq(2, 10, 1), seq(20, 100, 10))),
141	!	limits = c(-1, 2),
142	!	labels = c(0.1, rep(" ", 8), 1, rep(" ", 8), 10, rep(" ", 8), 100),
143	!	expand = c(0.01, 0.01)
144		) +
145	!	scale_y_continuous(
146	!	name = ylab,
147	!	breaks = log10(c(seq(0.1, 1, 0.1), seq(2, 10, 1), seq(20, 100, 10))),
148	!	limits = c(-1, 2),
149	!	labels = c(0.1, rep(" ", 8), 1, rep(" ", 8), 10, rep(" ", 8), 100),
150	!	expand = c(0.01, 0.01)
151		) +
152	!	labs(title = title, caption = caption) +
153	!	theme_bw(base_size = 14) +
154	!	theme(
155	!	plot.title = element_text(hjust = 0.5),
156	!	plot.title.position = "plot",
157	!	plot.caption = element_text(hjust = 0),
158	!	plot.caption.position = "plot",
159	!	legend.title = element_blank(),
160	!	panel.grid = element_blank()
161		) +
162	!	geom_segment(
163	!	aes(x = log10(folds[1]), y = log10(0), xend = log10(folds[1]), yend = log10(75)),
164	!	linewidth = 0.25,
165	!	color = "grey"
166		) +
167	!	geom_segment(
168	!	aes(x = log10(0), y = log10(folds[2]), xend = log10(65), yend = log10(folds[2])),
169	!	linewidth = 0.25,
170	!	color = "grey"
171		) +
172	!	geom_segment(
173	!	aes(x = log10(1), y = log10(0), xend = log10(1), yend = log10(1)),
174	!	linewidth = 0.25,
175	!	color = "black"
176		) +
177	!	geom_segment(
178	!	aes(x = log10(0), y = log10(1), xend = log10(1), yend = log10(1)),
179	!	linewidth = 0.25,
180	!	color = "black"
181		) +
182	!	annotate("text", label = paste0(folds[1], "XULN"), x = log10(folds[1]), y = log10(90)) +
183	!	annotate("text", label = paste0(folds[2], "XULN"), x = log10(85), y = log10(folds[2])) +
184	!	annotate("text", label = text[1], x = log10(0.2), y = log10(0.12)) +
185	!	annotate("text", label = text[2], x = log10(0.2), y = log10(80)) +
186	!	annotate("text", label = text[3], x = log10(40), y = log10(80)) +
187	!	annotate("text", label = text[4], x = log10(40), y = log10(0.12)) +
188	!	geom_point(aes(
189	!	x = log10(.data[[term_selected[1]]]),
190	!	y = log10(.data[[term_selected[2]]]),
191	!	shape = arm,
192	!	color = arm
193		)) +
194	!	scale_shape_manual(values = c(1:n_distinct(arm)))
195
196	!	g <- ggplotGrob(p)
197	!	grid::grid.newpage()
198	!	grid::grid.draw(g)
199	!	invisible(g)
200		}

1		#' Simple spider plot
2		#'
3		#' Description of this plot
4		#'
5		#' @param anl The analysis data frame
6		#' @param byvar Analysis dataset
7		#' @param days Variable with time in days
8		#' @param mes_value Variable with measurement
9		#' @param group_col Variable to color the individual lines and id in plot
10		#' @param baseday Numeric Value, points with only smaller values will be cut out
11		#'
12		#'
13		#' @return `ggplot` object
14		#'
15		#' @export
16		#'
17		#' @author Mika Maekinen
18		#'
19		#' @examplesIf require("nestcolor")
20		#' library(dplyr)
21		#' library(nestcolor)
22		#'
23		#' ADSL <- osprey::rADSL[1:15, ]
24		#' ADTR <- osprey::rADTR
25		#' ANL <- left_join(ADSL, ADTR)
26		#'
27		#' ANL %>%
28		#' dplyr::filter(ANL01FL == "Y" & PARAMCD == "SLDINV") %>%
29		#' spiderplot_simple(group_col = "SEX", days = "ADY", mes_value = "AVAL")
30		spiderplot_simple <- function(anl,
31		byvar = "USUBJID",
32		days = "TRTDURD",
33		mes_value = "PARAM",
34		group_col = "USUBJID",
35		baseday = 0) {
36		### remove patients without post baseline measurement
37	!	anl <- anl %>%
38	!	group_by(!!byvar) %>%
39	!	dplyr::mutate(morebase = ifelse(max(!!days, na.rm = TRUE) > baseday, TRUE, FALSE)) %>%
40	!	dplyr::filter(.data$morebase == TRUE) %>%
41	!	ungroup()
42		### find the last measurement
43	!	last_obs <- anl %>%
44	!	group_by(!!as.symbol(byvar)) %>%
45	!	slice(which.max(!!as.symbol(days)))
46
47		# plotr
48	!	ggplot(
49	!	data = anl,
50	!	mapping = aes(x = !!days, y = !!mes_value, group = !!byvar, colour = !!group_col),
51	!	size = 2,
52	!	alpha = 1
53		) +
54	!	geom_point(size = 3) +
55	!	geom_line(linewidth = 2, alpha = 0.7) +
56	!	geom_text(aes(x = !!days, y = !!mes_value, label = !!byvar), data = last_obs, hjust = 0) +
57	!	geom_hline(aes(yintercept = 0), linetype = "dotted", color = "black") +
58	!	xlab("Time (Days)") +
59	!	ylab("Change(%) from Baseline")
60		}