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 .