Skip to content

Commit

Permalink
Revert "code style + documentation updates"
Browse files Browse the repository at this point in the history 
This reverts commit ace4c0a.
  • Loading branch information
David Benkeser committed Jul 26, 2017
1 parent ace4c0a commit 62460f1
Show file tree
Hide file tree
Showing 21 changed files with 190 additions and 247 deletions.
12 changes: 5 additions & 7 deletions R/checkInputs.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,7 @@
#' default this is set to \code{max(ftime)}.
#' @param SL.ftime A character vector or list specification to be passed to the
#' \code{SL.library} argument in the call to \code{SuperLearner} for the
#' outcome regression, either cause-specific hazards or conditional mean.
#' outcome regression (either cause-specific hazards or conditional mean).
#' See \code{?SuperLearner} for more information on how to specify valid
#' \code{SuperLearner} libraries. It is expected that the wrappers used
#' in the library will play nicely with the input variables, which will
Expand All @@ -36,8 +36,8 @@
#' variables, which will be \code{names(adjustVars)}.
#' @param glm.ftime A character specification of the right-hand side of the
#' equation passed to the \code{formula} option of a call to \code{glm}
#' for the outcome regression, either cause-specific hazards or
#' conditional mean. Ignored if \code{SL.ftime != NULL}. Use \code{"trt"}
#' for the outcome regression (either cause-specific hazards or
#' conditional mean). Ignored if \code{SL.ftime != NULL}. Use \code{"trt"}
#' to specify the treatment in this formula (see examples). The formula
#' can additionally include any variables found in
#' \code{names(adjustVars)}.
Expand Down Expand Up @@ -300,8 +300,7 @@ checkInputs <- function(ftime,
}
# check that one of glm.ftime or SL.ftime is specified
if(is.null(glm.ftime) & is.null(SL.ftime)) {
warning("glm.ftime and SL.ftime not specified. Computing empirical
estimates.")
warning("glm.ftime and SL.ftime not specified. Computing empirical estimates.")
if(method == "hazard") {
glm.ftime <- paste0("-1 + ", paste0("I(t == ", unique(ftime[ftype > 0]),
")", collapse = "+"), "+",
Expand Down Expand Up @@ -343,8 +342,7 @@ checkInputs <- function(ftime,
adjustVars <- data.frame(dummy = rep(1,length(ftime)))
} else {
if(all(apply(adjustVars, 2, function(x){length(unique(x)) == 1}))) {
warning("Columns of adjustVars are constantly valued. Computing unadjusted
estimates.")
warning("Columns of adjustVars are constantly valued. Computing unadjusted estimates.")
if(is.null(glm.trt)) {
glm.trt <- "1"
}
Expand Down
21 changes: 10 additions & 11 deletions R/estimateCensoring.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,15 +24,15 @@
#' \code{t == t0} is different than if \code{t != t0}.
#' @param SL.ctime A character vector or list specification to be passed to the
#' \code{SL.library} argument in the call to \code{SuperLearner} for the
#' outcome regression, either cause-specific hazards or conditional mean.
#' See \code{?SuperLearner} for more information on how to specify valid
#' outcome regression (either cause-specific hazards or conditional mean).
#' See \code{?SuperLearner} for more information on how to specify valid
#' \code{SuperLearner} libraries. It is expected that the wrappers used
#' in the library will play nicely with the input variables, which will
#' be called \code{"trt"} and \code{names(adjustVars)}.
#' @param glm.ctime A character specification of the right-hand side of the
#' equation passed to the \code{formula} option of a call to \code{glm}
#' for the outcome regression, either cause-specific hazards or
#' conditional mean. Ignored if \code{SL.ctime != NULL}. Use \code{"trt"}
#' for the outcome regression (either cause-specific hazards or
#' conditional mean). Ignored if \code{SL.ctime != NULL}. Use \code{"trt"}
#' to specify the treatment in this formula (see examples). The formula
#' can additionally include any variables found in
#' \code{names(adjustVars)}.
Expand Down Expand Up @@ -77,7 +77,7 @@ estimateCensoring <- function(dataList,
if(!all(dataList[[1]]$C == 0)) {
ctimeForm <- sprintf("%s ~ %s", "C", glm.ctime)
ctimeMod <- glm(as.formula(ctimeForm),
data = dataList[[1]][include, ],
data = dataList[[1]][include,],
family = "binomial")
ctimeMod <- cleanglm(ctimeMod)
} else {
Expand All @@ -94,14 +94,14 @@ estimateCensoring <- function(dataList,
# get predictions from ctimeMod
if(all(class(ctimeMod) != "noCens")) {
dataList <- lapply(dataList, function(x) {
g_dC <- rep(1, length(x[, 1]))
g_dC <- rep(1, length(x[,1]))
if(t0 != 1) {
# temporarily replace time with t-1
# NOTE: this will fail if t enters model as a factor
x$t <- x$t - 1

suppressWarnings(
g_dC <- 1 - predict(ctimeMod, newdata = x, type = "response")
g_dC <- 1-predict(ctimeMod, newdata = x, type = "response")
)

# put time back to normal
Expand All @@ -120,12 +120,11 @@ estimateCensoring <- function(dataList,
})
}
} else {
if(class(SL.ctime) != "SuperLearner") {
if(class(SL.ctime) != "SuperLearner"){
if(!all(dataList[[1]]$C == 0)){
ctimeMod <- SuperLearner(Y = dataList[[1]]$C[include],
X = dataList[[1]][include,
c("t", "trt",
names(adjustVars))],
X = dataList[[1]][include,c("t", "trt",
names(adjustVars))],
id = dataList[[1]]$id[include],
family = "binomial",
SL.library = SL.ctime,
Expand Down
87 changes: 36 additions & 51 deletions R/estimateHazards.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,15 +29,15 @@
#' variables to adjust for in the regression.
#' @param SL.ftime A character vector or list specification to be passed to the
#' \code{SL.library} argument in the call to \code{SuperLearner} for the
#' outcome regression, either cause-specific hazards or conditional mean.
#' outcome regression (either cause-specific hazards or conditional mean).
#' See \code{?SuperLearner} for more information on how to specify valid
#' \code{SuperLearner} libraries. It is expected that the wrappers used
#' in the library will play nicely with the input variables, which will
#' be called \code{"trt"} and \code{names(adjustVars)}.
#' @param glm.ftime A character specification of the right-hand side of the
#' equation passed to the \code{formula} option of a call to \code{glm}
#' for the outcome regression, either cause-specific hazards or
#' conditional mean. Ignored if \code{SL.ftime != NULL}. Use \code{"trt"}
#' for the outcome regression (either cause-specific hazards or
#' conditional mean). Ignored if \code{SL.ftime != NULL}. Use \code{"trt"}
#' to specify the treatment in this formula (see examples). The formula
#' can additionally include any variables found in
#' \code{names(adjustVars)}.
Expand Down Expand Up @@ -74,10 +74,10 @@ estimateHazards <- function(dataList, J, adjustVars,
# formula
Qj.form <- sprintf("%s ~ %s", paste("N", j, sep = ""), glm.ftime)

# sum all events less than current j to see who to include in regression
# add up all events less than current j to see who to include in regression
NlessthanJ <- rep(0, nrow(dataList[[1]]))
for(i in J[J < j]) {
NlessthanJ <- NlessthanJ + dataList[[1]][[paste0("N", i)]]
NlessthanJ <- NlessthanJ + dataList[[1]][[paste0("N",i)]]
}

# fit GLM
Expand All @@ -94,20 +94,16 @@ estimateHazards <- function(dataList, J, adjustVars,
# get predictions back
dataList <- lapply(dataList, function(x, j) {
suppressWarnings(
x[[paste0("Q",j,"PseudoHaz")]] <- predict(Qj.mod, type = "response",
newdata = x)
x[[paste0("Q",j,"PseudoHaz")]] <- predict(Qj.mod, type = 'response', newdata = x)
)
if(j != min(J)) {
x[[paste0("hazLessThan", j)]] <- rowSums(cbind(rep(0, nrow(x)),
x[, paste0('Q',
J[J < j],
"Haz")]))
x[[paste0("Q", j, "Haz")]] <- x[[paste0("Q", j, "PseudoHaz")]] *
(1 - x[[paste0("hazLessThan", j)]])
x[[paste0("hazLessThan",j)]] <- rowSums(cbind(rep(0, nrow(x)),
x[, paste0('Q', J[J < j], 'Haz')]))
x[[paste0("Q",j,"Haz")]] <- x[[paste0("Q",j,"PseudoHaz")]] * (1-x[[paste0("hazLessThan",j)]])

} else {
x[[paste0("hazLessThan", j)]] <- 0
x[[paste0("Q", j, "Haz")]] <- x[[paste0("Q", j, "PseudoHaz")]]
x[[paste0("hazLessThan",j)]] <- 0
x[[paste0("Q",j,"Haz")]] <- x[[paste0("Q",j,"PseudoHaz")]]
}
x
}, j = j)
Expand All @@ -120,32 +116,28 @@ estimateHazards <- function(dataList, J, adjustVars,

NlessthanJ <- rep(0, nrow(dataList[[1]]))
for(i in J[J < j]) {
NlessthanJ <- NlessthanJ + dataList[[1]][[paste0("N", i)]]
NlessthanJ <- NlessthanJ + dataList[[1]][[paste0("N",i)]]
}

dataList <- lapply(dataList, function(x, j) {
if(j != min(J)) {
x[[paste0("hazLessThan", j)]] <- rowSums(cbind(rep(0, nrow(x)),
x[, paste0("Q",
J[J < j],
"Haz")]))
x[[paste0("hazLessThan",j)]] <- rowSums(cbind(rep(0, nrow(x)),
x[, paste0('Q', J[J < j], 'Haz')]))
} else {
x[[paste0("hazLessThan", j)]] <- 0
x[[paste0("hazLessThan",j)]] <- 0
}
x
}, j = j)
Ytilde <- (dataList[[1]][[paste0("N", j)]] -
dataList[[1]][[paste0("l", j)]]) /
(pmin(dataList[[1]][[paste0("u", j)]], 1 -
dataList[[1]][[paste0("hazLessThan", j)]]) -
dataList[[1]][[paste0("l", j)]])
Ytilde <- (dataList[[1]][[paste0("N",j)]] - dataList[[1]][[paste0("l",j)]])/
(pmin(dataList[[1]][[paste0("u",j)]],1-dataList[[1]][[paste0("hazLessThan",j)]]) -
dataList[[1]][[paste0("l",j)]])

if(class("glm.ftime") != "list") {
Qj.mod <- stats::optim(par = rep(0, ncol(X)), fn = LogLikelihood,
Y = Ytilde, X = X, method = "BFGS", gr = grad,
control = list(reltol = 1e-7, maxit = 50000))
} else {
Qj.mod <- glm.ftime[[paste0("J", j)]]
Qj.mod <- glm.ftime[[paste0("J",j)]]
}
if(Qj.mod$convergence != 0) {
stop("convergence failure")
Expand All @@ -154,14 +146,11 @@ estimateHazards <- function(dataList, J, adjustVars,
eval(parse(text = paste0("ftimeMod$J", j, " <- Qj.mod")))
dataList <- lapply(dataList, function(x, j) {
newX <- stats::model.matrix(stats::as.formula(Qj.form), data = x)
x[[paste0("Q", j, "PseudoHaz")]] <- plogis(newX %*% beta)
x[[paste0("Q", j, "Haz")]] <- (pmin(x[[paste0("u", j)]], 1 -
x[[paste0("hazLessThan", j)]]) -
x[[paste0("l", j)]]) *
x[[paste0("Q", j, "PseudoHaz")]] +
x[[paste0("l", j)]]
x[[paste0("Q",j,"PseudoHaz")]] <- plogis(newX %*% beta)
x[[paste0("Q",j,"Haz")]] <- (pmin(x[[paste0("u",j)]], 1 - x[[paste0("hazLessThan",j)]]) -
x[[paste0("l",j)]])*x[[paste0("Q",j,"PseudoHaz")]] + x[[paste0("l",j)]]
x
}, j = j)
},j = j)
}
}
}
Expand All @@ -170,41 +159,37 @@ estimateHazards <- function(dataList, J, adjustVars,
# add all events less than current j to see who to include in regression
NlessthanJ <- rep(0, nrow(dataList[[1]]))
for (i in J[J < j]) {
NlessthanJ <- NlessthanJ + dataList[[1]][[paste0("N", i)]]
NlessthanJ <- NlessthanJ + dataList[[1]][[paste0("N",i)]]

}

if(class(SL.ftime[[1]]) != "SuperLearner") {
Qj.mod <- SuperLearner(Y = dataList[[1]][[paste0("N",
j)]][NlessthanJ == 0],
Qj.mod <- SuperLearner(Y = dataList[[1]][[paste0("N",j)]][NlessthanJ == 0],
X = dataList[[1]][NlessthanJ == 0,
c("t", "trt",
names(adjustVars))],
c('t', 'trt', names(adjustVars))],
id = dataList[[1]]$id[NlessthanJ == 0],
family = stats::binomial(),
SL.library = SL.ftime,
verbose = verbose)
} else {
Qj.mod <- SL.ftime[[paste0("J", j)]]
Qj.mod <- SL.ftime[[paste0("J",j)]]
}
ftimeMod[[paste0("J", j)]] <- Qj.mod
ftimeMod[[paste0("J",j)]] <- Qj.mod

# get predictions back
dataList <- lapply(dataList, function(x, j){
suppressWarnings(
x[[paste0("Q", j, "PseudoHaz")]] <- predict(Qj.mod, onlySL = TRUE,
newdata = x[, c("t", "trt", names(adjustVars))])[[1]]
x[[paste0("Q",j,"PseudoHaz")]] <- predict(Qj.mod, onlySL = TRUE,
newdata = x[,c('t', 'trt', names(adjustVars))])[[1]]
)
if(j != min(J)) {
x[[paste0("hazLessThan", j)]] <- rowSums(cbind(rep(0, nrow(x)),
x[, paste0("Q",
J[J < j],
"Haz")]))
x[[paste0("Q", j, "Haz")]] <- x[[paste0("Q", j, "PseudoHaz")]] *
(1 - x[[paste0("hazLessThan", j)]])
x[[paste0("hazLessThan",j)]] <- rowSums(cbind(rep(0, nrow(x)),
x[, paste0('Q', J[J < j], 'Haz')]))
x[[paste0("Q",j,"Haz")]] <- x[[paste0("Q",j,"PseudoHaz")]] *
(1 - x[[paste0("hazLessThan",j)]])
} else {
x[[paste0("Q", j, "Haz")]] <- x[[paste0("Q", j, "PseudoHaz")]]
x[[paste0("hazLessThan", j)]] <- 0
x[[paste0("Q",j,"Haz")]] <- x[[paste0("Q",j,"PseudoHaz")]]
x[[paste0("hazLessThan",j)]] <- 0
}
x
}, j = j)
Expand Down
Loading

0 comments on commit 62460f1

Please sign in to comment.