Apply Multi-argument models on nested tibble (invoke_map tidyverse R)

Question

On the one hand I have some nested data in R. On the other hand I have several nls functions that I want to test in this data.

I am asking for a tidy workflow that allows me to cross all the nls formulas, with many starting points of several arguments, for each of the categories of the nested data.

The functions may share arguments or not.

As far as I have reached, I have managed to generalize the formulas, with a possibly but `the issue is I cannot touch the arguments of each nls function. (the starting points)

I put an example with Iris data and 2 functions. There are 6 combinations but I have to insist that I am looking for generalization.

#Iris Nested data-----
iris_nested <- iris %>% 
  group_by(Species) %>%  
  nest() %>%  
  ungroup()

#NLS functions  -----
## Weird function 1 -----
weird_test_1 <- function(Species_data, Petal.Length_0 = 0 ){
  nls(
    Petal.Length ~ Petal.Length_0 * (1 - exp( -Petal.Width/(Sepal.Length+Sepal.Width) )),
    start = list(
      Petal.Length_0 = Petal.Length_0),
    data = Species_data
  )
}
## Weird function 2 -----
weird_test_2 <- function(Species_data, Sepal.Length_0 = 0 ){
  nls(
    Petal.Length ~ Sepal.Length_0 * (1 - exp( -(Sepal.Length+Sepal.Width)/Petal.Width )),
    start = list(
      Sepal.Length_0 = Sepal.Length_0),
    data = Species_data
  )
}

#Iteration over the model with a map_df -----
# I create a function that given a function name and a Species data allows to iterate 

fn_model <- function(.model, df){
  # safer to avoid non-standard evaluation
  # df %>% mutate(model = map(data, .model)) 
  df %>% 
    mutate('model'= map(data, possibly(.model, NULL)))
}


# here is where I stop, due to I cannot find a way to implemnet invoke_map and manipulate starting arguments:

list(
  'weird_test_1' = weird_test_1,
  'weird_test_2' = weird_test_2) %>%
  map_df(fn_model, iris_nested, .id = "id_model")

I tried solutions with crossing or tribbles but does not seem to work all together due to incompatibility of functions arguments

Answer 1

Perhaps you can use this as a basis and extend it as needed.

library(tidyverse)

#Iris Nested data-----
iris_nested <- iris |> 
  group_by(Species) |>  
  nest() |>  
  ungroup()

#NLS functions  -----
## Weird function 1 -----
weird_test_1 <- function(Species_data, Petal.Length_0 = 0 ){
  nls(
    Petal.Length ~ Petal.Length_0 * (1 - exp( -Petal.Width/(Sepal.Length+Sepal.Width) )),
    start = list(
      Petal.Length_0 = Petal.Length_0),
    data = Species_data
  )
}
## Weird function 2 -----
weird_test_2 <- function(Species_data, Sepal.Length_0 = 0 ){
  nls(
    Petal.Length ~ Sepal.Length_0 * (1 - exp( -(Sepal.Length+Sepal.Width)/Petal.Width )),
    start = list(
      Sepal.Length_0 = Sepal.Length_0),
    data = Species_data
  )
}
#Iteration over the model with a map_df -----
# I create a function that given a function name and a Species data allows to iterate 

fn_model <- function(.model, df,...){
  safe_model <- possibly(.model)
  df |> 
    mutate('model'= map(data, \(d)safe_model(d,...))) 
}


# here is where I stop, due to I cannot find a way to implemnet invoke_map and manipulate starting arguments:

Petal.Length_0_starts <- c(0,2,4)
Sepal.Length_0_starts <- c(1,3,5)

(to_do <- tibble(start_var_name=c(rep("Petal.Length_0",3),
                            rep("Sepal.Length_0",3)),
           start_var_val = c(0,2,4,1,3,5)))

(to_do <- mutate(to_do,
                 fname = case_when(
                   startsWith(start_var_name,"Petal")~"weird_test_1",
                                   .default = "weird_test_2")))
library(rlang)
to_do$result <- pmap(to_do,
                     \(start_var_name,start_var_val ,fname){
                 
    args_to_use <- list2(.model=get(fname),
                    df=iris_nested,
                    !!sym(start_var_name):=start_var_val)

       do.call(fn_model,
               args = args_to_use)
     })

to_do

Answer 2

Try this:

library(tidyverse)

iris_nested <- iris %>% 
  group_by(Species) %>%  
  nest() %>%  
  ungroup()

weird_test_1 <- function(Species_data, Petal.Length_0 = 0 ){
  nls(
    Petal.Length ~ Petal.Length_0 * (1 - exp( -Petal.Width/(Sepal.Length+Sepal.Width) )),
    start = list(
      Petal.Length_0 = Petal.Length_0),
    data = Species_data
  )
}

weird_test_2 <- function(Species_data, Sepal.Length_0 = 0 ){
  nls(
    Petal.Length ~ Sepal.Length_0 * (1 - exp( -(Sepal.Length+Sepal.Width)/Petal.Width )),
    start = list(
      Sepal.Length_0 = Sepal.Length_0),
    data = Species_data
  )
}

fn_model <- function(.model, df){
  df %>% 
    mutate('model'= map(data, possibly(.model, NULL)))
}

lst <- list(
  'weird_test_1' = weird_test_1,
  'weird_test_2' = weird_test_2)

map(lst, \(x) {
  fn_model(x, iris_nested)
  }) |> 
  list_rbind(names_to = "id")
#> # A tibble: 6 × 4
#>   id           Species    data              model 
#>   <chr>        <fct>      <list>            <list>
#> 1 weird_test_1 setosa     <tibble [50 × 4]> <nls> 
#> 2 weird_test_1 versicolor <tibble [50 × 4]> <nls> 
#> 3 weird_test_1 virginica  <tibble [50 × 4]> <nls> 
#> 4 weird_test_2 setosa     <tibble [50 × 4]> <nls> 
#> 5 weird_test_2 versicolor <tibble [50 × 4]> <nls> 
#> 6 weird_test_2 virginica  <tibble [50 × 4]> <nls>

^{Created on 2024-03-13 with reprex v2.1.0}