hypertidy / ncmeta
Showing 3 of 474 files from the diff.
Other files ignored by Codecov
man/nc_meta.Rd has changed.
man/nc_axes.Rd has changed.
man/nc_grids.Rd has changed.
man/nc_var.Rd has changed.
man/nc_atts.Rd has changed.
docs/index.html has changed.
docs/404.html has changed.
docs/authors.html has changed.
man/nc_vars.Rd has changed.
man/nc_inq.Rd has changed.
man/nc_dim.Rd has changed.
revdep/README.md has changed.
man/nc_sources.Rd has changed.
ncmeta.Rproj has changed.
man/nc_axis.Rd has changed.
NAMESPACE has changed.
docs/pkgdown.yml has changed.
man/nc_dims.Rd has changed.
README.md has changed.
NEWS.md has changed.
DESCRIPTION has changed.
man/nc_att.Rd has changed.
cran-comments.md has changed.

@@ -1,384 +1,384 @@
Loading
1 -
#' Get Grid Mapping
2 -
#'
3 -
#' @description Get the grid mapping from a NetCDF file
4 -
#'
5 -
#' @return tibble containing attributes that make up the file's grid_mapping.
6 -
#' A data_variable column is included to indicate which data variable the grid
7 -
#' mapping belongs to.
8 -
#' @export
9 -
#' 
10 -
#' @name nc_grid_mapping_atts
11 -
#' @examples
12 -
#' 
13 -
#' nc_grid_mapping_atts(system.file("extdata/daymet_sample.nc", package = "ncmeta"))
14 -
15 -
nc_grid_mapping_atts <- function(x, data_variable = NULL) UseMethod("nc_grid_mapping_atts")
16 -
17 -
#' @param x open NetCDF object, character file path or url to be 
18 -
#' opened with RNetCDF::open.nc, or data.frame as returned from ncmeta::nc_atts
19 -
#' 
20 -
#' @param data_variable character variable of interest
21 -
#' 
22 -
#' @name nc_grid_mapping_atts
23 -
#' @export
24 -
nc_grid_mapping_atts.character <- function(x, data_variable = NULL) {
25 -
  nc <- RNetCDF::open.nc(x)
26 -
  on.exit(RNetCDF::close.nc(nc), add  = TRUE) 
27 -
  nc_grid_mapping_atts(nc, data_variable)
28 -
}
29 -
30 -
#' @name nc_grid_mapping_atts
31 -
#' @export
32 -
nc_grid_mapping_atts.NetCDF <- function(x, data_variable = NULL) {
33 -
  nc_grid_mapping_atts(nc_atts(x), data_variable)
34 -
}
35 -
36 -
#' @name nc_grid_mapping_atts
37 -
#' @export
38 -
nc_grid_mapping_atts.data.frame <- function(x, data_variable = NULL) {
39 -
  
40 -
  gm_att <- "grid_mapping"
41 -
  
42 -
  if(is.null(data_variable)) {
43 -
    data_variable <- find_var_by_att(x, gm_att)
44 -
  } else if(!gm_att %in% dplyr::filter(x, variable == data_variable)$name) {
45 -
    warning(paste("no grid_mapping attribute found for this variable"))
46 -
    return(tibble::tibble())
47 -
  }
48 -
  
49 -
  if (length(data_variable) == 0 ) {
50 -
    warning(paste("No variables with a grid mapping found.\n",
51 -
                  "Defaulting to WGS84 Lon/Lat"))
52 -
    
53 -
    return(tibble::as_tibble(list(name = c("grid_mapping_name", 
54 -
                                           "semi_major_axis", 
55 -
                                           "inverse_flattening", 
56 -
                                           "longitude_of_prime_meridian"),
57 -
                                  value = list("latitude_longitude", 
58 -
                                               6378137, 
59 -
                                               298.257223563, 
60 -
                                               0))))
61 -
  }
62 -
  
63 -
  grid_mapping_vars <- dplyr::filter(x, variable %in% data_variable & 
64 -
                                      name %in% gm_att) %>%
65 -
    dplyr::mutate(value = as.character(value))
66 -
  
67 -
  grid_mapping_atts <- dplyr::filter(x, variable %in% grid_mapping_vars$value)
68 -
  
69 -
  grid_mapping_atts <- 
70 -
    dplyr::left_join(grid_mapping_atts, 
71 -
                     select(grid_mapping_vars, data_variable = variable, value = value),
72 -
                     by = c("variable" = "value"))
73 -
  
74 -
  return(grid_mapping_atts)
75 -
}
76 -
77 -
#' Get NetCDF-CF grid mapping from projection
78 -
#'
79 -
#' Takes a proj4 string and returns a NetCDF-CF projection as
80 -
#' a named list of attributes.
81 -
#'
82 -
#' @param prj character PROJ string as used in raster, sf, sp, proj4, and rgdal packages.
83 -
#'
84 -
#' @return A named list containing attributes required for that grid_mapping.
85 -
#'
86 -
#' 
87 -
#' @references 
88 -
#' \enumerate{
89 -
#'   \item \url{https://en.wikibooks.org/wiki/PROJ.4}
90 -
#'   \item \url{https://trac.osgeo.org/gdal/wiki/NetCDF_ProjectionTestingStatus}
91 -
#'   \item \url{http://cfconventions.org/cf-conventions/cf-conventions.html#appendix-grid-mappings}
92 -
#' }
93 -
#'
94 -
#' @export
95 -
#' 
96 -
#' @examples
97 -
#' prj <- "+proj=longlat +datum=NAD27 +no_defs"
98 -
#' nc_prj_to_gridmapping(prj)
99 -
#' p1 <- "+proj=aea +lat_1=29.5 +lat_2=45.5 +lat_0=23 +lon_0=-96"
100 -
#' p2 <- "+x_0=0 +y_0=0 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
101 -
#' prj2 <- sprintf("%s %s", p1, p2) 
102 -
#' nc_prj_to_gridmapping(prj2)
103 -
#' 
104 -
#' nc_prj_to_gridmapping("+proj=longlat +a=6378137 +f=0.00335281066474748 +pm=0 +no_defs")
105 -
#' 
106 -
nc_prj_to_gridmapping <- function(prj) {
107 -
  
108 -
  al <- prepCRS(prj)
109 -
  
110 -
  if(is.null(al)) {
111 -
    return(tibble::as_tibble(list(name = character(0), value = list()))) 
112 -
  } else {
113 -
    
114 -
    gm <- GGFP(al)
115 -
    
116 -
    return(tibble::as_tibble(list(name = names(gm), value = unname(gm))))
117 -
  }
118 -
}
119 -
120 -
GGFP <- function(al) UseMethod("GGFP")
121 -
122 -
GGFP.latitude_longitude <- function(al) {
123 -
  gm <- c(list(grid_mapping_name = "latitude_longitude"),
124 -
          getGeoDatum_gm(al))
125 -
  gm
126 -
}
127 -
128 -
GGFP.albers_conical_equal_area <- function(al) {
129 -
  gm <- c(list(grid_mapping_name = "albers_conical_equal_area"),
130 -
       lonCentMer_gm(al),
131 -
       latProjOrig_gm(al),
132 -
       falseEastNorth_gm(al),
133 -
       standPar_gm(al),
134 -
       getGeoDatum_gm(al))
135 -
  gm
136 -
}
137 -
138 -
GGFP.azimuthal_equidistant <- function(al) {
139 -
  gm <- c(list(grid_mapping_name = "azimuthal_equidistant"),
140 -
          lonProjOrig_gm(al),
141 -
          latProjOrig_gm(al),
142 -
          falseEastNorth_gm(al),
143 -
          getGeoDatum_gm(al))
144 -
  gm
145 -
}
146 -
147 -
GGFP.lambert_azimuthal_equal_area <- function(al) {
148 -
  gm <- c(list(grid_mapping_name = "lambert_azimuthal_equal_area"),
149 -
          latProjOrig_gm(al),
150 -
          lonProjOrig_gm(al),
151 -
          falseEastNorth_gm(al),
152 -
          getGeoDatum_gm(al))
153 -
  gm
154 -
}
155 -
156 -
GGFP.lambert_conformal_conic <- function(al) {
157 -
  gm <- c(list(grid_mapping_name = "lambert_conformal_conic"),
158 -
                    standPar_gm(al),
159 -
                    falseEastNorth_gm(al),
160 -
                    latProjOrig_gm(al),
161 -
                    lonCentMer_gm(al),
162 -
                    getGeoDatum_gm(al))
163 -
  gm
164 -
}
165 -
166 -
GGFP.lambert_cylindrical_equal_area <- function(al) {
167 -
  gm <- c(list(grid_mapping_name = "lambert_cylindrical_equal_area"),
168 -
                    lonCentMer_gm(al),
169 -
                    oneStandPar_gm(al),
170 -
                    falseEastNorth_gm(al),
171 -
                    getGeoDatum_gm(al))
172 -
  gm
173 -
}
174 -
175 -
GGFP.mercator <- function(al) {
176 -
  if(!is.null(al$k)) {
177 -
    gm <- c(list(grid_mapping_name = "mercator"),
178 -
                      lonProjOrig_gm(al),
179 -
                      scaleFactor_gm(al),
180 -
                      falseEastNorth_gm(al),
181 -
                      getGeoDatum_gm(al))
182 -
  } else {
183 -
    gm <- c(list(grid_mapping_name = "mercator"),
184 -
                      lonProjOrig_gm(al),
185 -
                      oneStandPar_gm(al),
186 -
                      falseEastNorth_gm(al),
187 -
                      getGeoDatum_gm(al))
188 -
  }
189 -
  gm
190 -
}
191 -
192 -
GGFP.oblique_mercator <- function(al) {
193 -
  #!!!! Check this one out. the oMerc function is a hack !!!!
194 -
  gm <- c(list(grid_mapping_name = "oblique_mercator"),
195 -
                    latProjOrig_gm(al),
196 -
                    lonProjCent_gm(al),
197 -
                    scaleFactor_gm(al),
198 -
                    oMerc_gm(al),
199 -
                    falseEastNorth_gm(al),
200 -
                    getGeoDatum_gm(al))
201 -
  gm
202 -
}
203 -
204 -
GGFP.orthographic <- function(al) {
205 -
  gm <- c(list(grid_mapping_name = "orthographic"),
206 -
                    latProjOrig_gm(al),
207 -
                    lonProjOrig_gm(al),
208 -
                    falseEastNorth_gm(al),
209 -
                    getGeoDatum_gm(al))
210 -
  gm
211 -
}
212 -
213 -
# GGFP.polar_stereographic <- function(al) {
214 -
#   if(!is.null(al$k)) {
215 -
#     gm <- c(list(grid_mapping_name = "polar_stereographic"),
216 -
#                       latProjOrig_gm(al),
217 -
#                       stVertLon_gm(al),
218 -
#                       scaleFactor_gm(al),
219 -
#                       falseEastNorth_gm(al),
220 -
#                       getGeoDatum_gm(al))
221 -
#   } else {
222 -
#     gm <- c(list(grid_mapping_name = "polar_stereographic"),
223 -
#                       latProjOrig_gm(al),
224 -
#                       stVertLon_gm(al),
225 -
#                       oneStandPar_gm(al),
226 -
#                       falseEastNorth_gm(al),
227 -
#                       getGeoDatum_gm(al))
228 -
#   }
229 -
#  gm
230 -
# }
231 -
232 -
# GGFP.sinusoidal <- function(al) {
233 -
#   gm <- c(list(grid_mapping_name = "sinusoidal"),
234 -
#                     lonProjOrig_gm(al),
235 -
#                     falseEastNorth_gm(al),
236 -
#                     getGeoDatum_gm(al))
237 -
# gm
238 -
# }
239 -
240 -
GGFP.stereographic <- function(al) {
241 -
  gm <- c(list(grid_mapping_name = "stereographic"),
242 -
                    latProjOrig_gm(al),
243 -
                    lonProjOrig_gm(al),
244 -
                    scaleFactor_gm(al),
245 -
                    falseEastNorth_gm(al),
246 -
                    getGeoDatum_gm(al))
247 -
  gm
248 -
}
249 -
250 -
GGFP.transverse_mercator <- function(al) {
251 -
  gm <- c(list(grid_mapping_name = "transverse_mercator"),
252 -
                    latProjOrig_gm(al),
253 -
                    lonProjOrig_gm(al),
254 -
                    scaleFactor_gm(al),
255 -
                    falseEastNorth_gm(al),
256 -
                    getGeoDatum_gm(al))
257 -
  gm
258 -
}
259 -
260 -
lonCentMer_gm <- function(al) {
261 -
  list(longitude_of_central_meridian = as.numeric(al$lon_0))
262 -
}
263 -
264 -
latProjOrig_gm <- function(al) {
265 -
  list(latitude_of_projection_origin = as.numeric(al$lat_0))
266 -
}
267 -
268 -
lonProjOrig_gm <- function(al) {
269 -
  list(longitude_of_projection_origin = as.numeric(al$lon_0))
270 -
}
271 -
272 -
falseEastNorth_gm <- function(al) {
273 -
  list(false_easting = as.numeric(al$x_0),
274 -
  false_northing = as.numeric(al$y_0))
275 -
}
276 -
277 -
standPar_gm <- function(al) {
278 -
  if(al$lat_1 != al$lat_2) {
279 -
    list(standard_parallel = c(as.numeric(al$lat_1), as.numeric(al$lat_2)))
280 -
  } else if(al$lat_1 == al$lat_2) {
281 -
    list(standard_parallel = as.numeric(al$lat_1))
282 -
  }
283 -
}
284 -
285 -
oneStandPar_gm <- function(al) {
286 -
  list(standard_parallel = c(as.numeric(al$lat_ts)))
287 -
}
288 -
289 -
getGeoDatum_gm <- function(al) {
290 -
  if(!is.null(al$datum) && al$datum == "NAD83") {
291 -
    list(semi_major_axis = 6378137,
292 -
         inverse_flattening = 298.257222101,
293 -
         longitude_of_prime_meridian = 0)
294 -
  } else if(!is.null(al$datum) && al$datum == "WGS84") {
295 -
    list(semi_major_axis = 6378137,
296 -
         inverse_flattening = 298.257223563,
297 -
         longitude_of_prime_meridian = 0)
298 -
  } else if(!is.null(al$datum) && al$datum == "NAD27") {
299 -
    list(semi_major_axis = 6378206.4,
300 -
         inverse_flattening = 294.978698214,
301 -
         longitude_of_prime_meridian = 0)
302 -
  } else if(!is.null(al$ellps) && 
303 -
  					!is.null(al$towgs84) && 
304 -
  					al$towgs84 == "0,0,0,0,0,0,0") {
305 -
  	list(semi_major_axis = 6378137,
306 -
  			 inverse_flattening = 298.257223563,
307 -
  			 longitude_of_prime_meridian = 0)
308 -
  } else if(!is.null(al$a) && !is.null(al$f) && !is.null(al$pm)) {
309 -
    list(semi_major_axis = as.numeric(al$a),
310 -
        inverse_flattening = (1/as.numeric(al$f)),
311 -
        longitude_of_prime_meridian = as.numeric(al$pm))
312 -
  } else if(!is.null(al$a) && !is.null(al$b) && !is.null(al$pm)) {
313 -
  	list(semi_major_axis = as.numeric(al$a),
314 -
  			 semi_minor_axis = as.numeric(al$b),
315 -
  			 longitude_of_prime_meridian = as.numeric(al$pm))
316 -
  } else {
317 -
  	warning("no datum information found assuming WGS84")
318 -
  	list(semi_major_axis = 6378137,
319 -
  			 inverse_flattening = 298.257223563,
320 -
  			 longitude_of_prime_meridian = 0)
321 -
  }
322 -
}
323 -
324 -
scaleFactor_gm <- function(al) {
325 -
  list(scale_factor_at_projection_origin = as.numeric(al$k))
326 -
}
327 -
328 -
oMerc_gm <- function(al) {
329 -
  list(azimuth_of_central_line = as.numeric(al$alpha))
330 -
}
331 -
332 -
lonProjCent_gm <- function(al) {
333 -
  list(longitude_of_projection_origin = as.numeric(al$lonc))
334 -
}
335 -
336 -
check_args <- function (x) 
337 -
{
338 -
  ## FIXME: checks as in reproj stop("cannot convert from digits, did you enter an EPSG code?")
339 -
  if (is.numeric(x) || (nchar(x) %in% c(4, 5) && grepl("^[0-9]{1,5}$", 
340 -
                                                       x))) {
341 -
    return(FALSE)
342 -
  }
343 -
  if (!substr(x, 1, 1) == "+") 
344 -
    return(FALSE)
345 -
  TRUE
346 -
}
347 -
348 -
prepCRS <- function(prj) {
349 -
  if(class(prj) == "CRS") prj <- prj@projargs
350 -
351 -
  if(!check_args(prj)[1][[1]]) {
352 -
 
353 -
    warning("not a valid crs, returning an empty tibble")
354 -
    return(NULL)
355 -
  }
356 -
357 -
  args <- unique(unlist(strsplit(prj, " ")))
358 -
359 -
  argList <- list()
360 -
361 -
  for(arg in args) {
362 -
    a <- unlist(strsplit(sub("\\+", "", arg), "="))
363 -
    argList[a[1]] <- a[2]
364 -
  }
365 -
366 -
  cf_proj_lookup <- list(aea = "albers_conical_equal_area",
367 -
                         aeqd = "azimuthal_equidistant",
368 -
                         laea = "lambert_azimuthal_equal_area",
369 -
                         lcc = "lambert_conformal_conic",
370 -
                         cea = "lambert_cylindrical_equal_area",
371 -
                         longlat = "latitude_longitude",
372 -
                         merc = "mercator",
373 -
                         omerc = "oblique_mercator",
374 -
                         ortho = "orthographic",
375 -
                         stere = "stereographic",
376 -
                         tmerc = "transverse_mercator")
377 -
378 -
  class(argList) <- cf_proj_lookup[unlist(argList["proj"])][[1]]
379 -
380 -
  if(!class(argList) %in% cf_proj_lookup) {
381 -
    warning("no available mapping to netcdf projection, returning empty crs list")
382 -
    return(NULL) } else {
383 -
    return(argList) }
384 -
}
1 +
#' Get Grid Mapping
2 +
#'
3 +
#' @description Get the grid mapping from a NetCDF file
4 +
#'
5 +
#' @return tibble containing attributes that make up the file's grid_mapping.
6 +
#' A data_variable column is included to indicate which data variable the grid
7 +
#' mapping belongs to.
8 +
#' @export
9 +
#' 
10 +
#' @name nc_grid_mapping_atts
11 +
#' @examples
12 +
#' 
13 +
#' nc_grid_mapping_atts(system.file("extdata/daymet_sample.nc", package = "ncmeta"))
14 +
15 +
nc_grid_mapping_atts <- function(x, data_variable = NULL) UseMethod("nc_grid_mapping_atts")
16 +
17 +
#' @param x open NetCDF object, character file path or url to be 
18 +
#' opened with RNetCDF::open.nc, or data.frame as returned from ncmeta::nc_atts
19 +
#' 
20 +
#' @param data_variable character variable of interest
21 +
#' 
22 +
#' @name nc_grid_mapping_atts
23 +
#' @export
24 +
nc_grid_mapping_atts.character <- function(x, data_variable = NULL) {
25 +
  nc <- RNetCDF::open.nc(x)
26 +
  on.exit(RNetCDF::close.nc(nc), add  = TRUE) 
27 +
  nc_grid_mapping_atts(nc, data_variable)
28 +
}
29 +
30 +
#' @name nc_grid_mapping_atts
31 +
#' @export
32 +
nc_grid_mapping_atts.NetCDF <- function(x, data_variable = NULL) {
33 +
  nc_grid_mapping_atts(nc_atts(x), data_variable)
34 +
}
35 +
36 +
#' @name nc_grid_mapping_atts
37 +
#' @export
38 +
nc_grid_mapping_atts.data.frame <- function(x, data_variable = NULL) {
39 +
  
40 +
  gm_att <- "grid_mapping"
41 +
  
42 +
  if(is.null(data_variable)) {
43 +
    data_variable <- find_var_by_att(x, gm_att)
44 +
  } else if(!gm_att %in% dplyr::filter(x, variable == data_variable)$name) {
45 +
    warning(paste("no grid_mapping attribute found for this variable"))
46 +
    return(tibble::tibble())
47 +
  }
48 +
  
49 +
  if (length(data_variable) == 0 ) {
50 +
    warning(paste("No variables with a grid mapping found.\n",
51 +
                  "Defaulting to WGS84 Lon/Lat"))
52 +
    
53 +
    return(tibble::as_tibble(list(name = c("grid_mapping_name", 
54 +
                                           "semi_major_axis", 
55 +
                                           "inverse_flattening", 
56 +
                                           "longitude_of_prime_meridian"),
57 +
                                  value = list("latitude_longitude", 
58 +
                                               6378137, 
59 +
                                               298.257223563, 
60 +
                                               0))))
61 +
  }
62 +
  
63 +
  grid_mapping_vars <- dplyr::filter(x, variable %in% data_variable & 
64 +
                                      name %in% gm_att) %>%
65 +
    dplyr::mutate(value = as.character(value))
66 +
  
67 +
  grid_mapping_atts <- dplyr::filter(x, variable %in% grid_mapping_vars$value)
68 +
  
69 +
  grid_mapping_atts <- 
70 +
    dplyr::left_join(grid_mapping_atts, 
71 +
                     select(grid_mapping_vars, data_variable = variable, value = value),
72 +
                     by = c("variable" = "value"))
73 +
  
74 +
  return(grid_mapping_atts)
75 +
}
76 +
77 +
#' Get NetCDF-CF grid mapping from projection
78 +
#'
79 +
#' Takes a proj4 string and returns a NetCDF-CF projection as
80 +
#' a named list of attributes.
81 +
#'
82 +
#' @param prj character PROJ string as used in raster, sf, sp, proj4, and rgdal packages.
83 +
#'
84 +
#' @return A named list containing attributes required for that grid_mapping.
85 +
#'
86 +
#' 
87 +
#' @references 
88 +
#' \enumerate{
89 +
#'   \item \url{https://en.wikibooks.org/wiki/PROJ.4}
90 +
#'   \item \url{https://trac.osgeo.org/gdal/wiki/NetCDF_ProjectionTestingStatus}
91 +
#'   \item \url{http://cfconventions.org/cf-conventions/cf-conventions.html#appendix-grid-mappings}
92 +
#' }
93 +
#'
94 +
#' @export
95 +
#' 
96 +
#' @examples
97 +
#' prj <- "+proj=longlat +datum=NAD27 +no_defs"
98 +
#' nc_prj_to_gridmapping(prj)
99 +
#' p1 <- "+proj=aea +lat_1=29.5 +lat_2=45.5 +lat_0=23 +lon_0=-96"
100 +
#' p2 <- "+x_0=0 +y_0=0 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
101 +
#' prj2 <- sprintf("%s %s", p1, p2) 
102 +
#' nc_prj_to_gridmapping(prj2)
103 +
#' 
104 +
#' nc_prj_to_gridmapping("+proj=longlat +a=6378137 +f=0.00335281066474748 +pm=0 +no_defs")
105 +
#' 
106 +
nc_prj_to_gridmapping <- function(prj) {
107 +
  
108 +
  al <- prepCRS(prj)
109 +
  
110 +
  if(is.null(al)) {
111 +
    return(tibble::as_tibble(list(name = character(0), value = list()))) 
112 +
  } else {
113 +
    
114 +
    gm <- GGFP(al)
115 +
    
116 +
    return(tibble::as_tibble(list(name = names(gm), value = unname(gm))))
117 +
  }
118 +
}
119 +
120 +
GGFP <- function(al) UseMethod("GGFP")
121 +
122 +
GGFP.latitude_longitude <- function(al) {
123 +
  gm <- c(list(grid_mapping_name = "latitude_longitude"),
124 +
          getGeoDatum_gm(al))
125 +
  gm
126 +
}
127 +
128 +
GGFP.albers_conical_equal_area <- function(al) {
129 +
  gm <- c(list(grid_mapping_name = "albers_conical_equal_area"),
130 +
       lonCentMer_gm(al),
131 +
       latProjOrig_gm(al),
132 +
       falseEastNorth_gm(al),
133 +
       standPar_gm(al),
134 +
       getGeoDatum_gm(al))
135 +
  gm
136 +
}
137 +
138 +
GGFP.azimuthal_equidistant <- function(al) {
139 +
  gm <- c(list(grid_mapping_name = "azimuthal_equidistant"),
140 +
          lonProjOrig_gm(al),
141 +
          latProjOrig_gm(al),
142 +
          falseEastNorth_gm(al),
143 +
          getGeoDatum_gm(al))
144 +
  gm
145 +
}
146 +
147 +
GGFP.lambert_azimuthal_equal_area <- function(al) {
148 +
  gm <- c(list(grid_mapping_name = "lambert_azimuthal_equal_area"),
149 +
          latProjOrig_gm(al),
150 +
          lonProjOrig_gm(al),
151 +
          falseEastNorth_gm(al),
152 +
          getGeoDatum_gm(al))
153 +
  gm
154 +
}
155 +
156 +
GGFP.lambert_conformal_conic <- function(al) {
157 +
  gm <- c(list(grid_mapping_name = "lambert_conformal_conic"),
158 +
                    standPar_gm(al),
159 +
                    falseEastNorth_gm(al),
160 +
                    latProjOrig_gm(al),
161 +
                    lonCentMer_gm(al),
162 +
                    getGeoDatum_gm(al))
163 +
  gm
164 +
}
165 +
166 +
GGFP.lambert_cylindrical_equal_area <- function(al) {
167 +
  gm <- c(list(grid_mapping_name = "lambert_cylindrical_equal_area"),
168 +
                    lonCentMer_gm(al),
169 +
                    oneStandPar_gm(al),
170 +
                    falseEastNorth_gm(al),
171 +
                    getGeoDatum_gm(al))
172 +
  gm
173 +
}
174 +
175 +
GGFP.mercator <- function(al) {
176 +
  if(!is.null(al$k)) {
177 +
    gm <- c(list(grid_mapping_name = "mercator"),
178 +
                      lonProjOrig_gm(al),
179 +
                      scaleFactor_gm(al),
180 +
                      falseEastNorth_gm(al),
181 +
                      getGeoDatum_gm(al))
182 +
  } else {
183 +
    gm <- c(list(grid_mapping_name = "mercator"),
184 +
                      lonProjOrig_gm(al),
185 +
                      oneStandPar_gm(al),
186 +
                      falseEastNorth_gm(al),
187 +
                      getGeoDatum_gm(al))
188 +
  }
189 +
  gm
190 +
}
191 +
192 +
GGFP.oblique_mercator <- function(al) {
193 +
  #!!!! Check this one out. the oMerc function is a hack !!!!
194 +
  gm <- c(list(grid_mapping_name = "oblique_mercator"),
195 +
                    latProjOrig_gm(al),
196 +
                    lonProjCent_gm(al),
197 +
                    scaleFactor_gm(al),
198 +
                    oMerc_gm(al),
199 +
                    falseEastNorth_gm(al),
200 +
                    getGeoDatum_gm(al))
201 +
  gm
202 +
}
203 +
204 +
GGFP.orthographic <- function(al) {
205 +
  gm <- c(list(grid_mapping_name = "orthographic"),
206 +
                    latProjOrig_gm(al),
207 +
                    lonProjOrig_gm(al),
208 +
                    falseEastNorth_gm(al),
209 +
                    getGeoDatum_gm(al))
210 +
  gm
211 +
}
212 +
213 +
# GGFP.polar_stereographic <- function(al) {
214 +
#   if(!is.null(al$k)) {
215 +
#     gm <- c(list(grid_mapping_name = "polar_stereographic"),
216 +
#                       latProjOrig_gm(al),
217 +
#                       stVertLon_gm(al),
218 +
#                       scaleFactor_gm(al),
219 +
#                       falseEastNorth_gm(al),
220 +
#                       getGeoDatum_gm(al))
221 +
#   } else {
222 +
#     gm <- c(list(grid_mapping_name = "polar_stereographic"),
223 +
#                       latProjOrig_gm(al),
224 +
#                       stVertLon_gm(al),
225 +
#                       oneStandPar_gm(al),
226 +
#                       falseEastNorth_gm(al),
227 +
#                       getGeoDatum_gm(al))
228 +
#   }
229 +
#  gm
230 +
# }
231 +
232 +
# GGFP.sinusoidal <- function(al) {
233 +
#   gm <- c(list(grid_mapping_name = "sinusoidal"),
234 +
#                     lonProjOrig_gm(al),
235 +
#                     falseEastNorth_gm(al),
236 +
#                     getGeoDatum_gm(al))
237 +
# gm
238 +
# }
239 +
240 +
GGFP.stereographic <- function(al) {
241 +
  gm <- c(list(grid_mapping_name = "stereographic"),
242 +
                    latProjOrig_gm(al),
243 +
                    lonProjOrig_gm(al),
244 +
                    scaleFactor_gm(al),
245 +
                    falseEastNorth_gm(al),
246 +
                    getGeoDatum_gm(al))
247 +
  gm
248 +
}
249 +
250 +
GGFP.transverse_mercator <- function(al) {
251 +
  gm <- c(list(grid_mapping_name = "transverse_mercator"),
252 +
                    latProjOrig_gm(al),
253 +
                    lonProjOrig_gm(al),
254 +
                    scaleFactor_gm(al),
255 +
                    falseEastNorth_gm(al),
256 +
                    getGeoDatum_gm(al))
257 +
  gm
258 +
}
259 +
260 +
lonCentMer_gm <- function(al) {
261 +
  list(longitude_of_central_meridian = as.numeric(al$lon_0))
262 +
}
263 +
264 +
latProjOrig_gm <- function(al) {
265 +
  list(latitude_of_projection_origin = as.numeric(al$lat_0))
266 +
}
267 +
268 +
lonProjOrig_gm <- function(al) {
269 +
  list(longitude_of_projection_origin = as.numeric(al$lon_0))
270 +
}
271 +
272 +
falseEastNorth_gm <- function(al) {
273 +
  list(false_easting = as.numeric(al$x_0),
274 +
  false_northing = as.numeric(al$y_0))
275 +
}
276 +
277 +
standPar_gm <- function(al) {
278 +
  if(al$lat_1 != al$lat_2) {
279 +
    list(standard_parallel = c(as.numeric(al$lat_1), as.numeric(al$lat_2)))
280 +
  } else if(al$lat_1 == al$lat_2) {
281 +
    list(standard_parallel = as.numeric(al$lat_1))
282 +
  }
283 +
}
284 +
285 +
oneStandPar_gm <- function(al) {
286 +
  list(standard_parallel = c(as.numeric(al$lat_ts)))
287 +
}
288 +
289 +
getGeoDatum_gm <- function(al) {
290 +
  if(!is.null(al$datum) && al$datum == "NAD83") {
291 +
    list(semi_major_axis = 6378137,
292 +
         inverse_flattening = 298.257222101,
293 +
         longitude_of_prime_meridian = 0)
294 +
  } else if(!is.null(al$datum) && al$datum == "WGS84") {
295 +
    list(semi_major_axis = 6378137,
296 +
         inverse_flattening = 298.257223563,
297 +
         longitude_of_prime_meridian = 0)
298 +
  } else if(!is.null(al$datum) && al$datum == "NAD27") {
299 +
    list(semi_major_axis = 6378206.4,
300 +
         inverse_flattening = 294.978698214,
301 +
         longitude_of_prime_meridian = 0)
302 +
  } else if(!is.null(al$ellps) && 
303 +
  					!is.null(al$towgs84) && 
304 +
  					al$towgs84 == "0,0,0,0,0,0,0") {
305 +
  	list(semi_major_axis = 6378137,
306 +
  			 inverse_flattening = 298.257223563,
307 +
  			 longitude_of_prime_meridian = 0)
308 +
  } else if(!is.null(al$a) && !is.null(al$f) && !is.null(al$pm)) {
309 +
    list(semi_major_axis = as.numeric(al$a),
310 +
        inverse_flattening = (1/as.numeric(al$f)),
311 +
        longitude_of_prime_meridian = as.numeric(al$pm))
312 +
  } else if(!is.null(al$a) && !is.null(al$b) && !is.null(al$pm)) {
313 +
  	list(semi_major_axis = as.numeric(al$a),
314 +
  			 semi_minor_axis = as.numeric(al$b),
315 +
  			 longitude_of_prime_meridian = as.numeric(al$pm))
316 +
  } else {
317 +
  	warning("no datum information found assuming WGS84")
318 +
  	list(semi_major_axis = 6378137,
319 +
  			 inverse_flattening = 298.257223563,
320 +
  			 longitude_of_prime_meridian = 0)
321 +
  }
322 +
}
323 +
324 +
scaleFactor_gm <- function(al) {
325 +
  list(scale_factor_at_projection_origin = as.numeric(al$k))
326 +
}
327 +
328 +
oMerc_gm <- function(al) {
329 +
  list(azimuth_of_central_line = as.numeric(al$alpha))
330 +
}
331 +
332 +
lonProjCent_gm <- function(al) {
333 +
  list(longitude_of_projection_origin = as.numeric(al$lonc))
334 +
}
335 +
336 +
check_args <- function (x) 
337 +
{
338 +
  ## FIXME: checks as in reproj stop("cannot convert from digits, did you enter an EPSG code?")
339 +
  if (is.numeric(x) || (nchar(x) %in% c(4, 5) && grepl("^[0-9]{1,5}$", 
340 +
                                                       x))) {
341 +
    return(FALSE)
342 +
  }
343 +
  if (!substr(x, 1, 1) == "+") 
344 +
    return(FALSE)
345 +
  TRUE
346 +
}
347 +
348 +
prepCRS <- function(prj) {
349 +
  if(class(prj) == "CRS") prj <- prj@projargs
350 +
351 +
  if(!check_args(prj)[1][[1]]) {
352 +
 
353 +
    warning("not a valid crs, returning an empty tibble")
354 +
    return(NULL)
355 +
  }
356 +
357 +
  args <- unique(unlist(strsplit(prj, " ")))
358 +
359 +
  argList <- list()
360 +
361 +
  for(arg in args) {
362 +
    a <- unlist(strsplit(sub("\\+", "", arg), "="))
363 +
    argList[a[1]] <- a[2]
364 +
  }
365 +
366 +
  cf_proj_lookup <- list(aea = "albers_conical_equal_area",
367 +
                         aeqd = "azimuthal_equidistant",
368 +
                         laea = "lambert_azimuthal_equal_area",
369 +
                         lcc = "lambert_conformal_conic",
370 +
                         cea = "lambert_cylindrical_equal_area",
371 +
                         longlat = "latitude_longitude",
372 +
                         merc = "mercator",
373 +
                         omerc = "oblique_mercator",
374 +
                         ortho = "orthographic",
375 +
                         stere = "stereographic",
376 +
                         tmerc = "transverse_mercator")
377 +
378 +
  class(argList) <- cf_proj_lookup[unlist(argList["proj"])][[1]]
379 +
380 +
  if(!class(argList) %in% cf_proj_lookup) {
381 +
    warning("no available mapping to netcdf projection, returning empty crs list")
382 +
    return(NULL) } else {
383 +
    return(argList) }
384 +
}

