基于tidyverse的R嵌套数据多参数NLS模型批量拟合工作流需求

我在R中处理嵌套数据，同时有多个需要在该数据上测试的nls函数，想要一套tidy工作流实现：

• 将所有nls公式与多个参数起始点交叉组合
• 应用到嵌套数据的每个类别中
  这些函数的参数可能重叠或完全不同。目前已借助possibly实现公式泛化，但无法调整每个nls函数的起始参数，尝试过crossing或tribbles方案，但因函数参数不兼容未能成功，需要通用解决方案。

示例代码：

#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")

核心思路是把模型函数、对应起始参数、嵌套数据三者交叉组合，用purrr::pmap动态传递不同参数给对应模型，实现全组合的批量拟合。

步骤1：整理模型与参数配置 #

先把每个模型的名称、函数、以及要测试的起始参数值整理成结构化数据框，方便后续扩展：

library(tidyverse)

# 定义模型配置：模型名、模型函数、参数起始值列表
model_config <- tribble(
  ~model_name, ~model_fun, ~start_params,
  "weird_test_1", weird_test_1, list(Petal.Length_0 = c(0, 1, 2)),
  "weird_test_2", weird_test_2, list(Sepal.Length_0 = c(0, 5, 10))
) %>%
  # 展开每个模型的所有起始参数组合
  unnest_wider(start_params) %>%
  pivot_longer(cols = -c(model_name, model_fun), 
               names_to = "param_name", values_to = "param_value") %>%
  group_by(model_name, model_fun, param_name) %>%
  unnest(param_value) %>%
  ungroup()

步骤2：交叉嵌套数据与模型配置 #

将嵌套的鸢尾花数据和模型配置做全交叉，确保每个物种、每个模型、每个起始参数组合都能一一对应：

# 交叉嵌套数据与模型配置
crossed_data <- crossing(iris_nested, model_config)

步骤3：动态调用模型 #

用pmap根据每行的配置调用对应模型，同时用possibly处理拟合失败的情况：

# 定义带参数的模型调用函数
fit_model <- function(data, model_fun, ...) {
  possibly(model_fun, NULL)(data, ...)
}

# 批量拟合模型
result <- crossed_data %>%
  mutate(
    model = pmap(list(data = data, model_fun = model_fun, !!sym(param_name) := param_value), 
                 fit_model)
  ) %>%
  # 可选：过滤掉拟合失败的行
  filter(!is.null(model))

步骤4：提取拟合结果 #

可以用broom包提取模型的参数估计值，方便后续分析：

library(broom)

# 提取模型参数
result %>%
  mutate(params = map(model, tidy)) %>%
  unnest(params) %>%
  select(Species, model_name, param_name, param_value, estimate, std.error, p.value)

完整整合代码 #

library(tidyverse)
library(broom)

# 1. 构建嵌套数据
iris_nested <- iris %>% 
  group_by(Species) %>%  
  nest() %>%  
  ungroup()

# 2. 定义nls函数
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
  )
}

# 3. 模型配置与交叉
model_config <- tribble(
  ~model_name, ~model_fun, ~start_params,
  "weird_test_1", weird_test_1, list(Petal.Length_0 = c(0, 1, 2)),
  "weird_test_2", weird_test_2, list(Sepal.Length_0 = c(0, 5, 10))
) %>%
  unnest_wider(start_params) %>%
  pivot_longer(cols = -c(model_name, model_fun), 
               names_to = "param_name", values_to = "param_value") %>%
  group_by(model_name, model_fun, param_name) %>%
  unnest(param_value) %>%
  ungroup()

crossed_data <- crossing(iris_nested, model_config)

# 4. 批量拟合模型
fit_model <- function(data, model_fun, ...) {
  possibly(model_fun, NULL)(data, ...)
}

result <- crossed_data %>%
  mutate(
    model = pmap(list(data = data, model_fun = model_fun, !!sym(param_name) := param_value), 
                 fit_model)
  ) %>%
  filter(!is.null(model))

# 5. 提取结果
result %>%
  mutate(params = map(model, tidy)) %>%
  unnest(params) %>%
  select(Species, model_name, param_name, param_value, estimate, std.error, p.value)

方案优势 #

• 通用性：不管模型参数是否重叠，只要在model_config中正确配置参数名和起始值，就能自动匹配
• 可扩展性：新增模型或参数起始值时，只需修改model_config即可
• tidy风格：全程用tidyverse工具，结果保持数据框格式，方便后续分析与可视化

内容的提问来源于stack exchange，提问作者Aitor Gonzalez