uribo / jpmesh
1
#' @title Check include mesh areas
2
#' @description It roughly judges whether the given coordinates are within
3
#' the mesh area.
4
#' @inheritParams coords_to_mesh
5
#' @param ... other parameters
6
#' @examples
7
#' eval_jp_boundary(139.71471056, 35.70128943)
8
#' @aliases eval_jp_boundary
9
#' @export
10
eval_jp_boundary <- function(longitude = NULL, latitude = NULL, ...) {
11 6
  ifelse(
12 6
    ifelse(latitude >= 20.0 & latitude <= 46.0, TRUE, FALSE) &
13 6
      ifelse(longitude >= 120.0 & longitude <= 154.0, TRUE, FALSE),
14 6
    TRUE,
15 6
    FALSE
16
  )
17
}
18

19
mesh_to_poly <- function(lng_center, lat_center, lng_error, lat_error, ...) {
20 6
  sf::st_polygon(list(rbind(c(lng_center - lng_error,
21 6
                              lat_center - lat_error),
22 6
                            c(lng_center + lng_error,
23 6
                              lat_center - lat_error),
24 6
                            c(lng_center +  lng_error,
25 6
                              lat_center + lat_error),
26 6
                            c(lng_center - lng_error,
27 6
                              lat_center + lat_error),
28 6
                            c(lng_center - lng_error,
29 6
                              lat_center - lat_error)))) %>%
30 6
    sf::st_sfc(crs = 4326) %>%
31 6
    sf::st_as_text()
32
}
33

34
#' @title Identifer to mesh size
35
#' @description Returns a unit object of mesh size for the given number.
36
#' @inheritParams mesh_to_coords
37
#' @export
38
mesh_size <- function(meshcode) {
39 6
  mesh_length <- as.character(nchar(meshcode))
40 6
  res <- switch(mesh_length,
41 6
          "4" = mesh_units[1],
42 6
          "6" = mesh_units[2],
43 6
          "7" = mesh_units[3],
44 6
          "8" = mesh_units[4],
45 6
          "9" = mesh_units[5],
46 6
          "10" = mesh_units[6],
47 6
          "11" = mesh_units[7])
48 6
  if (rlang::is_null(res))
49 6
    res <- units::as_units(NA_integer_, "km")
50 6
  return(res)
51
}
52

53
mesh_units <- units::as_units(c(80.000, 10.000, 5.000,
54
                                1.000, 0.500, 0.250, 0.125), "km") # nolint
55

56
df_mesh_size_unit <-
57
  tibble::tibble(
58
    mesh_length = c(4L, 6L, 7L, 8L, 9L, 10L, 11L),
59
    mesh_size = mesh_units)
60

61
meshcode_set_80km <- as.character(c(3036,
62
  3622, 3623, 3624, 3631, 3641, 3653,
63
  3724, 3725, 3741,
64
  3823, 3824, 3831, 3841,
65
  3926, 3927, 3928, 3942,
66
  4027, 4028, 4040, 4042,
67
  4128, 4129, 4142,
68
  4229, 4230,
69
  4328, 4329,
70
  4429, 4440,
71
  4529, 4530, 4531, 4540,
72
  4629, 4630, 4631,
73
  4728, 4729, 4730, 4731, 4739, 4740,
74
  4828, 4829, 4830, 4831, 4839,
75
  4928, 4929, 4930, 4931, 4932, 4933, 4934, 4939,
76
  5029, 5030, 5031, 5032, 5033, 5034, 5035, 5036, 5038, 5039,
77
  5129, 5130, 5131, 5132, 5133, 5134, 5135, 5136, 5137, 5138, 5139,
78
  5229, 5231, 5232, 5233, 5234, 5235, 5236, 5237, 5238, 5239, 5240,
79
  5332, 5333, 5334, 5335, 5336, 5337, 5338, 5339, 5340,
80
  5432, 5433, 5435, 5436, 5437, 5438, 5439, 5440,
81
  5531, 5536, 5537, 5538, 5539, 5540, 5541,
82
  5636, 5637, 5638, 5639, 5640, 5641,
83
  5738, 5739, 5740, 5741,
84
  5839, 5840, 5841,
85
  5939, 5940, 5941, 5942,
86
  6039, 6040, 6041,
87
  6139, 6140, 6141,
88
  6239, 6240, 6241, 6243,
89
  6339, 6340, 6341, 6342, 6343,
90
  6439, 6440, 6441, 6442, 6443, 6444, 6445,
91
  6540, 6541, 6542, 6543, 6544, 6545, 6546,
92
  6641, 6642, 6643, 6644, 6645, 6646, 6647,
93
  6740, 6741, 6742, 6747, 6748,
94
  6840, 6841, 6842, 6847, 6848))
