# $Id: bagging.R,v 1.18 2003/03/31 08:44:16 peters Exp $

bagging <- function(formula, data, ...) UseMethod("bagging", data)

bagging.default <- function(formula, data, ...)
  stop(paste("Do not know how to handle objects of class", class(data)))

bagging.data.frame <-
function(formula, data, subset, na.action=na.rpart, ...)
{
    cl <- match.call()
    if(missing(formula)
       || (length(formula) != 3)
       || (length(attr(terms(formula[-2]), "term.labels")) < 1)
       || (length(attr(terms(formula[-3]), "term.labels")) != 1))
        stop("formula missing or incorrect")
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)
    m[[1]] <- as.name("model.frame")
    m$... <- NULL
    mf <- eval(m, parent.frame())
    response <- attr(attr(mf, "terms"), "response")
    # just extract the data.frame, no handling of contrasts or NA's here.
    # this is done by rpart or the user supplied methods

    DATA <- list(y = mf[,response], X = mf[,-response]) 
    names(DATA) <- c("y", "X")
    y <- do.call("ipredbagg", c(DATA, list(...)))
    y$call <- cl
    return(y)
}

# $Id: bootest.R,v 1.17 2003/06/11 10:40:16 peters Exp $

bootest <- function(y, ...) {
  if(is.null(class(y)))
    class(y) <- data.class(y)
#  UseMethod("bootest", y, ...)
  UseMethod("bootest", y)
}

bootest.default <- function(y, ...) {
  stop(paste("Do not know how to handle objects of class", class(y)))
}

bootest.integer <- function(y, ...) {
  bootest.numeric(y, ...)
}

bootest.factor <- function(y, formula, data, model, predict, 
                           nboot=25, bc632plus=FALSE, ...) {
  
  # bootstrap estimator of misclassification error

  N <- length(y)
  nindx <- 1:N
  bootindx <- matrix(NA, ncol=nboot, nrow=N)
  classes <- levels(y)
  USEPM <- FALSE
  
  if(!is.data.frame(data)) stop("data is not a data.frame")
  if(nboot <=2) stop("to small number of bootstrap replications")
  if(is.null(nboot)) stop("number of bootstrap replications is missing")

  for(i in 1:nboot) {
    tindx <- sample(nindx, N, replace = TRUE)
    mymodel <- model(formula, data = data[tindx,], ...)

    # check if mymodel is a function which should be used instead of   
    # predict
    if (is.function(mymodel)) {
      if(!is.null(predict) & i == 1) 
        warning("model returns a function and predict is specified, using models output")
      predict <- mymodel
      USEPM <- TRUE
    }

    if (USEPM) 
      pred <- predict(newdata=data)
    else 
      pred <- predict(mymodel, newdata = data)
    if (!is.factor(pred)) stop("predict does not return factor values")
    pred <- factor(pred, levels=classes)[-tindx]
    if (length(pred) != length(y[-tindx]))
        stop("different length of data and prediction")

    bootindx[-tindx, i] <- (pred != y[-tindx])
  }

  fun <- function(x)
       ifelse(all(is.na(x)), NA, mean(as.integer(x), na.rm = TRUE))

  one <- mean(apply(bootindx, 1, fun), na.rm = TRUE)

  if (bc632plus) {
    full.model <- model(formula, data = data, ...)
    # check if full.model is a function which should be used instead of
    # predict
    if (is.function(full.model)) {
      predict <- full.model
      USEPM <- TRUE
    }

    if (USEPM)
      full.pred <- predict(newdata=data)
    else

    full.pred <- predict(full.model, newdata = data)
    resubst <- mean(full.pred != y, na.rm = TRUE)

    err632 <- 0.368*resubst + 0.632*one

    y <- y[!is.na(y) & !is.na(full.pred)]
    full.pred <- full.pred[!is.na(y) & !is.na(full.pred)]
    gamma <- sum(outer(y, full.pred, function(x, y) ifelse(x==y, 0, 1) ))/
                 (length(y)^2)
    r <- (one - resubst)/(gamma - resubst)
    r <- ifelse(one > resubst & gamma > resubst, r, 0)
    errprime <- min(one, gamma)
    #    weight <- .632/(1-.368*r)
    #    err <- (1-weight)*resubst + weight*one
    err <- err632 + (errprime - resubst)*(0.368*0.632*r)/(1-0.368*r)
    RET <- list(error = err, nboot=nboot, bc632plus=TRUE)
  } else {
    err <- one
    expb <- rep(0, nboot)
    for(i in 1:nboot)
      expb[i] <- mean(apply(bootindx[,-i], 1, fun), na.rm = TRUE)
    sdint <- sqrt( ((nboot - 1)/nboot)*sum((expb - mean(expb))^2) )
    RET <- list(error = err, sd=sdint, bc632plus=FALSE, nboot=nboot)
  }
  class(RET) <- "bootestclass"
  RET
}

bootest.numeric <- function(y, formula, data, model, predict, 
                           nboot=25, bc632plus=FALSE, ...) {
  
  # bootstrap estimator of root of mean squared error 

  if (bc632plus) stop("cannot compute 632+ estimator of mean squared error")
  if (nboot <=2) stop("to small number of bootstrap replications")

  N <- length(y)
  nindx <- 1:N
  bootindx <- matrix(NA, ncol=nboot, nrow=N)
  USEPM <- FALSE
  
  if (!is.data.frame(data)) stop("data is not a data.frame")

  if(is.null(nboot)) stop("number of bootstrap replications is missing")


  for(i in 1:nboot) {
    tindx <- sample(nindx, N, replace = TRUE)
    mymodel <- model(formula, data = data[tindx,], ...)
    outbootdata <- subset(data, !(nindx %in% tindx))
    # check if mymodel is a function which should be used instead of
    # predict
    if (is.function(mymodel)) {
      if(!is.null(predict) & i == 1) 
        warning("model returns a function and predict is specified, using models output")
      predict <- mymodel
      USEPM <- TRUE
    }

    if (USEPM)
      pred <- predict(newdata=outbootdata)
    else
      pred <- predict(mymodel, newdata = outbootdata)
    if (!is.numeric(pred)) stop("predict does not return numerical values")
    if (length(pred) != length(y[-tindx]))
        stop("different length of data and prediction")

    bootindx[-tindx, i] <- (pred - y[-tindx])^2
  }

  fun <- function(x)
        ifelse(all(is.na(x)), NA, mean(x, na.rm = TRUE))

  err <- sqrt(mean(apply(bootindx, 1, fun), na.rm = TRUE))
  RET <- list(error = err, nboot=nboot)
  class(RET) <- "bootestreg"
  RET
}

bootest.Surv <- function(y, formula, data=NULL, model, predict, 
                           nboot=25, bc632plus=FALSE, ...) {
  
  # bootstrap estimator of Brier's score

  if (bc632plus) stop("cannot compute 632+ estimator of Brier's score")

  N <- dim(y)[1]
  nindx <- 1:N
  bootindx <- matrix(NA, ncol=nboot, nrow=N)
  USEPM <- FALSE

  if(is.null(nboot)) stop("number of bootstrap replications is missing")
  if (nboot <=2) stop("to small number of bootstrap replications")
  if (is.null(data)) data <- as.data.frame(rep(1, N))
  if (!is.data.frame(data)) stop("data is not a data.frame")

  for(i in 1:nboot) {
    tindx <- sample(nindx, N, replace = TRUE)
    mymodel <- model(formula, data=data[tindx,], ...)
    outbootdata <- subset(data, !(nindx %in% tindx))
    # check if mymodel is a function which should be used instead of
    # predict
    if (is.function(mymodel)) {
      if(!is.null(predict) & i == 1) 
        warning("model returns a function and predict is specified, using models output")
      predict <- mymodel
      USEPM <- TRUE
    }

    if (USEPM)
      pred <- predict(newdata=outbootdata)
    else
      pred <- predict(mymodel, newdata = outbootdata)

    if (is.list(pred)) {
      if (!inherits(pred[[1]], "survfit") && !inherits(pred, "survfit"))
        stop("predict does not return a list of survfit objects")
    } else {
      stop("predict does not return a list of survfit objects")
    }

    bootindx[-tindx, i] <- sbrier(y[-tindx], pred)
  }

  fun <- function(x)
        ifelse(all(is.na(x)), NA, mean(x, na.rm = TRUE))

  err <- mean(apply(bootindx, 1, fun), na.rm = TRUE)
  RET <- list(error = err, nboot=nboot)
  class(RET) <- "bootestsurv"
  RET
}

# $Id: checkfunArgs.R,v 1.1 2003/02/17 09:49:31 hothorn Exp $

checkfunArgs <- function(fun, type=c("model", "predict")) {

  # check for appropriate arguments of user-supplied function "fun" 
  # this will not work for generics in R < 1.7.0 and therefore not used by
  # now

  type <- match.arg(type)

  if (!is.function(fun)) {
    warning("fun is not a function")
    return(FALSE)
  }

  funargs <- formals(fun)

  switch(type, "model"={
    if (!all(names(funargs)[1:2] %in% c("formula", "data"))) {
      warning("fun is not a function with at least 'formula' and 'data' arguments")
      return(FALSE)
    } else {
      return(TRUE)
    }
  }, "predict"={
    if (length(funargs) < 2) {
      warnings("fun is not a function with at least 'object' and 'newdata' arguments")
      return(FALSE)
    } else {
      return(TRUE)
    }
  })
}
#  $Id: csurv.R,v 1.6 2003/03/28 12:55:32 hothorn Exp $

csurv <- function(newdata, pred, minprob=0, window=0.0001) {

  N <- nrow(newdata)
  if (!"hazard" %in% names(attributes(newdata)))
    stop("hazards attribute to newdata missing")
  hazards <- attr(newdata, "hazard")

  error <- rep(0, N)

  # if there is only one prediction for all observations
  GETPROB <- TRUE
  if (inherits(pred, "survfit")) {
    times <- pred$time 			# get times
    predprob <- getsurv(pred, times)	# get steps
    GETPROB <- FALSE
  }

  for (i in 1:N) {
    if (GETPROB) {
      times <- pred[[i]]$time 		# get times
      predprob <- getsurv(pred[[i]], times)	# get steps
    }
    # compute the integrated squared difference between
    # KM and S(t)
    # minprob: stop integration when S(t) < minprob
    lasttime <- -(log(minprob) / hazards[i])
    if (max(times) > lasttime) {
      thisprob  <- predprob[times <= lasttime]
      thistimes <- times[times <= lasttime]
    } else {
      thisprob  <- predprob
      thistimes <- times
    }
    error[i] <- .Call("SdiffKM", as.double(c(0,thistimes)), 
                       as.double(c(1,thisprob)),
                       as.double(c(hazards[i], window)), PACKAGE="ipred")
    # adjust for time scale by last event
    error[i] <- error[i]/max(thistimes)
    if (length(unique(hazards)) == 1) {
      error <- error[i]
      break
    }
  }
  error <- mean(error)
  error
}

foo <- function (time, prob, hazard, window) 
{
    myint <- 0
    time <- c(0, time)
    s <- exp(-time * hazard)
    prob <- c(1, prob)
    for (i in 1:(length(time)-1)) {   
        d <- time[i+1] - time[i]
        if (d < window) {
            myint <- myint + 0.5 * d * ((prob[i] - s[i])^2 +
                (prob[i] - s[i + 1])^2)
        }
        else {
            k <- ceiling(d/window)
            wi <- d/k
            for (j in 1:k) myint <- myint + 0.5 * wi * ((prob[i] -
                exp(-(time[i] + (j - 1) * wi) * hazard))^2 +
                (prob[i] - exp(-(time[i] + j * wi) * hazard))^2)
        }
    }
    myint
}
#$Id: cv.R,v 1.19 2003/06/11 10:40:17 peters Exp $

cv <- function(y, ...) {
  if(is.null(class(y)))
    class(y) <- data.class(y)
#  UseMethod("cv", y, ...)
  UseMethod("cv", y)
}

cv.default <- function(y, ...) {
  stop(paste("Do not know how to handle objects of class", class(y)))
}

cv.integer <- function(y, ...) {
  cv.numeric(y, ...)
}

