crossval bug

tagteam · Jun 14, 2024 · 7a9f154 · 7a9f154
1 parent 2637249
commit 7a9f154
Show file tree

Hide file tree

Showing 5 changed files with 24 additions and 13 deletions.
diff --git a/R/crossvalPerf.loob.AUC.R b/R/crossvalPerf.loob.AUC.R
@@ -3,9 +3,9 @@
 ## Author: Thomas Alexander Gerds
 ## Created: Jun  4 2024 (09:20) 
 ## Version: 
-## Last-Updated: Jun 13 2024 (15:40) 
+## Last-Updated: Jun 14 2024 (07:46) 
 ##           By: Thomas Alexander Gerds
-##     Update #: 93
+##     Update #: 97
 #----------------------------------------------------------------------
 ## 
 ### Commentary:
@@ -238,10 +238,10 @@ crossvalPerf.loob.AUC <- function(times,
                                                            dolist=dolist,
                                                            se.fit=TRUE)]
                 }
-                setnames(contrasts.AUC,"delta","delta.AUC")
-                output <- c(output,list(contrasts=contrasts.AUC))
             }
         }
+        setnames(contrasts.AUC,"delta","delta.AUC")
+        output <- c(output,list(contrasts=contrasts.AUC))
     }
     if (!is.null(output$score)){
         output$score[,model:=factor(model,levels=mlevs,mlabels)]

diff --git a/R/print.Score.R b/R/print.Score.R
@@ -3,9 +3,9 @@
 ## author: Thomas Alexander Gerds
 ## created: May 31 2016 (11:32)
 ## Version:
-## last-updated: Jun  5 2024 (07:27) 
+## last-updated: Jun 14 2024 (07:37) 
 ##           By: Thomas Alexander Gerds
-##     Update #: 70
+##     Update #: 71
 #----------------------------------------------------------------------
 ##
 ### Commentary:
@@ -50,7 +50,8 @@ print.Score <- function(x,digits,...){
             " each of size ",
             x$split.method$M,
             ".\n",
-            ifelse(x$call$se.fit,paste0("The level of significance is set at ",x$alpha,"\nThe 'confidence intervals' are bootstrap quantiles"),""),
+            ifelse(x$call$se.fit,paste0("The level of significance is set at ",x$alpha,
+                                        "\nThe 'confidence intervals' are bootstrap quantiles"),""),
             "\n",
             sep="")
     },"LeaveOneOutBoot"={
@@ -63,7 +64,8 @@ print.Score <- function(x,digits,...){
             " each of size ",
             x$split.method$M,
             ".\n",
-            "The 'confidence intervals' and 'p-values' are obtained with the delta method after bootstrap.\n",
+            ifelse(x$call$se.fit,paste0("The level of significance is set at ",x$alpha,
+                                        "The 'confidence intervals' and 'p-values' are obtained with the delta method after bootstrap.\n"),""),
             sep="")
     })
     if (x$split.method$internal.name == "crossval"){

diff --git a/R/riskRegression-package.R b/R/riskRegression-package.R
@@ -91,7 +91,7 @@ NULL
 #' @importFrom ggplot2 autoplot aes aes_string element_blank element_line element_rect geom_errorbar geom_line geom_point geom_ribbon ggplot labs guide_legend guides scale_colour_manual scale_color_continuous scale_fill_manual scale_linetype_manual scale_y_continuous theme theme_bw "%+replace%"  unit xlab  ylab
 #' @importFrom survival Surv strata coxph survreg
 #' @importFrom lava sim iid information score transform<- exogenous endogenous regression<-
-#' @importFrom data.table data.table set dcast setkeyv as.data.table copy data.table is.data.table melt rbindlist setnames setorder setcolorder setkey ":=" ".N" ".SD"
+#' @importFrom data.table data.table set dcast setkeyv as.data.table copy data.table is.data.table melt rbindlist setnames setorder setorderv setcolorder setkey ":=" ".N" ".SD"
 #' @importFrom prodlim Hist dimColor prodlim
 #' @importFrom foreach "%dopar%" foreach "%do%"
 #' @importFrom cmprsk predict.crr

diff --git a/slowtests/test-score-crossval.R b/slowtests/test-score-crossval.R
@@ -19,12 +19,20 @@ test_that("loob binary",{
 
 test_that("loob survival",{
     set.seed(8)
-    learndat=sampleData(38,outcome="survival")
+    learndat=sampleData(188,outcome="survival")
     cox1a = coxph(Surv(time,event)~X6,data=learndat,x=TRUE,y=TRUE)
-    cox2a = coxph(Surv(time,event)~X7+X8+X9,data=learndat,x=TRUE,y=TRUE)
+    cox2a = coxph(Surv(time,event)~X1+X9,data=learndat,x=TRUE,y=TRUE)
     ## leave-one-out bootstrap
     x <- Score(list("COX1"=cox1a,"COX2"=cox2a),formula=Surv(time,event)~1,data=learndat,times=5,seed = 5,split.method="loob",B=100,se.fit=FALSE,progress.bar=NULL,metrics = "auc",verbose = -1)
     y <- Score(list("COX1"=cox1a,"COX2"=cox2a),formula=Surv(time,event)~1,data=learndat,times=5,seed = 5,split.method="loob",B=10,se.fit=FALSE,progress.bar=NULL,metrics = "auc",verbose = -1)
+    z <- Score(list("COX1"=cox1a,"COX2"=cox2a),formula=Surv(time,event)~1,data=learndat,times=5,seed = 5,split.method="loob",M = .632*nrow(learndat),B=100,se.fit=FALSE,progress.bar=NULL,metrics = "auc",verbose = -1)
+    ## 10-fold, 7-fold, 5-fold, 2-fold
+    a <- Score(list("COX1"=cox1a,"COX2"=cox2a),formula=Surv(time,event)~1,data=learndat,times=5,seed = 5,split.method="cv10",B=1,se.fit=FALSE,progress.bar=NULL,metrics = "auc",verbose = -1)
+    b <- Score(list("COX1"=cox1a,"COX2"=cox2a),formula=Surv(time,event)~1,data=learndat,times=5,seed = 5,split.method="cv7",B=2,se.fit=FALSE,progress.bar=NULL,metrics = "auc",verbose = -1)
+    c <- Score(list("COX1"=cox1a,"COX2"=cox2a),formula=Surv(time,event)~1,data=learndat,times=5,seed = 5,split.method="cv2",B=20,se.fit=FALSE,progress.bar=NULL,metrics = "auc",verbose = -1)
+    d <- Score(list("COX1"=cox1a,"COX2"=cox2a),formula=Surv(time,event)~1,data=learndat,times=5,seed = 5,split.method="cv5",B=2,se.fit=FALSE,progress.bar=NULL,metrics = "auc",verbose = -1)
+    ## bootcv
+    e <- Score(list("COX1"=cox1a,"COX2"=cox2a),formula=Surv(time,event)~1,data=learndat,times=5,seed = 5,split.method="bootcv",B=100,se.fit=FALSE,progress.bar=NULL,metrics = "auc",verbose = -1)
 })
 
 #does give some warnings probably, nothing too serious

diff --git a/tests/testthat/test-score.R b/tests/testthat/test-score.R
@@ -3,9 +3,9 @@
 ## author: Thomas Alexander Gerds
 ## created: Jan  4 2016 (14:30) 
 ## Version: 
-## last-updated: Jun 10 2024 (11:55) 
+## last-updated: Jun 14 2024 (07:57) 
 ##           By: Thomas Alexander Gerds
-##     Update #: 179
+##     Update #: 180
 #----------------------------------------------------------------------
 ## 
 ### Commentary: 
@@ -234,6 +234,7 @@ test_that("binary outcome: AUC", {
 ## library(survival)
 ## library(riskRegression)
 ## library(rms)
+## library(pec)
 ## data(pbc)
 ## pbc <- na.omit(pbc)
 ## pbc$time=pbc$time+rnorm(nrow(pbc),sd=.1)