Fix Issue #42

R/robincar-tte.R

@@ -35,6 +35,15 @@ robincar_tte <- function(df,
                          car_scheme="simple", return_influence=FALSE, id_col=NULL, finite_sample = FALSE){
 
   .check.car_scheme(car_scheme, car_strata_cols)
+  .check.tte_reserved_names(
+    df=df,
+    treat_col=treat_col,
+    response_col=response_col,
+    event_col=event_col,
+    car_strata_cols=car_strata_cols,
+    covariate_cols=covariate_cols,
+    id_col=id_col
+  )
   data <- .make.data(
     df=df,
     classname="RoboDataTTE",

R/utils-arg.R

@@ -22,6 +22,74 @@
   }
 }
 
+# Names of columns that are created or overwritten internally when
+# building and processing the time-to-event dataset (see adjust-tte.R,
+# adjust-logrank.R, adjust-coxscore.R, adjust-covhr.R). User-supplied
+# covariates with these names would be silently overwritten or clash.
+.TTE.RESERVED.NAMES <- c(
+  # create.tte.df
+  "treat", "response", "event", "nu_d", "carcov_z", "car_strata",
+  # note: "id" is only added when return_influence=TRUE, and is checked in model.R
+  # process.tte.df
+  "Y", "Y0", "Y1", "trt0", "trt1", "n.events",
+  "cum.delta.Y0.over.Ysq", "cum.delta.Y1.over.Ysq",
+  "cum.delta.Y0.over.Ysq.theta_L", "cum.delta.Y1.over.Ysq.theta_L",
+  # get.ordered.data
+  "mu_t", "O.hat", "O.hat0", "O.hat1", "lin_pred",
+  "s0", "s1", "s0_seq", "s1_seq",
+  "mean_at_risk", "cumsum_at_risk", "mean_at_risk2", "cumsum_at_risk2",
+  "O_i", "u_i",
+  # calculate.adjustment and test statistics
+  "adjust1", "adjust0", "bsigb",
+  "uu_cl", "ssig_l", "U_SL_z", "var_adj",
+  "cond_var0", "cond_var1", "cond_mean0", "cond_mean1", "prob_z", "z_var"
+)
+
+# Prefixes of internally generated columns (design matrix and regression betas)
+.TTE.RESERVED.PREFIXES <- c("xmat_", "trt1_")
+
+.check.tte_reserved_names <- function(df, treat_col, response_col, event_col,
+                                      car_strata_cols=NULL,
+                                      covariate_cols=NULL, id_col=NULL){
+  # Columns of df that are used as covariates are copied into the internal
+  # dataset, so they must not collide with internally created columns.
+  # Other user columns (treat, response, event, id, strata) are renamed
+  # internally, but we still check every column of df that is used.
+  used <- c(covariate_cols)
+  bad <- used[used %in% .TTE.RESERVED.NAMES]
+  prefix_pattern <- paste0("^(", paste0(.TTE.RESERVED.PREFIXES, collapse="|"), ")")
+  bad <- unique(c(bad, used[grepl(prefix_pattern, used)]))
+  if(length(bad) > 0){
+    stop(paste0(
+      "The following covariate column(s) in df use reserved names that are ",
+      "overwritten internally and would produce incorrect results: ",
+      paste0(bad, collapse=", "),
+      ". Please rename these columns. Reserved names include: ",
+      paste0(.TTE.RESERVED.NAMES, collapse=", "),
+      "; and names beginning with: ",
+      paste0(.TTE.RESERVED.PREFIXES, collapse=", "), "."
+    ))
+  }
+  # Warn if the treatment/response/event/id/strata columns have reserved names
+  # that coincide with a *different* role (e.g. response column named "event").
+  roles <- list(treat=treat_col, response=response_col, event=event_col,
+                id=id_col)
+  for(role in names(roles)){
+    col <- roles[[role]]
+    if(!is.null(col) && col %in% .TTE.RESERVED.NAMES && col != role){
+      stop(paste0("Column '", col, "' supplied as ", role, "_col has a reserved ",
+                  "name used internally. Please rename it."))
+    }
+  }
+  for(col in car_strata_cols){
+    if(col %in% .TTE.RESERVED.NAMES){
+      stop(paste0("car_strata column '", col, "' has a reserved name used ",
+                  "internally. Please rename it."))
+    }
+  }
+  invisible(TRUE)
+}
+
 .check.variance_type <- function(variance_type){
   OPTIONS <- c(1, 2, 3)
   .check.options("variance_type", variance_type, OPTIONS)

tests/testthat/test-check-tte-reserved.R

@@ -0,0 +1,69 @@
+make_tte_df <- function(n=100){
+  set.seed(0)
+  df <- data_gen(
+    n=n, theta=0, randomization="permuted_block", p_trt=0.5, case="case2"
+  )
+  df$strata1 <- sample(letters[1:3], n, replace=TRUE)
+  df
+}
+
+run_tte <- function(df, covariate_cols, ...){
+  robincar_logrank(
+    df=df,
+    treat_col="I1",
+    response_col="t",
+    event_col="delta",
+    car_strata_cols="strata1",
+    covariate_cols=covariate_cols,
+    car_scheme="permuted-block",
+    adj_method="CL",
+    ...
+  )
+}
+
+test_that("covariates named s0 or s1 raise an error", {
+  df <- make_tte_df()
+  for(nm in c("s0", "s1")){
+    d <- df
+    d[[nm]] <- d$model_z1
+    expect_error(run_tte(d, c("model_z2", nm)), "reserved names")
+  }
+})
+
+test_that("all reserved covariate names raise an error", {
+  df <- make_tte_df()
+  for(nm in .TTE.RESERVED.NAMES){
+    d <- df
+    d[[nm]] <- d$model_z1
+    expect_error(run_tte(d, c("model_z2", nm)), "reserved names", info=nm)
+  }
+})
+
+test_that("reserved prefixes raise an error", {
+  df <- make_tte_df()
+  df$xmat_a <- df$model_z1
+  df$trt1_a <- df$model_z1
+  expect_error(run_tte(df, "xmat_a"), "reserved names")
+  expect_error(run_tte(df, "trt1_a"), "reserved names")
+})
+
+test_that("reserved names for strata and wrong roles raise an error", {
+  df <- make_tte_df()
+  df$s1 <- df$strata1
+  expect_error(
+    robincar_logrank(
+      df=df, treat_col="I1", response_col="t", event_col="delta",
+      car_strata_cols="s1", car_scheme="permuted-block", adj_method="CL"
+    ), "reserved name")
+  df$event <- df$delta
+  expect_error(
+    robincar_logrank(
+      df=df, treat_col="I1", response_col="event", event_col="delta",
+      car_strata_cols="strata1", car_scheme="permuted-block", adj_method="CL"
+    ), "reserved name")
+})
+
+test_that("valid covariate names do not error", {
+  df <- make_tte_df()
+  expect_error(run_tte(df, c("model_z1", "model_z2")), NA)
+})

tests/testthat/test-logrank-ties.R

@@ -101,7 +101,7 @@ test_that("Logrank ovarian", {
 
   # (1) Survdiff function
   lr <- survdiff(Surv(tte, obs) ~ rx, data = DATA)
-  lr_p <- lr$pvalue
+  lr_p <- pchisq(lr$chisq, df=1, lower.tail=FALSE)
   lr_num <- lr$obs[1] - lr$exp[1]
   lr_var <- lr$var[1, 1] / nrow(DATA)
 
@@ -116,7 +116,7 @@ test_that("Logrank ovarian", {
   )
   RC1res <- (2 * pnorm(abs(RC1$result$statistic), lower.tail = F))
 
-  data <- DATA %>% select(t = tte)
+  data <- DATA %>% dplyr::select(t = tte)
   data$delta <- 1*(DATA$obs==T)
   data$I1 <- DATA$rx - 1
   data$I0 <- 1 - data$I1
@@ -141,7 +141,7 @@ test_that("Logrank Ovarian with ties", {
 
   # (1) Survdiff function
   lr <- survdiff(Surv(tte, obs) ~ rx, data = DATA2)
-  lr_p <- lr$pvalue
+  lr_p <- pchisq(lr$chisq, df=1, lower.tail=FALSE)
   lr_num <- lr$obs[1] - lr$exp[1]
   lr_var <- lr$var[1, 1] / nrow(DATA)