cv.factor <- function(y, formula, data, model, predict, k=10, random=TRUE, 
                      strat=FALSE, predictions=NULL, getmodels=NULL,...) {

  # k-fold cross-validation of misclassification error

  if (!is.data.frame(data)) stop("data is not of class data.frame")

  N <- length(y)
  classes <- levels(y)

  if (is.null(k)) k <- 10
  if (is.null(random)) random <- TRUE
  if (is.null(strat)) strat <- FALSE
  if (is.null(predictions)) predictions <- FALSE
  if (is.null(getmodels)) getmodels <- FALSE
  USEPM <- FALSE

  # to reproduce results, either use `set.seed' or a fixed partition of 
  # the samples
  if (random) 
    myindx <- sample(1:N, N)
  else 
    myindx <- 1:N

  y <- y[myindx]
  data <- data[myindx,]

  # determine an appropriate splitting for the sample size into
  # k roughly equally sized parts

  mysplit <- ssubset(y, k, strat=strat)

  allpred <- vector(mode="character", length=N)
  fu <- function(x) levels(x)[as.integer(x)]
  nindx <- 1:N

  if (getmodels)
    models <- vector(k, mode="list")

  for(i in 1:k) {
    tindx <- mysplit[[i]]
    folddata <- subset(data, !(nindx %in% tindx))
    mymodel <- model(formula, data=folddata, ...)
    if (getmodels) models[[i]] <- mymodel

    # check of mymodel is a function which should be used instead of
    # predict
    if (is.function(mymodel)) {
      if(!is.null(predict) & i == 1) 
        warning("model returns a function and predict is specified, using models output")
      predict <- mymodel
      USEPM <- TRUE
    }

    # we assume predict to return factor levels
    if (USEPM)
      pred <- predict(newdata=data)
    else 
      pred <- predict(mymodel, newdata = data)
    if (!is.factor(pred)) stop("predict does not return factor values")
    pred <- factor(pred, levels=classes)
    
    # <FIXME>
    # there is no c() for factors which preserves the levels, isn't it?
    # use characters
    allpred[tindx] <- fu(pred[tindx])
    # </FIXME>
  }
  allpred <- factor(allpred, levels=classes)
  allpred <- allpred[order(myindx)]
  err <- mean(allpred != y[order(myindx)], na.rm = TRUE)
  if (predictions)
    RET <- list(error = err, k = k, predictions=allpred)
  else 
    RET <- list(error = err, k = k)
  if (getmodels)
    RET <- c(RET, models=list(models))
  class(RET) <- "cvclass"
  RET
}

cv.numeric <- function(y, formula, data, model, predict, k=10, random=TRUE,
                       predictions=NULL, strat=NULL, getmodels=NULL,...) {

  # k-fold cross-validation of mean squared error 

  if (!is.data.frame(data)) stop("data is not of class data.frame");
  N <- length(y)

  if (is.null(k)) k <- 10
  if (is.null(random)) random <- TRUE
  if (is.null(predictions)) predictions <- FALSE
  if (is.null(getmodels)) getmodels <- FALSE   
  USEPM <- FALSE
  # determine an appropriate splitting for the sample size into
  # k roughly equally sized parts

  a <- kfoldcv(k, N)

  # to reproduce results, either use `set.seed' or a fixed partition of
  # the samples
  if (random)
    myindx <- sample(1:N, N)
  else
    myindx <- 1:N
  nindx <- 1:N

  if (getmodels)
    models <- vector(k, mode="list")

  allpred <- rep(0, N)
  for(i in 1:k) {
    if (i > 1)
      tindx <- myindx[(sum(a[1:(i-1)])+1):sum(a[1:i])]
    else
      tindx <- myindx[1:a[1]]
    
    folddata <- subset(data, !(nindx %in% tindx))
    mymodel <- model(formula, data=folddata, ...)
    if (getmodels) models[[i]] <- mymodel

    # check of mymodel is a function which should be used instead of
    # predict
    if (is.function(mymodel)) {   
      if(!is.null(predict) & i == 1) 
        warning("model returns a function and predict is specified, using models output")
      predict <- mymodel  
      USEPM <- TRUE  
    }  

    outfolddata <- subset(data, nindx %in% tindx)
    if (USEPM)
      pred <- predict(newdata=outfolddata)
    else
      pred <- predict(mymodel, newdata = outfolddata)
    if (!is.numeric(pred)) stop("predict does not return numerical values")
    allpred[sort(tindx)] <- pred
  }
  err <- sqrt(mean((allpred - y)^2, na.rm = TRUE))
  if (predictions)
    RET <- list(error = err, k = k, predictions=allpred)
  else
    RET <- list(error = err, k = k)
  if (getmodels) 
    RET <- c(RET, models=list(models))
  class(RET) <- "cvreg" 
  RET  
}

cv.Surv <- function(y, formula, data=NULL, model, predict, k=10, random=TRUE,
                    predictions=FALSE, strat=FALSE, getmodels=NULL, ...) {

  # k-fold cross-validation of Brier's score

  if (is.null(predictions)) predictions <- FALSE
  if(is.null(random)) random <- TRUE
  if (is.null(predictions)) predictions <- FALSE
  if (is.null(strat)) strat <- FALSE
  if (is.null(getmodels)) getmodels <- FALSE   
  USEPM <- FALSE

  N <- length(y[,1])
  nindx <- 1:N
  if(is.null(random)) random <- TRUE
  if(is.null(k)) k <- 10
  if (is.null(data)) data <- rep(1, N)
  
  if(is.null(k)) stop("k for k-fold cross-validation is missing")

  # determine an appropriate splitting for the sample size into
  # k roughly equally sized parts

  a <- kfoldcv(k, N)

  # to reproduce results, either use `set.seed' or a fixed partition of
  # the samples
  if (random)
    myindx <- sample(1:N, N)
  else
    myindx <- 1:N

  if (getmodels)
    models <- vector(k, mode="list")

  cverr <- c()
  for(i in 1:k) {
    if (i > 1)
      tindx <- myindx[(sum(a[1:(i-1)])+1):sum(a[1:i])]
    else
      tindx <- myindx[1:a[1]]

    folddata <- subset(data, !(nindx %in% tindx))
    mymodel <- model(formula, data=folddata, ...)
    if (getmodels) models[[i]] <- mymodel

    # check if mymodel is a function which should be used instead of
    # predict
    if (is.function(mymodel)) {   
      if(!is.null(predict) & i == 1) 
        warning("model returns a function and predict is specified, using models output")
      predict <- mymodel  
      USEPM <- TRUE  
    }  

    outfolddata <- subset(data, (nindx %in% tindx))
    if (USEPM)
      pred <- predict(newdata=outfolddata)
    else
      pred <- predict(mymodel, newdata = outfolddata)
    if (is.list(pred)) {
      if (!inherits(pred[[1]], "survfit") && !inherits(pred, "survfit"))
        stop("predict does not return a list of survfit objects")
    } else {
      stop("predict does not return a list of survfit objects")
    }

    err <- sbrier(y[sort(tindx)], pred)
    cverr <- c(cverr,rep(err, length(tindx)))
  }
  RET <- list(error = mean(cverr), k=k)
  if (getmodels) 
    RET <- c(RET, models=list(models))
  class(RET) <- "cvsurv" 
  RET  
}
       # $Id: errorest.R,v 1.22 2003/04/02 14:43:03 hothorn Exp $

control.errorest <- function(k= 10, nboot = 25, strat=FALSE,
                     random=TRUE, predictions=FALSE, getmodels=FALSE) {
  if (k < 1) { 
    warning("k < 1, using k=10")
    k <- 10
  }
  if (nboot < 1) {
    warning("nboot < 1, using nboot=25")
    nboot <- 25
  }
  if (!is.logical(strat)) {
    warning("strat is not a logical, using strat=FALSE")
    strat <- FALSE
  }
  if (!is.logical(random)) {
    warning("random is not a logical, using random=TRUE")
    random <- TRUE
  }
  if (!is.logical(predictions)) {
    warning("predictions is not a logical, using predictions=FALSE")
    predictions <- FALSE
  }

  if (!is.logical(getmodels)) {
    warning("getmodel is not a logical, using getmodels=FALSE")
    getmodels <- FALSE
  }

  RET <- list(k=k, nboot=nboot, strat=strat, random=random, 
              predictions=predictions, getmodels=getmodels)
  return(RET)
}

errorest <- function(formula, data, ...) UseMethod("errorest", data)

errorest.default <- function(formula, data, ...)
  stop(paste("Do not know how to handle objects of class", class(data)))

errorest.data.frame <- function(formula, data, subset, na.action=na.omit,
                     model=NULL, predict=NULL, 
                     estimator = c("cv", "boot", "632plus"),
                     est.para = control.errorest(), ...) {

  cl <- match.call()
  m <- match.call(expand.dots = FALSE)
  if (length(grep("inclass", paste(m$model))) > 0 || 
      length(grep("inbagg", paste(m$model))) > 0) {
    RET <- errorestinclass(formula, data=data, subset, na.action,
           model, predict, estimator, est.para, ...)
    RET$call <- cl
  } else { 

    if(missing(formula)
      || (length(formula) != 3)
      || (length(attr(terms(formula[-3]), "term.labels")) != 1))
    stop("formula missing or incorrect")
    NOPRED <- (length(attr(terms(formula[-2]), "term.labels")) < 1) 
    if(is.matrix(eval(m$data, parent.frame())))
    m$data <- as.data.frame(data)
    m[[1]] <- as.name("model.frame")
    m$... <- NULL
    m$model <- NULL
    m$predict <- NULL
    m$estimator <- NULL
    m$est.para <- NULL

    mf <- eval(m, parent.frame())

    response <- attr(attr(mf, "terms"), "response")
    # just extract the data.frame, NA handling here
    # make sure to leave the time and censoring variable here
    # for "Surv(time, cens) ~ ." formulas
    # delete terms attribute 
    attr(mf, "terms") <- NULL
    y <- mf[,response]
    if (!NOPRED & !is.Surv(y))
      data <- mf
    else
      data <- data[complete.cases(data),]

    estimator <- match.arg(estimator)

    if(is.null(model)) 
      stop("no model specified")

    switch(estimator, "cv" = {
      RET <- cv(y, formula, data, model=model, predict=predict, 
                k=est.para$k, random=est.para$random,
                predictions=est.para$predictions, strat=est.para$strat,
                getmodels=est.para$getmodels, ...)
    }, "boot" = {
      RET <- bootest(y, formula, data, model=model, predict=predict,
                     nboot=est.para$nboot, ...)
    }, "632plus" = {
      RET <- bootest(y, formula, data, model=model, predict=predict,
                     nboot=est.para$nboot, bc632plus=TRUE, ...)
    })
  }
  RET$call <- cl
  return(RET)
}

