Last active
September 22, 2019 18:48
-
-
Save uribo/156b7bcd740e1b0339883e96baacb699 to your computer and use it in GitHub Desktop.
令和元年台風第15号に係る鉄道運行状況(千葉県)
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| library(drake) | |
| library(dplyr) | |
| library(purrr) | |
| library(assertr) | |
| library(tabulizer) | |
| matrix_to_tbl <- function(data) { | |
| data %>% | |
| as.data.frame(stringsAsFactors = FALSE) %>% | |
| janitor::clean_names() %>% | |
| dplyr::mutate_if(is.character, stringi::stri_trans_nfkc) %>% | |
| tibble::as_tibble() | |
| } | |
| col_carry <- function(data, ...) { | |
| vars <- names(data) | |
| vars_n <- length(vars) | |
| data[, vars_n + seq.int(1, ...)] <- NA_character_ | |
| data %>% | |
| dplyr::select(names(data)[!names(data) %in% vars], vars[seq_len(vars_n - ...)]) %>% | |
| purrr::set_names(vars) | |
| } | |
| fix_railway_table <- function(data) { | |
| fix_names_railway <- | |
| c("事業者名", "線名", "運転休止区間", | |
| paste("運転休止", c("日付", "時刻"), sep = "_"), | |
| paste("運転再開", c("日付", "時刻"), sep = "_"), | |
| "主な被害状況等") | |
| data <- | |
| data %>% | |
| purrr::reduce(rbind) %>% | |
| purrr::set_names(fix_names_railway) %>% | |
| dplyr::slice(-1L) %>% | |
| dplyr::mutate_all(na_if, y = "") %>% | |
| tibble::rowid_to_column() | |
| d_tmp <- | |
| data %>% | |
| dplyr::slice(stringr::str_which(data$`事業者名`, "線$")) | |
| if (nrow(d_tmp) > 0) { | |
| data_a <- | |
| data %>% | |
| dplyr::slice(stringr::str_which(data$`事業者名`, "線$", negate = TRUE)) %>% | |
| dplyr::bind_rows(d_tmp %>% | |
| select(-rowid) %>% | |
| col_carry(1L) %>% | |
| dplyr::bind_cols(d_tmp %>% | |
| dplyr::select(rowid)) %>% | |
| dplyr::select(rowid, fix_names_railway)) | |
| if (nrow(data_a) > 0) { | |
| data <- | |
| data %>% | |
| dplyr::filter(!rowid %in% data_a$rowid) %>% | |
| dplyr::bind_rows(data_a) %>% | |
| dplyr::arrange(rowid) | |
| } | |
| } | |
| d_tmp2 <- | |
| data %>% | |
| dplyr::slice(stringr::str_which(data$`事業者名`, "^.+~.+$")) | |
| if (nrow(d_tmp2) > 0) { | |
| data_b <- | |
| data %>% | |
| dplyr::slice(stringr::str_which(data$`事業者名`, "^.+~.+$", negate = TRUE)) %>% | |
| dplyr::bind_rows(d_tmp2 %>% | |
| dplyr::select(-rowid) %>% | |
| col_carry(2L) %>% | |
| dplyr::bind_cols(d_tmp2 %>% | |
| dplyr::select(rowid)) %>% | |
| dplyr::select(rowid, fix_names_railway)) | |
| if (nrow(data_b) > 0) { | |
| data <- | |
| data %>% | |
| dplyr::filter(!rowid %in% data_b$rowid) %>% | |
| dplyr::bind_rows(data_b) %>% | |
| dplyr::arrange(rowid) | |
| } | |
| } | |
| d_tmp3 <- | |
| data %>% | |
| dplyr::filter(stringr::str_detect(運転休止区間, "/")) | |
| if (nrow(d_tmp3) > 0) { | |
| d_tmp3 <- | |
| d_tmp3 %>% | |
| tibble::add_column(tmp = NA_character_, .before = 3) %>% | |
| dplyr::select(rowid, 事業者名, tmp, names(d_tmp3)[2:length(names(d_tmp3)) - 1]) %>% | |
| purrr::set_names(c("rowid", fix_names_railway)) | |
| data <- | |
| data %>% | |
| dplyr::filter(stringr::str_detect(運転休止区間, "/", negate = TRUE)) %>% | |
| dplyr::bind_rows(d_tmp3) %>% | |
| dplyr::arrange(rowid) %>% | |
| dplyr::select(-rowid) %>% | |
| tidyr::fill(`事業者名`, .direction = "down") %>% | |
| tidyr::fill(`線名`, .direction = "down") %>% | |
| dplyr::mutate_if(is.character, list(~ stringr::str_trim(.) %>% | |
| stringr::str_squish() %>% | |
| stringr::str_remove_all("[[:space:]]"))) | |
| } | |
| data | |
| } | |
| # File Download ----------------------------------------------------------- | |
| file_path <- "r1typhoon15_19.pdf" | |
| download.file("http://www.bousai.go.jp/updates/r1typhoon15/pdf/r1typhoon15_19.pdf", | |
| destfile = file_path) | |
| file_path <- "~/Documents/projects2019/jp-disaster/data-raw/r1typhoon15_19.pdf" | |
| plan_collect_data <- drake_plan( | |
| df_railway_raw = | |
| list( | |
| # 42 | |
| extract_tables(file_path, | |
| pages = 9, | |
| area = list(c(250, 95, 780, 510)), | |
| output = "matrix"), | |
| # 43-102(60), 103-160(58) | |
| extract_tables(file_path, | |
| pages = seq.int(10, 11), | |
| output = "matrix")) %>% | |
| flatten() %>% | |
| map(matrix_to_tbl), | |
| df_railway = | |
| df_railway_raw %>% | |
| fix_railway_table() %>% | |
| verify(dim(.) == c(160, 8)) %>% | |
| mutate_at(vars(ends_with("日付")), | |
| list(~ if_else(is.na(.), | |
| lubridate::ymd(NA), | |
| lubridate::ymd(paste0("2019/", .))))) | |
| ) | |
| make(plan_collect_data) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| source("01-file_download.R") | |
| library(dplyr) | |
| library(purrr) | |
| library(sf) | |
| library(zipangu) | |
| library(lubridate) | |
| library(drake) | |
| loadd(df_railway) | |
| filter_area_by_stname <- function(data, operationCompany = NULL, railwayLineName = NULL, stations) { | |
| op_company = rlang::enquo(operationCompany) | |
| line_name = rlang::enquo(railwayLineName) | |
| rfid_range <- | |
| data %>% | |
| dplyr::filter(operationCompany == !!op_company, | |
| railwayLineName == !!line_name) %>% | |
| filter(stationName %in% stations) %>% | |
| pull(rfid) %>% | |
| stringr::str_remove("EB03_") %>% | |
| as.numeric() %>% | |
| range() | |
| filter_area_stations(data, operationCompany, railwayLineName, rfid_range[1], rfid_range[2]) | |
| } | |
| filter_area_stations <- function(data, operationCompany = NULL, railwayLineName = NULL, rfid1, rfid2) { | |
| op_company = rlang::enquo(operationCompany) | |
| line_name = rlang::enquo(railwayLineName) | |
| data %>% | |
| dplyr::filter(operationCompany == !!op_company, | |
| railwayLineName == !!line_name) %>% | |
| dplyr::mutate(rfid_num = stringr::str_remove(rfid, "EB03_") %>% | |
| as.numeric()) %>% | |
| dplyr::filter(dplyr::between(rfid_num, rfid1, rfid2)) %>% | |
| dplyr::arrange(rfid_num) %>% | |
| dplyr::select(-rfid_num) | |
| } | |
| split_suspend_area <- function(data) { | |
| d <- | |
| sf_railroad_pref12 %>% | |
| dplyr::filter(operationCompany == data$operationCompany[1], | |
| railwayLineName == data$railwayLineName[1]) | |
| d2 <- | |
| sf_railstation_pref12 %>% | |
| dplyr::filter(operationCompany == data$operationCompany[1], | |
| railwayLineName == data$railwayLineName[1]) %>% | |
| arrange(rfid) | |
| if (data$suspend_all == TRUE) { | |
| sts <- | |
| d2 %>% | |
| slice(c(1, nrow(.))) %>% | |
| pull(stationName) | |
| data <- | |
| data %>% | |
| mutate(st1 = sts[1], | |
| st2 = sts[2]) | |
| } | |
| d <- | |
| d %>% | |
| lwgeom::st_split( | |
| d2 %>% | |
| filter(stationName %in% c(data$st1[1], | |
| data$st2[1])) | |
| ) %>% | |
| st_collection_extract("LINESTRING") %>% | |
| tibble::rowid_to_column() %>% | |
| left_join(data %>% | |
| select(operationCompany, railwayLineName, st1, st2, | |
| start_date, start_time, end_date, end_time, suspend_all), | |
| by = c("operationCompany", "railwayLineName")) %>% | |
| select(-trid, -trrm, -remark, -rfrm) | |
| d <- | |
| d %>% | |
| mutate(suspend_area = st_crosses(geometry, | |
| filter_area_by_stname(sf_railstation_pref12, | |
| operationCompany = data$operationCompany[1], | |
| railwayLineName = data$railwayLineName[1], | |
| c(data$st1[1], | |
| data$st2[1])) %>% | |
| summarise(do_union = FALSE) %>% | |
| st_cast("LINESTRING"), | |
| sparse = FALSE)[, 1]) %>% | |
| select(railwayLineName, operationCompany, st1, st2, | |
| start_date, start_time, end_date, end_time, | |
| suspend_all, suspend_area) | |
| d | |
| } | |
| read_ksj_n05(.year = 2016, .download = TRUE) | |
| # data -------------------------------------------------------------------- | |
| plan_dataset <- | |
| drake::drake_plan( | |
| # 千葉県 | |
| sf_pref12 = | |
| read_ksj_n03(.year = 2019, .pref_code = 12) %>% | |
| st_union() %>% | |
| st_sf() %>% | |
| st_transform(crs = 4326) %>% | |
| st_simplify(dTolerance = 0.0005), | |
| # 路線、駅データ | |
| df_ksj_n05 = | |
| read_ksj_n05(.year = 2018, .type = "station") %>% | |
| filter(timePeriod_End == "9999") %>% | |
| mutate(operationCompany = recode( | |
| operationCompany, | |
| `東日本旅客鉄道（旧国鉄）` = "東日本旅客鉄道")), | |
| df_ksj_n05_railroad = | |
| read_ksj_n05(.year = 2018, .type = "railroad") %>% | |
| filter(timePeriod_End == "9999") %>% | |
| mutate(operationCompany = recode( | |
| operationCompany, | |
| `東日本旅客鉄道（旧国鉄）` = "東日本旅客鉄道")), | |
| sf_railstation_pref12 = | |
| df_ksj_n05 %>% | |
| st_join(sf_pref12, | |
| join = st_intersects, | |
| left = FALSE), | |
| sf_railroad_pref12 = | |
| df_ksj_n05_railroad %>% | |
| st_intersection(sf_pref12), | |
| sf_railstation_pref12_beginend = | |
| sf_railstation_pref12 %>% | |
| st_drop_geometry() %>% | |
| select(railwayLineName, operationCompany, stationName, rfid) %>% | |
| group_by(railwayLineName, operationCompany) %>% | |
| arrange(rfid) %>% | |
| group_modify( | |
| ~ rbind(head(.x, 1), | |
| tail(.x, 1)) | |
| ) %>% | |
| ungroup() | |
| ) | |
| drake::make(plan_dataset) | |
| drake::loadd(list = plan_dataset$target) | |
| df_railway <- | |
| df_railway %>% | |
| set_names(c("operationCompany", "railwayLineName", "suspend_area", | |
| "start_date", "start_time", | |
| "end_date", "end_time", | |
| "note")) %>% | |
| mutate(operationCompany = recode(operationCompany, | |
| `JR東日本` = "東日本旅客鉄道")) %>% | |
| mutate(suspend_all = if_else(suspend_area == "全線", TRUE, FALSE), | |
| suspend_area = if_else(suspend_all == TRUE, NA_character_, suspend_area)) %>% | |
| inner_join(sf_railstation_pref12_beginend %>% | |
| group_by(railwayLineName, operationCompany) %>% | |
| mutate(be_area = paste0(stationName, collapse = "~")) %>% | |
| slice(1L) %>% | |
| ungroup() %>% | |
| select(railwayLineName, operationCompany, be_area), | |
| by = c("operationCompany", "railwayLineName")) %>% | |
| mutate(suspend_area = if_else(suspend_all == TRUE, | |
| be_area, | |
| suspend_area)) %>% | |
| tidyr::separate(suspend_area, into = c("st1", "st2"), sep = "~") %>% | |
| select(-note, -be_area) | |
| df_railway %>% | |
| distinct(operationCompany, railwayLineName) %>% | |
| anti_join(sf_railstation_pref12_beginend %>% | |
| distinct(operationCompany, railwayLineName), | |
| by = c("operationCompany", "railwayLineName")) %>% | |
| assertr::verify(nrow(.) == 0L) | |
| df_suspend_area <- | |
| df_railway %>% | |
| inner_join(sf_railstation_pref12 %>% | |
| select(railwayLineName, operationCompany, stationName, rfid) %>% | |
| st_drop_geometry(), | |
| by = c("railwayLineName", "operationCompany", | |
| "st1" = "stationName", | |
| "st2" = "stationName")) %>% | |
| filter(start_date >= "2019-09-08", | |
| end_date != "2019-09-09" | is.na(end_date)) | |
| df_suspend_area <- | |
| seq_len(nrow(df_suspend_area)) %>% | |
| # map_dfr がつかwないので.idもだめ | |
| purrr::map( | |
| ~ split_suspend_area(df_suspend_area[.x, ]) %>% | |
| mutate(index = .x)) %>% | |
| purrr::reduce(rbind) | |
| df_railline_label <- | |
| df_suspend_area %>% | |
| filter(suspend_area == TRUE) %>% | |
| mutate(longitude = sf::st_coordinates(st_centroid(geometry))[, 1], | |
| latitude = sf::st_coordinates(st_centroid(geometry))[, 2]) %>% | |
| st_drop_geometry() %>% | |
| select(-suspend_all) %>% | |
| distinct(operationCompany, railwayLineName, .keep_all = TRUE) %>% | |
| mutate(nudge_x = 0, | |
| nudge_y = 0, | |
| operationCompany = recode( | |
| operationCompany, | |
| `東日本旅客鉄道` = "JR東日本" | |
| ), | |
| operation_railway = paste(operationCompany, railwayLineName, sep = "\n")) | |
| # 運転再開した区間 | |
| df_suspend_area_daily <- | |
| df_suspend_area %>% | |
| filter(suspend_area == TRUE) %>% | |
| select(railwayLineName, operationCompany, start_date, end_date) %>% | |
| mutate(`2019-09-09`= int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190910"), ymd("20190910"))), | |
| `2019-09-10` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190911"), ymd("20190911"))), | |
| `2019-09-11` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190912"), ymd("20190912"))), | |
| `2019-09-12` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190913"), ymd("20190913"))), | |
| `2019-09-13` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190914"), ymd("20190914"))), | |
| `2019-09-14` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190915"), ymd("20190915"))), | |
| `2019-09-15` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190916"), ymd("20190916"))), | |
| `2019-09-16` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190917"), ymd("20190917"))), | |
| `2019-09-17` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190918"), ymd("20190918"))), | |
| `2019-09-18` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190919"), ymd("20190919"))), | |
| `2019-09-19` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190920"), ymd("20190920"))), | |
| `2019-09-20` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190921"), ymd("20190921"))), | |
| `2019-09-21` = int_overlaps(interval(start_date, end_date), | |
| interval(ymd("20190922"), ymd("20190922")))) %>% | |
| tidyr::pivot_longer(cols = starts_with("2019-"), | |
| names_to = "date", | |
| values_to = "suspend", | |
| values_drop_na = FALSE) %>% | |
| mutate(suspend = if_else(is.na(suspend), TRUE, suspend), | |
| suspend = case_when( | |
| suspend == TRUE ~ "運転休止", | |
| suspend == FALSE ~ "運転再開" | |
| )) %>% | |
| st_sf() |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| source("02-datasetup.R") | |
| library(ggplot2) | |
| library(ggrepel) | |
| library(ggtext) | |
| library(cowplot) | |
| # mapping ----------------------------------------------------------------- | |
| p_base <- | |
| ggplot() + | |
| geom_sf(data = sf_pref12, fill = "gray", alpha = 0.3) + | |
| geom_sf(data = sf_railroad_pref12, size = 0.25) + | |
| coord_sf(datum = NA) + | |
| theme_void(base_family = "IPAexGothic", base_size = 9) + | |
| labs( | |
| title = "令和元年台風第15号に係る鉄道運行状況(千葉県)", | |
| subtitle = "2019年9月21日14:00現在の情報を元に作成\nwww.bousai.go.jp/updates/r1typhoon15/pdf/r1typhoon15_19.pdf", | |
| caption = "データソース: 内閣府 防災情報のページ<br> | |
| 国土数値情報 行政区域データ(2019年 N03)<br> | |
| 国土数値情報 鉄道時系列データ(2018年 N05)<br> | |
| 加工・編集: 瓜生真也 (<span style='font-family: \"Font Awesome 5 Brands\"; color:#55acee'></span>@u_ribo)<br>") + | |
| theme( | |
| plot.caption = element_markdown()) | |
| p_pref12_railroad <- | |
| p_base + | |
| labs(title = "千葉県内の鉄道路線", | |
| subtitle = NULL, | |
| caption = "データソース: 国土数値情報 行政区域データ(2019年 N03)<br> | |
| 国土数値情報 鉄道時系列データ(2018年 N05)<br> | |
| 加工・編集: 瓜生真也 (<span style='font-family: \"Font Awesome 5 Brands\"; color:#55acee'></span>@u_ribo)<br>") | |
| p_pref12_suspend_railroad <- | |
| p_base + | |
| geom_sf(data = df_suspend_area %>% | |
| filter(suspend_area == TRUE) %>% | |
| mutate(operationCompany = recode( | |
| operationCompany, | |
| `東日本旅客鉄道` = "JR東日本" | |
| ), | |
| operation_railway = paste(operationCompany, railwayLineName)), | |
| aes(color = operation_railway), | |
| linetype = 1, | |
| show.legend = "line") + | |
| geom_label_repel(data = df_railline_label, | |
| aes(x = longitude, y = latitude, | |
| label = operation_railway), | |
| family = "IPAexGothic", | |
| size = 2, | |
| nudge_x = 0.02, | |
| nudge_y = 0.04) + | |
| guides(color = guide_legend( | |
| title = "運転休止のあった路線・区間" | |
| )) + | |
| labs( | |
| subtitle = NULL) | |
| plot_grid(p_pref12_railroad, p_pref12_suspend_railroad, ncol = 2, rel_widths = c(1, 1.5)) | |
| ggsave("reiwa01_typhoon15_pref12_railroad.png", last_plot(), width = 10, height = 5) | |
| p_pref12_suspend_railroad_daily <- | |
| p_base + | |
| geom_sf(data = df_suspend_area_daily, aes(color = suspend), show.legend = "line") + | |
| scale_color_manual(values = c("運転休止" = "red", "運転再開" = "blue")) + | |
| guides(color = guide_legend( | |
| title = NULL | |
| )) + | |
| theme(legend.position = "top") + | |
| facet_wrap(~ date, nrow = 2, ncol = 7) | |
| ggsave("reiwa01_typhoon15_pref12_railroad_daily_status.png", | |
| p_pref12_suspend_railroad_daily, | |
| width = 10, height = 5) |
Author
uribo
commented
Sep 22, 2019
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment