version 3.7-0

Author: Terry M Therneau

DESCRIPTION

@@ -1,8 +1,8 @@
 Title: Survival Analysis
 Priority: recommended
 Package: survival
-Version: 3.6-4
-Date: 2024-04-22
+Version: 3.7-0
+Date: 2024-06-01
 Depends: R (>= 3.5.0)
 Imports: graphics, Matrix, methods, splines, stats, utils
 LazyData: Yes
@@ -22,12 +22,12 @@ Description: Contains the core survival analysis routines, including
 License: LGPL (>= 2)
 URL: https://github.com/therneau/survival
 NeedsCompilation: yes
-Packaged: 2024-04-22 14:02:15 UTC; therneau
+Packaged: 2024-06-03 15:17:04 UTC; therneau
 Author: Terry M Therneau [aut, cre],
   Thomas Lumley [ctb, trl] (original S->R port and R maintainer until
     2009),
   Atkinson Elizabeth [ctb],
   Crowson Cynthia [ctb]
 Maintainer: Terry M Therneau <therneau.terry@mayo.edu>
 Repository: CRAN
-Date/Publication: 2024-04-24 06:50:02 UTC
+Date/Publication: 2024-06-05 16:30:02 UTC

MD5

@@ -68,15 +68,11 @@ S3method(as.character, Surv)
 S3method(as.character, Surv2)
 S3method(as.data.frame, Surv)
 S3method(as.data.frame, Surv2)
-S3method(as.integer, Surv)
-S3method(as.integer, Surv2)
 S3method(as.logical, Surv)
 S3method(as.logical, Surv2)
 S3method(as.matrix, ratetable)
 S3method(as.matrix, Surv)
 S3method(as.matrix, Surv2)
-S3method(as.numeric, Surv)
-S3method(as.numeric, Surv2)
 S3method(attrassign, default)
 S3method(attrassign, lm)
 S3method(barplot, Surv)

NAMESPACE

@@ -410,18 +410,23 @@ t.Surv <- function(x) t(as.matrix(x))
 
 as.logical.Surv <- function(x, ...)
     stop("invalid operation on a survival time")
-as.integer.Surv <- function(x, ...) {
-    nc <- ncol(x)
-    x[,-nc] <- as.integer(x[,-nc])
-    if (nc==3 && any(x[,1] >= x[,2]))
-        stop("invalid survival time created")
-    x
-}
-as.numeric.Surv <- function(x, ...) {
-    nc <- ncol(x)
-    x[,-nc] <- as.numeric(x[, -nc])
-    x
-}
+
+# removed 2024-06-02, make Surv act like a matrix for this op
+#as.integer.Surv <- function(x, ...) {
+#    nc <- ncol(x)
+#    x[,-nc] <- as.integer(x[,-nc])
+#    if (nc==3 && any(x[,1] >= x[,2]))
+#        stop("invalid survival time created")
+#    x
+#}
+
+# per the help file for as.numeric, this should have been as.double
+#  so never worked anyway
+#as.numeric.Surv <- function(x, ...) {
+#    nc <- ncol(x)
+#    x[,-nc] <- as.numeric(x[, -nc])
+#    x
+#}
 
 mean.Surv <-function(x, ...)
     stop("a mean method has not been defined for Surv objects")

R/Surv.R

@@ -202,14 +202,6 @@ t.Surv2 <- function(x) t(as.matrix(x))
 
 as.logical.Surv2 <- function(x, ...)
     stop("invalid operation on a survival time")
-as.integer.Surv2 <- function(x, ...) {
-    x[,1] <- as.integer(x[,1])
-    x
-}
-as.numeric.Surv2 <- function(x, ...) {
-    x[,1] <- as.numeric(x[,1])
-    x
-}
 
 mean.Surv2 <-function(x, ...)
     stop("a mean method has not been defined for Surv2 objects")

R/Surv2.R

@@ -244,7 +244,7 @@ concordancefit <- function(y, x, strata, weights, ymin=NULL, ymax=NULL,
             } else {
                 sort.stop  <- order(-y[,2], y[,3], risk) -1L   #order by endpoint
                 sort.start <- order(-y[,1]) -1L       
-                gfit <- .Call(Cfastkm2, y, wts, sort.stop, sort.start)
+                gfit <- .Call(Cfastkm2, y, wts, sort.start, sort.stop)
             }
             etime <- gfit$etime
         }

R/concordance.R

@@ -136,6 +136,7 @@ coxph <- function(formula, data, weights, subset, na.action,
         istate <- model.extract(mf, "istate")
     }
     if (n==0) stop("No (non-missing) observations")
+    if (length(id) >0) n.id <- length(unique(id))
 
     type <- attr(Y, "type")
     multi <- FALSE
@@ -588,6 +589,7 @@ coxph <- function(formula, data, weights, subset, na.action,
         }
         fit$n <- data.n
         fit$nevent <- sum(Y[,ncol(Y)])
+        if (length(id)>0) fit$n.id <- n.id
         fit$terms <- Terms
         fit$assign <- assign
         class(fit) <- fit$class

R/coxph.R

@@ -11,9 +11,10 @@ predict.coxph <- function(object, newdata,
     type <-match.arg(type)
     if (type=="survival") {
         survival <- TRUE
-        type <- "expected"  #this is to stop lots of "or" statements
+        type <- "expected"  # survival and expecte have nearly the same code path
     }
     else survival <- FALSE
+    if (type == "expected") reference <- "sample"  # a common ref is easiest
 
     n <- object$n
     Terms <-  object$terms
@@ -162,8 +163,14 @@ predict.coxph <- function(object, newdata,
                 pred <- se <- double(nrow(mf2))
                 newx <- newx - rep(object$means, each=nrow(newx))
                 newrisk <- c(exp(newx %*% object$coef) + newoffset)
+                if (ncol(y) ==3 && survival) { # 
+                    t0 <- unname(min(y[,1]))  # the start of the survival curve
+                    # simpler is all(newy[,1] == t0), but
+                    # use of all.equal allows for roundoff error in newdata
+                    if (!isTRUE(all.equal(as.vector(newy[,1]), rep(t0, nrow(newy)))))
+                        stop("predicted survival must be from the start of the curve")
                 }
-
+            }
             survtype<- ifelse(object$method=='efron', 3,2)
             for (i in ustrata) {
                 indx <- which(oldstrat == i)
@@ -173,66 +180,60 @@ predict.coxph <- function(object, newdata,
                 afit.n <- length(afit$time)
                 if (missing(newdata)) { 
                     # In this case we need se.fit, nothing else
-                    j1 <- approx(afit$time, 1:afit.n, y[indx,1], method='constant',
-                                 f=0, yleft=0, yright=afit.n)$y
+                    j1 <- findInterval(y[indx,1], afit$time)
                     chaz <- c(0, afit$cumhaz)[j1 +1]
                     varh <- c(0, cumsum(afit$varhaz))[j1 +1]
                     xbar <- rbind(0, afit$xbar)[j1+1,,drop=F]
                     if (ncol(y)==2) {
                         dt <- (chaz * x[indx,]) - xbar
                         se[indx] <- sqrt(varh + rowSums((dt %*% object$var) *dt)) *
                             risk[indx]
-                        }
+                    }
                     else {
-                        j2 <- approx(afit$time, 1:afit.n, y[indx,2], method='constant',
-                                 f=0, yleft=0, yright=afit.n)$y
-                        chaz2 <- c(0, afit$cumhaz)[j2 +1]
-                        varh2 <- c(0, cumsum(afit$varhaz))[j2 +1]
-                        xbar2 <- rbind(0, afit$xbar)[j2+1,,drop=F]
+                        j2 <- findInterval(y[indx,2], afit$time)
+                        chaz2 <- c(0, afit$cumhaz)[j2 +1L]
+                        varh2 <- c(0, cumsum(afit$varhaz))[j2 +1L]
+                        xbar2 <- rbind(0, afit$xbar)[j2+ 1L,,drop=F]
                         dt <- (chaz * x[indx,]) - xbar
                         v1 <- varh +  rowSums((dt %*% object$var) *dt)
                         dt2 <- (chaz2 * x[indx,]) - xbar2
                         v2 <- varh2 + rowSums((dt2 %*% object$var) *dt2)
                         se[indx] <- sqrt(v2-v1)* risk[indx]
-                        }
                     }
+                }
 
                 else {
                     #there is new data
                     use.x <- TRUE
                     indx2 <- which(newstrat == i)
-                    j1 <- approx(afit$time, 1:afit.n, newy[indx2,1], 
-                                 method='constant', f=0, yleft=0, yright=afit.n)$y
+                    j1 <- findInterval(newy[indx2,1], afit$time)
                     chaz <-c(0, afit$cumhaz)[j1+1]
                     pred[indx2] <- chaz * newrisk[indx2]
                     if (se.fit) {
                         varh <- c(0, cumsum(afit$varhaz))[j1+1]
                         xbar <- rbind(0, afit$xbar)[j1+1,,drop=F]
-                        }
+                    }
                     if (ncol(y)==2) {
                         if (se.fit) {
                             dt <- (chaz * newx[indx2,]) - xbar
                             se[indx2] <- sqrt(varh + rowSums((dt %*% object$var) *dt)) *
                                 newrisk[indx2]
-                            }
                         }
+                    }
                     else {
-                        j2 <- approx(afit$time, 1:afit.n, newy[indx2,2], 
-                                 method='constant', f=0, yleft=0, yright=afit.n)$y
-                                    chaz2 <- approx(-afit$time, afit$cumhaz, -newy[indx2,2],
-                                   method="constant", rule=2, f=0)$y
-                        chaz2 <-c(0, afit$cumhaz)[j2+1]
+                        j2 <- findInterval(newy[indx2,2], afit$time)
+                        chaz2 <-c(0, afit$cumhaz)[j2+1L]
                         pred[indx2] <- (chaz2 - chaz) * newrisk[indx2]
-                    
+
                         if (se.fit) {
-                            varh2 <- c(0, cumsum(afit$varhaz))[j1+1]
-                            xbar2 <- rbind(0, afit$xbar)[j1+1,,drop=F]
+                            varh2 <- c(0, cumsum(afit$varhaz))[j2 +1L]
+                            xbar2 <- rbind(0, afit$xbar)[j2 + 1L,,drop=F]
                             dt <- (chaz * newx[indx2,]) - xbar
                             dt2 <- (chaz2 * newx[indx2,]) - xbar2
 
                             v2 <- varh2 + rowSums((dt2 %*% object$var) *dt2)
                             v1 <- varh +  rowSums((dt %*% object$var) *dt)
-                            se[indx2] <- sqrt(v2-v1)* risk[indx2]
+                            se[indx2] <- sqrt(v2-v1)* newrisk[indx2]
                             }
                         }
                     }

R/predict.coxph.R

@@ -79,6 +79,7 @@ print.coxph <-
         "\n",  sep="")
     omit <- x$na.action
     cat("n=", x$n)
+    if (!is.null(x$n.id)) cat(", unique id=", x$n.id)
     if (!is.null(x$nevent)) cat(", number of events=", x$nevent, "\n")
     else cat("\n")
     if (length(omit))

R/print.coxph.R

@@ -20,7 +20,7 @@ print.summary.coxph <-
     if (length(omit))
 	cat("   (", naprint(omit), ")\n", sep="")
 
-    if (nrow(x$coef)==0) {   # Null model
+    if (nrow(x$coefficients)==0) {   # Null model
 	cat ("   Null model\n")
 	return()
         }