errorestinclass <- function(formula, data, subset=NULL, na.action=NULL, 
                     model=NULL, predict=NULL,
                     estimator = c("cv", "boot", "632plus"),
                     est.para = control.errorest(), ...) {
  if (is.null(data)) stop("data argument required but not given")
#  if (is.null(iclass)) 
#    stop("no class membership variable for indirect classification given")
  iclass <- paste(formula[[2]][[2]])
  if (!(iclass %in% colnames(data))) 
    stop("membership variable not in given data")

  # <FIXME> 
#  data <- data[complete.cases(data),]
  # </FIXME>

  iclassindx <- which(colnames(data) == iclass)

  y <- data[,iclassindx]
  if (!is.factor(y)) stop("iclass is not a factor")
#  X <- data[,-iclassindx]
  X <- data

  if(is.null(model))
      stop("no classifier specified")

  switch(estimator, "cv" = {
    RET <- cv(y, formula, data=X, model=model, predict=predict,
              k=est.para$k, random=est.para$random, ...)
    }, "boot" = {
      RET <- bootest(y, formula, data=X, model=model, predict=predict,
                     nboot=est.para$nboot, ...)
    }, "632plus" = {
      RET <- bootest(y, formula, data=X, model=model, predict=predict,
                     nboot=est.para$nboot, bc632plus=TRUE, ...)
  })
  RET
}
workhorse.inbagg <- function(object, y, X, W, 
  cFUN, w.training.set, y.training.set, bcontrol, control, ...)
{
  formula.list <- object
  data <- data.frame(y, X, W)
  mtrees <- vector(mode="list", length=bcontrol$nbagg)
  if(w.training.set[1] == "all") fit.vals <- 1:length(y)

  for (i in 1:bcontrol$nbagg) {
    bindx <- sample(1:length(y), bcontrol$ns, replace=bcontrol$replace)
    if(w.training.set[1] == "oob") fit.vals <- (-bindx)
    if(w.training.set[1] == "bag") fit.vals <- bindx

    objs <- vector(mode="list", length=length(formula.list))	#prediction models for intermediate variables
    names(objs) <- names(formula.list)

    addclass <- function() {					##START addclass <- function()
      for (j in 1:length(formula.list)) {			##Fitting prediction models for intermediates
        oX <- data[fit.vals, c(paste(formula.list[[j]]$formula[[2]]), attr(terms(formula.list[[j]]$formula), "term.labels"))]
        foo <- try(formula.list[[j]]$model(formula.list[[j]]$formula, data = oX))
        objs[[j]] <- foo
      }
     
      fct <- function(newdata) {				##START fct <- function(newdata)
        if (!is.data.frame(newdata))
          newdata <- as.data.frame(newdata)
        add.predictors <- rep(0, nrow(newdata))

        for (j in 1:length(formula.list)){			## predict additional intermediates using fitted models
          oXnewdata <- newdata[,attr(terms(formula.list[[j]]$formula), "term.labels")]
          if(is.null(formula.list[[j]]$predict)) {
            res <- try(predict(objs[[j]], newdata  = oXnewdata))
          } else {
            res <- try(formula.list[[j]]$predict(objs[[j]], newdata  = oXnewdata))
            }
###FIX: action for class(res) == "try-error"
          add.predictors <- data.frame(add.predictors, res)
        }
        add.predictors <- add.predictors[,-1]
        if(is.null(dim(add.predictors))) add.predictors <- matrix(add.predictors, ncol = 1)
        colnames(add.predictors) <- names(formula.list)
        add.predictors
      }
        					##END fct <- function(newdata)      
      return(fct)
    }						##END addclass <- function()


    bfct <- addclass()				###bfct is a function (addclass)

    if (!is.null(bfct)) {
      expl.cFUN <- attr(terms(as.formula(cFUN$formula)), "term.labels")

      if(!is.null(cFUN$fixed.function)) {
         btree <- cFUN
      } else {
        W.new <- bfct(X)
        W.new.names <- sub(".[0-9]$", "", colnames(W.new))

        if(y.training.set[1] == "fitted.bag") {	###contstruct on bag
          oX <- data.frame(y, X, W.new)[bindx,]
          right.side <- paste(c(expl.cFUN[!(expl.cFUN %in% W.new.names)], colnames(W.new)[W.new.names %in% expl.cFUN]), collapse = "+")
          cFUN$formula <- as.formula(paste(cFUN$formula[[2]], "~", right.side))
        }
		
        if(y.training.set[1] == "original") {	###construct on original variables
          if(length(W.new.names)> length(colnames(W))) stop("If classifying function is trained on original intermediate, only one predictive model per intermediate can be constructed.")
          oX <- data.frame(y, X, W[,W.new.names])
          names(oX)[(ncol(oX)-ncol(W)+1):ncol(oX)] <- colnames(W.new)
        }

        if(y.training.set[1] == "fitted.subset") {		###construct on subset
          oX <- data.frame(y, X, W.new)[!subset,]		
          right.side <- paste(c(expl.cFUN[!(expl.cFUN %in% W.new.names)], colnames(W.new)[W.new.names %in% expl.cFUN]), collapse = "+")
          cFUN$formula <- as.formula(paste(cFUN$formula[[2]], "~", right.side))
        }
        names(oX)[names(oX) == "y"] <- paste(cFUN$formula[[2]])
        btree <- cFUN$model(cFUN$formula, data = oX, ...)
        btree <- list(model = btree, predict = cFUN$predict)
      }

      this <- list(bindx = bindx, btree = btree, bfct=bfct)
    } else {
      stop("Predictive function for intermediates not executable: Classifying function can not be applied.")
    }
    class(this) <- "thisclass"
    mtrees[[i]] <- this
  }
  mtrees
}




inbagg <- function(formula, data, ...) UseMethod("inbagg", data)

inbagg.default <- function(formula, data,...)
{
  stop(paste("Do not know how to handle objects of class", class(data)))
}  


inbagg.data.frame <- function(formula, data, pFUN=NULL, 
 cFUN=list(model = NULL, predict = NULL, training.set = NULL), 
 nbagg = 25, ns = 0.5, replace = FALSE, ...)
{
  if(!is.function(cFUN) && is.null(cFUN$model)) {
    cFUN$model <-  function(formula, data) 
            rpart(formula, data, control = rpart.control(minsplit=2, cp=0, xval=0))
    if(is.null(cFUN$predict)) cFUN$predict <- function(object, newdata) predict(object, newdata, type = "class")
    if(is.null(cFUN$training.set))  cFUN$trainig.set <- "fitted.bag"
 }

##check formula
  if(missing(formula)
    || (length(formula) != 3)
    || (length(attr(terms(formula[-2]), "term.labels")) < 1))
    stop("formula missing or incorrect")

  m <- match.call(expand.dots = FALSE)
  if(is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)

##editing formula
  if(length(formula[[2]])==3) {
    if(!is.function(cFUN) && is.null(cFUN$formula)) y.formula <- as.formula(formula[[2]]) else y.formula <- cFUN$formula
  
    w.formula <- XX~YY
    w.formula[[2]] <- formula[[2]][[3]]
    w.formula[[3]] <- formula[[3]]

    response <-  paste(formula[[2]][[2]])
    w.names <- attr(terms(as.formula(formula[[2]])), "term.labels")
    x.names <- attr(terms(as.formula(formula)), "term.labels")

    if(length(x.names == 1) && x.names == ".") x.names <- colnames(data)[!(colnames(data) %in% c(response, w.names))]
    y <- data[, response]
    X <- data[, x.names]
    W <- data[, w.names]
    if(is.null(dim(X))) X <- matrix(X, ncol = 1, dimnames = list(rownames(W), x.names))
    if(is.null(dim(W))) W <- matrix(W, ncol = 1, dimnames = list(rownames(X), w.names))
                                    
    if(is.function(cFUN)) {
      y.formula <- as.formula(paste(formula[[2]][[2]], "~", paste(c(x.names, w.names), collapse = "+")))
      fixed.function <- cFUN
      cFUN <- list()
      cFUN$fixed.function <- fixed.function
    }
   cFUN$formula <- y.formula

  } else {
    stop(paste("Specified formula has to be of type y~x~w"))   
  }
##remove settings of training.set
  if(is.null(pFUN$training.set)) w.training.set <- "oob" else w.training.set <- pFUN$training.set[1]
  pFUN$training.set <- NULL

  if(is.null(cFUN$training.set)) y.training.set <- "fitted.bag" else y.training.set <- cFUN$training.set[1]
  cFUN$training.set <- NULL

  bcontrol <- list(nbagg = nbagg, ns = length(y)*ns, replace = replace)

  if(is.null(w.formula)) stop("no formula for prediction model specified")

  ##formula.list : list of lists which specify an abitrary number of models for intermediate variables:
  ##w1.1, w2.1, w3.1, ...., w2.1, w2.2, w3.1, .... where 'w*' is the variable and '.*' describes the model

  P <- length(pFUN)
  number.models <- c() 
  for(i in 1:P) {
    if(is.null(pFUN[[i]]$formula)) pFUN[[i]]$formula <- w.formula
    number.models <- c(number.models, paste(attr(terms(pFUN[[i]]$formula[-3]), "term.labels"), ".", i, sep = ""))
  }

  formula.list <- vector(mode = "list", length= length(number.models))
  names(formula.list) <- paste(number.models)

  for(i in 1:P) {  
    res <- list()  
    Qi <- length(attr(terms(pFUN[[i]]$formula[-3]), "term.labels"))
    for(j in 1:Qi) {
      res$formula <- w.formula
      res$formula[[2]] <- as.name(attr(terms(res$formula[-3]), "term.labels")[j])
      res$formula[[3]] <- pFUN[[i]]$formula[[3]]

      if(res$formula[[3]] == ".") res$formula <- as.formula(paste(res$formula[[2]], "~", paste(x.names, collapse= "+")))
      res$model <- pFUN[[i]]$model
      res$predict <- pFUN[[i]]$predict
      formula.list[[paste(res$formula[[2]], ".", i, sep = "")]] <- res
    }       
  }    

##apply
  res <- workhorse.inbagg(object = formula.list, y = y, X = X, W = W, 
    cFUN = cFUN, w.training.set = w.training.set, y.training.set = y.training.set, 
    bcontrol = bcontrol, control = control, ...)
  RET <- list(mtrees = res, y = y, W = W, X = X)
  class(RET) <- "inbagg"
  RET
}
 

print.inbagg <- function(x, ...)
{
  q <- length(x$mtrees)
  intermediates <- attr(x$W, "names")
  text.intermediates <- paste("Indirect bagging, with", q, 
    "bootstrap samples and intermediate variables: \n", 
    paste(intermediates, collapse = " "))
  cat("\n", text.intermediates, "\n")
}


summary.inbagg <- function(object, ...)
{
  class(object) <- "summary.inbagg"
  object
}


print.summary.inbagg <- function(x, ...)
{
  q <- length(x$mtrees)
  intermediates <- attr(x$W, "names")
 
  text.intermediates <- paste("Indirect bagging, with", q,
"bootstrap samples and intermediate variables:", paste(intermediates, collapse = " "))

  cat("\n", text.intermediates, "\n")
  for(i in 1:length(x)) {
    print(x$mtrees[[i]])
  }
}

# $Id: inclass.R,v 1.30 2003/07/22 14:56:31 peters Exp $

inclass <- function(formula, data, ...) UseMethod("inclass", data)

inclass.default <- function(formula, data,  ...)
{
  stop(paste("Do not know how to handle objects of class", class(data)))
}

inclass.data.frame <- function(formula, data, pFUN = NULL, cFUN = NULL, ...) 
{
##check formula
  if(missing(formula)
    || (length(formula) != 3)
    || (length(attr(terms(formula[-2]), "term.labels")) < 1))
    stop("formula missing or incorrect")

  m <- match.call(expand.dots = FALSE)
  if(is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)

##editing formula
###main formula
  if(length(formula[[2]])==3) {
    if(is.null(cFUN$formula)) y.formula <- formula[[2]] else y.formula <- cFUN$formula
    w.formula <- XX~YY
    w.formula[[2]] <- formula[[2]][[3]]
    w.formula[[3]] <- formula[[3]]

    response <-  paste(formula[[2]][[2]])
    w.names <- attr(terms(as.formula(formula[[2]])), "term.labels")
    x.names <- attr(terms(as.formula(formula)), "term.labels")

    if(x.names[1] == ".") x.names <- colnames(data)[!(colnames(data) %in% c(response, w.names))]
  } else {
    stop(paste("Specified formula has to be of type y~x~w"))   
  }


  if(is.null(w.formula)) stop("no formula for prediction model specified")

  formula.list <- vector(mode = "list", length= length(w.names))
  names(formula.list) <- w.names

  P <- length(pFUN)
  Qi <- length(w.names)
  for(j in 1:Qi) {
    res <- list()
    res$formula <- w.formula
    res$formula[[2]] <- as.name(attr(terms(res$formula[-3]), "term.labels")[j])
    if(attr(terms(res$formula), "term.labels")[1] == ".") {
      res$formula <- as.formula(paste(res$formula[[2]], "~", paste(x.names, collapse= "+")))
    }
    for(i in 1:P) {  
      if(is.null(pFUN[[i]]$formula)) {
        if(is.null(formula.list[[w.names[j]]]$formula)) formula.list[[w.names[j]]]$formula <- res$formula
        if(is.null(formula.list[[w.names[j]]]$model)) formula.list[[w.names[j]]]$model <- pFUN[[i]]$model
        if(is.null(formula.list[[w.names[j]]]$predict)) formula.list[[w.names[j]]]$predict <- pFUN[[i]]$predict
      } else {
        QQ <- attr(terms(pFUN[[i]]$formula[-3]), "term.labels")
        for(k in QQ) {
          if(w.names[j] == k) {
            res$formula[[3]] <- pFUN[[i]]$formula[[3]]
            if(paste(pFUN[[i]]$formula[[3]]) == ".") {
              res$formula[[3]] <- as.formula(paste(w.names[j], "~", paste(x.names, collapse= "+")))
            }
            formula.list[[w.names[j]]]$formula <- pFUN[[i]]$formula
            formula.list[[w.names[j]]]$model <- pFUN[[i]]$model
            formula.list[[w.names[j]]]$predict <- pFUN[[i]]$predict
          }
        }
      }       

    }
  }
                                                                                         
  if(!is.function(cFUN)) {
   cFUN$formula <- y.formula
   if(is.null(cFUN$training.set)) cFUN$training.set <- "original"
  }

  result <- workhorse.inclass(object = formula.list, data = data, cFUN = cFUN, ...)
  return(result)
}


workhorse.inclass <- function(object, data, cFUN, subset, na.action, ...) 
{
  formula.list <- object
  q <- length(formula.list)

  result <- list()
  namen <- c()

##model fitting
  for(i in 1:q) {
    formula <- formula.list[[i]]$formula
##check necessary?? >
    if(missing(formula)
      || (length(formula) != 3)
      || (length(attr(terms(formula[-2]), "term.labels")) < 1)
      || (length(attr(terms(formula[-3]), "term.labels")) != 1))
      stop("formula missing or incorrect")
## check necessary?? < 
    m <- match.call(expand.dots= FALSE)
    res <- formula.list[[i]]$model(formula = formula, data = data)

    namen <- c(namen, as.character(formula[[2]]))
    result <- c(result, list(res))
  }
  names(result) <- namen

  if(!is.function(cFUN)) {
 ###cFUN can be trained on original intermediate variables or on fitted values or on the subset
    if(!is.null(m$subset) && cFUN$training.set == "subset") dataresp <- data[!subset, ]
    if(cFUN$training.set == "original") dataresp <- data
    if(cFUN$training.set == "fitted") {
      dataresp <- data
      for(i in 1:q){
        if(!is.null(formula.list[[i]]$predict)){
         dataresp[,namen[i]] <- formula.list[[i]]$predict(result[[i]], newdata = data)} else {
         dataresp[,namen[i]] <- predict(result[[i]], newdata = data)
        }
      }
    }
    model.response <- cFUN$model(as.formula(cFUN$formula), data = dataresp, ...)
  } else {
    model.response <- cFUN
  }

###predict specificatiations are not delivered
  result <- list("model.intermediate" = result, "model.response" = model.response, "para.intermediate" = object, "para.response" = cFUN)

  class(result) <- "inclass"
  return(result)
}


