From 7a9f1541795da8affd35573a8990185e4ac73582 Mon Sep 17 00:00:00 2001 From: Thomas Alexander Gerds Date: Fri, 14 Jun 2024 16:35:20 +0200 Subject: [PATCH] crossval bug --- R/crossvalPerf.loob.AUC.R | 8 ++++---- R/print.Score.R | 10 ++++++---- R/riskRegression-package.R | 2 +- slowtests/test-score-crossval.R | 12 ++++++++++-- tests/testthat/test-score.R | 5 +++-- 5 files changed, 24 insertions(+), 13 deletions(-) diff --git a/R/crossvalPerf.loob.AUC.R b/R/crossvalPerf.loob.AUC.R index 4d91644..afc1b4d 100644 --- 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 index 8ea33e4..442e964 100644 --- 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 index 6b16a6a..ef11c8f 100644 --- 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 index 886df60..ecd14ae 100644 --- 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 index d5e3680..9f6a5bf 100644 --- 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)