diff --git a/R/Data.R b/R/Data.R index d59e028..5776ca7 100644 --- a/R/Data.R +++ b/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) diff --git a/R/adjust-logrank.R b/R/adjust-logrank.R index ac64049..7338546 100644 --- a/R/adjust-logrank.R +++ b/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", diff --git a/R/adjust-tte.R b/R/adjust-tte.R index acaf689..1f85158 100644 --- a/R/adjust-tte.R +++ b/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) diff --git a/R/model.R b/R/model.R index 481f6be..514e909 100644 --- a/R/model.R +++ b/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) } diff --git a/R/robincar-covhr.R b/R/robincar-covhr.R index 9d8b23c..2d0c676 100644 --- a/R/robincar-covhr.R +++ b/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 diff --git a/R/robincar-logrank.R b/R/robincar-logrank.R index 910599c..2c0e88c 100644 --- a/R/robincar-logrank.R +++ b/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.} #' diff --git a/R/robincar-tte.R b/R/robincar-tte.R index 8201104..323ee46 100644 --- a/R/robincar-tte.R +++ b/R/robincar-tte.R @@ -29,10 +29,9 @@ 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", @@ -40,7 +39,8 @@ robincar_tte <- function(df, 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) diff --git a/tests/testthat/test-inf-func.R b/tests/testthat/test-inf-func.R new file mode 100644 index 0000000..1fed82c --- /dev/null +++ b/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]) +}) \ No newline at end of file diff --git a/tests/testthat/testthat-problems.rds b/tests/testthat/testthat-problems.rds new file mode 100644 index 0000000..8905ae9 Binary files /dev/null and b/tests/testthat/testthat-problems.rds differ