R/survConcordance.fit.R

Defines functions survConcordance.fit

Documented in survConcordance.fit

# Replaced by concordance.R.  This code is now frozen and will be deprecated
survConcordance.fit <- function(y, x, strata, weight) { 
    .Deprecated("concordancefit")
    # The coxph program may occassionally fail, and this will kill the C
    #  routine below
    if (any(is.na(x)) || any(is.na(y))) return(NULL)   
    btree <- function(n) {
        ranks <- rep(0L, n)  #will be overwritten
        yet.to.do <- 1:n
        depth <- floor(logb(n,2))
        start <- as.integer(2^depth)
        lastrow.length <- 1+n-start
        indx <- seq(1L, by=2L, length= lastrow.length)
        ranks[yet.to.do[indx]] <- start + 0:(length(indx)-1L)
        yet.to.do <- yet.to.do[-indx]

        while (start >1) {
            start <- as.integer(start/2)
            indx <- seq(1L, by=2L, length=start)
            ranks[yet.to.do[indx]] <- start + 0:(start-1L)
            yet.to.do <- yet.to.do[-indx]
        }
        ranks
    }
        
    docount <- function(stime, risk, wts) {
        if (attr(stime, 'type') == 'right') {
            ord <- order(stime[,1], -stime[,2])
            ux <- sort(unique(risk))
            n2 <- length(ux)
            index <- btree(n2)[match(risk[ord], ux)] - 1L
             .Call(Cconcordance1, stime[ord,], 
                   as.double(wts[ord]), 
                   as.integer(index), 
                   as.integer(length(ux)))
        }
        else if (attr(stime, 'type') == "counting") {
            sort.stop <- order(-stime[,2], stime[,3])
            sort.start <- order(-stime[,1])
            ux <- sort(unique(risk))
            n2 <- length(ux)
            index <- btree(n2)[match(risk, ux)] - 1L

            .Call(Cconcordance2, stime, 
                  as.double(wts), 
                  as.integer(index), 
                  as.integer(length(ux)),
                  as.integer(sort.stop-1L), 
                  as.integer(sort.start-1L))
        }
        else stop("Invalid survival type for concordance")
    }
        
    if (missing(weight) || length(weight)==0)
        weight <- rep(1.0, length(x))
    storage.mode(y) <- "double"
    
    if (missing(strata) || length(strata)==0) {
        count <- docount(y, x, weight)
        if (count[1]==0 && count[2]==0) count[5]<-0
        else count[5] <- 2*sqrt(count[5])
        names(count) <- c("concordant", "discordant", "tied.risk", "tied.time",
                          "std(c-d)")
    }
    else {
        strata <- as.factor(strata)
        ustrat <- levels(strata)[table(strata) >0]  #some strata may have 0 obs
        count <- matrix(0., nrow=length(ustrat), ncol=5)
        for (i in 1:length(ustrat)) {
            keep <- which(strata == ustrat[i])
            count[i,] <- docount(y[keep,,drop=F], x[keep], weight[keep])
        }
        
        count[,5] <- 2*sqrt(ifelse(count[,1]+count[,2]==0, 0, count[,5]))
        dimnames(count) <- list(ustrat,  c("concordant", "discordant",
                                           "tied.risk", "tied.time",
                                           "std(c-d)"))
    }
    count
}

Try the survival package in your browser

Any scripts or data that you put into this service are public.

survival documentation built on Aug. 24, 2021, 5:06 p.m.