80 add binary to wrapper function for unanchored case

DESCRIPTION

@@ -21,13 +21,14 @@ Imports:
     DescTools,
     MASS,
     boot,
-    stringr
+    stringr,
+    lmtest,
+    cli
 Suggests:
     knitr,
     testthat (>= 2.0),
     ggplot2,
     rmarkdown,
-    clubSandwich,
     dplyr,
     sandwich,
     survminer,

NAMESPACE

@@ -13,6 +13,7 @@ export(dummize_ipd)
 export(estimate_weights)
 export(find_SE_from_CI)
 export(generate_survival_data)
+export(get_pseudo_ipd_binary)
 export(get_time_conversion)
 export(kmplot)
 export(kmplot2)
@@ -25,7 +26,8 @@ export(ph_diagplot_schoenfeld)
 export(plot_weights_base)
 export(plot_weights_ggplot)
 export(process_agd)
-export(report_table)
+export(report_table_binary)
+export(report_table_tte)
 export(set_time_conversion)
 export(survfit_makeup)
 import(DescTools)
@@ -38,6 +40,8 @@ import(stringr)
 import(survival)
 importFrom(grDevices,col2rgb)
 importFrom(grDevices,rgb)
+importFrom(lmtest,coefci)
+importFrom(lmtest,coeftest)
 importFrom(survival,Surv)
 importFrom(survival,survfit)
 importFrom(utils,stack)

R/binary-helper.R

@@ -0,0 +1,86 @@
+#' Create pseudo IPD given aggregated binary data
+#'
+#' @param binary_agd a data.frame that take different formats depending on \code{format}
+#' @param format a string, "stacked" or "unstacked"
+#'
+#' @return a data.frame of pseudo binary IPD, with columns USUBJID, ARM, RESPONSE
+#' @example inst/examples/get_pseudo_ipd_binary_ex.R
+#' @export
+
+get_pseudo_ipd_binary <- function(binary_agd, format = c("stacked", "unstacked")) {
+  # pre check
+  if (format == "stacked") {
+    if (!is.data.frame(binary_agd)) {
+      stop("stacked binary_agd should be data.frame with columns 'ARM', 'RESPONSE', 'COUNT'")
+    }
+    names(binary_agd) <- toupper(names(binary_agd))
+    if (!all(c("ARM", "RESPONSE", "COUNT") %in% names(binary_agd))) {
+      stop("stacked binary_agd should be data.frame with columns 'ARM', 'Response', 'Count'")
+    }
+    if (!is.logical(binary_agd$RESPONSE) && !all(toupper(binary_agd$RESPONSE) %in% c("YES", "NO"))) {
+      stop("'RESPONSE' column in stacked binary_agd should be either logical vector or character vector of 'Yes'/'No'")
+    }
+    if (nrow(binary_agd) %% 2 != 0) {
+      stop("nrow(binary_agd) is not even number, you may miss to provide 1 level of binary response to certain arm")
+    }
+  } else if (format == "unstacked") {
+    if (!(is.data.frame(binary_agd) || is.matrix(binary_agd))) {
+      stop("unstacked binary_agd should be either a 1x2 or 2x2 data frame or matrix")
+    }
+    if (ncol(binary_agd) != 2 || !nrow(binary_agd) %in% c(1, 2)) {
+      stop("unstacked binary_agd should be either a 1x2 or 2x2 data frame or matrix")
+    }
+    bin_res <- toupper(colnames(binary_agd))
+    bin_res <- sort(bin_res)
+    if (!(identical(bin_res, c("FALSE", "TRUE")) || identical(bin_res, c("NO", "YES")))) {
+      stop("column names of unstacked binary_agd should be either TRUE/FALSE or Yes/No")
+    }
+  }
+
+  # pre process binary_agd, depending on format
+  use_binary_agd <- switch(format,
+    "stacked" = {
+      names(binary_agd) <- toupper(names(binary_agd))
+      if (!is.logical(binary_agd$RESPONSE)) {
+        binary_agd$RESPONSE <- toupper(binary_agd$RESPONSE)
+        binary_agd$RESPONSE <- binary_agd$RESPONSE == "YES"
+      }
+      binary_agd
+    },
+    "unstacked" = {
+      trt_names <- rownames(binary_agd)
+      bin_res <- toupper(colnames(binary_agd))
+      if ("YES" %in% bin_res) {
+        bin_res <- ifelse(bin_res == "YES", "TRUE", "FALSE")
+        colnames(binary_agd) <- bin_res
+      }
+      tmpout <- utils::stack(binary_agd)
+      tmpout <- cbind(ARM = rep(trt_names, each = 2), tmpout)
+      names(tmpout) <- c("ARM", "COUNT", "RESPONSE")
+      rownames(tmpout) <- NULL
+      tmpout$RESPONSE <- as.logical(tmpout$RESPONSE)
+      tmpout
+    }
+  )
+
+  # create pseudo binary IPD
+  use_binary_agd$ARM <- factor(use_binary_agd$ARM, levels = unique(use_binary_agd$ARM))
+  n_per_arm <- tapply(use_binary_agd$COUNT, use_binary_agd$ARM, sum)
+  n_yes_per_arm <- use_binary_agd$COUNT[use_binary_agd$RESPONSE] # use_binary_agd is already ordered as per factor ARM
+
+  tmpipd <- data.frame(
+    USUBJID = NA,
+    ARM = unlist(
+      mapply(rep, x = levels(use_binary_agd$ARM), each = n_per_arm, SIMPLIFY = FALSE, USE.NAMES = FALSE)
+    ),
+    RESPONSE = unlist(
+      lapply(seq_along(n_per_arm), function(ii) {
+        c(rep(TRUE, n_yes_per_arm[ii]), rep(FALSE, n_per_arm[ii] - n_yes_per_arm[ii]))
+      })
+    )
+  )
+  tmpipd$USUBJID <- paste0("pseudo_binary_subj_", seq_len(nrow(tmpipd)))
+
+  # output
+  tmpipd
+}