print.inclass <- function(x, ...)
{
  x <- x$model.intermediate
  q <- length(x)
  intermediates <- attr(x, "names")
  classes <- c()
  for(i in 1:q) {
    classes <- c(classes, class(x[[i]]))
  }

  text.intermediates <- paste("Indirect classification, with", q, "intermediate variables:")
  if(length(unique(classes)) == 1) { 
    predictive  <- paste("Predictive model per intermediate is", unique(classes))
  } else {
    predictive  <- paste("Predictive model per intermediate is \n", 
                        paste(intermediates, ": ", classes, "\n  ", collapse = ""))
  }
  cat("\n", text.intermediates, "\n", intermediates, "\n", "\n", predictive, "\n")
}


summary.inclass <- function(object, ...)
{
  class(object) <- "summary.inclass"
  object
}


print.summary.inclass <- function(x, ...)
{
  x <- x$model.intermediate
  q <- length(x)
  intermediates <- attr(x, "names")
  classes <- c() 
  for(i in 1:q) {
    classes <- c(classes, class(x[[i]]))
  }

  text.intermediates <- paste("Indirect classification, with", q, "intermediate variables:")
  if(length(unique(classes)) == 1) { 
    predictive  <- paste("Predictive model per intermediate is", unique(classes))
  } else {
    predictive  <- paste("Predictive model per intermediate is", "\n ", 
                        paste(intermediates, ": ", classes, "\n  ", collapse = ""))
  }
  cat("\n", text.intermediates, "\n", intermediates, "\n", "\n", predictive,
        "\n", "\n", "Models:", "\n") 
  print(x)

}


#$Id: ipredbagg.R,v 1.13 2003/06/11 10:40:17 peters Exp $

workhorse <- function(y, X, control, comb, bcontrol, thisclass, ...) {
  # This is double-bagging (comb is lda) or bundling (any arbritrary
  # model in comb)
  if (!is.data.frame(X)) X <- as.data.frame(X)

  # check user supplied functions
  if (!is.list(comb)) stop("comb not a list")

  N <- nrow(X)

  mydata <- cbind(data.frame(y), X)
  mtrees <- vector(mode="list", length=bcontrol$nbagg)

  for (i in 1:bcontrol$nbagg) {
    # double-bagging or bundling
    # comb is a list of lists, each of them having two elements:
    # model and predict

    bindx <- sample(1:N, bcontrol$ns, replace=bcontrol$replace)

    objs <- vector(mode="list", length=length(comb))
    addclass <- function() {
      myindx <- 1:length(comb)
      for (k in 1:length(comb)) {
        # put the user supplied models into a try statement
        # if this fails, simply ignore it.
        # options(show.error.messages = FALSE)
        oX <- mydata[-bindx,]
        foo <- try(comb[[k]]$model(y ~ ., data=oX))
        if (inherits(foo, "try-error")) {
          warning("could not build model:")
          print(foo[1])
          foo <- NA
          myindx <- myindx[-k]
        } 
        objs[[k]] <- foo
        # options(show.error.messages = TRUE)
      }
      fct <- function(newdata) {
        # use lexical scoping: return this function for the computation of 
        # the additional predictors
        if (!is.data.frame(newdata))
          newdata <- as.data.frame(newdata)
        addpred <- c()
        # the user supplied model failed, ignore it here.
        if (length(myindx) < 1) {
          RET <- NULL 
        } else {
          # compute additional predictors for user supplied models
          for (k in myindx)
            addpred <- cbind(addpred, comb[[k]]$predict(objs[[k]], newdata))
          # <FIXME>: more informative names???
          colnames(addpred) <- paste("addpred", 1:ncol(addpred), sep="")
          # </FIXME>
          RET <- addpred
        }
        RET
      }
      if (length(myindx) < 1) return(NULL) else return(fct)
    }
    bfct <- addclass()
    # may have failed
    if (!is.null(bfct)) {
      # grow a tree using the original predictors
      # from the bootstrap sample and the additional predictors computed on
      # the bootstrap sample.
      oX <- cbind(mydata, bfct(X))[bindx,]
      btree <- rpart(y ~., data=oX, control = control,...)
      # return this object
      this <- list(bindx = bindx, btree = btree, bfct=bfct)
    } else {
      # return a simple tree if the user supplied model failed.
      oX <- mydata[bindx,]
      btree <- rpart(y ~., data=oX, control = control,...)
      this <- list(bindx = bindx, btree = btree)
    }
    class(this) <- thisclass
    mtrees[[i]] <- this
  }
  mtrees
}


ipredbagg <- function(y, ...) {
  if(is.null(class(y))) 
    class(y) <- data.class(y)
#  UseMethod("ipredbagg", y, ...)
  UseMethod("ipredbagg", y)
}

ipredbagg.default <- function(y, ...) {
  stop(paste("Do not know how to handle objects of class", class(y)))
}

ipredbagg.integer <- function(y, ...) {
  ipredbagg.numeric(y,...)
}


ipredbagg.factor <- function(y, X=NULL, nbagg=25, control=
                             rpart.control(minsplit=2, cp=0, xval=0), 
                             comb=NULL, coob=FALSE, ns=length(y), keepX = 
                             TRUE, ...) {
  # bagging classification trees

  if (!is.null(comb) && coob) 
    stop("cannot compute out-of-bag estimate for combined models")

  if (nbagg == 1 && coob) 
    stop("cannot compute out-of-bag estimate for single tree")

  # check nbagg
  if (nbagg < 1) stop("nbagg is not a positive integer")
  # bagging only if nbagg greater 1, else use the whole sample, i.e. one
  # simple tree
  if (nbagg == 1) { 
    REPLACE <- FALSE 
  } else {
    if (ns < length(y)) {
      # this is "subagging", i.e. sampling ns out of length(y) WITHOUT
      # replacement
      REPLACE <- FALSE 
    } else {
      # the usual bootstrap: n out of n with replacement
      REPLACE <- TRUE
    }
  }

  if (!is.null(comb)) {
    # this is rather slow but we need to be as general as possible
    # with respect to classifiers as well as outcome of prediction (classes,
    # linear discriminant functions, conditional class probabilities, random
    # noise, if you like)
    mtrees <- workhorse(y, X, control, comb,
                        bcontrol=list(nbagg=nbagg, ns=ns, replace=REPLACE),
                        thisclass="sclass")
  } else {
    # use an optimized version
    mydata <- cbind(data.frame(y), X)
    mtrees <- irpart(y ~ ., data=mydata, control=control,
                     bcontrol=list(nbagg=nbagg, ns=ns, replace=REPLACE))
  }
  # always keep response and predictors as well as a list of nbagg objects
  # of class "sclass" 
  if (keepX) 
    RET <- list(y=y, X=X, mtrees=mtrees, OOB=coob, comb=!is.null(comb))
  else 
    RET <- list(y=y, X=NULL, mtrees=mtrees, OOB=coob, comb=!is.null(comb))
  class(RET) <- "classbagg"

  if (coob) {
    pred <- predict(RET)
    ae <- all.equal(levels(pred), levels(RET$y))
    if (is.logical(ae) && ae)
       RET$err <- mean(pred != RET$y, na.rm=TRUE)
    else
       RET$err <- mean(as.character(pred) != as.character(RET$y), 
                       na.rm=TRUE)
   }
   RET
}

ipredbagg.numeric <- function(y, X=NULL, nbagg=25, control=
                             rpart.control(xval=0), 
                             comb=NULL, coob=FALSE, ns=length(y), keepX =
                             TRUE, ...) {
  # <FIXME> is control meaningful here??? </FIXME>

  # bagging regression trees

  if (!is.null(comb) && coob) 
    stop("cannot compute out-of-bag estimate for combined models")

  if (nbagg == 1 && coob) 
    stop("cannot compute out-of-bag estimate for single tree") 

  # check nbagg
  if (nbagg < 1) stop("nbagg is not a positive integer")
  # only bagg if nbagg greater 1, else use the whole sample 
  if (nbagg == 1) {
    REPLACE <- FALSE
  } else {
    if (ns < length(y)) {
      # this is "subagging", i.e. sampling ns out of length(y) WITHOUT
      # replacement
      REPLACE <- FALSE
    } else {
      # the usual bootstrap: n out of n with replacement
      REPLACE <- TRUE
    }
  }

  if (!is.null(comb)) {
    mtrees <- workhorse(y, X, control, comb,
                        bcontrol=list(nbagg=nbagg, ns=ns, replace=REPLACE),
                        thisclass="sreg")
  } else {
    mydata <- cbind(data.frame(y), X)
    mtrees <- irpart(y ~ ., data=mydata, control=control,
                     bcontrol=list(nbagg=nbagg, ns=ns, replace=REPLACE))
  }

  if (keepX) 
    RET <- list(y=y, X=X, mtrees=mtrees, OOB=coob, comb=!is.null(comb))
  else 
    RET <- list(y=y, X=NULL, mtrees=mtrees, OOB=coob, comb=!is.null(comb))
  class(RET) <- "regbagg"

  if (coob)
    RET$err <- sqrt(mean((predict(RET) - RET$y)^2, na.rm=TRUE))
  RET
}


ipredbagg.Surv <- function(y, X=NULL, nbagg=25, control=
                             rpart.control(xval=0), 
                             comb=NULL, coob=FALSE, ns=dim(y)[1], keepX =
                             TRUE, ...) {
  # <FIXME> is control meaningful here??? </FIXME>

  # bagging survival trees

  if (!is.null(comb) && coob) 
    stop("cannot compute out-of-bag estimate for combined models")

  if (nbagg == 1 && coob) 
    stop("cannot compute out-of-bag estimate for single tree") 

  # check nbagg
  if (nbagg < 1) stop("nbagg is not a positive integer")
  # only bagg if nbagg greater 1, else use the whole sample 
  if (nbagg == 1) {
    REPLACE <- FALSE
  } else {
    if (ns < dim(y)[1]) {
      # this is "subagging", i.e. sampling ns out of length(y) WITHOUT
      # replacement
      REPLACE <- FALSE
    } else {
      # the usual bootstrap: n out of n with replacement
      REPLACE <- TRUE
    }
  }

  if (!is.null(comb)) {
    mtrees <- workhorse(y, X, control, comb,
                        bcontrol=list(nbagg=nbagg, ns=ns, replace=REPLACE),
                        thisclass="ssurv")
  } else {
    mydata <- cbind(data.frame(y), X)
    mtrees <- irpart(y ~ ., data=mydata, control=control,
                     bcontrol=list(nbagg=nbagg, ns=ns, replace=REPLACE))
  }
  if (keepX) 
    RET <- list(y=y, X=X, mtrees=mtrees, OOB=coob, comb=!is.null(comb))
  else 
    RET <- list(y=y, X=NULL, mtrees=mtrees, OOB=coob, comb=!is.null(comb))
  class(RET) <- "survbagg"
  
  if (coob) 
    RET$err <- sbrier(RET$y, predict(RET))
  RET
}

# $Id: ipredknn.R,v 1.4 2003/03/31 08:44:16 peters Exp $

# k-NN compatible with the fit(formula) - predict(object) framework

ipredknn <- function(formula, data, subset, na.action, k=5, ...) {
    cl <- match.call()
    if(missing(formula)
       || (length(formula) != 3)
       || (length(attr(terms(formula[-2]), "term.labels")) < 1)
       || (length(attr(terms(formula[-3]), "term.labels")) != 1))
        stop("formula missing or incorrect")
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)
    m[[1]] <- as.name("model.frame")
    m$... <- NULL
    m$k <- NULL
    m <- eval(m, parent.frame())
    Terms <- attr(m, "terms")   
    y <- model.extract(m, "response")
    x <- model.matrix(Terms, m)
    xvars <- as.character(attr(Terms, "variables"))[-1]
    if ((yvar <- attr(Terms, "response")) > 0) xvars <- xvars[-yvar]
    xlev <- if (length(xvars) > 0) {
        xlev <- lapply(m[xvars], levels)
        xlev[!sapply(xlev, is.null)]
    }
    xint <- match("(Intercept)", colnames(x), nomatch=0)
    if(xint > 0) x <- x[, -xint, drop=FALSE]
    RET <- list(learn=list(y=y, X=x))
    RET$k <- k
    RET$terms <- Terms
    RET$call <- match.call()
    RET$contrasts <- attr(x, "contrasts")
    RET$xlevels <- xlev
    attr(RET, "na.message") <- attr(m, "na.message")
    if(!is.null(attr(m, "na.action"))) RET$na.action <- attr(m, "na.action")
    class(RET) <- "ipredknn"
    RET
}

