Merge pull request #1812 from cmu-delphi/ndefries/backfill/lp-solver-opt

[Backfill corrections] Force modeling to use GLPK if gurobi license info isn't provided

Author: krivard

backfill_corrections/delphiBackfillCorrection/DESCRIPTION

@@ -32,6 +32,7 @@ Suggests:
     knitr (>= 1.15),
     rmarkdown (>= 1.4),
     testthat (>= 1.0.1),
-    covr (>= 2.2.2)
+    covr (>= 2.2.2),
+    mockr
 RoxygenNote: 7.2.0
 Encoding: UTF-8

backfill_corrections/delphiBackfillCorrection/R/model.R

@@ -131,7 +131,10 @@ model_training_and_testing <- function(train_data, test_data, taus, covariates,
 
         success = success + 1
       },
-      error=function(e) {msg_ts("Training failed for ", model_path)}
+      error=function(e) {
+        msg_ts("Training failed for ", model_path, ". Check that your gurobi ",
+          "license is valid and being passed properly to the program.")
+      }
     )
   }
   if (success < length(taus)) {return (NULL)}

backfill_corrections/delphiBackfillCorrection/R/utils.R

@@ -67,9 +67,37 @@ read_params <- function(path = "params.json", template_path = "params.json.templ
   # Model parameters
   if (!("taus" %in% names(params))) {params$taus <- TAUS}
   if (!("lambda" %in% names(params))) {params$lambda <- LAMBDA}
-  if (!("lp_solver" %in% names(params))) {params$lp_solver <- LP_SOLVER}
   if (!("lag_pad" %in% names(params))) {params$lag_pad <- LAG_PAD}
 
+  if ("lp_solver" %in% names(params)) {
+    params$lp_solver <- match.arg(params$lp_solver, c("gurobi", "glpk"))
+  } else {
+    params$lp_solver <- LP_SOLVER
+  }
+  if (params$lp_solver == "gurobi") {
+    # Make call to gurobi CLI to check license. Returns a status of `0` if
+    # license can be found and is valid.
+    tryCatch(
+      expr = {
+        license_status <- run_cli("gurobi_cl")
+      },
+      error=function(e) {
+        if (grepl("Error 10032: License has expired", e$message, fixed=TRUE)) {
+          stop("The gurobi license has expired. Please renew or switch to ",
+            "using glpk. lp_solver can be specified in params.json.")
+        }
+        msg_ts(e$message)
+        license_status <- 1
+      }
+    )
+
+    if (license_status != 0) {
+      warning("gurobi solver was requested but license information was ",
+        "not available or not valid; using glpk instead")
+      params$lp_solver <- "glpk"
+    }
+  }
+
   # Data parameters
   if (!("num_col" %in% names(params))) {params$num_col <- "num"}
   if (!("denom_col" %in% names(params))) {params$denom_col <- "denom"}
@@ -109,6 +137,13 @@ read_params <- function(path = "params.json", template_path = "params.json.templ
   return(params)
 }
 
+#' Wrapper for `base::system2` for testing convenience
+#'
+#' @param command string to run as command
+run_cli <- function(command) {
+  system2(command)
+}
+
 #' Create directory if not already existing
 #'
 #' @param path string specifying a directory to create

backfill_corrections/delphiBackfillCorrection/man/run_cli.Rd

@@ -0,0 +1,4 @@
+{
+  "input_dir": "./test.temp",
+  "lp_solver": "glpk"
+}

backfill_corrections/delphiBackfillCorrection/unit-tests/testthat/params-glpk.json.template

@@ -0,0 +1,4 @@
+{
+  "input_dir": "./test.temp",
+  "lp_solver": "gurobi"
+}

backfill_corrections/delphiBackfillCorrection/unit-tests/testthat/params-gurobi.json.template

@@ -4,5 +4,6 @@
   "ref_lag": 3,
   "input_dir": "./input",
   "export_dir": "./output",
-  "cache_dir": "./cache"
+  "cache_dir": "./cache",
+  "lp_solver": "glpk"
 }

backfill_corrections/delphiBackfillCorrection/unit-tests/testthat/params-run.json.template

@@ -1,3 +1,4 @@
 {
-  "input_dir": "./test.temp"
+  "input_dir": "./test.temp",
+  "lp_solver": "gurobi"
 }

backfill_corrections/delphiBackfillCorrection/unit-tests/testthat/params-test.json.template

@@ -70,7 +70,7 @@ test_that("testing the squared error objection function given the beta prior", {
 test_that("testing the prior estimation", {
   dw <- "Sat_ref"
   priors <- est_priors(train_data, prior_test_data, geo, value_type, dw, TAUS, 
-                       covariates, response, LP_SOLVER, lambda, 
+                       covariates, response, "glpk", lambda,
                        indicator, signal, geo_level, signal_suffix, 
                        training_end_date, training_start_date, model_save_dir)
   alpha <- priors[2]
@@ -110,7 +110,7 @@ test_that("testing the main beta prior adjustment function", {
                            indicator, signal, geo_level, signal_suffix,
                            lambda, value_type, geo, 
                            training_end_date, training_start_date, model_save_dir,
-                           taus = TAUS, lp_solver = LP_SOLVER)
+                           taus = TAUS, lp_solver = "glpk")
   updated_train_data <- updated_data[[1]]
   updated_test_data <- updated_data[[2]]
 

backfill_corrections/delphiBackfillCorrection/unit-tests/testthat/test-beta_prior_estimation.R

@@ -113,21 +113,21 @@ test_that("testing generating or loading the model", {
 
   # Generate the model and check again
   obj <- get_model(model_path, train_data, covariates, tau,
-                        lambda, LP_SOLVER, train_models=TRUE) 
+                        lambda, "glpk", train_models=TRUE)
   expect_true(file.exists(model_path))
   created <- file.info(model_path)$ctime
 
   # Check that the model was not generated again.
   obj <- get_model(model_path, train_data, covariates, tau,
-                        lambda, LP_SOLVER, train_models=FALSE)   
+                        lambda, "glpk", train_models=FALSE)
   expect_equal(file.info(model_path)$ctime, created)
 
   expect_silent(file.remove(model_path))
 })
 
 test_that("testing model training and testing", {
   result <- model_training_and_testing(train_data, test_data, taus=TAUS, covariates=covariates,
-                                       lp_solver=LP_SOLVER, lambda=lambda, test_lag=test_lag,
+                                       lp_solver="glpk", lambda=lambda, test_lag=test_lag,
                                        geo=geo, value_type=value_type, model_save_dir=model_save_dir,
                                        indicator=indicator, signal=signal,
                                        geo_level=geo_level, signal_suffix=signal_suffix,