R/maic_anchored.R

@@ -7,7 +7,7 @@
 #' @param ipd a data frame that meet format requirements in 'Details', individual patient data (IPD) of internal trial
 #' @param pseudo_ipd a data frame, pseudo IPD from digitized KM curve of external trial (for time-to-event endpoint) or
 #'   from contingency table (for binary endpoint)
-#' @param trt_ipd  a string, name of the interested investigation arm in internal trial \code{dat_igd} (real IPD)
+#' @param trt_ipd  a string, name of the interested investigation arm in internal trial \code{ipd} (internal IPD)
 #' @param trt_agd a string, name of the interested investigation arm in external trial \code{pseudo_ipd} (pseudo IPD)
 #' @param trt_common a string, name of the common comparator in internal and external trial
 #' @param trt_var_ipd a string, column name in \code{ipd} that contains the treatment assignment
@@ -226,9 +226,9 @@ maic_anchored_tte <- function(res,
 
   # make analysis report table
   res$inferential[["report_overall_robustCI"]] <- rbind(
-    report_table(coxobj_ipd, medSurv_ipd, tag = paste0("IPD/", endpoint_name)),
-    report_table(coxobj_ipd_adj, medSurv_ipd_adj, tag = paste0("weighted IPD/", endpoint_name)),
-    report_table(coxobj_agd, medSurv_agd, tag = paste0("Agd/", endpoint_name)),
+    report_table_tte(coxobj_ipd, medSurv_ipd, tag = paste0("IPD/", endpoint_name)),
+    report_table_tte(coxobj_ipd_adj, medSurv_ipd_adj, tag = paste0("weighted IPD/", endpoint_name)),
+    report_table_tte(coxobj_agd, medSurv_agd, tag = paste0("Agd/", endpoint_name)),
     c(
       paste0("** adj.", trt_ipd, " vs ", trt_agd),
       rep("-", 4),
@@ -244,9 +244,9 @@ maic_anchored_tte <- function(res,
     boot_res_AB$ci_l <- exp(log(boot_res_AB$est) + qnorm(0.025) * boot_logres_se)
     boot_res_AB$ci_u <- exp(log(boot_res_AB$est) + qnorm(0.975) * boot_logres_se)
     res$inferential[["report_overall_bootCI"]] <- rbind(
-      report_table(coxobj_ipd, medSurv_ipd, tag = paste0("IPD/", endpoint_name)),
-      report_table(coxobj_ipd_adj, medSurv_ipd_adj, tag = paste0("weighted IPD/", endpoint_name)),
-      report_table(coxobj_agd, medSurv_agd, tag = paste0("Agd/", endpoint_name)),
+      report_table_tte(coxobj_ipd, medSurv_ipd, tag = paste0("IPD/", endpoint_name)),
+      report_table_tte(coxobj_ipd_adj, medSurv_ipd_adj, tag = paste0("weighted IPD/", endpoint_name)),
+      report_table_tte(coxobj_agd, medSurv_agd, tag = paste0("Agd/", endpoint_name)),
       c(
         paste0("** adj.", trt_ipd, " vs ", trt_agd),
         rep("-", 4),