predict.ipredknn <- function(object, newdata, type=c("prob", "class"), ...) {
    type <- match.arg(type)
    if(!inherits(object, "ipredknn")) stop("object not of class ipredknn")
    if(!is.null(Terms <- object$terms)) { #
    # formula fit (only)
        if(missing(newdata)) newdata <- model.frame(object)
        else {
            newdata <- model.frame(as.formula(delete.response(Terms)),
                                   newdata, na.action=function(x) x,  
                                   xlev = object$xlevels)
        }
        x <- model.matrix(delete.response(Terms), newdata,
                          contrasts = object$contrasts)   
        xint <- match("(Intercept)", colnames(x), nomatch=0)
        if(xint > 0) x <- x[, -xint, drop=FALSE]
    } else { 
      stop("object has no terms element")
    }
#    <FIXME>: check for variable names
#    if(length(colnames(x)) > 0 &&
#      any(colnames(x) != dimnames(object$means)[[2]]))
#         warning("Variable names in newdata do not match those in object")
#   </FIXME>
  RET <- knn(object$learn$X, x, 
             object$learn$y, k=object$k, prob=TRUE)
  if (type=="prob") return(attr(RET, "prob"))
  else return(RET)
}
#
#  a modified version of `rpart.s' from the rpart package
#  see COPYRIGHTS for details.
#
irpart <- function(formula, data=NULL, weights, subset,
		   na.action=na.rpart, method, model=FALSE, x=FALSE, y=TRUE,
		   parms, control, cost, bcontrol, ...)
{
    call <- match.call()
    if (is.data.frame(model)) {
	m <- model
	model <- FALSE
	}
    else {
	m <- match.call(expand=FALSE)
	m$model <- m$method <- m$control<- NULL
	m$x <- m$y <- m$parms <- m$... <- NULL
	m$cost <- NULL
        m$bcontrol <- NULL
	m$na.action <- na.action
	m[[1]] <- as.name("model.frame.default")
	m <- eval(m, parent.frame())
	}
    Terms <- attr(m, "terms")
    if(any(attr(Terms, "order") > 1))
	stop("Trees cannot handle interaction terms")

    Y <- model.extract(m, "response")
    wt <- model.extract(m, "weights")
    if(length(wt)==0) wt <- rep(1.0, nrow(m))
    offset <- attr(Terms, "offset")
    X <- getFromNamespace("rpart.matrix", ns = "rpart")(m)
    nobs <- nrow(X)
    nvar <- ncol(X)

    if (missing(method)) {
	if (is.factor(Y) || is.character(Y))      method <- 'class'
        else if (is.Surv(Y))   method <- 'exp'
	else if (is.matrix(Y)) method<- 'poisson'
	else                   method<- 'anova'
	}

    if (is.list(method)) {
	# User written split methods
	mlist <- method
	method <- 'user'

	if (missing(parms)) init <- mlist$init(Y, offset, wt=wt)
	else                init <- mlist$init(Y, offset, parms, wt)

	method.int <- 4      #the fourth entry in func_table.h

        ## assign this to avoid garbage collection
        keep <- rpartcallback(mlist, nobs, init)
    }
    else {
	method.int <- pmatch(method, c("anova", "poisson", "class", "exp"))
	if (is.na(method.int)) stop("Invalid method")
	method <- c("anova", "poisson", "class", "exp")[method.int]
	if (method.int==4) method.int <- 2

	if (missing(parms))
	  init <- getFromNamespace(paste("rpart", method, sep='.'), 
                     ns = "rpart")(Y,offset, ,wt)
	else
	  init <- getFromNamespace(paste("rpart", method, sep='.'), 
                     ns = "rpart")(Y,offset, parms, wt)
	}

    Y <- init$y

    xlevels <- attr(X, "column.levels")
    cats <- rep(0,ncol(X))
    if(!is.null(xlevels)) {
	cats[match(names(xlevels), dimnames(X)[[2]])] <-
		  unlist(lapply(xlevels, length))
	}

    # We want to pass any ... args to rpart.control, but not pass things
    #  like "dats=mydata" where someone just made a typo.  The use of ...
    #  is just to allow things like "cp=.05" with easier typing
    extraArgs <- list(...)
    if (length(extraArgs)) {
	controlargs <- names(formals(rpart.control))  #legal arg names
	indx <- match(names(extraArgs), controlargs, nomatch=0)
	if (any(indx==0))
		stop(paste("Argument", names(extraArgs)[indx==0],
			    "not matched"))
	}

    controls <- rpart.control(...)
    if (!missing(control)) controls[names(control)] <- control

    xval <- controls$xval
    if (is.null(xval) || (length(xval)==1 && xval==0) || method=='user') {
	xgroups <-0
	xval <- 0
	}
    else if (length(xval)==1) {
	# make random groups
        xgroups <- sample(rep(1:xval, length=nobs), nobs, replace=FALSE)
	}
    else if (length(xval) == nobs) {
	xgroups <- xval
	xval <- length(unique(xgroups))
	}
    else {
	# Check to see if observations were removed due to missing
	if (!is.null(attr(m, 'na.action'))) {
	    # if na.rpart was used, then na.action will be a vector
	    temp <- as.integer(attr(m, 'na.action'))
	    xval <- xval[-temp]
	    if (length(xval) == nobs) {
		xgroups <- xval
		xval <- length(unique(xgroups))
		}
	    else stop("Wrong length for xval")
	    }
	else stop("Wrong length for xval")
	}

    #
    # Incorporate costs
    #
    if (missing(cost)) cost <- rep(1.0, nvar)
    else {
	if (length(cost) != nvar)
		stop("Cost vector is the wrong length")
	if (any(cost <=0)) stop("Cost vector must be positive")
	}

    #
    # Have s_to_rp consider ordered categories as continuous
    #  A right-hand side variable that is a matrix forms a special case
    # for the code.
    #
    tfun <- function(x) {
	if (is.matrix(x)) rep(is.ordered(x), ncol(x))
	else is.ordered(x)
	}
    isord <- unlist(lapply(m[attr(Terms, 'term.labels')], tfun))

    # 
    # Bagging: repeat this several times!
    #

    if (is.null(bcontrol)) stop("bcontrol not given")
    mod <- vector(mode="list", length=bcontrol$nbagg)

    for (b in 1:bcontrol$nbagg) {
        if (bcontrol$nbagg > 1)
            bindx <- sample(1:nrow(X), bcontrol$ns, replace=bcontrol$replace)
        else
            bindx <- 1:nrow(X)

        if(is.null(dim(init$y)))
          by <- t(init$y[bindx])
        else
          by <- t(init$y[bindx,])
        bX <- X[bindx,]

        rpfit <- .C("s_to_rp",
		    n = as.integer(nobs),
		    nvarx = as.integer(nvar),
		    ncat = as.integer(cats* !isord),
		    method= as.integer(method.int),
		    as.double(unlist(controls)),
		    parms = as.double(unlist(init$parms)),
		    as.integer(xval),
		    as.integer(xgroups),
		    as.double(by),
		    as.double(bX),
		    as.integer(!is.finite(X)), # R lets Infs through
		    error = character(1),
		    wt = as.double(wt),
		    as.integer(init$numy),
		    as.double(cost),
		    NAOK=TRUE, PACKAGE="rpart")
        if (rpfit$n == -1)  stop(rpfit$error)

        # rpfit$newX[1:n] contains the final sorted order of the observations
        nodes <- rpfit$n          # total number of nodes
        nsplit<- rpfit$nvarx      # total number of splits, primary and surrogate
        numcp <- rpfit$method     # number of lines in cp table
        ncat  <- rpfit$ncat[1]    #total number of categorical splits
        numresp<- init$numresp    # length of the response vector

        if (nsplit == 0) xval <- 0
        cpcol <- if (xval>0 && nsplit>0) 5 else 3
        if (ncat==0) catmat <- 0
        else         catmat <- matrix(integer(1), ncat, max(cats))

        rp    <- .C("s_to_rp2",
		       as.integer(nobs),
		       as.integer(nsplit),
		       as.integer(nodes),
		       as.integer(ncat),
		       as.integer(cats *!isord),
		       as.integer(max(cats)),
		       as.integer(xval),
		       which = integer(nobs),
		       cptable = matrix(double(numcp*cpcol), nrow=cpcol),
		       dsplit =  matrix(double(1),  nsplit,3),
		       isplit =  matrix(integer(1), nsplit,3),
		       csplit =  catmat,
		       dnode  =  matrix(double(1),  nodes, 3+numresp),
		       inode  =  matrix(integer(1), nodes, 6),
                       PACKAGE="rpart")
        tname <- c("<leaf>", dimnames(X)[[2]])

        if (cpcol==3) temp <- c("CP", "nsplit", "rel error")
        else          temp <- c("CP", "nsplit", "rel error", "xerror", "xstd")
        dimnames(rp$cptable) <- list(temp, 1:numcp)

        splits<- matrix(c(rp$isplit[,2:3], rp$dsplit), ncol=5,
    		     dimnames=list(tname[rp$isplit[,1]+1],
			  c("count", "ncat", "improve", "index", "adj")))
        index <- rp$inode[,2]  #points to the first split for each node

        # Now, make ordered categories look like categories again (a printout
        #  choice)
        nadd <- sum(isord[rp$isplit[,1]])
        if (nadd >0) {
            newc <- matrix(integer(1), nadd, max(cats))
	    cvar <- rp$isplit[,1]
	    indx <- isord[cvar]		     # vector of T/F
	    cdir <- splits[indx,2]               # which direction splits went
	    ccut <- floor(splits[indx,4])        # cut point
	    splits[indx,2] <- cats[cvar[indx]]   #Now, # of categories instead
	    splits[indx,4] <- ncat + 1:nadd      # rows to contain the splits

            # Next 4 lines can be done without a loop, but become indecipherable
	    for (i in 1:nadd) {
	        newc[i, 1:(cats[(cvar[indx])[i]])] <- -1*as.integer(cdir[i])
	        newc[i, 1:ccut[i]] <- as.integer(cdir[i])
	    }
 	    if (ncat==0) catmat <- newc
	    else         catmat <- rbind(rp$csplit, newc)
	    ncat <- ncat + nadd
        }
        else catmat <- rp$csplit

        if (nsplit==0) {  #tree with no splits
    	    frame <- data.frame(row.names=1,
			    var=  "<leaf>",
			    n =   rp$inode[,5],
			    wt=   rp$dnode[,3],
			    dev=  rp$dnode[,1],
			    yval= rp$dnode[,4],
			    complexity=rp$dnode[,2],
			    ncompete  = pmax(0, rp$inode[,3]-1),
			    nsurrogate=rp$inode[,4])
	    }
        else {
	    temp <- ifelse(index==0, 1, index)
	    svar <- ifelse(index==0, 0, rp$isplit[temp,1]) #var number
	    frame <- data.frame(row.names=rp$inode[,1],
			    var=  factor(svar, 0:ncol(X), tname),
			    n =   rp$inode[,5],
			    wt=   rp$dnode[,3],
			    dev=  rp$dnode[,1],
			    yval= rp$dnode[,4],
			    complexity=rp$dnode[,2],
			    ncompete  = pmax(0, rp$inode[,3]-1),
			    nsurrogate=rp$inode[,4])
	     }
        if (method.int ==3 ) {
            numclass <- init$numresp -1
            temp <- rp$dnode[,-(1:4)] %*% diag(init$parms$prior*
					   sum(init$counts)/init$counts)
            yprob <- temp /apply(temp,1,sum)   #necessary with altered priors
            yval2 <- matrix(rp$dnode[, -(1:3)], ncol=numclass+1)
	    frame$yval2 <- cbind(yval2, yprob)
	}
        else if (init$numresp >1) frame$yval2 <- rp$dnode[,-(1:3)]

        if (is.null(init$summary))
	    stop("Initialization routine is missing the summary function")
        if (is.null(init$print))
	    functions <- list(summary=init$summary)
        else    functions <- list(summary=init$summary, print=init$print)
        if (!is.null(init$text)) functions <- c(functions, list(text=init$text))
        if (method=='user')	functions <- c(functions, mlist)

        where <- rp$which
        names(where) <- row.names(m)

        if (nsplit ==0) {  # no 'splits' component
	    ans <- list(frame = frame,
		    where = where,
		    call=call, terms=Terms,
		    cptable =  t(rp$cptable),
		    method = method,
		    parms  = init$parms,
		    control= controls,
		    functions= functions)
	    }
        else {
	    ans <- list(frame = frame,
		    where = where,
		    call=call, terms=Terms,
		    cptable =  t(rp$cptable),
		    splits = splits,
		    method = method,
		    parms  = init$parms,
		    control= controls,
		    functions= functions)
	}
        if (ncat>0) ans$csplit <- catmat +2
        if (model) {
	    ans$model <- m
	    if (missing(y)) y <- FALSE
	    }
        if (y) ans$y <- Y
        if (x) {
	    ans$x <- X
	    ans$wt<- wt
	}
        ans$ordered <- isord
        if(!is.null(attr(m, "na.action")))
	    ans$na.action <- attr(m, "na.action")
        if (!is.null(xlevels)) attr(ans, 'xlevels') <- xlevels
        if(method=='class') attr(ans, "ylevels") <- init$ylevels
#    if (length(xgroups)) ans$xgroups <- xgroups
        class(ans) <- "rpart"

        # return the appropriate class
        this <- list(bindx = bindx, btree = ans)
        if (method == "class") class(this) <- "sclass"
        if (method == "exp") class(this) <- "ssurv"
        if (method == "anova") class(this) <- "sreg"
        mod[[b]] <- this
        }
    mod
    }
