R/prime.imp.R

In LogicForest: Logic Forest

#' Extract Prime Variable Interactions from a Logic Regression Tree
#'
#' Internal function called by \code{\link{pimp.import}}.
#' It is not intended to be used independently.
#' Generates a list of all variables and variable interactions identified by a specific
#' logic regression tree within a logic forest or LBoost model.
#'
#' @param tree An object of class \code{"logregtree"}.
#' @param data Data frame used to fit the logic forest.
#' @param Xs A vector of predictor names corresponding to columns in \code{data}.
#' @param mtype Model type (e.g., classification, linear regression, survival regression).
#'
#' @details
#' This function constructs all possible interactions of the predictors contained in
#' the tree, identifies those that contribute to a positive outcome ("prime interactions"),
#' and returns information about which variables and interactions are included in each.
#'
#' @return An object of class \code{"primeImp"} with the following elements:
#' \item{vec.primes}{Character vector of variable interactions in logical format.}
#' \item{tmp.mat}{Matrix of all binary interactions contained in the tree.}
#' \item{vec.pimpvars}{Sorted vector of column indices in \code{data} for important predictors.}
#' \item{list.pimps}{List of vectors, each containing indices of predictors involved in each interaction.}
#'
#' @author Bethany Wolf \email{wolfb@@musc.edu}
#' @keywords internal
#' @export
prime.imp<-function (tree, data, Xs, mtype)
{
  test.mat <- NULL  # Initialize to avoid 'no visible binding' note
  mat<-TTab(data, tree, Xs=Xs, mtype=mtype)
  test.mat <<- mat

  mat[mat == 0] <- -1
  n.var <- ncol(mat)
  if (is.null(colnames(mat))) {colnames(mat) <- paste("X", 1:n.var, sep = "")}
  ia <- p.combos(n.var)
  ia.rowS <- rowSums(ia)
  vec.primes <- character(0)
  list.pimps<-list()
  list.cover <- list()
  mat.in <- NULL
  name.paste <- function(x)
  {
    x <- x[x != ""]
    paste(x, collapse = " & ")
  }
  tmp.list <- vector("list",n.var)

  for (i in 1:n.var)
  {
    pairt <- p.combos(i, conj = -1)
    n.p <- nrow(pairt)  #number of combos for i vars
    ia2 <- matrix(ia[ia.rowS == i, ], ncol = n.var)
    tmp <- matrix(0, nrow(ia2) * n.p, n.var)
    for (j in 1:nrow(ia2)) tmp[((j - 1) * n.p + 1):(j * n.p), ia2[j, ] == 1] <- pairt

    tmp2 <- tmp %*% t(mat) == i
    ids <- which(rowSums(tmp2) == 2^(n.var - i))
    tmp <- tmp[ids, ]
    tmp.list[[i]]<-tmp
    if (length(ids) > 0)
    {
      mat.in <- rbind(mat.in, tmp)
      for (k in ids) list.cover[[length(list.cover) + 1]] <- which(tmp2[k, ])
      mat.names <- matrix(rep(colnames(mat), e = length(ids)), ncol = n.var)
      mat.names[tmp == 0] <- ""
      mat.pimps<-vector("list", nrow(mat.names))
      for (m in 1:nrow(mat.names))
      {
        mat.pimps[[m]]<-which(colnames(data)%in%mat.names[m,])
      }
      list.pimps<-append(list.pimps, mat.pimps)
      mat.names[tmp == -1] <- paste("!", mat.names[tmp == -1], sep = "")
      tmp.prime <- apply(mat.names, 1, name.paste)
      vec.primes <- c(vec.primes, tmp.prime)
    }
    cover <- unique(unlist(list.cover))
    if (length(cover) == nrow(mat))
      break
  }
  tmp.mat<-NULL
  for (i in 1:length(tmp.list)){
    tmp.mat<-rbind(tmp.mat, tmp.list[[i]])
  }
  vec.pimpvars<-sort(unique(unlist(list.pimps)))
  n.prime <- length(vec.primes)

  listPI <- list(vec.primes=vec.primes, tmp.mat=tmp.mat, vec.pimpvars=vec.pimpvars, list.pimps=list.pimps)
  class(listPI) <- "primeImp"
  listPI
}