R/a.frame.logreg2.R

In LogicForest: Logic Forest

#' INTERNAL FUNCTION TO EVALUATE IMPORTANCE OF PREDICTOR COMBINATIONS
#' @importFrom LogicReg eval.logreg logreg logreg.anneal.control
#' @importFrom methods is
#'
#' @details This function is called by \code{predict.logreg2}. It is not intended to be used independently.
#' @param fit An object of type \code{"logreg"} fit to data
#' @param msz Max number of leaves on a tree
#' @param ntr Number of trees of fit
#' @param newbin new binary variables
#' @param newresp new response variable
#' @param newsep new number of separate predictors
#' @param newcens new censoring indicators
#' @param newweight new weightings
#'
#' @returns outframe
#' @export
#' @keywords internal

frame.logreg2 <- function(fit, msz, ntr, newbin, newresp, newsep, newcens, newweight)
{
  if(class(fit)[1] != "logreg")
    stop("fit not of class logreg")
  if(missing(newbin)) {
    outframe <- data.frame(y = fit$response)
    outframe <- data.frame(outframe, wgt = fit$weight)
    if(fit$type == "proportional.hazards")
      outframe <- data.frame(outframe, cens = fit$censor)
    if(fit$nsep > 0)
      outframe <- data.frame(outframe, fit$separate)
    binhere <- fit$binary
  }
  else {
    binhere <- newbin
    lbinhere <- length(binhere)
    if(is.data.frame(binhere))
      binhere <- as.matrix(binhere)
    if(is.matrix(binhere) == FALSE)
      binhere <- matrix(binhere, ncol = fit$nbinary)
    n1 <- length(binhere[, 1])
    n2 <- length(binhere[1,  ])
    if(n2 != fit$nbinary)
      stop("new number of binary predictors doesn't match fit")
    if(!missing(newweight)) {
      if(length(newweight) != n1)
        stop("length(newweight) != length(newbin[,1])")
    }
    else {
      newweight <- rep(1, n1)
    }
    if(!missing(newresp)) {
      if(length(newresp) != n1)
        stop("length(newresp) != length(newbin[,1])")
      outframe <- data.frame(y = newresp, wgt = newweight)
    }
    else {
      outframe <- data.frame(wgt = newweight)
    }
    if(fit$type == "proportional.hazards" || fit$type == "exponential.survival"){
      if(missing(newcens)) {
        warning("newcens missing, taking all censoring indicators to be 1")    #MN commented out this warning
        outframe <- data.frame(outframe, cens = rep(1, n1))
      }
      else {
        if(length(newcens) != n1)
          stop("length(newcens) != length(newbin[,1])")
        outframe <- data.frame(outframe, cens = newcens)
      }
    }
    if(fit$nsep > 0) {
      if(missing(newsep))
        stop("you need to specify newsep")
      if(is.matrix(newsep) == FALSE)
        newsep <- matrix(newsep, ncol = fit$nsep)
      if(is.data.frame(newsep))
        newsep <- as.matrix(newsep)
      if(length(newsep[, 1]) != n1)
        stop("length(newsep[,1]) != length(newbin[,1])")
      if(length(newsep[1,  ]) != fit$nsep)
        stop("new number of separate predictors doesn't match fit")
      outframe <- data.frame(outframe, newsep)
    }
  }
  if(fit$choice!=1 && fit$choice!=2 && fit$choice!=6)
    stop("fit$choice needs to be 1, 2, or 6")
  if(fit$choice == 1) {
    ntr <- fit$ntrees[1]
    msz <- fit$nleaves[1]
    for(j in 1:ntr) {
      mtree <- fit$model$trees[[j]]$trees
      if(msz < 0)
        msz <- 0.5 * (length(mtree[, 1]) + 1)
      if(mtree[1, 2] == 0)
        outframe <- data.frame(outframe, tmp = 0)
      else {
        tmp <- eval.logreg(fit$model$trees[[j]], binhere)
        outframe <- data.frame(outframe, tmp = tmp)
      }
      l1 <- length(outframe[1,  ])
      names(outframe)[l1] <- paste("tree", msz, ".", ntr, ".", j, sep = "")
    }
  }
  else {
    for(i in 1:fit$nmodels) {
      xfit <- fit$alltrees[[i]]
      ntrx <- xfit$ntrees[1]
      mszx <- xfit$nleaves[1]
      l1 <- 1
      if(!missing(ntr) && fit$choice == 2)
        l1 <- sum(ntrx == ntr)
      if(!missing(msz))
        l1 <- l1 * sum(mszx == msz)
      if(l1 > 0)
        for(j in 1:ntrx) {
          if(xfit$trees[[j]]$trees[1, 2] == 0)
            outframe <- data.frame(outframe, tmp = 0)
          else {
            tmp <- eval.logreg(xfit$trees[[j]], binhere)
            outframe <- data.frame(outframe, tmp = tmp)
          }
          l1 <- length(outframe[1,  ])
          names(outframe)[l1] <- paste("tree", mszx, ".", ntrx, ".", j, sep = "")
        }
    }
  }
  outframe
}