look back applicable to all hypotheses with data at current or any previous analysis

Author: xidongdxi

R/graph_test_shortcut_gsd.R

@@ -473,22 +473,36 @@ gsd_test <- function(graph, p, alpha, info_frac, spending_fn, look_back,
   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 analysis k
+    # 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])
-    active <- !rejected & has_data_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,
-      seq_p_matrix[, k],
+      last_seq_p,
       rep_p_matrix[, k]
     )
 
-    # For hypotheses without data at analysis k or already rejected,
-    # set p to 1 so they are never selected by graph_test_shortcut().
+    # 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
@@ -568,18 +582,26 @@ gsd_test <- function(graph, p, alpha, info_frac, spending_fn, look_back,
             info_frac, spending_fn, hyp_names, w_at_rej
           )
 
-          # Set the analysis-k row's Reject to FALSE for this hypothesis
+          # 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)
-          tv_details[[k]]$Reject[hyp_row] <- FALSE
 
-          # Insert look_back rows immediately after the hypothesis's row
-          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]
+          if (length(hyp_row) > 0) {
+            # Has data at analysis k: set Reject to FALSE and insert
+            # look_back rows after it
+            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)
           }
-          tv_details[[k]] <- rbind(before, lb_rows, after)
         }
       }
     }

R/print.gsd_graph_report.R

@@ -78,7 +78,7 @@ print.gsd_graph_report <- function(x, ..., precision = 6, indent = 2) {
   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) format(col, digits = precision))
+  p_df[] <- lapply(p_df, function(col) formatC(col, format = "f", digits = precision))
   print(p_df)
 
   # Spending functions
@@ -124,7 +124,8 @@ print.gsd_graph_report <- function(x, ..., precision = 6, indent = 2) {
   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] <- format(adj_p[!exceed_1], digits = precision)
+  adj_p_format[!exceed_1] <- formatC(adj_p[!exceed_1], format = "f",
+                                     digits = precision)
 
   decision_at <- x$outputs$decision_at
 
