Fix independent evaluation and add new functions

NAMESPACE

@@ -36,6 +36,7 @@ export(plot_explore_partition)
 export(plot_importance)
 export(predict.glmnet_mx)
 export(predict_selected)
+export(prediction_changes)
 export(prepare_data)
 export(prepare_projection)
 export(prepare_user_data)
@@ -49,6 +50,7 @@ export(remove_duplicates)
 export(remove_missing)
 export(response_curve)
 export(select_models)
+export(single_mop)
 export(sort_columns)
 export(variable_importance)
 importFrom(doSNOW,registerDoSNOW)
@@ -87,6 +89,7 @@ importFrom(graphics,text)
 importFrom(graphics,title)
 importFrom(mgcv,gam)
 importFrom(mop,mop)
+importFrom(parallel,detectCores)
 importFrom(parallel,makeCluster)
 importFrom(parallel,stopCluster)
 importFrom(stats,aggregate)
@@ -122,6 +125,7 @@ importFrom(terra,diff)
 importFrom(terra,distance)
 importFrom(terra,ext)
 importFrom(terra,extract)
+importFrom(terra,is.factor)
 importFrom(terra,levels)
 importFrom(terra,mask)
 importFrom(terra,mean)

R/colors_for_changes.R

@@ -94,6 +94,35 @@ colors_for_changes <- function(changes_projections, gain_color = "#009E73",
                                stable_unsuitable = "grey",
                                max_alpha = 1, min_alpha = 0.25){
 
+  #### Check data ####
+  if(!inherits(changes_projections, "changes_projections")){
+    stop("Argument 'changes_projections' must be an object of class 'changes_projections'")
+  }
+
+  if (!inherits(gain_color, "character") || length(gain_color) > 1) {
+    stop("Argument 'gain_color' must be a single 'character' value.")
+  }
+  if (!inherits(loss_color, "character") || length(loss_color) > 1) {
+    stop("Argument 'loss_color' must be a single 'character' value.")
+  }
+  if (!inherits(stable_suitable, "character") || length(stable_suitable) > 1) {
+    stop("Argument 'stable_suitable' must be a single 'character' value.")
+  }
+  if (!inherits(stable_unsuitable, "character") || length(stable_unsuitable) > 1) {
+    stop("Argument 'stable_unsuitable' must be a single 'character' value.")
+  }
+  if(!inherits(max_alpha, "numeric") || length(max_alpha) > 1 ||
+     min(max_alpha) < 0 || max(max_alpha) > 1){
+    stop("Argument 'max_alpha' must be a single numeric value between 0 and 1")
+  }
+  if(!inherits(min_alpha, "numeric") || length(min_alpha) > 1 ||
+     min(min_alpha) < 0 || max(min_alpha) > 1){
+    stop("Argument 'min_alpha' must be a single numeric value between 0 and 1")
+  }
+  if(min_alpha >= max_alpha){
+    stop("Argument 'min_alpha' can't be equal or higher than 'max_alpha'")
+  }
+
   #Create list to save results
   r <- list()
 

R/independent_evaluation.R

@@ -222,7 +222,7 @@ independent_evaluation <- function(fitted_models, new_data,
 
   #Check variables
   v <- unique(unlist(sapply(fitted_models$Models, function(x)
-    names(x$Full_model$betas)[-1],
+    names(x$Full_model$varmax)[-1],
     simplify = F)))
   v <- gsub("I\\((.*?)\\^2\\)", "\\1", v) #Remove quadratic pattern
   v <- v[!grepl("categorical", v)] #Remove categorical pattern
@@ -236,7 +236,7 @@ independent_evaluation <- function(fitted_models, new_data,
 
   #Predict to independent records
   pred_test <- predict_selected(models = fitted_models,
-                                new_variables = new_data[,v],
+                                new_variables = new_data[,v, drop = FALSE],
                                 consensus = consensus,
                                 extrapolation_type = extrapolation_type,
                                 var_to_restrict = var_to_restrict,
@@ -248,7 +248,7 @@ independent_evaluation <- function(fitted_models, new_data,
   #Predict to background
   bg_data <- fitted_models$calibration_data
   pred_bg <- predict_selected(models = fitted_models,
-                              new_variables = bg_data[,v],
+                              new_variables = bg_data[,v, drop = FALSE],
                               consensus = consensus,
                               extrapolation_type = extrapolation_type,
                               var_to_restrict = var_to_restrict,
@@ -277,7 +277,7 @@ independent_evaluation <- function(fitted_models, new_data,
   names(thr)[names(thr) == "consensus"] <- "General_consensus"
 
   res <- lapply(names(pred_test), function(i){
-    #print(i)
+    # print(i)
     #Get pred test i
     p_i <- pred_test[[i]]
 
@@ -296,11 +296,15 @@ independent_evaluation <- function(fitted_models, new_data,
 
     #Calculate proc
     proc_i <- lapply(names(p_i), function(x){
-      fpROC::auc_metrics(test_prediction = p_i[[x]],
+      res_x <- fpROC::auc_metrics(test_prediction = p_i[[x]],
                          prediction = bg_i[[x]],
                          threshold = fitted_models$omission_rate)$summary[, 4:5]
+      if(is.null(res_x)){
+        res_x <- c(Mean_AUC_ratio = NA, pval_pROC = NA)
+      }
+      return(res_x)
     })
-    names(proc_i) <- names(p_i$Model_consensus)
+    names(proc_i) <- names(p_i)
     proc_i <- as.data.frame(do.call(rbind, proc_i))
 
     #Save results

R/predict_selected.R

@@ -554,6 +554,7 @@ predict_selected <- function(models,
 
     names(res) <- nm
     res$General_consensus <- as.data.frame(gen_res)
+    colnames(res$General_consensus) <- names(gen_res)
   }
 
   # Write results to disk if required