r-如何从多个拟合模型中获得预测

Question

我有一个数据帧，其中包含多个样本的校准曲线(信号s是浓度c的函数(：

cal <- data.frame(sample = c(rep("A", 8), rep("B", 8), rep("C", 8)),
c_std = rep(c(0, 1, 5, 10, 25, 50, 100, 200), 3),
s_std = c(40341, 24196, 13403,  6956,  3000,  1507, 312, 12,
40261, 24250, 13537,  6977,  2940,  1465, 304, 12,
40075, 24469, 13696,  7060,  2972,  1487, 307, 12))

此外，我有一个数据帧，其中包含对相同样本的观察结果：

obs <- data.frame(sample = c("A", "B", "C"),
s_sample = c(1364, 4726, 521))

首先，我使用drc库中的drm为每个校准曲线拟合模型。

model <- function(df) drc::drm(c_std ~ s_std, fct = LL2.3(), data = df)
library(dplyr)
cal_models <- cal %>%
group_by(sample) %>%
nest() %>%
mutate(model = map(data, model)) %>%
unnest(sample) %>%
distinct(sample, model)

从获得的模型中，我想得到我对样本的观测结果的预测。这就是我被卡住的地方。我的想法是通过样本ID合并包含模型和观察结果的两个对象，然后以类似于我使用map拟合模型的方式应用统计包中的预测。不过我不知道该怎么做。这就是我合并数据帧的方式：

dat <- merge(cal_models, obs)

这是我从模型中获得预测的方法，只是我想对所有样本一步到位：

cal_A <- subset(cal, sample == "A")
model_A <- drc::drm(c_std ~ s_std, data = cal_A, fct = LL2.3()
predicted <- stats::predict(model_A, data.frame(obs$s_sample[1]))
predicted

Answer 1

使用校准数据列出模型列表可能最简单，如下所示：

models <- by( cal , INDICES = cal$sample , FUN = model )

然后在obs数据上映射predict，如下所示：

mapply( FUN = function(x, y) { predict(models[[x]], data.frame(y)) }, 
x=obs$sample ,  
y=obs$s_sample)
A.Prediction B.Prediction C.Prediction 
45.09688     18.07154     79.75994 

如果您想将其添加到现有数据帧中：

cbind(obs, prediction=mapply( FUN = function(x, y) { predict(models[[x]], data.frame(y)) }, 
x=obs$sample ,  
y=obs$s_sample))
sample s_sample prediction
A.Prediction      A     1364   45.09688
B.Prediction      B     4726   18.07154
C.Prediction      C      521   79.75994

Answer 2

cal <- data.frame(sample = c(rep("A", 8), rep("B", 8), rep("C", 8)),
c_std = rep(c(0, 1, 5, 10, 25, 50, 100, 200), 3),
s_std = c(40341, 24196, 13403,  6956,  3000,  1507, 312, 12,
40261, 24250, 13537,  6977,  2940,  1465, 304, 12,
40075, 24469, 13696,  7060,  2972,  1487, 307, 12))
obs <- data.frame(sample = c("A", "B", "C"),
s_std = c(1364, 4726, 521))
library(purrr)
library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
library(tidyr)
setNames(predict(drc::drm(c_std ~ s_std, fct = drc::LL2.3(), data = cal), obs), obs$sample)
#>        A        B        C 
#> 44.78515 18.20520 79.81111
cal %>%
group_by(sample) %>%
nest() %>%
mutate(
model = map(data, ~drc::drm(c_std ~ s_std, fct = drc::LL2.3(), data = .x)),
pred = map2(model, sample, ~predict(.x, filter(obs, sample == .y)))
) %>%
unnest(pred)
#> # A tibble: 3 x 4
#> # Groups:   sample [3]
#>   sample data             model   pred
#>   <chr>  <list>           <list> <dbl>
#> 1 A      <tibble [8 x 2]> <drc>   45.1
#> 2 B      <tibble [8 x 2]> <drc>   18.1
#> 3 C      <tibble [8 x 2]> <drc>   79.8

^{创建于2022-03-07由reprex包(v2.0.0(}