R/plot.r

Defines functions geom_builder data_builder axis_builder plot.bnb plot.nb plot.log_lognormal_one_sample plot.log_lognormal_mixed_two_sample plot.log_lognormal_dependent_two_sample plot.log_lognormal_independent_two_sample plot.depower

Documented in plot.depower

#' Plot power objects
#'
#' An automatic plot method for objects returned by [depower::power()].
#'
#' If you are limited by the output from `plot.depower()`, keep in mind that the
#' object returned by [depower::power()] is a standard data frame. This allows
#' you to easily plot all results with standard plotting functions. In addition,
#' because `plot.depower()` uses ggplot2, you can modify the plot as you
#' normally would. For example:
#'
#' ```{r, plot_details, dev=c('svg','cairo_pdf'), fig.width=5, fig.height=4, fig.show='hide'}
#' set.seed(1234)
#' sim_log_lognormal(
#'   n1 = c(10, 15),
#'   n2 = c(10, 15),
#'   ratio = c(1.3, 1.5),
#'   cv1 = c(0.3),
#'   cv2 = c(0.3, 0.5),
#'   nsims = 1000
#' ) |>
#'   power(alpha = 0.05) |>
#'   plot(hline = 0.8, caption_width = 60) +
#'   ggplot2::theme_bw() +
#'   ggplot2::theme(plot.caption = ggplot2::element_text(hjust = 0)) +
#'   ggplot2::labs(title = "Power for the ratio of geometric means")
#' ```
#'
#' \if{html}{\out{<div style="display: flex; justify-content: center; padding-top: 10px; padding-bottom: 10px;">
#'   <img style="max-width: 100\%; height: auto;" src="figures/plot_details-1.svg" alt="Example of extending plot() with ggplot2 functions" />
#' </div>}}
#' \if{latex}{
#'   \out{\begin{center}}
#'   \figure{plot_details-1.pdf}{options: width=4in}
#'   \out{\end{center}}
#' }
#'
#' @param x (depower)\cr
#'        The data frame returned by [depower::power()].
#' @param x_axis (string: `NULL`; `names(x)`)\cr
#'        The name of the column to be used for the x-axis. Automatically chosen
#'        if `NULL`.
#' @param y_axis (string: `NULL`; `names(x)`)\cr
#'        The name of the column to be used for the y-axis. Automatically chosen
#'        if `NULL`. Generally, `"power"` (default) should be used for the y-axis.
#' @param color (string: `NULL`; `names(x)`)\cr
#'        The name of the column to be used for the [ggplot2::aes()] color
#'        aesthetic. Automatically chosen if `NULL`. Use `NA` to turn off.
#' @param facet_row (string: `NULL`; `names(x)`)\cr
#'        The name of the column to be used for the [ggplot2::facet_grid()] row.
#'        Automatically chosen if `NULL`. Use `NA` to turn off.
#' @param facet_col (string: `NULL`; `names(x)`)\cr
#'        The name of the column to be used for the [ggplot2::facet_grid()]
#'        column. Automatically chosen if `NULL`. Use `NA` to turn off.
#' @param hline (numeric: `NULL`; `(0, 1)`)\cr
#'        The y-intercept at which to draw a horizontal line.
#' @param caption (Scalar logical: `TRUE`)\cr
#'        If `TRUE` (default), a caption is added to the plot. The caption
#'        includes information on parameter values that were conditioned on to
#'        generate the plot. If `FALSE`, the caption is not included.
#' @param caption_width (Scalar integer: `70L`)\cr
#'        The target column number for wrapping the caption text.
#' @param ... Unused additional arguments.
#'
#' @return A [ggplot2::ggplot()] object.
#'
#' @seealso [depower::power()]
#'
#' @examples
#' #----------------------------------------------------------------------------
#' # plot() examples
#' #----------------------------------------------------------------------------
#' library(depower)
#'
#' # Power for independent two-sample t-test
#' set.seed(1234)
#' sim_log_lognormal(
#'   n1 = c(10, 15),
#'   n2 = c(10, 15),
#'   ratio = c(1.3, 1.5),
#'   cv1 = c(0.3),
#'   cv2 = c(0.3, 0.5),
#'   nsims = 500
#' ) |>
#'   power(alpha = 0.05) |>
#'   plot()
#'
#' # Power for dependent two-sample t-test
#' set.seed(1234)
#' sim_log_lognormal(
#'   n1 = c(10, 15),
#'   n2 = c(10, 15),
#'   ratio = c(1.3, 1.5),
#'   cv1 = c(0.3, 0.5),
#'   cv2 = c(0.3, 0.5),
#'   cor = c(0.3),
#'   nsims = 500
#' ) |>
#'   power(alpha = 0.01) |>
#'   plot()
#'
#' # Power for two-sample independent AND two-sample dependent t-test
#' set.seed(1234)
#' sim_log_lognormal(
#'   n1 = c(10, 15),
#'   n2 = c(10, 15),
#'   ratio = c(1.3, 1.5),
#'   cv1 = c(0.3),
#'   cv2 = c(0.3),
#'   cor = c(0, 0.3, 0.6),
#'   nsims = 500
#' ) |>
#'   power(alpha = c(0.05, 0.01)) |>
#'   plot(facet_row = "cor", color = "test")
#'
#' # Power for one-sample t-test
#' set.seed(1234)
#' sim_log_lognormal(
#'   n1 = c(10, 15),
#'   ratio = c(1.2, 1.4),
#'   cv1 = c(0.3, 0.5),
#'   nsims = 500
#' ) |>
#'   power(alpha = c(0.05, 0.01)) |>
#'   plot()
#'
#' \donttest{
#' # Power for independent two-sample NB test
#' set.seed(1234)
#' sim_nb(
#'   n1 = c(10, 15),
#'   mean1 = 10,
#'   ratio = c(1.8, 2),
#'   dispersion1 = 10,
#'   dispersion2 = 3,
#'   nsims = 100
#' ) |>
#'   power(alpha = 0.01) |>
#'   plot()
#'
#' # Power for BNB test
#' set.seed(1234)
#' sim_bnb(
#'   n = c(10, 12),
#'   mean1 = 10,
#'   ratio = c(1.3, 1.5),
#'   dispersion = 5,
#'   nsims = 100
#' ) |>
#'   power(alpha = 0.01) |>
#'   plot()
#' }
#'
#' @importFrom dplyr filter summarize across all_of any_of select left_join
#'                   mutate bind_cols
#' @importFrom ggplot2 ggplot aes facet_grid geom_point geom_line labs vars
#'                     labeller label_both scale_y_continuous scale_x_continuous
#'                     scale_color_discrete geom_hline
#' @importFrom scales percent
#'
#' @export
#' @rdname plot.depower
plot.depower <- function(
    x,
    x_axis = NULL,
    y_axis = NULL,
    color = NULL,
    facet_row = NULL,
    facet_col = NULL,
    hline = NULL,
    caption = TRUE,
    caption_width = 70L,
    ...
) {
  #-----------------------------------------------------------------------------
  # Check arguments
  #-----------------------------------------------------------------------------
  if(nrow(x) < 2L) {
    stop("Argument 'x' must have at least 2 rows.")
  }

  # axis should be null or length==1
  axis <- list(
    x_axis = x_axis, y_axis = y_axis, color = color,
    facet_row = facet_row, facet_col = facet_col
  )
  if(!all(lengths(axis) < 2L)) {
    idx_bad <- which(lengths(axis) > 1L)
    stop(paste0(
      "Argument(s) ",
      csw(names(axis)[idx_bad], and = TRUE),
      " should be a string of length 1 for the column to be used."
    ))
  }
  # axis should be variable in x
  axis <- unlist(axis)
  if(!is.null(axis)) {
    axis <- axis[!is.na(axis)]
    are_bad <- !axis %in% names(x)
    if(any(are_bad)) {
      stop(paste0(
        "Column(s) ",
        csw(axis[are_bad], and = TRUE),
        " are not found in object for argument 'x'."
      ))
    }
  }
  if(!is.null(hline)) {
    if(!is.numeric(hline) || length(hline) != 1L || hline <= 0 || hline >= 1) {
      stop("Argument 'hline' must be a scalar numeric from (0,1).")
    }
  }
  if(!(is.logical(caption) && length(caption) == 1L)) {
    stop("Argument 'caption' must be a scalar logical.")
  }
  if(!(is.numeric(caption_width) && length(caption_width) == 1L && caption_width > 0)) {
    stop("Argument 'caption_width' must be a positive scalar numeric.")
  }

  #-----------------------------------------------------------------------------
  # Jump to next method
  #-----------------------------------------------------------------------------
  NextMethod("plot")
}

