R/misc.R

In fftrees: Fast- and Frugal Tree Analysis

# MISC
# Intent:
#   This function suppresses the following notes generated by "R CMD check":
#   - "Note: no visible binding for global variable '.->ConfigString'"
#   - "Note: no visible binding for '<<-' assignment to 'ConfigString'"
# Usage:
#   Add the following right in the beginning of the .r file (before the Reference
#   class is defined in the sourced .r file):
#   suppressBindingNotes(c(".->ConfigString","ConfigString"))
.suppressBindingNotes <- function(variablesMentionedInNotes) {
  for(variable in variablesMentionedInNotes) {
    assign(variable,NULL, envir = .GlobalEnv)       
  }
}


.onLoad <- function(libname,pkgname){
  
  #.suppressBindingNotes(".Data")
  #.suppressBindingNotes("shell.exec")
  #.suppressBindingNotes("opt")
  #.suppressBindingNotes("Package")
  #.suppressBindingNotes("LibPath")
  .suppressBindingNotes("i")
  .suppressBindingNotes("result")
  .suppressBindingNotes("fftcues")
  .suppressBindingNotes("predicts")
  if(require(compiler)){
    setCompilerOptions("suppressAll", TRUE)
    compilePKGS(enable=TRUE)
    enableJIT(3)
    
    packageStartupMessage("Package 'compiler' found and activated. Ignore notes about missing 'visible binding for global variable'.")
  }else{
    packageStartupMessage("Package 'compiler' isn't installed. For huge performance boost install it, and reload ",pkgname,".")
  }
}

.logger <- function(...,sep="",digits=4){
  
  pst <- function(...) paste(...,sep=sep)
  
  cat("[",format(Sys.time(), "%X"),"] ",sep="")
  content <- lapply(X=list(...), function(x) ifelse(is.numeric(x), signif(round(x,digits),digits+1),x))
  
  all <- do.call(pst, content)
  cat(all,"\n")
}  

#' Prepares Titanic data for fftm
#'
#' @name fftm.Titanic.data
#' @return data.frame with modified titanic data
#' @seealso \code{\link{Fftm}}
#' ...
fftm.Titanic.data <- function(){
  data(Titanic)
  #Get Titanic Data
  tiData <- as.data.frame(Titanic,stringsAsFactors=F)
  
  #Extract Columns with Freq > 0 (the others aren't interesting)
  tiData <- tiData[tiData$Freq > 0,]
  
  #Make linear data
  tiData[tiData$Class == "Crew","Class"] <- 0
  tiData[tiData$Class == "1st" ,"Class"] <- 1
  tiData[tiData$Class == "2nd" ,"Class"] <- 2
  tiData[tiData$Class == "3rd" ,"Class"] <- 3
  
  tiData[tiData$Sex == "Female", "Sex"] <- 1
  tiData[tiData$Sex == "Male"  , "Sex"] <- 2
  
  tiData[tiData$Age == "Child" , "Age"] <- 1
  tiData[tiData$Age == "Adult" , "Age"] <- 2
  
  tiData[tiData$Survived == "No", "Survived"]  <- 0
  tiData[tiData$Survived == "Yes", "Survived"] <- 1
  
  #Convert all columns to numeric
  tiData <- as.data.frame(apply(tiData,MARGIN=c(2),as.numeric))
  
  #Expand Frequency
  expTiData <- do.call(rbind, apply(tiData,MARGIN=c(1), function(x) matrix(data=rep(x[1:4], x[5]), ncol=4, byrow=TRUE)))
  colnames(expTiData) <- colnames(as.data.frame(Titanic)[-5])
  
  return(data.frame(expTiData))
}


#' Prepares Titanic data for fftm
#'
#' @name fftm.Titanic.data
#' @return data.frame with modified titanic data
#' @seealso \code{\link{Fftm}}
#' ...
fftm.UCBAdmissions.data <- function(){
  data(UCBAdmissions)
  #Get Titanic Data
  ucbData <- as.data.frame(UCBAdmissions,stringsAsFactors=F)
  
  #Extract Columns with Freq > 0 (the others aren't interesting)
  ucbData <- ucbData[ucbData$Freq > 0,]
  
  #Make linear data
  ucbData[ucbData$Dept == "A" ,"Dept"] <- 1
  ucbData[ucbData$Dept == "B" ,"Dept"] <- 2
  ucbData[ucbData$Dept == "C" ,"Dept"] <- 3
  ucbData[ucbData$Dept == "D" ,"Dept"] <- 4
  ucbData[ucbData$Dept == "E" ,"Dept"] <- 5
  ucbData[ucbData$Dept == "F" ,"Dept"] <- 6
  
  ucbData[ucbData$Gender == "Female", "Gender"] <- 1
  ucbData[ucbData$Gender == "Male"  , "Gender"] <- 2
  
  ucbData[ucbData$Admit == "Rejected", "Admit"] <- 1
  ucbData[ucbData$Admit == "Admitted", "Admit"] <- 2
  
  
  #Convert all columns to numeric
  ucbData <- as.data.frame(apply(ucbData,MARGIN=c(2),as.numeric))
  
  #Expand Frequency
  expUcbData <- do.call(rbind, apply(ucbData,MARGIN=c(1), function(x) matrix(data=rep(x[1:3], x[4]), ncol=3, byrow=TRUE)))
  colnames(expUcbData) <- colnames(as.data.frame(UCBAdmissions)[-4])
  
  return(data.frame(expUcbData))
}