@@ -1,208 +1,208 @@
Loading
1 -
#' Get Coordinate Variables for Given Variable
2 -
#' 
3 -
#' In NetCDF, variables are defined along dimensions and are said to have "coordinate 
4 -
#' variables" that define the (typically spatio-temporal) positions of the data's cells.
5 -
#' 
6 -
#' This function attempts to identify the X, Y, Z, and T coordinate variables for each
7 -
#' data variable in the provided NetCDF source. The NetCDF-CF attribute conventions are
8 -
#' used to make this determination.
9 -
#' 
10 -
#' All variables that can be related to a spatio-temporal axis, including coordinate 
11 -
#' variables are returned. For coordinate variables, a "bounds" column is included in 
12 -
#' the response indicating which variable contains bounds information.
13 -
#' 
14 -
#' See \url{http://cfconventions.org/cf-conventions/v1.6.0/cf-conventions.html#coordinate-system}
15 -
#' for more.
16 -
#' 
17 -
#' @return tibble with "variable", "X", "Y", "Z", "T", and "bounds" columns that reference 
18 -
#' variables by name. 
19 -
#' 
20 -
#' @name nc_coord_var
21 -
#' @export
22 -
#' @examples
23 -
#' f <- system.file("extdata", "S2008001.L3m_DAY_CHL_chlor_a_9km.nc", package = "ncmeta")
24 -
#' nc_coord_var(f, "chlor_a")
25 -
#' 
26 -
#' f <- system.file("extdata", "guam.nc", package = "ncmeta")
27 -
#' nc_coord_var(f)
28 -
29 -
nc_coord_var <- function(x, variable = NULL, ...) UseMethod("nc_coord_var")
30 -
31 -
#' @param x NetCDF source
32 -
#' @param variable variable name of interest. 
33 -
#' If not included, all variables will be returned.
34 -
#' @param ... ignored
35 -
#'
36 -
#' @name nc_coord_var
37 -
#' @export
38 -
nc_coord_var.character <- function(x, variable = NULL, ...) {
39 -
  if (nchar(x) < 1) stop("NetCDF source cannot be empty string")
40 -
  
41 -
  nc <- RNetCDF::open.nc(x)
42 -
  on.exit(RNetCDF::close.nc(nc), add  = TRUE)
43 -
  nc_coord_var_call(nc_dims(nc), nc_vars(nc), nc_atts(nc), nc_axes(x), variable)
44 -
}
45 -
46 -
#' @name nc_coord_var
47 -
#' @export
48 -
nc_coord_var.NetCDF <- function(x, variable = NULL, ...) {
49 -
  nc_coord_var_call(nc_dims(x), nc_vars(x), nc_atts(x), nc_axes(x), variable)
50 -
}
51 -
52 -
#' @importFrom dplyr bind_rows
53 -
nc_coord_var_call <- function(dim, var, att, axe, variable) {
54 -
  if (is.null(var) || (nrow(var) < 1 & nrow(dim) < 1)) return(tibble::tibble())
55 -
  
56 -
  if(is.null(variable)) {
57 -
    bind_rows(lapply(var$name, 
58 -
                     function(v) nc_coord_var_finder(dim, var, att, axe, v)))
59 -
    
60 -
  } else {
61 -
    nc_coord_var_finder(dim, var, att, axe, variable)
62 -
  }
63 -
}
64 -
65 -
#' @importFrom dplyr bind_rows filter select left_join group_by arrange mutate ungroup distinct
66 -
nc_coord_var_finder <- function(dim, var, att, axe, variable) {
67 -
  
68 -
  if(nrow(att) == 0) return(NULL)
69 -
  
70 -
  v_atts <- att$variable == variable
71 -
  v_atts <- filter(att, v_atts)
72 -
  
73 -
  aux = FALSE
74 -
  
75 -
  if ("coordinates" %in% v_atts$name) {
76 -
    # NetCDF-CF introduces a "coordinates" attribute
77 -
    coordinates_atts <- filter(v_atts, name == "coordinates")
78 -
    coord_vars <- strsplit(coordinates_atts[["value"]][[1]], " ")[[1]]
79 -
    coord_vars <- coord_vars[nchar(coord_vars) > 0]
80 -
    
81 -
    if(!any(coord_vars %in% var$name)) {
82 -
      warning(paste("missing coordinate variables names in coordinates attribute",
83 -
                    "trying to find non-auxiliary coordinate variables."))
84 -
    } else {
85 -
      aux = TRUE
86 -
    }
87 -
  }
88 -
  
89 -
  # COARDS style coordinate variables have the same name as a dimension.
90 -
  v_dims <- axe$dimension[axe$variable == variable]
91 -
  v_dims <- dim$name[dim$id %in% v_dims]
92 -
  
93 -
  if(!aux) {
94 -
    if(length(v_dims) == 0) return(NULL)
95 -
    
96 -
    if(any(v_dims %in% var$name)) { 
97 -
      coord_vars <- v_dims[v_dims %in% var$name]
98 -
    } else {
99 -
      return(NULL)
100 -
    }
101 -
  } else {
102 -
    if(any(v_dims %in% var$name)) {
103 -
      coord_vars <- unique(c(coord_vars, v_dims[v_dims %in% var$name]))
104 -
    }
105 -
  }
106 -
  
107 -
  coord_var <- sapply(coord_vars, divine_XYZT,
108 -
                      atts = filter(att, variable %in% coord_vars), 
109 -
                      simplify = FALSE)
110 -
  
111 -
  coord_var <- coord_var[!sapply(coord_var, is.null)]
112 -
  
113 -
  if(length(coord_var) == 0) {
114 -
    return(NULL)
115 -
  } else {
116 -
    coord_var_base <- tibble::as_tibble(list(coord_var = names(coord_var),
117 -
                                             axis = unlist(coord_var)))
118 -
    
119 -
    out <- tibble::tibble(variable = character(0), 
120 -
                          X = character(0),
121 -
                          Y = character(0),
122 -
                          Z = character(0),
123 -
                          T = character(0))
124 -
    
125 -
    # coordinate variables not named in a coordinates attribute relate 
126 -
    # by a shared dimension. First we need to get their dimension joined in.
127 -
    coord_var <- coord_var_base %>%
128 -
      left_join(select(axe, -axis), by = c("coord_var" = "variable"))
129 -
    
130 -
    # Now we can build up a table that relates data variables to 
131 -
    # coordinate variables.
132 -
    coord_var <- tibble::as_tibble(list(variable = variable)) %>%
133 -
      left_join(select(axe, -axis), by = "variable") %>%
134 -
      left_join(coord_var, by = "dimension") %>%
135 -
      filter(!is.na(coord_var)) %>%
136 -
      select(variable, axis, coord_var) %>%
137 -
      distinct()
138 -
    
139 -
    out <-tryCatch({
140 -
      bind_rows(out, coord_var %>%
141 -
                  tidyr::spread(key = axis, value = coord_var))
142 -
    }, error = function(e) { 
143 -
      # Takes care of the case where there are both normal and auxiliary coordinate variables.
144 -
      bind_rows(out, filter(coord_var, !coord_var %in% dim$name) %>%
145 -
                  tidyr::spread(key = axis, value = coord_var),
146 -
                filter(coord_var, coord_var %in% dim$name)  %>%
147 -
                  tidyr::spread(key = axis, value = coord_var))
148 -
    })
149 -
    
150 -
    bounds <- get_bounds(att)
151 -
    if(nrow(bounds) > 0) {
152 -
      out <- left_join(out, bounds, by = "variable")
153 -
    } else {
154 -
      if(nrow(out) > 0) {
155 -
        out$bounds <- NA_character_
156 -
      } else {
157 -
        out$bounds <- character(0)
158 -
      }
159 -
    }
160 -
    return(out)
161 -
  }
162 -
}
163 -
164 -
axis <- variable <- name <- value <- NULL
165 -
166 -
divine_XYZT <- function(var, atts) {
167 -
  att_sub <- filter(atts, variable == var)
168 -
  att_sub <- stats::setNames(att_sub$value, att_sub$name)
169 -
  
170 -
  # By units is preferred by COARDS
171 -
  lon_units <- c("degrees_east|degree_east|degree_E|degrees_E|degreeE|degreesE")
172 -
  if(!is.null(att_sub[["units"]]) &&
173 -
     grepl(lon_units, att_sub[["units"]], ignore.case = TRUE)) return("X")
174 -
  
175 -
  lat_units <- "degrees_north|degree_north|degree_N|degrees_N|degreeN|degreesN"
176 -
  if(!is.null(att_sub[["units"]]) &&
177 -
     grepl(lat_units, att_sub[["units"]], ignore.case = TRUE)) return("Y")
178 -
  
179 -
  # lat/lon by standard name
180 -
  if(!is.null(att_sub[["standard_name"]]) && 
181 -
     grepl("longitude", att_sub[["standard_name"]], ignore.case = TRUE)) return("X")
182 -
  
183 -
  if(!is.null(att_sub[["standard_name"]]) && 
184 -
     grepl("latitude", att_sub[["standard_name"]], ignore.case = TRUE)) return("Y")
185 -
  
186 -
  if(!is.null(att_sub[["standard_name"]]) && 
187 -
     grepl("time", att_sub[["standard_name"]], ignore.case = TRUE)) return("T")
188 -
  
189 -
  # X/Y/Z/T by Axis
190 -
  if(!is.null(att_sub[["axis"]])) return(att_sub[["axis"]])
191 -
  
192 -
  if(!is.null(att_sub[["positive"]])) return("Z")
193 -
  
194 -
  if(!is.null(att_sub[["units"]]) &&
195 -
     grepl("since", att_sub[["units"]])) return("T")
196 -
  
197 -
  if(any(grepl("x coordinate of projection", att_sub)) | 
198 -
     any(grepl("projection_x_coordinate", att_sub))) return("X")
199 -
  
200 -
  if(any(grepl("y coordinate of projection", att_sub)) | 
201 -
     any(grepl("projection_y_coordinate", att_sub))) return("Y")
202 -
}
203 -
#' @importFrom rlang .data
204 -
get_bounds <- function(atts) {
205 -
  dplyr::filter(atts, grepl("bounds", atts$name, ignore.case = TRUE)) %>%
206 -
    dplyr::select(variable, bounds = value) %>%
207 -
    dplyr::mutate(bounds = as.character(.data$bounds))
208 -
}
1 +
#' Get Coordinate Variables for Given Variable
2 +
#' 
3 +
#' In NetCDF, variables are defined along dimensions and are said to have "coordinate 
4 +
#' variables" that define the (typically spatio-temporal) positions of the data's cells.
5 +
#' 
6 +
#' This function attempts to identify the X, Y, Z, and T coordinate variables for each
7 +
#' data variable in the provided NetCDF source. The NetCDF-CF attribute conventions are
8 +
#' used to make this determination.
9 +
#' 
10 +
#' All variables that can be related to a spatio-temporal axis, including coordinate 
11 +
#' variables are returned. For coordinate variables, a "bounds" column is included in 
12 +
#' the response indicating which variable contains bounds information.
13 +
#' 
14 +
#' See \url{http://cfconventions.org/cf-conventions/v1.6.0/cf-conventions.html#coordinate-system}
15 +
#' for more.
16 +
#' 
17 +
#' @return tibble with "variable", "X", "Y", "Z", "T", and "bounds" columns that reference 
18 +
#' variables by name. 
19 +
#' 
20 +
#' @name nc_coord_var
21 +
#' @export
22 +
#' @examples
23 +
#' f <- system.file("extdata", "S2008001.L3m_DAY_CHL_chlor_a_9km.nc", package = "ncmeta")
24 +
#' nc_coord_var(f, "chlor_a")
25 +
#' 
26 +
#' f <- system.file("extdata", "guam.nc", package = "ncmeta")
27 +
#' nc_coord_var(f)
28 +
29 +
nc_coord_var <- function(x, variable = NULL, ...) UseMethod("nc_coord_var")
30 +
31 +
#' @param x NetCDF source
32 +
#' @param variable variable name of interest. 
33 +
#' If not included, all variables will be returned.
34 +
#' @param ... ignored
35 +
#'
36 +
#' @name nc_coord_var
37 +
#' @export
38 +
nc_coord_var.character <- function(x, variable = NULL, ...) {
39 +
  if (nchar(x) < 1) stop("NetCDF source cannot be empty string")
40 +
  
41 +
  nc <- RNetCDF::open.nc(x)
42 +
  on.exit(RNetCDF::close.nc(nc), add  = TRUE)
43 +
  nc_coord_var_call(nc_dims(nc), nc_vars(nc), nc_atts(nc), nc_axes(x), variable)
44 +
}
45 +
46 +
#' @name nc_coord_var
47 +
#' @export
48 +
nc_coord_var.NetCDF <- function(x, variable = NULL, ...) {
49 +
  nc_coord_var_call(nc_dims(x), nc_vars(x), nc_atts(x), nc_axes(x), variable)
50 +
}
51 +
52 +
#' @importFrom dplyr bind_rows
53 +
nc_coord_var_call <- function(dim, var, att, axe, variable) {
54 +
  if (is.null(var) || (nrow(var) < 1 & nrow(dim) < 1)) return(tibble::tibble())
55 +
  
56 +
  if(is.null(variable)) {
57 +
    bind_rows(lapply(var$name, 
58 +
                     function(v) nc_coord_var_finder(dim, var, att, axe, v)))
59 +
    
60 +
  } else {
61 +
    nc_coord_var_finder(dim, var, att, axe, variable)
62 +
  }
63 +
}
64 +
65 +
#' @importFrom dplyr bind_rows filter select left_join group_by arrange mutate ungroup distinct
66 +
nc_coord_var_finder <- function(dim, var, att, axe, variable) {
67 +
  
68 +
  if(nrow(att) == 0) return(NULL)
69 +
  
70 +
  v_atts <- att$variable == variable
71 +
  v_atts <- filter(att, v_atts)
72 +
  
73 +
  aux = FALSE
74 +
  
75 +
  if ("coordinates" %in% v_atts$name) {
76 +
    # NetCDF-CF introduces a "coordinates" attribute
77 +
    coordinates_atts <- filter(v_atts, name == "coordinates")
78 +
    coord_vars <- strsplit(coordinates_atts[["value"]][[1]], " ")[[1]]
79 +
    coord_vars <- coord_vars[nchar(coord_vars) > 0]
80 +
    
81 +
    if(!any(coord_vars %in% var$name)) {
82 +
      warning(paste("missing coordinate variables names in coordinates attribute",
83 +
                    "trying to find non-auxiliary coordinate variables."))
84 +
    } else {
85 +
      aux = TRUE
86 +
    }
87 +
  }
88 +
  
89 +
  # COARDS style coordinate variables have the same name as a dimension.
90 +
  v_dims <- axe$dimension[axe$variable == variable]
91 +
  v_dims <- dim$name[dim$id %in% v_dims]
92 +
  
93 +
  if(!aux) {
94 +
    if(length(v_dims) == 0) return(NULL)
95 +
    
96 +
    if(any(v_dims %in% var$name)) { 
97 +
      coord_vars <- v_dims[v_dims %in% var$name]
98 +
    } else {
99 +
      return(NULL)
100 +
    }
101 +
  } else {
102 +
    if(any(v_dims %in% var$name)) {
103 +
      coord_vars <- unique(c(coord_vars, v_dims[v_dims %in% var$name]))
104 +
    }
105 +
  }
106 +
  
107 +
  coord_var <- sapply(coord_vars, divine_XYZT,
108 +
                      atts = filter(att, variable %in% coord_vars), 
109 +
                      simplify = FALSE)
110 +
  
111 +
  coord_var <- coord_var[!sapply(coord_var, is.null)]
112 +
  
113 +
  if(length(coord_var) == 0) {
114 +
    return(NULL)
115 +
  } else {
116 +
    coord_var_base <- tibble::as_tibble(list(coord_var = names(coord_var),
117 +
                                             axis = unlist(coord_var)))
118 +
    
119 +
    out <- tibble::tibble(variable = character(0), 
120 +
                          X = character(0),
121 +
                          Y = character(0),
122 +
                          Z = character(0),
123 +
                          T = character(0))
124 +
    
125 +
    # coordinate variables not named in a coordinates attribute relate 
126 +
    # by a shared dimension. First we need to get their dimension joined in.
127 +
    coord_var <- coord_var_base %>%
128 +
      left_join(select(axe, -axis), by = c("coord_var" = "variable"))
129 +
    
130 +
    # Now we can build up a table that relates data variables to 
131 +
    # coordinate variables.
132 +
    coord_var <- tibble::as_tibble(list(variable = variable)) %>%
133 +
      left_join(select(axe, -axis), by = "variable") %>%
134 +
      left_join(coord_var, by = "dimension") %>%
135 +
      filter(!is.na(coord_var)) %>%
136 +
      select(variable, axis, coord_var) %>%
137 +
      distinct()
138 +
    
139 +
    out <-tryCatch({
140 +
      bind_rows(out, coord_var %>%
141 +
                  tidyr::spread(key = axis, value = coord_var))
142 +
    }, error = function(e) { 
143 +
      # Takes care of the case where there are both normal and auxiliary coordinate variables.
144 +
      bind_rows(out, filter(coord_var, !coord_var %in% dim$name) %>%
145 +
                  tidyr::spread(key = axis, value = coord_var),
146 +
                filter(coord_var, coord_var %in% dim$name)  %>%
147 +
                  tidyr::spread(key = axis, value = coord_var))
148 +
    })
149 +
    
150 +
    bounds <- get_bounds(att)
151 +
    if(nrow(bounds) > 0) {
152 +
      out <- left_join(out, bounds, by = "variable")
153 +
    } else {
154 +
      if(nrow(out) > 0) {
155 +
        out$bounds <- NA_character_
156 +
      } else {
157 +
        out$bounds <- character(0)
158 +
      }
159 +
    }
160 +
    return(out)
161 +
  }
162 +
}
163 +
164 +
axis <- variable <- name <- value <- NULL
165 +
166 +
divine_XYZT <- function(var, atts) {
167 +
  att_sub <- filter(atts, variable == var)
168 +
  att_sub <- stats::setNames(att_sub$value, att_sub$name)
169 +
  
170 +
  # By units is preferred by COARDS
171 +
  lon_units <- c("degrees_east|degree_east|degree_E|degrees_E|degreeE|degreesE")
172 +
  if(!is.null(att_sub[["units"]]) &&
173 +
     grepl(lon_units, att_sub[["units"]], ignore.case = TRUE)) return("X")
174 +
  
175 +
  lat_units <- "degrees_north|degree_north|degree_N|degrees_N|degreeN|degreesN"
176 +
  if(!is.null(att_sub[["units"]]) &&
177 +
     grepl(lat_units, att_sub[["units"]], ignore.case = TRUE)) return("Y")
178 +
  
179 +
  # lat/lon by standard name
180 +
  if(!is.null(att_sub[["standard_name"]]) && 
181 +
     grepl("longitude", att_sub[["standard_name"]], ignore.case = TRUE)) return("X")
182 +
  
183 +
  if(!is.null(att_sub[["standard_name"]]) && 
184 +
     grepl("latitude", att_sub[["standard_name"]], ignore.case = TRUE)) return("Y")
185 +
  
186 +
  if(!is.null(att_sub[["standard_name"]]) && 
187 +
     grepl("time", att_sub[["standard_name"]], ignore.case = TRUE)) return("T")
188 +
  
189 +
  # X/Y/Z/T by Axis
190 +
  if(!is.null(att_sub[["axis"]])) return(att_sub[["axis"]])
191 +
  
192 +
  if(!is.null(att_sub[["positive"]])) return("Z")
193 +
  
194 +
  if(!is.null(att_sub[["units"]]) &&
195 +
     grepl("since", att_sub[["units"]])) return("T")
196 +
  
197 +
  if(any(grepl("x coordinate of projection", att_sub)) | 
198 +
     any(grepl("projection_x_coordinate", att_sub))) return("X")
199 +
  
200 +
  if(any(grepl("y coordinate of projection", att_sub)) | 
201 +
     any(grepl("projection_y_coordinate", att_sub))) return("Y")
202 +
}
203 +
#' @importFrom rlang .data
204 +
get_bounds <- function(atts) {
205 +
  dplyr::filter(atts, grepl("bounds", atts$name, ignore.case = TRUE)) %>%
206 +
    dplyr::select(variable, bounds = value) %>%
207 +
    dplyr::mutate(bounds = as.character(.data$bounds))
208 +
}