# $Id: kfoldcv.R,v 1.3 2002/09/12 08:56:42 hothorn Exp $

kfoldcv <- function(k,N, nlevel=NULL) {
  if (is.null(nlevel)) {
    # no stratification
    if (k > N) return(c(rep(1, N), rep(0, k-N)))
    fl <- floor(N/k)
    ce <- ceiling(N/k)
    if (fl == ce) return(rep(fl, k)) 
      else 
    return(c(rep(ce, round((N/k - fl)*k)), rep(fl, round((1 - (N/k -
                     fl))*k))))
  } else {
    # stratification
    # if (!is.integer(nlevel)) stop("nlevel is not a vector if integers")
    kmat <- matrix(0, ncol=k, nrow=length(nlevel))
    for (i in 1:length(nlevel))
      kmat[i,] <- kfoldcv(k, nlevel[i])
    return(kmat)
  }
}
# $Id: mypredict.lm.R,v 1.7 2003/04/02 11:22:49 peters Exp $

mypredict.lm <- function(object, newdata) {

  xn <- as.data.frame(newdata)

  test <- attr(terms(object), "term.labels")
  xn <- xn[,test]

  if (!is.null(nrow(xn))) {
    pred <- rep(NA, nrow(xn))
    names(pred) <- row.names(xn)
  } else {
    pred <- NA
    names(pred) <- "1"
  }

  # evaluate na.omit (delete lines containing NA)

  xnn <- na.omit(xn)

  # attr(xnn, "na.action") returns which na.action is 
  # evaluated, lines and corresponding row.name where NAs occur 

  if(is.null(attr(xnn, "na.action"))) 
    pred <- predict(object, xnn) 
  else 
    pred[-attr(xnn, "na.action")] <- predict(object, xnn)

  pred

}
# $Id: predict.bagging.R,v 1.16 2003/08/08 12:13:42 hothorn Exp $

uwhich.max <- function(x) {
  # need to determine all maxima in order to sample from them
  wm <- (1:length(x))[x == max(x)]
  if (length(wm) > 1)
    wm <- wm[sample(length(wm), 1)]
  wm
}

predict.classbagg <- function(object, newdata=NULL, type=c("class", "prob"),
                              aggregation=c("majority", "average", "weighted"), ...) {
  type <- match.arg(type)
  agg <- match.arg(aggregation)
  if (missing(newdata)) {
    if (length(object$mtrees) < 10) 
      stop("cannot compute out-of-bag predictions for small number of trees")
    OOB <- TRUE
    if (!is.null(object$X))
      newdata <- object$X
    else
      stop("cannot compute out-of-bag predictions without object$X!")
  } else {
    OOB <- FALSE
  }
  if (!is.data.frame(newdata)) newdata <- as.data.frame(newdata)
  N <- nrow(newdata)
  if (!object$comb) {
    tree <- object$mtrees[[1]]$btree
    Terms <- delete.response(tree$terms)
    act <- (tree$call)$na.action
    if (is.null(act)) act<- na.rpart
    newdata <- model.frame(Terms, newdata, na.action = act,
                           xlev=attr(tree, "xlevels"))
    newdata <- getFromNamespace("rpart.matrix", ns = "rpart")(newdata)
  }
  classes <- levels(object$y)
  switch(agg, "majority" = {
    vote <- matrix(0, nrow=N, ncol=length(classes))
    for (i in 1:length(object$mtrees)) {
      if (OOB) {
        bindx <- object$mtrees[[i]]$bindx
        if (!is.null(object$mtrees[[i]]$bfct)) 
          stop("cannot compute out-of-bag estimate for combined models!")
        pred <- predict(object$mtrees[[i]], newdata, type="class")
        tindx <- cbind((1:N), pred)[-bindx,]
      } else {
        tindx <- cbind(1:N, predict(object$mtrees[[i]], newdata,
                                    type="class"))
      }
      vote[tindx] <- vote[tindx] + 1
    }
    if (type=="class") {
      RET <- factor(classes[apply(vote, 1, uwhich.max)])
    } else {
      RET <- vote/apply(vote, 1, sum)
      colnames(RET) <- classes
    }
  }, 
  "average" = {
    cprob <- matrix(0, nrow=N, ncol=length(classes))
    if (OOB) ncount <- rep(0,N) else ncount <- length(object$mtrees)
    for (i in 1:length(object$mtrees)) {
      if (OOB) {
        bindx <- object$mtrees[[i]]$bindx
        pred <- predict(object$mtrees[[i]], newdata, type="prob")[-bindx,]
        tindx <- (1:N)[-bindx]
        ncount[tindx] <- ncount[tindx] + 1
      } else {
        pred <- predict(object$mtrees[[i]], newdata, type="prob")
        tindx <- 1:N
      }
      cprob[tindx,] <- cprob[tindx,] + pred
    }
    switch(type, "class" = {
      RET <- as.factor(apply(cprob, 1, uwhich.max))
      levels(RET) <- classes
    }, 
    "prob" = {
      ncount[ncount < 1] <- NA
      RET <- cprob / ncount
      colnames(RET) <- classes
    })
  },
  "weighted" = {
    agglsample <- matrix(0, ncol=length(classes), nrow=N)
    for (i in 1:length(object$mtrees)) {
      bdata <- object$y[object$mtrees[[i]]$bindx]
      newpart <- getpartition(object$mtrees[[i]], newdata)
      oldpart <- object$mtrees[[i]]$btree$where
      if (OOB)
        tindx <- (1:N)[-object$mtrees[[i]]$bindx]
      else
        tindx <- 1:N
      for (j in tindx) {
        aggobs <- table(bdata[oldpart == newpart[j]])
        agglsample[j,] <- agglsample[j,] + aggobs
      }
    }
    switch(type, "class" = {
      RET <- c()
      for (j in 1:N)
        RET <- as.factor(c(RET, uwhich.max(agglsample[j,])))
      levels(RET) <- classes
    },
    "prob" = {
      RET <- agglsample / apply(agglsample, 1, sum)
      colnames(RET) <- classes
    })
  })
  RET
}

predict.sclass <- function(object, newdata=NULL, type=c("class", "prob"),
...) {
  if (!is.null(object$bfct))
    newdata <- cbind(newdata, object$bfct(newdata))
  pred <- predict.irpart(object$btree, newdata, type=type)
  RET <- pred
  if (type == "class") RET <- as.integer(pred)
  if (type == "prob" && is.vector(pred)) RET <- cbind(pred, 1 - pred)
  RET
}


predict.regbagg <- function(object, newdata=NULL, aggregation=c("average",
"weighted"), ...) {
  agg <- match.arg(aggregation)
  if (missing(newdata)) {
    if (length(object$mtrees) < 10) 
      stop("cannot compute out-of-bag predictions for small number of trees")
    OOB <- TRUE
    if (!is.null(object$X))
      newdata <- object$X
    else 
      stop("cannot compute out-of-bag predictions without object$X!")
  } else {
    OOB <- FALSE
  }
  if (!is.data.frame(newdata)) newdata <- as.data.frame(newdata)
  N <- nrow(newdata)
  if (!object$comb) {
    tree <- object$mtrees[[1]]$btree
    Terms <- delete.response(tree$terms)
    act <- (tree$call)$na.action
    if (is.null(act)) act<- na.rpart
    newdata <- model.frame(Terms, newdata, na.action = act,
                           xlev=attr(tree, "xlevels"))
    newdata <- getFromNamespace("rpart.matrix", ns = "rpart")(newdata)
  }
  switch(agg, "average" = {
    cprob <- rep(0, N)
    if (OOB) ncount <- rep(0,N) else ncount <- length(object$mtrees)
    for (i in 1:length(object$mtrees)) {
      if (OOB) {
        bindx <- object$mtrees[[i]]$bindx
        if (!is.null(object$mtrees[[i]]$bfct))
          stop("cannot compute out-of-bag estimate for combined models!")
        pred <- predict(object$mtrees[[i]], newdata)[-bindx]
        tindx <- (1:N)[-bindx]
        ncount[tindx] <- ncount[tindx] + 1
      } else {
        pred <- predict(object$mtrees[[i]], newdata)
        tindx <- 1:N
      }
      cprob[tindx] <- cprob[tindx] + pred
    }
    ncount[ncount < 1] <- NA
    RET <- cprob / ncount
  },
  "weighted" = {
    agglsample <- rep(0, N)
    ncount <- rep(0, N)
    for (i in 1:length(object$mtrees)) {
      bdata <- object$y[object$mtrees[[i]]$bindx]
      newpart <- getpartition(object$mtrees[[i]], newdata)
      oldpart <- object$mtrees[[i]]$btree$where
      if (OOB)
        tindx <- (1:N)[-object$mtrees[[i]]$bindx]
      else
        tindx <- 1:N
      for (j in tindx) {
        aggobs <- bdata[oldpart == newpart[j]]
        agglsample[j] <-  agglsample[j] + sum(aggobs)
        ncount[j] <- ncount[j] + length(aggobs)
      }
    }
    ncount[ncount < 1] <- NA
    RET <- agglsample / ncount
  })
  RET
}


predict.sreg <- function(object, newdata=NULL, ...) {
  if (!is.null(object$bfct))
    newdata <- cbind(newdata, object$bfct(newdata))
  predict.irpart(object$btree, newdata)
}


predict.survbagg <- function(object, newdata=NULL, ...) {
  if (missing(newdata)) {
    if (length(object$mtrees) < 10) 
      stop("cannot compute out-of-bag predictions for small number of trees")
    OOB <- TRUE
    if (!is.null(object$X))
      newdata <- object$X
    else 
      stop("cannot compute out-of-bag predictions without object$X!")
  } else {
    OOB <- FALSE
  }
  if (!is.data.frame(newdata)) newdata <- as.data.frame(newdata)
  N <- nrow(newdata)
  if (!object$comb) {
    tree <- object$mtrees[[1]]$btree
    Terms <- delete.response(tree$terms)
    act <- (tree$call)$na.action
    if (is.null(act)) act<- na.rpart
    newdata <- model.frame(Terms, newdata, na.action = act,
                           xlev=attr(tree, "xlevels"))
    newdata <- getFromNamespace("rpart.matrix", ns = "rpart")(newdata)
  }
  agglsample <- list()
  aggcens <- list()
  for (j in 1:N) { 
    agglsample <- c(agglsample, list(c()))
    aggcens <- c(aggcens, list(c()))
  }
  for (i in 1:length(object$mtrees)) {
    bdata <- object$y[object$mtrees[[i]]$bindx]
    newpart <- getpartition(object$mtrees[[i]], newdata)
    oldpart <- object$mtrees[[i]]$btree$where
    if (OOB) {
      if (!is.null(object$mtrees[[i]]$bfct))
        stop("cannot compute out-of-bag estimate for combined models!")
      tindx <- (1:N)[-object$mtrees[[i]]$bindx]
    } else {
      tindx <- 1:N
    }
    for (j in tindx) {
        aggobs <- bdata[oldpart == newpart[j],1]
        agglsample[[j]] <- c(agglsample[[j]], aggobs)
        aggobs <- bdata[oldpart == newpart[j],2]
        aggcens[[j]] <- c(aggcens[[j]], aggobs)
    }
  }
  RET <- list()
  for (j in 1:N)
    RET <- c(RET, list(survfit(Surv(agglsample[[j]], aggcens[[j]]))))
  RET
}

