Skip to content
Permalink
Browse files
Large set of changes while traveling/testing
  • Loading branch information
Terry Therneau committed Jul 22, 2019
1 parent 6ef3b6a commit 5da455de4f16fbed7f867b1fc5b15f2157a132cd
Show file tree
Hide file tree
Showing 18 changed files with 540 additions and 180 deletions.

This file was deleted.

@@ -1,7 +1,7 @@
#
# Reconstruct the Cox model data. This is done in so many routines
# that I extracted it out.
# Newer routines use model.matrix.coxph and model.frame.coxph methods.
# Reconstruct the Cox model data. This is done in many routines.
# Users use model.matrix.coxph and model.frame.coxph methods, but they
# do not extract strata or offset.
#
# The "stratax" name is to avoid conflicts with the strata() function, but
# still allow users to type "strata" as an arg.
@@ -12,7 +12,7 @@ coxph.getdata <- function(fit, y=TRUE, x=TRUE, stratax=TRUE, offset=FALSE) {
strat <- fit$strata
Terms <- fit$terms
if (is.null(attr(Terms, 'offset'))) offset <- FALSE
if (offset) x<- TRUE
if (offset) x<- TRUE # can't grab offset without x
if (!inherits(Terms, 'terms'))
stop("invalid terms component of fit")
strats <- attr(Terms, "specials")$strata
@@ -21,22 +21,50 @@ coxph.getdata <- function(fit, y=TRUE, x=TRUE, stratax=TRUE, offset=FALSE) {
if ( (y && is.null(ty)) || (x && is.null(tx)) ||
(stratax && is.null(strat)) || offset) {
# get the model frame
m <- stats::model.frame(fit)
mf <- stats::model.frame(fit)

# Pull things out
if (y && is.null(ty)) ty <- model.extract(m, 'response')
if (y && is.null(ty)) ty <- model.extract(mf, 'response')

if (offset) toff <- model.extract(m, 'offset')
if (offset) toff <- model.extract(mf, 'offset')

# strata was saved in the fit if and only if x was
if ((x || stratax) && is.null(tx)) {
if (stratax) {
temp <- untangle.specials(Terms, 'strata', 1)
strat <- strata(m[temp$vars], shortlabel=T)
strat <- strata(mf[temp$vars], shortlabel=T)
}
if (x) tx <- model.matrix(fit, data=m)
}
tx <- model.matrix.coxph(fit, data=mf)
}

if (inherits(fit, "coxphms")) {
# Expand the x matrix. First recreate istate
id <- model.extract(mf, "id")
istate <- model.extract(mf, "istate")
check <- survcheck2(ty, id, istate)

# Now expand the data
xstack <- stacker(fit$cmap, check$istate, tx, ty,
as.integer(strata), check$states)
tx <- xstack$X
ty <- xstack$Y
strat <- xstack$strata
stratax <- TRUE
if (offset) toff <- offset[xstack$rindex]

# And last, toss missing values, which had been deferred
ismiss <- is.nan(ty) | apply(is.na(tx), 1, any)
if (offset) {
ismiss <- ismiss | is.nan(offset)
offset <- offset[imiss]
}
if (any(ismiss)) {
if (y) ty<- ty[!ismiss]
tx <- tx[!ismiss,,drop=FALSE]
strat <- strat[!ismiss]
}
}
}
else if (offset)
toff <- fit$linear.predictors -(c(tx %*% fit$coef) -
sum(fit$means*fit$coef))
@@ -76,7 +76,8 @@ survobrien <- function(formula, data, subset,
indx <- lapply(etime, function(x) which(y[,1]<x & y[,2] >= x))
}
else {
temp <- unique(data.frame(y[,2], strata.keep)[y[,3]==1,])
temp <- unique(data.frame(y[,2], strata.keep,
stringsAsFactors=FALSE)[y[,3]==1,])
etime <- temp[,1]
indx <- lapply(1:nrow(temp), function(x)
which(y[,1] < temp[x,1] & y[,2]>= temp[x,1] &
@@ -91,7 +92,8 @@ survobrien <- function(formula, data, subset,
indx <- lapply(etime, function(x) which(y[,1] >=x))
}
else {
temp <- unique(data.frame(y[,1], strata.keep)[y[,2]==1,])
temp <- unique(data.frame(y[,1], strata.keep,
stringsAsFactors=FALSE)[y[,2]==1,])
etime <- temp[,1]
indx <- lapply(1:nrow(temp), function(x)
which(y[,2] >= temp[x,1] & strata.keep == temp[x,2]))
7 inst/NEWS.Rd 100755 → 100644
@@ -1,5 +1,10 @@
\name{NEWS}
\title{NEWS file for the survival package}
\section{Changes in version 3.0-9}{
\itemize{
\item Make sure all calls to data.frame explicitly select a value
for the stringsAsFactors option.
}}
\section{Changes in version 3.0}{
\itemize{
\item Major revision of the survfit routines, see the survival vignette.
@@ -10,7 +15,7 @@
\item Subscripting survfit object removes the na.action. This is a
loss in the sense that the printout no longer tells us that
observations were removed, but the information about which and how
many were removed was incorrect after the selection.
many rows were removed was incorrect after the selection.
\item The survexp function, applied to a coxph model with strata,
would sometimes produce extraneous y=0 values at the start of a
curve.
@@ -21,6 +21,7 @@ PARTS = main.Rnw \
statefig.Rnw\
tmerge.Rnw\
yates.Rnw yates2.Rnw\
zph.Rnw \
tail
# coxdetail.nw

@@ -46,7 +47,8 @@ SFUN = agreg.fit.R \
survfit.coxphms.R \
survfitms.R\
tmerge.R \
yates.R
yates.R \
cox.zph.R

CFUN = agfit4.c \
agsurv4.c agsurv5.c \
@@ -1003,6 +1003,7 @@ if (multi) {
fit$states <- states
fit$cmap <- cmap
fit$resid <- rowsum(fit$resid, xstack$rindex)
if (x) fit$strata <- istrat # save the expanded strata
class(fit) <- c("coxphms", class(fit))
}

@@ -426,7 +426,7 @@ if (is.vector(newdata, "numeric")) {
if (is.null(names(newdata))) {
stop("Newdata argument must be a data frame")
}
newdata <- data.frame(as.list(newdata))
newdata <- data.frame(as.list(newdata), stringsAsFactors=FALSE)
}
@

@@ -190,7 +190,7 @@ and the transitions count.
<<parsecovar>>=
parsecovar2 <- function(covar1, statedata, dformula, Terms, transitions,states) {
if (is.null(statedata))
statedata <- data.frame(state = states)
statedata <- data.frame(state = states, stringsAsFactors=FALSE)
else {
if (is.null(statedata$state))
stop("the statedata data set must contain a variable 'state'")
@@ -75,7 +75,7 @@ dim.survfit <- function(x) {
d1name <- "strata"
d2name <- "data"
d3name <- "states"
if (is.null(x$strata)) d1<- 1 else d1 <- length(x$strata)
if (is.null(x$strata)) {d1<- d1name <- NULL} else d1 <- length(x$strata)
if (is.null(x$newdata)) {d2 <- d2name <- NULL} else d2 <- nrow(x$newdata)
if (is.null(x$states)) {d3 <- d3name <- NULL} else d3 <- length(x$states)

@@ -88,7 +88,7 @@ dim.survfit <- function(x) {

dd <- c(d1, d2, d3)
names(dd) <- c(d1name, d2name, d3name)
dd
if (is.null(dd)) 1 else dd
}

# there is a separate function for survfitms objects
@@ -298,7 +298,7 @@ for (ii in seq(along.with=args)) {
stop("argument ", argname[ii], " is not the same length as id")
if (!is.null(argi$value)) {
if (length(argi$value) != length(saveid))
stop("argument", argname[ii], "is not the same length as id")
stop("argument ", argname[ii], " is not the same length as id")
if (topt$na.rm) keep <- !(is.na(etime) | is.na(argi$value))
else keep <- !is.na(etime)
if (!all(keep)) {
@@ -156,11 +156,11 @@ cmatrix <- function(fit, term,
} else dimnames(levels)[[2]] <- parts
if (any(duplicated(levels)))
stop("levels matrix has duplicated rows")
levels <- data.frame(levels)
levels <- data.frame(levels, stringsAsFactors=FALSE)
}
else if (length(parts) > 1)
stop("levels should be a data frame or matrix")
else levels <- data.frame(x=unique(levels))
else levels <- data.frame(x=unique(levels), stringsAsFactors=FALSE)
names(levels) <- user.name
}

0 comments on commit 5da455d

Please sign in to comment.