@@ -1,22 +1,22 @@
Loading
1 -
#' NetCDF sources
2 -
#' 
3 -
#' A record of file, URL, or any data source with NetCDF. 
4 -
#' @param x data source string
5 -
#'
6 -
#' @param ... ignored
7 -
#'
8 -
#' @name nc_sources
9 -
#' @export
10 -
nc_sources <- function(x, ...) {
11 -
  UseMethod("nc_sources")
12 -
}
13 -
#' @name nc_sources
14 -
#' @export
15 -
nc_sources.character <- function(x, ...) {
16 -
  if (file.exists(x)) {
17 -
    path <- normalizePath(x, winslash = "/")
18 -
  } else {
19 -
    path <- x
20 -
  }
21 -
  tibble(access = Sys.time(), source = path)
22 -
}
1 +
#' NetCDF sources
2 +
#' 
3 +
#' A record of file, URL, or any data source with NetCDF. 
4 +
#' @param x data source string
5 +
#'
6 +
#' @param ... ignored
7 +
#'
8 +
#' @name nc_sources
9 +
#' @export
10 +
nc_sources <- function(x, ...) {
11 +
  UseMethod("nc_sources")
12 +
}
13 +
#' @name nc_sources
14 +
#' @export
15 +
nc_sources.character <- function(x, ...) {
16 +
  if (file.exists(x)) {
17 +
    path <- normalizePath(x, winslash = "/")
18 +
  } else {
19 +
    path <- x
20 +
  }
21 +
  tibble(access = Sys.time(), source = path)
22 +
}
Files Coverage
R 87.06%
Project Totals (16 files) 87.06%
Notifications are pending CI completion. Periodically Codecov will check the CI state, when complete notifications will be submitted. Push notifications now.
Sunburst
The inner-most circle is the entire project, moving away from the center are folders then, finally, a single file. The size and color of each slice is representing the number of statements and the coverage, respectively.
Icicle
The top section represents the entire project. Proceeding with folders and finally individual files. The size and color of each slice is representing the number of statements and the coverage, respectively.
Grid
Each block represents a single file in the project. The size and color of each block is represented by the number of statements and the coverage, respectively.
Loading