R/pimp.mat.nonbin.R

In LogicForest: Logic Forest

#' Predictor Importance Matrix - Regression
#'
#' Internal function called in \code{\link{pimp.import}} to construct a binary/logical matrix of predictors used (columns) in each of the interactions of a sample (rows).
#' 
#' NOTE: For classification models, \code{\link{pimp.mat.bin}} is used.
#'
#' @param pimps.out R object containing \code{vec.primes}, \code{tmp.mat}, \code{vec.pimpvars}, \code{list.pimps}, and \code{cmp}.
#' @param testdata Out-of-bag sample.
#'
#' @return A list with:
#' \describe{
#'   \item{pimp.names}{Vector of predictor names.}
#'   \item{pimp.datamat}{Logical matrix of predictors used (columns) in each of the interactions of a sample (rows).}
#' }
#'
#' @references
#' Wolf BJ, Hill EG, Slate EH. Logic Forest: an ensemble classifier for discovering logical combinations of binary markers. \emph{Bioinformatics}. 2010;26(17):2183-2189. \doi{10.1093/bioinformatics/btq354}
#'
#' @author
#' Bethany J. Wolf \email{wolfb@@musc.edu}
#'
#' @seealso \code{\link{pimp.import}}
#'
#' @keywords internal

pimp.mat.nonbin<-function(pimps.out, testdata)
{
  tmp.mat <- pimps.out$tmp.mat #tmp.mat is the matrix for num unique interactions (rows) by unique predictors (cols)
  zero.ids<-c()
  
  for(i in 1:ncol(tmp.mat))
  {
    ids<-if(all(tmp.mat[,i]==0)) {ids<-i}
    zero.ids<-append(zero.ids, ids)
  }
  if (length(zero.ids) > 0) {tmp.mat<-tmp.mat[,-zero.ids]}
  
  pimp.ids <- pimps.out$vec.pimpvars 
  subdata <- as.matrix(testdata[,pimp.ids]) #subdata is the matrix of unique predictors (cols from tmp.mat) for each OOB sample
  
  if (is.null(dim(tmp.mat))) {tmp.mat<-matrix(1,1,1)}
  if (nrow(tmp.mat)!=length(pimps.out$vec.primes)) {tmp.mat<-t(tmp.mat)}
  if (is.matrix(tmp.mat)) {npimps <- nrow(tmp.mat)}
  if (is.vector(tmp.mat)) {npimps <- 1}
  
  n <- nrow(subdata)
  indcomp <- matrix(rep(pimps.out$cmp, n), nrow=n, ncol=length(pimps.out$cmp), byrow=T)
  pimp.datamat <- matrix(0, nrow=n, ncol=npimps)
  colnames(pimp.datamat) <- pimps.out$vec.primes
  
  for (i in 1:npimps)
  {
    if (is.matrix(tmp.mat)) {match.matrix<-matrix(0, nrow=n, ncol=ncol(tmp.mat))}
    if (is.vector(tmp.mat)) {match.matrix<-matrix(0, nrow=n, ncol=length(tmp.mat))}
    for (j in 1:n)
    {
      if (is.matrix(tmp.mat)) 
      {
        for (k in 1:ncol(tmp.mat))
        {
          if (tmp.mat[i,k]==1 & subdata[j,k]==1) {match.matrix[j,k]<-1}
          if (tmp.mat[i,k]==-1 & subdata[j,k]==0) {match.matrix[j,k]<-1}
          if (tmp.mat[i,k]==1 & subdata[j,k]==1) {match.matrix[j,k]<-1}
          if (tmp.mat[i,k]==-1 & subdata[j,k]==0) {match.matrix[j,k]<-1}
          if (tmp.mat[i,k]==0 & subdata[j,k]==1|tmp.mat[i,k]==0 & subdata[j,k]==0) {match.matrix[j,k]<-1}
        }
      }
      if(is.vector(tmp.mat)) 
      {
        for (k in 1:length(tmp.mat))
        {
          if (tmp.mat[k]==1 & subdata[j,k]==1) {match.matrix[j,k]<-1}
          if (tmp.mat[k]==-1 & subdata[j,k]==0) {match.matrix[j,k]<-1}
          if (tmp.mat[k]==0 & subdata[j,k]==1|tmp.mat[k]==0 & subdata[j,k]==0) {match.matrix[j,k]<-1}
        }
      }
      pimp.datamat[j,i]<-ifelse(all(match.matrix[j,]==1), 1, 0)
    }
  }
  pimp.datamat<-abs(indcomp-pimp.datamat)
  pimp.names<-pimps.out$vec.primes
  pimp.info<-list(pimp.names=pimp.names, pimp.datamat=pimp.datamat)
  pimp.info 
}