#' @export
plot.log_lognormal_independent_two_sample <- function(
    x,
    x_axis = NULL,
    y_axis = NULL,
    color = NULL,
    facet_row = NULL,
    facet_col = NULL,
    hline = NULL,
    caption = TRUE,
    caption_width = 70L,
    ...
) {
  #-----------------------------------------------------------------------------
  # Get axis labels
  #-----------------------------------------------------------------------------
  axis <- axis_builder(
    data = x,
    sorted_axis = c("power", "n2", "n1", "ratio", "cv2", "cv1", "cor", "alpha", "test"),
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  x_axis <- axis[["x_axis"]]
  y_axis <- axis[["y_axis"]]
  color <- axis[["color"]]
  facet_row <- axis[["facet_row"]]
  facet_col <- axis[["facet_col"]]

  #-----------------------------------------------------------------------------
  # Prepare plot data
  #-----------------------------------------------------------------------------
  plot_data <- data_builder(
    data = x,
    exclude = NULL,
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  #-----------------------------------------------------------------------------
  # Create plot & return
  #-----------------------------------------------------------------------------
  ggplot(
    data = plot_data$df_plot,
    aes(x = .data[[x_axis]], y = .data[[y_axis]])
  ) +
    geom_builder(
      plot_data$condition_at, x_axis, y_axis, color,
      facet_row, facet_col, hline, caption, caption_width, plot_data$axis_labels
    )
}

#' @export
plot.log_lognormal_dependent_two_sample <- function(
    x,
    x_axis = NULL,
    y_axis = NULL,
    color = NULL,
    facet_row = NULL,
    facet_col = NULL,
    hline = NULL,
    caption = TRUE,
    caption_width = 70L,
    ...
) {
  #-----------------------------------------------------------------------------
  # Get axis labels
  #-----------------------------------------------------------------------------
  axis <- axis_builder(
    data = x,
    sorted_axis = c("power", "n2", "n1", "ratio", "cv2", "cv1", "cor", "alpha", "test"),
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  x_axis <- axis[["x_axis"]]
  y_axis <- axis[["y_axis"]]
  color <- axis[["color"]]
  facet_row <- axis[["facet_row"]]
  facet_col <- axis[["facet_col"]]

  #-----------------------------------------------------------------------------
  # Prepare plot data
  #-----------------------------------------------------------------------------
  # two sample dependent t-test requires both groups have the same sample size.
  # So n1 or n2 should not be included in conditioning.
  if(any(c(x_axis, y_axis, color, facet_row, facet_col) %in% c("n1", "n2"))) {
    exclude <- c("n1", "n2")
  } else {
    exclude <- NULL
  }

  plot_data <- data_builder(
    data = x,
    exclude = exclude,
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  # Add sample size descriptor to caption 'n1 = n2'
  # when n1 or n2 is used as axis/color/facet.
  if(any(c(x_axis, y_axis, color, facet_row, facet_col) %in% c("n1", "n2"))) {
    plot_data$condition_at <- c("n1" = "n2", plot_data$condition_at)
  }

  #-----------------------------------------------------------------------------
  # Create plot & return
  #-----------------------------------------------------------------------------
  ggplot(
    data = plot_data$df_plot,
    aes(x = .data[[x_axis]], y = .data[[y_axis]])
  ) +
    geom_builder(
      plot_data$condition_at, x_axis, y_axis, color,
      facet_row, facet_col, hline, caption, caption_width, plot_data$axis_labels
    )
}

#' @export
plot.log_lognormal_mixed_two_sample <- function(
    x,
    x_axis = NULL,
    y_axis = NULL,
    color = NULL,
    facet_row = NULL,
    facet_col = NULL,
    hline = NULL,
    caption = TRUE,
    caption_width = 70L,
    ...
) {
  #-----------------------------------------------------------------------------
  # Get axis labels
  #-----------------------------------------------------------------------------
  axis <- axis_builder(
    data = x,
    sorted_axis = c("power", "n2", "n1", "ratio", "cv2", "cv1", "cor", "alpha", "test"),
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  x_axis <- axis[["x_axis"]]
  y_axis <- axis[["y_axis"]]
  color <- axis[["color"]]
  facet_row <- axis[["facet_row"]]
  facet_col <- axis[["facet_col"]]

  #-----------------------------------------------------------------------------
  # Prepare plot data
  #-----------------------------------------------------------------------------
  all_cor_0 <- all(x[["cor"]] == 0)
  any_cor_0 <- any(x[["cor"]] == 0)

  # two sample dependent t-test requires both groups have the same sample size.
  # So n1 or n2 should not be included in conditioning.
  if(
    !all_cor_0 &&
    (any(c(x_axis, y_axis, color, facet_row, facet_col) %in% c("n1", "n2")))
  ) {
    exclude <- c("n1", "n2")
  } else {
    exclude <- NULL
  }

  # If we have mixed correlation=0 and correlation>0 data, we need to remove
  # the mixed sample size rows (i.e. n1 != n2) where cor=0.
  if(any_cor_0 && !all_cor_0) {
    x <- x |>
      dplyr::filter(!(.data[["cor"]] == 0 & (.data[["n1"]] != .data[["n2"]])))
  }

  plot_data <- data_builder(
    data = x,
    exclude = exclude,
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  # Add sample size descriptor to caption 'n1 = n2'
  # when n1 or n2 is used as axis/color/facet.
  if(
    !all_cor_0 &&
    (any(c(x_axis, y_axis, color, facet_row, facet_col) %in% c("n1", "n2")))
  ) {
    plot_data$condition_at <- c("n1" = "n2", plot_data$condition_at)
  }

  #-----------------------------------------------------------------------------
  # Create plot & return
  #-----------------------------------------------------------------------------
  ggplot(
    data = plot_data$df_plot,
    aes(x = .data[[x_axis]], y = .data[[y_axis]])
  ) +
    geom_builder(
      plot_data$condition_at, x_axis, y_axis, color,
      facet_row, facet_col, hline, caption, caption_width, plot_data$axis_labels
    )
}

#' @export
plot.log_lognormal_one_sample <- function(
    x,
    x_axis = NULL,
    y_axis = NULL,
    color = NULL,
    facet_row = NULL,
    facet_col = NULL,
    hline = NULL,
    caption = TRUE,
    caption_width = 70L,
    ...
) {
  #-----------------------------------------------------------------------------
  # Get axis labels
  #-----------------------------------------------------------------------------
  axis <- axis_builder(
    data = x,
    sorted_axis = c("power", "n1", "ratio", "cv1", "alpha", "test"),
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  x_axis <- axis[["x_axis"]]
  y_axis <- axis[["y_axis"]]
  color <- axis[["color"]]
  facet_row <- axis[["facet_row"]]
  facet_col <- axis[["facet_col"]]

  #-----------------------------------------------------------------------------
  # Prepare plot data
  #-----------------------------------------------------------------------------
  plot_data <- data_builder(
    data = x,
    exclude = NULL,
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  #-----------------------------------------------------------------------------
  # Create plot & return
  #-----------------------------------------------------------------------------
  ggplot(
    data = plot_data$df_plot,
    aes(x = .data[[x_axis]], y = .data[[y_axis]])
  ) +
    geom_builder(
      plot_data$condition_at, x_axis, y_axis, color,
      facet_row, facet_col, hline, caption, caption_width, plot_data$axis_labels
    )
}

#' @export
plot.nb <- function(
    x,
    x_axis = NULL,
    y_axis = NULL,
    color = NULL,
    facet_row = NULL,
    facet_col = NULL,
    hline = NULL,
    caption = TRUE,
    caption_width = 70L,
    ...
) {
  #-----------------------------------------------------------------------------
  # Get axis labels
  #-----------------------------------------------------------------------------
  axis <- axis_builder(
    data = x,
    sorted_axis = c("power", "n2", "n1", "ratio", "mean1", "dispersion2",
                    "dispersion1", "alpha", "test"),
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  x_axis <- axis[["x_axis"]]
  y_axis <- axis[["y_axis"]]
  color <- axis[["color"]]
  facet_row <- axis[["facet_row"]]
  facet_col <- axis[["facet_col"]]

  #-----------------------------------------------------------------------------
  # Prepare plot data
  #-----------------------------------------------------------------------------
  plot_data <- data_builder(
    data = x,
    exclude = NULL,
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  #-----------------------------------------------------------------------------
  # Create plot & return
  #-----------------------------------------------------------------------------
  ggplot(
    data = plot_data$df_plot,
    aes(x = .data[[x_axis]], y = .data[[y_axis]])
  ) +
    geom_builder(
      plot_data$condition_at, x_axis, y_axis, color,
      facet_row, facet_col, hline, caption, caption_width, plot_data$axis_labels
    )
}

#' @export
plot.bnb <- function(
    x,
    x_axis = NULL,
    y_axis = NULL,
    color = NULL,
    facet_row = NULL,
    facet_col = NULL,
    hline = NULL,
    caption = TRUE,
    caption_width = 70L,
    ...
) {
  #-----------------------------------------------------------------------------
  # Get axis labels
  #-----------------------------------------------------------------------------
  axis <- axis_builder(
    data = x,
    sorted_axis = c("power", "n1", "ratio", "mean1", "dispersion1", "alpha", "test"),
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  x_axis <- axis[["x_axis"]]
  y_axis <- axis[["y_axis"]]
  color <- axis[["color"]]
  facet_row <- axis[["facet_row"]]
  facet_col <- axis[["facet_col"]]

  #-----------------------------------------------------------------------------
  # Prepare plot data
  #-----------------------------------------------------------------------------
  # BNB requires both groups have the same sample size.
  # So n1 or n2 should not be included in conditioning.
  if(any(c(x_axis, y_axis, color, facet_row, facet_col) %in% c("n1", "n2"))) {
    exclude <- c("n1", "n2")
  } else {
    exclude <- NULL
  }

  plot_data <- data_builder(
    data = x,
    exclude = exclude,
    x_axis = x_axis,
    y_axis = y_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )

  # Add sample size descriptor to caption 'n1 = n2'
  # when n1 or n2 is used as axis/color/facet.
  if(any(c(x_axis, y_axis, color, facet_row, facet_col) %in% c("n1", "n2"))) {
    plot_data$condition_at <- c("n1" = "n2", plot_data$condition_at)
  }

  #-----------------------------------------------------------------------------
  # Create plot & return
  #-----------------------------------------------------------------------------
  ggplot(
    data = plot_data$df_plot,
    aes(x = .data[[x_axis]], y = .data[[y_axis]])
  ) +
    geom_builder(
      plot_data$condition_at, x_axis, y_axis, color,
      facet_row, facet_col, hline, caption, caption_width, plot_data$axis_labels
    )
}

#===============================================================================
# Plot helper functions
#===============================================================================
#-------------------------------------------------------------------------------
# Select plot axis
#-------------------------------------------------------------------------------
axis_builder <- function(
    data,
    sorted_axis,
    x_axis = NULL,
    y_axis = NULL,
    color = NULL,
    facet_row = NULL,
    facet_col = NULL
) {
  # Prepare data used for axis assignment
  ## Create a vector of axis names sorted in the order we want to assign them.
  ## Match the sorted vars to the actual data.
  names_data <- names(data)
  idx <- match(sorted_axis, names_data) |>
    remove_na()
  sorted_axis <- names_data[idx]

  ## Number of unique values for each variable of interest.
  n_uniques <- vapply(
    X = data,
    FUN = function(x) {length(unique(x))},
    FUN.VALUE = integer(1),
    USE.NAMES = TRUE
  )
  n_uniques <- n_uniques[sorted_axis]

  ## Only use variables which are not previously used and have 2 or more levels
  used <- c(y_axis, x_axis, color, facet_row, facet_col)
  ok_to_use <- vapply(
    X = sorted_axis,
    FUN = function(x) {!x %in% used},
    FUN.VALUE = logical(1),
    USE.NAMES = TRUE
  )

  axis <- n_uniques > 1L & ok_to_use
  axis <- axis[axis] |>
    remove_na() |>
    names()

  ## In a dependent two-sample t-Test, n1 shouldn't be used when n2 is already
  ## in use, because they must be the same value.
  if("cor" %in% names_data) {
    ok_to_use_n1 <- all(data[["cor"]] == 0)
    if(!ok_to_use_n1) {
      axis <- axis[axis != "n1"]
    }
  }
  ## In a BNB test, n2 shouldn't be used when n1 is already in use, because they
  ## must be the same value.
  if(inherits(data, "bnb")) {
    axis <- axis[axis != "n2"]
  }

  # Assign axis where needed
  if(is.null(y_axis)) {
    # handle pathological cases
    if(isTRUE(ok_to_use["power"]) && !"power" %in% axis) {
      y_axis <- "power"
    } else {
      y_axis <- axis[1L]
      axis <- remove_used_axis(axis)
    }
  }

  if(is.null(x_axis)) {
    # handle pathological cases
    if(isTRUE(ok_to_use["n2"]) && is.na(axis[1L])) {
      x_axis <- "n2"
    } else if(isTRUE(ok_to_use["n1"]) && is.na(axis[1L])) {
      x_axis <- "n1"
    } else if(isTRUE(ok_to_use["n"]) && is.na(axis[1L])) {
      x_axis <- "n"
    } else {
      x_axis <- axis[1L]
      axis <- remove_used_axis(axis)
    }
  }

  if(is.null(color)) {
    color <- axis[1L]
    axis <- remove_used_axis(axis)
  }

  if(is.null(facet_row)) {
    facet_row <- axis[1L]
    axis <- remove_used_axis(axis)
  }

  if(is.null(facet_col)) {
    facet_col <- axis[1L]
    axis <- remove_used_axis(axis)
  }

  # Return
  list(
    y_axis = y_axis,
    x_axis = x_axis,
    color = color,
    facet_row = facet_row,
    facet_col = facet_col
  )
}

#-------------------------------------------------------------------------------
# Create list of data items for creating the plot
#-------------------------------------------------------------------------------
data_builder <- function(
    data,
    exclude = NULL,
    x_axis,
    y_axis,
    color,
    facet_row,
    facet_col
) {
  # Combine factors and get labels
  axis <- c(x_axis, y_axis, color, facet_row, facet_col)
  axis <- axis[!is.na(axis)]

  axis_labels <- vapply(
    X = data[axis],
    FUN = function(x) {attr(x, "label", exact = TRUE)},
    FUN.VALUE = character(1L),
    USE.NAMES = TRUE
  )

  #-----------------------------------------------------------------------------
  # Determine what we are conditioning on and get values to hold constant for
  # the left_join below. We don't want to plot data that is being conditioned on.
  # Because nsims may unexpectedly be reduced, we will need to handle this separately.
  #-----------------------------------------------------------------------------
  # Exclude unnecessary variables.
  unused <- setdiff(names(data), axis)
  unused <- unused[!unused %in% c("nsims", "data", "result")]

  # Don't lose labels during mutate (middle.labelled)
  condition_at <- data |>
    summarize(across(.cols = all_of(unused), .fns = middle.labelled)) |>
    select(
      any_of(
        c("n1", "n2", "n", "ratio", "mean1", "cv", "cv1", "cv2", "dispersion1",
          "dispersion2", "dispersion", "cor", "alpha", "alternative", "mean_null",
          "ratio_null", "test")
      )
    ) |>
    select(
      -any_of({{exclude}})
    )

  # Don't want these variables to be numeric, so factorize them
  vars_to_factorize <- c(color)
  vars_to_factorize <- vars_to_factorize[!is.na(vars_to_factorize)]
  if(length(vars_to_factorize) == 0L) {vars_to_factorize <- NULL}

  # Create data frame for plotting
  df_plot <- condition_at |>
    left_join(data, by = names(condition_at)) |>
    mutate(across(.cols = any_of({{vars_to_factorize}}), .fns = as.factor))

  # now add nsims back to condition_at
  if("nsims" %in% names(data)) {
    df_nsims <- data |>
      select(nsims) |>
      filter(!duplicated(nsims))
    if(nrow(df_nsims) > 1L) {
      df_nsims <- df_nsims |>
        summarize(nsims = paste0("Varying: ", "min=", min(nsims), ",max=", max(nsims)))
      attr(df_nsims[["nsims"]], "label") <- "N Simulations"
    }
    condition_at <- bind_cols(condition_at, df_nsims)
  }

  # Replace names with labels and convert to list
  names(condition_at) <- vapply(
    X = condition_at,
    FUN = function(x) {attr(x, "label", exact = TRUE)},
    FUN.VALUE = character(1L),
    USE.NAMES = FALSE
  )
  condition_at <- as.list(condition_at)

  # Return
  list(df_plot = df_plot, axis_labels = axis_labels, condition_at = condition_at)
}

#-------------------------------------------------------------------------------
# Build geoms using a list
#-------------------------------------------------------------------------------
geom_builder <- function(
    condition_at,
    x_axis,
    y_axis,
    color,
    facet_row,
    facet_col,
    hline,
    caption,
    caption_width,
    axis_labels
) {
  list(
    if(is.na(color)) {
      geom_point()
    } else {
      geom_point(aes(color = .data[[color]], group = .data[[color]]))
    },
    if(is.na(color)) {
      geom_line()
    } else {
      geom_line(aes(color = .data[[color]], group = .data[[color]]))
    },
    if(x_axis %in% c("n1", "n2", "n")) {
      scale_x_continuous(breaks = ~round(unique(pretty(.)))) # integer breaks
    },
    if(x_axis %in% c("power")) {
      scale_x_continuous(limits = c(0, 1), labels = percent)
    },
    if(y_axis %in% c("n1", "n2", "n")) {
      scale_y_continuous(breaks = ~round(unique(pretty(.)))) # integer breaks
    },
    if(y_axis %in% c("power")) {
      scale_y_continuous(limits = c(0, 1), labels = percent)
    },
    if(!is.na(facet_row) && is.na(facet_col)) {
      facet_grid(
        rows = vars(.data[[facet_row]]),
        labeller = labeller(.rows = label_both2)
      )
    },
    if(is.na(facet_row) && !is.na(facet_col)) {
      facet_grid(
        cols = vars(.data[[facet_col]]),
        labeller = labeller(.cols = label_both2)
      )
    },
    if(!is.na(facet_row) && !is.na(facet_col)) {
      facet_grid(
        rows = vars(.data[[facet_row]]),
        cols = vars(.data[[facet_col]]),
        labeller = labeller(.rows = label_both2, .cols = label_both2)
      )
    },
    scale_color_discrete(labels = round2),
    labs(x = axis_labels[match(x_axis, names(axis_labels))]),
    labs(y = axis_labels[match(y_axis, names(axis_labels))]),
    if(!is.na(color)) {
      labs(color = axis_labels[match(color, names(axis_labels))])
    },
    if(!is.null(hline)) {geom_hline(yintercept = hline, alpha = 0.5)},
    if(caption) {labs(caption = caption_builder(condition_at, caption_width))}
  )
}

# Build caption for plot
caption_builder <- function(condition_at, caption_width) {
  if(length(condition_at) == 0L) {
    return(NULL)
  }
  paste0(
    "Conditioned on: ",
    csw(
      paste0(names(condition_at), "=", round2(condition_at)),
      quote = FALSE,
      and = TRUE,
      period = TRUE,
      new_line = Inf
    )
  ) |>
    str_wrap(width = caption_width, collapse = "\n")
}

# Add rounding to ggplot2::label_both() because we don't want long decimals
label_both2 <- function(labels, sep = ": ") {
  value <- lapply(labels, round2)
  variable <- lapply(
    as.list(names(labels)),
    rep,
    if(is.null(nrow(labels))) length(labels[[1]]) else nrow(labels)
  )
  out <- vector("list", length(value))
  for(i in seq_along(out)) {
    out[[i]] <- paste(variable[[i]], value[[i]], sep = sep)
  }
  out
}
attr(label_both2, "class") <- c("function", "labeller")

remove_used_axis <- function(x) {
 if(length(x) > 1L) {
   x <- x[-1L]
 } else {
   x <- NA
 }
  x
}

utils::globalVariables(c(".data", "nsims"))

Try the depower package in your browser

Any scripts or data that you put into this service are public.

depower documentation built on April 3, 2025, 9:23 p.m.