From b6b405dcbce4888a98251486cb39e2e20bda43d6 Mon Sep 17 00:00:00 2001 From: Martin Jung <3788377+Martin-Jung@users.noreply.github.com> Date: Sat, 14 Dec 2024 15:53:19 +0100 Subject: [PATCH] Doc revamping and conversion scripts (#10) * Documentation and pkgdown addition * Adding datapaths as entry * :rocket: negated in function * Small updates and convenience stuff (#8) (#9) * Documentation and pkgdown addition * Adding datapaths as entry * :rocket: negated in function * :rocket: Function to export raster to netcdf files * Transferred object size function from ibis * Updated docs, code and downscalr conversion code * Small typo :bug: in tests * :bug: fix nr 2 for dependencies --- .gitignore | 3 + DESCRIPTION | 15 +- NAMESPACE | 8 +- R/conv_downscalr2ibis.R | 254 ++++++++++++++++++ R/data.R | 1 + R/misc_objectSize.R | 104 +++++++ R/misc_sanitizeNames.R | 5 + R/spl_exportNetCDF.R | 220 +++++++++++++++ R/spl_replaceGriddedNA.R | 4 +- R/{sp_resampleRas.R => spl_resampleRas.R} | 4 +- README.md | 16 ++ _pkgdown.yml | 50 ++++ inst/iiasa_meta.yaml | 51 ++++ man/bnr_datapaths.Rd | 2 +- man/conv_downscalr2ibis.Rd | 55 ++++ man/misc_objectSize.Rd | 37 +++ man/spl_exportNetCDF.Rd | 62 +++++ ...ceGriddedNA.Rd => spl_replaceGriddedNA.Rd} | 8 +- man/{sp_resampleRas.Rd => spl_resampleRas.Rd} | 10 +- tests/testthat/test-misc_tests.R | 6 +- tests/testthat/test-sp_resampleRas.R | 2 +- tests/testthat/test-spl_tests.R | 4 +- 22 files changed, 899 insertions(+), 22 deletions(-) create mode 100644 R/conv_downscalr2ibis.R create mode 100644 R/misc_objectSize.R create mode 100644 R/spl_exportNetCDF.R rename R/{sp_resampleRas.R => spl_resampleRas.R} (95%) create mode 100644 inst/iiasa_meta.yaml create mode 100644 man/conv_downscalr2ibis.Rd create mode 100644 man/misc_objectSize.Rd create mode 100644 man/spl_exportNetCDF.Rd rename man/{sp_replaceGriddedNA.Rd => spl_replaceGriddedNA.Rd} (89%) rename man/{sp_resampleRas.Rd => spl_resampleRas.Rd} (83%) diff --git a/.gitignore b/.gitignore index b27cb91..431c156 100644 --- a/.gitignore +++ b/.gitignore @@ -49,3 +49,6 @@ po/*~ rsconnect/ .Rproj.user docs + +# Other temporary files created by some functions +test.nc diff --git a/DESCRIPTION b/DESCRIPTION index d860387..c761744 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -17,11 +17,22 @@ URL: https://github.com/iiasa/BNRTools, https://iiasa.github.io/BNRTools/ BugReports: https://github.com/iiasa/BNRTools/issues Depends: R (>= 3.6) Imports: + cli, + janitor, + dplyr, assertthat, - terra + sf, + terra, + stars, + abind, + RNetCDF, + ncdf4, + yaml Suggests: gdalUtilities, - stars, + cubelyr, + purrr, + progress, testthat (>= 3.0.0) Encoding: UTF-8 Roxygen: list(markdown = TRUE) diff --git a/NAMESPACE b/NAMESPACE index e8b90d0..4254263 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,10 @@ # Generated by roxygen2: do not edit by hand export("%notin%") +export(conv_downscalr2ibis) +export(misc_objectSize) export(misc_sanitizeNames) -export(sp_replaceGriddedNA) -export(sp_resampleRas) +export(spl_exportNetCDF) +export(spl_replaceGriddedNA) +export(spl_resampleRas) +importFrom(utils,object.size) diff --git a/R/conv_downscalr2ibis.R b/R/conv_downscalr2ibis.R new file mode 100644 index 0000000..cee113a --- /dev/null +++ b/R/conv_downscalr2ibis.R @@ -0,0 +1,254 @@ +#' Function to format a prepared GLOBIOM netCDF file for use in \code{ibis.iSDM} +#' +#' @description +#' This function expects a downscaled GLOBIOM output as created in +#' the BIOCLIMA project. It converts the input to a stars object to be fed to +#' the \code{ibis.iSDM} R-package. +#' +#' @param fname A filename in [`character`] pointing to a GLOBIOM output in netCDF format. +#' @param ignore A [`vector`] of variables to be ignored (Default: \code{NULL}). +#' @param period A [`character`] limiting the period to be returned from the +#' formatted data. Options include \code{"reference"} for the first entry, \code{"projection"} +#' for all entries but the first, and \code{"all"} for all entries (Default: \code{"reference"}). +#' @param template An optional [`SpatRaster`] object towards which projects +#' should be transformed. +#' @param shares_to_area A [`logical`] on whether shares should be corrected to +#' areas (if identified). +#' @param use_gdalutils (Deprecated) [`logical`] on to use gdalutils hack-around. +#' @param verbose [`logical`] on whether to be chatty. +#' +#' @return A [`SpatRaster`] stack with the formatted GLOBIOM predictors. +#' +#' @keywords conversion +#' +#' @author Martin Jung +#' @examples +#' \dontrun{ +#' ## Does not work unless downscalr file is provided. +#' # Expects a filename pointing to a netCDF file. +#' covariates <- conv_downscalr2ibis(fname) +#' } +#' +#' @export +conv_downscalr2ibis <- function(fname, ignore = NULL, + period = "all", template = NULL, shares_to_area = FALSE, + use_gdalutils = FALSE, + verbose = TRUE){ + assertthat::assert_that( + file.exists(fname), + assertthat::has_extension(fname, "nc"), + is.null(ignore) || is.character(ignore), + is.character(period), + is.character(fname), + is.logical(shares_to_area), + is.logical(use_gdalutils), + is.logical(verbose) + ) + period <- match.arg(period, c("reference", "projection", "all"), several.ok = FALSE) + + # Try and load in the GLOBIOM file to get the attributes + fatt <- ncdf4::nc_open(fname) + if(verbose) cli::cli_alert_warning(paste0("[Setup] Found ", fatt$ndims, " dimensions and ", fatt$nvars, " variables")) + + # Get all dimension names and variable names + dims <- names(fatt$dim) + vars <- names(fatt$var) + if(!is.null(ignore)) assertthat::assert_that( all( ignore %in% vars ) ) + + attrs <- list() # For storing the attributes + sc <- vector() # For storing the scenario files + sc_area <- list() # For storing any area information if set + + # Now open the netcdf file with stars + if( length( grep("netcdf", stars::detect.driver(fname), ignore.case = TRUE) )>0 ){ + if(verbose){ + cli::cli_alert_warning("[Predictor] Loading in predictor file...") + pb <- progress::progress_bar$new(total = length(vars), + format = "Loading :variable (:spin) [:bar] :percent") + } + + for(v in vars) { + if(verbose) pb$tick(tokens = list(variable = v)) + if(!is.null(ignore)) if(ignore == v) next() + + # Get and save the attributes of each variable + attrs[[v]] <- ncdf4::ncatt_get(fatt, varid = v, verbose = FALSE) + + # Load in the variable + suppressWarnings( + suppressMessages( + ff <- stars::read_ncdf(fname, + var = v, + proxy = FALSE, + make_time = TRUE, # Make time on 'time' band + make_units = FALSE # To avoid unnecessary errors due to unknown units + ) + ) + ) + + # Sometimes variables don't seem to have a time dimension + if(!"time" %in% names(stars::st_dimensions(ff))) { + if(shares_to_area && length(grep("area",names(ff)))>0){ + # Check that the unit is a unit + if(fatt$var[[v]]$units %in% c("km2","ha","m2")){ + sc_area <- ff + } + } else { + next() + } + } + + # Record dimensions for later + full_dis <- stars::st_dimensions(ff) + + # Get dimensions other that x,y and time and split + # Commonly used column names + check = c("x","X","lon","longitude", "y", "Y", "lat", "latitude", "time", "Time", "year", "Year") + chk <- which(!names(stars::st_dimensions(ff)) %in% check) + + if(length(chk)>0){ + for(i in chk){ + col_class <- names(stars::st_dimensions(ff))[i] + # FIXME: Dirty hack to remove forest zoning + if(length( grep("zone",col_class,ignore.case = T) )>0) next() + + # And class units as description from over + class_units <- fatt$dim[[col_class]]$units + class_units <- class_units |> + base::strsplit(";") |> + # Remove emptyspace and special symbols + sapply(function(y) gsub("[^0-9A-Za-z///' ]", "" , y, ignore.case = TRUE) ) |> + sapply(function(y) gsub(" ", "" , y, ignore.case = TRUE) ) + # Convert to vector and make names + class_units <- paste0( + v, "__", + make.names(unlist(class_units)) |> as.vector() + ) + + ff <- ff |> split(col_class) |> stats::setNames(nm = class_units) + + # FIXME: Dirty hack to deal with the forest zone dimension + # If there are more dimensions than 3, aggregate over them + if( length(stars::st_dimensions(ff)) >3){ + # Aggregate spatial-temporally + ff <- stars::st_apply(ff, c("longitude", "latitude", "time"), sum, na.rm = TRUE) + } + } + } + + # Finally aggregate + if(!is.null(template) && inherits(template, "SpatRaster")){ + # FIXME: MJ 14/11/2022 - The code below is buggy, resulting in odd + # curvilinear extrapolations for Europe Hacky approach now is to convert + # to raster, crop, project and then convert back. Only use if gdalUtils + # is installed + # if(("gdalUtilities" %in% utils::installed.packages()[,1])&&use_gdalutils){ + # ff <- ibis.iSDM:::hack_project_stars(ff, template, use_gdalutils) + # } else { + # Make background + bg <- stars::st_as_stars(template) + + # # Get resolution + res <- stars::st_res(bg) + assertthat::assert_that(!anyNA(res)) + + # # And warp by projecting and resampling + ff <- ff |> stars::st_warp(bg, crs = sf::st_crs(bg), + cellsize = res, method = "near") |> + sf::st_transform(crs = sf::st_crs(template)) + # } + # Overwrite full dimensions + full_dis <- stars::st_dimensions(ff) + } + # Now append to vector + sc <- c(sc, ff) + rm(ff) + } + invisible(gc()) + assertthat::assert_that(length(names(full_dis))>=3) + + # Format sc object as stars and set dimensions again + sc <- stars::st_as_stars(sc) + assertthat::assert_that(length(sc)>0) + full_dis <- full_dis[c( + grep("x|longitude",names(full_dis), ignore.case = TRUE,value = TRUE), + grep("y|latitude",names(full_dis), ignore.case = TRUE,value = TRUE), + grep("year|time",names(full_dis), ignore.case = TRUE,value = TRUE) + )] # Order assumed to be correct + assertthat::assert_that(length(names(full_dis))==3) + stars::st_dimensions(sc) <- full_dis # Target dimensions + + } else { cli::cli_abort("Fileformat not recognized!")} + + # Get time dimension (without applying offset) so at the centre + times <- stars::st_get_dimension_values(sc, "time", center = TRUE) + + # Make checks on length of times and if equal to one, drop. check. + if(length(times)==1){ + if(period == "projection") cli::cli_abort("Found only a single time slot. Projections not possible.") + if(verbose) cli::cli_alert_warning('[Setup] Found only a single time point in file. Dropping time dimension.') + # Drop the time dimension + sc <- abind::adrop(sc, drop = which(names(stars::st_dimensions(sc)) == "time") ) + } + + # Formate times unit and convert to posix if not already set + if(is.numeric(times) && length(times) > 1){ + # Assume year and paste0 as properly POSIX formatted + times <- as.POSIXct( paste0(times, "-01-01") ) + sc <- stars::st_set_dimensions(sc, "time", times) + } + + # Depending on the period, slice the input data + if(period == "reference"){ + # Get the first entry and filter + if(length(times)>1){ + # In case times got removed + times_first <- stars::st_get_dimension_values(sc, "time")[1] + sc <- sc |> dplyr::filter("time" == times_first) + times <- times_first;rm(times_first) + } + } else if(period == "projection"){ + # Remove the first time entry instead, only using the last entries + times_allbutfirst <- stars::st_get_dimension_values(sc, "time")[-1] + sc <- sc |> dplyr::filter("time" %in% times_allbutfirst) + times <- times_allbutfirst; rm(times_allbutfirst) + } + assertthat::assert_that(length(times)>0, + length(sc)>=1) + + # Create raster template if set + if(!is.null(template)){ + # Check that template is a raster, otherwise rasterize for GLOBIOM use + if(inherits(template, "sf")){ + o <- sc |> dplyr::slice("time" , 1) |> terra::rast() + template <- terra::rasterize(template, o, field = 1) + rm(o) + } + } + + # Correct shares to area if set + if(shares_to_area && inherits(sc_area,"stars")){ + # Transform and warp the shares + sc_area <- stars::st_warp(sc_area, stars::st_as_stars(template), crs = sf::st_crs(sc),method = "near") + # grep those layers with the name share + shares <- grep(pattern = "share|fraction|proportion", names(sc),value = TRUE) + sc[shares] <- sc[shares] * sc_area + } + + return( sc ) +} + +#' Deprecated formatting function +#' @description +#' This function is only kept for backwards compatability with old \code{ibis.iSDM} +#' code. Instead the new `conv_downscalr2ibis()` function should be used. +#' @param ... Parameters passed on [`conv_downscalr2ibis()`] +#' @inheritParams conv_downscalr2ibis +#' @returns None +#' @keywords spatial +#' @noRd +formatGLOBIOM <- function(...){ + cli::cli_alert_warning(c("formatGLOBIOM() is deprecated! ", + "i" = "Use conv_downscalr2ibis() instead.")) + conv_downscalr2ibis(...) +} diff --git a/R/data.R b/R/data.R index a96fa12..83df8a3 100644 --- a/R/data.R +++ b/R/data.R @@ -19,6 +19,7 @@ #' To update or overwrite, load the file and update, then apply #' \code{usethis::use_data(bnr_datapaths, overwrite = TRUE) }. #' +#' @keywords internal #' @format A [data.frame] containing paths to key spatial data sources. #' @source Manually updated and curated by BNR researchers "bnr_datapaths" diff --git a/R/misc_objectSize.R b/R/misc_objectSize.R new file mode 100644 index 0000000..22ce82b --- /dev/null +++ b/R/misc_objectSize.R @@ -0,0 +1,104 @@ +#' @title Shows size of objects in the R environment +#' @description Shows the size of the objects currently in the R environment. +#' Helps to locate large objects cluttering the R environment and/or +#' causing memory problems during the execution of large workflows. +#' +#' @param n Number of objects to show, Default: `10` +#' @return A data frame with the row names indicating the object name, +#' the field 'Type' indicating the object type, 'Size' indicating the object size, +#' and the columns 'Length/Rows' and 'Columns' indicating the object dimensions if applicable. +#' +#' @examples +#' if(interactive()){ +#' +#' #creating dummy objects +#' x <- matrix(runif(100), 10, 10) +#' y <- matrix(runif(10000), 100, 100) +#' +#' #reading their in-memory size +#' misc_objectSize() +#' +#' } +#' @author Bias Benito +#' @aliases object_size +#' @importFrom utils object.size +#' @export +misc_objectSize <- function(n = 10) { + + .ls.objects <- function ( + pos = 1, + pattern, + order.by, + decreasing=FALSE, + head=FALSE, + n=5 + ){ + + napply <- function(names, fn) sapply( + names, + function(x) fn(get(x, pos = pos)) + ) + + names <- ls( + pos = pos, + pattern = pattern + ) + + obj.class <- napply( + names, + function(x) as.character(class(x))[1] + ) + + obj.mode <- napply( + names, + mode + ) + + obj.type <- ifelse( + is.na(obj.class), + obj.mode, + obj.class + ) + + obj.prettysize <- napply( + names, + function(x) {format(utils::object.size(x), units = "auto") } + ) + + obj.size <- napply( + names, + object.size + ) + + obj.dim <- t( + napply( + names, + function(x)as.numeric(dim(x))[1:2] + ) + ) + + vec <- is.na(obj.dim)[, 1] & (obj.type != "function") + + obj.dim[vec, 1] <- napply(names, length)[vec] + + out <- data.frame( + obj.type, + obj.prettysize, + obj.dim + ) + names(out) <- c("Type", "Size", "Length/Rows", "Columns") + if (!missing(order.by)) + out <- out[order(out[[order.by]], decreasing=decreasing), ] + if (head) + out <- head(out, n) + out + } + + .ls.objects( + order.by = "Size", + decreasing=TRUE, + head=TRUE, + n=n + ) + +} diff --git a/R/misc_sanitizeNames.R b/R/misc_sanitizeNames.R index 48ae3e2..5a4ed87 100644 --- a/R/misc_sanitizeNames.R +++ b/R/misc_sanitizeNames.R @@ -22,6 +22,11 @@ misc_sanitizeNames <- function(names){ assertthat::assert_that( length(names) > 0 ) + cli::cli_alert_info("Note: Method deprecated. Just janitor::make_clean_names() directly!") + return( + janitor::make_clean_names(names) + ) + # Convert the variable names new_names <- vapply(names, function(x) { gsub("[-() ]", "_", x = x, fixed = FALSE) diff --git a/R/spl_exportNetCDF.R b/R/spl_exportNetCDF.R new file mode 100644 index 0000000..0ae1f79 --- /dev/null +++ b/R/spl_exportNetCDF.R @@ -0,0 +1,220 @@ +#' RExport a gridded raster to a NetCDF format +#' +#' @description +#' This function serves as a general wrapper function to export a provided +#' spatial gridded layer as multi-dimensional NetCDF file. It furthermore requires +#' the specification of a list containing metadata information. +#' +#' @details +#' The default metadata is contained in \code{"inst/iiasa_meta"}. See examples. +#' +#' @note +#' A support for \code{'stars'} could be added. +#' +#' @param obj A [`SpatRaster`] object to be exported. +#' @param filename A [`character`] with the output filename. +#' @param global_meta A global metadata descriptor by default using IIASA standard +#' metadata (Default: \code{"iiasa_meta data"}). +#' @param separate_meta A [`logical`] flag on whether the metadata should be +#' written separately in \code{"yaml"} format (Default: \code{FALSE}). +#' @param ... Any other metadata that should be overwritten or added to \code{"global_meta"}. +#' +#' @returns NULL +#' +#' @author Martin Jung +#' +#' @keywords spatial +#' +#' @seealso +#' \code{\link[terra]{writeCDF}}, +#' \code{\link[terra]{writeRaster}} +#' +#' @examples +#' # Load default metadata (loaded by default by function too) +#' meta <- yaml::read_yaml(system.file("iiasa_meta.yaml", package = "BNRTools")) +#' +#' # Dummy raster +#' obj <- terra::rast(ncol = 100, nrow = 100, +#' xmin = 0, xmax = 100, +#' ymin = 0, ymax = 100, +#' resolution = 5, crs = terra::crs("WGS84"), +#' val = runif(400) +#' ) +#' +#' # Export +#' spl_exportNetCDF(obj, filename = "test.nc", +#' global_meta = meta, title = "Super cool analysis") +#' @export +spl_exportNetCDF <- function(obj, + filename, + global_meta = system.file("iiasa_meta.yaml", package = "BNRTools"), + separate_meta = FALSE, + ...){ + # Checks + assertthat::assert_that( + inherits(obj, "SpatRaster") || inherits(obj, "stars"), + is.character(filename), + is.character(global_meta) || is.list(global_meta), + is.logical(separate_meta) + ) + # Check that output dir is writeable + assertthat::assert_that( + assertthat::is.writeable(dirname(filename)), + msg = "Note that output directory is not writeable..." + ) + # Check that output name has correct extension + if(!tools::file_ext(filename) %in% c("nc","NC")){ + filename <- paste0(filename, ".nc") + } + + # --- # + # Load global metadata + if(is.character(global_meta)){ + atrs <- yaml::read_yaml(global_meta) + } else { atrs <- global_meta} + # Check level of attribute and flatten otherwise + if(purrr::pluck_depth(atrs) > 2) atrs <- purrr::flatten(atrs) + + # Check that list is correct + assertthat::assert_that( + is.list(atrs), + length(atrs)>1, + purrr::pluck_depth(atrs)>=2 + ) + # Load other fields and add them to the list or replace + mc <- list(...) + if(length(mc)>0){ + if(any(names(mc) %in% names(atrs))){ + ind <- names(mc)[which( names(mc) %in% names(atrs) )] + for(k in ind){ + atrs[[k]] <- mc[[k]] + mc[[k]] <- NULL # Remove + } + } + } + + # Check common fields and raise warnings if empty + if(utils::hasName(atrs,"title") & atrs[['title']] == ""){ + cli::cli_alert_warning("No set title found (empty attribute).") + } + + # --- # + # Create nc file + nc <- RNetCDF::create.nc(filename = filename) + + # Get range of coordinates and define them + focal_x <- terra::crds(obj)[,1] |> unique() + focal_y <- terra::crds(obj)[,2] |> unique() + + # Define x dimension + RNetCDF::dim.def.nc( nc, dimname = "lon", dimlength = length(focal_x)) + # Define x variable + RNetCDF::var.def.nc(nc, varname = "lon", vartype = "NC_DOUBLE", dimensions = "lon") + # Add attributes + RNetCDF::att.put.nc(nc, variable = "lon", name = "units", + type = "NC_CHAR", value = atrs[['geospatial_lon_units']]) + RNetCDF::att.put.nc(nc, variable = "lon", name = "standard_name", + type = "NC_CHAR", value = atrs[['geospatial_lon_name']]) + RNetCDF::att.put.nc(nc, variable = "lon", name = "long_name", + type = "NC_CHAR", value = atrs[['geospatial_lon_name']]) + # Put data + RNetCDF::var.put.nc(nc, variable = "lon", data = focal_x) + + # Define y dimension + RNetCDF::dim.def.nc(nc, dimname = "lat", dimlength = length(focal_y)) + # Define y variable + RNetCDF::var.def.nc(nc, varname = "lat", vartype = "NC_DOUBLE", dimensions = "lat") + # Add attributes + RNetCDF::att.put.nc(nc, variable = "lat", name = "units", + type = "NC_CHAR", value = atrs[['geospatial_lat_units']]) + RNetCDF::att.put.nc(nc, variable = "lat", name = "standard_name", + type = "NC_CHAR", value = atrs[['geospatial_lat_name']]) + RNetCDF::att.put.nc(nc, variable = "lat", name = "long_name", + type = "NC_CHAR", value = atrs[['geospatial_lat_name']]) + # Put data + RNetCDF::var.put.nc(nc, variable = "lat", data = focal_y) + + # --- # + # Define non-dimensional geographic projectioncrs variable + RNetCDF::var.def.nc(nc, varname = "crs", vartype = "NC_CHAR", dimensions = NA) + + # Add attributes + RNetCDF::att.put.nc(nc, variable = "crs", name = "long_name", type = "NC_CHAR", value = "Coordinate Reference System") + RNetCDF::att.put.nc(nc, variable = "crs", name = "geographic_crs_name", + type = "NC_CHAR", value = ifelse(terra::is.lonlat(terra::crs(obj)), "WGS 84", "Custom")) + RNetCDF::att.put.nc(nc, variable = "crs", name = "reference_ellipsoid_name", + type = "NC_CHAR", value = ifelse(terra::is.lonlat(terra::crs(obj)), "WGS 84", "Custom")) + RNetCDF::att.put.nc(nc, variable = "crs", name = "grid_mapping_name", type = "NC_CHAR", + value = ifelse(terra::is.lonlat(terra::crs(obj)), "latitude_longitude", "Custom")) + RNetCDF::att.put.nc(nc, variable = "crs", name = "horizontal_datum_name", + type = "NC_CHAR", value = ifelse(terra::is.lonlat(terra::crs(obj)), "WGS 84", "Custom")) + RNetCDF::att.put.nc(nc, variable = "crs", name = "prime_meridian_name", type = "NC_CHAR", value = "Greenwich") + RNetCDF::att.put.nc(nc, variable = "crs", name = "longitude_of_prime_meridian", type = "NC_DOUBLE", value = 0.) + RNetCDF::att.put.nc(nc, variable = "crs", name = "semi_major_axis", type = "NC_DOUBLE", value = 6378137.) + RNetCDF::att.put.nc(nc, variable = "crs", name = "semi_minor_axis", type = "NC_DOUBLE", value = 6356752.314245179) + RNetCDF::att.put.nc(nc, variable = "crs", name = "inverse_flattening", type = "NC_DOUBLE", value = 298.257223563) + RNetCDF::att.put.nc(nc, variable = "crs",name = "spatial_ref", type = "NC_CHAR", value = terra::crs(obj)) + # RNetCDF::att.put.nc(nc, variable = "crs", name = "GeoTransform", type = "NC_CHAR", + # value = '-180 0.08333333333333333 0 90 0 -0.08333333333333333 ') + + # Get variable names + vnames <- names(obj) + + # Create and fill variables + for(i in vnames){ + # Create the diversity metric variable defined by the four dimensions + RNetCDF::var.def.nc(nc, varname = i, vartype = "NC_DOUBLE", dimensions = c("lon", "lat")) + # Add no data fill values + RNetCDF::att.put.nc(nc, variable = i, name = "_FillValue", type = "NC_DOUBLE", value = -99999) + + vnames_val <- paste(basename(filename), i) + RNetCDF::att.put.nc(nc, variable = i, + name = "long_name", type = "NC_CHAR", value = vnames_val) + + # add data + focal_array <- base::array( + terra::values(obj)[,1], + dim = c(length(focal_y), length(focal_x)) + ) + RNetCDF::var.put.nc(nc, variable = i, data = t(focal_array)) + } + + # --- # + # Internal function to add the global attributes + add_global_attributes <- function(nc, attributes){ + assertthat::assert_that( + is.list(attributes) + ) + + # Loop through attributes + for(i in 1:length(attributes)){ + if(is.character(attributes[[i]])){ + type <- "NC_CHAR" + }else if(is.numeric(attributes[[i]])){ + type <- "NC_DOUBLE" + } + RNetCDF::att.put.nc(nc, variable = "NC_GLOBAL", name = names(attributes[i]), + type = type, value = attributes[[i]]) + } + RNetCDF::sync.nc(nc) + } + + # Add attributes + add_global_attributes(nc, attributes = atrs) + + RNetCDF::sync.nc(nc) + RNetCDF::close.nc(nc) + + # Check whether metadata should also be written + if(separate_meta){ + ofname <- paste0(tools::file_path_sans_ext(filename), ".yaml") + yaml::write_yaml(x = atrs,file = ofname) + cli::cli_alert_info("Wrote separate metadata to file.") + } + + # Final checks + assertthat::assert_that( + file.exists(filename) + ) + cli::cli_alert_success("Succesfully written output format!") +} diff --git a/R/spl_replaceGriddedNA.R b/R/spl_replaceGriddedNA.R index 1e06d5c..fca3155 100644 --- a/R/spl_replaceGriddedNA.R +++ b/R/spl_replaceGriddedNA.R @@ -19,14 +19,14 @@ #' # Example #' s <- terra::rast(system.file("ex/logo.tif", package="terra")) #' s[sample(1:terra::ncell(s), 100)] <- NA -#' sfill <- sp_replaceGriddedNA(s, value = 100) +#' sfill <- spl_replaceGriddedNA(s, value = 100) #' terra::plot(sfill) #' #' @returns A object of the same type as the input but with no-data values replaced with \code{'value'}. #' @author Martin Jung #' @keywords internal, utils #' @export -sp_replaceGriddedNA <- function(obj, value = 0, mask, verbose = FALSE){ +spl_replaceGriddedNA <- function(obj, value = 0, mask, verbose = FALSE){ assertthat::assert_that( inherits(obj, "stars") || inherits(obj, "SpatRaster"), is.numeric(value) || length(value)==1, diff --git a/R/sp_resampleRas.R b/R/spl_resampleRas.R similarity index 95% rename from R/sp_resampleRas.R rename to R/spl_resampleRas.R index 0070ae5..05d59d0 100644 --- a/R/sp_resampleRas.R +++ b/R/spl_resampleRas.R @@ -26,10 +26,10 @@ #' terra::values(ras_a) <- runif(n = terra::ncell(ras_a)) #' terra::values(ras_b) <- runif(n = terra::ncell(ras_b)) #' -#' sp_resampleRas(x = ras_a, y = ras_b) +#' spl_resampleRas(x = ras_a, y = ras_b) #' #' @export -sp_resampleRas <- function(x, y, discrete = FALSE) { +spl_resampleRas <- function(x, y, discrete = FALSE) { # MH: Switch this to assertthat::assert_that() # check if CRS are already the same diff --git a/README.md b/README.md index cf52678..9ba87ac 100644 --- a/README.md +++ b/README.md @@ -21,6 +21,22 @@ please stick to the following house rules: See this [website](https://r-pkgs.org/) for more general help and examples in developing content for R-packages. +## Installation + +The `BNRTools` package can be installed either through the `remotes` R-package or +directly from r-universe. + +```r +# Install from source +remotes::install_github("iiasa/BNRTools") +# Or for the current development branch +remotes::install_github("iiasa/BNRTools", "dev") + +# Installation +install.packages('BNRTools', repos = "https://iiasa.r-universe.dev") + +``` + ## Code of Conduct Please note that the BNRTools project is released with a [Contributor Code of Conduct](https://contributor-covenant.org/version/2/1/CODE_OF_CONDUCT.html). By contributing to this project, you agree to abide by its terms. diff --git a/_pkgdown.yml b/_pkgdown.yml index ead1603..31d649f 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -1,4 +1,54 @@ url: https://iiasa.github.io/BNRTools/ + +development: + mode: auto + template: bootstrap: 5 + bootswatch: zephyr + bslib: + pkgdown-nav-height: 80px + opengraph: + twitter: + creator: "@IIASAVienna" + site: "@IIASAVienna" + card: summary + +home: + title: The BNRTools package - Helper functions for IIASA researchers + description: Community managed R-package containing different scripts a + sidebar: + structure: [links, citation, license, authors, dev] + links: + - text: IIASA + href: https://iiasa.ac.at/ + +navbar: + structure: + left: [home, reference, news] + right: [search, github] + +reference: + - title: Conversion functions + desc: > + Key functions to convert model outputs for use in other modelling environments. + contents: + - conv_downscalr2ibis + - has_keyword("conversion") + + - title: Spatial functions + desc: > + Helper function combine, aggregate or otherwise modify spatial files. + contents: + - spl_resampleRas + - spl_exportNetCDF + - spl_replaceGriddedNA + - has_keyword("spatial") + - title: Miscellaneous functions + desc: > + Any other functions that are generally useful for a wide range of applications. + contents: + - has_keyword("utils") + - misc_objectSize + - misc_sanitizeNames diff --git a/inst/iiasa_meta.yaml b/inst/iiasa_meta.yaml new file mode 100644 index 0000000..96fd8fd --- /dev/null +++ b/inst/iiasa_meta.yaml @@ -0,0 +1,51 @@ +# Global information +global: + publisher_name: "IIASA" + publisher_email: "info@iiasa.ac.at" + publisher_url: "https://iiasa.ac.at" + publisher_institution: "International Institute for Applied Systems Analysis (IIASA)" + # publisher_type = "", + conventions: "CF-1.8" + standard_name_vocabulary: "CF Standard Name Table v1.8" + naming_authority: "iiasa.ac.at" + history: "https://github.com/iiasa/BNRTools" + source: "https://github.com/iiasa/BNRTools" + +# Creater information +creator: + creator_name: "" + creator_email: "" + creator_url: "https://iiasa.ac.at" + creator_institution: "International Institute for Applied Systems Analysis (IIASA)" + project: "iBIOM" + +file: + id: 1 + title: "" + summary: "" + date_created: "" + date_modified: "" + date_issued: "" + processing_level: "" + license: "CC-BY 4.0" + comment: "Uses attributes recommended by http://cfconventions.org" + citation: "" + acknowledgment: "" + +# Spatial metadata +spatial: + geospatial_bounds: "" + geospatial_bounds_crs: "" + geospatial_bounds_vertical_crs: "" + geospatial_lat_name: "latitude" + geospatial_lon_name: "longitude" + geospatial_lat_units: "degrees_north" + geospatial_lon_units: "degrees_east" + geospatial_lat_min: -90 + geospatial_lat_max: 90 + geospatial_lon_min: -180 + geospatial_lon_max: 180 + time_coverage_start: 2000 + time_coverage_end: 2100 + time_coverage_duration: "100" + time_coverage_resolution: "year" diff --git a/man/bnr_datapaths.Rd b/man/bnr_datapaths.Rd index ca5cee2..dcdc470 100644 --- a/man/bnr_datapaths.Rd +++ b/man/bnr_datapaths.Rd @@ -32,4 +32,4 @@ The file has the following columns: To update or overwrite, load the file and update, then apply \code{usethis::use_data(bnr_datapaths, overwrite = TRUE) }. } -\keyword{datasets} +\keyword{internal} diff --git a/man/conv_downscalr2ibis.Rd b/man/conv_downscalr2ibis.Rd new file mode 100644 index 0000000..1b1caeb --- /dev/null +++ b/man/conv_downscalr2ibis.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/conv_downscalr2ibis.R +\name{conv_downscalr2ibis} +\alias{conv_downscalr2ibis} +\title{Function to format a prepared GLOBIOM netCDF file for use in \code{ibis.iSDM}} +\usage{ +conv_downscalr2ibis( + fname, + ignore = NULL, + period = "all", + template = NULL, + shares_to_area = FALSE, + use_gdalutils = FALSE, + verbose = TRUE +) +} +\arguments{ +\item{fname}{A filename in \code{\link{character}} pointing to a GLOBIOM output in netCDF format.} + +\item{ignore}{A \code{\link{vector}} of variables to be ignored (Default: \code{NULL}).} + +\item{period}{A \code{\link{character}} limiting the period to be returned from the +formatted data. Options include \code{"reference"} for the first entry, \code{"projection"} +for all entries but the first, and \code{"all"} for all entries (Default: \code{"reference"}).} + +\item{template}{An optional \code{\link{SpatRaster}} object towards which projects +should be transformed.} + +\item{shares_to_area}{A \code{\link{logical}} on whether shares should be corrected to +areas (if identified).} + +\item{use_gdalutils}{(Deprecated) \code{\link{logical}} on to use gdalutils hack-around.} + +\item{verbose}{\code{\link{logical}} on whether to be chatty.} +} +\value{ +A \code{\link{SpatRaster}} stack with the formatted GLOBIOM predictors. +} +\description{ +This function expects a downscaled GLOBIOM output as created in +the BIOCLIMA project. It converts the input to a stars object to be fed to +the \code{ibis.iSDM} R-package. +} +\examples{ +\dontrun{ +## Does not work unless downscalr file is provided. +# Expects a filename pointing to a netCDF file. +covariates <- conv_downscalr2ibis(fname) +} + +} +\author{ +Martin Jung +} +\keyword{conversion} diff --git a/man/misc_objectSize.Rd b/man/misc_objectSize.Rd new file mode 100644 index 0000000..51bbc7a --- /dev/null +++ b/man/misc_objectSize.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc_objectSize.R +\name{misc_objectSize} +\alias{misc_objectSize} +\alias{object_size} +\title{Shows size of objects in the R environment} +\usage{ +misc_objectSize(n = 10) +} +\arguments{ +\item{n}{Number of objects to show, Default: \code{10}} +} +\value{ +A data frame with the row names indicating the object name, +the field 'Type' indicating the object type, 'Size' indicating the object size, +and the columns 'Length/Rows' and 'Columns' indicating the object dimensions if applicable. +} +\description{ +Shows the size of the objects currently in the R environment. +Helps to locate large objects cluttering the R environment and/or +causing memory problems during the execution of large workflows. +} +\examples{ +if(interactive()){ + + #creating dummy objects + x <- matrix(runif(100), 10, 10) + y <- matrix(runif(10000), 100, 100) + + #reading their in-memory size + misc_objectSize() + +} +} +\author{ +Bias Benito +} diff --git a/man/spl_exportNetCDF.Rd b/man/spl_exportNetCDF.Rd new file mode 100644 index 0000000..5da1893 --- /dev/null +++ b/man/spl_exportNetCDF.Rd @@ -0,0 +1,62 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/spl_exportNetCDF.R +\name{spl_exportNetCDF} +\alias{spl_exportNetCDF} +\title{RExport a gridded raster to a NetCDF format} +\usage{ +spl_exportNetCDF( + obj, + filename, + global_meta = system.file("iiasa_meta.yaml", package = "BNRTools"), + separate_meta = FALSE, + ... +) +} +\arguments{ +\item{obj}{A \code{\link{SpatRaster}} object to be exported.} + +\item{filename}{A \code{\link{character}} with the output filename.} + +\item{global_meta}{A global metadata descriptor by default using IIASA standard +metadata (Default: \code{"iiasa_meta data"}).} + +\item{separate_meta}{A \code{\link{logical}} flag on whether the metadata should be +written separately in \code{"yaml"} format (Default: \code{FALSE}).} + +\item{...}{Any other metadata that should be overwritten or added to \code{"global_meta"}.} +} +\description{ +This function serves as a general wrapper function to export a provided +spatial gridded layer as multi-dimensional NetCDF file. It furthermore requires +the specification of a list containing metadata information. +} +\details{ +The default metadata is contained in \code{"inst/iiasa_meta"}. See examples. +} +\note{ +A support for \code{'stars'} could be added. +} +\examples{ +# Load default metadata (loaded by default by function too) +meta <- yaml::read_yaml(system.file("iiasa_meta.yaml", package = "BNRTools")) + +# Dummy raster +obj <- terra::rast(ncol = 100, nrow = 100, + xmin = 0, xmax = 100, + ymin = 0, ymax = 100, + resolution = 5, crs = terra::crs("WGS84"), + val = runif(400) + ) + +# Export +spl_exportNetCDF(obj, filename = "test.nc", + global_meta = meta, title = "Super cool analysis") +} +\seealso{ +\code{\link[terra]{writeCDF}}, +\code{\link[terra]{writeRaster}} +} +\author{ +Martin Jung +} +\keyword{spatial} diff --git a/man/sp_replaceGriddedNA.Rd b/man/spl_replaceGriddedNA.Rd similarity index 89% rename from man/sp_replaceGriddedNA.Rd rename to man/spl_replaceGriddedNA.Rd index 207968d..923d8a3 100644 --- a/man/sp_replaceGriddedNA.Rd +++ b/man/spl_replaceGriddedNA.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/spl_replaceGriddedNA.R -\name{sp_replaceGriddedNA} -\alias{sp_replaceGriddedNA} +\name{spl_replaceGriddedNA} +\alias{spl_replaceGriddedNA} \title{Replace NA values in gridded layers with a fixed value.} \usage{ -sp_replaceGriddedNA(obj, value = 0, mask, verbose = FALSE) +spl_replaceGriddedNA(obj, value = 0, mask, verbose = FALSE) } \arguments{ \item{obj}{A \code{\link{SpatRaster}}, \code{\link{SpatRasterDataset}} or \code{\link{stars}} object.} @@ -32,7 +32,7 @@ all no-data values a replaced with the value in this mask. # Example s <- terra::rast(system.file("ex/logo.tif", package="terra")) s[sample(1:terra::ncell(s), 100)] <- NA -sfill <- sp_replaceGriddedNA(s, value = 100) +sfill <- spl_replaceGriddedNA(s, value = 100) terra::plot(sfill) } diff --git a/man/sp_resampleRas.Rd b/man/spl_resampleRas.Rd similarity index 83% rename from man/sp_resampleRas.Rd rename to man/spl_resampleRas.Rd index 5c1f03b..879dcc2 100644 --- a/man/sp_resampleRas.Rd +++ b/man/spl_resampleRas.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sp_resampleRas.R -\name{sp_resampleRas} -\alias{sp_resampleRas} +% Please edit documentation in R/spl_resampleRas.R +\name{spl_resampleRas} +\alias{spl_resampleRas} \title{Resample raster} \usage{ -sp_resampleRas(x, y, discrete = FALSE) +spl_resampleRas(x, y, discrete = FALSE) } \arguments{ \item{x}{A \code{\link{SpatRaster}} to be resampled.} @@ -30,7 +30,7 @@ ymin = 0, ymax = 100, resolution = 5, crs = NA) terra::values(ras_a) <- runif(n = terra::ncell(ras_a)) terra::values(ras_b) <- runif(n = terra::ncell(ras_b)) - sp_resampleRas(x = ras_a, y = ras_b) + spl_resampleRas(x = ras_a, y = ras_b) } \seealso{ diff --git a/tests/testthat/test-misc_tests.R b/tests/testthat/test-misc_tests.R index 2350eb9..f52c2c3 100644 --- a/tests/testthat/test-misc_tests.R +++ b/tests/testthat/test-misc_tests.R @@ -1,5 +1,9 @@ test_that("Basic unit tests for small misc functions", { - expect_equal(misc_sanitizeNames("Climate-temperature2015"), "Climate_temperature2015") + expect_equal( + suppressMessages( + misc_sanitizeNames("Climate-temperature2015") + ), "climate_temperature2015" + ) # Not in function\ lu <- c("Forest", "Cropland", "Wetland", "OtherLand") diff --git a/tests/testthat/test-sp_resampleRas.R b/tests/testthat/test-sp_resampleRas.R index d74bf87..684200e 100644 --- a/tests/testthat/test-sp_resampleRas.R +++ b/tests/testthat/test-sp_resampleRas.R @@ -9,7 +9,7 @@ terra::values(ras_b) <- runif(n = terra::ncell(ras_b)) test_that("sp_resampleRas results in same resolution/extent", { - ras_a_res <- sp_resampleRas(x = ras_a, y = ras_b) + ras_a_res <- spl_resampleRas(x = ras_a, y = ras_b) expect_true(terra::compareGeom(ras_a_res, ras_b)) diff --git a/tests/testthat/test-spl_tests.R b/tests/testthat/test-spl_tests.R index 25545df..7e978b1 100644 --- a/tests/testthat/test-spl_tests.R +++ b/tests/testthat/test-spl_tests.R @@ -12,13 +12,13 @@ test_that("Spatial object modifications", { # NA replacements # r1[sample(1:terra::ncell(r1),100)] <- NA expect_no_error( - r1_filled <- sp_replaceGriddedNA(r1, value = 0) + r1_filled <- spl_replaceGriddedNA(r1, value = 0) ) expect_s4_class(r1_filled, "SpatRaster") expect_equal(terra::global(r1_filled,"min")[,1], 0) # Should be 0 # Use layer 2 for masking instead expect_no_error( - r1_filled2 <- sp_replaceGriddedNA(r1,mask = r2) + r1_filled2 <- spl_replaceGriddedNA(r1,mask = r2) ) expect_s4_class(r1_filled2, "SpatRaster") # --- #