.packageName <- "eha"
# 'Horizontal cut' in the Lexis diagram; (C) Gran Brostrm (2001).

age.window <- function(dat, window,
                       surv = c("enter", "exit", "event")){

  if (!is.data.frame(dat))stop("dat must be a data frame")
  if (length(surv) != 3) stop("surv must have length 3")
  fixed.names <- names(dat)
  surv.indices <- match(surv, fixed.names)
  if (length(which(is.na(surv.indices)))){
    x <- which(is.na(surv.indices))
    stop(paste(surv[x], " is not a name in the data frame."))
  }

  enter <- dat[, surv.indices[1]]
  exit <- dat[, surv.indices[2]]
  event <- dat[, surv.indices[3]]
  
  event <- ifelse( (exit > window[2]), 0, event)
  who <- (exit > window[1]) & (enter < window[2])
  event <- event[who]
  exit <- pmin(exit[who], window[2])
  enter <- pmax(enter[who], window[1])

  dat <- dat[who, ]
  dat[, surv.indices[1]] <- enter
  dat[, surv.indices[2]] <- exit
  dat[, surv.indices[3]] <- event
  
  dat
}
# Vertical cut in the Lexis diagram. (C) Gran Brostrm (2001).

cal.window <- function(dat, window,
                       surv = c("enter", "exit", "event", "birthdate")){

  if (!is.data.frame(dat))stop("dat must be a data frame")
  if (length(surv) != 4) stop("surv must have length 4")
  fixed.names <- names(dat)
  surv.indices <- match(surv, fixed.names)
  if (length(which(is.na(surv.indices)))){
    x <- which(is.na(surv.indices))
    stop(paste(surv[x], " is not a name in the fixed data frame."))
  }

  enter <- dat[, surv.indices[1]]
  exit <- dat[, surv.indices[2]]
  event <- dat[, surv.indices[3]]
  bdate <- dat[, surv.indices[4]]
  
  event <- ifelse(exit > (window[2] - bdate), 0, event)
  who <- ((exit > (window[1] - bdate)) &
          (enter < (window[2] - bdate)))
  event <- event[who]
  bdate <- bdate[who]
  exit <- pmin(exit[who], (window[2] - bdate))
  enter <- pmax(enter[who], (window[1] - bdate))

  dat <- dat[who, ]
  dat[, surv.indices[1]] <- enter
  dat[, surv.indices[2]] <- exit
  dat[, surv.indices[3]] <- event
  dat[, surv.indices[4]] <- bdate
  
  dat
}
check.surv <- function(enter, exit, event, id = NULL, eps = 1.e-8){
    ## The '.Fortran' version.
    ##########################
    n <- length(enter)
    if (length(exit) != n)stop("Length mismatch (enter/exit)")
    if (length(event) != n)stop("Length mismatch (enter/event)")
    if(!is.null(id)) if (length(id) != n)stop("Length mismatch (enter/id)")

    ## If no id (or one record per id).
    if (is.null(id) || (length(unique(id)) == n)) return(all(enter < exit))

    ## Now, id is set; let's sort data:
    #id <- factor(id)
    n.ind <- length(unique(id))
    ord <- order(id, enter)
    id <- id[ord]
    enter <- enter[ord]
    exit <- exit[ord]
    event <- as.logical(event[ord])

    id.size <- table(id)

    id <- factor(id)
    xx <- .Fortran("chek",
                   as.integer(n),
                   as.integer(n.ind),
                   as.integer(id.size),    ## length = n.ind
                   as.integer(id),         ## length = n
                   as.double(enter),       ## length = n
                   as.double(exit),        ## length = n
                   as.integer(event),      ## length = n
                   as.double(eps),
                   sane = integer(n.ind),  ## boolean; TRUE: good individual
                   PACKAGE = "eha")

    bad.id <- levels(id)[xx$sane == 0]
    bad.id
}
# Cox regression. (C) Gran Brostrm (2003). Initial code borrowed from
# 'coxph' in 'survival. Thanks to Terry Therneau and Thomas Lumley. 

coxreg <-
function (formula = formula(data),
          data = parent.frame(), 
          na.action = getOption("na.action"),
          init,
          method = c("efron", "breslow"),
          control = list(eps = 1e-8, maxiter = 10, trace = FALSE),
          singular.ok = TRUE,
          model = FALSE, 
          x = FALSE,
          y = TRUE,
          boot = FALSE,
          rs,
          max.survs) 
{
    method <- match.arg(method)
    call <- match.call()
    m <- match.call(expand.dots = FALSE)
    temp <- c("", "formula", "data", "na.action")
    m <- m[match(temp, names(m), nomatch = 0)]
 
    special <- "strata"
    Terms <- if (missing(data)) 
        terms(formula, special)
    else terms(formula, special, data = data)
    m$formula <- Terms
    m[[1]] <- as.name("model.frame")
    m <- eval(m, parent.frame())

    Y <- model.extract(m, "response")
    if (!inherits(Y, "Surv")) 
        stop("Response must be a survival object")
    if (missing(max.survs)) max.survs <- NROW(Y)
    weights <- model.extract(m, "weights")
    offset <- attr(Terms, "offset")
    tt <- length(offset)
    offset <- if (tt == 0) 
        rep(0, nrow(Y))
    else if (tt == 1) 
        m[[offset]]
    else {
        ff <- m[[offset[1]]]
        for (i in 2:tt) ff <- ff + m[[offset[i]]]
        ff
    }
    attr(Terms, "intercept") <- 1
    strats <- attr(Terms, "specials")$strata
    dropx <- NULL

    if (length(strats)) {
        temp <- untangle.specials(Terms, "strata", 1)
        dropx <- c(dropx, temp$terms)
        if (length(temp$vars) == 1) 
            strata.keep <- m[[temp$vars]]
        else strata.keep <- strata(m[, temp$vars], shortlabel = TRUE)
        strats <- as.numeric(strata.keep)
    }
    if (length(dropx)) 
        newTerms <- Terms[-dropx]
    else newTerms <- Terms
    X <- model.matrix(newTerms, m)
    assign <- lapply(attrassign(X, newTerms)[-1], function(x) x - 
        1)
    X <- X[, -1, drop = FALSE]

    #########################################

    if (length(dropx)){
      covars <- names(m)[-c(1, (dropx + 1))]
    }else{
      covars <- names(m)[-1]
    }

    isF <- logical(length(covars))
    for (i in 1:length(covars)){
      if (length(dropx)){
        isF[i] <- ( is.factor(m[, -(dropx + 1)][, (i + 1)]) ||
                   is.logical(m[, -(dropx + 1)][, (i + 1)]) )
      }else{
        isF[i] <- ( is.factor(m[, (i + 1)]) ||
                   is.logical(m[, (i + 1)]) )
      }      
    }

    if (ant.fak <- sum(isF)){
      levels <- list()
      index <- 0
      for ( i in 1:length(covars) ){
        if (isF[i]){
          index <- index + 1
          if (length(dropx)){
            levels[[i]] <- levels(m[, -(dropx + 1)][, (i + 1)])
          }else{
            levels[[i]] <- levels(m[, (i + 1)])
          }
        }else{
          levels[[i]] <- NULL
        }
      }
    }else{
      levels <- NULL
    }

    ##########################################
    type <- attr(Y, "type")
    if (type != "right" && type != "counting") 
        stop(paste("Cox model doesn't support \"", type, "\" survival data", 
            sep = ""))

    if (NCOL(Y) == 2){
      Y <- cbind(numeric(NROW(Y)), Y)
    }

    n.events <- sum(Y[, 3] != 0)
    if (n.events == 0) stop("No events; no sense in continuing!")
    if (missing(init)){ 
      init <- NULL
    }else{
      if (length(init) != NCOL(X)) stop("Wrong length of 'init'")
    }

    if (missing(rs)) 
        rs <- NULL

    if (is.list(control)){
      if (is.null(control$eps)) control$eps <- 1e-8
      if (is.null(control$maxiter)) control$maxiter <- 10
      if (is.null(control$trace)) control$trace <- FALSE
    }else{
      stop("control must be a list")
    }
    #if (is.numeric(control$eps)

    fit <- coxreg.fit(X,
                      Y,
                      rs,
                      strats,
                      offset,
                      init,
                      max.survs,
                      method,
                      boot,
                      control)

    if (!fit$fail) fit$fail <- NULL
    else
        fit$fail <- TRUE

    fit$convergence <- as.logical(fit$conver)
    fit$conver <- NULL ## Ugly!

###########################################################################    
## Crap dealt with ......
    
    if (is.character(fit)) {
        fit <- list(fail = fit)
        class(fit) <- "coxreg"
    }
    else if (is.null(fit$fail)){
        if (!is.null(fit$coef) && any(is.na(fit$coef))) {
            vars <- (1:length(fit$coef))[is.na(fit$coef)]
            msg <- paste("X matrix deemed to be singular; variable", 
                paste(vars, collapse = " "))
            if (singular.ok) 
                warning(msg)
            else stop(msg)
        }
        fit$n <- nrow(Y)
        class(fit) <- fit$method
        fit$terms <- Terms
        fit$assign <- assign
        if (FALSE){ ## Out-commented
        if (length(fit$coef) && is.null(fit$wald.test)) {
            nabeta <- !is.na(fit$coef)
            if (is.null(init)) 
                temp <- fit$coef[nabeta]
            else temp <- (fit$coef - init)[nabeta]
            fit$wald.test <- coxph.wtest(fit$var[nabeta, nabeta], 
                temp, control$toler.chol)$test
        }
      }
        na.action <- attr(m, "na.action")
        if (length(na.action)) 
            fit$na.action <- na.action
        if (model) 
            fit$model <- m
        if (x) {
            fit$x <- X
            if (length(strats)) 
                fit$strata <- strata.keep
        }
        if (y) 
            fit$y <- Y
    }
    ##if (!is.null(weights) && any(weights != 1)) 
    ##    fit$weights <- weights

    ##########################################

    fit$isF <- isF
    fit$covars <- covars
    s.wght <- (Y[, 2] - Y[, 1])## * weights
    fit$ttr <- sum(s.wght)
    fit$w.means <- list()
    for (i in 1:length(fit$covars)){
      nam <- fit$covars[i]
      col.m <- which(nam == names(m))
      if (isF[i]){
        n.lev <- length(levels[[i]])
        fit$w.means[[i]] <- numeric(n.lev)
        for (j in 1:n.lev){
          who <- m[, col.m] == levels[[i]][j]
          fit$w.means[[i]][j] <-
          sum( s.wght[who] ) / fit$ttr ## * 100, if in per cent
        }
      }else{
        fit$w.means[[i]] <- sum(s.wght * m[, col.m]) / fit$ttr
      }
    }

    ##########################################
    fit$levels <- levels
    fit$formula <- formula(Terms)
    fit$call <- call
    fit$events <- n.events 
    names(fit$coefficients) <- colnames(X)
    fit$method <- method
    class(fit) <- c("coxreg", "coxph")
    fit$means <- apply(X, 2, mean)
    fit
}
# Cox regression. (C) Gran Brostrm (2003). Initial code borrowed from
# 'coxph' in 'survival. Thanks to Terry Therneau and Thomas Lumley. 

