R - 使用嵌套的數據幀運行不同參數集的函數

Question

我想爲類似於nls2（nls2庫）的Levenberg-Marquardt非線性最小二乘函數nls.lm（minpack.lm庫）創建一個包裝，以給出用於評估模型與觀測數據擬合程度的蠻力方法。

的想法是創建一個範圍開始值的組合和任意的：

• 通過這些給函數，則該函數輸出與觀測到的數據，爲每個創建一個R^2值開始值組合並運行nls.lm配合其中最好的一個。對所有組合

或

• 運行nls.lm並選擇最佳的契合返回。

我想這樣做沒有循環和here吸氣後想使用嵌套dataframes，與參數輸入列表中的一個列，一個用於值通過我的函數返回的，一個是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？ follwing將列表拆分爲列：

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將評估foo在maxiter隨機點和返回starting_fits這是在那些點的擬合運行nls2。它由在每個隨機選擇的起始值處評估的一組"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錯誤嘗試try(nlsLM(...))更換nlsLM(...)。這將發出錯誤消息（如果您不需要，請使用try(..., silent = TRUE)），但不會停止處理。

注2：我認爲在問題中顯示的foo只是一個例子，實際功能更復雜。所示的foo在係數中是線性的，因此可以使用lm。不需要非線性優化。

Answer 2

也許這樣的方法？

library(dplyr) 
library(purrr) 

foo2 <- function(x,data) data$a*x^2+data$b 
r2 <- function(e, o) 1 - sum((e - 0)^2)/sum((e - mean(e)^2)) 

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

df %>% 
    mutate(fun_out = map(data, foo2, x = x), 
     R2 = map(fun_out, o = y_obs, r2)) 

結果：

# A tibble: 3 x 4 
    id    data fun_out  R2 
    <int>   <list>  <list> <list> 
1  1 <tibble [1 x 2]> <dbl [10]> <dbl [1]> 
2  2 <tibble [1 x 2]> <dbl [10]> <dbl [1]> 
3  3 <tibble [1 x 2]> <dbl [10]> <dbl [1]>