R/util.R

In uribo/jpndistrict: Create Japanese Administration Area and Office Maps

#' Collect administration office point datasets.
#'
#' @param path path to P34 shapefile (if already exist)
collect_ksj_p34 <- function(path = NULL) {
  jis_code <- NULL
  code <- gsub(".+P34-14_|_GML|/", "", path)
  d <- sf::st_read(
    paste0(path, "/", list.files(path, pattern = paste0(code, ".shp$"))),
    stringsAsFactors = FALSE,
    as_tibble = TRUE,
    crs = 4612,
    options = "ENCODING=cp932") %>%
    purrr::set_names(
      c("jis_code", "type", "name", "address", "geometry")) %>%
    dplyr::mutate(jis_code = as.factor(jis_code))
  return(d)
}

#' Intermediate function
#'
#' @param pref sf object (prefecture)
raw_bind_cityareas <- function(pref) {
  tmp_union <-
    suppressMessages(suppressWarnings(sf::st_buffer(pref, 0) %>%
                                        sf::st_union() %>%
                                        sf::st_sf()))
  df_res <- suppressMessages(
    suppressWarnings(
      tmp_union %>%
        dplyr::mutate(
          pref_code  = as.numeric(substr(pref$city_code[1], 1, 2)),
          prefecture = pref$prefecture[1]
        ) %>%
        sf::st_sf() %>%
        sf::st_buffer(dist = 0.001)
    ) %>%
      dplyr::select(
        pref_code = 1,
        prefecture = 2,
        geometry = 3
      ))
  return(df_res)
}

#' Intermediate function
#'
#' @description Download N03 raw data files or loading if file exists.
#' @param code prefecture code (JIS X 0402)
#' @param path path to N03 shapefile (if already exist)
read_ksj_cityarea <- function(code = NULL, path = NULL) {
  # nocov start
  if (missing(path)) {
    path <- path_ksj_cityarea(code)
  }
  res <-
    collect_cityarea(path)
  return(res)
  # nocov end
}

#' Download KSJ N03 zip files
#'
#' @param code prefecture code (JIS X 0402)
#' @param path path to N03 shapefile (if already exist)
path_ksj_cityarea <- function(code = NULL, path = NULL) {
  # nocov start
  if (missing(path)) {
    pref_identifer <- sprintf("%02d", code)
    dest_path <-
      paste(tempdir(),
            paste0("N03-150101_", pref_identifer, "_GML.zip"),
            sep = "/")
    extract_path <- paste(tempdir(), pref_identifer,  sep = "/")
    # ksj zip file none
    if (is.null(path) & file.exists(dest_path) == FALSE) {
      curl::curl_download(
        paste0(
          "https://nlftp.mlit.go.jp/ksj/gml/data/N03/N03-2015/N03-150101_",
          pref_identifer,
          "_GML.zip"
        ),
        destfile = dest_path,
        handle = curl::new_handle(ssl_verifypeer = FALSE))

      utils::unzip(zipfile = dest_path,
                   exdir   = extract_path)
      path <- paste(extract_path, gsub(
        ".zip$",
        "",
        paste0("N03-20150101_", pref_identifer, "_GML.zip")
      ), sep = "/")

      # ksj zip file exist
    } else if (file.exists(dest_path) == TRUE) {
      path <- extract_path
    }
  }
  return(path)
  # nocov end
}

#' Get prefecture code (JIS X 0402)
#'
#' @description Get prefecture code from prefecture of name or number.
#' @param code numeric
#' @param admin_name prefecture code for Japanese (character)
collect_prefcode <- function(code = NULL, admin_name = NULL) {
  jis_code <- prefecture <- NULL
  if (missing(admin_name)) {
    pref_code <-
      dplyr::filter(jpnprefs, jis_code == code_validate(code)$code) %>%
      dplyr::pull(jis_code)
  } else if (missing(code)) {
    pref_code <-
      dplyr::filter(jpnprefs, prefecture == admin_name) %>%
      dplyr::pull(jis_code)
  }
  return(pref_code)
}


#' Collect administration area
#'
#' @param path path to N03 shapefile (if already exist)
collect_cityarea <- function(path = NULL) {
  # nocov start
  . <- N03_001 <- N03_002 <- N03_003 <- N03_004 <- N03_007 <- tmp_var <- NULL # nolint
  pref_name <-
    city_name_ <- city_name <- city_name_full <- city_code <- geometry <- NULL # nolint
  res <-
    suppressWarnings(
      sf::st_read(
        list.files(
          path,
          pattern = "shp$",
          full.names = TRUE,
          recursive = TRUE),
        crs = 4612,
        as_tibble = TRUE,
        stringsAsFactors = FALSE) %>%
        sf::st_simplify(preserveTopology = FALSE, dTolerance = 0.001) %>%
        dplyr::filter(sf::st_is_empty(.) == FALSE) %>%
        dplyr::mutate(
          tmp_var = dplyr::if_else(is.na(N03_003), "", N03_003),
          city_name_full = gsub("[[:space:]]", "", gsub("NA", "", paste(tmp_var, N03_004))) # nolint
        ) %>%
        dplyr::rename(
          pref_name  = N03_001,
          city_name_ = N03_003,
          city_name  = N03_004,
          city_code  = N03_007
        ) %>%
        dplyr::mutate_at(.vars = dplyr::vars(dplyr::contains("name")),
                  iconv,
                  to = "UTF8") %>%
        dplyr::select(pref_name,
                      city_name_, city_name, city_name_full, city_code,
                      geometry)
    )
  return(res)
  # nocov end
}