coxreg.fit <- function(X, Y, rs, strats, offset, init, max.survs,
                       method = "breslow", boot = FALSE, control){

  nn <- NROW(X)
  ncov <- NCOL(X)

  if (missing(strats) || is.null(strats)) 
    strats <- rep(1, nn)

  if (missing(rs) || is.null(rs)){
    rs <- risksets(Y, strata = strats, max.survs)
  }

  if (max(rs$riskset) > nn) stop("Riskset does not match data")

  if (missing(offset) || is.null(offset)) 
    offset <- rep(0, nn)

  if (missing(init) || is.null(init)) 
    init <- rep(0, ncov)

  if (missing(control)){
      control <- list(eps=1.e-8, maxiter = 10, trace = FALSE)
  }else{
      if (!is.numeric(control$eps)){
          stop("Error in control = list(eps = ...) ")
      }else{
          if (control$eps <= 0) stop("control$eps must be strictly positive")
      }
      if (!is.numeric(control$maxiter)){
          stop("Error in control = list(maxiter = ...) ")
      }else{
          if (control$maxiter < 0) stop("control$maxiter must be positive")
      }
      if (!is.logical(control$trace)) stop("control$trace must be logical")
  }
      

  printlevel <- control$trace
      ## NOTE: silent == TRUE ===> printlevel = 0
  iter <- control$maxiter
  fit <- .Fortran("sup",
                  as.integer(method == "efron"),
                  iter = as.integer(iter), #maxit on input, actual on output
                  as.double(control$eps),
                  as.integer(printlevel),
                  #
                  as.integer(sum(rs$n.events)), ## total No. of events
                  as.integer(sum(rs$antrs)),  ## total No. of risksets
                  as.integer(length(rs$antrs)), # No. of strata
                  #
                  as.integer(rs$antrs),
                  as.integer(rs$n.events),
                  as.integer(rs$size),
                  #
                  as.integer(length(rs$riskset)), # Sum of risk set sizes.
                  as.integer(rs$eventset),
                  as.integer(rs$riskset),
                  #
                  as.integer(nn),
                  as.integer(ncov),
                  as.double(scale(X, center = TRUE, scale = FALSE)),
                  as.double(offset),
                  #
                  as.double(init),     # 'start.beta'
                  beta = double(ncov),
                  #
                  loglik = double(2), # [1] == start, [2] == maximized
                  dloglik = double(ncov),
                  variance = double(ncov * ncov),
                  sctest = double(1),
                  #
                  double(nn),     ## 'score', work area
                  double(ncov),          ## 'sumdscore', work area.
                  double(ncov * ncov), ## 'sumd2score', work area.
                  #
                  conver = integer(1),
                  f.conver = integer(1),
                  fail = integer(1),
                  DUP = FALSE,
                  PACKAGE = "eha")

  if (fit$fail){
      out <- paste("Singular hessian; suspicious variable No. ",
                   as.character(fit$fail), ":\n",
                   colnames(X)[fit$fail], sep = "")
      stop(out)
  }else if (!fit$conver){
      fit$conver <- 1
      if (!fit$f.conver){
          warning("Did not converge")
      }else{
          warning("log liklihood converged, but not variables")
      }
  }
      
  score <- exp(X %*% fit$beta)
  hazard <- .Fortran("hazards",
                     as.integer(sum(rs$n.events)), ## total No. of events
                     as.integer(sum(rs$antrs)),  ## total No. of risksets
                     as.integer(length(rs$antrs)), # No. of strata
                                        #
                     as.integer(rs$antrs),
                     as.integer(rs$n.events),
                     as.integer(rs$size),
                                        #
                     as.integer(length(rs$riskset)), # Sum of risk set sizes.
                     as.integer(rs$riskset),
                                        #
                     as.integer(nn),
                     as.integer(ncov),
                                        #
                     as.double(fit$beta),
                     as.double(score),
                     hazard = double(sum(rs$antrs)),
                                        #
                     #DUP = FALSE,
                     PACKAGE = "eha")$hazard

  resid <- .Fortran("martres",
                    as.integer(sum(rs$n.events)),
                    as.integer(sum(rs$antrs)),
                    as.integer(length(rs$antrs)),
                    #
                    as.integer(rs$antrs),
                    as.integer(rs$n.events),
                    as.integer(rs$size),
                    #
                    as.integer(length(rs$riskset)), # Sum of risk set sizes.
                    as.integer(rs$riskset),
                    #
                    as.integer(nn),
                    #
                    as.double(score),       ## 'score'
                    as.double(hazard),
                    resid = double(nn),
                    #DUP = FALSE,
                    PACKAGE = "eha"
                    )$resid

  if (!fit$fail)
    var <- matrix(fit$variance, ncov, ncov)
  else
    var <- NULL

  bootstrap <- NULL
  boot.sd <- NULL
  if (boot & (fit$fail == 0)){
    if (!is.numeric(boot)){
      cat("boot must be numeric (number of bootstrap replicates)")
    }else{
      init <- fit$beta
      iter <- control$maxiter
      fit.boot <- .Fortran("bootcox",
                           as.integer(1), ## means 'coxreg'
                           as.integer(boot),
                           boot.sample = double(boot * ncov),
                           boot.sd = double(boot * ncov),
                           as.integer(method == "efron"),
                           iter = as.integer(iter),
                           as.double(control$eps),
                           as.integer(printlevel),
                                        #
                           as.integer(sum(rs$n.events)), 
                           as.integer(sum(rs$antrs)),  
                           as.integer(length(rs$antrs)),
                                        #
                           as.integer(rs$antrs),
                           as.integer(rs$n.events),
                           as.integer(rs$size),
                                        #
                           as.integer(length(rs$riskset)), 
                           as.integer(rs$eventset),
                           as.integer(rs$riskset),
                                        #
                           as.integer(nn),
                           as.integer(ncov),
                           as.double(scale(X, center = TRUE, scale = FALSE)),
                           as.double(offset),
                                        #
                           as.double(init),     
                           as.double(fit$beta), ## Estimated beta
                                        #
                           loglik = double(2), 
                           dloglik = double(ncov),
                           variance = double(ncov * ncov),
                           sctest = double(1),
                                        #
                           double(nn),     
                           double(ncov),   
                           double(ncov * ncov),
                                        #
                           conver = integer(1),
                           fail = integer(1),
                                        #DUP = FALSE,
                           PACKAGE = "eha")
      bootstrap <- matrix(fit.boot$boot.sample, ncol = ncov, byrow = TRUE)
      boot.sd <- matrix(fit.boot$boot.sd, ncol = ncov, byrow = TRUE)
    }      
   }   

  list(coefficients = fit$beta,
       var = var,
       loglik = fit$loglik,
       score = fit$sctest,
       linear.predictors = X %*% fit$beta,
       residuals = resid,
       hazard = hazard,
       means = apply(X, 2, mean),
       bootstrap = bootstrap,
       boot.sd = boot.sd,
       conver = fit$conver,
       fail = fit$fail,
       iter = fit$iter
       )
       
  }
cro <- function(dat, response = 1){
  covar <- unique(dat[, -response, drop = FALSE])
  dat.keys <-
    match(do.call("paste", c(dat[, -response, drop = FALSE], sep="\001")),
          do.call("paste", c(covar,  sep="\001")))

  list(y = dat[, response],
       covar = covar,
       keys = dat.keys)
}
frail.fit <- function(X,
                      Y, rs, strats, offset, init, max.survs,
                      frailty, control
                      ){

    ## NOTE: Without intercept!
    ## Parameters: 1,..., n.rs first, then 1,..., p.
    nn <- NROW(X)
    ncov <- NCOL(X)
    
    if (missing(strats) || is.null(strats)) 
        strats <- rep(1, nn)
    
    if (missing(rs) || is.null(rs)){
        rs <- risksets(Y, strata = strats, max.survs)
    }

    if (max(rs$riskset) > nn) stop("Riskset does not match data")
    
    weg <- (abs(rs$size - rs$n.events) > 0.01) ## They are integers ?!!
    rs$riskset <- rs$riskset[rep(weg, rs$size)]
    rs$eventset <- rs$eventset[rep(weg, rs$n.events)]
    rs$n.events <- rs$n.events[weg]
    rs$size <- rs$size[weg]

    n.rs <- length(rs$size)

    ev <- numeric(sum(rs$size))

    start <- 1

    for (i in 1:n.rs){
        ev[start:(start + rs$n.events[i] - 1)] <- 1
        start <- start + rs$size[i]
    }
    
    haz <- rep(1:length(rs$size), rs$size)

    frailty <- frailty[rs$riskset]

    frailty <- as.integer(frailty)

    #ord <- order(frailty + seq(0, 0.9, length = length(frailty))) #integers
    # This is faster (?!?):
    ord <- sort(frailty, method = "quick", index.return = TRUE)$ix

    fam.size <- table(frailty)

    haz <- haz[ord]
    ev <- ev[ord]  # Binary Response
    rs$riskset <- rs$riskset[ord]

    n <- length(ev)
    
    if (missing(offset) || is.null(offset)) 
        offset <- rep(0, nn)
    
    if (missing(init) || is.null(init)) 
        init <- rep(0, ncov)
    
    if (missing(control)){
        control <- list(eps=1.e-8,
                        maxiter = 10,
                        n.points = 12,
                        trace = FALSE)
    }else{
        if (!is.numeric(control$eps)){
            stop("Error in control = list(eps = ...) ")
        }else{
            if (control$eps <= 0) stop("control$eps must be strictly positive")
        }
        if (!is.numeric(control$maxiter)){
            stop("Error in control = list(maxiter = ...) ")
        }else{
            if (as.integer(control$maxiter) <= 0)
                stop("control$maxiter must be positive")
        }
        if (!is.numeric(control$n.points)){
            stop("Error in control = list(n.points = ...) ")
        }else{
            if (as.integer(control$n.points) <= 0)
                stop("control$maxiter must be positive")
        }
        if (!is.logical(control$trace)) stop("control$trace must be logical")
    }

    n.rs <- max(haz)
    p <- ncov
    start.coef <- numeric(p + n.rs)
    start.coef[1:n.rs] <- log(-log(1 - rs$n.events / rs$size))

    start.coef[(n.rs + 1):(n.rs + p)] <- init

    printlevel <- control$trace
      ## NOTE: silent == TRUE ===> printlevel = 0
    iter <- control$maxiter

    fam <- 1 ##logit(link = cloglog)
    method <- 1
    start.sigma <- 1
    n.fam <- length(fam.size)

    X <- scale(X, center = TRUE, scale = FALSE)
    if (control$trace)
        cat("Go into [frail_ml]\n")
    bdim = n.rs + p + 1
    fit <- .C("frail_ml",
              as.integer(fam), ## logit(cloglog)
              as.integer(method), ## "vmmin"
              as.integer(p), #leading dimension of t(X)
              as.integer(nn), #second dimension of t(X)
              as.integer(n.rs), # No. of risksets (extra parameters).
              as.integer(rs$riskset - 1),
              as.double(start.coef), 
              as.double(start.sigma),
              as.double(t(X)),       ### Note CAREFULLY (03-01-09)!!!
              as.integer(ev),    ## "Y"
              as.integer(haz - 1),  ## New, for hazard contributions
              as.double(offset),
              as.integer(fam.size),
              as.integer(n.fam),
              as.integer(control$n.points),  ## For Gauss-Hermite
              as.double(control$eps),
              as.integer(control$maxit),
              as.integer(control$trace),
              beta = double(p),  ## Return values from here.
              hazards = double(n.rs),
              sigma = double(1),
              sigma.sd = double(1),
              loglik = double(2), ## Changed from 1 to 2, May 8, 2003
              variance = double(bdim * bdim),
              frail = double(n.fam),
           ##   mu = double(n),
              convergence = integer(1),
              fail = integer(1),
              PACKAGE = "eha"
            )  

    if (fit$fail){
        warning("Singular hessian (returned); no S.E. estimates.")
    }

    var <- matrix(fit$variance, ncol = bdim)[(n.rs + 1):(n.rs + p),
                                (n.rs + 1):(n.rs + p), drop = FALSE]

    list(coefficients = fit$beta,
         var = var,
         sigma = fit$sigma,
         sigma.sd = fit$sigma.sd,
         loglik = fit$loglik,
         ##score = fit$sctest,
         linear.predictors = X %*% fit$beta,
         residuals = resid,
         hazards = fit$hazards,
         frailty = fit$frail,
         means = apply(X, 2, mean),
         conver = fit$conver,
         fail = fit$fail,
         iter = fit$iter
       )
       
  }
# ML or MPPL estimation of proportional hazards models.
# (C) Gran Brostrm (2001).

