rpurrrpmap

Using possibly with pmap and a function


I have a function like so:

create_model_spec <- function(.parsnip_eng = list("lm"),
                              .mode = list("regression"),
                              .parsnip_fns = list("linear_reg"),
                              .return_tibble = TRUE) {
  
  # Tidyeval ----
  engine <- .parsnip_eng%>%
    purrr::flatten_chr() %>%
    as.list()
  mode <- .mode %>%
    purrr::flatten_chr() %>%
    as.list()
  call <- .parsnip_fns %>%
    purrr::flatten_chr() %>%
    as.list()
  ret_tibble <- as.logical(.return_tibble)
  
  # Make Model list for purrr call
  model_spec_list <- list(
    call,
    engine,
    mode
  )
  
  # Use purrr pmap to make mode specs
  models <- purrr::pmap(
    .l = model_spec_list,
    .f = function(call, engine, mode) {
      match.fun(call)(engine = engine, mode = mode)
    }
  )
  
  # Return ----
  models_list <- list(
    .parsnip_engine = engine,
    .parsnip_mode = mode,
    .parsnip_fns = call,
    .model_spec = models
  )
  
  ret_tbl <- dplyr::tibble(
    .parsnip_engine = unlist(engine),
    .parsnip_mode   = unlist(mode),
    .parsnip_fns    = unlist(call),
    .model_spec     = models
  )
  
  ifelse(ret_tibble, return(ret_tbl), return(models_list))
}

I can make an object like so:

> tst <- create_model_spec(
+   .parsnip_eng = list("gee","lm"),
+   .mode = list("regression"),
+   .parsnip_fns = list("linear_reg")
+ )
> 
> tst
# A tibble: 2 × 4
  .parsnip_engine .parsnip_mode .parsnip_fns .model_spec
  <chr>           <chr>         <chr>        <list>     
1 gee             regression    linear_reg   <spec[+]>  
2 lm              regression    linear_reg   <spec[+]>  

> str(tst)
tibble [2 × 4] (S3: tbl_df/tbl/data.frame)
 $ .parsnip_engine: chr [1:2] "gee" "lm"
 $ .parsnip_mode  : chr [1:2] "regression" "regression"
 $ .parsnip_fns   : chr [1:2] "linear_reg" "linear_reg"
 $ .model_spec    :List of 2
  ..$ :List of 7
  .. ..$ args                 :List of 2
  .. .. ..$ penalty: language ~NULL
  .. .. .. ..- attr(*, ".Environment")=<environment: R_EmptyEnv> 
  .. .. ..$ mixture: language ~NULL
  .. .. .. ..- attr(*, ".Environment")=<environment: R_EmptyEnv> 
  .. ..$ eng_args             : NULL
  .. ..$ mode                 : chr "regression"
  .. ..$ user_specified_mode  : logi TRUE
  .. ..$ method               : NULL
  .. ..$ engine               : chr "gee"
  .. ..$ user_specified_engine: logi TRUE
  .. ..- attr(*, "class")= chr [1:2] "linear_reg" "model_spec"
  ..$ :List of 7
  .. ..$ args                 :List of 2
  .. .. ..$ penalty: language ~NULL
  .. .. .. ..- attr(*, ".Environment")=<environment: R_EmptyEnv> 
  .. .. ..$ mixture: language ~NULL
  .. .. .. ..- attr(*, ".Environment")=<environment: R_EmptyEnv> 
  .. ..$ eng_args             : NULL
  .. ..$ mode                 : chr "regression"
  .. ..$ user_specified_mode  : logi TRUE
  .. ..$ method               : NULL
  .. ..$ engine               : chr "lm"
  .. ..$ user_specified_engine: logi TRUE
  .. ..- attr(*, "class")= chr [1:2] "linear_reg" "model_spec"

Ok cool...but, when I try to make a column of workflows it fails out, when I'd like it to just error and move along. Here is the custom mapping function:

make_wflw_obj <- function(.model_recipe, .model_spec){
  
  mr <- .model_recipe
  ms <- .model_spec
  
  res <- pmap(.l = list(mr, ms),.f = ~ workflows::workflow() %>%
           workflows::add_recipe(..1) %>%
            workflows::add_model(..2))
  return(res)
}

possibly_make_wflw_obj <- possibly(.f = make_wflw_obj, otherwise = "Error")

The behavior is not expected, I expect the 'gee' model to fail because I don't have the extension package installed, but I expect the 'lm' model to pass.

> tst %>%
+   mutate(model_recipe = list(rec_obj)) %>%
+   mutate(
+     wflw_tst = list(
+       possibly_make_wflw_obj(model_recipe, model_spec)
+     )
+   ) %>%
+   mutate(error = unlist(wflw_tst))
# A tibble: 2 × 7
  .parsnip_engine .parsnip_mode .parsnip_fns .model_spec model_recipe wflw_tst  error
  <chr>           <chr>         <chr>        <list>      <list>       <list>    <chr>
1 gee             regression    linear_reg   <spec[+]>   <recipe>     <chr [1]> Error
2 lm              regression    linear_reg   <spec[+]>   <recipe>     <chr [1]> Error

Solution

  • Solved my issue by using purrr::imap()

    tst <- create_model_spec(
      .parsnip_eng = list("gee","lm"),
      .mode = list("regression"),
      .parsnip_fns = list("linear_reg")
    )
    
    tst <- tst %>%
      mutate(.model_id = row_number()) %>%
      select(.model_id, everything()) %>%
      mutate(.model_id = forcats::as_factor(.model_id)) %>%
      mutate(rec_obj = list(rec_obj))
    
    models_tbl <- tst %>%
      group_split(.model_id)
    
    wflw_list <- models_tbl %>% 
      purrr::imap(
        .f = function(obj, id){
          mod <-  obj %>% dplyr::pull(5) %>% purrr::pluck(1)
          rec_obj <- obj %>% dplyr::pull(6) %>% purrr::pluck(1)
          
          safe_add_mod <- purrr::safely(workflows::add_model, otherwise = NULL, quiet = TRUE)
          
          ret <- workflow() %>% add_recipe(rec_obj) %>% safe_add_mod(mod)
          
          res <- ret %>% purrr::pluck("result")
          
          return(res)
        }
      )
    
    wflw_list_compacted <- purrr::compact(wflw_list)
    wflw_list_compacted
    
    [[1]]
    ══ Workflow ══════════════════════════════════════════════════════════════════════════════════════════
    Preprocessor: Recipe
    Model: linear_reg()
    
    ── Preprocessor ──────────────────────────────────────────────────────────────────────────────────────
    0 Recipe Steps
    
    ── Model ─────────────────────────────────────────────────────────────────────────────────────────────
    Linear Regression Model Specification (regression)
    
    Computational engine: lm