uribo / jpmesh
1
#' Find out neighborhood meshes collection
2
#' @inheritParams mesh_to_coords
3
#' @param contains logical. contains input meshcode (default `TRUE`)
4
#' @description input should use meshcode under the 1km mesh size.
5
#' @return mesh code vectors (`character`)
6
#' @examples
7
#' neighbor_mesh(53394501)
8
#' neighbor_mesh(533945011)
9
#' neighbor_mesh(533945011, contains = FALSE)
10
#' @rdname neighbor_mesh
11
#' @export
12
neighbor_mesh <- function(meshcode, contains = TRUE) {
13 6
  if (rlang::is_false(is_meshcode(meshcode))) { # nolint
14 6
    rlang::abort("Unexpect meshcode value")
15
  }
16 6
  size <- mesh_size(meshcode) # nolint
17 6
  if (size < units::as_units(0.5, "km")) {
18 6
    rlang::inform("Too small meshsize. Enable 80km to 500m size.")
19
  }
20 6
  res <- if (size >= units::as_units(1, "km"))
21 6
    find_neighbor_mesh(meshcode, contains = contains) # nolint
22 6
  else if (size == units::as_units(0.5, "km"))
23 6
    find_neighbor_finemesh(meshcode, contains = contains) # nolint
24
  else
25 6
    NULL
26 6
  return(res)
27
}
28

29
#' @rdname neighbor_mesh
30
#' @export
31
find_neighbor_mesh <- function(meshcode = NULL, contains = TRUE) { # nolint
32 6
  meshcode <- as.numeric(meshcode)
33 6
  size <- mesh_size(meshcode) # nolint
34
  # nolint start
35 6
  if (size == units::as_units(80, "km")) {
36 6
    res <- meshcode - c(1, -1, 101, 100, 0, 99, -99, -100, -101)
37 6
  } else if (size == units::as_units(10, "km")) {
38 6
    if (is_corner(meshcode)) {
39 6
      if (grepl("(00|70|07|77|0[1-6]|[1-6]7|[1-6]0|7[1-6])$", meshcode)) {
40 6
        res <- meshcode + 
41 6
          if (grepl("00$", meshcode)) 
42 6
            c(0, 1, -83, 10, 11, -93, -10023, -9930, -9929)
43 6
          else if (grepl("07$", meshcode))
44 6
            c(-1, 0, 93, 9, 10, 103, -9931, -9930, -9837)
45 6
          else if (grepl("70$", meshcode))
46 6
            c(0, 1, 9930, 9931, -9, -10, -93, -83, -103)
47 6
          else if (grepl("77$", meshcode))
48 6
            c(9929, 9930, 10023, -1, 0, 93, -11, -10, 83)
49 6
          else if (grepl("0[1-6]$", meshcode))
50 6
            c(-1, 0, 1, 9, 10, 11, -9931, -9930, -9929)
51 6
          else if (grepl("[1-6]7$", meshcode))
52 6
            c(-1, 0, 93, 9, 10, 103, -11, -10, 83)
53 6
          else if (grepl("[1-6]0$", meshcode))
54 6
            c(0, 1, -9, -10, 11, 10, -83, -93, -103)    
55 6
          else if (grepl("7[1-6]$", meshcode))
56 6
            c(-1, 0, 1, 9929, 9930, 9931, -11, -10, -9)    
57
      }} else
58 6
        res <- meshcode + c(9, 10, 11, -1, 0, 1, -9, -10, -11)
59
    # Must be ends 1-7
60 6
    res <- unique(res[grepl("[8-9]$", res) == FALSE])  
61 6
  } else if (size == units::as_units(1, "km")) {
62 6
    if (is_corner(meshcode)) {
63 6
      if (grepl("(00|09|90|99|010[1-8]|[1-8]9|[1-8]0|9[1-8]|0[1-8])$", meshcode)) {
64 6
        res <- meshcode - if (grepl("0000$", meshcode)) 
65 6
          c(9281, -10, -11, 9291, 0, -1, 1002201, 992910, 992909)
66 6
        else if (grepl("0[1-9]00$", meshcode))
67 6
          c(81, -10, -11, 91, 0, -1, 993001, 992910, 992909)
68 6
        else if (grepl("[1-9]000$", meshcode))
69 6
          c(9281, -10, -11, 9291, 0, -1, 10201, 910, 909)
70 6
        else if (grepl("[0-9][1-9]00$", meshcode))
71 6
          c(81, -10, -11, 91, 0, -1, 1001, 910, 909)          
72 6
        else if (grepl("[1-9][0-9]09$", meshcode))
73 6
          c(-9, -10, -101, 1, 0, -91, 911, 910, 819) # 51331109 
74 6
        else if (grepl("0[0-9]09$", meshcode))
75 6
          c(-9, -10, -101, 1, 0, -91, 992911, 992910, 992819)
76 6
        else if (grepl("0009$", meshcode))
77 6
          c(-9, -10, -101, 1, 0, -91, 992911, 992910, 992819)          
78 6
        else if (grepl("[0-9][1-9]90$", meshcode))
79 6
          c(-819, -910, -911, 91, 0, -1, 101, 10, 9)
80 6
        else if (grepl("[0-9]090$", meshcode))
81 6
          c(8381, -910, -911, 9291, 0, -1, 9301, 10, 9)
82 6
        else if (grepl("99$", meshcode))
83 6
          c(-909, -910, -1001, 1, 0, -91, 11, 10, -81)
84 6
        else if (grepl("(0[1-9]0[1-8])$", meshcode))
85 6
          c(-9, -10, -11, 1, 0, -1, 992911, 992910, 992909)
86 6
        else if (grepl("([1-8]9)$", meshcode))
87 6
          c(-9, -10, -101, 1, 0, -91, 11, 10, -81)
88 6
        else if (grepl("[0-9][1-9][1-8]0$", meshcode))
89 6
          c(81, -10, -11, 91, 0, -1, 101, 10, 9)
90 6
        else if (grepl("[0-9]0[1-8]0$", meshcode))
91 6
          c(9281, -10, -11, 9291, 0, -1, 9301, 10, 9)
92 6
        else if (grepl("9[1-8]$", meshcode))
93 6
          c(-909, -910, -911, 1, 0, -1, 11, 10, 9) # 53394592
94 6
        else if (grepl("[1-9][0-9]0[1-8]$", meshcode))
95 6
          c(-9, -10, -11, 1, 0, -1, 911, 910, 909)
96 6
        else if (grepl("0[0-9]0[1-8]$", meshcode))
97 6
          c(-9, -10, -11, 1, 0, -1, 992911, 992910, 992909)
98
      }} else {
99 6
        res <- meshcode + c(9, 10, 11, -1, 0, 1, -9, -10, -11)
100
      }}
101
  # nolint end
102 6
  if (rlang::is_false(contains)) {
103 6
    res <- res[res != meshcode]
104
  }
105 6
  neighbor <- unique(cut_off(res)) # nolint
106 6
  return(neighbor)
107
}
108