geome.fit <- function(X, Y, rs, strats, offset, init, max.survs,
                       method = "ML", boot = FALSE, control){

  nn <- NROW(X)
  ncov <- NCOL(X)

  if (missing(strats) || is.null(strats)) 
    strats <- rep(1, nn)

  if (missing(rs) || is.null(rs)){
    rs <- risksets(Y, strata = strats, max.survs)
  }

  if (max(rs$riskset) > nn) stop("Riskset does not match data")
  
  if (missing(offset) || is.null(offset)) 
    offset <- rep(0, nn)

  if (missing(init) || is.null(init)) 
    init <- rep(0, ncov)

    if (missing(control)){
      control <- list(eps=1.e-8, maxiter = 10, trace = FALSE)
  }else{
      if (!is.numeric(control$eps)){
          stop("Error in control = list(eps = ...) ")
      }else{
          if (control$eps <= 0) stop("control$eps must be strictly positive")
      }
      if (!is.numeric(control$maxiter)){
          stop("Error in control = list(maxiter = ...) ")
      }else{
          if (control$maxiter < 0) stop("control$maxiter must be positive")
      }
      if (!is.logical(control$trace)) stop("control$trace must be logical")
  }

  printlevel <- control$trace
      ## NOTE: silent == TRUE ===> printlevel = 0
  iter <- control$maxiter
  ## No. of risk set with tied events and not 'trivial':
  nsk2 <- sum( (rs$n.events < rs$size) & (rs$n.events > 1))
  fit <- .Fortran("geomsup",
                  as.integer(method == "MPPL"),
                  iter = as.integer(iter), #maxit on input, actual on output
                  as.double(control$eps),
                  as.integer(printlevel),
                  #
                  as.integer(sum(rs$n.events)), ## total No. of events
                  as.integer(sum(rs$antrs)),  ## total No. of risksets
                  as.integer(length(rs$antrs)), # No. of strata
                  #
                  as.integer(rs$antrs),
                  as.integer(rs$n.events),
                  as.integer(rs$size),
                  #
                  as.integer(length(rs$riskset)), # Sum of risk set sizes.
                  as.integer(rs$eventset),
                  as.integer(rs$riskset),
                  #
                  as.integer(nn),
                  as.integer(ncov),
                  as.double(scale(X, center = TRUE, scale = FALSE)),
                  as.double(offset),
                  #
                  as.double(init),     # 'start.beta'
                  beta = double(ncov),
                  #
                  loglik = double(2), # [1] == start, [2] == maximized
                  dloglik = double(ncov),
                  variance = double(ncov * ncov),
                  sctest = double(1),
                  #
                  hazard = numeric(sum(rs$antrs)),
                  #
                  double(nn),     ## 'score', work area
                  double(ncov),          ## 'sumdscore', work area.
                  double(ncov * ncov), ## 'sumd2score', work area.
                  #
                  conver = integer(1),
                  f.conver = integer(1),
                  fail = integer(1),
                  #DUP = FALSE,
                  PACKAGE = "eha")
  if (fit$fail){
      out <- paste("Singular hessian; suspicious variable No. ",
                   as.character(fit$fail), ":\n",
                   colnames(X)[fit$fail], sep = "")
      stop(out)
  }else if (!fit$conver){
      fit$conver <- 1
      if (!fit$f.conver){
          warning("Did not converge")
      }else{
          warning("log liklihood converged, but not variables")
      }
  }

  lp <- offset + X %*% fit$beta
  score <- exp(lp)

  hazard <- fit$hazard

  if (!any(is.na(hazard))){
    resid <- .Fortran("martres",
                      as.integer(sum(rs$n.events)),
                      as.integer(sum(rs$antrs)),
                      as.integer(length(rs$antrs)),
                                        #
                      as.integer(rs$antrs),
                      as.integer(rs$n.events),
                      as.integer(rs$size),
                                        #
                      as.integer(length(rs$riskset)), # Sum of risk set sizes.
                      as.integer(rs$riskset),
                                        #
                      as.integer(nn),
                                        #
                      as.double(score),       ## 'score'
                      as.double(hazard),
                      resid = double(nn),
                                        #DUP = FALSE,
                      PACKAGE = "eha"
                      )$resid
  }
      
  if (!fit$fail)
    var <- matrix(fit$variance, ncov, ncov)
  else
    var <- NULL

  bootstrap <- NULL
  if (boot & (fit$fail == 0)){
    if (!is.numeric(boot)){
      cat("boot must be numeric (number of bootstrap replicates)")
    }else{
      init <- fit$beta
      fit.boot <- .Fortran("bootcox",
                           as.integer(2), ## means 'mlreg'
                           as.integer(boot),
                           boot.sample = double(boot * ncov),
                           boot.sd = double(boot * ncov),
                           as.integer(method == "efron"),
                           iter = as.integer(iter),
                           as.double(control$eps),
                           as.integer(printlevel),
                                        #
                           as.integer(sum(rs$n.events)), 
                           as.integer(sum(rs$antrs)),  
                           as.integer(length(rs$antrs)),
                                        #
                           as.integer(rs$antrs),
                           as.integer(rs$n.events),
                           as.integer(rs$size),
                                        #
                           as.integer(length(rs$riskset)), 
                           as.integer(rs$eventset),
                           as.integer(rs$riskset),
                                        #
                           as.integer(nn),
                           as.integer(ncov),
                           as.double(scale(X, center = TRUE, scale = FALSE)),
                           as.double(offset),
                                        #
                           as.double(init),     
                           as.double(fit$beta), ## Estimated beta
                                        #
                           loglik = double(2), 
                           dloglik = double(ncov),
                           variance = double(ncov * ncov),
                           sctest = double(1),
                                        #
                           double(nn),     
                           double(ncov),   
                           double(ncov * ncov),
                                        #
                           conver = integer(1),
                           fail = integer(1),
                                        #DUP = FALSE,
                           PACKAGE = "eha")
      bootstrap <- matrix(fit.boot$boot.sample, ncol = ncov, byrow = TRUE)
      boot.sd <- matrix(fit.boot$boot.sd, ncol = ncov, byrow = TRUE)
    }      
  }else{
      boot.sd <- NULL
  }
  
  list(coefficients = fit$beta,
       var = var,
       loglik = fit$loglik,
       score = fit$sctest,
       linear.predictors = lp,
       residuals = resid,
       hazard = hazard,
       means = apply(X, 2, mean),
       bootstrap = bootstrap,
       boot.sd = boot.sd,
       conver = fit$conver,
       fail = fit$fail,
       iter = fit$iter
       )
       
}
join.spells <- function(dat, eps = 1.e-8){
    ## Survival data: (enter, exit], event (0-1, or TRUE/FALSE),
    ## birthdate in years since 1 jan 0, eg 1877.500 = 1 july 1877
    ## Assumes: enter, exit, event, id, birthdate
    ## Must have unique id (as a covariate).

    
    resp <- match(c("enter", "exit", "event"), names(dat))
    if (any(is.na(resp))) stop("Wrong variable names")
    
    koll <- match(c("id"), names(dat))
    if (any(is.na(resp))) stop("No 'id' in variable names")

    ## First, check data:
    res.check <- check.surv(dat$enter, dat$exit, dat$event, dat$id)
    if (length(res.check)){
        cat("Error in individual(s). Return value is id of the bad.")
        return(res.check)
    }
    covar <- dat[ , -resp]
    n.cov <- ncol(covar)
    n.rec <- nrow(covar)
    all <- unique(dat$id)
    nn <- length(all)
    
    ide <- as.integer(factor(dat$id, labels = 1:nn))
    ord <- order(ide, dat$enter, dat$exit)
    dat <- dat[ord, ]
    
    res <- .Fortran("cleanup",
                    as.double(t(covar)),
                    as.double(dat$enter),
                    as.double(dat$exit),
                    as.integer(dat$event),
                    as.integer(ide),
                    as.integer(n.cov),
                    as.integer(n.rec),
                    as.integer(nn),
                    as.double(eps),
                    new.n.rec = integer(1),
                    new.cov = double(n.rec * n.cov),
                    enter = double(n.rec),
                    exit = double(n.rec),
                    event = integer(n.rec),
                    id = integer(n.rec),
                    ##DUP = FALSE,
                    PACKAGE = "eha")
    
  
    out <- data.frame(new.id = res$id[1:res$new.n.rec],
                      enter = res$enter[1:res$new.n.rec],
                      exit = res$exit[1:res$new.n.rec],
                      event = res$event[1:res$new.n.rec]
                      )
    
    new.cov <-
        data.frame(matrix(res$new.cov, byrow = TRUE,
                          ncol = n.cov))[1:res$new.n.rec, , drop = FALSE]
    
    names(new.cov) <- names(covar)
    
    cbind(out, new.cov)
}
# Puts in 'communal time dependent covariates by 'splitting spells'.
# Gran Brostrm (2001).

make.communal <- function(dat,
                          com.dat,
                          ##com.info,
                          communal = TRUE,
                          start,
                          period = 1,
                          lag = 0,
                          surv = c("enter", "exit", "event", "birthdate"),
                          tol = 0.0001,
                          fortran = TRUE){
  
  ## 'dat' is a data frame with variables:
  ## birthdate = birth date
  ## enter = left truncation time
  ## exit  = right censoring/event time
  ## event = event indicator (0 if no event).
  ## other covariates.

  ## 'com.dat' is a data frame with columns communal covariates.

  ## Formula: datum = bdate + risktime * as.numeric(communal) + lag
  ## Note: 'scale' may only be 0 or 1. If scale = 1,
  ## the 'lag' must be <= 0! ("causality")
  ## Leaving:
  ## either 'datum = bdate + risktime + lag' (communal == TRUE, lag == 0)
  ## or     'datum = bdate + lag'      (communal == FALSE).

  ## NOTE: names(com.dat) must be != names(dat) !!!

  if (!is.data.frame(dat))stop("dat must be a data frame")
  if (!is.data.frame(com.dat))stop("com.dat must be a data frame")
  ##if (!is.vector(com.info))stop("com.info must be a vector")
  ##if (length(com.info) != 4)stop("com.info must be a vector of length 4")
  ##scale <- com.info[4]
  ##if ( !((scale == 0) || (scale == 1)) ) stop("scale must be 0 or 1")
  ## lag <- com.info[3]
  
  if (length(surv) != 4) stop("surv must have length 4")
  fixed.names <- names(dat)
  surv.indices <- match(surv, fixed.names)
  if (length(which(is.na(surv.indices)))){
    x <- which(is.na(surv.indices))
    stop(paste(surv[x], " is not a name in the fixed data frame."))
  }
  com.names <- names(com.dat)
  if ( length(x <- which(!is.na(match(com.names, c(surv, fixed.names))))) )
    stop(paste(com.names[x], "are names in fixed data frame.")) 
  
  nn <- nrow(dat)
  n.years <- nrow(com.dat)
  n.com <- NCOL(com.dat) ## No. of communal covariates.  
  ## Function to calculate start and stop period

  if (n.com > 1) stop("Only one communal covariate at a time!")
  ## NOTE: Will only work with n.com == 1 for now!!

  cuts <- start + c(0, (1:n.years) * period) - lag

  beg.per <- cuts[1]
  end.per <- cuts[n.years + 1]
  iv.length <- period
  

  ## cut off in calendar time:
  spell.tot <- sum(dat[, surv.indices[2]] - dat[, surv.indices[1]])
  dat <- cal.window(dat, c(beg.per, end.per), surv)
  if (sum(dat[, surv.indices[2]] - dat[, surv.indices[1]]) < spell.tot)
    warning("Spells are cut")
  nn <- nrow(dat)
    
  if (!communal){ ## "Fixed" communal!

    get.per <- function(dates)
      pmin(pmax(1, ceiling((dates - beg.per) / iv.length)),
           n.years)
    dates <- dat[, surv.indices[4]]
    ppp <- get.per(dates)
    yy <- matrix(0, ncol = n.com, nrow = nn)
    for (i in 1:n.com){
      yy[, i] <- com.dat[ppp, i]
    }
    yy <- as.data.frame(yy)
    names(yy) <- com.names
    yy <- cbind(dat, yy)
    
  }else{ ## Real communal!

    get.iv <- function(dates)

      cbind(pmin(pmax( 1, floor((dates[, 1, drop = FALSE] - beg.per) /
                          iv.length) + 1 ), n.years ),
            pmin(pmax( 1, ceiling((dates[, 2, drop = FALSE] - beg.per) /
                                 iv.length) ), n.years) 
	)

    event.boolean <- is.logical(dat[, surv.indices[3]])
    xx <- cbind(dat[, surv.indices, drop = FALSE], 1:nn)
    xx[, 3] <- as.numeric(xx[, 3]) ## Could be a boolean vector.
    xx <- as.matrix(xx)
    if (!is.numeric(xx))
      stop("Internal error in [make.communal]: xx not numeric")
    
    ## First, find the size of the new data frame (nn.out):
    ind.date <- cbind(xx[, 1, drop = FALSE] + xx[, 4, drop = FALSE],
                      xx[, 2, drop = FALSE] + xx[, 4, drop = FALSE])
    
    cases <- ( (ind.date[, 1] < end.per) & (ind.date[, 2] > beg.per) )
    xx <- xx[cases, , drop = FALSE]
    ind.date <- ind.date[cases, , drop = FALSE]
    
    ##  if (nrow(com.info) != n.com) stop("Error in com.info: wrong noof rows")
    ##return(xx)
    ind.iv <- get.iv(ind.date)
    ##return(ind.date, ind.iv)
    nn <- nrow(xx) ## NOTE: New definition of nn!
    nn.out <- sum(ind.iv[, 2] - ind.iv[, 1] + 1)
    ## return(nn.out)
    
    yy <- matrix(0, nrow = nn.out, ncol = ncol(xx) + 1)
    
    ## And so we fill it!
    
    nn.out <- ind.iv[, 2] - ind.iv[, 1] + 1
    cur.row <- 0

    com.dat <- as.matrix(com.dat)
    
    split <- function(i)
      {
        n.rows <- nn.out[i]
        if (n.rows == 1){
          return(list( c(xx[i, ], ind.iv[i, 1]) ))
        }else{
          x.i <- xx[i, ]
          out <- matrix(0, nrow = n.rows, ncol = ncol(yy))
          out[n.rows, 3] <- x.i[3]
          out[, 4] <- x.i[4]
          out[, 5] <- x.i[5]
          out[1, 1] <- x.i[1]
          out[1, 2] <- cuts[ind.iv[i, 1] + 1] - x.i[4]
          out[1, 6] <- ind.iv[i, 1]
          out[n.rows, 1] <- cuts[ind.iv[i, 2]] - x.i[4]
          out[n.rows, 2] <- x.i[2]
          out[n.rows, 6] <- ind.iv[i, 2]
          if (n.rows > 2){
            for (j in 2:(n.rows - 1)){
              out[j, 1] <- out[j - 1, 2]
              out[j, 2] <- out[j - 1, 2] + iv.length
              out[j, 6] <- ind.iv[i, 1] + j - 1
            }
          }
          return(out)
        }
      }

    beg.row <- end.row <- 0

    if (!fortran){
      for (j in 1:nn){
        beg.row <- end.row + 1
        end.row <- end.row + nn.out[j]
        yy[beg.row:end.row, ] <- split(j) 
        if (j %/% 100 * 100 == j) cat("j = ", j, "\n")
        NULL
      }
    }
    if (fortran){
      
      yy <- .Fortran("split",
                     as.double(xx),
                     as.integer(nn),
                     as.integer(ncol(xx)),
                     yy = as.double(yy),
                     as.integer(nrow(yy)),
                     as.integer(ncol(yy)),
                     as.integer(nn.out),
                     as.integer(ind.iv),
                     as.double(cuts),
                     as.integer(n.years),
                     DUP = FALSE,
                     PACKAGE = "eha",
                     )$yy
      yy <- matrix(yy, ncol = ncol(xx) + 1)
    }

    yy <- cbind(yy[, 1:4, drop = FALSE],
                dat[yy[, 5], -surv.indices, drop = FALSE],
                com.dat[yy[, 6], , drop = FALSE])
    names(yy)[1:4] <- surv
    all.names <- c(surv, fixed.names[-surv.indices], com.names)
    row.names(yy) <- as.character(1:nrow(yy))
    yy <- as.data.frame(yy)
    names(yy) <- all.names
    if (event.boolean) yy[, 3] <- as.logical(yy[, 3]) ## Beware of '3'!
  }
  
  yy
}
          