getpartition <- function(object, newdata=NULL) {
  if (!is.null(object$bfct)) {
    newdata <- cbind(newdata, object$bfct(newdata))
    Terms <- delete.response(object$btree$terms)
    act <- (object$btree$call)$na.action
    if (is.null(act)) act<- na.rpart
    newdata <- model.frame(Terms, newdata, na.action = act,
                             xlev=attr(object$btree, "xlevels"))
    newdata <- getFromNamespace("rpart.matrix", ns = "rpart")(newdata)
  }
  getFromNamespace("pred.rpart", ns = "rpart")(object$btree, newdata)
}

predict.inbagg <- function(object, newdata, ...) {
  if(!is.data.frame(newdata)) newdata <- as.data.frame(newdata)
  if(any(names(object$W) %in% names(newdata))) newdata <- newdata[!(names(newdata) %in% names(object$W))]
  NBAGG <- length(object$mtrees)
  N <- nrow(newdata)
  classes <- levels(object$y)
  vote <- matrix(0, nrow=N, ncol=length(classes))
  for(i in 1:NBAGG) {
    intermed <- object$mtrees[[i]]$bfct(newdata)
#    XX <- data.frame(newdata, intermed)
    if(!is.null(object$mtrees[[i]]$btree$fixed.function)) {
      names(intermed) <- sub(".[0-9]$", "", names(intermed))
      XX <- data.frame(newdata, intermed)
#      names(XX)[(ncol(XX)-ncol(intermed)+1):ncol(XX)] <- sub(".[0-9]$", "", names(intermed))
      res <- object$mtrees[[i]]$btree$fixed.function(XX)
    } else {
      XX <- data.frame(newdata, intermed)
      if(is.null(object$mtrees[[i]]$btree$predict)) {
        res <- try(predict(object$mtrees[[i]]$btree$model, newdata = XX, ...))
      } else {
        res <- try(object$mtrees[[i]]$btree$predict(object$mtrees[[i]]$btree$model, newdata = XX, ...))
      }
    }
    res <- cbind(1:N, res)
    vote[res] <- vote[res] +1 
  }

  RET <- factor(classes[apply(vote, 1, uwhich.max)])
  RET
}
# $Id: predict.inclass.R,v 1.19 2003/03/31 08:44:16 peters Exp $

# Additional option type ="class", if intermediate is nominal

predict.inclass <- function(object, newdata, ...)
{
  if(!is.data.frame(newdata)) newdata <- as.data.frame(newdata)
  q <- length(object$model.intermediate)		# number of intermediates
  namen <- names(object$model.intermediate) 

  intermediate <- is.vector(NULL, mode = "NULL")

  for(i in 1:q) {
    if(!is.null(object$para.intermediate[[i]][["predict"]])) {
      RET <- object$para.intermediate[[i]][["predict"]](object$model.intermediate[[i]], newdata = newdata, ...)
    } else {
      RET <- predict(object$model.intermediate[[i]], newdata = newdata, ...)
    }
  intermediate <- data.frame(intermediate, RET)
  }

  intermediate <- intermediate[,-1]  
  names(intermediate) <- namen
  
  intermediate <- data.frame(newdata[,!(names(newdata) %in% names(intermediate))], intermediate)

  if(!is.function(object$para.response)) {
   if(!is.null(object$para.response[["predict"]])) {
       RET <- object$para.response[["predict"]](object$model.response, newdata = intermediate, ...)
     } else {
       RET <- predict(object$model.response, newdata = intermediate, ...)
     }
  } else {
    RET <- object$para.response(intermediate)
  }
  return(RET)
}
#
#  a modified version of `predict.rpart.s' from the rpart package
#  see COPYRIGHTS for details.
#
predict.irpart <-
function(object, newdata = list(),
	 type = c("vector", "prob", "class", "matrix"), ...) {
    if(!inherits(object, "rpart"))
	stop("Not legitimate tree")
    mtype <- missing(type)
    type <- match.arg(type)
    if(missing(newdata))
	where <- object$where
    else {
	if(is.null(attr(newdata, "terms")) & !inherits(newdata, "rpart.matrix")) {
	    Terms <- delete.response(object$terms)
	    act <- (object$call)$na.action
	    if (is.null(act)) act<- na.rpart
	    newdata <- model.frame(Terms, newdata, na.action = act,
                                      xlev=attr(object, "xlevels"))
            newdata <- getFromNamespace("rpart.matrix", ns = "rpart")(newdata)
        } 
	where <- getFromNamespace("pred.rpart", ns = "rpart")(object, newdata)
      }
    frame <- object$frame
    method <- object$method
    ylevels <- attr(object, "ylevels")
    nclass <- length(ylevels)
    if(mtype && nclass > 0) type <- "prob"
    if(type == "vector" || (type=="matrix" && is.null(frame$yval2))) {
	pred <- frame$yval[where]
	names(pred) <- names(where)
    }
    else if (type == "matrix") {
	pred <- frame$yval2[where,]
	dimnames(pred) <- list(names(where), NULL)
    }
    else if(type == "class" && nclass > 0) {
	pred <- factor(ylevels[frame$yval[where]], levels=ylevels)
	names(pred) <- names(where)
    }
    else if (type == "prob" && nclass > 0) {
	pred <- frame$yval2[where, 1 + nclass + 1:nclass]
	dimnames(pred) <- list(names(where), ylevels)
    }
    else stop("Invalid prediction for rpart object")

    # Expand out the missing values in the result
    # But only if operating on the original dataset
    if (missing(newdata) && !is.null(object$na.action))
        pred <- naresid(object$na.action, pred)
    pred
}

#$Id: print.R,v 1.3 2002/09/24 12:31:49 hothorn Exp $

print.classbagg <- function(x, digits=4, ...)
{
    cat("\n")
    B <- length(x$mtrees)
    if (B > 1)
      method <- paste("Bagging classification trees with", B, 
                      "bootstrap replications")
    else 
      method <- "Classification tree"
    cat(method, "\n")
    if (!is.null(x$call)) {
      cat("\nCall: ")
      print(x$call)
      cat("\n")
    }
    if (x$OOB) {
      cat("Out-of-bag estimate of misclassification error: ",
           round(x$err, digits), "\n")
    }
    cat("\n")
}

print.regbagg <- function(x, digits=4, ...)
{
    cat("\n")
    B <- length(x$mtrees)
    if (B > 1)
      method <- paste("Bagging regression trees with", B, 
                    "bootstrap replications")
    else
      method <- "Regression tree"
    cat(method, "\n")
    if (!is.null(x$call)) {
      cat("\nCall: ")
      print(x$call)
      cat("\n")
    }
    if (x$OOB)
      cat("Out-of-bag estimate of root mean squared error: ",
           round(x$err, digits), "\n")
    cat("\n")

}

print.survbagg <- function(x, digits=4, ...)
{
    cat("\n")
    B <- length(x$mtrees)
    if (B > 1)
      method <- paste("Bagging survival trees with", B, 
                      "bootstrap replications")
    else
      method <- "Survival tree"
    cat(method, "\n")
    if (!is.null(x$call)) {
      cat("\nCall: ")
      print(x$call)
      cat("\n")
    }
    if (x$OOB)
      cat("Out-of-bag estimate of Brier's score: ",
           round(x$err, digits), "\n")
    cat("\n")

}

summary.classbagg <- function(object, ...)
{
     print(object, ...)
     class(object) <- "summary.bagging"
     object
}

summary.regbagg <- function(object, ...)
{
     print(object, ...)
     class(object) <- "summary.bagging"
     object
}

summary.survbagg <- function(object, ...)
{
     print(object, ...)
     class(object) <- "summary.bagging"
     object
}

print.summary.bagging <- function(x, digits = max(3, getOption("digits")-3),
                                 ...)
{
     cat("Trees: \n")
     print(x$mtrees)
     invisible(x$mtrees)
}

print.cvclass <- function(x, digits=4, ...)
{
  cat("\n")
  if (!is.null(x$call)) {
    cat("Call:\n")
    print(x$call)
    cat("\n")
  }
  cat("\t", paste(x$k, "-fold", sep=""), 
      "cross-validation estimator of misclassification error \n") 
  cat("\n")
  cat("Misclassification error: ", round(x$error, digits), "\n")
  cat("\n")
}

print.bootestclass <- function(x, digits=4, ...)
{
  cat("\n")
  if (!is.null(x$call)) {
    cat("Call:\n")
    print(x$call)
    cat("\n")
  }
  if (x$bc632plus) 
    cat("\t", ".632+ Bootstrap estimator of misclassification error \n")
  else 
    cat("\t", "Bootstrap estimator of misclassification error \n")
  cat("\t with" , x$nboot, "bootstrap replications\n")
  cat("\n")
  cat("Misclassification error: ", round(x$error, digits), "\n")
  if (!x$bc632plus)
  cat("Standard deviation:", round(x$sd, digits), "\n")
  cat("\n")
}


print.cvreg <- function(x, digits=4, ...)
{
  cat("\n")
  if (!is.null(x$call)) {
    cat("Call:\n")
    print(x$call) 
    cat("\n")
  }
  cat("\t", paste(x$k, "-fold", sep=""),
      "cross-validation estimator of root mean squared error\n")
  cat("\n")
  cat("Root mean squared error: ", round(x$error, digits), "\n")
  cat("\n")
}

print.bootestreg <- function(x, digits=4, ...)
{
  cat("\n")
  if (!is.null(x$call)) {
    cat("Call:\n")
    print(x$call)
    cat("\n")
  }
  cat("\t", "Bootstrap estimator of root mean squared error \n")
  cat("\t with" , x$nboot, "bootstrap replications\n")
  cat("\n")
  cat("Root mean squared error: ", round(x$error, digits), "\n")  
  cat("\n")
}


print.cvsurv <- function(x, digits=4, ...)
{
  cat("\n")
  if (!is.null(x$call)) {
    cat("Call:\n")
    print(x$call) 
    cat("\n")
  }
  cat("\t", paste(x$k, "-fold", sep=""),
      "cross-validation estimator of Brier's score\n")
  cat("\n")
  cat("Brier's score: ", round(x$error, digits), "\n")
  cat("\n")
}

print.bootestsurv <- function(x, digits=4, ...)
{
  cat("\n")
  if (!is.null(x$call)) {
    cat("Call:\n")
    print(x$call)
    cat("\n")
  }
  cat("\t", "Bootstrap estimator of Brier's score\n")
  cat("\t with" , x$nboot, "bootstrap replications\n")
  cat("\n")
  cat("Brier's score: ", round(x$error, digits), "\n")  
  cat("\n")
}
# $Id: prune.bagging.R,v 1.2 2002/09/12 08:59:13 hothorn Exp $

prune.classbagg <- function(tree, cp=0.01,...)
{
  for(i in 1:length(tree$mtrees))
    tree$mtrees[[i]]$btree <- prune( tree$mtrees[[i]]$btree, cp=cp, ...)
  tree
}

prune.regbagg <- function(tree, cp=0.01,...)
{
  for(i in 1:length(tree$mtrees))
    tree$mtrees[[i]]$btree <- prune( tree$mtrees[[i]]$btree, cp=cp, ...)
  tree
}


prune.survbagg <- function(tree, cp=0.01,...)
{
  for(i in 1:length(tree$mtrees))
    tree$mtrees[[i]]$btree <- prune( tree$mtrees[[i]]$btree, cp=cp, ...)
  tree
}
# $Id: rsurv.R,v 1.5 2003/03/31 08:44:16 peters Exp $

rsurv <- function(N, model=c("A", "B", "C", "D", "tree"), gamma=NULL, fact=1,
                  pnon=10, gethaz=FALSE)
{
    model <- match.arg(model)
    X <- matrix(runif(N*5), ncol=5)
    colnames(X) <- paste("X", 1:ncol(X), sep="")
    switch(model,
        "A" =  { 
            time <- rexp(N)
            haz <- rep(1, N)
        }, 
        "B" = {
            hazard <- as.numeric(X[,1] <= 0.5 & X[,2] > 0.5)
            time <- rexp(N)
            time[hazard == 1] <- rexp(sum(hazard==1), exp(3))
            haz <- rep(1, N)
	    haz[hazard == 1] <- exp(3)
        },
        "C" = {
            hazard <- 3*X[,1] + X[,2]
            haz <- exp(hazard)
            time <- sapply(haz, rexp, n=1)
        },
        "D" = {
            hazard <- 3*X[,1] - 3*X[,2] + 4*X[,3] - 2*X[,4]
            haz <- exp(hazard)
            time <- sapply(haz, rexp, n=1)
        },
        "tree" = {
            hazard <- rep(0, nrow(X))
            hazard[(X[,1] <= 0.5 & X[,2] <= 0.5)] <- 0
            hazard[(X[,1] <= 0.5 & X[,2] > 0.5 & X[,4] <= 0.5)] <- 1
            hazard[(X[,1] <= 0.5 & X[,2] > 0.5 & X[,4] > 0.5)] <- 0
            hazard[(X[,1] > 0.5 & X[,3] <= 0.5 & X[,5] <= 0.3)] <- 1
            hazard[(X[,1] > 0.5 & X[,3] <= 0.5 & X[,5] > 0.3)] <- 2
            hazard[(X[,1] > 0.5 & X[,3] > 0.5 & X[,4] <= 0.7)] <- 2
            hazard[(X[,1] > 0.5 & X[,3] > 0.5 & X[,4] > 0.7)] <- 3
            hazard <- hazard * fact
            haz <- exp(hazard)
            time <- sapply(haz, rexp, n=1)
            if (pnon > 0)
              X <- cbind(X, matrix(runif(N*pnon), ncol=pnon))
            colnames(X) <- paste("X", 1:ncol(X), sep="")
        })
    if (!is.null(gamma))  
        censtime <- runif(N, min=0, max=gamma)
    else
        censtime <- Inf
    cens <- as.numeric(time <= censtime)
    time <- pmin(time, censtime)
    simdat <- as.data.frame(cbind(time, cens, X))
    if (gethaz) attr(simdat, "hazard") <- haz
    return(simdat)
}
# $Id: sbrier.R,v 1.4 2003/03/31 08:44:16 peters Exp $

