R - 使用嵌套数据框运行具有不同参数集的函数

Question

我想为 Levenberg-Marquardt 非线性最小二乘函数 nls.lm (minpack.lm 库)创建一个包装器，类似于 nls2 (nls2 库)给出一种用于评估模型与观测数据的拟合度的强力方法。

这个想法是创建一系列起始值组合，并且:

• 将这些传递给函数，然后将函数输出与观察到的数据进行比较，为每个起始值组合创建一个 R^2 值，并使用其中最好的一个运行 nls.lm 拟合。

或

• 对所有组合运行 nls.lm 并选择返回的最佳拟合。

我想在不循环的情况下做到这一点，并且是在 here 的启发之后完成的。我正在尝试使用嵌套数据框，其中一列用于参数输入列表，一列用于我的函数返回的值，一列用于 R^2 值，一列用于最佳拟合模型，例如:

df
#   start_val fun_out       R^2   
# 1 {a=2,b=2} {22,24,26...} 0.8   
# 2 {a=3,b=5} {35,38,41...} 0.6   

这是我到目前为止的代码:

require(dplyr);require(tidyr)

foo <- function(x,a,b) a*x^2+b # function I am fitting
x <- 1:10 # independent variable
y_obs <- foo(x,1.5,2.5) + rnorm(length(x),0,10) # observed data (dependent variable)

start_range <- data.frame(a=c(1,2),b=c(2,3)) # range of allowed starting points for fitting
reps <- 2 # number of starting points to generate

# Create a data frame of starting points
df<-as.data.frame(sapply(start_range, function(x) runif(reps,min=x[[1]],max=x[[2]]))) %>%
  mutate(id=seq_len(reps)) %>% # fudge to make nest behave as I want
  nest(1:ncol(start_range)) %>%
  mutate(data=as.list(data)) %>%
  as.data.frame()

df
#   id               data
# 1  1 1.316356, 2.662923
# 2  2 1.059356, 2.723081

我现在在尝试将数据中的参数传递到函数 foo() 时陷入困境。我尝试过使用 do.call()，即使使用常量参数也会出现以下错误:

mutate(df,y=do.call(foo,list(x,1,2)))
# Error: wrong result size (5), expected 2 or 1

有没有办法在不使用nest()的情况下直接创建包含列表的数据框列？

此外，当尝试使用数据帧列创建要传递给 do.call() 的列表时，如何创建一个列表，其中第一个元素是向量 x，第二个元素是参数a 第三个是参数b？以下将列表按列拆分:

mutate(df,my_list=list(x,data))
#   id               data                                my_list
# 1  1 1.316356, 2.662923          1, 2, 3, 4, 5, 6, 7, 8, 9, 10
# 2  2 1.059356, 2.723081 1.316356, 2.662923, 1.059356, 2.723081

Answer 1

使用 algorithm = "random-search" 和 all = TRUE 以及指定的 maxiter 运行 nls2 将在 maxiter 随机点处评估 foo 并返回 starting_fits，这是这些点的拟合值。它由一组在每个随机选择的起始值处评估的“nls”类对象组成。它不会对每个起始值进行优化，而只是返回每个起始值的 "nls" 对象。也就是说，nls 未运行。现在，对于每个起始拟合运行nlsLM，给出fits，一个nlsLM拟合列表，并从中将它们总结在data中(每次运行一行的数据框)并显示最少。

如果我们只想选择最佳的起始值并仅从中运行一次 nlsLM ，则在接近末尾时使用备用代码。

library(nls2)

fo <- y_obs ~ foo(x, a, b)
starting_fits <- nls2(fo, algorithm = "random-search", 
 start = start_range, control = nls.control(maxiter = reps), all = TRUE)

fits <- lapply(starting_fits, function(fit) nlsLM(fo, start = coef(fit)))

data <- data.frame(RSS = sapply(fits, deviance), t(sapply(fits, coef)),
   start = t(sapply(starting_fits, coef)))
# data$fits <- fits   # optional to store each row's fitted object in that row
subset(data, RSS == min(RSS))   # minimum(s)

给予:

       RSS        a        b  start.a  start.b
2 706.3956 1.396616 7.226525 1.681819 2.768374

R 平方用于线性回归。它对于非线性回归无效。上面显示的是残差平方和 (RSS)。

或者，如果您只想选出最佳起始值并对其运行 nlsLM，则只需从 nls2 调用中省略 all=TRUE 参数即可。如果您需要稍后代码的系数和 RSS，请尝试 coef(fit) 和 deviance(fit) 。

starting_fit <- nls2(fo, algorithm = "random-search", 
 start = start_range, control = nls.control(maxiter = reps))

fit <- nlsLM(fo, start = coef(starting_fit))

注意 1:如果您从 nlsLM 收到错误，请尝试将 nlsLM(...) 替换为 try(nlsLM( ...))。这将发出错误消息(如果您不需要，请使用 try(...,silent = TRUE))，但不会停止处理。

注2:我假设问题中显示的foo只是一个例子，真正的功能更复杂。显示的 foo 的系数是线性的，因此可以使用 lm 来实现。不需要非线性优化。