# ML or MPPL estimation of proportional hazards models.
# (C) Gran Brostrm (2001).

mlreg <-
function (formula = formula(data),
          data = parent.frame(), 
          na.action = getOption("na.action"),
          init,
          method = c("ML", "MPPL"),
          control = list(eps = 1e-8,
          maxiter = 10, n.points = 12,
          trace = FALSE),
          singular.ok = TRUE,
          model = FALSE, 
          x = FALSE,
          y = TRUE,
          boot = FALSE,
          geometric = FALSE,
          rs,
          frailty = NULL,
          max.survs) 
{
    method <- match.arg(method)
    call <- match.call()
    m <- match.call(expand.dots = FALSE)
    temp <- c("", "formula", "data", "na.action")
    m <- m[match(temp, names(m), nomatch = 0)]
    
    special <- "strata"
    Terms <- if (missing(data)) 
        terms(formula, special)
    else terms(formula, special, data = data)
    m$formula <- Terms
    m[[1]] <- as.name("model.frame")
    m <- eval(m, parent.frame())
    
    Y <- model.extract(m, "response")
    if (!inherits(Y, "Surv")) 
        stop("Response must be a survival object")
    if (missing(max.survs)) max.survs <- NROW(Y)
    weights <- model.extract(m, "weights")
    offset <- attr(Terms, "offset")
    tt <- length(offset)
    offset <- if (tt == 0) 
        rep(0, nrow(Y))
    else if (tt == 1) 
        m[[offset]]
    else {
        ff <- m[[offset[1]]]
        for (i in 2:tt) ff <- ff + m[[offset[i]]]
        ff
    }
    attr(Terms, "intercept") <- 1
    strats <- attr(Terms, "specials")$strata
    dropx <- NULL
    
    if (length(strats)) {
        temp <- untangle.specials(Terms, "strata", 1)
        dropx <- c(dropx, temp$terms)
        if (length(temp$vars) == 1) 
            strata.keep <- m[[temp$vars]]
        else strata.keep <- strata(m[, temp$vars], shortlabel = TRUE)
        strats <- as.numeric(strata.keep)
    }
    if (length(dropx)) 
        newTerms <- Terms[-dropx]
    else newTerms <- Terms
    X <- model.matrix(newTerms, m)
    assign <- lapply(attrassign(X, newTerms)[-1], function(x) x - 
                     1)
    X <- X[, -1, drop = FALSE]
    
#########################################
    
    if (length(dropx)){
        covars <- names(m)[-c(1, (dropx + 1))]
    }else{
        covars <- names(m)[-1]
    }

    isF <- logical(length(covars))
    for (i in 1:length(covars)){
        if (length(dropx)){
            isF[i] <- ( is.factor(m[, -(dropx + 1)][, (i + 1)]) ||
                       is.logical(m[, -(dropx + 1)][, (i + 1)]) )
        }else{
            isF[i] <- ( is.factor(m[, (i + 1)]) ||
                       is.logical(m[, (i + 1)]) )
        }      
    }
    
    if (ant.fak <- sum(isF)){
        levels <- list()
        index <- 0
        for ( i in 1:length(covars) ){
            if (isF[i]){
                index <- index + 1
                if (length(dropx)){
                    levels[[i]] <- levels(m[, -(dropx + 1)][, (i + 1)])
                }else{
                    levels[[i]] <- levels(m[, (i + 1)])
                }
            }else{
                ##cat("NULL level no  ", i, "\n")
                levels[[i]] <- NULL
            }
        }
    }else{
        levels <- NULL
    }

    ##########################################
    type <- attr(Y, "type")
    if (type != "right" && type != "counting") 
        stop(paste("Cox model doesn't support \"", type, "\" survival data", 
                   sep = ""))
    
    if (NCOL(Y) == 2){
        Y <- cbind(numeric(NROW(Y)), Y)
    }
    
    n.events <- sum(Y[, 3] != 0)
    if (n.events == 0) stop("No events; no sense in continuing!")
    if (missing(init)) 
        init <- NULL
    
    if (missing(rs)) 
        rs <- NULL
    
    if (is.list(control)){
        if (is.null(control$eps)) control$eps <- 1e-8
        if (is.null(control$maxiter)) control$maxiter <- 10
        if (is.null(control$n.points)) control$n.points <- 12
        if (is.null(control$trace)) control$trace <- FALSE
    }else{
        stop("control must be a list")
    }
    
    if (geometric) {
        if (!is.null(frailty))
            error("Frailty not implemented for geometric yet")
        fit <- geome.fit(X,
                         Y,
                         rs,
                         strats,
                         offset,
                         init,
                         max.survs,
                         method,
                         boot,
                         control)
    }else{
        fit <- mlreg.fit(X,
                         Y,
                         rs,
                         strats,
                         offset,
                         init,
                         max.survs,
                         method,
                         boot,
                         control)
    }
    
    if (!fit$fail) fit$fail <- NULL
    else
        fit$fail <- TRUE
    
    fit$convergence <- as.logical(fit$conver)
    fit$conver <- NULL ## Ugly!
    if (!is.null(frailty)){
        if (length(frailty) != NROW(X)) stop("Wrong length of 'frailty'")

##        init = fit$coef
        fit <- frail.fit(X,
                         Y,
                         rs,
                         strats,
                         offset,
                         init,
                         max.survs,
                         frailty,
                         control
                         )
        
    if (!fit$fail) fit$fail <- NULL
    else
        fit$fail <- TRUE

    fit$convergence <- as.logical(fit$conver)
    fit$conver <- NULL ## Ugly!
    }        

###########################################################################    
## Crap dealt with ......
    
    if (is.character(fit)) {
        fit <- list(fail = fit)
        class(fit) <- "mlreg"
    }
    else if (is.null(fit$fail)){
        if (!is.null(fit$coef) && any(is.na(fit$coef))) {
            vars <- (1:length(fit$coef))[is.na(fit$coef)]
            msg <- paste("X matrix deemed to be singular; variable", 
                         paste(vars, collapse = " "))
            if (singular.ok) 
                warning(msg)
            else stop(msg)
        }
        fit$n <- nrow(Y)
        fit$terms <- Terms
        fit$assign <- assign
        if (FALSE){ ##AAAAAARRRRRRRRRRGGGGGGGGHHHHHHH!!!!!!!!!!!!
            if (length(fit$coef) && is.null(fit$wald.test)) {
                nabeta <- !is.na(fit$coef)
                if (is.null(init)) 
                    temp <- fit$coef[nabeta]
                else temp <- (fit$coef - init)[nabeta]
                fit$wald.test <- coxph.wtest(fit$var[nabeta, nabeta], 
                                             temp, control$toler.chol)$test
            }
        }
        na.action <- attr(m, "na.action")
        if (length(na.action)) 
            fit$na.action <- na.action
        if (model) 
            fit$model <- m
        if (x) {
            fit$x <- X
            if (length(strats)) 
                fit$strata <- strata.keep
        }
        if (y) 
            fit$y <- Y
    }
    
    ##########################################

    fit$isF <- isF
    fit$covars <- covars
    s.wght <- (Y[, 2] - Y[, 1])## * weights
    fit$ttr <- sum(s.wght)
    fit$w.means <- list()
    for (i in 1:length(fit$covars)){
        nam <- fit$covars[i]
        col.m <- which(nam == names(m))
        if (isF[i]){
            n.lev <- length(levels[[i]])
            fit$w.means[[i]] <- numeric(n.lev)
            for (j in 1:n.lev){
                who <- m[, col.m] == levels[[i]][j]
                fit$w.means[[i]][j] <-
                    sum( s.wght[who] ) / fit$ttr ## * 100, if in per cent
            }
        }else{
            fit$w.means[[i]] <- sum(s.wght * m[, col.m]) / fit$ttr
        }
    }

    ##########################################
    fit$levels <- levels
    fit$formula <- formula(Terms)
    fit$call <- call
    fit$events <- n.events 
    names(fit$coefficients) <- colnames(X)
    fit$method <- method
    class(fit) <- c("mlreg", "coxreg", "coxph")
    fit$means <- apply(X, 2, mean)

    fit
}
# ML or MPPL estimation of proportional hazards models.
# (C) Gran Brostrm (2001).