getsurv <- function(obj, times)
{
    # get the survival probability for times from KM curve `obj'

    if (!inherits(obj, "survfit")) stop("obj is not of class survfit")
    # <FIXME: methods may have problems with that>
    class(obj) <- NULL
    # </FIXME>
    lt <- length(times)
    nsurv <- times

    # if the times are the same, return the km-curve

    if(length(times) == length(obj$time)) {
        if (all(times == obj$time)) return(obj$surv)
    }

    # otherwise get the km-value for every element of times separatly
 
    inside <- times %in% obj$time
    for (i in (1:lt)) {
        if (inside[i])
            nsurv[i] <- obj$surv[obj$time == times[i]]
        else  {
            less <- obj$time[obj$time < times[i]]
            if (length(less) == 0) 
                nsurv[i] <- 1
            else 
                nsurv[i] <- obj$surv[obj$time == max(less)]
        }
    }
    nsurv
}

sbrier <- function(obj, pred, btime=c(0, max(obj[,1])))
{
    if(!inherits(obj, "Surv"))
        stop("obj is not of class Surv")

    # check for right censoring

    # <FIXME>
    class(obj) <- NULL
    # </FIXME>
    if (attr(obj, "type") != "right")
        stop("only right-censoring allowed")
    N <- nrow(obj)	

    # get the times and censoring of the data, order them with resp. to time

    time <- obj[,1]
    ot <- order(time)
    cens <- obj[ot,2]
    time <- time[ot]

    # get the times to compute the (integrated) Brier score over

    if (is.null(btime)) stop("btime not given")
    if (length(btime) < 1) stop("btime not given")

    if (length(btime) == 2) btime <- time[time >= btime[1] & time <=
                                          btime[2]]

    ptype <- class(pred)
    # <begin> S3 workaround
    if (is.null(ptype)) {
      if (is.vector(pred)) ptype <- "vector"
      if (is.list(pred)) ptype <- "list"
    }
    # <end>
    if (ptype == "numeric" && is.vector(pred)) ptype <- "vector"

    survs <- NULL
    switch(ptype, survfit = {
        survs <- getsurv(pred, btime)
        survs <- matrix(rep(survs, N), nrow=length(btime))
    }, list = {
        if (!inherits(pred[[1]], "survfit")) stop("pred is not a list of survfit objects") 
        if (length(pred) != N) stop("pred must be of length(time)")
        pred <- pred[ot]
        survs <-  matrix(unlist(lapply(pred, getsurv, times = btime)),
                                nrow=length(btime), ncol=N)
    }, vector = {
        if (length(pred) != N) stop("pred must be of length(time)")
        if (length(btime) != 1) stop("cannot compute integrated Brier score with pred")
        survs <- pred[ot]
    }, matrix = {
        # <FIXME>
        if (all(dim(pred) == c(length(time), N)))
            survs <- pred[,ot]
        else
            stop("wrong dimensions of pred")
        # </FIXME>
    })
    if (is.null(survs)) stop("unknown type of pred")

    # reverse Kaplan-Meier: estimate censoring distribution

    hatcdist <- survfit(Surv(time, 1 - cens))
    csurv <- getsurv(hatcdist, time)
    csurv[csurv == 0] <- Inf

    bsc <- rep(0, length(btime))
    
    # compute Lebesque-integrated Brier score

    if (length(btime) > 1) {
        for (j in 1:length(btime)) {
            help1 <- as.integer(time <= btime[j] & cens == 1)
            help2 <- as.integer(time > btime[j])
            bsc[j] <-  mean((0 - survs[j,])^2*help1*(1/csurv) +
                            (1-survs[j,])^2*help2*(1/csurv[j]))
        }
        diffs <- c(btime[1], btime[2:length(btime)] -
                             btime[1:(length(btime)-1)])
        RET <- sum(diffs*bsc)/max(btime)
        names(RET) <- "integrated Brier score"
        attr(RET, "time") <- range(btime)

    # compute Brier score at one single time `btime'
 
    } else {
        help1 <- as.integer(time <= btime & cens == 1)
        help2 <- as.integer(time > btime)
        cs <- getsurv(hatcdist, btime)
        if (cs == 0) cs <- Inf
        RET <-  mean((0 - survs)^2*help1*(1/csurv) +
                     (1-survs)^2*help2*(1/cs))
        names(RET) <- "Brier score"
        attr(RET, "time") <- btime
    }
    RET
}
# $Id: slda.R,v 1.7 2003/11/03 15:29:14 hothorn Exp $

# stabilized linear discriminant analysis according to Laeuter & Kropf

slda <- function(y, ...) UseMethod("slda")

slda.default <- function(y, ...) 
  stop(paste("Do not know how to handle objects of class", class(data)))

slda.formula <- function(formula, data, subset, na.action=na.rpart, ...) {
   cl <- match.call()
   if(missing(formula)
       || (length(formula) != 3)
       || (length(attr(terms(formula[-2]), "term.labels")) < 1)
       || (length(attr(terms(formula[-3]), "term.labels")) != 1))
        stop("formula missing or incorrect")
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)
    m[[1]] <- as.name("model.frame")
    m$... <- NULL
    m <- eval(m, parent.frame())
    Terms <- attr(m, "terms")
    grouping <- model.extract(m, "response")
    x <- model.matrix(Terms, m)
    xvars <- as.character(attr(Terms, "variables"))[-1]
    if ((yvar <- attr(Terms, "response")) > 0) xvars <- xvars[-yvar]
    xlev <- if (length(xvars) > 0) {
        xlev <- lapply(m[xvars], levels)
        xlev[!sapply(xlev, is.null)]
    }
    xint <- match("(Intercept)", colnames(x), nomatch=0)
    if(xint > 0) x <- x[, -xint, drop=FALSE]
    RET <- slda(y=grouping, X=x, ...)
    RET$terms <- Terms
    RET$call <- match.call()
    RET$contrasts <- attr(x, "contrasts")
    RET$xlevels <- xlev
    attr(RET, "na.message") <- attr(m, "na.message")
    if(!is.null(attr(m, "na.action"))) RET$na.action <- attr(m, "na.action")
    RET
}


slda.factor <- function(y, X, q=NULL, ...) {

  p <- ncol(X)
  # substract global mean 
  Xnull <- X - apply(X, 2, mean)
  if (!is.null(q)) {
    if (floor(q) != q) stop("q is not an integer")
    if (q > p) {
      q <- p
      warning("q is greater ncol(X), using q = ncol(X)")
    }
    if (q < 1) {
      q <- 1
      warning("q is less than 1, using q = 1")
    }
  }

  # this is S_0 in Kropf (2000)
  Snull <- cov(Xnull)
  ewp <- svd(solve(diag(diag(Snull)))%*%Snull)
  if (!is.complex(ewp$d)) {
    # determine q by the number of eigenvalues > 1
    if (is.null(q)) q <- sum(ewp$d > 1)
    D <- ewp$v[,1:q]
    if (q == 1) D <- as.matrix(D)
    # Xstab is still spherically distributed (Fang & Zhang, Laeuter, Kropf &
    # Glimm)!
  } else {
    D <- diag(p)
  }
  Xstab <- as.matrix(X) %*% D
  colnames(Xstab) <- paste("V", 1:ncol(Xstab), sep="")
  mylda <- lda(Xstab, grouping = y, ...)
  RET <- list(scores = D, mylda = mylda)
  class(RET) <- "slda"
  RET
}

predict.slda <- function(object, newdata, ...) {
    if(!inherits(object, "slda")) stop("object not of class slda")
    if(!is.null(Terms <- object$terms)) { #
    # formula fit (only)
        if(missing(newdata)) newdata <- model.frame(object)
        else {
            newdata <- model.frame(as.formula(delete.response(Terms)),
                                   newdata, na.action=function(x) x,
                                   xlev = object$xlevels)
        }
        x <- model.matrix(delete.response(Terms), newdata,
                          contrasts = object$contrasts)
        xint <- match("(Intercept)", colnames(x), nomatch=0)
        if(xint > 0) x <- x[, -xint, drop=FALSE]
    } else { 
      stop("object has no terms element") 
    }
    if(ncol(x) != nrow(object$scores)) stop("wrong number of variables")
#   <FIXME>: check for variable names!
#    if(length(colnames(x)) > 0 &&
#      any(colnames(x) != dimnames(object$means)[[2]]))
#         warning("Variable names in newdata do not match those in object")
#   </FIXME>
    X <- x %*% object$scores
    if (inherits(object$mylda, "lda"))
      return(predict(object$mylda, newdata=as.data.frame(X), ...))
    else
      stop(paste("Do not know how to predict from objects of class", class(object$mylda)))

}

ssubset <- function(y, k, strat=TRUE) {
  if (!is.factor(y)) stop("y is not of class factor")
  N <- length(y)
  nlevel <- table(y)
  nindx <- list()
  indx <- 1:N
  outindx <- list()
  if (strat) {
    for (j in 1:length(nlevel))
      nindx <- c(nindx, list(indx[which(y == levels(y)[j])]))
    kmat <- kfoldcv(k, N, nlevel)
    for (i in 1:k) {
      sset <- kmat[,i]
      kindx <- c()
      for (j in 1:length(nlevel)) {
        if (i > 1)
          kindx <- c(kindx, nindx[[j]][(sum(kmat[j,
                     1:(i-1)])+1):sum(kmat[j,1:i])])
        else
          kindx <- c(kindx, nindx[[j]][1:kmat[j,1]])
      }
      kindx <- kindx[!is.na(kindx)]
      outindx <- c(outindx, list(kindx))
    }
    return(outindx)
  } else {
    kmat <- kfoldcv(k, N)
    nindx <- indx
    for (i in 1:k) { 
      if (i > 1)
        outindx <- c(outindx,
                  list(nindx[(sum(kmat[1:(i-1)])+1):sum(kmat[1:i])]))
      else
        outindx <- c(outindx, list(nindx[1:kmat[1]]))
    }
  }
  return(outindx)
}
# $Id: varset.R,v 1.2 2002/03/26 16:29:15 hothorn Exp $

varset <- function(N, sigma = 0.1, theta = 90, threshold = 0, u = 1:3)
{
  # create U
  U <- matrix(rep(0, 4), ncol = 2)
  U[1, 1] <- u[1]
  U[1, 2] <- u[2]
  U[2, 1] <- u[3]
  U[2, 2] <- (theta-u[1]*u[3])/u[2]
  lambda <- sqrt(U[1, 1]^2 + U[1, 2]^2)
  U[1, ] <- U[1, ]/lambda
  lambda <- sqrt(U[2, 1]^2 + U[2, 2]^2)
  U[2, ] <- U[2, ]/lambda

  e <- matrix(rnorm(2*N, sd = sigma), ncol = 2, byrow = TRUE)
  expl <- matrix(rnorm(2*N), ncol = 2, byrow = TRUE)
  inter <- t(U %*%t(expl) + t(e))
  z <- (inter > threshold)
  resp <- as.factor(ifelse((z[,1] + z[,2]) > 1, 1, 0))
  colnames(expl) <- c("x1", "x2")
  colnames(inter) <- c("y1", "y2")

  result <- list(explanatory = expl, intermediate = inter, response = resp)
  return(result)
}  
# $Id: zzz.R,v 1.12 2003/07/22 14:56:31 peters Exp $

.onLoad <- function(lib, pkg) {
    if(!require(rpart))
        warning("Could not load package rpart")
    if(!require(MASS))
        warning("Could not load package MASS")
    if(!require(mlbench))
        warning("Could not load package mlbench")
    if(!require(survival))
        warning("Could not load package mlbench")
    if(!require(class))
        warning("Could not load package class")
    if(!require(nnet))
        warning("Could not load package nnet")
    if(!require(mvtnorm))
        warning("Could not load package mvtnorm")
    library.dynam("ipred", pkg, lib)
}
