CLASSRFPERF

BEGIN
sys.rqScriptDrop('CLASSRFPERF');
sys.rqScriptCreate('CLASSRFPERF','function(p_dataframe,perc_over,perc_under,kn,isR,p_spltratio,pY,p_imputetype,ds.name){                 
  #--------------------------------------------------------------------------
  ## FORMULA for Model Building
  #--------------------------------------------------------------------------     
  
  p_formula <- as.formula(paste(tail(names(p_dataframe), 1) , paste(head(names(p_dataframe), -1), collapse=" + "), sep=" ~ "))  
  
  #--------------------------------------------------------------------------
  ## PARAMETERS for Model Building
  #--------------------------------------------------------------------------  
  
  p_topn = 20         
  
  #-----------------------------------------------------------------------------
  ## 0.Model Metrix Evaluation
  #-----------------------------------------------------------------------------
  
  Evaluate <- function(actual=NULL, predicted=NULL, cm=NULL){
    if(is.null(cm)) {
      naVals = union(which(is.na(actual)), which(is.na(predicted)))
      if(length(naVals) > 0) {
        actual = actual[-naVals]
        predicted = predicted[-naVals]
      }
      f = factor(union(unique(actual), unique(predicted)))
      actual = factor(actual, levels = levels(f))
      predicted = factor(predicted, levels = levels(f))
      cm = as.matrix(table(Actual=actual, Predicted=predicted))
    }
    
    n = sum(cm)                 # number of instances
    nc = nrow(cm)               # number of classes
    diag = diag(cm)             # number of correctly classified instances per class
    rowsums = apply(cm, 1, sum) # number of instances per class
    colsums = apply(cm, 2, sum) # number of predictions per class
    p = rowsums / n             # distribution of instances over the classes
    q = colsums / n             # distribution of instances over the predicted classes
    
    #accuracy
    accuracy = sum(diag) / n
    
    #per class prf
    recall = diag / rowsums
    precision = diag / colsums
    f1 = 2 * precision * recall / (precision + recall)
    
    #macro prf
    macroPrecision = mean(precision)
    macroRecall = mean(recall)
    macroF1 = mean(f1)
    
    #1-vs-all matrix
    oneVsAll = lapply(1 : nc,
                      function(i){
                        v = c(cm[i,i],
                              rowsums[i] - cm[i,i],
                              colsums[i] - cm[i,i],
                              n-rowsums[i] - colsums[i] + cm[i,i]);
                        return(matrix(v, nrow = 2, byrow = T))})
    
    s = matrix(0, nrow=2, ncol=2)
    for(i in 1:nc){s=s+oneVsAll[[i]]}
    
    #avg accuracy
    avgAccuracy = sum(diag(s))/sum(s)
    
    #micro prf
    microPrf = (diag(s) / apply(s,1, sum))[1];
    
    #majority class
    mcIndex = which(rowsums==max(rowsums))[1] # majority-class index
    mcAccuracy = as.numeric(p[mcIndex])
    mcRecall = 0*p;  mcRecall[mcIndex] = 1
    mcPrecision = 0*p; mcPrecision[mcIndex] = p[mcIndex]
    mcF1 = 0*p; mcF1[mcIndex] = 2 * mcPrecision[mcIndex] /
      (mcPrecision[mcIndex] + 1)
    
    #random/expected accuracy
    expAccuracy = sum(p*q)
    #kappa
    kappa = (accuracy - expAccuracy) / (1 - expAccuracy)
    
    #random guess
    rgAccuracy = 1 / nc
    rgPrecision = p
    rgRecall = 0*p + 1 / nc
    rgF1 = 2 * p / (nc * p + 1)
    
    #random weighted guess
    rwgAccurcy = sum(p^2)
    rwgPrecision = p
    rwgRecall = p
    rwgF1 = p
    
    classNames = names(diag)
    if(is.null(classNames)) classNames = paste("C",(1:nc),sep="")
    
    metrics = rbind(
      Accuracy = accuracy,
      Precision = precision,
      Recall = recall,
      F1 = f1,
      MacroAvgPrecision = macroPrecision,
      MacroAvgRecall = macroRecall,
      MacroAvgF1 = macroF1,
      AvgAccuracy = avgAccuracy,
      MicroAvgPrecision = microPrf,
      MicroAvgRecall = microPrf,
      MicroAvgF1 = microPrf,
      MajorityClassAccuracy = mcAccuracy,
      MajorityClassPrecision = mcPrecision,
      MajorityClassRecall = mcRecall,
      MajorityClassF1 = mcF1,
      Kappa = kappa,
      RandomGuessAccuracy = rgAccuracy,
      RandomGuessPrecision = rgPrecision,
      RandomGuessRecall = rgRecall,
      RandomGuessF1 = rgF1,
      RandomWeightedGuessAccuracy = rwgAccurcy,
      RandomWeightedGuessPrecision = rwgPrecision,
      RandomWeightedGuessRecall = rwgRecall,
      RandomWeightedGuessF1 = rwgF1)
    
    colnames(metrics) = classNames    
     
    lst_metrics <- (list(ConfusionMatrix = cm, Metrics = metrics))
    return(lst_metrics)
  }
  
  #-------------------------------------------------------------------------
  ## 0.Data splitting into train and validation Set
  #-------------------------------------------------------------------------
  data.split <- function(df,resVal,seedvalue,spltratio)
  {
    library(caTools)
    set.seed(seedvalue)
    split <- sample.split(Y = df[ ,resVal],SplitRatio = spltratio)				  
  }            			
  
  #-------------------------------------------------------------------------
  ## 1.Building Random Forest Model
  #-------------------------------------------------------------------------
  
  mdl.training.RF <- function(p_trainx,p_trainy){
    library(randomForest)
    
    get_oob_err <- function(model){
      a <- capture.output(model)[8]
      m <- gregexpr("\\(?[0-9,.]+",a)
      return(as.numeric(regmatches(a,m)[[1]])) 
    }
    
    # Intialize err_arr
    err_arr <- c()
    ntree_vec <- c(101,201,301,401,501,601,701,801,901,1001,1101,1201,1301,1401,1501)
    
    # Looping through various ntree values
    for(i in 1:length(ntree_vec))
    {
      #set.seed(456)
      model <- randomForest(x = p_trainx,y = as.factor(p_trainy),ntree=ntree_vec[i])
      #print(model)
      err_arr[i] <- get_oob_err(model)
    }
    print(err_arr)
    
    # Optimum No. of Trees
    opti_ntrees <- min(ntree_vec[which(err_arr == min(err_arr))])
    print(opti_ntrees)
    
    # mtry tuning
    trf <- tuneRF(x = p_trainx ,y = as.factor(p_trainy), mtryStart=2, ntreeTry=1501, stepFactor=2, improve=0.05, trace=T, plot=FALSE)
    opti_mtry <- trf[which.min(trf[ ,"OOBError"])]
    
    # Building Model WITH tuned mtry and ntrees
    #set.seed(456)
    mdl <- randomForest(x = p_trainx,y = p_trainy,ntree=opti_ntrees,mtry=opti_mtry,importance = TRUE,keep.forest = T)  
    
    return(mdl)
  }
  
  #-------------------------------------------------------------------------
  ## 3.Model Metrics Display
  # What percent of your predictions were correct?- Accuracy                    
  # What percent of the positive cases did you catch? - recall
  # What percent of positive predictions were correct? - precision
  #-------------------------------------------------------------------------
  
  
  #-------------------------------------------------------------------------
  ## 3.1.Model Metrics Display Cross-validation
  # What percent of your predictions were correct?- Accuracy                    
  # What percent of the positive cases did you catch? - recall
  # What percent of positive predictions were correct? - precision
  #-------------------------------------------------------------------------
 

  # -------------------------------------------------------------------
  ## 5.Data Imputation
  #--------------------------------------------------------------------
  
  impute.data <- function(data,imputetype="mean")
  {
    ## This function imputes NA by mean or median values
    if(imputetype == "mean"){
      for (i in which(sapply(data, is.numeric))) {
        data[is.na(data[, i]), i] <- mean(data[, i],  na.rm = TRUE)
      }
    } else if(imputetype == "median") {
      for (i in which(sapply(data, is.numeric))) {
        data[is.na(data[, i]), i] <- median(data[, i],  na.rm = TRUE)
      }
    } else if(imputetype == "knn"){
      library(DMwR)      
      data <- knnImputation(data = data)
    }else{
      stop("wrong imputation type.Only mean,median and knn is supported")
    }
    
    return(data)
  }	
  
  # -------------------------------------------------------------------
  ## 6.Converting formula to vectors of string
  #--------------------------------------------------------------------	
  
  x_variables <- function(form,Y)
  {
    aa <- gsub(pattern =" ",replacement="",x=paste0(format(form), collapse = ""))
    bb <- gsub(pattern = "[+~]",replacement=",",x=aa)
    cc <- unlist(strsplit(x = bb,split = "[,]"))
    xcols <- cc[!cc %in% c(Y)]			  
    return(xcols)
  }
  
  # -------------------------------------------------------------------
  ## 7.Rare Class Balancing
  #--------------------------------------------------------------------	                      
  imbalance_correction <- function(form,data,perc.over,perc.under,k,isRequired)
  {
    # Handling class Imbalance
    library(DMwR)                          
    if(isRequired == "Y"){
      data_bal <- SMOTE(form = form,data = data,perc.over = perc.over,k = k,perc.under = perc.under) 
      return(data_bal)
    }
    else{
      return(data)
    }
  }
  
  # -------------------------------------------------------------------
  ## 8.Cross-Validation
  #--------------------------------------------------------------------	
  
  ore_cv <- function(data,form,pY,ds.name,imputetype){
    
    # 10 Fold CV
    k <- 10
    
    # sample from 1 to k, nrow times (the number of observations in the data_test)
    data$id <- sample(1:k, nrow(data), replace = TRUE)
    list <- 1:k
    
    for (i in 1:k){
      # remove rows with id i from data to create training set
      # select rows with id i to create test set
      cv.train <- subset(data, id %in% list[-i])
      cv.test <- subset(data, id %in% c(i))
      
      # Imputing the NA on main dataset
      cv.train <- impute.data(data = cv.train,imputetype = imputetype)
      cv.test <- impute.data(data = cv.test,imputetype = imputetype)   
      
      # Extracting only X columns
      cv.trainx <- cv.train[ ,x_variables(form,pY)]
      
      # Extracting Y column
      cv.trainy <- cv.train[,pY]
      
      ## Conversion of CHAR columns to FACTOR
      # Training Data Predictors
      cv.trainx[sapply(cv.trainx, is.character)] <- lapply(cv.trainx[sapply(cv.trainx, is.character)], as.factor)
      
      # Validation Data Predictors
      cv.test[sapply(cv.test, is.character)] <- lapply(cv.test[sapply(cv.test, is.character)], as.factor)
      
      # run a random forest model
      cv.modRF <- mdl.training.RF(p_trainx = cv.trainx,p_trainy = cv.trainy)
      
      # Calculating Metric
      # ENTER THE CODE
      #cv.metric <- paste0("CV_Metric_",i,"_Fold")
      
      # Assigning Name to a variable
      assign(x = cv.metric,value = cv.mdl_metric_RF)
      
      # Saving to ore Store
      ore.save(list = c(cv.metric),name = ds.name,append = TRUE)
    }
  }
  
  ######################################################
  ## THE MAIN FUNCTION ##
  ## This is the Entry point
  ######################################################                  	    
  
  # Pulling dataset into ORE transparency Layer
  dataset <- ore.pull(p_dataframe)   
  
  ## Find which columns are factors
  factor_cols <- names(dataset)[sapply(dataset,is.character)]            
  
  ## Converting training character columns to factor
  dataset[, factor_cols] <- lapply(dataset[, factor_cols], as.factor) 
  
  # Handling class Imbalance
  dataset_bal <- imbalance_correction(form = p_formula,data = dataset,perc.over = perc_over,perc.under = perc_under,k = kn,isRequired = isR)
  
  ## Data splitting into training and validation set
  splt <- data.split(df = dataset_bal,resVal = pY,seedvalue = 1000,spltratio = p_spltratio)
  
  # Creation of training and validation set
  training <- subset(x = dataset_bal,splt == TRUE)
  validation <- subset(x = dataset_bal,splt == FALSE)                      
  
  # Seeing the distribution in Balanced Set
  bal <- table(training[,pY])
  
  # Imputing the NA on main dataset
  training_imputed <- impute.data(data = training,imputetype = p_imputetype)
  validation_imputed <- impute.data(data = validation,imputetype = p_imputetype)    
  dataset_bal_imputed <- impute.data(data = dataset_bal,imputetype = p_imputetype) 
  
  print("##########################################################")
  print("***1.Model Building -  RandomForest on Train/Test Split...")
  print("##########################################################")
  
  # Extracting only X columns
  p_trainx <- training_imputed[ ,x_variables(p_formula,pY)]
  
  # Extracting Y column
  p_trainy <- training_imputed[,pY]
  
  ## Conversion of CHAR columns to FACTOR
  # Training Data Predictors
  p_trainx[sapply(p_trainx, is.character)] <- lapply(p_trainx[sapply(p_trainx, is.character)], as.factor)
  
  # Validation Data Predictors
  validation_imputed[sapply(validation_imputed, is.character)] <- lapply(validation_imputed[sapply(validation_imputed, is.character)], as.factor)
  
  print("***2.Training the RF Model")
  modRF <- mdl.training.RF(p_trainx = p_trainx,p_trainy = p_trainy)
  
  # Predicted on Test dataset
  modRFPred <- predict(object = modRF,newdata = validation_imputed,type = "response")
  
  print("***3.Random Forest Variable Importance")
  print(varImpPlot(modRF))
  
  varImp <- modRF$importance
  varImp_MDG <- varImp[order(varImp[,2],decreasing = T),][,c(1,2)]
  varImp_MDA <- varImp[order(varImp[,3],decreasing = T),][,c(1,3)]
  
  print("#################################################")
  print("***.COMPLETED - Model Building -  Random Forest...")
  print("#################################################")
  
  print("#################################################")
  print("*** Start  Random Forest on Full Set...")
  print("#################################################") 
  
  # Extracting only X columns
  p_trainx_full <- dataset_bal[ ,x_variables(p_formula,pY)]
  
  # Extracting Y column
  p_trainy_full <- dataset_bal[,pY]
  
  print("***2.Training the RF Model")
  modRF_Full <- mdl.training.RF(p_trainx = p_trainx_full,p_trainy = p_trainy_full)
  
  # Predicting on whole dataset
  # Predicted on Test dataset
  modRFPred_Full <- predict(object = modRF_Full,newdata = dataset_bal_imputed,type = "response")
  
  print("#################################################")
  print("*** End Random Forest on Full Set...")
  print("#################################################") 
  
  if (nrow(ore.datastore(name=ds.name)) > 0 ) 
  {
    ore.delete(name = ds.name)
  }
  ore.save(modRF,name = ds.name,append = TRUE)
  ore.save(varImp,name = ds.name,append= TRUE)
  ore.save(varImp_MDG,name = ds.name,append= TRUE)
  ore.save(varImp_MDA,name = ds.name,append= TRUE)
  ore.save(bal,name = ds.name,append= TRUE)
  ore.save(modRF_Full,name = ds.name,append= TRUE)
  
  print("***3.Model Metrics for Train/Test Split...")
  mdl_metric_RF_Full <- Evaluate(actual=dataset_bal_imputed[,pY], predicted=modRFPred_Full)
  mdl_metric_RF <- Evaluate(actual=validation_imputed[,pY], predicted=modRFPred)
  
  #ore.save(mdl_metric_RF_Full,name = ds.name,append= TRUE)
  ore.save(mdl_metric_RF,name = ds.name,append= TRUE)
  
  # Returning the Metrics                   
    mtx <- mdl_metric_RF[[2]]
    metric_df <- data.frame(METRIC=row.names(mtx),SCORE_RATING2=mtx[,1],SCORE_RATING3=mtx[,2],SCORE_RATING4=mtx[,3],SCORE_RATING5=mtx[,4])
    metric_df
}');
END;