如何在R中按年分割日历热图?

wmomyfyw  于 2023-04-18  发布在  其他
关注(0)|答案(1)|浏览(94)

我正在尝试复制热图的代码,如下所示。

我找到了创建这个热图here的代码。但是,我的数据由两个位置的四年实验的某些月份组成,我想在一个图中显示所有四年,按月份和年份显示。目前,它只按月份显示一年。
我已经成功地创建了一个按月份分面的每年的热图,但是我不知道如何得到一个按月份和年份分面的图。下面是我目前的代码-它不接受下面代码中facet_wrap( ~ month,步骤中的year。有人能帮我修改这个代码来创建一个按年份分面的图吗?这样我就可以在一个图中看到所有四年的情况了。

# paquetes
library(tidyverse)
library(lubridate)
library(ragg)

# color ramp
pubu <- RColorBrewer::brewer.pal(9, "PuBu")
col_p <- colorRampPalette(pubu)

theme_calendar <- function() {
  theme(
    aspect.ratio = 1 / 2,
    
    axis.title = element_blank(),
    axis.ticks = element_blank(),
    axis.text.y = element_blank(),
    axis.text = element_text(),
    
    panel.grid = element_blank(),
    panel.background = element_blank(),
    
    strip.background = element_blank(),
    strip.text = element_text(face = "bold", size = 15),
    
    legend.position = "top",
    legend.text = element_text(hjust = .5),
    legend.title = element_text(size = 9, hjust = 1),
    
    plot.caption =  element_text(hjust = 1, size = 8),
    panel.border = element_rect(
      colour = "grey",
      fill = NA,
      size = 1
    ),
    plot.title = element_text(
      hjust = .5,
      size = 26,
      face = "bold",
      margin = margin(0, 0, 0.5, 0, unit = "cm")
    ),
    plot.subtitle = element_text(hjust = .5, size = 16)
  )
}

dat_prr <- dat_prr %>%
  rename(pr = precipitation) %>%
  complete(date = seq(min(date),
                      max(date),
                      "day")) %>%
  mutate(
    weekday = lubridate::wday(date, label = T, week_start = 1),
    month = lubridate::month(date, label = T, abbr = F),
    week = isoweek(date),
    day = day(date)
  ) %>%
  na.omit()

#> Adding missing grouping variables: `month`

dat_prr <- mutate(
  dat_prr,
  week = case_when(
    month == "December" & week == 1 ~ 53,
    month == "January" &
      week %in% 52:53 ~ 0,
    TRUE ~ week
  ),
  pcat = cut(pr, c(-1, 0, 0.5, 1:5, 7, 9, 25, 75)),
  text_col = ifelse(pcat %in% c("(7,9]", "(9,25]"), "white", "black")
)

calendar_Lowgap <- ggplot(dat_prr,
                          aes(weekday,-week, fill = pcat)) +
  geom_tile(colour = "white", size = .4)  +
  geom_text(aes(label = day, colour = text_col), size = 2.5) +
  guides(fill = guide_colorsteps(
    barwidth = 25,
    barheight = .4,
    title.position = "top"
  )) +
  scale_fill_manual(
    values = c("white", col_p(13)),
    na.value = "grey90",
    drop = FALSE
  ) +
  scale_colour_manual(values = c("black", "white"), guide = FALSE) +
  facet_wrap( ~ month,
              nrow = 4,
              ncol = 3,
              scales = "free") +
  labs(title = "Rainfall durirng trials from 2015 to 2017",
       subtitle = "Rainfall",
       fill = "mm") +
  theme_calendar()

下面是可重复的示例

dat_prr <- structure(
  list(
    date = structure(
      c(
        16216,
        16217,
        16218,
        16219,
        16220,
        16221,
        16222,
        16223,
        16230,
        16231,
        16232,
        16233,
        16234,
        16235,
        16236,
        16574,
        16575,
        16576,
        16577,
        16578,
        16579,
        16580,
        16581,
        16582,
        16583,
        16584,
        16585,
        16586,
        16587,
        16588,
        16981,
        16982,
        16983,
        16984,
        16985,
        16986,
        16987,
        16988,
        16989,
        16990,
        16991,
        16992,
        16993,
        16994,
        16995,
        17233,
        17234,
        17235,
        17236,
        17237,
        17238,
        17239,
        17240,
        17241,
        17242,
        17243,
        17244,
        17245,
        17246,
        17247
      ),
      class = "Date"
    ),
    year = structure(
      c(
        1L,
        1L,
        1L,
        1L,
        1L,
        1L,
        1L,
        1L,
        1L,
        1L,
        1L,
        1L,
        1L,
        1L,
        1L,
        2L,
        2L,
        2L,
        2L,
        2L,
        2L,
        2L,
        2L,
        2L,
        2L,
        2L,
        2L,
        2L,
        2L,
        2L,
        3L,
        3L,
        3L,
        3L,
        3L,
        3L,
        3L,
        3L,
        3L,
        3L,
        3L,
        3L,
        3L,
        3L,
        3L,
        4L,
        4L,
        4L,
        4L,
        4L,
        4L,
        4L,
        4L,
        4L,
        4L,
        4L,
        4L,
        4L,
        4L,
        4L
      ),
      .Label = c("2014", "2015",
                 "2016", "2017"),
      class = "factor"
    ),
    precipitation = c(
      0.8,
      0,
      1.4,
      3,
      0,
      1,
      0,
      0,
      3,
      0,
      2.4,
      1.2,
      0,
      0,
      0,
      0,
      0,
      1.00000001490116,
      0,
      0,
      0,
      0,
      0,
      1.40000002086163,
      19.8000004887581,
      0,
      0,
      0.200000002980232,
      5.20000007748604,
      3.00000007450581,
      0.400000005960464,
      0.200000002980232,
      6.00000014901161,
      26.3999992460012,
      0.800000011920929,
      19.999999910593,
      1.40000002086163,
      1,
      0.800000011920929,
      3.60000005364418,
      0.200000002980232,
      0.200000002980232,
      0,
      6.79999981820583,
      0,
      0,
      0,
      2.20000003278255,
      0,
      0,
      0,
      9.00000016391277,
      0,
      0,
      0,
      2.80000004172325,
      0,
      0,
      0,
      0
    )
  ),
  class = c("grouped_df", "tbl_df", "tbl", "data.frame"),
  row.names = c(NA,-60L),
  groups = structure(
    list(
      year = structure(
        1:4,
        .Label = c("2014",
                   "2015", "2016", "2017"),
        class = "factor"
      ),
      .rows = structure(
        list(1:15, 16:30, 31:45, 46:60),
        ptype = integer(0),
        class = c("vctrs_list_of",
                  "vctrs_vctr", "list")
      )
    ),
    row.names = c(NA,-4L),
    class = c("tbl_df",
              "tbl", "data.frame"),
    .drop = TRUE
  )
)

dat_prr$date = as.Date(dat_prr$date)

[![在此处输入图像描述][3]][3]

k97glaaz

k97glaaz1#

你试过这样吗?

ggplot(dat_prr,
                          aes(weekday,-week, fill = pcat)) +
  geom_tile(colour = "white", size = .4)  +
  geom_text(aes(label = day, colour = text_col), size = 2.5) +
  guides(fill = guide_colorsteps(
    barwidth = 25,
    barheight = .4,
    title.position = "top"
  )) +
  scale_fill_manual(
    values = c("white", col_p(13)),
    na.value = "grey90",
    drop = FALSE
  ) +
  scale_colour_manual(values = c("black", "white"), guide = "none") +
  facet_wrap(vars(year,month),
              nrow = 4,
              ncol = 3,
              scales = "free") +
  labs(title = "Rainfall durirng trials from 2015 to 2017",
       subtitle = "Rainfall",
       fill = "mm") +
  theme_calendar()

相关问题