在dplyr中插值样条函数的应用方法

Question

我正在尝试对以下示例数据进行样条插值：

trt    depth    root    carbon
A       2        1        14
A       4        2        18
A       6        3        18
A       8        3        17
A      10        1        12
B       2        3        16
B       4        4        18
B       6        4        17
B       8        2        15
B      10        1        12

以以下方式进行：

new_df<-df%>%
  group_by(trt)%>%
  summarise_each(funs(splinefun(., x=depth, method="natural")))

我收到了一个错误：不是向量的提示，但我不知道为什么会出现这个错误。难道我的函数表达方式不正确吗？

- Nazer

---

我不知道你问题的答案，但我认为 summarise_each(funs(splinefun(., x=depth, method="natural"))) 这行可能有些问题。它不应该像这样 summarise_each(funs(splinefun(y = ., x=depth, method="natural"))) 吗？ - steveb

funs 应该接受一个函数名称的向量或由 funs 返回的列表。我本来就不会期望 y=. 能够工作，因为 y 应该是一个向量，而 . 的值将是一个 table_df（或者那些 dplyr 东西被称为什么）。我无法提供经过测试的解决方案，因为我所做的所有努力都会导致我的当前版本的 R 与当前（在 CRAN 上）版本的 dplyr 崩溃。 - IRTFM

Answer 1

你需要一个包含插值数值的数据集吗？如果是这样，我已经扩展了数据集，使其包含在进行样条计算之前所需的x位置。

这些点的分辨率由 expand.grid() 函数的第二行确定。只需确保原始深度点是扩展深度点的一个子集（例如，不要使用不均匀的东西，如 by=.732）。

library(magrittr)
ds <- readr::read_csv("trt,depth,root,carbon\nA,2,1,14\nA,4,2,18\nA,6,3,18\nA,8,3,17\nA,10,1,12\nB,2,3,16\nB,4,4,18\nB,6,4,17\nB,8,2,15\nB,10,1,12")

ds_depths_possible <- expand.grid(
  depth            = seq(from=min(ds$depth), max(ds$depth), by=.5), #Decide resolution here.
  trt              = c("A", "B"),
  stringsAsFactors = FALSE
  )

ds_intpolated <- ds %>% 
  dplyr::right_join(ds_depths_possible, by=c("trt", "depth")) %>% #Incorporate locations to interpolate
  dplyr::group_by(trt) %>% 
  dplyr::mutate(
    root_interpolated     = spline(x=depth, y=root  , xout=depth)$y,
    carbon_interpolated   = spline(x=depth, y=carbon, xout=depth)$y
  ) %>% 
  dplyr::ungroup()
ds_intpolated

输出：

Source: local data frame [34 x 6]

     trt depth  root carbon root_interpolated carbon_interpolated
   (chr) (dbl) (int)  (int)             (dbl)               (dbl)
1      A   2.0     1     14          1.000000            14.00000
2      A   2.5    NA     NA          1.195312            15.57031
3      A   3.0    NA     NA          1.437500            16.72917
4      A   3.5    NA     NA          1.710938            17.52344
5      A   4.0     2     18          2.000000            18.00000
6      A   4.5    NA     NA          2.289062            18.21094
7      A   5.0    NA     NA          2.562500            18.22917
8      A   5.5    NA     NA          2.804688            18.13281
9      A   6.0     3     18          3.000000            18.00000
10     A   6.5    NA     NA          3.132812            17.88281
..   ...   ...   ...    ...               ...                 ...

在上面的图表中，小点和线是插值出来的。大而粗的点是观测到的。

library(ggplot2)
ggplot(ds_intpolated, aes(x=depth, y=root_interpolated, color=trt)) +
  geom_line() +
  geom_point(shape=1) +
  geom_point(aes(y=root), size=5, alpha=.3, na.rm=T) +
  theme_bw()

ggplot(ds_intpolated, aes(x=depth, y=carbon_interpolated, color=trt)) +
  geom_line() +
  geom_point(shape=1) +
  geom_point(aes(y=carbon), size=5, alpha=.3, na.rm=T) +
  theme_bw()

如果您需要更多示例，这里有一些最近的代码和幻灯片。我们需要一个滚动中位数来处理一些缺失点，并使用线性stats::approx()处理其他一些点。另一个选择是stats::loess()，但它的参数与approx()和spline()不太相似。

- wibeasley

Answer 2

我放弃尝试使用dplyr::summarise_each（也尝试了dplyr::summarise，因为您选择的函数似乎与您希望返回仅两个函数的多列输入不匹配）。我不确定在dplyr中是否可能。以下是可能被称为处理此问题的规范方法：

 lapply( split(df, df$trt), function(d) splinefun(x=d$depth, y=d$carbon) )
#-------------

$A
function (x, deriv = 0L) 
{
    deriv <- as.integer(deriv)
    if (deriv < 0L || deriv > 3L) 
        stop("'deriv' must be between 0 and 3")
    if (deriv > 0L) {
        z0 <- double(z$n)
        z[c("y", "b", "c")] <- switch(deriv, list(y = z$b, b = 2 * 
            z$c, c = 3 * z$d), list(y = 2 * z$c, b = 6 * z$d, 
            c = z0), list(y = 6 * z$d, b = z0, c = z0))
        z[["d"]] <- z0
    }
    res <- .splinefun(x, z)
    if (deriv > 0 && z$method == 2 && any(ind <- x <= z$x[1L])) 
        res[ind] <- ifelse(deriv == 1, z$y[1L], 0)
    res
}
<bytecode: 0x7fe56e4853f8>
<environment: 0x7fe56efd3d80>

$B
function (x, deriv = 0L) 
{
    deriv <- as.integer(deriv)
    if (deriv < 0L || deriv > 3L) 
        stop("'deriv' must be between 0 and 3")
    if (deriv > 0L) {
        z0 <- double(z$n)
        z[c("y", "b", "c")] <- switch(deriv, list(y = z$b, b = 2 * 
            z$c, c = 3 * z$d), list(y = 2 * z$c, b = 6 * z$d, 
            c = z0), list(y = 6 * z$d, b = z0, c = z0))
        z[["d"]] <- z0
    }
    res <- .splinefun(x, z)
    if (deriv > 0 && z$method == 2 && any(ind <- x <= z$x[1L])) 
        res[ind] <- ifelse(deriv == 1, z$y[1L], 0)
    res
}
<bytecode: 0x7fe56e4853f8>
<environment: 0x7fe56efc4db8>

- IRTFM