#' Intermediate function
#'
#' @param pref_code prefecture code (JIS X 0402)
#' @param path path to P34 shapefile (if already exist)
read_ksj_p34 <- function(pref_code = NULL, path = NULL) {
  # nolint start
  if (missing(path)) {
    df_df_url <-
      readRDS(system.file("extdata/ksj_P34_index.rds",
                          package = "jpndistrict"))
    if (is.null(path) &
        file.exists(paste(tempdir(),
                          df_df_url$dest_file[pref_code], sep = "/")) == FALSE) {
      curl::curl_download(
        df_df_url$zipFileUrl[pref_code],
        destfile = paste(tempdir(), df_df_url$dest_file[pref_code], sep = "/"),
        handle = curl::new_handle(ssl_verifypeer = FALSE))
      utils::unzip(
        zipfile = paste(tempdir(), df_df_url$dest_file[pref_code], sep = "/"),
        exdir   = paste(tempdir(), gsub(".zip", "",
                                        df_df_url$dest_file[pref_code]),
                        sep = "/"))
      path <- paste(tempdir(), gsub(".zip", "",
                                    df_df_url$dest_file[pref_code]),
                    sep = "/")
    } else if (file.exists(paste(tempdir(),
                                 df_df_url$dest_file[pref_code],
                                 sep = "/")) == TRUE) {
      path <- paste(tempdir(), gsub(".zip", "",
                                    df_df_url$dest_file[pref_code]),
                    sep = "/") # nocov
    }
    res <- collect_ksj_p34(path = path)
  } else {
    res <- collect_ksj_p34(path = path) # nocov
  }
  return(res)
  # nolint end
}

#' Internal function
#'
#' @param longitude longitude
#' @param latitude latitude
#' @param ... export parameter to other functions
#' @name which_pol_min
which_pol_min <- function(longitude, latitude, ...) {
  pref_code <- NULL
  pref_code_chr <-
    find_prefs(longitude = longitude, latitude = latitude) %>%
    dplyr::pull(pref_code)
  sp_polygon <- NULL
  which_row  <- integer(0)
  if (identical(pref_code_chr, character(0)) == TRUE) {
    1
  } else {
    sp_polygon <-
      pref_code_chr %>%
      purrr::map(jpn_pref) %>%
      purrr::reduce(rbind)
    x <-
      sf::st_point(c(longitude, latitude), dim = "XY")
    which_row <-
      suppressMessages(grep(
        TRUE,
        sf::st_intersects(sp_polygon,
                          x,
                          sparse = FALSE)
      ))
    if (length(which_row) > 1) {
      which_row <-
        which.min(sf::st_distance(sf::st_sfc(x, crs = 4326),
                                  sp_polygon,
                                  by_element = TRUE))
      sp_polygon <-
        jpn_pref(pref_code = which_row)
    }
  }
  list(spdf = sp_polygon, which = which_row)
}

crs_4326 <-
  structure(list(epsg = 4326L,
                 proj4string = "+proj=longlat +datum=WGS84 +no_defs"),
            class = "crs")

tweak_sf_output <- function(target) {
  target <-
    sf::st_sf(target)
  if (identical(sf::st_crs(target)$input, "EPSG:4326") != TRUE)
      target <-
      sf::st_transform(target, crs = 4326)
  target %>%
    tibble::as_tibble() %>%
    sf::st_sf() %>%
    sf::st_make_valid()
}

sfg_point_as_coords <- function(geometry) {
  if (sf::st_is(geometry, "POINT")) {
      list(longitude = sf::st_coordinates(geometry)[1],
           latitude =  sf::st_coordinates(geometry)[2])
    }
}

collapse_int2utf8 <- function(var) {
  paste(intToUtf8(var, multiple = TRUE), collapse = "")
}

export_pref_80km_mesh <- function(code, ...) {
  meshcode <- NULL
  sf_pref <-
    jpn_pref(pref_code = code) %>%
    sf::st_make_valid()
  res <- suppressMessages(jpmesh::sf_jpmesh %>%
                            sf::st_join(sf_pref,
                                        sf::st_overlaps,
                                        left = FALSE) %>%
                            dplyr::pull(meshcode) %>%
                            unique())
  return(res)
}

mesh_intersect <- function(data, x) {
  id <- res_contains <- NULL
  df_tmp <- tibble::tibble(
    res_contains = suppressMessages(
      rowSums(sf::st_intersects(data,
                                x %>%
                                  dplyr::group_by() %>%
                                  dplyr::summarise(do_union = FALSE),
                                sparse = FALSE))))
  df_tmp$id <-
    seq_len(nrow(df_tmp))
  data[df_tmp %>%
         dplyr::filter(res_contains != 0) %>%
         dplyr::pull(id) %>%
         unique(), ]
}

mesh_intersect_filter <- function(data) {
  meshcode <- NULL # nolint
  data %>%
    dplyr::pull(meshcode) %>%
    jpmesh::fine_separate() %>%
    unique() %>%
    tibble::enframe(name = NULL, value = "meshcode") %>%
    jpmesh::meshcode_sf(mesh_var = "meshcode") %>%
    dplyr::select(meshcode, tidyselect::everything())
}

decode.sfencoded <- function(x, crs = 4326) { # nolint
  geometry <- NULL
  googlePolylines::polyline_wkt(x) %>%
    dplyr::mutate(geometry = sf::st_as_sfc(geometry)) %>%
    sf::st_sf(crs = crs)
}

decode.sf <- function(x) { # nolint
  crs <- sf::st_crs(x)
  geometry <- NULL
  googlePolylines::encode(x) %>%
    googlePolylines::polyline_wkt() %>%
    dplyr::mutate(geometry = sf::st_as_sfc(geometry)) %>%
    sf::st_sf(crs = crs)
}