Skip to content

Commit

Permalink
fixed cutpoint option
Browse files Browse the repository at this point in the history
  • Loading branch information
@tagteam
tagteam committed Dec 6, 2024
1 parent 8f2047f commit ba3cd4b
Show file tree
Hide file tree
Showing 4 changed files with 57 additions and 59 deletions.
55 changes: 27 additions & 28 deletions R/AUC.competing.risks.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,9 +3,9 @@
## Author: Thomas Alexander Gerds
## Created: Jan 11 2022 (17:06)
## Version:
## Last-Updated: Jun 25 2024 (09:34)
## Last-Updated: Dec 6 2024 (13:29)
## By: Thomas Alexander Gerds
## Update #: 44
## Update #: 52
#----------------------------------------------------------------------
##
### Commentary:
Expand Down Expand Up @@ -35,6 +35,7 @@ AUC.competing.risks <- function(DT,
cutpoints,
...){
riskRegression_ID=model=times=risk=Cases=riskRegression_time=riskRegression_status=riskRegression_event=Controls1=Controls2=TPR=FPR=WTi=Wt=ipcwControls1=ipcwControls2=ipcwCases=IF.AUC=lower=se=upper=AUC=nth.times=NULL
output = NULL
aucDT <- DT[model>0]
dolist <- dolist[sapply(dolist,function(do){match("0",do,nomatch=0L)})==0]
## assign Weights before ordering
Expand All @@ -59,7 +60,7 @@ AUC.competing.risks <- function(DT,
aucDT[,FPR:=(cumsum(ipcwControls1)+cumsum(ipcwControls2))/(sum(ipcwControls2)+sum(ipcwControls1)),by=list(model,times)]
nodups <- aucDT[,c(!duplicated(risk)[-1],TRUE),by=list(model,times)]$V1
if (!is.null(cutpoints)){
breaks <- sort(cutpoints,decreasing = TRUE)
## breaks <- sort(cutpoints,decreasing = TRUE)
aucDT[,nth.times:=as.numeric(factor(times))]
cutpoint.helper.fun <- function(FPR,
TPR,
Expand Down Expand Up @@ -119,7 +120,7 @@ AUC.competing.risks <- function(DT,
TPRi <- FPRi <- 0
SE.TPR <- SE.FPR <- NA
}
if (den_PPV > 1e-10){
if (den_PPV > 0){
PPV <- (TPRi*den_TPR)/den_PPV
if (se.fit){
IC0.PPV <- (risk > cutpoints[i])/den_PPV*(((ipcwCases+ipcwControls2)*N)*(1*(riskRegression_event==1)-1*(riskRegression_event!=0)*PPV)-ipcwControls1*N*PPV) #OBS, check other causes, paul's implementation
Expand All @@ -138,9 +139,9 @@ AUC.competing.risks <- function(DT,
}
}
else {
PPV <- NA
PPV <- SE.PPV <- NA
}
if (den_NPV > 1e-10){
if (den_NPV > 0){
NPV <- ((1-FPRi)*den_FPR)/den_NPV
if (se.fit){
IC0.NPV <- (risk <= cutpoints[i])/den_NPV*(((ipcwCases+ipcwControls2)*N)*(1*(riskRegression_event!=1 & riskRegression_event!=0)-1*(riskRegression_event!=0)*NPV)+ipcwControls1*N*(1-NPV)) #OBS, check other causes, paul's implementation
Expand All @@ -159,7 +160,7 @@ AUC.competing.risks <- function(DT,
}
}
else {
NPV <- NA
NPV <- SE.NPV <- NA
}
res[[i]] <- data.table(risk = cutpoints[i],
TPR=TPRi,
Expand All @@ -173,37 +174,35 @@ AUC.competing.risks <- function(DT,
}
do.call("rbind",res)
}
output <- list(cutpoints=aucDT[, cutpoint.helper.fun(FPR = FPR,
TPR = TPR,
risk = risk,
ipcwCases = ipcwCases,
ipcwControls1 = ipcwControls1,
ipcwControls2 = ipcwControls2,
N = N,
riskRegression_time = riskRegression_time,
times = times[1],
riskRegression_event = riskRegression_status*riskRegression_event,
cens.model = cens.model,
nth.times = nth.times[1],
conservative = conservative,
IC.G = MC,
cutpoints = cutpoints,
se.fit = se.fit),by=list(model,times)])
output <- c(output,list(cutpoints=aucDT[, cutpoint.helper.fun(FPR = FPR,
TPR = TPR,
risk = risk,
ipcwCases = ipcwCases,
ipcwControls1 = ipcwControls1,
ipcwControls2 = ipcwControls2,
N = N,
riskRegression_time = riskRegression_time,
times = times[1],
riskRegression_event = riskRegression_status*riskRegression_event,
cens.model = cens.model,
nth.times = nth.times[1],
conservative = conservative,
IC.G = MC,
cutpoints = sort(cutpoints,decreasing = TRUE),
se.fit = se.fit),by=list(model,times)]))
}
else if (ROC) {
if (ROC[[1]] == TRUE) {
if (is.null(breaks)){
output <- list(ROC=aucDT[nodups,c("model","times","risk","TPR","FPR"),with=FALSE])
output <- c(output,list(ROC=aucDT[nodups,c("model","times","risk","TPR","FPR"),with=FALSE]))
}
else {
breaks <- sort(breaks,decreasing = TRUE)
helper.fun <- function(FPR,TPR,risk, breaks){
indeces <- sindex(risk,breaks,comp = "greater",FALSE)
data.table(risk = breaks, TPR = c(rep(0,sum(indeces==0)),TPR[indeces[indeces!=0]]), FPR = c(rep(0,sum(indeces==0)),FPR[indeces[indeces!=0]]))
}
output <- list(ROC=aucDT[, helper.fun(FPR,TPR,risk,breaks=breaks),by=list(model,times)])
output <- c(output,list(ROC=aucDT[, helper.fun(FPR,TPR,risk,breaks=breaks),by=list(model,times)]))
}
}else{
output <- NULL
}
AireTrap <- function(FP,TP,N){
N <- length(FP)
Expand Down
55 changes: 27 additions & 28 deletions R/AUC.survival.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,9 +3,9 @@
## Author: Thomas Alexander Gerds
## Created: Jan 11 2022 (17:06)
## Version:
## Last-Updated: Jun 25 2024 (09:47)
## Last-Updated: Dec 6 2024 (13:29)
## By: Thomas Alexander Gerds
## Update #: 52
## Update #: 55
#----------------------------------------------------------------------
##
### Commentary:
Expand All @@ -32,6 +32,7 @@ AUC.survival <- function(DT,
cutpoints,
...){
riskRegression_ID=model=times=risk=Cases=riskRegression_time=riskRegression_status=Controls=TPR=FPR=WTi=Wt=ipcwControls=ipcwCases=IF.AUC=lower=se=upper=AUC=nth.times=NULL
output = NULL
cause <- 1
aucDT <- DT[model>0]
## remove null model comparisons
Expand All @@ -57,7 +58,7 @@ AUC.survival <- function(DT,
}
score <- aucDT[nodups,list(AUC=AireTrap(FPR,TPR)),by=list(model,times)]
if (!is.null(cutpoints)){
breaks <- sort(cutpoints,decreasing = TRUE)
## breaks <- sort(cutpoints,decreasing = TRUE)
aucDT[,nth.times:=as.numeric(factor(times))]
cutpoint.helper.fun <- function(FPR,
TPR,
Expand Down Expand Up @@ -113,7 +114,7 @@ AUC.survival <- function(DT,
else {
TPRi <- FPRi <- 0
}
if (den_PPV > 1e-10){
if (den_PPV > 0){
PPV <- (TPRi*den_TPR)/den_PPV
if (se.fit){
#OBS, check other causes, paul's implementation
Expand All @@ -130,9 +131,9 @@ AUC.survival <- function(DT,
}
}
else {
PPV <- NA
PPV <- SE.PPV <- NA
}
if (den_NPV > 1e-10){
if (den_NPV > 0){
NPV <- ((1-FPRi)*den_FPR)/den_NPV
if (se.fit){
IC0.NPV <- (risk <= cutpoints[i])/den_NPV*(((ipcwCases)*N)*(1*(riskRegression_event!=1 & riskRegression_event!=0)-1*(riskRegression_event!=0)*NPV)+ipcwControls*N*(1-NPV)) #OBS, check other causes, paul's implementation
Expand All @@ -148,7 +149,7 @@ AUC.survival <- function(DT,
}
}
else {
NPV <- NA
NPV <- SE.NPV <- NA
}
res[[i]] <- data.table(risk = cutpoints[i],
TPR=TPRi,
Expand All @@ -162,37 +163,35 @@ AUC.survival <- function(DT,
}
do.call("rbind",res)
}
output <- list(cutpoints=aucDT[,
cutpoint.helper.fun(FPR = FPR,
TPR = TPR,
risk = risk,
ipcwCases = ipcwCases,
ipcwControls = ipcwControls,
N = N,
riskRegression_time = riskRegression_time,
times = times[1],
riskRegression_event = riskRegression_status,
cens.model = cens.model,
nth.times = nth.times[1],
conservative = conservative,
IC.G = MC,
cutpoints = cutpoints,
se.fit = se.fit),by=list(model,times)])
output <- c(output,list(cutpoints=aucDT[,
cutpoint.helper.fun(FPR = FPR,
TPR = TPR,
risk = risk,
ipcwCases = ipcwCases,
ipcwControls = ipcwControls,
N = N,
riskRegression_time = riskRegression_time,
times = times[1],
riskRegression_event = riskRegression_status,
cens.model = cens.model,
nth.times = nth.times[1],
conservative = conservative,
IC.G = MC,
cutpoints = sort(cutpoints,decreasing = TRUE),
se.fit = se.fit),by=list(model,times)]))
}
else if (ROC==TRUE) {
if (ROC[[1]]==TRUE) {
if (is.null(breaks)){
output <- list(ROC=aucDT[nodups,c("model","times","risk","TPR","FPR"),with=FALSE])
output <- c(output,list(ROC=aucDT[nodups,c("model","times","risk","TPR","FPR"),with=FALSE]))
}
else {
breaks <- sort(breaks,decreasing = TRUE)
helper.fun <- function(FPR,TPR,risk, breaks){
indeces <- sindex(risk,breaks,comp = "greater",FALSE)
data.table(risk = breaks, TPR = c(rep(0,sum(indeces==0)),TPR[indeces[indeces!=0]]), FPR = c(rep(0,sum(indeces==0)),FPR[indeces[indeces!=0]]))
}
output <- list(ROC=aucDT[, helper.fun(FPR,TPR,risk,breaks=breaks),by=list(model,times)])
output <- c(output,list(ROC=aucDT[, helper.fun(FPR,TPR,risk,breaks=breaks),by=list(model,times)]))
}
}else{
output <- NULL
}
aucDT <- merge(score,aucDT,by = c("model","times"),all=TRUE)
data.table::setkey(aucDT,model,times)
Expand Down
4 changes: 2 additions & 2 deletions R/computePerformance.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,9 +3,9 @@
## Author: Thomas Alexander Gerds
## Created: Feb 27 2022 (09:12)
## Version:
## Last-Updated: Jun 17 2024 (10:15)
## Last-Updated: Dec 6 2024 (12:58)
## By: Thomas Alexander Gerds
## Update #: 24
## Update #: 26
#----------------------------------------------------------------------
##
### Commentary:
Expand Down
2 changes: 1 addition & 1 deletion R/predict.FGR.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -48,7 +48,7 @@ predict.FGR <- function(object,newdata,times,...){
args <- list(object=object$crrFit,cov1=cov1,cov2=cov2,...)
args <- args[!sapply(args,is.null)]
## warning("uuu")
print(colnames(args$cov1))
## print(colnames(args$cov1))
pred <- do.call(cmprsk::predict.crr,args)
## warning("bbb")
out <- pred[,-1,drop=FALSE]
Expand Down

0 comments on commit ba3cd4b

Please sign in to comment.