Merge pull request #408 from tidymodels/add-in

RStudio addin

Author: topepo

NAMESPACE

@@ -145,6 +145,7 @@ export(new_model_spec)
 export(null_model)
 export(null_value)
 export(nullmodel)
+export(parsnip_addin)
 export(pred_value_template)
 export(predict.model_fit)
 export(predict_class.model_fit)

NEWS.md

@@ -1,5 +1,7 @@
 # parsnip (development version)
 
+ * An RStudio add-in is availble that makes writing multiple `parsnip` model specifications to the source window. It can be accessed via the IDE addin menus or by calling `parsnip_addin()`.
+ 
 # parsnip 0.1.4
 
 * `show_engines()` will provide information on the current set for a model. 

R/add_in.R

@@ -0,0 +1,15 @@
+#' Start an RStudio Addin that can write model specifications
+#'
+#' `parsnip_addin()` starts a process in the RStudio IDE Viewer window
+#' that allows users to write code for `parsnip` model specifications from
+#' various R packages. The new code is written to the current document at the
+#' location of the cursor.
+#'
+#' @export
+parsnip_addin <- function() {
+  sys.source(
+    system.file("add-in", "gadget.R", package = "parsnip", mustWork = TRUE),
+    envir = rlang::new_environment(parent = rlang::global_env()),
+    keep.source = FALSE
+  )
+}

R/data.R

@@ -0,0 +1,14 @@
+#' parsnip model specification database
+#'
+#' This is used in the RStudio add-in and captures information about mode
+#' specifications in various R packages.
+#'
+#' @name model_db
+#' @aliases model_db
+#' @docType data
+#' @return \item{model_db}{a data frame}
+#' @keywords datasets
+#' @examples
+#' data(model_db)
+NULL
+

data/model_db.rda

@@ -0,0 +1,160 @@
+parsnip_spec_add_in <- function() {
+  # ------------------------------------------------------------------------------
+  # check installs
+
+  libs <- c("shiny", "miniUI", "rstudioapi")
+  is_inst <- rlang::is_installed(libs)
+  if (any(!is_inst)) {
+    missing_pkg <- libs[!is_inst]
+    missing_pkg <- paste0(missing_pkg, collapse = ", ")
+    rlang::abort(
+      glue::glue(
+        "The add-in requires some CRAN package installs: ",
+        glue::glue_collapse(glue::glue("'{missing_pkg}'"), sep = ", ")
+      )
+    )
+  }
+
+  library(shiny)
+  library(miniUI)
+  library(rstudioapi)
+
+  data(model_db, package = "parsnip")
+
+  # ------------------------------------------------------------------------------
+
+  make_spec <- function(x, tune_args) {
+    if (tune_args) {
+      nms <- x$parameters[[1]]$parameter
+      args <- purrr::map(nms, ~ rlang::call2("tune"))
+      names(args) <- nms
+    } else {
+      args <- NULL
+    }
+
+    if (x$package != "parsnip") {
+      pkg <- x$package
+    } else {
+      pkg <- NULL
+    }
+
+    if (length(args) > 0) {
+      cl_1 <- rlang::call2(.ns = pkg, .fn = x$model, !!!args)
+    } else {
+      cl_1 <- rlang::call2(.ns = pkg, .fn = x$model)
+    }
+
+    obj_nm <- paste0(x$model,"_", x$engine, "_spec")
+    chr_1 <- rlang::expr_text(cl_1, width = 500)
+    chr_1 <- paste0(chr_1, collapse = " ")
+    chr_1 <- paste(obj_nm, "<-\n ", chr_1)
+    chr_2 <- paste0("set_engine('", x$engine, "')")
+
+    res <- paste0(chr_1, " %>%\n  ", chr_2)
+
+    if (!x$single_mode) {
+      chr_3 <- paste0("set_mode('", x$mode, "')")
+      res <- paste0(res, " %>%\n  ", chr_3)
+    }
+
+    res
+  }
+
+  ui <-
+    miniPage(
+      gadgetTitleBar("Write out model specifications"),
+      miniContentPanel(
+        fillRow(
+          fillCol(
+            radioButtons(
+              "model_mode",
+              label = h3("Type of Model"),
+              choices = c("Classification", "Regression")
+            ),
+            checkboxInput(
+              "tune_args",
+              label = "Tag parameters for tuning (if any)?",
+              value = TRUE
+            ),
+            textInput(
+              "pattern",
+              label = "Match on (regex)"
+            )
+          ),
+          fillRow(
+            miniContentPanel(uiOutput("model_choices"))
+          )
+        )
+      ),
+      miniButtonBlock(
+        actionButton("write", "Write specification code", class = "btn-success")
+      )
+    )
+
+
+  server <-
+    function(input, output) {
+      get_models <- reactive({
+        req(input$model_mode)
+
+        models <- model_db[model_db$mode == tolower(input$model_mode),]
+        if (nchar(input$pattern) > 0) {
+          incld <- grepl(input$pattern, models$model) | grepl(input$pattern, models$engine)
+          models <- models[incld,]
+
+        }
+        models
+      }) # get_models
+
+      output$model_choices <- renderUI({
+
+        model_list <- get_models()
+        if (nrow(model_list) > 0) {
+
+        choices <- paste0(model_list$model, " (", model_list$engine, ")")
+        choices <- unique(choices)
+        } else {
+          choices <- NULL
+        }
+
+        checkboxGroupInput(
+          inputId = "model_name",
+          label = "",
+          choices = choices
+        )
+      }) # model_choices
+
+      create_code <- reactive({
+
+        req(input$model_name)
+        req(input$model_mode)
+
+        model_mode <- tolower(input$model_mode)
+        selected <- model_db[model_db$label %in% input$model_name,]
+        selected <- selected[selected$mode %in% model_mode,]
+
+        res <- purrr::map_chr(1:nrow(selected),
+                              ~ make_spec(selected[.x,], tune_args = input$tune_args))
+
+        paste0(res, sep = "\n\n")
+
+      }) # create_code
+
+      observeEvent(input$write, {
+        res <- create_code()
+        for (txt in res) {
+          rstudioapi::insertText(txt)
+        }
+      })
+
+      observeEvent(input$done, {
+        stopApp()
+      })
+    }
+
+  viewer <- paneViewer(300)
+  runGadget(ui, server, viewer = viewer)
+}
+
+parsnip_spec_add_in()
+

