Nothing
R/utils.R
In rerddapUtils: Miscellaneous Utilities for 'rerddap'
Defines functions
strtrim
strextract
foo
dimvars
getallvars
getvars
getvar
parse_args
fix_dims
check_lat_data_range
check_lon_data_range
check_time_range
is_lat_text
is_lon_text
check_lat_text
check_lon_text
check_dims
field_handler
copy_attributes
create_nc_file
define_split_nc
extract_rerddap_call
get_dimVals
# Retrieve Dimension Values for a Dataset from an ERDDAP Server
#
# This function queries an ERDDAP server for the dimension values of a specified dataset.
# It constructs a request to the server without fetching the actual data (fields set to 'none' and read set to FALSE),
# aiming to retrieve metadata about the dataset dimensions. It is useful for understanding the range of
# values each dimension covers, such as time, depth, latitude, and longitude.
#
# @param x An object returned by `rerddap::info()` that contains metadata about the dataset,
# including the base URL of the ERDDAP server and the dataset identifier.
# @param dimargs A list specifying the dimensions and their ranges for which to retrieve values.
# Each element of the list should be named according to the dimension it represents.
#
# @return A list containing two elements: `dimVals`, a list of the retrieved dimension values,
# where each element is named after a dimension and contains the values for that dimension;
# and `nc_file`, a string indicating the filename of the NetCDF file that would contain the
# data (if it were to be downloaded).
#
# @examples
# # Assuming `x` is a valid object returned by `rerddap::info()` for a dataset:
# dimargs <- list(time = c('2020-01-01', '2020-12-31'), depth = c(0, 100))
# dimVals <- get_dimVals(x, dimargs)
# print(dimVals$dimVals)
# print(dimVals$nc_file)
#
get_dimVals <- function(x, dimargs) {
base_url <- paste0(x$base_url, '/')
call_args <- list(datasetx = x)
call_args <- c(call_args, dimargs)
# for (i in seq_along(dimargs)){
# call_args <- c(call_args, dimargs[i])
# names(call_args)[i + 1] <- names(dimargs)[i]
# }
call_args$fields <- 'none'
call_args$read <- FALSE
call_args$url <- base_url
temp_result <- do.call(rerddap::griddap, call_args)
dimVals <- lapply(temp_result$summary$dim, `[[`, "vals")
# dimVals = list()
# for (i in seq_along(temp_result$summary$dim)){
# temp <- temp_result$summary$dim[[i]]
# dimVals[[temp$name]] <- temp$vals
# }
if ('time' %in% names(dimVals)) {
dimVals$time <- as.character(as.POSIXlt(dimVals$time, origin = '1970-01-01', tz = "GMT"))
}
return(list(dimVals = dimVals, nc_file = temp_result$summary$filename))
}
# Prepare a Call to `rerddap::griddap()` for Data Retrieval
#
# This function constructs the necessary arguments for a `rerddap::griddap()` call to retrieve
# data from an ERDDAP server based on specified dimensions, stride, and fields. It checks and
# adjusts dimension arguments, validates data ranges for latitude and longitude, and builds
# a URL for the data request. This preparation includes parsing dimension arguments, handling
# field selections, and determining the correct endpoint URL.
#
# @param x An object returned by `rerddap::info()` that contains metadata about the dataset,
# including the base URL of the ERDDAP server and the dataset identifier.
# @param dimargs A named list specifying the dimensions and their ranges for the data retrieval.
# Each element of the list should be named according to the dimension it represents, and
# contain the range of values to request for that dimension.
# @param stride An integer or named list specifying the stride (step size) for each dimension,
# used to thin the data retrieval. For a single integer, the same stride is applied to all
# dimensions.
# @param fields A character vector specifying which fields (variables) to retrieve from the
# dataset. Can be a single variable name or 'all' for all available fields.
# @param url The base URL of the ERDDAP server from which to fetch the data.
#
# @return A list containing detailed information necessary for making a `rerddap::griddap()`
# call, including adjusted dimension arguments, parsed dimension ranges, selected fields,
# the base URL for the dataset, and the path to the NetCDF file that will contain the
# downloaded data.
#
# @examples
# # Assuming `x` is an info object for a specific dataset on an ERDDAP server:
# dimargs <- list(time = c('2020-01-01', '2020-12-31'), latitude = c(-90, 90), longitude = c(-180, 180))
# stride <- 1
# fields <- 'all'
# url <- "https://example.erddap.server/erddap/"
#
# call_info <- extract_rerddap_call(x, dimargs, stride, fields, url)
# # call_info can now be used with `do.call(rerddap::griddap, call_info)` or similar logic.
#
extract_rerddap_call <- function(x, dimargs, stride, fields, url) {
check_lat_text(dimargs)
check_lon_text(dimargs)
dimargs <- fix_dims(dimargs, .info = x)
check_lon_data_range(dimargs, x)
check_lat_data_range(dimargs, x)
d <- attr(x, "datasetid")
var <- field_handler(fields, x$variables$variable_name)
dims <- dimvars(x)
#store <- toggle_store(fmt, store)
pargs <- sapply(dims, function(y) parse_args(x, y, stride, dimargs))
dim_args <- list()
for (i in seq_along(dims)){
dim_args[[dims[i]]] <- paste0(dims[i], pargs[i])
}
#dim_args <- paste(temp_args, collapse = ',')
#args <- lapply(dims, function(y) {
# paste0(y, paste0(pargs, collapse = ""))
# })
#fmt <- match.arg(fmt, c("nc", "csv"))
fmt <- "nc"
lenURL <- nchar(url)
if (substr(url, lenURL, lenURL) != '/') {
url <- paste0(url, '/')
}
url_base <- sprintf("%sgriddap/%s.%s", url, d, fmt)
dimVals_extract <- get_dimVals(x, dimargs)
dimVals <- dimVals_extract$dimVals
nc_file <- dimVals_extract$nc_file
call_info <- list(dimargs = dimargs, dim_args = dim_args,
dimVals = dimVals, url_base = url_base,
fields = var, nc_file = nc_file)
return(call_info)
}
# Determine Split Indices for NetCDF File Dimensions
#
# This function calculates indices for splitting a NetCDF file into smaller segments along its
# dimensions (time, altitude, latitude, longitude). It's useful for segmenting large NetCDF files
# into more manageable pieces for analysis or for parallel processing tasks. The function
# determines the number of segments and the indices at which to split each dimension based on
# the provided split criteria.
#
# @param source_nc A list or object containing details about the NetCDF file's dimensions,
# including the length (number of elements) of each dimension (time, altitude, latitude,
# longitude).
# @param split A named list specifying the desired number of splits for each dimension.
# The names of the list should correspond to the dimensions of the NetCDF file (e.g., time,
# altitude, latitude, longitude).
#
# @return A list with two elements: `no_extract`, a data frame indicating the number of extracts
# (segments) to be made for each dimension; and `dim_indices`, a data frame containing the
# indices for each dimension at which the splits should occur. These indices can be used to
# segment the NetCDF file into smaller pieces.
#
# @examples
# source_nc <- list(dim = list(time = list(len = 365),
# altitude = list(len = 10),
# latitude = list(len = 180),
# longitude = list(len = 360)))
# split_criteria <- list(time = 4, altitude = 1, latitude = 2, longitude = 2)
#
# split_info <- define_split_nc(source_nc, split_criteria)
# print(split_info$no_extract)
# print(split_info$dim_indices)
#
#define_split_nc <- function(source_nc, split){
# no_time <- source_nc$dim[['time']]$len
# no_altitude <- source_nc$dim[['altitude']]$len
# no_latitude <- source_nc$dim[['latitude']]$len
# no_longitude <- source_nc$dim[['longitude']]$len
# indices <- split > 1
# split[indices] <- unlist(split[indices]) + 1
# time_indices <- as.integer(seq(1, no_time, length.out = split$time))
# altitude_indices <-as.integer(seq(1, no_altitude, length.out = split$altitude))
# latitude_indices <- as.integer(seq(1, no_latitude, length.out = split$latitude))
# longitude_indices <- as.integer(seq(1, no_longitude, length.out = split$longitude))
# no_time_extracts <- ifelse(length(time_indices) == 1, 1, length(time_indices) - 1)
# no_altitude_extracts <- ifelse(length(altitude_indices) == 1, 1, length(altitude_indices) - 1)
# no_latitude_extracts <- ifelse(length(latitude_indices) == 1, 1, length(latitude_indices) - 1)
# no_longitude_extracts <- ifelse(length(longitude_indices) == 1, 1, length(longitude_indices) - 1)
# no_extracts <- data.frame(time = no_time_extracts,
# altitude = no_altitude_extracts,
# latitude = no_latitude_extracts,
# longitude = no_longitude_extracts
# )
# dim_indices <- data.frame(time = time_indices,
# altitude = altitude_indices,
# latitude = latitude_indices,
# longitude = longitude_indices
# )
# return(list(no_extract = no_extracts, dim_indices = dim_indices))
#}
define_split_nc <- function(source_nc, split) {
# Get dimension names and lengths directly from source_nc
dim_names <- names(source_nc$dim)
#dim_lengths <- sapply(dim_names, function(d) source_nc$dim[[d]]$len)
dim_lengths <- vapply(dim_names, function(d) source_nc$dim[[d]]$len,
FUN.VALUE = numeric(1))
# For any dimension not specified in split, default to 1 (no split)
split_vals <- stats::setNames(rep(1L, length(dim_names)), dim_names)
split_vals[names(split)] <- unlist(split[names(split)])
# Increment splits > 1 by 1 (to get correct boundary indices)
split_vals[split_vals > 1] <- split_vals[split_vals > 1] + 1
# Calculate indices for each dimension
dim_indices_list <- lapply(dim_names, function(d) {
as.integer(seq(1, dim_lengths[d], length.out = split_vals[d]))
})
names(dim_indices_list) <- dim_names
# Calculate number of extracts per dimension
no_extracts_list <- lapply(dim_names, function(d) {
idx <- dim_indices_list[[d]]
ifelse(length(idx) == 1, 1L, length(idx) - 1L)
})
names(no_extracts_list) <- dim_names
# Pad shorter vectors with NA so data.frame() works when lengths differ
# max_len <- max(sapply(dim_indices_list, length))
max_len <- max(vapply(dim_indices_list, length, FUN.VALUE = integer(1)))
dim_indices_padded <- lapply(dim_indices_list, function(x) {
length(x) <- max_len
x
})
return(list(
no_extract = as.data.frame(no_extracts_list),
dim_indices = as.data.frame(dim_indices_padded)
))
}
# Create a New NetCDF File with Specified Fields from a Source File
#
# This function creates a new NetCDF file, copying dimensions from a source NetCDF file and
# including only the specified fields. It's useful for extracting a subset of variables from a
# large NetCDF file and saving them into a new file. The function handles the definition of
# dimensions and variables based on the source file and the provided field list, including units
# and data type precision for each field.
#
# @param data_info A data structure containing metadata about the variables to be included in the
# new NetCDF file. This should include data types and units for each variable specified in `fields`.
# @param fields A vector of strings specifying the names of the variables to include in the new
# NetCDF file. These should correspond to variable names in the source NetCDF file and the
# `data_info` metadata.
# @param source_file A string specifying the path to the source NetCDF file from which dimensions
# and variable metadata will be copied.
# @param destination_file A string specifying the path where the new NetCDF file will be created.
#
# @return This function does not return a value but creates a new NetCDF file at `destination_file`
# containing the variables specified in `fields` with dimensions and metadata copied from
# `source_file`.
#
# @examples
# data_info <- list(
# alldata = list(
# temperature = list(data_type = "double", attribute_name = c("units"), value = c("Celsius"))
# )
# )
# fields <- c("temperature")
# source_file <- "path/to/source_file.nc"
# destination_file <- "path/to/destination_file.nc"
#
# create_nc_file(data_info, fields, source_file, destination_file)
# # This will create 'destination_file.nc' containing only the 'temperature' variable.
#
create_nc_file <- function(data_info, fields, source_file, destination_file) {
source_nc <- ncdf4::nc_open(source_file)
on.exit(ncdf4::nc_close(source_nc), add = TRUE)
# Copy dimensions from source
source_dim <- lapply(rev(source_nc$dim), function(d) {
ncdf4::ncdim_def(d$name, d$units, d$vals)
})
# Define output variables
source_var <- lapply(fields, function(var_name) {
attrs <- data_info$alldata[[var_name]]
ncdf4::ncvar_def(
name = var_name,
units = attrs$value[attrs$attribute_name == "units"],
dim = source_dim,
missval = NA,
prec = attrs$data_type[1]
)
}) |> stats::setNames(fields)
dest_nc <- ncdf4::nc_create(destination_file, vars = source_var, force_v4 = TRUE)
on.exit(ncdf4::nc_close(dest_nc), add = TRUE)
}
# ----------------------------------------
# Function to copy attributes
# Copy Attributes from Source to Destination NetCDF File
#
# This function copies global attributes and specified variable attributes from a source NetCDF
# file to a destination NetCDF file. It is useful for replicating metadata when creating a new
# NetCDF file based on an existing file, ensuring that the new file retains relevant contextual
# information and variable-specific attributes.
#
# @param data_info A data structure containing metadata and attribute values for the variables
# specified in `fields`. This metadata is used to copy variable-specific attributes to the
# destination file.
# @param fields A vector of strings specifying the names of the variables for which attributes
# should be copied from the source to the destination file. These should correspond to variable
# names in both the source file and the `data_info` metadata structure.
# @param source_file A string specifying the path to the source NetCDF file from which attributes
# will be copied.
# @param destination_file A string specifying the path to the destination NetCDF file where the
# attributes will be copied to.
#
# @return This function does not return a value but modifies the destination NetCDF file by
# copying attributes for global scope and for the specified variables from the source file.
#
# @examples
# data_info <- list(
# alldata = list(
# temperature = list(values = list(units = "Celsius", long_name = "Sea Surface Temperature")),
# salinity = list(values = list(units = "PSU", long_name = "Sea Surface Salinity"))
# )
# )
# fields <- c("temperature", "salinity")
# source_file <- "path/to/source_file.nc"
# destination_file <- "path/to/destination_file.nc"
#
# copy_attributes(data_info, fields, source_file, destination_file)
# # This will copy global attributes and attributes for 'temperature' and 'salinity' variables.
#
copy_attributes <- function(data_info, fields, source_file, destination_file) {
source_nc <- ncdf4::nc_open(source_file)
on.exit(ncdf4::nc_close(source_nc), add = TRUE)
dest_nc <- ncdf4::nc_open(destination_file, write = TRUE)
on.exit(ncdf4::nc_close(dest_nc), add = TRUE)
# Copy global attributes from source
global_attrs <- ncdf4::ncatt_get(source_nc, 0)
lapply(names(global_attrs), function(attr_name) {
ncdf4::ncatt_put(dest_nc, 0, attr_name, global_attrs[[attr_name]])
})
# Copy variable attributes from data_info (skipping first and _FillValue)
lapply(fields, function(var_name) {
var_attrs <- data_info$alldata[[var_name]]$values[-1]
var_attrs <- var_attrs[names(var_attrs) != "_FillValue"]
lapply(names(var_attrs), function(attr) {
ncdf4::ncatt_put(dest_nc, var_name, attr, var_attrs[[attr]])
})
})
invisible(NULL)
}
#############################
## from package 'rerddap'
############################
field_handler <- function(x, y){
x <- match.arg(x, c(y, "none", "all"), TRUE)
if (length(x) == 1 && x == "all") {
y
} else if (all(x %in% y) || x == "none") {
x
}
}
check_dims <- function(dimargs, .info) {
if (any(lengths(dimargs )!= 2)) {
#print("All coordinate bounds must be of length 2, even if same value")
#print("Present values are:")
#print(dimargs)
#stop("rerddap halted", call. = FALSE)
cli::cli_warn(c(
"All coordinate bounds must be of length 2, even if the same value.",
"i" = "Present values: {.val {dimargs}}"
))
return(NULL)
}
if (!all(names(dimargs) %in% dimvars(.info))) {
stop(sprintf("Some input dimensions (%s) don't match those in dataset (%s)",
paste0(names(dimargs), collapse = ", "),
paste0(dimvars(.info), collapse = ", ")), call. = FALSE)
}
}
check_lon_text <- function(dimargs) {
if (!is.null(dimargs$longitude)) {
#if (any(sapply(dimargs$longitude, class) == "character")) {
#txt <- dimargs$longitude[sapply(dimargs$longitude, class) == "character"]
if (any(vapply(dimargs$longitude, class, FUN.VALUE = character(1)) == "character")) {
txt <- dimargs$longitude[vapply(dimargs$longitude, class,
FUN.VALUE = character(1)) == "character"]
if (!all(grepl("last", txt))) stop("Only text values allowed are 'last' & variants on that", call. = FALSE)
}
}
}
check_lat_text <- function(dimargs) {
if (!is.null(dimargs$latitude)) {
#if (any(sapply(dimargs$latitude, class) == "character")) {
#txt <- dimargs$latitude[sapply(dimargs$latitude, class) == "character"]
if (any(vapply(dimargs$latitude, class, FUN.VALUE = character(1)) == "character")) {
txt <- dimargs$latitude[vapply(dimargs$latitude, class,
FUN.VALUE = character(1)) == "character"]
if (!all(grepl("last", txt))) stop("Only text values allowed are 'last' & variants on that", call. = FALSE)
}
}
}
is_lon_text <- function(dimargs) {
if (!is.null(dimargs$longitude)) {
#any(sapply(dimargs$longitude, class) == "character")
any(vapply(dimargs$longitude, class, FUN.VALUE = character(1)) == "character")
} else {
FALSE
}
}
is_lat_text <- function(dimargs) {
if (!is.null(dimargs$latitude)) {
# any(sapply(dimargs$latitude, class) == "character")
any(vapply(dimargs$latitude, class, FUN.VALUE = character(1)) == "character")
} else {
FALSE
}
}
check_time_range <- function(dimargs, x) {
# if(!class(dimargs$time) == 'character'){
if(!is.character(dimargs$time)){
print('time must be given as character strings')
print('you are passing ', paste0(class(dimargs$time)))
stop('rerddap halted', call. = FALSE)
}
global <- x$alldata$NC_GLOBAL
tt <- global[ global$attribute_name %in%c('time_coverage_end','time_coverage_start'), "value", ]
tt <- rev(tt)
if (!('last' %in% dimargs$time)){
if((dimargs$time[1] < tt[1]) | (dimargs$time[2] > tt[2])) {
#print('time bounds are out of range')
#print('You gave: ')
#print(dimargs$time)
#print("Dataset times are: ")
#print(tt)
#stop('rerddap halted', call. = FALSE)
cli::cli_warn(c(
"Requested time bounds are outside the dataset range.",
"x" = "You requested: {.val {dimargs$time[1]}} to {.val {dimargs$time[2]}}.",
"i" = "Dataset range: {.val {tt[1]}} to {.val {tt[2]}}."
))
return(NULL)
}
}
}
check_lon_data_range <- function(dimargs, .info) {
if (!is.null(dimargs$longitude)) {
val <- .info$alldata$longitude[ .info$alldata$longitude$attribute_name == "actual_range", "value"]
val2 <- as.numeric(strtrim(strsplit(val, ",")[[1]]))
if (!is_lon_text(dimargs)) {
if (max(dimargs$longitude) > max(val2) || min(dimargs$longitude) < min(val2)) {
stop(sprintf("One or both longitude values (%s) outside data range (%s)",
paste0(dimargs$longitude, collapse = ", "),
paste0(val2, collapse = ", ")), call. = FALSE)
}
}
}
}
check_lat_data_range <- function(dimargs, .info) {
if (!is.null(dimargs$latitude)) {
val <- .info$alldata$latitude[ .info$alldata$latitude$attribute_name == "actual_range", "value"]
val2 <- as.numeric(strtrim(strsplit(val, ",")[[1]]))
if (!is_lat_text(dimargs)) {
if (max(dimargs$latitude) > max(val2) || min(dimargs$latitude) < min(val2)) {
stop(sprintf("One or both latitude values (%s) outside data range (%s)",
paste0(dimargs$latitude, collapse = ", "),
paste0(val2, collapse = ", ")), call. = FALSE)
}
}
}
}
fix_dims <- function(dimargs, .info) {
for (i in seq_along(dimargs)) {
tmp <- dimargs[[i]]
nm <- names(dimargs[i])
tmp <- grep("last+", tmp, value = TRUE, invert = TRUE)
if (nm == "time") {
tmp <- as.Date(tmp)
}
val <- .info$alldata[[nm]][ .info$alldata[[nm]]$attribute_name == "actual_range", "value"]
temp_val <- strsplit(val, ",")[[1]]
temp_val <- gsub("^\\s+|\\s+$", "", temp_val)
val2 <- as.numeric(temp_val)
# val2 <- as.numeric(strtrim(strsplit(val, ",")[[1]]))
if (length(tmp) != 0) {
if (which.min(val2) != which.min(tmp)) {
dimargs[[i]] <- rev(dimargs[[i]])
}
}
## new
# if (nm %in% c('latitude', 'longitude')) {
if (nm != 'time') {
z <- unlist(strsplit(.info$alldata[[nm]]$value[1], ","))
spacing <- as.numeric(unlist(strsplit(z[3], "=")[[1]])[2])
if ((!is.na(spacing)) & (spacing < 0)) {
if (!(dimargs[[i]][1] > dimargs[[i]][2])) {
dimargs[[i]] <- rev(dimargs[[i]])
}
}
}
}
dimargs
}
parse_args <- function(.info, dim, s, dimargs, wname = FALSE){
tmp <- if (dim %in% names(dimargs)) {
dimargs[[dim]]
} else {
if (dim == "time") {
times <- c(getvar(.info, "time_coverage_start"), getvar(.info, "time_coverage_end"))
sprintf('[(%s):%s:(%s)]', times[1], s, times[2])
} else {
actrange <- foo(.info$alldata[[dim]], "actual_range")
gsub("\\s+", "", strsplit(actrange, ",")[[1]])
}
}
if (length(s) > 1) {
if (!length(s) == length(dimvars(.info))) stop("Your stride vector must equal length of dimension variables", call. = FALSE)
names(s) <- dimvars(.info)
if (!wname) {
sprintf('[(%s):%s:(%s)]', tmp[1], s[[dim]], tmp[2])
} else {
sprintf('%s[(%s):%s:(%s)]', dim, tmp[1], s[[dim]], tmp[2])
}
} else {
if (!wname) {
if (length(tmp) == 1) {
tmp
} else {
sprintf('[(%s):%s:(%s)]', tmp[1], s, tmp[2])
}
} else {
if (length(tmp) == 1) {
tmp
} else {
sprintf('%s[(%s):%s:(%s)]', dim, tmp[1], s, tmp[2])
}
}
}
}
getvar <- function(x, y){
x$alldata$NC_GLOBAL[ x$alldata$NC_GLOBAL$attribute_name == y, "value"]
}
getvars <- function(x){
vars <- names(x$alldata)
vars[ !vars %in% c("NC_GLOBAL", "time", x$variables$variable_name) ]
}
getallvars <- function(x){
vars <- names(x$alldata)
vars[ !vars %in% "NC_GLOBAL" ]
}
dimvars <- function(x){
vars <- names(x$alldata)
vars[ !vars %in% c("NC_GLOBAL", x$variables$variable_name) ]
}
foo <- function(x, y){
x[ x$attribute_name == y, "value"]
}
`%||%` <- function (x, y) {
if (is.null(x) || length(x) == 0) y else x
}
strextract <- function(str, pattern) regmatches(str, regexpr(pattern, str))
strtrim <- function(str) gsub("^\\s+|\\s+$", "", str)
Try the rerddapUtils package in your browser
Any scripts or data that you put into this service are public.
rerddapUtils documentation built on Oct. 30, 2026, 1:07 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions strtrim strextract foo dimvars getallvars getvars getvar parse_args fix_dims check_lat_data_range check_lon_data_range check_time_range is_lat_text is_lon_text check_lat_text check_lon_text check_dims field_handler copy_attributes create_nc_file define_split_nc extract_rerddap_call get_dimVals
# Retrieve Dimension Values for a Dataset from an ERDDAP Server
#
# This function queries an ERDDAP server for the dimension values of a specified dataset.
# It constructs a request to the server without fetching the actual data (fields set to 'none' and read set to FALSE),
# aiming to retrieve metadata about the dataset dimensions. It is useful for understanding the range of
# values each dimension covers, such as time, depth, latitude, and longitude.
#
# @param x An object returned by `rerddap::info()` that contains metadata about the dataset,
# including the base URL of the ERDDAP server and the dataset identifier.
# @param dimargs A list specifying the dimensions and their ranges for which to retrieve values.
# Each element of the list should be named according to the dimension it represents.
#
# @return A list containing two elements: `dimVals`, a list of the retrieved dimension values,
# where each element is named after a dimension and contains the values for that dimension;
# and `nc_file`, a string indicating the filename of the NetCDF file that would contain the
# data (if it were to be downloaded).
#
# @examples
# # Assuming `x` is a valid object returned by `rerddap::info()` for a dataset:
# dimargs <- list(time = c('2020-01-01', '2020-12-31'), depth = c(0, 100))
# dimVals <- get_dimVals(x, dimargs)
# print(dimVals$dimVals)
# print(dimVals$nc_file)
#
get_dimVals <- function(x, dimargs) {
base_url <- paste0(x$base_url, '/')
call_args <- list(datasetx = x)
call_args <- c(call_args, dimargs)
# for (i in seq_along(dimargs)){
# call_args <- c(call_args, dimargs[i])
# names(call_args)[i + 1] <- names(dimargs)[i]
# }
call_args$fields <- 'none'
call_args$read <- FALSE
call_args$url <- base_url
temp_result <- do.call(rerddap::griddap, call_args)
dimVals <- lapply(temp_result$summary$dim, `[[`, "vals")
# dimVals = list()
# for (i in seq_along(temp_result$summary$dim)){
# temp <- temp_result$summary$dim[[i]]
# dimVals[[temp$name]] <- temp$vals
# }
if ('time' %in% names(dimVals)) {
dimVals$time <- as.character(as.POSIXlt(dimVals$time, origin = '1970-01-01', tz = "GMT"))
}
return(list(dimVals = dimVals, nc_file = temp_result$summary$filename))
}
# Prepare a Call to `rerddap::griddap()` for Data Retrieval
#
# This function constructs the necessary arguments for a `rerddap::griddap()` call to retrieve
# data from an ERDDAP server based on specified dimensions, stride, and fields. It checks and
# adjusts dimension arguments, validates data ranges for latitude and longitude, and builds
# a URL for the data request. This preparation includes parsing dimension arguments, handling
# field selections, and determining the correct endpoint URL.
#
# @param x An object returned by `rerddap::info()` that contains metadata about the dataset,
# including the base URL of the ERDDAP server and the dataset identifier.
# @param dimargs A named list specifying the dimensions and their ranges for the data retrieval.
# Each element of the list should be named according to the dimension it represents, and
# contain the range of values to request for that dimension.
# @param stride An integer or named list specifying the stride (step size) for each dimension,
# used to thin the data retrieval. For a single integer, the same stride is applied to all
# dimensions.
# @param fields A character vector specifying which fields (variables) to retrieve from the
# dataset. Can be a single variable name or 'all' for all available fields.
# @param url The base URL of the ERDDAP server from which to fetch the data.
#
# @return A list containing detailed information necessary for making a `rerddap::griddap()`
# call, including adjusted dimension arguments, parsed dimension ranges, selected fields,
# the base URL for the dataset, and the path to the NetCDF file that will contain the
# downloaded data.
#
# @examples
# # Assuming `x` is an info object for a specific dataset on an ERDDAP server:
# dimargs <- list(time = c('2020-01-01', '2020-12-31'), latitude = c(-90, 90), longitude = c(-180, 180))
# stride <- 1
# fields <- 'all'
# url <- "https://example.erddap.server/erddap/"
#
# call_info <- extract_rerddap_call(x, dimargs, stride, fields, url)
# # call_info can now be used with `do.call(rerddap::griddap, call_info)` or similar logic.
#
extract_rerddap_call <- function(x, dimargs, stride, fields, url) {
check_lat_text(dimargs)
check_lon_text(dimargs)
dimargs <- fix_dims(dimargs, .info = x)
check_lon_data_range(dimargs, x)
check_lat_data_range(dimargs, x)
d <- attr(x, "datasetid")
var <- field_handler(fields, x$variables$variable_name)
dims <- dimvars(x)
#store <- toggle_store(fmt, store)
pargs <- sapply(dims, function(y) parse_args(x, y, stride, dimargs))
dim_args <- list()
for (i in seq_along(dims)){
dim_args[[dims[i]]] <- paste0(dims[i], pargs[i])
}
#dim_args <- paste(temp_args, collapse = ',')
#args <- lapply(dims, function(y) {
# paste0(y, paste0(pargs, collapse = ""))
# })
#fmt <- match.arg(fmt, c("nc", "csv"))
fmt <- "nc"
lenURL <- nchar(url)
if (substr(url, lenURL, lenURL) != '/') {
url <- paste0(url, '/')
}
url_base <- sprintf("%sgriddap/%s.%s", url, d, fmt)
dimVals_extract <- get_dimVals(x, dimargs)
dimVals <- dimVals_extract$dimVals
nc_file <- dimVals_extract$nc_file
call_info <- list(dimargs = dimargs, dim_args = dim_args,
dimVals = dimVals, url_base = url_base,
fields = var, nc_file = nc_file)
return(call_info)
}
# Determine Split Indices for NetCDF File Dimensions
#
# This function calculates indices for splitting a NetCDF file into smaller segments along its
# dimensions (time, altitude, latitude, longitude). It's useful for segmenting large NetCDF files
# into more manageable pieces for analysis or for parallel processing tasks. The function
# determines the number of segments and the indices at which to split each dimension based on
# the provided split criteria.
#
# @param source_nc A list or object containing details about the NetCDF file's dimensions,
# including the length (number of elements) of each dimension (time, altitude, latitude,
# longitude).
# @param split A named list specifying the desired number of splits for each dimension.
# The names of the list should correspond to the dimensions of the NetCDF file (e.g., time,
# altitude, latitude, longitude).
#
# @return A list with two elements: `no_extract`, a data frame indicating the number of extracts
# (segments) to be made for each dimension; and `dim_indices`, a data frame containing the
# indices for each dimension at which the splits should occur. These indices can be used to
# segment the NetCDF file into smaller pieces.
#
# @examples
# source_nc <- list(dim = list(time = list(len = 365),
# altitude = list(len = 10),
# latitude = list(len = 180),
# longitude = list(len = 360)))
# split_criteria <- list(time = 4, altitude = 1, latitude = 2, longitude = 2)
#
# split_info <- define_split_nc(source_nc, split_criteria)
# print(split_info$no_extract)
# print(split_info$dim_indices)
#
#define_split_nc <- function(source_nc, split){
# no_time <- source_nc$dim[['time']]$len
# no_altitude <- source_nc$dim[['altitude']]$len
# no_latitude <- source_nc$dim[['latitude']]$len
# no_longitude <- source_nc$dim[['longitude']]$len
# indices <- split > 1
# split[indices] <- unlist(split[indices]) + 1
# time_indices <- as.integer(seq(1, no_time, length.out = split$time))
# altitude_indices <-as.integer(seq(1, no_altitude, length.out = split$altitude))
# latitude_indices <- as.integer(seq(1, no_latitude, length.out = split$latitude))
# longitude_indices <- as.integer(seq(1, no_longitude, length.out = split$longitude))
# no_time_extracts <- ifelse(length(time_indices) == 1, 1, length(time_indices) - 1)
# no_altitude_extracts <- ifelse(length(altitude_indices) == 1, 1, length(altitude_indices) - 1)
# no_latitude_extracts <- ifelse(length(latitude_indices) == 1, 1, length(latitude_indices) - 1)
# no_longitude_extracts <- ifelse(length(longitude_indices) == 1, 1, length(longitude_indices) - 1)
# no_extracts <- data.frame(time = no_time_extracts,
# altitude = no_altitude_extracts,
# latitude = no_latitude_extracts,
# longitude = no_longitude_extracts
# )
# dim_indices <- data.frame(time = time_indices,
# altitude = altitude_indices,
# latitude = latitude_indices,
# longitude = longitude_indices
# )
# return(list(no_extract = no_extracts, dim_indices = dim_indices))
#}
define_split_nc <- function(source_nc, split) {
# Get dimension names and lengths directly from source_nc
dim_names <- names(source_nc$dim)
#dim_lengths <- sapply(dim_names, function(d) source_nc$dim[[d]]$len)
dim_lengths <- vapply(dim_names, function(d) source_nc$dim[[d]]$len,
FUN.VALUE = numeric(1))
# For any dimension not specified in split, default to 1 (no split)
split_vals <- stats::setNames(rep(1L, length(dim_names)), dim_names)
split_vals[names(split)] <- unlist(split[names(split)])
# Increment splits > 1 by 1 (to get correct boundary indices)
split_vals[split_vals > 1] <- split_vals[split_vals > 1] + 1
# Calculate indices for each dimension
dim_indices_list <- lapply(dim_names, function(d) {
as.integer(seq(1, dim_lengths[d], length.out = split_vals[d]))
})
names(dim_indices_list) <- dim_names
# Calculate number of extracts per dimension
no_extracts_list <- lapply(dim_names, function(d) {
idx <- dim_indices_list[[d]]
ifelse(length(idx) == 1, 1L, length(idx) - 1L)
})
names(no_extracts_list) <- dim_names
# Pad shorter vectors with NA so data.frame() works when lengths differ
# max_len <- max(sapply(dim_indices_list, length))
max_len <- max(vapply(dim_indices_list, length, FUN.VALUE = integer(1)))
dim_indices_padded <- lapply(dim_indices_list, function(x) {
length(x) <- max_len
x
})
return(list(
no_extract = as.data.frame(no_extracts_list),
dim_indices = as.data.frame(dim_indices_padded)
))
}
# Create a New NetCDF File with Specified Fields from a Source File
#
# This function creates a new NetCDF file, copying dimensions from a source NetCDF file and
# including only the specified fields. It's useful for extracting a subset of variables from a
# large NetCDF file and saving them into a new file. The function handles the definition of
# dimensions and variables based on the source file and the provided field list, including units
# and data type precision for each field.
#
# @param data_info A data structure containing metadata about the variables to be included in the
# new NetCDF file. This should include data types and units for each variable specified in `fields`.
# @param fields A vector of strings specifying the names of the variables to include in the new
# NetCDF file. These should correspond to variable names in the source NetCDF file and the
# `data_info` metadata.
# @param source_file A string specifying the path to the source NetCDF file from which dimensions
# and variable metadata will be copied.
# @param destination_file A string specifying the path where the new NetCDF file will be created.
#
# @return This function does not return a value but creates a new NetCDF file at `destination_file`
# containing the variables specified in `fields` with dimensions and metadata copied from
# `source_file`.
#
# @examples
# data_info <- list(
# alldata = list(
# temperature = list(data_type = "double", attribute_name = c("units"), value = c("Celsius"))
# )
# )
# fields <- c("temperature")
# source_file <- "path/to/source_file.nc"
# destination_file <- "path/to/destination_file.nc"
#
# create_nc_file(data_info, fields, source_file, destination_file)
# # This will create 'destination_file.nc' containing only the 'temperature' variable.
#
create_nc_file <- function(data_info, fields, source_file, destination_file) {
source_nc <- ncdf4::nc_open(source_file)
on.exit(ncdf4::nc_close(source_nc), add = TRUE)
# Copy dimensions from source
source_dim <- lapply(rev(source_nc$dim), function(d) {
ncdf4::ncdim_def(d$name, d$units, d$vals)
})
# Define output variables
source_var <- lapply(fields, function(var_name) {
attrs <- data_info$alldata[[var_name]]
ncdf4::ncvar_def(
name = var_name,
units = attrs$value[attrs$attribute_name == "units"],
dim = source_dim,
missval = NA,
prec = attrs$data_type[1]
)
}) |> stats::setNames(fields)
dest_nc <- ncdf4::nc_create(destination_file, vars = source_var, force_v4 = TRUE)
on.exit(ncdf4::nc_close(dest_nc), add = TRUE)
}
# ----------------------------------------
# Function to copy attributes
# Copy Attributes from Source to Destination NetCDF File
#
# This function copies global attributes and specified variable attributes from a source NetCDF
# file to a destination NetCDF file. It is useful for replicating metadata when creating a new
# NetCDF file based on an existing file, ensuring that the new file retains relevant contextual
# information and variable-specific attributes.
#
# @param data_info A data structure containing metadata and attribute values for the variables
# specified in `fields`. This metadata is used to copy variable-specific attributes to the
# destination file.
# @param fields A vector of strings specifying the names of the variables for which attributes
# should be copied from the source to the destination file. These should correspond to variable
# names in both the source file and the `data_info` metadata structure.
# @param source_file A string specifying the path to the source NetCDF file from which attributes
# will be copied.
# @param destination_file A string specifying the path to the destination NetCDF file where the
# attributes will be copied to.
#
# @return This function does not return a value but modifies the destination NetCDF file by
# copying attributes for global scope and for the specified variables from the source file.
#
# @examples
# data_info <- list(
# alldata = list(
# temperature = list(values = list(units = "Celsius", long_name = "Sea Surface Temperature")),
# salinity = list(values = list(units = "PSU", long_name = "Sea Surface Salinity"))
# )
# )
# fields <- c("temperature", "salinity")
# source_file <- "path/to/source_file.nc"
# destination_file <- "path/to/destination_file.nc"
#
# copy_attributes(data_info, fields, source_file, destination_file)
# # This will copy global attributes and attributes for 'temperature' and 'salinity' variables.
#
copy_attributes <- function(data_info, fields, source_file, destination_file) {
source_nc <- ncdf4::nc_open(source_file)
on.exit(ncdf4::nc_close(source_nc), add = TRUE)
dest_nc <- ncdf4::nc_open(destination_file, write = TRUE)
on.exit(ncdf4::nc_close(dest_nc), add = TRUE)
# Copy global attributes from source
global_attrs <- ncdf4::ncatt_get(source_nc, 0)
lapply(names(global_attrs), function(attr_name) {
ncdf4::ncatt_put(dest_nc, 0, attr_name, global_attrs[[attr_name]])
})
# Copy variable attributes from data_info (skipping first and _FillValue)
lapply(fields, function(var_name) {
var_attrs <- data_info$alldata[[var_name]]$values[-1]
var_attrs <- var_attrs[names(var_attrs) != "_FillValue"]
lapply(names(var_attrs), function(attr) {
ncdf4::ncatt_put(dest_nc, var_name, attr, var_attrs[[attr]])
})
})
invisible(NULL)
}
#############################
## from package 'rerddap'
############################
field_handler <- function(x, y){
x <- match.arg(x, c(y, "none", "all"), TRUE)
if (length(x) == 1 && x == "all") {
y
} else if (all(x %in% y) || x == "none") {
x
}
}
check_dims <- function(dimargs, .info) {
if (any(lengths(dimargs )!= 2)) {
#print("All coordinate bounds must be of length 2, even if same value")
#print("Present values are:")
#print(dimargs)
#stop("rerddap halted", call. = FALSE)
cli::cli_warn(c(
"All coordinate bounds must be of length 2, even if the same value.",
"i" = "Present values: {.val {dimargs}}"
))
return(NULL)
}
if (!all(names(dimargs) %in% dimvars(.info))) {
stop(sprintf("Some input dimensions (%s) don't match those in dataset (%s)",
paste0(names(dimargs), collapse = ", "),
paste0(dimvars(.info), collapse = ", ")), call. = FALSE)
}
}
check_lon_text <- function(dimargs) {
if (!is.null(dimargs$longitude)) {
#if (any(sapply(dimargs$longitude, class) == "character")) {
#txt <- dimargs$longitude[sapply(dimargs$longitude, class) == "character"]
if (any(vapply(dimargs$longitude, class, FUN.VALUE = character(1)) == "character")) {
txt <- dimargs$longitude[vapply(dimargs$longitude, class,
FUN.VALUE = character(1)) == "character"]
if (!all(grepl("last", txt))) stop("Only text values allowed are 'last' & variants on that", call. = FALSE)
}
}
}
check_lat_text <- function(dimargs) {
if (!is.null(dimargs$latitude)) {
#if (any(sapply(dimargs$latitude, class) == "character")) {
#txt <- dimargs$latitude[sapply(dimargs$latitude, class) == "character"]
if (any(vapply(dimargs$latitude, class, FUN.VALUE = character(1)) == "character")) {
txt <- dimargs$latitude[vapply(dimargs$latitude, class,
FUN.VALUE = character(1)) == "character"]
if (!all(grepl("last", txt))) stop("Only text values allowed are 'last' & variants on that", call. = FALSE)
}
}
}
is_lon_text <- function(dimargs) {
if (!is.null(dimargs$longitude)) {
#any(sapply(dimargs$longitude, class) == "character")
any(vapply(dimargs$longitude, class, FUN.VALUE = character(1)) == "character")
} else {
FALSE
}
}
is_lat_text <- function(dimargs) {
if (!is.null(dimargs$latitude)) {
# any(sapply(dimargs$latitude, class) == "character")
any(vapply(dimargs$latitude, class, FUN.VALUE = character(1)) == "character")
} else {
FALSE
}
}
check_time_range <- function(dimargs, x) {
# if(!class(dimargs$time) == 'character'){
if(!is.character(dimargs$time)){
print('time must be given as character strings')
print('you are passing ', paste0(class(dimargs$time)))
stop('rerddap halted', call. = FALSE)
}
global <- x$alldata$NC_GLOBAL
tt <- global[ global$attribute_name %in%c('time_coverage_end','time_coverage_start'), "value", ]
tt <- rev(tt)
if (!('last' %in% dimargs$time)){
if((dimargs$time[1] < tt[1]) | (dimargs$time[2] > tt[2])) {
#print('time bounds are out of range')
#print('You gave: ')
#print(dimargs$time)
#print("Dataset times are: ")
#print(tt)
#stop('rerddap halted', call. = FALSE)
cli::cli_warn(c(
"Requested time bounds are outside the dataset range.",
"x" = "You requested: {.val {dimargs$time[1]}} to {.val {dimargs$time[2]}}.",
"i" = "Dataset range: {.val {tt[1]}} to {.val {tt[2]}}."
))
return(NULL)
}
}
}
check_lon_data_range <- function(dimargs, .info) {
if (!is.null(dimargs$longitude)) {
val <- .info$alldata$longitude[ .info$alldata$longitude$attribute_name == "actual_range", "value"]
val2 <- as.numeric(strtrim(strsplit(val, ",")[[1]]))
if (!is_lon_text(dimargs)) {
if (max(dimargs$longitude) > max(val2) || min(dimargs$longitude) < min(val2)) {
stop(sprintf("One or both longitude values (%s) outside data range (%s)",
paste0(dimargs$longitude, collapse = ", "),
paste0(val2, collapse = ", ")), call. = FALSE)
}
}
}
}
check_lat_data_range <- function(dimargs, .info) {
if (!is.null(dimargs$latitude)) {
val <- .info$alldata$latitude[ .info$alldata$latitude$attribute_name == "actual_range", "value"]
val2 <- as.numeric(strtrim(strsplit(val, ",")[[1]]))
if (!is_lat_text(dimargs)) {
if (max(dimargs$latitude) > max(val2) || min(dimargs$latitude) < min(val2)) {
stop(sprintf("One or both latitude values (%s) outside data range (%s)",
paste0(dimargs$latitude, collapse = ", "),
paste0(val2, collapse = ", ")), call. = FALSE)
}
}
}
}
fix_dims <- function(dimargs, .info) {
for (i in seq_along(dimargs)) {
tmp <- dimargs[[i]]
nm <- names(dimargs[i])
tmp <- grep("last+", tmp, value = TRUE, invert = TRUE)
if (nm == "time") {
tmp <- as.Date(tmp)
}
val <- .info$alldata[[nm]][ .info$alldata[[nm]]$attribute_name == "actual_range", "value"]
temp_val <- strsplit(val, ",")[[1]]
temp_val <- gsub("^\\s+|\\s+$", "", temp_val)
val2 <- as.numeric(temp_val)
# val2 <- as.numeric(strtrim(strsplit(val, ",")[[1]]))
if (length(tmp) != 0) {
if (which.min(val2) != which.min(tmp)) {
dimargs[[i]] <- rev(dimargs[[i]])
}
}
## new
# if (nm %in% c('latitude', 'longitude')) {
if (nm != 'time') {
z <- unlist(strsplit(.info$alldata[[nm]]$value[1], ","))
spacing <- as.numeric(unlist(strsplit(z[3], "=")[[1]])[2])
if ((!is.na(spacing)) & (spacing < 0)) {
if (!(dimargs[[i]][1] > dimargs[[i]][2])) {
dimargs[[i]] <- rev(dimargs[[i]])
}
}
}
}
dimargs
}
parse_args <- function(.info, dim, s, dimargs, wname = FALSE){
tmp <- if (dim %in% names(dimargs)) {
dimargs[[dim]]
} else {
if (dim == "time") {
times <- c(getvar(.info, "time_coverage_start"), getvar(.info, "time_coverage_end"))
sprintf('[(%s):%s:(%s)]', times[1], s, times[2])
} else {
actrange <- foo(.info$alldata[[dim]], "actual_range")
gsub("\\s+", "", strsplit(actrange, ",")[[1]])
}
}
if (length(s) > 1) {
if (!length(s) == length(dimvars(.info))) stop("Your stride vector must equal length of dimension variables", call. = FALSE)
names(s) <- dimvars(.info)
if (!wname) {
sprintf('[(%s):%s:(%s)]', tmp[1], s[[dim]], tmp[2])
} else {
sprintf('%s[(%s):%s:(%s)]', dim, tmp[1], s[[dim]], tmp[2])
}
} else {
if (!wname) {
if (length(tmp) == 1) {
tmp
} else {
sprintf('[(%s):%s:(%s)]', tmp[1], s, tmp[2])
}
} else {
if (length(tmp) == 1) {
tmp
} else {
sprintf('%s[(%s):%s:(%s)]', dim, tmp[1], s, tmp[2])
}
}
}
}
getvar <- function(x, y){
x$alldata$NC_GLOBAL[ x$alldata$NC_GLOBAL$attribute_name == y, "value"]
}
getvars <- function(x){
vars <- names(x$alldata)
vars[ !vars %in% c("NC_GLOBAL", "time", x$variables$variable_name) ]
}
getallvars <- function(x){
vars <- names(x$alldata)
vars[ !vars %in% "NC_GLOBAL" ]
}
dimvars <- function(x){
vars <- names(x$alldata)
vars[ !vars %in% c("NC_GLOBAL", x$variables$variable_name) ]
}
foo <- function(x, y){
x[ x$attribute_name == y, "value"]
}
`%||%` <- function (x, y) {
if (is.null(x) || length(x) == 0) y else x
}
strextract <- function(str, pattern) regmatches(str, regexpr(pattern, str))
strtrim <- function(str) gsub("^\\s+|\\s+$", "", str)
Try the rerddapUtils package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.