Skip to content

Instantly share code, notes, and snippets.

@uribo
Last active August 25, 2020 13:03
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save uribo/cd289197a210df0aab7c1a16eeac6818 to your computer and use it in GitHub Desktop.
気象庁 観測史上の記録
####################################
# 気象庁 観測史上の記録
####################################
library(tidyverse)
library(jmastats) # remotes::install_gitlab("uribo/jmastats")
library(ggalt)
library(sf)
library(patchwork)
tgt_st_block_no <- c("47418", "47407", "47412", "47575", "47582", "47590", "47615", "47662",
"47610", "47604", "47605", "47636", "47772", "47741", "47765", "47891",
"47893", "47807", "47827", "47909", "47936", "47918", "47971")
sf_target_st <-
stations %>%
distinct(area, station_no, station_name, block_no) %>%
filter(block_no %in% tgt_st_block_no) %>%
group_by(block_no) %>%
slice(1L) %>%
ungroup() %>%
assertr::verify(dim(.) == c(23, 5))
# mapview::mapview(sf_target_st)
tgt_st_block_no
jma_record_temp <- function(year, block_no, type = c("高い", "低い")) {
d <-
jmastats::jma_collect(item = "rank", block_no = block_no, year = year) %>%
filter(str_detect(element, glue::glue("日最高気温の{type}方から")))
if (nrow(d) == 0)
rlang::abort("データがありません")
d %>%
select(element, value, date, period) %>%
mutate(value = as.numeric(value),
date = lubridate::as_date(date))
}
mod_record_data <- function(data) {
data %>%
arrange(date) %>%
mutate(y = row_number(),
to_date = tidyr::replace_na(lead(date),
lubridate::today())) %>%
rename(from_date = date) %>%
mutate(y_value = paste0(format(from_date, "%Y年%m月%d日"),
"\n",
value,
"\u2103") %>%
forcats::fct_inorder(),
days = as.numeric(to_date - from_date))
}
plot_jma_record_interval_base <- function(data, station_name) {
d <-
data %>%
filter(lubridate::year(from_date) >= 1990)
y_longest <-
as.character(d$y_value[which.max(dplyr::min_rank(d$days))])
d %>%
ggplot(aes(x = from_date,
y = y_value,
xend = to_date)) +
geom_text(aes(x = from_date + floor((to_date - from_date) / 2),
label = paste0(days, "")),
nudge_y = -0.25,
size = 1.6,
fontface = "bold",
family = "Klee-Medium") +
geom_dumbbell(data = d %>%
filter(str_detect(y_value,
y_longest)),
color = "#32478B") +
geom_dumbbell(data = d %>%
filter(str_detect(y_value,
y_longest,
negate = TRUE)),
color = "gray") +
# gghighlight(str_detect(y_value, as.character(d$y_value[dplyr::min_rank(d$days)[1]])),
# unhighlighted_params = list(color = "gray",
# type = 2)) +
scale_x_date(limits = c(lubridate::ymd(19900101),
lubridate::today()),
date_labels = "%Y年") +
theme_light(base_family = "Klee-Medium", base_size = 6) +
labs(subtitle = glue::glue("観測地点: {station_name}")) +
ylab(NULL) +
xlab(NULL)
}
plot_jma_record_interval <- function(data, station_name) {
plot_jma_record_interval_base(data, station_name) +
labs(title = "1990年以降の日最高気温、観測史上の記録継続期間",
caption = "日数が最も長い期間をハイライト\nSource: 気象庁 過去の気象データ検索 http://www.data.jma.go.jp/obd/stats/etrn/index.php\n
瓜生真也が加工・編集")
}
df_jma_records <-
tgt_st_block_no %>%
purrr::map_dfr(~ jmastats::jma_collect(item = "rank", block_no = .x, year = 2020) %>%
mutate(block_no = .x))
df_jma_records_htemp <-
df_jma_records %>%
filter(str_detect(element, glue::glue("日最高気温の高い方から"))) %>%
select(block_no, element, value, date, period) %>%
mutate(value = as.numeric(value),
date = lubridate::as_date(date))
res <-
df_jma_records_htemp %>%
left_join(stations %>%
st_drop_geometry() %>%
distinct(block_no, station_name),
by = "block_no") %>%
group_by(block_no) %>%
group_modify(~ mod_record_data(.x)) %>%
ungroup() %>%
group_by(block_no) %>%
group_map(~ plot_jma_record_interval_base(data = .x, station_name = .x$station_name))
res %>%
wrap_plots() +
plot_annotation(title = "1990年以降の日最高気温における観測史上上位記録の継続期間",
caption = "日数が最も長い期間をハイライト\nSource: 気象庁 過去の気象データ検索 http://www.data.jma.go.jp/obd/stats/etrn/index.php\n
瓜生真也が加工・編集",
theme = theme(text = element_text(family = "Klee-Medium")))
ggsave("out.png", last_plot(), width = 15, height = 10, dpi = 320)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment