/
metadata_utils.R
161 lines (137 loc) · 5.56 KB
/
metadata_utils.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
#' Update NatureCounts metadata files
#'
#' Updates the local copies of meta data used by the package.
#'
#' @param force Logical. Force update even if the remote version matches local?
#' @param utm Logical. Update [meta_utm_squares()] as well? **WARNING**: This is a
#' large and time consuming download!
#' @param verbose Logical. Show progress messages?
#'
#' @examples
#' \donttest{nc_metadata()}
#'
#' @export
nc_metadata <- function(force = FALSE, utm = FALSE, verbose = TRUE) {
nc_metadata_internal(system.file("extdata", package = "naturecounts"),
force = force, utm = utm, verbose = verbose)
}
#' Fetch API metadata version
#'
#' Returns the current version of the metadata on the API
#'
#' @keywords internal
metadata_v_remote <- function() {
srv_query(api$version) %>%
unlist()
}
metadata_save <- function(data, path, name = deparse(substitute(data)),
compress = TRUE) {
save(data, file = file.path(path, paste0(name, ".rds")), compress = compress)
}
metadata_read <- function(name) {
data <- NULL # load(f) reads data into envir as 'data', use this to avoid NOTE
f <- system.file("extdata", paste0(name, ".rds"), package = "naturecounts")
if(!file.exists(f)) stop("Could not find metadata file '", name, "'",
call. = FALSE)
load(f)
data
}
nc_metadata_internal <- function(path = "./inst/extdata", force = TRUE,
utm = FALSE, verbose = TRUE) {
# Check if update necessary
# (either no version file, force = TRUE, or out of date)
if(all(class(try(metadata_v_local(), silent = TRUE)) != "try-error") &&
!force &&
metadata_v_local() == metadata_v_remote()) {
message("Local metadata already up-to-date with server")
} else {
# Species authorities
message("Updating species authority...")
species_authority <- srv_query(api$species_authority) %>%
parse_results(results = FALSE) %>%
dplyr::select("authority", dplyr::everything())
metadata_save(species_authority, path)
# Get species codes
message("Updating species codes...")
species_codes <- srv_query(api$species_codes) %>%
parse_results(results = FALSE) %>%
dplyr::mutate(species_id2 = dplyr::if_else(is.na(.data$species_id2),
.data$species_id,
.data$species_id2))
metadata_save(species_codes, path = path)
message("Updating species taxonomy...")
species_taxonomy <- srv_query(api$species_taxonomy) %>%
parse_results(results = FALSE)
metadata_save(species_taxonomy, path)
# Get country codes
message("Updating country codes...")
country_codes <- srv_query(api$country_codes) %>%
parse_results(results = FALSE) %>%
dplyr::arrange(.data$country_code)
metadata_save(country_codes, path)
# Get province/state codes
message("Updating state/province codes...")
statprov_codes <- srv_query(api$statprov_codes) %>%
parse_results(results = FALSE) %>%
dplyr::select("country_code", "statprov_code", dplyr::everything()) %>%
dplyr::arrange(.data$country_code, .data$statprov_code)
metadata_save(statprov_codes, path)
# Get subnational codes
message("Updating subnational codes...")
subnational2_codes <- srv_query(api$subnational2_codes) %>%
parse_results(results = FALSE) %>%
dplyr::select("country_code", "statprov_code",
subnational2_code = "subnat2_code",
subnational2_name = "subnat2_name", dplyr::everything()) %>%
dplyr::arrange(.data$country_code, .data$statprov_code,
.data$subnational2_code)
metadata_save(subnational2_codes, path)
# Get IBA codes
message("Updating IBA codes...")
iba_codes <- srv_query(api$iba_codes) %>%
parse_results(results = FALSE) %>%
dplyr::rename_all(tolower) %>%
dplyr::select("iba_site", dplyr::everything())
metadata_save(iba_codes, path)
# Get BCA codes
message("Updating BCR codes...")
bcr_codes <- srv_query(api$bcr_codes) %>%
parse_results(results = FALSE) %>%
dplyr::rename_all(tolower)
metadata_save(bcr_codes, path)
if(utm) {
if(!requireNamespace("sf", quietly = TRUE)) {
stop("The sf package is required to use and process utm_squares. ",
"It can be installed with \"install.packages('sf')\"",
call. = FALSE)
}
# Get UTM square codes
message("Updating UTM squares codes...")
utm_squares <- statprov_codes()$statprov_code %>%
lapply(., function(x) {
message(" Getting ", x)
srv_query(api$utm_squares, query = list('statprov' = x))
}) %>%
lapply(parse_results, results = FALSE) %>%
dplyr::bind_rows() %>%
dplyr::rename("geometry" = "square_wkt") %>%
sf::st_as_sf(., wkt = "geometry", crs = 3347)
metadata_save(utm_squares, path, compress = "xz")
}
# Get BMDE fields
message("Updating BMDE Field list...")
bmde_fields <- meta_bmde_versions() %>%
dplyr::pull(.data$version) %>%
lapply(X = ., FUN = function(x) {
srv_query(api$bmde_fields, query = list(version = x)) %>%
parse_results()
}) %>%
do.call('rbind', .) %>%
dplyr::select(-"field_name")
metadata_save(bmde_fields, path)
# Update metadata version
message("Metadata version updated to ", metadata_v_remote())
metadata_save(metadata_v_remote(), name = "metadata_v_local", path = path)
}
}
metadata_v_local <- function() {metadata_read("metadata_v_local")}