mlreg.fit <- function(X, Y, rs, strats, offset, init, max.survs,
                       method = "ML", boot = FALSE, control){

  nn <- NROW(X)
  ncov <- NCOL(X)

  if (missing(strats) || is.null(strats)) 
    strats <- rep(1, nn)

  if (missing(rs) || is.null(rs)){
    rs <- risksets(Y, strata = strats, max.survs)
  }

  if (max(rs$riskset) > nn) stop("Riskset does not match data")
  
  if (missing(offset) || is.null(offset)) 
    offset <- rep(0, nn)

  if (missing(init) || is.null(init)) 
    init <- rep(0, ncov)

    if (missing(control)){
      control <- list(eps=1.e-8, maxiter = 10, trace = FALSE)
  }else{
      if (!is.numeric(control$eps)){
          stop("Error in control = list(eps = ...) ")
      }else{
          if (control$eps <= 0) stop("control$eps must be strictly positive")
      }
      if (!is.numeric(control$maxiter)){
          stop("Error in control = list(maxiter = ...) ")
      }else{
          if (control$maxiter < 0) stop("control$maxiter must be positive")
      }
      if (!is.logical(control$trace)) stop("control$trace must be logical")
  }

  printlevel <- control$trace
      ## NOTE: silent == TRUE ===> printlevel = 0
  iter <- control$maxiter
  ## No. of risk set with tied events and not 'trivial':
  nsk2 <- sum( (rs$n.events < rs$size) & (rs$n.events > 1))
  fit <- .Fortran("mlsup",
                  as.integer(method == "MPPL"),
                  iter = as.integer(iter), #maxit on input, actual on output
                  as.double(control$eps),
                  as.integer(printlevel),
                  #
                  as.integer(sum(rs$n.events)), ## total No. of events
                  as.integer(sum(rs$antrs)),  ## total No. of risksets
                  as.integer(length(rs$antrs)), # No. of strata
                  #
                  as.integer(rs$antrs),
                  as.integer(rs$n.events),
                  as.integer(rs$size),
                  #
                  as.integer(length(rs$riskset)), # Sum of risk set sizes.
                  as.integer(rs$eventset),
                  as.integer(rs$riskset),
                  #
                  as.integer(nn),
                  as.integer(nsk2),
                  as.integer(ncov),
                  as.double(scale(X, center = TRUE, scale = FALSE)),
                  as.double(offset),
                  #
                  as.double(init),     # 'start.beta'
                  beta = double(ncov),
                  #
                  loglik = double(2), # [1] == start, [2] == maximized
                  dloglik = double(ncov),
                  variance = double(ncov * ncov),
                  sctest = double(1),
                  #
                  hazard = numeric(sum(rs$antrs)),
                  #
                  double(nn),     ## 'score', work area
                  double(ncov),          ## 'sumdscore', work area.
                  double(ncov * ncov), ## 'sumd2score', work area.
                  #
                  conver = integer(1),
                  f.conver = integer(1),
                  fail = integer(1),
                  #DUP = FALSE,
                  PACKAGE = "eha")
  if (fit$fail){
      out <- paste("Singular hessian; suspicious variable No. ",
                   as.character(fit$fail), ":\n",
                   colnames(X)[fit$fail], sep = "")
      stop(out)
  }else if (!fit$conver){
      fit$conver <- 1
      if (!fit$f.conver){
          warning("Did not converge")
      }else{
          warning("log liklihood converged, but not variables")
      }
  }

  lp <- offset + X %*% fit$beta
  score <- exp(lp)

  hazard <- fit$hazard

  if (!any(is.na(hazard))){
    resid <- .Fortran("martres",
                      as.integer(sum(rs$n.events)),
                      as.integer(sum(rs$antrs)),
                      as.integer(length(rs$antrs)),
                                        #
                      as.integer(rs$antrs),
                      as.integer(rs$n.events),
                      as.integer(rs$size),
                                        #
                      as.integer(length(rs$riskset)), # Sum of risk set sizes.
                      as.integer(rs$riskset),
                                        #
                      as.integer(nn),
                                        #
                      as.double(score),       ## 'score'
                      as.double(hazard),
                      resid = double(nn),
                                        #DUP = FALSE,
                      PACKAGE = "eha"
                      )$resid
  }
      
  if (!fit$fail)
    var <- matrix(fit$variance, ncov, ncov)
  else
    var <- NULL

  bootstrap <- NULL
  if (boot & (fit$fail == 0)){
    if (!is.numeric(boot)){
      cat("boot must be numeric (number of bootstrap replicates)")
    }else{
      init <- fit$beta
      fit.boot <- .Fortran("bootcox",
                           as.integer(2), ## means 'mlreg'
                           as.integer(boot),
                           boot.sample = double(boot * ncov),
                           boot.sd = double(boot * ncov),
                           as.integer(method == "efron"),
                           iter = as.integer(iter),
                           as.double(control$eps),
                           as.integer(printlevel),
                                        #
                           as.integer(sum(rs$n.events)), 
                           as.integer(sum(rs$antrs)),  
                           as.integer(length(rs$antrs)),
                                        #
                           as.integer(rs$antrs),
                           as.integer(rs$n.events),
                           as.integer(rs$size),
                                        #
                           as.integer(length(rs$riskset)), 
                           as.integer(rs$eventset),
                           as.integer(rs$riskset),
                                        #
                           as.integer(nn),
                           as.integer(ncov),
                           as.double(scale(X, center = TRUE, scale = FALSE)),
                           as.double(offset),
                                        #
                           as.double(init),     
                           as.double(fit$beta), ## Estimated beta
                                        #
                           loglik = double(2), 
                           dloglik = double(ncov),
                           variance = double(ncov * ncov),
                           sctest = double(1),
                                        #
                           double(nn),     
                           double(ncov),   
                           double(ncov * ncov),
                                        #
                           conver = integer(1),
                           fail = integer(1),
                                        #DUP = FALSE,
                           PACKAGE = "eha")
      bootstrap <- matrix(fit.boot$boot.sample, ncol = ncov, byrow = TRUE)
      boot.sd <- matrix(fit.boot$boot.sd, ncol = ncov, byrow = TRUE)
    }      
  }else{
      boot.sd <- NULL
  }
  
  list(coefficients = fit$beta,
       var = var,
       loglik = fit$loglik,
       score = fit$sctest,
       linear.predictors = lp,
       residuals = resid,
       hazard = hazard,
       means = apply(X, 2, mean),
       bootstrap = bootstrap,
       boot.sd = boot.sd,
       conver = fit$conver,
       fail = fit$fail,
       iter = fit$iter
       )
       
}
# 'Period statistics'; (C) Gran Brostrm (2003).

perstat <- function(surv, period, age = c(0, 200)){
  if (ncol(surv) != 4) stop("Need a full 'surv' object with four columns.")
  surv <- data.frame(surv)
  names(surv) <- c("enter", "exit", "event", "birthdate")
  n.rows <- length(period) - 1
  n.cols <- length(age) - 1
  row.name <- character(n.rows)
  for (i in 1:n.rows){
    row.name[i] <-
      paste("(", as.character(period[i]),
            " - ", as.character(period[i+1]), "]", sep = "")  
  }
  if (n.cols > 1){
    col.name <- character(n.cols)
    for (i in 1:n.cols){
      col.name[i] <-
        paste("(", as.character(age[i]),
              " - ", as.character(age[i+1]), "]", sep = "")  
    }
  }

  events <- matrix(0, ncol = n.cols, nrow = n.rows)
  exposure <- matrix(0, ncol = n.cols, nrow = n.rows)
  intensity <- matrix(0, ncol = n.cols, nrow = n.rows)
  rownames(events) <- row.name
  rownames(exposure) <- row.name
  rownames(intensity) <- row.name
  if(n.cols > 1){
    colnames(events) <- col.name
    colnames(exposure) <- col.name
    colnames(intensity) <- col.name
  }
  
  for (i in 1:n.rows){
    per.dat <- cal.window(surv, c(period[i], period[i + 1]))
    if (nrow(per.dat) > 0){
      for (j in 1:n.cols){
        pa.dat <- age.window(per.dat, c(age[j], age[j + 1]))
        nr <- nrow(pa.dat)
        if (nr > 0){
          events[i, j] <- sum(pa.dat$event)
          exposure[i, j] <- sum(pa.dat$exit - pa.dat$enter)
          intensity[i, j] <- events[i, j] / exposure[i, j]
        }else{
          intensity[i, j] <- NaN
        }
      }
    }else{
      for (j in 1:n.cols){
        intensity[i, j] <- NaN
      }
    }
  }
    
  list(events = events,
       exposure = exposure,
       intensity = intensity)
}
          
# Piecewise constant hazards...(C) Gran Brostrm (2002).

piecewise <- function(enter, exit, event, cutpoints){
  n <- length(cutpoints) + 1 ## No. of time intervals.
  d <- numeric(n) ## Events
  tt <- numeric(n) ## Risk times

  # assume 0 <= enter < exit < \infty.

  nn <- length(enter) ## Check length(exit), length(event), etc.

  ## First interval:
  d[1] <- sum( event[( (exit <= cutpoints[1]) & (exit > 0) )] )
  left <- pmin( enter, cutpoints[1] )
  right <- pmin( exit, cutpoints[1] )
  tt[1] <- sum(right - left)

  ## Intervals 2, ..., (n - 1):
  for ( j in 2:(n-1) ){
    d[j] <- sum( event[( (exit <= cutpoints[j]) &
                        (exit > cutpoints[j-1]) )] )
    left <- pmin( pmax(enter, cutpoints[j-1]), cutpoints[j])
    right <- pmax( pmin(exit, cutpoints[j]), cutpoints[j-1] )
    tt[j] <- sum(right - left)
  }

  ## Last interval:
  d[n] <- sum( event[ (exit > cutpoints[n - 1]) ] )
  left <- pmax( enter, cutpoints[n-1] )
  right <- pmax( exit, cutpoints[n-1] )
  tt[n] <- sum(right - left)

  intensity <- ifelse(tt > 0, d / tt, NA)
  list(deaths = d, exposure = tt, hazard = intensity)
}
plot.cum <- function(x, ## A survival object
                     group = rep(1, length(exit)),
                     main = "Cumulative hazards function(s)",
                     xlab = "Duration",
                     ylab = "",
                     log.scale = FALSE, ...
                     )
  {

    require(survival)
        ## Check input data:
    if (!inherits(x, "Surv")) 
      stop("First arg must be of type 'Surv'")

    if (ncol(x) == 3){
      enter <- x[, 1]
      exit <- x[, 2]
      event <- x[, 3]
      n <- length(exit)
    }else{
      exit <- x[, 1]
      n <- length(exit)
      enter <- rep(0, n)
      event <- x[, 2]
    }

 
    if (length(enter) != n) stop("enter and exit must have equal length.")
    if (length(event) != n) stop("event and exit must have equal length.")
    if (length(group) != n) stop("group and exit must have equal length.")
    if (min(exit - enter) <= 0) stop("Interval lengths must be positive.") 

    if (is.factor(group)){
      strata <- levels(group)
    }else{
      group <- as.character(group)
      strata <- sort(unique(group))
    }
    no.of.groups <- length(strata)
    if (no.of.groups > 9)
      stop("Too many groups. No more than 9 are allowed.")
     
    ## Check for ylim, xlim in coming plots:
    y.max <- 0
    y.min <- 1
    x.max <- 0
    x.min <- 1e103
    for (stratum in strata)
      {
        atom <- table.events(enter[group == stratum],
                        exit[group == stratum],
                        event[group == stratum])
        y.max <- max( y.max, sum(atom$events / atom$riskset.sizes) )
        y.min <- min(y.min, atom$events[1] / atom$riskset.sizes[1])
        x.max <- max(x.max, atom$times)
        x.min <- min(x.min, atom$times[1])
      }

    ## Start plotting:        
    gang <- 0

    for (stratum in strata)
      {
        atom <- table.events(enter[group == stratum],
                             exit[group == stratum],
                             event[group == stratum])
        
        gang <- gang + 1

        if (log.scale)
          {
            xy <- "xy"
            if (x.min <= 0) x.min <- x.max / 100
            cum <- c(cumsum(atom$events / atom$riskset.sizes))
          }
        else
          {
            xy <- ""
            y.min <- 0
            atom$times <- c(0, atom$times) 
            cum <- c(0, cumsum(atom$events / atom$riskset.sizes))
          }
        n.po <- length(cum)
        x.po <- c(atom$times[1], rep(atom$times[-1], rep(2, n.po - 1)))
        y.po <- c(rep(cum[-n.po], rep(2, n.po - 1)), cum[n.po])
        if (gang == 1)
          {
            plot(x.po, y.po, type = "l",
                 xlab = xlab, ylab = ylab, 
                 main = main, log = xy,
                 xlim = c(x.min, x.max), ylim = c(y.min, y.max),
                 lty = gang%%(no.of.groups + 1), ...)
            abline(h = 0)
          }
        else
          {
            lines(x.po, y.po, type = "l",  
                  lty = gang%%(no.of.groups + 1))
          }
        if (no.of.groups > 1)
          {
            colors <- (1:no.of.groups)%%(no.of.groups + 1)
            legend(x.min, y.max, lty = colors, legend = strata)
          }
      }
  }
