fix code and test compliance

Author: jtanevski

DESCRIPTION

@@ -41,7 +41,7 @@ Encoding: UTF-8
 VignetteBuilder: knitr
 Imports: assertthat, caret, deldir, digest, distances, dplyr, filelock, 
     furrr (>= 0.2.0), ggplot2, methods, purrr, ranger, readr, ridge, rlang, 
-    rlist, R.utils, stats, stringr, tibble, tidyr, utils, withr
+    rlist, R.utils, stats, stringr, tibble, tidyr, tidyselect, utils, withr
 Suggests: BiocStyle, covr, earth, future, igraph (>= 1.2.7), iml, kernlab, 
     knitr, MASS, rmarkdown, RSNNS, testthat (>= 3.0.0), xgboost
 RoxygenNote: 7.2.0

NEWS.md

@@ -1,7 +1,6 @@
 # mistyR 1.5.x
 - Added different modeling functions. Might not be completely backwards compatible!
 
-
 # mistyR 1.4.0
 
 - Release version for Bioconductor 3.15. See changes for 1.3.x.

R/misty.R

@@ -134,6 +134,9 @@ run_misty <- function(views, results.folder = "results", seed = 42,
                       model.function = random_forest_model, ...) {
 
   model.name <- as.character(rlang::enexpr(model.function))
+  
+  if(!exists(model.name, envir = globalenv()))
+    model.function <- utils::getFromNamespace(model.name, "mistyR")
 
   normalized.results.folder <- R.utils::getAbsolutePath(results.folder)
 

R/model-functions.R

@@ -114,10 +114,10 @@ gradient_boosting_model <- function(view_data, target, seed, k = 10, ...) {
       dplyr::select(-tidyselect::all_of(target)) %>%
       as.matrix()
 
-    label.hat <- predict(model, pred.test)
+    label.hat <- stats::predict(model, pred.test)
 
     tibble::tibble(index = holdout, prediction = label.hat)
-  }) %>% dplyr::arrange(index)
+  }) %>% dplyr::arrange(.data$index)
 
   predictors <- view_data %>%
     dplyr::select(-tidyselect::all_of(target)) %>%
