graphicalMCP coverage - 96.92%

Files
Source

#' Create the initial graph for a multiple comparison procedure
#'
#' @description
#' A graphical multiple comparison procedure is represented by 1) a vector of
#' initial hypothesis weights `hypotheses`, and 2) a matrix of initial
#' transition weights `transitions`. This function creates the initial graph
#' object using hypothesis weights and transition weights.
#'
#' @param hypotheses A numeric vector of hypothesis weights in a graphical
#'   multiple comparison procedure. Must be a vector of values between 0 & 1
#'   (inclusive). The length should match the row and column lengths of
#'   `transitions`. The sum of hypothesis weights should not exceed 1.
#' @param transitions A numeric matrix of transition weights between hypotheses
#'   in a graphical multiple comparison procedure. Must be a square matrix of
#'   values between 0 & 1 (inclusive). The row and column lengths should match
#'   the length of `hypotheses`. Each row (Transition weights leaving a
#'   hypothesis) can sum to no more than 1. The diagonal entries (Transition
#'   weights from a hypothesis to itself) must be all 0s.
#' @param hyp_names (Optional) A character vector of hypothesis names. If not
#'   provided, names from `hypotheses` and `transitions` will be used. If names
#'   are not specified, hypotheses will be named sequentially as H1, H2, .......
#'
#' @return An S3 object of class `initial_graph` with a list of 2 elements:
#'   * Hypothesis weights `hypotheses`.
#'   * Transition weights `transitions`.
#'
#' @section Validation of inputs:
#'  Inputs are also validated to make sure of the validity of the graph:
#'   * Hypothesis weights `hypotheses` are numeric.
#'   * Transition weights `transitions` are numeric.
#'   * Length of `hypotheses` and dimensions of `transitions` match.
#'   * Hypothesis weights `hypotheses` must be non-negative and sum to no more
#'     than 1.
#'   * Transition weights `transitions`:
#'      + Values must be non-negative.
#'      + Rows must sum to no more than 1.
#'      + Diagonal entries must be all 0.
#'   * Hypothesis names `hyp_names` override names in `hypotheses` or
#'     `transitions`.
#'
#' @seealso
#'   [graph_update()] for the updated graph after hypotheses being deleted
#'   from the initial graph.
#'
#' @rdname graph_create
#'
#' @export
#'
#' @references
#'   Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
#'   approach to sequentially rejective multiple test procedures.
#'   \emph{Statistics in Medicine}, 28(4), 586-604.
#'
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 1 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' transitions <- rbind(
#'   c(0, 0, 1, 0),
#'   c(0, 0, 0, 1),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' hyp_names <- c("H11", "H12", "H21", "H22")
#' g <- graph_create(hypotheses, transitions, hyp_names)
#' g
#'
#' # Explicit names override names in `hypotheses` (with a warning)
#' hypotheses <- c(h1 = 0.5, h2 = 0.5, h3 = 0, h4 = 0)
#' transitions <- rbind(
#'   c(0, 0, 1, 0),
#'   c(0, 0, 0, 1),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions, hyp_names)
#' g
#'
#' # Use names in `transitions`
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' transitions <- rbind(
#'   H1 = c(0, 0, 1, 0),
#'   H2 = c(0, 0, 0, 1),
#'   H3 = c(0, 1, 0, 0),
#'   H4 = c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#' g
#'
#' # Unmatched names in `hypotheses` and `transitions` (with an error)
#' hypotheses <- c(h1 = 0.5, h2 = 0.5, h3 = 0, h4 = 0)
#' transitions <- rbind(
#'   H1 = c(0, 0, 1, 0),
#'   H2 = c(0, 0, 0, 1),
#'   H3 = c(0, 1, 0, 0),
#'   H4 = c(1, 0, 0, 0)
#' )
#' try(
#'   g <- graph_create(hypotheses, transitions)
#' )
#'
#' # When names are not specified, hypotheses are numbered sequentially as
#' # H1, H2, ...
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' transitions <- rbind(
#'   c(0, 0, 1, 0),
#'   c(0, 0, 0, 1),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#' g
graph_create <- function(hypotheses, transitions, hyp_names = NULL) {
  # Basic input validation -----------------------------------------------------
  stopifnot(
    "Hypothesis weights must be numeric" = is.numeric(hypotheses),
    "Transition weights must be numeric" = is.numeric(transitions)
  )

  if (
    any(
      nrow(transitions) != ncol(transitions),
      nrow(transitions) != length(hypotheses),
      ncol(transitions) != length(hypotheses)
    )
  ) {
    stop("Length of `hypotheses`, rows of `transitions`, and columns of
             `transitions` must all match")
  }

  # Validation of names of hypotheses ----------------------------------------
  explicit_names <- !is.null(hyp_names)

  implicit_names <- any(
    !is.null(names(hypotheses)),
    !is.null(colnames(transitions)),
    !is.null(rownames(transitions))
  )

  names_diff <- any(
    names(hypotheses) != colnames(transitions),
    names(hypotheses) != rownames(transitions),
    colnames(transitions) != rownames(transitions)
  )

  if (implicit_names && explicit_names) {
    warning("Hypothesis names specified - overriding names in
                    `hypotheses` and `transitions`")
  } else if (implicit_names && names_diff) {
    stop("Names provided in `hypotheses` and `transitions` should match")
  } else if (implicit_names) {
    hyp_names <- unique(
      c(names(hypotheses), colnames(transitions), rownames(transitions))
    )
  } else if (!explicit_names) {
    hyp_names <- paste0("H", seq_along(hypotheses))
  }

  names(hypotheses) <-
    colnames(transitions) <- rownames(transitions) <- hyp_names

  # Validation of numerical conditions for a valid graphical multiple
  # comparison procedure -----------------------------------------------------
  if (any(hypotheses < 0 | hypotheses > 1)) {
    offending <- hypotheses[hypotheses < 0 | hypotheses > 1]
    not_zero_float <- sapply(offending, function(x) !isTRUE(all.equal(0, x)))
    not_one_float <- sapply(offending, function(x) !isTRUE(all.equal(1, x)))

    if (any(not_zero_float & not_one_float)) {
      stop("Hypothesis weights must be between 0 and 1")
    }
  }

  if (sum(hypotheses) > 1 && !isTRUE(all.equal(sum(hypotheses), 1))) {
    stop("Hypothesis weights must sum to no more than 1")
  }

  if (any(transitions < 0 | transitions > 1)) {
    offending <- transitions[transitions < 0 | transitions > 1, drop = TRUE]
    not_zero_float <- sapply(offending, function(x) !isTRUE(all.equal(0, x)))
    not_one_float <- sapply(offending, function(x) !isTRUE(all.equal(1, x)))

    if (any(not_zero_float & not_one_float)) {
      stop("Transition weights must be between 0 and 1")
    }
  }

  not_zero_float <- sapply(
    diag(transitions),
    function(x) !isTRUE(all.equal(0, x))
  )

  if (any(not_zero_float)) {
    stop("Diagonal of transition weights must be all 0s")
  }

  if (any(rowSums(transitions) > 1)) {
    not_one_float <- sapply(
      rowSums(transitions[rowSums(transitions) > 1, , drop = FALSE]),
      function(x) !isTRUE(all.equal(1, x))
    )

    if (any(not_one_float)) {
      stop("Transition weights from each row must sum to no more than 1")
    }
  }

  # Warn about very small transition weights that may cause numerical issues
  if (any(transitions > 0 & transitions < 1e-6)) {
    warning(
      "Some transition weights are very small (< 1e-6). This may cause ",
      "numerical instability in hypothesis weights due to floating-point ",
      "precision. Consider using larger values."
    )
  }

  # Create an initial graph object ---------------------------------------------
  new_graph <- structure(
    list(hypotheses = hypotheses, transitions = transitions),
    class = "initial_graph",
    title = "Initial graph",
    deleted = NULL
  )
  new_graph
}

#' Calculate the sequential p-value for a single hypothesis
#'
#' @description
#' A sequential p-value is the minimum significance level at which a group
#' sequential boundary would be crossed at any analysis up to and including the
#' current one. It is computed using the group sequential boundaries derived
#' from the spending function and the joint distribution of test statistics
#' across analyses.
#'
#' Sequential p-values are used in graphical multiple comparison procedures
#' for group sequential designs. They allow the separation of the group
#' sequential testing (handled by the spending function and boundaries) from
#' the multiplicity adjustment (handled by the graph). See Maurer and Bretz
#' (2013) for details.
#'
#' @param p A numeric vector of p-values at each analysis for a single
#'   hypothesis. The length must match the length of `info_frac`. All values
#'   must be non-missing and between 0 and 1.
#' @param info_frac A numeric vector of information fractions at each analysis.
#'   Values must be in (0, 1] and monotonically non-decreasing. The length
#'   should match the length of `p`.
#' @param spending_fn A spending function. Must accept two arguments:
#'   `alpha` (total significance level) and `info_frac` (information fraction), and
#'   return the cumulative alpha spent at information fraction `t`. Built-in
#'   options include [spending_of()], [spending_pocock()], [spending_hsd()],
#'   and [spending_linear()].
#' @param tol A numeric scalar for the tolerance of the root-finding
#'   algorithm. The default is `1e-6`.
#' @param maxpts An integer scalar for the maximum number of function values
#'   for `mvtnorm::GenzBretz`. The default is 25000.
#' @param abseps A numeric scalar for the absolute error tolerance for
#'   `mvtnorm::GenzBretz`. The default is 1e-6.
#'
#' @return A numeric scalar of the sequential p-value.
#'
#' @details
#' For a hypothesis tested at analyses \eqn{k = 1, \ldots, K} with p-values
#' \eqn{p^{(k)}} and information fractions \eqn{t^{(k)}}, the sequential
#' p-value is the minimum \eqn{\tilde{p}} such that for some analysis
#' \eqn{k}, the observed p-value \eqn{p^{(k)}} crosses the group sequential
#' boundary \eqn{c_k(\tilde{p})} derived from the spending function:
#' \deqn{\tilde{p} = \min\{\alpha : p^{(k)} \le c_k(\alpha)
#' \text{ for some } k\},}
#' where \eqn{c_k(\alpha)} is the nominal p-value boundary at analysis
#' \eqn{k} when the total significance level is \eqn{\alpha}.
#'
#' The boundary \eqn{c_k(\alpha)} is computed from the spending function
#' \eqn{f(\alpha, t)} using the joint distribution of test statistics.
#' Specifically, the Z-scale boundary \eqn{b_k} satisfies
#' \deqn{P(Z_1 < b_1, \ldots, Z_k < b_k) = 1 - f(\alpha, t_k),}
#' and \eqn{c_k = 1 - \Phi(b_k)}. Note that \eqn{c_k \neq
#' f(\alpha, t_k) - f(\alpha, t_{k-1})} for \eqn{k > 1} due to the
#' correlation between test statistics across analyses.
#'
#' The sequential p-value is found using [stats::uniroot()] on the function
#' \eqn{g(\alpha) = \max_k (z_k - b_k(\alpha))}, where \eqn{z_k =
#' \Phi^{-1}(1 - p^{(k)})} is the observed Z-statistic and \eqn{b_k(\alpha)}
#' is the Z-scale boundary. This function is monotonically increasing in
#' \eqn{\alpha} since boundaries become less stringent as \eqn{\alpha}
#' increases.
#'
#' @seealso
#'   [gs_boundaries()] for computing group sequential boundaries,
#'   [graph_test_shortcut_gsd()] for graphical multiple comparison procedures
#'   with group sequential designs, [spending_of()], [spending_pocock()],
#'   [spending_hsd()], [spending_linear()] for spending functions.
#'
#' @rdname sequential_p
#'
#' @export
#'
#' @references
#'   Maurer, W., and Bretz, F. (2013). Multiple testing in group sequential
#'   trials using graphical approaches. \emph{Statistics in Biopharmaceutical
#'   Research}, 5(4), 311-320.
#'
#'   Liu, Q., and Anderson, K. M. (2008). On adaptive extensions of group
#'   sequential trials for clinical investigations. \emph{Journal of the
#'   American Statistical Association}, 103(484), 1621-1630.
#'
#' @examples
#' # A hypothesis tested at two analyses (interim at 50% and final at 100%)
#' sequential_p(
#'   p = c(0.024, 0.01),
#'   info_frac = c(0.5, 1),
#'   spending_fn = spending_of
#' )
#'
#' # Sequential p-value with Pocock spending
#' sequential_p(
#'   p = c(0.024, 0.01),
#'   info_frac = c(0.5, 1),
#'   spending_fn = spending_pocock
#' )
#'
#' # Sequential p-value updates as more analyses are conducted
#' # After analysis 1 only
#' sequential_p(
#'   p = 0.05,
#'   info_frac = 0.3,
#'   spending_fn = spending_of
#' )
#'
#' # After analyses 1 and 2
#' sequential_p(
#'   p = c(0.05, 0.02),
#'   info_frac = c(0.3, 0.7),
#'   spending_fn = spending_of
#' )
#'
#' # After all three analyses
#' sequential_p(
#'   p = c(0.05, 0.02, 0.01),
#'   info_frac = c(0.3, 0.7, 1),
#'   spending_fn = spending_of
#' )
sequential_p <- function(p,
                         info_frac,
                         spending_fn,
                         tol = 1e-6,
                         maxpts = 25000,
                         abseps = 1e-6) {
  stopifnot(
    "p must be a numeric vector" = is.numeric(p),
    "p must not contain NA" = !anyNA(p),
    "p must be between 0 and 1" = all(p >= 0 & p <= 1),
    "info_frac must be a numeric vector" = is.numeric(info_frac),
    "info_frac must not contain NA" = !anyNA(info_frac),
    "p and info_frac must have the same length" = length(info_frac) == length(p)
  )

  # Convert observed p-values to Z-statistics
  z_obs <- stats::qnorm(1 - p)

  # For a candidate alpha, compute boundaries and return the maximum
  # exceedance: max_k(z_obs[k] - b_k(alpha)).
  # Positive means at least one boundary is crossed.
  # This function is monotonically increasing in alpha since boundaries
  # decrease (become less stringent) as alpha increases.
  max_exceedance <- function(alpha_candidate) {
    bounds <- gs_boundaries(
      alpha = alpha_candidate,
      info_frac = info_frac,
      spending_fn = spending_fn,
      maxpts = maxpts,
      abseps = abseps
    )

    max(z_obs - bounds$bounds_z)
  }

  # Check edge cases before root-finding.
  # The search interval is [lower, upper] = [tol, 1 - tol] to avoid
  # numerical issues at the exact boundaries 0 and 1.
  upper <- 1 - tol
  lower <- tol

  # If no boundary is crossed even at the most lenient alpha (~1),
  # the observed p-values are too large to ever be significant.
  # Return 1 (the largest possible sequential p-value).
  exc_upper <- tryCatch(
    max_exceedance(upper),
    error = function(e) NA_real_
  )
  if (is.na(exc_upper) || exc_upper <= 0) {
    message("No boundary crossed; returning 1 as an upper bound.")
    return(1)
  }

  # If a boundary is already crossed at the most stringent alpha (~0),
  # the observed p-values are extremely small. Return the lower bound.
  # Use >= 0 to also handle the edge case where the exceedance is exactly 0
  # (boundary exactly crossed), which would cause uniroot to fail because
  # f(lower) and f(upper) would have the same sign.
  exc_lower <- tryCatch(
    max_exceedance(lower),
    error = function(e) {
      # gs_boundaries can fail at very small alpha due to numerical issues
      # in pmvnorm. Treat this as the boundary being extremely large
      # (i.e., not crossed), so exceedance is negative.
      -1
    }
  )
  if (exc_lower >= 0) {
    message(
      "Boundary crossed at alpha = ", lower,
      "; returning ", lower, " as a lower bound."
    )
    return(lower)
  }

  # Find the root: minimum alpha where boundary is crossed.
  # Wrap in tryCatch to handle numerical edge cases in uniroot.
  result <- tryCatch(
    stats::uniroot(
      max_exceedance,
      interval = c(lower, upper),
      tol = tol
    ),
    error = function(e) {
      # If uniroot fails, try with a wider lower bound
      tryCatch(
        stats::uniroot(
          max_exceedance,
          interval = c(lower * 10, upper),
          tol = tol
        ),
        error = function(e2) {
          message(
            "Root-finding failed; returning ", lower,
            " as a lower bound. Original error: ", e$message
          )
          list(root = lower)
        }
      )
    }
  )

  result$root
}

#' Perform closed graphical multiple comparison procedures
#'
#' @description
#' Closed graphical multiple comparison procedures, or graphical multiple
#' comparison procedures based on the closure, generate the closure based on a
#' graph consisting of all intersection hypotheses. It tests each intersection
#' hypothesis and rejects an individual hypothesis if all intersection
#' hypotheses involving it have been rejected. An intersection hypothesis
#' represents the parameter space where individual null hypotheses involved are
#' true simultaneously.
#'
#' For a graphical multiple comparison procedure with $m$ hypotheses, there are
#' \eqn{2^m-1} intersection hypotheses. For each intersection hypothesis, a test
#' type could be chosen to determine how to reject the intersection hypothesis.
#' Current choices of test types include Bonferroni, Simes and parametric. This
#' implementation offers a more general framework covering Bretz et al. (2011),
#' Lu (2016), and Xi et al. (2017). See `vignette("closed-testing")` for more
#' illustration of closed test procedures and interpretation of their outputs.
#'
#' @inheritParams graph_update
#' @param p A numeric vector of p-values (unadjusted, raw), whose values should
#'   be between 0 & 1. The length should match the number of hypotheses in
#'   `graph`.
#' @param alpha A numeric value of the overall significance level, which should
#'   be between 0 & 1. The default is 0.025 for one-sided hypothesis testing
#'   problems; another common choice is 0.05 for two-sided hypothesis testing
#'   problems. Note when parametric tests are used, only one-sided tests are
#'   supported.
#' @param test_groups A list of numeric vectors specifying hypotheses to test
#'   together. Grouping is needed to correctly perform Simes and parametric
#'   tests.
#' @param test_types A character vector of test types to apply to each test
#'   group. This is needed to correctly perform Simes and parametric
#'   tests. The length should match the number of elements in `test_groups`.
#' @param test_corr (Optional) A list of numeric correlation matrices. Each
#'   entry in the list should correspond to each test group. For a test group
#'   using Bonferroni or Simes tests, its corresponding entry in `test_corr`
#'   should be `NA`. For a test group using parametric tests, its
#'   corresponding entry in `test_corr` should be a numeric correlation matrix
#'   specifying the correlation between test statistics for hypotheses in this
#'   test group. The length should match the number of elements in
#'   `test_groups`.
#' @param verbose A logical scalar specifying whether the details of the
#'   adjusted p-value calculations should be included in results. When
#'   `verbose = TRUE`, adjusted p-values are provided for each intersection
#'   hypothesis. The default is `verbose = FALSE`.
#' @param test_values A logical scalar specifying whether adjusted significance
#'   levels should be provided for each hypothesis. When `test_values = TRUE`,
#'   it provides an equivalent way of performing graphical multiple comparison
#'   procedures by comparing each p-value with its significance level. If the
#'   p-value of a hypothesis is less than or equal to its significance level,
#'   the hypothesis is rejected. The default is `test_values = FALSE`.
#'
#' @return A `graph_report` object with a list of 4 elements:
#'   * `inputs` - Input parameters, which is a list of:
#'     * `graph` - Initial graph,
#'     * `p` - (Unadjusted or raw) p-values,
#'     * `alpha` - Overall significance level,
#'     * `test_groups` - Groups of hypotheses for different types of tests,
#'     * `test_types` - Different types of tests,
#'     * `test_corr` - Correlation matrices for parametric tests.
#'   * `outputs` - Output parameters, which is a list of:
#'     * `adjusted_p` - Adjusted p-values,
#'     * `rejected` - Rejected hypotheses,
#'     * `graph` - Updated graph after deleting all rejected hypotheses.
#'   * `details` - Verbose outputs with adjusted p-values for intersection
#'   hypotheses, if `verbose = TRUE`.
#'   * `test_values` - Adjusted significance levels, if `test_values = TRUE`.
#'
#' @section Details for test specification:
#' Test specification includes three components: `test_groups`, `test_types`,
#' and `test_corr`. Alignment among entries in these components is important
#' for correct implementation. There are two ways to provide test specification.
#' The first approach is the "unnamed" approach, which assumes that all 3
#' components are ordered the same way, i.e., the $n$-th element of `test_types`
#' and `test_corr` should apply to the $n$-th group in `test_groups`. The
#' second "named" approach uses the name of each element of each component to
#' connect the element of `test_types` and `test_corr` with the correct element
#' of `test_groups`. Consistency should be ensured for correct implementation.
#'
#' @seealso
#'   [graph_test_shortcut()] for shortcut graphical multiple comparison
#'   procedures.
#'
#' @rdname graph_test_closure
#'
#' @export
#'
#' @references
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#'   Lu, K. (2016). Graphical approaches using a Bonferroni mixture of weighted
#'   Simes tests. \emph{Statistics in Medicine}, 35(22), 4041-4055.
#'
#'   Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework
#'   for weighted parametric multiple test procedures.
#'   \emph{Biometrical Journal}, 59(5), 918-931.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses
#' # (H1 and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 4 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' delta <- 0.5
#' transitions <- rbind(
#'   c(0, delta, 1 - delta, 0),
#'   c(delta, 0, 0, 1 - delta),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#'
#' p <- c(0.018, 0.01, 0.105, 0.006)
#' alpha <- 0.025
#'
#' # Closed graphical multiple comparison procedure using Bonferroni tests
#' # Same results as `graph_test_shortcut(g, p, alpha)`
#' graph_test_closure(g, p, alpha)
#'
#' # Closed graphical multiple comparison procedure using parametric tests for
#' # H1 and H2, and Bonferroni tests for H3 and H4
#' set.seed(1234)
#' corr_list <- list(matrix(c(1, 0.5, 0.5, 1), nrow = 2), NA)
#' graph_test_closure(
#'   graph = g,
#'   p = p,
#'   alpha = alpha,
#'   test_groups = list(1:2, 3:4),
#'   test_types = c("parametric", "bonferroni"),
#'   test_corr = corr_list
#' )
#' # The "named" approach to obtain the same results
#' # Note that "group2" appears before "group1" in `test_groups`
#' set.seed(1234)
#' corr_list <- list(group1 = matrix(c(1, 0.5, 0.5, 1), nrow = 2), group2 = NA)
#' graph_test_closure(
#'   graph = g,
#'   p = p,
#'   alpha = alpha,
#'   test_groups = list(group1 = 1:2, group2 = 3:4),
#'   test_types = c(group2 = "bonferroni", group1 = "parametric"),
#'   test_corr = corr_list
#' )
#'
#' # Closed graphical multiple comparison procedure using parametric tests for
#' # H1 and H2, and Simes tests for H3 and H4
#' set.seed(1234)
#' graph_test_closure(
#'   graph = g,
#'   p = p,
#'   alpha = alpha,
#'   test_groups = list(group1 = 1:2, group2 = 3:4),
#'   test_types = c(group1 = "parametric", group2 = "simes"),
#'   test_corr = corr_list
#' )
graph_test_closure <- function(graph,
                               p,
                               alpha = 0.025,
                               test_groups = list(seq_along(graph$hypotheses)),
                               test_types = c("bonferroni"),
                               test_corr = rep(list(NA), length(test_types)),
                               verbose = FALSE,
                               test_values = FALSE) {
  # Input validation & sanitization --------------------------------------------
  # Test types should be specified as full names or first initial,
  # case-insensitive. A single provided test type should be applied to all
  # groups.
  test_types_names <- names(test_types)
  test_opts <- c(
    bonferroni = "bonferroni",
    parametric = "parametric",
    simes = "simes",
    hochberg = "hochberg",
    b = "bonferroni",
    p = "parametric",
    s = "simes",
    h = "hochberg"
  )
  test_types <- test_opts[tolower(test_types)]
  names(test_types) <- test_types_names
  if (length(test_types) == 1) {
    test_types <- rep(test_types, length(test_groups))
  }

  test_input_val(
    graph,
    p,
    alpha,
    test_groups,
    test_types,
    test_corr,
    verbose,
    test_values
  )

  # The test specification arguments can be named or not. However, if
  # `test_groups` is named, all of them must be named. The other two are
  # re-ordered to match `test_groups`
  if (!is.null(names(test_groups))) {
    if (!all(c(names(test_types), names(test_corr)) %in% names(test_groups))) {
      stop("If `test_groups` is named, `test_types` and `test_corr` must use the
           same names")
    } else {
      test_types <- test_types[names(test_groups)]
      test_corr <- test_corr[names(test_groups)]
    }
  } else {
    names(test_groups) <-
      names(test_types) <-
      names(test_corr) <-
      paste0("grp", seq_along(test_groups))
  }

  num_hyps <- length(graph$hypotheses)
  num_groups <- length(test_groups)

  hyp_names <- names(graph$hypotheses)
  names(p) <- hyp_names

  # Correlation matrix input is easier for end users to input as a list, but
  # it's easier to work with internally as a full matrix, potentially with
  # missing values. This puts all the correlation pieces into one matrix
  new_corr <- matrix(NA, num_hyps, num_hyps)

  for (group_num in seq_along(test_groups)) {
    new_corr[test_groups[[group_num]], test_groups[[group_num]]] <-
      test_corr[[group_num]]
  }
  diag(new_corr) <- 1
  test_corr <- if (any(test_types == "parametric")) new_corr else NULL

  if (!is.null(test_corr)) dimnames(test_corr) <- list(hyp_names, hyp_names)

  # Generate weights of the closure --------------------------------------------
  weighting_strategy <- graph_generate_weights(graph)
  matrix_intersections <- weighting_strategy[, seq_len(num_hyps), drop = FALSE]

  # "Compact" representation shows hypothesis weights where a hypothesis is
  # present (even when that weight is 0), and NA where a hypothesis is missing.
  # This form represents the closure with only `num_hyps` columns
  weighting_strategy_compact <- ifelse(
    matrix_intersections,
    weighting_strategy[, seq_len(num_hyps) + num_hyps, drop = FALSE],
    NA_real_
  )

  num_intersections <- nrow(matrix_intersections)

  adjusted_p <- matrix(
    NA_real_,
    nrow = num_intersections,
    ncol = num_groups,
    dimnames = list(NULL, paste0("adj_p_grp", seq_along(test_groups)))
  )

  # Calculate adjusted p-values ------------------------------------------------
  # Adjusted p-values are calculated for each group in each intersection of the
  # closure
  for (intersection_index in seq_len(num_intersections)) {
    vec_intersection <- matrix_intersections[intersection_index, , drop = TRUE]
    vec_weights <-
      weighting_strategy_compact[intersection_index, , drop = TRUE]

    for (group_index in seq_len(num_groups)) {
      group <- test_groups[[group_index]]
      test <- test_types[[group_index]]

      # Hypotheses to include in adjusted p-value calculations must be in both
      # the current group and the current intersection
      group_by_intersection <- group[as.logical(vec_intersection[group])]

      # The adjusted p-value for a *group* has varying rules depending on the
      # test type. Each `adjust_p_*` function expects a whole group as input and
      # returns a single value as output (adjusted p-value for the whole group)
      if (test == "bonferroni") {
        adjusted_p[[intersection_index, group_index]] <- adjust_p_bonferroni(
          p[group_by_intersection],
          vec_weights[group_by_intersection]
        )
      } else if (test == "simes") {
        adjusted_p[[intersection_index, group_index]] <- adjust_p_simes(
          p[group_by_intersection],
          vec_weights[group_by_intersection]
        )
      } else if (test == "hochberg") {
        adjusted_p[[intersection_index, group_index]] <- adjust_p_hochberg(
          p[group_by_intersection],
          vec_weights[group_by_intersection]
        )
      } else if (test == "parametric") {
        adjusted_p[[intersection_index, group_index]] <- adjust_p_parametric(
          p[group_by_intersection],
          vec_weights[group_by_intersection],
          test_corr[group_by_intersection, group_by_intersection, drop = FALSE]
        )
      } else {
        stop(paste(test, "testing is not supported at this time"))
      }
    }
  }

  # Adjusted p-value summaries -------------------------------------------------
  # The adjusted p-value for an *intersection* is the smallest adjusted p-value
  # for the groups it contains
  adjusted_p_intersection <- apply(adjusted_p, 1, min)

  # When parametric tests are used, mvtnorm::pmvnorm introduces Monte Carlo
  # error (controlled by abseps, default 1e-6). A small tolerance is added to
  # rejection comparisons to avoid false non-rejections at the boundary.
  tol <- if (any(test_types == "parametric")) 1e-6 else .Machine$double.eps

  reject_intersection <- adjusted_p_intersection <= (alpha + tol)

  # The adjusted p-value for a *hypothesis* is the largest adjusted p-value for
  # the intersections containing that hypothesis
  adjusted_p_hypothesis <-
    apply(adjusted_p_intersection * matrix_intersections, 2, max, na.rm = TRUE)
  reject_hypothesis <- adjusted_p_hypothesis <= (alpha + tol)

  # Adjusted p-value details ---------------------------------------------------
  # Reported adjusted p-values shouldn't exceed 1
  intersections <- apply(matrix_intersections, 1, paste, collapse = "")

  detail_results <- list(
    results = cbind(
      data.frame(Intersection = intersections),
      weighting_strategy_compact,
      pmin(adjusted_p, 1 + 1e-14),
      data.frame(adj_p_inter = pmin(adjusted_p_intersection, 1 + 1e-14)),
      data.frame(reject_intersection = reject_intersection)
    )
  )

  # Adjusted weight details ----------------------------------------------------
  if (test_values) {
    # Adjusted weights are recorded in a dataframe, which doesn't store in a
    # matrix. So for the test values loops, each group's adjusted weight
    # dataframe is stored in a list. These are the initialized list and counter
    # for indexing into it.
    test_values_index <- 1
    test_values_list <- vector("list", num_intersections * num_groups)

    # Adjusted weights are calculated for each group in each intersection of the
    # closure
    for (intersection_index in seq_len(num_intersections)) {
      vec_intersection <-
        matrix_intersections[intersection_index, , drop = TRUE]
      vec_weights <-
        weighting_strategy_compact[intersection_index, , drop = TRUE]

      str_intersection <- paste(vec_intersection, collapse = "")

      for (group_index in seq_len(num_groups)) {
        group <- test_groups[[group_index]]
        test <- test_types[[group_index]]

        # Hypotheses to include in adjusted weight calculations must be in both
        # the current group and the current intersection
        group_by_intersection <- group[as.logical(vec_intersection[group])]

        # adjusted weights, like adjusted p-values, must be calculated at both
        # the group and intersection level. Inputs are for a single group, and
        # output is a dataframe containing adjusted weight test information at
        # the hypothesis/operand level.
        if (test == "bonferroni") {
          test_values_list[[test_values_index]] <- test_values_bonferroni(
            p[group_by_intersection],
            vec_weights[group_by_intersection],
            alpha,
            str_intersection
          )
        } else if (test == "simes") {
          test_values_list[[test_values_index]] <- test_values_simes(
            p[group_by_intersection],
            vec_weights[group_by_intersection],
            alpha,
            str_intersection
          )
        } else if (test == "hochberg") {
          test_values_list[[test_values_index]] <- test_values_hochberg(
            p[group_by_intersection],
            vec_weights[group_by_intersection],
            alpha,
            str_intersection
          )
        } else if (test == "parametric") {
          test_values_list[[test_values_index]] <- test_values_parametric(
            p[group_by_intersection],
            vec_weights[group_by_intersection],
            alpha,
            str_intersection,
            test_corr[group_by_intersection,
              group_by_intersection,
              drop = FALSE
            ]
          )
        } else {
          stop(paste(test, "testing is not supported at this time"))
        }

        test_values_index <- test_values_index + 1
      }
    }

    df_test_values <- do.call(rbind, test_values_list)
    rownames(df_test_values) <- NULL

    # sort by hypothesis natural order
    df_test_values$Hypothesis <-
      factor(df_test_values$Hypothesis, levels = hyp_names, ordered = TRUE)

    df_test_values <-
      df_test_values[with(df_test_values, order(-as.numeric(Intersection), Hypothesis)), ]

    # "c" value is only used in parametric testing, so there's no need to
    # include this column when there are no parametric groups
    if (!any(test_types == "parametric")) {
      df_test_values[c("c_value")] <- NULL
    }
  }

  # Build the report -----------------------------------------------------------
  # The core output of a test report is the adjusted p-values, rejection
  # decisions, and resulting graph after deleting all rejected hypotheses.
  # Inputs are recorded as well. Details about adjusted p-values and test
  # values are optionally available.
  structure(
    list(
      inputs = list(
        graph = graph,
        p = p,
        alpha = alpha,
        test_groups = test_groups,
        test_types = test_types,
        test_corr = test_corr
      ),
      outputs = list(
        adjusted_p = pmin(adjusted_p_hypothesis, 1 + 1e-14), # Cap reported at 1
        rejected = reject_hypothesis,
        graph = graph_update(graph, reject_hypothesis)$updated_graph
      ),
      details = if (verbose) detail_results,
      test_values = if (test_values) list(results = df_test_values)
    ),
    class = "graph_report"
  )
}

#' Validate inputs for testing and power simulations
#'
#' @param graph An initial graph as returned by [graph_create()].
#' @param p A numeric vector of p-values (unadjusted, raw), whose values should
#'   be between 0 & 1. The length should match the number of hypotheses in
#'   `graph`.
#' @param alpha A numeric value of the overall significance level, which should
#'   be between 0 & 1. The default is 0.025 for one-sided hypothesis testing
#'   problems; another common choice is 0.05 for two-sided hypothesis testing
#'   problems. Note when parametric tests are used, only one-sided tests are
#'   supported.
#' @param test_groups A list of numeric vectors specifying hypotheses to test
#'   together. Grouping is needed to correctly perform Simes and parametric
#'   tests.
#' @param test_types A character vector of test types to apply to each test
#'   group. This is needed to correctly perform Simes and parametric
#'   tests. The length should match the number of elements in `test_groups`.
#' @param test_corr (Optional) A list of numeric correlation matrices. Each
#'   entry in the list should correspond to each test group. For a test group
#'   using Bonferroni or Simes tests, its corresponding entry in `test_corr`
#'   should be `NA`. For a test group using parametric tests, its
#'   corresponding entry in `test_corr` should be a numeric correlation matrix
#'   specifying the correlation between test statistics for hypotheses in this
#'   test group. The length should match the number of elements in
#'   `test_groups`.
#' @param verbose A logical scalar specifying whether the details of the
#'   adjusted p-value calculations should be included in results. When
#'   `verbose = TRUE`, adjusted p-values are provided for each intersection
#'   hypothesis. The default is `verbose = FALSE`.
#' @param test_values A logical scalar specifying whether adjusted significance
#'   levels should be provided for each hypothesis. When `test_values = TRUE`,
#'   it provides an equivalent way of performing graphical multiple comparison
#'   procedures by comparing each p-value with its significance level. If the
#'   p-value of a hypothesis is less than or equal to its significance level,
#'   the hypothesis is rejected. The default is `test_values = FALSE`.
#' @param sim_n An integer scalar specifying the number of simulations. The
#'   default is 1e5.
#' @param power_marginal A numeric vector of marginal power values to use when
#'   simulating p-values. See Details for more on the simulation process.
#' @param success A list of user-defined functions to specify the success
#'   criteria. Functions must take one simulation's logical vector of results as
#'   an input, and return a length-one logical vector. For instance, if
#'   "success" means rejecting hypotheses 1 and 2, use `sim_success = list("1
#'   and 2" = function(x) x[1] && x[2])`. If the list is not named, the function
#'   body will be used as the name. Lambda functions also work starting with R
#'   4.1, e.g. `sim_success = list(\(x) x[3] || x[4])`.
#'
#' @return Returns `graph` invisibly
#'
#' @rdname input_val
#'
#' @keywords internal
test_input_val <- function(graph,
                           p,
                           alpha,
                           test_groups = list(seq_along(graph$hypotheses)),
                           test_types = c("bonferroni"),
                           test_corr,
                           verbose,
                           test_values) {
  test_opts <- c(
    bonferroni = "bonferroni",
    parametric = "parametric",
    simes = "simes",
    hochberg = "hochberg",
    b = "bonferroni",
    p = "parametric",
    s = "simes",
    h = "hochberg"
  )

  corr_is_matrix_list <- is.list(test_corr) &&
    all(
      vapply(test_corr, function(elt) is.matrix(elt) || is.na(elt), logical(1))
    )

  stopifnot(
    "Please test an `initial_graph` object" = class(graph) == "initial_graph",
    "P-values must be numeric" = is.numeric(p),
    "P-values must be between 0 & 1" = all(p >= 0 & p <= 1),
    "Alpha must be numeric" = is.numeric(alpha),
    "Please choose a single alpha level for testing" = length(alpha) == 1,
    "Alpha must be between 0 & 1" = alpha >= 0 && alpha <= 1,
    "Only Bonferroni, parametric, Simes, or Hochberg tests are currently supported" =
      all(test_types %in% test_opts),
    "Groups specification must be a list" = is.list(test_groups),
    "Please include each hypothesis in exactly one group" =
      setequal(seq_along(graph$hypotheses), unlist(test_groups)) &&
        length(graph$hypotheses) == length(unlist(test_groups)),
    "Correlation matrix should be a list of matrices or missing values" =
      corr_is_matrix_list,
    "Number of test types, groups, and correlation matrices should match" =
      unique(length(test_types), length(test_groups)) == length(test_corr),
    "Length of p-values & groups must match the number of hypotheses" =
      unique(length(p), length(unlist(test_groups))) ==
        length(graph$hypotheses),
    "Verbose flag must be a length one logical" =
      is.logical(verbose) && length(verbose) == 1,
    "Test values flag must be a length one logical" =
      is.logical(test_values) && length(test_values) == 1
  )

  # Additional correlation matrix checks ---------------------------------------
  if (is.null(names(test_types))) {
    corr_parametric <- test_corr[test_types == "parametric"]
  } else {
    corr_parametric <- test_corr[names(test_types)[test_types == "parametric"]]
  }

  missing_corr <- any(
    vapply(corr_parametric, function(cr) any(is.na(cr)), logical(1))
  )

  symmetric_corr <- all(vapply(corr_parametric, isSymmetric.matrix, logical(1)))

  bounded_corr <- all(
    vapply(corr_parametric, function(cr) all(cr >= 0 & cr <= 1), logical(1))
  )

  # Positive definite-ness is irrelevant if there are missing values, and
  # testing for it will throw an error
  positive_definite_corr <- ifelse(
    !missing_corr,
    all(
      vapply(
        corr_parametric,
        function(cr) all(round(eigen(cr)$values, 10) >= 0),
        logical(1)
      )
    ),
    TRUE
  )

  stopifnot(
    "Correlation matrix for parametric test groups must be fully specified" =
      !missing_corr,
    "Correlation matrix must be symmetric" = symmetric_corr,
    "Dimensions of correlation matrices must match the parametric test groups" =
      all(
        lengths(test_corr[names(test_types)[test_types == "parametric"]]) ==
          lengths(test_groups[names(test_types)[test_types == "parametric"]])^2
      ),
    "Correlation values must be between 0 & 1" = bounded_corr,
    "Correlation matrix must be positive definite for parametric test groups" =
      positive_definite_corr
  )

  # Additional Hochberg checks -------------------------------------------------
  if (is.null(names(test_types))) {
    groups_hochberg <- test_groups[test_types == "hochberg"]
  } else {
    groups_hochberg <- test_groups[names(test_types)[test_types == "hochberg"]]
  }

  num_hyps <- length(graph$hypotheses)
  weighting_strategy <- graph_generate_weights(graph)
  matrix_intersections <- weighting_strategy[, seq_len(num_hyps)]
  matrix_weights <- weighting_strategy[, -seq_len(num_hyps)]
  weighting_strategy_compact <- ifelse(
    matrix_intersections,
    matrix_weights,
    NA_real_
  )

  hochberg_weights_all_equal <- TRUE
  for (row in seq_len(nrow(weighting_strategy_compact))) {
    for (group in groups_hochberg) {
      hypotheses <- weighting_strategy_compact[row, group, drop = TRUE]
      hypotheses <- hypotheses[!is.na(hypotheses)]

      hypotheses_all_equal <- length(unique(hypotheses)) <= 1

      hochberg_weights_all_equal <-
        hochberg_weights_all_equal && hypotheses_all_equal
    }
  }

  stopifnot(
    "Each Hochberg group must have uniform weights in all subgraphs" =
      hochberg_weights_all_equal
  )

  invisible(graph)
}

#' @rdname input_val
#' @keywords internal
power_input_val <- function(graph, sim_n, power_marginal, test_corr, success) {
  num_hyps <- length(graph$hypotheses)

  stopifnot(
    "Number of simulations must be a length one integer" =
      is.numeric(sim_n) && as.integer(sim_n) == sim_n && length(sim_n) == 1,
    "Marginal power must be between 0 and 1" =
      all(power_marginal >= 0 & power_marginal <= 1),
    "Marginal power and correlation parameters must be numeric" =
      is.numeric(power_marginal) && is.numeric(test_corr),
    "Lengths of marginal power must match number of hypotheses" =
      length(power_marginal) == num_hyps,
    "Correlation matrix for simulating p-values must match no. of hypotheses" =
      unique(nrow(test_corr), ncol(test_corr)) == num_hyps,
    "Correlation matrix for simulating p-values cannot have missing values" =
      !any(is.na(test_corr)),
    "Correlation matrix for simulating p-values must be symmetric" =
      isSymmetric.matrix(test_corr),
    "Correlation matrix for simulating p-values must have diagonal all 1" =
      all(diag(test_corr) == 1),
    "Correlation matrix for simulating p-values must be positive definite" =
      all(round(eigen(test_corr)$values, 10) >= 0),
    "'sim_success' must be a list of functions" =
      all(vapply(success, is.function, logical(1)))
  )

  invisible(graph)
}

#' Compute group sequential boundaries from an alpha spending function
#'
#' @description
#' Given a significance level, information fractions, and a spending function,
#' compute the group sequential boundaries at each analysis. The boundaries are
#' computed on the Z-scale using the recursive relationship between cumulative
#' spending and the joint distribution of test statistics. The null hypothesis
#' is rejected at analysis \eqn{k} if the test statistic \eqn{Z_k \ge b_k}.
#'
#' At analysis \eqn{k}, the Z-scale boundary \eqn{b_k} satisfies
#' \deqn{P(Z_1 < b_1, \ldots, Z_k < b_k) = 1 - f(\alpha, t_k),}
#' where \eqn{f(\alpha, t_k)} is the cumulative spending at information
#' fraction \eqn{t_k}, and \eqn{(Z_1, \ldots, Z_k)} follows the canonical
#' joint distribution with mean zero and correlations given by [gs_corr()].
#'
#' @param alpha A numeric scalar of the significance level to be spent across
#'   analyses.
#' @param info_frac A numeric vector of information fractions at each analysis.
#'   Must be monotonically non-decreasing with values in (0, 1].
#' @param spending_fn A spending function that takes two arguments: `alpha`
#'   (significance level) and `info_frac` (information fraction), and returns
#'   the cumulative alpha spent. See [spending_of()].
#' @param maxpts An integer scalar for the maximum number of function values
#'   for `mvtnorm::GenzBretz`. The default is 25000.
#' @param abseps A numeric scalar for the absolute error tolerance for
#'   `mvtnorm::GenzBretz`. The default is 1e-6.
#'
#' @return A list with elements:
#'   * `bounds_z` - A numeric vector of Z-scale boundaries at each analysis.
#'   * `bounds_nominal` - A numeric vector of nominal p-value boundaries at
#'     each analysis, i.e., \eqn{c_k = 1 - \Phi(b_k)}.
#'
#' @seealso
#'   [spending_of()], [spending_pocock()], [spending_hsd()], [spending_linear()]
#'   for spending functions, [sequential_p()] for sequential p-values,
#'   [graph_test_shortcut_gsd()] for graphical MCPs with group sequential
#'   designs, [gs_corr()] for the correlation matrix.
#'
#' @rdname gs_boundaries
#'
#' @export
gs_boundaries <- function(alpha,
                          info_frac,
                          spending_fn,
                          maxpts = 25000,
                          abseps = 1e-6) {
  K <- length(info_frac)
  bounds_z <- numeric(K)

  # Compute cumulative spending at all analyses up front
  cum_spent <- spending_fn(alpha, info_frac)

  for (k in seq_len(K)) {
    # Treat cumulative spending below machine precision as zero
    if (cum_spent[k] < .Machine$double.eps) {
      bounds_z[k] <- Inf
      next
    }
    if (cum_spent[k] >= 1 - .Machine$double.eps) {
      bounds_z[k] <- -Inf
      next
    }

    target_prob <- 1 - cum_spent[k]

    if (k == 1) {
      # First analysis: simple univariate case
      bounds_z[k] <- stats::qnorm(target_prob)
      next
    }

    # All boundaries computed so far
    all_bounds <- bounds_z[seq_len(k - 1)]

    # If all previous bounds are Inf, the multivariate constraint reduces
    # to a univariate problem: P(Z_k < b_k) = target_prob
    if (all(is.infinite(all_bounds) & all_bounds > 0)) {
      bounds_z[k] <- stats::qnorm(target_prob)
      next
    }

    # For the multivariate case, replace any Inf bounds with a large finite
    # value to avoid numerical issues in pmvnorm (following gsDesign convention)
    finite_bounds <- pmin(all_bounds, 20)

    # Correlation matrix for analyses 1, ..., k
    corr_k <- gs_corr(info_frac[seq_len(k)])

    # Find b_k such that P(Z_1 < b_1, ..., Z_k < b_k) = target_prob
    f_root <- function(bk) {
      upper_vec <- c(finite_bounds, bk)

      prob <- mvtnorm::pmvnorm(
        upper = upper_vec,
        corr = corr_k,
        algorithm = mvtnorm::GenzBretz(
          maxpts = maxpts,
          abseps = abseps
        )
      )[[1]]

      prob - target_prob
    }

    # Determine a reasonable search interval
    # Start from the univariate approximation and expand
    b_approx <- stats::qnorm(target_prob)
    search_lower <- min(b_approx - 6, -8)
    search_upper <- max(b_approx + 6, 8)

    # Verify that the root is bracketed; widen if necessary
    f_lower <- f_root(search_lower)
    f_upper <- f_root(search_upper)

    if (f_lower > 0) {
      search_lower <- search_lower - 5
      f_lower <- f_root(search_lower)
    }
    if (f_upper < 0) {
      search_upper <- search_upper + 5
      f_upper <- f_root(search_upper)
    }

    if (f_lower * f_upper > 0) {
      # Fallback: if still not bracketed, use the univariate approximation
      bounds_z[k] <- b_approx
      next
    }

    result <- stats::uniroot(
      f_root,
      interval = c(search_lower, search_upper),
      tol = abseps
    )
    bounds_z[k] <- result$root
  }

  list(
    bounds_z = bounds_z,
    bounds_nominal = stats::pnorm(bounds_z, lower.tail = FALSE)
  )
}

#' Organize outputs for testing an intersection hypothesis
#'
#' @description
#' An intersection hypothesis can be tested by a mixture of test types including
#'   Bonferroni, parametric and Simes tests. This function organize outputs of
#'   testing and prepare them for `graph_report`.
#'
#' @inheritParams graph_test_closure
#' @inheritParams graph_create
#' @param intersection (optional) A numeric scalar used to name the
#'   intersection hypothesis in a weighting strategy.
#'
#' @return A data frame with rows corresponding to individual hypotheses
#'   involved in the intersection hypothesis with hypothesis weights
#'   `hypotheses`. There are following columns:
#'   * `Intersection` - Name of this intersection hypothesis,
#'   * `Hypothesis` - Name of an individual hypothesis,
#'   * `Test` - Test type for an individual hypothesis,
#'   * `p` - (Unadjusted or raw) p-values for a individual hypothesis,
#'   * `c_value`- C value for parametric tests,
#'   * `Weight` - Hypothesis weight for an individual hypothesis,
#'   * `Alpha` - Overall significance level \eqn{\alpha},
#'   * `Inequality_holds` - Indicator to show if the p-value is less than or
#'     equal to its significance level.
#'       - For Bonferroni and Simes tests, the significance level is the
#'         hypothesis weight times \eqn{\alpha}.
#'       - For parametric tests, the significance level is the c value times
#'         the hypothesis weight times \eqn{\alpha}.
#'
#' @rdname test_values
#'
#' @keywords internal
#'
#' @references
#'   Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
#'   approach to sequentially rejective multiple test procedures.
#'   \emph{Statistics in Medicine}, 28(4), 586-604.
#'
#'   Lu, K. (2016). Graphical approaches using a Bonferroni mixture of weighted
#'   Simes tests. \emph{Statistics in Medicine}, 35(22), 4041-4055.
#'
#'   Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework
#'   for weighted parametric multiple test procedures.
#'   \emph{Biometrical Journal}, 59(5), 918-931.
#'
test_values_bonferroni <- function(p, hypotheses, alpha, intersection = NA) {
  if (length(p) == 0) {
    NULL
  } else {
    data.frame(
      Intersection = intersection,
      Hypothesis = names(hypotheses),
      Test = "bonferroni",
      p = p,
      "c_value" = "",
      "Weight" = hypotheses,
      Alpha = alpha,
      Inequality_holds = ifelse(
        p == 0 & hypotheses == 0,
        NA,
        p <= hypotheses * alpha
      ),
      check.names = FALSE
    )
  }
}

#' @rdname test_values
#' @keywords internal
test_values_parametric <- function(p,
                                   hypotheses,
                                   alpha,
                                   intersection = NA,
                                   test_corr) {
  if (length(p) == 0) {
    NULL
  } else {
    c_value <- solve_c_parametric(hypotheses, test_corr, alpha)

    data.frame(
      Intersection = intersection,
      Hypothesis = names(hypotheses),
      Test = "parametric",
      p = p,
      "c_value" = c_value,
      "Weight" = hypotheses,
      Alpha = alpha,
      Inequality_holds = ifelse(
        p == 0 & hypotheses == 0,
        NA,
        p <= c_value * hypotheses * alpha
      ),
      check.names = FALSE
    )
  }
}

#' @rdname test_values
#' @keywords internal
test_values_simes <- function(p, hypotheses, alpha, intersection = NA) {
  if (length(p) == 0) {
    NULL
  } else {
    vec_res <- vector(length = length(hypotheses))
    w_sum <- vector("numeric", length = length(hypotheses))

    for (i in seq_along(hypotheses)) {
      w_sum[[i]] <- sum(hypotheses[p <= p[[i]]])
      vec_res[[i]] <- p[[i]] <= alpha * w_sum[[i]]
    }

    data.frame(
      Intersection = intersection,
      Hypothesis = names(hypotheses),
      Test = "simes",
      p = p,
      "c_value" = "",
      "Weight" = w_sum,
      Alpha = alpha,
      Inequality_holds = ifelse(
        p == 0 & w_sum == 0,
        NA,
        vec_res
      ),
      check.names = FALSE
    )
  }
}

#' @rdname test_values
#' @keywords internal
test_values_hochberg <- function(p, hypotheses, alpha, intersection = NA) {
  if (length(p) == 0) {
    NULL
  } else {
    vec_res <- vector(length = length(hypotheses))
    w_quo <- vector("numeric", length = length(hypotheses))
    total_weight <- sum(hypotheses)

    for (i in seq_along(hypotheses)) {
      w_quo[[i]] <- total_weight / (length(hypotheses) - sum(p <= p[[i]]) + 1)
      vec_res[[i]] <- p[[i]] <= alpha * w_quo[[i]]
    }

    data.frame(
      Intersection = intersection,
      Hypothesis = names(hypotheses),
      Test = "hochberg",
      p = p,
      "c_value" = "",
      "Weight" = w_quo,
      Alpha = alpha,
      Inequality_holds = ifelse(
        p == 0 & w_quo == 0,
        NA,
        vec_res
      ),
      check.names = FALSE
    )
  }
}

#' S3 print method for the class `graph_report`
#'
#' @description
#' A printed `graph_report` displays the initial graph, p-values and
#' significance levels, rejection decisions, and optional detailed test results.
#'
#' @param x An object of class `graph_report` to print.
#' @param ... Other values passed on to other methods (currently unused)
#' @param precision An integer scalar indicating the number of decimal places
#'   to to display.
#' @param indent An integer scalar indicating how many spaces to indent results.
#' @param rows An integer scalar indicating how many rows of detailed test
#' results to print.
#'
#' @return An object x of class `graph_report`, after printing the report of
#'   conducting a graphical multiple comparison procedure.
#'
#' @rdname print.graph_report
#'
#' @export
#'
#' @references
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 1 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' transitions <- rbind(
#'   c(0, 0, 1, 0),
#'   c(0, 0, 0, 1),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#'
#' p <- c(0.018, 0.01, 0.105, 0.006)
#' alpha <- 0.025
#' graph_test_shortcut(g, p, alpha)
print.graph_report <- function(x, ..., precision = 4, indent = 2, rows = 10) {
  pad <- paste(rep(" ", indent), collapse = "")
  pad_less_1 <- paste(rep(" ", max(indent - 1, 0)), collapse = "")
  hyp_names <- names(x$inputs$graph$hypotheses)

  # Input calcs ----------------------------------------------------------------
  cat("\n")
  section_break("Test parameters ($inputs)")

  hyp_groups <- lapply(x$inputs$test_groups, function(group) hyp_names[group])
  pad_tests <- formatC(
    x$inputs$test_types,
    width = max(nchar(x$inputs$test_types)) + indent
  )

  test_spec <- paste0(
    pad_tests,
    ": (",
    lapply(hyp_groups, paste, collapse = ", "),
    ")",
    collapse = "\n"
  )

  p_mat <- matrix(
    x$inputs$p,
    nrow = 1,
    dimnames = list(
      paste0(pad, "Unadjusted p-values:"),
      hyp_names
    ),
  )

  if (any(x$inputs$test_types == "parametric")) {
    para_hyps <-
      unlist(x$inputs$test_groups[x$inputs$test_types == "parametric"])

    dimnames(x$inputs$test_corr) <- dimnames(x$inputs$graph$transitions)
    colname_pad <- format(
      "Correlation matrix:   ",
      width = max(nchar(rownames(x$inputs$test_corr)))
    )
    label <- paste0(pad_less_1, colname_pad)
    df_corr <- data.frame(
      paste0(pad_less_1, rownames(x$inputs$test_corr[para_hyps, ])),
      format(x$inputs$test_corr[para_hyps, para_hyps], digits = precision),
      check.names = FALSE
    )
    names(df_corr)[[1]] <- label
  }

  # Input print ----------------------------------------------------------------
  print(x$inputs$graph, precision = precision, indent = indent)
  cat("\n")
  cat(pad, "Alpha = ", x$inputs$alpha, sep = "")
  cat("\n\n")
  print(as.data.frame(format(p_mat, digits = precision)))
  cat("\n")
  if (any(x$inputs$test_types == "parametric")) {
    print(df_corr, row.names = FALSE)
    cat("\n")
  }
  cat(pad, "Test types", "\n", test_spec, sep = "")
  cat("\n")

  # Output ---------------------------------------------------------------------
  cat("\n")
  section_break("Test summary ($outputs)")

  hyp_width <- max(nchar(c("Hypothesis", hyp_names))) + indent - 1

  adjusted_p <- x$outputs$adjusted_p
  exceed_1 <- adjusted_p > 1
  adjusted_p_plus <- gsub(".00000001", "+", adjusted_p[exceed_1])
  adjusted_p_format <- format(adjusted_p[!exceed_1], digits = precision)

  adjusted_p[exceed_1] <- adjusted_p_plus
  adjusted_p[!exceed_1] <- adjusted_p_format

  df_summary <- data.frame(
    Hypothesis = formatC(hyp_names, width = hyp_width),
    Adj.p = adjusted_p,
    Reject = x$outputs$rejected,
    check.names = FALSE
  )
  names(df_summary)[[1]] <- formatC("Hypothesis", width = hyp_width)

  print(df_summary, row.names = FALSE)

  cat("\n")

  attr(x$outputs$graph, "title") <-
    "Final updated graph after removing rejected hypotheses"

  print(
    x$outputs$graph,
    precision = precision,
    indent = indent
  )

  cat("\n")

  # Adjusted p/rejection sequence details --------------------------------------
  if (!is.null(x$details)) {
    if (is.data.frame(x$details$results)) {
      df_details <- x$details$results

      for (col_num in seq_along(df_details)) {
        if (is.numeric(df_details[[col_num]])) {
          df_details[[col_num]] <-
            format(df_details[[col_num]], digits = precision)
        }
      }

      max_print_old <- getOption("max.print")
      options(max.print = 99999)

      section_break("Adjusted p details ($details)")
      detail_results_out <- utils::capture.output(
        print(utils::head(df_details, rows), row.names = FALSE)
      )
      cat(paste0(pad_less_1, detail_results_out), sep = "\n")

      options(max.print = max_print_old)

      if (rows < nrow(df_details)) {
        cat(pad, "... (Use `print(x, rows = <nn>)` for more)\n\n", sep = "")
      } else {
        cat("\n")
      }
    } else {
      graph_seq <- x$details$results
      del_seq <- x$details$del_seq

      section_break("Rejection sequence details ($details)")
      for (i in seq_along(graph_seq) - 1) {
        if (i == 0) {
          print(graph_seq[[i + 1]], precision = precision, indent = indent)
        } else {
          attr(graph_seq[[i + 1]], "title") <- paste0(
            "Step ", i, ": Updated graph after removing ",
            if (i == 1) "hypothesis " else "hypotheses ",
            paste0(del_seq[seq_len(i)], collapse = ", ")
          )

          print(
            graph_seq[[i + 1]],
            precision = precision,
            indent = indent * (i + 1)
          )
        }
        cat("\n")
      }

      attr(graph_seq[[length(graph_seq)]], "title") <-
        "Final updated graph after removing rejected hypotheses"

      print(
        graph_seq[[length(graph_seq)]],
        precision = precision,
        indent = indent
      )
      cat("\n")
    }
  }

  # Test values details --------------------------------------------------------
  if (!is.null(x$test_values)) {
    section_break("Detailed test values ($test_values)")

    if (any(x$inputs$test_types == "parametric")) {
      num_cols <- c("p", "c_value", "Weight", "Alpha")
    } else {
      num_cols <- c("p", "Weight", "Alpha")
    }

    crit_res <- x$test_values$results
    crit_res[num_cols] <- apply(
      crit_res[num_cols],
      2,
      function(num_col) {
        format(as.numeric(num_col), digits = precision)
      }
    )

    p_col_index <- which(names(crit_res) == "p")
    if (any(x$inputs$test_types == "parametric")) {
      crit_res$"c_value" <- ifelse(
        trimws(crit_res$"c_value") == "NA",
        "",
        crit_res$"c_value"
      )

      crit_res <- cbind(
        crit_res[1:p_col_index],
        data.frame("<=" = "<=", check.names = FALSE),
        crit_res[p_col_index + 1],
        data.frame("*" = "*", check.names = FALSE),
        crit_res[p_col_index + 2],
        data.frame("*" = "*", check.names = FALSE),
        crit_res[(p_col_index + 3):(p_col_index + 4)]
      )
    } else {
      crit_res <- cbind(
        crit_res[1:p_col_index],
        data.frame("<=" = "<=", check.names = FALSE),
        crit_res[p_col_index + 1],
        data.frame("*" = "*", check.names = FALSE),
        crit_res[(p_col_index + 2):(p_col_index + 3)]
      )
    }

    max_print_old <- getOption("max.print")
    options(max.print = 99999)

    test_values_results_out <- utils::capture.output(
      print(utils::head(crit_res, rows), row.names = FALSE)
    )
    cat(paste0(pad_less_1, test_values_results_out), sep = "\n")

    options(max.print = max_print_old)

    if (rows < nrow(crit_res)) {
      cat(pad, "... (Use `print(x, rows = <nn>)` for more)\n\n", sep = "")
    } else {
      cat("\n")
    }
  }

  # Optional alternate orderings
  if (!is.null(x$valid_orderings)) {
    section_break("Alternate rejection orderings ($valid_rejection_orderings)")

    lapply(
      x$valid_orderings,
      function(ordering) {
        print(ordering)
        cat("\n")
      }
    )
  }

  invisible(x)
}

section_break <- function(text) {
  cat(text, " ", rep("-", 79 - nchar(text)), "\n", sep = "")
}

#' Calculate adjusted p-values
#'
#' @description
#' For an intersection hypothesis, an adjusted p-value is the smallest
#' significance level at which the intersection hypothesis can be rejected.
#' The intersection hypothesis can be rejected if its adjusted p-value is less
#' than or equal to \eqn{\alpha}. Currently, there are three test types
#' supported:
#' * Bonferroni tests for [adjust_p_bonferroni()],
#' * Parametric tests for [adjust_p_parametric()],
#'     - Note that one-sided tests are required for parametric tests.
#' * Simes tests for [adjust_p_simes()],
#' * Hochberg tests for [adjust_p_hochberg()].
#'
#' @param p A numeric vector of p-values (unadjusted, raw), whose values should
#'   be between 0 & 1. The length should match the length of `hypotheses`.
#' @param hypotheses A numeric vector of hypothesis weights. Must be a vector of
#'   values between 0 & 1 (inclusive). The length should match the length of
#'   `p`. The sum of hypothesis weights should not exceed 1.
#' @param test_corr (Optional) A numeric matrix of correlations between test
#'   statistics, which is needed to perform parametric tests using
#'   [adjust_p_parametric()]. The number of rows and columns of
#'   this correlation matrix should match the length of `p`.
#' @param maxpts (Optional) An integer scalar for the maximum number of function
#'   values, which is needed to perform parametric tests using the
#'   `mvtnorm::GenzBretz` algorithm. The default is 25000.
#' @param abseps (Optional) A numeric scalar for the absolute error tolerance,
#'   which is needed to perform parametric tests using the `mvtnorm::GenzBretz`
#'   algorithm. The default is 1e-6.
#' @param releps (Optional) A numeric scalar for the relative error tolerance
#'   as double, which is needed to perform parametric tests using the
#'   `mvtnorm::GenzBretz` algorithm. The default is 0.
#'
#' @return A single adjusted p-value for the intersection hypothesis.
#'
#' @seealso
#'   [adjust_weights_parametric()] for adjusted hypothesis weights using
#'   parametric tests, [adjust_weights_simes()] for adjusted hypothesis weights
#'   using Simes tests, [adjust_weights_hochberg()] for adjusted hypothesis
#'   weights using Hochberg tests.
#'
#' @rdname adjust_p
#'
#' @export
#'
#' @references
#'   Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
#'   approach to sequentially rejective multiple test procedures.
#'   \emph{Statistics in Medicine}, 28(4), 586-604.
#'
#'   Lu, K. (2016). Graphical approaches using a Bonferroni mixture of weighted
#'   Simes tests. \emph{Statistics in Medicine}, 35(22), 4041-4055.
#'
#'   Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework
#'   for weighted parametric multiple test procedures.
#'   \emph{Biometrical Journal}, 59(5), 918-931.
#'
#'   Xi, D., and Bretz, F. (2019). Symmetric graphs for equally weighted tests,
#'   with application to the Hochberg procedure. \emph{Statistics in Medicine},
#'   38(27), 5268-5282.
#'
#' @examples
#' hypotheses <- c(H1 = 0.5, H2 = 0.25, H3 = 0.25)
#' p <- c(0.019, 0.025, 0.05)
#' adjust_p_bonferroni(p, hypotheses)
adjust_p_bonferroni <- function(p, hypotheses) {
  if (sum(hypotheses) == 0) {
    return(Inf)
  }

  # We need na.rm = TRUE to handle the 0 / 0 case. This may be too blunt a way
  # to handle it, but I suspect it's the fastest. Another option is to reduce p
  # and weights by keeping only indices where `!(p == 0 & weights == 0)`.
  # Considering that p-values are validated in the test function, this should be
  # safe
  round(min(p / hypotheses, na.rm = TRUE), 10)
}

#' @rdname adjust_p
#' @export
#' @examples
#' set.seed(1234)
#' hypotheses <- c(H1 = 0.5, H2 = 0.25, H3 = 0.25)
#' p <- c(0.019, 0.025, 0.05)
#' # Using the `mvtnorm::GenzBretz` algorithm
#' corr <- matrix(0.5, nrow = 3, ncol = 3)
#' diag(corr) <- 1
#' adjust_p_parametric(p, hypotheses, corr)
adjust_p_parametric <- function(p,
                                hypotheses,
                                test_corr = NULL,
                                maxpts = 25000,
                                abseps = 1e-6,
                                releps = 0) {
  if (sum(hypotheses) == 0) {
    return(Inf)
  }

  w_nonzero <- hypotheses > 0
  q <- min(p[w_nonzero] / hypotheses[w_nonzero])
  q <- q * hypotheses[w_nonzero]
  z <- stats::qnorm(q, lower.tail = FALSE)
  prob_less_than_z <- ifelse(
    length(z) == 1,
    stats::pnorm(z, lower.tail = FALSE)[[1]],
    1 - mvtnorm::pmvnorm(
      lower = -Inf,
      upper = z,
      corr = test_corr[w_nonzero, w_nonzero, drop = FALSE],
      algorithm = mvtnorm::GenzBretz(
        maxpts = maxpts,
        abseps = abseps,
        releps = releps
      )
    )[[1]]
  )

  # Occasionally off by floating point differences, so round at some high detail
  # This level of detail should always remove floating point differences
  # appropriately, as they're typically 10^(<=-15). Conversely, this
  round(1 / sum(hypotheses) * prob_less_than_z, 10)
}

#' @rdname adjust_p
#' @export
#' @examples
#' hypotheses <- c(H1 = 0.5, H2 = 0.25, H3 = 0.25)
#' p <- c(0.019, 0.025, 0.05)
#' adjust_p_simes(p, hypotheses)
adjust_p_simes <- function(p, hypotheses) {
  if (sum(hypotheses) == 0) {
    return(Inf)
  }

  adjusted_p <- Inf
  for (i in seq_along(hypotheses)) {
    # This demonstrates a different and slightly more accurate way of
    # calculating Simes adjusted weights/adjusted p-values compared to the
    # method used in [adjust_weights_simes()]. In this function (and
    # [test_values_simes()]), we add all hypothesis weights for hypotheses with
    # a smaller p-value than hypothesis_j, for all j in J. In the case that two
    # p-values are identical, the corresponding hypotheses will get identical
    # adjusted weights/adjusted p-values. [adjust_weights_simes()], on the other
    # hand, uses an alternate method that's faster: First order hypotheses
    # according to their p-values in ascending order, then take the cumulative
    # sum. In the case that two p-values are identical, they will be sorted
    # sequentially, and the hypothesis that happens to come first will get a
    # smaller, incorrect adjusted weight (larger, incorrect adjusted p-value).
    # The hypothesis that comes second will be correct. [adjust_weights_simes()]
    # is only used in power calculations where it should not be possible to have
    # identical p-values, since they are sampled randomly (unless `all(test_corr
    # == 1)`). Furthermore, even when there are incorrect adjusted weights, it
    # cannot affect the hypothesis rejections. See Bonferroni function above for
    # na.rm reasoning
    adjusted_p <- min(
      adjusted_p,
      p[[i]] / sum(hypotheses[p <= p[[i]]]),
      na.rm = TRUE
    )
  }

  round(adjusted_p, 10)
}

#' @rdname adjust_p
#' @export
#' @examples
#' hypotheses <- c(H1 = .25, H2 = .25, H3 = 0.25, H4 = 0.25)
#' p <- c(0.019, 0.025, 0.05, .05)
#' adjust_p_hochberg(p, hypotheses)
adjust_p_hochberg <- function(p, hypotheses) {
  if (sum(hypotheses) == 0) {
    return(Inf)
  }

  adjusted_p <- Inf
  for (i in seq_along(hypotheses)) {
    # This demonstrates a different and slightly more accurate way of
    # calculating Hochberg adjusted weights/adjusted p-values compared to the
    # method used in [adjust_weights_hochberg()]. In this function (and
    # [test_values_hochberg()]), we count how many hypotheses with a smaller
    # p-value than hypothesis_j, for all j in J. In the case that two p-values
    # are identical, the corresponding hypotheses will get identical adjusted
    # weights/adjusted p-values. [adjust_weights_hochberg()], on the other hand,
    # uses an alternate method that's faster: First order hypotheses according
    # to their p-values in ascending order, then take the cumulative sum. In the
    # case that two p-values are identical, they will be sorted sequentially,
    # and the hypothesis that happens to come first will get a smaller,
    # incorrect adjusted weight (larger, incorrect adjusted p-value). The
    # hypothesis that comes second will be correct. [adjust_weights_hochberg()]
    # is only used in power calculations where it should not be possible to have
    # identical p-values, since they are sampled randomly (unless `all(test_corr
    # == 1)`). Furthermore, even when there are incorrect adjusted weights, it
    # cannot affect the hypothesis rejections. See Bonferroni function above for
    # na.rm reasoning.
    adjusted_p <- min(
      adjusted_p,
      p[[i]] / sum(hypotheses) * (length(hypotheses) - sum(p <= p[[i]]) + 1),
      na.rm = TRUE
    )
  }

  round(adjusted_p, 10)
}

#' Example graphs of commonly used multiple comparison procedures
#'
#' @description
#' Built-in functions to quickly generate select graphical multiple comparison
#' procedures.
#'
#' @param hypotheses (Optional) A numeric vector of hypothesis weights in a
#'   graphical multiple comparison procedure. Must be a vector of values
#'   between 0 & 1 (inclusive). The length should match `num_hyps` and the
#'   length of `hyp_names`. The sum of hypothesis weights should not exceed 1.
#' @param hyp_names (Optional) A character vector of hypothesis names. The
#'   length should match `num_hyps` and the length of `hypotheses`. If
#'   `hyp_names` are not specified, hypotheses will be named sequentially as
#'   H1, H2, .......
#' @param epsilon (Optional) A numeric scalar indicating the value of the
#'   \eqn{\epsilon} edge. This should be a much smaller value than hypothesis
#'   and transition weights. The default is 1e-4.
#' @param num_hyps (Optional) Number of hypotheses in a graphical multiple
#'   comparison procedure.
#'
#' @return An S3 object as returned by [graph_create()].
#'
#' @seealso
#'   [graph_create()] for a general way to create the initial graph.
#'
#' @rdname example_graphs
#'
#' @export
#'
#' @references
#'   Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
#'   approach to sequentially rejective multiple test procedures.
#'   \emph{Statistics in Medicine}, 28(4), 586-604.
#'
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#'   Hochberg, Y. (1988). A sharper Bonferroni procedure for multiple tests of
#'   significance. \emph{Biometrika}, 75(4), 800-802.
#'
#'   Hommel, G. (1988). A stagewise rejective multiple test procedure based on a
#'   modified Bonferroni test. \emph{Biometrika}, 75(2), 383-386.
#'
#'   Huque, M. F., Alosh, M., and Bhore, R. (2011). Addressing multiplicity
#'   issues of a composite endpoint and its components in clinical trials.
#'   \emph{Journal of Biopharmaceutical Statistics}, 21(4), 610-634.
#'
#'   Maurer, W., Hothorn, L., and Lehmacher, W. (1995). Multiple comparisons in
#'   drug clinical trials and preclinical assays: a-priori ordered hypotheses.
#'   \emph{Biometrie in der chemisch-pharmazeutischen Industrie}, 6, 3-18.
#'
#'   Šidák, Z. (1967). Rectangular confidence regions for the means of
#'   multivariate normal distributions. \emph{Journal of the American Statistical
#'   Association}, 62(318), 626-633.
#'
#'   Westfall, P. H., and Krishen, A. (2001). Optimally weighted, fixed sequence
#'   and gatekeeper multiple testing procedures.
#'   \emph{Journal of Statistical Planning and Inference}, 99(1), 25-40.
#'
#'   Wiens, B. L. (2003). A fixed sequence Bonferroni procedure for testing
#'   multiple endpoints. \emph{Pharmaceutical Statistics}, 2(3), 211-215.
#'
#'   Wiens, B. L., and Dmitrienko, A. (2005). The fallback procedure for
#'   evaluating a single family of hypotheses.
#'   \emph{Journal of Biopharmaceutical Statistics}, 15(6), 929-942.
#'
#'   Xi, D., and Bretz, F. (2019). Symmetric graphs for equally weighted tests,
#'   with application to the Hochberg procedure. \emph{Statistics in Medicine},
#'   38(27), 5268-5282.
#'
#' @examples
#' # Bretz et al. (2009)
#' bonferroni(num_hyps = 3)
bonferroni <- function(num_hyps, hyp_names = NULL) {
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  hypotheses <- rep(1 / num_hyps, num_hyps)
  transitions <- matrix(0, num_hyps, num_hyps)

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Bretz et al. (2009)
#' hypotheses <- c(0.5, 0.3, 0.2)
#' bonferroni_weighted(hypotheses)
bonferroni_weighted <- function(hypotheses, hyp_names = NULL) {
  num_hyps <- length(hypotheses)
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  transitions <- matrix(0, num_hyps, num_hyps)

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Bretz et al. (2009)
#' bonferroni_holm(num_hyps = 3)
bonferroni_holm <- function(num_hyps, hyp_names = NULL) {
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  hypotheses <- rep(1 / num_hyps, num_hyps)
  transitions <- matrix(rep(1 / (num_hyps - 1), num_hyps^2), nrow = num_hyps)
  diag(transitions) <- rep(0, num_hyps)

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Bretz et al. (2009)
#' hypotheses <- c(0.5, 0.3, 0.2)
#' bonferroni_holm_weighted(hypotheses)
bonferroni_holm_weighted <- function(hypotheses, hyp_names = NULL) {
  num_hyps <- length(hypotheses)
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  transitions <- matrix(rep(1 / (num_hyps - 1), num_hyps^2), nrow = num_hyps)
  diag(transitions) <- rep(0, num_hyps)

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Xi et al. (2017)
#' dunnett_single_step(num_hyps = 3)
dunnett_single_step <- function(num_hyps, hyp_names = NULL) {
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  hypotheses <- rep(1 / num_hyps, num_hyps)
  transitions <- matrix(0, num_hyps, num_hyps)

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Xi et al. (2017)
#' hypotheses <- c(0.5, 0.3, 0.2)
#' dunnett_single_step_weighted(hypotheses)
dunnett_single_step_weighted <- function(hypotheses, hyp_names = NULL) {
  num_hyps <- length(hypotheses)
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  transitions <- matrix(0, num_hyps, num_hyps)

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Xi et al. (2009)
#' hypotheses <- c(0.5, 0.3, 0.2)
#' dunnett_closure_weighted(hypotheses)
dunnett_closure_weighted <- function(hypotheses, hyp_names = NULL) {
  num_hyps <- length(hypotheses)
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  transitions <- matrix(rep(1 / (num_hyps - 1), num_hyps^2), nrow = num_hyps)
  diag(transitions) <- rep(0, num_hyps)

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Hochberg (1988)
#' hochberg(num_hyps = 3)
hochberg <- function(num_hyps, hyp_names = NULL) {
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  hypotheses <- rep(1 / num_hyps, num_hyps)
  transitions <- matrix(rep(1 / (num_hyps - 1), num_hyps^2), nrow = num_hyps)
  diag(transitions) <- rep(0, num_hyps)

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Hommel (1988)
#' hommel(num_hyps = 3)
hommel <- function(num_hyps, hyp_names = NULL) {
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  hypotheses <- rep(1 / num_hyps, num_hyps)
  transitions <- matrix(rep(1 / (num_hyps - 1), num_hyps^2), nrow = num_hyps)
  diag(transitions) <- rep(0, num_hyps)

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Huque et al. (2011)
#' huque_etal()
huque_etal <- function(hyp_names = NULL) {
  graph_create(
    c(1, 0, 0, 0),
    matrix(
      c(
        0, 0.5, 0.5, 0,
        0, 0, 0, 1,
        0, 0.5, 0, 0.5,
        0, 1, 0, 0
      ),
      nrow = 4,
      byrow = TRUE
    ),
    hyp_names = hyp_names
  )
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Wiens (2003)
#' hypotheses <- c(0.5, 0.3, 0.2)
#' fallback(hypotheses)
fallback <- function(hypotheses, hyp_names = NULL) {
  num_hyps <- length(hypotheses)
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  transitions <- matrix(0, nrow = num_hyps, ncol = num_hyps)
  for (i in seq_len(num_hyps - 1)) {
    transitions[i, i + 1] <- 1
  }

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Wiens and Dmitrienko (2005)
#' hypotheses <- c(0.5, 0.3, 0.2)
#' fallback_improved_1(hypotheses)
fallback_improved_1 <- function(hypotheses, hyp_names = NULL) {
  num_hyps <- length(hypotheses)
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names)),
    "sum of all hypothesis weights excluding the last one should be greater
      than 0" = sum(hypotheses[seq_len(num_hyps - 1)]) > 0
  )
  transitions <- matrix(0, nrow = num_hyps, ncol = num_hyps)
  for (i in seq_len(num_hyps - 1)) {
    transitions[i, i + 1] <- 1
  }
  transitions[num_hyps, seq_len(num_hyps - 1)] <-
    hypotheses[seq_len(num_hyps - 1)] / sum(hypotheses[seq_len(num_hyps - 1)])

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Bretz et al. (2009)
#' hypotheses <- c(0.5, 0.3, 0.2)
#' fallback_improved_2(hypotheses)
fallback_improved_2 <- function(hypotheses, epsilon = 1e-4, hyp_names = NULL) {
  num_hyps <- length(hypotheses)
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  transitions <- matrix(0, nrow = num_hyps, ncol = num_hyps)
  if (num_hyps == 2) {
    transitions[1, 2] <- transition[2, 1] <- 1
  } else if (num_hyps > 2) {
    transitions[, 1] <- c(0, rep(1 - epsilon, num_hyps - 2), 1)
    transitions[1, 2] <- 1
    for (i in 2:(num_hyps - 1)) {
      transitions[i, i + 1] <- epsilon
    }
  }

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Maurer et al. (1995); Westfall and Krishen (2001)
#' fixed_sequence(num_hyps = 3)
fixed_sequence <- function(num_hyps, hyp_names = NULL) {
  hypotheses <- c(1, rep(0, num_hyps - 1))
  transitions <- matrix(0, nrow = num_hyps, ncol = num_hyps)
  for (i in seq_len(num_hyps - 1)) {
    transitions[i, i + 1] <- 1
  }

  graph_create(hypotheses, transitions, hyp_names)
}


#' @export
#' @rdname example_graphs
#' @examples
#' # sidak (1967)
#' sidak(num_hyps = 3)
sidak <- function(num_hyps, hyp_names = NULL) {
  stopifnot(
    "number of hypotheses must match number of names" =
      (num_hyps == length(hyp_names) || is.null(hyp_names))
  )
  hypotheses <- rep(1 / num_hyps, num_hyps)
  transitions <- matrix(0, num_hyps, num_hyps)

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Figure 1 in Bretz et al. (2011)
#' simple_successive_1()
simple_successive_1 <- function(hyp_names = NULL) {
  hypotheses <- c(0.5, 0.5, 0, 0)
  transitions <- rbind(
    c(0, 0, 1, 0),
    c(0, 0, 0, 1),
    c(0, 1, 0, 0),
    c(1, 0, 0, 0)
  )

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Figure 4 in Bretz et al. (2011)
#' simple_successive_2()
simple_successive_2 <- function(hyp_names = NULL) {
  hypotheses <- c(0.5, 0.5, 0, 0)
  transitions <- rbind(
    c(0, 0.5, 0.5, 0),
    c(0.5, 0, 0, 0.5),
    c(0, 1, 0, 0),
    c(1, 0, 0, 0)
  )

  graph_create(hypotheses, transitions, hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Figure 6 in Xi and Bretz et al. (2019)
#' two_doses_two_primary_two_secondary()
two_doses_two_primary_two_secondary <- function(hyp_names = NULL) {
  eps <- 1e-4
  weights <- c(rep(c(1 / 2, 0, 0), 2))
  transitions <- rbind(
    c(0, 0.5, 0.5, 0, 0, 0),
    c(0, 0, 1, 0, 0, 0),
    c(0, 1 - eps, 0, eps, 0, 0),
    c(0, 0, 0, 0, 0.5, 0.5),
    c(0, 0, 0, 0, 0, 1),
    c(eps, 0, 0, 0, 1 - eps, 0)
  )

  graph_create(weights, transitions, hyp_names = hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Add another dose to Figure 6 in Xi and Bretz et al. (2019)
#' three_doses_two_primary_two_secondary()
three_doses_two_primary_two_secondary <- function(hyp_names = NULL) {
  eps <- 1e-4
  weights <- c(rep(c(1 / 3, 0, 0), 3))
  transitions <- rbind(
    c(0, 0.5, 0.5, 0, 0, 0, 0, 0, 0), # 1 --> 2 & 3
    c(0, 0, 1, 0, 0, 0, 0, 0, 0), # 2 --> 3
    c(0, 1 - eps, 0, eps / 2, 0, 0, eps / 2, 0, 0), # 3 --> 2, 3 - - > 4 & 7
    c(0, 0, 0, 0, 0.5, 0.5, 0, 0, 0), # 4 --> 5 & 6
    c(0, 0, 0, 0, 0, 1, 0, 0, 0), # 5 --> 6
    c(eps / 2, 0, 0, 0, 1 - eps, 0, eps / 2, 0, 0), # 6 --> 5, 6 - - > 1 & 7
    c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5), # 7 --> 8 & 9
    c(0, 0, 0, 0, 0, 0, 0, 0, 1), # 8 --> 9
    c(eps / 2, 0, 0, eps / 2, 0, 0, 0, 1 - eps, 0) # 9 --> 8, 9 - - > 1 & 4
  )

  graph_create(weights, transitions, hyp_names = hyp_names)
}

#' @export
#' @rdname example_graphs
#' @examples
#' # Create a random graph with three hypotheses
#' random_graph(num_hyps = 3)
random_graph <- function(num_hyps, hyp_names = NULL) {
  hypotheses <- sample(seq_len(num_hyps), replace = TRUE)
  hypotheses <- hypotheses / sum(hypotheses)
  transitions <- replicate(
    num_hyps,
    sample(seq_len(num_hyps), replace = TRUE),
    simplify = TRUE
  )
  diag(transitions) <- 0
  transitions <- transitions / rowSums(transitions)

  graph_create(hypotheses, transitions, hyp_names)
}

#' Perform shortcut graphical multiple comparison procedures with group
#' sequential designs
#'
#' @description
#' Extends [graph_test_shortcut()] to group sequential designs where hypotheses
#' can be tested at multiple analyses (interim and final). At each analysis,
#' the significance level available for each hypothesis is determined by a
#' spending function evaluated at the information fraction. The group
#' sequential boundaries (critical values) are computed from the spending using
#' the joint distribution of test statistics across analyses.
#'
#' The procedure supports two modes
#' controlled by the `look_back` parameter:
#' * **`look_back = FALSE`** (default): At each analysis, rejection decisions
#'   are based on **repeated p-values** at the current analysis only. A
#'   repeated p-value at analysis \eqn{k} is the minimum significance level at
#'   which the group sequential boundary at analysis \eqn{k} would be crossed.
#'   The graphical shortcut procedure ([graph_test_shortcut()]) is applied at
#'   each analysis using repeated p-values, and the graph is updated before
#'   proceeding to the next analysis.
#' * **`look_back = TRUE`**: Rejection decisions are based on **sequential
#'   p-values**, which consider all analyses up to the current one. A
#'   sequential p-value is the minimum of repeated p-values across all
#'   analyses conducted so far. Like the default mode, the procedure
#'   processes analyses sequentially, applying [graph_test_shortcut()] at
#'   each analysis using sequential p-values and updating the graph before
#'   proceeding. When a hypothesis becomes testable at a later analysis
#'   (via graph update), its `first_rejected_at` is set to the earliest
#'   analysis where its boundary was crossed, while `decision_at` records
#'   the analysis where the rejection was operationally processed.
#'
#' @inheritParams graph_test_shortcut
#' @param p A numeric matrix of p-values with \eqn{m} rows (hypotheses) and
#'   \eqn{K} columns (analyses), where \eqn{K} is the maximum number of
#'   analyses across all hypotheses. For hypotheses not tested at every
#'   analysis, use `NA` for the columns without data. Each hypothesis
#'   must have at least one non-`NA` value.
#' @param info_frac Information fractions at each analysis. Can be:
#'   * A numeric vector of length \eqn{K} — same fractions for all hypotheses.
#'     Only allowed when `p` contains no `NA` values (i.e., all hypotheses
#'     have the same number of analyses).
#'   * A numeric matrix with \eqn{m} rows (hypotheses) and \eqn{K} columns
#'     (analyses) — different fractions per hypothesis. When `p` contains
#'     `NA` padding, `info_frac` must be a matrix with `NA` in the same
#'     positions as `p`.
#'
#'   Non-`NA` values must be positive and monotonically non-decreasing per
#'   hypothesis. Values greater than 1 are allowed (e.g., when more
#'   information is collected than planned). The spending functions cap
#'   the cumulative spending at `alpha` for information fractions at or
#'   above 1. The last non-`NA` value does not need to be 1, allowing
#'   the procedure to be applied up to an interim analysis.
#' @param spending_fn Spending function(s) for computing group sequential
#'   boundaries. Can be:
#'   * A single function — applied to all hypotheses.
#'   * A list of \eqn{m} functions — one per hypothesis.
#'
#'   Each function must accept two arguments: `alpha` (significance level)
#'   and `info_frac` (information fraction), and return the cumulative alpha
#'   spent. Built-in options include [spending_of()], [spending_pocock()],
#'   [spending_hsd()], and [spending_linear()].
#' @param look_back A logical scalar or vector controlling the testing strategy.
#'   Can be:
#'   * A single logical — applied to all hypotheses.
#'   * A logical vector of length \eqn{m} — one per hypothesis, allowing
#'     different strategies for different hypotheses.
#'
#'   For hypotheses with `look_back = FALSE` (the default), rejection decisions
#'   at each analysis are based on repeated p-values at that analysis only.
#'   For hypotheses with `look_back = TRUE`, rejection decisions are based on
#'   sequential p-values which consider all analyses up to the current one.
#'   The `look_back = TRUE` option can lead to additional rejections because
#'   a hypothesis may have crossed its boundary at an earlier analysis but
#'   only becomes testable (via graph update) at a later analysis.
#' @param test_values A logical scalar specifying whether to include the
#'   per-analysis rejection details in results. When `test_values = TRUE`, the
#'   rejection sequence, analysis at which each rejection occurred, and the
#'   nominal p-value boundaries are reported. The default is
#'   `test_values = FALSE`.
#' @param verbose A logical scalar specifying whether to include the boundary
#'   table in results. When `verbose = TRUE`, a table of nominal p-value
#'   boundaries is computed for each hypothesis at all possible weights from
#'   the graph's closure (via [graph_generate_weights()]). This enables manual
#'   verification of rejection decisions. The default is `FALSE`.
#'
#' @return An S3 object of class `gsd_graph_report` with a list of elements:
#'   * `inputs` - Input parameters, including the initial graph, p-values,
#'     alpha, information fractions, and spending functions.
#'   * `outputs` - Output parameters:
#'     * `repeated_p` - An m x K matrix of repeated p-values at each analysis,
#'     * `sequential_p` - An m x K matrix of sequential p-values (cumulative
#'       minimum of repeated p-values),
#'     * `adjusted_p` - Adjusted p-values from the shortcut procedure
#'       (adjusted repeated p-values when `look_back = FALSE`, adjusted
#'       sequential p-values when `look_back = TRUE`),
#'     * `rejected` - Logical vector of rejection decisions,
#'     * `decision_at` - Integer vector indicating the analysis at which each
#'       hypothesis's decision was made. For rejected hypotheses, this is
#'       the analysis where the rejection was operationally processed. For
#'       non-rejected hypotheses, this is the last analysis where the
#'       hypothesis was tested,
#'     * `first_rejected_at` - Integer vector indicating the earliest analysis
#'       at which each hypothesis's boundary was crossed. For non-rejected
#'       hypotheses, this is `NA`. When `look_back = TRUE`, this may be
#'       earlier than `decision_at` if a hypothesis crossed its boundary at
#'       a prior analysis but only became testable at a later analysis,
#'     * `last_rejected_at` - Integer vector indicating the latest analysis
#'       at which each hypothesis's boundary was crossed. For non-rejected
#'       hypotheses, this is `NA`. Comparing `first_rejected_at` and
#'       `last_rejected_at` shows whether the rejection is supported by
#'       data at multiple analyses or only at a single analysis,
#'     * `rejection_sequence` - Character vector giving the order in which
#'       hypotheses were rejected across all analyses,
#'     * `graph` - Updated graph after removing all rejected hypotheses.
#'   * `test_values` - Per-analysis details (if `test_values = TRUE`). A list
#'     of length \eqn{K} (one entry per analysis). Each entry is a data frame
#'     containing the hypothesis name, current weight, observed p-value,
#'     nominal boundary, and rejection decision at that analysis. Entries are
#'     `NULL` for analyses where no hypotheses are active. When
#'     `look_back = TRUE` and a hypothesis is rejected at an earlier analysis,
#'     additional rows show the nominal p-value and boundary at each prior
#'     analysis, with a `Look_back` column indicating these rows.
#'   * `boundary_table` - Boundary lookup table (if `verbose = TRUE`). A named
#'     list with one data frame per hypothesis. Each data frame contains the
#'     columns `Weight`, `Alpha.Allocated`, and `Boundary.k` for each
#'     analysis \eqn{k}, showing the nominal p-value boundary at each analysis
#'     for every possible weight from the graph's closure. This table is
#'     independent of observed p-values and can be used to manually verify
#'     rejection decisions.
#'
#' @seealso
#'   [graph_test_shortcut()] for the fixed-sample (non-sequential) shortcut
#'   procedure, [sequential_p()] for computing sequential p-values,
#'   [repeated_p()] for computing repeated p-values,
#'   [spending_of()], [spending_pocock()], [spending_hsd()],
#'   [spending_linear()] for spending functions.
#'
#' @rdname graph_test_shortcut_gsd
#'
#' @export
#'
#' @references
#'   Maurer, W., and Bretz, F. (2013). Multiple testing in group sequential
#'   trials using graphical approaches. \emph{Statistics in Biopharmaceutical
#'   Research}, 5(4), 311-320.
#'
#'   Zhao, Y., Liu, Q., Sun, L. Z., and Anderson, K. M. (2025). Adjusted
#'   inference for multiple testing procedure in group-sequential designs.
#'   \emph{Biometrical Journal}, 67(1), e70020.
#'   \doi{10.1002/bimj.70020}
#'
#' @examples
#' # A graphical procedure with two hypotheses tested at two analyses
#' hypotheses <- c(0.5, 0.5)
#' transitions <- rbind(c(0, 1), c(1, 0))
#' g <- graph_create(hypotheses, transitions)
#'
#' # P-values at interim (50% info) and final (100% info) analyses
#' p <- rbind(
#'   H1 = c(0.024, 0.01),
#'   H2 = c(0.015, 0.005)
#' )
#'
#' graph_test_shortcut_gsd(
#'   graph = g,
#'   p = p,
#'   alpha = 0.025,
#'   info_frac = c(0.5, 1),
#'   spending_fn = spending_of
#' )
#'
#' # With look_back = TRUE (sequential p-values)
#' graph_test_shortcut_gsd(
#'   graph = g,
#'   p = p,
#'   alpha = 0.025,
#'   info_frac = c(0.5, 1),
#'   spending_fn = spending_of,
#'   look_back = TRUE
#' )
#'
#' # Different spending functions per hypothesis
#' graph_test_shortcut_gsd(
#'   graph = g,
#'   p = p,
#'   alpha = 0.025,
#'   info_frac = c(0.5, 1),
#'   spending_fn = list(spending_of, spending_pocock)
#' )
#'
#' # User-defined spending functions can also be used, e.g., wrapping
#' # gsDesign::sfHSD(). See vignette("group-sequential-testing") for details.
#'
#' # Different information fractions per hypothesis
#' graph_test_shortcut_gsd(
#'   graph = g,
#'   p = p,
#'   alpha = 0.025,
#'   info_frac = rbind(c(0.5, 1), c(0.6, 1)),
#'   spending_fn = spending_of
#' )
#'
#' # Different numbers of analyses per hypothesis (NA padding)
#' # H1 at analyses 1-2, H2 at 1-3, H3 at 2-3, H4 at 1 and 3
#' g4 <- graph_create(
#'   rep(0.25, 4),
#'   rbind(
#'     c(0, 1 / 3, 1 / 3, 1 / 3),
#'     c(1 / 3, 0, 1 / 3, 1 / 3),
#'     c(1 / 3, 1 / 3, 0, 1 / 3),
#'     c(1 / 3, 1 / 3, 1 / 3, 0)
#'   )
#' )
#' p4 <- rbind(
#'   H1 = c(0.024, 0.01, NA),
#'   H2 = c(0.015, 0.005, 0.001),
#'   H3 = c(NA, 0.012, 0.004),
#'   H4 = c(0.05, NA, 0.015)
#' )
#' # info_frac must be a matrix with NA matching p
#' info_frac4 <- rbind(
#'   H1 = c(0.5, 1, NA),
#'   H2 = c(1 / 3, 2 / 3, 1),
#'   H3 = c(NA, 0.5, 1),
#'   H4 = c(0.4, NA, 1)
#' )
#' graph_test_shortcut_gsd(
#'   graph = g4,
#'   p = p4,
#'   alpha = 0.025,
#'   info_frac = info_frac4,
#'   spending_fn = spending_of
#' )
graph_test_shortcut_gsd <- function(graph,
                                    p,
                                    alpha = 0.025,
                                    info_frac,
                                    spending_fn,
                                    look_back = FALSE,
                                    verbose = FALSE,
                                    test_values = FALSE) {
  # Input normalization --------------------------------------------------------
  # p is an m × K matrix (hypotheses × analyses). Ensure it is a matrix and
  # label rows with hypothesis names from the graph if not already named.
  num_hyps <- length(graph$hypotheses)
  hyp_names <- names(graph$hypotheses)

  if (!is.matrix(p)) p <- as.matrix(p)
  if (is.null(rownames(p))) rownames(p) <- hyp_names
  num_analyses <- ncol(p)

  # info_frac can be a vector (same fractions for all hypotheses) or an m × K
  # matrix (different fractions per hypothesis). Normalize to m × K so that
  # info_frac[j, ] gives the information fractions for hypothesis j. When a
  # vector is provided, each hypothesis gets the same fractions.
  if (is.vector(info_frac)) {
    if (anyNA(p)) {
      stop(
        "When p contains NA (different numbers of analyses per hypothesis), ",
        "info_frac must be a matrix with NA in the same positions as p."
      )
    }
    info_frac <- matrix(
      rep(info_frac, each = num_hyps),
      nrow = num_hyps,
      ncol = num_analyses
    )
  }
  rownames(info_frac) <- hyp_names

  # spending_fn can be a single function (same for all hypotheses) or a list
  # of m functions (one per hypothesis). Normalize to a named list so that
  # spending_fn[[j]] gives the spending function for hypothesis j.
  if (is.function(spending_fn)) {
    spending_fn <- rep(list(spending_fn), num_hyps)
  }
  names(spending_fn) <- hyp_names

  # look_back can be a scalar (same for all hypotheses) or a logical vector
  # of length m (per hypothesis). Normalize to a named logical vector.
  if (length(look_back) == 1) {
    look_back <- structure(rep(look_back, num_hyps), names = hyp_names)
  }
  names(look_back) <- hyp_names

  # Input validation -----------------------------------------------------------
  gsd_input_val(
    graph, p, alpha, info_frac, spending_fn, look_back,
    verbose, test_values
  )

  # Determine analysis names from column names of p and info_frac.
  # If both have column names, they must match. If only one has them, use those.
  # If neither has them, default to Analysis_1, Analysis_2, ...
  p_names <- colnames(p)
  if_names <- colnames(info_frac)
  if (!is.null(p_names) && !is.null(if_names)) {
    stopifnot(
      "Column names of p and info_frac must match" =
        identical(p_names, if_names)
    )
    analysis_names <- p_names
  } else if (!is.null(p_names)) {
    analysis_names <- p_names
  } else if (!is.null(if_names)) {
    analysis_names <- if_names
  } else {
    analysis_names <- paste0("Analysis_", seq_len(num_analyses))
  }
  colnames(p) <- analysis_names
  colnames(info_frac) <- analysis_names

  # Run the procedure ----------------------------------------------------------
  result <- gsd_test(
    graph, p, alpha, info_frac, spending_fn, look_back,
    num_analyses, num_hyps, hyp_names, analysis_names,
    test_values, verbose
  )

  # Build the report -----------------------------------------------------------
  # Combine inputs, outputs, and optional test_values into an S3 object.
  # Both repeated_p and sequential_p are always included for reporting,
  # regardless of which was used for rejection decisions.
  structure(
    list(
      inputs = list(
        graph = graph,
        p = p,
        alpha = alpha,
        info_frac = info_frac,
        spending_fn = spending_fn,
        look_back = look_back,
        test_groups = list(seq_len(num_hyps)),
        test_types = "bonferroni"
      ),
      outputs = list(
        repeated_p = result$rep_p_matrix,
        sequential_p = result$seq_p_matrix,
        adjusted_p = result$adjusted_p,
        rejected = result$rejected,
        decision_at = result$decision_at,
        first_rejected_at = result$first_rejected_at,
        last_rejected_at = result$last_rejected_at,
        rejection_sequence = result$rejection_sequence,
        graph = if (any(result$rejected)) {
          graph_update(graph, result$rejected)$updated_graph
        } else {
          graph
        }
      ),
      test_values = if (test_values) result$test_values,
      boundary_table = if (verbose) {
        gsd_boundary_table(
          graph, alpha, info_frac, spending_fn,
          num_hyps, hyp_names
        )
      }
    ),
    class = "gsd_graph_report"
  )
}


#' Compute boundary table for all possible hypothesis weights
#'
#' For each hypothesis, enumerates all unique weights from the graph's closure
#' (via [graph_generate_weights()]) and computes the group sequential boundaries
#' at each analysis for each weight. This provides a lookup table for manual
#' verification: given a hypothesis's weight (from graph propagation), the
#' nominal boundary at each analysis can be read directly.
#'
#' @param graph An `initial_graph` object.
#' @param alpha Overall significance level.
#' @param info_frac Information fraction matrix (m x K).
#' @param spending_fn List of spending functions.
#' @param num_hyps Number of hypotheses.
#' @param hyp_names Character vector of hypothesis names.
#'
#' @return A named list of data frames, one per hypothesis. Each data frame
#'   has columns: `Weight`, `Alpha.Allocated`, and one `Boundary.k` column
#'   per analysis, showing the nominal p-value boundary at each analysis
#'   for each possible weight.
#'
#' @keywords internal
gsd_boundary_table <- function(graph, alpha, info_frac, spending_fn,
                               num_hyps, hyp_names) {
  # Get all possible weights from the closure
  weights_matrix <- graph_generate_weights(graph)
  # The weight columns are the last num_hyps columns
  weight_cols <- weights_matrix[, (num_hyps + 1):(2 * num_hyps), drop = FALSE]

  result <- list()
  for (j in seq_len(num_hyps)) {
    hyp <- hyp_names[j]

    # Get unique non-zero weights for this hypothesis, sorted
    unique_weights <- sort(unique(weight_cols[, j]))

    # Non-NA analysis indices for this hypothesis
    non_na <- which(!is.na(info_frac[j, ]))
    if_j <- info_frac[j, non_na]
    num_analyses_j <- length(if_j)

    rows <- list()
    for (w in unique_weights) {
      allocated <- w * alpha
      if (allocated <= 0) {
        boundaries <- rep(0, num_analyses_j)
      } else {
        bounds_result <- gs_boundaries(
          alpha = allocated,
          info_frac = if_j,
          spending_fn = spending_fn[[j]]
        )
        boundaries <- bounds_result$bounds_nominal
      }

      row <- data.frame(
        Weight = w,
        Alpha.Allocated = allocated,
        stringsAsFactors = FALSE
      )
      for (kk in seq_len(num_analyses_j)) {
        row[[paste0("Boundary.", non_na[kk])]] <- boundaries[kk]
      }
      rows[[length(rows) + 1]] <- row
    }

    result[[hyp]] <- do.call(rbind, rows)
  }

  result
}


#' Unified GSD procedure supporting per-hypothesis look_back
#'
#' Computes repeated and sequential p-values, then processes analyses
#' sequentially. At each analysis k, applies `graph_test_shortcut()` using
#' the appropriate p-values for each hypothesis: sequential p-values for
#' hypotheses with `look_back = TRUE`, repeated p-values for those with
#' `look_back = FALSE`. The graph is updated after each analysis before
#' proceeding to the next.
#'
#' @keywords internal
gsd_test <- function(graph, p, alpha, info_frac, spending_fn, look_back,
                     num_analyses, num_hyps, hyp_names, analysis_names,
                     test_values, verbose) {
  # Indices of non-NA analyses per hypothesis
  non_na_indices <- lapply(seq_len(num_hyps), function(j) which(!is.na(p[j, ])))

  # Compute repeated p-values at each analysis (m × K matrix)
  rep_p_matrix <- matrix(
    NA_real_, num_hyps, num_analyses,
    dimnames = list(hyp_names, analysis_names)
  )
  for (j in seq_len(num_hyps)) {
    idx_j <- non_na_indices[[j]]
    for (kk in seq_along(idx_j)) {
      cols <- idx_j[1:kk]
      rep_p_matrix[j, idx_j[kk]] <- suppressMessages(repeated_p(
        p = p[j, cols],
        info_frac = info_frac[j, cols],
        spending_fn = spending_fn[[j]]
      ))
    }
  }

  # Derive sequential p-values as cumulative minimum of repeated p-values
  seq_p_matrix <- rep_p_matrix
  for (j in seq_len(num_hyps)) {
    non_na <- !is.na(rep_p_matrix[j, ])
    if (any(non_na)) {
      seq_p_matrix[j, non_na] <- cummin(rep_p_matrix[j, non_na])
    }
  }

  # Process analyses sequentially
  rejected <- structure(rep(FALSE, num_hyps), names = hyp_names)
  last_rejected_at <- structure(rep(NA_integer_, num_hyps), names = hyp_names)
  decision_at <- structure(rep(NA_integer_, num_hyps), names = hyp_names)
  first_rejected_at <- structure(rep(NA_integer_, num_hyps), names = hyp_names)
  adjusted_p <- structure(rep(NA_real_, num_hyps), names = hyp_names)
  rejection_sequence <- character(0)

  step_graph <- graph
  tv_details <- if (test_values) vector("list", num_analyses)

  for (k in seq_len(num_analyses)) {
    # Get active hypotheses: not rejected AND has data at this analysis.
    # For look_back hypotheses, "has data" means data at any analysis up to k
    # (since the sequential p-value carries forward from prior analyses).
    has_data_k <- !is.na(p[, k])
    has_prior_data <- vapply(seq_len(num_hyps), function(j) {
      any(!is.na(p[j, seq_len(k)]))
    }, logical(1))
    active_at_k <- ifelse(look_back, has_prior_data, has_data_k)
    active <- !rejected & active_at_k

    if (!any(active)) next

    # Construct the p-value vector for the shortcut: use sequential p-values
    # for hypotheses with look_back = TRUE, repeated p-values otherwise.
    # For look_back hypotheses without data at analysis k, use their most
    # recent sequential p-value (carried forward from the last available
    # analysis).
    last_seq_p <- vapply(seq_len(num_hyps), function(j) {
      available <- which(!is.na(seq_p_matrix[j, seq_len(k)]))
      if (length(available) == 0) NA_real_ else seq_p_matrix[j, max(available)]
    }, numeric(1))

    p_for_shortcut <- ifelse(
      look_back,
      last_seq_p,
      rep_p_matrix[, k]
    )

    # For hypotheses that are not active, set p to 1 so they are never
    # selected by graph_test_shortcut().
    p_for_shortcut[!active] <- 1

    # Apply shortcut to the current graph
    shortcut_k <- graph_test_shortcut(
      graph = step_graph,
      p = p_for_shortcut,
      alpha = alpha,
      verbose = TRUE,
      test_values = FALSE
    )

    # Identify newly rejected hypotheses at this analysis
    newly_rejected <- shortcut_k$outputs$rejected & active & !rejected
    newly_rejected_names <- hyp_names[newly_rejected]

    # Record the rejection sequence at this analysis (in shortcut order)
    del_seq_k <- shortcut_k$details$del_seq
    newly_in_order <- del_seq_k[del_seq_k %in% newly_rejected_names]
    rejection_sequence <- c(rejection_sequence, newly_in_order)

    # Record adjusted p-values and decision analysis for newly rejected.
    # decision_at = the operational analysis k.
    # first_rejected_at = earliest analysis where boundary was crossed.
    # For look_back hypotheses, search backwards; otherwise, set to k.
    for (hyp_name in newly_rejected_names) {
      adjusted_p[hyp_name] <- shortcut_k$outputs$adjusted_p[hyp_name]
      decision_at[hyp_name] <- k

      if (look_back[hyp_name]) {
        # Find the weight at the point of rejection from the shortcut's
        # graph sequence
        rej_idx <- which(del_seq_k == hyp_name)
        w_at_rejection <-
          shortcut_k$details$results[[rej_idx]]$hypotheses[hyp_name]
        allocated_alpha <- w_at_rejection * alpha

        # Look back: earliest and latest analysis where boundary is crossed.
        # Check repeated p-values (not sequential) at each analysis against
        # the allocated alpha — a repeated p <= allocated alpha means the
        # boundary at that specific analysis is crossed.
        j <- which(hyp_names == hyp_name)
        crossed <- which(rep_p_matrix[j, 1:k] <= allocated_alpha)
        first_rejected_at[hyp_name] <-
          if (length(crossed) > 0) crossed[1] else k
        last_rejected_at[hyp_name] <-
          if (length(crossed) > 0) crossed[length(crossed)] else k
      } else {
        first_rejected_at[hyp_name] <- k
        last_rejected_at[hyp_name] <- k
      }
    }

    # For non-rejected active hypotheses, update adjusted p-values and
    # track the last analysis where they were tested.
    not_rejected_active <- active & !shortcut_k$outputs$rejected
    adjusted_p[not_rejected_active] <-
      shortcut_k$outputs$adjusted_p[not_rejected_active]
    decision_at[not_rejected_active] <- k

    rejected[newly_rejected] <- TRUE

    # Per-analysis test_values details
    if (test_values) {
      tv_details[[k]] <- gsd_test_values_details(
        step_graph, p, k, alpha, info_frac, spending_fn,
        newly_in_order, hyp_names, rejected, active_at_k
      )

      # Add Look_back column (FALSE for all standard rows)
      tv_details[[k]]$Look_back <- FALSE

      # For look_back hypotheses: insert prior-analysis rows where
      # first_rejected_at < k (boundary crossed at an earlier analysis).
      for (hyp_name in newly_rejected_names) {
        if (look_back[hyp_name] &&
          !is.na(first_rejected_at[hyp_name]) &&
          first_rejected_at[hyp_name] < k) {
          rej_idx <- which(del_seq_k == hyp_name)
          w_at_rej <-
            shortcut_k$details$results[[rej_idx]]$hypotheses[hyp_name]
          lb_rows <- gsd_test_values_look_back(
            hyp_name, k, first_rejected_at[hyp_name], alpha, p,
            info_frac, spending_fn, hyp_names, w_at_rej
          )

          # Check if this hypothesis has a standard row at analysis k
          hyp_row <- which(tv_details[[k]]$Hypothesis == hyp_name &
            tv_details[[k]]$Analysis == k)

          if (length(hyp_row) > 0) {
            # Has data at analysis k: check if the nominal p-value at
            # analysis k also crosses the boundary. If not, set Reject
            # to FALSE (the rejection is only via look_back).
            p_at_k <- tv_details[[k]]$p[hyp_row]
            b_at_k <- tv_details[[k]]$Boundary[hyp_row]
            if (is.na(p_at_k) || p_at_k > b_at_k) {
              tv_details[[k]]$Reject[hyp_row] <- FALSE
            }
            before <- tv_details[[k]][seq_len(hyp_row), , drop = FALSE]
            after <- if (hyp_row < nrow(tv_details[[k]])) {
              tv_details[[k]][(hyp_row + 1):nrow(tv_details[[k]]), ,
                drop = FALSE
              ]
            }
            tv_details[[k]] <- rbind(before, lb_rows, after)
          } else {
            # No data at analysis k (look_back-only): append look_back rows
            # at the position where this hypothesis was rejected in the
            # shortcut sequence
            tv_details[[k]] <- rbind(tv_details[[k]], lb_rows)
          }
        }
      }
    }

    # Update graph: remove all rejected hypotheses
    if (any(newly_rejected)) {
      step_graph <- graph_update(step_graph, rejected)$updated_graph
    }
  }

  list(
    rep_p_matrix = rep_p_matrix,
    seq_p_matrix = seq_p_matrix,
    adjusted_p = adjusted_p,
    rejected = rejected,
    decision_at = decision_at,
    first_rejected_at = first_rejected_at,
    last_rejected_at = last_rejected_at,
    rejection_sequence = rejection_sequence,
    test_values = tv_details
  )
}


#' Compute test_values for look_back = FALSE (analysis-by-analysis)
#'
#' For each analysis, computes the nominal boundaries and records the
#' rejection sequence with boundaries at which rejections occurred.
#' Walks through the rejection sequence within each analysis, updating
#' the graph and recomputing boundaries after each rejection.
#'
#' @keywords internal
gsd_test_values_details <- function(step_graph, p, k, alpha, info_frac,
                                    spending_fn, rejection_seq_k,
                                    hyp_names, rejected_after,
                                    has_data_k = rep(TRUE, length(hyp_names))) {
  num_hyps <- length(hyp_names)
  # Active hypotheses at the start of this analysis: have data at analysis k,
  # and either not yet rejected or rejected at this analysis
  active_before <- has_data_k &
    (!rejected_after | (hyp_names %in% rejection_seq_k))

  # Early return if no hypotheses are active (e.g., all rejected at earlier
  # analyses) or if rejection_seq_k is empty and no active hypotheses remain
  if (!any(active_before)) {
    return(NULL)
  }

  # Helper: compute the nominal boundary at analysis k for hypothesis j
  # using the current graph's allocated alpha (weight * alpha)
  compute_boundary <- function(j, current_graph) {
    total_alpha_j <- current_graph$hypotheses[j] * alpha
    if (total_alpha_j <= 0) {
      return(0)
    }
    # Use non-NA entries up to and including analysis k
    non_na_up_to_k <- which(!is.na(info_frac[j, ]) & seq_len(ncol(info_frac)) <= k)
    if_j <- info_frac[j, non_na_up_to_k]
    k_eff <- length(if_j)
    bounds_result <- gs_boundaries(
      alpha = total_alpha_j,
      info_frac = if_j,
      spending_fn = spending_fn[[j]]
    )
    bounds_result$bounds_nominal[k_eff]
  }

  detail_rows <- list()
  current_graph <- step_graph

  # Walk through rejections: compute boundary on-the-fly with current graph
  # weights, then update graph after each rejection
  for (hyp_name in rejection_seq_k) {
    j <- which(hyp_names == hyp_name)
    detail_rows[[length(detail_rows) + 1]] <- data.frame(
      Hypothesis = hyp_name,
      Weight = current_graph$hypotheses[hyp_name],
      p = p[j, k],
      Boundary = compute_boundary(j, current_graph),
      Reject = TRUE,
      stringsAsFactors = FALSE
    )

    # Update graph after this rejection
    delete_vec <- structure(rep(FALSE, num_hyps), names = hyp_names)
    delete_vec[hyp_name] <- TRUE
    current_graph <- graph_update(current_graph, delete_vec)$updated_graph
  }

  # Add non-rejected active hypotheses with boundaries from the final
  # updated graph (after all rejections at this analysis)
  rejected_names <- if (length(detail_rows) > 0) {
    vapply(detail_rows, function(r) r$Hypothesis, character(1))
  } else {
    character(0)
  }
  not_rejected_active <- active_before & !(hyp_names %in% rejected_names)
  for (j in which(not_rejected_active)) {
    detail_rows[[length(detail_rows) + 1]] <- data.frame(
      Hypothesis = hyp_names[j],
      Weight = current_graph$hypotheses[j],
      p = p[j, k],
      Boundary = compute_boundary(j, current_graph),
      Reject = FALSE,
      stringsAsFactors = FALSE
    )
  }

  if (length(detail_rows) == 0) {
    return(NULL)
  }

  data.frame(
    Analysis = k,
    do.call(rbind, detail_rows),
    stringsAsFactors = FALSE,
    row.names = NULL
  )
}


#' Compute look_back rows for test_values
#'
#' When a hypothesis is rejected via look_back at an earlier analysis than the
#' operational analysis, this function generates rows showing the nominal
#' p-value and boundary at each prior analysis (in decreasing order from the
#' operational analysis down to the attributed analysis). The weight and
#' boundaries are computed using the hypothesis's weight at the point of
#' rejection. The `Reject` column indicates whether the nominal p-value
#' crosses the boundary at each analysis.
#'
#' @param hyp_name Name of the hypothesis.
#' @param k The operational analysis where the rejection occurred.
#' @param attributed_to The analysis to which the rejection is attributed.
#' @param alpha Overall significance level.
#' @param p P-value matrix.
#' @param info_frac Information fraction matrix.
#' @param spending_fn List of spending functions.
#' @param hyp_names Character vector of hypothesis names.
#' @param w_at_rejection The hypothesis weight at the point of rejection
#'   (from the shortcut's internal graph sequence).
#'
#' @return A data frame with look_back rows for analyses k-1, k-2, ...,
#'   attributed_to.
#'
#' @keywords internal
gsd_test_values_look_back <- function(hyp_name, k, attributed_to, alpha, p,
                                      info_frac, spending_fn, hyp_names,
                                      w_at_rejection) {
  j <- which(hyp_names == hyp_name)
  total_alpha_j <- w_at_rejection * alpha

  # Non-NA analysis indices for this hypothesis
  non_na_all <- which(!is.na(info_frac[j, ]))

  # Compute boundaries at all analyses up to k using the allocated alpha
  non_na_up_to_k <- non_na_all[non_na_all <= k]
  if_j <- info_frac[j, non_na_up_to_k]
  bounds_result <- gs_boundaries(
    alpha = total_alpha_j,
    info_frac = if_j,
    spending_fn = spending_fn[[j]]
  )

  # Generate rows for analyses k-1 down to attributed_to (decreasing order)
  prior_analyses <- seq(k - 1, attributed_to)
  detail_rows <- list()

  for (a in prior_analyses) {
    # Find the position of analysis a within the non-NA analyses up to k
    a_pos <- which(non_na_up_to_k == a)
    if (length(a_pos) == 0) next # hypothesis has no data at this analysis

    nominal_p <- p[j, a]
    boundary <- bounds_result$bounds_nominal[a_pos]
    crossed <- !is.na(nominal_p) && nominal_p <= boundary

    detail_rows[[length(detail_rows) + 1]] <- data.frame(
      Analysis = a,
      Hypothesis = hyp_name,
      Weight = w_at_rejection,
      p = nominal_p,
      Boundary = boundary,
      Reject = crossed,
      Look_back = TRUE,
      stringsAsFactors = FALSE
    )
  }

  if (length(detail_rows) == 0) {
    return(NULL)
  }
  do.call(rbind, detail_rows)
}


#' Validate inputs for group sequential graphical MCP
#'
#' @inheritParams graph_test_shortcut_gsd
#'
#' @return Invisibly returns `graph`.
#'
#' @keywords internal
gsd_input_val <- function(graph, p, alpha, info_frac, spending_fn, look_back,
                          verbose, test_values) {
  num_hyps <- length(graph$hypotheses)
  num_analyses <- ncol(p)

  p_non_na <- p[!is.na(p)]
  if_non_na <- info_frac[!is.na(info_frac)]

  stopifnot(
    "Please test an `initial_graph` object" =
      inherits(graph, "initial_graph"),
    "P-values must be a matrix with rows matching the number of hypotheses" =
      is.matrix(p) && nrow(p) == num_hyps,
    "P-values must be numeric" = is.numeric(p),
    "Non-NA p-values must be between 0 and 1" =
      length(p_non_na) == 0 || all(p_non_na >= 0 & p_non_na <= 1),
    "NA positions in p and info_frac must match" =
      identical(is.na(p), is.na(info_frac)),
    "Alpha must be numeric" = is.numeric(alpha),
    "Please choose a single alpha level" = length(alpha) == 1,
    "Alpha must be between 0 and 1" = alpha >= 0 && alpha <= 1,
    "Information fractions must be a matrix with rows matching hypotheses" =
      is.matrix(info_frac) && nrow(info_frac) == num_hyps,
    "Information fractions must have the same number of columns as p" =
      ncol(info_frac) == num_analyses,
    "Information fractions must be numeric" = is.numeric(info_frac),
    "Non-NA information fractions must be positive" =
      length(if_non_na) == 0 || all(if_non_na > 0),
    "Spending functions must be a list of functions" =
      is.list(spending_fn) &&
        all(vapply(spending_fn, is.function, logical(1))),
    "Number of spending functions must match the number of hypotheses" =
      length(spending_fn) == num_hyps,
    "look_back must be a logical vector of length matching hypotheses" =
      is.logical(look_back) && length(look_back) == num_hyps,
    "Verbose flag must be a length one logical" =
      is.logical(verbose) && length(verbose) == 1,
    "Test values flag must be a length one logical" =
      is.logical(test_values) && length(test_values) == 1
  )

  # Each hypothesis must have at least one non-NA analysis
  for (j in seq_len(num_hyps)) {
    stopifnot(
      "Each hypothesis must have at least one non-NA analysis" =
        any(!is.na(p[j, ]))
    )
  }

  # Check info_frac is non-decreasing per hypothesis (non-NA values only)
  for (j in seq_len(num_hyps)) {
    t_j <- info_frac[j, !is.na(info_frac[j, ])]
    if (length(t_j) > 1) {
      stopifnot(
        "Information fractions must be non-decreasing for each hypothesis" =
          all(diff(t_j) >= 0)
      )
    }
  }

  invisible(graph)
}

#' S3 print method for the class `gsd_graph_report`
#'
#' @description
#' A printed `gsd_graph_report` displays:
#' * **Test parameters**: the initial graph, alpha, information fractions,
#'   p-values, spending functions, and per-hypothesis look_back settings.
#' * **Test summary**: adjusted p-values, rejection decisions, the analysis
#'   at which each decision was made (`Decision.at`), the earliest analysis
#'   at which the boundary was crossed (`First.Rej.at`), look_back status,
#'   and the rejection sequence.
#' * **Per-analysis details** (if `test_values = TRUE`): nominal p-values,
#'   boundaries, and rejection decisions at each analysis. For hypotheses
#'   rejected via look_back, additional rows show the boundary crossing at
#'   earlier analyses, marked with `*` and a footnote.
#' * **Boundary table** (if `verbose = TRUE`): nominal p-value boundaries
#'   for all possible hypothesis weights from the graph's closure, enabling
#'   manual verification of rejection decisions.
#'
#' @param x An object of class `gsd_graph_report` to print.
#' @param ... Other values passed on to other methods (currently unused).
#' @param precision An integer scalar indicating the number of decimal places
#'   to display.
#' @param indent An integer scalar indicating how many spaces to indent
#'   results.
#'
#' @return An object x of class `gsd_graph_report`, invisibly.
#'
#' @rdname print.gsd_graph_report
#'
#' @export
#'
#' @references
#'   Maurer, W., and Bretz, F. (2013). Multiple testing in group sequential
#'   trials using graphical approaches. \emph{Statistics in Biopharmaceutical
#'   Research}, 5(4), 311-320.
#'
#' @examples
#' hypotheses <- c(0.5, 0.5)
#' transitions <- rbind(c(0, 1), c(1, 0))
#' g <- graph_create(hypotheses, transitions)
#'
#' p <- rbind(
#'   H1 = c(0.024, 0.01),
#'   H2 = c(0.015, 0.005)
#' )
#'
#' graph_test_shortcut_gsd(
#'   graph = g,
#'   p = p,
#'   alpha = 0.025,
#'   info_frac = c(0.5, 1),
#'   spending_fn = spending_of
#' )
print.gsd_graph_report <- function(x, ..., precision = 6, indent = 2) {
  pad <- paste(rep(" ", indent), collapse = "")
  hyp_names <- names(x$inputs$graph$hypotheses)
  num_hyps <- length(hyp_names)
  num_analyses <- ncol(x$inputs$p)

  # Input parameters -----------------------------------------------------------
  cat("\n")
  section_break("Test parameters ($inputs)")

  print(x$inputs$graph, precision = precision, indent = indent)
  cat("\n")
  cat(pad, "Alpha = ", x$inputs$alpha, "\n", sep = "")

  # Analysis names from column names of p
  analysis_names <- colnames(x$inputs$p)

  # Information fractions table
  cat("\n", pad, "Information fractions\n", sep = "")
  info_df <- as.data.frame(x$inputs$info_frac, row.names = hyp_names)
  colnames(info_df) <- analysis_names
  print(info_df)

  # P-values table
  cat("\n", pad, "P-values\n", sep = "")
  p_df <- as.data.frame(x$inputs$p, row.names = hyp_names)
  colnames(p_df) <- analysis_names
  p_df[] <- lapply(p_df, function(col) formatC(col, format = "f", digits = precision))
  print(p_df)

  # Spending functions
  cat("\n", pad, "Spending functions\n", sep = "")
  for (j in seq_len(num_hyps)) {
    sf_body <- deparse(body(x$inputs$spending_fn[[j]]))
    sf_name <- tryCatch(
      {
        env <- environment(x$inputs$spending_fn[[j]])
        if (identical(x$inputs$spending_fn[[j]], spending_of)) {
          "O'Brien-Fleming"
        } else if (identical(x$inputs$spending_fn[[j]], spending_pocock)) {
          "Pocock"
        } else if (identical(x$inputs$spending_fn[[j]], spending_linear)) {
          "Linear"
        } else {
          paste(sf_body, collapse = " ")
        }
      },
      error = function(e) paste(sf_body, collapse = " ")
    )
    cat(pad, pad, hyp_names[j], ": ", sf_name, "\n", sep = "")
  }

  # Look back mode
  look_back <- x$inputs$look_back
  if (all(look_back == look_back[1])) {
    cat("\n", pad, "Look back = ", look_back[1], "\n", sep = "")
  } else {
    cat("\n", pad, "Look back\n", sep = "")
    for (j in seq_len(num_hyps)) {
      cat(pad, pad, hyp_names[j], ": ", look_back[j], "\n", sep = "")
    }
  }

  # Test summary ---------------------------------------------------------------
  cat("\n")
  section_break("Test summary ($outputs)")

  hyp_width <- max(nchar(c("Hypothesis", hyp_names))) + indent - 1

  adj_p <- x$outputs$adjusted_p
  exceed_1 <- adj_p > 1
  adj_p_format <- character(length(adj_p))
  adj_p_format[exceed_1] <- gsub(".00000001", "+", adj_p[exceed_1])
  adj_p_format[!exceed_1] <- formatC(adj_p[!exceed_1],
    format = "f",
    digits = precision
  )

  decision_at <- x$outputs$decision_at

  first_rej_display <- ifelse(
    is.na(x$outputs$first_rejected_at),
    "--",
    as.character(x$outputs$first_rejected_at)
  )

  last_rej_display <- ifelse(
    is.na(x$outputs$last_rejected_at),
    "--",
    as.character(x$outputs$last_rejected_at)
  )

  df_summary <- data.frame(
    Hypothesis = formatC(hyp_names, width = hyp_width),
    Adj.P = adj_p_format,
    Reject = x$outputs$rejected,
    Tested.at = as.character(decision_at),
    First.Rej.at = first_rej_display,
    Last.Rej.at = last_rej_display,
    Look.back = look_back,
    check.names = FALSE
  )
  names(df_summary)[[1]] <- formatC("Hypothesis", width = hyp_width)
  names(df_summary)[[2]] <- "Adj.p*"

  print(df_summary, row.names = FALSE)

  cat(pad, "(*) Adjusted p-values account for both the group sequential",
    " design and the\n", pad, "    graphical multiple comparison procedure.",
    " Based on repeated p-values when\n", pad, "    look_back = FALSE,",
    " and sequential p-values when look_back = TRUE.\n",
    sep = ""
  )

  # Rejection sequence
  rej_seq <- x$outputs$rejection_sequence
  if (length(rej_seq) > 0) {
    cat("\n", pad, "Rejection sequence: ",
      paste(rej_seq, collapse = " -> "), "\n",
      sep = ""
    )
  }
  cat("\n")

  attr(x$outputs$graph, "title") <-
    "Final updated graph after removing rejected hypotheses"
  print(x$outputs$graph, precision = precision, indent = indent)
  cat("\n")

  # Per-analysis test values ---------------------------------------------------
  if (!is.null(x$test_values)) {
    section_break("Per-analysis details ($test_values)")

    for (k in seq_along(x$test_values)) {
      detail <- x$test_values[[k]]
      if (is.null(detail)) next

      cat(pad, "Analysis ", k, "\n", sep = "")

      # Check for look_back rows
      has_look_back <- "Look_back" %in% names(detail) && any(detail$Look_back)
      lb_hypotheses <- if (has_look_back) {
        unique(detail$Hypothesis[detail$Look_back])
      } else {
        character(0)
      }

      # Add footnote marker (*) to hypotheses with look_back attribution
      if (has_look_back) {
        detail$Hypothesis[detail$Look_back] <-
          paste0(detail$Hypothesis[detail$Look_back], "*")
      }

      # Remove the Look_back column from display
      detail$Look_back <- NULL

      # Format numeric columns with consistent fixed notation
      detail$Weight <- formatC(detail$Weight, format = "f", digits = precision)
      detail$p <- formatC(detail$p, format = "f", digits = precision)
      detail$Boundary <- formatC(detail$Boundary, format = "f", digits = precision)

      detail_out <- utils::capture.output(
        print(detail, row.names = FALSE)
      )
      cat(paste0(pad, detail_out), sep = "\n")

      # Print footnote for look_back hypotheses
      if (has_look_back) {
        cat(pad, "(*) Rejected via look_back: the nominal p-value crossed",
          " the boundary at an\n", pad, "    earlier analysis with the",
          " hypothesis weight updated via graph propagation.\n",
          sep = ""
        )
      }
      cat("\n")
    }
  }

  # Repeated and sequential p-values (verbose) --------------------------------
  if (!is.null(x$boundary_table)) {
    section_break("Repeated p-values ($outputs$repeated_p)")
    rep_p_display <- x$outputs$repeated_p
    rep_p_display[] <- formatC(rep_p_display, format = "f", digits = precision)
    print(as.data.frame(rep_p_display))

    cat("\n")
    section_break("Sequential p-values ($outputs$sequential_p)")
    seq_p_display <- x$outputs$sequential_p
    seq_p_display[] <- formatC(seq_p_display, format = "f", digits = precision)
    print(as.data.frame(seq_p_display))
    cat("\n")
  }

  # Boundary table (verbose) ---------------------------------------------------
  if (!is.null(x$boundary_table)) {
    section_break("Boundary table ($boundary_table)")

    cat(pad, "Nominal p-value boundaries for all possible hypothesis weights\n",
      pad, "from the graph's closure. Use to verify rejection decisions:\n",
      pad, "a hypothesis is rejected when its p-value <= boundary.\n\n",
      sep = ""
    )

    for (hyp in names(x$boundary_table)) {
      cat(pad, hyp, "\n", sep = "")
      bt <- x$boundary_table[[hyp]]
      bt_display <- bt
      # Format numeric columns with consistent fixed notation
      for (col in names(bt_display)) {
        bt_display[[col]] <- formatC(bt_display[[col]],
          format = "f", digits = precision
        )
      }
      bt_out <- utils::capture.output(print(bt_display, row.names = FALSE))
      cat(paste0(pad, bt_out), sep = "\n")
      cat("\n")
    }
  }

  invisible(x)
}

#' Generate the weighting strategy based on a graphical multiple comparison
#' procedure
#'
#' @description
#' A graphical multiple comparison procedure defines a closed test procedure,
#' which tests each intersection hypothesis and reject an individual hypothesis
#' if all intersection hypotheses involving it have been rejected. An
#' intersection hypothesis represents the parameter space where individual null
#' hypotheses involved are true simultaneously.
#'
#' The closure based on a graph consists of all updated graphs (corresponding
#' to intersection hypotheses) after all combinations of hypotheses are deleted.
#' For a graphical multiple comparison procedure with \eqn{m} hypotheses, there
#' are \eqn{2^{m}-1} updated graphs (intersection hypotheses), including the
#' initial graph (the overall intersection hypothesis). The weighting strategy
#' of this graph consists of hypothesis weights from all \eqn{2^{m}-1} updated
#' graphs (intersection hypotheses). The algorithm to derive the weighting
#' strategy is based on Algorithm 1 in Bretz et al. (2011).
#'
#' @inheritParams graph_update
#'
#' @return A numeric matrix of all intersection hypotheses and their hypothesis
#' weights. For a graphical multiple comparison procedure with \eqn{m} hypotheses,
#' the number of rows is \eqn{2^{m}-1}, each of which corresponds to an intersection
#' hypothesis. The number of columns is \eqn{2\cdot m}. The first \eqn{m} columns
#' indicate which individual hypotheses are included in a given intersection
#' hypothesis and the second half of columns provide hypothesis weights for each
#' individual hypothesis for a given intersection hypothesis.
#'
#' @section Performance:
#' Generation of intersection hypotheses is closely related to the power set
#' of a given set of indices. As the number of hypotheses increases, the memory
#' and time usage can grow quickly (e.g., at a rate of \eqn{O(2^n)}). There are also
#' multiple ways to implement Algorithm 1 in Bretz et al. (2011). See
#' `vignette("generate-closure")` for more information about generating
#' intersection hypotheses and comparisons of different approaches to calculate
#' weighting strategies.
#'
#' @seealso
#'   [graph_test_closure()] for graphical multiple comparison procedures using
#'   the closed test.
#'
#' @rdname graph_generate_weights
#'
#' @export
#'
#' @references
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 1 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' transitions <- rbind(
#'   c(0, 0, 1, 0),
#'   c(0, 0, 0, 1),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#'
#' graph_generate_weights(g)
graph_generate_weights <- function(graph) {
  hyp_names <- names(graph$hypotheses)
  num_hyps <- length(graph$hypotheses)

  parents <- do.call(c, lapply(2^(seq_len(num_hyps) - 1), seq_len))
  parents <- parents[-(2^num_hyps - 1)]

  delete <- rep(rev(seq_len(num_hyps)), 2^(seq_len(num_hyps) - 1))
  delete <- delete[-(2^num_hyps - 1)]

  graphs <- vector("list", length(parents))
  graphs[[1]] <- graph

  matrix_weights <- matrix(nrow = 2^num_hyps - 1, ncol = num_hyps)
  dimnames(matrix_weights) <- list(seq_len(2^num_hyps - 1), hyp_names)
  matrix_weights[1, ] <- graph$hypotheses

  for (i in seq_along(parents)) {
    parent <- graphs[[parents[[i]]]]
    del_index <- which(hyp_names[[delete[[i]]]] == names(parent$hypotheses))

    init_hypotheses <- parent$hypotheses
    init_transitions <- parent$transitions

    hypotheses <- parent$hypotheses
    transitions <- parent$transitions

    hyp_nums <- seq_along(hypotheses)[-del_index]

    for (hyp_num in hyp_nums) {
      hypotheses[[hyp_num]] <-
        init_hypotheses[[hyp_num]] +
        init_hypotheses[[del_index]] * init_transitions[[del_index, hyp_num]]

      denominator <- 1 - init_transitions[[hyp_num, del_index]] *
        init_transitions[[del_index, hyp_num]]

      for (end_num in hyp_nums) {
        if (hyp_num == end_num || denominator <= 0) {
          transitions[[hyp_num, end_num]] <- 0
        } else {
          transitions[[hyp_num, end_num]] <-
            (init_transitions[[hyp_num, end_num]] +
              init_transitions[[hyp_num, del_index]] *
                init_transitions[[del_index, end_num]]) / denominator
        }
      }
    }

    graphs[[i + 1]] <- structure(
      list(
        hypotheses = hypotheses[-del_index],
        transitions =
          as.matrix(transitions[-del_index, -del_index, drop = FALSE])
      ),
      class = "initial_graph"
    )

    matrix_weights[i + 1, ] <- hypotheses[-del_index][hyp_names]
  }

  matrix_intersections <- !is.na(matrix_weights)
  matrix_weights[is.na(matrix_weights)] <- 0

  cbind(matrix_intersections, matrix_weights)
}

#' S3 print method for the class `power_report`
#'
#' @description
#' A printed `power_report` displays the initial graph, testing and simulation
#' options, power outputs, and optional detailed simulations and test results.
#'
#' @param x An object of the class `power_report` to print
#' @inheritParams print.graph_report
#'
#' @return An object x of the class `power_report`, after printing the report of
#'   conducting power simulations based on a graphical multiple comparison
#'   procedure.
#'
#' @rdname print.power_report
#'
#' @export
#'
#' @references
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011a). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#'   Bretz, F., Maurer, W., and Hommel, G. (2011b). Test and power
#'   considerations for multiple endpoint analyses using sequentially rejective
#'   graphical procedures. \emph{Statistics in Medicine}, 30(13), 1489-1501.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 4 in Bretz et al. (2011).
#' alpha <- 0.025
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' delta <- 0.5
#' transitions <- rbind(
#'   c(0, delta, 1 - delta, 0),
#'   c(delta, 0, 0, 1 - delta),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#'
#' marginal_power <- c(0.8, 0.8, 0.7, 0.9)
#' corr1 <- matrix(0.5, nrow = 2, ncol = 2)
#' diag(corr1) <- 1
#' corr <- rbind(
#'   cbind(corr1, 0.5 * corr1),
#'   cbind(0.5 * corr1, corr1)
#' )
#' success_fns <- list(
#'   # Probability to reject both H1 and H2
#'   `H1andH2` = function(x) x[1] & x[2],
#'   # Probability to reject both (H1 and H3) or (H2 and H4)
#'   `(H1andH3)or(H2andH4)` = function(x) (x[1] & x[3]) | (x[2] & x[4])
#' )
#' set.seed(1234)
#' # Bonferroni tests
#' power_output <- graph_calculate_power(
#'   g,
#'   alpha,
#'   sim_corr = corr,
#'   sim_n = 1e5,
#'   power_marginal = marginal_power,
#'   sim_success = success_fns
#' )
print.power_report <- function(x, ..., precision = 4, indent = 2, rows = 10) {
  pad <- paste(rep(" ", indent), collapse = "")
  pad_less_1 <- paste(rep(" ", max(indent - 1, 0)), collapse = "")
  hyp_names <- names(x$inputs$graph$hypotheses)

  # Test input calcs -----------------------------------------------------------
  cat("\n")
  section_break("Test parameters ($inputs)")

  hyp_groups <- lapply(x$inputs$test_groups, function(group) hyp_names[group])
  pad_tests <- formatC(
    x$inputs$test_types,
    width = max(nchar(x$inputs$test_types)) + indent
  )

  test_spec <- paste0(
    pad_tests,
    ": (",
    lapply(hyp_groups, paste, collapse = ", "),
    ")",
    collapse = "\n"
  )

  if (!is.null(x$inputs$test_corr)) {
    para_hyps <-
      unlist(x$inputs$test_groups[x$inputs$test_types == "parametric"])
    dimnames(x$inputs$test_corr) <- dimnames(x$inputs$graph$transitions)
    colname_pad <- format(
      "Parametric testing correlation:   ",
      width = max(nchar(rownames(x$inputs$test_corr[para_hyps, para_hyps])))
    )
    label <- paste0(pad_less_1, colname_pad)
    df_corr <- data.frame(
      paste0(pad_less_1, rownames(x$inputs$test_corr)[para_hyps]),
      format(x$inputs$test_corr[para_hyps, para_hyps], digits = precision),
      check.names = FALSE
    )
    names(df_corr)[[1]] <- label
  }

  # Test input print -----------------------------------------------------------
  print(x$inputs$graph, precision = precision, indent = indent)
  cat("\n")
  cat(pad, "Alpha = ", x$inputs$alpha, sep = "")
  cat("\n\n")
  if (!is.null(x$inputs$test_corr)) {
    print(df_corr, row.names = FALSE)
    cat("\n")
  }
  cat(pad, "Test types", "\n", test_spec, sep = "")
  cat("\n")

  # Sim input calcs ------------------------------------------------------------
  cat("\n")
  section_break("Simulation parameters ($inputs)")

  theta_mat <- matrix(
    x$inputs$power_marginal,
    nrow = 1,
    dimnames = list(
      paste0(pad, "Marginal power:"),
      hyp_names
    ),
  )

  dimnames(x$inputs$sim_corr) <- dimnames(x$inputs$graph$transitions)
  colname_pad <- format(
    "Correlation:   ",
    width = max(nchar(rownames(x$inputs$sim_corr)))
  )
  label <- paste0(pad_less_1, colname_pad)
  df_corr <- data.frame(
    paste0(pad_less_1, rownames(x$inputs$sim_corr)),
    format(x$inputs$sim_corr, digits = precision),
    check.names = FALSE
  )
  names(df_corr)[[1]] <- label

  # Sim input print ------------------------------------------------------------
  cat(paste0(
    paste0(pad, "Testing "),
    format(x$inputs$sim_n, scientific = FALSE, big.mark = ","),
    " simulations with multivariate normal params:"
  ))
  cat("\n\n")

  print(as.data.frame(format(theta_mat, digits = precision)))
  cat("\n")
  print(df_corr, row.names = FALSE)

  # Power ----------------------------------------------------------------------
  cat("\n")
  section_break("Power calculation ($power)")

  local_mat <- matrix(
    x$power$power_local,
    nrow = 1,
    dimnames = list(
      paste0(pad, "               Local power:"),
      hyp_names
    ),
  )

  print(as.data.frame(format(local_mat, digits = precision)))
  cat("\n")

  cat(
    pad,
    "Expected no. of rejections: ",
    format(x$power$rejection_expected, digits = precision),
    "\n",
    sep = ""
  )
  cat(
    pad,
    " Power to reject 1 or more: ",
    format(x$power$power_at_least_1, digits = precision),
    "\n",
    sep = ""
  )
  cat(
    pad,
    "       Power to reject all: ",
    format(x$power$power_all, digits = precision),
    "\n",
    sep = ""
  )

  if (!length(x$power$power_success) == 0) {
    cat("\n")

    success_df <- data.frame(
      ` Success measure` = paste0(pad_less_1, names(x$power$power_success)),
      `Power` = format(x$power$power_success, digits = precision),
      check.names = FALSE
    )

    print(success_df, row.names = FALSE)
  }
  cat("\n")

  # Details --------------------------------------------------------------------
  if (!is.null(x$details)) {
    section_break("Simulation details ($details)")

    p_dets <- format(x$details$p_sim, digits = precision)
    colnames(p_dets) <- paste0("p_sim_", hyp_names)
    colnames(p_dets)[[1]] <- paste0(pad_less_1, colnames(p_dets)[[1]])

    test_dets <- x$details$test_results
    colnames(test_dets) <- paste0("rej_", hyp_names)

    max_print_old <- getOption("max.print")
    options(max.print = 99999)

    sim_det_out <- utils::capture.output(
      print(
        utils::head(
          cbind(as.data.frame(p_dets), as.data.frame(test_dets)),
          rows
        ),
        row.names = FALSE
      )
    )
    cat(paste0(pad, sim_det_out), sep = "\n")

    options(max.print = max_print_old)

    if (rows < nrow(p_dets)) {
      cat(pad, "... (Use `print(x, rows = <nn>)` for more)\n\n", sep = "")
    } else {
      cat("\n")
    }
  }

  invisible(x)
}

#' Find alternate rejection orderings (sequences) for shortcut tests
#'
#' @description
#' When multiple hypotheses are rejected by using [graph_test_shortcut()],
#' there may be multiple orderings or sequences in which hypotheses are rejected
#' one by one. The default order in [graph_test_shortcut()] is based on the
#' adjusted p-values, from the smallest to the largest. This function
#' [graph_rejection_orderings()] provides all possible and valid orders
#' (or sequences) of rejections. Although the order of rejection does not affect
#' the final rejection decisions Bretz et al. (2009), different sequences could
#' offer different ways to explain the step-by-step process of shortcut
#' graphical multiple comparison procedures.
#'
#' @param shortcut_test_result A `graph_report` object as returned by
#'   [graph_test_shortcut()].
#'
#' @return A modified `graph_report` object containing all valid orderings of
#'   rejections of hypotheses
#'
#' @seealso
#'   [graph_test_shortcut()] for shortcut graphical multiple comparison
#'   procedures.
#'
#' @rdname graph_rejection_orderings
#'
#' @export
#'
#' @references
#'   Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
#'   approach to sequentially rejective multiple test procedures.
#'   \emph{Statistics in Medicine}, 28(4), 586-604.
#'
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 4 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' delta <- 0.5
#' transitions <- rbind(
#'   c(0, delta, 1 - delta, 0),
#'   c(delta, 0, 0, 1 - delta),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#'
#' p <- c(0.018, 0.01, 0.105, 0.006)
#' alpha <- 0.025
#'
#' shortcut_testing <- graph_test_shortcut(g, p, alpha, verbose = TRUE)
#'
#' # Reject H1, H2, and H4
#' shortcut_testing$outputs$rejected
#'
#' # Default order of rejections: H2, H1, H4
#' shortcut_testing$details$del_seq
#'
#' # There is another valid sequence of rejection: H2, H4, H1
#' graph_rejection_orderings(shortcut_testing)$valid_orderings
#'
#' # Finally, intermediate updated graphs can be obtained by providing the order
#' # of rejections into `[graph_update()]`
#' graph_update(g, delete = c(2, 4, 1))
graph_rejection_orderings <- function(shortcut_test_result) {
  # Extract basic testing values -----------------------------------------------
  graph <- shortcut_test_result$inputs$graph
  p <- shortcut_test_result$inputs$p
  alpha <- shortcut_test_result$inputs$alpha

  hyp_names <- names(graph$hypotheses)

  # Permute rejected hypotheses ------------------------------------------------
  rejected <- which(shortcut_test_result$outputs$rejected)

  list_possible_orderings <- apply(
    rev(expand.grid(rep(list(rejected), length(rejected)))),
    1,
    function(row) {
      if (length(unique(row)) == length(row)) {
        structure(row, names = hyp_names[row])
      } else {
        NULL
      }
    }
  )
  list_possible_orderings <- Filter(Negate(is.null), list_possible_orderings)

  # Find which permutations are valid rejection orderings ----------------------
  orderings_valid <- vector("logical", length(list_possible_orderings))

  for (hyp_ordering_num in seq_along(list_possible_orderings)) {
    hyp_ordering <- list_possible_orderings[[hyp_ordering_num]]
    intermediate_graph <- graph

    for (hyp_num in hyp_ordering) {
      if (p[[hyp_num]] <= intermediate_graph$hypotheses[[hyp_num]] * alpha) {
        intermediate_graph <-
          graph_update(intermediate_graph, hyp_num)$updated_graph
      } else {
        orderings_valid[[hyp_ordering_num]] <- FALSE
        break
      }

      orderings_valid[[hyp_ordering_num]] <- TRUE
    }
  }

  structure(
    c(
      shortcut_test_result,
      list(valid_orderings = list_possible_orderings[orderings_valid])
    ),
    class = "graph_report"
  )
}

#' Perform shortcut (sequentially rejective) graphical multiple comparison
#' procedures
#'
#' @description
#' Shortcut graphical multiple comparison procedures are sequentially rejective
#' procedure based on Bretz et al. (2009). With $m$ hypotheses, there are at
#' most $m$ steps to obtain all rejection decisions. These procedure are
#' equivalent to closed graphical multiple comparison procedures using
#' Bonferroni tests for intersection hypotheses, but shortcut procedures are
#' faster to perform. See `vignette("shortcut-testing")` for more illustration
#' of shortcut procedures and interpretation of their outputs.
#'
#' @inheritParams graph_update
#' @param p A numeric vector of p-values (unadjusted, raw), whose values should
#'   be between 0 & 1. The length should match the number of hypotheses in
#'   `graph`.
#' @param alpha A numeric scalar of the overall significance level, which should
#'   be between 0 & 1. The default is 0.025 for one-sided hypothesis testing
#'   problems; another common choice is 0.05 for two-sided hypothesis testing
#'   problems.
#' @param verbose A logical scalar specifying whether the details of
#'   intermediate update graphs should be included in results. When
#'   `verbose = TRUE`, intermediate update graphs are provided after deleting
#'   each hypothesis, which has been rejected. The default is `verbose = FALSE`.
#' @param test_values A logical scalar specifying whether adjusted significance
#'   levels should be provided for each hypothesis. When `test_values = TRUE`,
#'   it provides an equivalent way of performing graphical multiple comparison
#'   procedures by comparing each p-value with its significance level. If the
#'   p-value of a hypothesis is less than or equal to its significance level,
#'   the hypothesis is rejected. The order of rejection is based on the order
#'   of adjusted p-values from the smallest to the largest. The default is
#'   `test_values = FALSE`.
#'
#' @return An S3 object of class `graph_report` with a list of 4 elements:
#'   * `inputs` - Input parameters, which is a list of:
#'     * `graph` - Initial graph,
#'     *`p` - (Unadjusted or raw) p-values,
#'     * `alpha` - Overall significance level,
#'     * `test_groups` - Groups of hypotheses for different types of tests,
#'     which are the list of all hypotheses for [graph_test_shortcut()],
#'     * `test_types` - Different types of tests, which are "bonferroni" for
#'     [graph_test_shortcut()].
#'   * Output parameters `outputs`, which is a list of:
#'     * `adjusted_p` - Adjusted p-values,
#'     * `rejected` - Rejected hypotheses,
#'     * `graph` - Updated graph after deleting all rejected hypotheses.
#'   * `details` - Verbose outputs with intermediate updated graphs, if
#'   `verbose = TRUE`.
#'   * `test_values` - Adjusted significance levels, if `test_values = TRUE`.
#'
#' @seealso
#'   * [graph_test_closure()] for graphical multiple comparison procedures using
#'   the closed test,
#'   * [graph_rejection_orderings()] for all possible rejection orderings.
#'
#' @rdname graph_test_shortcut
#'
#' @export
#'
#' @references
#'   Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
#'   approach to sequentially rejective multiple test procedures.
#'   \emph{Statistics in Medicine}, 28(4), 586-604.
#'
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 1 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' transitions <- rbind(
#'   c(0, 0, 1, 0),
#'   c(0, 0, 0, 1),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#'
#' p <- c(0.018, 0.01, 0.105, 0.006)
#' alpha <- 0.025
#' graph_test_shortcut(g, p, alpha)
graph_test_shortcut <- function(graph,
                                p,
                                alpha = 0.025,
                                verbose = FALSE,
                                test_values = FALSE) {
  # Input validation -----------------------------------------------------------
  test_input_val(
    graph,
    p,
    alpha,
    test_groups = list(seq_along(graph$hypotheses)),
    test_types = "bonferroni",
    test_corr = list(NA),
    verbose = verbose,
    test_values = test_values
  )

  initial_graph <- graph

  hyp_names <- names(graph$hypotheses)
  num_hyps <- length(graph$hypotheses)

  # Adjusted p-value calculations ----------------------------------------------
  names(p) <- hyp_names
  adjusted_p <- structure(vector("numeric", num_hyps), names = hyp_names)
  adjusted_p_max <- 0

  hyps_deleted_sequence <- vector("integer")

  # Calculate adjusted p-values for all hypotheses by deleting every hypothesis
  # one at a time
  for (i in seq_along(graph$hypotheses)) {
    hyps_not_deleted <- setdiff(hyp_names, hyps_deleted_sequence)

    adjusted_p_subgraph <-
      p[hyps_not_deleted] / graph$hypotheses[hyps_not_deleted]

    # which.min will throw an error if all elements are missing; we want to
    # catch this before which.min does
    if (all(is.nan(adjusted_p_subgraph))) {
      err_msg <- paste0(
        "Calculation of adjusted p-values stops when all remaining\n",
        "    hypotheses have 0 hypothesis weights and 0 p-values\n",
        "  Hypotheses [", paste(hyps_deleted_sequence, collapse = ", "), "]\n",
        "    have been deleted\n",
        paste(
          utils::capture.output(print(
            graph,
            indent = 2,
            precision = 6,
            title = paste0("Step ", i, ", Graph state:")
          )),
          collapse = "\n"
        )
      )

      stop(err_msg)
    }

    # Identify the hypothesis with the smallest adjusted p-value only among
    # hypotheses not deleted so far. Choose the first hypothesis in case of a
    # tie in adjusted p-values.
    min_hyp_name <- names(which.min(adjusted_p_subgraph[hyps_not_deleted]))

    # Record the adjusted p-value for the current hypothesis being considered;
    # that is, the largest adjusted p-value seen so far in the sequence
    adjusted_p_max <- max(adjusted_p_max, adjusted_p_subgraph[[min_hyp_name]])
    adjusted_p[[min_hyp_name]] <- adjusted_p_max

    hyps_deleted_sequence <- c(hyps_deleted_sequence, min_hyp_name)

    # Update graph to delete a hypothesis
    graph <-
      graph_update(graph, hyp_names %in% hyps_deleted_sequence)$updated_graph
  }

  rejected <- round(adjusted_p, 10) <= alpha
  adjusted_p <- pmin(adjusted_p, 1 + 1e-14) # adj p-values should not exceed 1

  # Adjusted p-value details (sequence of graphs) ------------------------------
  if (verbose) {
    # The first n = (number of rejected) hypotheses in the adjusted p sequence
    # are the hypotheses that will be rejected
    rejection_sequence <- hyps_deleted_sequence[seq_along(which(rejected))]

    # The sequence of graphs is the initial graph, plus one entry for each
    # rejected hypothesis
    graph_sequence <- vector("list", length(rejection_sequence) + 1)
    graph_sequence[[1]] <- initial_graph

    if (length(rejection_sequence) > 0) {
      verbose_delete <- rep(FALSE, num_hyps)
      names(verbose_delete) <- hyp_names

      # Starting from the original initial graph, delete each hypothesis with
      # adjusted p-value less than alpha. Record the graph state after each
      # deletion
      for (hyp_num_to_reject in seq_along(rejection_sequence)) {
        hyp_name_to_reject <- rejection_sequence[[hyp_num_to_reject]]
        verbose_delete[[hyp_name_to_reject]] <- TRUE

        # Update a graph to delete a hypothesis. Record the resulting graph
        graph_sequence[[hyp_num_to_reject + 1]] <- graph_update(
          graph_sequence[[hyp_num_to_reject]],
          verbose_delete
        )$updated_graph
      }
    }

    details <- list(del_seq = rejection_sequence, results = graph_sequence)
  }

  # Adjusted weight details ----------------------------------------------------
  if (test_values) {
    # Record the final graph after all rejected hypotheses have been deleted
    graph_after_rejections <-
      graph_update(initial_graph, rejected)$updated_graph

    df_test_values <- NULL

    step_graph <- initial_graph
    step_num <- 1

    # Calculate adjusted weights for all hypotheses. For rejected hypotheses,
    # adjusted weights should come from the last graph they're present in. For
    # non-rejected hypotheses, adjusted weights should be calculated from the
    # graph with all rejected hypotheses deleted.
    for (i in seq_along(hyps_deleted_sequence)) {
      # Follow the same hypothesis order as adjusted p-values
      hyp_name_for_test_values <- hyps_deleted_sequence[[i]]

      # Record adjusted weights
      test_values_step <- test_values_bonferroni(
        p[hyp_name_for_test_values],
        step_graph$hypotheses[hyp_name_for_test_values],
        alpha
      )

      # Normally the first column of `*_test_values()` is an intersection
      # counter. Since shortcut testing doesn't track intersections, re-purpose
      # that column as a step counter. Steps count up one at a time for each
      # hypothesis rejected, then switch to NA for non-rejected hypotheses (i.e.
      # "These rows represent steps that are not taken by the shortcut rejection
      # algorithm")
      names(test_values_step)[[1]] <- "Step"
      test_values_step$Step <- step_num
      test_values_step[c("Test", "c_value")] <- NULL

      df_test_values <- rbind(df_test_values, test_values_step)

      if (rejected[hyp_name_for_test_values]) {
        step_num <- step_num + 1

        step_graph <- graph_update(
          step_graph,
          hyp_names == hyp_name_for_test_values
        )$updated_graph
      } else {
        step_graph <- graph_after_rejections
      }
    }
    rownames(df_test_values) <- NULL
  }

  # Build the report -----------------------------------------------------------
  # The core output of a test report is the adjusted p-values, rejection
  # decisions, and resulting graph after deleting all rejected hypotheses.
  # Inputs are recorded as well. Details about adjusted p-values and test
  # values are optionally available.
  structure(
    list(
      inputs = list(
        graph = initial_graph,
        p = p,
        alpha = alpha,
        test_groups = list(seq_len(num_hyps)),
        test_types = "bonferroni",
        test_corr = NULL
      ),
      outputs = list(
        adjusted_p = adjusted_p,
        rejected = rejected,
        graph = graph_update(initial_graph, rejected)$updated_graph
      ),
      details = if (verbose) details,
      test_values = if (test_values) list(results = df_test_values)
    ),
    class = "graph_report"
  )
}

#' S3 print method for the class `updated_graph`
#'
#' @description
#' A printed `updated_graph` displays the initial graph, the (final) updated
#' graph, and the sequence of intermediate updated graphs after hypotheses are
#' deleted (if available).
#'
#' @param x An object of the class `updated_graph` to print.
#' @param ... Other values passed on to other methods (currently unused).
#' @param precision An integer scalar indicating the number of decimal places
#'   to to display.
#' @param indent An integer scalar indicating how many spaces to indent results.
#'
#' @return An object x of the class `updated_graph`, after printing the updated
#'   graph.
#'
#' @seealso
#'   [print.initial_graph()] for the print method for the initial graph.
#'
#' @rdname print.updated_graph
#'
#' @export
#'
#' @references
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011a). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 1 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' transitions <- rbind(
#'   c(0, 0, 1, 0),
#'   c(0, 0, 0, 1),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#'
#' # Delete the second and third hypotheses in the "unordered mode"
#' graph_update(g, delete = c(FALSE, TRUE, TRUE, FALSE))
#'
#' # Equivalent way in the "ordered mode" to obtain the updated graph after
#' # deleting the second and third hypotheses
#' # Additional intermediate updated graphs are also provided
#' graph_update(g, delete = 2:3)
print.updated_graph <- function(x, ..., precision = 6, indent = 2) {
  # Initial graph and updated graph
  section_break("Initial and final graphs")
  cat("\n")

  print(x$initial_graph, ...)

  cat("\n")

  if (length(x$deleted) == 0) {
    title <- "Updated graph after deleting no hypotheses"
  } else if (length(x$deleted) == 1) {
    title <- paste("Updated graph after deleting hypothesis", x$deleted)
  } else {
    title <- paste(
      "Updated graph after deleting hypotheses",
      paste(x$deleted, collapse = ", ")
    )
  }

  attr(x$updated_graph, "title") <- title

  print(x$updated_graph, ...)

  # Graph sequence
  if (!is.null(x$intermediate_graphs)) {
    graph_seq <- x$intermediate_graphs
    del_seq <- x$deleted

    cat("\n")
    section_break("Deletion sequence ($intermediate_graphs)")
    cat("\n")
    for (i in seq_along(graph_seq) - 1) {
      if (i == 0) {
        print(graph_seq[[i + 1]], precision = precision, indent = indent)
      } else {
        attr(graph_seq[[i + 1]], "title") <- paste0(
          "Step ", i, ": Updated graph after removing ",
          if (i == 1) "hypothesis " else "hypotheses ",
          paste0(del_seq[seq_len(i)], collapse = ", ")
        )

        print(
          graph_seq[[i + 1]],
          precision = precision,
          indent = indent * (i + 1)
        )
      }
      cat("\n")
    }

    attr(graph_seq[[length(graph_seq)]], "title") <-
      "Final updated graph after removing deleted hypotheses"

    print(
      graph_seq[[length(graph_seq)]],
      precision = precision,
      indent = indent
    )
    cat("\n")
  }

  invisible(x)
}

#' Alpha spending functions for group sequential designs
#'
#' @description
#' Alpha spending functions determine how the total significance level (alpha)
#' is allocated across interim and final analyses in a group sequential design.
#' Given the total alpha and the information fraction(s) at one or more
#' analyses, a spending function returns the cumulative alpha spent at each
#' information fraction.
#'
#' Four commonly used spending functions are provided:
#' * [spending_of()] for the Lan-DeMets O'Brien-Fleming approximation,
#' * [spending_pocock()] for the Lan-DeMets Pocock approximation,
#' * [spending_hsd()] for the Hwang-Shih-DeCani family,
#' * [spending_linear()] for linear (uniform) spending.
#'
#' @param alpha A numeric scalar of the total significance level to be spent.
#'   Must be between 0 and 1.
#' @param info_frac A numeric scalar or vector of information fractions. Values
#'   must be non-negative. When `info_frac = 0`, the spending is 0. When
#'   `info_frac >= 1`, the spending is capped at `alpha`.
#' @param gamma A numeric scalar for the gamma parameter of the
#'   Hwang-Shih-DeCani spending function. Common choices are `gamma = -4`
#'   (approximates O'Brien-Fleming), `gamma = 1` (approximates Pocock), and
#'   `gamma = 0` (linear spending). The default is `gamma = -4`.
#'
#' @return A numeric vector the same length as `info_frac` of cumulative alpha
#'   spent at each information fraction.
#'
#' @details
#' All spending functions satisfy the following properties:
#' * \eqn{f(\alpha, 0) = 0},
#' * \eqn{f(\alpha, 1) = \alpha},
#' * \eqn{f(\alpha, t)} is non-decreasing in \eqn{t}.
#'
#' The cumulative alpha spent at analysis \eqn{k} is \eqn{f(\alpha, t_k)},
#' and the incremental spending is
#' \deqn{\Delta\alpha_k = f(\alpha, t_k) - f(\alpha, t_{k-1}).}
#'
#' Note that the incremental spending is \emph{not} the nominal significance
#' level (boundary) at analysis \eqn{k}. The boundary must be derived from the
#' spending using the joint distribution of test statistics across analyses.
#' See [sequential_p()] and [graph_test_shortcut_gsd()] for details.
#'
#' @section Spending function formulas:
#' * **O'Brien-Fleming** (`spending_of`):
#'   \deqn{f(\alpha, t) = 2\left(1 - \Phi\left(\frac{\Phi^{-1}(1 - \alpha/2)}
#'   {\sqrt{t}}\right)\right).}
#'   This is the Lan-DeMets approximation to O'Brien-Fleming boundaries.
#'   It is very conservative at early analyses and spends most of the alpha
#'   at the final analysis.
#'
#' * **Pocock** (`spending_pocock`):
#'   \deqn{f(\alpha, t) = \alpha \cdot \ln(1 + (e - 1) \cdot t).}
#'   This spends alpha more evenly across analyses compared to O'Brien-Fleming.
#'
#' * **Hwang-Shih-DeCani** (`spending_hsd`):
#'   \deqn{f(\alpha, t) = \alpha \cdot \frac{1 - e^{-\gamma t}}{1 -
#'   e^{-\gamma}}, \quad \gamma \neq 0,}
#'   \deqn{f(\alpha, t) = \alpha \cdot t, \quad \gamma = 0.}
#'   With `gamma = -4`, it approximates O'Brien-Fleming; with `gamma = 1`,
#'   it approximates Pocock.
#'
#' * **Linear** (`spending_linear`):
#'   \deqn{f(\alpha, t) = \alpha \cdot t.}
#'
#' @references
#'   Lan, K. K. G., and DeMets, D. L. (1983). Discrete sequential boundaries
#'   for clinical trials. \emph{Biometrika}, 70(3), 659-663.
#'
#'   Hwang, I. K., Shih, W. J., and De Cani, J. S. (1990). Group sequential
#'   designs using a family of type I error probability spending functions.
#'   \emph{Statistics in Medicine}, 9(12), 1439-1445.
#'
#' @rdname spending_functions
#'
#' @export
#'
#' @examples
#' # O'Brien-Fleming spending at 50% information
#' spending_of(0.025, 0.5)
#'
#' # Cumulative spending across analyses (vectorized)
#' spending_of(0.025, c(0, 0.5, 1))
#'
#' # Compare spending functions at information fractions (1/3, 2/3, 1)
#' spending_of(0.025, c(1 / 3, 2 / 3, 1))
#' spending_pocock(0.025, c(1 / 3, 2 / 3, 1))
#' spending_hsd(0.025, c(1 / 3, 2 / 3, 1), gamma = -4)
#' spending_linear(0.025, c(1 / 3, 2 / 3, 1))
#'
#' # User-defined spending function: piecewise combination.
#' # Use O'Brien-Fleming for the first half of alpha (conservative at
#' # early analyses), and Pocock for the second half (more aggressive).
#' # This can be useful when a hypothesis starts with a small weight
#' # (OBF spending) and later receives additional weight via graph
#' # propagation (Pocock spending for the increment).
#' spending_piecewise <- function(alpha, info_frac, threshold = 0.0125) {
#'   spending_of(pmin(alpha, threshold), info_frac) +
#'     spending_pocock(pmax(alpha - threshold, 0), info_frac)
#' }
#' spending_piecewise(0.025, c(1 / 3, 2 / 3, 1))
#' # Compare: alpha = 0.0125 uses only OBF
#' spending_piecewise(0.0125, c(1 / 3, 2 / 3, 1))
#' spending_of(0.0125, c(1 / 3, 2 / 3, 1))
spending_of <- function(alpha, info_frac) {
  stopifnot(
    "info_frac must be non-negative" = all(info_frac >= 0),
    "At most one info_frac value can be >= 1" = sum(info_frac >= 1) <= 1
  )
  result <- 2 * (1 - stats::pnorm(stats::qnorm(1 - alpha / 2) / sqrt(info_frac)))
  result[info_frac == 0] <- 0
  result <- pmin(result, alpha)
  result
}

#' @rdname spending_functions
#' @export
#' @examples
#' # Pocock spending at 50% information
#' spending_pocock(0.025, 0.5)
spending_pocock <- function(alpha, info_frac) {
  stopifnot(
    "info_frac must be non-negative" = all(info_frac >= 0),
    "At most one info_frac value can be >= 1" = sum(info_frac >= 1) <= 1
  )
  result <- alpha * log(1 + (exp(1) - 1) * info_frac)
  result[info_frac == 0] <- 0
  result <- pmin(result, alpha)
  result
}

#' @rdname spending_functions
#' @export
#' @examples
#' # Hwang-Shih-DeCani spending at 50% information
#' spending_hsd(0.025, 0.5, gamma = -4)
#' spending_hsd(0.025, 0.5, gamma = 1)
#' spending_hsd(0.025, 0.5, gamma = 0)
spending_hsd <- function(alpha, info_frac, gamma = -4) {
  stopifnot(
    "info_frac must be non-negative" = all(info_frac >= 0),
    "At most one info_frac value can be >= 1" = sum(info_frac >= 1) <= 1
  )
  if (gamma == 0) {
    result <- alpha * info_frac
  } else {
    result <- alpha * (1 - exp(-gamma * info_frac)) / (1 - exp(-gamma))
  }
  result[info_frac == 0] <- 0
  result <- pmin(result, alpha)
  result
}

#' @rdname spending_functions
#' @export
#' @examples
#' # Linear spending at 50% information
#' spending_linear(0.025, 0.5)
spending_linear <- function(alpha, info_frac) {
  stopifnot(
    "info_frac must be non-negative" = all(info_frac >= 0),
    "At most one info_frac value can be >= 1" = sum(info_frac >= 1) <= 1
  )
  pmin(alpha * info_frac, alpha)
}


#' Create a spending function with a custom spending time
#'
#' @description
#' Wraps an existing spending function to use a fixed **spending time** instead
#' of the information fractions passed to it at runtime. This controls only
#' the alpha allocation schedule. The correlation structure of the test
#' statistics is determined separately by the `info_frac` argument in
#' [graph_test_shortcut_gsd()] (via [gs_corr()]), not by the spending
#' function.
#'
#' This is useful in two common scenarios:
#' * **Subgroup analyses**: all-subjects hypotheses use subgroup event
#'   fractions as spending time (controlling how alpha is allocated across
#'   analyses), while `info_frac` in [graph_test_shortcut_gsd()] uses
#'   all-subjects event fractions (controlling the correlation structure).
#' * **Monitoring with changed final information**: when the actual total
#'   information at the final analysis differs from the planned total, the
#'   planned information fractions are used as spending time to preserve
#'   the alpha allocation at earlier analyses, while `info_frac` in
#'   [graph_test_shortcut_gsd()] uses the actual information fractions
#'   for the correlation structure.
#'
#' @param spending_fn A spending function to wrap. Must accept two arguments:
#'   `alpha` (significance level) and `info_frac` (information fraction), and
#'   return the cumulative alpha spent.
#' @param spending_time A numeric vector of spending time values. These replace
#'   the `info_frac` argument when the wrapped function is called. May contain
#'   `NA` for analyses that are skipped (e.g., a hypothesis not tested at a
#'   particular analysis). The last non-`NA` value should be 1 if the final
#'   analysis has been specified.
#' @param info_frac An optional numeric vector of information fractions with
#'   the same length as `spending_time`. If provided, the `NA` positions are
#'   validated to match those in `spending_time`. This ensures that the
#'   spending time and information fraction structures are consistent.
#'
#' @return A function with the same signature as `spending_fn` —
#'   `function(alpha, info_frac)` — that internally uses `spending_time`
#'   instead of `info_frac` for alpha allocation.
#'
#' @seealso [spending_of()], [spending_pocock()], [spending_hsd()],
#'   [spending_linear()] for built-in spending functions,
#'   [graph_test_shortcut_gsd()] for the graphical procedure with group
#'   sequential designs.
#'
#' @export
#'
#' @examples
#' # --- Subgroup spending time ---
#' # Without spending_with_time, spending_of() uses info_frac for spending:
#' info_frac_all <- c(529 / 800, 700 / 800, 1) # all-subjects fractions
#' spending_of(0.01, info_frac_all)
#'
#' # With spending_with_time, spending uses subgroup fractions instead.
#' # The info_frac passed at runtime is ignored by the spending function;
#' # it is only used by gs_boundaries()/graph_test_shortcut_gsd() for
#' # the correlation structure.
#' spending_time_sub <- c(185 / 295, 245 / 295, 1) # subgroup fractions
#' spending_with_time(spending_of, spending_time_sub)
#'
#' # --- Monitoring with changed final information ---
#' # Planned: 295 OS events at 3 analyses (185, 245, 295 events).
#' # spending_time uses planned fractions for interim analyses and 1
#' # for the final analysis.
#' spending_monitor <- spending_with_time(
#'   spending_of,
#'   spending_time = c(185 / 295, 245 / 295, 1)
#' )
#'
#' # Overrunning (310 events) or underrunning (280 events):
#' # spending_time is the same in both cases — it uses planned fractions
#' # for interim analyses and 1 for the final analysis, because alpha
#' # spent has been fixed for interim analyses. The actual info_frac
#' # (which differs between overrunning and underrunning) only affects
#' # the correlation structure in gs_boundaries()/graph_test_shortcut_gsd().
#' spending_monitor(0.01, c(185 / 295, 245 / 295, 1))
#'
#' # --- Skipped analyses (NA in spending_time) ---
#' # If a hypothesis is not tested at analysis 2, both spending_time and
#' # info_frac have NA at that position. The output also has NA there.
#' spending_skip <- spending_with_time(
#'   spending_of,
#'   spending_time = c(185 / 295, NA, 1),
#'   info_frac = c(185 / 295, NA, 1)
#' )
#' spending_skip(0.01, c(185 / 295, NA, 1))
spending_with_time <- function(spending_fn, spending_time, info_frac = NULL) {
  stopifnot(
    "spending_fn must be a function" = is.function(spending_fn),
    "spending_time must be a numeric vector" = is.numeric(spending_time)
  )

  # Validate non-NA spending_time values
  st_non_na <- spending_time[!is.na(spending_time)]
  stopifnot(
    "Non-NA spending_time values must be non-negative" =
      length(st_non_na) == 0 || all(st_non_na >= 0),
    "At most one non-NA spending_time value can be >= 1" =
      sum(st_non_na >= 1) <= 1
  )

  # If info_frac provided, validate NA positions match
  if (!is.null(info_frac)) {
    stopifnot(
      "spending_time and info_frac must have the same length" =
        length(spending_time) == length(info_frac),
      "NA positions in spending_time and info_frac must match" =
        identical(is.na(spending_time), is.na(info_frac))
    )
  }

  function(alpha, info_frac_runtime) {
    non_na <- !is.na(info_frac_runtime)
    n_non_na <- sum(non_na)

    # Use the first n_non_na entries of the non-NA spending_time
    st <- st_non_na[seq_len(n_non_na)]

    # Compute spending for non-NA entries
    spent <- spending_fn(alpha, st)

    # Build result with NAs in the same positions as info_frac_runtime
    result <- rep(NA_real_, length(info_frac_runtime))
    result[non_na] <- spent
    result
  }
}


#' Wang-Tsiatis spending function
#'
#' @description
#' Computes the implied cumulative alpha spending from the Wang-Tsiatis family
#' of group sequential boundaries. The Wang-Tsiatis boundaries at analysis
#' \eqn{k} with information fraction \eqn{t_k} are defined as:
#' \deqn{c_k = C \cdot t_k^{\Delta - 0.5},}
#' where \eqn{\Delta} is the shape parameter and \eqn{C} is a constant
#' calibrated so that the overall Type I error equals \eqn{\alpha}.
#'
#' Special cases:
#' * \eqn{\Delta = 0.5}: Pocock boundaries (equal Z-scale boundaries across
#'   analyses).
#' * \eqn{\Delta = 0}: O'Brien-Fleming boundaries (very conservative at
#'   early analyses).
#' * \eqn{0 < \Delta < 0.5}: intermediate between O'Brien-Fleming and Pocock.
#'
#' Unlike the Lan-DeMets approximations ([spending_of()], [spending_pocock()]),
#' this function computes the **exact** boundaries from the Wang-Tsiatis
#' family and derives the implied spending. It is computationally more
#' expensive because it requires root-finding and multivariate normal
#' integration at each call.
#'
#' @param alpha A numeric scalar of the total significance level.
#' @param info_frac A numeric vector of information fractions at each analysis.
#'   Must be non-negative, with at most one value \eqn{\geq 1}. The last
#'   value must be \eqn{\geq 1} (i.e., the final analysis must be included),
#'   because the Wang-Tsiatis constant \eqn{C} is calibrated over the full
#'   set of analyses.
#' @param delta A numeric scalar for the shape parameter \eqn{\Delta}.
#'   The default is `0.5` (Pocock). Use `0` for O'Brien-Fleming.
#' @param maxpts An integer scalar for the maximum number of function values
#'   for [mvtnorm::GenzBretz()]. The default is 25000.
#' @param abseps A numeric scalar for the absolute error tolerance for
#'   [mvtnorm::GenzBretz()]. The default is 1e-6.
#'
#' @return A numeric vector the same length as `info_frac` of cumulative alpha
#'   spent at each information fraction.
#'
#' @seealso [spending_of()] and [spending_pocock()] for the Lan-DeMets
#'   approximations, [gs_boundaries()] for computing boundaries from spending
#'   functions, [graph_test_shortcut_gsd()] for the graphical procedure.
#'
#' @references
#'   Wang, S. K., and Tsiatis, A. A. (1987). Approximately optimal one-parameter
#'   boundaries for group sequential trials. \emph{Biometrics}, 43(1), 193-199.
#'
#' @export
#'
#' @examples
#' # Exact O'Brien-Fleming (delta = 0)
#' spending_wt(0.025, c(0.5, 1), delta = 0)
#'
#' # Exact Pocock (delta = 0.5)
#' spending_wt(0.025, c(0.5, 1), delta = 0.5)
#'
#' # Intermediate (delta = 0.25)
#' spending_wt(0.025, c(1 / 3, 2 / 3, 1), delta = 0.25)
#'
#' # Compare with Lan-DeMets approximations
#' spending_of(0.025, c(1 / 3, 2 / 3, 1)) # Lan-DeMets OBF approximation
#' spending_wt(0.025, c(1 / 3, 2 / 3, 1), 0) # Exact OBF
#'
#' # Use in graph_test_shortcut_gsd (wrap to fix delta)
#' \donttest{
#' g <- graph_create(c(0.5, 0.5), rbind(c(0, 1), c(1, 0)))
#' p <- rbind(H1 = c(0.024, 0.01), H2 = c(0.015, 0.005))
#' graph_test_shortcut_gsd(
#'   graph = g, p = p, alpha = 0.025,
#'   info_frac = c(0.5, 1),
#'   spending_fn = function(a, t) spending_wt(a, t, delta = 0.25)
#' )
#' }
spending_wt <- function(alpha, info_frac, delta = 0.5,
                        maxpts = 25000, abseps = 1e-6) {
  stopifnot(
    "info_frac must be non-negative" = all(info_frac >= 0),
    "At most one info_frac value can be >= 1" = sum(info_frac >= 1) <= 1,
    "The last info_frac value must be >= 1 for spending_wt" =
      length(info_frac) > 0 && info_frac[length(info_frac)] >= 1,
    "delta must be a numeric scalar" = is.numeric(delta) && length(delta) == 1
  )

  K <- length(info_frac)

  # Handle edge cases
  if (alpha <= 0) {
    return(rep(0, K))
  }
  if (K == 1) {
    return(pmin(alpha, alpha))
  }

  # Correlation matrix
  corr <- gs_corr(info_frac)

  # Wang-Tsiatis boundary shape: c_k = C * t_k^(delta - 0.5)
  # For info_frac = 0, the shape is Inf (or 0 depending on delta),
  # handle by setting those boundaries to Inf (never cross)
  shape <- ifelse(info_frac == 0, 0, info_frac^(delta - 0.5))

  algo <- mvtnorm::GenzBretz(maxpts = maxpts, abseps = abseps)

  # Find C such that P(cross at some k | H0) = alpha
  # P(cross) = 1 - P(Z_1 < c_1, ..., Z_K < c_K)
  find_C <- function(C_val) {
    bounds_z <- C_val * shape
    # Replace any Inf or very large bounds with 20 for numerical stability
    bounds_z <- pmin(bounds_z, 20)

    prob_no_cross <- mvtnorm::pmvnorm(
      upper = bounds_z,
      corr = corr,
      algorithm = algo
    )[[1]]

    (1 - prob_no_cross) - alpha
  }

  # Search for C. Boundaries are on the Z-scale, so C is typically 1-5
  C_root <- tryCatch(
    stats::uniroot(find_C, interval = c(0.1, 20), tol = abseps),
    error = function(e) {
      # Widen search if needed
      stats::uniroot(find_C, interval = c(0.01, 50), tol = abseps)
    }
  )
  C_val <- C_root$root
  bounds_z <- C_val * shape
  bounds_z <- pmin(bounds_z, 20)

  # Compute implied cumulative spending at each analysis k:
  # alpha_k = P(Z_1 >= c_1 or ... or Z_k >= c_k)
  #         = 1 - P(Z_1 < c_1, ..., Z_k < c_k)
  cum_spending <- numeric(K)
  for (k in seq_len(K)) {
    if (info_frac[k] == 0) {
      cum_spending[k] <- 0
      next
    }
    if (k == 1) {
      # Univariate case: P(Z >= c_1) = 1 - Phi(c_1)
      cum_spending[k] <- stats::pnorm(bounds_z[1], lower.tail = FALSE)
    } else {
      cum_spending[k] <- 1 - mvtnorm::pmvnorm(
        upper = bounds_z[seq_len(k)],
        corr = corr[seq_len(k), seq_len(k)],
        algorithm = algo
      )[[1]]
    }
  }

  # Cap at alpha for numerical stability
  cum_spending <- pmin(cum_spending, alpha)
  cum_spending
}

#' Perform graphical multiple comparison procedures efficiently for power
#' calculation
#'
#' @description
#' These functions performs similarly to [graph_test_closure()] or
#' [graph_test_shortcut()] but are optimized for efficiently calculating power.
#' For example, generating weights and calculating adjusted weights can be done
#' only once. Vectorization has been applied where possible.
#'
#' @param p A numeric vector of one-sided p-values (unadjusted, raw), whose
#'   values should be between 0 & 1. The length should match the number of
#'   hypotheses in `graph`.
#' @param alpha A numeric value of the one-sided overall significance level,
#'   which should be between 0 & 1. The default is 0.025 for one-sided
#'   hypothesis testing. Note that only one-sided tests are supported.
#' @param adjusted_weights The adjusted hypothesis weights, which are the
#'   second half of columns from [graph_generate_weights()] output, adjusted by
#'   the appropriate test types (Bonferroni, Simes, or parametric).
#' @param matrix_intersections A matrix of hypothesis indicators in a weighting
#'   strategy, which are the first half the [graph_generate_weights()] output.
#'
#' @return A logical or integer vector indicating whether each hypothesis can
#'   be rejected or not.
#'
#' @seealso
#'   * [graph_test_closure()] for closed graphical multiple comparison
#'   procedures.
#'   * [graph_test_shortcut()] for shortcut graphical multiple comparison
#'   procedures.
#'
#' @rdname graph_test_fast
#'
#' @keywords internal
#'
graph_test_closure_fast <- function(p,
                                    alpha,
                                    adjusted_weights,
                                    matrix_intersections) {
  rej_hyps <- t(p <= alpha * t(adjusted_weights))

  # "+ 0" converts to integer from logical
  matrixStats::colSums2(
    matrix_intersections * matrixStats::rowMaxs(rej_hyps + 0)
  ) == 2^(ncol(adjusted_weights) - 1)
}

#' @rdname graph_test_fast
#' @keywords internal
graph_test_shortcut_fast <- function(p, alpha, adjusted_weights) {
  num_hyps <- ncol(adjusted_weights)
  # There is a mapping from current rejected hypotheses to corresponding row of
  # the closure weights matrix by treating the rejected vector as a binary
  # number. This line creates a vector of binary place values.
  binary_slots <- 2^(num_hyps:1 - 1)
  nrow_critical <- nrow(adjusted_weights)

  rejected <- vector("logical", num_hyps)

  while (!all(rejected)) {
    # The actual mapping to intersection number is to treat the rejected vector
    # as a binary number, then count that many lines up from the bottom of the
    # weights matrix, then go down one line
    intersection_num <-
      nrow_critical - sum(binary_slots * !rejected) + 1
    rejected_step <-
      p <= adjusted_weights[intersection_num, , drop = TRUE] * alpha

    if (!any(rejected_step)) {
      break
    } else {
      rejected <- rejected | rejected_step
    }
  }

  rejected
}

#' S3 print method for the class `initial_graph`
#'
#' @description
#' A printed `initial_graph` displays a header stating "Initial graph",
#' hypothesis weights, and transition weights.
#'
#' @param x An object of class `initial_graph` to print.
#' @param ... Other values passed on to other methods (currently unused).
#' @param precision An integer scalar indicating the number of decimal places
#'   to to display.
#' @param indent An integer scalar indicating how many spaces to indent results.
#'
#' @return An object x of class `initial_graph`, after printing the initial
#'   graph.
#'
#' @seealso
#'   [print.updated_graph()] for the print method for the updated graph after
#'   hypotheses being deleted from the initial graph.
#'
#' @rdname print.initial_graph
#'
#' @export
#'
#' @references
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 1 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' transitions <- rbind(
#'   c(0, 0, 1, 0),
#'   c(0, 0, 0, 1),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' hyp_names <- c("H11", "H12", "H21", "H22")
#' g <- graph_create(hypotheses, transitions, hyp_names)
#' g
print.initial_graph <- function(x,
                                ...,
                                precision = 4,
                                indent = 0) {
  x$hypotheses[attr(x, "deleted")] <-
    x$transitions[attr(x, "deleted"), ] <-
    x$transitions[, attr(x, "deleted")] <-
    NA

  if (is.null(attr(x, "title"))) attr(x, "title") <- "Initial graph"

  pad <- paste(rep(" ", indent), collapse = "")
  pad_less_1 <- paste(rep(" ", max(indent - 1, 0)), collapse = "")

  cat(paste0(pad, attr(x, "title"), "\n\n"))

  cat(paste0(pad, "--- Hypothesis weights ---\n"))

  hypotheses_text <- paste(
    pad,
    formatC(
      names(x$hypotheses),
      width = max(nchar(names(x$hypotheses)))
    ),
    ": ",
    format(x$hypotheses, digits = precision),
    sep = "",
    collapse = "\n"
  )

  cat(hypotheses_text, "", sep = "\n")

  cat(paste0(pad, "--- Transition weights ---\n"))

  transitions <- format(
    x$transitions,
    digits = precision,
    scientific = FALSE
  )

  colname_pad <- format("", width = max(nchar(rownames(transitions))))
  label <- paste0(pad_less_1, colname_pad)
  df_trn <- data.frame(
    paste0(pad_less_1, rownames(transitions)),
    transitions,
    check.names = FALSE
  )
  names(df_trn)[[1]] <- label

  transitions_text <- data.frame(df_trn, check.names = FALSE)

  print(transitions_text, row.names = FALSE)

  invisible(x)
}

#' Convert between graphicalMCP, gMCP, and igraph graph classes
#'
#' @description
#' Graph objects have different structures and attributes in
#' `graphicalMCP`, `gMCP`, and `igraph` R packages. These functions convert
#' between different classes to increase compatibility.
#'
#' Note that `igraph` and `gMCP` have additional attributes for vertices, edges,
#' or a graph itself. These conversion functions only handle attributes related
#' to hypothesis names, hypothesis weights and transition weights. Other
#' attributes will be dropped when converting.
#'
#' @param graph An `initial_graph` object from the `graphicalMCP` package, a
#'   `graphMCP` object from the `gMCP` package, or an `igraph` object from the
#'   `igraph` package, depending on the conversion type.
#'
#' @return
#'   * `as_graphMCP()` returns a `graphMCP` object for the `gMCP` package.
#'   * `as_igraph()` returns an `igraph` object for the `igraph` package.
#'   * `as_initial_graph()` returns an `initial_graph` object for the
#' `graphicalMCP` package.
#'
#' @seealso [graph_create()] for the initial graph used in the `graphicalMCP`
#' package.
#'
#' @rdname as_graph
#'
#' @export
#'
#' @references Csardi, G., Nepusz, T., Traag, V., Horvat, S., Zanini, F., Noom,
#' D., and Mueller, K. (2024). \emph{igraph}: Network analysis and visualization
#' in R. R package version 2.0.3.
#' \url{https://CRAN.R-project.org/package=igraph}.
#'
#' Rohmeyer, K., and Klinglmueller, K. (2024). \emph{gMCP}: Graph based multiple
#' test procedures. R package version 0.8-17.
#' \url{https://cran.r-project.org/package=gMCP}.
#'
#' @examples
#' g_graphicalMCP <- random_graph(5)
#'
#' if (requireNamespace("gMCP", quietly = TRUE)) {
#'   g_gMCP <- as_graphMCP(g_graphicalMCP)
#'
#'   all.equal(g_graphicalMCP, as_initial_graph(g_gMCP))
#' }
#'
#' if (requireNamespace("igraph", quietly = TRUE)) {
#'   g_igraph <- as_igraph(g_graphicalMCP)
#'
#'   all.equal(g_graphicalMCP, as_initial_graph(g_igraph))
#' }
as_initial_graph <- function(graph) {
  UseMethod("as_initial_graph", graph)
}

#' @rdname as_graph
#' @export
as_initial_graph.graphMCP <- function(graph) {
  graph_create(graph@weights, graph@m)
}

#' @rdname as_graph
#' @export
as_initial_graph.igraph <- function(graph) {
  hypotheses <- igraph::vertex_attr(graph, "weight")
  names(hypotheses) <- igraph::vertex_attr(graph, "name")

  transitions <- matrix(0, length(hypotheses), length(hypotheses))
  dimnames(transitions) <- rep(list(names(hypotheses)), 2)

  for (tail in seq_along(hypotheses)) {
    transitions[tail, ] <- graph[tail]
  }

  graph_create(hypotheses, transitions)
}

#' @rdname as_graph
#' @export
as_graphMCP <- function(graph) {
  UseMethod("as_graphMCP", graph)
}

#' @rdname as_graph
#' @export
as_graphMCP.initial_graph <- function(graph) {
  if (!requireNamespace("gMCP", quietly = TRUE)) {
    stop("Please install.packages('gMCP') before converting to a gMCP graph")
  } else {
    gMCP::matrix2graph(graph$transitions, graph$hypotheses)
  }
}

#' @rdname as_graph
#' @export
as_igraph <- function(graph) {
  UseMethod("as_igraph", graph)
}

#' @rdname as_graph
#' @export
as_igraph.initial_graph <- function(graph) {
  if (!requireNamespace("igraph", quietly = TRUE)) {
    stop("Please install.packages('igraph') before converting to an igraph")
  } else {
    num_hyps <- length(graph$hypotheses)
    hyp_names <- names(graph$hypotheses)

    empty_igraph <- igraph::make_empty_graph()

    vertex_igraph <- igraph::add_vertices(
      empty_igraph,
      num_hyps,
      name = hyp_names,
      weight = graph$hypotheses
    )

    matrix_edge_tails <- matrix(rep(hyp_names, num_hyps), nrow = num_hyps)
    matrix_edge_heads <-
      matrix(rep(hyp_names, num_hyps), nrow = num_hyps, byrow = TRUE)

    edge_tails <- matrix_edge_tails[graph$transitions != 0]
    edge_heads <- matrix_edge_heads[graph$transitions != 0]

    vector_edges <- as.vector(rbind(edge_tails, edge_heads))

    complete_igraph <- igraph::add_edges(
      vertex_igraph,
      vector_edges,
      weight = graph$transitions[graph$transitions != 0]
    )

    complete_igraph
  }
}

#' S3 plot method for class `initial_graph`
#'
#' @description The plot of an `initial_graph` translates the `hypotheses` into
#' vertices and `transitions` into edges to create a network plot. Vertices are
#' labeled with hypothesis names and hypothesis weights, and edges are labeled
#' with transition weights. See `vignette("graph-examples")` for more
#' illustration of commonly used multiple comparison procedure using graphs.
#'
#' @param x An object of class `initial_graph` to plot.
#' @param ... Other arguments passed on to `igraph::plot.igraph()`.
#' @param v_palette A character vector of length two specifying the colors for
#'   retained and deleted hypotheses. More extensive color customization must be
#'   done with `vertex.color`.
#' @param layout An igraph layout specification (See `?igraph.plotting`), or
#'   `"grid"`, which lays out hypotheses left-to-right and top-to-bottom. `nrow`
#'   and `ncol` control the grid shape.
#' @param nrow An integer scalar specifying the number of rows in the vertex
#'   grid. If row and column counts are not specified, vertices will be laid out
#'   as close to a square as possible.
#' @param ncol An integer scalar specifying the number of columns in the vertex
#'   grid. If row and column counts are not specified, vertices will be laid out
#'   as close to a square as possible.
#' @param edge_curves A named numeric vector specifying the curvature of
#'   specific edges. Edge pairs (Where two vertices share an edge in each
#'   possible direction) are detected automatically and get 0.25 curvature.
#'   Adjust edges by adding an entry with name `"vertex1|vertex2`, and adjust
#'   default edge pairs curvature by adding an entry with name `"pairs"` -
#'   `edge_curves = c("pairs" = 0.5, "H1|H3" = 0.25, "H3|H4" = 0.75)`.
#' @param precision An integer scalar indicating the number of decimal places to
#'   display.
#' @param eps A numeric scalar. The transition weight of `eps` will be displayed
#'   as \eqn{\epsilon}, which indicates edges with infinitesimally small
#'   weights. See Bretz et al. (2009) for more details.
#' @param background_color A character scalar specifying a background color for
#'   the whole plotting area. Passed directly to [graphics::par()] (`bg`).
#' @param margins A length 4 numeric vector specifying the margins for the plot.
#'   Defaults to all 1, since igraph plots tend to have large margins. It is
#'   passed directly to [graphics::par()] (`mar`).
#'
#' @return An object x of class `initial_graph`, after plotting the initial
#'   graph.
#'
#' @section Customization of graphs: There are a few values for
#'   [igraph::plot.igraph()] that get their defaults changed for graphicalMCP.
#'   These values can still be changed by passing them as arguments to
#'   `plot.initial_graph()`. Here are the new defaults:
#'   * `vertex.color = "#6baed6"`,
#'   * `vertex.label.color = "black"`,
#'   * `vertex.size = 20`,
#'   * `edge.arrow.size = 1`,
#'   * `edge.arrow.width = 1`,
#'   * `edge.label.color = "black"`
#'   * `asp = 0`.
#'
#'   Neither `graphicalMCP` nor `igraph` does anything about overlapping edge
#'   labels. If you run into this problem, and vertices can't practically be
#'   moved enough to avoid collisions of edge labels, using edge curves can
#'   help. `igraph` puts edge labels closer to the tail of an edge when an edge
#'   is straight, and closer to the head of an edge when it's curved. By setting
#'   an edge's curve to some very small value, an effectively straight edge can
#'   be shifted to a new position.
#'
#' @seealso [plot.updated_graph()] for the plot method for the updated graph
#' after hypotheses being deleted from the initial graph.
#'
#' @rdname plot.initial_graph
#'
#' @export
#'
#' @references Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W.,
#' and Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#' procedures using weighted Bonferroni, Simes, or parametric tests.
#' \emph{Biometrical Journal}, 53(6), 894-913.
#'
#' Xi, D., and Bretz, F. (2019). Symmetric graphs for equally weighted tests,
#' with application to the Hochberg procedure. \emph{Statistics in Medicine},
#' 38(27), 5268-5282.
#'
#' @examplesIf requireNamespace("igraph", quietly = TRUE)
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 4 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' delta <- 0.5
#' transitions <- rbind(
#'   c(0, delta, 1 - delta, 0),
#'   c(delta, 0, 0, 1 - delta),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#' plot(g)
#'
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and four secondary hypotheses (H31, H32, H41, and H42)
#' # See Figure 6 in Xi and Bretz (2019).
#' hypotheses <- c(0.5, 0.5, 0, 0, 0, 0)
#' epsilon <- 1e-5
#' transitions <- rbind(
#'   c(0, 0.5, 0.25, 0, 0.25, 0),
#'   c(0.5, 0, 0, 0.25, 0, 0.25),
#'   c(0, 0, 0, 0, 1, 0),
#'   c(epsilon, 0, 0, 0, 0, 1 - epsilon),
#'   c(0, epsilon, 1 - epsilon, 0, 0, 0),
#'   c(0, 0, 0, 1, 0, 0)
#' )
#' hyp_names <- c("H1", "H2", "H31", "H32", "H41", "H42")
#' g <- graph_create(hypotheses, transitions, hyp_names)
#'
#' plot_layout <- rbind(
#'   c(0.15, 0.5),
#'   c(0.65, 0.5),
#'   c(0, 0),
#'   c(0.5, 0),
#'   c(0.3, 0),
#'   c(0.8, 0)
#' )
#'
#' plot(g, layout = plot_layout, eps = epsilon, edge_curves = c(pairs = .5))
plot.initial_graph <- function(x,
                               ...,
                               v_palette = c("#6baed6", "#cccccc"),
                               layout = "grid",
                               nrow = NULL,
                               ncol = NULL,
                               edge_curves = NULL,
                               precision = 4,
                               eps = NULL,
                               background_color = "white",
                               margins = c(1, 1, 1, 1)) {
  oldpar <- graphics::par("bg", "mar")
  on.exit(suppressWarnings(graphics::par(oldpar)))

  if (length(v_palette) != 2) {
    stop("Choose 2 palette colors or use `vertex.color` for more customization")
  }

  graph_size <- length(x$hypotheses)
  graph_seq <- seq_along(x$hypotheses)

  graph_igraph <- as_igraph(x)

  v_attr <- igraph::vertex_attr(graph_igraph)
  e_attr <- igraph::edge_attr(graph_igraph)

  # Vertex colors --------------------------------------------------------------
  v_color <- rep(v_palette[[1]], length(x$hypotheses))
  v_color[attr(x, "deleted")] <- v_palette[[2]]

  # Make labels ----------------------------------------------------------------
  v_labels <- paste(v_attr$name, round(v_attr$weight, precision), sep = "\n")

  # Very small edges should display as epsilon
  edge_labels <- e_attr$weight
  if (is.null(edge_labels)) edge_labels <- numeric(0)

  near_0 <- edge_labels <= eps & edge_labels != 0
  near_1 <- edge_labels >= 1 - eps & edge_labels != 1

  if (length(near_0) == 0 || length(near_1) == 0) {
    edge_labels <- round(edge_labels, precision)
  } else {
    edge_labels[!near_0 & !near_1] <-
      round(edge_labels[!near_0 & !near_1], precision)
  }

  if (!is.null(eps)) {
    edge_labels[near_0] <- expression(epsilon)
    edge_labels[near_1] <- expression(1 - epsilon)
  }

  # Set curves -----------------------------------------------------------------
  curve <- rep(0, length(igraph::E(graph_igraph)))
  names(curve) <- attr(igraph::E(graph_igraph), "vnames")

  # Vertex pairs connected in both directions should get a small default so
  # their edges don't overlap each other
  if (!is.null(edge_curves)) {
    if (!is.na(edge_curves["pairs"])) {
      edge_pair_curve <- edge_curves["pairs"]
    } else {
      edge_pair_curve <- .25
    }
  } else {
    edge_pair_curve <- .25
  }

  edge_pair_locs <-
    attr(igraph::E(graph_igraph), "vnames") %in% edge_pairs(x)

  curve[edge_pair_locs] <- edge_pair_curve

  curve[names(edge_curves)] <- edge_curves

  # Set layout -----------------------------------------------------------------
  if (!is.function(layout)) {
    if (!is.matrix(layout)) {
      if (layout == "grid") {
        if (is.null(nrow) && is.null(ncol)) {
          nrow <- ceiling(sqrt(graph_size))
          ncol <- nrow
        } else if (is.null(nrow)) {
          nrow <- ceiling(graph_size / ncol)
        } else if (is.null(ncol)) {
          ncol <- ceiling(graph_size / nrow)
        }

        # [] removes extras when grid is not filled all the way
        layout <- cbind(
          rep(seq_len(ncol), nrow)[graph_seq],
          vapply(rev(seq_len(nrow)), rep, integer(ncol), ncol)[graph_seq]
        )
      }
    }
  }

  graphics::par(mar = margins)
  graphics::par(bg = background_color)

  # Draw! ----------------------------------------------------------------------
  igraph::plot.igraph(
    graph_igraph,
    ...,
    layout = layout,
    vertex.color = v_color,
    vertex.label = v_labels,
    vertex.label.color = "black",
    vertex.size = 20,
    edge.label = edge_labels,
    edge.label.color = "black",
    edge.curved = curve,
    edge.arrow.size = 1,
    edge.arrow.width = 1,
    asp = 0
  )

  invisible(x)
}

#' Calculate adjusted hypothesis weights for parametric tests
#'
#' @description
#' An intersection hypothesis can be rejected if its p-values are less than or
#' equal to their adjusted significance levels, which are their adjusted
#' hypothesis weights times \eqn{\alpha}. For Bonferroni tests, their adjusted
#' hypothesis weights are their hypothesis weights of the intersection
#' hypothesis. Additional adjustment is needed for parametric tests:
#' * Parametric tests for [adjust_weights_parametric()],
#'     - Note that one-sided tests are required for parametric tests.
#'
#' @param x The root to solve for with `stats::uniroot()`.
#' @param alpha (Optional) A numeric value of the overall significance level,
#'   which should be between 0 & 1. The default is 0.025 for one-sided
#'   hypothesis testing problems; another common choice is 0.05 for two-sided
#'   hypothesis testing problems. Note when parametric tests are used, only
#'   one-sided tests are supported.
#' @param hypotheses A numeric vector of hypothesis weights. Must be a vector of
#'   values between 0 & 1 (inclusive). The sum of hypothesis weights should not
#'   exceed 1.
#' @param test_corr (Optional) A numeric matrix of correlations between test
#'   statistics, which is needed to perform parametric tests using
#'   [adjust_weights_parametric()]. The number of rows and columns of
#'   this correlation matrix should match the length of `p`.
#' @param maxpts (Optional) An integer scalar for the maximum number of function
#'   values, which is needed to perform parametric tests using the
#'   `mvtnorm::GenzBretz` algorithm. The default is 25000.
#' @param abseps (Optional) A numeric scalar for the absolute error tolerance,
#'   which is needed to perform parametric tests using the `mvtnorm::GenzBretz`
#'   algorithm. The default is 1e-6.
#' @param releps (Optional) A numeric scalar for the relative error tolerance
#'   as double, which is needed to perform parametric tests using the
#'   `mvtnorm::GenzBretz` algorithm. The default is 0.
#'
#' @return
#' * `c_value_function()` returns the difference between
#'   \eqn{\alpha} and the Type I error of the parametric test with the \eqn{c}
#'   value of `x`, adjusted for the correlation between test statistics using
#'   parametric tests based on equation (6) of Xi et al. (2017).
#' * `solve_c_parametric()` returns the c value adjusted for the
#'   correlation between test statistics using parametric tests based on
#'   equation (6) of Xi et al. (2017).
#'
#' @seealso
#'   [adjust_weights_parametric()] for adjusted hypothesis weights using
#'   parametric tests.
#'
#' @rdname adjust_weights_parametric_util
#'
#' @keywords internal
#'
#' @references
#'   Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework
#'   for weighted parametric multiple test procedures.
#'   \emph{Biometrical Journal}, 59(5), 918-931.
c_value_function <- function(x,
                             hypotheses,
                             test_corr,
                             alpha,
                             maxpts = 25000,
                             abseps = 1e-6,
                             releps = 0) {
  hyps_nonzero <- which(hypotheses > 0)
  z <- stats::qnorm(x * hypotheses[hyps_nonzero] * alpha, lower.tail = FALSE)
  y <- ifelse(
    length(z) == 1,
    stats::pnorm(z, lower.tail = FALSE)[[1]],
    1 - mvtnorm::pmvnorm(
      lower = -Inf,
      upper = z,
      corr = test_corr[hyps_nonzero, hyps_nonzero, drop = FALSE],
      algorithm = mvtnorm::GenzBretz(
        maxpts = maxpts,
        abseps = abseps,
        releps = releps
      )
    )[[1]]
  )

  y - alpha * sum(hypotheses)
}

#' @rdname adjust_weights_parametric_util
#' @keywords internal
solve_c_parametric <- function(hypotheses,
                               test_corr,
                               alpha,
                               maxpts = 25000,
                               abseps = 1e-6,
                               releps = 0) {
  num_hyps <- seq_along(hypotheses)
  c_value <- ifelse(
    length(num_hyps) == 1 || sum(hypotheses) == 0,
    1,
    stats::uniroot(
      c_value_function,
      lower = 0, # Why is this not -Inf? Ohhhh because c_value >= 1
      # upper > 40 errors when w[i] ~= 1 && w[j] = epsilon
      # upper = 2 errors when w = c(.5, .5) && all(test_corr == 1)
      # furthermore, even under perfect correlation & with balanced weights, the
      # c_function_to_solve does not exceed `length(hypotheses)`
      upper = length(hypotheses) + 1,
      hypotheses = hypotheses,
      test_corr = test_corr,
      alpha = alpha,
      maxpts = maxpts,
      abseps = abseps,
      releps = releps
    )$root
  )

  # Occasionally has floating point differences
  round(c_value, 10)
}

#' @rdname adjust_weights_parametric_util
#' @keywords internal
#' This function only allows `test_corr` to be a single correlation matrix. This
#' is different from `adjust_weights_parametric()` which allows a list of
#' correlation matrices.
adjust_weights_parametric_util <- function(matrix_weights,
                                           matrix_intersections,
                                           test_corr,
                                           alpha,
                                           test_groups,
                                           maxpts = 25000,
                                           abseps = 1e-6,
                                           releps = 0) {
  c_values <- matrix(
    nrow = nrow(matrix_weights),
    ncol = ncol(matrix_weights),
    dimnames = dimnames(matrix_weights)
  )

  for (group in test_groups) {
    for (row in seq_len(nrow(matrix_weights))) {
      group_by_intersection <-
        group[as.logical(matrix_intersections[row, , drop = TRUE][group])]

      group_c_value <- solve_c_parametric(
        matrix_weights[row, group_by_intersection, drop = TRUE],
        test_corr[group_by_intersection, group_by_intersection, drop = FALSE],
        alpha,
        maxpts,
        abseps,
        releps
      )

      c_values[row, group] <-
        group_c_value * matrix_intersections[row, group, drop = TRUE]
    }
  }

  adjusted_weights <- c_values * matrix_weights

  adjusted_weights[, unlist(test_groups), drop = FALSE]
}

#' Obtain an updated graph by updating an initial graphical after deleting
#' hypotheses
#'
#' @description
#' After a hypothesis is deleted, an initial graph will be updated. The deleted
#' hypothesis will have the hypothesis weight of 0 and the transition weight of
#' 0. Remaining hypotheses will have updated hypothesis weights and transition
#' weights according to Algorithm 1 of Bretz et al. (2009).
#'
#' @param graph An initial graph as returned by [graph_create()].
#' @param delete A logical or integer vector, denoting which hypotheses to
#'   delete. A logical vector results in the "unordered mode", which means that
#'   hypotheses corresponding to `TRUE` in `delete` will be deleted. The
#'   sequence of deletion will follow the sequence of `TRUE`'s in `delete`. In
#'   this case, the length of the logical vector must match the number of
#'   hypotheses in `graph`. An integer vector results in the "ordered mode",
#'   which means that `delete` specifies the sequence in which hypotheses
#'   should be deleted by indicating the location of deleted hypotheses, e.g.,
#'   1st, 2nd, etc. In this case, the integer vector can have any length, but
#'   must only contain valid hypothesis numbers (greater than 0, and less than
#'   or equal to he number of hypotheses in `graph`).
#'
#' @return An S3 object of class `updated_graph` with a list of 4 elements:
#'   * `initial_graph`: The initial graph object.
#'   * `updated_graph`: The updated graph object with specified hypotheses
#'     deleted.
#'   * `deleted`: A numeric vector indicating which hypotheses were deleted.
#'   * `intermediate_graphs`: When using the ordered mode, a list of
#'     intermediate updated graphs after each hypothesis is deleted according
#'     to the sequence specified by `delete`.
#'
#' @section Sequence of deletion:
#' When there are multiple hypotheses to be deleted from a graph, there are many
#' sequences of deletion in which an initial graph is updated to an updated
#' graph. If the interest is in the updated graph after all hypotheses specified
#' by `delete` are deleted, this updated graph is the same no matter which
#' sequence of deletion is used. This property has been proved by Bretz et al.
#' (2009). If the interest is in the intermediate updated graph after each
#' hypothesis is deleted according to the sequence specified by `delete`, an
#' integer vector of `delete` should be specified and these detailed outputs
#' will be provided.
#'
#' @seealso
#'   * [graph_create()] for the initial graph.
#'   * [graph_rejection_orderings()] for possible sequences of rejections for a
#'     graphical multiple comparison procedure using shortcut testing.
#'
#' @rdname graph_update
#'
#' @export
#'
#' @references
#'   Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
#'   approach to sequentially rejective multiple test procedures.
#'   \emph{Statistics in Medicine}, 28(4), 586-604.
#'
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 1 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' transitions <- rbind(
#'   c(0, 0, 1, 0),
#'   c(0, 0, 0, 1),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#'
#' # Delete the second and third hypotheses in the "unordered mode"
#' graph_update(g, delete = c(FALSE, TRUE, TRUE, FALSE))
#'
#' # Equivalent way in the "ordered mode" to obtain the updated graph after
#' # deleting the second and third hypotheses
#' # Additional intermediate updated graphs are also provided
#' graph_update(g, delete = 2:3)
graph_update <- function(graph, delete) {
  # Basic type checking
  stopifnot(
    "Please update an `initial_graph` object" = class(graph) == "initial_graph",
    "Hypothesis index must be a logical or integer vector" =
      is.logical(delete) || (all(as.integer(delete) == delete))
  )

  ordered <- !is.logical(delete)

  # Qualitative checking
  if (ordered) {
    stopifnot(
      "Ordered deletion index must contain only valid hypothesis numbers" =
        all(delete > 0 & delete <= length(graph$hypotheses)),
      "Ordered deletion index must have unique values" =
        length(delete) == length(unique(delete))
    )

    intermediate_graphs <- list(graph)
  } else {
    stopifnot(
      "Length of unordered deletion index must match size of graph" =
        length(graph$hypotheses) == length(delete),
      "Unordered deletion index must only contain TRUE or FALSE" =
        all(delete %in% c(TRUE, FALSE))
    )

    delete <- which(delete)
  }

  initial_graph <- graph
  cume_delete <- integer(0)

  # Iterate over the hypotheses to delete
  for (delete_num in delete) {
    cume_delete <- c(cume_delete, delete_num)

    # Save current state of the graph to use in calculations
    # Also make a copy of graph elements for storing new values in
    init_hypotheses <- hypotheses <- graph$hypotheses
    init_transitions <- transitions <- graph$transitions

    hyp_nums <- seq_along(hypotheses)

    # Loop over hypotheses, calculating new weights based on initial hypothesis
    # weights and storing in `hypotheses`
    for (hyp_num in hyp_nums) {
      hypotheses[[hyp_num]] <-
        init_hypotheses[[hyp_num]] +
        init_hypotheses[[delete_num]] * init_transitions[[delete_num, hyp_num]]

      denominator <- 1 - init_transitions[[hyp_num, delete_num]] *
        init_transitions[[delete_num, hyp_num]]

      # In this loop, hyp_num is the starting node of the transition, and
      # end_num is the ending node
      # Calculate new transition weights based on original transition weights,
      # and store in `transitions`
      for (end_num in hyp_nums) {
        if (hyp_num == end_num || denominator <= 0) {
          transitions[[hyp_num, end_num]] <- 0
        } else {
          transitions[[hyp_num, end_num]] <- (
            init_transitions[[hyp_num, end_num]] +
              init_transitions[[hyp_num, delete_num]] *
                init_transitions[[delete_num, end_num]]
          ) / denominator
        }
      }
    }

    # Make sure to zero out the deleted node's values
    hypotheses[delete_num] <- 0
    transitions[delete_num, ] <- 0
    transitions[, delete_num] <- 0

    # At this point, a single hypothesis has been removed from the graph.
    # Assign the newly calculated hypotheses and transitions to `graph`, and
    # loop to the next hypothesis to delete
    graph <- structure(
      list(hypotheses = hypotheses, transitions = transitions),
      class = "initial_graph",
      title = "Updated graph",
      deleted = cume_delete
    )

    if (ordered) intermediate_graphs <- c(intermediate_graphs, list(graph))
  }

  structure(
    list(
      initial_graph = initial_graph,
      updated_graph = graph,
      deleted = delete,
      intermediate_graphs = if (ordered) intermediate_graphs
    ),
    class = "updated_graph"
  )
}

#' Calculate the repeated p-value for a single hypothesis at a given analysis
#'
#' @description
#' A repeated p-value at analysis \eqn{k} is the minimum significance level at
#' which the group sequential boundary at analysis \eqn{k} would be crossed.
#' Unlike the sequential p-value, which considers all analyses up to \eqn{k},
#' the repeated p-value only considers the boundary at analysis \eqn{k} itself.
#'
#' The sequential p-value equals the minimum of repeated p-values across
#' analyses: \eqn{\tilde{p}_k = \min_{l=1}^{k} \hat{p}_l}, where
#' \eqn{\hat{p}_l} is the repeated p-value at analysis \eqn{l}.
#'
#' @param p A numeric vector of p-values at each analysis for a single
#'   hypothesis. The length must match the length of `info_frac`. All values
#'   must be non-missing and between 0 and 1.
#' @param info_frac A numeric vector of information fractions at each analysis.
#'   Values must be in (0, 1] and monotonically non-decreasing. The length
#'   should match the length of `p`.
#' @param spending_fn A spending function. Must accept two arguments:
#'   `alpha` (total significance level) and `info_frac` (information fraction),
#'   and return the cumulative alpha spent. Built-in options include
#'   [spending_of()], [spending_pocock()], [spending_hsd()], and
#'   [spending_linear()].
#' @param tol A numeric scalar for the tolerance of the root-finding
#'   algorithm. The default is `1e-6`.
#' @param maxpts An integer scalar for the maximum number of function values
#'   for `mvtnorm::GenzBretz`. The default is 25000.
#' @param abseps A numeric scalar for the absolute error tolerance for
#'   `mvtnorm::GenzBretz`. The default is 1e-6.
#'
#' @return A numeric scalar of the repeated p-value at the last analysis in
#'   the input vectors.
#'
#' @details
#' For a hypothesis tested at analyses \eqn{k = 1, \ldots, K} with p-values
#' \eqn{p^{(k)}} and information fractions \eqn{t^{(k)}}, the repeated
#' p-value at analysis \eqn{K} is the minimum \eqn{\hat{p}} such that the
#' observed p-value \eqn{p^{(K)}} crosses the group sequential boundary
#' \eqn{c_K(\hat{p})} at that analysis:
#' \deqn{\hat{p}_K = \min\{\alpha : p^{(K)} \le c_K(\alpha)\}.}
#'
#' Note that computing the boundary \eqn{c_K(\alpha)} requires knowledge of
#' all previous information fractions \eqn{t^{(1)}, \ldots, t^{(K)}} because
#' the boundary at analysis \eqn{K} depends on the cumulative spending and
#' the joint distribution of test statistics.
#'
#' The repeated p-value is found using [stats::uniroot()] on the function
#' \eqn{g(\alpha) = z_K - b_K(\alpha)}, where \eqn{z_K =
#' \Phi^{-1}(1 - p^{(K)})} is the observed Z-statistic at analysis \eqn{K}
#' and \eqn{b_K(\alpha)} is the Z-scale boundary.
#'
#' @seealso
#'   [sequential_p()] for the sequential p-value (minimum repeated p-value),
#'   [gs_boundaries()] for computing group sequential boundaries,
#'   [graph_test_shortcut_gsd()] for graphical multiple comparison procedures
#'   with group sequential designs.
#'
#' @rdname repeated_p
#'
#' @export
#'
#' @references
#'   Maurer, W., and Bretz, F. (2013). Multiple testing in group sequential
#'   trials using graphical approaches. \emph{Statistics in Biopharmaceutical
#'   Research}, 5(4), 311-320.
#'
#' @examples
#' # Repeated p-value at the second analysis (interim at 50%, final at 100%)
#' repeated_p(
#'   p = c(0.024, 0.01),
#'   info_frac = c(0.5, 1),
#'   spending_fn = spending_of
#' )
#'
#' # Compare with sequential p-value (which is the minimum repeated p-value)
#' sequential_p(
#'   p = c(0.024, 0.01),
#'   info_frac = c(0.5, 1),
#'   spending_fn = spending_of
#' )
#'
#' # Repeated p-values at each analysis
#' # Analysis 1
#' repeated_p(
#'   p = 0.05,
#'   info_frac = 0.3,
#'   spending_fn = spending_of
#' )
#'
#' # Analysis 2
#' repeated_p(
#'   p = c(0.05, 0.02),
#'   info_frac = c(0.3, 0.7),
#'   spending_fn = spending_of
#' )
repeated_p <- function(p,
                       info_frac,
                       spending_fn,
                       tol = 1e-6,
                       maxpts = 25000,
                       abseps = 1e-6) {
  stopifnot(
    "p must be a numeric vector" = is.numeric(p),
    "p must not contain NA" = !anyNA(p),
    "p must be between 0 and 1" = all(p >= 0 & p <= 1),
    "info_frac must be a numeric vector" = is.numeric(info_frac),
    "info_frac must not contain NA" = !anyNA(info_frac),
    "p and info_frac must have the same length" = length(info_frac) == length(p)
  )

  K <- length(p)

  # Convert observed p-value at the current analysis to Z-statistic
  z_obs_K <- stats::qnorm(1 - p[K])

  # For a candidate alpha, compute boundaries and return the exceedance
  # at analysis K only: z_obs[K] - b_K(alpha).
  # Positive means the boundary at analysis K is crossed.
  exceedance_K <- function(alpha_candidate) {
    bounds <- gs_boundaries(
      alpha = alpha_candidate,
      info_frac = info_frac,
      spending_fn = spending_fn,
      maxpts = maxpts,
      abseps = abseps
    )

    z_obs_K - bounds$bounds_z[K]
  }

  # Check edge cases before root-finding.
  upper <- 1 - tol
  lower <- tol

  # If boundary at analysis K is not crossed even at alpha ~ 1,
  # the p-value at this analysis is too large. Return 1.
  exc_upper <- tryCatch(
    exceedance_K(upper),
    error = function(e) NA_real_
  )
  if (is.na(exc_upper) || exc_upper <= 0) {
    message("Boundary at analysis K not crossed; returning 1 as an upper bound.")
    return(1)
  }

  # If boundary at analysis K is crossed even at alpha ~ 0,
  # the p-value is extremely small. Return the lower bound.
  # Use >= 0 to also handle the edge case where the exceedance is exactly 0
  # (boundary exactly crossed), which would cause uniroot to fail because
  # f(lower) and f(upper) would have the same sign.
  exc_lower <- tryCatch(
    exceedance_K(lower),
    error = function(e) {
      # gs_boundaries can fail at very small alpha due to numerical issues
      # in pmvnorm. Treat this as the boundary being extremely large
      # (i.e., not crossed), so exceedance is negative.
      -1
    }
  )
  if (exc_lower >= 0) {
    message(
      "Boundary crossed at alpha = ", lower,
      "; returning ", lower, " as a lower bound."
    )
    return(lower)
  }

  # Find the root: minimum alpha where boundary at analysis K is crossed.
  # Wrap in tryCatch to handle numerical edge cases in uniroot.
  result <- tryCatch(
    stats::uniroot(
      exceedance_K,
      interval = c(lower, upper),
      tol = tol
    ),
    error = function(e) {
      # If uniroot fails, try with a wider lower bound
      tryCatch(
        stats::uniroot(
          exceedance_K,
          interval = c(lower * 10, upper),
          tol = tol
        ),
        error = function(e2) {
          message(
            "Root-finding failed; returning ", lower,
            " as a lower bound. Original error: ", e$message
          )
          list(root = lower)
        }
      )
    }
  )

  result$root
}

#' Calculate power values for a graphical multiple comparison procedure
#'
#' @description
#' Under the alternative hypotheses, the distribution of test statistics is
#' assumed to be a multivariate normal distribution. Given this distribution,
#' this function calculates power values for a graphical multiple comparison
#' procedure. By default, it calculate the local power, which is the probability
#' to reject an individual hypothesis, the probability to reject at least one
#' hypothesis, the probability to reject all hypotheses, the expected number of
#' rejections, and the probability of user-defined success criteria.
#' See `vignette("shortcut-testing")` and `vignette("closed-testing")` for more
#' illustration of power calculation.
#'
#' @inheritParams graph_test_closure
#' @param alpha A numeric value of the one-sided overall significance level,
#'   which should be between 0 & 1. The default is 0.025 for one-sided
#'   hypothesis testing. Note that only one-sided tests are supported.
#' @param sim_n An integer scalar specifying the number of simulations. The
#'   default is 1e5.
#' @param power_marginal A numeric vector of marginal power values to use when
#'   simulating p-values. See Details for more on the simulation process.
#' @param sim_corr A numeric matrix of correlations between test statistics for
#'   all hypotheses. The dimensions should match the number of hypotheses in
#'   `graph`.
#' @param sim_success A list of user-defined functions to specify the success
#'   criteria. Functions must take one simulation's logical vector of results as
#'   an input, and return a length-one logical vector. For instance, if
#'   "success" means rejecting hypotheses 1 and 2, use `sim_success = list("1
#'   and 2" = function(x) x[1] && x[2])`. If the list is not named, the function
#'   body will be used as the name. Lambda functions also work starting with R
#'   4.1, e.g. `sim_success = list(\(x) x[3] || x[4])`.
#' @param verbose A logical scalar specifying whether the details of power
#'   simulations should be included in results. The default is `verbose =
#'   FALSE`.
#'
#' @return A `power_report` object with a list of 3 elements:
#'   * `inputs` - Input parameters, which is a list of:
#'     * `graph` - Initial graph,
#'     * `alpha` - Overall significance level,
#'     * `test_groups` - Groups of hypotheses for different types of tests,
#'     * `test_types` - Different types of tests,
#'     * `test_corr` - Correlation matrices for parametric tests,
#'     * `sim_n` - Number of simulations,
#'     * `power_marginal` - Marginal power of all hypotheses
#'     * `sim_corr` - Correlation matrices for simulations,
#'     * `sim_success` - User-defined success criteria.
#'   * `power` - A list of power values
#'     * `power_local` - Local power of all hypotheses, which is the proportion
#'   of simulations in which each hypothesis is rejected,
#'     * `rejection_expected` - Expected (average) number of rejected hypotheses,
#'     * `power_at_least_1` - Power to reject at least one hypothesis,
#'     * `power_all` - Power to reject all hypotheses,
#'     * `power_success` - Power of user-defined success, which is the
#'   proportion of simulations in which the user-defined success criterion
#'     * `sim_success` is met.
#'   * `details` - An optional list of datasets showing simulated p-values and
#'   results for each simulation.
#'
#' @section Simulation details: The power calculation is based on simulations.
#'   The distribution to simulate from is determined as a multivariate normal
#'   distribution by `power_marginal` and `sim_corr`. In particular,
#'   `power_marginal` is a vector of marginal power values for all hypotheses.
#'   The marginal power is the power to reject the null hypothesis at the
#'   significance level `alpha` *without multiplicity adjustment*. This value could be readily available from
#'   standard software and other R packages. Then we can determine the mean of
#'   the multivariate normal distribution as
#'   \deqn{\Phi^{-1}\left(1-\alpha\right)-\Phi^{-1}\left(1-d_i\right)}, which is
#'   often called the non-centrality parameter or the drift parameter. Here
#'   \eqn{d_i} is the marginal power `power_marginal` of hypothesis \eqn{i}.
#'   Given the correlation matrix `sim_corr`, we can simulate from this
#'   multivariate normal distribution using the `mvtnorm` R package (Genz and
#'   Bretz, 2009).
#'
#'   Each set simulated values can be used to calculate the corresponding
#'   one-sided p-values. Then this set of p-values are plugged into the
#'   graphical multiple comparison procedure to determine which hypotheses are
#'   rejected. This process is repeated `n_sim` times to produce the power
#'   values as the proportion of simulations in which a particular success
#'   criterion is met.
#'
#' @rdname graph_calculate_power
#'
#' @export
#'
#' @references Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W.,
#'   and Rohmeyer, K. (2011a). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#'   Bretz, F., Maurer, W., and Hommel, G. (2011b). Test and power
#'   considerations for multiple endpoint analyses using sequentially rejective
#'   graphical procedures. \emph{Statistics in Medicine}, 30(13), 1489-1501.
#'
#'   Genz, A., and Bretz, F. (2009). \emph{Computation of Multivariate Normal
#'   and t Probabilities}, series Lecture Notes in Statistics. Springer-Verlag,
#'   Heidelberg.
#'
#'   Lu, K. (2016). Graphical approaches using a Bonferroni mixture of weighted
#'   Simes tests. \emph{Statistics in Medicine}, 35(22), 4041-4055.
#'
#'   Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework
#'   for weighted parametric multiple test procedures. \emph{Biometrical
#'   Journal}, 59(5), 918-931.
#'
#' @examples
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 4 in Bretz et al. (2011a).
#' alpha <- 0.025
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' delta <- 0.5
#' transitions <- rbind(
#'   c(0, delta, 1 - delta, 0),
#'   c(delta, 0, 0, 1 - delta),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#'
#' marginal_power <- c(0.8, 0.8, 0.7, 0.9)
#' corr1 <- matrix(0.5, nrow = 2, ncol = 2)
#' diag(corr1) <- 1
#' corr <- rbind(
#'   cbind(corr1, 0.5 * corr1),
#'   cbind(0.5 * corr1, corr1)
#' )
#' success_fns <- list(
#'   # Probability to reject both H1 and H2
#'   `H1andH2` = function(x) x[1] & x[2],
#'   # Probability to reject both (H1 and H3) or (H2 and H4)
#'   `(H1andH3)or(H2andH4)` = function(x) (x[1] & x[3]) | (x[2] & x[4])
#' )
#' set.seed(1234)
#' # Bonferroni tests
#' # Reduce the number of simulations to save time for package compilation
#' power_output <- graph_calculate_power(
#'   g,
#'   alpha,
#'   sim_corr = corr,
#'   sim_n = 1e2,
#'   power_marginal = marginal_power,
#'   sim_success = success_fns
#' )
#'
#' # Parametric tests for H1 and H2; Simes tests for H3 and H4
#' # User-defined success: to reject H1 or H2; to reject H1 and H2
#' # Reduce the number of simulations to save time for package compilation
#' graph_calculate_power(
#'   g,
#'   alpha,
#'   test_groups = list(1:2, 3:4),
#'   test_types = c("parametric", "simes"),
#'   test_corr = list(corr1, NA),
#'   sim_n = 1e2,
#'   sim_success = list(
#'     function(.) .[1] || .[2],
#'     function(.) .[1] && .[2]
#'   )
#' )
#'
graph_calculate_power <- function(graph,
                                  alpha = 0.025,
                                  power_marginal =
                                    rep(alpha, length(graph$hypotheses)),
                                  test_groups =
                                    list(seq_along(graph$hypotheses)),
                                  test_types = c("bonferroni"),
                                  test_corr = rep(list(NA), length(test_types)),
                                  sim_n = 1e5,
                                  sim_corr = diag(length(graph$hypotheses)),
                                  sim_success = NULL,
                                  verbose = FALSE) {
  # Input sanitization ---------------------------------------------------------
  # Test types should be passed as full names or first letter, case-insensitive,
  # and a single provided type should get expanded to all groups
  test_types_names <- names(test_types)
  test_opts <- c(
    bonferroni = "bonferroni",
    parametric = "parametric",
    simes = "simes",
    hochberg = "hochberg",
    b = "bonferroni",
    p = "parametric",
    s = "simes",
    h = "hochberg"
  )
  test_types <- test_opts[tolower(test_types)]
  names(test_types) <- test_types_names
  if (length(test_types) == 1) {
    test_types <- rep(test_types, length(test_groups))
  }

  # Groups of size 1 should always use Bonferroni testing
  test_types[lengths(test_groups) == 1] <- "bonferroni"

  # A bare success function should get put into a length-one list
  if (is.function(sim_success)) sim_success <- list(sim_success)

  hyp_names <- names(graph$hypotheses)
  num_hyps <- length(graph$hypotheses)

  # Input validation -----------------------------------------------------------
  test_input_val(
    graph,
    rep(alpha, length(graph$hypotheses)),
    alpha,
    test_groups,
    test_types,
    test_corr,
    FALSE,
    FALSE
  )

  # The test specification arguments can be named or not. However, if
  # `test_groups` is named, all of them must be named. The other two are
  # re-ordered to match `test_groups`
  if (!is.null(names(test_groups))) {
    if (!all(names(c(test_types, test_corr)) %in% names(test_groups))) {
      stop("If `test_groups` is named, `test_types` and `test_corr` must use the
           same names")
    } else {
      test_types <- test_types[names(test_groups)]
      test_corr <- test_corr[names(test_groups)]
    }
  } else {
    names(test_groups) <-
      names(test_types) <-
      names(test_corr) <-
      paste0("grp", seq_along(test_groups))
  }

  # Correlation matrix input is easier for end users to input as a list, but
  # it's easier to work with internally as a full matrix, potentially with
  # missing values. This puts all the correlation pieces into one matrix
  new_corr <- matrix(NA, num_hyps, num_hyps)

  for (group_num in seq_along(test_groups)) {
    new_corr[test_groups[[group_num]], test_groups[[group_num]]] <-
      test_corr[[group_num]]
  }
  diag(new_corr) <- 1
  test_corr <- if (any(test_types == "parametric")) new_corr else NULL

  power_input_val(graph, sim_n, power_marginal, sim_corr, sim_success)

  # Simulated p-values are generated by sampling from the multivariate normal
  # distribution. The means are set with `power_marginal`, and the correlations
  # are set with `sim_corr`. Random samples are converted to p-values with a
  # one-sided test.
  noncentrality_parameter <-
    stats::qnorm(1 - alpha, lower.tail = TRUE) -
    stats::qnorm(1 - power_marginal, lower.tail = TRUE)

  p_sim <- stats::pnorm(
    mvtnorm::rmvnorm(
      sim_n,
      noncentrality_parameter,
      sigma = sim_corr
    ),
    lower.tail = FALSE
  )

  simulation_test_results <- matrix(
    NA,
    nrow = sim_n,
    ncol = length(power_marginal),
    dimnames = list(seq_len(sim_n), hyp_names)
  )

  # Calculate weights for each intersection in the closure -------------------
  weighting_strategy <- graph_generate_weights(graph)
  matrix_intersections <- weighting_strategy[, seq_len(num_hyps), drop = FALSE]
  matrix_weights <-
    weighting_strategy[, seq_len(num_hyps) + num_hyps, drop = FALSE]

  if (all(test_types == "bonferroni")) {
    for (row in seq_len(sim_n)) {
      simulation_test_results[row, ] <- graph_test_shortcut_fast(
        p_sim[row, ],
        alpha,
        matrix_weights
      )
    }
  } else {
    # Calculate Bonferroni adjusted weights ------------------------------------
    groups_bonferroni <- test_groups[test_types == "bonferroni", drop = FALSE]

    # Bonferroni adjusted weights are just the weights from the closure
    adjusted_weights_bonferroni <-
      matrix_weights[, unlist(groups_bonferroni), drop = FALSE]

    # Calculate parametric adjusted weights ------------------------------------
    groups_parametric <- test_groups[test_types == "parametric", drop = FALSE]

    # Parametric adjusted weights depend only on the joint distribution and
    # alpha. This allows adjusted weights to be calculated once, rather than
    # re-calculating for each simulation
    adjusted_weights_parametric <- adjust_weights_parametric_util(
      matrix_weights,
      matrix_intersections,
      test_corr,
      alpha,
      groups_parametric
    )

    # Separate Simes weighting strategy ----------------------------------------
    groups_simes <- test_groups[test_types == "simes", drop = FALSE]

    # The fastest option found for calculating Simes adjusted weights requires
    # missing hypotheses' weights to be 0, rather than NA
    matrix_weights_simes <-
      matrix_weights[, unlist(groups_simes), drop = FALSE]

    # Unlike Bonferroni and parametric adjusted weights, Simes adjusted weights
    # depend on the order of p-values. This means they must be re-calculated for
    # each simulation. Because this causes a bottleneck in calculations, Simes
    # testing has been heavily optimized. Fast Simes testing requires Simes
    # hypothesis numbers to be mapped to their relative position within the set
    # of all Simes hypotheses. For example, if hypotheses 1/7 form a parametric
    # group, and 2/5 & 3/4/6 each form a Simes group, the fast Simes functions
    # will get hypotheses 2/5 & 3/4/6 passed, but the groups must first be
    # re-indexed to 1/4 & 2/3/5 (their relative locations within all Simes
    # groups).
    groups_simes_reduce <- lapply(
      groups_simes,
      function(group) which(unlist(groups_simes) %in% group)
    )

    # Fast Simes testing also requires a set of p-values with columns already
    # subset for Simes testing, similar to how the weighting strategy is subset
    # for each test type
    p_sim_simes <- p_sim[, unlist(groups_simes), drop = FALSE]

    # Separate Hochberg weighting strategy -------------------------------------
    # All Simes comments apply to Hochberg
    groups_hochberg <- test_groups[test_types == "hochberg", drop = FALSE]

    matrix_weights_hochberg <-
      matrix_weights[, unlist(groups_hochberg), drop = FALSE]

    matrix_intersections_hochberg <-
      matrix_intersections[, unlist(groups_hochberg), drop = FALSE]

    groups_hochberg_reduce <- lapply(
      groups_hochberg,
      function(group) which(unlist(groups_hochberg) %in% group)
    )

    p_sim_hochberg <- p_sim[, unlist(groups_hochberg), drop = FALSE]

    # Apply closure testing to each simulation ---------------------------------
    for (row in seq_len(sim_n)) {
      # If there are no Simes groups, adjusted weights are the Simes weighting
      # strategy (a matrix with 0 columns)
      if (length(groups_simes) == 0) {
        adjusted_weights_simes <- matrix_weights_simes
      } else {
        # Simes testing depends on p-values, so adjusted weights must be
        # calculated for each simulation.
        adjusted_weights_simes <- adjust_weights_simes(
          matrix_weights_simes,
          p_sim_simes[row, ],
          groups_simes_reduce
        )

        # *Note:* The Simes adjusted weights are incorrect for missing Simes
        # hypotheses. To improve performance, missing hypotheses are given a
        # zero value rather than NA before calculating adjusted weights. This
        # results in missing hypotheses getting an adjusted weight calculated
        # for them. These incorrect values are then replaced with zeroes for
        # testing
      }

      # All Simes comments apply to similar lines for Hochberg
      if (length(groups_hochberg) == 0) {
        adjusted_weights_hochberg <- matrix_weights_hochberg
      } else {
        adjusted_weights_hochberg <- adjust_weights_hochberg(
          matrix_weights_hochberg,
          matrix_intersections_hochberg,
          p_sim_hochberg[row, ],
          groups_hochberg_reduce
        )
      }

      # `graph_test_closure_fast()` requires hypotheses, p-values, and the
      # intersections matrix to all have hypotheses/columns in the same order.
      # P-values and the intersections matrix are already in the original order,
      # so order the adjusted weights back in original hypothesis order.
      adjusted_weights_all <- cbind(
        adjusted_weights_bonferroni,
        adjusted_weights_simes,
        adjusted_weights_hochberg,
        adjusted_weights_parametric
      )[, hyp_names, drop = FALSE]

      # Similar to Simes adjusted weights, the optimized testing function
      # requires missing values to be replaced by zero. This line also replaces
      # the incorrect Simes and Hochberg adjusted weights with zero.
      adjusted_weights_all[!matrix_intersections] <- 0

      # Record test results for one simulation, all groups
      simulation_test_results[row, ] <- graph_test_closure_fast(
        p_sim[row, ],
        alpha,
        adjusted_weights_all,
        matrix_intersections
      )
    }
  }

  # Summarize power results ----------------------------------------------------
  # Each user-defined function provided as a "success" measure should take a
  # logical vector (a single simulation's test results) as input, and return a
  # logical scalar. Applying such a function to each simulation, results in a
  # success indicator vector with one entry per simulation. The average of this
  # vector is the probability of "success".
  power_success <- vapply(
    sim_success,
    function(fn_success) mean(apply(simulation_test_results, 1, fn_success)),
    numeric(1)
  )

  # If the success functions are not named, set names according to each
  # function's body
  if (is.null(names(power_success))) {
    success_fun_bodies <- vapply(
      sim_success,
      function(fn_success) deparse(fn_success)[[2]],
      character(1)
    )

    names(power_success) <- success_fun_bodies
  }

  # Power summaries:
  # * Local power is the probability of rejecting each individual hypothesis:
  # Mean of results for each hypothesis individually.
  # * Expected rejections is the total number of rejections divided by the total
  # possible rejections.
  # * Power to reject at least one hypothesis is the probability that any result
  # in a row is TRUE. This one is just like if a success function was defined as
  # rejecting any hypothesis in the graph
  # * Power to reject all hypotheses is the mean of a success vector where
  # success is only triggered when the whole results vector is TRUE
  power <- list(
    power_local = colMeans(simulation_test_results),
    rejection_expected = sum(simulation_test_results) / sim_n,
    power_at_least_1 = mean(rowSums(simulation_test_results) > 0),
    power_all =
      mean(rowSums(simulation_test_results) == length(power_marginal)),
    power_success = power_success
  )

  # The core output of a power report is the 5 power summaries. It also includes
  # the main testing and simulation input parameters (similar to test results).
  # For completion, the full matrix of simulations and corresponding matrix of
  # test results are included. They are truncated in the print method so as to
  # not blow up output space. It may be preferred for these to be an optional
  # output with e.g. `verbose = TRUE/FALSE`.
  structure(
    list(
      inputs = list(
        graph = graph,
        alpha = alpha,
        test_groups = test_groups,
        test_types = test_types,
        test_corr = test_corr,
        sim_n = sim_n,
        power_marginal = power_marginal,
        sim_corr = sim_corr,
        sim_success = sim_success
      ),
      power = power,
      details = if (verbose) {
        list(
          p_sim = p_sim,
          test_results = simulation_test_results
        )
      }
    ),
    class = "power_report"
  )
}

#' Compute the correlation matrix for group sequential test statistics
#'
#' @description
#' In a group sequential design, test statistics \eqn{Z_1, \ldots, Z_K} at
#' analyses with information fractions \eqn{t_1, \ldots, t_K} follow the
#' canonical joint distribution with correlation
#' \deqn{\text{Cor}(Z_i, Z_j) = \sqrt{t_i / t_j}, \quad i \le j.}
#'
#' This correlation structure arises from the independent increments property
#' of the score process. It depends only on the information fractions, not on
#' the specific test or endpoint.
#'
#' @param info_frac A numeric vector of information fractions at each analysis.
#'   Must be positive and monotonically non-decreasing.
#'
#' @return A symmetric correlation matrix of dimension \eqn{K \times K}, where
#'   \eqn{K} is the length of `info_frac`. The diagonal entries are all 1.
#'
#' @seealso [gs_boundaries()] which uses this correlation matrix for computing
#'   group sequential boundaries.
#'
#' @rdname gs_corr
#'
#' @export
#'
#' @examples
#' # Three equally spaced analyses
#' gs_corr(c(1 / 3, 2 / 3, 1))
#'
#' # Two analyses at 50% and 100%
#' gs_corr(c(0.5, 1))
gs_corr <- function(info_frac) {
  outer(
    info_frac, info_frac,
    function(ti, tj) sqrt(pmin(ti, tj) / pmax(ti, tj))
  )
}

#' Calculate adjusted hypothesis weights
#'
#' @description
#' An intersection hypothesis can be rejected if its p-values are
#' less than or equal to their adjusted significance levels, which are their
#' adjusted hypothesis weights times \eqn{\alpha}. For Bonferroni tests, their
#' adjusted hypothesis weights are their hypothesis weights of the intersection
#' hypothesis. Additional adjustment is needed for parametric, Simes, and
#' Hochberg tests:
#' * Parametric tests for [adjust_weights_parametric()],
#'     - Note that one-sided tests are required for parametric tests.
#' * Simes tests for [adjust_weights_simes()],
#' * Hochberg tests for [adjust_weights_hochberg()].
#'
#' @param matrix_weights (Optional) A matrix of hypothesis weights of all
#'   intersection hypotheses. This can be obtained as the second half of columns
#'   from the output of [graph_generate_weights()].
#' @param matrix_intersections (Optional) A matrix of hypothesis indicators of
#'   all intersection hypotheses. This can be obtained as the first half of
#'   columns from the output of [graph_generate_weights()].
#' @param alpha (Optional) A numeric value of the overall significance level,
#'   which should be between 0 & 1. The default is 0.025 for one-sided
#'   hypothesis testing problems; another common choice is 0.05 for two-sided
#'   hypothesis testing problems. Note when parametric tests are used, only
#'   one-sided tests are supported.
#' @param p (Optional) A numeric vector of p-values (unadjusted, raw), whose
#'   values should be between 0 & 1. The length should match the number of
#'   columns of `matrix_weights`.
#' @param test_corr (Optional) A numeric matrix of correlations between test
#'   statistics, which is needed to perform parametric tests using
#'   [adjust_weights_parametric()]. The number of rows and columns of this
#'   correlation matrix should match the length of `p`.
#' @param test_groups (Optional) A list of numeric vectors specifying hypotheses
#'   to test together. Grouping is needed to correctly perform Simes and
#'   parametric tests.
#' @param ... Additional arguments to perform parametric tests using the
#'   `mvtnorm::GenzBretz` algorithm. `maxpts` is an integer scalar for the
#'   maximum number of function values, whose default value is 25000. `abseps`
#'   is a numeric scalar for the absolute error tolerance, whose default value
#'   is 1e-6. `releps` is a numeric scalar for the relative error tolerance as
#'   double, whose default value is 0.
#'
#' @return
#' * [adjust_weights_parametric()] returns a matrix with the same
#' dimensions as `matrix_weights`, whose hypothesis weights have been adjusted
#' according to parametric tests.
#' * [adjust_weights_simes()] returns a matrix with the same
#' dimensions as `matrix_weights`, whose hypothesis weights have been adjusted
#' according to Simes tests.
#' * [adjust_weights_hochberg()] returns a matrix with the same
#' dimensions as `matrix_weights`, whose hypothesis weights have been adjusted
#' according to Hochberg tests.
#'
#' @seealso [adjust_p_parametric()] for adjusted p-values using parametric
#' tests, [adjust_p_simes()] for adjusted p-values using Simes tests,
#' [adjust_p_hochberg()] for adjusted p-values using Hochberg tests.
#'
#' @rdname adjust_weights
#'
#' @export
#'
#' @references Lu, K. (2016). Graphical approaches using a Bonferroni mixture of
#' weighted Simes tests. \emph{Statistics in Medicine}, 35(22), 4041-4055.
#'
#' Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework for
#' weighted parametric multiple test procedures. \emph{Biometrical Journal},
#' 59(5), 918-931.
#'
#' Xi, D., and Bretz, F. (2019). Symmetric graphs for equally weighted tests,
#' with application to the Hochberg procedure. \emph{Statistics in Medicine},
#' 38(27), 5268-5282.
#'
#' @examples
#' alpha <- 0.025
#' num_hyps <- 4
#' g <- bonferroni_holm(num_hyps)
#' weighting_strategy <- graph_generate_weights(g)
#' matrix_intersections <- weighting_strategy[, seq_len(num_hyps)]
#' matrix_weights <- weighting_strategy[, -seq_len(num_hyps)]
#'
#' set.seed(1234)
#' adjust_weights_parametric(
#'   matrix_weights = matrix_weights,
#'   matrix_intersections = matrix_intersections,
#'   test_corr = list(diag(2), diag(2)),
#'   alpha = alpha,
#'   test_groups = list(1:2, 3:4)
#' )
adjust_weights_parametric <- function(matrix_weights,
                                      matrix_intersections,
                                      test_corr,
                                      alpha,
                                      test_groups,
                                      ...) {
  # Convert the list of correlation matrices to a big matrix
  num_hyps <- ncol(matrix_weights)
  new_corr <- matrix(NA, num_hyps, num_hyps)
  for (group_num in seq_along(test_groups)) {
    new_corr[test_groups[[group_num]], test_groups[[group_num]]] <-
      test_corr[[group_num]]
  }
  diag(new_corr) <- 1
  test_corr <- new_corr

  # Call the internal function
  adjusted_weights <- adjust_weights_parametric_util(
    matrix_weights,
    matrix_intersections,
    test_corr,
    alpha,
    test_groups,
    ...
  )

  adjusted_weights[, colnames(matrix_weights), drop = FALSE]
}

#' @rdname adjust_weights
#' @export
#' @examples
#' alpha <- 0.025
#' p <- c(0.018, 0.01, 0.105, 0.006)
#' num_hyps <- length(p)
#' g <- bonferroni_holm(num_hyps)
#' weighting_strategy <- graph_generate_weights(g)
#' matrix_intersections <- weighting_strategy[, seq_len(num_hyps)]
#' matrix_weights <- weighting_strategy[, -seq_len(num_hyps)]
#'
#' adjust_weights_simes(
#'   matrix_weights = matrix_weights,
#'   p = p,
#'   test_groups = list(1:2, 3:4)
#' )
adjust_weights_simes <- function(matrix_weights, p, test_groups) {
  natural_order <- colnames(matrix_weights)
  ordered_p <- order(p)

  matrix_weights <- matrix_weights[, ordered_p, drop = FALSE]

  group_adjusted_weights <- vector("list", length(test_groups))
  for (i in seq_along(test_groups)) {
    group_adjusted_weights[[i]] <- matrixStats::rowCumsums(
      matrix_weights[, ordered_p %in% test_groups[[i]], drop = FALSE],
      useNames = TRUE
    )
  }

  adjusted_weights <- do.call(cbind, group_adjusted_weights)

  adjusted_weights[, colnames(matrix_weights), drop = FALSE]
}

#' @rdname adjust_weights
#' @export
#' @examples
#' alpha <- 0.025
#' p <- c(0.018, 0.01, 0.105, 0.006)
#' num_hyps <- length(p)
#' g <- bonferroni_holm(num_hyps)
#' weighting_strategy <- graph_generate_weights(g)
#' matrix_intersections <- weighting_strategy[, seq_len(num_hyps)]
#' matrix_weights <- weighting_strategy[, -seq_len(num_hyps)]
#'
#' adjust_weights_hochberg(
#'   matrix_weights = matrix_weights,
#'   matrix_intersections = matrix_intersections,
#'   p = p,
#'   test_groups = list(1:2, 3:4)
#' )
adjust_weights_hochberg <- function(matrix_weights,
                                    matrix_intersections,
                                    p,
                                    test_groups) {
  ordered_p <- order(p)

  ordered_matrix_weights <- matrix_weights[, ordered_p, drop = FALSE]

  ordered_matrix_intersections <-
    matrix_intersections[, ordered_p, drop = FALSE]

  group_lengths <- lengths(test_groups)
  group_adjusted_weights <- vector("list", length(test_groups))
  for (i in seq_along(test_groups)) {
    test_group <- ordered_p %in% test_groups[[i]]
    rev_group <- rev(seq_len(group_lengths[[i]]))

    group_weights <- ordered_matrix_weights[, test_group, drop = FALSE]

    group_total_weights <- matrixStats::rowSums2(group_weights)

    group_intersections <-
      ordered_matrix_intersections[, test_group, drop = FALSE]

    group_intersection_sums <-
      matrixStats::rowCumsums(
        group_intersections[, rev_group, drop = FALSE],
        useNames = TRUE
      )[, rev_group, drop = FALSE]

    group_adjusted_weights[[i]] <- group_total_weights / group_intersection_sums
    group_adjusted_weights[[i]][group_intersections == 0] <- 0
  }

  adjusted_weights <- do.call(cbind, group_adjusted_weights)

  adjusted_weights[, colnames(matrix_weights), drop = FALSE]
}

#' Find pairs of vertices that are connected in both directions
#'
#' @description
#' For an initial graph, find pairs of hypotheses that are connected in both
#' directions. This is used to plot graphs using [plot.initial_graph()].
#'
#' @inheritParams graph_update
#'
#' @return A list of vertex pairs which are connected in both directions. NULL
#'   if no such pairs are found.
#'
#' @rdname edge_pairs
#'
#' @keywords internal
#'
edge_pairs <- function(graph) {
  g_names <- names(graph$hypotheses)

  pair_indices <- graph$transitions > 0 & t(graph$transitions) > 0

  pair_nums <- which(pair_indices, arr.ind = TRUE, useNames = FALSE)

  if (nrow(pair_nums) > 0) {
    apply(
      pair_nums,
      1,
      function(row) paste(g_names[[row[[1]]]], g_names[[row[[2]]]], sep = "|"),
      simplify = FALSE
    )
  } else {
    NULL
  }
}

#' S3 plot method for the class `updated_graph`
#'
#' @description
#' Plotting an updated graph is a *very* light wrapper around
#' [plot.initial_graph()], only changing the default vertex color to use gray
#' for deleted hypotheses.
#'
#' @param x An object of class `updated_graph` to plot.
#' @inheritDotParams plot.initial_graph
#'
#' @return An object x of class `updated_graph`, after plotting the updated
#'   graph.
#'
#' @seealso
#'   [plot.initial_graph()] for the plot method for the initial graph.
#'
#' @rdname plot.updated_graph
#'
#' @export
#'
#' @references
#'   Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
#'   Rohmeyer, K. (2011). Graphical approaches for multiple comparison
#'   procedures using weighted Bonferroni, Simes, or parametric tests.
#'   \emph{Biometrical Journal}, 53(6), 894-913.
#'
#' @examplesIf requireNamespace("igraph", quietly = TRUE)
#' # A graphical multiple comparison procedure with two primary hypotheses (H1
#' # and H2) and two secondary hypotheses (H3 and H4)
#' # See Figure 1 in Bretz et al. (2011).
#' hypotheses <- c(0.5, 0.5, 0, 0)
#' transitions <- rbind(
#'   c(0, 0, 1, 0),
#'   c(0, 0, 0, 1),
#'   c(0, 1, 0, 0),
#'   c(1, 0, 0, 0)
#' )
#' g <- graph_create(hypotheses, transitions)
#'
#' # Delete the second and third hypotheses in the "unordered mode"
#' plot(
#'   graph_update(
#'     g,
#'     c(FALSE, TRUE, TRUE, FALSE)
#'   ),
#'   layout = "grid"
#' )
plot.updated_graph <- function(x, ...) {
  v_colors <- rep("#6baed6", length(x$updated_graph$hypotheses))
  v_colors[x$deleted] <- "#cccccc"

  plot(x$updated_graph, vertex.color = v_colors, ...)

  invisible(x)
}

1		#' Create the initial graph for a multiple comparison procedure
2		#'
3		#' @description
4		#' A graphical multiple comparison procedure is represented by 1) a vector of
5		#' initial hypothesis weights `hypotheses`, and 2) a matrix of initial
6		#' transition weights `transitions`. This function creates the initial graph
7		#' object using hypothesis weights and transition weights.
8		#'
9		#' @param hypotheses A numeric vector of hypothesis weights in a graphical
10		#' multiple comparison procedure. Must be a vector of values between 0 & 1
11		#' (inclusive). The length should match the row and column lengths of
12		#' `transitions`. The sum of hypothesis weights should not exceed 1.
13		#' @param transitions A numeric matrix of transition weights between hypotheses
14		#' in a graphical multiple comparison procedure. Must be a square matrix of
15		#' values between 0 & 1 (inclusive). The row and column lengths should match
16		#' the length of `hypotheses`. Each row (Transition weights leaving a
17		#' hypothesis) can sum to no more than 1. The diagonal entries (Transition
18		#' weights from a hypothesis to itself) must be all 0s.
19		#' @param hyp_names (Optional) A character vector of hypothesis names. If not
20		#' provided, names from `hypotheses` and `transitions` will be used. If names
21		#' are not specified, hypotheses will be named sequentially as H1, H2, .......
22		#'
23		#' @return An S3 object of class `initial_graph` with a list of 2 elements:
24		#' * Hypothesis weights `hypotheses`.
25		#' * Transition weights `transitions`.
26		#'
27		#' @section Validation of inputs:
28		#' Inputs are also validated to make sure of the validity of the graph:
29		#' * Hypothesis weights `hypotheses` are numeric.
30		#' * Transition weights `transitions` are numeric.
31		#' * Length of `hypotheses` and dimensions of `transitions` match.
32		#' * Hypothesis weights `hypotheses` must be non-negative and sum to no more
33		#' than 1.
34		#' * Transition weights `transitions`:
35		#' + Values must be non-negative.
36		#' + Rows must sum to no more than 1.
37		#' + Diagonal entries must be all 0.
38		#' * Hypothesis names `hyp_names` override names in `hypotheses` or
39		#' `transitions`.
40		#'
41		#' @seealso
42		#' [graph_update()] for the updated graph after hypotheses being deleted
43		#' from the initial graph.
44		#'
45		#' @rdname graph_create
46		#'
47		#' @export
48		#'
49		#' @references
50		#' Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
51		#' approach to sequentially rejective multiple test procedures.
52		#' \emph{Statistics in Medicine}, 28(4), 586-604.
53		#'
54		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
55		#' Rohmeyer, K. (2011). Graphical approaches for multiple comparison
56		#' procedures using weighted Bonferroni, Simes, or parametric tests.
57		#' \emph{Biometrical Journal}, 53(6), 894-913.
58		#'
59		#' @examples
60		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
61		#' # and H2) and two secondary hypotheses (H3 and H4)
62		#' # See Figure 1 in Bretz et al. (2011).
63		#' hypotheses <- c(0.5, 0.5, 0, 0)
64		#' transitions <- rbind(
65		#' c(0, 0, 1, 0),
66		#' c(0, 0, 0, 1),
67		#' c(0, 1, 0, 0),
68		#' c(1, 0, 0, 0)
69		#' )
70		#' hyp_names <- c("H11", "H12", "H21", "H22")
71		#' g <- graph_create(hypotheses, transitions, hyp_names)
72		#' g
73		#'
74		#' # Explicit names override names in `hypotheses` (with a warning)
75		#' hypotheses <- c(h1 = 0.5, h2 = 0.5, h3 = 0, h4 = 0)
76		#' transitions <- rbind(
77		#' c(0, 0, 1, 0),
78		#' c(0, 0, 0, 1),
79		#' c(0, 1, 0, 0),
80		#' c(1, 0, 0, 0)
81		#' )
82		#' g <- graph_create(hypotheses, transitions, hyp_names)
83		#' g
84		#'
85		#' # Use names in `transitions`
86		#' hypotheses <- c(0.5, 0.5, 0, 0)
87		#' transitions <- rbind(
88		#' H1 = c(0, 0, 1, 0),
89		#' H2 = c(0, 0, 0, 1),
90		#' H3 = c(0, 1, 0, 0),
91		#' H4 = c(1, 0, 0, 0)
92		#' )
93		#' g <- graph_create(hypotheses, transitions)
94		#' g
95		#'
96		#' # Unmatched names in `hypotheses` and `transitions` (with an error)
97		#' hypotheses <- c(h1 = 0.5, h2 = 0.5, h3 = 0, h4 = 0)
98		#' transitions <- rbind(
99		#' H1 = c(0, 0, 1, 0),
100		#' H2 = c(0, 0, 0, 1),
101		#' H3 = c(0, 1, 0, 0),
102		#' H4 = c(1, 0, 0, 0)
103		#' )
104		#' try(
105		#' g <- graph_create(hypotheses, transitions)
106		#' )
107		#'
108		#' # When names are not specified, hypotheses are numbered sequentially as
109		#' # H1, H2, ...
110		#' hypotheses <- c(0.5, 0.5, 0, 0)
111		#' transitions <- rbind(
112		#' c(0, 0, 1, 0),
113		#' c(0, 0, 0, 1),
114		#' c(0, 1, 0, 0),
115		#' c(1, 0, 0, 0)
116		#' )
117		#' g <- graph_create(hypotheses, transitions)
118		#' g
119		graph_create <- function(hypotheses, transitions, hyp_names = NULL) {
120		# Basic input validation -----------------------------------------------------
121	194x	stopifnot(
122	194x	"Hypothesis weights must be numeric" = is.numeric(hypotheses),
123	194x	"Transition weights must be numeric" = is.numeric(transitions)
124		)
125
126		if (
127	192x	any(
128	192x	nrow(transitions) != ncol(transitions),
129	192x	nrow(transitions) != length(hypotheses),
130	192x	ncol(transitions) != length(hypotheses)
131		)
132		) {
133	1x	stop("Length of `hypotheses`, rows of `transitions`, and columns of
134	1x	`transitions` must all match")
135		}
136
137		# Validation of names of hypotheses ----------------------------------------
138	191x	explicit_names <- !is.null(hyp_names)
139
140	191x	implicit_names <- any(
141	191x	!is.null(names(hypotheses)),
142	191x	!is.null(colnames(transitions)),
143	191x	!is.null(rownames(transitions))
144		)
145
146	191x	names_diff <- any(
147	191x	names(hypotheses) != colnames(transitions),
148	191x	names(hypotheses) != rownames(transitions),
149	191x	colnames(transitions) != rownames(transitions)
150		)
151
152	191x	if (implicit_names && explicit_names) {
153	1x	warning("Hypothesis names specified - overriding names in
154	1x	`hypotheses` and `transitions`")
155	190x	} else if (implicit_names && names_diff) {
156	1x	stop("Names provided in `hypotheses` and `transitions` should match")
157	189x	} else if (implicit_names) {
158	12x	hyp_names <- unique(
159	12x	c(names(hypotheses), colnames(transitions), rownames(transitions))
160		)
161	177x	} else if (!explicit_names) {
162	172x	hyp_names <- paste0("H", seq_along(hypotheses))
163		}
164
165	190x	names(hypotheses) <-
166	190x	colnames(transitions) <- rownames(transitions) <- hyp_names
167
168		# Validation of numerical conditions for a valid graphical multiple
169		# comparison procedure -----------------------------------------------------
170	190x	if (any(hypotheses < 0 \| hypotheses > 1)) {
171	6x	offending <- hypotheses[hypotheses < 0 \| hypotheses > 1]
172	6x	not_zero_float <- sapply(offending, function(x) !isTRUE(all.equal(0, x)))
173	6x	not_one_float <- sapply(offending, function(x) !isTRUE(all.equal(1, x)))
174
175	6x	if (any(not_zero_float & not_one_float)) {
176	4x	stop("Hypothesis weights must be between 0 and 1")
177		}
178		}
179
180	186x	if (sum(hypotheses) > 1 && !isTRUE(all.equal(sum(hypotheses), 1))) {
181	3x	stop("Hypothesis weights must sum to no more than 1")
182		}
183
184	183x	if (any(transitions < 0 \| transitions > 1)) {
185	6x	offending <- transitions[transitions < 0 \| transitions > 1, drop = TRUE]
186	6x	not_zero_float <- sapply(offending, function(x) !isTRUE(all.equal(0, x)))
187	6x	not_one_float <- sapply(offending, function(x) !isTRUE(all.equal(1, x)))
188
189	6x	if (any(not_zero_float & not_one_float)) {
190	4x	stop("Transition weights must be between 0 and 1")
191		}
192		}
193
194	179x	not_zero_float <- sapply(
195	179x	diag(transitions),
196	179x	function(x) !isTRUE(all.equal(0, x))
197		)
198
199	179x	if (any(not_zero_float)) {
200	3x	stop("Diagonal of transition weights must be all 0s")
201		}
202
203	176x	if (any(rowSums(transitions) > 1)) {
204	7x	not_one_float <- sapply(
205	7x	rowSums(transitions[rowSums(transitions) > 1, , drop = FALSE]),
206	7x	function(x) !isTRUE(all.equal(1, x))
207		)
208
209	7x	if (any(not_one_float)) {
210	3x	stop("Transition weights from each row must sum to no more than 1")
211		}
212		}
213
214		# Warn about very small transition weights that may cause numerical issues
215	173x	if (any(transitions > 0 & transitions < 1e-6)) {
216	2x	warning(
217	2x	"Some transition weights are very small (< 1e-6). This may cause ",
218	2x	"numerical instability in hypothesis weights due to floating-point ",
219	2x	"precision. Consider using larger values."
220		)
221		}
222
223		# Create an initial graph object ---------------------------------------------
224	173x	new_graph <- structure(
225	173x	list(hypotheses = hypotheses, transitions = transitions),
226	173x	class = "initial_graph",
227	173x	title = "Initial graph",
228	173x	deleted = NULL
229		)
230	173x	new_graph
231		}

1		#' Calculate the sequential p-value for a single hypothesis
2		#'
3		#' @description
4		#' A sequential p-value is the minimum significance level at which a group
5		#' sequential boundary would be crossed at any analysis up to and including the
6		#' current one. It is computed using the group sequential boundaries derived
7		#' from the spending function and the joint distribution of test statistics
8		#' across analyses.
9		#'
10		#' Sequential p-values are used in graphical multiple comparison procedures
11		#' for group sequential designs. They allow the separation of the group
12		#' sequential testing (handled by the spending function and boundaries) from
13		#' the multiplicity adjustment (handled by the graph). See Maurer and Bretz
14		#' (2013) for details.
15		#'
16		#' @param p A numeric vector of p-values at each analysis for a single
17		#' hypothesis. The length must match the length of `info_frac`. All values
18		#' must be non-missing and between 0 and 1.
19		#' @param info_frac A numeric vector of information fractions at each analysis.
20		#' Values must be in (0, 1] and monotonically non-decreasing. The length
21		#' should match the length of `p`.
22		#' @param spending_fn A spending function. Must accept two arguments:
23		#' `alpha` (total significance level) and `info_frac` (information fraction), and
24		#' return the cumulative alpha spent at information fraction `t`. Built-in
25		#' options include [spending_of()], [spending_pocock()], [spending_hsd()],
26		#' and [spending_linear()].
27		#' @param tol A numeric scalar for the tolerance of the root-finding
28		#' algorithm. The default is `1e-6`.
29		#' @param maxpts An integer scalar for the maximum number of function values
30		#' for `mvtnorm::GenzBretz`. The default is 25000.
31		#' @param abseps A numeric scalar for the absolute error tolerance for
32		#' `mvtnorm::GenzBretz`. The default is 1e-6.
33		#'
34		#' @return A numeric scalar of the sequential p-value.
35		#'
36		#' @details
37		#' For a hypothesis tested at analyses \eqn{k = 1, \ldots, K} with p-values
38		#' \eqn{p^{(k)}} and information fractions \eqn{t^{(k)}}, the sequential
39		#' p-value is the minimum \eqn{\tilde{p}} such that for some analysis
40		#' \eqn{k}, the observed p-value \eqn{p^{(k)}} crosses the group sequential
41		#' boundary \eqn{c_k(\tilde{p})} derived from the spending function:
42		#' \deqn{\tilde{p} = \min\{\alpha : p^{(k)} \le c_k(\alpha)
43		#' \text{ for some } k\},}
44		#' where \eqn{c_k(\alpha)} is the nominal p-value boundary at analysis
45		#' \eqn{k} when the total significance level is \eqn{\alpha}.
46		#'
47		#' The boundary \eqn{c_k(\alpha)} is computed from the spending function
48		#' \eqn{f(\alpha, t)} using the joint distribution of test statistics.
49		#' Specifically, the Z-scale boundary \eqn{b_k} satisfies
50		#' \deqn{P(Z_1 < b_1, \ldots, Z_k < b_k) = 1 - f(\alpha, t_k),}
51		#' and \eqn{c_k = 1 - \Phi(b_k)}. Note that \eqn{c_k \neq
52		#' f(\alpha, t_k) - f(\alpha, t_{k-1})} for \eqn{k > 1} due to the
53		#' correlation between test statistics across analyses.
54		#'
55		#' The sequential p-value is found using [stats::uniroot()] on the function
56		#' \eqn{g(\alpha) = \max_k (z_k - b_k(\alpha))}, where \eqn{z_k =
57		#' \Phi^{-1}(1 - p^{(k)})} is the observed Z-statistic and \eqn{b_k(\alpha)}
58		#' is the Z-scale boundary. This function is monotonically increasing in
59		#' \eqn{\alpha} since boundaries become less stringent as \eqn{\alpha}
60		#' increases.
61		#'
62		#' @seealso
63		#' [gs_boundaries()] for computing group sequential boundaries,
64		#' [graph_test_shortcut_gsd()] for graphical multiple comparison procedures
65		#' with group sequential designs, [spending_of()], [spending_pocock()],
66		#' [spending_hsd()], [spending_linear()] for spending functions.
67		#'
68		#' @rdname sequential_p
69		#'
70		#' @export
71		#'
72		#' @references
73		#' Maurer, W., and Bretz, F. (2013). Multiple testing in group sequential
74		#' trials using graphical approaches. \emph{Statistics in Biopharmaceutical
75		#' Research}, 5(4), 311-320.
76		#'
77		#' Liu, Q., and Anderson, K. M. (2008). On adaptive extensions of group
78		#' sequential trials for clinical investigations. \emph{Journal of the
79		#' American Statistical Association}, 103(484), 1621-1630.
80		#'
81		#' @examples
82		#' # A hypothesis tested at two analyses (interim at 50% and final at 100%)
83		#' sequential_p(
84		#' p = c(0.024, 0.01),
85		#' info_frac = c(0.5, 1),
86		#' spending_fn = spending_of
87		#' )
88		#'
89		#' # Sequential p-value with Pocock spending
90		#' sequential_p(
91		#' p = c(0.024, 0.01),
92		#' info_frac = c(0.5, 1),
93		#' spending_fn = spending_pocock
94		#' )
95		#'
96		#' # Sequential p-value updates as more analyses are conducted
97		#' # After analysis 1 only
98		#' sequential_p(
99		#' p = 0.05,
100		#' info_frac = 0.3,
101		#' spending_fn = spending_of
102		#' )
103		#'
104		#' # After analyses 1 and 2
105		#' sequential_p(
106		#' p = c(0.05, 0.02),
107		#' info_frac = c(0.3, 0.7),
108		#' spending_fn = spending_of
109		#' )
110		#'
111		#' # After all three analyses
112		#' sequential_p(
113		#' p = c(0.05, 0.02, 0.01),
114		#' info_frac = c(0.3, 0.7, 1),
115		#' spending_fn = spending_of
116		#' )
117		sequential_p <- function(p,
118		info_frac,
119		spending_fn,
120		tol = 1e-6,
121		maxpts = 25000,
122		abseps = 1e-6) {
123	21x	stopifnot(
124	21x	"p must be a numeric vector" = is.numeric(p),
125	21x	"p must not contain NA" = !anyNA(p),
126	21x	"p must be between 0 and 1" = all(p >= 0 & p <= 1),
127	21x	"info_frac must be a numeric vector" = is.numeric(info_frac),
128	21x	"info_frac must not contain NA" = !anyNA(info_frac),
129	21x	"p and info_frac must have the same length" = length(info_frac) == length(p)
130		)
131
132		# Convert observed p-values to Z-statistics
133	21x	z_obs <- stats::qnorm(1 - p)
134
135		# For a candidate alpha, compute boundaries and return the maximum
136		# exceedance: max_k(z_obs[k] - b_k(alpha)).
137		# Positive means at least one boundary is crossed.
138		# This function is monotonically increasing in alpha since boundaries
139		# decrease (become less stringent) as alpha increases.
140	21x	max_exceedance <- function(alpha_candidate) {
141	248x	bounds <- gs_boundaries(
142	248x	alpha = alpha_candidate,
143	248x	info_frac = info_frac,
144	248x	spending_fn = spending_fn,
145	248x	maxpts = maxpts,
146	248x	abseps = abseps
147		)
148
149	245x	max(z_obs - bounds$bounds_z)
150		}
151
152		# Check edge cases before root-finding.
153		# The search interval is [lower, upper] = [tol, 1 - tol] to avoid
154		# numerical issues at the exact boundaries 0 and 1.
155	21x	upper <- 1 - tol
156	21x	lower <- tol
157
158		# If no boundary is crossed even at the most lenient alpha (~1),
159		# the observed p-values are too large to ever be significant.
160		# Return 1 (the largest possible sequential p-value).
161	21x	exc_upper <- tryCatch(
162	21x	max_exceedance(upper),
163	21x	error = function(e) NA_real_
164		)
165	21x	if (is.na(exc_upper) \|\| exc_upper <= 0) {
166	1x	message("No boundary crossed; returning 1 as an upper bound.")
167	1x	return(1)
168		}
169
170		# If a boundary is already crossed at the most stringent alpha (~0),
171		# the observed p-values are extremely small. Return the lower bound.
172		# Use >= 0 to also handle the edge case where the exceedance is exactly 0
173		# (boundary exactly crossed), which would cause uniroot to fail because
174		# f(lower) and f(upper) would have the same sign.
175	20x	exc_lower <- tryCatch(
176	20x	max_exceedance(lower),
177	20x	error = function(e) {
178		# gs_boundaries can fail at very small alpha due to numerical issues
179		# in pmvnorm. Treat this as the boundary being extremely large
180		# (i.e., not crossed), so exceedance is negative.
181	1x	-1
182		}
183		)
184	20x	if (exc_lower >= 0) {
185	2x	message(
186	2x	"Boundary crossed at alpha = ", lower,
187	2x	"; returning ", lower, " as a lower bound."
188		)
189	2x	return(lower)
190		}
191
192		# Find the root: minimum alpha where boundary is crossed.
193		# Wrap in tryCatch to handle numerical edge cases in uniroot.
194	18x	result <- tryCatch(
195	18x	stats::uniroot(
196	18x	max_exceedance,
197	18x	interval = c(lower, upper),
198	18x	tol = tol
199		),
200	18x	error = function(e) {
201		# If uniroot fails, try with a wider lower bound
202	1x	tryCatch(
203	1x	stats::uniroot(
204	1x	max_exceedance,
205	1x	interval = c(lower * 10, upper),
206	1x	tol = tol
207		),
208	1x	error = function(e2) {
209	1x	message(
210	1x	"Root-finding failed; returning ", lower,
211	1x	" as a lower bound. Original error: ", e$message
212		)
213	1x	list(root = lower)
214		}
215		)
216		}
217		)
218
219	18x	result$root
220		}

1		#' Perform closed graphical multiple comparison procedures
2		#'
3		#' @description
4		#' Closed graphical multiple comparison procedures, or graphical multiple
5		#' comparison procedures based on the closure, generate the closure based on a
6		#' graph consisting of all intersection hypotheses. It tests each intersection
7		#' hypothesis and rejects an individual hypothesis if all intersection
8		#' hypotheses involving it have been rejected. An intersection hypothesis
9		#' represents the parameter space where individual null hypotheses involved are
10		#' true simultaneously.
11		#'
12		#' For a graphical multiple comparison procedure with $m$ hypotheses, there are
13		#' \eqn{2^m-1} intersection hypotheses. For each intersection hypothesis, a test
14		#' type could be chosen to determine how to reject the intersection hypothesis.
15		#' Current choices of test types include Bonferroni, Simes and parametric. This
16		#' implementation offers a more general framework covering Bretz et al. (2011),
17		#' Lu (2016), and Xi et al. (2017). See `vignette("closed-testing")` for more
18		#' illustration of closed test procedures and interpretation of their outputs.
19		#'
20		#' @inheritParams graph_update
21		#' @param p A numeric vector of p-values (unadjusted, raw), whose values should
22		#' be between 0 & 1. The length should match the number of hypotheses in
23		#' `graph`.
24		#' @param alpha A numeric value of the overall significance level, which should
25		#' be between 0 & 1. The default is 0.025 for one-sided hypothesis testing
26		#' problems; another common choice is 0.05 for two-sided hypothesis testing
27		#' problems. Note when parametric tests are used, only one-sided tests are
28		#' supported.
29		#' @param test_groups A list of numeric vectors specifying hypotheses to test
30		#' together. Grouping is needed to correctly perform Simes and parametric
31		#' tests.
32		#' @param test_types A character vector of test types to apply to each test
33		#' group. This is needed to correctly perform Simes and parametric
34		#' tests. The length should match the number of elements in `test_groups`.
35		#' @param test_corr (Optional) A list of numeric correlation matrices. Each
36		#' entry in the list should correspond to each test group. For a test group
37		#' using Bonferroni or Simes tests, its corresponding entry in `test_corr`
38		#' should be `NA`. For a test group using parametric tests, its
39		#' corresponding entry in `test_corr` should be a numeric correlation matrix
40		#' specifying the correlation between test statistics for hypotheses in this
41		#' test group. The length should match the number of elements in
42		#' `test_groups`.
43		#' @param verbose A logical scalar specifying whether the details of the
44		#' adjusted p-value calculations should be included in results. When
45		#' `verbose = TRUE`, adjusted p-values are provided for each intersection
46		#' hypothesis. The default is `verbose = FALSE`.
47		#' @param test_values A logical scalar specifying whether adjusted significance
48		#' levels should be provided for each hypothesis. When `test_values = TRUE`,
49		#' it provides an equivalent way of performing graphical multiple comparison
50		#' procedures by comparing each p-value with its significance level. If the
51		#' p-value of a hypothesis is less than or equal to its significance level,
52		#' the hypothesis is rejected. The default is `test_values = FALSE`.
53		#'
54		#' @return A `graph_report` object with a list of 4 elements:
55		#' * `inputs` - Input parameters, which is a list of:
56		#' * `graph` - Initial graph,
57		#' * `p` - (Unadjusted or raw) p-values,
58		#' * `alpha` - Overall significance level,
59		#' * `test_groups` - Groups of hypotheses for different types of tests,
60		#' * `test_types` - Different types of tests,
61		#' * `test_corr` - Correlation matrices for parametric tests.
62		#' * `outputs` - Output parameters, which is a list of:
63		#' * `adjusted_p` - Adjusted p-values,
64		#' * `rejected` - Rejected hypotheses,
65		#' * `graph` - Updated graph after deleting all rejected hypotheses.
66		#' * `details` - Verbose outputs with adjusted p-values for intersection
67		#' hypotheses, if `verbose = TRUE`.
68		#' * `test_values` - Adjusted significance levels, if `test_values = TRUE`.
69		#'
70		#' @section Details for test specification:
71		#' Test specification includes three components: `test_groups`, `test_types`,
72		#' and `test_corr`. Alignment among entries in these components is important
73		#' for correct implementation. There are two ways to provide test specification.
74		#' The first approach is the "unnamed" approach, which assumes that all 3
75		#' components are ordered the same way, i.e., the $n$-th element of `test_types`
76		#' and `test_corr` should apply to the $n$-th group in `test_groups`. The
77		#' second "named" approach uses the name of each element of each component to
78		#' connect the element of `test_types` and `test_corr` with the correct element
79		#' of `test_groups`. Consistency should be ensured for correct implementation.
80		#'
81		#' @seealso
82		#' [graph_test_shortcut()] for shortcut graphical multiple comparison
83		#' procedures.
84		#'
85		#' @rdname graph_test_closure
86		#'
87		#' @export
88		#'
89		#' @references
90		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
91		#' Rohmeyer, K. (2011). Graphical approaches for multiple comparison
92		#' procedures using weighted Bonferroni, Simes, or parametric tests.
93		#' \emph{Biometrical Journal}, 53(6), 894-913.
94		#'
95		#' Lu, K. (2016). Graphical approaches using a Bonferroni mixture of weighted
96		#' Simes tests. \emph{Statistics in Medicine}, 35(22), 4041-4055.
97		#'
98		#' Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework
99		#' for weighted parametric multiple test procedures.
100		#' \emph{Biometrical Journal}, 59(5), 918-931.
101		#'
102		#' @examples
103		#' # A graphical multiple comparison procedure with two primary hypotheses
104		#' # (H1 and H2) and two secondary hypotheses (H3 and H4)
105		#' # See Figure 4 in Bretz et al. (2011).
106		#' hypotheses <- c(0.5, 0.5, 0, 0)
107		#' delta <- 0.5
108		#' transitions <- rbind(
109		#' c(0, delta, 1 - delta, 0),
110		#' c(delta, 0, 0, 1 - delta),
111		#' c(0, 1, 0, 0),
112		#' c(1, 0, 0, 0)
113		#' )
114		#' g <- graph_create(hypotheses, transitions)
115		#'
116		#' p <- c(0.018, 0.01, 0.105, 0.006)
117		#' alpha <- 0.025
118		#'
119		#' # Closed graphical multiple comparison procedure using Bonferroni tests
120		#' # Same results as `graph_test_shortcut(g, p, alpha)`
121		#' graph_test_closure(g, p, alpha)
122		#'
123		#' # Closed graphical multiple comparison procedure using parametric tests for
124		#' # H1 and H2, and Bonferroni tests for H3 and H4
125		#' set.seed(1234)
126		#' corr_list <- list(matrix(c(1, 0.5, 0.5, 1), nrow = 2), NA)
127		#' graph_test_closure(
128		#' graph = g,
129		#' p = p,
130		#' alpha = alpha,
131		#' test_groups = list(1:2, 3:4),
132		#' test_types = c("parametric", "bonferroni"),
133		#' test_corr = corr_list
134		#' )
135		#' # The "named" approach to obtain the same results
136		#' # Note that "group2" appears before "group1" in `test_groups`
137		#' set.seed(1234)
138		#' corr_list <- list(group1 = matrix(c(1, 0.5, 0.5, 1), nrow = 2), group2 = NA)
139		#' graph_test_closure(
140		#' graph = g,
141		#' p = p,
142		#' alpha = alpha,
143		#' test_groups = list(group1 = 1:2, group2 = 3:4),
144		#' test_types = c(group2 = "bonferroni", group1 = "parametric"),
145		#' test_corr = corr_list
146		#' )
147		#'
148		#' # Closed graphical multiple comparison procedure using parametric tests for
149		#' # H1 and H2, and Simes tests for H3 and H4
150		#' set.seed(1234)
151		#' graph_test_closure(
152		#' graph = g,
153		#' p = p,
154		#' alpha = alpha,
155		#' test_groups = list(group1 = 1:2, group2 = 3:4),
156		#' test_types = c(group1 = "parametric", group2 = "simes"),
157		#' test_corr = corr_list
158		#' )
159		graph_test_closure <- function(graph,
160		p,
161		alpha = 0.025,
162		test_groups = list(seq_along(graph$hypotheses)),
163		test_types = c("bonferroni"),
164		test_corr = rep(list(NA), length(test_types)),
165		verbose = FALSE,
166		test_values = FALSE) {
167		# Input validation & sanitization --------------------------------------------
168		# Test types should be specified as full names or first initial,
169		# case-insensitive. A single provided test type should be applied to all
170		# groups.
171	57x	test_types_names <- names(test_types)
172	57x	test_opts <- c(
173	57x	bonferroni = "bonferroni",
174	57x	parametric = "parametric",
175	57x	simes = "simes",
176	57x	hochberg = "hochberg",
177	57x	b = "bonferroni",
178	57x	p = "parametric",
179	57x	s = "simes",
180	57x	h = "hochberg"
181		)
182	57x	test_types <- test_opts[tolower(test_types)]
183	57x	names(test_types) <- test_types_names
184	57x	if (length(test_types) == 1) {
185	32x	test_types <- rep(test_types, length(test_groups))
186		}
187
188	57x	test_input_val(
189	57x	graph,
190	57x	p,
191	57x	alpha,
192	57x	test_groups,
193	57x	test_types,
194	57x	test_corr,
195	57x	verbose,
196	57x	test_values
197		)
198
199		# The test specification arguments can be named or not. However, if
200		# `test_groups` is named, all of them must be named. The other two are
201		# re-ordered to match `test_groups`
202	40x	if (!is.null(names(test_groups))) {
203	1x	if (!all(c(names(test_types), names(test_corr)) %in% names(test_groups))) {
204	!	stop("If `test_groups` is named, `test_types` and `test_corr` must use the
205	!	same names")
206		} else {
207	1x	test_types <- test_types[names(test_groups)]
208	1x	test_corr <- test_corr[names(test_groups)]
209		}
210		} else {
211	39x	names(test_groups) <-
212	39x	names(test_types) <-
213	39x	names(test_corr) <-
214	39x	paste0("grp", seq_along(test_groups))
215		}
216
217	40x	num_hyps <- length(graph$hypotheses)
218	40x	num_groups <- length(test_groups)
219
220	40x	hyp_names <- names(graph$hypotheses)
221	40x	names(p) <- hyp_names
222
223		# Correlation matrix input is easier for end users to input as a list, but
224		# it's easier to work with internally as a full matrix, potentially with
225		# missing values. This puts all the correlation pieces into one matrix
226	40x	new_corr <- matrix(NA, num_hyps, num_hyps)
227
228	40x	for (group_num in seq_along(test_groups)) {
229	54x	new_corr[test_groups[[group_num]], test_groups[[group_num]]] <-
230	54x	test_corr[[group_num]]
231		}
232	40x	diag(new_corr) <- 1
233	40x	test_corr <- if (any(test_types == "parametric")) new_corr else NULL
234
235	12x	if (!is.null(test_corr)) dimnames(test_corr) <- list(hyp_names, hyp_names)
236
237		# Generate weights of the closure --------------------------------------------
238	40x	weighting_strategy <- graph_generate_weights(graph)
239	40x	matrix_intersections <- weighting_strategy[, seq_len(num_hyps), drop = FALSE]
240
241		# "Compact" representation shows hypothesis weights where a hypothesis is
242		# present (even when that weight is 0), and NA where a hypothesis is missing.
243		# This form represents the closure with only `num_hyps` columns
244	40x	weighting_strategy_compact <- ifelse(
245	40x	matrix_intersections,
246	40x	weighting_strategy[, seq_len(num_hyps) + num_hyps, drop = FALSE],
247	40x	NA_real_
248		)
249
250	40x	num_intersections <- nrow(matrix_intersections)
251
252	40x	adjusted_p <- matrix(
253	40x	NA_real_,
254	40x	nrow = num_intersections,
255	40x	ncol = num_groups,
256	40x	dimnames = list(NULL, paste0("adj_p_grp", seq_along(test_groups)))
257		)
258
259		# Calculate adjusted p-values ------------------------------------------------
260		# Adjusted p-values are calculated for each group in each intersection of the
261		# closure
262	40x	for (intersection_index in seq_len(num_intersections)) {
263	1348x	vec_intersection <- matrix_intersections[intersection_index, , drop = TRUE]
264	1348x	vec_weights <-
265	1348x	weighting_strategy_compact[intersection_index, , drop = TRUE]
266
267	1348x	for (group_index in seq_len(num_groups)) {
268	1798x	group <- test_groups[[group_index]]
269	1798x	test <- test_types[[group_index]]
270
271		# Hypotheses to include in adjusted p-value calculations must be in both
272		# the current group and the current intersection
273	1798x	group_by_intersection <- group[as.logical(vec_intersection[group])]
274
275		# The adjusted p-value for a group has varying rules depending on the
276		# test type. Each `adjust_p_*` function expects a whole group as input and
277		# returns a single value as output (adjusted p-value for the whole group)
278	1798x	if (test == "bonferroni") {
279	891x	adjusted_p[[intersection_index, group_index]] <- adjust_p_bonferroni(
280	891x	p[group_by_intersection],
281	891x	vec_weights[group_by_intersection]
282		)
283	907x	} else if (test == "simes") {
284	468x	adjusted_p[[intersection_index, group_index]] <- adjust_p_simes(
285	468x	p[group_by_intersection],
286	468x	vec_weights[group_by_intersection]
287		)
288	439x	} else if (test == "hochberg") {
289	15x	adjusted_p[[intersection_index, group_index]] <- adjust_p_hochberg(
290	15x	p[group_by_intersection],
291	15x	vec_weights[group_by_intersection]
292		)
293	424x	} else if (test == "parametric") {
294	424x	adjusted_p[[intersection_index, group_index]] <- adjust_p_parametric(
295	424x	p[group_by_intersection],
296	424x	vec_weights[group_by_intersection],
297	424x	test_corr[group_by_intersection, group_by_intersection, drop = FALSE]
298		)
299		} else {
300	!	stop(paste(test, "testing is not supported at this time"))
301		}
302		}
303		}
304
305		# Adjusted p-value summaries -------------------------------------------------
306		# The adjusted p-value for an intersection is the smallest adjusted p-value
307		# for the groups it contains
308	40x	adjusted_p_intersection <- apply(adjusted_p, 1, min)
309
310		# When parametric tests are used, mvtnorm::pmvnorm introduces Monte Carlo
311		# error (controlled by abseps, default 1e-6). A small tolerance is added to
312		# rejection comparisons to avoid false non-rejections at the boundary.
313	40x	tol <- if (any(test_types == "parametric")) 1e-6 else .Machine$double.eps
314
315	40x	reject_intersection <- adjusted_p_intersection <= (alpha + tol)
316
317		# The adjusted p-value for a hypothesis is the largest adjusted p-value for
318		# the intersections containing that hypothesis
319	40x	adjusted_p_hypothesis <-
320	40x	apply(adjusted_p_intersection * matrix_intersections, 2, max, na.rm = TRUE)
321	40x	reject_hypothesis <- adjusted_p_hypothesis <= (alpha + tol)
322
323		# Adjusted p-value details ---------------------------------------------------
324		# Reported adjusted p-values shouldn't exceed 1
325	40x	intersections <- apply(matrix_intersections, 1, paste, collapse = "")
326
327	40x	detail_results <- list(
328	40x	results = cbind(
329	40x	data.frame(Intersection = intersections),
330	40x	weighting_strategy_compact,
331	40x	pmin(adjusted_p, 1 + 1e-14),
332	40x	data.frame(adj_p_inter = pmin(adjusted_p_intersection, 1 + 1e-14)),
333	40x	data.frame(reject_intersection = reject_intersection)
334		)
335		)
336
337		# Adjusted weight details ----------------------------------------------------
338	40x	if (test_values) {
339		# Adjusted weights are recorded in a dataframe, which doesn't store in a
340		# matrix. So for the test values loops, each group's adjusted weight
341		# dataframe is stored in a list. These are the initialized list and counter
342		# for indexing into it.
343	9x	test_values_index <- 1
344	9x	test_values_list <- vector("list", num_intersections * num_groups)
345
346		# Adjusted weights are calculated for each group in each intersection of the
347		# closure
348	9x	for (intersection_index in seq_len(num_intersections)) {
349	223x	vec_intersection <-
350	223x	matrix_intersections[intersection_index, , drop = TRUE]
351	223x	vec_weights <-
352	223x	weighting_strategy_compact[intersection_index, , drop = TRUE]
353
354	223x	str_intersection <- paste(vec_intersection, collapse = "")
355
356	223x	for (group_index in seq_len(num_groups)) {
357	424x	group <- test_groups[[group_index]]
358	424x	test <- test_types[[group_index]]
359
360		# Hypotheses to include in adjusted weight calculations must be in both
361		# the current group and the current intersection
362	424x	group_by_intersection <- group[as.logical(vec_intersection[group])]
363
364		# adjusted weights, like adjusted p-values, must be calculated at both
365		# the group and intersection level. Inputs are for a single group, and
366		# output is a dataframe containing adjusted weight test information at
367		# the hypothesis/operand level.
368	424x	if (test == "bonferroni") {
369	186x	test_values_list[[test_values_index]] <- test_values_bonferroni(
370	186x	p[group_by_intersection],
371	186x	vec_weights[group_by_intersection],
372	186x	alpha,
373	186x	str_intersection
374		)
375	238x	} else if (test == "simes") {
376	108x	test_values_list[[test_values_index]] <- test_values_simes(
377	108x	p[group_by_intersection],
378	108x	vec_weights[group_by_intersection],
379	108x	alpha,
380	108x	str_intersection
381		)
382	130x	} else if (test == "hochberg") {
383	!	test_values_list[[test_values_index]] <- test_values_hochberg(
384	!	p[group_by_intersection],
385	!	vec_weights[group_by_intersection],
386	!	alpha,
387	!	str_intersection
388		)
389	130x	} else if (test == "parametric") {
390	130x	test_values_list[[test_values_index]] <- test_values_parametric(
391	130x	p[group_by_intersection],
392	130x	vec_weights[group_by_intersection],
393	130x	alpha,
394	130x	str_intersection,
395	130x	test_corr[group_by_intersection,
396	130x	group_by_intersection,
397	130x	drop = FALSE
398		]
399		)
400		} else {
401	!	stop(paste(test, "testing is not supported at this time"))
402		}
403
404	424x	test_values_index <- test_values_index + 1
405		}
406		}
407
408	9x	df_test_values <- do.call(rbind, test_values_list)
409	9x	rownames(df_test_values) <- NULL
410
411		# sort by hypothesis natural order
412	9x	df_test_values$Hypothesis <-
413	9x	factor(df_test_values$Hypothesis, levels = hyp_names, ordered = TRUE)
414
415	9x	df_test_values <-
416	9x	df_test_values[with(df_test_values, order(-as.numeric(Intersection), Hypothesis)), ]
417
418		# "c" value is only used in parametric testing, so there's no need to
419		# include this column when there are no parametric groups
420	9x	if (!any(test_types == "parametric")) {
421	4x	df_test_values[c("c_value")] <- NULL
422		}
423		}
424
425		# Build the report -----------------------------------------------------------
426		# The core output of a test report is the adjusted p-values, rejection
427		# decisions, and resulting graph after deleting all rejected hypotheses.
428		# Inputs are recorded as well. Details about adjusted p-values and test
429		# values are optionally available.
430	40x	structure(
431	40x	list(
432	40x	inputs = list(
433	40x	graph = graph,
434	40x	p = p,
435	40x	alpha = alpha,
436	40x	test_groups = test_groups,
437	40x	test_types = test_types,
438	40x	test_corr = test_corr
439		),
440	40x	outputs = list(
441	40x	adjusted_p = pmin(adjusted_p_hypothesis, 1 + 1e-14), # Cap reported at 1
442	40x	rejected = reject_hypothesis,
443	40x	graph = graph_update(graph, reject_hypothesis)$updated_graph
444		),
445	40x	details = if (verbose) detail_results,
446	40x	test_values = if (test_values) list(results = df_test_values)
447		),
448	40x	class = "graph_report"
449		)
450		}

1		#' Validate inputs for testing and power simulations
2		#'
3		#' @param graph An initial graph as returned by [graph_create()].
4		#' @param p A numeric vector of p-values (unadjusted, raw), whose values should
5		#' be between 0 & 1. The length should match the number of hypotheses in
6		#' `graph`.
7		#' @param alpha A numeric value of the overall significance level, which should
8		#' be between 0 & 1. The default is 0.025 for one-sided hypothesis testing
9		#' problems; another common choice is 0.05 for two-sided hypothesis testing
10		#' problems. Note when parametric tests are used, only one-sided tests are
11		#' supported.
12		#' @param test_groups A list of numeric vectors specifying hypotheses to test
13		#' together. Grouping is needed to correctly perform Simes and parametric
14		#' tests.
15		#' @param test_types A character vector of test types to apply to each test
16		#' group. This is needed to correctly perform Simes and parametric
17		#' tests. The length should match the number of elements in `test_groups`.
18		#' @param test_corr (Optional) A list of numeric correlation matrices. Each
19		#' entry in the list should correspond to each test group. For a test group
20		#' using Bonferroni or Simes tests, its corresponding entry in `test_corr`
21		#' should be `NA`. For a test group using parametric tests, its
22		#' corresponding entry in `test_corr` should be a numeric correlation matrix
23		#' specifying the correlation between test statistics for hypotheses in this
24		#' test group. The length should match the number of elements in
25		#' `test_groups`.
26		#' @param verbose A logical scalar specifying whether the details of the
27		#' adjusted p-value calculations should be included in results. When
28		#' `verbose = TRUE`, adjusted p-values are provided for each intersection
29		#' hypothesis. The default is `verbose = FALSE`.
30		#' @param test_values A logical scalar specifying whether adjusted significance
31		#' levels should be provided for each hypothesis. When `test_values = TRUE`,
32		#' it provides an equivalent way of performing graphical multiple comparison
33		#' procedures by comparing each p-value with its significance level. If the
34		#' p-value of a hypothesis is less than or equal to its significance level,
35		#' the hypothesis is rejected. The default is `test_values = FALSE`.
36		#' @param sim_n An integer scalar specifying the number of simulations. The
37		#' default is 1e5.
38		#' @param power_marginal A numeric vector of marginal power values to use when
39		#' simulating p-values. See Details for more on the simulation process.
40		#' @param success A list of user-defined functions to specify the success
41		#' criteria. Functions must take one simulation's logical vector of results as
42		#' an input, and return a length-one logical vector. For instance, if
43		#' "success" means rejecting hypotheses 1 and 2, use `sim_success = list("1
44		#' and 2" = function(x) x[1] && x[2])`. If the list is not named, the function
45		#' body will be used as the name. Lambda functions also work starting with R
46		#' 4.1, e.g. `sim_success = list(\(x) x[3] \|\| x[4])`.
47		#'
48		#' @return Returns `graph` invisibly
49		#'
50		#' @rdname input_val
51		#'
52		#' @keywords internal
53		test_input_val <- function(graph,
54		p,
55		alpha,
56		test_groups = list(seq_along(graph$hypotheses)),
57		test_types = c("bonferroni"),
58		test_corr,
59		verbose,
60		test_values) {
61	235x	test_opts <- c(
62	235x	bonferroni = "bonferroni",
63	235x	parametric = "parametric",
64	235x	simes = "simes",
65	235x	hochberg = "hochberg",
66	235x	b = "bonferroni",
67	235x	p = "parametric",
68	235x	s = "simes",
69	235x	h = "hochberg"
70		)
71
72	235x	corr_is_matrix_list <- is.list(test_corr) &&
73	235x	all(
74	235x	vapply(test_corr, function(elt) is.matrix(elt) \|\| is.na(elt), logical(1))
75		)
76
77	235x	stopifnot(
78	235x	"Please test an `initial_graph` object" = class(graph) == "initial_graph",
79	235x	"P-values must be numeric" = is.numeric(p),
80	235x	"P-values must be between 0 & 1" = all(p >= 0 & p <= 1),
81	235x	"Alpha must be numeric" = is.numeric(alpha),
82	235x	"Please choose a single alpha level for testing" = length(alpha) == 1,
83	235x	"Alpha must be between 0 & 1" = alpha >= 0 && alpha <= 1,
84	235x	"Only Bonferroni, parametric, Simes, or Hochberg tests are currently supported" =
85	235x	all(test_types %in% test_opts),
86	235x	"Groups specification must be a list" = is.list(test_groups),
87	235x	"Please include each hypothesis in exactly one group" =
88	235x	setequal(seq_along(graph$hypotheses), unlist(test_groups)) &&
89	235x	length(graph$hypotheses) == length(unlist(test_groups)),
90	235x	"Correlation matrix should be a list of matrices or missing values" =
91	235x	corr_is_matrix_list,
92	235x	"Number of test types, groups, and correlation matrices should match" =
93	235x	unique(length(test_types), length(test_groups)) == length(test_corr),
94	235x	"Length of p-values & groups must match the number of hypotheses" =
95	235x	unique(length(p), length(unlist(test_groups))) ==
96	235x	length(graph$hypotheses),
97	235x	"Verbose flag must be a length one logical" =
98	235x	is.logical(verbose) && length(verbose) == 1,
99	235x	"Test values flag must be a length one logical" =
100	235x	is.logical(test_values) && length(test_values) == 1
101		)
102
103		# Additional correlation matrix checks ---------------------------------------
104	221x	if (is.null(names(test_types))) {
105	217x	corr_parametric <- test_corr[test_types == "parametric"]
106		} else {
107	4x	corr_parametric <- test_corr[names(test_types)[test_types == "parametric"]]
108		}
109
110	221x	missing_corr <- any(
111	221x	vapply(corr_parametric, function(cr) any(is.na(cr)), logical(1))
112		)
113
114	221x	symmetric_corr <- all(vapply(corr_parametric, isSymmetric.matrix, logical(1)))
115
116	221x	bounded_corr <- all(
117	221x	vapply(corr_parametric, function(cr) all(cr >= 0 & cr <= 1), logical(1))
118		)
119
120		# Positive definite-ness is irrelevant if there are missing values, and
121		# testing for it will throw an error
122	221x	positive_definite_corr <- ifelse(
123	221x	!missing_corr,
124	221x	all(
125	221x	vapply(
126	221x	corr_parametric,
127	221x	function(cr) all(round(eigen(cr)$values, 10) >= 0),
128	221x	logical(1)
129		)
130		),
131	221x	TRUE
132		)
133
134	220x	stopifnot(
135	220x	"Correlation matrix for parametric test groups must be fully specified" =
136	220x	!missing_corr,
137	220x	"Correlation matrix must be symmetric" = symmetric_corr,
138	220x	"Dimensions of correlation matrices must match the parametric test groups" =
139	220x	all(
140	220x	lengths(test_corr[names(test_types)[test_types == "parametric"]]) ==
141	220x	lengths(test_groups[names(test_types)[test_types == "parametric"]])^2
142		),
143	220x	"Correlation values must be between 0 & 1" = bounded_corr,
144	220x	"Correlation matrix must be positive definite for parametric test groups" =
145	220x	positive_definite_corr
146		)
147
148		# Additional Hochberg checks -------------------------------------------------
149	218x	if (is.null(names(test_types))) {
150	215x	groups_hochberg <- test_groups[test_types == "hochberg"]
151		} else {
152	3x	groups_hochberg <- test_groups[names(test_types)[test_types == "hochberg"]]
153		}
154
155	218x	num_hyps <- length(graph$hypotheses)
156	218x	weighting_strategy <- graph_generate_weights(graph)
157	218x	matrix_intersections <- weighting_strategy[, seq_len(num_hyps)]
158	218x	matrix_weights <- weighting_strategy[, -seq_len(num_hyps)]
159	218x	weighting_strategy_compact <- ifelse(
160	218x	matrix_intersections,
161	218x	matrix_weights,
162	218x	NA_real_
163		)
164
165	218x	hochberg_weights_all_equal <- TRUE
166	218x	for (row in seq_len(nrow(weighting_strategy_compact))) {
167	5182x	for (group in groups_hochberg) {
168	15x	hypotheses <- weighting_strategy_compact[row, group, drop = TRUE]
169	15x	hypotheses <- hypotheses[!is.na(hypotheses)]
170
171	15x	hypotheses_all_equal <- length(unique(hypotheses)) <= 1
172
173	15x	hochberg_weights_all_equal <-
174	15x	hochberg_weights_all_equal && hypotheses_all_equal
175		}
176		}
177
178	218x	stopifnot(
179	218x	"Each Hochberg group must have uniform weights in all subgraphs" =
180	218x	hochberg_weights_all_equal
181		)
182
183	218x	invisible(graph)
184		}
185
186		#' @rdname input_val
187		#' @keywords internal
188		power_input_val <- function(graph, sim_n, power_marginal, test_corr, success) {
189	28x	num_hyps <- length(graph$hypotheses)
190
191	28x	stopifnot(
192	28x	"Number of simulations must be a length one integer" =
193	28x	is.numeric(sim_n) && as.integer(sim_n) == sim_n && length(sim_n) == 1,
194	28x	"Marginal power must be between 0 and 1" =
195	28x	all(power_marginal >= 0 & power_marginal <= 1),
196	28x	"Marginal power and correlation parameters must be numeric" =
197	28x	is.numeric(power_marginal) && is.numeric(test_corr),
198	28x	"Lengths of marginal power must match number of hypotheses" =
199	28x	length(power_marginal) == num_hyps,
200	28x	"Correlation matrix for simulating p-values must match no. of hypotheses" =
201	28x	unique(nrow(test_corr), ncol(test_corr)) == num_hyps,
202	28x	"Correlation matrix for simulating p-values cannot have missing values" =
203	28x	!any(is.na(test_corr)),
204	28x	"Correlation matrix for simulating p-values must be symmetric" =
205	28x	isSymmetric.matrix(test_corr),
206	28x	"Correlation matrix for simulating p-values must have diagonal all 1" =
207	28x	all(diag(test_corr) == 1),
208	28x	"Correlation matrix for simulating p-values must be positive definite" =
209	28x	all(round(eigen(test_corr)$values, 10) >= 0),
210	28x	"'sim_success' must be a list of functions" =
211	28x	all(vapply(success, is.function, logical(1)))
212		)
213
214	20x	invisible(graph)
215		}

1		#' Compute group sequential boundaries from an alpha spending function
2		#'
3		#' @description
4		#' Given a significance level, information fractions, and a spending function,
5		#' compute the group sequential boundaries at each analysis. The boundaries are
6		#' computed on the Z-scale using the recursive relationship between cumulative
7		#' spending and the joint distribution of test statistics. The null hypothesis
8		#' is rejected at analysis \eqn{k} if the test statistic \eqn{Z_k \ge b_k}.
9		#'
10		#' At analysis \eqn{k}, the Z-scale boundary \eqn{b_k} satisfies
11		#' \deqn{P(Z_1 < b_1, \ldots, Z_k < b_k) = 1 - f(\alpha, t_k),}
12		#' where \eqn{f(\alpha, t_k)} is the cumulative spending at information
13		#' fraction \eqn{t_k}, and \eqn{(Z_1, \ldots, Z_k)} follows the canonical
14		#' joint distribution with mean zero and correlations given by [gs_corr()].
15		#'
16		#' @param alpha A numeric scalar of the significance level to be spent across
17		#' analyses.
18		#' @param info_frac A numeric vector of information fractions at each analysis.
19		#' Must be monotonically non-decreasing with values in (0, 1].
20		#' @param spending_fn A spending function that takes two arguments: `alpha`
21		#' (significance level) and `info_frac` (information fraction), and returns
22		#' the cumulative alpha spent. See [spending_of()].
23		#' @param maxpts An integer scalar for the maximum number of function values
24		#' for `mvtnorm::GenzBretz`. The default is 25000.
25		#' @param abseps A numeric scalar for the absolute error tolerance for
26		#' `mvtnorm::GenzBretz`. The default is 1e-6.
27		#'
28		#' @return A list with elements:
29		#' * `bounds_z` - A numeric vector of Z-scale boundaries at each analysis.
30		#' * `bounds_nominal` - A numeric vector of nominal p-value boundaries at
31		#' each analysis, i.e., \eqn{c_k = 1 - \Phi(b_k)}.
32		#'
33		#' @seealso
34		#' [spending_of()], [spending_pocock()], [spending_hsd()], [spending_linear()]
35		#' for spending functions, [sequential_p()] for sequential p-values,
36		#' [graph_test_shortcut_gsd()] for graphical MCPs with group sequential
37		#' designs, [gs_corr()] for the correlation matrix.
38		#'
39		#' @rdname gs_boundaries
40		#'
41		#' @export
42		gs_boundaries <- function(alpha,
43		info_frac,
44		spending_fn,
45		maxpts = 25000,
46		abseps = 1e-6) {
47	6795x	K <- length(info_frac)
48	6795x	bounds_z <- numeric(K)
49
50		# Compute cumulative spending at all analyses up front
51	6795x	cum_spent <- spending_fn(alpha, info_frac)
52
53	6785x	for (k in seq_len(K)) {
54		# Treat cumulative spending below machine precision as zero
55	10971x	if (cum_spent[k] < .Machine$double.eps) {
56	482x	bounds_z[k] <- Inf
57	482x	next
58		}
59	10489x	if (cum_spent[k] >= 1 - .Machine$double.eps) {
60	!	bounds_z[k] <- -Inf
61	!	next
62		}
63
64	10489x	target_prob <- 1 - cum_spent[k]
65
66	10489x	if (k == 1) {
67		# First analysis: simple univariate case
68	6303x	bounds_z[k] <- stats::qnorm(target_prob)
69	6303x	next
70		}
71
72		# All boundaries computed so far
73	4186x	all_bounds <- bounds_z[seq_len(k - 1)]
74
75		# If all previous bounds are Inf, the multivariate constraint reduces
76		# to a univariate problem: P(Z_k < b_k) = target_prob
77	4186x	if (all(is.infinite(all_bounds) & all_bounds > 0)) {
78	258x	bounds_z[k] <- stats::qnorm(target_prob)
79	258x	next
80		}
81
82		# For the multivariate case, replace any Inf bounds with a large finite
83		# value to avoid numerical issues in pmvnorm (following gsDesign convention)
84	3928x	finite_bounds <- pmin(all_bounds, 20)
85
86		# Correlation matrix for analyses 1, ..., k
87	3928x	corr_k <- gs_corr(info_frac[seq_len(k)])
88
89		# Find b_k such that P(Z_1 < b_1, ..., Z_k < b_k) = target_prob
90	3928x	f_root <- function(bk) {
91	69455x	upper_vec <- c(finite_bounds, bk)
92
93	69455x	prob <- mvtnorm::pmvnorm(
94	69455x	upper = upper_vec,
95	69455x	corr = corr_k,
96	69455x	algorithm = mvtnorm::GenzBretz(
97	69455x	maxpts = maxpts,
98	69455x	abseps = abseps
99		)
100	69455x	)[[1]]
101
102	69455x	prob - target_prob
103		}
104
105		# Determine a reasonable search interval
106		# Start from the univariate approximation and expand
107	3928x	b_approx <- stats::qnorm(target_prob)
108	3928x	search_lower <- min(b_approx - 6, -8)
109	3928x	search_upper <- max(b_approx + 6, 8)
110
111		# Verify that the root is bracketed; widen if necessary
112	3928x	f_lower <- f_root(search_lower)
113	3928x	f_upper <- f_root(search_upper)
114
115	3928x	if (f_lower > 0) {
116	!	search_lower <- search_lower - 5
117	!	f_lower <- f_root(search_lower)
118		}
119	3928x	if (f_upper < 0) {
120	!	search_upper <- search_upper + 5
121	!	f_upper <- f_root(search_upper)
122		}
123
124	3928x	if (f_lower * f_upper > 0) {
125		# Fallback: if still not bracketed, use the univariate approximation
126	!	bounds_z[k] <- b_approx
127	!	next
128		}
129
130	3928x	result <- stats::uniroot(
131	3928x	f_root,
132	3928x	interval = c(search_lower, search_upper),
133	3928x	tol = abseps
134		)
135	3928x	bounds_z[k] <- result$root
136		}
137
138	6785x	list(
139	6785x	bounds_z = bounds_z,
140	6785x	bounds_nominal = stats::pnorm(bounds_z, lower.tail = FALSE)
141		)
142		}

1		#' Organize outputs for testing an intersection hypothesis
2		#'
3		#' @description
4		#' An intersection hypothesis can be tested by a mixture of test types including
5		#' Bonferroni, parametric and Simes tests. This function organize outputs of
6		#' testing and prepare them for `graph_report`.
7		#'
8		#' @inheritParams graph_test_closure
9		#' @inheritParams graph_create
10		#' @param intersection (optional) A numeric scalar used to name the
11		#' intersection hypothesis in a weighting strategy.
12		#'
13		#' @return A data frame with rows corresponding to individual hypotheses
14		#' involved in the intersection hypothesis with hypothesis weights
15		#' `hypotheses`. There are following columns:
16		#' * `Intersection` - Name of this intersection hypothesis,
17		#' * `Hypothesis` - Name of an individual hypothesis,
18		#' * `Test` - Test type for an individual hypothesis,
19		#' * `p` - (Unadjusted or raw) p-values for a individual hypothesis,
20		#' * `c_value`- C value for parametric tests,
21		#' * `Weight` - Hypothesis weight for an individual hypothesis,
22		#' * `Alpha` - Overall significance level \eqn{\alpha},
23		#' * `Inequality_holds` - Indicator to show if the p-value is less than or
24		#' equal to its significance level.
25		#' - For Bonferroni and Simes tests, the significance level is the
26		#' hypothesis weight times \eqn{\alpha}.
27		#' - For parametric tests, the significance level is the c value times
28		#' the hypothesis weight times \eqn{\alpha}.
29		#'
30		#' @rdname test_values
31		#'
32		#' @keywords internal
33		#'
34		#' @references
35		#' Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
36		#' approach to sequentially rejective multiple test procedures.
37		#' \emph{Statistics in Medicine}, 28(4), 586-604.
38		#'
39		#' Lu, K. (2016). Graphical approaches using a Bonferroni mixture of weighted
40		#' Simes tests. \emph{Statistics in Medicine}, 35(22), 4041-4055.
41		#'
42		#' Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework
43		#' for weighted parametric multiple test procedures.
44		#' \emph{Biometrical Journal}, 59(5), 918-931.
45		#'
46		test_values_bonferroni <- function(p, hypotheses, alpha, intersection = NA) {
47	216x	if (length(p) == 0) {
48	26x	NULL
49		} else {
50	190x	data.frame(
51	190x	Intersection = intersection,
52	190x	Hypothesis = names(hypotheses),
53	190x	Test = "bonferroni",
54	190x	p = p,
55	190x	"c_value" = "",
56	190x	"Weight" = hypotheses,
57	190x	Alpha = alpha,
58	190x	Inequality_holds = ifelse(
59	190x	p == 0 & hypotheses == 0,
60	190x	NA,
61	190x	p <= hypotheses * alpha
62		),
63	190x	check.names = FALSE
64		)
65		}
66		}
67
68		#' @rdname test_values
69		#' @keywords internal
70		test_values_parametric <- function(p,
71		hypotheses,
72		alpha,
73		intersection = NA,
74		test_corr) {
75	132x	if (length(p) == 0) {
76	28x	NULL
77		} else {
78	104x	c_value <- solve_c_parametric(hypotheses, test_corr, alpha)
79
80	104x	data.frame(
81	104x	Intersection = intersection,
82	104x	Hypothesis = names(hypotheses),
83	104x	Test = "parametric",
84	104x	p = p,
85	104x	"c_value" = c_value,
86	104x	"Weight" = hypotheses,
87	104x	Alpha = alpha,
88	104x	Inequality_holds = ifelse(
89	104x	p == 0 & hypotheses == 0,
90	104x	NA,
91	104x	p <= c_value * hypotheses * alpha
92		),
93	104x	check.names = FALSE
94		)
95		}
96		}
97
98		#' @rdname test_values
99		#' @keywords internal
100		test_values_simes <- function(p, hypotheses, alpha, intersection = NA) {
101	112x	if (length(p) == 0) {
102	29x	NULL
103		} else {
104	83x	vec_res <- vector(length = length(hypotheses))
105	83x	w_sum <- vector("numeric", length = length(hypotheses))
106
107	83x	for (i in seq_along(hypotheses)) {
108	110x	w_sum[[i]] <- sum(hypotheses[p <= p[[i]]])
109	110x	vec_res[[i]] <- p[[i]] <= alpha * w_sum[[i]]
110		}
111
112	83x	data.frame(
113	83x	Intersection = intersection,
114	83x	Hypothesis = names(hypotheses),
115	83x	Test = "simes",
116	83x	p = p,
117	83x	"c_value" = "",
118	83x	"Weight" = w_sum,
119	83x	Alpha = alpha,
120	83x	Inequality_holds = ifelse(
121	83x	p == 0 & w_sum == 0,
122	83x	NA,
123	83x	vec_res
124		),
125	83x	check.names = FALSE
126		)
127		}
128		}
129
130		#' @rdname test_values
131		#' @keywords internal
132		test_values_hochberg <- function(p, hypotheses, alpha, intersection = NA) {
133	3x	if (length(p) == 0) {
134	1x	NULL
135		} else {
136	2x	vec_res <- vector(length = length(hypotheses))
137	2x	w_quo <- vector("numeric", length = length(hypotheses))
138	2x	total_weight <- sum(hypotheses)
139
140	2x	for (i in seq_along(hypotheses)) {
141	4x	w_quo[[i]] <- total_weight / (length(hypotheses) - sum(p <= p[[i]]) + 1)
142	4x	vec_res[[i]] <- p[[i]] <= alpha * w_quo[[i]]
143		}
144
145	2x	data.frame(
146	2x	Intersection = intersection,
147	2x	Hypothesis = names(hypotheses),
148	2x	Test = "hochberg",
149	2x	p = p,
150	2x	"c_value" = "",
151	2x	"Weight" = w_quo,
152	2x	Alpha = alpha,
153	2x	Inequality_holds = ifelse(
154	2x	p == 0 & w_quo == 0,
155	2x	NA,
156	2x	vec_res
157		),
158	2x	check.names = FALSE
159		)
160		}
161		}

1		#' S3 print method for the class `graph_report`
2		#'
3		#' @description
4		#' A printed `graph_report` displays the initial graph, p-values and
5		#' significance levels, rejection decisions, and optional detailed test results.
6		#'
7		#' @param x An object of class `graph_report` to print.
8		#' @param ... Other values passed on to other methods (currently unused)
9		#' @param precision An integer scalar indicating the number of decimal places
10		#' to to display.
11		#' @param indent An integer scalar indicating how many spaces to indent results.
12		#' @param rows An integer scalar indicating how many rows of detailed test
13		#' results to print.
14		#'
15		#' @return An object x of class `graph_report`, after printing the report of
16		#' conducting a graphical multiple comparison procedure.
17		#'
18		#' @rdname print.graph_report
19		#'
20		#' @export
21		#'
22		#' @references
23		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
24		#' Rohmeyer, K. (2011). Graphical approaches for multiple comparison
25		#' procedures using weighted Bonferroni, Simes, or parametric tests.
26		#' \emph{Biometrical Journal}, 53(6), 894-913.
27		#'
28		#' @examples
29		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
30		#' # and H2) and two secondary hypotheses (H3 and H4)
31		#' # See Figure 1 in Bretz et al. (2011).
32		#' hypotheses <- c(0.5, 0.5, 0, 0)
33		#' transitions <- rbind(
34		#' c(0, 0, 1, 0),
35		#' c(0, 0, 0, 1),
36		#' c(0, 1, 0, 0),
37		#' c(1, 0, 0, 0)
38		#' )
39		#' g <- graph_create(hypotheses, transitions)
40		#'
41		#' p <- c(0.018, 0.01, 0.105, 0.006)
42		#' alpha <- 0.025
43		#' graph_test_shortcut(g, p, alpha)
44		print.graph_report <- function(x, ..., precision = 4, indent = 2, rows = 10) {
45	13x	pad <- paste(rep(" ", indent), collapse = "")
46	13x	pad_less_1 <- paste(rep(" ", max(indent - 1, 0)), collapse = "")
47	13x	hyp_names <- names(x$inputs$graph$hypotheses)
48
49		# Input calcs ----------------------------------------------------------------
50	13x	cat("\n")
51	13x	section_break("Test parameters ($inputs)")
52
53	13x	hyp_groups <- lapply(x$inputs$test_groups, function(group) hyp_names[group])
54	13x	pad_tests <- formatC(
55	13x	x$inputs$test_types,
56	13x	width = max(nchar(x$inputs$test_types)) + indent
57		)
58
59	13x	test_spec <- paste0(
60	13x	pad_tests,
61		": (",
62	13x	lapply(hyp_groups, paste, collapse = ", "),
63		")",
64	13x	collapse = "\n"
65		)
66
67	13x	p_mat <- matrix(
68	13x	x$inputs$p,
69	13x	nrow = 1,
70	13x	dimnames = list(
71	13x	paste0(pad, "Unadjusted p-values:"),
72	13x	hyp_names
73		),
74		)
75
76	13x	if (any(x$inputs$test_types == "parametric")) {
77	3x	para_hyps <-
78	3x	unlist(x$inputs$test_groups[x$inputs$test_types == "parametric"])
79
80	3x	dimnames(x$inputs$test_corr) <- dimnames(x$inputs$graph$transitions)
81	3x	colname_pad <- format(
82	3x	"Correlation matrix: ",
83	3x	width = max(nchar(rownames(x$inputs$test_corr)))
84		)
85	3x	label <- paste0(pad_less_1, colname_pad)
86	3x	df_corr <- data.frame(
87	3x	paste0(pad_less_1, rownames(x$inputs$test_corr[para_hyps, ])),
88	3x	format(x$inputs$test_corr[para_hyps, para_hyps], digits = precision),
89	3x	check.names = FALSE
90		)
91	3x	names(df_corr)[[1]] <- label
92		}
93
94		# Input print ----------------------------------------------------------------
95	13x	print(x$inputs$graph, precision = precision, indent = indent)
96	13x	cat("\n")
97	13x	cat(pad, "Alpha = ", x$inputs$alpha, sep = "")
98	13x	cat("\n\n")
99	13x	print(as.data.frame(format(p_mat, digits = precision)))
100	13x	cat("\n")
101	13x	if (any(x$inputs$test_types == "parametric")) {
102	3x	print(df_corr, row.names = FALSE)
103	3x	cat("\n")
104		}
105	13x	cat(pad, "Test types", "\n", test_spec, sep = "")
106	13x	cat("\n")
107
108		# Output ---------------------------------------------------------------------
109	13x	cat("\n")
110	13x	section_break("Test summary ($outputs)")
111
112	13x	hyp_width <- max(nchar(c("Hypothesis", hyp_names))) + indent - 1
113
114	13x	adjusted_p <- x$outputs$adjusted_p
115	13x	exceed_1 <- adjusted_p > 1
116	13x	adjusted_p_plus <- gsub(".00000001", "+", adjusted_p[exceed_1])
117	13x	adjusted_p_format <- format(adjusted_p[!exceed_1], digits = precision)
118
119	13x	adjusted_p[exceed_1] <- adjusted_p_plus
120	13x	adjusted_p[!exceed_1] <- adjusted_p_format
121
122	13x	df_summary <- data.frame(
123	13x	Hypothesis = formatC(hyp_names, width = hyp_width),
124	13x	Adj.p = adjusted_p,
125	13x	Reject = x$outputs$rejected,
126	13x	check.names = FALSE
127		)
128	13x	names(df_summary)[[1]] <- formatC("Hypothesis", width = hyp_width)
129
130	13x	print(df_summary, row.names = FALSE)
131
132	13x	cat("\n")
133
134	13x	attr(x$outputs$graph, "title") <-
135	13x	"Final updated graph after removing rejected hypotheses"
136
137	13x	print(
138	13x	x$outputs$graph,
139	13x	precision = precision,
140	13x	indent = indent
141		)
142
143	13x	cat("\n")
144
145		# Adjusted p/rejection sequence details --------------------------------------
146	13x	if (!is.null(x$details)) {
147	9x	if (is.data.frame(x$details$results)) {
148	4x	df_details <- x$details$results
149
150	4x	for (col_num in seq_along(df_details)) {
151	34x	if (is.numeric(df_details[[col_num]])) {
152	26x	df_details[[col_num]] <-
153	26x	format(df_details[[col_num]], digits = precision)
154		}
155		}
156
157	4x	max_print_old <- getOption("max.print")
158	4x	options(max.print = 99999)
159
160	4x	section_break("Adjusted p details ($details)")
161	4x	detail_results_out <- utils::capture.output(
162	4x	print(utils::head(df_details, rows), row.names = FALSE)
163		)
164	4x	cat(paste0(pad_less_1, detail_results_out), sep = "\n")
165
166	4x	options(max.print = max_print_old)
167
168	4x	if (rows < nrow(df_details)) {
169	4x	cat(pad, "... (Use `print(x, rows = <nn>)` for more)\n\n", sep = "")
170		} else {
171	!	cat("\n")
172		}
173		} else {
174	5x	graph_seq <- x$details$results
175	5x	del_seq <- x$details$del_seq
176
177	5x	section_break("Rejection sequence details ($details)")
178	5x	for (i in seq_along(graph_seq) - 1) {
179	27x	if (i == 0) {
180	5x	print(graph_seq[[i + 1]], precision = precision, indent = indent)
181		} else {
182	22x	attr(graph_seq[[i + 1]], "title") <- paste0(
183	22x	"Step ", i, ": Updated graph after removing ",
184	22x	if (i == 1) "hypothesis " else "hypotheses ",
185	22x	paste0(del_seq[seq_len(i)], collapse = ", ")
186		)
187
188	22x	print(
189	22x	graph_seq[[i + 1]],
190	22x	precision = precision,
191	22x	indent = indent * (i + 1)
192		)
193		}
194	27x	cat("\n")
195		}
196
197	5x	attr(graph_seq[[length(graph_seq)]], "title") <-
198	5x	"Final updated graph after removing rejected hypotheses"
199
200	5x	print(
201	5x	graph_seq[[length(graph_seq)]],
202	5x	precision = precision,
203	5x	indent = indent
204		)
205	5x	cat("\n")
206		}
207		}
208
209		# Test values details --------------------------------------------------------
210	13x	if (!is.null(x$test_values)) {
211	7x	section_break("Detailed test values ($test_values)")
212
213	7x	if (any(x$inputs$test_types == "parametric")) {
214	2x	num_cols <- c("p", "c_value", "Weight", "Alpha")
215		} else {
216	5x	num_cols <- c("p", "Weight", "Alpha")
217		}
218
219	7x	crit_res <- x$test_values$results
220	7x	crit_res[num_cols] <- apply(
221	7x	crit_res[num_cols],
222	7x	2,
223	7x	function(num_col) {
224	23x	format(as.numeric(num_col), digits = precision)
225		}
226		)
227
228	7x	p_col_index <- which(names(crit_res) == "p")
229	7x	if (any(x$inputs$test_types == "parametric")) {
230	2x	crit_res$"c_value" <- ifelse(
231	2x	trimws(crit_res$"c_value") == "NA",
232		"",
233	2x	crit_res$"c_value"
234		)
235
236	2x	crit_res <- cbind(
237	2x	crit_res[1:p_col_index],
238	2x	data.frame("<=" = "<=", check.names = FALSE),
239	2x	crit_res[p_col_index + 1],
240	2x	data.frame("" = "", check.names = FALSE),
241	2x	crit_res[p_col_index + 2],
242	2x	data.frame("" = "", check.names = FALSE),
243	2x	crit_res[(p_col_index + 3):(p_col_index + 4)]
244		)
245		} else {
246	5x	crit_res <- cbind(
247	5x	crit_res[1:p_col_index],
248	5x	data.frame("<=" = "<=", check.names = FALSE),
249	5x	crit_res[p_col_index + 1],
250	5x	data.frame("" = "", check.names = FALSE),
251	5x	crit_res[(p_col_index + 2):(p_col_index + 3)]
252		)
253		}
254
255	7x	max_print_old <- getOption("max.print")
256	7x	options(max.print = 99999)
257
258	7x	test_values_results_out <- utils::capture.output(
259	7x	print(utils::head(crit_res, rows), row.names = FALSE)
260		)
261	7x	cat(paste0(pad_less_1, test_values_results_out), sep = "\n")
262
263	7x	options(max.print = max_print_old)
264
265	7x	if (rows < nrow(crit_res)) {
266	4x	cat(pad, "... (Use `print(x, rows = <nn>)` for more)\n\n", sep = "")
267		} else {
268	3x	cat("\n")
269		}
270		}
271
272		# Optional alternate orderings
273	13x	if (!is.null(x$valid_orderings)) {
274	2x	section_break("Alternate rejection orderings ($valid_rejection_orderings)")
275
276	2x	lapply(
277	2x	x$valid_orderings,
278	2x	function(ordering) {
279	10x	print(ordering)
280	10x	cat("\n")
281		}
282		)
283		}
284
285	13x	invisible(x)
286		}
287
288		section_break <- function(text) {
289	104x	cat(text, " ", rep("-", 79 - nchar(text)), "\n", sep = "")
290		}

1		#' Calculate adjusted p-values
2		#'
3		#' @description
4		#' For an intersection hypothesis, an adjusted p-value is the smallest
5		#' significance level at which the intersection hypothesis can be rejected.
6		#' The intersection hypothesis can be rejected if its adjusted p-value is less
7		#' than or equal to \eqn{\alpha}. Currently, there are three test types
8		#' supported:
9		#' * Bonferroni tests for [adjust_p_bonferroni()],
10		#' * Parametric tests for [adjust_p_parametric()],
11		#' - Note that one-sided tests are required for parametric tests.
12		#' * Simes tests for [adjust_p_simes()],
13		#' * Hochberg tests for [adjust_p_hochberg()].
14		#'
15		#' @param p A numeric vector of p-values (unadjusted, raw), whose values should
16		#' be between 0 & 1. The length should match the length of `hypotheses`.
17		#' @param hypotheses A numeric vector of hypothesis weights. Must be a vector of
18		#' values between 0 & 1 (inclusive). The length should match the length of
19		#' `p`. The sum of hypothesis weights should not exceed 1.
20		#' @param test_corr (Optional) A numeric matrix of correlations between test
21		#' statistics, which is needed to perform parametric tests using
22		#' [adjust_p_parametric()]. The number of rows and columns of
23		#' this correlation matrix should match the length of `p`.
24		#' @param maxpts (Optional) An integer scalar for the maximum number of function
25		#' values, which is needed to perform parametric tests using the
26		#' `mvtnorm::GenzBretz` algorithm. The default is 25000.
27		#' @param abseps (Optional) A numeric scalar for the absolute error tolerance,
28		#' which is needed to perform parametric tests using the `mvtnorm::GenzBretz`
29		#' algorithm. The default is 1e-6.
30		#' @param releps (Optional) A numeric scalar for the relative error tolerance
31		#' as double, which is needed to perform parametric tests using the
32		#' `mvtnorm::GenzBretz` algorithm. The default is 0.
33		#'
34		#' @return A single adjusted p-value for the intersection hypothesis.
35		#'
36		#' @seealso
37		#' [adjust_weights_parametric()] for adjusted hypothesis weights using
38		#' parametric tests, [adjust_weights_simes()] for adjusted hypothesis weights
39		#' using Simes tests, [adjust_weights_hochberg()] for adjusted hypothesis
40		#' weights using Hochberg tests.
41		#'
42		#' @rdname adjust_p
43		#'
44		#' @export
45		#'
46		#' @references
47		#' Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
48		#' approach to sequentially rejective multiple test procedures.
49		#' \emph{Statistics in Medicine}, 28(4), 586-604.
50		#'
51		#' Lu, K. (2016). Graphical approaches using a Bonferroni mixture of weighted
52		#' Simes tests. \emph{Statistics in Medicine}, 35(22), 4041-4055.
53		#'
54		#' Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework
55		#' for weighted parametric multiple test procedures.
56		#' \emph{Biometrical Journal}, 59(5), 918-931.
57		#'
58		#' Xi, D., and Bretz, F. (2019). Symmetric graphs for equally weighted tests,
59		#' with application to the Hochberg procedure. \emph{Statistics in Medicine},
60		#' 38(27), 5268-5282.
61		#'
62		#' @examples
63		#' hypotheses <- c(H1 = 0.5, H2 = 0.25, H3 = 0.25)
64		#' p <- c(0.019, 0.025, 0.05)
65		#' adjust_p_bonferroni(p, hypotheses)
66		adjust_p_bonferroni <- function(p, hypotheses) {
67	891x	if (sum(hypotheses) == 0) {
68	48x	return(Inf)
69		}
70
71		# We need na.rm = TRUE to handle the 0 / 0 case. This may be too blunt a way
72		# to handle it, but I suspect it's the fastest. Another option is to reduce p
73		# and weights by keeping only indices where `!(p == 0 & weights == 0)`.
74		# Considering that p-values are validated in the test function, this should be
75		# safe
76	843x	round(min(p / hypotheses, na.rm = TRUE), 10)
77		}
78
79		#' @rdname adjust_p
80		#' @export
81		#' @examples
82		#' set.seed(1234)
83		#' hypotheses <- c(H1 = 0.5, H2 = 0.25, H3 = 0.25)
84		#' p <- c(0.019, 0.025, 0.05)
85		#' # Using the `mvtnorm::GenzBretz` algorithm
86		#' corr <- matrix(0.5, nrow = 3, ncol = 3)
87		#' diag(corr) <- 1
88		#' adjust_p_parametric(p, hypotheses, corr)
89		adjust_p_parametric <- function(p,
90		hypotheses,
91		test_corr = NULL,
92		maxpts = 25000,
93		abseps = 1e-6,
94		releps = 0) {
95	424x	if (sum(hypotheses) == 0) {
96	96x	return(Inf)
97		}
98
99	328x	w_nonzero <- hypotheses > 0
100	328x	q <- min(p[w_nonzero] / hypotheses[w_nonzero])
101	328x	q <- q * hypotheses[w_nonzero]
102	328x	z <- stats::qnorm(q, lower.tail = FALSE)
103	328x	prob_less_than_z <- ifelse(
104	328x	length(z) == 1,
105	328x	stats::pnorm(z, lower.tail = FALSE)[[1]],
106	328x	1 - mvtnorm::pmvnorm(
107	328x	lower = -Inf,
108	328x	upper = z,
109	328x	corr = test_corr[w_nonzero, w_nonzero, drop = FALSE],
110	328x	algorithm = mvtnorm::GenzBretz(
111	328x	maxpts = maxpts,
112	328x	abseps = abseps,
113	328x	releps = releps
114		)
115	328x	)[[1]]
116		)
117
118		# Occasionally off by floating point differences, so round at some high detail
119		# This level of detail should always remove floating point differences
120		# appropriately, as they're typically 10^(<=-15). Conversely, this
121	328x	round(1 / sum(hypotheses) * prob_less_than_z, 10)
122		}
123
124		#' @rdname adjust_p
125		#' @export
126		#' @examples
127		#' hypotheses <- c(H1 = 0.5, H2 = 0.25, H3 = 0.25)
128		#' p <- c(0.019, 0.025, 0.05)
129		#' adjust_p_simes(p, hypotheses)
130		adjust_p_simes <- function(p, hypotheses) {
131	468x	if (sum(hypotheses) == 0) {
132	62x	return(Inf)
133		}
134
135	406x	adjusted_p <- Inf
136	406x	for (i in seq_along(hypotheses)) {
137		# This demonstrates a different and slightly more accurate way of
138		# calculating Simes adjusted weights/adjusted p-values compared to the
139		# method used in [adjust_weights_simes()]. In this function (and
140		# [test_values_simes()]), we add all hypothesis weights for hypotheses with
141		# a smaller p-value than hypothesis_j, for all j in J. In the case that two
142		# p-values are identical, the corresponding hypotheses will get identical
143		# adjusted weights/adjusted p-values. [adjust_weights_simes()], on the other
144		# hand, uses an alternate method that's faster: First order hypotheses
145		# according to their p-values in ascending order, then take the cumulative
146		# sum. In the case that two p-values are identical, they will be sorted
147		# sequentially, and the hypothesis that happens to come first will get a
148		# smaller, incorrect adjusted weight (larger, incorrect adjusted p-value).
149		# The hypothesis that comes second will be correct. [adjust_weights_simes()]
150		# is only used in power calculations where it should not be possible to have
151		# identical p-values, since they are sampled randomly (unless `all(test_corr
152		# == 1)`). Furthermore, even when there are incorrect adjusted weights, it
153		# cannot affect the hypothesis rejections. See Bonferroni function above for
154		# na.rm reasoning
155	834x	adjusted_p <- min(
156	834x	adjusted_p,
157	834x	p[[i]] / sum(hypotheses[p <= p[[i]]]),
158	834x	na.rm = TRUE
159		)
160		}
161
162	406x	round(adjusted_p, 10)
163		}
164
165		#' @rdname adjust_p
166		#' @export
167		#' @examples
168		#' hypotheses <- c(H1 = .25, H2 = .25, H3 = 0.25, H4 = 0.25)
169		#' p <- c(0.019, 0.025, 0.05, .05)
170		#' adjust_p_hochberg(p, hypotheses)
171		adjust_p_hochberg <- function(p, hypotheses) {
172	15x	if (sum(hypotheses) == 0) {
173	!	return(Inf)
174		}
175
176	15x	adjusted_p <- Inf
177	15x	for (i in seq_along(hypotheses)) {
178		# This demonstrates a different and slightly more accurate way of
179		# calculating Hochberg adjusted weights/adjusted p-values compared to the
180		# method used in [adjust_weights_hochberg()]. In this function (and
181		# [test_values_hochberg()]), we count how many hypotheses with a smaller
182		# p-value than hypothesis_j, for all j in J. In the case that two p-values
183		# are identical, the corresponding hypotheses will get identical adjusted
184		# weights/adjusted p-values. [adjust_weights_hochberg()], on the other hand,
185		# uses an alternate method that's faster: First order hypotheses according
186		# to their p-values in ascending order, then take the cumulative sum. In the
187		# case that two p-values are identical, they will be sorted sequentially,
188		# and the hypothesis that happens to come first will get a smaller,
189		# incorrect adjusted weight (larger, incorrect adjusted p-value). The
190		# hypothesis that comes second will be correct. [adjust_weights_hochberg()]
191		# is only used in power calculations where it should not be possible to have
192		# identical p-values, since they are sampled randomly (unless `all(test_corr
193		# == 1)`). Furthermore, even when there are incorrect adjusted weights, it
194		# cannot affect the hypothesis rejections. See Bonferroni function above for
195		# na.rm reasoning.
196	32x	adjusted_p <- min(
197	32x	adjusted_p,
198	32x	p[[i]] / sum(hypotheses) * (length(hypotheses) - sum(p <= p[[i]]) + 1),
199	32x	na.rm = TRUE
200		)
201		}
202
203	15x	round(adjusted_p, 10)
204		}

1		#' Example graphs of commonly used multiple comparison procedures
2		#'
3		#' @description
4		#' Built-in functions to quickly generate select graphical multiple comparison
5		#' procedures.
6		#'
7		#' @param hypotheses (Optional) A numeric vector of hypothesis weights in a
8		#' graphical multiple comparison procedure. Must be a vector of values
9		#' between 0 & 1 (inclusive). The length should match `num_hyps` and the
10		#' length of `hyp_names`. The sum of hypothesis weights should not exceed 1.
11		#' @param hyp_names (Optional) A character vector of hypothesis names. The
12		#' length should match `num_hyps` and the length of `hypotheses`. If
13		#' `hyp_names` are not specified, hypotheses will be named sequentially as
14		#' H1, H2, .......
15		#' @param epsilon (Optional) A numeric scalar indicating the value of the
16		#' \eqn{\epsilon} edge. This should be a much smaller value than hypothesis
17		#' and transition weights. The default is 1e-4.
18		#' @param num_hyps (Optional) Number of hypotheses in a graphical multiple
19		#' comparison procedure.
20		#'
21		#' @return An S3 object as returned by [graph_create()].
22		#'
23		#' @seealso
24		#' [graph_create()] for a general way to create the initial graph.
25		#'
26		#' @rdname example_graphs
27		#'
28		#' @export
29		#'
30		#' @references
31		#' Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
32		#' approach to sequentially rejective multiple test procedures.
33		#' \emph{Statistics in Medicine}, 28(4), 586-604.
34		#'
35		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
36		#' Rohmeyer, K. (2011). Graphical approaches for multiple comparison
37		#' procedures using weighted Bonferroni, Simes, or parametric tests.
38		#' \emph{Biometrical Journal}, 53(6), 894-913.
39		#'
40		#' Hochberg, Y. (1988). A sharper Bonferroni procedure for multiple tests of
41		#' significance. \emph{Biometrika}, 75(4), 800-802.
42		#'
43		#' Hommel, G. (1988). A stagewise rejective multiple test procedure based on a
44		#' modified Bonferroni test. \emph{Biometrika}, 75(2), 383-386.
45		#'
46		#' Huque, M. F., Alosh, M., and Bhore, R. (2011). Addressing multiplicity
47		#' issues of a composite endpoint and its components in clinical trials.
48		#' \emph{Journal of Biopharmaceutical Statistics}, 21(4), 610-634.
49		#'
50		#' Maurer, W., Hothorn, L., and Lehmacher, W. (1995). Multiple comparisons in
51		#' drug clinical trials and preclinical assays: a-priori ordered hypotheses.
52		#' \emph{Biometrie in der chemisch-pharmazeutischen Industrie}, 6, 3-18.
53		#'
54		#' Šidák, Z. (1967). Rectangular confidence regions for the means of
55		#' multivariate normal distributions. \emph{Journal of the American Statistical
56		#' Association}, 62(318), 626-633.
57		#'
58		#' Westfall, P. H., and Krishen, A. (2001). Optimally weighted, fixed sequence
59		#' and gatekeeper multiple testing procedures.
60		#' \emph{Journal of Statistical Planning and Inference}, 99(1), 25-40.
61		#'
62		#' Wiens, B. L. (2003). A fixed sequence Bonferroni procedure for testing
63		#' multiple endpoints. \emph{Pharmaceutical Statistics}, 2(3), 211-215.
64		#'
65		#' Wiens, B. L., and Dmitrienko, A. (2005). The fallback procedure for
66		#' evaluating a single family of hypotheses.
67		#' \emph{Journal of Biopharmaceutical Statistics}, 15(6), 929-942.
68		#'
69		#' Xi, D., and Bretz, F. (2019). Symmetric graphs for equally weighted tests,
70		#' with application to the Hochberg procedure. \emph{Statistics in Medicine},
71		#' 38(27), 5268-5282.
72		#'
73		#' @examples
74		#' # Bretz et al. (2009)
75		#' bonferroni(num_hyps = 3)
76		bonferroni <- function(num_hyps, hyp_names = NULL) {
77	2x	stopifnot(
78	2x	"number of hypotheses must match number of names" =
79	2x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
80		)
81	2x	hypotheses <- rep(1 / num_hyps, num_hyps)
82	2x	transitions <- matrix(0, num_hyps, num_hyps)
83
84	2x	graph_create(hypotheses, transitions, hyp_names)
85		}
86
87		#' @export
88		#' @rdname example_graphs
89		#' @examples
90		#' # Bretz et al. (2009)
91		#' hypotheses <- c(0.5, 0.3, 0.2)
92		#' bonferroni_weighted(hypotheses)
93		bonferroni_weighted <- function(hypotheses, hyp_names = NULL) {
94	1x	num_hyps <- length(hypotheses)
95	1x	stopifnot(
96	1x	"number of hypotheses must match number of names" =
97	1x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
98		)
99	1x	transitions <- matrix(0, num_hyps, num_hyps)
100
101	1x	graph_create(hypotheses, transitions, hyp_names)
102		}
103
104		#' @export
105		#' @rdname example_graphs
106		#' @examples
107		#' # Bretz et al. (2009)
108		#' bonferroni_holm(num_hyps = 3)
109		bonferroni_holm <- function(num_hyps, hyp_names = NULL) {
110	10x	stopifnot(
111	10x	"number of hypotheses must match number of names" =
112	10x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
113		)
114	10x	hypotheses <- rep(1 / num_hyps, num_hyps)
115	10x	transitions <- matrix(rep(1 / (num_hyps - 1), num_hyps^2), nrow = num_hyps)
116	10x	diag(transitions) <- rep(0, num_hyps)
117
118	10x	graph_create(hypotheses, transitions, hyp_names)
119		}
120
121		#' @export
122		#' @rdname example_graphs
123		#' @examples
124		#' # Bretz et al. (2009)
125		#' hypotheses <- c(0.5, 0.3, 0.2)
126		#' bonferroni_holm_weighted(hypotheses)
127		bonferroni_holm_weighted <- function(hypotheses, hyp_names = NULL) {
128	1x	num_hyps <- length(hypotheses)
129	1x	stopifnot(
130	1x	"number of hypotheses must match number of names" =
131	1x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
132		)
133	1x	transitions <- matrix(rep(1 / (num_hyps - 1), num_hyps^2), nrow = num_hyps)
134	1x	diag(transitions) <- rep(0, num_hyps)
135
136	1x	graph_create(hypotheses, transitions, hyp_names)
137		}
138
139		#' @export
140		#' @rdname example_graphs
141		#' @examples
142		#' # Xi et al. (2017)
143		#' dunnett_single_step(num_hyps = 3)
144		dunnett_single_step <- function(num_hyps, hyp_names = NULL) {
145	1x	stopifnot(
146	1x	"number of hypotheses must match number of names" =
147	1x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
148		)
149	1x	hypotheses <- rep(1 / num_hyps, num_hyps)
150	1x	transitions <- matrix(0, num_hyps, num_hyps)
151
152	1x	graph_create(hypotheses, transitions, hyp_names)
153		}
154
155		#' @export
156		#' @rdname example_graphs
157		#' @examples
158		#' # Xi et al. (2017)
159		#' hypotheses <- c(0.5, 0.3, 0.2)
160		#' dunnett_single_step_weighted(hypotheses)
161		dunnett_single_step_weighted <- function(hypotheses, hyp_names = NULL) {
162	1x	num_hyps <- length(hypotheses)
163	1x	stopifnot(
164	1x	"number of hypotheses must match number of names" =
165	1x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
166		)
167	1x	transitions <- matrix(0, num_hyps, num_hyps)
168
169	1x	graph_create(hypotheses, transitions, hyp_names)
170		}
171
172		#' @export
173		#' @rdname example_graphs
174		#' @examples
175		#' # Xi et al. (2009)
176		#' hypotheses <- c(0.5, 0.3, 0.2)
177		#' dunnett_closure_weighted(hypotheses)
178		dunnett_closure_weighted <- function(hypotheses, hyp_names = NULL) {
179	1x	num_hyps <- length(hypotheses)
180	1x	stopifnot(
181	1x	"number of hypotheses must match number of names" =
182	1x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
183		)
184	1x	transitions <- matrix(rep(1 / (num_hyps - 1), num_hyps^2), nrow = num_hyps)
185	1x	diag(transitions) <- rep(0, num_hyps)
186
187	1x	graph_create(hypotheses, transitions, hyp_names)
188		}
189
190		#' @export
191		#' @rdname example_graphs
192		#' @examples
193		#' # Hochberg (1988)
194		#' hochberg(num_hyps = 3)
195		hochberg <- function(num_hyps, hyp_names = NULL) {
196	1x	stopifnot(
197	1x	"number of hypotheses must match number of names" =
198	1x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
199		)
200	1x	hypotheses <- rep(1 / num_hyps, num_hyps)
201	1x	transitions <- matrix(rep(1 / (num_hyps - 1), num_hyps^2), nrow = num_hyps)
202	1x	diag(transitions) <- rep(0, num_hyps)
203
204	1x	graph_create(hypotheses, transitions, hyp_names)
205		}
206
207		#' @export
208		#' @rdname example_graphs
209		#' @examples
210		#' # Hommel (1988)
211		#' hommel(num_hyps = 3)
212		hommel <- function(num_hyps, hyp_names = NULL) {
213	1x	stopifnot(
214	1x	"number of hypotheses must match number of names" =
215	1x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
216		)
217	1x	hypotheses <- rep(1 / num_hyps, num_hyps)
218	1x	transitions <- matrix(rep(1 / (num_hyps - 1), num_hyps^2), nrow = num_hyps)
219	1x	diag(transitions) <- rep(0, num_hyps)
220
221	1x	graph_create(hypotheses, transitions, hyp_names)
222		}
223
224		#' @export
225		#' @rdname example_graphs
226		#' @examples
227		#' # Huque et al. (2011)
228		#' huque_etal()
229		huque_etal <- function(hyp_names = NULL) {
230	1x	graph_create(
231	1x	c(1, 0, 0, 0),
232	1x	matrix(
233	1x	c(
234	1x	0, 0.5, 0.5, 0,
235	1x	0, 0, 0, 1,
236	1x	0, 0.5, 0, 0.5,
237	1x	0, 1, 0, 0
238		),
239	1x	nrow = 4,
240	1x	byrow = TRUE
241		),
242	1x	hyp_names = hyp_names
243		)
244		}
245
246		#' @export
247		#' @rdname example_graphs
248		#' @examples
249		#' # Wiens (2003)
250		#' hypotheses <- c(0.5, 0.3, 0.2)
251		#' fallback(hypotheses)
252		fallback <- function(hypotheses, hyp_names = NULL) {
253	2x	num_hyps <- length(hypotheses)
254	2x	stopifnot(
255	2x	"number of hypotheses must match number of names" =
256	2x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
257		)
258	2x	transitions <- matrix(0, nrow = num_hyps, ncol = num_hyps)
259	2x	for (i in seq_len(num_hyps - 1)) {
260	4x	transitions[i, i + 1] <- 1
261		}
262
263	2x	graph_create(hypotheses, transitions, hyp_names)
264		}
265
266		#' @export
267		#' @rdname example_graphs
268		#' @examples
269		#' # Wiens and Dmitrienko (2005)
270		#' hypotheses <- c(0.5, 0.3, 0.2)
271		#' fallback_improved_1(hypotheses)
272		fallback_improved_1 <- function(hypotheses, hyp_names = NULL) {
273	2x	num_hyps <- length(hypotheses)
274	2x	stopifnot(
275	2x	"number of hypotheses must match number of names" =
276	2x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names)),
277	2x	"sum of all hypothesis weights excluding the last one should be greater
278	2x	than 0" = sum(hypotheses[seq_len(num_hyps - 1)]) > 0
279		)
280	2x	transitions <- matrix(0, nrow = num_hyps, ncol = num_hyps)
281	2x	for (i in seq_len(num_hyps - 1)) {
282	4x	transitions[i, i + 1] <- 1
283		}
284	2x	transitions[num_hyps, seq_len(num_hyps - 1)] <-
285	2x	hypotheses[seq_len(num_hyps - 1)] / sum(hypotheses[seq_len(num_hyps - 1)])
286
287	2x	graph_create(hypotheses, transitions, hyp_names)
288		}
289
290		#' @export
291		#' @rdname example_graphs
292		#' @examples
293		#' # Bretz et al. (2009)
294		#' hypotheses <- c(0.5, 0.3, 0.2)
295		#' fallback_improved_2(hypotheses)
296		fallback_improved_2 <- function(hypotheses, epsilon = 1e-4, hyp_names = NULL) {
297	1x	num_hyps <- length(hypotheses)
298	1x	stopifnot(
299	1x	"number of hypotheses must match number of names" =
300	1x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
301		)
302	1x	transitions <- matrix(0, nrow = num_hyps, ncol = num_hyps)
303	1x	if (num_hyps == 2) {
304	!	transitions[1, 2] <- transition[2, 1] <- 1
305	1x	} else if (num_hyps > 2) {
306	1x	transitions[, 1] <- c(0, rep(1 - epsilon, num_hyps - 2), 1)
307	1x	transitions[1, 2] <- 1
308	1x	for (i in 2:(num_hyps - 1)) {
309	1x	transitions[i, i + 1] <- epsilon
310		}
311		}
312
313	1x	graph_create(hypotheses, transitions, hyp_names)
314		}
315
316		#' @export
317		#' @rdname example_graphs
318		#' @examples
319		#' # Maurer et al. (1995); Westfall and Krishen (2001)
320		#' fixed_sequence(num_hyps = 3)
321		fixed_sequence <- function(num_hyps, hyp_names = NULL) {
322	2x	hypotheses <- c(1, rep(0, num_hyps - 1))
323	2x	transitions <- matrix(0, nrow = num_hyps, ncol = num_hyps)
324	2x	for (i in seq_len(num_hyps - 1)) {
325	5x	transitions[i, i + 1] <- 1
326		}
327
328	2x	graph_create(hypotheses, transitions, hyp_names)
329		}
330
331
332		#' @export
333		#' @rdname example_graphs
334		#' @examples
335		#' # sidak (1967)
336		#' sidak(num_hyps = 3)
337		sidak <- function(num_hyps, hyp_names = NULL) {
338	1x	stopifnot(
339	1x	"number of hypotheses must match number of names" =
340	1x	(num_hyps == length(hyp_names) \|\| is.null(hyp_names))
341		)
342	1x	hypotheses <- rep(1 / num_hyps, num_hyps)
343	1x	transitions <- matrix(0, num_hyps, num_hyps)
344
345	1x	graph_create(hypotheses, transitions, hyp_names)
346		}
347
348		#' @export
349		#' @rdname example_graphs
350		#' @examples
351		#' # Figure 1 in Bretz et al. (2011)
352		#' simple_successive_1()
353		simple_successive_1 <- function(hyp_names = NULL) {
354	29x	hypotheses <- c(0.5, 0.5, 0, 0)
355	29x	transitions <- rbind(
356	29x	c(0, 0, 1, 0),
357	29x	c(0, 0, 0, 1),
358	29x	c(0, 1, 0, 0),
359	29x	c(1, 0, 0, 0)
360		)
361
362	29x	graph_create(hypotheses, transitions, hyp_names)
363		}
364
365		#' @export
366		#' @rdname example_graphs
367		#' @examples
368		#' # Figure 4 in Bretz et al. (2011)
369		#' simple_successive_2()
370		simple_successive_2 <- function(hyp_names = NULL) {
371	2x	hypotheses <- c(0.5, 0.5, 0, 0)
372	2x	transitions <- rbind(
373	2x	c(0, 0.5, 0.5, 0),
374	2x	c(0.5, 0, 0, 0.5),
375	2x	c(0, 1, 0, 0),
376	2x	c(1, 0, 0, 0)
377		)
378
379	2x	graph_create(hypotheses, transitions, hyp_names)
380		}
381
382		#' @export
383		#' @rdname example_graphs
384		#' @examples
385		#' # Figure 6 in Xi and Bretz et al. (2019)
386		#' two_doses_two_primary_two_secondary()
387		two_doses_two_primary_two_secondary <- function(hyp_names = NULL) {
388	2x	eps <- 1e-4
389	2x	weights <- c(rep(c(1 / 2, 0, 0), 2))
390	2x	transitions <- rbind(
391	2x	c(0, 0.5, 0.5, 0, 0, 0),
392	2x	c(0, 0, 1, 0, 0, 0),
393	2x	c(0, 1 - eps, 0, eps, 0, 0),
394	2x	c(0, 0, 0, 0, 0.5, 0.5),
395	2x	c(0, 0, 0, 0, 0, 1),
396	2x	c(eps, 0, 0, 0, 1 - eps, 0)
397		)
398
399	2x	graph_create(weights, transitions, hyp_names = hyp_names)
400		}
401
402		#' @export
403		#' @rdname example_graphs
404		#' @examples
405		#' # Add another dose to Figure 6 in Xi and Bretz et al. (2019)
406		#' three_doses_two_primary_two_secondary()
407		three_doses_two_primary_two_secondary <- function(hyp_names = NULL) {
408	!	eps <- 1e-4
409	!	weights <- c(rep(c(1 / 3, 0, 0), 3))
410	!	transitions <- rbind(
411	!	c(0, 0.5, 0.5, 0, 0, 0, 0, 0, 0), # 1 --> 2 & 3
412	!	c(0, 0, 1, 0, 0, 0, 0, 0, 0), # 2 --> 3
413	!	c(0, 1 - eps, 0, eps / 2, 0, 0, eps / 2, 0, 0), # 3 --> 2, 3 - - > 4 & 7
414	!	c(0, 0, 0, 0, 0.5, 0.5, 0, 0, 0), # 4 --> 5 & 6
415	!	c(0, 0, 0, 0, 0, 1, 0, 0, 0), # 5 --> 6
416	!	c(eps / 2, 0, 0, 0, 1 - eps, 0, eps / 2, 0, 0), # 6 --> 5, 6 - - > 1 & 7
417	!	c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5), # 7 --> 8 & 9
418	!	c(0, 0, 0, 0, 0, 0, 0, 0, 1), # 8 --> 9
419	!	c(eps / 2, 0, 0, eps / 2, 0, 0, 0, 1 - eps, 0) # 9 --> 8, 9 - - > 1 & 4
420		)
421
422	!	graph_create(weights, transitions, hyp_names = hyp_names)
423		}
424
425		#' @export
426		#' @rdname example_graphs
427		#' @examples
428		#' # Create a random graph with three hypotheses
429		#' random_graph(num_hyps = 3)
430		random_graph <- function(num_hyps, hyp_names = NULL) {
431	20x	hypotheses <- sample(seq_len(num_hyps), replace = TRUE)
432	20x	hypotheses <- hypotheses / sum(hypotheses)
433	20x	transitions <- replicate(
434	20x	num_hyps,
435	20x	sample(seq_len(num_hyps), replace = TRUE),
436	20x	simplify = TRUE
437		)
438	20x	diag(transitions) <- 0
439	20x	transitions <- transitions / rowSums(transitions)
440
441	20x	graph_create(hypotheses, transitions, hyp_names)
442		}

1		#' S3 print method for the class `gsd_graph_report`
2		#'
3		#' @description
4		#' A printed `gsd_graph_report` displays:
5		#' * Test parameters: the initial graph, alpha, information fractions,
6		#' p-values, spending functions, and per-hypothesis look_back settings.
7		#' * Test summary: adjusted p-values, rejection decisions, the analysis
8		#' at which each decision was made (`Decision.at`), the earliest analysis
9		#' at which the boundary was crossed (`First.Rej.at`), look_back status,
10		#' and the rejection sequence.
11		#' * Per-analysis details (if `test_values = TRUE`): nominal p-values,
12		#' boundaries, and rejection decisions at each analysis. For hypotheses
13		#' rejected via look_back, additional rows show the boundary crossing at
14		#' earlier analyses, marked with `*` and a footnote.
15		#' * Boundary table (if `verbose = TRUE`): nominal p-value boundaries
16		#' for all possible hypothesis weights from the graph's closure, enabling
17		#' manual verification of rejection decisions.
18		#'
19		#' @param x An object of class `gsd_graph_report` to print.
20		#' @param ... Other values passed on to other methods (currently unused).
21		#' @param precision An integer scalar indicating the number of decimal places
22		#' to display.
23		#' @param indent An integer scalar indicating how many spaces to indent
24		#' results.
25		#'
26		#' @return An object x of class `gsd_graph_report`, invisibly.
27		#'
28		#' @rdname print.gsd_graph_report
29		#'
30		#' @export
31		#'
32		#' @references
33		#' Maurer, W., and Bretz, F. (2013). Multiple testing in group sequential
34		#' trials using graphical approaches. \emph{Statistics in Biopharmaceutical
35		#' Research}, 5(4), 311-320.
36		#'
37		#' @examples
38		#' hypotheses <- c(0.5, 0.5)
39		#' transitions <- rbind(c(0, 1), c(1, 0))
40		#' g <- graph_create(hypotheses, transitions)
41		#'
42		#' p <- rbind(
43		#' H1 = c(0.024, 0.01),
44		#' H2 = c(0.015, 0.005)
45		#' )
46		#'
47		#' graph_test_shortcut_gsd(
48		#' graph = g,
49		#' p = p,
50		#' alpha = 0.025,
51		#' info_frac = c(0.5, 1),
52		#' spending_fn = spending_of
53		#' )
54		print.gsd_graph_report <- function(x, ..., precision = 6, indent = 2) {
55	7x	pad <- paste(rep(" ", indent), collapse = "")
56	7x	hyp_names <- names(x$inputs$graph$hypotheses)
57	7x	num_hyps <- length(hyp_names)
58	7x	num_analyses <- ncol(x$inputs$p)
59
60		# Input parameters -----------------------------------------------------------
61	7x	cat("\n")
62	7x	section_break("Test parameters ($inputs)")
63
64	7x	print(x$inputs$graph, precision = precision, indent = indent)
65	7x	cat("\n")
66	7x	cat(pad, "Alpha = ", x$inputs$alpha, "\n", sep = "")
67
68		# Analysis names from column names of p
69	7x	analysis_names <- colnames(x$inputs$p)
70
71		# Information fractions table
72	7x	cat("\n", pad, "Information fractions\n", sep = "")
73	7x	info_df <- as.data.frame(x$inputs$info_frac, row.names = hyp_names)
74	7x	colnames(info_df) <- analysis_names
75	7x	print(info_df)
76
77		# P-values table
78	7x	cat("\n", pad, "P-values\n", sep = "")
79	7x	p_df <- as.data.frame(x$inputs$p, row.names = hyp_names)
80	7x	colnames(p_df) <- analysis_names
81	7x	p_df[] <- lapply(p_df, function(col) formatC(col, format = "f", digits = precision))
82	7x	print(p_df)
83
84		# Spending functions
85	7x	cat("\n", pad, "Spending functions\n", sep = "")
86	7x	for (j in seq_len(num_hyps)) {
87	28x	sf_body <- deparse(body(x$inputs$spending_fn[[j]]))
88	28x	sf_name <- tryCatch(
89		{
90	28x	env <- environment(x$inputs$spending_fn[[j]])
91	28x	if (identical(x$inputs$spending_fn[[j]], spending_of)) {
92	20x	"O'Brien-Fleming"
93	8x	} else if (identical(x$inputs$spending_fn[[j]], spending_pocock)) {
94	8x	"Pocock"
95	!	} else if (identical(x$inputs$spending_fn[[j]], spending_linear)) {
96	!	"Linear"
97		} else {
98	!	paste(sf_body, collapse = " ")
99		}
100		},
101	28x	error = function(e) paste(sf_body, collapse = " ")
102		)
103	28x	cat(pad, pad, hyp_names[j], ": ", sf_name, "\n", sep = "")
104		}
105
106		# Look back mode
107	7x	look_back <- x$inputs$look_back
108	7x	if (all(look_back == look_back[1])) {
109	6x	cat("\n", pad, "Look back = ", look_back[1], "\n", sep = "")
110		} else {
111	1x	cat("\n", pad, "Look back\n", sep = "")
112	1x	for (j in seq_len(num_hyps)) {
113	4x	cat(pad, pad, hyp_names[j], ": ", look_back[j], "\n", sep = "")
114		}
115		}
116
117		# Test summary ---------------------------------------------------------------
118	7x	cat("\n")
119	7x	section_break("Test summary ($outputs)")
120
121	7x	hyp_width <- max(nchar(c("Hypothesis", hyp_names))) + indent - 1
122
123	7x	adj_p <- x$outputs$adjusted_p
124	7x	exceed_1 <- adj_p > 1
125	7x	adj_p_format <- character(length(adj_p))
126	7x	adj_p_format[exceed_1] <- gsub(".00000001", "+", adj_p[exceed_1])
127	7x	adj_p_format[!exceed_1] <- formatC(adj_p[!exceed_1],
128	7x	format = "f",
129	7x	digits = precision
130		)
131
132	7x	decision_at <- x$outputs$decision_at
133
134	7x	first_rej_display <- ifelse(
135	7x	is.na(x$outputs$first_rejected_at),
136		"--",
137	7x	as.character(x$outputs$first_rejected_at)
138		)
139
140	7x	last_rej_display <- ifelse(
141	7x	is.na(x$outputs$last_rejected_at),
142		"--",
143	7x	as.character(x$outputs$last_rejected_at)
144		)
145
146	7x	df_summary <- data.frame(
147	7x	Hypothesis = formatC(hyp_names, width = hyp_width),
148	7x	Adj.P = adj_p_format,
149	7x	Reject = x$outputs$rejected,
150	7x	Tested.at = as.character(decision_at),
151	7x	First.Rej.at = first_rej_display,
152	7x	Last.Rej.at = last_rej_display,
153	7x	Look.back = look_back,
154	7x	check.names = FALSE
155		)
156	7x	names(df_summary)[[1]] <- formatC("Hypothesis", width = hyp_width)
157	7x	names(df_summary)[[2]] <- "Adj.p*"
158
159	7x	print(df_summary, row.names = FALSE)
160
161	7x	cat(pad, "(*) Adjusted p-values account for both the group sequential",
162	7x	" design and the\n", pad, " graphical multiple comparison procedure.",
163	7x	" Based on repeated p-values when\n", pad, " look_back = FALSE,",
164	7x	" and sequential p-values when look_back = TRUE.\n",
165	7x	sep = ""
166		)
167
168		# Rejection sequence
169	7x	rej_seq <- x$outputs$rejection_sequence
170	7x	if (length(rej_seq) > 0) {
171	7x	cat("\n", pad, "Rejection sequence: ",
172	7x	paste(rej_seq, collapse = " -> "), "\n",
173	7x	sep = ""
174		)
175		}
176	7x	cat("\n")
177
178	7x	attr(x$outputs$graph, "title") <-
179	7x	"Final updated graph after removing rejected hypotheses"
180	7x	print(x$outputs$graph, precision = precision, indent = indent)
181	7x	cat("\n")
182
183		# Per-analysis test values ---------------------------------------------------
184	7x	if (!is.null(x$test_values)) {
185	3x	section_break("Per-analysis details ($test_values)")
186
187	3x	for (k in seq_along(x$test_values)) {
188	6x	detail <- x$test_values[[k]]
189	!	if (is.null(detail)) next
190
191	6x	cat(pad, "Analysis ", k, "\n", sep = "")
192
193		# Check for look_back rows
194	6x	has_look_back <- "Look_back" %in% names(detail) && any(detail$Look_back)
195	6x	lb_hypotheses <- if (has_look_back) {
196	1x	unique(detail$Hypothesis[detail$Look_back])
197		} else {
198	5x	character(0)
199		}
200
201		# Add footnote marker (*) to hypotheses with look_back attribution
202	6x	if (has_look_back) {
203	1x	detail$Hypothesis[detail$Look_back] <-
204	1x	paste0(detail$Hypothesis[detail$Look_back], "*")
205		}
206
207		# Remove the Look_back column from display
208	6x	detail$Look_back <- NULL
209
210		# Format numeric columns with consistent fixed notation
211	6x	detail$Weight <- formatC(detail$Weight, format = "f", digits = precision)
212	6x	detail$p <- formatC(detail$p, format = "f", digits = precision)
213	6x	detail$Boundary <- formatC(detail$Boundary, format = "f", digits = precision)
214
215	6x	detail_out <- utils::capture.output(
216	6x	print(detail, row.names = FALSE)
217		)
218	6x	cat(paste0(pad, detail_out), sep = "\n")
219
220		# Print footnote for look_back hypotheses
221	6x	if (has_look_back) {
222	1x	cat(pad, "(*) Rejected via look_back: the nominal p-value crossed",
223	1x	" the boundary at an\n", pad, " earlier analysis with the",
224	1x	" hypothesis weight updated via graph propagation.\n",
225	1x	sep = ""
226		)
227		}
228	6x	cat("\n")
229		}
230		}
231
232		# Repeated and sequential p-values (verbose) --------------------------------
233	7x	if (!is.null(x$boundary_table)) {
234	1x	section_break("Repeated p-values ($outputs$repeated_p)")
235	1x	rep_p_display <- x$outputs$repeated_p
236	1x	rep_p_display[] <- formatC(rep_p_display, format = "f", digits = precision)
237	1x	print(as.data.frame(rep_p_display))
238
239	1x	cat("\n")
240	1x	section_break("Sequential p-values ($outputs$sequential_p)")
241	1x	seq_p_display <- x$outputs$sequential_p
242	1x	seq_p_display[] <- formatC(seq_p_display, format = "f", digits = precision)
243	1x	print(as.data.frame(seq_p_display))
244	1x	cat("\n")
245		}
246
247		# Boundary table (verbose) ---------------------------------------------------
248	7x	if (!is.null(x$boundary_table)) {
249	1x	section_break("Boundary table ($boundary_table)")
250
251	1x	cat(pad, "Nominal p-value boundaries for all possible hypothesis weights\n",
252	1x	pad, "from the graph's closure. Use to verify rejection decisions:\n",
253	1x	pad, "a hypothesis is rejected when its p-value <= boundary.\n\n",
254	1x	sep = ""
255		)
256
257	1x	for (hyp in names(x$boundary_table)) {
258	4x	cat(pad, hyp, "\n", sep = "")
259	4x	bt <- x$boundary_table[[hyp]]
260	4x	bt_display <- bt
261		# Format numeric columns with consistent fixed notation
262	4x	for (col in names(bt_display)) {
263	16x	bt_display[[col]] <- formatC(bt_display[[col]],
264	16x	format = "f", digits = precision
265		)
266		}
267	4x	bt_out <- utils::capture.output(print(bt_display, row.names = FALSE))
268	4x	cat(paste0(pad, bt_out), sep = "\n")
269	4x	cat("\n")
270		}
271		}
272
273	7x	invisible(x)
274		}

1		#' Generate the weighting strategy based on a graphical multiple comparison
2		#' procedure
3		#'
4		#' @description
5		#' A graphical multiple comparison procedure defines a closed test procedure,
6		#' which tests each intersection hypothesis and reject an individual hypothesis
7		#' if all intersection hypotheses involving it have been rejected. An
8		#' intersection hypothesis represents the parameter space where individual null
9		#' hypotheses involved are true simultaneously.
10		#'
11		#' The closure based on a graph consists of all updated graphs (corresponding
12		#' to intersection hypotheses) after all combinations of hypotheses are deleted.
13		#' For a graphical multiple comparison procedure with \eqn{m} hypotheses, there
14		#' are \eqn{2^{m}-1} updated graphs (intersection hypotheses), including the
15		#' initial graph (the overall intersection hypothesis). The weighting strategy
16		#' of this graph consists of hypothesis weights from all \eqn{2^{m}-1} updated
17		#' graphs (intersection hypotheses). The algorithm to derive the weighting
18		#' strategy is based on Algorithm 1 in Bretz et al. (2011).
19		#'
20		#' @inheritParams graph_update
21		#'
22		#' @return A numeric matrix of all intersection hypotheses and their hypothesis
23		#' weights. For a graphical multiple comparison procedure with \eqn{m} hypotheses,
24		#' the number of rows is \eqn{2^{m}-1}, each of which corresponds to an intersection
25		#' hypothesis. The number of columns is \eqn{2\cdot m}. The first \eqn{m} columns
26		#' indicate which individual hypotheses are included in a given intersection
27		#' hypothesis and the second half of columns provide hypothesis weights for each
28		#' individual hypothesis for a given intersection hypothesis.
29		#'
30		#' @section Performance:
31		#' Generation of intersection hypotheses is closely related to the power set
32		#' of a given set of indices. As the number of hypotheses increases, the memory
33		#' and time usage can grow quickly (e.g., at a rate of \eqn{O(2^n)}). There are also
34		#' multiple ways to implement Algorithm 1 in Bretz et al. (2011). See
35		#' `vignette("generate-closure")` for more information about generating
36		#' intersection hypotheses and comparisons of different approaches to calculate
37		#' weighting strategies.
38		#'
39		#' @seealso
40		#' [graph_test_closure()] for graphical multiple comparison procedures using
41		#' the closed test.
42		#'
43		#' @rdname graph_generate_weights
44		#'
45		#' @export
46		#'
47		#' @references
48		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
49		#' Rohmeyer, K. (2011). Graphical approaches for multiple comparison
50		#' procedures using weighted Bonferroni, Simes, or parametric tests.
51		#' \emph{Biometrical Journal}, 53(6), 894-913.
52		#'
53		#' @examples
54		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
55		#' # and H2) and two secondary hypotheses (H3 and H4)
56		#' # See Figure 1 in Bretz et al. (2011).
57		#' hypotheses <- c(0.5, 0.5, 0, 0)
58		#' transitions <- rbind(
59		#' c(0, 0, 1, 0),
60		#' c(0, 0, 0, 1),
61		#' c(0, 1, 0, 0),
62		#' c(1, 0, 0, 0)
63		#' )
64		#' g <- graph_create(hypotheses, transitions)
65		#'
66		#' graph_generate_weights(g)
67		graph_generate_weights <- function(graph) {
68	294x	hyp_names <- names(graph$hypotheses)
69	294x	num_hyps <- length(graph$hypotheses)
70
71	294x	parents <- do.call(c, lapply(2^(seq_len(num_hyps) - 1), seq_len))
72	294x	parents <- parents[-(2^num_hyps - 1)]
73
74	294x	delete <- rep(rev(seq_len(num_hyps)), 2^(seq_len(num_hyps) - 1))
75	294x	delete <- delete[-(2^num_hyps - 1)]
76
77	294x	graphs <- vector("list", length(parents))
78	294x	graphs[[1]] <- graph
79
80	294x	matrix_weights <- matrix(nrow = 2^num_hyps - 1, ncol = num_hyps)
81	294x	dimnames(matrix_weights) <- list(seq_len(2^num_hyps - 1), hyp_names)
82	294x	matrix_weights[1, ] <- graph$hypotheses
83
84	294x	for (i in seq_along(parents)) {
85	8356x	parent <- graphs[[parents[[i]]]]
86	8356x	del_index <- which(hyp_names[[delete[[i]]]] == names(parent$hypotheses))
87
88	8356x	init_hypotheses <- parent$hypotheses
89	8356x	init_transitions <- parent$transitions
90
91	8356x	hypotheses <- parent$hypotheses
92	8356x	transitions <- parent$transitions
93
94	8356x	hyp_nums <- seq_along(hypotheses)[-del_index]
95
96	8356x	for (hyp_num in hyp_nums) {
97	26168x	hypotheses[[hyp_num]] <-
98	26168x	init_hypotheses[[hyp_num]] +
99	26168x	init_hypotheses[[del_index]] * init_transitions[[del_index, hyp_num]]
100
101	26168x	denominator <- 1 - init_transitions[[hyp_num, del_index]] *
102	26168x	init_transitions[[del_index, hyp_num]]
103
104	26168x	for (end_num in hyp_nums) {
105	101996x	if (hyp_num == end_num \|\| denominator <= 0) {
106	26326x	transitions[[hyp_num, end_num]] <- 0
107		} else {
108	75670x	transitions[[hyp_num, end_num]] <-
109	75670x	(init_transitions[[hyp_num, end_num]] +
110	75670x	init_transitions[[hyp_num, del_index]] *
111	75670x	init_transitions[[del_index, end_num]]) / denominator
112		}
113		}
114		}
115
116	8356x	graphs[[i + 1]] <- structure(
117	8356x	list(
118	8356x	hypotheses = hypotheses[-del_index],
119	8356x	transitions =
120	8356x	as.matrix(transitions[-del_index, -del_index, drop = FALSE])
121		),
122	8356x	class = "initial_graph"
123		)
124
125	8356x	matrix_weights[i + 1, ] <- hypotheses[-del_index][hyp_names]
126		}
127
128	294x	matrix_intersections <- !is.na(matrix_weights)
129	294x	matrix_weights[is.na(matrix_weights)] <- 0
130
131	294x	cbind(matrix_intersections, matrix_weights)
132		}

1		#' S3 print method for the class `power_report`
2		#'
3		#' @description
4		#' A printed `power_report` displays the initial graph, testing and simulation
5		#' options, power outputs, and optional detailed simulations and test results.
6		#'
7		#' @param x An object of the class `power_report` to print
8		#' @inheritParams print.graph_report
9		#'
10		#' @return An object x of the class `power_report`, after printing the report of
11		#' conducting power simulations based on a graphical multiple comparison
12		#' procedure.
13		#'
14		#' @rdname print.power_report
15		#'
16		#' @export
17		#'
18		#' @references
19		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
20		#' Rohmeyer, K. (2011a). Graphical approaches for multiple comparison
21		#' procedures using weighted Bonferroni, Simes, or parametric tests.
22		#' \emph{Biometrical Journal}, 53(6), 894-913.
23		#'
24		#' Bretz, F., Maurer, W., and Hommel, G. (2011b). Test and power
25		#' considerations for multiple endpoint analyses using sequentially rejective
26		#' graphical procedures. \emph{Statistics in Medicine}, 30(13), 1489-1501.
27		#'
28		#' @examples
29		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
30		#' # and H2) and two secondary hypotheses (H3 and H4)
31		#' # See Figure 4 in Bretz et al. (2011).
32		#' alpha <- 0.025
33		#' hypotheses <- c(0.5, 0.5, 0, 0)
34		#' delta <- 0.5
35		#' transitions <- rbind(
36		#' c(0, delta, 1 - delta, 0),
37		#' c(delta, 0, 0, 1 - delta),
38		#' c(0, 1, 0, 0),
39		#' c(1, 0, 0, 0)
40		#' )
41		#' g <- graph_create(hypotheses, transitions)
42		#'
43		#' marginal_power <- c(0.8, 0.8, 0.7, 0.9)
44		#' corr1 <- matrix(0.5, nrow = 2, ncol = 2)
45		#' diag(corr1) <- 1
46		#' corr <- rbind(
47		#' cbind(corr1, 0.5 * corr1),
48		#' cbind(0.5 * corr1, corr1)
49		#' )
50		#' success_fns <- list(
51		#' # Probability to reject both H1 and H2
52		#' `H1andH2` = function(x) x[1] & x[2],
53		#' # Probability to reject both (H1 and H3) or (H2 and H4)
54		#' `(H1andH3)or(H2andH4)` = function(x) (x[1] & x[3]) \| (x[2] & x[4])
55		#' )
56		#' set.seed(1234)
57		#' # Bonferroni tests
58		#' power_output <- graph_calculate_power(
59		#' g,
60		#' alpha,
61		#' sim_corr = corr,
62		#' sim_n = 1e5,
63		#' power_marginal = marginal_power,
64		#' sim_success = success_fns
65		#' )
66		print.power_report <- function(x, ..., precision = 4, indent = 2, rows = 10) {
67	7x	pad <- paste(rep(" ", indent), collapse = "")
68	7x	pad_less_1 <- paste(rep(" ", max(indent - 1, 0)), collapse = "")
69	7x	hyp_names <- names(x$inputs$graph$hypotheses)
70
71		# Test input calcs -----------------------------------------------------------
72	7x	cat("\n")
73	7x	section_break("Test parameters ($inputs)")
74
75	7x	hyp_groups <- lapply(x$inputs$test_groups, function(group) hyp_names[group])
76	7x	pad_tests <- formatC(
77	7x	x$inputs$test_types,
78	7x	width = max(nchar(x$inputs$test_types)) + indent
79		)
80
81	7x	test_spec <- paste0(
82	7x	pad_tests,
83		": (",
84	7x	lapply(hyp_groups, paste, collapse = ", "),
85		")",
86	7x	collapse = "\n"
87		)
88
89	7x	if (!is.null(x$inputs$test_corr)) {
90	3x	para_hyps <-
91	3x	unlist(x$inputs$test_groups[x$inputs$test_types == "parametric"])
92	3x	dimnames(x$inputs$test_corr) <- dimnames(x$inputs$graph$transitions)
93	3x	colname_pad <- format(
94	3x	"Parametric testing correlation: ",
95	3x	width = max(nchar(rownames(x$inputs$test_corr[para_hyps, para_hyps])))
96		)
97	3x	label <- paste0(pad_less_1, colname_pad)
98	3x	df_corr <- data.frame(
99	3x	paste0(pad_less_1, rownames(x$inputs$test_corr)[para_hyps]),
100	3x	format(x$inputs$test_corr[para_hyps, para_hyps], digits = precision),
101	3x	check.names = FALSE
102		)
103	3x	names(df_corr)[[1]] <- label
104		}
105
106		# Test input print -----------------------------------------------------------
107	7x	print(x$inputs$graph, precision = precision, indent = indent)
108	7x	cat("\n")
109	7x	cat(pad, "Alpha = ", x$inputs$alpha, sep = "")
110	7x	cat("\n\n")
111	7x	if (!is.null(x$inputs$test_corr)) {
112	3x	print(df_corr, row.names = FALSE)
113	3x	cat("\n")
114		}
115	7x	cat(pad, "Test types", "\n", test_spec, sep = "")
116	7x	cat("\n")
117
118		# Sim input calcs ------------------------------------------------------------
119	7x	cat("\n")
120	7x	section_break("Simulation parameters ($inputs)")
121
122	7x	theta_mat <- matrix(
123	7x	x$inputs$power_marginal,
124	7x	nrow = 1,
125	7x	dimnames = list(
126	7x	paste0(pad, "Marginal power:"),
127	7x	hyp_names
128		),
129		)
130
131	7x	dimnames(x$inputs$sim_corr) <- dimnames(x$inputs$graph$transitions)
132	7x	colname_pad <- format(
133	7x	"Correlation: ",
134	7x	width = max(nchar(rownames(x$inputs$sim_corr)))
135		)
136	7x	label <- paste0(pad_less_1, colname_pad)
137	7x	df_corr <- data.frame(
138	7x	paste0(pad_less_1, rownames(x$inputs$sim_corr)),
139	7x	format(x$inputs$sim_corr, digits = precision),
140	7x	check.names = FALSE
141		)
142	7x	names(df_corr)[[1]] <- label
143
144		# Sim input print ------------------------------------------------------------
145	7x	cat(paste0(
146	7x	paste0(pad, "Testing "),
147	7x	format(x$inputs$sim_n, scientific = FALSE, big.mark = ","),
148	7x	" simulations with multivariate normal params:"
149		))
150	7x	cat("\n\n")
151
152	7x	print(as.data.frame(format(theta_mat, digits = precision)))
153	7x	cat("\n")
154	7x	print(df_corr, row.names = FALSE)
155
156		# Power ----------------------------------------------------------------------
157	7x	cat("\n")
158	7x	section_break("Power calculation ($power)")
159
160	7x	local_mat <- matrix(
161	7x	x$power$power_local,
162	7x	nrow = 1,
163	7x	dimnames = list(
164	7x	paste0(pad, " Local power:"),
165	7x	hyp_names
166		),
167		)
168
169	7x	print(as.data.frame(format(local_mat, digits = precision)))
170	7x	cat("\n")
171
172	7x	cat(
173	7x	pad,
174	7x	"Expected no. of rejections: ",
175	7x	format(x$power$rejection_expected, digits = precision),
176	7x	"\n",
177	7x	sep = ""
178		)
179	7x	cat(
180	7x	pad,
181	7x	" Power to reject 1 or more: ",
182	7x	format(x$power$power_at_least_1, digits = precision),
183	7x	"\n",
184	7x	sep = ""
185		)
186	7x	cat(
187	7x	pad,
188	7x	" Power to reject all: ",
189	7x	format(x$power$power_all, digits = precision),
190	7x	"\n",
191	7x	sep = ""
192		)
193
194	7x	if (!length(x$power$power_success) == 0) {
195	1x	cat("\n")
196
197	1x	success_df <- data.frame(
198	1x	` Success measure` = paste0(pad_less_1, names(x$power$power_success)),
199	1x	`Power` = format(x$power$power_success, digits = precision),
200	1x	check.names = FALSE
201		)
202
203	1x	print(success_df, row.names = FALSE)
204		}
205	7x	cat("\n")
206
207		# Details --------------------------------------------------------------------
208	7x	if (!is.null(x$details)) {
209	2x	section_break("Simulation details ($details)")
210
211	2x	p_dets <- format(x$details$p_sim, digits = precision)
212	2x	colnames(p_dets) <- paste0("p_sim_", hyp_names)
213	2x	colnames(p_dets)[[1]] <- paste0(pad_less_1, colnames(p_dets)[[1]])
214
215	2x	test_dets <- x$details$test_results
216	2x	colnames(test_dets) <- paste0("rej_", hyp_names)
217
218	2x	max_print_old <- getOption("max.print")
219	2x	options(max.print = 99999)
220
221	2x	sim_det_out <- utils::capture.output(
222	2x	print(
223	2x	utils::head(
224	2x	cbind(as.data.frame(p_dets), as.data.frame(test_dets)),
225	2x	rows
226		),
227	2x	row.names = FALSE
228		)
229		)
230	2x	cat(paste0(pad, sim_det_out), sep = "\n")
231
232	2x	options(max.print = max_print_old)
233
234	2x	if (rows < nrow(p_dets)) {
235	1x	cat(pad, "... (Use `print(x, rows = <nn>)` for more)\n\n", sep = "")
236		} else {
237	1x	cat("\n")
238		}
239		}
240
241	7x	invisible(x)
242		}

1		#' Find alternate rejection orderings (sequences) for shortcut tests
2		#'
3		#' @description
4		#' When multiple hypotheses are rejected by using [graph_test_shortcut()],
5		#' there may be multiple orderings or sequences in which hypotheses are rejected
6		#' one by one. The default order in [graph_test_shortcut()] is based on the
7		#' adjusted p-values, from the smallest to the largest. This function
8		#' [graph_rejection_orderings()] provides all possible and valid orders
9		#' (or sequences) of rejections. Although the order of rejection does not affect
10		#' the final rejection decisions Bretz et al. (2009), different sequences could
11		#' offer different ways to explain the step-by-step process of shortcut
12		#' graphical multiple comparison procedures.
13		#'
14		#' @param shortcut_test_result A `graph_report` object as returned by
15		#' [graph_test_shortcut()].
16		#'
17		#' @return A modified `graph_report` object containing all valid orderings of
18		#' rejections of hypotheses
19		#'
20		#' @seealso
21		#' [graph_test_shortcut()] for shortcut graphical multiple comparison
22		#' procedures.
23		#'
24		#' @rdname graph_rejection_orderings
25		#'
26		#' @export
27		#'
28		#' @references
29		#' Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
30		#' approach to sequentially rejective multiple test procedures.
31		#' \emph{Statistics in Medicine}, 28(4), 586-604.
32		#'
33		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
34		#' Rohmeyer, K. (2011). Graphical approaches for multiple comparison
35		#' procedures using weighted Bonferroni, Simes, or parametric tests.
36		#' \emph{Biometrical Journal}, 53(6), 894-913.
37		#'
38		#' @examples
39		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
40		#' # and H2) and two secondary hypotheses (H3 and H4)
41		#' # See Figure 4 in Bretz et al. (2011).
42		#' hypotheses <- c(0.5, 0.5, 0, 0)
43		#' delta <- 0.5
44		#' transitions <- rbind(
45		#' c(0, delta, 1 - delta, 0),
46		#' c(delta, 0, 0, 1 - delta),
47		#' c(0, 1, 0, 0),
48		#' c(1, 0, 0, 0)
49		#' )
50		#' g <- graph_create(hypotheses, transitions)
51		#'
52		#' p <- c(0.018, 0.01, 0.105, 0.006)
53		#' alpha <- 0.025
54		#'
55		#' shortcut_testing <- graph_test_shortcut(g, p, alpha, verbose = TRUE)
56		#'
57		#' # Reject H1, H2, and H4
58		#' shortcut_testing$outputs$rejected
59		#'
60		#' # Default order of rejections: H2, H1, H4
61		#' shortcut_testing$details$del_seq
62		#'
63		#' # There is another valid sequence of rejection: H2, H4, H1
64		#' graph_rejection_orderings(shortcut_testing)$valid_orderings
65		#'
66		#' # Finally, intermediate updated graphs can be obtained by providing the order
67		#' # of rejections into `[graph_update()]`
68		#' graph_update(g, delete = c(2, 4, 1))
69		graph_rejection_orderings <- function(shortcut_test_result) {
70		# Extract basic testing values -----------------------------------------------
71	2x	graph <- shortcut_test_result$inputs$graph
72	2x	p <- shortcut_test_result$inputs$p
73	2x	alpha <- shortcut_test_result$inputs$alpha
74
75	2x	hyp_names <- names(graph$hypotheses)
76
77		# Permute rejected hypotheses ------------------------------------------------
78	2x	rejected <- which(shortcut_test_result$outputs$rejected)
79
80	2x	list_possible_orderings <- apply(
81	2x	rev(expand.grid(rep(list(rejected), length(rejected)))),
82	2x	1,
83	2x	function(row) {
84	46912x	if (length(unique(row)) == length(row)) {
85	744x	structure(row, names = hyp_names[row])
86		} else {
87	46168x	NULL
88		}
89		}
90		)
91	2x	list_possible_orderings <- Filter(Negate(is.null), list_possible_orderings)
92
93		# Find which permutations are valid rejection orderings ----------------------
94	2x	orderings_valid <- vector("logical", length(list_possible_orderings))
95
96	2x	for (hyp_ordering_num in seq_along(list_possible_orderings)) {
97	744x	hyp_ordering <- list_possible_orderings[[hyp_ordering_num]]
98	744x	intermediate_graph <- graph
99
100	744x	for (hyp_num in hyp_ordering) {
101	958x	if (p[[hyp_num]] <= intermediate_graph$hypotheses[[hyp_num]] * alpha) {
102	224x	intermediate_graph <-
103	224x	graph_update(intermediate_graph, hyp_num)$updated_graph
104		} else {
105	734x	orderings_valid[[hyp_ordering_num]] <- FALSE
106	734x	break
107		}
108
109	224x	orderings_valid[[hyp_ordering_num]] <- TRUE
110		}
111		}
112
113	2x	structure(
114	2x	c(
115	2x	shortcut_test_result,
116	2x	list(valid_orderings = list_possible_orderings[orderings_valid])
117		),
118	2x	class = "graph_report"
119		)
120		}

1		#' Perform shortcut (sequentially rejective) graphical multiple comparison
2		#' procedures
3		#'
4		#' @description
5		#' Shortcut graphical multiple comparison procedures are sequentially rejective
6		#' procedure based on Bretz et al. (2009). With $m$ hypotheses, there are at
7		#' most $m$ steps to obtain all rejection decisions. These procedure are
8		#' equivalent to closed graphical multiple comparison procedures using
9		#' Bonferroni tests for intersection hypotheses, but shortcut procedures are
10		#' faster to perform. See `vignette("shortcut-testing")` for more illustration
11		#' of shortcut procedures and interpretation of their outputs.
12		#'
13		#' @inheritParams graph_update
14		#' @param p A numeric vector of p-values (unadjusted, raw), whose values should
15		#' be between 0 & 1. The length should match the number of hypotheses in
16		#' `graph`.
17		#' @param alpha A numeric scalar of the overall significance level, which should
18		#' be between 0 & 1. The default is 0.025 for one-sided hypothesis testing
19		#' problems; another common choice is 0.05 for two-sided hypothesis testing
20		#' problems.
21		#' @param verbose A logical scalar specifying whether the details of
22		#' intermediate update graphs should be included in results. When
23		#' `verbose = TRUE`, intermediate update graphs are provided after deleting
24		#' each hypothesis, which has been rejected. The default is `verbose = FALSE`.
25		#' @param test_values A logical scalar specifying whether adjusted significance
26		#' levels should be provided for each hypothesis. When `test_values = TRUE`,
27		#' it provides an equivalent way of performing graphical multiple comparison
28		#' procedures by comparing each p-value with its significance level. If the
29		#' p-value of a hypothesis is less than or equal to its significance level,
30		#' the hypothesis is rejected. The order of rejection is based on the order
31		#' of adjusted p-values from the smallest to the largest. The default is
32		#' `test_values = FALSE`.
33		#'
34		#' @return An S3 object of class `graph_report` with a list of 4 elements:
35		#' * `inputs` - Input parameters, which is a list of:
36		#' * `graph` - Initial graph,
37		#' *`p` - (Unadjusted or raw) p-values,
38		#' * `alpha` - Overall significance level,
39		#' * `test_groups` - Groups of hypotheses for different types of tests,
40		#' which are the list of all hypotheses for [graph_test_shortcut()],
41		#' * `test_types` - Different types of tests, which are "bonferroni" for
42		#' [graph_test_shortcut()].
43		#' * Output parameters `outputs`, which is a list of:
44		#' * `adjusted_p` - Adjusted p-values,
45		#' * `rejected` - Rejected hypotheses,
46		#' * `graph` - Updated graph after deleting all rejected hypotheses.
47		#' * `details` - Verbose outputs with intermediate updated graphs, if
48		#' `verbose = TRUE`.
49		#' * `test_values` - Adjusted significance levels, if `test_values = TRUE`.
50		#'
51		#' @seealso
52		#' * [graph_test_closure()] for graphical multiple comparison procedures using
53		#' the closed test,
54		#' * [graph_rejection_orderings()] for all possible rejection orderings.
55		#'
56		#' @rdname graph_test_shortcut
57		#'
58		#' @export
59		#'
60		#' @references
61		#' Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
62		#' approach to sequentially rejective multiple test procedures.
63		#' \emph{Statistics in Medicine}, 28(4), 586-604.
64		#'
65		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
66		#' Rohmeyer, K. (2011). Graphical approaches for multiple comparison
67		#' procedures using weighted Bonferroni, Simes, or parametric tests.
68		#' \emph{Biometrical Journal}, 53(6), 894-913.
69		#'
70		#' @examples
71		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
72		#' # and H2) and two secondary hypotheses (H3 and H4)
73		#' # See Figure 1 in Bretz et al. (2011).
74		#' hypotheses <- c(0.5, 0.5, 0, 0)
75		#' transitions <- rbind(
76		#' c(0, 0, 1, 0),
77		#' c(0, 0, 0, 1),
78		#' c(0, 1, 0, 0),
79		#' c(1, 0, 0, 0)
80		#' )
81		#' g <- graph_create(hypotheses, transitions)
82		#'
83		#' p <- c(0.018, 0.01, 0.105, 0.006)
84		#' alpha <- 0.025
85		#' graph_test_shortcut(g, p, alpha)
86		graph_test_shortcut <- function(graph,
87		p,
88		alpha = 0.025,
89		verbose = FALSE,
90		test_values = FALSE) {
91		# Input validation -----------------------------------------------------------
92	149x	test_input_val(
93	149x	graph,
94	149x	p,
95	149x	alpha,
96	149x	test_groups = list(seq_along(graph$hypotheses)),
97	149x	test_types = "bonferroni",
98	149x	test_corr = list(NA),
99	149x	verbose = verbose,
100	149x	test_values = test_values
101		)
102
103	149x	initial_graph <- graph
104
105	149x	hyp_names <- names(graph$hypotheses)
106	149x	num_hyps <- length(graph$hypotheses)
107
108		# Adjusted p-value calculations ----------------------------------------------
109	149x	names(p) <- hyp_names
110	149x	adjusted_p <- structure(vector("numeric", num_hyps), names = hyp_names)
111	149x	adjusted_p_max <- 0
112
113	149x	hyps_deleted_sequence <- vector("integer")
114
115		# Calculate adjusted p-values for all hypotheses by deleting every hypothesis
116		# one at a time
117	149x	for (i in seq_along(graph$hypotheses)) {
118	563x	hyps_not_deleted <- setdiff(hyp_names, hyps_deleted_sequence)
119
120	563x	adjusted_p_subgraph <-
121	563x	p[hyps_not_deleted] / graph$hypotheses[hyps_not_deleted]
122
123		# which.min will throw an error if all elements are missing; we want to
124		# catch this before which.min does
125	563x	if (all(is.nan(adjusted_p_subgraph))) {
126	4x	err_msg <- paste0(
127	4x	"Calculation of adjusted p-values stops when all remaining\n",
128	4x	" hypotheses have 0 hypothesis weights and 0 p-values\n",
129	4x	" Hypotheses [", paste(hyps_deleted_sequence, collapse = ", "), "]\n",
130	4x	" have been deleted\n",
131	4x	paste(
132	4x	utils::capture.output(print(
133	4x	graph,
134	4x	indent = 2,
135	4x	precision = 6,
136	4x	title = paste0("Step ", i, ", Graph state:")
137		)),
138	4x	collapse = "\n"
139		)
140		)
141
142	4x	stop(err_msg)
143		}
144
145		# Identify the hypothesis with the smallest adjusted p-value only among
146		# hypotheses not deleted so far. Choose the first hypothesis in case of a
147		# tie in adjusted p-values.
148	559x	min_hyp_name <- names(which.min(adjusted_p_subgraph[hyps_not_deleted]))
149
150		# Record the adjusted p-value for the current hypothesis being considered;
151		# that is, the largest adjusted p-value seen so far in the sequence
152	559x	adjusted_p_max <- max(adjusted_p_max, adjusted_p_subgraph[[min_hyp_name]])
153	559x	adjusted_p[[min_hyp_name]] <- adjusted_p_max
154
155	559x	hyps_deleted_sequence <- c(hyps_deleted_sequence, min_hyp_name)
156
157		# Update graph to delete a hypothesis
158	559x	graph <-
159	559x	graph_update(graph, hyp_names %in% hyps_deleted_sequence)$updated_graph
160		}
161
162	145x	rejected <- round(adjusted_p, 10) <= alpha
163	145x	adjusted_p <- pmin(adjusted_p, 1 + 1e-14) # adj p-values should not exceed 1
164
165		# Adjusted p-value details (sequence of graphs) ------------------------------
166	145x	if (verbose) {
167		# The first n = (number of rejected) hypotheses in the adjusted p sequence
168		# are the hypotheses that will be rejected
169	132x	rejection_sequence <- hyps_deleted_sequence[seq_along(which(rejected))]
170
171		# The sequence of graphs is the initial graph, plus one entry for each
172		# rejected hypothesis
173	132x	graph_sequence <- vector("list", length(rejection_sequence) + 1)
174	132x	graph_sequence[[1]] <- initial_graph
175
176	132x	if (length(rejection_sequence) > 0) {
177	63x	verbose_delete <- rep(FALSE, num_hyps)
178	63x	names(verbose_delete) <- hyp_names
179
180		# Starting from the original initial graph, delete each hypothesis with
181		# adjusted p-value less than alpha. Record the graph state after each
182		# deletion
183	63x	for (hyp_num_to_reject in seq_along(rejection_sequence)) {
184	173x	hyp_name_to_reject <- rejection_sequence[[hyp_num_to_reject]]
185	173x	verbose_delete[[hyp_name_to_reject]] <- TRUE
186
187		# Update a graph to delete a hypothesis. Record the resulting graph
188	173x	graph_sequence[[hyp_num_to_reject + 1]] <- graph_update(
189	173x	graph_sequence[[hyp_num_to_reject]],
190	173x	verbose_delete
191	173x	)$updated_graph
192		}
193		}
194
195	132x	details <- list(del_seq = rejection_sequence, results = graph_sequence)
196		}
197
198		# Adjusted weight details ----------------------------------------------------
199	145x	if (test_values) {
200		# Record the final graph after all rejected hypotheses have been deleted
201	5x	graph_after_rejections <-
202	5x	graph_update(initial_graph, rejected)$updated_graph
203
204	5x	df_test_values <- NULL
205
206	5x	step_graph <- initial_graph
207	5x	step_num <- 1
208
209		# Calculate adjusted weights for all hypotheses. For rejected hypotheses,
210		# adjusted weights should come from the last graph they're present in. For
211		# non-rejected hypotheses, adjusted weights should be calculated from the
212		# graph with all rejected hypotheses deleted.
213	5x	for (i in seq_along(hyps_deleted_sequence)) {
214		# Follow the same hypothesis order as adjusted p-values
215	26x	hyp_name_for_test_values <- hyps_deleted_sequence[[i]]
216
217		# Record adjusted weights
218	26x	test_values_step <- test_values_bonferroni(
219	26x	p[hyp_name_for_test_values],
220	26x	step_graph$hypotheses[hyp_name_for_test_values],
221	26x	alpha
222		)
223
224		# Normally the first column of `*_test_values()` is an intersection
225		# counter. Since shortcut testing doesn't track intersections, re-purpose
226		# that column as a step counter. Steps count up one at a time for each
227		# hypothesis rejected, then switch to NA for non-rejected hypotheses (i.e.
228		# "These rows represent steps that are not taken by the shortcut rejection
229		# algorithm")
230	26x	names(test_values_step)[[1]] <- "Step"
231	26x	test_values_step$Step <- step_num
232	26x	test_values_step[c("Test", "c_value")] <- NULL
233
234	26x	df_test_values <- rbind(df_test_values, test_values_step)
235
236	26x	if (rejected[hyp_name_for_test_values]) {
237	18x	step_num <- step_num + 1
238
239	18x	step_graph <- graph_update(
240	18x	step_graph,
241	18x	hyp_names == hyp_name_for_test_values
242	18x	)$updated_graph
243		} else {
244	8x	step_graph <- graph_after_rejections
245		}
246		}
247	5x	rownames(df_test_values) <- NULL
248		}
249
250		# Build the report -----------------------------------------------------------
251		# The core output of a test report is the adjusted p-values, rejection
252		# decisions, and resulting graph after deleting all rejected hypotheses.
253		# Inputs are recorded as well. Details about adjusted p-values and test
254		# values are optionally available.
255	145x	structure(
256	145x	list(
257	145x	inputs = list(
258	145x	graph = initial_graph,
259	145x	p = p,
260	145x	alpha = alpha,
261	145x	test_groups = list(seq_len(num_hyps)),
262	145x	test_types = "bonferroni",
263	145x	test_corr = NULL
264		),
265	145x	outputs = list(
266	145x	adjusted_p = adjusted_p,
267	145x	rejected = rejected,
268	145x	graph = graph_update(initial_graph, rejected)$updated_graph
269		),
270	145x	details = if (verbose) details,
271	145x	test_values = if (test_values) list(results = df_test_values)
272		),
273	145x	class = "graph_report"
274		)
275		}

1		#' S3 print method for the class `updated_graph`
2		#'
3		#' @description
4		#' A printed `updated_graph` displays the initial graph, the (final) updated
5		#' graph, and the sequence of intermediate updated graphs after hypotheses are
6		#' deleted (if available).
7		#'
8		#' @param x An object of the class `updated_graph` to print.
9		#' @param ... Other values passed on to other methods (currently unused).
10		#' @param precision An integer scalar indicating the number of decimal places
11		#' to to display.
12		#' @param indent An integer scalar indicating how many spaces to indent results.
13		#'
14		#' @return An object x of the class `updated_graph`, after printing the updated
15		#' graph.
16		#'
17		#' @seealso
18		#' [print.initial_graph()] for the print method for the initial graph.
19		#'
20		#' @rdname print.updated_graph
21		#'
22		#' @export
23		#'
24		#' @references
25		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
26		#' Rohmeyer, K. (2011a). Graphical approaches for multiple comparison
27		#' procedures using weighted Bonferroni, Simes, or parametric tests.
28		#' \emph{Biometrical Journal}, 53(6), 894-913.
29		#'
30		#' @examples
31		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
32		#' # and H2) and two secondary hypotheses (H3 and H4)
33		#' # See Figure 1 in Bretz et al. (2011).
34		#' hypotheses <- c(0.5, 0.5, 0, 0)
35		#' transitions <- rbind(
36		#' c(0, 0, 1, 0),
37		#' c(0, 0, 0, 1),
38		#' c(0, 1, 0, 0),
39		#' c(1, 0, 0, 0)
40		#' )
41		#' g <- graph_create(hypotheses, transitions)
42		#'
43		#' # Delete the second and third hypotheses in the "unordered mode"
44		#' graph_update(g, delete = c(FALSE, TRUE, TRUE, FALSE))
45		#'
46		#' # Equivalent way in the "ordered mode" to obtain the updated graph after
47		#' # deleting the second and third hypotheses
48		#' # Additional intermediate updated graphs are also provided
49		#' graph_update(g, delete = 2:3)
50		print.updated_graph <- function(x, ..., precision = 6, indent = 2) {
51		# Initial graph and updated graph
52	9x	section_break("Initial and final graphs")
53	9x	cat("\n")
54
55	9x	print(x$initial_graph, ...)
56
57	9x	cat("\n")
58
59	9x	if (length(x$deleted) == 0) {
60	1x	title <- "Updated graph after deleting no hypotheses"
61	8x	} else if (length(x$deleted) == 1) {
62	2x	title <- paste("Updated graph after deleting hypothesis", x$deleted)
63		} else {
64	6x	title <- paste(
65	6x	"Updated graph after deleting hypotheses",
66	6x	paste(x$deleted, collapse = ", ")
67		)
68		}
69
70	9x	attr(x$updated_graph, "title") <- title
71
72	9x	print(x$updated_graph, ...)
73
74		# Graph sequence
75	9x	if (!is.null(x$intermediate_graphs)) {
76	8x	graph_seq <- x$intermediate_graphs
77	8x	del_seq <- x$deleted
78
79	8x	cat("\n")
80	8x	section_break("Deletion sequence ($intermediate_graphs)")
81	8x	cat("\n")
82	8x	for (i in seq_along(graph_seq) - 1) {
83	24x	if (i == 0) {
84	8x	print(graph_seq[[i + 1]], precision = precision, indent = indent)
85		} else {
86	16x	attr(graph_seq[[i + 1]], "title") <- paste0(
87	16x	"Step ", i, ": Updated graph after removing ",
88	16x	if (i == 1) "hypothesis " else "hypotheses ",
89	16x	paste0(del_seq[seq_len(i)], collapse = ", ")
90		)
91
92	16x	print(
93	16x	graph_seq[[i + 1]],
94	16x	precision = precision,
95	16x	indent = indent * (i + 1)
96		)
97		}
98	24x	cat("\n")
99		}
100
101	8x	attr(graph_seq[[length(graph_seq)]], "title") <-
102	8x	"Final updated graph after removing deleted hypotheses"
103
104	8x	print(
105	8x	graph_seq[[length(graph_seq)]],
106	8x	precision = precision,
107	8x	indent = indent
108		)
109	8x	cat("\n")
110		}
111
112	9x	invisible(x)
113		}

1		#' Alpha spending functions for group sequential designs
2		#'
3		#' @description
4		#' Alpha spending functions determine how the total significance level (alpha)
5		#' is allocated across interim and final analyses in a group sequential design.
6		#' Given the total alpha and the information fraction(s) at one or more
7		#' analyses, a spending function returns the cumulative alpha spent at each
8		#' information fraction.
9		#'
10		#' Four commonly used spending functions are provided:
11		#' * [spending_of()] for the Lan-DeMets O'Brien-Fleming approximation,
12		#' * [spending_pocock()] for the Lan-DeMets Pocock approximation,
13		#' * [spending_hsd()] for the Hwang-Shih-DeCani family,
14		#' * [spending_linear()] for linear (uniform) spending.
15		#'
16		#' @param alpha A numeric scalar of the total significance level to be spent.
17		#' Must be between 0 and 1.
18		#' @param info_frac A numeric scalar or vector of information fractions. Values
19		#' must be non-negative. When `info_frac = 0`, the spending is 0. When
20		#' `info_frac >= 1`, the spending is capped at `alpha`.
21		#' @param gamma A numeric scalar for the gamma parameter of the
22		#' Hwang-Shih-DeCani spending function. Common choices are `gamma = -4`
23		#' (approximates O'Brien-Fleming), `gamma = 1` (approximates Pocock), and
24		#' `gamma = 0` (linear spending). The default is `gamma = -4`.
25		#'
26		#' @return A numeric vector the same length as `info_frac` of cumulative alpha
27		#' spent at each information fraction.
28		#'
29		#' @details
30		#' All spending functions satisfy the following properties:
31		#' * \eqn{f(\alpha, 0) = 0},
32		#' * \eqn{f(\alpha, 1) = \alpha},
33		#' * \eqn{f(\alpha, t)} is non-decreasing in \eqn{t}.
34		#'
35		#' The cumulative alpha spent at analysis \eqn{k} is \eqn{f(\alpha, t_k)},
36		#' and the incremental spending is
37		#' \deqn{\Delta\alpha_k = f(\alpha, t_k) - f(\alpha, t_{k-1}).}
38		#'
39		#' Note that the incremental spending is \emph{not} the nominal significance
40		#' level (boundary) at analysis \eqn{k}. The boundary must be derived from the
41		#' spending using the joint distribution of test statistics across analyses.
42		#' See [sequential_p()] and [graph_test_shortcut_gsd()] for details.
43		#'
44		#' @section Spending function formulas:
45		#' * O'Brien-Fleming (`spending_of`):
46		#' \deqn{f(\alpha, t) = 2\left(1 - \Phi\left(\frac{\Phi^{-1}(1 - \alpha/2)}
47		#' {\sqrt{t}}\right)\right).}
48		#' This is the Lan-DeMets approximation to O'Brien-Fleming boundaries.
49		#' It is very conservative at early analyses and spends most of the alpha
50		#' at the final analysis.
51		#'
52		#' * Pocock (`spending_pocock`):
53		#' \deqn{f(\alpha, t) = \alpha \cdot \ln(1 + (e - 1) \cdot t).}
54		#' This spends alpha more evenly across analyses compared to O'Brien-Fleming.
55		#'
56		#' * Hwang-Shih-DeCani (`spending_hsd`):
57		#' \deqn{f(\alpha, t) = \alpha \cdot \frac{1 - e^{-\gamma t}}{1 -
58		#' e^{-\gamma}}, \quad \gamma \neq 0,}
59		#' \deqn{f(\alpha, t) = \alpha \cdot t, \quad \gamma = 0.}
60		#' With `gamma = -4`, it approximates O'Brien-Fleming; with `gamma = 1`,
61		#' it approximates Pocock.
62		#'
63		#' * Linear (`spending_linear`):
64		#' \deqn{f(\alpha, t) = \alpha \cdot t.}
65		#'
66		#' @references
67		#' Lan, K. K. G., and DeMets, D. L. (1983). Discrete sequential boundaries
68		#' for clinical trials. \emph{Biometrika}, 70(3), 659-663.
69		#'
70		#' Hwang, I. K., Shih, W. J., and De Cani, J. S. (1990). Group sequential
71		#' designs using a family of type I error probability spending functions.
72		#' \emph{Statistics in Medicine}, 9(12), 1439-1445.
73		#'
74		#' @rdname spending_functions
75		#'
76		#' @export
77		#'
78		#' @examples
79		#' # O'Brien-Fleming spending at 50% information
80		#' spending_of(0.025, 0.5)
81		#'
82		#' # Cumulative spending across analyses (vectorized)
83		#' spending_of(0.025, c(0, 0.5, 1))
84		#'
85		#' # Compare spending functions at information fractions (1/3, 2/3, 1)
86		#' spending_of(0.025, c(1 / 3, 2 / 3, 1))
87		#' spending_pocock(0.025, c(1 / 3, 2 / 3, 1))
88		#' spending_hsd(0.025, c(1 / 3, 2 / 3, 1), gamma = -4)
89		#' spending_linear(0.025, c(1 / 3, 2 / 3, 1))
90		#'
91		#' # User-defined spending function: piecewise combination.
92		#' # Use O'Brien-Fleming for the first half of alpha (conservative at
93		#' # early analyses), and Pocock for the second half (more aggressive).
94		#' # This can be useful when a hypothesis starts with a small weight
95		#' # (OBF spending) and later receives additional weight via graph
96		#' # propagation (Pocock spending for the increment).
97		#' spending_piecewise <- function(alpha, info_frac, threshold = 0.0125) {
98		#' spending_of(pmin(alpha, threshold), info_frac) +
99		#' spending_pocock(pmax(alpha - threshold, 0), info_frac)
100		#' }
101		#' spending_piecewise(0.025, c(1 / 3, 2 / 3, 1))
102		#' # Compare: alpha = 0.0125 uses only OBF
103		#' spending_piecewise(0.0125, c(1 / 3, 2 / 3, 1))
104		#' spending_of(0.0125, c(1 / 3, 2 / 3, 1))
105		spending_of <- function(alpha, info_frac) {
106	5609x	stopifnot(
107	5609x	"info_frac must be non-negative" = all(info_frac >= 0),
108	5609x	"At most one info_frac value can be >= 1" = sum(info_frac >= 1) <= 1
109		)
110	5608x	result <- 2 * (1 - stats::pnorm(stats::qnorm(1 - alpha / 2) / sqrt(info_frac)))
111	5608x	result[info_frac == 0] <- 0
112	5608x	result <- pmin(result, alpha)
113	5608x	result
114		}
115
116		#' @rdname spending_functions
117		#' @export
118		#' @examples
119		#' # Pocock spending at 50% information
120		#' spending_pocock(0.025, 0.5)
121		spending_pocock <- function(alpha, info_frac) {
122	1114x	stopifnot(
123	1114x	"info_frac must be non-negative" = all(info_frac >= 0),
124	1114x	"At most one info_frac value can be >= 1" = sum(info_frac >= 1) <= 1
125		)
126	1113x	result <- alpha * log(1 + (exp(1) - 1) * info_frac)
127	1113x	result[info_frac == 0] <- 0
128	1113x	result <- pmin(result, alpha)
129	1113x	result
130		}
131
132		#' @rdname spending_functions
133		#' @export
134		#' @examples
135		#' # Hwang-Shih-DeCani spending at 50% information
136		#' spending_hsd(0.025, 0.5, gamma = -4)
137		#' spending_hsd(0.025, 0.5, gamma = 1)
138		#' spending_hsd(0.025, 0.5, gamma = 0)
139		spending_hsd <- function(alpha, info_frac, gamma = -4) {
140	11x	stopifnot(
141	11x	"info_frac must be non-negative" = all(info_frac >= 0),
142	11x	"At most one info_frac value can be >= 1" = sum(info_frac >= 1) <= 1
143		)
144	10x	if (gamma == 0) {
145	!	result <- alpha * info_frac
146		} else {
147	10x	result <- alpha * (1 - exp(-gamma * info_frac)) / (1 - exp(-gamma))
148		}
149	10x	result[info_frac == 0] <- 0
150	10x	result <- pmin(result, alpha)
151	10x	result
152		}
153
154		#' @rdname spending_functions
155		#' @export
156		#' @examples
157		#' # Linear spending at 50% information
158		#' spending_linear(0.025, 0.5)
159		spending_linear <- function(alpha, info_frac) {
160	80x	stopifnot(
161	80x	"info_frac must be non-negative" = all(info_frac >= 0),
162	80x	"At most one info_frac value can be >= 1" = sum(info_frac >= 1) <= 1
163		)
164	79x	pmin(alpha * info_frac, alpha)
165		}
166
167
168		#' Create a spending function with a custom spending time
169		#'
170		#' @description
171		#' Wraps an existing spending function to use a fixed spending time instead
172		#' of the information fractions passed to it at runtime. This controls only
173		#' the alpha allocation schedule. The correlation structure of the test
174		#' statistics is determined separately by the `info_frac` argument in
175		#' [graph_test_shortcut_gsd()] (via [gs_corr()]), not by the spending
176		#' function.
177		#'
178		#' This is useful in two common scenarios:
179		#' * Subgroup analyses: all-subjects hypotheses use subgroup event
180		#' fractions as spending time (controlling how alpha is allocated across
181		#' analyses), while `info_frac` in [graph_test_shortcut_gsd()] uses
182		#' all-subjects event fractions (controlling the correlation structure).
183		#' * Monitoring with changed final information: when the actual total
184		#' information at the final analysis differs from the planned total, the
185		#' planned information fractions are used as spending time to preserve
186		#' the alpha allocation at earlier analyses, while `info_frac` in
187		#' [graph_test_shortcut_gsd()] uses the actual information fractions
188		#' for the correlation structure.
189		#'
190		#' @param spending_fn A spending function to wrap. Must accept two arguments:
191		#' `alpha` (significance level) and `info_frac` (information fraction), and
192		#' return the cumulative alpha spent.
193		#' @param spending_time A numeric vector of spending time values. These replace
194		#' the `info_frac` argument when the wrapped function is called. May contain
195		#' `NA` for analyses that are skipped (e.g., a hypothesis not tested at a
196		#' particular analysis). The last non-`NA` value should be 1 if the final
197		#' analysis has been specified.
198		#' @param info_frac An optional numeric vector of information fractions with
199		#' the same length as `spending_time`. If provided, the `NA` positions are
200		#' validated to match those in `spending_time`. This ensures that the
201		#' spending time and information fraction structures are consistent.
202		#'
203		#' @return A function with the same signature as `spending_fn` —
204		#' `function(alpha, info_frac)` — that internally uses `spending_time`
205		#' instead of `info_frac` for alpha allocation.
206		#'
207		#' @seealso [spending_of()], [spending_pocock()], [spending_hsd()],
208		#' [spending_linear()] for built-in spending functions,
209		#' [graph_test_shortcut_gsd()] for the graphical procedure with group
210		#' sequential designs.
211		#'
212		#' @export
213		#'
214		#' @examples
215		#' # --- Subgroup spending time ---
216		#' # Without spending_with_time, spending_of() uses info_frac for spending:
217		#' info_frac_all <- c(529 / 800, 700 / 800, 1) # all-subjects fractions
218		#' spending_of(0.01, info_frac_all)
219		#'
220		#' # With spending_with_time, spending uses subgroup fractions instead.
221		#' # The info_frac passed at runtime is ignored by the spending function;
222		#' # it is only used by gs_boundaries()/graph_test_shortcut_gsd() for
223		#' # the correlation structure.
224		#' spending_time_sub <- c(185 / 295, 245 / 295, 1) # subgroup fractions
225		#' spending_with_time(spending_of, spending_time_sub)
226		#'
227		#' # --- Monitoring with changed final information ---
228		#' # Planned: 295 OS events at 3 analyses (185, 245, 295 events).
229		#' # spending_time uses planned fractions for interim analyses and 1
230		#' # for the final analysis.
231		#' spending_monitor <- spending_with_time(
232		#' spending_of,
233		#' spending_time = c(185 / 295, 245 / 295, 1)
234		#' )
235		#'
236		#' # Overrunning (310 events) or underrunning (280 events):
237		#' # spending_time is the same in both cases — it uses planned fractions
238		#' # for interim analyses and 1 for the final analysis, because alpha
239		#' # spent has been fixed for interim analyses. The actual info_frac
240		#' # (which differs between overrunning and underrunning) only affects
241		#' # the correlation structure in gs_boundaries()/graph_test_shortcut_gsd().
242		#' spending_monitor(0.01, c(185 / 295, 245 / 295, 1))
243		#'
244		#' # --- Skipped analyses (NA in spending_time) ---
245		#' # If a hypothesis is not tested at analysis 2, both spending_time and
246		#' # info_frac have NA at that position. The output also has NA there.
247		#' spending_skip <- spending_with_time(
248		#' spending_of,
249		#' spending_time = c(185 / 295, NA, 1),
250		#' info_frac = c(185 / 295, NA, 1)
251		#' )
252		#' spending_skip(0.01, c(185 / 295, NA, 1))
253		spending_with_time <- function(spending_fn, spending_time, info_frac = NULL) {
254	3x	stopifnot(
255	3x	"spending_fn must be a function" = is.function(spending_fn),
256	3x	"spending_time must be a numeric vector" = is.numeric(spending_time)
257		)
258
259		# Validate non-NA spending_time values
260	3x	st_non_na <- spending_time[!is.na(spending_time)]
261	3x	stopifnot(
262	3x	"Non-NA spending_time values must be non-negative" =
263	3x	length(st_non_na) == 0 \|\| all(st_non_na >= 0),
264	3x	"At most one non-NA spending_time value can be >= 1" =
265	3x	sum(st_non_na >= 1) <= 1
266		)
267
268		# If info_frac provided, validate NA positions match
269	2x	if (!is.null(info_frac)) {
270	!	stopifnot(
271	!	"spending_time and info_frac must have the same length" =
272	!	length(spending_time) == length(info_frac),
273	!	"NA positions in spending_time and info_frac must match" =
274	!	identical(is.na(spending_time), is.na(info_frac))
275		)
276		}
277
278	2x	function(alpha, info_frac_runtime) {
279	2x	non_na <- !is.na(info_frac_runtime)
280	2x	n_non_na <- sum(non_na)
281
282		# Use the first n_non_na entries of the non-NA spending_time
283	2x	st <- st_non_na[seq_len(n_non_na)]
284
285		# Compute spending for non-NA entries
286	2x	spent <- spending_fn(alpha, st)
287
288		# Build result with NAs in the same positions as info_frac_runtime
289	2x	result <- rep(NA_real_, length(info_frac_runtime))
290	2x	result[non_na] <- spent
291	2x	result
292		}
293		}
294
295
296		#' Wang-Tsiatis spending function
297		#'
298		#' @description
299		#' Computes the implied cumulative alpha spending from the Wang-Tsiatis family
300		#' of group sequential boundaries. The Wang-Tsiatis boundaries at analysis
301		#' \eqn{k} with information fraction \eqn{t_k} are defined as:
302		#' \deqn{c_k = C \cdot t_k^{\Delta - 0.5},}
303		#' where \eqn{\Delta} is the shape parameter and \eqn{C} is a constant
304		#' calibrated so that the overall Type I error equals \eqn{\alpha}.
305		#'
306		#' Special cases:
307		#' * \eqn{\Delta = 0.5}: Pocock boundaries (equal Z-scale boundaries across
308		#' analyses).
309		#' * \eqn{\Delta = 0}: O'Brien-Fleming boundaries (very conservative at
310		#' early analyses).
311		#' * \eqn{0 < \Delta < 0.5}: intermediate between O'Brien-Fleming and Pocock.
312		#'
313		#' Unlike the Lan-DeMets approximations ([spending_of()], [spending_pocock()]),
314		#' this function computes the exact boundaries from the Wang-Tsiatis
315		#' family and derives the implied spending. It is computationally more
316		#' expensive because it requires root-finding and multivariate normal
317		#' integration at each call.
318		#'
319		#' @param alpha A numeric scalar of the total significance level.
320		#' @param info_frac A numeric vector of information fractions at each analysis.
321		#' Must be non-negative, with at most one value \eqn{\geq 1}. The last
322		#' value must be \eqn{\geq 1} (i.e., the final analysis must be included),
323		#' because the Wang-Tsiatis constant \eqn{C} is calibrated over the full
324		#' set of analyses.
325		#' @param delta A numeric scalar for the shape parameter \eqn{\Delta}.
326		#' The default is `0.5` (Pocock). Use `0` for O'Brien-Fleming.
327		#' @param maxpts An integer scalar for the maximum number of function values
328		#' for [mvtnorm::GenzBretz()]. The default is 25000.
329		#' @param abseps A numeric scalar for the absolute error tolerance for
330		#' [mvtnorm::GenzBretz()]. The default is 1e-6.
331		#'
332		#' @return A numeric vector the same length as `info_frac` of cumulative alpha
333		#' spent at each information fraction.
334		#'
335		#' @seealso [spending_of()] and [spending_pocock()] for the Lan-DeMets
336		#' approximations, [gs_boundaries()] for computing boundaries from spending
337		#' functions, [graph_test_shortcut_gsd()] for the graphical procedure.
338		#'
339		#' @references
340		#' Wang, S. K., and Tsiatis, A. A. (1987). Approximately optimal one-parameter
341		#' boundaries for group sequential trials. \emph{Biometrics}, 43(1), 193-199.
342		#'
343		#' @export
344		#'
345		#' @examples
346		#' # Exact O'Brien-Fleming (delta = 0)
347		#' spending_wt(0.025, c(0.5, 1), delta = 0)
348		#'
349		#' # Exact Pocock (delta = 0.5)
350		#' spending_wt(0.025, c(0.5, 1), delta = 0.5)
351		#'
352		#' # Intermediate (delta = 0.25)
353		#' spending_wt(0.025, c(1 / 3, 2 / 3, 1), delta = 0.25)
354		#'
355		#' # Compare with Lan-DeMets approximations
356		#' spending_of(0.025, c(1 / 3, 2 / 3, 1)) # Lan-DeMets OBF approximation
357		#' spending_wt(0.025, c(1 / 3, 2 / 3, 1), 0) # Exact OBF
358		#'
359		#' # Use in graph_test_shortcut_gsd (wrap to fix delta)
360		#' \donttest{
361		#' g <- graph_create(c(0.5, 0.5), rbind(c(0, 1), c(1, 0)))
362		#' p <- rbind(H1 = c(0.024, 0.01), H2 = c(0.015, 0.005))
363		#' graph_test_shortcut_gsd(
364		#' graph = g, p = p, alpha = 0.025,
365		#' info_frac = c(0.5, 1),
366		#' spending_fn = function(a, t) spending_wt(a, t, delta = 0.25)
367		#' )
368		#' }
369		spending_wt <- function(alpha, info_frac, delta = 0.5,
370		maxpts = 25000, abseps = 1e-6) {
371	27x	stopifnot(
372	27x	"info_frac must be non-negative" = all(info_frac >= 0),
373	27x	"At most one info_frac value can be >= 1" = sum(info_frac >= 1) <= 1,
374	27x	"The last info_frac value must be >= 1 for spending_wt" =
375	27x	length(info_frac) > 0 && info_frac[length(info_frac)] >= 1,
376	27x	"delta must be a numeric scalar" = is.numeric(delta) && length(delta) == 1
377		)
378
379	23x	K <- length(info_frac)
380
381		# Handle edge cases
382	23x	if (alpha <= 0) {
383	1x	return(rep(0, K))
384		}
385	22x	if (K == 1) {
386	4x	return(pmin(alpha, alpha))
387		}
388
389		# Correlation matrix
390	18x	corr <- gs_corr(info_frac)
391
392		# Wang-Tsiatis boundary shape: c_k = C * t_k^(delta - 0.5)
393		# For info_frac = 0, the shape is Inf (or 0 depending on delta),
394		# handle by setting those boundaries to Inf (never cross)
395	18x	shape <- ifelse(info_frac == 0, 0, info_frac^(delta - 0.5))
396
397	18x	algo <- mvtnorm::GenzBretz(maxpts = maxpts, abseps = abseps)
398
399		# Find C such that P(cross at some k \| H0) = alpha
400		# P(cross) = 1 - P(Z_1 < c_1, ..., Z_K < c_K)
401	18x	find_C <- function(C_val) {
402	356x	bounds_z <- C_val * shape
403		# Replace any Inf or very large bounds with 20 for numerical stability
404	356x	bounds_z <- pmin(bounds_z, 20)
405
406	356x	prob_no_cross <- mvtnorm::pmvnorm(
407	356x	upper = bounds_z,
408	356x	corr = corr,
409	356x	algorithm = algo
410	356x	)[[1]]
411
412	356x	(1 - prob_no_cross) - alpha
413		}
414
415		# Search for C. Boundaries are on the Z-scale, so C is typically 1-5
416	18x	C_root <- tryCatch(
417	18x	stats::uniroot(find_C, interval = c(0.1, 20), tol = abseps),
418	18x	error = function(e) {
419		# Widen search if needed
420	2x	stats::uniroot(find_C, interval = c(0.01, 50), tol = abseps)
421		}
422		)
423	16x	C_val <- C_root$root
424	16x	bounds_z <- C_val * shape
425	16x	bounds_z <- pmin(bounds_z, 20)
426
427		# Compute implied cumulative spending at each analysis k:
428		# alpha_k = P(Z_1 >= c_1 or ... or Z_k >= c_k)
429		# = 1 - P(Z_1 < c_1, ..., Z_k < c_k)
430	16x	cum_spending <- numeric(K)
431	16x	for (k in seq_len(K)) {
432	49x	if (info_frac[k] == 0) {
433	!	cum_spending[k] <- 0
434	!	next
435		}
436	49x	if (k == 1) {
437		# Univariate case: P(Z >= c_1) = 1 - Phi(c_1)
438	16x	cum_spending[k] <- stats::pnorm(bounds_z[1], lower.tail = FALSE)
439		} else {
440	33x	cum_spending[k] <- 1 - mvtnorm::pmvnorm(
441	33x	upper = bounds_z[seq_len(k)],
442	33x	corr = corr[seq_len(k), seq_len(k)],
443	33x	algorithm = algo
444	33x	)[[1]]
445		}
446		}
447
448		# Cap at alpha for numerical stability
449	16x	cum_spending <- pmin(cum_spending, alpha)
450	16x	cum_spending
451		}

1		#' Perform graphical multiple comparison procedures efficiently for power
2		#' calculation
3		#'
4		#' @description
5		#' These functions performs similarly to [graph_test_closure()] or
6		#' [graph_test_shortcut()] but are optimized for efficiently calculating power.
7		#' For example, generating weights and calculating adjusted weights can be done
8		#' only once. Vectorization has been applied where possible.
9		#'
10		#' @param p A numeric vector of one-sided p-values (unadjusted, raw), whose
11		#' values should be between 0 & 1. The length should match the number of
12		#' hypotheses in `graph`.
13		#' @param alpha A numeric value of the one-sided overall significance level,
14		#' which should be between 0 & 1. The default is 0.025 for one-sided
15		#' hypothesis testing. Note that only one-sided tests are supported.
16		#' @param adjusted_weights The adjusted hypothesis weights, which are the
17		#' second half of columns from [graph_generate_weights()] output, adjusted by
18		#' the appropriate test types (Bonferroni, Simes, or parametric).
19		#' @param matrix_intersections A matrix of hypothesis indicators in a weighting
20		#' strategy, which are the first half the [graph_generate_weights()] output.
21		#'
22		#' @return A logical or integer vector indicating whether each hypothesis can
23		#' be rejected or not.
24		#'
25		#' @seealso
26		#' * [graph_test_closure()] for closed graphical multiple comparison
27		#' procedures.
28		#' * [graph_test_shortcut()] for shortcut graphical multiple comparison
29		#' procedures.
30		#'
31		#' @rdname graph_test_fast
32		#'
33		#' @keywords internal
34		#'
35		graph_test_closure_fast <- function(p,
36		alpha,
37		adjusted_weights,
38		matrix_intersections) {
39	431733x	rej_hyps <- t(p <= alpha * t(adjusted_weights))
40
41		# "+ 0" converts to integer from logical
42	431733x	matrixStats::colSums2(
43	431733x	matrix_intersections * matrixStats::rowMaxs(rej_hyps + 0)
44	431733x	) == 2^(ncol(adjusted_weights) - 1)
45		}
46
47		#' @rdname graph_test_fast
48		#' @keywords internal
49		graph_test_shortcut_fast <- function(p, alpha, adjusted_weights) {
50	510107x	num_hyps <- ncol(adjusted_weights)
51		# There is a mapping from current rejected hypotheses to corresponding row of
52		# the closure weights matrix by treating the rejected vector as a binary
53		# number. This line creates a vector of binary place values.
54	510107x	binary_slots <- 2^(num_hyps:1 - 1)
55	510107x	nrow_critical <- nrow(adjusted_weights)
56
57	510107x	rejected <- vector("logical", num_hyps)
58
59	510107x	while (!all(rejected)) {
60		# The actual mapping to intersection number is to treat the rejected vector
61		# as a binary number, then count that many lines up from the bottom of the
62		# weights matrix, then go down one line
63	531213x	intersection_num <-
64	531213x	nrow_critical - sum(binary_slots * !rejected) + 1
65	531213x	rejected_step <-
66	531213x	p <= adjusted_weights[intersection_num, , drop = TRUE] * alpha
67
68	531213x	if (!any(rejected_step)) {
69	509896x	break
70		} else {
71	21317x	rejected <- rejected \| rejected_step
72		}
73		}
74
75	510107x	rejected
76		}

1		#' S3 print method for the class `initial_graph`
2		#'
3		#' @description
4		#' A printed `initial_graph` displays a header stating "Initial graph",
5		#' hypothesis weights, and transition weights.
6		#'
7		#' @param x An object of class `initial_graph` to print.
8		#' @param ... Other values passed on to other methods (currently unused).
9		#' @param precision An integer scalar indicating the number of decimal places
10		#' to to display.
11		#' @param indent An integer scalar indicating how many spaces to indent results.
12		#'
13		#' @return An object x of class `initial_graph`, after printing the initial
14		#' graph.
15		#'
16		#' @seealso
17		#' [print.updated_graph()] for the print method for the updated graph after
18		#' hypotheses being deleted from the initial graph.
19		#'
20		#' @rdname print.initial_graph
21		#'
22		#' @export
23		#'
24		#' @references
25		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
26		#' Rohmeyer, K. (2011). Graphical approaches for multiple comparison
27		#' procedures using weighted Bonferroni, Simes, or parametric tests.
28		#' \emph{Biometrical Journal}, 53(6), 894-913.
29		#'
30		#' @examples
31		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
32		#' # and H2) and two secondary hypotheses (H3 and H4)
33		#' # See Figure 1 in Bretz et al. (2011).
34		#' hypotheses <- c(0.5, 0.5, 0, 0)
35		#' transitions <- rbind(
36		#' c(0, 0, 1, 0),
37		#' c(0, 0, 0, 1),
38		#' c(0, 1, 0, 0),
39		#' c(1, 0, 0, 0)
40		#' )
41		#' hyp_names <- c("H11", "H12", "H21", "H22")
42		#' g <- graph_create(hypotheses, transitions, hyp_names)
43		#' g
44		print.initial_graph <- function(x,
45		...,
46		precision = 4,
47		indent = 0) {
48	136x	x$hypotheses[attr(x, "deleted")] <-
49	136x	x$transitions[attr(x, "deleted"), ] <-
50	136x	x$transitions[, attr(x, "deleted")] <-
51	136x	NA
52
53	1x	if (is.null(attr(x, "title"))) attr(x, "title") <- "Initial graph"
54
55	136x	pad <- paste(rep(" ", indent), collapse = "")
56	136x	pad_less_1 <- paste(rep(" ", max(indent - 1, 0)), collapse = "")
57
58	136x	cat(paste0(pad, attr(x, "title"), "\n\n"))
59
60	136x	cat(paste0(pad, "--- Hypothesis weights ---\n"))
61
62	136x	hypotheses_text <- paste(
63	136x	pad,
64	136x	formatC(
65	136x	names(x$hypotheses),
66	136x	width = max(nchar(names(x$hypotheses)))
67		),
68		": ",
69	136x	format(x$hypotheses, digits = precision),
70	136x	sep = "",
71	136x	collapse = "\n"
72		)
73
74	136x	cat(hypotheses_text, "", sep = "\n")
75
76	136x	cat(paste0(pad, "--- Transition weights ---\n"))
77
78	136x	transitions <- format(
79	136x	x$transitions,
80	136x	digits = precision,
81	136x	scientific = FALSE
82		)
83
84	136x	colname_pad <- format("", width = max(nchar(rownames(transitions))))
85	136x	label <- paste0(pad_less_1, colname_pad)
86	136x	df_trn <- data.frame(
87	136x	paste0(pad_less_1, rownames(transitions)),
88	136x	transitions,
89	136x	check.names = FALSE
90		)
91	136x	names(df_trn)[[1]] <- label
92
93	136x	transitions_text <- data.frame(df_trn, check.names = FALSE)
94
95	136x	print(transitions_text, row.names = FALSE)
96
97	136x	invisible(x)
98		}

1		#' Convert between graphicalMCP, gMCP, and igraph graph classes
2		#'
3		#' @description
4		#' Graph objects have different structures and attributes in
5		#' `graphicalMCP`, `gMCP`, and `igraph` R packages. These functions convert
6		#' between different classes to increase compatibility.
7		#'
8		#' Note that `igraph` and `gMCP` have additional attributes for vertices, edges,
9		#' or a graph itself. These conversion functions only handle attributes related
10		#' to hypothesis names, hypothesis weights and transition weights. Other
11		#' attributes will be dropped when converting.
12		#'
13		#' @param graph An `initial_graph` object from the `graphicalMCP` package, a
14		#' `graphMCP` object from the `gMCP` package, or an `igraph` object from the
15		#' `igraph` package, depending on the conversion type.
16		#'
17		#' @return
18		#' * `as_graphMCP()` returns a `graphMCP` object for the `gMCP` package.
19		#' * `as_igraph()` returns an `igraph` object for the `igraph` package.
20		#' * `as_initial_graph()` returns an `initial_graph` object for the
21		#' `graphicalMCP` package.
22		#'
23		#' @seealso [graph_create()] for the initial graph used in the `graphicalMCP`
24		#' package.
25		#'
26		#' @rdname as_graph
27		#'
28		#' @export
29		#'
30		#' @references Csardi, G., Nepusz, T., Traag, V., Horvat, S., Zanini, F., Noom,
31		#' D., and Mueller, K. (2024). \emph{igraph}: Network analysis and visualization
32		#' in R. R package version 2.0.3.
33		#' \url{https://CRAN.R-project.org/package=igraph}.
34		#'
35		#' Rohmeyer, K., and Klinglmueller, K. (2024). \emph{gMCP}: Graph based multiple
36		#' test procedures. R package version 0.8-17.
37		#' \url{https://cran.r-project.org/package=gMCP}.
38		#'
39		#' @examples
40		#' g_graphicalMCP <- random_graph(5)
41		#'
42		#' if (requireNamespace("gMCP", quietly = TRUE)) {
43		#' g_gMCP <- as_graphMCP(g_graphicalMCP)
44		#'
45		#' all.equal(g_graphicalMCP, as_initial_graph(g_gMCP))
46		#' }
47		#'
48		#' if (requireNamespace("igraph", quietly = TRUE)) {
49		#' g_igraph <- as_igraph(g_graphicalMCP)
50		#'
51		#' all.equal(g_graphicalMCP, as_initial_graph(g_igraph))
52		#' }
53		as_initial_graph <- function(graph) {
54	2x	UseMethod("as_initial_graph", graph)
55		}
56
57		#' @rdname as_graph
58		#' @export
59		as_initial_graph.graphMCP <- function(graph) {
60	1x	graph_create(graph@weights, graph@m)
61		}
62
63		#' @rdname as_graph
64		#' @export
65		as_initial_graph.igraph <- function(graph) {
66	1x	hypotheses <- igraph::vertex_attr(graph, "weight")
67	1x	names(hypotheses) <- igraph::vertex_attr(graph, "name")
68
69	1x	transitions <- matrix(0, length(hypotheses), length(hypotheses))
70	1x	dimnames(transitions) <- rep(list(names(hypotheses)), 2)
71
72	1x	for (tail in seq_along(hypotheses)) {
73	11x	transitions[tail, ] <- graph[tail]
74		}
75
76	1x	graph_create(hypotheses, transitions)
77		}
78
79		#' @rdname as_graph
80		#' @export
81		as_graphMCP <- function(graph) {
82	2x	UseMethod("as_graphMCP", graph)
83		}
84
85		#' @rdname as_graph
86		#' @export
87		as_graphMCP.initial_graph <- function(graph) {
88	2x	if (!requireNamespace("gMCP", quietly = TRUE)) {
89	!	stop("Please install.packages('gMCP') before converting to a gMCP graph")
90		} else {
91	2x	gMCP::matrix2graph(graph$transitions, graph$hypotheses)
92		}
93		}
94
95		#' @rdname as_graph
96		#' @export
97		as_igraph <- function(graph) {
98	3x	UseMethod("as_igraph", graph)
99		}
100
101		#' @rdname as_graph
102		#' @export
103		as_igraph.initial_graph <- function(graph) {
104	3x	if (!requireNamespace("igraph", quietly = TRUE)) {
105	!	stop("Please install.packages('igraph') before converting to an igraph")
106		} else {
107	3x	num_hyps <- length(graph$hypotheses)
108	3x	hyp_names <- names(graph$hypotheses)
109
110	3x	empty_igraph <- igraph::make_empty_graph()
111
112	3x	vertex_igraph <- igraph::add_vertices(
113	3x	empty_igraph,
114	3x	num_hyps,
115	3x	name = hyp_names,
116	3x	weight = graph$hypotheses
117		)
118
119	3x	matrix_edge_tails <- matrix(rep(hyp_names, num_hyps), nrow = num_hyps)
120	3x	matrix_edge_heads <-
121	3x	matrix(rep(hyp_names, num_hyps), nrow = num_hyps, byrow = TRUE)
122
123	3x	edge_tails <- matrix_edge_tails[graph$transitions != 0]
124	3x	edge_heads <- matrix_edge_heads[graph$transitions != 0]
125
126	3x	vector_edges <- as.vector(rbind(edge_tails, edge_heads))
127
128	3x	complete_igraph <- igraph::add_edges(
129	3x	vertex_igraph,
130	3x	vector_edges,
131	3x	weight = graph$transitions[graph$transitions != 0]
132		)
133
134	3x	complete_igraph
135		}
136		}

1		#' S3 plot method for class `initial_graph`
2		#'
3		#' @description The plot of an `initial_graph` translates the `hypotheses` into
4		#' vertices and `transitions` into edges to create a network plot. Vertices are
5		#' labeled with hypothesis names and hypothesis weights, and edges are labeled
6		#' with transition weights. See `vignette("graph-examples")` for more
7		#' illustration of commonly used multiple comparison procedure using graphs.
8		#'
9		#' @param x An object of class `initial_graph` to plot.
10		#' @param ... Other arguments passed on to `igraph::plot.igraph()`.
11		#' @param v_palette A character vector of length two specifying the colors for
12		#' retained and deleted hypotheses. More extensive color customization must be
13		#' done with `vertex.color`.
14		#' @param layout An igraph layout specification (See `?igraph.plotting`), or
15		#' `"grid"`, which lays out hypotheses left-to-right and top-to-bottom. `nrow`
16		#' and `ncol` control the grid shape.
17		#' @param nrow An integer scalar specifying the number of rows in the vertex
18		#' grid. If row and column counts are not specified, vertices will be laid out
19		#' as close to a square as possible.
20		#' @param ncol An integer scalar specifying the number of columns in the vertex
21		#' grid. If row and column counts are not specified, vertices will be laid out
22		#' as close to a square as possible.
23		#' @param edge_curves A named numeric vector specifying the curvature of
24		#' specific edges. Edge pairs (Where two vertices share an edge in each
25		#' possible direction) are detected automatically and get 0.25 curvature.
26		#' Adjust edges by adding an entry with name `"vertex1\|vertex2`, and adjust
27		#' default edge pairs curvature by adding an entry with name `"pairs"` -
28		#' `edge_curves = c("pairs" = 0.5, "H1\|H3" = 0.25, "H3\|H4" = 0.75)`.
29		#' @param precision An integer scalar indicating the number of decimal places to
30		#' display.
31		#' @param eps A numeric scalar. The transition weight of `eps` will be displayed
32		#' as \eqn{\epsilon}, which indicates edges with infinitesimally small
33		#' weights. See Bretz et al. (2009) for more details.
34		#' @param background_color A character scalar specifying a background color for
35		#' the whole plotting area. Passed directly to [graphics::par()] (`bg`).
36		#' @param margins A length 4 numeric vector specifying the margins for the plot.
37		#' Defaults to all 1, since igraph plots tend to have large margins. It is
38		#' passed directly to [graphics::par()] (`mar`).
39		#'
40		#' @return An object x of class `initial_graph`, after plotting the initial
41		#' graph.
42		#'
43		#' @section Customization of graphs: There are a few values for
44		#' [igraph::plot.igraph()] that get their defaults changed for graphicalMCP.
45		#' These values can still be changed by passing them as arguments to
46		#' `plot.initial_graph()`. Here are the new defaults:
47		#' * `vertex.color = "#6baed6"`,
48		#' * `vertex.label.color = "black"`,
49		#' * `vertex.size = 20`,
50		#' * `edge.arrow.size = 1`,
51		#' * `edge.arrow.width = 1`,
52		#' * `edge.label.color = "black"`
53		#' * `asp = 0`.
54		#'
55		#' Neither `graphicalMCP` nor `igraph` does anything about overlapping edge
56		#' labels. If you run into this problem, and vertices can't practically be
57		#' moved enough to avoid collisions of edge labels, using edge curves can
58		#' help. `igraph` puts edge labels closer to the tail of an edge when an edge
59		#' is straight, and closer to the head of an edge when it's curved. By setting
60		#' an edge's curve to some very small value, an effectively straight edge can
61		#' be shifted to a new position.
62		#'
63		#' @seealso [plot.updated_graph()] for the plot method for the updated graph
64		#' after hypotheses being deleted from the initial graph.
65		#'
66		#' @rdname plot.initial_graph
67		#'
68		#' @export
69		#'
70		#' @references Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W.,
71		#' and Rohmeyer, K. (2011). Graphical approaches for multiple comparison
72		#' procedures using weighted Bonferroni, Simes, or parametric tests.
73		#' \emph{Biometrical Journal}, 53(6), 894-913.
74		#'
75		#' Xi, D., and Bretz, F. (2019). Symmetric graphs for equally weighted tests,
76		#' with application to the Hochberg procedure. \emph{Statistics in Medicine},
77		#' 38(27), 5268-5282.
78		#'
79		#' @examplesIf requireNamespace("igraph", quietly = TRUE)
80		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
81		#' # and H2) and two secondary hypotheses (H3 and H4)
82		#' # See Figure 4 in Bretz et al. (2011).
83		#' hypotheses <- c(0.5, 0.5, 0, 0)
84		#' delta <- 0.5
85		#' transitions <- rbind(
86		#' c(0, delta, 1 - delta, 0),
87		#' c(delta, 0, 0, 1 - delta),
88		#' c(0, 1, 0, 0),
89		#' c(1, 0, 0, 0)
90		#' )
91		#' g <- graph_create(hypotheses, transitions)
92		#' plot(g)
93		#'
94		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
95		#' # and H2) and four secondary hypotheses (H31, H32, H41, and H42)
96		#' # See Figure 6 in Xi and Bretz (2019).
97		#' hypotheses <- c(0.5, 0.5, 0, 0, 0, 0)
98		#' epsilon <- 1e-5
99		#' transitions <- rbind(
100		#' c(0, 0.5, 0.25, 0, 0.25, 0),
101		#' c(0.5, 0, 0, 0.25, 0, 0.25),
102		#' c(0, 0, 0, 0, 1, 0),
103		#' c(epsilon, 0, 0, 0, 0, 1 - epsilon),
104		#' c(0, epsilon, 1 - epsilon, 0, 0, 0),
105		#' c(0, 0, 0, 1, 0, 0)
106		#' )
107		#' hyp_names <- c("H1", "H2", "H31", "H32", "H41", "H42")
108		#' g <- graph_create(hypotheses, transitions, hyp_names)
109		#'
110		#' plot_layout <- rbind(
111		#' c(0.15, 0.5),
112		#' c(0.65, 0.5),
113		#' c(0, 0),
114		#' c(0.5, 0),
115		#' c(0.3, 0),
116		#' c(0.8, 0)
117		#' )
118		#'
119		#' plot(g, layout = plot_layout, eps = epsilon, edge_curves = c(pairs = .5))
120		plot.initial_graph <- function(x,
121		...,
122		v_palette = c("#6baed6", "#cccccc"),
123		layout = "grid",
124		nrow = NULL,
125		ncol = NULL,
126		edge_curves = NULL,
127		precision = 4,
128		eps = NULL,
129		background_color = "white",
130		margins = c(1, 1, 1, 1)) {
131	2x	oldpar <- graphics::par("bg", "mar")
132	2x	on.exit(suppressWarnings(graphics::par(oldpar)))
133
134	2x	if (length(v_palette) != 2) {
135	!	stop("Choose 2 palette colors or use `vertex.color` for more customization")
136		}
137
138	2x	graph_size <- length(x$hypotheses)
139	2x	graph_seq <- seq_along(x$hypotheses)
140
141	2x	graph_igraph <- as_igraph(x)
142
143	2x	v_attr <- igraph::vertex_attr(graph_igraph)
144	2x	e_attr <- igraph::edge_attr(graph_igraph)
145
146		# Vertex colors --------------------------------------------------------------
147	2x	v_color <- rep(v_palette[[1]], length(x$hypotheses))
148	2x	v_color[attr(x, "deleted")] <- v_palette[[2]]
149
150		# Make labels ----------------------------------------------------------------
151	2x	v_labels <- paste(v_attr$name, round(v_attr$weight, precision), sep = "\n")
152
153		# Very small edges should display as epsilon
154	2x	edge_labels <- e_attr$weight
155	!	if (is.null(edge_labels)) edge_labels <- numeric(0)
156
157	2x	near_0 <- edge_labels <= eps & edge_labels != 0
158	2x	near_1 <- edge_labels >= 1 - eps & edge_labels != 1
159
160	2x	if (length(near_0) == 0 \|\| length(near_1) == 0) {
161	!	edge_labels <- round(edge_labels, precision)
162		} else {
163	2x	edge_labels[!near_0 & !near_1] <-
164	2x	round(edge_labels[!near_0 & !near_1], precision)
165		}
166
167	2x	if (!is.null(eps)) {
168	2x	edge_labels[near_0] <- expression(epsilon)
169	2x	edge_labels[near_1] <- expression(1 - epsilon)
170		}
171
172		# Set curves -----------------------------------------------------------------
173	2x	curve <- rep(0, length(igraph::E(graph_igraph)))
174	2x	names(curve) <- attr(igraph::E(graph_igraph), "vnames")
175
176		# Vertex pairs connected in both directions should get a small default so
177		# their edges don't overlap each other
178	2x	if (!is.null(edge_curves)) {
179	2x	if (!is.na(edge_curves["pairs"])) {
180	2x	edge_pair_curve <- edge_curves["pairs"]
181		} else {
182	!	edge_pair_curve <- .25
183		}
184		} else {
185	!	edge_pair_curve <- .25
186		}
187
188	2x	edge_pair_locs <-
189	2x	attr(igraph::E(graph_igraph), "vnames") %in% edge_pairs(x)
190
191	2x	curve[edge_pair_locs] <- edge_pair_curve
192
193	2x	curve[names(edge_curves)] <- edge_curves
194
195		# Set layout -----------------------------------------------------------------
196	2x	if (!is.function(layout)) {
197	2x	if (!is.matrix(layout)) {
198	2x	if (layout == "grid") {
199	2x	if (is.null(nrow) && is.null(ncol)) {
200	2x	nrow <- ceiling(sqrt(graph_size))
201	2x	ncol <- nrow
202	!	} else if (is.null(nrow)) {
203	!	nrow <- ceiling(graph_size / ncol)
204	!	} else if (is.null(ncol)) {
205	!	ncol <- ceiling(graph_size / nrow)
206		}
207
208		# [] removes extras when grid is not filled all the way
209	2x	layout <- cbind(
210	2x	rep(seq_len(ncol), nrow)[graph_seq],
211	2x	vapply(rev(seq_len(nrow)), rep, integer(ncol), ncol)[graph_seq]
212		)
213		}
214		}
215		}
216
217	2x	graphics::par(mar = margins)
218	2x	graphics::par(bg = background_color)
219
220		# Draw! ----------------------------------------------------------------------
221	2x	igraph::plot.igraph(
222	2x	graph_igraph,
223		...,
224	2x	layout = layout,
225	2x	vertex.color = v_color,
226	2x	vertex.label = v_labels,
227	2x	vertex.label.color = "black",
228	2x	vertex.size = 20,
229	2x	edge.label = edge_labels,
230	2x	edge.label.color = "black",
231	2x	edge.curved = curve,
232	2x	edge.arrow.size = 1,
233	2x	edge.arrow.width = 1,
234	2x	asp = 0
235		)
236
237	2x	invisible(x)
238		}

1		#' Calculate adjusted hypothesis weights for parametric tests
2		#'
3		#' @description
4		#' An intersection hypothesis can be rejected if its p-values are less than or
5		#' equal to their adjusted significance levels, which are their adjusted
6		#' hypothesis weights times \eqn{\alpha}. For Bonferroni tests, their adjusted
7		#' hypothesis weights are their hypothesis weights of the intersection
8		#' hypothesis. Additional adjustment is needed for parametric tests:
9		#' * Parametric tests for [adjust_weights_parametric()],
10		#' - Note that one-sided tests are required for parametric tests.
11		#'
12		#' @param x The root to solve for with `stats::uniroot()`.
13		#' @param alpha (Optional) A numeric value of the overall significance level,
14		#' which should be between 0 & 1. The default is 0.025 for one-sided
15		#' hypothesis testing problems; another common choice is 0.05 for two-sided
16		#' hypothesis testing problems. Note when parametric tests are used, only
17		#' one-sided tests are supported.
18		#' @param hypotheses A numeric vector of hypothesis weights. Must be a vector of
19		#' values between 0 & 1 (inclusive). The sum of hypothesis weights should not
20		#' exceed 1.
21		#' @param test_corr (Optional) A numeric matrix of correlations between test
22		#' statistics, which is needed to perform parametric tests using
23		#' [adjust_weights_parametric()]. The number of rows and columns of
24		#' this correlation matrix should match the length of `p`.
25		#' @param maxpts (Optional) An integer scalar for the maximum number of function
26		#' values, which is needed to perform parametric tests using the
27		#' `mvtnorm::GenzBretz` algorithm. The default is 25000.
28		#' @param abseps (Optional) A numeric scalar for the absolute error tolerance,
29		#' which is needed to perform parametric tests using the `mvtnorm::GenzBretz`
30		#' algorithm. The default is 1e-6.
31		#' @param releps (Optional) A numeric scalar for the relative error tolerance
32		#' as double, which is needed to perform parametric tests using the
33		#' `mvtnorm::GenzBretz` algorithm. The default is 0.
34		#'
35		#' @return
36		#' * `c_value_function()` returns the difference between
37		#' \eqn{\alpha} and the Type I error of the parametric test with the \eqn{c}
38		#' value of `x`, adjusted for the correlation between test statistics using
39		#' parametric tests based on equation (6) of Xi et al. (2017).
40		#' * `solve_c_parametric()` returns the c value adjusted for the
41		#' correlation between test statistics using parametric tests based on
42		#' equation (6) of Xi et al. (2017).
43		#'
44		#' @seealso
45		#' [adjust_weights_parametric()] for adjusted hypothesis weights using
46		#' parametric tests.
47		#'
48		#' @rdname adjust_weights_parametric_util
49		#'
50		#' @keywords internal
51		#'
52		#' @references
53		#' Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework
54		#' for weighted parametric multiple test procedures.
55		#' \emph{Biometrical Journal}, 59(5), 918-931.
56		c_value_function <- function(x,
57		hypotheses,
58		test_corr,
59		alpha,
60		maxpts = 25000,
61		abseps = 1e-6,
62		releps = 0) {
63	2658x	hyps_nonzero <- which(hypotheses > 0)
64	2658x	z <- stats::qnorm(x * hypotheses[hyps_nonzero] * alpha, lower.tail = FALSE)
65	2658x	y <- ifelse(
66	2658x	length(z) == 1,
67	2658x	stats::pnorm(z, lower.tail = FALSE)[[1]],
68	2658x	1 - mvtnorm::pmvnorm(
69	2658x	lower = -Inf,
70	2658x	upper = z,
71	2658x	corr = test_corr[hyps_nonzero, hyps_nonzero, drop = FALSE],
72	2658x	algorithm = mvtnorm::GenzBretz(
73	2658x	maxpts = maxpts,
74	2658x	abseps = abseps,
75	2658x	releps = releps
76		)
77	2658x	)[[1]]
78		)
79
80	2658x	y - alpha * sum(hypotheses)
81		}
82
83		#' @rdname adjust_weights_parametric_util
84		#' @keywords internal
85		solve_c_parametric <- function(hypotheses,
86		test_corr,
87		alpha,
88		maxpts = 25000,
89		abseps = 1e-6,
90		releps = 0) {
91	930x	num_hyps <- seq_along(hypotheses)
92	930x	c_value <- ifelse(
93	930x	length(num_hyps) == 1 \|\| sum(hypotheses) == 0,
94	930x	1,
95	930x	stats::uniroot(
96	930x	c_value_function,
97	930x	lower = 0, # Why is this not -Inf? Ohhhh because c_value >= 1
98		# upper > 40 errors when w[i] ~= 1 && w[j] = epsilon
99		# upper = 2 errors when w = c(.5, .5) && all(test_corr == 1)
100		# furthermore, even under perfect correlation & with balanced weights, the
101		# c_function_to_solve does not exceed `length(hypotheses)`
102	930x	upper = length(hypotheses) + 1,
103	930x	hypotheses = hypotheses,
104	930x	test_corr = test_corr,
105	930x	alpha = alpha,
106	930x	maxpts = maxpts,
107	930x	abseps = abseps,
108	930x	releps = releps
109	930x	)$root
110		)
111
112		# Occasionally has floating point differences
113	930x	round(c_value, 10)
114		}
115
116		#' @rdname adjust_weights_parametric_util
117		#' @keywords internal
118		#' This function only allows `test_corr` to be a single correlation matrix. This
119		#' is different from `adjust_weights_parametric()` which allows a list of
120		#' correlation matrices.
121		adjust_weights_parametric_util <- function(matrix_weights,
122		matrix_intersections,
123		test_corr,
124		alpha,
125		test_groups,
126		maxpts = 25000,
127		abseps = 1e-6,
128		releps = 0) {
129	16x	c_values <- matrix(
130	16x	nrow = nrow(matrix_weights),
131	16x	ncol = ncol(matrix_weights),
132	16x	dimnames = dimnames(matrix_weights)
133		)
134
135	16x	for (group in test_groups) {
136	14x	for (row in seq_len(nrow(matrix_weights))) {
137	826x	group_by_intersection <-
138	826x	group[as.logical(matrix_intersections[row, , drop = TRUE][group])]
139
140	826x	group_c_value <- solve_c_parametric(
141	826x	matrix_weights[row, group_by_intersection, drop = TRUE],
142	826x	test_corr[group_by_intersection, group_by_intersection, drop = FALSE],
143	826x	alpha,
144	826x	maxpts,
145	826x	abseps,
146	826x	releps
147		)
148
149	826x	c_values[row, group] <-
150	826x	group_c_value * matrix_intersections[row, group, drop = TRUE]
151		}
152		}
153
154	16x	adjusted_weights <- c_values * matrix_weights
155
156	16x	adjusted_weights[, unlist(test_groups), drop = FALSE]
157		}

1		#' Obtain an updated graph by updating an initial graphical after deleting
2		#' hypotheses
3		#'
4		#' @description
5		#' After a hypothesis is deleted, an initial graph will be updated. The deleted
6		#' hypothesis will have the hypothesis weight of 0 and the transition weight of
7		#' 0. Remaining hypotheses will have updated hypothesis weights and transition
8		#' weights according to Algorithm 1 of Bretz et al. (2009).
9		#'
10		#' @param graph An initial graph as returned by [graph_create()].
11		#' @param delete A logical or integer vector, denoting which hypotheses to
12		#' delete. A logical vector results in the "unordered mode", which means that
13		#' hypotheses corresponding to `TRUE` in `delete` will be deleted. The
14		#' sequence of deletion will follow the sequence of `TRUE`'s in `delete`. In
15		#' this case, the length of the logical vector must match the number of
16		#' hypotheses in `graph`. An integer vector results in the "ordered mode",
17		#' which means that `delete` specifies the sequence in which hypotheses
18		#' should be deleted by indicating the location of deleted hypotheses, e.g.,
19		#' 1st, 2nd, etc. In this case, the integer vector can have any length, but
20		#' must only contain valid hypothesis numbers (greater than 0, and less than
21		#' or equal to he number of hypotheses in `graph`).
22		#'
23		#' @return An S3 object of class `updated_graph` with a list of 4 elements:
24		#' * `initial_graph`: The initial graph object.
25		#' * `updated_graph`: The updated graph object with specified hypotheses
26		#' deleted.
27		#' * `deleted`: A numeric vector indicating which hypotheses were deleted.
28		#' * `intermediate_graphs`: When using the ordered mode, a list of
29		#' intermediate updated graphs after each hypothesis is deleted according
30		#' to the sequence specified by `delete`.
31		#'
32		#' @section Sequence of deletion:
33		#' When there are multiple hypotheses to be deleted from a graph, there are many
34		#' sequences of deletion in which an initial graph is updated to an updated
35		#' graph. If the interest is in the updated graph after all hypotheses specified
36		#' by `delete` are deleted, this updated graph is the same no matter which
37		#' sequence of deletion is used. This property has been proved by Bretz et al.
38		#' (2009). If the interest is in the intermediate updated graph after each
39		#' hypothesis is deleted according to the sequence specified by `delete`, an
40		#' integer vector of `delete` should be specified and these detailed outputs
41		#' will be provided.
42		#'
43		#' @seealso
44		#' * [graph_create()] for the initial graph.
45		#' * [graph_rejection_orderings()] for possible sequences of rejections for a
46		#' graphical multiple comparison procedure using shortcut testing.
47		#'
48		#' @rdname graph_update
49		#'
50		#' @export
51		#'
52		#' @references
53		#' Bretz, F., Maurer, W., Brannath, W., and Posch, M. (2009). A graphical
54		#' approach to sequentially rejective multiple test procedures.
55		#' \emph{Statistics in Medicine}, 28(4), 586-604.
56		#'
57		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
58		#' Rohmeyer, K. (2011). Graphical approaches for multiple comparison
59		#' procedures using weighted Bonferroni, Simes, or parametric tests.
60		#' \emph{Biometrical Journal}, 53(6), 894-913.
61		#'
62		#' @examples
63		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
64		#' # and H2) and two secondary hypotheses (H3 and H4)
65		#' # See Figure 1 in Bretz et al. (2011).
66		#' hypotheses <- c(0.5, 0.5, 0, 0)
67		#' transitions <- rbind(
68		#' c(0, 0, 1, 0),
69		#' c(0, 0, 0, 1),
70		#' c(0, 1, 0, 0),
71		#' c(1, 0, 0, 0)
72		#' )
73		#' g <- graph_create(hypotheses, transitions)
74		#'
75		#' # Delete the second and third hypotheses in the "unordered mode"
76		#' graph_update(g, delete = c(FALSE, TRUE, TRUE, FALSE))
77		#'
78		#' # Equivalent way in the "ordered mode" to obtain the updated graph after
79		#' # deleting the second and third hypotheses
80		#' # Additional intermediate updated graphs are also provided
81		#' graph_update(g, delete = 2:3)
82		graph_update <- function(graph, delete) {
83		# Basic type checking
84	1333x	stopifnot(
85	1333x	"Please update an `initial_graph` object" = class(graph) == "initial_graph",
86	1333x	"Hypothesis index must be a logical or integer vector" =
87	1333x	is.logical(delete) \|\| (all(as.integer(delete) == delete))
88		)
89
90	1333x	ordered <- !is.logical(delete)
91
92		# Qualitative checking
93	1333x	if (ordered) {
94	236x	stopifnot(
95	236x	"Ordered deletion index must contain only valid hypothesis numbers" =
96	236x	all(delete > 0 & delete <= length(graph$hypotheses)),
97	236x	"Ordered deletion index must have unique values" =
98	236x	length(delete) == length(unique(delete))
99		)
100
101	232x	intermediate_graphs <- list(graph)
102		} else {
103	1097x	stopifnot(
104	1097x	"Length of unordered deletion index must match size of graph" =
105	1097x	length(graph$hypotheses) == length(delete),
106	1097x	"Unordered deletion index must only contain TRUE or FALSE" =
107	1097x	all(delete %in% c(TRUE, FALSE))
108		)
109
110	1096x	delete <- which(delete)
111		}
112
113	1328x	initial_graph <- graph
114	1328x	cume_delete <- integer(0)
115
116		# Iterate over the hypotheses to delete
117	1328x	for (delete_num in delete) {
118	2738x	cume_delete <- c(cume_delete, delete_num)
119
120		# Save current state of the graph to use in calculations
121		# Also make a copy of graph elements for storing new values in
122	2738x	init_hypotheses <- hypotheses <- graph$hypotheses
123	2738x	init_transitions <- transitions <- graph$transitions
124
125	2738x	hyp_nums <- seq_along(hypotheses)
126
127		# Loop over hypotheses, calculating new weights based on initial hypothesis
128		# weights and storing in `hypotheses`
129	2738x	for (hyp_num in hyp_nums) {
130	12406x	hypotheses[[hyp_num]] <-
131	12406x	init_hypotheses[[hyp_num]] +
132	12406x	init_hypotheses[[delete_num]] * init_transitions[[delete_num, hyp_num]]
133
134	12406x	denominator <- 1 - init_transitions[[hyp_num, delete_num]] *
135	12406x	init_transitions[[delete_num, hyp_num]]
136
137		# In this loop, hyp_num is the starting node of the transition, and
138		# end_num is the ending node
139		# Calculate new transition weights based on original transition weights,
140		# and store in `transitions`
141	12406x	for (end_num in hyp_nums) {
142	60560x	if (hyp_num == end_num \|\| denominator <= 0) {
143	12799x	transitions[[hyp_num, end_num]] <- 0
144		} else {
145	47761x	transitions[[hyp_num, end_num]] <- (
146	47761x	init_transitions[[hyp_num, end_num]] +
147	47761x	init_transitions[[hyp_num, delete_num]] *
148	47761x	init_transitions[[delete_num, end_num]]
149	47761x	) / denominator
150		}
151		}
152		}
153
154		# Make sure to zero out the deleted node's values
155	2738x	hypotheses[delete_num] <- 0
156	2738x	transitions[delete_num, ] <- 0
157	2738x	transitions[, delete_num] <- 0
158
159		# At this point, a single hypothesis has been removed from the graph.
160		# Assign the newly calculated hypotheses and transitions to `graph`, and
161		# loop to the next hypothesis to delete
162	2738x	graph <- structure(
163	2738x	list(hypotheses = hypotheses, transitions = transitions),
164	2738x	class = "initial_graph",
165	2738x	title = "Updated graph",
166	2738x	deleted = cume_delete
167		)
168
169	241x	if (ordered) intermediate_graphs <- c(intermediate_graphs, list(graph))
170		}
171
172	1328x	structure(
173	1328x	list(
174	1328x	initial_graph = initial_graph,
175	1328x	updated_graph = graph,
176	1328x	deleted = delete,
177	1328x	intermediate_graphs = if (ordered) intermediate_graphs
178		),
179	1328x	class = "updated_graph"
180		)
181		}

1		#' Calculate the repeated p-value for a single hypothesis at a given analysis
2		#'
3		#' @description
4		#' A repeated p-value at analysis \eqn{k} is the minimum significance level at
5		#' which the group sequential boundary at analysis \eqn{k} would be crossed.
6		#' Unlike the sequential p-value, which considers all analyses up to \eqn{k},
7		#' the repeated p-value only considers the boundary at analysis \eqn{k} itself.
8		#'
9		#' The sequential p-value equals the minimum of repeated p-values across
10		#' analyses: \eqn{\tilde{p}_k = \min_{l=1}^{k} \hat{p}_l}, where
11		#' \eqn{\hat{p}_l} is the repeated p-value at analysis \eqn{l}.
12		#'
13		#' @param p A numeric vector of p-values at each analysis for a single
14		#' hypothesis. The length must match the length of `info_frac`. All values
15		#' must be non-missing and between 0 and 1.
16		#' @param info_frac A numeric vector of information fractions at each analysis.
17		#' Values must be in (0, 1] and monotonically non-decreasing. The length
18		#' should match the length of `p`.
19		#' @param spending_fn A spending function. Must accept two arguments:
20		#' `alpha` (total significance level) and `info_frac` (information fraction),
21		#' and return the cumulative alpha spent. Built-in options include
22		#' [spending_of()], [spending_pocock()], [spending_hsd()], and
23		#' [spending_linear()].
24		#' @param tol A numeric scalar for the tolerance of the root-finding
25		#' algorithm. The default is `1e-6`.
26		#' @param maxpts An integer scalar for the maximum number of function values
27		#' for `mvtnorm::GenzBretz`. The default is 25000.
28		#' @param abseps A numeric scalar for the absolute error tolerance for
29		#' `mvtnorm::GenzBretz`. The default is 1e-6.
30		#'
31		#' @return A numeric scalar of the repeated p-value at the last analysis in
32		#' the input vectors.
33		#'
34		#' @details
35		#' For a hypothesis tested at analyses \eqn{k = 1, \ldots, K} with p-values
36		#' \eqn{p^{(k)}} and information fractions \eqn{t^{(k)}}, the repeated
37		#' p-value at analysis \eqn{K} is the minimum \eqn{\hat{p}} such that the
38		#' observed p-value \eqn{p^{(K)}} crosses the group sequential boundary
39		#' \eqn{c_K(\hat{p})} at that analysis:
40		#' \deqn{\hat{p}_K = \min\{\alpha : p^{(K)} \le c_K(\alpha)\}.}
41		#'
42		#' Note that computing the boundary \eqn{c_K(\alpha)} requires knowledge of
43		#' all previous information fractions \eqn{t^{(1)}, \ldots, t^{(K)}} because
44		#' the boundary at analysis \eqn{K} depends on the cumulative spending and
45		#' the joint distribution of test statistics.
46		#'
47		#' The repeated p-value is found using [stats::uniroot()] on the function
48		#' \eqn{g(\alpha) = z_K - b_K(\alpha)}, where \eqn{z_K =
49		#' \Phi^{-1}(1 - p^{(K)})} is the observed Z-statistic at analysis \eqn{K}
50		#' and \eqn{b_K(\alpha)} is the Z-scale boundary.
51		#'
52		#' @seealso
53		#' [sequential_p()] for the sequential p-value (minimum repeated p-value),
54		#' [gs_boundaries()] for computing group sequential boundaries,
55		#' [graph_test_shortcut_gsd()] for graphical multiple comparison procedures
56		#' with group sequential designs.
57		#'
58		#' @rdname repeated_p
59		#'
60		#' @export
61		#'
62		#' @references
63		#' Maurer, W., and Bretz, F. (2013). Multiple testing in group sequential
64		#' trials using graphical approaches. \emph{Statistics in Biopharmaceutical
65		#' Research}, 5(4), 311-320.
66		#'
67		#' @examples
68		#' # Repeated p-value at the second analysis (interim at 50%, final at 100%)
69		#' repeated_p(
70		#' p = c(0.024, 0.01),
71		#' info_frac = c(0.5, 1),
72		#' spending_fn = spending_of
73		#' )
74		#'
75		#' # Compare with sequential p-value (which is the minimum repeated p-value)
76		#' sequential_p(
77		#' p = c(0.024, 0.01),
78		#' info_frac = c(0.5, 1),
79		#' spending_fn = spending_of
80		#' )
81		#'
82		#' # Repeated p-values at each analysis
83		#' # Analysis 1
84		#' repeated_p(
85		#' p = 0.05,
86		#' info_frac = 0.3,
87		#' spending_fn = spending_of
88		#' )
89		#'
90		#' # Analysis 2
91		#' repeated_p(
92		#' p = c(0.05, 0.02),
93		#' info_frac = c(0.3, 0.7),
94		#' spending_fn = spending_of
95		#' )
96		repeated_p <- function(p,
97		info_frac,
98		spending_fn,
99		tol = 1e-6,
100		maxpts = 25000,
101		abseps = 1e-6) {
102	450x	stopifnot(
103	450x	"p must be a numeric vector" = is.numeric(p),
104	450x	"p must not contain NA" = !anyNA(p),
105	450x	"p must be between 0 and 1" = all(p >= 0 & p <= 1),
106	450x	"info_frac must be a numeric vector" = is.numeric(info_frac),
107	450x	"info_frac must not contain NA" = !anyNA(info_frac),
108	450x	"p and info_frac must have the same length" = length(info_frac) == length(p)
109		)
110
111	450x	K <- length(p)
112
113		# Convert observed p-value at the current analysis to Z-statistic
114	450x	z_obs_K <- stats::qnorm(1 - p[K])
115
116		# For a candidate alpha, compute boundaries and return the exceedance
117		# at analysis K only: z_obs[K] - b_K(alpha).
118		# Positive means the boundary at analysis K is crossed.
119	450x	exceedance_K <- function(alpha_candidate) {
120	6400x	bounds <- gs_boundaries(
121	6400x	alpha = alpha_candidate,
122	6400x	info_frac = info_frac,
123	6400x	spending_fn = spending_fn,
124	6400x	maxpts = maxpts,
125	6400x	abseps = abseps
126		)
127
128	6393x	z_obs_K - bounds$bounds_z[K]
129		}
130
131		# Check edge cases before root-finding.
132	450x	upper <- 1 - tol
133	450x	lower <- tol
134
135		# If boundary at analysis K is not crossed even at alpha ~ 1,
136		# the p-value at this analysis is too large. Return 1.
137	450x	exc_upper <- tryCatch(
138	450x	exceedance_K(upper),
139	450x	error = function(e) NA_real_
140		)
141	450x	if (is.na(exc_upper) \|\| exc_upper <= 0) {
142	5x	message("Boundary at analysis K not crossed; returning 1 as an upper bound.")
143	5x	return(1)
144		}
145
146		# If boundary at analysis K is crossed even at alpha ~ 0,
147		# the p-value is extremely small. Return the lower bound.
148		# Use >= 0 to also handle the edge case where the exceedance is exactly 0
149		# (boundary exactly crossed), which would cause uniroot to fail because
150		# f(lower) and f(upper) would have the same sign.
151	445x	exc_lower <- tryCatch(
152	445x	exceedance_K(lower),
153	445x	error = function(e) {
154		# gs_boundaries can fail at very small alpha due to numerical issues
155		# in pmvnorm. Treat this as the boundary being extremely large
156		# (i.e., not crossed), so exceedance is negative.
157	1x	-1
158		}
159		)
160	445x	if (exc_lower >= 0) {
161	2x	message(
162	2x	"Boundary crossed at alpha = ", lower,
163	2x	"; returning ", lower, " as a lower bound."
164		)
165	2x	return(lower)
166		}
167
168		# Find the root: minimum alpha where boundary at analysis K is crossed.
169		# Wrap in tryCatch to handle numerical edge cases in uniroot.
170	443x	result <- tryCatch(
171	443x	stats::uniroot(
172	443x	exceedance_K,
173	443x	interval = c(lower, upper),
174	443x	tol = tol
175		),
176	443x	error = function(e) {
177		# If uniroot fails, try with a wider lower bound
178	1x	tryCatch(
179	1x	stats::uniroot(
180	1x	exceedance_K,
181	1x	interval = c(lower * 10, upper),
182	1x	tol = tol
183		),
184	1x	error = function(e2) {
185	1x	message(
186	1x	"Root-finding failed; returning ", lower,
187	1x	" as a lower bound. Original error: ", e$message
188		)
189	1x	list(root = lower)
190		}
191		)
192		}
193		)
194
195	443x	result$root
196		}

1		#' Calculate power values for a graphical multiple comparison procedure
2		#'
3		#' @description
4		#' Under the alternative hypotheses, the distribution of test statistics is
5		#' assumed to be a multivariate normal distribution. Given this distribution,
6		#' this function calculates power values for a graphical multiple comparison
7		#' procedure. By default, it calculate the local power, which is the probability
8		#' to reject an individual hypothesis, the probability to reject at least one
9		#' hypothesis, the probability to reject all hypotheses, the expected number of
10		#' rejections, and the probability of user-defined success criteria.
11		#' See `vignette("shortcut-testing")` and `vignette("closed-testing")` for more
12		#' illustration of power calculation.
13		#'
14		#' @inheritParams graph_test_closure
15		#' @param alpha A numeric value of the one-sided overall significance level,
16		#' which should be between 0 & 1. The default is 0.025 for one-sided
17		#' hypothesis testing. Note that only one-sided tests are supported.
18		#' @param sim_n An integer scalar specifying the number of simulations. The
19		#' default is 1e5.
20		#' @param power_marginal A numeric vector of marginal power values to use when
21		#' simulating p-values. See Details for more on the simulation process.
22		#' @param sim_corr A numeric matrix of correlations between test statistics for
23		#' all hypotheses. The dimensions should match the number of hypotheses in
24		#' `graph`.
25		#' @param sim_success A list of user-defined functions to specify the success
26		#' criteria. Functions must take one simulation's logical vector of results as
27		#' an input, and return a length-one logical vector. For instance, if
28		#' "success" means rejecting hypotheses 1 and 2, use `sim_success = list("1
29		#' and 2" = function(x) x[1] && x[2])`. If the list is not named, the function
30		#' body will be used as the name. Lambda functions also work starting with R
31		#' 4.1, e.g. `sim_success = list(\(x) x[3] \|\| x[4])`.
32		#' @param verbose A logical scalar specifying whether the details of power
33		#' simulations should be included in results. The default is `verbose =
34		#' FALSE`.
35		#'
36		#' @return A `power_report` object with a list of 3 elements:
37		#' * `inputs` - Input parameters, which is a list of:
38		#' * `graph` - Initial graph,
39		#' * `alpha` - Overall significance level,
40		#' * `test_groups` - Groups of hypotheses for different types of tests,
41		#' * `test_types` - Different types of tests,
42		#' * `test_corr` - Correlation matrices for parametric tests,
43		#' * `sim_n` - Number of simulations,
44		#' * `power_marginal` - Marginal power of all hypotheses
45		#' * `sim_corr` - Correlation matrices for simulations,
46		#' * `sim_success` - User-defined success criteria.
47		#' * `power` - A list of power values
48		#' * `power_local` - Local power of all hypotheses, which is the proportion
49		#' of simulations in which each hypothesis is rejected,
50		#' * `rejection_expected` - Expected (average) number of rejected hypotheses,
51		#' * `power_at_least_1` - Power to reject at least one hypothesis,
52		#' * `power_all` - Power to reject all hypotheses,
53		#' * `power_success` - Power of user-defined success, which is the
54		#' proportion of simulations in which the user-defined success criterion
55		#' * `sim_success` is met.
56		#' * `details` - An optional list of datasets showing simulated p-values and
57		#' results for each simulation.
58		#'
59		#' @section Simulation details: The power calculation is based on simulations.
60		#' The distribution to simulate from is determined as a multivariate normal
61		#' distribution by `power_marginal` and `sim_corr`. In particular,
62		#' `power_marginal` is a vector of marginal power values for all hypotheses.
63		#' The marginal power is the power to reject the null hypothesis at the
64		#' significance level `alpha` without multiplicity adjustment. This value could be readily available from
65		#' standard software and other R packages. Then we can determine the mean of
66		#' the multivariate normal distribution as
67		#' \deqn{\Phi^{-1}\left(1-\alpha\right)-\Phi^{-1}\left(1-d_i\right)}, which is
68		#' often called the non-centrality parameter or the drift parameter. Here
69		#' \eqn{d_i} is the marginal power `power_marginal` of hypothesis \eqn{i}.
70		#' Given the correlation matrix `sim_corr`, we can simulate from this
71		#' multivariate normal distribution using the `mvtnorm` R package (Genz and
72		#' Bretz, 2009).
73		#'
74		#' Each set simulated values can be used to calculate the corresponding
75		#' one-sided p-values. Then this set of p-values are plugged into the
76		#' graphical multiple comparison procedure to determine which hypotheses are
77		#' rejected. This process is repeated `n_sim` times to produce the power
78		#' values as the proportion of simulations in which a particular success
79		#' criterion is met.
80		#'
81		#' @rdname graph_calculate_power
82		#'
83		#' @export
84		#'
85		#' @references Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W.,
86		#' and Rohmeyer, K. (2011a). Graphical approaches for multiple comparison
87		#' procedures using weighted Bonferroni, Simes, or parametric tests.
88		#' \emph{Biometrical Journal}, 53(6), 894-913.
89		#'
90		#' Bretz, F., Maurer, W., and Hommel, G. (2011b). Test and power
91		#' considerations for multiple endpoint analyses using sequentially rejective
92		#' graphical procedures. \emph{Statistics in Medicine}, 30(13), 1489-1501.
93		#'
94		#' Genz, A., and Bretz, F. (2009). \emph{Computation of Multivariate Normal
95		#' and t Probabilities}, series Lecture Notes in Statistics. Springer-Verlag,
96		#' Heidelberg.
97		#'
98		#' Lu, K. (2016). Graphical approaches using a Bonferroni mixture of weighted
99		#' Simes tests. \emph{Statistics in Medicine}, 35(22), 4041-4055.
100		#'
101		#' Xi, D., Glimm, E., Maurer, W., and Bretz, F. (2017). A unified framework
102		#' for weighted parametric multiple test procedures. \emph{Biometrical
103		#' Journal}, 59(5), 918-931.
104		#'
105		#' @examples
106		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
107		#' # and H2) and two secondary hypotheses (H3 and H4)
108		#' # See Figure 4 in Bretz et al. (2011a).
109		#' alpha <- 0.025
110		#' hypotheses <- c(0.5, 0.5, 0, 0)
111		#' delta <- 0.5
112		#' transitions <- rbind(
113		#' c(0, delta, 1 - delta, 0),
114		#' c(delta, 0, 0, 1 - delta),
115		#' c(0, 1, 0, 0),
116		#' c(1, 0, 0, 0)
117		#' )
118		#' g <- graph_create(hypotheses, transitions)
119		#'
120		#' marginal_power <- c(0.8, 0.8, 0.7, 0.9)
121		#' corr1 <- matrix(0.5, nrow = 2, ncol = 2)
122		#' diag(corr1) <- 1
123		#' corr <- rbind(
124		#' cbind(corr1, 0.5 * corr1),
125		#' cbind(0.5 * corr1, corr1)
126		#' )
127		#' success_fns <- list(
128		#' # Probability to reject both H1 and H2
129		#' `H1andH2` = function(x) x[1] & x[2],
130		#' # Probability to reject both (H1 and H3) or (H2 and H4)
131		#' `(H1andH3)or(H2andH4)` = function(x) (x[1] & x[3]) \| (x[2] & x[4])
132		#' )
133		#' set.seed(1234)
134		#' # Bonferroni tests
135		#' # Reduce the number of simulations to save time for package compilation
136		#' power_output <- graph_calculate_power(
137		#' g,
138		#' alpha,
139		#' sim_corr = corr,
140		#' sim_n = 1e2,
141		#' power_marginal = marginal_power,
142		#' sim_success = success_fns
143		#' )
144		#'
145		#' # Parametric tests for H1 and H2; Simes tests for H3 and H4
146		#' # User-defined success: to reject H1 or H2; to reject H1 and H2
147		#' # Reduce the number of simulations to save time for package compilation
148		#' graph_calculate_power(
149		#' g,
150		#' alpha,
151		#' test_groups = list(1:2, 3:4),
152		#' test_types = c("parametric", "simes"),
153		#' test_corr = list(corr1, NA),
154		#' sim_n = 1e2,
155		#' sim_success = list(
156		#' function(.) .[1] \|\| .[2],
157		#' function(.) .[1] && .[2]
158		#' )
159		#' )
160		#'
161		graph_calculate_power <- function(graph,
162		alpha = 0.025,
163		power_marginal =
164		rep(alpha, length(graph$hypotheses)),
165		test_groups =
166		list(seq_along(graph$hypotheses)),
167		test_types = c("bonferroni"),
168		test_corr = rep(list(NA), length(test_types)),
169		sim_n = 1e5,
170		sim_corr = diag(length(graph$hypotheses)),
171		sim_success = NULL,
172		verbose = FALSE) {
173		# Input sanitization ---------------------------------------------------------
174		# Test types should be passed as full names or first letter, case-insensitive,
175		# and a single provided type should get expanded to all groups
176	29x	test_types_names <- names(test_types)
177	29x	test_opts <- c(
178	29x	bonferroni = "bonferroni",
179	29x	parametric = "parametric",
180	29x	simes = "simes",
181	29x	hochberg = "hochberg",
182	29x	b = "bonferroni",
183	29x	p = "parametric",
184	29x	s = "simes",
185	29x	h = "hochberg"
186		)
187	29x	test_types <- test_opts[tolower(test_types)]
188	29x	names(test_types) <- test_types_names
189	29x	if (length(test_types) == 1) {
190	24x	test_types <- rep(test_types, length(test_groups))
191		}
192
193		# Groups of size 1 should always use Bonferroni testing
194	29x	test_types[lengths(test_groups) == 1] <- "bonferroni"
195
196		# A bare success function should get put into a length-one list
197	1x	if (is.function(sim_success)) sim_success <- list(sim_success)
198
199	29x	hyp_names <- names(graph$hypotheses)
200	29x	num_hyps <- length(graph$hypotheses)
201
202		# Input validation -----------------------------------------------------------
203	29x	test_input_val(
204	29x	graph,
205	29x	rep(alpha, length(graph$hypotheses)),
206	29x	alpha,
207	29x	test_groups,
208	29x	test_types,
209	29x	test_corr,
210	29x	FALSE,
211	29x	FALSE
212		)
213
214		# The test specification arguments can be named or not. However, if
215		# `test_groups` is named, all of them must be named. The other two are
216		# re-ordered to match `test_groups`
217	29x	if (!is.null(names(test_groups))) {
218	2x	if (!all(names(c(test_types, test_corr)) %in% names(test_groups))) {
219	1x	stop("If `test_groups` is named, `test_types` and `test_corr` must use the
220	1x	same names")
221		} else {
222	1x	test_types <- test_types[names(test_groups)]
223	1x	test_corr <- test_corr[names(test_groups)]
224		}
225		} else {
226	27x	names(test_groups) <-
227	27x	names(test_types) <-
228	27x	names(test_corr) <-
229	27x	paste0("grp", seq_along(test_groups))
230		}
231
232		# Correlation matrix input is easier for end users to input as a list, but
233		# it's easier to work with internally as a full matrix, potentially with
234		# missing values. This puts all the correlation pieces into one matrix
235	28x	new_corr <- matrix(NA, num_hyps, num_hyps)
236
237	28x	for (group_num in seq_along(test_groups)) {
238	38x	new_corr[test_groups[[group_num]], test_groups[[group_num]]] <-
239	38x	test_corr[[group_num]]
240		}
241	28x	diag(new_corr) <- 1
242	28x	test_corr <- if (any(test_types == "parametric")) new_corr else NULL
243
244	28x	power_input_val(graph, sim_n, power_marginal, sim_corr, sim_success)
245
246		# Simulated p-values are generated by sampling from the multivariate normal
247		# distribution. The means are set with `power_marginal`, and the correlations
248		# are set with `sim_corr`. Random samples are converted to p-values with a
249		# one-sided test.
250	20x	noncentrality_parameter <-
251	20x	stats::qnorm(1 - alpha, lower.tail = TRUE) -
252	20x	stats::qnorm(1 - power_marginal, lower.tail = TRUE)
253
254	20x	p_sim <- stats::pnorm(
255	20x	mvtnorm::rmvnorm(
256	20x	sim_n,
257	20x	noncentrality_parameter,
258	20x	sigma = sim_corr
259		),
260	20x	lower.tail = FALSE
261		)
262
263	20x	simulation_test_results <- matrix(
264	20x	NA,
265	20x	nrow = sim_n,
266	20x	ncol = length(power_marginal),
267	20x	dimnames = list(seq_len(sim_n), hyp_names)
268		)
269
270		# Calculate weights for each intersection in the closure -------------------
271	20x	weighting_strategy <- graph_generate_weights(graph)
272	20x	matrix_intersections <- weighting_strategy[, seq_len(num_hyps), drop = FALSE]
273	20x	matrix_weights <-
274	20x	weighting_strategy[, seq_len(num_hyps) + num_hyps, drop = FALSE]
275
276	20x	if (all(test_types == "bonferroni")) {
277	8x	for (row in seq_len(sim_n)) {
278	510105x	simulation_test_results[row, ] <- graph_test_shortcut_fast(
279	510105x	p_sim[row, ],
280	510105x	alpha,
281	510105x	matrix_weights
282		)
283		}
284		} else {
285		# Calculate Bonferroni adjusted weights ------------------------------------
286	12x	groups_bonferroni <- test_groups[test_types == "bonferroni", drop = FALSE]
287
288		# Bonferroni adjusted weights are just the weights from the closure
289	12x	adjusted_weights_bonferroni <-
290	12x	matrix_weights[, unlist(groups_bonferroni), drop = FALSE]
291
292		# Calculate parametric adjusted weights ------------------------------------
293	12x	groups_parametric <- test_groups[test_types == "parametric", drop = FALSE]
294
295		# Parametric adjusted weights depend only on the joint distribution and
296		# alpha. This allows adjusted weights to be calculated once, rather than
297		# re-calculating for each simulation
298	12x	adjusted_weights_parametric <- adjust_weights_parametric_util(
299	12x	matrix_weights,
300	12x	matrix_intersections,
301	12x	test_corr,
302	12x	alpha,
303	12x	groups_parametric
304		)
305
306		# Separate Simes weighting strategy ----------------------------------------
307	12x	groups_simes <- test_groups[test_types == "simes", drop = FALSE]
308
309		# The fastest option found for calculating Simes adjusted weights requires
310		# missing hypotheses' weights to be 0, rather than NA
311	12x	matrix_weights_simes <-
312	12x	matrix_weights[, unlist(groups_simes), drop = FALSE]
313
314		# Unlike Bonferroni and parametric adjusted weights, Simes adjusted weights
315		# depend on the order of p-values. This means they must be re-calculated for
316		# each simulation. Because this causes a bottleneck in calculations, Simes
317		# testing has been heavily optimized. Fast Simes testing requires Simes
318		# hypothesis numbers to be mapped to their relative position within the set
319		# of all Simes hypotheses. For example, if hypotheses 1/7 form a parametric
320		# group, and 2/5 & 3/4/6 each form a Simes group, the fast Simes functions
321		# will get hypotheses 2/5 & 3/4/6 passed, but the groups must first be
322		# re-indexed to 1/4 & 2/3/5 (their relative locations within all Simes
323		# groups).
324	12x	groups_simes_reduce <- lapply(
325	12x	groups_simes,
326	12x	function(group) which(unlist(groups_simes) %in% group)
327		)
328
329		# Fast Simes testing also requires a set of p-values with columns already
330		# subset for Simes testing, similar to how the weighting strategy is subset
331		# for each test type
332	12x	p_sim_simes <- p_sim[, unlist(groups_simes), drop = FALSE]
333
334		# Separate Hochberg weighting strategy -------------------------------------
335		# All Simes comments apply to Hochberg
336	12x	groups_hochberg <- test_groups[test_types == "hochberg", drop = FALSE]
337
338	12x	matrix_weights_hochberg <-
339	12x	matrix_weights[, unlist(groups_hochberg), drop = FALSE]
340
341	12x	matrix_intersections_hochberg <-
342	12x	matrix_intersections[, unlist(groups_hochberg), drop = FALSE]
343
344	12x	groups_hochberg_reduce <- lapply(
345	12x	groups_hochberg,
346	12x	function(group) which(unlist(groups_hochberg) %in% group)
347		)
348
349	12x	p_sim_hochberg <- p_sim[, unlist(groups_hochberg), drop = FALSE]
350
351		# Apply closure testing to each simulation ---------------------------------
352	12x	for (row in seq_len(sim_n)) {
353		# If there are no Simes groups, adjusted weights are the Simes weighting
354		# strategy (a matrix with 0 columns)
355	431728x	if (length(groups_simes) == 0) {
356	120200x	adjusted_weights_simes <- matrix_weights_simes
357		} else {
358		# Simes testing depends on p-values, so adjusted weights must be
359		# calculated for each simulation.
360	311528x	adjusted_weights_simes <- adjust_weights_simes(
361	311528x	matrix_weights_simes,
362	311528x	p_sim_simes[row, ],
363	311528x	groups_simes_reduce
364		)
365
366		# Note: The Simes adjusted weights are incorrect for missing Simes
367		# hypotheses. To improve performance, missing hypotheses are given a
368		# zero value rather than NA before calculating adjusted weights. This
369		# results in missing hypotheses getting an adjusted weight calculated
370		# for them. These incorrect values are then replaced with zeroes for
371		# testing
372		}
373
374		# All Simes comments apply to similar lines for Hochberg
375	431728x	if (length(groups_hochberg) == 0) {
376	431728x	adjusted_weights_hochberg <- matrix_weights_hochberg
377		} else {
378	!	adjusted_weights_hochberg <- adjust_weights_hochberg(
379	!	matrix_weights_hochberg,
380	!	matrix_intersections_hochberg,
381	!	p_sim_hochberg[row, ],
382	!	groups_hochberg_reduce
383		)
384		}
385
386		# `graph_test_closure_fast()` requires hypotheses, p-values, and the
387		# intersections matrix to all have hypotheses/columns in the same order.
388		# P-values and the intersections matrix are already in the original order,
389		# so order the adjusted weights back in original hypothesis order.
390	431728x	adjusted_weights_all <- cbind(
391	431728x	adjusted_weights_bonferroni,
392	431728x	adjusted_weights_simes,
393	431728x	adjusted_weights_hochberg,
394	431728x	adjusted_weights_parametric
395	431728x	)[, hyp_names, drop = FALSE]
396
397		# Similar to Simes adjusted weights, the optimized testing function
398		# requires missing values to be replaced by zero. This line also replaces
399		# the incorrect Simes and Hochberg adjusted weights with zero.
400	431728x	adjusted_weights_all[!matrix_intersections] <- 0
401
402		# Record test results for one simulation, all groups
403	431728x	simulation_test_results[row, ] <- graph_test_closure_fast(
404	431728x	p_sim[row, ],
405	431728x	alpha,
406	431728x	adjusted_weights_all,
407	431728x	matrix_intersections
408		)
409		}
410		}
411
412		# Summarize power results ----------------------------------------------------
413		# Each user-defined function provided as a "success" measure should take a
414		# logical vector (a single simulation's test results) as input, and return a
415		# logical scalar. Applying such a function to each simulation, results in a
416		# success indicator vector with one entry per simulation. The average of this
417		# vector is the probability of "success".
418	20x	power_success <- vapply(
419	20x	sim_success,
420	20x	function(fn_success) mean(apply(simulation_test_results, 1, fn_success)),
421	20x	numeric(1)
422		)
423
424		# If the success functions are not named, set names according to each
425		# function's body
426	20x	if (is.null(names(power_success))) {
427	20x	success_fun_bodies <- vapply(
428	20x	sim_success,
429	20x	function(fn_success) deparse(fn_success)[[2]],
430	20x	character(1)
431		)
432
433	20x	names(power_success) <- success_fun_bodies
434		}
435
436		# Power summaries:
437		# * Local power is the probability of rejecting each individual hypothesis:
438		# Mean of results for each hypothesis individually.
439		# * Expected rejections is the total number of rejections divided by the total
440		# possible rejections.
441		# * Power to reject at least one hypothesis is the probability that any result
442		# in a row is TRUE. This one is just like if a success function was defined as
443		# rejecting any hypothesis in the graph
444		# * Power to reject all hypotheses is the mean of a success vector where
445		# success is only triggered when the whole results vector is TRUE
446	20x	power <- list(
447	20x	power_local = colMeans(simulation_test_results),
448	20x	rejection_expected = sum(simulation_test_results) / sim_n,
449	20x	power_at_least_1 = mean(rowSums(simulation_test_results) > 0),
450	20x	power_all =
451	20x	mean(rowSums(simulation_test_results) == length(power_marginal)),
452	20x	power_success = power_success
453		)
454
455		# The core output of a power report is the 5 power summaries. It also includes
456		# the main testing and simulation input parameters (similar to test results).
457		# For completion, the full matrix of simulations and corresponding matrix of
458		# test results are included. They are truncated in the print method so as to
459		# not blow up output space. It may be preferred for these to be an optional
460		# output with e.g. `verbose = TRUE/FALSE`.
461	20x	structure(
462	20x	list(
463	20x	inputs = list(
464	20x	graph = graph,
465	20x	alpha = alpha,
466	20x	test_groups = test_groups,
467	20x	test_types = test_types,
468	20x	test_corr = test_corr,
469	20x	sim_n = sim_n,
470	20x	power_marginal = power_marginal,
471	20x	sim_corr = sim_corr,
472	20x	sim_success = sim_success
473		),
474	20x	power = power,
475	20x	details = if (verbose) {
476	3x	list(
477	3x	p_sim = p_sim,
478	3x	test_results = simulation_test_results
479		)
480		}
481		),
482	20x	class = "power_report"
483		)
484		}

1		#' Compute the correlation matrix for group sequential test statistics
2		#'
3		#' @description
4		#' In a group sequential design, test statistics \eqn{Z_1, \ldots, Z_K} at
5		#' analyses with information fractions \eqn{t_1, \ldots, t_K} follow the
6		#' canonical joint distribution with correlation
7		#' \deqn{\text{Cor}(Z_i, Z_j) = \sqrt{t_i / t_j}, \quad i \le j.}
8		#'
9		#' This correlation structure arises from the independent increments property
10		#' of the score process. It depends only on the information fractions, not on
11		#' the specific test or endpoint.
12		#'
13		#' @param info_frac A numeric vector of information fractions at each analysis.
14		#' Must be positive and monotonically non-decreasing.
15		#'
16		#' @return A symmetric correlation matrix of dimension \eqn{K \times K}, where
17		#' \eqn{K} is the length of `info_frac`. The diagonal entries are all 1.
18		#'
19		#' @seealso [gs_boundaries()] which uses this correlation matrix for computing
20		#' group sequential boundaries.
21		#'
22		#' @rdname gs_corr
23		#'
24		#' @export
25		#'
26		#' @examples
27		#' # Three equally spaced analyses
28		#' gs_corr(c(1 / 3, 2 / 3, 1))
29		#'
30		#' # Two analyses at 50% and 100%
31		#' gs_corr(c(0.5, 1))
32		gs_corr <- function(info_frac) {
33	3950x	outer(
34	3950x	info_frac, info_frac,
35	3950x	function(ti, tj) sqrt(pmin(ti, tj) / pmax(ti, tj))
36		)
37		}

1		#' Find pairs of vertices that are connected in both directions
2		#'
3		#' @description
4		#' For an initial graph, find pairs of hypotheses that are connected in both
5		#' directions. This is used to plot graphs using [plot.initial_graph()].
6		#'
7		#' @inheritParams graph_update
8		#'
9		#' @return A list of vertex pairs which are connected in both directions. NULL
10		#' if no such pairs are found.
11		#'
12		#' @rdname edge_pairs
13		#'
14		#' @keywords internal
15		#'
16		edge_pairs <- function(graph) {
17	3x	g_names <- names(graph$hypotheses)
18
19	3x	pair_indices <- graph$transitions > 0 & t(graph$transitions) > 0
20
21	3x	pair_nums <- which(pair_indices, arr.ind = TRUE, useNames = FALSE)
22
23	3x	if (nrow(pair_nums) > 0) {
24	3x	apply(
25	3x	pair_nums,
26	3x	1,
27	3x	function(row) paste(g_names[[row[[1]]]], g_names[[row[[2]]]], sep = "\|"),
28	3x	simplify = FALSE
29		)
30		} else {
31	!	NULL
32		}
33		}

1		#' S3 plot method for the class `updated_graph`
2		#'
3		#' @description
4		#' Plotting an updated graph is a very light wrapper around
5		#' [plot.initial_graph()], only changing the default vertex color to use gray
6		#' for deleted hypotheses.
7		#'
8		#' @param x An object of class `updated_graph` to plot.
9		#' @inheritDotParams plot.initial_graph
10		#'
11		#' @return An object x of class `updated_graph`, after plotting the updated
12		#' graph.
13		#'
14		#' @seealso
15		#' [plot.initial_graph()] for the plot method for the initial graph.
16		#'
17		#' @rdname plot.updated_graph
18		#'
19		#' @export
20		#'
21		#' @references
22		#' Bretz, F., Posch, M., Glimm, E., Klinglmueller, F., Maurer, W., and
23		#' Rohmeyer, K. (2011). Graphical approaches for multiple comparison
24		#' procedures using weighted Bonferroni, Simes, or parametric tests.
25		#' \emph{Biometrical Journal}, 53(6), 894-913.
26		#'
27		#' @examplesIf requireNamespace("igraph", quietly = TRUE)
28		#' # A graphical multiple comparison procedure with two primary hypotheses (H1
29		#' # and H2) and two secondary hypotheses (H3 and H4)
30		#' # See Figure 1 in Bretz et al. (2011).
31		#' hypotheses <- c(0.5, 0.5, 0, 0)
32		#' transitions <- rbind(
33		#' c(0, 0, 1, 0),
34		#' c(0, 0, 0, 1),
35		#' c(0, 1, 0, 0),
36		#' c(1, 0, 0, 0)
37		#' )
38		#' g <- graph_create(hypotheses, transitions)
39		#'
40		#' # Delete the second and third hypotheses in the "unordered mode"
41		#' plot(
42		#' graph_update(
43		#' g,
44		#' c(FALSE, TRUE, TRUE, FALSE)
45		#' ),
46		#' layout = "grid"
47		#' )
48		plot.updated_graph <- function(x, ...) {
49	1x	v_colors <- rep("#6baed6", length(x$updated_graph$hypotheses))
50	1x	v_colors[x$deleted] <- "#cccccc"
51
52	1x	plot(x$updated_graph, vertex.color = v_colors, ...)
53
54	1x	invisible(x)
55		}