add influence function calculation

R/Data.R

@@ -32,6 +32,12 @@
   }
 }
 
+.check.id <- function(data){
+  if (!length(data$id) == length(unique(data$id))){
+    return("Id column must not have duplicated values")
+  }
+}
+
 .check.attributes <- function(x, ...){
   required <- c(...)
   existing <- names(x)
@@ -97,6 +103,10 @@ validate.RoboDataTTE <- function(data, ref_arm, ...){
       )
     }
   }
+  if (!is.null(data$id_col)) {
+    errors <- c(errors, .check.attributes(data, "id"))
+    errors <- c(errors, .check.id(data))
+  }
 
   .return.error(errors)
 }
@@ -200,7 +210,13 @@ validate.RoboDataMH <- function(data, ...){
 
       att_name <- gsub("_cols", "", att_name)
       att_name <- gsub("_col", "", att_name)
-
+      if(!is.null(att)){
+        for (a in att) {
+          if (!a %in% colnames(df)) {
+            stop(paste0("Column ", a, " not found."))
+          }
+        }
+      }
       data[[att_name]] <- df[att]
 
     } else {
@@ -236,6 +252,11 @@ validate.RoboDataMH <- function(data, ...){
   if(ncol(data$car_strata) == 0){
     data$car_strata <- NULL
   }
+  if (!is.null(data$id)){
+    if (ncol(data$id) > 0) {
+      data$id <- data$id[[1]]
+    }
+  }
   if(!is.null(data$car_strata)){
     # Create joint car_strata levels
     data$joint_strata <- joint.car_strata(data$car_strata)

R/adjust-logrank.R

@@ -37,14 +37,17 @@ adjust.LogRank <- function(model, data, ...){
   var_CSL   <- (sum(df$ssig_l, na.rm=TRUE) - sum(ss$var_adj)) / data$n^2
   se        <- sqrt(var_CSL)
   statistic <- U_CSL / se
-
+  
   result <- list(
     strata_sum=ss,
     U=U_CSL,
     se=se,
     statistic=statistic
   )
-
+  if (model$return_influence) {
+    influence_function <- df$uu_cl + (model$p_trt) * df$adjust1 - (1 - model$p_trt) * df$adjust0
+    result$inf_func <- data.frame(id = df$id, inf_func = influence_function)
+  } 
   return(
     structure(
       class="TTEResult",

R/adjust-tte.R

@@ -9,6 +9,11 @@ create.tte.df <- function(model, data){
     event=data$event,
     nu_d=nu.d(model$car_scheme)
   )
+  if ("return_influence" %in% names(model)){
+    if (model$return_influence) {
+      df$id <- data$id
+    }
+  }
   # Adjust for x-covariates
   if(model$adj_cov){
     df <- cbind(df, data$covariate)

R/model.R

@@ -71,7 +71,7 @@
 # with settings for covariate randomization
 # scheme and vcovHC type.
 .make.model.RoboDataTTE <- function(data, adj_method, car_scheme,
-                                    p_trt, ref_arm, ...) {
+                                    p_trt, ref_arm, return_influence, ...) {
 
   x_exists <- !is.null(data$covariate)
   z_exists <- !is.null(data$car_strata)
@@ -97,11 +97,24 @@
       car_scheme=car_scheme,
       p_trt=p_trt,
       ref_arm=ref_arm,
+      return_influence=return_influence,
       ...
     ),
     class=c(classtype, logic$method)
   )
 
+  if ("return_influence" %in% names(model)){
+    if (!is.logical(model$return_influence)) stop("return_influence must be either TRUE or FALSE.")
+    if (model$return_influence) {
+      if (!"id_col" %in% names(data)) stop("id_col must not be NULL if return_influence is TRUE")
+      if (!is.null(data$covariate)){
+        if ("id" %in% colnames(data$covariate)){
+          stop("if return_influence is TRUE, no covariate can be called 'id'.")
+        }
+      }
+    }
+  }
+
   return(model)
 }
 

R/robincar-covhr.R

@@ -57,7 +57,8 @@ robincar_covhr <- function(df,
     car_scheme=car_scheme,
     p_trt=p_trt,
     ref_arm=ref_arm,
-    interval=interval
+    interval=interval, 
+    return_influence=F
   )
 
   # Append the CovHR classification

R/robincar-logrank.R

@@ -78,7 +78,7 @@
 #'
 #' @returns A result object with the following attributes:
 #'
-#' \item{result}{A list: "statistic" is the adjusted logrank test statistic which can be used to obtain p-values; "U" and "se" are the numerator and denominator of the test statistic, respectively.}
+#' \item{result}{A list: "statistic" is the adjusted logrank test statistic which can be used to obtain p-values; "U" and "se" are the numerator and denominator of the test statistic, respectively; if the input parameter "return_influence" is set to TRUE, the list will contain an element called "inf_func", which is a data.frame with columns "id" and "inf_func", which is the influence function for each subject for the covariate-adjusted log-rank test (stratified or unstratified). This influence function can be used, e.g., to calculate the correlation between interim and final test statistics in a group sequential design.}
 #' \item{settings}{The covariate adjustment settings used.}
 #' \item{original_df}{The dataset supplied by the user.}
 #'

R/robincar-tte.R

@@ -29,18 +29,18 @@ robincar_tte <- function(df,
                          adj_method,
                          car_strata_cols=NULL, covariate_cols=NULL,
                          p_trt=0.5, ref_arm=NULL, sparse_remove=TRUE,
-                         car_scheme="simple"){
+                         car_scheme="simple",return_influence=FALSE,id_col=NULL){
 
   .check.car_scheme(car_scheme, car_strata_cols)
-
   data <- .make.data(
     df=df,
     classname="RoboDataTTE",
     treat_col=treat_col,
     response_col=response_col,
     event_col=event_col,
     car_strata_cols=car_strata_cols,
-    covariate_cols=covariate_cols
+    covariate_cols=covariate_cols,
+    id_col=id_col
   )
   validate(data, ref_arm)
 
@@ -51,11 +51,12 @@ robincar_tte <- function(df,
     car_scheme=car_scheme,
     p_trt=p_trt,
     ref_arm=ref_arm,
-    sparse_remove=sparse_remove
+    sparse_remove=sparse_remove, 
+    return_influence=return_influence
   )
 
   # Perform adjustment
-  result <- adjust(model, data)
+  result <- adjust(model, data, return_influence)
   result$original_df <- df
 
   return(result)

tests/testthat/test-inf-func.R

@@ -0,0 +1,114 @@
+library(survival)
+library(tidyverse)
+
+files <- Sys.glob("~/Documents/GitHub/RobinCar/R/*.R")
+map(files, source)
+
+DATA <- ovarian %>%
+  rename(tte = futime, obs = fustat) %>%
+  arrange(tte)
+
+test_that("Logrank influence function error checking 6", {
+  DATA$id <- DATA$ecog.ps
+  expect_error(robincar_logrank(
+    adj_method = "CL",
+    df = DATA,
+    treat_col = "rx",
+    p_trt = 0.5,
+    ref_arm = 1,
+    response_col = "tte",
+    event_col = "obs",
+    return_influence = T,
+    id_col = "idx"
+  ), "Column idx not found")
+})
+
+test_that("Logrank influence function error checking 5", {
+  DATA$id <- DATA$ecog.ps
+  expect_no_error(robincar_logrank(
+    adj_method = "CL",
+    df = DATA,
+    treat_col = "rx",
+    p_trt = 0.5,
+    covariate_col = "id",
+    ref_arm = 1,
+    response_col = "tte",
+    event_col = "obs"
+  ))
+})
+
+test_that("Logrank influence function error checking 4", {
+  DATA$idx <- 1:nrow(DATA)
+  DATA$id <- DATA$ecog.ps
+  expect_error(robincar_logrank(
+    adj_method = "CL",
+    df = DATA,
+    treat_col = "rx",
+    p_trt = 0.5,
+    covariate_col = "id",
+    ref_arm = 1,
+    response_col = "tte",
+    event_col = "obs",
+    return_influence = T,
+    id_col = "idx"
+  ), "if return_influence is TRUE, no covariate can be called 'id'.")
+})
+
+test_that("Logrank influence function error checking 3", {
+  DATA$idx <- 1:nrow(DATA)
+  expect_error(robincar_logrank(
+    adj_method = "CL",
+    df = DATA,
+    treat_col = "rx",
+    p_trt = 0.5,
+    ref_arm = 1,
+    response_col = "tte",
+    event_col = "obs",
+    return_influence = "cheese",
+    id_col = "idx"
+  ), "return_influence must be either TRUE or FALSE")
+})
+
+test_that("Logrank influence function error checking 2", {
+  DATA$idx <- 5
+  expect_error(robincar_logrank(
+    adj_method = "CL",
+    df = DATA,
+    treat_col = "rx",
+    p_trt = 0.5,
+    ref_arm = 1,
+    response_col = "tte",
+    event_col = "obs",
+    return_influence = T,
+    id_col = "idx"
+  ), "Id column must not have duplicated values")
+})
+
+test_that("Logrank influence function error checking 1", {
+  expect_error(robincar_logrank(
+    adj_method = "CL",
+    df = DATA,
+    treat_col = "rx",
+    p_trt = 0.5,
+    ref_arm = 1,
+    response_col = "tte",
+    event_col = "obs",
+    return_influence = T
+  ), "id_col must not be NULL if return_influence is TRUE")
+})
+
+test_that("Logrank influence function", {
+  DATA$idx <- 1:nrow(DATA)
+  RC1 <- robincar_logrank(
+    adj_method = "CL",
+    df = DATA,
+    treat_col = "rx",
+    p_trt = 0.5,
+    ref_arm = 1,
+    response_col = "tte",
+    event_col = "obs",
+    return_influence = T,
+    id_col = "idx"
+  )
+  expect_equal(sum(RC1$result$inf_func$inf_func), RC1$result$strata_sum$U_SL_z[1])
+})