r - ggplot2，facet_wrap : plotting data twice in different facets

Question

假设我有一个这样的数据框:

df <- data.frame(year_day = rep(1:365, 3), 
                 year = rep(2001:2003, each = 365), 
                 value = sin(2*pi*rep(1:365, 3)/365))

它表示从 2001 年到 2003 年一年中的每一天 (year_day) 的一些值 (value)。我想绘制每一年并使用 ggplot2 这样做。

ggplot(df) + geom_point(aes(year_day, value)) + facet_wrap(~year, ncol=1)

这给了我:

太棒了。现在，假设我想稍微扩展我的绘图区域，以便每年包括前一年的 3 个月和下一年的 3 个月(如果这些数据存在)。这意味着某些数据将被绘制两次。例如，2003 年的前三个月将出现在 2002 年和 2003 年的图中。因此，我可以复制这些行并将它们分配给 2002 年，但 year-day 为 366 到 485。这有效，但很笨拙。有没有更优雅的解决方案？

Answer 1

编辑删除旧版本并替换

这是我考虑了一段时间的事情，所以这是尝试实现它的充分理由。它仍然涉及复制行，这很笨拙，但这是我能想到的最好的方法。

这是一个整洁的管道函数，它将一个数据帧(甚至是一个分组的数据帧)作为它的第一个参数，并将一列日期作为它的第二个参数。有一个可选的第三个参数来扩展每个窗口扩展的距离(默认为 0.25，或 3 个月)。第四个论点是关于财政年度或学年等不是一月一月的事情，但我还没有深入思考过那个。

输出是相同的数据框，年份尾部有重复的行，还有额外的列 doy_wrapped 表示一年中的第几天(从负数到 >365)，以及 nominal_yr，这是每个窗口居中的年份。

示例，使用数据集 ggplot2::economics:

library(dplyr)
library(lubridate)

economics %>% 
  filter(year(date) > 2007) 

# A tibble: 88 x 6
         date     pce    pop psavert uempmed unemploy
       <date>   <dbl>  <int>   <dbl>   <dbl>    <int>
 1 2008-01-01  9963.2 303506     3.4     9.0     7685
 2 2008-02-01  9955.7 303711     3.9     8.7     7497
 3 2008-03-01 10004.2 303907     4.0     8.7     7822
 4 2008-04-01 10044.6 304117     3.5     9.4     7637
 5 2008-05-01 10093.3 304323     7.9     7.9     8395
 6 2008-06-01 10149.4 304556     5.6     9.0     8575
 7 2008-07-01 10151.1 304798     4.4     9.7     8937
 8 2008-08-01 10140.3 305045     3.7     9.7     9438
 9 2008-09-01 10083.2 305309     4.4    10.2     9494
10 2008-10-01  9983.3 305554     5.4    10.4    10074
# ... with 78 more rows

---

economics %>% 
  filter(year(date) > 2007) %>% 
  wrap_years(date, expand = 3/12)

# A tibble: 136 x 8
# Groups:   nominal_yr [8]
         date     pce    pop psavert uempmed unemploy nominal_yr doy_wrapped
       <date>   <dbl>  <int>   <dbl>   <dbl>    <int>      <dbl>       <dbl>
 1 2008-01-01  9963.2 303506     3.4     9.0     7685       2008           1
 2 2008-02-01  9955.7 303711     3.9     8.7     7497       2008          32
 3 2008-03-01 10004.2 303907     4.0     8.7     7822       2008          61
 4 2008-04-01 10044.6 304117     3.5     9.4     7637       2008          92
 5 2008-05-01 10093.3 304323     7.9     7.9     8395       2008         122
 6 2008-06-01 10149.4 304556     5.6     9.0     8575       2008         153
 7 2008-07-01 10151.1 304798     4.4     9.7     8937       2008         183
 8 2008-08-01 10140.3 305045     3.7     9.7     9438       2008         214
 9 2008-09-01 10083.2 305309     4.4    10.2     9494       2008         245
10 2008-10-01  9983.3 305554     5.4    10.4    10074       2009         -90
# ... with 126 more rows

这确实有点打乱了秩序；它按顺序将行一式三份，然后将它们重新分配给邻近的年份。它保留了原始分组，同时为新的 nominal_yr 添加了一个分组(以删除可能缺少中央年份数据的孤立尾部)。

economics %>% 
  filter(year(date) > 2007) %>% 
  wrap_years(date, expand = 3/12) %>%
  ggplot(aes(doy_wrapped, unemploy)) + 
  geom_line() + facet_wrap(~nominal_yr, ncol = 3)

然后一些技巧来装饰它并校正轴:

economics %>% 
  filter(year(date) > 2007) %>% 
  wrap_years(date, expand = 3/12) %>%
  ggplot(aes(doy_wrapped + ymd("1900-01-01") - 1, unemploy)) + 
  geom_line() + facet_wrap(~nominal_yr, ncol = 2) +
  geom_vline(xintercept = as.numeric(c(ymd("1900-01-01"), ymd("1901-01-01")))) +
  scale_x_date(date_breaks = "2 months",date_labels = "%b",
               name = NULL, expand = c(0,0) +
  theme_minimal() +
  theme(panel.spacing.x = unit(1, "cm"))

aes(...) 中的 + ymd("1900-01-01") - 1 是任意的，您只希望它与1 月 1 日，这样每年都有正确的月份。然后将它与垂直线中的 xintercept = 匹配。

理想情况下，这最终将成为 wrap_* 函数系列的一部分，适用于季度、月份、小时、十年等。

函数代码:

wrap_years <- function(df, datecol, expand = 0.25, offset = "2001-01-01") {

  if(!is.data.frame(df)) {return(df)}

  datecol <- enquo(datecol)

  if(expand > 1) {
    warning(paste0("Window expansions of > 1 are not supported."))
    return(df)
  }


  if(!(quo_name(datecol) %in% names(df))) {
    warning(paste0("Column '", quo_name(datecol), "' not found in data."))
    return(df)
  }

  # offset <- as_date(offset)
  # warning(paste0("Using  ", stamp("August 26", orders = "md")(offset), 
  #                " as start of year. Not yet implemented."))

  if(!is.Date(df %>% pull(!!datecol))) {
    warning(paste0("Use lubridate functions to parse '", 
                   quo_name(datecol), 
                   "' before proceeding."))
    return(df)
  }

  df %>% 
    mutate(adj_wrap = list(-1:1)) %>% 
    tidyr::unnest() %>% 
    mutate(nominal_yr =  year(!!datecol) -     adj_wrap,
           doy_wrapped = yday(!!datecol) + 365*adj_wrap) %>% 
    filter(between(doy_wrapped, -expand * 365, (1 + expand) * 365)) %>% 
    select(-adj_wrap) %>% 
    group_by(nominal_yr, add = T) %>% 
    filter(sum(year(!!datecol) != nominal_yr) != length(nominal_yr))

}

我曾假设复制最少的行数将是最快的方法，这是我第一次尝试它背后的范例。后来想想，我意识到一个更天真的方法是简单地复制所有行，事实证明这要快得多。然后过滤步骤用between完成，也很快。这个版本的函数速度大约是以前版本的 2 倍(但绘制原始数据的速度大约是 0.01 倍)。