plot.Surv <- function(x,  ## A survival object
                      strata = rep( 1, length(exit) ),
                      limits = FALSE,
                      conf = 0.95,
                      xlim = NULL,
                      ylim = NULL,
                      main = "Survivor function(s)",
                      xlab = "Duration",
                      ylab = "Remaining fraction",
                      ...)
  {
    require(survival)
    ## Input data:
    ##
    ## enter : left truncation point
    ## exit  : exit time point
    ## event : if zero, a censored observation; otherwise an event.
    ## strata : one curve for each value of strata.
    ## limits: if TRUE, and only one strata, pointwise confidence
    ##         limits (Greenwoods formula, log(-log) type.
    ## conf  : confidence level. Can be given as a percentage.
    
    ## Check input data:
    if (!inherits(x, "Surv")) 
      stop("First arg must be of type 'Surv'")

    if (ncol(x) == 3){
      enter <- x[, 1]
      exit <- x[, 2]
      event <- x[, 3]
      n <- length(exit)
    }else{
      exit <- x[, 1]
      n <- length(exit)
      enter <- rep(0, n)
      event <- x[, 2]
    }

    if (is.na(strata)) strata <- rep(1, n)
    if (length(enter) != n)stop("enter and exit must have equal length.")
    if (length(event) != n)
      stop("event and exit must have equal length.")
    if (length(strata) != n)
      stop("strata and exit must have equal length.")
    if (min(exit - enter) <= 0) stop("Interval length must be positive.")
    if (conf > 1) conf <- conf / 100 ## conf given as a percentage(?)
    if ( (conf < 0.5) | (conf >=1) ) stop("Bad conf value")

    grupp <- as.character(strata)
   
    strata <- sort(unique(grupp))
    no.of.groups <- length(strata)
    if (no.of.groups > 9)
      stop("Too many groups. No more than 9 are allowed.")
    
    ##
    if (length(strata) > 1) limits <- FALSE # No limits if multiple curves.

    ## Check xmin, xmax:

    if ( is.null(xlim) ){
      x.max <- max(exit) ## Must be better?!
      x.min <- 0
      xlim = c(0, x.max)
    }else{
      x.min <- xlim[1]
      x.max <- xlim[2]
    }

    
    if ( is.null(ylim) ){
      ylim = c(0, 1)
    }
      
    gang <- 0

    for (stratum in strata)
      {
        atom <- table.events(enter[grupp == stratum],
                             exit[grupp == stratum],
                             event[grupp == stratum])
        
        gang <- gang + 1
        surv <- c( 1, cumprod(1 - atom$events / atom$riskset.sizes) )
        if (gang == 1)
          {
            X <- rep(c(0, atom$times), each = 2)[-1]
            Y <- rep(surv, each = 2)[-2*length(surv)]
            plot(X, Y, type = "l",
                 xlab = xlab, ylab = ylab,
                 main = main, xlim = xlim, ylim = ylim,
                 lty = gang%%no.of.groups + 1, ...)
            if (limits) ## Greenwood's formula,
                        ## Kalbfleisch & Prentice, p. 15 (note error!).
              {
                q.alpha <- abs(qnorm((1 - conf) / 2))
                survived <- (atom$riskset.size - atom$events)
                se <- sqrt(cumsum(atom$events /
                                  ( atom$riskset.sizes * survived )
                                  )
                           )/
                            cumsum(-log(survived / atom$riskset.sizes))
                upper <- surv ^ exp(q.alpha * c(0, se))
                lower <- surv ^ exp(-q.alpha * c(0, se))
                X <- rep(c(0, atom$times), each = 2)[-1]
                Y <- rep(upper, each = 2)[-2*length(upper)]

                lines(X, Y, type = "l",
                      lty = gang%%no.of.groups + 2)
                Y <- rep(lower, each = 2)[-2*length(lower)]
                lines(X, Y, type = "l",
                      lty = gang%%no.of.groups + 2)
              }
          }
        else
          {
            X <- rep(c(0, atom$times), each = 2)[-1]
            Y <- rep(surv, each = 2)[-2*length(surv)]
            lines(X, Y, type = "l", 
                  lty = gang%%no.of.groups + 1)
          }
      }
    abline(h = 0)
    abline(v = 0)
    if (no.of.groups > 1)
      {
        colors <- (1:no.of.groups)%%no.of.groups + 1
        legend(x.min, 0, xjust = 0, yjust = 0,
               legend = strata, lty = colors)
      }
  }
## Doesn't work with 'newdata'! Will be fixed.

plot.weibreg <- function(x, new.data = rep(0, length(x$means)), ...){
    if (!inherits(x, "weibreg")) stop("Works only with 'weibreg' objects.")
    ncov <- length(x$means)
    ns <- x$n.strata
    lambda <- exp(x$coefficients[ncov + (1:ns) * 2 - 1])
    p <- exp(x$coefficients[ncov + (1:ns) * 2])
    xlim <- c(min(x$y[, 1]), max(x$y[, 2]))
    
    npts <- 199
    xx <- seq(xlim[1], xlim[2], length = npts)
    if (xx[1] <= 0) xx[1] <- 0.001
    haz <- matrix(ncol = npts, nrow = ns)

    for (i in 1:ns){
        tl <- xx / lambda[i]
        haz[i, ] <- (p[i] / lambda[i]) *
            tl^(p[i]-1)## * exp(new.data[1:ncov] * x$coefficients[1:ncov])
    }

    ylim <- c(0, max(haz))

    plot(xx, haz[1, ], type = "l", xlim = xlim, ylim = ylim,
         xlab = "age", ylab = "hazard", main = "Webull hazards")
    if (ns > 1){
        for (i in 2:ns){
            lines(xx, haz[i, ], type = "l", lty = i)
        }
    }
}
print.coxreg <-
 function(x, digits=max(options()$digits - 4, 3), ...)
    {
    if (!is.null(cl<- x$call)) {
	cat("Call:\n")
	dput(cl)
	cat("\n")
	}
    if (!is.null(x$fail)) {
	cat(" coxreg failed.\n")
	return()
	}
    savedig <- options(digits = digits)
    on.exit(options(savedig))

    coef <- x$coef

    se <- sqrt(diag(x$var))

    wald.p <- formatC(1 - pchisq((coef/ se)^2, 1),
                      digits = 3,
                      width = 9, format = "f")
    if(is.null(coef) | is.null(se))
        stop("Input is not valid")
#####################################
    cat("Covariate           Mean       Coef  Rel.Risk      L-R p   Wald p\n")
    e.coef <- formatC(exp(coef), width = 9, digits = 3, format = "f")
    coef <- formatC(coef, width = 9, digits = 3, format = "f")
    se <- formatC(se, width = 9, digits = 3, format = "f")
    
    ett <-  formatC(1, width = 9, digits = 0, format = "f")
    noll <-  formatC(0, width = 5, digits = 0, format = "f")

    factors <- attr(x$terms, "factors")
    resp <- attr(x$terms, "response")
    row.strata <- attr(x$terms, "specials")$strata
    if (!is.null(row.strata))
      col.strata <- which(factors[row.strata, ] == 1)
    else col.strata <- NULL
    if (!is.null(col.strata)){
        factors <-
            attr(x$terms, "factors")[-c(resp, row.strata), -col.strata,
                                 drop = FALSE]
    }else{
        factors <-
            attr(x$terms, "factors")[-c(resp, row.strata), ,
                                     drop = FALSE]
    }

    covar.names <- x$covars
    term.names <- colnames(factors)

    isF <- x$isF

    ord <- attr(x$terms, "order")
    if (!is.null(col.strata)) ord <- ord[-col.strata]

    index <- 0

    for (term.no in 1:length(term.names)){

        if (ord[term.no] == 1){
            covar.no <- which(factors[, term.no] == 1)

            if (isF[covar.no]){ ## Factors:
                cat(covar.names[covar.no], "\n")
                ##p <- match(covar.names[covar.no], names(data))
                no.lev <- length(x$levels[[covar.no]])
                x$levels[[covar.no]] <-
                    substring(x$levels[[covar.no]], 1, 16)
                cat(format.char(x$levels[[covar.no]][1], 16, "+"),
                    formatC(x$w.means[[covar.no]][1],
                            width = 8, digits = 3, format = "f"),
                    noll,
                    ett,
                    "          (reference)\n")
                for (lev in 2:no.lev){
            ##cat("lev = ", lev, "\n")
                    index <- index + 1
                    cat(format.char(x$levels[[covar.no]][lev], 16, "+"),
                        formatC(x$w.means[[covar.no]][lev],
                                width = 8, digits = 3, format = "f"),
                        coef[index],
                        e.coef[index],
                        ## se[index],
                        format.char(" ", 9),
                        formatC(wald.p[index],
                                digits = 3,
                                width = digits + 2,
                                format = "f"),
                        ##signif(1 - pchisq((coef/ se)^2, 1), digits - 1),
                        "\n")
                }
            }else{ ## Covariates:
                index <- index + 1
                cat(format.char(covar.names[covar.no], 16),
                    formatC(x$w.means[[covar.no]],
                            width = 8, digits = 3, format = "f"),
                    coef[index],
                    e.coef[index],
                                        #exp(coef[index]),
                    ##se[index],
                    format.char(" ", 9),
                    formatC(wald.p[index],
                            digits = 3,
                            width = digits + 2,
                            format = "f"),
                    ##signif(1 - pchisq((coef/ se)^2, 1), digits - 1),
                    "\n")
            }
        }else if (ord[term.no] > 1){ ## Interactions:
            cat(format.char(term.names[term.no], 16), "\n")
            niv <- numeric(ord[term.no])
            covar.no <- which(factors[, term.no] == 1)

            for (i in 1:ord[term.no]){
                if (isF[covar.no[i]]){
                    niv[i] <- length(x$levels[[covar.no[i]]]) - 1
                }else{
                    niv[i] <- 1
                }
            }
            stt <- index + 1
            for (index in stt:(stt + prod(niv) - 1)){
                vn <- sub(covar.names[covar.no[1]], "", names(coef)[index])
                for (i in 1:ord[term.no]){
                    vn <- sub(covar.names[covar.no[i]], "", vn)
                }
                ##          cat(format.char(names(coef)[index], 15, "+"),
                cat(format.char(" ", 2),
                    format.char(substring(vn, 1, 22), 22, "-"),
                    ##format.char(" ", 8),
                    coef[index],
                    e.coef[index],
                    ##se[index],
                    format.char(" ", 9),
                    formatC(wald.p[index],
                            digits = 3,
                            width = digits + 2,
                            format = "f"),
                    ##signif(1 - pchisq((coef[index]/ se[index])^2, 1), digits - 1),
                    "\n")
            }
        }
        
    }
      
#####################################
    if(FALSE){
        tmp <- cbind(coef, exp(coef), se,
                     signif(1 - pchisq((coef/ se)^2, 1), digits - 1))
        dimnames(tmp) <- list(names(coef), c("coef", "rel. risk",
                                             "se(coef)", "p"))
        
        cat("\n")
        prmatrix(tmp)
    }

    if (!is.null(x$frailty)){
        cat("\nFrailty standard deviation = ", x$sigma, "\n")
        cat("                      S.E. = ", x$sigma.sd, "\n\n")
    }
    
    logtest <- -2 * (x$loglik[1] - x$loglik[2])
    if (is.null(x$df)) df <- sum(!is.na(coef))
    else  df <- round(sum(x$df),2)
    cat("\n")
    cat(format.char("Events", 25), x$events, "\n")
    cat(format.char("Total time at risk", 25),
        formatC(x$ttr, digits = 5, format = "fg"), "\n")
    cat(format.char("Max. log. likelihood", 25),
        formatC(x$loglik[2], digits = 5, format = "fg"), "\n")
    cat(format.char("LR test statistic", 25),
        format(round(logtest, 2)), "\n")
    cat(format.char("Degrees of freedom", 25),
        formatC(df, digits = 0, format = "f"), "\n")
    cat(format.char("Overall p-value", 25),
        format.pval(1 - pchisq(logtest, df), digits = 6, "\n"))
    cat("\n")
    if (length(x$icc))
	cat("   number of clusters=", x$icc[1],
	    "    ICC=", format(x$icc[2:3]), "\n")
    invisible()
    }
