修改后的 cumsum - 以比率 r 汇总

Question

我有一个移动粒子的 df，我每小时跟踪一次。我在 1、11、21、31、41 小时有参考距离，并且轨道都在这些时间之间的某个时间点结束。

所以我想要做的是找到每组/试验在 hour0 和 hour(end) 之间的总距离。这意味着我需要在结束前添加小时参考的累积总和，以及结束后一小时的比例距离。

例如，如果轨道在 34 小时结束，我会知道行驶的长度是（1、11、21、31 小时长度的总和）+ 3/10 长度（41）。

我的代码可以找到 cumsum，但我不知道如何添加额外的小比例位。

 set.seed(1)
 df1 <- data.frame(matrix(nrow=20,ncol=4))
 colnames(df1) <- c("group","trial","hour","length")
 df1$group <- rep(c("a","b"),each=10)
 df1$trial <- rep(c(1,1,1,1,1,2,2,2,2,2),times=2)
 df1$hour <- rep(c(1,11,21,31,41),times=4)
 df1$length <- rep(c(10,12,13,17,21),times=4)


 df2 <- data.frame(matrix(nrow=4,ncol=3))
 colnames(df2) <- c("group","trial","end")
 df2$group <- c("a","a","b","b")
 df2$trial <- c(1,2,1,2)
 df2$end <- runif(4,1,40)


 df3 <- df2 %>% 
   left_join(df1,by=c("group","trial")) %>%
   group_by(group,trial) %>%
   mutate(cumlength = cumsum(length)) %>%
   slice({i1 <- which(hour <= end) 
   c(i1, tail(i1, 1) + 1)})

这让我得到一个包含我应该需要的所有数据的 df，但我希望能够 summarise() 以找到最后一小时的长度总和 + 比例额外位。

 df3 %>% summarise(total = sum(length))
 # sum of all lengths, but this overshoots. 

感谢您的帮助

Answer 1

如果我理解您的问题，您希望在任意小时 (end) 对您的 cumsum(length) ~ hour 进行线性插值。有一个方便的基本 R 函数，approxfun。

鉴于您的df1 和df2：

  library(dplyr)

  df1 %>% 
    group_by(group, trial) %>% 
    summarise(
      f = list(approxfun(cumsum(length) ~ hour))
      )

# A tibble: 4 x 3
# Groups:   group [2]
  group trial f     
  <chr> <dbl> <list>
1 a         1 <fn>  
2 a         2 <fn>  
3 b         1 <fn>  
4 b         2 <fn>

---

现在您有了一个函数列表，每个函数都可以在您选择的时间进行评估。所以让我们加入：

  df1 %>% 
    group_by(group, trial) %>% 
    summarise(
      f = list(approxfun(cumsum(length) ~ hour))
      ) %>% 
    full_join(df2) 

Joining, by = c("group", "trial")
# A tibble: 4 x 4
# Groups:   group [2]
  group trial f        end
  <chr> <dbl> <list> <dbl>
1 a         1 <fn>    11.4
2 a         2 <fn>    15.5
3 b         1 <fn>    23.3
4 b         2 <fn>    36.4

---

现在我们可以在该列表中使用purrr::map*。我们将使用map2，因为我们希望同时评估f 和end，并且我们知道它应该返回一个数字，所以我们将专门使用map2_dbl。

  library(purrr)

  df1 %>% 
    group_by(group, trial) %>% 
    summarise(
      f = list(approxfun(cumsum(length) ~ hour))
      ) %>% 
    full_join(df2) %>% 
    mutate(total = map2_dbl(f, end, ~.x(.y)))

Joining, by = c("group", "trial")
# A tibble: 4 x 5
# Groups:   group [2]
  group trial f        end total
  <chr> <dbl> <list> <dbl> <dbl>
1 a         1 <fn>    11.4  22.5
2 a         2 <fn>    15.5  27.9
3 b         1 <fn>    23.3  39.0
4 b         2 <fn>    36.4  63.4

---

如果您之前没有使用过purrr，那可能看起来像是黑魔法。 map 函数是迭代器，类似于基础 R 中的 lapply。它们获取列表的元素并对其应用函数。你可以使用这些“匿名”函数，写成公式。 ~.x+.y 之类的内容与 function(arg1, arg2) {arg1 + arg2} 相同。

这里强大的应用是其中一个参数本身就是我们要使用的函数，列f。通过首先传递它，它是匿名函数中的.x。第二个参数end 变为.y。那么~.x(.y) 与为四对中的每一对调用 f(end) 相同。

---

让我们通过可视化结果来做一些健全性检查。将上述结果存储在df3 中并：

library(ggplot2)

df1 %>% 
  group_by(group, trial) %>% 
  mutate(cumlength = cumsum(length)) %>% 
  ggplot(aes(hour, cumlength)) +
  geom_point() +
  geom_path() + 
  geom_vline(
    data = df3, 
    aes(xintercept = end),
    color = "red"
    ) +
  geom_point(
    data = df3, 
    aes(end, total), 
    color = "red", size = 3, shape = 0
    ) +
  facet_grid(group~trial)