95

96
meshcode_set_10km <- meshcode_set_80km %>%
97
  purrr::map(fine_separate) %>%
98
  purrr::flatten_chr()
99

100
meshcode_set_5km <-
101
  meshcode_set_10km %>%
102
  purrr::map(~ paste0(.x, seq.int(1, 4))) %>%
103
  purrr::flatten_chr()
104

105
meshcode_set_1km <- meshcode_set_10km %>%
106
  purrr::map(fine_separate) %>%
107
  purrr::flatten_chr()
108

109
#' @title Export meshcode vectors ranges 80km to 1km.
110
#' @description Unique 176 meshcodes.
111
#' The output code may contain values not found in the actual mesh code.
112
#' @param mesh_size Export mesh size from 80km to 1km.
113
#' @examples
114
#' meshcode_set(mesh_size = 80)
115
#' @export
116
meshcode_set <- function(mesh_size = c(80, 10, 5, 1)) {
117 6
  get(sprintf("meshcode_set_%skm", mesh_size), envir = asNamespace("jpmesh")) # nolint
118
}
119

120
#' @title Cutoff mesh of outside the area
121
#' @inheritParams mesh_to_coords
122
cut_off <- function(meshcode) {
123 6
  mesh_80km <- substr(meshcode, 1, 4)
124 6
  res <- meshcode[mesh_80km %in% c(meshcode_set(80))] # nolint
125 6
  if (length(res) < length(meshcode)) {
126 6
    rlang::warn("Some neighborhood meshes are outside the area.")
127
  }
128 6
  res <- as.character(sort(res))
129 6
  return(res)
130
}
131

132
validate_neighbor_mesh <- function(meshcode) {
133 6
  df_bbox <-
134 6
    find_neighbor_mesh(meshcode) %>%
135 6
    export_meshes()
136 6
  df_bbox <-
137 6
    df_bbox %>%
138 6
    sf::st_sf() %>%
139 6
    sf::st_union() %>%
140 6
    sf::st_bbox()
141 6
  tibble::tibble(
142 6
    xlim = as.numeric(df_bbox[3] - df_bbox[1]),
143 6
    ylim = as.numeric(df_bbox[4] - df_bbox[2]))
144
}
145

146
bind_meshpolys <- function(meshcode) {
147 6
  meshcode %>%
148 6
    purrr::map(fine_separate) %>%
149 6
    purrr::reduce(c) %>%
150 6
    unique() %>%
151 6
    export_meshes()
152
}
153

154
code_reform <- function(jis_code) {
155 6
  . <- NULL
156 6
  checked <-
157 6
    jis_code %>%
158 6
    purrr::map(nchar) %>%
159 6
    purrr::keep(~ .x %in% c(1, 2, 5)) %>%
160 6
    length()
161 6
  if (length(jis_code) != checked)
162 6
    rlang::abort("Input jis-code must to 2 or 5 digits.")
163 6
  jis_code %>%
164 6
    purrr::map(as.numeric) %>%
165 6
    purrr::map_if(.p = nchar(.) %in% c(1, 2), ~ sprintf("%02d", .x)) %>%
166 6
    purrr::map_if(.p = nchar(.) %in% c(4, 5), ~ sprintf("%05d", .x)) %>%
167 6
    purrr::flatten_chr()
168
}

Read our documentation on viewing source code .

Loading