inst/add-in/gadget.R

@@ -0,0 +1,84 @@
+# ------------------------------------------------------------------------------
+# code to make the parsnip model database used by the RStudio addin
+
+# ------------------------------------------------------------------------------
+
+library(tidymodels)
+library(usethis)
+
+# also requires installation of:
+packages <- c("parsnip", "discrim", "plsmod", "rules", "baguette", "poissonreg", "modeltime", "modeltime.gluonts")
+
+# ------------------------------------------------------------------------------
+
+# Detects model specifications via their print methods
+print_methods <- function(x) {
+  require(x, character.only  = TRUE)
+  ns <- asNamespace(ns = x)
+  mthds <- ls(envir = ns, pattern = "^print\\.")
+  mthds <- gsub("^print\\.", "", mthds)
+  purrr::map_dfr(mthds, get_engines) %>% dplyr::mutate(package = x)
+}
+get_engines <- function(x) {
+  eng <- try(parsnip::show_engines(x), silent = TRUE)
+  if (inherits(eng, "try-error")) {
+    eng <- tibble::tibble(engine = NA_character_, mode = NA_character_, model = x)
+  } else {
+    eng$model <- x
+  }
+  eng
+}
+get_tunable_param <- function(mode, package, model, engine) {
+  cl <- rlang::call2(.ns = package, .fn = model)
+  obj <- rlang::eval_tidy(cl)
+  obj <- parsnip::set_engine(obj, engine)
+  obj <- parsnip::set_mode(obj, mode)
+  res <-
+    tune::tunable(obj) %>%
+    dplyr::select(parameter = name)
+
+  # ------------------------------------------------------------------------------
+  # Edit some model parameters
+
+  if (model == "rand_forest") {
+    res <- res[res$parameter != "trees",]
+  }
+  if (model == "mars") {
+    res <- res[res$parameter == "prod_degree",]
+  }
+  if (engine %in% c("rule_fit", "xgboost")) {
+    res <- res[res$parameter != "mtry",]
+  }
+  if (model %in% c("bag_tree", "bag_mars")) {
+    res <- res[0,]
+  }
+  if (engine %in% c("rpart")) {
+    res <- res[res$parameter != "tree-depth",]
+  }
+  res
+
+}
+
+# ------------------------------------------------------------------------------
+
+model_db <-
+  purrr::map_dfr(packages, print_methods) %>%
+  dplyr::filter(!is.na(engine)) %>%
+  dplyr::mutate(label = paste0(model, " (", engine, ")")) %>%
+  dplyr::arrange(model, engine, mode)
+
+num_modes <-
+  model_db %>%
+  dplyr::group_by(package, model, engine) %>%
+  dplyr::count() %>%
+  dplyr::ungroup() %>%
+  dplyr::mutate(single_mode = n == 1) %>%
+  dplyr::select(package, model, engine, single_mode)
+
+model_db <-
+  dplyr::left_join(model_db, num_modes, by = c("package", "model", "engine")) %>%
+  dplyr::filter(engine != "spark") %>%
+  dplyr::mutate(parameters = purrr::pmap(list(mode, package, model, engine), get_tunable_param))
+
+usethis::use_data(model_db, overwrite = TRUE)
+

inst/add-in/parsnip_model_db.R

@@ -0,0 +1,5 @@
+
+Name: Generate parsnip model specifications
+Description: Automatically generate code for multiple parsnip model specifications.
+Binding: write_parsnip_specs
+Interactive: true