print.weibreg <-
 function(x, digits=max(options()$digits - 4, 3), ...)
    {
    if (!is.null(cl<- x$call)) {
	cat("Call:\n")
	dput(cl)
	cat("\n")
	}
    if (!is.null(x$fail)) {
	cat(" weibreg failed.\n")
	return()
	}
    savedig <- options(digits = digits)
    on.exit(options(savedig))

    if (x$pfixed){

        n.slsh <- 1

    }else{
        n.slsh <- 2 * x$n.strata

    }
    coef <- x$coef

    se <- sqrt(diag(x$var))
    wald.p <- formatC(1 - pchisq((coef/ se)^2, 1),
                      digits = 3,
                      width = 9, format = "f")
    if(is.null(coef) | is.null(se))
        stop("Input is not valid")
#####################################
    cat("Covariate           Mean       Coef  Rel.Risk      L-R p   Wald p\n")
    e.coef <- formatC(exp(coef), width = 9, digits = 3, format = "f")
    coef <- formatC(coef, width = 9, digits = 3, format = "f")
    se <- formatC(se, width = 9, digits = 3, format = "f")
    
    ett <-  formatC(1, width = 9, digits = 0, format = "f")
    noll <-  formatC(0, width = 5, digits = 0, format = "f")

    factors <- attr(x$terms, "factors")
    resp <- attr(x$terms, "response")
    row.strata <- attr(x$terms, "specials")$strata
    if (!is.null(row.strata))
      col.strata <- which(factors[row.strata, ] == 1)
    else col.strata <- NULL
    if (!is.null(col.strata)){
        factors <-
            attr(x$terms, "factors")[-c(resp, row.strata), -col.strata,
                                 drop = FALSE]
    }else{
        factors <-
            attr(x$terms, "factors")[-c(resp, row.strata), ,
                                     drop = FALSE]
    }

    covar.names <- c(x$covars,
                     names(x$coef)[(length(x$coef)-n.slsh + 1):length(x$coef)])
    term.names <- colnames(factors)

    isF <- x$isF

    ord <- attr(x$terms, "order")
    if (!is.null(col.strata)) ord <- ord[-col.strata]

    index <- 0

    for (term.no in 1:length(term.names)){

        if (ord[term.no] == 1){
            covar.no <- which(factors[, term.no] == 1)

            if (isF[covar.no]){ ## Factors:
                cat(covar.names[covar.no], "\n")

                no.lev <- length(x$levels[[covar.no]])
                cat(format.char(x$levels[[covar.no]][1], 16, "+"),
                    formatC(x$w.means[[covar.no]][1],
                            width = 8, digits = 3, format = "f"),
                    noll,
                    ett,
                    "          (reference)\n")
                for (lev in 2:no.lev){

                    index <- index + 1
                    cat(format.char(x$levels[[covar.no]][lev], 16, "+"),
                        formatC(x$w.means[[covar.no]][lev],
                                width = 8, digits = 3, format = "f"),
                        coef[index],
                        e.coef[index],

                        format.char(" ", 9),
                        formatC(wald.p[index],
                                digits = 3,
                                width = digits + 2,
                                format = "f"),
                        ##signif(1 - pchisq((coef/ se)^2, 1), digits - 1),
                        "\n")
                }
            }else{ ## Covariates:
                index <- index + 1
                cat(format.char(covar.names[covar.no], 16),
                    formatC(x$w.means[[covar.no]],
                            width = 8, digits = 3, format = "f"),
                    coef[index],
                    e.coef[index],
                                        #exp(coef[index]),
                    ##se[index],
                    format.char(" ", 9),
                    formatC(wald.p[index],
                            digits = 3,
                            width = digits + 2,
                            format = "f"),
                    ##signif(1 - pchisq((coef/ se)^2, 1), digits - 1),
                    "\n")
            }
        }else if (ord[term.no] > 1){ ## Interactions:
            cat(format.char(term.names[term.no], 16), "\n")
            niv <- numeric(ord[term.no])
            covar.no <- which(factors[, term.no] == 1)

            for (i in 1:ord[term.no]){
                if (isF[covar.no[i]]){
                    niv[i] <- length(x$levels[[covar.no[i]]]) - 1
                }else{
                    niv[i] <- 1
                }
            }
            stt <- index + 1
            for (index in stt:(stt + prod(niv) - 1)){
                vn <- sub(covar.names[covar.no[1]], "", names(coef)[index])
                for (i in 1:ord[term.no]){
                    vn <- sub(covar.names[covar.no[i]], "", vn)
                }

                cat(format.char(" ", 2),
                    format.char(substring(vn, 1, 22), 22, "-"),
                    ## format.char(" ", 8),
                    coef[index],
                    e.coef[index],
                    ##se[index],
                    format.char(" ", 9),
                    formatC(wald.p[index],
                            digits = 3,
                            width = digits + 2,
                            format = "f"),
                    ##signif(1 - pchisq((coef[index]/ se[index])^2, 1), digits - 1),
                    "\n")
            }
        }
        
    }
    cat("\n")
    for (i in 1:n.slsh){
        jup <- length(x$coef)
        ss.names <- names(x$coef[(jup - n.slsh + 1):jup])
        index <- index + 1
        covar.no <- covar.no + 1
        cat(format.char(ss.names[i], 16),
            formatC(0,
                    width = 8, digits = 3, format = "f"),
            coef[index],
            e.coef[index],
                                        #exp(coef[index]),
            ##se[index],
            format.char(" ", 9),
            formatC(wald.p[index],
                    digits = 3,
                    width = digits + 2,
                    format = "f"),
            ##signif(1 - pchisq((coef/ se)^2, 1), digits - 1),
            "\n")
    }
#####################################
    if(FALSE){
        tmp <- cbind(coef, exp(coef), se,
                     signif(1 - pchisq((coef/ se)^2, 1), digits - 1))
        dimnames(tmp) <- list(names(coef), c("coef", "rel. risk",
                                             "se(coef)", "p"))
        
        cat("\n")
        prmatrix(tmp)
    }
    logtest <- -2 * (x$loglik[1] - x$loglik[2])
    if (is.null(x$df)) df <- sum(!is.na(coef))
    else  df <- round(sum(x$df),2)
    cat("\n")
    cat(format.char("Events", 25), x$events, "\n")
    cat(format.char("Total time at risk", 25),
        formatC(x$ttr, digits = 5, format = "fg"), "\n")
    cat(format.char("Max. log. likelihood", 25),
        formatC(x$loglik[2], digits = 5, format = "fg"), "\n")
    cat(format.char("LR test statistic", 25),
        format(round(logtest, 2)), "\n")
    cat(format.char("Degrees of freedom", 25),
        formatC(df, digits = 0, format = "f"), "\n")
    cat(format.char("Overall p-value", 25),
        format.pval(1 - pchisq(logtest, df), digits = 6, "\n"))
    cat("\n")
    if (length(x$icc))
	cat("   number of clusters=", x$icc[1],
	    "    ICC=", format(x$icc[2:3]), "\n")
    invisible()
    }
# Calculate pointers from risk sets to their members.
# (C) Gran Brostrm (2002).

risksets <- function (x, strata = NULL, max.survs = NULL){
  ## x is a Surv (survival) object.

  nn <- NROW(x)
  if (is.null(strata)){
      strata <- rep(1, nn)
  }else{
      if (length(strata) != nn) stop("'strata' has wrong length")
      else
          strata <- as.integer(factor(strata))
  }

  if (is.null(max.survs)) max.survs <- nn - 1
  if (NCOL(x) == 2){
      enter <- numeric(nn)
      exit <- x[, 1]
      event <- (x[, 2] != 0)
  }else{
      if (NCOL(x) != 3) stop("'x' is not a Surv object")
      enter <- x[, 1]
      exit <- x[, 2]
      event <- (x[, 3] != 0) ## TRUE == event
  }

  ord <- order(strata, exit, -event)
  strata <- strata[ord]
  enter <- enter[ord]
  exit <- exit[ord]
  event <- event[ord]
  w.totrs <- sum(nn) ## Working 'totrs'
  ns <- max(strata)
  nstra <- c(0, cumsum(table(strata)))
  
  counts <- .C("sizes",
               as.integer(ns),
               as.integer(nn), 
               as.double(enter),
               as.double(exit),
               as.integer(event),
               ##
               antrs = integer(ns),
               as.integer(nstra),
               risktimes = double(w.totrs),
               ##
               n.events = integer(w.totrs),
               size = integer(w.totrs),
               totrs = integer(1),
               PACKAGE = "eha")

  counts$risktimes <- counts$risktimes[1:counts$totrs]
  counts$n.events <- counts$n.events[1:counts$totrs]
  counts$size <- counts$size[1:counts$totrs]

  totsize <- sum(counts$size)
  totevents <- sum(counts$n.events)

  res <- .C("risk_get",
            as.integer(max.survs),
            as.integer(nn),
            as.integer(ns),
            ##
            as.double(enter),
            as.double(exit),
            as.integer(event),
            ##
            as.integer(nstra),
            as.integer(length(nstra)),
            ##
            new.totrs = integer(1),  ## If sampling...
            ##
            as.integer(counts$antrs),
            as.integer(counts$n.events),
            size = as.integer(counts$size), ## If sampling...
            as.double(counts$risktimes),
            eventset = integer(totevents),
            riskset = integer(totsize),
            PACKAGE = "eha")
            
  list(ns = ns,
       antrs = counts$antrs,
       risktimes = counts$risktimes,
       n.events = counts$n.events,
       size = res$size,
       eventset = ord[res$eventset],
       riskset = ord[res$riskset[1:res$new.totrs]])
}
summary.coxreg <- function(object, ...) print(object)
summary.weibreg <- function(object, ...) print(object)
table.events <- function(enter = rep(0, length(exit)),
                         exit,
                         event)
{
  n <- length(exit)

  ## Check input data:
  if ( length(enter) != n ) stop("enter and exit must have equal length.")
  if ( length(event) != n ) stop("event and exit must have equal length.")
  ##
  
  event <- (event != 0) ## 0 (FALSE) = censoring, else (TRUE) = event

  times <- c(unique(sort(exit[event])))
  nn <- length(times)

  rs.size <- double(nn)
  n.events <- double(nn)

  for (i in 1:nn) ## Try to avoid this loop!
    {
      rs.size[i] <- sum( (enter < times[i]) &
                        (exit >= times[i]) )
      n.events[i] <- sum( (exit == times[i]) & event )
    }

  stop.at <- which(rs.size == n.events)
  if (length(stop.at))
    {
      stop.at <- min(stop.at) - 1
      if (stop.at <= 0) stop("Bad data. All died immediately!")
      times <- times[1:stop.at]
      n.events <- n.events[1:stop.at]
      rs.size <- rs.size[1:stop.at]
    }
      
  return ( list(times         = times,
                events        = n.events,
                riskset.sizes = rs.size)
          )
}

# Weibull regression for left truncated and right censored data.
# (C) Gran Brostrm (1982-2003).