@@ -188,10 +189,10 @@ print.gsd_graph_report <- function(x, ..., precision = 6, indent = 2) {
       # Remove the Look_back column from display
       detail$Look_back <- NULL
 
-      # Format numeric columns
-      detail$Weight <- format(detail$Weight, digits = precision)
-      detail$p <- format(detail$p, digits = precision)
-      detail$Boundary <- format(detail$Boundary, digits = precision)
+      # 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)
@@ -212,13 +213,13 @@ print.gsd_graph_report <- function(x, ..., precision = 6, indent = 2) {
   if (!is.null(x$boundary_table)) {
     section_break("Repeated p-values ($outputs$repeated_p)")
     rep_p_display <- x$outputs$repeated_p
-    rep_p_display[] <- format(rep_p_display, digits = precision)
+    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[] <- format(seq_p_display, digits = precision)
+    seq_p_display[] <- formatC(seq_p_display, format = "f", digits = precision)
     print(as.data.frame(seq_p_display))
     cat("\n")
   }
@@ -236,9 +237,10 @@ print.gsd_graph_report <- function(x, ..., precision = 6, indent = 2) {
       cat(pad, hyp, "\n", sep = "")
       bt <- x$boundary_table[[hyp]]
       bt_display <- bt
-      # Format numeric columns
+      # Format numeric columns with consistent fixed notation
       for (col in names(bt_display)) {
-        bt_display[[col]] <- format(bt_display[[col]], digits = precision)
+        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")

tests/testthat/test-graph_test_shortcut_gsd.R

@@ -999,3 +999,213 @@ test_that("print method shows rejection sequence", {
 
   expect_output(print(result), "Rejection sequence")
 })
+
+# =============================================================================
+# Look_back tests: H4-type (data at both analyses, crosses only at earlier)
+# and H5-type (data at analysis 1 only, look_back from later analysis)
+# =============================================================================
+
+# Helper: oncology-like graph for look_back tests
+gsd_onc_graph <- function() {
+  alpha_allocation <- c(0.01, 0.01, 0.004, 0, 0.0005, 0.0005)
+  hypotheses <- alpha_allocation / sum(alpha_allocation)
+  names(hypotheses) <- c("H1", "H2", "H3", "H4", "H5", "H6")
+  transitions <- rbind(
+    c(0, 1, 0, 0, 0, 0),
+    c(0, 0, 0.5, 0.5, 0, 0),
+    c(0, 0, 0, 1, 0, 0),
+    c(0, 0, 0, 0, 0.5, 0.5),
+    c(0, 0, 0, 0, 0, 1),
+    c(0.5, 0.5, 0, 0, 0, 0)
+  )
+  graph_create(hypotheses, transitions)
+}
+
+gsd_onc_info_frac <- function() {
+  rbind(
+    H1 = c(185 / 295, 245 / 295, 1),
+    H2 = c(529 / 800, 700 / 800, 1),
+    H3 = c(265 / 310, 1, NA),
+    H4 = c(675 / 750, 1, NA),
+    H5 = c(1, NA, NA),
+    H6 = c(1, NA, NA)
+  )
+}
+
+test_that("H4-type look_back: data at both analyses, crosses only at earlier", {
+  g <- gsd_onc_graph()
+  info_frac <- gsd_onc_info_frac()
+
+  # H4 has strong evidence at analysis 1, weak at analysis 2
+  # H4 starts with weight 0, gets weight after H3 rejection at analysis 2
+  p <- rbind(
+    H1 = c(0.03, 0.0001, 0.000001),
+    H2 = c(0.2, 0.15, 0.1),
+    H3 = c(0.2, 0.001, NA),
+    H4 = c(0.0001, 0.02, NA),
+    H5 = c(0.00001, NA, NA),
+    H6 = c(0.1, NA, NA)
+  )
+
+  r_no <- graph_test_shortcut_gsd(
+    g, p, alpha = 0.025, info_frac = info_frac,
+    spending_fn = spending_of, look_back = FALSE
+  )
+  r_yes <- graph_test_shortcut_gsd(
+    g, p, alpha = 0.025, info_frac = info_frac,
+    spending_fn = spending_of, look_back = TRUE, test_values = TRUE
+  )
+
+  # H4 not rejected without look_back
+  expect_false(r_no$outputs$rejected[["H4"]])
+
+  # H4 rejected with look_back, attributed to analysis 1
+  expect_true(r_yes$outputs$rejected[["H4"]])
+  expect_equal(r_yes$outputs$decision_at[["H4"]], 2L)
+  expect_equal(r_yes$outputs$first_rejected_at[["H4"]], 1L)
+
+  # test_values at analysis 2: H4 has standard row (Reject=FALSE) and
+  # look_back row (Reject=TRUE)
+  tv2 <- r_yes$test_values[[2]]
+  h4_standard <- tv2[tv2$Hypothesis == "H4" & !tv2$Look_back, ]
+  h4_lb <- tv2[tv2$Hypothesis == "H4" & tv2$Look_back, ]
+
+  expect_equal(nrow(h4_standard), 1)
+  expect_false(h4_standard$Reject)
+  expect_equal(h4_standard$Analysis, 2L)
+
+  expect_equal(nrow(h4_lb), 1)
+  expect_true(h4_lb$Reject)
+  expect_equal(h4_lb$Analysis, 1L)
+})
+
+test_that("H5-type look_back: single-analysis hypothesis, rejected via look_back at later analysis", {
+  g <- gsd_onc_graph()
+  info_frac <- gsd_onc_info_frac()
+
+  # H5 has 1 analysis, p=0.0008 > initial boundary (0.0005)
+  # After graph propagation at analysis 2, H5 gets more weight and
+  # look_back finds p=0.0008 crosses the new boundary
+  p <- rbind(
+    H1 = c(0.03, 0.0001, 0.000001),
+    H2 = c(0.2, 0.15, 0.1),
+    H3 = c(0.2, 0.001, NA),
+    H4 = c(0.0001, 0.02, NA),
+    H5 = c(0.0008, NA, NA),
+    H6 = c(0.1, NA, NA)
+  )
+
+  r_no <- graph_test_shortcut_gsd(
+    g, p, alpha = 0.025, info_frac = info_frac,
+    spending_fn = spending_of, look_back = FALSE
+  )
+  r_yes <- graph_test_shortcut_gsd(
+    g, p, alpha = 0.025, info_frac = info_frac,
+    spending_fn = spending_of, look_back = TRUE, test_values = TRUE
+  )
+
+  # H5 not rejected without look_back
+  expect_false(r_no$outputs$rejected[["H5"]])
+
+  # H5 rejected with look_back, attributed to analysis 1
+  expect_true(r_yes$outputs$rejected[["H5"]])
+  expect_equal(r_yes$outputs$decision_at[["H5"]], 2L)
+  expect_equal(r_yes$outputs$first_rejected_at[["H5"]], 1L)
+
+  # test_values at analysis 2: H5 has a standard row with p=NA (no data)
+  # and a look_back row at analysis 1 (Reject=TRUE)
+  tv2 <- r_yes$test_values[[2]]
+  h5_standard <- tv2[tv2$Hypothesis == "H5" & !tv2$Look_back, ]
+  h5_lb <- tv2[tv2$Hypothesis == "H5" & tv2$Look_back, ]
+
+  # Standard row: p is NA, Reject is FALSE
+  expect_equal(nrow(h5_standard), 1)
+  expect_true(is.na(h5_standard$p))
+  expect_false(h5_standard$Reject)
+
+  # Look_back row: analysis 1, p=0.0008, Reject=TRUE
+  expect_equal(nrow(h5_lb), 1)
+  expect_true(h5_lb$Reject)
+  expect_equal(h5_lb$Analysis, 1L)
+  expect_equal(h5_lb$p, 0.0008)
+})
+
+test_that("H5-type: without look_back, single-analysis hypothesis not reconsidered", {
+  g <- gsd_onc_graph()
+  info_frac <- gsd_onc_info_frac()
+
+  p <- rbind(
+    H1 = c(0.03, 0.0001, 0.000001),
+    H2 = c(0.2, 0.15, 0.1),
+    H3 = c(0.2, 0.001, NA),
+    H4 = c(0.0001, 0.02, NA),
+    H5 = c(0.0008, NA, NA),
+    H6 = c(0.1, NA, NA)
+  )
+
+  result <- graph_test_shortcut_gsd(
+    g, p, alpha = 0.025, info_frac = info_frac,
+    spending_fn = spending_of, look_back = FALSE, test_values = TRUE
+  )
+
+  # H5 not rejected
+  expect_false(result$outputs$rejected[["H5"]])
+  # H5 decision_at should be 1 (only analysis with data)
+  expect_equal(result$outputs$decision_at[["H5"]], 1L)
+
+  # H5 should not appear in test_values at analysis 2
+  tv2 <- result$test_values[[2]]
+  expect_false("H5" %in% tv2$Hypothesis)
+})
+
+test_that("look_back with single-analysis hypothesis: not rejected when p too large", {
+  g <- gsd_onc_graph()
+  info_frac <- gsd_onc_info_frac()
+
+  # H5 p=0.01 is too large even after propagation
+  p <- rbind(
+    H1 = c(0.03, 0.0001, 0.000001),
+    H2 = c(0.2, 0.15, 0.1),
+    H3 = c(0.2, 0.001, NA),
+    H4 = c(0.0001, 0.02, NA),
+    H5 = c(0.01, NA, NA),
+    H6 = c(0.1, NA, NA)
+  )
+
+  result <- graph_test_shortcut_gsd(
+    g, p, alpha = 0.025, info_frac = info_frac,
+    spending_fn = spending_of, look_back = TRUE
+  )
+
+  # H5 still not rejected — p=0.01 too large even with increased weight
+  expect_false(result$outputs$rejected[["H5"]])
+})
+
+test_that("look_back carries forward sequential p for hypotheses with no current data", {
+  g <- gsd_onc_graph()
+  info_frac <- gsd_onc_info_frac()
+
+  p <- rbind(
+    H1 = c(0.03, 0.0001, 0.000001),
+    H2 = c(0.2, 0.15, 0.1),
+    H3 = c(0.2, 0.001, NA),
+    H4 = c(0.0001, 0.02, NA),
+    H5 = c(0.0008, NA, NA),
+    H6 = c(0.1, NA, NA)
+  )
+
+  result <- graph_test_shortcut_gsd(
+    g, p, alpha = 0.025, info_frac = info_frac,
+    spending_fn = spending_of, look_back = TRUE
+  )
+
+  # Sequential p for H5 should be the same at analysis 1
+  # (only one analysis with data)
+  expect_equal(
+    result$outputs$sequential_p["H5", 1],
+    result$outputs$repeated_p["H5", 1]
+  )
+  # Analysis 2 and 3 should be NA for H5
+  expect_true(is.na(result$outputs$sequential_p["H5", 2]))
+  expect_true(is.na(result$outputs$sequential_p["H5", 3]))
+})