uribo / jpmesh
1
#' @title Convert from coordinate to mesh code
2
#' @description From coordinate to mesh codes.
3
#' @param longitude longitude that approximately to .120.0 to 154.0 (`double`)
4
#' @param latitude latitude that approximately to 20.0 to 46.0 (`double`)
5
#' @param mesh_size Gives the unit in km for target mesh type.
6
#' That is, 1 for 1km, and 0.5 for 500m. From 80km to 125m. Default is 1.
7
#' @param geometry XY sfg object
8
#' @param ... other parameters
9
#' @importFrom rlang is_true quo_squash warn
10
#' @return mesh code (default 3rd meshcode aka 1km mesh)
11
#' @references Akio Takenaka: [http://takenaka-akio.org/etc/j_map/index.html](http://takenaka-akio.org/etc/j_map/index.html) # nolint
12
#' @seealso [mesh_to_coords()] for convert from meshcode to coordinates
13
#' @examples
14
#' coords_to_mesh(141.3468, 43.06462, mesh_size = 1)
15
#' coords_to_mesh(139.6917, 35.68949, mesh_size = 0.250)
16
#' coords_to_mesh(139.71475, 35.70078)
17
#' # Using sf (point as sfg object)
18
#' library(sf)
19
#' coords_to_mesh(geometry = st_point(c(139.71475, 35.70078)))
20
#' coords_to_mesh(geometry = st_point(c(130.4412895, 30.2984335)))
21
#' @export
22
coords_to_mesh <- function(longitude, latitude, mesh_size = 1, geometry = NULL, ...) { # nolint
23 6
  to_mesh_size <- units::as_units(mesh_size, "km")
24 6
  if (rlang::is_true(identical(which(to_mesh_size %in% mesh_units), integer(0)))) # nolint
25 0
    rlang::abort(
26 0
      paste0("`mesh_size` should be one of: ",
27 0
             paste(
28 0
               units::drop_units(mesh_units)[-6],
29 0
               collapse = ", "),
30 0
             " or ",
31 0
             paste(units::drop_units(mesh_units)[6])))
32 6
  if (rlang::is_false(is.null(geometry))) {
33 6
    geometry <- sf::st_sfc(geometry)
34 6
    coords <-
35 6
      lapply(geometry, function(x) {
36 6
        if (sf::st_is(x, "POINT"))
37 6
          list(longitude = sf::st_coordinates(x)[1],
38 6
               latitude =  sf::st_coordinates(x)[2])
39
        else
40 6
          list(longitude = sf::st_coordinates(sf::st_centroid(x))[1],
41 6
               latitude =  sf::st_coordinates(sf::st_centroid(x))[2])
42
      })
43 6
    if (!rlang::is_missing(longitude) | !rlang::is_missing(latitude))
44 6
      rlang::inform("the condition assigned coord and geometry, only the geometry will be used") # nolint
45 6
    longitude <-
46 6
      coords %>%
47 6
      purrr::map("longitude")
48 6
    latitude <-
49 6
      coords %>%
50 6
      purrr::map("latitude")
51
  } else {
52 6
    longitude <- rlang::quo_squash(longitude)
53 6
    latitude <- rlang::quo_squash(latitude)
54
  }
55 6
  purrr::pmap_chr(
56 6
    list(longitude = longitude,
57 6
         latitude = latitude,
58 6
         to_mesh_size = to_mesh_size),
59 6
    ~ .coord2mesh(..1, ..2, ..3))
60
}
61

62
.coord2mesh <- function(longitude, latitude, to_mesh_size) {
63 6
  coords_evalated <-
64 6
    purrr::map2_lgl(longitude,
65 6
                    latitude,
66 6
                    ~ eval_jp_boundary(.x, .y))
67 6
  if (coords_evalated == TRUE) {
68 6
    code12 <- (latitude * 60) %/% 40
69 6
    code34 <- as.integer(longitude - 100)
70 6
    check_80km_ares <- paste0(code12, code34) %>%
71 6
      match(meshcode_set(mesh_size = 80.000)) %>% # nolint
72 6
      any()
73 6
    if (rlang::is_true(check_80km_ares)) {
74 6
      code_a <- (latitude * 60) %% 40
75 6
      code5 <- code_a %/% 5
76 6
      code_b <- code_a %% 5
77 6
      code7 <- (code_b * 60) %/% 30
78 6
      code_c <- (code_b * 60) %% 30
79 6
      code_s <- code_c %/% 15
80 6
      code_d <- code_c %% 15
81 6
      code_t <- code_d %/% 7.5
82 6
      code_e <- code_d %% 7.5
83 6
      code_u <- code_e %/% 3.75
84 6
      code_f <- (longitude - 100) - as.integer(longitude - 100)
85 6
      code6 <- (code_f * 60) %/% 7.5
86 6
      code_g <- (code_f * 60) %% 7.5
87 6
      code8 <- (code_g * 60) %/% 45
88 6
      code_h <- (code_g * 60) %% 45
89 6
      code_x <- code_h %/% 22.5
90 6
      code_i <- code_h %% 22.5
91 6
      code_y <- code_i %/% 11.25
92 6
      code_j <- code_i %% 11.25
93 6
      code_z <- code_j %/% 5.625
94 6
      code9 <- (code_s * 2) + (code_x + 1)
95 6
      code10 <- (code_t * 2) + (code_y + 1)
96 6
      code11 <- (code_u * 2) + (code_z + 1)
97 6
      meshcode <- paste0(code12,
98 6
                         code34,
99 6
                         code5,
100 6
                         code6,
101 6
                         code7,
102 6
                         code8,
103 6
                         code9,
104 6
                         code10,
105 6
                         code11)
106 6
      meshcode <-
107 6
        if (to_mesh_size == units::as_units(80.000, "km")) {
108 6
          substr(meshcode, 1, 4)
109 6
        } else if (to_mesh_size == units::as_units(10.000, "km")) {
110 6
          substr(meshcode, 1, 6)
111 6
        } else if (to_mesh_size == units::as_units(5.000, "km")) {
112 6
          paste0(substr(meshcode, 1, 6),
113 6
                 (code_b %/% (5 / 2) * 2) + (code_g %/% (7.5 / 2) + 1))
114 6
        } else if (to_mesh_size == units::as_units(1.000, "km")) {
115 6
          substr(meshcode, 1, 8)
116 6
        } else if (to_mesh_size == units::as_units(0.500, "km")) {
117 6
          substr(meshcode, 1, 9)
118 6
        } else if (to_mesh_size == units::as_units(0.250, "km")) {
119 6
          substr(meshcode, 1, 10)
120 6
        } else if (to_mesh_size == units::as_units(0.125, "km")) {
121 6
          meshcode
122
        }
123 6
      return(meshcode)
124 6
    } else if (is.na(check_80km_ares)) {
125 6
      rlang::warn("Longitude / Latitude values is out of range.")
126 6
      return(NA_character_)
127
    }
128 6
  } else if (coords_evalated == FALSE) {
129 6
    rlang::warn("Longitude / Latitude values is out of range.")
130 6
    return(NA_character_)
131
  }
132
}

Read our documentation on viewing source code .

Loading