weibreg <-
function (formula = formula(data),
          data = parent.frame(), 
          na.action = getOption("na.action"),
          init,
          shape = 0, ## Means shape is estimated, ie true Weibull; > 0 fixed!
          control = list(eps = 1e-4, maxiter = 10, trace = FALSE),
          singular.ok = TRUE,
          model = FALSE, 
          x = FALSE,
          y = TRUE) 
{

    pfixed <- (shape > 0)
    call <- match.call()
    m <- match.call(expand.dots = FALSE)
    temp <- c("", "formula", "data", "na.action")
    m <- m[match(temp, names(m), nomatch = 0)]
 
    special <- "strata"
    Terms <- if (missing(data)) 
        terms(formula, special)
    else terms(formula, special, data = data)
    m$formula <- Terms
    m[[1]] <- as.name("model.frame")
    m <- eval(m, parent.frame())

    Y <- model.extract(m, "response")
    if (!inherits(Y, "Surv")) 
        stop("Response must be a survival object")

    weights <- model.extract(m, "weights")
    offset <- attr(Terms, "offset")
    tt <- length(offset)
    offset <- if (tt == 0) 
        rep(0, nrow(Y))
    else if (tt == 1) 
        m[[offset]]
    else {
        ff <- m[[offset[1]]]
        for (i in 2:tt) ff <- ff + m[[offset[i]]]
        ff
    }
    attr(Terms, "intercept") <- 1
    strats <- attr(Terms, "specials")$strata
    dropx <- NULL

    if (length(strats)) {
        temp <- untangle.specials(Terms, "strata", 1)
        dropx <- c(dropx, temp$terms)
        if (length(temp$vars) == 1) 
            strata.keep <- m[[temp$vars]]
        else strata.keep <- strata(m[, temp$vars], shortlabel = TRUE)
        strats <- as.numeric(strata.keep)
    }
    if (length(dropx)) 
        newTerms <- Terms[-dropx]
    else newTerms <- Terms
    X <- model.matrix(newTerms, m)
    assign <- lapply(attrassign(X, newTerms)[-1], function(x) x - 
        1)
    X <- X[, -1, drop = FALSE]

    #########################################

    if (length(dropx)){
      covars <- names(m)[-c(1, (dropx + 1))]
    }else{
      covars <- names(m)[-1]
    }

    isF <- logical(length(covars))
    for (i in 1:length(covars)){
      if (length(dropx)){
        isF[i] <- ( is.factor(m[, -(dropx + 1)][, (i + 1)]) ||
                   is.logical(m[, -(dropx + 1)][, (i + 1)]) )
      }else{
        isF[i] <- ( is.factor(m[, (i + 1)]) ||
                   is.logical(m[, (i + 1)]) )
      }      
    }

    if (ant.fak <- sum(isF)){
      levels <- list()
      index <- 0
      for ( i in 1:length(covars) ){
        if (isF[i]){
          index <- index + 1
          if (length(dropx)){
            levels[[i]] <- levels(m[, -(dropx + 1)][, (i + 1)])
          }else{
            levels[[i]] <- levels(m[, (i + 1)])
          }
        }else{
          ##cat("NULL level no  ", i, "\n")
          levels[[i]] <- NULL
        }
      }
    }else{
      levels <- NULL
    }

    ##########################################
    type <- attr(Y, "type")
    if (type != "right" && type != "counting") 
        stop(paste("Cox model doesn't support \"", type, "\" survival data", 
            sep = ""))

    if (NCOL(Y) == 2){
      Y <- cbind(numeric(NROW(Y)), Y)
    }

    n.events <- sum(Y[, 3] != 0)
    if (n.events == 0) stop("No events; no sense in continuing!")
    if (missing(init)) 
        init <- NULL

    if (is.list(control)){
      if (is.null(control$eps)) control$eps <- 1e-4
      if (is.null(control$maxiter)) control$maxiter <- 10
      if (is.null(control$trace)) control$trace <- FALSE
    }else{
      stop("control must be a list")
    }

    fit <- weibreg.fit(X,
                       Y,
                       strats,
                       offset,
                       init,
                       shape,
                       control)
    if (pfixed){
        coef.names <- c(colnames(X), "log(scale)")
    }else{
        coef.names <- colnames(X)
        if (fit$n.strata > 1){
            for (i in 1:fit$n.strata){
                coef.names <- c(coef.names,
                                paste("log(scale)", as.character(i), sep =":"),
                                paste("log(shape)", as.character(i), sep =":"))
            }
        }else{
            coef.names <- c(coef.names,
                            "log(scale)", "log(shape)")
        }                
        
    }

    cat("fit$fail = ", fit$fail, "\n")
    if (!fit$fail){
        fit$fail <- NULL
    }else{
        out <- paste("Singular hessian; suspicious variable No. ",
                     as.character(fit$fail), ":\n",
                     coef.names[fit$fail], " = ",
                     as.character(fit$value),
                     "\nTry running with fixed shape", sep = "")
        stop(out)
      }


    fit$convergence <- as.logical(fit$conver)
    fit$conver <- NULL ## Ugly!

###########################################################################    
## Crap dealt with ......
    
    if (is.character(fit)) {
        fit <- list(fail = fit)
        class(fit) <- "mlreg"
    }
    else if (is.null(fit$fail)){
        if (!is.null(fit$coef) && any(is.na(fit$coef))) {
            vars <- (1:length(fit$coef))[is.na(fit$coef)]
            msg <- paste("X matrix deemed to be singular; variable", 
                paste(vars, collapse = " "))
            if (singular.ok) 
                warning(msg)
            else stop(msg)
        }
        fit$n <- nrow(Y)
        fit$terms <- Terms
        fit$assign <- assign
        if (FALSE){ ## Out-commented...(why?)
            if (length(fit$coef) && is.null(fit$wald.test)) {
                nabeta <- !is.na(fit$coef)
                if (is.null(init)) 
                    temp <- fit$coef[nabeta]
                else temp <- (fit$coef - init)[nabeta]
                fit$wald.test <- coxph.wtest(fit$var[nabeta, nabeta], 
                                             temp, control$toler.chol)$test
            }
        }
        na.action <- attr(m, "na.action")
        if (length(na.action)) 
            fit$na.action <- na.action
        if (model) 
            fit$model <- m
        if (x) {
            fit$x <- X
            if (length(strats)) 
                fit$strata <- strata.keep
        }
        if (y) 
            fit$y <- Y
    }
    ##if (!is.null(weights) && any(weights != 1)) 
    ##    fit$weights <- weights

    ##########################################

    fit$isF <- isF
    fit$covars <- covars
    s.wght <- (Y[, 2] - Y[, 1])## * weights
    fit$ttr <- sum(s.wght)
    fit$w.means <- list()
    for (i in 1:length(fit$covars)){
        nam <- fit$covars[i]
        col.m <- which(nam == names(m))
        if (isF[i]){
            n.lev <- length(levels[[i]])
            fit$w.means[[i]] <- numeric(n.lev)
            for (j in 1:n.lev){
                who <- m[, col.m] == levels[[i]][j]
                fit$w.means[[i]][j] <-
                    sum( s.wght[who] ) / fit$ttr ## * 100, if in per cent
            }
        }else{
            fit$w.means[[i]] <- sum(s.wght * m[, col.m]) / fit$ttr
        }
    }

    ##########################################
    fit$levels <- levels
    fit$formula <- formula(Terms)
    fit$call <- call
    fit$events <- n.events 
    names(fit$coefficients) <- coef.names 
    class(fit) <- c("weibreg", "coxreg", "coxph")
    fit$means <- apply(X, 2, mean)
    fit$pfixed <- pfixed
    fit
}
weibreg.fit <- function(X, Y, strata, offset, init, shape, control){

  nn <- NROW(X)
  ncov <- NCOL(X)

  if (missing(strata) || is.null(strata)){ 
      strata <- rep(1, nn)
      ns <- 1
  }else{
      strata <- as.integer(factor(strata))
      ns <- max(strata)
  }

  if (length(strata) != nn) stop("Error in stratum variable")
  if (missing(offset) || is.null(offset)) 
    offset <- rep(0, nn)

  if (missing(init) || is.null(init)) 
    init <- rep(0, ncov)
  if (length(init) != ncov) stop("Error in init")

  printlevel <- control$trace
  iter <- control$maxiter

  if (shape <= 0){

      bdim <- ncov + 2 * ns
      if (ns > 0){
          ord <- order(strata)
          X <- X[ord, ]
          Y <- Y[ord, ]
          offset <- offset[ord]
          nstra <- c(0, cumsum(table(strata)))
      }
      X <- scale(X, center = TRUE, scale = FALSE)
      fit <- .C("weibsup",
                iter = as.integer(iter), #maxit on ip, actual on op.
                as.double(control$eps),
                as.integer(printlevel),
                                        #
                as.integer(ns), # No. of strata
                as.integer(nstra),
                as.integer(nn),
                as.integer(ncov),
                as.integer(bdim),
                                        #
                as.double(Y[, 1]),  ## 'enter'
                as.double(Y[, 2]),  ## 'exit'
                as.integer(Y[, 3]), ## 'event'
                                        #
                as.double(t(X)), ## NOTE transpose!
                as.double(offset),
                                        #
                as.double(init),     # 'start.beta'
                beta = double(bdim), # results -->
                lambda = double(ns),
                lambda.sd = double(ns),
                shape = double(ns),  ## "p"
                shape.sd = double(ns),
                                        #
                loglik = double(2), # [1] == start, [2] == maximized
                dloglik = double(bdim),
                variance = double(bdim * bdim),
                sctest = double(1),
                                        #
                conver = integer(1),
                fail = integer(1),
                #DUP = FALSE,
                PACKAGE = "eha")

      if (fit$fail) return(list(fail = fit$fail,
                                n.strata = ns,
                                value = fit$beta[fit$fail])
                           )
      
      for (i in 1:ns) ## Really a HACK !!!!!!!!!!!!!!!
          fit$beta[ncov + 2 * i - 1] <- -fit$beta[ncov + 2 * i - 1]
      fit$shape.fixed <- FALSE
  }else{  ## Exponential regression:
      if (ns >= 2) warning("'strata' is not meaningful for exponential regression.\n Include stratum variable as a factor in the model instead.")
      bdim <- ncov + 1
      X <- scale(X, center = TRUE, scale = FALSE)

      fit <- .C("expsup",
                iter = as.integer(iter), #maxit on ip, actual on op.
                as.double(control$eps),
                as.integer(printlevel),
                                        #
                as.integer(nn),
                as.integer(ncov),
                as.integer(bdim),
                #
                as.double(Y[, 1]),  ## 'enter'
                as.double(Y[, 2]),  ## 'exit'
                as.integer(Y[, 3]), ## 'event'
                #
                as.double(t(X)),
                as.double(offset),
                as.double(shape), ## "p"
                                        #
                as.double(init),     # 'start.beta'
                beta = double(bdim), # results -->
                lambda = double(1),
                lambda.sd = double(1),
                                        #
                loglik = double(2), # [1] == start, [2] == maximized
                dloglik = double(bdim),
                variance = double(bdim * bdim),
                sctest = double(1),
                                        #
                conver = integer(1),
                fail = integer(1),
                                        #DUP = FALSE,
                PACKAGE = "eha")
      if (fit$fail) return(list(fail = fit$fail,
                                n.strata = ns,
                                value = fit$beta[fit$fail])
                           )
      fit$shape.fixed <- TRUE
      fit$shape <- shape
      fit$shape.sd <- NULL  ## Not necessary!?!?
      fit$beta[bdim] <- -fit$beta[bdim] ## To get "1 / lambda"!
      ## Note; this is really a "hack"!!!!!!!!!!!!!!!
}

  lp <- offset + X %*% fit$beta[1:ncov]
  score <- exp(lp)
  ##cat("done!\n")
      
  if (!fit$fail)
    var <- matrix(fit$variance, bdim, bdim)
  else
    var <- NULL

  
  list(coefficients = fit$beta,
       var = var,
       loglik = fit$loglik,
       score = fit$sctest,
       linear.predictors = lp,
       means = apply(X, 2, mean),
       conver = fit$conver,
       fail = fit$fail,
       iter = fit$iter,
       n.strata = ns
       )
       
}
# 'For internal use'

wfunk <- function(beta, lambda, p, X, Y,
                  offset = rep(0, NROW(X)),
                  ord = 2, pfixed = FALSE,
                    trace = TRUE){

## Returns loglik, score, and information (=-fpp) 
## For one stratum (only)!!

  nn <- NROW(Y)
  if (NCOL(Y) == 2) Y <- cbind(rep(0, nn), Y)
  mb <- NCOL(X)
  if (pfixed){
    bdim <- mb + 1
    b <- c(beta, log(lambda))
  }else{
    bdim <- mb + 2
    b <- c(beta, log(lambda), log(p))
  }
    
  fit <- .Fortran("wfunc", ## Returns -loglik, -score, +information
                  as.integer(ord),
                  as.integer(pfixed),
                  as.double(p),
                  as.integer(bdim),
                  as.integer(mb),
                  as.double(b),
                  #
                  as.integer(nn),
                  as.double(t(X)),
                  as.double(Y[, 1]), ## enter
                  as.double(Y[, 2]), ## exit
                  as.integer(Y[, 3]), ## event
                  as.double(offset),
                  #
                  f = double(1),
                  fp = double(bdim),
                  fpp = double(bdim * bdim), ok = integer(1),
                  PACKAGE = "eha")

  if (ord >= 2) fit$fpp <- matrix(fit$fpp, ncol = bdim)
  if (ord <= 1) fit$fpp <- NULL
  if (ord <= 0) fit$fp <- NULL
  list(f = -fit$f,
       fp = -fit$fp,
       fpp = fit$fpp)
}
           
.First.lib <- function(lib, pkg)
{
  if (!require(survival)) error("'survival' is essential!")
  library.dynam( "eha", pkg, lib )
}
