根据拟合逻辑模型预测值

Question

试图将多个逻辑模型拟合到不同县的数据，并希望最终在一个数据框中（所有县，所有预测人口，指定年份）。

这是数据：

county <- structure(list(name = structure(c(1L, 1L, 1L, 1L, 1L, 2L, 2L, 
2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 5L, 5L, 5L, 
5L, 5L, 6L, 6L, 6L, 6L, 6L, 7L, 7L, 7L, 7L, 7L, 8L, 8L, 8L, 8L, 
8L, 9L, 9L, 9L, 9L, 9L), .Label = c("Alachua", "Columbia", "Gilchrist", 
"Lake", "Levy", "Marion", "Orange", "Seminole", "Volusia"), class = 
"factor"), 
year = c(1920L, 1940L, 1970L, 1990L, 2010L, 1920L, 1940L, 
1970L, 1990L, 2010L, 1920L, 1940L, 1970L, 1990L, 2010L, 1920L, 
1940L, 1970L, 1990L, 2010L, 1920L, 1940L, 1970L, 1990L, 2010L, 
1920L, 1940L, 1970L, 1990L, 2010L, 1920L, 1940L, 1970L, 1990L, 
2010L, 1920L, 1940L, 1970L, 1990L, 2010L, 1920L, 1940L, 1970L, 
1990L, 2010L), pop = c(24662.84498, 38518.67335, 105080.0739, 
182378.0527, 247964.4355, 14353.67655, 16988.63031, 25423.53768, 
42636.12851, 67396.52047, 6955.297482, 4331.7027, 3661.621676, 
9835.709676, 16780.95117, 12812.1731, 27202.15681, 65668.28125, 
153585.2153, 297441.8053, 10034.20186, 12707.52359, 12911.58508, 
26370.47373, 41650.51535, 23990.09377, 31340.67059, 69056.41468, 
194358.0547, 334117.7792, 19825.73528, 68559.76913, 337259.2307, 
670422.46, 1140314.083, 11027.52715, 23881.62063, 91628.11201, 
298115.877, 438079.7446, 24526.72497, 55775.68449, 175004.8787, 
382885.1367, 516049.0225)), .Names = c("name", "year", "pop"
), row.names = c(NA, -45L), class = "data.frame")

这就是我最终得到的结果：

library(dplyr) 
county %>% 
    group_by(name) %>%
    (function(x) {
            fm<- nls(pop ~ SSlogis(year, phi1, phi2, phi3), data = x)
            timevalues <- c(1992, 2002, 2007, 2012)
            predict <- predict(fm,list(year=timevalues))
            cbind(predict, predict)
    })

但这只给了我一个四个数据点的列表：

out:
  predict  predict
[1,] 226713.5 226713.5
[2,] 293596.4 293596.4
[3,] 326455.5 326455.5
[4,] 357640.8 357640.8

不知道他们所在的县是什么？ 如果我单独使用这个代码（不使用groupby），我可以让它工作。 但是我必须为每个县单独做，然后自己绑定它，一旦我与超过9个县合作，这将变得乏味。

Answer 1

正如@Esther在评论中所建议的那样，好的第一步是将匿名预测函数提取到命名函数中。 使函数接受预测年份作为参数也是有意义的，而不是将它们固定在函数内：

predict_pop <- function(data, year) {
  model <- nls(pop ~ SSlogis(year, phi1, phi2, phi3), data = data)

  nd <- data.frame(year)
  pred <- predict(model, nd)

  cbind(nd, pred)
}

让我们检查一下这是否适用于完整数据：

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

years <- c(1992, 2002, 2007, 2012)
predict_pop(county, years)
#>   year     pred
#> 1 1992 226713.5
#> 2 2002 293596.4
#> 3 2007 326455.5
#> 4 2012 357640.8

大！ 现在，为了适应每个县的模型，一种方式（如评论中的@ eipi10所示）将首先split()数据split()为每个县的数据框列表，然后使用lapply()在每个子集中获得预测。

split(county, county$name) %>%
  lapply(predict_pop, years)
#> Error in nls(y ~ 1/(1 + exp((xmid - x)/scal)), data = xy, start = list(xmid = aux[[1L]], : step factor 0.000488281 reduced below 'minFactor' of 0.000976562

但是，这会导致错误：似乎模型不能适合某些县自己。 你可能需要用模型本身解决这个问题; 但是如果我们想要从这个模型中预测模型可以适合的那些县，我们可以修改预测函数来处理模型不适合的情况。

一种方法是使用purrr::safely()来创建nls()函数的“安全”版本，它不会阻止错误中的所有内容，而是始终返回一个两元素列表： result ，如果函数执行成功则包含结果，如果有错误则包含NULL ; 和error包含错误是否发生之一。

使用安全建模功能，我们可以检查模型是否可以拟合，如果没有，则返回NA作为预测而不是错误。 这是预测函数的修改版本，它就是这样做的：

predict_pop <- function(data, year) {
  safe_nls <- function(...) purrr::safely(nls)(...)$result
  model <- safe_nls(pop ~ SSlogis(year, phi1, phi2, phi3), data = data)

  nd <- data.frame(year)
  pred <- NA_real_

  if (!is.null(model))
    pred <- predict(model, nd)

  cbind(nd, pred)
}

现在我们可以使用之前的技术形式来获得预测。 我添加了一个bind_rows()调用，将列表结果组合成一个数据框：

split(county, county$name) %>%
  lapply(predict_pop, years) %>% 
  bind_rows(.id = "county") %>% 
  head()
#>     county year     pred
#> 1  Alachua 1992 186020.6
#> 2  Alachua 2002 222332.3
#> 3  Alachua 2007 239432.0
#> 4  Alachua 2012 255440.9
#> 5 Columbia 1992       NA
#> 6 Columbia 2002       NA

在这里，我们可以看到哥伦比亚的缺失预测，哥伦比亚是模型拟合失败的县之一。

还有其他几种方法可以预测每个县。 @rawr和@Esther在评论中提到的一种替代方法是使用do() ：

county %>% 
  group_by(name) %>% 
  do(predict_pop(., years)) %>% 
  head()
#> # A tibble: 6 x 3
#> # Groups:   name [2]
#>   name      year    pred
#>   <fct>    <dbl>   <dbl>
#> 1 Alachua   1992 186021.
#> 2 Alachua   2002 222332.
#> 3 Alachua   2007 239432.
#> 4 Alachua   2012 255441.
#> 5 Columbia  1992     NA 
#> 6 Columbia  2002     NA

另一种方法是通过使用tidyr::nest()将分组数据分配到列表列来创建“嵌套”数据框。 然后我们可以使用lapply()从模型中获取每个数据子集的预测，最后使用tidyr::unnest()从列表列中获取预测。

county %>% 
  tidyr::nest(-name) %>% 
  tidyr::unnest(lapply(data, predict_pop, years)) %>% 
  head()
#>       name year     pred
#> 1  Alachua 1992 186020.6
#> 2  Alachua 2002 222332.3
#> 3  Alachua 2007 239432.0
#> 4  Alachua 2012 255440.9
#> 5 Columbia 1992       NA
#> 6 Columbia 2002       NA

我们拥有它：处理许多模型的一整套技术。 有关此问题的进一步讨论和示例，您可能会对R for Data Science一书中的许多模型章节感兴趣。

由reprex包 （v0.2.0）创建于2018-06-04。