109
find_neighbor_finemesh <- function(meshcode, contains = TRUE) {
110 6
  relate <- NULL
111 6
  df_poly <-
112 6
    substr(meshcode, 1, nchar(eval(meshcode)) - 1) %>%
113 6
    find_neighbor_mesh() %>% # nolint
114 6
    purrr::map(bind_meshpolys) %>%
115 6
    purrr::reduce(rbind)
116 6
  df_poly$n <- seq_len(nrow(df_poly))
117
  # nolint start
118 6
  df_poly$relate <- 
119 6
    suppressWarnings(
120 6
      suppressMessages(
121 6
        sapply(df_poly$geometry, 
122 6
               sf::st_relate, 
123 6
               y = sf::st_buffer(
124 6
                 df_poly$geometry[which(df_poly$meshcode == meshcode)], 
125 6
                 dist = 0.00005), 
126 6
               sparse = FALSE)))
127 6
  if (length(df_poly$meshcode[df_poly$relate %in% c("212101212", "2FF1FF212")]) != 9) { # nolint
128 0
      df_poly$relate <- 
129 0
        suppressWarnings(
130 0
          suppressMessages(
131 0
            sapply(df_poly$geometry, 
132 0
                   sf::st_relate, 
133 0
                   y = sf::st_buffer(
134 0
                     df_poly$geometry[which(df_poly$meshcode == meshcode)], 
135 0
                     dist = 0.0002), 
136 0
                   sparse = FALSE)))  
137
  }
138
  # nolint end
139 6
    neighbor <- subset(df_poly, relate %in% c("212101212", "2FF1FF212"))$meshcode # nolint
140 6
    if (rlang::is_false(contains))
141 6
      neighbor <- neighbor[!neighbor %in% meshcode]
142 6
    return(neighbor)
143
}

Read our documentation on viewing source code .

Loading