@@ -214,7 +214,7 @@ bagged_mars_model <- function(view_data, target, seed,
 
     oob <- seq.int(1, nrow(view_data))[!(seq.int(1, nrow(view_data)) %in% bag)]
 
-    pred <- predict(model, view_data[oob, ])
+    pred <- stats::predict(model, view_data[oob, ])
     list(
       model = model,
       prediction = tibble::tibble(index = oob, prediction = as.vector(pred))
@@ -225,9 +225,9 @@ bagged_mars_model <- function(view_data, target, seed,
   predictions <- purrr::map_dfr(models, function(model) {
     tibble::tibble(model$prediction)
   }) %>%
-    dplyr::group_by(index) %>%
-    dplyr::summarise(prediction = mean(prediction)) %>%
-    dplyr::arrange(index)
+    dplyr::group_by(.data$index) %>%
+    dplyr::summarise(prediction = mean(.data$prediction)) %>%
+    dplyr::arrange(.data$index)
 
   assertthat::assert_that(nrow(predictions) == nrow(view_data),
     msg = "There are too few bags to get OOB predictions for all observations.
@@ -305,10 +305,10 @@ mars_model <- function(view_data, target, seed, approx = 1.0, k = 10, ...) {
 
     model <- do.call(earth::earth, algo.arguments)
 
-    label.hat <- predict(model, test)
+    label.hat <- stats::predict(model, test)
 
     tibble::tibble(index = holdout, prediction = label.hat[,1])
-  }) %>% dplyr::arrange(index)
+  }) %>% dplyr::arrange(.data$index)
 
   algo.arguments.wm <- list(
     formula = stats::as.formula(paste0(target, " ~ .")),
@@ -365,10 +365,10 @@ linear_model <- function(view_data, target, seed, k = 10, ...) {
 
     model <- do.call(stats::lm, algo.arguments)
 
-    pred <- predict.lm(model, view_data[holdout, ])
+    pred <- stats::predict(model, view_data[holdout, ])
 
     tibble::tibble(index = holdout, prediction = as.vector(pred))
-  }) %>% dplyr::arrange(index)
+  }) %>% dplyr::arrange(.data$index)
 
   algo.arguments.wm <- list(
     formula = stats::as.formula(paste0(target, " ~ .")),
@@ -443,7 +443,7 @@ svm_model <- function(view_data, target, seed, approx = 0.4, k = 10, ...) {
     pred <- kernlab::predict(model, view_data[holdout, ])
 
     tibble::tibble(index = holdout, prediction = as.vector(pred))
-  }) %>% dplyr::arrange(index)
+  }) %>% dplyr::arrange(.data$index)
 
   algo.arguments.wm <- list(
     x = stats::as.formula(paste0(target, " ~ .")),
@@ -533,10 +533,10 @@ mlp_model <- function(view_data, target, seed, approx = 0.6, k = 10, ...) {
 
     model <- do.call(RSNNS::mlp, algo.arguments)
 
-    label.hat <- predict(model, X_test)
+    label.hat <- stats::predict(model, X_test)
 
     tibble::tibble(index = holdout, prediction = label.hat[,1])
-  }) %>% dplyr::arrange(index)
+  }) %>% dplyr::arrange(.data$index)
 
   algo.arguments.wm <- list(
     x = X,

tests/testthat/test-misty.R

@@ -99,20 +99,20 @@ test_that("warning raised if variance of variable is 0", {
 })
 
 test_that("all models work and produce the correct output", {
-  functions <- list("rf" = random_forest_model, 
-                    "bag_mars" = bagged_mars_model, 
-                    "mars" = mars_model,
-                    "linear" = linear_model,
-                    "svm" = svm_model,
-                    "boosting" = gradient_boosting_model,
-                    "mpl" = mlp_model)
+  functions <- list("rf" = rlang::expr(random_forest_model), 
+                    "bag_mars" = rlang::expr(bagged_mars_model), 
+                    "mars" = rlang::expr(mars_model),
+                    "linear" = rlang::expr(linear_model),
+                    "svm" = rlang::expr(svm_model),
+                    "boosting" = rlang::expr(gradient_boosting_model),
+                    "mpl" = rlang::expr(mlp_model))
 
   ncols <- 5
   expr <- generate_random_tibble(100, ncols)
   misty.views <- create_initial_view(expr)
 
-  misty.test <- purrr::map(functions, function(fun) {
-    suppressWarnings(misty.results <- run_misty(misty.views, model.function = fun) %>%
+  misty.test <- purrr::walk(functions, function(fun) {
+    suppressWarnings(misty.results <- run_misty(misty.views, model.function = !!fun) %>%
       collect_results()
     )
     expect_true(dir.exists("results"))
@@ -135,114 +135,18 @@ test_that("ellipsis arguments can be passed to the provided ML models", {
   misty.views <- create_initial_view(expr) %>%
     add_paraview(positions = pos, l = 10)
 
-  # random forest
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = random_forest_model)
-  )
-  end <- Sys.time()
-  first.run = end - start
-  
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = random_forest_model, 
-                          num.trees = 2000)
-  )
-  end <- Sys.time()
-  second.run = end - start
-  testthat::expect_true(first.run < second.run)
-  
-  # bagged mars
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = bagged_mars_model,
-                          degree = 1)
-  )
-  end <- Sys.time()
-  first.run = end - start
-  
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = bagged_mars_model, 
-                          n.bags = 50)
+  suppressWarnings(misty.test <- run_misty(misty.views, model.function = mars_model, 
+                                        degree = 3, nk = 30, cached = TRUE)
   )
-  end <- Sys.time()
-  second.run = end - start
-  testthat::expect_true(first.run < second.run)
 
-  # mars
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = mars_model,
-                          degree = 3, nk = 30)
-  )
-  end <- Sys.time()
-  first.run = end - start
-  
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = mars_model, 
-                          degree = 3, nk = 30)
-  )
-  end <- Sys.time()
-  second.run = end - start
-  testthat::expect_true(first.run < second.run)
-  
-  # svm
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = svm_model,
-                          C = 1)
-  )
-  end <- Sys.time()
-  first.run = end - start
-  
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = svm_model, 
-                          C = 100)
-  )
-  end <- Sys.time()
-  second.run = end - start
-  testthat::expect_true(first.run < second.run)
-  
-  # gradient boosting
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = gradient_boosting_model,
-                          booster = "gbtree", nrounds = 10)
-  )
-  end <- Sys.time()
-  first.run = end - start
-  
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = gradient_boosting_model, 
-                          booster = "gbtree", nrounds = 20)
-  )
-  end <- Sys.time()
-  second.run = end - start
-  testthat::expect_true(first.run < second.run)
-
-  # multi-layer perceptron
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = mlp_model,
-                          size = c(1), maxit = 1)
-  )
-  end <- Sys.time()
-  first.run = end - start
-  
-  start <- Sys.time()
-  suppressWarnings(
-  misty.test <- run_misty(misty.views, model.function = mlp_model, 
-                          size = c(10), maxit = 100)
-  )
-  end <- Sys.time()
-  second.run = end - start
-  testthat::expect_true(first.run < second.run)
-  
-  unlink("results", recursive = TRUE)
+ cache.folder <- paste0(".misty.temp/", misty.views[["misty.uniqueid"]])
+ cached.files <- list.files(cache.folder)
+ 
+ expect_true(all(stringr::str_detect(cached.files, "mars_model")) & 
+               all(stringr::str_detect(cached.files, "degree.3.nk.30")))
+ 
+ clear_cache()
+ unlink("results", recursive = TRUE)
 })
 
 test_that("k for cv , n.bags for bagging can be changed and approx works", {