From 3cffad863de0e9088f586761242598a819dc4ccb Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Mon, 18 Dec 2023 14:22:11 +0100 Subject: [PATCH 01/20] Check getField() arguments with is.null() Instead of missing(). --- R/getField.R | 52 ++++++++++++++++++++++++------------------------- man/getField.Rd | 6 +++--- 2 files changed, 29 insertions(+), 29 deletions(-) diff --git a/R/getField.R b/R/getField.R index 347126d..4af7213 100644 --- a/R/getField.R +++ b/R/getField.R @@ -24,8 +24,8 @@ #' @param sta.info Optionally an \code{\linkS4class{STAInfo}} object defining the exact spatial-temporal-annual domain over which the data should be retrieved. #' Can also be a Field object from which the STA info will de derived. #' If specified the following 9 arguments are ignored (with a warning) -#' @param first.year The first year (as a numeric) of the data to be returned (if not specified or NULL start from the beginning of the data set) -#' @param last.year The last year (as a numeric) of the data to be returned (if not specified or NULL take the data to the end of the data set) +#' @param first.year The first year (as a numeric) of the data to be returned (if not specified or \code{NULL} start from the beginning of the data set) +#' @param last.year The last year (as a numeric) of the data to be returned (if not specified or \code{NULL} take the data to the end of the data set) #' @param year.aggregate.method A character string describing the method by which to annual aggregate the data. Leave blank to apply no annual aggregation. Can currently be "mean", "sum", "max", "min", "sd", "var and "cv" (= coefficient of variation: sd/mean). #' For technical reasons these need to be implemented in the package in the code however it should be easy to implement more, please just contact the author! #' See \code{\link{aggregateYears}} @@ -49,7 +49,7 @@ #' @param ... Other arguments that are passed to the getField function for the specific Format or additional arguements for selecting space/time/years. #' For all Formats, the followings arguments apply: #' \itemize{ -#' \item{\code{cover.fraction}} When selecting gridcells based on a SpatialPolygonsDataFrame (ie from a shapefile) as the \code{spatial.extent} argument, this optional arguement determines +#' \item{\code{cover.fraction}} When selecting gridcells based on a \code{sf} object (ie from a shapefile) as the \code{spatial.extent} argument, this optional arguement determines #' how much of the gridcell needs to be in the the polygon for it to be selected. Should be between 0 and 1. #' } #' For the aDGVM(1) Format, the following arguments apply: @@ -104,10 +104,10 @@ getField <- function(source, Lon = Lat = Year = NULL ### CHECK ARGUMENTS - if(!(missing(first.year) | is.null(first.year)) & !(missing(last.year) | is.null(last.year)) ) { + if(!is.null(first.year) && !is.null(last.year) ) { if(first.year > last.year) stop("first.year cannot be greater than last.year!") } - if(!missing(layers) && !is.character(layers) && !is.null(layers)) stop("The 'layers' argument must be a character string or a list of character strings.") + if(!is.character(layers) && !is.null(layers)) stop("The 'layers' argument must be a character string or a list of character strings.") ## QUICK READ ARGUMENTS AND AUTODELETE @@ -153,36 +153,36 @@ getField <- function(source, ### TIDY THE RELEVANT STA ARGUMENTS INTO THE TARGET STA OBJECT - if(missing(sta.info)) { + if(is.null(sta.info)) { sta.info <- new("STAInfo") - if(!missing(first.year)) sta.info@first.year = first.year - if(!missing(last.year)) sta.info@last.year = last.year - if(!missing(year.aggregate.method)) sta.info@year.aggregate.method = year.aggregate.method - if(!missing(spatial.extent)) sta.info@spatial.extent = spatial.extent - if(!missing(spatial.extent.id)) sta.info@spatial.extent.id = spatial.extent.id - if(!missing(spatial.aggregate.method)) sta.info@spatial.aggregate.method = spatial.aggregate.method - if(!missing(subannual.resolution)) sta.info@subannual.resolution = subannual.resolution - if(!missing(subannual.original)) sta.info@subannual.original = subannual.original - if(!missing(subannual.aggregate.method)) sta.info@subannual.aggregate.method = subannual.aggregate.method + if(!is.null(first.year)) sta.info@first.year = first.year + if(!is.null(last.year)) sta.info@last.year = last.year + if(!is.null(year.aggregate.method)) sta.info@year.aggregate.method = year.aggregate.method + if(!is.null(spatial.extent)) sta.info@spatial.extent = spatial.extent + if(!is.null(spatial.extent.id)) sta.info@spatial.extent.id = spatial.extent.id + if(!is.null(spatial.aggregate.method)) sta.info@spatial.aggregate.method = spatial.aggregate.method + if(!is.null(subannual.resolution)) sta.info@subannual.resolution = subannual.resolution + if(!is.null(subannual.original)) sta.info@subannual.original = subannual.original + if(!is.null(subannual.aggregate.method)) sta.info@subannual.aggregate.method = subannual.aggregate.method } else { if(is.Field(sta.info)) sta.info <- as(sta.info, "STAInfo") - if(!missing(first.year)) warning("Since 'sta.info' argument has been specified, the 'first.year' argument will be ignored") - if(!missing(last.year)) warning("Since 'sta.info' argument has been specified, the 'last.year' argument will be ignored") - if(!missing(year.aggregate.method)) warning("Since 'sta.info' argument has been specified, the 'year.aggregate.method' argument will be ignored") - if(!missing(spatial.extent)) warning("Since 'sta.info' argument has been specified, the 'spatial.extent' argument will be ignored") - if(!missing(spatial.extent.id)) warning("Since 'sta.info' argument has been specified, the 'spatial.extent.id' argument will be ignored") - if(!missing(spatial.aggregate.method)) warning("Since 'sta.info' has been argument specified, the 'spatial.aggregate.method' argument will be ignored") - if(!missing(subannual.original)) warning("Since 'sta.info' argument has been specified, the 'subannual.original' argument will be ignored") - if(!missing(subannual.resolution)) warning("Since 'sta.info' argument has been specified, the 'subannual.resolution' argument will be ignored") - if(!missing(subannual.aggregate.method)) warning("Since 'sta.info' argument has been specified, the 'subannual.aggregate.method' argument will be ignored") + if(!is.null(first.year)) warning("Since 'sta.info' argument has been specified, the 'first.year' argument will be ignored") + if(!is.null(last.year)) warning("Since 'sta.info' argument has been specified, the 'last.year' argument will be ignored") + if(!is.null(year.aggregate.method)) warning("Since 'sta.info' argument has been specified, the 'year.aggregate.method' argument will be ignored") + if(!is.null(spatial.extent)) warning("Since 'sta.info' argument has been specified, the 'spatial.extent' argument will be ignored") + if(!is.null(spatial.extent.id)) warning("Since 'sta.info' argument has been specified, the 'spatial.extent.id' argument will be ignored") + if(!is.null(spatial.aggregate.method)) warning("Since 'sta.info' has been argument specified, the 'spatial.aggregate.method' argument will be ignored") + if(!is.null(subannual.original)) warning("Since 'sta.info' argument has been specified, the 'subannual.original' argument will be ignored") + if(!is.null(subannual.resolution)) warning("Since 'sta.info' argument has been specified, the 'subannual.resolution' argument will be ignored") + if(!is.null(subannual.aggregate.method)) warning("Since 'sta.info' argument has been specified, the 'subannual.aggregate.method' argument will be ignored") } ### CATCH AWKWARD CASE ### Fail when a spatial.extent is specified but no spatial.extent.id - if(!missing(spatial.extent) && missing(spatial.extent.id)){ + if(!is.null(spatial.extent) && is.null(spatial.extent.id)){ stop("Please specify a spatial.extent.id when specifying a spatial.extent (just a simple character string). This is to maintain metadata integrity.") } @@ -234,7 +234,7 @@ getField <- function(source, # check layers (if specified) layers.match <- TRUE - if(!missing(layers) && !is.null(layers)) { + if(!is.null(layers)) { layers.match <- identical(sort(layers), sort(layers(preprocessed.field))) if(verbose) { if(layers.match) message("*** Preprocessed file matches in terms of layers present. ***") diff --git a/man/getField.Rd b/man/getField.Rd index 932b05d..858dc6f 100644 --- a/man/getField.Rd +++ b/man/getField.Rd @@ -42,9 +42,9 @@ For the \code{GUESS}, \code{aDGVM} and \code{aDGVM2} Formats this is optional un standardised (although they have been renamed). However for the \code{NetCDF} Format this is pretty much always essential because random netCDF files don't tend to have standardised file names in the same way that model output does. Leave missing or set to \code{NULL} to use the standard file name for the particular Format.} -\item{first.year}{The first year (as a numeric) of the data to be returned (if not specified or NULL start from the beginning of the data set)} +\item{first.year}{The first year (as a numeric) of the data to be returned (if not specified or \code{NULL} start from the beginning of the data set)} -\item{last.year}{The last year (as a numeric) of the data to be returned (if not specified or NULL take the data to the end of the data set)} +\item{last.year}{The last year (as a numeric) of the data to be returned (if not specified or \code{NULL} take the data to the end of the data set)} \item{year.aggregate.method}{A character string describing the method by which to annual aggregate the data. Leave blank to apply no annual aggregation. Can currently be "mean", "sum", "max", "min", "sd", "var and "cv" (= coefficient of variation: sd/mean). For technical reasons these need to be implemented in the package in the code however it should be easy to implement more, please just contact the author! @@ -83,7 +83,7 @@ found in the file match that which was requested by the arguments here).} \item{...}{Other arguments that are passed to the getField function for the specific Format or additional arguements for selecting space/time/years. For all Formats, the followings arguments apply: \itemize{ - \item{\code{cover.fraction}} When selecting gridcells based on a SpatialPolygonsDataFrame (ie from a shapefile) as the \code{spatial.extent} argument, this optional arguement determines + \item{\code{cover.fraction}} When selecting gridcells based on a \code{sf} object (ie from a shapefile) as the \code{spatial.extent} argument, this optional arguement determines how much of the gridcell needs to be in the the polygon for it to be selected. Should be between 0 and 1. } For the aDGVM(1) Format, the following arguments apply: From 9d00d567257db62f83d289cb066759d85d4ff3f6 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Tue, 20 Aug 2024 14:52:24 +0000 Subject: [PATCH 02/20] Started plotScatterComparison() Barest functionality is there. --- DESCRIPTION | 4 +- NAMESPACE | 2 + R/plotScatterComparison.R | 169 ++++++++++++++++++++++++++++++++++++++ R/plotScatter_old.R | 80 ++++++++++++++++++ 4 files changed, 254 insertions(+), 1 deletion(-) create mode 100644 R/plotScatterComparison.R create mode 100644 R/plotScatter_old.R diff --git a/DESCRIPTION b/DESCRIPTION index 65569de..290073b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,7 +40,7 @@ License: GPL | file LICENSE URL: https://www.bik-f.de BugReports: https://github.com/MagicForrest/DGVMTools/issues NeedsCompilation: no -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 VignetteBuilder: knitr Encoding: UTF-8 Collate: @@ -85,6 +85,8 @@ Collate: 'package-documentation.R' 'periods.R' 'plotScatter.R' + 'plotScatterComparison.R' + 'plotScatter_old.R' 'plotSpatial.R' 'plotSpatialComparison.R' 'plotSubannual.R' diff --git a/NAMESPACE b/NAMESPACE index a0cd6d3..be26949 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,6 +67,8 @@ export(makeSPDFfromDT) export(matchLayerCols) export(periods) export(plotScatter) +export(plotScatterComparison) +export(plotScatter_old) export(plotSpatial) export(plotSpatialComparison) export(plotSubannual) diff --git a/R/plotScatterComparison.R b/R/plotScatterComparison.R new file mode 100644 index 0000000..7bb7b3d --- /dev/null +++ b/R/plotScatterComparison.R @@ -0,0 +1,169 @@ +#!/usr/bin/Rscript + + +################################################################################################################################################# +################################################## PLOT COMPARISON MAPS ######################################################################### +################################################################################################################################################# + + +#' Plot a comparison between two spatial layers +#' +#' This function is for plotting maps from Comparison objects (or a list of those Comparisons). Three types of comparisons plots are supported: 'difference' - +#' a difference map; "values" - the absolute values plotted in panels and "percentage.difference" - the percentage differences. +#' +#' @param comparisons The data to plot, must be a Comparison or a list of Comparisons +#' @param type A character specifying what type of plot to make. Can be "difference" (default, for a difference plot), "percentage.difference", "values" +#' (actual values, side-by-side) or "nme" (for the Normalised Mean Error, not yet implemented) +#' @param limits A numeric vector with two members (lower and upper limit) to limit the plotted values. +#' @param legend.title A character string or expression to override the default legend title. Set to NULL for no legend title. The default legend title is the \code{units} +#' of the \linkS4class{Quantity} of the first \linkS4class{Comparison} provided in the \code{comparisions} argument. This argument allows general flexibility, but it is particularly handy +#' to facilitate expressions for nicely marked up subscript and superscript. +#' @param panel.bg.col Colour string for the panel background, default to "white" for absolute values plots, and a grey for difference plots. +#' @param override.cols A colour palette function to override the defaults. +#' @param symmetric.scale If plotting a differences, make the scale symmetric around zero (default is TRUE) +#' @param do.phase Logical, only applies to plotting Comparison objects of type "seasonal". +#' If TRUE plot the the seasonal phase, if FALSE (the default), plot the seasonal concentration. +#' @param ... Parameters passed to \link{plotSpatial} +#' +#' @details A wrapper for around \link{plotSpatial} to plot the spatial Comparisons as maps. Extra arguments to \link{plotSpatial} can also be specified. +#' +#' @return Returns a ggplot object +#' +#' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} +#' @import ggplot2 data.table +#' +#' @export +#' @seealso \link{plotSpatial}, \link{compareLayers} + +plotScatterComparison <- function(comparisons, + type = c("difference", "percentage.difference", "values", "nme"), + limits = NULL, + legend.title, + panel.bg.col = "white", + override.cols = NULL, + symmetric.scale = TRUE, + do.phase = FALSE, + ...){ + + addPerfect <- TRUE + matchLimits <- TRUE + doHex = TRUE + + Source = Value = Lat = Lon = Layer = long = lat = group = NULL + Day = Month = Year = Season = NULL + Difference = Percentage.Difference = NULL + + # sort type argument + type <- match.arg(type) + + if(!missing(limits)) symmetric.scale <- FALSE + + ### CHECK TO SEE EXACTLY WHAT WE SHOULD PLOT + + ### 1. COMPARISONS - check the input Comparison objects (and if it is a single Comparison put it into a one-item list) + + comparisons <- santiseComparisonsForPlotting(comparisons) + if(is.null(comparisons)) return(NULL) + + + ### 2. DIMENSIONS - check the dimensions (require that all fields the same dimensions) + + dim.names <- santiseDimensionsForPlotting(comparisons) + # need at least one dimension + if(is.null(dim.names)) return(NULL) + + + ### 3. CONVERT - the Comparisons into a big data.table for plotting + + # + objects.to.plot <- list() + layers.to.plot <- c() + plotting_dt <- data.table() + for(object in comparisons){ + + tmp_dt <- copy(object@data) + all_names <- names(tmp_dt) + old_names <- all_names[(length(all_names)-2):length(all_names)] + setnames(tmp_dt, old = old_names, new = c("Y", "X", "Difference")) + tmp_dt[ , Difference := NULL] + tmp_dt[ , Comparison := gsub(pattern = " - ", replacement = " vs ", x = object@name)] + plotting_dt <- rbind(plotting_dt, tmp_dt) + + + # # first make a list of the layers that we expect to be present in the data.table, based on the meta-data in the Comparison object + # layers.names <- names(object) + # expected.layers.1 <- paste(object@layers1, makeFieldID(source = object@source1, quant.string = object@quant1@id, sta.info = object@sta.info1), sep = ".") + # expected.layers.2 <- paste(object@layers2, makeFieldID(source = object@source2, quant.string = object@quant2@id, sta.info = object@sta.info2), sep = ".") + # + # # check the layers + # for(this.layer in expected.layers.1) if(!this.layer %in% layers.names) stop(paste("Layer", this.layer, "expected in Comparison object but not found")) + # for(this.layer in expected.layers.2) if(!this.layer %in% layers.names) stop(paste("Layer", this.layer, "expected in Comparison object but not found")) + # + # # adjust the source ids if they are identical + # if(object@source1@id == object@source2@id) { + # + # # include the first and last years if they are not the same + # if((object@sta.info1@first.year != object@sta.info2@first.year) && (object@sta.info1@last.year != object@sta.info2@last.year)){ + # object@source1@name <- paste0(object@source1@name, " (", object@sta.info1@first.year, "-", object@sta.info1@last.year, ")") + # object@source2@name <- paste0(object@source2@name, " (", object@sta.info2@first.year, "-", object@sta.info2@last.year, ")") + # } + # + # } + # + # + # + # # SECOND INFO - putting this first because this is the 'base' dataset ("one minus two" convention) + # new.dt <- object@data[, append(getDimInfo(object), expected.layers.2), with=FALSE] + # #setnames(new.dt, names(new.dt)[length(names(new.dt))], object@quant2@id ) + # setnames(new.dt, expected.layers.2, object@layers2) + # layers.to.plot <- append(layers.to.plot, object@layers2) + # objects.to.plot[[length(objects.to.plot)+1]] <- new("Field", + # id = object@id, + # data = new.dt, + # quant = object@quant2, + # source = object@source2, + # object@sta.info2) + # + # # FIRST INFO + # new.dt <- object@data[, append(getDimInfo(object), expected.layers.1), with=FALSE] + # #setnames(new.dt, names(new.dt)[length(names(new.dt))], object@quant1@id ) + # setnames(new.dt, expected.layers.1, object@layers1 ) + # layers.to.plot <- append(layers.to.plot, object@layers1) + # objects.to.plot[[length(objects.to.plot)+1]] <- new("Field", + # id = object@id, + # data = new.dt, + # quant = object@quant1, + # source = object@source1, + # object@sta.info1) + # + } + + # make a legend title if one has not been supplied + #if(missing(legend.title)) legend.title <- stringToExpression(standardiseUnitString(object@quant1@units)) + + this_plot <- ggplot(plotting_dt, aes(x = X, y = Y)) + if(doHex){ + this_plot <- this_plot + geom_hex() + this_plot <- this_plot + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") + } + else{ + this_plot <- this_plot + geom_point() + } + + this_plot <- this_plot + facet_wrap(facets = vars(Comparison)) + if(matchLimits) { + mylims <- range(with(plotting_dt, c(X, Y))) + this_plot <- this_plot + coord_cartesian(xlim = mylims, ylim = mylims) + } + if(addPerfect) this_plot <- this_plot + geom_abline(slope=1, intercept = 0, col = "black") + + + return(this_plot) + + + + + + + +} \ No newline at end of file diff --git a/R/plotScatter_old.R b/R/plotScatter_old.R new file mode 100644 index 0000000..7c6ce88 --- /dev/null +++ b/R/plotScatter_old.R @@ -0,0 +1,80 @@ +#' Make a scatter plot +#' +#' This simple function makes (and returns it as an object, it doesn't print it) a simple scatter plot (using ggplot2). +#' The data are two layers from either one or two Field objects. Data points which appear in one Field but not the other are excluded +#' +#' @param x The first DGVMTools::Field or Comparison object from which the data to be plotted should be taken. +#' @param y The second DGVMTools::Field or Comparison object from which the data to be plotted should be taken. +#' Default value is x. +#' @param layer.x The first layer to be plotted (taken from x) +#' @param layer.y The second layer to be plotted (taken from y). Defaults to layer.x. +#' @param alpha Numeric between 0 and 1 specifing the transparency of the points. Default is 1 (= fully opaque). +#' @param text.multiplier A number specifying an overall multiplier for the text on the plot. +#' Make it bigger if the text is too small on large plots and vice-versa. +#' @param tolerance Numeric, passed to copyLayers. Defines how close the longitudes and latitudes of the gridcells in \code{x} and \code{y} (if different) +#' need to be to the coordinates in order to get a match. Can be a single numeric (for the same tolerance for both lon and lat) or a vector of two numerics (for lon and lat separately). +#' Default is no rounding (value is NULL) and so is fine for most regular spaced grids. However, setting this can be useful to force matching of +#' coordinates with many decimal places which may have lost a small amount of precision and so don't match exactly. +#' +#' @return A ggplot2 object +#' @export +#' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} +plotScatter_old <- function(x, y = x, layer.x, layer.y = layer.x, alpha = 1, text.multiplier, tolerance = NULL) { + + # check + if(identical(layer.x, layer.y) && identical(x, y)) stop("To make a meaningful scatter plot I need either two different layers, or a two different Fields, or both!)") + + # extract the data.tables + if(is.Field(x) || is.Comparison(x)) x.dt <- copy(x@data) + else if(is.data.table(x)) x.dt <- copy(x) + else stop(paste("Cannot plot scatter from object x of type:", paste(class(x), collapse = " "))) + if(is.Field(y) || is.Comparison(y)) y.dt <- copy(y@data) + else if(is.data.table(y)) y.dt <- copy(y) + else stop(paste("Cannot plot scatter object y of type:", paste(class(y), collapse = " "))) + + # rename layers if they are the same + old.layer.y <- layer.y + old.layer.x <- layer.x + if(identical(layer.x, layer.y)) { + old.layer.y <- layer.y + old.layer.x <- layer.x + layer.y <- paste(y@source@id, layer.y, sep = "_") + layer.x <- paste(x@source@id, layer.x, sep = "_") + setnames(y.dt, old.layer.y, layer.y) + setnames(x.dt, old.layer.x, layer.x) + } + + # copy layers to one data.table + if(!identical(x, y)) { + to.plot <- x.dt[, append(getDimInfo(x.dt), layer.x), with = FALSE] + to.plot <- copyLayers(from = y.dt, to = to.plot, layer.names = layer.y, keep.all.to = FALSE, keep.all.from = FALSE, tolerance = tolerance) + } + else { + to.plot <- x.dt[, append(getDimInfo(x.dt), c(layer.x, layer.y)), with = FALSE] + } + + + # remove spaces and -" "from column names otherwise ggplot2 goes a bit flooby (although check out 'tidyevaluation' to maybe do this nicer) + for(this.character in c(" ", "-")) { + x.new <- gsub(x = layer.x, pattern = this.character, replacement = "_") + y.new <- gsub(x = layer.y, pattern = this.character, replacement = "_") + } + setnames(to.plot, c(layer.x, layer.y), c(x.new, y.new)) + + + # make the scatter plot + scatter.plot <- ggplot(as.data.frame(stats::na.omit(to.plot)), aes(x=.data[[x.new]], y=.data[[y.new]])) + geom_point(size=3, alpha = alpha) + if(!missing(text.multiplier)) scatter.plot <- scatter.plot + theme(text = element_text(size = theme_get()$text$size * text.multiplier)) + + # labels depending on input type + if(is.Field(x) && is.Field(y)) { + scatter.plot <- scatter.plot + labs(y = stringToExpression(paste0(old.layer.y, " ", y@source@name, " ", y@quant@name, " (", standardiseUnitString(y@quant@units), ")")), + x = stringToExpression(paste0(old.layer.x, " ", x@source@name, " ", x@quant@name, " (", standardiseUnitString(x@quant@units), ")"))) + } + else scatter.plot <- scatter.plot + labs(y = layer.y, x = layer.x) + + + + return(scatter.plot) + +} \ No newline at end of file From 475ae980df57a1f6f301f3f34536f26d443b2053 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Wed, 21 Aug 2024 15:23:02 +0000 Subject: [PATCH 03/20] First version of plotXYComparison() The function itself, but also a few changes to auxiliary function.s --- DESCRIPTION | 1 + NAMESPACE | 2 +- R/commonSTAInfo.R | 3 +- R/makePlotTitle.R | 7 +- R/plotScatter.R | 423 +++++++++++++++--- ...ScatterComparison.R => plotXYComparison.R} | 85 ++-- R/plotting-framework-functions.R | 218 ++++++++- 7 files changed, 641 insertions(+), 98 deletions(-) rename R/{plotScatterComparison.R => plotXYComparison.R} (72%) diff --git a/DESCRIPTION b/DESCRIPTION index 290073b..260ea3b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -92,6 +92,7 @@ Collate: 'plotSubannual.R' 'plotTemporal.R' 'plotTemporalComparison.R' + 'plotXYComparison.R' 'plotting-framework-functions.R' 'read-netcdf-utility-functions.R' 'renameLayers.R' diff --git a/NAMESPACE b/NAMESPACE index be26949..665db89 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,13 +67,13 @@ export(makeSPDFfromDT) export(matchLayerCols) export(periods) export(plotScatter) -export(plotScatterComparison) export(plotScatter_old) export(plotSpatial) export(plotSpatialComparison) export(plotSubannual) export(plotTemporal) export(plotTemporalComparison) +export(plotXYComparison) export(promoteToRaster) export(proportionsComparison) export(renameLayers) diff --git a/R/commonSTAInfo.R b/R/commonSTAInfo.R index a19cc6c..a8de765 100644 --- a/R/commonSTAInfo.R +++ b/R/commonSTAInfo.R @@ -12,11 +12,12 @@ commonSTAInfo <- function(sta.objects, logical = FALSE) { sta.infos <- list() - if(is.Field(sta.objects) || is.STAInfo(sta.objects)) sta.objects <- list(sta.objects) + if(is.Field(sta.objects) || is.STAInfo(sta.objects) ||is.Comparison(sta.objects)) sta.objects <- list(sta.objects) for(sta.object in sta.objects) { if(is.Field(sta.object)) sta.infos[[length(sta.infos)+1]] <- as(sta.object, "STAInfo") else if(is.STAInfo(sta.object)) sta.infos[[length(sta.infos)+1]] <- sta.object + else if(is.Comparison(sta.object)) sta.infos[[length(sta.infos)+1]] <- commonSTAInfo(list(sta.object@sta.info1, sta.object@sta.info2)) else warning(paste("No STAInfo can be derived from class", class(sta.object), "so ignoring it", sep = " ")) } diff --git a/R/makePlotTitle.R b/R/makePlotTitle.R index 0b1c1f4..566f6e6 100644 --- a/R/makePlotTitle.R +++ b/R/makePlotTitle.R @@ -134,9 +134,10 @@ makePlotTitle <- function(fields){ layers.vec <- c() for(field in fields) { layers.vec <- append(layers.vec, names(field)) - sources.vec <- append(sources.vec, field@source@name ) - quants.vec <- append(quants.vec, field@quant@name ) - quants.id.vec <- append(quants.id.vec, field@quant@id) + if(is.Field(field)) sources.vec <- append(sources.vec, field@source@name ) + else if(is.Comparison(field)) sources.vec <- append(sources.vec, field@name ) + if(is.Field(field)) quants.vec <- append(quants.vec, field@quant@name ) + if(is.Field(field)) quants.id.vec <- append(quants.id.vec, field@quant@id) } sources.vec <- unique(sources.vec) quants.vec <- unique(quants.vec) diff --git a/R/plotScatter.R b/R/plotScatter.R index 65a8dbf..12c4463 100644 --- a/R/plotScatter.R +++ b/R/plotScatter.R @@ -1,80 +1,385 @@ -#' Make a scatter plot + +#' Scatter plots #' -#' This simple function makes (and returns it as an object, it doesn't print it) a simple scatter plot (using ggplot2). -#' The data are two layers from either one or two Field objects. Data points which appear in one Field but not the other are excluded +#' For a list of Fields, compare layers using scatter plots. Automatically splits data into separate panels based on Source, Quantity, +#' Sire and/or Region, but instead these can be distinguished by aesthetics - see the \code{col.by}, \code{linetype.by} and \code{alpha.by} arguments. +#' Summary or aggregate function can optionally be applied and plotted on top. #' -#' @param x The first DGVMTools::Field or Comparison object from which the data to be plotted should be taken. -#' @param y The second DGVMTools::Field or Comparison object from which the data to be plotted should be taken. -#' Default value is x. -#' @param layer.x The first layer to be plotted (taken from x) -#' @param layer.y The second layer to be plotted (taken from y). Defaults to layer.x. -#' @param alpha Numeric between 0 and 1 specifing the transparency of the points. Default is 1 (= fully opaque). +#' @param fields The data to plot. Can be a Field or a list of Fields. +#' @param layers A list of strings specifying which layers to plot. Defaults to all layers. +#' @param gridcells A list of gridcells to be plotted (either in different panels or the same panel). For formatting of this argument see \code{selectGridcells}. +#' Leave empty or NULL to plot all gridsizrecells (but note that if this involves too many gridcells the code will stop) +#' @param title A character string to override the default title. +#' @param subtitle A character string to override the default subtitle. +#' @param x.label,y.label Character strings (or expressions) for the x and y axes (optional) +#' @param col.by,linetype.by,alpha.by Character strings defining the aspects of the data which which should be used to set the colour, line type and alpha (transparency). +#' Can meaningfully take the values "Layer", "Source", "Site", "Region" or "Quantity". +#' NOTE SPECIAL DEFAULT CASE: By default, \code{col.by} is set to "Year" which means that the years are plotted according to a colour gradient, and all other aspects of the +#' the data are distinguished by different facet panels. To change this behaviour and colour the lines according to something different, set the "col.by" argument to one of the +#' strings suggested above. +#' @param cols,linetypes,alphas A vector of colours, line types, or alpha values (respectively) to control the aesthetics of the lines. +#' Only "cols" makes sense without a corresponding "xxx.by" argument (see above). The vectors can/should be named to match particular col/linetype/alpha values +#' to particular Layers/Sources/Sites/Quantities/Regions. +#' @param col.labels,linetype.labels,alpha.labels A vector of character strings which are used as the labels for the lines. Must have the same length as the +#' number of Sources/Layers/Sites/Quantities in the plot. The vectors can/should be named to match particular col/linewtype/alpha values to particular Layers/Sources/Sites/Quantities/Region. +#' @param linewidth Numeric (as ggplot2), width of the lines on the plot, consistent with ggplot2. Note the width is doubled for the aggregate/summary line. +#' @param size Numeric, size of the points for the aggregate/summary data, consistent with ggplot2. +#' @param summary.function A function to summarise (aggregate) across year and plot on top. Obvious choice is \code{mean}, but there is flexibility to anything that operates on +#' a vector of numerics - eg median, a 95th percentile, standard deviation. +#' @param summary.function.label An optional character string to give a pretty label to the summary function legend. #' @param text.multiplier A number specifying an overall multiplier for the text on the plot. #' Make it bigger if the text is too small on large plots and vice-versa. -#' @param tolerance Numeric, passed to copyLayers. Defines how close the longitudes and latitudes of the gridcells in \code{x} and \code{y} (if different) -#' need to be to the coordinates in order to get a match. Can be a single numeric (for the same tolerance for both lon and lat) or a vector of two numerics (for lon and lat separately). -#' Default is no rounding (value is NULL) and so is fine for most regular spaced grids. However, setting this can be useful to force matching of -#' coordinates with many decimal places which may have lost a small amount of precision and so don't match exactly. +#' @param plot Boolean, if FALSE return a data.table with the final data instead of the ggplot object. This can be useful for inspecting the structure of the facetting columns, amongst other things. +#' @param ... Arguments passed to \code{ggplot2::facet_wrap()}. See the ggplot2 documentation for full details but the following are particularly useful. +#' \itemize{ +#' \item{"nrow"}{The number of rows of facets} +#' \item{"ncol"}{The number of columns of facets} +#' \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) +#' "free" (all facets can their x and y ranges), "free_x" and "free_y" (only x and y ranges can vary, respectively).} +#' \item{"labeller"}{A function to define the labels for the facets. This is a little tricky, please look to the ggplot2 documentation} +#' } #' -#' @return A ggplot2 object +#' @details +#' +#' Note that like all \code{DGVMTools} plotting functions, \code{plotSubannual} splits the data into separate panels using the \code{ggplot2::facet_wrap()}. If you want to 'grid' the facets +#' using \code{ggplot2::facet_grid()} you can do so afterwards. 'gridding the facets' implies the each column and row of facets vary by one specific aspect. +#' For example you might have one column for each Source, and one row for each "Quantity". +#' +#' +#' +#' @return Returns either a ggplot2 object or a data.table (depending on the 'plot' argument) +#' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} #' @export -#' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} -plotScatter <- function(x, y = x, layer.x, layer.y = layer.x, alpha = 1, text.multiplier, tolerance = NULL) { - - # check - if(identical(layer.x, layer.y) && identical(x, y)) stop("To make a meaningful scatter plot I need either two different layers, or a two different Fields, or both!)") - - # extract the data.tables - if(is.Field(x) || is.Comparison(x)) x.dt <- copy(x@data) - else if(is.data.table(x)) x.dt <- copy(x) - else stop(paste("Cannot plot scatter from object x of type:", paste(class(x), collapse = " "))) - if(is.Field(y) || is.Comparison(y)) y.dt <- copy(y@data) - else if(is.data.table(y)) y.dt <- copy(y) - else stop(paste("Cannot plot scatter object y of type:", paste(class(y), collapse = " "))) - - # rename layers if they are the same - old.layer.y <- layer.y - old.layer.x <- layer.x - if(identical(layer.x, layer.y)) { - old.layer.y <- layer.y - old.layer.x <- layer.x - layer.y <- paste(y@source@id, layer.y, sep = "_") - layer.x <- paste(x@source@id, layer.x, sep = "_") - setnames(y.dt, old.layer.y, layer.y) - setnames(x.dt, old.layer.x, layer.x) + + + +plotScatter <- function(fields1, # can be a Field or a list of Fields + fields2=fields1, # can be a Field or a list of Fields + layers1, + layers2 = layers1, + gridcells = NULL, + title = NULL, + subtitle = NULL, + cols = NULL, + col.by = "Year", + col.labels = waiver(), + linetypes = NULL, + linetype.by = NULL, + linetype.labels = waiver(), + alphas = NULL, + alpha.by = NULL, + alpha.labels = waiver(), + linewidth = 0.5, + size = 3 , + y.label = NULL, + x.label = NULL, + summary.function, + summary.function.label = deparse(substitute(summary.function)), + text.multiplier = NULL, + plot = TRUE, + ...) { + + + Quantity = Month = Source = Value = Year = PlotGroup = StatsGroup = NULL + + ### CHECK INPUTS AND HANDLE SPECIAL CASES + + # set a flag for the special case of colouring by year + special_case_year_colour <- FALSE + if(identical(col.by,"Year")) { + special_case_year_colour <- TRUE + if(!missing(cols) || !is.null(cols)) { + warning("'cols' argument ignored since colouring by Year and therefore using a continuous scale") + cols <- NULL + } + } + + + + ### SANITISE FIELDS, LAYERS AND DIMENSIONS + + ## 1. FIELDS - check the input Field objects (and if it is a single Field put it into a one-item list) + + fields1 <- santiseFieldsForPlotting(fields1) + if(is.null(fields1)) return(NULL) + fields2 <- santiseFieldsForPlotting(fields2) + if(is.null(fields2)) return(NULL) + + ## 3. DIMENSIONS - check the dimensions (require that all fields the same dimensions) + + # check the Fields for consistent dimensions + dim.names <- santiseDimensionsForPlotting(append(fields1, fields2)) + if(is.null(dim.names)) return(NULL) + + ## 2. LAYERS - check the number of layers + + # this is special version for plotScatter since + plot_dt <- santiseLayersForPlottingXY(fields1, fields2, layers1, layers2) + print(plot_dt) + if(is.null(layers)) return(NULL) + + + + + + ### PREPARE AND CHECK DATA FOR PLOTTING + final.fields <- trimFieldsForPlottingXY(fields, layers, gridcells = gridcells) + + ### MERGE DATA FOR PLOTTING INTO ONE BIG DATA.TABLE + # MF TODO maybe make some clever checks on these switches + if("Lon" %in% dim.names & "Lat" %in% dim.names) add.Site <- TRUE + else add.Site <- FALSE + add.Region <- TRUE + + # MF TODO: Consider adding add.TimePeriod? + data.toplot <- mergeFieldsForPlotting(final.fields, add.Quantity = TRUE, add.Site = add.Site, add.Region = TRUE) + + ### CHECK IS YEAR IS PRESENT + if(!("Year" %in% names(data.toplot))) { + special_case_year_colour <- FALSE + if(missing(col.by)) col.by = NULL + } + + + ### XX. FACETTING + + # all column names, used a lot below + all.columns <- names(data.toplot) + + # check the "xxx.by" arguments + if(!missing(col.by) && !is.null(col.by) && !col.by %in% all.columns) stop(paste("Colouring by", col.by, "requested, but that is not available, so failing.")) + if(!missing(linetype.by) && !is.null(linetype.by) && !linetype.by %in% all.columns) stop(paste("Setting linetypes by", linetype.by, "requested, but that is not available, so failing.")) + if(!missing(alpha.by) && !is.null(alpha.by) && !alpha.by %in% all.columns) stop(paste("Setting alphas by", alpha.by, "requested, but that is not available, so failing.")) + + # ar first assume facetting by everything except for... + dontFacet <- c("Value", "Time", "Year", "Month", "Season", "Day", "Lon", "Lat", col.by, linetype.by, alpha.by) + facet.vars <- all.columns[!all.columns %in% dontFacet] + + # then remove facets with only one unique value + for(this.facet in facet.vars) { + if(length(unique(data.toplot[[this.facet]])) == 1) facet.vars <- facet.vars[!facet.vars == this.facet] } - # copy layers to one data.table - if(!identical(x, y)) { - to.plot <- x.dt[, append(getDimInfo(x.dt), layer.x), with = FALSE] - to.plot <- copyLayers(from = y.dt, to = to.plot, layer.names = layer.y, keep.all.to = FALSE, keep.all.from = FALSE, tolerance = tolerance) + + ### LEGEND ENTRY ORDERING + # ## Fix order of items in legend(s) by making them factors with levels corresponding to the order of the input fields + # all.sources <- list() + # # first loop across the fields + # for(this.field in fields) { + # all.sources <- append(all.sources, this.field@source@name) + # } + # if("Source" %in% names(data.toplot)) data.toplot[, Source := factor(Source, levels = unique(all.sources))] + + + ### 7. MAKE THE Y-AXIS LABEL + if(is.null(y.label)) { + y.label <- makeYAxis(final.fields) } - else { - to.plot <- x.dt[, append(getDimInfo(x.dt), c(layer.x, layer.y)), with = FALSE] + + ### MATCH LAYER COLOUR + + # if cols is not specified and plots are to be coloured by Layers, look up line colours from Layer meta-data + if(missing(cols) && !is.null(col.by) && col.by == "Layer"){ + + # check the defined Layers present in the Fields and make a unique list + # maybe also here check which one are actually in the layers to plot, since we have that information + all.layers.defined <- list() + for(object in fields){ + all.layers.defined <- append(all.layers.defined, object@source@defined.layers) + } + all.layers.defined <- unique(all.layers.defined) + + + all.layers <- unique(as.character(data.toplot[["Layer"]])) + cols <- matchLayerCols(all.layers, all.layers.defined) } + #### MAKE LIST OF QUANTITIES AND UNITS FOR Y LABEL + + ### DEPRECATED BY CALL TO makeYAxis() above, but some functionality might be needed to keep for now. + + # unit.str <- list() + # quant.str <- list() + # id.str <- list() + # for(this.field in final.fields) { + # + # # pull out the unit string, id and full name string + # quant <- this.field@quant + # unit.str <- append(unit.str, quant@units) + # quant.str <- append(quant.str, quant@name) + # id.str <- append(id.str, quant@id) + # + # } + # + # # check the units + # if(length(unique(unit.str)) == 1){ + # unit.str <- unique(unit.str) + # } + # else { + # unit.str <- paste(unique(unit.str), collapse = ", ") + # warning("Quants to be plotted have non-identical units in plotSeasonal().") + # } + # + # # check the strings + # if(length(unique(quant.str)) == 1){ quant.str <- unique(quant.str) } + # else{ quant.str <- paste(id.str, sep = ", ", collapse = ", ") } + + + ### MAKE A DESCRIPTIVE TITLE IF ONE HAS NOT BEEN SUPPLIED + if(missing(title) || missing(subtitle)) { + titles <- makePlotTitle(final.fields) + if(missing(title)) title <- titles[["title"]] + else if(is.null(title)) title <- waiver() + if(missing(subtitle)) subtitle <- titles[["subtitle"]] + else if(is.null(subtitle)) subtitle <- waiver() + } + + - # remove spaces and -" "from column names otherwise ggplot2 goes a bit flooby (although check out 'tidyevaluation' to maybe do this nicer) - for(this.character in c(" ", "-")) { - x.new <- gsub(x = layer.x, pattern = this.character, replacement = "_") - y.new <- gsub(x = layer.y, pattern = this.character, replacement = "_") + ### MAKE THE GROUPS - these are columns for ggplot which are essentially interaction terms to group the data + + # The plot group + + # include Year only if not colouring by year + if(special_case_year_colour) interaction_list <- c() + else { + if("Year" %in% names(data.toplot)) interaction_list <- c("Year") + else interaction_list <- c() + } + + # include the other columns if required for an aesthetic + if(!is.null(col.by)) { + interaction_list <- append(interaction_list, col.by) # special case for col.by because if missing is taken to be "Year" } - setnames(to.plot, c(layer.x, layer.y), c(x.new, y.new)) + if(!missing(linetype.by) && !is.null(linetype.by)) interaction_list <- append(interaction_list, linetype.by) + if(!missing(alpha.by) && !is.null(alpha.by)) interaction_list <- append(interaction_list, alpha.by) + + # and now make the interaction column + data.toplot[, PlotGroup := interaction(.SD), .SDcols = interaction_list] + + + # The Stats Group - this is much easier since we every possible combination must have it's own stat + stats_SDcols <- names(data.toplot) %in% c("Source", "Quantity", "Layer", "Region", "Site") + data.toplot[, StatsGroup := interaction(.SD), .SDcols = stats_SDcols] + - # make the scatter plot - scatter.plot <- ggplot(as.data.frame(stats::na.omit(to.plot)), aes(x=.data[[x.new]], y=.data[[y.new]])) + geom_point(size=3, alpha = alpha) - if(!missing(text.multiplier)) scatter.plot <- scatter.plot + theme(text = element_text(size = theme_get()$text$size * text.multiplier)) + ###### MAKE THE PLOT ##### - # labels depending on input type - if(is.Field(x) && is.Field(y)) { - scatter.plot <- scatter.plot + labs(y = stringToExpression(paste0(old.layer.y, " ", y@source@name, " ", y@quant@name, " (", standardiseUnitString(y@quant@units), ")")), - x = stringToExpression(paste0(old.layer.x, " ", x@source@name, " ", x@quant@name, " (", standardiseUnitString(x@quant@units), ")"))) + # return the data if plot = FALSE + if(!plot) return(data.toplot) + + # make the "symbols" for the ggplot2 call. A bit of a pain -since they ggplot2 folks took away aes_string()- but what can you do... + col.sym <- if(is.character(col.by)) ensym(col.by) else NULL + alpha.sym <- if(is.character(alpha.by)) ensym(alpha.by) else NULL + linetype.sym <- if(is.character(linetype.by)) ensym(linetype.by) else NULL + + # build the basic plot + p <- ggplot(as.data.frame(data.toplot), aes(x = .data[[subannual.dimension]], y = Value, group = PlotGroup, + col = !! col.sym, + alpha = !! alpha.sym, + linetype = !! linetype.sym)) + + # build arguments for aesthetics to geom_line/geom_line and/or fixed arguments outside + geom_args <- list() + + # col, alpha and linetyp + if(!is.null(cols) && is.null(col.by)) geom_args[["colour"]] <- cols + if(!is.null(alphas) && is.null(alpha.by)) geom_args[["alpha"]] <- alphas + if(!is.null(linetypes) && is.null(linetype.by)) geom_args[["linetype"]] <- linetypes + + # line width if a fixed value for all + geom_args[["linewidth"]] <- linewidth + + # call geom_line (with fixed aesthetics define above) + p <- p + do.call(geom_line, geom_args) + + + # add scales for the defined aesthetics + + # colour scale is a special case for two reasons, + # 1. if col.by not variable provided, then the special case is activated and colour by year (and hence we have a continuous colour scale) + # 2. if no colours provided, use a viridis pallete to override ggplot2 + if(special_case_year_colour) p <- p + viridis::scale_color_viridis(name = "Year") + else if (!is.null(col.by) & !is.null(cols)) p <- p + scale_color_manual(values=cols, labels=col.labels) + else p <- p + viridis::scale_colour_viridis(discrete=TRUE, option = "C", end = 0.9 ) + + # these are simply defined by the arguments, no special cases + if(!is.null(linetype.by) & !is.null(linetypes)) p <- p + scale_linetype_manual(values=linetypes, labels=linetype.labels) + if(!is.null(alpha.by) & !is.null(alphas)) p <- p + scale_alpha_manual(values=alphas, labels=alpha.labels) + + # set the theme to theme_bw, simplest way to set the background to white + p <- p + theme_bw() + + # make scale a bit bigger - consider removing for purity?? this can easy be controlled by the user + p <- p + theme(legend.key.size = unit(2, 'lines')) + + + # if chosen, plot the average year + if(!missing(summary.function)) { + + # if is the special case where we colour by year + if(special_case_year_colour) { + + # NOTE in this case we always use black + + # special case to add a line type scale if it wasn't already added + # honestly not sure exactly why this works and many other things I tried didn't work + if(missing(linetype.by) || is.null(linetype.by)) { + + p <- p + stat_summary(aes(group=col.by, linetype = "dummy string"), fun=summary.function, geom="line", color="black", linewidth = linewidth * 2) + p <- p + scale_linetype_manual(values=c("dummy string"="solid"), labels = c("dummy string" = summary.function.label), name = element_blank()) + + } + # if linetypes are already specified + else{ + p <- p + stat_summary(aes(group=StatsGroup, linetype = .data[[linetype.by]]), fun=summary.function, geom="line", color="black", linewidth = linewidth * 2) + # title the legend + p <- p + labs(linetype=summary.function.label) + } + + + + } + #if *not* the special case where we colour by year + else { + + # add the stats + p <- p + stat_summary(aes(group=StatsGroup, fill = get(col.by)), fun=summary.function, geom="point", color="black", shape = 21, size = size) + + # colour the points appropriately + if(!is.null(cols)) p <- p + scale_fill_manual(values = cols, name = summary.function.label, labels = col.labels) + else p <- p + viridis::scale_fill_viridis(name = summary.function.label, labels = col.labels, discrete = TRUE, option = "C", end = 0.9 ) + p <- p + labs(shape=summary.function.label ) + + # also add linetype if necessary + if(!missing(linetype.by) && !is.null(linetype.by)) { + p <- p + stat_summary(aes(group=StatsGroup, linetype = .data[[linetype.by]]), fun=summary.function, geom="line", color="black", linewidth = linewidth * 2) + } + + } + } - else scatter.plot <- scatter.plot + labs(y = layer.y, x = layer.x) + # set the x-axis + if(subannual.dimension == "Month") p <- p + scale_x_continuous(breaks = 1:12, labels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun","Jul", "Aug", "Sep","Oct","Nov","Dec")) + + # set the title + p <- p + labs(title = title, subtitle = subtitle, y = y.label, x = subannual.dimension) + + p <- p + theme(plot.title = element_text(hjust = 0.5), + plot.subtitle = element_text(hjust = 0.5)) + + # set legend + p <- p + theme(legend.position = "right", legend.key.size = unit(2, 'lines')) + + # facet if necessary + if(length(facet.vars) > 0) p <- p + facet_wrap(facet.vars, ...) + + # overall text multiplier + if(!is.null(text.multiplier)) p <- p + theme(text = element_text(size = theme_get()$text$size * text.multiplier)) - return(scatter.plot) + return(p) -} \ No newline at end of file +} diff --git a/R/plotScatterComparison.R b/R/plotXYComparison.R similarity index 72% rename from R/plotScatterComparison.R rename to R/plotXYComparison.R index 7bb7b3d..3182eff 100644 --- a/R/plotScatterComparison.R +++ b/R/plotXYComparison.R @@ -35,28 +35,20 @@ #' @export #' @seealso \link{plotSpatial}, \link{compareLayers} -plotScatterComparison <- function(comparisons, - type = c("difference", "percentage.difference", "values", "nme"), - limits = NULL, - legend.title, - panel.bg.col = "white", - override.cols = NULL, - symmetric.scale = TRUE, - do.phase = FALSE, +plotXYComparison <- function(comparisons, + type = c("points", "hex", "bin2d"), + fit_line_col = NULL, + perfect_line_col = NULL, + matchLimits = TRUE, ...){ - addPerfect <- TRUE - matchLimits <- TRUE - doHex = TRUE - Source = Value = Lat = Lon = Layer = long = lat = group = NULL Day = Month = Year = Season = NULL - Difference = Percentage.Difference = NULL - + # sort type argument type <- match.arg(type) - if(!missing(limits)) symmetric.scale <- FALSE + ### CHECK TO SEE EXACTLY WHAT WE SHOULD PLOT @@ -75,19 +67,21 @@ plotScatterComparison <- function(comparisons, ### 3. CONVERT - the Comparisons into a big data.table for plotting - # - objects.to.plot <- list() - layers.to.plot <- c() plotting_dt <- data.table() - for(object in comparisons){ + fit_lines_dt <- data.table() + for(object in comparisons){ + + pretty_comparison_name <- gsub(pattern = " - ", replacement = " vs ", x = object@name) tmp_dt <- copy(object@data) all_names <- names(tmp_dt) old_names <- all_names[(length(all_names)-2):length(all_names)] setnames(tmp_dt, old = old_names, new = c("Y", "X", "Difference")) tmp_dt[ , Difference := NULL] - tmp_dt[ , Comparison := gsub(pattern = " - ", replacement = " vs ", x = object@name)] + tmp_dt[ , Comparison := pretty_comparison_name] plotting_dt <- rbind(plotting_dt, tmp_dt) + fit_lines_dt <- rbind(data.table(slope = object@stats$m, intercept = object@stats$c, Comparison = pretty_comparison_name), + fit_lines_dt) # # first make a list of the layers that we expect to be present in the data.table, based on the meta-data in the Comparison object @@ -137,28 +131,57 @@ plotScatterComparison <- function(comparisons, # object@sta.info1) # } - + # make a legend title if one has not been supplied #if(missing(legend.title)) legend.title <- stringToExpression(standardiseUnitString(object@quant1@units)) - this_plot <- ggplot(plotting_dt, aes(x = X, y = Y)) - if(doHex){ - this_plot <- this_plot + geom_hex() - this_plot <- this_plot + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") + # if plotting a single comparison object + # - + + # default labels + y_label <- "Change me with '+ ylab()'" + x_label <- "Change me with '+ xlab()'" + subtitle <- waiver() + titles <- makePlotTitle(comparisons) + subtitle <- titles[["subtitle"]] + title <-titles[["title"]] + if(length(comparisons) == 1) { + x_label <- stringToExpression(paste0(comparisons[[1]]@source1@name, " ", comparisons[[1]]@quant1@name, " (", standardiseUnitString(comparisons[[1]]@quant1@units), ")")) + y_label <- stringToExpression(paste0(comparisons[[1]]@source2@name, " ", comparisons[[1]]@quant2@name, " (", standardiseUnitString(comparisons[[1]]@quant2@units), ")")) } - else{ - this_plot <- this_plot + geom_point() + + scatter_plot <- ggplot(plotting_dt, aes(x = X, y = Y)) + if(type == "hex"){ + scatter_plot <- scatter_plot + geom_hex() + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") + } + else if(type == "points"){ + scatter_plot <- scatter_plot + geom_point() + } + else if(type == "bin2d"){ + scatter_plot <- scatter_plot + geom_bin2d() + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") + } + + if(length(comparisons) > 1) { + scatter_plot <- scatter_plot + facet_wrap(facets = vars(Comparison)) } - this_plot <- this_plot + facet_wrap(facets = vars(Comparison)) if(matchLimits) { mylims <- range(with(plotting_dt, c(X, Y))) - this_plot <- this_plot + coord_cartesian(xlim = mylims, ylim = mylims) + scatter_plot <- scatter_plot + coord_cartesian(xlim = mylims, ylim = mylims) } - if(addPerfect) this_plot <- this_plot + geom_abline(slope=1, intercept = 0, col = "black") + if(!missing(perfect_line_col) & !is.null(fit_line_col)) scatter_plot <- scatter_plot + geom_abline(slope=1, intercept = 0, col = perfect_line_col, linetype = "dashed") + if(!missing(fit_line_col) & !is.null(fit_line_col)) scatter_plot <- scatter_plot + geom_abline(data = fit_lines_dt, aes(slope=slope, intercept = intercept), col = fit_line_col) + + + scatter_plot <- scatter_plot + labs(title = title, + subtitle = subtitle, + y = y_label, + x = x_label) + # set the theme to theme_bw, simplest way to set the background to white + scatter_plot <- scatter_plot + theme_bw() - return(this_plot) + return(scatter_plot) diff --git a/R/plotting-framework-functions.R b/R/plotting-framework-functions.R index d75951c..7c0dc3d 100644 --- a/R/plotting-framework-functions.R +++ b/R/plotting-framework-functions.R @@ -126,6 +126,128 @@ santiseLayersForPlotting <- function(fields, layers) { } +#' Sanitise input layers for X-Y plotting +#' +#' This is an internal helper function which checks the layers requested to be plotted against the layers in the the fields to be plotted. If layers is NULL, then +#' it returns all layers present in any fields +#' +#' @param fields The list of Fields to be plotted (should have been check by santiseFieldsForPlotting first) +#' @param layers The layers requested to be plotted +#' @return Returns character vector of the layers to be plotted +#' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} +#' @keywords internal +#' +#' +santiseLayersForPlottingXY <- function(fields1, fields2, layers1, layers2) { + + print(fields1) + print(fields2) + print(layers1) + print(layers2) + + + #### Must return a list of 2-element named, character vectors where the names are the Field + + layers.superset <- c() + num.layers.x.fields <- 0 + + # Work through all the possible combinations of fields and layers arguments + final_layers <- list() + plotting_dt <- data.table() + + # for each fields1, copy layers from each fields2 + all_comps <- list + for(fld1 in fields1){ + for(fld2 in fields2){ + all_comps <- compareLayers(field1 = fld1, field2 = fld2, layers1 = layers1, layers2 = layers2, show.stats = FALSE) + } + } + + print(plotting_dt) + return(plotting_dt) + + # a single field + if(length(fields) == 1){ + + if(length(layers) == 1) { + stop("plotScatter: Failing. You gave me one Field, so I need at least two layers, you only specified one.") + } + else if(is.null(layers) || missing(layers)){ + layers <- layers(fields[[1]]) + print(layers) + # compare every layer to every other layer + layers_todo <- layers + + for(this_layer in layers){ + print(this_layer) + # remove this layer from layers_todo + layers_todo <- layers_todo[-which(layers_todo == this_layer)] + print(layers_todo[!which(layers_todo == this_layer)]) + print(layers_todo) + for(this_second_layer in layers_todo){ + this_group <- + plotting_dt < plotting_dt + final_layers[[paste0(this_layer, "_x_", this_second_layer)]] <- c( this_layer, this_second_layer) + } + } + + } + } + + print(final_layers) + + + # if no layers argument supplied make a list of all layers present (in any object) + if(is.null(layers) || missing(layers)){ + + for(object in fields){ + temp.layers <- names(object) + num.layers.x.fields <- num.layers.x.fields + length(temp.layers) + layers.superset <- append(layers.superset, temp.layers) + } + layers <- unique(layers.superset) + + } + else if(is.character(layers)) { + + + + } + + # else if layers have been specified check that we have some of the requested layers present + else{ + + for(object in fields){ + + layers.present <- intersect(names(object), layers) + num.layers.x.fields <- num.layers.x.fields + length(layers.present) + + if(length(layers.present) == 0) {warning("Some Fields to plot don't have all the layers that were requested to plot.\n")} + layers.superset <- append(layers.superset, layers.present) + + } + + # Return empty plot if not layers found + if(num.layers.x.fields == 0){ + warning("None of the specified layers found in the objects provided to plot. Returning NULL.\n") + return(NULL) + } + + # Also check for missing layers and given a warning + missing.layers <- layers[!(layers %in% unique(layers.superset))] + if(length(missing.layers) != 0) { warning(paste("The following layers were requested to plot but not present in any of the supplied objects:", paste(missing.layers, collapse = " "), ".\n", sep = " ")) } + + # finally make a unique list of layers to be carried in to the actual plotting + layers <- unique(layers.superset) + + } + + return(layers) + +} + + + #' Sanitise STAInfo for plotting #' @@ -299,6 +421,95 @@ trimFieldsForPlotting <- function(fields, layers, years = NULL, days = NULL, mon } +#' Subsets data from Field for XY plotting +#' +#' This is an internal helper function which pulls out the data needed to make a plot from a bunch of Fields, and returns +#' a list of the Field with only the required layers and points in space and time included +#' +#' @param fields The list of Fields to be plotted (should have been check by santiseFieldsForPlotting first) +#' @param layers A character vector of the layers to be plotted +#' @param years The years to be extracted (as a numeric vector), if NULL all years are used +#' @param days The days to be extracted (as a numeric vector), if NULL all days are used +#' @param months The months to be extracted (as a numeric vector), if NULL all months are used +#' @param seasons The months to be extracted (as a character vector), if NULL all seasons are used +#' @param gridcells The months to be extracted (as a character vector), if NULL all seasons are used +#' @param dropEmpty Logical, if TRUE drop layers consisting only of zeros +#' +#' @return Returns a list of Fields +#' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} +#' @keywords internal +#' +#' +trimFieldsForPlottingXY <- function(fields, layers, years = NULL, days = NULL, months = NULL, seasons = NULL, gridcells = NULL, dropEmpty = FALSE) { + + J = Year = NULL + + discrete <- FALSE + continuous <- FALSE + + # Loop through the objects and select the layers and dimensions that we want for plotting + + final.fields <- list() + + for(object in fields){ + + # check that at least one layer is present in this object and make a list of those which are + all.layers <- names(object) + layers.present <- c() + for(this.layer in layers) { + # if layer is present + if(this.layer %in% all.layers) { + + # if dropEmpty is true check if it it non-zero before appending it + if(dropEmpty) { + if(!(object@data[[this.layer]][1] == 0 && all(duplicated(object@data[[this.layer]])[-1L]))){ + layers.present <- append(layers.present, this.layer) + } + } + # else just append it + else { + layers.present <- append(layers.present, this.layer) + } + + } # if layer present + } # for all requested layers loop + + # if at least one layer present subset it + if(length(layers.present) > 0) { + + # select the layers and time periods required and mash the data into shape + these.layers <- selectLayers(object, layers.present) + if(!is.null(years)) { + # set key to Year, subset by years, the set keys back + # note we are not doing selectYears() because we may want to select non-contiguous years + setkey(these.layers@data, Year) + these.layers@data <- these.layers@data[J(years)] + setKeyDGVM(these.layers@data) + } + if(!is.null(days)) these.layers <- selectDays(these.layers, days) + if(!is.null(months)) these.layers <- selectMonths(these.layers, months) + if(!is.null(seasons)) these.layers <- selectSeasons(these.layers, seasons) + if(!is.null(gridcells)) these.layers <- selectGridcells(these.layers, gridcells, spatial.extent.id = "Subset_For_Plotting") + + # check if layers are all continuous or discrete + for(layer in layers.present) { + if(is(object@data[[layer]], "factor") || is(object@data[[layer]], "logical") || is(object@data[[layer]], "ordered")) discrete <- TRUE + if(is(object@data[[layer]], "numeric") || is(object@data[[layer]],"integer" )) continuous <- TRUE + } + if(discrete & continuous) stop("Cannot simultaneously plot discrete and continuous layers, check your layers") + if(!discrete & !continuous) stop("Can only plot 'numeric', 'integer', 'factor', 'ordered' or 'logical' layers, check your layers") + + + final.fields <- append(final.fields, these.layers) + + } # end if length(layers.present) > 0 + + } + + return(final.fields) + +} + #' Merge data from Field for plotting #' #' This is an internal helper function which pulls out the data from a bunch of Fields to be plotted, adds columns to describe the characteristics @@ -374,12 +585,13 @@ mergeFieldsForPlotting <- function(fields, add.Quantity = FALSE, add.Site = FA #' @keywords internal #' -makeYAxis <- function(final.fields) { +makeYAxis <- function(objects) { # first extract the names and units and store them in a tuples (two element vector) for the Quantity from each Field all.quant.tuples <- list() - for(field in final.fields) { - all.quant.tuples[[length(all.quant.tuples)+1]] <- c(field@quant@name, field@quant@units) + for(object in objects) { + if(is.Field(object)) all.quant.tuples[[length(all.quant.tuples)+1]] <- c(object@quant@name, object@quant@units) + else if(is.Quantity(object)) all.quant.tuples[[length(all.quant.tuples)+1]] <- c(object@name, object@units) } # select the unique ones From c43169d9d7deadff95f0ba884ad85e84e409da32 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Thu, 22 Aug 2024 14:27:55 +0000 Subject: [PATCH 04/20] Improvements to plotXYComparison() --- DESCRIPTION | 1 - R/benchmarking.R | 2 +- R/plotXYComparison.R | 119 +++++++++++++++++++++++++++++-------------- 3 files changed, 82 insertions(+), 40 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 260ea3b..c07add4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -85,7 +85,6 @@ Collate: 'package-documentation.R' 'periods.R' 'plotScatter.R' - 'plotScatterComparison.R' 'plotScatter_old.R' 'plotSpatial.R' 'plotSpatialComparison.R' diff --git a/R/benchmarking.R b/R/benchmarking.R index bf76f08..83225dd 100644 --- a/R/benchmarking.R +++ b/R/benchmarking.R @@ -165,7 +165,7 @@ continuousComparison <- function(x, layers1, layers2, additional, verbose = TRUE # Pearson product moment correlation coefficient, and then R^2 # MF: not the best thing in my opinion - r <- stats::cor(vector1, vector2, method = "pearson", ) + r <- stats::cor(vector1, vector2, method = "pearson") r2 <- r^2 # calculate a simple linear regression diff --git a/R/plotXYComparison.R b/R/plotXYComparison.R index 3182eff..f5c3f73 100644 --- a/R/plotXYComparison.R +++ b/R/plotXYComparison.R @@ -12,19 +12,10 @@ #' a difference map; "values" - the absolute values plotted in panels and "percentage.difference" - the percentage differences. #' #' @param comparisons The data to plot, must be a Comparison or a list of Comparisons -#' @param type A character specifying what type of plot to make. Can be "difference" (default, for a difference plot), "percentage.difference", "values" -#' (actual values, side-by-side) or "nme" (for the Normalised Mean Error, not yet implemented) -#' @param limits A numeric vector with two members (lower and upper limit) to limit the plotted values. -#' @param legend.title A character string or expression to override the default legend title. Set to NULL for no legend title. The default legend title is the \code{units} -#' of the \linkS4class{Quantity} of the first \linkS4class{Comparison} provided in the \code{comparisions} argument. This argument allows general flexibility, but it is particularly handy -#' to facilitate expressions for nicely marked up subscript and superscript. -#' @param panel.bg.col Colour string for the panel background, default to "white" for absolute values plots, and a grey for difference plots. -#' @param override.cols A colour palette function to override the defaults. -#' @param symmetric.scale If plotting a differences, make the scale symmetric around zero (default is TRUE) -#' @param do.phase Logical, only applies to plotting Comparison objects of type "seasonal". -#' If TRUE plot the the seasonal phase, if FALSE (the default), plot the seasonal concentration. -#' @param ... Parameters passed to \link{plotSpatial} -#' +#' @param type A character specifying what type of plot to make. Can be "points" (default, for geom_points), "hex" (for hex binning), "bin2d" (for square binning). +#' There might be more useful options to add later. + + #' @details A wrapper for around \link{plotSpatial} to plot the spatial Comparisons as maps. Extra arguments to \link{plotSpatial} can also be specified. #' #' @return Returns a ggplot object @@ -36,19 +27,23 @@ #' @seealso \link{plotSpatial}, \link{compareLayers} plotXYComparison <- function(comparisons, - type = c("points", "hex", "bin2d"), - fit_line_col = NULL, - perfect_line_col = NULL, - matchLimits = TRUE, - ...){ + type = c("points", "hex", "bin2d"), + fit_line_col = NULL, + perfect_line_col = NULL, + matchLimits = TRUE, + metrics = c(), + metric_text_size = waiver(), + text.multiplier = NULL, + + ...){ Source = Value = Lat = Lon = Layer = long = lat = group = NULL Day = Month = Year = Season = NULL - + # sort type argument type <- match.arg(type) - + ### CHECK TO SEE EXACTLY WHAT WE SHOULD PLOT @@ -69,6 +64,7 @@ plotXYComparison <- function(comparisons, plotting_dt <- data.table() fit_lines_dt <- data.table() + metrics_dt <- data.table() for(object in comparisons){ pretty_comparison_name <- gsub(pattern = " - ", replacement = " vs ", x = object@name) @@ -82,7 +78,22 @@ plotXYComparison <- function(comparisons, plotting_dt <- rbind(plotting_dt, tmp_dt) fit_lines_dt <- rbind(data.table(slope = object@stats$m, intercept = object@stats$c, Comparison = pretty_comparison_name), fit_lines_dt) - + if(length(metrics) > 0 ){ + tmp_metrics_list <- list() + for(metric in metrics){ + metric_text <- metric + if(metric == "m") metric_text <- "Slope" + if(metric == "c") metric_text <- "Intercept" + if(metric == "R2") metric_text <- "R^2" + if(metric == "r2") metric_text <- "r^2" + tmp_metrics_list[[metric_text]] <- paste0(metric_text, "==", signif(object@stats[[metric]], 2)) + } + tmp_metrics_string <- paste(tmp_metrics_list, collapse = " ") + tmp_dt <- data.table(Comparison = pretty_comparison_name, label = gsub(" ", "~", tmp_metrics_string)) + metrics_dt <- rbind(metrics_dt, tmp_dt) + } + + # # first make a list of the layers that we expect to be present in the data.table, based on the meta-data in the Comparison object # layers.names <- names(object) @@ -131,7 +142,7 @@ plotXYComparison <- function(comparisons, # object@sta.info1) # } - + # make a legend title if one has not been supplied #if(missing(legend.title)) legend.title <- stringToExpression(standardiseUnitString(object@quant1@units)) @@ -150,38 +161,70 @@ plotXYComparison <- function(comparisons, y_label <- stringToExpression(paste0(comparisons[[1]]@source2@name, " ", comparisons[[1]]@quant2@name, " (", standardiseUnitString(comparisons[[1]]@quant2@units), ")")) } - scatter_plot <- ggplot(plotting_dt, aes(x = X, y = Y)) + + + #### MAKE THE PLOT INCLUDING SELECTIONG THE CORRECT GEOM_ #### + xy_plot <- ggplot(plotting_dt, aes(x = X, y = Y)) if(type == "hex"){ - scatter_plot <- scatter_plot + geom_hex() + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") + xy_plot <- xy_plot + geom_hex() + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") } else if(type == "points"){ - scatter_plot <- scatter_plot + geom_point() + xy_plot <- xy_plot + geom_point() } else if(type == "bin2d"){ - scatter_plot <- scatter_plot + geom_bin2d() + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") + xy_plot <- xy_plot + geom_bin2d() + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") } + + #### FACET IF NECESSARY #### if(length(comparisons) > 1) { - scatter_plot <- scatter_plot + facet_wrap(facets = vars(Comparison)) + xy_plot <- xy_plot + facet_wrap(facets = vars(Comparison)) } + + #### HANDLE LIMITS #### + mylims <- range(with(plotting_dt, c(X, Y))) if(matchLimits) { - mylims <- range(with(plotting_dt, c(X, Y))) - scatter_plot <- scatter_plot + coord_cartesian(xlim = mylims, ylim = mylims) + xy_plot <- xy_plot + coord_fixed(xlim = mylims, ylim = mylims) } - if(!missing(perfect_line_col) & !is.null(fit_line_col)) scatter_plot <- scatter_plot + geom_abline(slope=1, intercept = 0, col = perfect_line_col, linetype = "dashed") - if(!missing(fit_line_col) & !is.null(fit_line_col)) scatter_plot <- scatter_plot + geom_abline(data = fit_lines_dt, aes(slope=slope, intercept = intercept), col = fit_line_col) - - scatter_plot <- scatter_plot + labs(title = title, - subtitle = subtitle, - y = y_label, - x = x_label) + #### ADD LINES #### + if(!missing(perfect_line_col) & !is.null(fit_line_col)) xy_plot <- xy_plot + geom_abline(slope=1, intercept = 0, col = perfect_line_col, linetype = "dashed") + if(!missing(fit_line_col) & !is.null(fit_line_col)) xy_plot <- xy_plot + geom_abline(data = fit_lines_dt, aes(slope=slope, intercept = intercept), col = fit_line_col) + + + #### ADD METRICS #### + if(length(metrics) > 0){ + metrics_dt[ , x := mylims[1]] + metrics_dt[ , y := mylims[2]] + if(!is.null(text.multiplier)) metric_size <- theme_get()$text$size * text.multiplier + else metric_size <- theme_get()$text$size + xy_plot <- xy_plot + geom_text(data = metrics_dt, + mapping = aes(x = x, y = y, label = label), + size = metric_size, + size.unit = "pt", + vjust = 0, + hjust = 0, + parse = TRUE) + #, size = settings$map_annotation_text_size) + } + + #### ADD TITLES #### + xy_plot <- xy_plot + labs(title = title, + subtitle = subtitle, + y = y_label, + x = x_label) + + + #### SET THEME #### # set the theme to theme_bw, simplest way to set the background to white - scatter_plot <- scatter_plot + theme_bw() + xy_plot <- xy_plot + theme_bw() + + #### TEXT MULTIPLIER #### + if(!is.null(text.multiplier)) xy_plot <- xy_plot + theme(text = element_text(size = theme_get()$text$size * text.multiplier)) - return(scatter_plot) + return(xy_plot) From 42684dad7ea30922639e1dcd4e4a6d1a50f5859e Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Tue, 12 Nov 2024 16:49:23 +0100 Subject: [PATCH 05/20] Tweaks and bugfixes to plotXYComparison() Made for Tellme report, needs some generalisation, in particular equivalents to the col.by argument. --- R/plotXYComparison.R | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/R/plotXYComparison.R b/R/plotXYComparison.R index f5c3f73..616826f 100644 --- a/R/plotXYComparison.R +++ b/R/plotXYComparison.R @@ -14,7 +14,9 @@ #' @param comparisons The data to plot, must be a Comparison or a list of Comparisons #' @param type A character specifying what type of plot to make. Can be "points" (default, for geom_points), "hex" (for hex binning), "bin2d" (for square binning). #' There might be more useful options to add later. - +#' @param col.by,size.by,shape.by,alpha.by Character strings defining the aspects of the data which which should be used to set the colour, line type, line width, point size and point shape and alpha (transparency). +#' Can meaningfully take the values "Layer", "Source", "Site" or "Quantity". By default \code{col.by} is set to "Layer" and all others set to NULL, which means the different aspects are +#' distinguished by different facet panels. Thus the standard behaviour is that different Layers are distinguished by different colours, but everything is separated into different panels. #' @details A wrapper for around \link{plotSpatial} to plot the spatial Comparisons as maps. Extra arguments to \link{plotSpatial} can also be specified. #' @@ -34,7 +36,7 @@ plotXYComparison <- function(comparisons, metrics = c(), metric_text_size = waiver(), text.multiplier = NULL, - + col.by = NULL, ...){ Source = Value = Lat = Lon = Layer = long = lat = group = NULL @@ -169,7 +171,15 @@ plotXYComparison <- function(comparisons, xy_plot <- xy_plot + geom_hex() + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") } else if(type == "points"){ - xy_plot <- xy_plot + geom_point() + + # first make the "symbols" for the ggplot2 call. A bit of a pain -since they ggplot2 folks took away aes_string()- but what can you do... + col.sym <- if(is.character(col.by)) ensym(col.by) else NULL + #alpha.sym <- if(is.character(alpha.by)) ensym(alpha.by) else NULL + #size.sym <- if(is.character(size.by)) ensym(size.by) else NULL + #shape.sym <- if(is.character(shape.by)) ensym(shape.by) else NULL + #linewidth.sym <- if(is.character(linewidth.by)) ensym(linewidth.by) else NULL + #linetype.sym <- if(is.character(linetype.by)) ensym(linetype.by) else NULL + xy_plot <- xy_plot + geom_point(aes(col = !! col.sym)) } else if(type == "bin2d"){ xy_plot <- xy_plot + geom_bin2d() + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") @@ -183,7 +193,7 @@ plotXYComparison <- function(comparisons, #### HANDLE LIMITS #### - mylims <- range(with(plotting_dt, c(X, Y))) + mylims <- range(with(plotting_dt, c(X, Y)), na.rm = TRUE) if(matchLimits) { xy_plot <- xy_plot + coord_fixed(xlim = mylims, ylim = mylims) } @@ -215,11 +225,13 @@ plotXYComparison <- function(comparisons, subtitle = subtitle, y = y_label, x = x_label) + - - #### SET THEME #### + #### SET THEME AND OTHER LAYOUT OPTIONS #### # set the theme to theme_bw, simplest way to set the background to white xy_plot <- xy_plot + theme_bw() + xy_plot <- xy_plot + theme(plot.title = element_text(hjust = 0.5), + plot.subtitle = element_text(hjust = 0.5)) #### TEXT MULTIPLIER #### if(!is.null(text.multiplier)) xy_plot <- xy_plot + theme(text = element_text(size = theme_get()$text$size * text.multiplier)) From 5ba02e3d2ff16cb2c4015ea9dd2c8bf0f84c698a Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Fri, 13 Dec 2024 13:38:03 +0000 Subject: [PATCH 06/20] Change IBS to "Boreal" from "Temperate" This is important for the Smith2014 biome scheme --- R/Format-GUESS.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/Format-GUESS.R b/R/Format-GUESS.R index 4eeeb80..84d49aa 100755 --- a/R/Format-GUESS.R +++ b/R/Format-GUESS.R @@ -1098,7 +1098,7 @@ GUESS.Layers <- list( growth.form = "Tree", leaf.form = "Broadleaved", phenology = "Summergreen", - climate.zone = "Temperate", + climate.zone = "Boreal", shade.tolerance = "None", land.cover = "Natural") ), From 465ce9f304e5d51ff78577b70367e81a6516babc Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Mon, 16 Dec 2024 12:38:57 +0000 Subject: [PATCH 07/20] Better control of metrics, but facetting order still doesn't work --- R/plotXYComparison.R | 117 +++++++++++++++++-------------------------- 1 file changed, 46 insertions(+), 71 deletions(-) diff --git a/R/plotXYComparison.R b/R/plotXYComparison.R index 616826f..604cc89 100644 --- a/R/plotXYComparison.R +++ b/R/plotXYComparison.R @@ -34,7 +34,9 @@ plotXYComparison <- function(comparisons, perfect_line_col = NULL, matchLimits = TRUE, metrics = c(), - metric_text_size = waiver(), + metric_size = waiver(), + metric_x_pos = 0.025, + metric_y_pos = 0.975, text.multiplier = NULL, col.by = NULL, ...){ @@ -67,10 +69,11 @@ plotXYComparison <- function(comparisons, plotting_dt <- data.table() fit_lines_dt <- data.table() metrics_dt <- data.table() + comparison_obj_factors <- c() for(object in comparisons){ - + pretty_comparison_name <- gsub(pattern = " - ", replacement = " vs ", x = object@name) - + comparison_obj_factors <- append(comparison_obj_factors, pretty_comparison_name) tmp_dt <- copy(object@data) all_names <- names(tmp_dt) old_names <- all_names[(length(all_names)-2):length(all_names)] @@ -83,68 +86,34 @@ plotXYComparison <- function(comparisons, if(length(metrics) > 0 ){ tmp_metrics_list <- list() for(metric in metrics){ - metric_text <- metric - if(metric == "m") metric_text <- "Slope" - if(metric == "c") metric_text <- "Intercept" - if(metric == "R2") metric_text <- "R^2" - if(metric == "r2") metric_text <- "r^2" - tmp_metrics_list[[metric_text]] <- paste0(metric_text, "==", signif(object@stats[[metric]], 2)) + + # for something represing new lines + if(metric %in% c("", "\n")) { + tmp_metrics_list[[length(tmp_metrics_list)+1]] <- "\n" + } + # for a real metric + else { + metric_text <- metric + if(metric == "m") metric_text <- "Slope" + if(metric == "c") metric_text <- "Intercept" + if(metric == "R2") metric_text <- "R^2" + if(metric == "r2") metric_text <- "r^2" + tmp_metrics_list[[metric_text]] <- paste0(metric_text, "==", signif(object@stats[[metric]], 2)) + } } tmp_metrics_string <- paste(tmp_metrics_list, collapse = " ") tmp_dt <- data.table(Comparison = pretty_comparison_name, label = gsub(" ", "~", tmp_metrics_string)) metrics_dt <- rbind(metrics_dt, tmp_dt) } - - - - # # first make a list of the layers that we expect to be present in the data.table, based on the meta-data in the Comparison object - # layers.names <- names(object) - # expected.layers.1 <- paste(object@layers1, makeFieldID(source = object@source1, quant.string = object@quant1@id, sta.info = object@sta.info1), sep = ".") - # expected.layers.2 <- paste(object@layers2, makeFieldID(source = object@source2, quant.string = object@quant2@id, sta.info = object@sta.info2), sep = ".") - # - # # check the layers - # for(this.layer in expected.layers.1) if(!this.layer %in% layers.names) stop(paste("Layer", this.layer, "expected in Comparison object but not found")) - # for(this.layer in expected.layers.2) if(!this.layer %in% layers.names) stop(paste("Layer", this.layer, "expected in Comparison object but not found")) - # - # # adjust the source ids if they are identical - # if(object@source1@id == object@source2@id) { - # - # # include the first and last years if they are not the same - # if((object@sta.info1@first.year != object@sta.info2@first.year) && (object@sta.info1@last.year != object@sta.info2@last.year)){ - # object@source1@name <- paste0(object@source1@name, " (", object@sta.info1@first.year, "-", object@sta.info1@last.year, ")") - # object@source2@name <- paste0(object@source2@name, " (", object@sta.info2@first.year, "-", object@sta.info2@last.year, ")") - # } - # - # } - # - # - # - # # SECOND INFO - putting this first because this is the 'base' dataset ("one minus two" convention) - # new.dt <- object@data[, append(getDimInfo(object), expected.layers.2), with=FALSE] - # #setnames(new.dt, names(new.dt)[length(names(new.dt))], object@quant2@id ) - # setnames(new.dt, expected.layers.2, object@layers2) - # layers.to.plot <- append(layers.to.plot, object@layers2) - # objects.to.plot[[length(objects.to.plot)+1]] <- new("Field", - # id = object@id, - # data = new.dt, - # quant = object@quant2, - # source = object@source2, - # object@sta.info2) - # - # # FIRST INFO - # new.dt <- object@data[, append(getDimInfo(object), expected.layers.1), with=FALSE] - # #setnames(new.dt, names(new.dt)[length(names(new.dt))], object@quant1@id ) - # setnames(new.dt, expected.layers.1, object@layers1 ) - # layers.to.plot <- append(layers.to.plot, object@layers1) - # objects.to.plot[[length(objects.to.plot)+1]] <- new("Field", - # id = object@id, - # data = new.dt, - # quant = object@quant1, - # source = object@source1, - # object@sta.info1) - # + } + + #### set the facet ordering by using the factor - Gahhh!! why doesn't this work?? + plotting_dt[ , Comparison := factor(x = Comparison, + levels = comparison_obj_factors)] + + # make a legend title if one has not been supplied #if(missing(legend.title)) legend.title <- stringToExpression(standardiseUnitString(object@quant1@units)) @@ -185,13 +154,7 @@ plotXYComparison <- function(comparisons, xy_plot <- xy_plot + geom_bin2d() + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") } - - #### FACET IF NECESSARY #### - if(length(comparisons) > 1) { - xy_plot <- xy_plot + facet_wrap(facets = vars(Comparison)) - } - - + #### HANDLE LIMITS #### mylims <- range(with(plotting_dt, c(X, Y)), na.rm = TRUE) if(matchLimits) { @@ -206,17 +169,19 @@ plotXYComparison <- function(comparisons, #### ADD METRICS #### if(length(metrics) > 0){ - metrics_dt[ , x := mylims[1]] - metrics_dt[ , y := mylims[2]] - if(!is.null(text.multiplier)) metric_size <- theme_get()$text$size * text.multiplier - else metric_size <- theme_get()$text$size + xlims <- range(with(plotting_dt, c(X)), na.rm = TRUE) + ylims <- range(with(plotting_dt, c(Y)), na.rm = TRUE) + metrics_dt[ , x := xlims[2] * metric_x_pos] + metrics_dt[ , y := ylims[2] * metric_y_pos] + if(!is.null(text.multiplier)) metric_size <- metric_size * text.multiplier xy_plot <- xy_plot + geom_text(data = metrics_dt, mapping = aes(x = x, y = y, label = label), size = metric_size, size.unit = "pt", vjust = 0, hjust = 0, - parse = TRUE) + parse = TRUE, + lineheight = 100) #, size = settings$map_annotation_text_size) } @@ -225,7 +190,7 @@ plotXYComparison <- function(comparisons, subtitle = subtitle, y = y_label, x = x_label) - + #### SET THEME AND OTHER LAYOUT OPTIONS #### # set the theme to theme_bw, simplest way to set the background to white @@ -236,6 +201,16 @@ plotXYComparison <- function(comparisons, #### TEXT MULTIPLIER #### if(!is.null(text.multiplier)) xy_plot <- xy_plot + theme(text = element_text(size = theme_get()$text$size * text.multiplier)) + #### DONT EXPAND LIMITS + xy_plot <- xy_plot + scale_x_continuous(expand = c(0, 0)) + scale_y_continuous(expand = c(0, 0)) + + + + #### FACET IF NECESSARY #### + if(length(comparisons) > 1) { + xy_plot <- xy_plot + facet_wrap(~Comparison, ...) + } + return(xy_plot) From 3e9f29fe9a0f40a543f6c612f8992ba3a635b7f4 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Wed, 18 Dec 2024 13:55:24 +0000 Subject: [PATCH 08/20] Bugfix: correct colour/legend ordering in plotSubannual() --- R/plotSubannual.R | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/R/plotSubannual.R b/R/plotSubannual.R index 1ae23bb..6522a5d 100644 --- a/R/plotSubannual.R +++ b/R/plotSubannual.R @@ -261,6 +261,16 @@ plotSubannual <- function(fields, # can be a Field or a list of Fields data.toplot[, StatsGroup := interaction(.SD), .SDcols = stats_SDcols] + ### LEGEND ENTRY ORDERING + ## Fix order of items in legend(s) by making them factors with levels corresponding to the order of the input fields + all.sources <- list() + # first loop across the fields + for(this.field in fields) { + all.sources <- append(all.sources, this.field@source@name) + } + if("Source" %in% names(data.toplot)) data.toplot[, Source := factor(Source, levels = unique(all.sources))] + + ###### MAKE THE PLOT ##### From b44bc66c7762c344a5e9ae8fe7a59b60e2873d1c Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Thu, 19 Dec 2024 16:56:34 +0000 Subject: [PATCH 09/20] Added metrics to plotSpatialComparison(). Also documented plotXYComparison(), cleaned code squashed some CHECK notes. --- DESCRIPTION | 4 +- NAMESPACE | 2 - R/Format-GUESS.R | 4 - R/Format-NetCDF.R | 2 +- R/Format-aDGVM.R | 6 - R/classification-schemes.R | 2 +- R/plotScatter.R | 385 ------------------------------- R/plotScatter_old.R | 80 ------- R/plotSpatialComparison.R | 88 +++++-- R/plotXYComparison.R | 78 ++++--- R/plotting-framework-functions.R | 162 +++---------- 11 files changed, 149 insertions(+), 664 deletions(-) delete mode 100644 R/plotScatter.R delete mode 100644 R/plotScatter_old.R diff --git a/DESCRIPTION b/DESCRIPTION index c07add4..a061d46 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,7 +40,7 @@ License: GPL | file LICENSE URL: https://www.bik-f.de BugReports: https://github.com/MagicForrest/DGVMTools/issues NeedsCompilation: no -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 VignetteBuilder: knitr Encoding: UTF-8 Collate: @@ -84,8 +84,6 @@ Collate: 'names-methods.R' 'package-documentation.R' 'periods.R' - 'plotScatter.R' - 'plotScatter_old.R' 'plotSpatial.R' 'plotSpatialComparison.R' 'plotSubannual.R' diff --git a/NAMESPACE b/NAMESPACE index 665db89..6247273 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -66,8 +66,6 @@ export(makePlotTitle) export(makeSPDFfromDT) export(matchLayerCols) export(periods) -export(plotScatter) -export(plotScatter_old) export(plotSpatial) export(plotSpatialComparison) export(plotSubannual) diff --git a/R/Format-GUESS.R b/R/Format-GUESS.R index 84d49aa..c2cd302 100755 --- a/R/Format-GUESS.R +++ b/R/Format-GUESS.R @@ -359,8 +359,6 @@ openLPJOutputFile <- function(run, #' @param run A \code{\linkS4class{Source}} containing the meta-data about the LPJ-GUESS run #' @param quant A Quantity to define what output file from the LPJ-GUESS run to open. #' @param layers A character string (or a vector of character strings) specifying which layer columns are to be read. NULL (default) means read all. -#' @param first.year The first year (as a numeric) of the data to be return -#' @param last.year The last year (as a numeric) of the data to be return #' @param file.name Character string holding the name of the file. This can be left blank, in which case the file name is just taken to be #' ".out" (also ".out.gz") #' @param verbose A logical, set to true to give progress/debug information @@ -756,8 +754,6 @@ openLPJOutputFile_FireMIP <- function(run, #' #' @param run A \code{\linkS4class{Source}} containing the meta-data about the LPJ-GUESS run from which the data is to be read. Most importantly it must contain the run.dara nd the offsets. #' @param quant A Quantity to define what output file from the LPJ-GUESS run to open -#' @param first.year The first year (as a numeric) of the data to be return -#' @param last.year The last year (as a numeric) of the data to be return #' @param file.name Character string holding the name of the file. This can be left blank, in which case the file name is just taken to be #' ".out" (also ".out.gz") #' @param verbose A logical, set to true to give progress/debug information diff --git a/R/Format-NetCDF.R b/R/Format-NetCDF.R index f4c800b..76f1b7c 100644 --- a/R/Format-NetCDF.R +++ b/R/Format-NetCDF.R @@ -14,7 +14,7 @@ #' @param quant A Quantity object to specify what quantity should be opened. #' @param layers A character string (or a vector of character strings) specifying which variables from the NetCDF file are to be read. #' NULL (default) means read all. -#' @param target.sta.info An STAInfo object defining the spatial-temporal-annual extent over which we want the data +#' @param target.STAInfo An STAInfo object defining the spatial-temporal-annual extent over which we want the data #' @param file.name Character string holding the name of the file. This can be left blank, in which case the file name is automatically generated #' @param calendar Character string, sometimes the calendar string on the time axis can be incorrect or missing. Here you can manually provide it. #' Note: A common error in paleo files is "standard" instead of "proleptic_gregorian". Specifically, if you have dates with years 1582 diff --git a/R/Format-aDGVM.R b/R/Format-aDGVM.R index 599b583..2a74d45 100755 --- a/R/Format-aDGVM.R +++ b/R/Format-aDGVM.R @@ -65,8 +65,6 @@ getField_aDGVM <- function(source, #' @param run A \code{\linkS4class{Source}} containing the meta-data about the aDGVM run #' @param quant A Quant to define what output file from the aDGVM run to open, #' can also be a simple string defining the aDGVM output file if the \code{return.data.table} argument is TRUE -#' @param first.year The first year (as a numeric) of the data to be return -#' @param last.year The last year (as a numeric) of the data to be return #' @param verbose A logical, set to true to give progress/debug information #' @param file.name An optional character string (or a list of character strings) holding the name of the file(s) #' This can be left blank, in which case the file name is automatically generated. @@ -383,8 +381,6 @@ getYearlyField_aDGVM <- function(run, #' @param run A \code{\linkS4class{Source}} containing the meta-data about the aDGVM run #' @param quant A Quant to define what output file from the aDGVM run to open, #' can also be a simple string defining the aDGVM output file if the \code{return.data.table} argument is TRUE -#' @param first.year The first year (as a numeric) of the data to be return -#' @param last.year The last year (as a numeric) of the data to be return #' @param verbose A logical, set to true to give progress/debug information #' @param file.name An optional character string (or a list of character strings) holding the name of the file(s) #' This can be left blank, in which case the file name is automatically generated. @@ -799,8 +795,6 @@ getDailyField_aDGVM <- function(run, #' for each and every model to ensure completeness. #' @param run A \code{\linkS4class{Source}} containing the meta-data about the aDGVM run from which the data is to be read. Most importantly it must contain the run.dara nd the offsets. #' @param quant A Quantity to define what output file from the aDGVM run to open -#' @param first.year The first year (as a numeric) of the data to be return -#' @param last.year The last year (as a numeric) of the data to be return #' @param file.name An optional character string (or a list of character strings) holding the name of the file(s) #' This can be left blank, in which case the file name is automatically generated. #' @param verbose A logical, set to true to give progress/debug information diff --git a/R/classification-schemes.R b/R/classification-schemes.R index 223b4c3..8d0174d 100644 --- a/R/classification-schemes.R +++ b/R/classification-schemes.R @@ -908,7 +908,7 @@ FireMIPBiomeScheme <- new("Scheme", #' #' lalala #' -#' @param fpc Vector of FPC values +#' @param x Vector of FPC values #' @keywords internal FPCMegaBiomeRules <- function(x) { diff --git a/R/plotScatter.R b/R/plotScatter.R deleted file mode 100644 index 12c4463..0000000 --- a/R/plotScatter.R +++ /dev/null @@ -1,385 +0,0 @@ - -#' Scatter plots -#' -#' For a list of Fields, compare layers using scatter plots. Automatically splits data into separate panels based on Source, Quantity, -#' Sire and/or Region, but instead these can be distinguished by aesthetics - see the \code{col.by}, \code{linetype.by} and \code{alpha.by} arguments. -#' Summary or aggregate function can optionally be applied and plotted on top. -#' -#' @param fields The data to plot. Can be a Field or a list of Fields. -#' @param layers A list of strings specifying which layers to plot. Defaults to all layers. -#' @param gridcells A list of gridcells to be plotted (either in different panels or the same panel). For formatting of this argument see \code{selectGridcells}. -#' Leave empty or NULL to plot all gridsizrecells (but note that if this involves too many gridcells the code will stop) -#' @param title A character string to override the default title. -#' @param subtitle A character string to override the default subtitle. -#' @param x.label,y.label Character strings (or expressions) for the x and y axes (optional) -#' @param col.by,linetype.by,alpha.by Character strings defining the aspects of the data which which should be used to set the colour, line type and alpha (transparency). -#' Can meaningfully take the values "Layer", "Source", "Site", "Region" or "Quantity". -#' NOTE SPECIAL DEFAULT CASE: By default, \code{col.by} is set to "Year" which means that the years are plotted according to a colour gradient, and all other aspects of the -#' the data are distinguished by different facet panels. To change this behaviour and colour the lines according to something different, set the "col.by" argument to one of the -#' strings suggested above. -#' @param cols,linetypes,alphas A vector of colours, line types, or alpha values (respectively) to control the aesthetics of the lines. -#' Only "cols" makes sense without a corresponding "xxx.by" argument (see above). The vectors can/should be named to match particular col/linetype/alpha values -#' to particular Layers/Sources/Sites/Quantities/Regions. -#' @param col.labels,linetype.labels,alpha.labels A vector of character strings which are used as the labels for the lines. Must have the same length as the -#' number of Sources/Layers/Sites/Quantities in the plot. The vectors can/should be named to match particular col/linewtype/alpha values to particular Layers/Sources/Sites/Quantities/Region. -#' @param linewidth Numeric (as ggplot2), width of the lines on the plot, consistent with ggplot2. Note the width is doubled for the aggregate/summary line. -#' @param size Numeric, size of the points for the aggregate/summary data, consistent with ggplot2. -#' @param summary.function A function to summarise (aggregate) across year and plot on top. Obvious choice is \code{mean}, but there is flexibility to anything that operates on -#' a vector of numerics - eg median, a 95th percentile, standard deviation. -#' @param summary.function.label An optional character string to give a pretty label to the summary function legend. -#' @param text.multiplier A number specifying an overall multiplier for the text on the plot. -#' Make it bigger if the text is too small on large plots and vice-versa. -#' @param plot Boolean, if FALSE return a data.table with the final data instead of the ggplot object. This can be useful for inspecting the structure of the facetting columns, amongst other things. -#' @param ... Arguments passed to \code{ggplot2::facet_wrap()}. See the ggplot2 documentation for full details but the following are particularly useful. -#' \itemize{ -#' \item{"nrow"}{The number of rows of facets} -#' \item{"ncol"}{The number of columns of facets} -#' \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) -#' "free" (all facets can their x and y ranges), "free_x" and "free_y" (only x and y ranges can vary, respectively).} -#' \item{"labeller"}{A function to define the labels for the facets. This is a little tricky, please look to the ggplot2 documentation} -#' } -#' -#' @details -#' -#' Note that like all \code{DGVMTools} plotting functions, \code{plotSubannual} splits the data into separate panels using the \code{ggplot2::facet_wrap()}. If you want to 'grid' the facets -#' using \code{ggplot2::facet_grid()} you can do so afterwards. 'gridding the facets' implies the each column and row of facets vary by one specific aspect. -#' For example you might have one column for each Source, and one row for each "Quantity". -#' -#' -#' -#' @return Returns either a ggplot2 object or a data.table (depending on the 'plot' argument) -#' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} -#' @export - - - -plotScatter <- function(fields1, # can be a Field or a list of Fields - fields2=fields1, # can be a Field or a list of Fields - layers1, - layers2 = layers1, - gridcells = NULL, - title = NULL, - subtitle = NULL, - cols = NULL, - col.by = "Year", - col.labels = waiver(), - linetypes = NULL, - linetype.by = NULL, - linetype.labels = waiver(), - alphas = NULL, - alpha.by = NULL, - alpha.labels = waiver(), - linewidth = 0.5, - size = 3 , - y.label = NULL, - x.label = NULL, - summary.function, - summary.function.label = deparse(substitute(summary.function)), - text.multiplier = NULL, - plot = TRUE, - ...) { - - - Quantity = Month = Source = Value = Year = PlotGroup = StatsGroup = NULL - - ### CHECK INPUTS AND HANDLE SPECIAL CASES - - # set a flag for the special case of colouring by year - special_case_year_colour <- FALSE - if(identical(col.by,"Year")) { - special_case_year_colour <- TRUE - if(!missing(cols) || !is.null(cols)) { - warning("'cols' argument ignored since colouring by Year and therefore using a continuous scale") - cols <- NULL - } - } - - - - ### SANITISE FIELDS, LAYERS AND DIMENSIONS - - ## 1. FIELDS - check the input Field objects (and if it is a single Field put it into a one-item list) - - fields1 <- santiseFieldsForPlotting(fields1) - if(is.null(fields1)) return(NULL) - fields2 <- santiseFieldsForPlotting(fields2) - if(is.null(fields2)) return(NULL) - - ## 3. DIMENSIONS - check the dimensions (require that all fields the same dimensions) - - # check the Fields for consistent dimensions - dim.names <- santiseDimensionsForPlotting(append(fields1, fields2)) - if(is.null(dim.names)) return(NULL) - - ## 2. LAYERS - check the number of layers - - # this is special version for plotScatter since - plot_dt <- santiseLayersForPlottingXY(fields1, fields2, layers1, layers2) - print(plot_dt) - if(is.null(layers)) return(NULL) - - - - - - ### PREPARE AND CHECK DATA FOR PLOTTING - final.fields <- trimFieldsForPlottingXY(fields, layers, gridcells = gridcells) - - ### MERGE DATA FOR PLOTTING INTO ONE BIG DATA.TABLE - # MF TODO maybe make some clever checks on these switches - if("Lon" %in% dim.names & "Lat" %in% dim.names) add.Site <- TRUE - else add.Site <- FALSE - add.Region <- TRUE - - # MF TODO: Consider adding add.TimePeriod? - data.toplot <- mergeFieldsForPlotting(final.fields, add.Quantity = TRUE, add.Site = add.Site, add.Region = TRUE) - - ### CHECK IS YEAR IS PRESENT - if(!("Year" %in% names(data.toplot))) { - special_case_year_colour <- FALSE - if(missing(col.by)) col.by = NULL - } - - - ### XX. FACETTING - - # all column names, used a lot below - all.columns <- names(data.toplot) - - # check the "xxx.by" arguments - if(!missing(col.by) && !is.null(col.by) && !col.by %in% all.columns) stop(paste("Colouring by", col.by, "requested, but that is not available, so failing.")) - if(!missing(linetype.by) && !is.null(linetype.by) && !linetype.by %in% all.columns) stop(paste("Setting linetypes by", linetype.by, "requested, but that is not available, so failing.")) - if(!missing(alpha.by) && !is.null(alpha.by) && !alpha.by %in% all.columns) stop(paste("Setting alphas by", alpha.by, "requested, but that is not available, so failing.")) - - # ar first assume facetting by everything except for... - dontFacet <- c("Value", "Time", "Year", "Month", "Season", "Day", "Lon", "Lat", col.by, linetype.by, alpha.by) - facet.vars <- all.columns[!all.columns %in% dontFacet] - - # then remove facets with only one unique value - for(this.facet in facet.vars) { - if(length(unique(data.toplot[[this.facet]])) == 1) facet.vars <- facet.vars[!facet.vars == this.facet] - } - - - ### LEGEND ENTRY ORDERING - # ## Fix order of items in legend(s) by making them factors with levels corresponding to the order of the input fields - # all.sources <- list() - # # first loop across the fields - # for(this.field in fields) { - # all.sources <- append(all.sources, this.field@source@name) - # } - # if("Source" %in% names(data.toplot)) data.toplot[, Source := factor(Source, levels = unique(all.sources))] - - - ### 7. MAKE THE Y-AXIS LABEL - if(is.null(y.label)) { - y.label <- makeYAxis(final.fields) - } - - ### MATCH LAYER COLOUR - - # if cols is not specified and plots are to be coloured by Layers, look up line colours from Layer meta-data - if(missing(cols) && !is.null(col.by) && col.by == "Layer"){ - - # check the defined Layers present in the Fields and make a unique list - # maybe also here check which one are actually in the layers to plot, since we have that information - all.layers.defined <- list() - for(object in fields){ - all.layers.defined <- append(all.layers.defined, object@source@defined.layers) - } - all.layers.defined <- unique(all.layers.defined) - - - all.layers <- unique(as.character(data.toplot[["Layer"]])) - cols <- matchLayerCols(all.layers, all.layers.defined) - } - - #### MAKE LIST OF QUANTITIES AND UNITS FOR Y LABEL - - ### DEPRECATED BY CALL TO makeYAxis() above, but some functionality might be needed to keep for now. - - # unit.str <- list() - # quant.str <- list() - # id.str <- list() - # for(this.field in final.fields) { - # - # # pull out the unit string, id and full name string - # quant <- this.field@quant - # unit.str <- append(unit.str, quant@units) - # quant.str <- append(quant.str, quant@name) - # id.str <- append(id.str, quant@id) - # - # } - # - # # check the units - # if(length(unique(unit.str)) == 1){ - # unit.str <- unique(unit.str) - # } - # else { - # unit.str <- paste(unique(unit.str), collapse = ", ") - # warning("Quants to be plotted have non-identical units in plotSeasonal().") - # } - # - # # check the strings - # if(length(unique(quant.str)) == 1){ quant.str <- unique(quant.str) } - # else{ quant.str <- paste(id.str, sep = ", ", collapse = ", ") } - - - ### MAKE A DESCRIPTIVE TITLE IF ONE HAS NOT BEEN SUPPLIED - if(missing(title) || missing(subtitle)) { - titles <- makePlotTitle(final.fields) - if(missing(title)) title <- titles[["title"]] - else if(is.null(title)) title <- waiver() - if(missing(subtitle)) subtitle <- titles[["subtitle"]] - else if(is.null(subtitle)) subtitle <- waiver() - } - - - - ### MAKE THE GROUPS - these are columns for ggplot which are essentially interaction terms to group the data - - # The plot group - - # include Year only if not colouring by year - if(special_case_year_colour) interaction_list <- c() - else { - if("Year" %in% names(data.toplot)) interaction_list <- c("Year") - else interaction_list <- c() - } - - # include the other columns if required for an aesthetic - if(!is.null(col.by)) { - interaction_list <- append(interaction_list, col.by) # special case for col.by because if missing is taken to be "Year" - } - if(!missing(linetype.by) && !is.null(linetype.by)) interaction_list <- append(interaction_list, linetype.by) - if(!missing(alpha.by) && !is.null(alpha.by)) interaction_list <- append(interaction_list, alpha.by) - - # and now make the interaction column - data.toplot[, PlotGroup := interaction(.SD), .SDcols = interaction_list] - - - # The Stats Group - this is much easier since we every possible combination must have it's own stat - stats_SDcols <- names(data.toplot) %in% c("Source", "Quantity", "Layer", "Region", "Site") - data.toplot[, StatsGroup := interaction(.SD), .SDcols = stats_SDcols] - - - - ###### MAKE THE PLOT ##### - - # return the data if plot = FALSE - if(!plot) return(data.toplot) - - # make the "symbols" for the ggplot2 call. A bit of a pain -since they ggplot2 folks took away aes_string()- but what can you do... - col.sym <- if(is.character(col.by)) ensym(col.by) else NULL - alpha.sym <- if(is.character(alpha.by)) ensym(alpha.by) else NULL - linetype.sym <- if(is.character(linetype.by)) ensym(linetype.by) else NULL - - # build the basic plot - p <- ggplot(as.data.frame(data.toplot), aes(x = .data[[subannual.dimension]], y = Value, group = PlotGroup, - col = !! col.sym, - alpha = !! alpha.sym, - linetype = !! linetype.sym)) - - # build arguments for aesthetics to geom_line/geom_line and/or fixed arguments outside - geom_args <- list() - - # col, alpha and linetyp - if(!is.null(cols) && is.null(col.by)) geom_args[["colour"]] <- cols - if(!is.null(alphas) && is.null(alpha.by)) geom_args[["alpha"]] <- alphas - if(!is.null(linetypes) && is.null(linetype.by)) geom_args[["linetype"]] <- linetypes - - # line width if a fixed value for all - geom_args[["linewidth"]] <- linewidth - - # call geom_line (with fixed aesthetics define above) - p <- p + do.call(geom_line, geom_args) - - - # add scales for the defined aesthetics - - # colour scale is a special case for two reasons, - # 1. if col.by not variable provided, then the special case is activated and colour by year (and hence we have a continuous colour scale) - # 2. if no colours provided, use a viridis pallete to override ggplot2 - if(special_case_year_colour) p <- p + viridis::scale_color_viridis(name = "Year") - else if (!is.null(col.by) & !is.null(cols)) p <- p + scale_color_manual(values=cols, labels=col.labels) - else p <- p + viridis::scale_colour_viridis(discrete=TRUE, option = "C", end = 0.9 ) - - # these are simply defined by the arguments, no special cases - if(!is.null(linetype.by) & !is.null(linetypes)) p <- p + scale_linetype_manual(values=linetypes, labels=linetype.labels) - if(!is.null(alpha.by) & !is.null(alphas)) p <- p + scale_alpha_manual(values=alphas, labels=alpha.labels) - - # set the theme to theme_bw, simplest way to set the background to white - p <- p + theme_bw() - - # make scale a bit bigger - consider removing for purity?? this can easy be controlled by the user - p <- p + theme(legend.key.size = unit(2, 'lines')) - - - # if chosen, plot the average year - if(!missing(summary.function)) { - - # if is the special case where we colour by year - if(special_case_year_colour) { - - # NOTE in this case we always use black - - # special case to add a line type scale if it wasn't already added - # honestly not sure exactly why this works and many other things I tried didn't work - if(missing(linetype.by) || is.null(linetype.by)) { - - p <- p + stat_summary(aes(group=col.by, linetype = "dummy string"), fun=summary.function, geom="line", color="black", linewidth = linewidth * 2) - p <- p + scale_linetype_manual(values=c("dummy string"="solid"), labels = c("dummy string" = summary.function.label), name = element_blank()) - - } - # if linetypes are already specified - else{ - p <- p + stat_summary(aes(group=StatsGroup, linetype = .data[[linetype.by]]), fun=summary.function, geom="line", color="black", linewidth = linewidth * 2) - # title the legend - p <- p + labs(linetype=summary.function.label) - } - - - - } - #if *not* the special case where we colour by year - else { - - # add the stats - p <- p + stat_summary(aes(group=StatsGroup, fill = get(col.by)), fun=summary.function, geom="point", color="black", shape = 21, size = size) - - # colour the points appropriately - if(!is.null(cols)) p <- p + scale_fill_manual(values = cols, name = summary.function.label, labels = col.labels) - else p <- p + viridis::scale_fill_viridis(name = summary.function.label, labels = col.labels, discrete = TRUE, option = "C", end = 0.9 ) - p <- p + labs(shape=summary.function.label ) - - # also add linetype if necessary - if(!missing(linetype.by) && !is.null(linetype.by)) { - p <- p + stat_summary(aes(group=StatsGroup, linetype = .data[[linetype.by]]), fun=summary.function, geom="line", color="black", linewidth = linewidth * 2) - } - - } - - } - - - # set the x-axis - if(subannual.dimension == "Month") p <- p + scale_x_continuous(breaks = 1:12, labels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun","Jul", "Aug", "Sep","Oct","Nov","Dec")) - - # set the title - p <- p + labs(title = title, subtitle = subtitle, y = y.label, x = subannual.dimension) - - p <- p + theme(plot.title = element_text(hjust = 0.5), - plot.subtitle = element_text(hjust = 0.5)) - - # set legend - p <- p + theme(legend.position = "right", legend.key.size = unit(2, 'lines')) - - # facet if necessary - if(length(facet.vars) > 0) p <- p + facet_wrap(facet.vars, ...) - - # overall text multiplier - if(!is.null(text.multiplier)) p <- p + theme(text = element_text(size = theme_get()$text$size * text.multiplier)) - - return(p) - -} diff --git a/R/plotScatter_old.R b/R/plotScatter_old.R deleted file mode 100644 index 7c6ce88..0000000 --- a/R/plotScatter_old.R +++ /dev/null @@ -1,80 +0,0 @@ -#' Make a scatter plot -#' -#' This simple function makes (and returns it as an object, it doesn't print it) a simple scatter plot (using ggplot2). -#' The data are two layers from either one or two Field objects. Data points which appear in one Field but not the other are excluded -#' -#' @param x The first DGVMTools::Field or Comparison object from which the data to be plotted should be taken. -#' @param y The second DGVMTools::Field or Comparison object from which the data to be plotted should be taken. -#' Default value is x. -#' @param layer.x The first layer to be plotted (taken from x) -#' @param layer.y The second layer to be plotted (taken from y). Defaults to layer.x. -#' @param alpha Numeric between 0 and 1 specifing the transparency of the points. Default is 1 (= fully opaque). -#' @param text.multiplier A number specifying an overall multiplier for the text on the plot. -#' Make it bigger if the text is too small on large plots and vice-versa. -#' @param tolerance Numeric, passed to copyLayers. Defines how close the longitudes and latitudes of the gridcells in \code{x} and \code{y} (if different) -#' need to be to the coordinates in order to get a match. Can be a single numeric (for the same tolerance for both lon and lat) or a vector of two numerics (for lon and lat separately). -#' Default is no rounding (value is NULL) and so is fine for most regular spaced grids. However, setting this can be useful to force matching of -#' coordinates with many decimal places which may have lost a small amount of precision and so don't match exactly. -#' -#' @return A ggplot2 object -#' @export -#' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} -plotScatter_old <- function(x, y = x, layer.x, layer.y = layer.x, alpha = 1, text.multiplier, tolerance = NULL) { - - # check - if(identical(layer.x, layer.y) && identical(x, y)) stop("To make a meaningful scatter plot I need either two different layers, or a two different Fields, or both!)") - - # extract the data.tables - if(is.Field(x) || is.Comparison(x)) x.dt <- copy(x@data) - else if(is.data.table(x)) x.dt <- copy(x) - else stop(paste("Cannot plot scatter from object x of type:", paste(class(x), collapse = " "))) - if(is.Field(y) || is.Comparison(y)) y.dt <- copy(y@data) - else if(is.data.table(y)) y.dt <- copy(y) - else stop(paste("Cannot plot scatter object y of type:", paste(class(y), collapse = " "))) - - # rename layers if they are the same - old.layer.y <- layer.y - old.layer.x <- layer.x - if(identical(layer.x, layer.y)) { - old.layer.y <- layer.y - old.layer.x <- layer.x - layer.y <- paste(y@source@id, layer.y, sep = "_") - layer.x <- paste(x@source@id, layer.x, sep = "_") - setnames(y.dt, old.layer.y, layer.y) - setnames(x.dt, old.layer.x, layer.x) - } - - # copy layers to one data.table - if(!identical(x, y)) { - to.plot <- x.dt[, append(getDimInfo(x.dt), layer.x), with = FALSE] - to.plot <- copyLayers(from = y.dt, to = to.plot, layer.names = layer.y, keep.all.to = FALSE, keep.all.from = FALSE, tolerance = tolerance) - } - else { - to.plot <- x.dt[, append(getDimInfo(x.dt), c(layer.x, layer.y)), with = FALSE] - } - - - # remove spaces and -" "from column names otherwise ggplot2 goes a bit flooby (although check out 'tidyevaluation' to maybe do this nicer) - for(this.character in c(" ", "-")) { - x.new <- gsub(x = layer.x, pattern = this.character, replacement = "_") - y.new <- gsub(x = layer.y, pattern = this.character, replacement = "_") - } - setnames(to.plot, c(layer.x, layer.y), c(x.new, y.new)) - - - # make the scatter plot - scatter.plot <- ggplot(as.data.frame(stats::na.omit(to.plot)), aes(x=.data[[x.new]], y=.data[[y.new]])) + geom_point(size=3, alpha = alpha) - if(!missing(text.multiplier)) scatter.plot <- scatter.plot + theme(text = element_text(size = theme_get()$text$size * text.multiplier)) - - # labels depending on input type - if(is.Field(x) && is.Field(y)) { - scatter.plot <- scatter.plot + labs(y = stringToExpression(paste0(old.layer.y, " ", y@source@name, " ", y@quant@name, " (", standardiseUnitString(y@quant@units), ")")), - x = stringToExpression(paste0(old.layer.x, " ", x@source@name, " ", x@quant@name, " (", standardiseUnitString(x@quant@units), ")"))) - } - else scatter.plot <- scatter.plot + labs(y = layer.y, x = layer.x) - - - - return(scatter.plot) - -} \ No newline at end of file diff --git a/R/plotSpatialComparison.R b/R/plotSpatialComparison.R index 6d80d0c..b11ec11 100644 --- a/R/plotSpatialComparison.R +++ b/R/plotSpatialComparison.R @@ -18,6 +18,11 @@ #' @param legend.title A character string or expression to override the default legend title. Set to NULL for no legend title. The default legend title is the \code{units} #' of the \linkS4class{Quantity} of the first \linkS4class{Comparison} provided in the \code{comparisions} argument. This argument allows general flexibility, but it is particularly handy #' to facilitate expressions for nicely marked up subscript and superscript. +#' @param metrics A character vector specifying the metrics to put on the plots. For spatial data these can be: "ME", "NME", "NMSE", "RMSE", "NME_2", "NMSE_2", "NME_3", +#' "NSME_3", "r2_eff", "r", "r2", "m", "c". +#' @param metric_size A numeric value for the size of the metric text, note that this will be also be scaled by the \code{text.multiplier} argument. +#' @param metric_x_pos,metric_y_pos A number value specifying the x/y location of the metric text as a fraction of the plot area. Note, it uses the +#' overall range of the plotting for calculating this (not the specific ranges of the axes), so using facets or grids with "free" scales will mess this up. #' @param panel.bg.col Colour string for the panel background, default to "white" for absolute values plots, and a grey for difference plots. #' @param override.cols A colour palette function to override the defaults. #' @param symmetric.scale If plotting a differences, make the scale symmetric around zero (default is TRUE) @@ -43,17 +48,22 @@ plotSpatialComparison <- function(comparisons, override.cols = NULL, symmetric.scale = TRUE, do.phase = FALSE, + metrics = c(), + metric_size = waiver(), + metric_x_pos = 0.025, + metric_y_pos = 0.975, ...){ - + Source = Value = Lat = Lon = Layer = long = lat = group = NULL Day = Month = Year = Season = NULL Difference = Percentage.Difference = NULL + x = y = label = NULL # sort type argument type <- match.arg(type) if(!missing(limits)) symmetric.scale <- FALSE - + ### CHECK TO SEE EXACTLY WHAT WE SHOULD PLOT ### 1. COMPARISONS - check the input Comparison objects (and if it is a single Comparison put it into a one-item list) @@ -68,8 +78,12 @@ plotSpatialComparison <- function(comparisons, if(is.null(dim.names)) return(NULL) # dim names not used later + #### 3. METRICS - Make a table to store them + metrics_dt <- makeMetricTableForPlotting(comparisons, metrics, mode = "spatial") + + - ### 3. LAYERS AND FIELDS - the layers to plot are defined by the plot type, here build appropriate Field objects + ### 4. LAYERS AND FIELDS - the layers to plot are defined by the plot type, here build appropriate Field objects #### DIFFERENCE OR PERCENTAGE DIFFERENCE if(type == "difference" || type == "percentage.difference") { @@ -100,7 +114,7 @@ plotSpatialComparison <- function(comparisons, layers.names <- names(object) expected.layers.1 <- paste(object@layers1, makeFieldID(source = object@source1, quant.string = object@quant1@id, sta.info = object@sta.info1), sep = ".") expected.layers.2 <- paste(object@layers2, makeFieldID(source = object@source2, quant.string = object@quant2@id, sta.info = object@sta.info2), sep = ".") - + # check the layers for(this.layer in expected.layers.1) if(!this.layer %in% layers.names) stop(paste("Layer", this.layer, "expected in Comparison object but not found")) for(this.layer in expected.layers.2) if(!this.layer %in% layers.names) stop(paste("Layer", this.layer, "expected in Comparison object but not found")) @@ -141,13 +155,13 @@ plotSpatialComparison <- function(comparisons, else { temp.dt[,c(difference.column.name) := get(expected.layers.1[layer.counter]) - get(expected.layers.2[layer.counter])] if(type == "percentage.difference") temp.dt[,c(difference.column.name) := 100 * get(difference.column.name) / get(expected.layers.2[layer.counter])] - - + + } } } - + object@data <- temp.dt new.object <- selectLayers(object, layers.to.plot) @@ -180,7 +194,7 @@ plotSpatialComparison <- function(comparisons, # set a symmetric scale (so zero always white/centre colour) if(symmetric.scale) limits <- c(-max.for.scale, max.for.scale) - + # if no panel background panel colour specified, use a non-white one if(missing(panel.bg.col)) panel.bg.col = "#999999" @@ -190,8 +204,11 @@ plotSpatialComparison <- function(comparisons, if(type == "percentage.difference") legend.title <- expression(Delta * "%") else legend.title <- stringToExpression(paste0("Delta~", standardiseUnitString(object@quant1@units))) } - - the.plot <- plotSpatial(objects.to.plot, + + ### + + + spatial_comp_plot <- plotSpatial(objects.to.plot, layers = layers.to.plot, cols = override.cols, legend.title = legend.title, @@ -201,9 +218,8 @@ plotSpatialComparison <- function(comparisons, - if(object@type[[1]] == "categorical") the.plot <- the.plot + scale_fill_discrete(name = "Agreement") - return(the.plot) - + if(object@type[[1]] == "categorical") spatial_comp_plot <- spatial_comp_plot + scale_fill_discrete(name = "Agreement") + } ### VALUES @@ -284,17 +300,51 @@ plotSpatialComparison <- function(comparisons, # make a legend title if one has not been supplied if(missing(legend.title)) legend.title <- stringToExpression(standardiseUnitString(object@quant1@units)) - return(plotSpatial(objects.to.plot, - layers = unique(layers.to.plot), - cols = override.cols, - limits = limits, - legend.title = legend.title, - ...)) + spatial_comp_plot <- plotSpatial(objects.to.plot, + layers = unique(layers.to.plot), + cols = override.cols, + limits = limits, + legend.title = legend.title, + ...) + + } + + + #### ADD METRICS #### + if(length(metrics) > 0){ + + args <- list(...) + if("text.multipler" %in% names(args)) text.multiplier <- args[["text.multipler"]] + else text.multiplier <- 1 + + plotting_dt <- plotSpatial(objects.to.plot, + layers = unique(layers.to.plot), + cols = override.cols, + limits = limits, + legend.title = legend.title, + plot = FALSE) + + xlims <- range(with(plotting_dt, c(Lon)), na.rm = TRUE) + ylims <- range(with(plotting_dt, c(Lat)), na.rm = TRUE) + metrics_dt[ , x := (xlims[2] - xlims[1]) * metric_x_pos + xlims[1]] + metrics_dt[ , y := (ylims[2] - ylims[1]) * metric_y_pos + ylims[1]] + if(!is.null(text.multiplier)) metric_size <- metric_size * text.multiplier + spatial_comp_plot <- spatial_comp_plot + geom_text(data = metrics_dt, + mapping = aes(x = x, y = y, label = label), + size = metric_size, + size.unit = "pt", + vjust = 0, + hjust = 0, + parse = TRUE) + } + return(spatial_comp_plot) + + } \ No newline at end of file diff --git a/R/plotXYComparison.R b/R/plotXYComparison.R index 604cc89..57adcd1 100644 --- a/R/plotXYComparison.R +++ b/R/plotXYComparison.R @@ -1,24 +1,45 @@ #!/usr/bin/Rscript -################################################################################################################################################# -################################################## PLOT COMPARISON MAPS ######################################################################### -################################################################################################################################################# +################################################################################################################################################ +################################################## PLOT XY COMPARISON ######################################################################### +################################################################################################################################################ -#' Plot a comparison between two spatial layers +#' Plot a scatter comparison between two layers #' -#' This function is for plotting maps from Comparison objects (or a list of those Comparisons). Three types of comparisons plots are supported: 'difference' - -#' a difference map; "values" - the absolute values plotted in panels and "percentage.difference" - the percentage differences. +#' This produces X-Y scatter plots from Comparison objects (or a list of those Comparisons). These plots can be rendered with points or point densities +#' with square binsor hexagonal bins. #' #' @param comparisons The data to plot, must be a Comparison or a list of Comparisons #' @param type A character specifying what type of plot to make. Can be "points" (default, for geom_points), "hex" (for hex binning), "bin2d" (for square binning). #' There might be more useful options to add later. -#' @param col.by,size.by,shape.by,alpha.by Character strings defining the aspects of the data which which should be used to set the colour, line type, line width, point size and point shape and alpha (transparency). -#' Can meaningfully take the values "Layer", "Source", "Site" or "Quantity". By default \code{col.by} is set to "Layer" and all others set to NULL, which means the different aspects are -#' distinguished by different facet panels. Thus the standard behaviour is that different Layers are distinguished by different colours, but everything is separated into different panels. - -#' @details A wrapper for around \link{plotSpatial} to plot the spatial Comparisons as maps. Extra arguments to \link{plotSpatial} can also be specified. +#' @param fit_line_col A colour for the fit line through the data (default is NULL meaning no fit line). +#' @param perfect_line_col A colour for the perfect one-to-one line (default is NULL meaning no one-to-one line). +#' @param col.by Character strings defining the aspects of the data which which should be used to set the colour of the points +#' @param matchLimits Logical, determins if the X and X axes should have the same range. Default is TRUE. +#' (only works for \code{type = "points"}). Can meaningfully take the values of spatiotemporal dimensions which are in the dataset +#' such as "Day", "Month", "Season", "Year", "Lon" and "Lat". +#' By default \code{col.by} is set to NULL, which doesn't distinguish the points by colour. +#' @param text.multiplier A number specifying an overall multiplier for the text on the plot. +#' Make it bigger if the text is too small on large plots and vice-versa. +#' @param metrics A character vector specifying the metrics to put on the plots. For spatial data these can be: "ME", "NME", "NMSE", "RMSE", "NME_2", "NMSE_2", "NME_3", +#' "NSME_3", "r2_eff", "r", "r2", "m", "c". +#' @param metric_size A numeric value for the size of the metric text, note that this will be also be scaled by the \code{text.multiplier} argument. +#' @param metric_x_pos,metric_y_pos A number value specifying the x/y location of the metric text as a fraction of the plot area. Note, it uses the +#' overall range of the plotting for calculating this (not the specific ranges of the axes), so using facets or grids with "free" scales will mess this up. +#' +#' @param ... Arguments passed to \code{ggplot2::facet_wrap()}. See the ggplot2 documentation for full details but the following are particularly useful. +#' \itemize{ +#' \item{"nrow"}{The number of rows of facets} +#' \item{"ncol"}{The number of columns of facets} +#' \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) +#' "free" (all facets can their x and y ranges), "free_x" and "free_y" (only x and y ranges can vary, respectively).} +#' \item{"labeller"}{A function to define the labels for the facets. This is a little tricky, please look to the ggplot2 documentation. +#' But basically what you want is to define a named character vector, the names are the previous facet names and the values are the new names. +#' Then make this into a function by passing it to the ggplot function "as.labeller", and then that becomes your 'labeller' argument.} +#' } +#' @details A wrapper for around \link{plotSpatial} to plot the spatial Comparisons as maps. Extra arguments to \link{plotSpatial} can also be specified. #' #' @return Returns a ggplot object #' @@ -43,6 +64,7 @@ plotXYComparison <- function(comparisons, Source = Value = Lat = Lon = Layer = long = lat = group = NULL Day = Month = Year = Season = NULL + X = x = Y = y = slope = intercept = label = Difference = Comparison = NULL # sort type argument type <- match.arg(type) @@ -71,7 +93,7 @@ plotXYComparison <- function(comparisons, metrics_dt <- data.table() comparison_obj_factors <- c() for(object in comparisons){ - + pretty_comparison_name <- gsub(pattern = " - ", replacement = " vs ", x = object@name) comparison_obj_factors <- append(comparison_obj_factors, pretty_comparison_name) tmp_dt <- copy(object@data) @@ -83,37 +105,18 @@ plotXYComparison <- function(comparisons, plotting_dt <- rbind(plotting_dt, tmp_dt) fit_lines_dt <- rbind(data.table(slope = object@stats$m, intercept = object@stats$c, Comparison = pretty_comparison_name), fit_lines_dt) - if(length(metrics) > 0 ){ - tmp_metrics_list <- list() - for(metric in metrics){ - - # for something represing new lines - if(metric %in% c("", "\n")) { - tmp_metrics_list[[length(tmp_metrics_list)+1]] <- "\n" - } - # for a real metric - else { - metric_text <- metric - if(metric == "m") metric_text <- "Slope" - if(metric == "c") metric_text <- "Intercept" - if(metric == "R2") metric_text <- "R^2" - if(metric == "r2") metric_text <- "r^2" - tmp_metrics_list[[metric_text]] <- paste0(metric_text, "==", signif(object@stats[[metric]], 2)) - } - } - tmp_metrics_string <- paste(tmp_metrics_list, collapse = " ") - tmp_dt <- data.table(Comparison = pretty_comparison_name, label = gsub(" ", "~", tmp_metrics_string)) - metrics_dt <- rbind(metrics_dt, tmp_dt) - } - + } + #### METRICS - Make a table to store them + metrics_dt <- makeMetricTableForPlotting(comparisons, metrics) + #### set the facet ordering by using the factor - Gahhh!! why doesn't this work?? plotting_dt[ , Comparison := factor(x = Comparison, levels = comparison_obj_factors)] - + # make a legend title if one has not been supplied #if(missing(legend.title)) legend.title <- stringToExpression(standardiseUnitString(object@quant1@units)) @@ -154,7 +157,7 @@ plotXYComparison <- function(comparisons, xy_plot <- xy_plot + geom_bin2d() + viridis::scale_fill_viridis(option = "F", direction = -1, trans = "log10") } - + #### HANDLE LIMITS #### mylims <- range(with(plotting_dt, c(X, Y)), na.rm = TRUE) if(matchLimits) { @@ -169,6 +172,7 @@ plotXYComparison <- function(comparisons, #### ADD METRICS #### if(length(metrics) > 0){ + xlims <- range(with(plotting_dt, c(X)), na.rm = TRUE) ylims <- range(with(plotting_dt, c(Y)), na.rm = TRUE) metrics_dt[ , x := xlims[2] * metric_x_pos] diff --git a/R/plotting-framework-functions.R b/R/plotting-framework-functions.R index 7c0dc3d..208d546 100644 --- a/R/plotting-framework-functions.R +++ b/R/plotting-framework-functions.R @@ -126,129 +126,6 @@ santiseLayersForPlotting <- function(fields, layers) { } -#' Sanitise input layers for X-Y plotting -#' -#' This is an internal helper function which checks the layers requested to be plotted against the layers in the the fields to be plotted. If layers is NULL, then -#' it returns all layers present in any fields -#' -#' @param fields The list of Fields to be plotted (should have been check by santiseFieldsForPlotting first) -#' @param layers The layers requested to be plotted -#' @return Returns character vector of the layers to be plotted -#' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} -#' @keywords internal -#' -#' -santiseLayersForPlottingXY <- function(fields1, fields2, layers1, layers2) { - - print(fields1) - print(fields2) - print(layers1) - print(layers2) - - - #### Must return a list of 2-element named, character vectors where the names are the Field - - layers.superset <- c() - num.layers.x.fields <- 0 - - # Work through all the possible combinations of fields and layers arguments - final_layers <- list() - plotting_dt <- data.table() - - # for each fields1, copy layers from each fields2 - all_comps <- list - for(fld1 in fields1){ - for(fld2 in fields2){ - all_comps <- compareLayers(field1 = fld1, field2 = fld2, layers1 = layers1, layers2 = layers2, show.stats = FALSE) - } - } - - print(plotting_dt) - return(plotting_dt) - - # a single field - if(length(fields) == 1){ - - if(length(layers) == 1) { - stop("plotScatter: Failing. You gave me one Field, so I need at least two layers, you only specified one.") - } - else if(is.null(layers) || missing(layers)){ - layers <- layers(fields[[1]]) - print(layers) - # compare every layer to every other layer - layers_todo <- layers - - for(this_layer in layers){ - print(this_layer) - # remove this layer from layers_todo - layers_todo <- layers_todo[-which(layers_todo == this_layer)] - print(layers_todo[!which(layers_todo == this_layer)]) - print(layers_todo) - for(this_second_layer in layers_todo){ - this_group <- - plotting_dt < plotting_dt - final_layers[[paste0(this_layer, "_x_", this_second_layer)]] <- c( this_layer, this_second_layer) - } - } - - } - } - - print(final_layers) - - - # if no layers argument supplied make a list of all layers present (in any object) - if(is.null(layers) || missing(layers)){ - - for(object in fields){ - temp.layers <- names(object) - num.layers.x.fields <- num.layers.x.fields + length(temp.layers) - layers.superset <- append(layers.superset, temp.layers) - } - layers <- unique(layers.superset) - - } - else if(is.character(layers)) { - - - - } - - # else if layers have been specified check that we have some of the requested layers present - else{ - - for(object in fields){ - - layers.present <- intersect(names(object), layers) - num.layers.x.fields <- num.layers.x.fields + length(layers.present) - - if(length(layers.present) == 0) {warning("Some Fields to plot don't have all the layers that were requested to plot.\n")} - layers.superset <- append(layers.superset, layers.present) - - } - - # Return empty plot if not layers found - if(num.layers.x.fields == 0){ - warning("None of the specified layers found in the objects provided to plot. Returning NULL.\n") - return(NULL) - } - - # Also check for missing layers and given a warning - missing.layers <- layers[!(layers %in% unique(layers.superset))] - if(length(missing.layers) != 0) { warning(paste("The following layers were requested to plot but not present in any of the supplied objects:", paste(missing.layers, collapse = " "), ".\n", sep = " ")) } - - # finally make a unique list of layers to be carried in to the actual plotting - layers <- unique(layers.superset) - - } - - return(layers) - -} - - - - #' Sanitise STAInfo for plotting #' #' This is an internal helper function which checks the dimensions of the Fields to be plotted @@ -578,7 +455,7 @@ mergeFieldsForPlotting <- function(fields, add.Quantity = FALSE, add.Site = FA #' #' This is an internal helper function to build a y-axis for Temporal and Subannual plots, possibly with multiple Quantities #' -#' @param final.fields The list of Fields to be plotted (should have been check by santiseFieldsForPlotting first) +#' @param objects The list of Fields to be plotted (should have been check by santiseFieldsForPlotting first) #' #' @return Returns the y-axis as a chatacter string, #' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} @@ -590,8 +467,8 @@ makeYAxis <- function(objects) { # first extract the names and units and store them in a tuples (two element vector) for the Quantity from each Field all.quant.tuples <- list() for(object in objects) { - if(is.Field(object)) all.quant.tuples[[length(all.quant.tuples)+1]] <- c(object@quant@name, object@quant@units) - else if(is.Quantity(object)) all.quant.tuples[[length(all.quant.tuples)+1]] <- c(object@name, object@units) + if(is.Field(object)) all.quant.tuples[[length(all.quant.tuples)+1]] <- c(object@quant@name, object@quant@units) + else if(is.Quantity(object)) all.quant.tuples[[length(all.quant.tuples)+1]] <- c(object@name, object@units) } # select the unique ones @@ -705,6 +582,39 @@ addMapOverlay <- function(map_plot, map_overlay) { } +# TODO +makeMetricTableForPlotting <- function(comparisons, metrics, mode = "xy") { + + metrics_dt <- data.table() + for(object in comparisons){ + + tmp_metrics_list <- list() + for(metric in metrics){ + + # for something represing new lines + if(metric %in% c("", "\n")) { + tmp_metrics_list[[length(tmp_metrics_list)+1]] <- "\n" + } + # for a real metric + else { + metric_text <- metric + if(metric == "m") metric_text <- "Slope" + if(metric == "c") metric_text <- "Intercept" + if(metric == "R2") metric_text <- "R^2" + if(metric == "r2") metric_text <- "r^2" + tmp_metrics_list[[metric_text]] <- paste0(metric_text, "==", signif(object@stats[[metric]], 2)) + } + } + tmp_metrics_string <- paste(tmp_metrics_list, collapse = " ") + if(mode == "xy") tmp_dt <- data.table(Comparison = gsub(pattern = " - ", replacement = " vs ", x = object@name), label = gsub(" ", "~", tmp_metrics_string)) + else if(mode == "spatial") tmp_dt <- data.table(Facet = object@name, label = gsub(" ", "~", tmp_metrics_string)) + metrics_dt <- rbind(metrics_dt, tmp_dt) + } + + if(mode == "spatial") metrics_dt[ , Facet := factor(Facet)] + + return(metrics_dt) +} #' @keywords internal #' @importFrom units as_units From 00f48e3ade7097e05d87a2fb892b6d764e50d354 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Thu, 9 Jan 2025 14:01:05 +0000 Subject: [PATCH 10/20] Bug fixes for controlling facets with factors --- R/plotXYComparison.R | 1 + R/plotting-framework-functions.R | 1 + 2 files changed, 2 insertions(+) diff --git a/R/plotXYComparison.R b/R/plotXYComparison.R index 57adcd1..699e0ad 100644 --- a/R/plotXYComparison.R +++ b/R/plotXYComparison.R @@ -107,6 +107,7 @@ plotXYComparison <- function(comparisons, fit_lines_dt) } + fit_lines_dt[ , Comparison := factor(Comparison)] #### METRICS - Make a table to store them metrics_dt <- makeMetricTableForPlotting(comparisons, metrics) diff --git a/R/plotting-framework-functions.R b/R/plotting-framework-functions.R index 208d546..1acd77b 100644 --- a/R/plotting-framework-functions.R +++ b/R/plotting-framework-functions.R @@ -612,6 +612,7 @@ makeMetricTableForPlotting <- function(comparisons, metrics, mode = "xy") { } if(mode == "spatial") metrics_dt[ , Facet := factor(Facet)] + if(mode == "xy") metrics_dt[ , Comparison := factor(Comparison)] return(metrics_dt) } From 2a64c8e2dc8902d4b2ceb9400ca9110436442239 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Wed, 5 Feb 2025 14:37:21 +0000 Subject: [PATCH 11/20] Tweaks to solve CHECK NOTES etc. Mostly tweaks documentation. Also incremented version number and commited all updated .Rd files. --- DESCRIPTION | 2 +- R/benchmarking.R | 2 +- R/calcNewField.R | 2 +- R/classes.R | 16 +++---- R/getField.R | 2 +- R/layerOp.R | 24 +++++----- R/package-documentation.R | 10 ++--- R/plotSpatial.R | 2 +- R/plotSubannual.R | 2 +- R/plotTemporal.R | 2 +- R/plotXYComparison.R | 2 +- R/plotting-framework-functions.R | 2 + R/writeNetCDF-methods.R | 12 ++--- man/Comparison-class.Rd | 6 +-- man/DGVMTools-package.Rd | 26 +++++++++-- man/FPCMegaBiomeRules.Rd | 2 +- man/Period-class.Rd | 8 ++-- man/Scheme-class.Rd | 2 +- man/calcNewField.Rd | 2 +- man/commonSTAInfo.Rd | 2 +- man/getDailyField_aDGVM.Rd | 4 -- man/getField.Rd | 2 +- man/getField_NetCDF.Rd | 4 +- man/getStandardQuantity_LPJ.Rd | 4 -- man/getStandardQuantity_aDGVM.Rd | 4 -- man/getYearlyField_aDGVM.Rd | 4 -- man/layerOp.Rd | 24 +++++----- man/lm_eqn.Rd | 2 +- man/makeYAxis.Rd | 4 +- man/openLPJOutputFile_FireMIP.Rd | 4 -- man/plotScatter.Rd | 46 ------------------- man/plotSpatial.Rd | 2 +- man/plotSpatialComparison.Rd | 12 +++++ man/plotSubannual.Rd | 2 +- man/plotTemporal.Rd | 2 +- man/plotXYComparison.Rd | 76 ++++++++++++++++++++++++++++++++ man/trimFieldsForPlottingXY.Rd | 45 +++++++++++++++++++ man/writeNetCDF-methods.Rd | 12 ++--- 38 files changed, 234 insertions(+), 147 deletions(-) delete mode 100644 man/plotScatter.Rd create mode 100644 man/plotXYComparison.Rd create mode 100644 man/trimFieldsForPlottingXY.Rd diff --git a/DESCRIPTION b/DESCRIPTION index a061d46..78cf39b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: DGVMTools Type: Package -Version: 1.1.0 +Version: 1.2.0 Title: DGVM Processing, Analysis and Plotting Tools Date: 2023-04-13 Authors@R: c(person("Matthew", "Forrest", role=c("aut", "cre"), email="matthew.forrest@senckenberg.de"), diff --git a/R/benchmarking.R b/R/benchmarking.R index 83225dd..c82683b 100644 --- a/R/benchmarking.R +++ b/R/benchmarking.R @@ -1,7 +1,7 @@ #' Make linear fit equation string #' -#' Makes a string (form: y = ax + b, r^2 = r^2) for putting on plots from a linear model (lm) +#' Makes a string (form: y = ax \+ b, r^2 = r^2) for putting on plots from a linear model (lm) #' #' @param linear.model An object of class lm, should have been made with a simple \code{y ~ x} formula #' diff --git a/R/calcNewField.R b/R/calcNewField.R index 2d66eab..b9b03e9 100644 --- a/R/calcNewField.R +++ b/R/calcNewField.R @@ -9,7 +9,7 @@ #' @param y The second \code{\linkS4class{Field}} #' @param x.col the column of the first Field. If empty or NULL all columns are used. #' @param y.col the column of the second Field. If empty or NULL all columns are used. -#' @param op which arithmetic should be performed: addition ('+'), substraction ('-'), multiplication ('*') or division ('/'). +#' @param op which arithmetic should be performed: addition ('+'), subtraction ('-'), multiplication ('*') or division ('/'). #' @param quant new Quantity definition to use, if NULL it will be guessed. #' @param verbose print some messages. #' @return A new Field. diff --git a/R/classes.R b/R/classes.R index 91680f4..8f83d32 100644 --- a/R/classes.R +++ b/R/classes.R @@ -56,10 +56,10 @@ setClass("Format", #' @details #' Since these are for the most part standard (ie. people commonly need the months, the seasons (DJF, MAM, JJA, SON) and annual) these are defined in simple list that might be commonly used and can be looped through. These are: #' \describe{ -#' \item{\code{months}}{which contains all the months.} -#' \item{\code{seasons}}{which contains all the seasons.} -#' \item{\code{annual}}{which only contains only the annual period.} -#' \item{\code{all.periods, periods}}{which contains all of the above.} +#' \item{all.months}{which contains all the months.} +#' \item{all.seasons}{which contains all the seasons.} +#' \item{annual}{which only contains only the annual period.} +#' \item{all.periods}{which contains all of the above.} #' } #' #' However other periods can be defined for specific growing seasons etc. @@ -332,11 +332,11 @@ setClass("Quantity", #' @slot id A unique character string to identify this particular vegetation object. Recommended to be alphanumeric because it is used to construct file names. #' @slot name A character string describing this comparison layer, is automatically generated #' @slot type A character string describing what type of comparisons this is (automatically determined). Can be -#' \itemize{ +#' \describe{ #' \item{"continuous"}{A comparison of two continous, numerical layers.} #' \item{"categorical"}{A comparison of two categorical layers.} -#' \item{"relative.abundance"} {A comparison of multiple numerical layers whose sum equals unity.} -#' \item{"seasonal"} {A comparison of the seasonal concentration and phase calculated from two numerical layers which have monthly data.} +#' \item{"relative.abundance"}{A comparison of multiple numerical layers whose sum equals unity.} +#' \item{"seasonal"}{A comparison of the seasonal concentration and phase calculated from two numerical layers which have monthly data.} #' } #' @slot data A data.table object. This is used because is it very much faster for calculations that data.frame or raster layers. #' @slot quant1 A \linkS4class{Quantity} object to define what quantity the data from first field represents @@ -393,7 +393,7 @@ setClass("Comparison", #' @slot rules A function which is applied to every row of the data.table and describes the classification rules. #' @slot layers.needed List of vegetation layers needed to perform the classification and the name of the new layer, to be interpreted by \code{\link{layerOp}}, specified as a list of three- or four-item list #' whose elements first element id the id of a \code{\linkS4class{Quantity}} and whose other elements are passed as arguments to the \code{\link{layerOp}} function. -#' For example one element could be \code{Woody = list(quantity = "LAI_std", operator = "+", layers = c(".Tree", ".Shrubs"), new.layer = "Woody")}, +#' For example one element could be \code{Woody = list(quantity = "LAI_std", operator = "\+", layers = c(".Tree", ".Shrubs"), new.layer = "Woody")}, #' which would make a layer called "Woody" which would be the sum of all LAI trees and shrubs. #' @slot data.reference Character string giving a reference where the data for this classification scheme comes from #' @slot published.reference Character string giving a reference where this model output classification scheme was published diff --git a/R/getField.R b/R/getField.R index 347126d..1fecd7e 100644 --- a/R/getField.R +++ b/R/getField.R @@ -10,7 +10,7 @@ #' To check what dimensions you have you can use \code{\link{getDimInfo}} #' #' @param source The \code{\linkS4class{Source}} object for which the \code{\linkS4class{Field}} should be built, typically a model run or a dataset. -#' @param quant The \\code{\linkS4class{Quantity}} to be read - either a \code{\linkS4class{Quantity}} object or a string containing its \code{id}. If it is a character string it will be checked +#' @param quant The \code{\linkS4class{Quantity}} to be read - either a \code{\linkS4class{Quantity}} object or a string containing its \code{id}. If it is a character string it will be checked #' against the predefined \code{Quantities} in the \code{\linkS4class{Source}} object and failing that a simple dummy \code{\linkS4class{Quantity}} will be be made. For the \code{NetCDF Format} #' most \code{\linkS4class{Quantity}} metadata will be taken from the NetCDF file where possible (thus overriding this option). #' @param layers A list (or vector of character) of character strings to specify which Layers should be read from the file. diff --git a/R/layerOp.R b/R/layerOp.R index 6fde439..8248955 100644 --- a/R/layerOp.R +++ b/R/layerOp.R @@ -5,18 +5,18 @@ #' #' @param x The x object on which we are operating. #' @param operator The operator we are applying, can be: -#' \itemize{ -#' \item{"+" (or "sum" or "add")} {Add the layers, can apply to any number of layers} -#' \item{"mean" (or "average")} {Average the layers, can apply to any number of layers} -#' \item{"*" (or "multiply" or "product")} {Multiply the layers, can apply to any number of layers} -#' \item{"-" (or "subtract" or "minus")} {Subtract one layer from another. Requires exactly two layers to be specified, subtracts the second from the first, ie. layer1 - layer 2.} -#' \item{"/" (or "divide" or "through")} {Divide one layer by another. Nore this does 'safe division' which returns zero if the denomination is zero. Requires exactly two layers to be specified, divides the first by the second, ie. layer1 / layer 2.} -#' \item{"max.layer"} {Gets the layer with the maximum value from the input layers (is a layer of factors). If they are all zero at a point then "None" is assigned. In the case of ties, the first layer in the layers arguement will be returned as the max.} -#' \item{"min.layer"} {Gets the layer with the minimum value from the input layers (is a layer of factors). If they are all zero at a point then "None" is assigned. In the case of ties, the first layer in the layers arguement will be returned as the min.} -#' \item{"mulc"/"divc"/"addc"/"subc"} {Multiplies, divides, adds or subtracts the layer with a numeric value in the "constant" argument} -#' \item{\emph{any numeric value}} {Sets each of the layers specified uniformly to the numeric value specified, most usefuly for 0. Previously not existing layers in the layers and new.layer argument will be created.} -#' \item{\emph{NULL}} {A special case of the above which removes the layers from the Field} -#' \item{\emph{Whatever function}} {Now we are into crazy territory! You can provide any function (the actual function, not a string ) that operates on a vector of numerics and it might just work! Works for sd, var, min and max, but your mileage may vary.} +#' \describe{ +#' \item{"+" (or "sum" or "add")}{Add the layers, can apply to any number of layers} +#' \item{"mean" (or "average")}{Average the layers, can apply to any number of layers} +#' \item{"*" (or "multiply" or "product")}{Multiply the layers, can apply to any number of layers} +#' \item{"-" (or "subtract" or "minus")}{Subtract one layer from another. Requires exactly two layers to be specified, subtracts the second from the first, ie. layer1 - layer 2.} +#' \item{"/" (or "divide" or "through")}{Divide one layer by another. Nore this does 'safe division' which returns zero if the denomination is zero. Requires exactly two layers to be specified, divides the first by the second, ie. layer1 / layer 2.} +#' \item{"max.layer"}{Gets the layer with the maximum value from the input layers (is a layer of factors). If they are all zero at a point then "None" is assigned. In the case of ties, the first layer in the layers arguement will be returned as the max.} +#' \item{"min.layer"}{Gets the layer with the minimum value from the input layers (is a layer of factors). If they are all zero at a point then "None" is assigned. In the case of ties, the first layer in the layers arguement will be returned as the min.} +#' \item{"mulc"/"divc"/"addc"/"subc"}{Multiplies, divides, adds or subtracts the layer with a numeric value in the "constant" argument} +#' \item{\emph{any numeric value}}{Sets each of the layers specified uniformly to the numeric value specified, most usefuly for 0. Previously not existing layers in the layers and new.layer argument will be created.} +#' \item{\emph{NULL}}{A special case of the above which removes the layers from the Field} +#' \item{\emph{Whatever function}}{Now we are into crazy territory! You can provide any function (the actual function, not a string ) that operates on a vector of numerics and it might just work! Works for sd, var, min and max, but your mileage may vary.} #' \item{\emph{Something else?}}{Contact the author!} #' } #' @param layers The names of the layers upon which to operate (as a vector of characters). Furthermore, one can utilise a handy trick whereby any layer specified, diff --git a/R/package-documentation.R b/R/package-documentation.R index 80107a6..33b761c 100644 --- a/R/package-documentation.R +++ b/R/package-documentation.R @@ -1,10 +1,9 @@ #' @title An overview of the DGVMTools package #' #' @name DGVMTools-package -#' @docType package #' #' @description This package is designed for reading, processing and plotting output from Dynamic Vegetation Models (DGVMs), land surface models from climate models and other -#' spatial representions of the terrestrial biosphere or land surface. There are many such models and each have their own output format. +#' spatial representations of the terrestrial biosphere or land surface. There are many such models and each have their own output format. #' This package gives a framework for reading the different outputs from these models and putting them into a common internal representation. Once this is done, #' it provides many tools for analysing the model results and comparing them to data (and each other). These include common tasks such as: #' @@ -28,10 +27,10 @@ #' are explicit objects with their own meta-data (if you don't know what these concepts are then this package probably isn't for you). #' Once these objects are correctly defined (which is not difficult), analysis is very convenient. #' Many common tasks are already coded efficiently into functions, and because of the meta-data attached to the objects, -#' These functions can do a lot of 'sensible and standard'stuff without too much direction from the user. +#' These functions can do a lot of 'sensible and standard' stuff without too much direction from the user. #' Secondly, the data is stored internally as a data.table (as opposed to a data.frame). #' The advantage of this is that data.tables are very, very much faster than data.frames for many operations (check out the data.table package -#' documentation and webpage for more info). This is obviously a great advantage when working with very large spatial-temporal datasets. +#' documentation and webpage for more info). This is obviously a great advantage when working with very large spatial-temporal data sets. #' It should be noted that this advantage was very important compared to the now outdated raster package. The replacement for raster (terra) is faster so this #' advantage is not as large. #' @@ -42,5 +41,4 @@ #' functions. However, DGVMTools is intended to be a reasonably complete analysis environment in itself. It should be possible to go from model output #'all the way to results and publication quality plots using only DGVMTools and some base R functionality for other tasks. #' - -NULL \ No newline at end of file +"_PACKAGE" \ No newline at end of file diff --git a/R/plotSpatial.R b/R/plotSpatial.R index 81487c9..68031ca 100644 --- a/R/plotSpatial.R +++ b/R/plotSpatial.R @@ -50,7 +50,7 @@ #' @param pixel.size Numeric, allows you to alter the plotted pixel size (height and width simultaneously using the same value). This is useful #' if you are plotting a collection of individual sites which do not have regular spacing. Note the "tile = TRUE" (see above) will automatically set if you haven't done it manually. #' @param ... Arguments passed to \code{ggplot2::facet_wrap()}. See the ggplot2 documentation for full details but the following are particularly useful. -#' \itemize{ +#' \describe{ #' \item{"nrow"}{The number of rows of facets} #' \item{"ncol"}{The number of columns of facets} #' \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) diff --git a/R/plotSubannual.R b/R/plotSubannual.R index 6522a5d..58ee1e9 100644 --- a/R/plotSubannual.R +++ b/R/plotSubannual.R @@ -31,7 +31,7 @@ #' Make it bigger if the text is too small on large plots and vice-versa. #' @param plot Boolean, if FALSE return a data.table with the final data instead of the ggplot object. This can be useful for inspecting the structure of the facetting columns, amongst other things. #' @param ... Arguments passed to \code{ggplot2::facet_wrap()}. See the ggplot2 documentation for full details but the following are particularly useful. -#' \itemize{ +#' \describe{ #' \item{"nrow"}{The number of rows of facets} #' \item{"ncol"}{The number of columns of facets} #' \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) diff --git a/R/plotTemporal.R b/R/plotTemporal.R index 3cb4859..f7a4fc6 100644 --- a/R/plotTemporal.R +++ b/R/plotTemporal.R @@ -27,7 +27,7 @@ #' @param dropEmpty Logical, if TRUE don't plot time series lines consisting only of zeros (default is FALSE). #' @param plot Logical, if FALSE return the data.table of data instead of the plot #' @param ... Arguments passed to \code{ggplot2::facet_wrap()} and \code{ggplot2::stat_smooth()}. See the ggplot2 documentation for full details but the following are particularly useful. -#' \itemize{ +#' \describe{ #' \item{"nrow"}{The number of rows of facets. (facet_wrap)} #' \item{"ncol"}{The number of columns of facets. (facet_wrap)} #' \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) diff --git a/R/plotXYComparison.R b/R/plotXYComparison.R index 699e0ad..bbf2c8d 100644 --- a/R/plotXYComparison.R +++ b/R/plotXYComparison.R @@ -30,7 +30,7 @@ #' overall range of the plotting for calculating this (not the specific ranges of the axes), so using facets or grids with "free" scales will mess this up. #' #' @param ... Arguments passed to \code{ggplot2::facet_wrap()}. See the ggplot2 documentation for full details but the following are particularly useful. -#' \itemize{ +#' \describe{ #' \item{"nrow"}{The number of rows of facets} #' \item{"ncol"}{The number of columns of facets} #' \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) diff --git a/R/plotting-framework-functions.R b/R/plotting-framework-functions.R index 1acd77b..3d8f4c0 100644 --- a/R/plotting-framework-functions.R +++ b/R/plotting-framework-functions.R @@ -585,6 +585,8 @@ addMapOverlay <- function(map_plot, map_overlay) { # TODO makeMetricTableForPlotting <- function(comparisons, metrics, mode = "xy") { + Comparison = NULL + metrics_dt <- data.table() for(object in comparisons){ diff --git a/R/writeNetCDF-methods.R b/R/writeNetCDF-methods.R index 701c1d3..3b5eeed 100644 --- a/R/writeNetCDF-methods.R +++ b/R/writeNetCDF-methods.R @@ -37,15 +37,15 @@ #' @param .sta.info Advanced. An object of STAInfo for tracking spatio-temporal metadata. IGNORED for for a Field as it is handled #' automatically when writing a Field. But can be added manually for a raster if you wish. #' @param ... Other arguments that can usefully be passed to ncdf4::ncvar_def, in particular: -#' \itemize{ -#' \item{compression} {Integer to define compression level when define netCDF variables (1 = a little compression, 9 = a lot of compression). +#' \describe{ +#' \item{compression}{Integer to define compression level when define netCDF variables (1 = a little compression, 9 = a lot of compression). #' Set to NA (default) for no compression. Using compression forces netCDF version 4.} -#' \item{missval} {Numeric, for the missing value. Default is NA which gives NaN as the missing value. NULL can be used to specify "no missing value" +#' \item{missval}{Numeric, for the missing value. Default is NA which gives NaN as the missing value. NULL can be used to specify "no missing value" #' although it is not clear what that does in the resultant netcdf file in practice. TRENDY/GCP likes -99999.0 for missing values.} -#' \item{prec} {Character, the output precision (although that is confusing terminology, 'type' would be more descriptive) to use in the netCDF file. +#' \item{prec}{Character, the output precision (although that is confusing terminology, 'type' would be more descriptive) to use in the netCDF file. #' See the 'prec' argument of ncdf4::ncvar_def, can be 'short', 'integer', 'float', 'double', 'char', 'byte'). Default is 'float'.} -#' \item{shuffle} {Logical, if TRUE turn on the shuffle filter see netCDF docs and ncdf4::ncvar_def for details} -#' \item{chunksize} {If set, this must be a vector of integers with a length equal to the number of dimensions in the variable. Potentially very useful +#' \item{shuffle}{Logical, if TRUE turn on the shuffle filter see netCDF docs and ncdf4::ncvar_def for details} +#' \item{chunksize}{If set, this must be a vector of integers with a length equal to the number of dimensions in the variable. Potentially very useful #' to optimise the read and write time, but rather advanced, see netCDF docs and ncdf4::ncvar_def for details} #' } #' diff --git a/man/Comparison-class.Rd b/man/Comparison-class.Rd index 555f1f7..d7b32ad 100644 --- a/man/Comparison-class.Rd +++ b/man/Comparison-class.Rd @@ -23,11 +23,11 @@ Generally these are not created directly by the user, but rather by the function \item{\code{name}}{A character string describing this comparison layer, is automatically generated} \item{\code{type}}{A character string describing what type of comparisons this is (automatically determined). Can be -\itemize{ +\describe{ \item{"continuous"}{A comparison of two continous, numerical layers.} \item{"categorical"}{A comparison of two categorical layers.} - \item{"relative.abundance"} {A comparison of multiple numerical layers whose sum equals unity.} - \item{"seasonal"} {A comparison of the seasonal concentration and phase calculated from two numerical layers which have monthly data.} + \item{"relative.abundance"}{A comparison of multiple numerical layers whose sum equals unity.} + \item{"seasonal"}{A comparison of the seasonal concentration and phase calculated from two numerical layers which have monthly data.} }} \item{\code{data}}{A data.table object. This is used because is it very much faster for calculations that data.frame or raster layers.} diff --git a/man/DGVMTools-package.Rd b/man/DGVMTools-package.Rd index ad75025..8e934aa 100644 --- a/man/DGVMTools-package.Rd +++ b/man/DGVMTools-package.Rd @@ -2,11 +2,12 @@ % Please edit documentation in R/package-documentation.R \docType{package} \name{DGVMTools-package} +\alias{DGVMTools} \alias{DGVMTools-package} \title{An overview of the DGVMTools package} \description{ This package is designed for reading, processing and plotting output from Dynamic Vegetation Models (DGVMs), land surface models from climate models and other -spatial representions of the terrestrial biosphere or land surface. There are many such models and each have their own output format. +spatial representations of the terrestrial biosphere or land surface. There are many such models and each have their own output format. This package gives a framework for reading the different outputs from these models and putting them into a common internal representation. Once this is done, it provides many tools for analysing the model results and comparing them to data (and each other). These include common tasks such as: @@ -29,10 +30,10 @@ Firstly, it is tailored for a typical DGVM analysis workflow. Concepts like 'da are explicit objects with their own meta-data (if you don't know what these concepts are then this package probably isn't for you). Once these objects are correctly defined (which is not difficult), analysis is very convenient. Many common tasks are already coded efficiently into functions, and because of the meta-data attached to the objects, -These functions can do a lot of 'sensible and standard'stuff without too much direction from the user. +These functions can do a lot of 'sensible and standard' stuff without too much direction from the user. Secondly, the data is stored internally as a data.table (as opposed to a data.frame). The advantage of this is that data.tables are very, very much faster than data.frames for many operations (check out the data.table package -documentation and webpage for more info). This is obviously a great advantage when working with very large spatial-temporal datasets. +documentation and webpage for more info). This is obviously a great advantage when working with very large spatial-temporal data sets. It should be noted that this advantage was very important compared to the now outdated raster package. The replacement for raster (terra) is faster so this advantage is not as large. @@ -43,3 +44,22 @@ data and perform standard operations, but then data can be converted to a raster functions. However, DGVMTools is intended to be a reasonably complete analysis environment in itself. It should be possible to go from model output all the way to results and publication quality plots using only DGVMTools and some base R functionality for other tasks. } +\seealso{ +Useful links: +\itemize{ + \item \url{https://www.bik-f.de} + \item Report bugs at \url{https://github.com/MagicForrest/DGVMTools/issues} +} + +} +\author{ +\strong{Maintainer}: Matthew Forrest \email{matthew.forrest@senckenberg.de} + +Authors: +\itemize{ + \item Simon Scheiter \email{simon.scheiter@senckenberg.de} + \item Joerg Steinkamp \email{joerg.steinkamp@senckenberg.de} + \item Glenn Moncrieff \email{glenn@saeon.ac.za} +} + +} diff --git a/man/FPCMegaBiomeRules.Rd b/man/FPCMegaBiomeRules.Rd index b050590..bf74a15 100644 --- a/man/FPCMegaBiomeRules.Rd +++ b/man/FPCMegaBiomeRules.Rd @@ -7,7 +7,7 @@ FPCMegaBiomeRules(x) } \arguments{ -\item{fpc}{Vector of FPC values} +\item{x}{Vector of FPC values} } \description{ lalala diff --git a/man/Period-class.Rd b/man/Period-class.Rd index 13671c4..6ca9c1f 100644 --- a/man/Period-class.Rd +++ b/man/Period-class.Rd @@ -37,10 +37,10 @@ A simple S4 class to define a month, a season or a year used for aggregating mon \details{ Since these are for the most part standard (ie. people commonly need the months, the seasons (DJF, MAM, JJA, SON) and annual) these are defined in simple list that might be commonly used and can be looped through. These are: \describe{ - \item{\code{months}}{which contains all the months.} - \item{\code{seasons}}{which contains all the seasons.} - \item{\code{annual}}{which only contains only the annual period.} - \item{\code{all.periods, periods}}{which contains all of the above.} + \item{all.months}{which contains all the months.} + \item{all.seasons}{which contains all the seasons.} + \item{annual}{which only contains only the annual period.} + \item{all.periods}{which contains all of the above.} } However other periods can be defined for specific growing seasons etc. diff --git a/man/Scheme-class.Rd b/man/Scheme-class.Rd index 77491b5..2d33045 100644 --- a/man/Scheme-class.Rd +++ b/man/Scheme-class.Rd @@ -25,7 +25,7 @@ It describes what how the model output (in the form of a data.table) must be pre \item{\code{layers.needed}}{List of vegetation layers needed to perform the classification and the name of the new layer, to be interpreted by \code{\link{layerOp}}, specified as a list of three- or four-item list whose elements first element id the id of a \code{\linkS4class{Quantity}} and whose other elements are passed as arguments to the \code{\link{layerOp}} function. -For example one element could be \code{Woody = list(quantity = "LAI_std", operator = "+", layers = c(".Tree", ".Shrubs"), new.layer = "Woody")}, +For example one element could be \code{Woody = list(quantity = "LAI_std", operator = "\+", layers = c(".Tree", ".Shrubs"), new.layer = "Woody")}, which would make a layer called "Woody" which would be the sum of all LAI trees and shrubs.} \item{\code{data.reference}}{Character string giving a reference where the data for this classification scheme comes from} diff --git a/man/calcNewField.Rd b/man/calcNewField.Rd index 8edd7a8..77b4ce5 100644 --- a/man/calcNewField.Rd +++ b/man/calcNewField.Rd @@ -19,7 +19,7 @@ calcNewField( \item{y}{The second \code{\linkS4class{Field}}} -\item{op}{which arithmetic should be performed: addition ('+'), substraction ('-'), multiplication ('*') or division ('/').} +\item{op}{which arithmetic should be performed: addition ('+'), subtraction ('-'), multiplication ('*') or division ('/').} \item{x.col}{the column of the first Field. If empty or NULL all columns are used.} diff --git a/man/commonSTAInfo.Rd b/man/commonSTAInfo.Rd index 6e94b3d..a454880 100644 --- a/man/commonSTAInfo.Rd +++ b/man/commonSTAInfo.Rd @@ -7,7 +7,7 @@ commonSTAInfo(sta.objects, logical = FALSE) } \arguments{ -\item{sta.objects}{A list of Field and/or STAInfo objects which should be compared to dermine the common STAInfo} +\item{sta.objects}{A list of Field and/or STAInfo objects which should be compared to determine the common STAInfo} \item{logical}{Logical, if TRUE return a simple TRUE/FALSE rather than an STAInfo object of common info.} } diff --git a/man/getDailyField_aDGVM.Rd b/man/getDailyField_aDGVM.Rd index a38dcc7..c354daf 100644 --- a/man/getDailyField_aDGVM.Rd +++ b/man/getDailyField_aDGVM.Rd @@ -30,10 +30,6 @@ This can be left blank, in which case the file name is automatically generated.} \item{verbose}{A logical, set to true to give progress/debug information} \item{data.table.only}{A logical, if TRUE return a data.table and not a Field} - -\item{first.year}{The first year (as a numeric) of the data to be return} - -\item{last.year}{The last year (as a numeric) of the data to be return} } \value{ a data.table (with the correct tear offset and lon-lat offsets applied) diff --git a/man/getField.Rd b/man/getField.Rd index 932b05d..9e5a659 100644 --- a/man/getField.Rd +++ b/man/getField.Rd @@ -28,7 +28,7 @@ getField( \arguments{ \item{source}{The \code{\linkS4class{Source}} object for which the \code{\linkS4class{Field}} should be built, typically a model run or a dataset.} -\item{quant}{The \\code{\linkS4class{Quantity}} to be read - either a \code{\linkS4class{Quantity}} object or a string containing its \code{id}. If it is a character string it will be checked +\item{quant}{The \code{\linkS4class{Quantity}} to be read - either a \code{\linkS4class{Quantity}} object or a string containing its \code{id}. If it is a character string it will be checked against the predefined \code{Quantities} in the \code{\linkS4class{Source}} object and failing that a simple dummy \code{\linkS4class{Quantity}} will be be made. For the \code{NetCDF Format} most \code{\linkS4class{Quantity}} metadata will be taken from the NetCDF file where possible (thus overriding this option).} diff --git a/man/getField_NetCDF.Rd b/man/getField_NetCDF.Rd index ef799e1..36995a8 100644 --- a/man/getField_NetCDF.Rd +++ b/man/getField_NetCDF.Rd @@ -24,6 +24,8 @@ getField_NetCDF( \item{layers}{A character string (or a vector of character strings) specifying which variables from the NetCDF file are to be read. NULL (default) means read all.} +\item{target.STAInfo}{An STAInfo object defining the spatial-temporal-annual extent over which we want the data} + \item{file.name}{Character string holding the name of the file. This can be left blank, in which case the file name is automatically generated} \item{verbose}{A logical, set to true to give progress/debug information} @@ -37,8 +39,6 @@ so it is handy to control that separately.} \item{calendar}{Character string, sometimes the calendar string on the time axis can be incorrect or missing. Here you can manually provide it. Note: A common error in paleo files is "standard" instead of "proleptic_gregorian". Specifically, if you have dates with years 1582 (the start of the Gregorian calendar) and it includes leap years the calendar needs to be set to "proleptic_gregorian".} - -\item{target.sta.info}{An STAInfo object defining the spatial-temporal-annual extent over which we want the data} } \value{ A list containing firstly the data.table containing the data, and secondly the STAInfo for the data that we have diff --git a/man/getStandardQuantity_LPJ.Rd b/man/getStandardQuantity_LPJ.Rd index 653a9ef..6c41c7f 100644 --- a/man/getStandardQuantity_LPJ.Rd +++ b/man/getStandardQuantity_LPJ.Rd @@ -22,10 +22,6 @@ getStandardQuantity_LPJ( ".out" (also ".out.gz")} \item{verbose}{A logical, set to true to give progress/debug information} - -\item{first.year}{The first year (as a numeric) of the data to be return} - -\item{last.year}{The last year (as a numeric) of the data to be return} } \value{ a data.table (with the correct tear offset and lon-lat offsets applied) diff --git a/man/getStandardQuantity_aDGVM.Rd b/man/getStandardQuantity_aDGVM.Rd index c2611f0..9d7b869 100644 --- a/man/getStandardQuantity_aDGVM.Rd +++ b/man/getStandardQuantity_aDGVM.Rd @@ -23,10 +23,6 @@ getStandardQuantity_aDGVM( This can be left blank, in which case the file name is automatically generated.} \item{verbose}{A logical, set to true to give progress/debug information} - -\item{first.year}{The first year (as a numeric) of the data to be return} - -\item{last.year}{The last year (as a numeric) of the data to be return} } \value{ a data.table (with the correct tear offset and lon-lat offsets applied) diff --git a/man/getYearlyField_aDGVM.Rd b/man/getYearlyField_aDGVM.Rd index 747fd1e..2b9fb36 100644 --- a/man/getYearlyField_aDGVM.Rd +++ b/man/getYearlyField_aDGVM.Rd @@ -29,10 +29,6 @@ This can be left blank, in which case the file name is automatically generated.} \item{verbose}{A logical, set to true to give progress/debug information} \item{data.table.only}{A logical, if TRUE return a data.table and not a Field} - -\item{first.year}{The first year (as a numeric) of the data to be return} - -\item{last.year}{The last year (as a numeric) of the data to be return} } \value{ a data.table (with the correct tear offset and lon-lat offsets applied) diff --git a/man/layerOp.Rd b/man/layerOp.Rd index c9cb33e..d4392e9 100644 --- a/man/layerOp.Rd +++ b/man/layerOp.Rd @@ -10,18 +10,18 @@ layerOp(x, operator, layers, new.layer, constant = 1) \item{x}{The x object on which we are operating.} \item{operator}{The operator we are applying, can be: -\itemize{ - \item{"+" (or "sum" or "add")} {Add the layers, can apply to any number of layers} - \item{"mean" (or "average")} {Average the layers, can apply to any number of layers} - \item{"*" (or "multiply" or "product")} {Multiply the layers, can apply to any number of layers} - \item{"-" (or "subtract" or "minus")} {Subtract one layer from another. Requires exactly two layers to be specified, subtracts the second from the first, ie. layer1 - layer 2.} - \item{"/" (or "divide" or "through")} {Divide one layer by another. Nore this does 'safe division' which returns zero if the denomination is zero. Requires exactly two layers to be specified, divides the first by the second, ie. layer1 / layer 2.} - \item{"max.layer"} {Gets the layer with the maximum value from the input layers (is a layer of factors). If they are all zero at a point then "None" is assigned. In the case of ties, the first layer in the layers arguement will be returned as the max.} - \item{"min.layer"} {Gets the layer with the minimum value from the input layers (is a layer of factors). If they are all zero at a point then "None" is assigned. In the case of ties, the first layer in the layers arguement will be returned as the min.} - \item{"mulc"/"divc"/"addc"/"subc"} {Multiplies, divides, adds or subtracts the layer with a numeric value in the "constant" argument} - \item{\emph{any numeric value}} {Sets each of the layers specified uniformly to the numeric value specified, most usefuly for 0. Previously not existing layers in the layers and new.layer argument will be created.} - \item{\emph{NULL}} {A special case of the above which removes the layers from the Field} - \item{\emph{Whatever function}} {Now we are into crazy territory! You can provide any function (the actual function, not a string ) that operates on a vector of numerics and it might just work! Works for sd, var, min and max, but your mileage may vary.} +\describe{ + \item{"+" (or "sum" or "add")}{Add the layers, can apply to any number of layers} + \item{"mean" (or "average")}{Average the layers, can apply to any number of layers} + \item{"*" (or "multiply" or "product")}{Multiply the layers, can apply to any number of layers} + \item{"-" (or "subtract" or "minus")}{Subtract one layer from another. Requires exactly two layers to be specified, subtracts the second from the first, ie. layer1 - layer 2.} + \item{"/" (or "divide" or "through")}{Divide one layer by another. Nore this does 'safe division' which returns zero if the denomination is zero. Requires exactly two layers to be specified, divides the first by the second, ie. layer1 / layer 2.} + \item{"max.layer"}{Gets the layer with the maximum value from the input layers (is a layer of factors). If they are all zero at a point then "None" is assigned. In the case of ties, the first layer in the layers arguement will be returned as the max.} + \item{"min.layer"}{Gets the layer with the minimum value from the input layers (is a layer of factors). If they are all zero at a point then "None" is assigned. In the case of ties, the first layer in the layers arguement will be returned as the min.} + \item{"mulc"/"divc"/"addc"/"subc"}{Multiplies, divides, adds or subtracts the layer with a numeric value in the "constant" argument} + \item{\emph{any numeric value}}{Sets each of the layers specified uniformly to the numeric value specified, most usefuly for 0. Previously not existing layers in the layers and new.layer argument will be created.} + \item{\emph{NULL}}{A special case of the above which removes the layers from the Field} + \item{\emph{Whatever function}}{Now we are into crazy territory! You can provide any function (the actual function, not a string ) that operates on a vector of numerics and it might just work! Works for sd, var, min and max, but your mileage may vary.} \item{\emph{Something else?}}{Contact the author!} }} diff --git a/man/lm_eqn.Rd b/man/lm_eqn.Rd index 5fdf124..12126fb 100644 --- a/man/lm_eqn.Rd +++ b/man/lm_eqn.Rd @@ -13,7 +13,7 @@ lm_eqn(linear.model) A character string } \description{ -Makes a string (form: y = ax + b, r^2 = r^2) for putting on plots from a linear model (lm) +Makes a string (form: y = ax \+ b, r^2 = r^2) for putting on plots from a linear model (lm) } \details{ Make sure the model is \code{y ~ x} or this function doesn't really make sense diff --git a/man/makeYAxis.Rd b/man/makeYAxis.Rd index 2953741..fe166c9 100644 --- a/man/makeYAxis.Rd +++ b/man/makeYAxis.Rd @@ -4,10 +4,10 @@ \alias{makeYAxis} \title{Make y-axis} \usage{ -makeYAxis(final.fields) +makeYAxis(objects) } \arguments{ -\item{final.fields}{The list of Fields to be plotted (should have been check by santiseFieldsForPlotting first)} +\item{objects}{The list of Fields to be plotted (should have been check by santiseFieldsForPlotting first)} } \value{ Returns the y-axis as a chatacter string, diff --git a/man/openLPJOutputFile_FireMIP.Rd b/man/openLPJOutputFile_FireMIP.Rd index 0c0909b..b752546 100644 --- a/man/openLPJOutputFile_FireMIP.Rd +++ b/man/openLPJOutputFile_FireMIP.Rd @@ -26,10 +26,6 @@ openLPJOutputFile_FireMIP( ".out" (also ".out.gz")} \item{verbose}{A logical, set to true to give progress/debug information} - -\item{first.year}{The first year (as a numeric) of the data to be return} - -\item{last.year}{The last year (as a numeric) of the data to be return} } \value{ a data.table (with the correct tear offset and lon-lat offsets applied) diff --git a/man/plotScatter.Rd b/man/plotScatter.Rd deleted file mode 100644 index 5f15b33..0000000 --- a/man/plotScatter.Rd +++ /dev/null @@ -1,46 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plotScatter.R -\name{plotScatter} -\alias{plotScatter} -\title{Make a scatter plot} -\usage{ -plotScatter( - x, - y = x, - layer.x, - layer.y = layer.x, - alpha = 1, - text.multiplier, - tolerance = NULL -) -} -\arguments{ -\item{x}{The first DGVMTools::Field or Comparison object from which the data to be plotted should be taken.} - -\item{y}{The second DGVMTools::Field or Comparison object from which the data to be plotted should be taken. -Default value is x.} - -\item{layer.x}{The first layer to be plotted (taken from x)} - -\item{layer.y}{The second layer to be plotted (taken from y). Defaults to layer.x.} - -\item{alpha}{Numeric between 0 and 1 specifing the transparency of the points. Default is 1 (= fully opaque).} - -\item{text.multiplier}{A number specifying an overall multiplier for the text on the plot. -Make it bigger if the text is too small on large plots and vice-versa.} - -\item{tolerance}{Numeric, passed to copyLayers. Defines how close the longitudes and latitudes of the gridcells in \code{x} and \code{y} (if different) -need to be to the coordinates in order to get a match. Can be a single numeric (for the same tolerance for both lon and lat) or a vector of two numerics (for lon and lat separately). -Default is no rounding (value is NULL) and so is fine for most regular spaced grids. However, setting this can be useful to force matching of -coordinates with many decimal places which may have lost a small amount of precision and so don't match exactly.} -} -\value{ -A ggplot2 object -} -\description{ -This simple function makes (and returns it as an object, it doesn't print it) a simple scatter plot (using ggplot2). -The data are two layers from either one or two Field objects. Data points which appear in one Field but not the other are excluded -} -\author{ -Matthew Forrest \email{matthew.forrest@senckenberg.de} -} diff --git a/man/plotSpatial.Rd b/man/plotSpatial.Rd index fd24d69..e025fff 100644 --- a/man/plotSpatial.Rd +++ b/man/plotSpatial.Rd @@ -92,7 +92,7 @@ for example, be plotted on polar coordinates. However \code{geom_tile} is much if you are plotting a collection of individual sites which do not have regular spacing. Note the "tile = TRUE" (see above) will automatically set if you haven't done it manually.} \item{...}{Arguments passed to \code{ggplot2::facet_wrap()}. See the ggplot2 documentation for full details but the following are particularly useful. -\itemize{ +\describe{ \item{"nrow"}{The number of rows of facets} \item{"ncol"}{The number of columns of facets} \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) diff --git a/man/plotSpatialComparison.Rd b/man/plotSpatialComparison.Rd index 68f6069..4004001 100644 --- a/man/plotSpatialComparison.Rd +++ b/man/plotSpatialComparison.Rd @@ -13,6 +13,10 @@ plotSpatialComparison( override.cols = NULL, symmetric.scale = TRUE, do.phase = FALSE, + metrics = c(), + metric_size = waiver(), + metric_x_pos = 0.025, + metric_y_pos = 0.975, ... ) } @@ -37,6 +41,14 @@ to facilitate expressions for nicely marked up subscript and superscript.} \item{do.phase}{Logical, only applies to plotting Comparison objects of type "seasonal". If TRUE plot the the seasonal phase, if FALSE (the default), plot the seasonal concentration.} +\item{metrics}{A character vector specifying the metrics to put on the plots. For spatial data these can be: "ME", "NME", "NMSE", "RMSE", "NME_2", "NMSE_2", "NME_3", +"NSME_3", "r2_eff", "r", "r2", "m", "c".} + +\item{metric_size}{A numeric value for the size of the metric text, note that this will be also be scaled by the \code{text.multiplier} argument.} + +\item{metric_x_pos, metric_y_pos}{A number value specifying the x/y location of the metric text as a fraction of the plot area. Note, it uses the +overall range of the plotting for calculating this (not the specific ranges of the axes), so using facets or grids with "free" scales will mess this up.} + \item{...}{Parameters passed to \link{plotSpatial}} } \value{ diff --git a/man/plotSubannual.Rd b/man/plotSubannual.Rd index ae98e8f..75c6cdd 100644 --- a/man/plotSubannual.Rd +++ b/man/plotSubannual.Rd @@ -72,7 +72,7 @@ Make it bigger if the text is too small on large plots and vice-versa.} \item{plot}{Boolean, if FALSE return a data.table with the final data instead of the ggplot object. This can be useful for inspecting the structure of the facetting columns, amongst other things.} \item{...}{Arguments passed to \code{ggplot2::facet_wrap()}. See the ggplot2 documentation for full details but the following are particularly useful. -\itemize{ +\describe{ \item{"nrow"}{The number of rows of facets} \item{"ncol"}{The number of columns of facets} \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) diff --git a/man/plotTemporal.Rd b/man/plotTemporal.Rd index 694b834..45132fa 100644 --- a/man/plotTemporal.Rd +++ b/man/plotTemporal.Rd @@ -82,7 +82,7 @@ Good for plotting time series with missing data where geom_lines joins lines ove \item{plot}{Logical, if FALSE return the data.table of data instead of the plot} \item{...}{Arguments passed to \code{ggplot2::facet_wrap()} and \code{ggplot2::stat_smooth()}. See the ggplot2 documentation for full details but the following are particularly useful. -\itemize{ +\describe{ \item{"nrow"}{The number of rows of facets. (facet_wrap)} \item{"ncol"}{The number of columns of facets. (facet_wrap)} \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) diff --git a/man/plotXYComparison.Rd b/man/plotXYComparison.Rd new file mode 100644 index 0000000..56fddf7 --- /dev/null +++ b/man/plotXYComparison.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plotXYComparison.R +\name{plotXYComparison} +\alias{plotXYComparison} +\title{Plot a scatter comparison between two layers} +\usage{ +plotXYComparison( + comparisons, + type = c("points", "hex", "bin2d"), + fit_line_col = NULL, + perfect_line_col = NULL, + matchLimits = TRUE, + metrics = c(), + metric_size = waiver(), + metric_x_pos = 0.025, + metric_y_pos = 0.975, + text.multiplier = NULL, + col.by = NULL, + ... +) +} +\arguments{ +\item{comparisons}{The data to plot, must be a Comparison or a list of Comparisons} + +\item{type}{A character specifying what type of plot to make. Can be "points" (default, for geom_points), "hex" (for hex binning), "bin2d" (for square binning). +There might be more useful options to add later.} + +\item{fit_line_col}{A colour for the fit line through the data (default is NULL meaning no fit line).} + +\item{perfect_line_col}{A colour for the perfect one-to-one line (default is NULL meaning no one-to-one line).} + +\item{matchLimits}{Logical, determins if the X and X axes should have the same range. Default is TRUE. +(only works for \code{type = "points"}). Can meaningfully take the values of spatiotemporal dimensions which are in the dataset +such as "Day", "Month", "Season", "Year", "Lon" and "Lat". +By default \code{col.by} is set to NULL, which doesn't distinguish the points by colour.} + +\item{metrics}{A character vector specifying the metrics to put on the plots. For spatial data these can be: "ME", "NME", "NMSE", "RMSE", "NME_2", "NMSE_2", "NME_3", +"NSME_3", "r2_eff", "r", "r2", "m", "c".} + +\item{metric_size}{A numeric value for the size of the metric text, note that this will be also be scaled by the \code{text.multiplier} argument.} + +\item{metric_x_pos, metric_y_pos}{A number value specifying the x/y location of the metric text as a fraction of the plot area. Note, it uses the +overall range of the plotting for calculating this (not the specific ranges of the axes), so using facets or grids with "free" scales will mess this up.} + +\item{text.multiplier}{A number specifying an overall multiplier for the text on the plot. +Make it bigger if the text is too small on large plots and vice-versa.} + +\item{col.by}{Character strings defining the aspects of the data which which should be used to set the colour of the points} + +\item{...}{Arguments passed to \code{ggplot2::facet_wrap()}. See the ggplot2 documentation for full details but the following are particularly useful. +\describe{ + \item{"nrow"}{The number of rows of facets} + \item{"ncol"}{The number of columns of facets} + \item{"scales"}{Whether the scales (ie. x and y ranges) should be fixed for all facets. Options are "fixed" (same scales on all facets, default) + "free" (all facets can their x and y ranges), "free_x" and "free_y" (only x and y ranges can vary, respectively).} + \item{"labeller"}{A function to define the labels for the facets. This is a little tricky, please look to the ggplot2 documentation. + But basically what you want is to define a named character vector, the names are the previous facet names and the values are the new names. + Then make this into a function by passing it to the ggplot function "as.labeller", and then that becomes your 'labeller' argument.} +}} +} +\value{ +Returns a ggplot object +} +\description{ +This produces X-Y scatter plots from Comparison objects (or a list of those Comparisons). These plots can be rendered with points or point densities + with square binsor hexagonal bins. +} +\details{ +A wrapper for around \link{plotSpatial} to plot the spatial Comparisons as maps. Extra arguments to \link{plotSpatial} can also be specified. +} +\seealso{ +\link{plotSpatial}, \link{compareLayers} +} +\author{ +Matthew Forrest \email{matthew.forrest@senckenberg.de} +} diff --git a/man/trimFieldsForPlottingXY.Rd b/man/trimFieldsForPlottingXY.Rd new file mode 100644 index 0000000..b1e1ade --- /dev/null +++ b/man/trimFieldsForPlottingXY.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plotting-framework-functions.R +\name{trimFieldsForPlottingXY} +\alias{trimFieldsForPlottingXY} +\title{Subsets data from Field for XY plotting} +\usage{ +trimFieldsForPlottingXY( + fields, + layers, + years = NULL, + days = NULL, + months = NULL, + seasons = NULL, + gridcells = NULL, + dropEmpty = FALSE +) +} +\arguments{ +\item{fields}{The list of Fields to be plotted (should have been check by santiseFieldsForPlotting first)} + +\item{layers}{A character vector of the layers to be plotted} + +\item{years}{The years to be extracted (as a numeric vector), if NULL all years are used} + +\item{days}{The days to be extracted (as a numeric vector), if NULL all days are used} + +\item{months}{The months to be extracted (as a numeric vector), if NULL all months are used} + +\item{seasons}{The months to be extracted (as a character vector), if NULL all seasons are used} + +\item{gridcells}{The months to be extracted (as a character vector), if NULL all seasons are used} + +\item{dropEmpty}{Logical, if TRUE drop layers consisting only of zeros} +} +\value{ +Returns a list of Fields +} +\description{ +This is an internal helper function which pulls out the data needed to make a plot from a bunch of Fields, and returns +a list of the Field with only the required layers and points in space and time included +} +\author{ +Matthew Forrest \email{matthew.forrest@senckenberg.de} +} +\keyword{internal} diff --git a/man/writeNetCDF-methods.Rd b/man/writeNetCDF-methods.Rd index a4088ef..f854013 100644 --- a/man/writeNetCDF-methods.Rd +++ b/man/writeNetCDF-methods.Rd @@ -175,15 +175,15 @@ separately to the DGVMTools output.} automatically when writing a Field. But can be added manually for a raster if you wish.} \item{...}{Other arguments that can usefully be passed to ncdf4::ncvar_def, in particular: -\itemize{ - \item{compression} {Integer to define compression level when define netCDF variables (1 = a little compression, 9 = a lot of compression). +\describe{ + \item{compression}{Integer to define compression level when define netCDF variables (1 = a little compression, 9 = a lot of compression). Set to NA (default) for no compression. Using compression forces netCDF version 4.} - \item{missval} {Numeric, for the missing value. Default is NA which gives NaN as the missing value. NULL can be used to specify "no missing value" + \item{missval}{Numeric, for the missing value. Default is NA which gives NaN as the missing value. NULL can be used to specify "no missing value" although it is not clear what that does in the resultant netcdf file in practice. TRENDY/GCP likes -99999.0 for missing values.} - \item{prec} {Character, the output precision (although that is confusing terminology, 'type' would be more descriptive) to use in the netCDF file. + \item{prec}{Character, the output precision (although that is confusing terminology, 'type' would be more descriptive) to use in the netCDF file. See the 'prec' argument of ncdf4::ncvar_def, can be 'short', 'integer', 'float', 'double', 'char', 'byte'). Default is 'float'.} - \item{shuffle} {Logical, if TRUE turn on the shuffle filter see netCDF docs and ncdf4::ncvar_def for details} - \item{chunksize} {If set, this must be a vector of integers with a length equal to the number of dimensions in the variable. Potentially very useful + \item{shuffle}{Logical, if TRUE turn on the shuffle filter see netCDF docs and ncdf4::ncvar_def for details} + \item{chunksize}{If set, this must be a vector of integers with a length equal to the number of dimensions in the variable. Potentially very useful to optimise the read and write time, but rather advanced, see netCDF docs and ncdf4::ncvar_def for details} } From 41aff5fb4d8edcf41c43a6bb998e4fe5d390706d Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Thu, 6 Feb 2025 14:08:37 +0000 Subject: [PATCH 12/20] Area weighting for seasonal and proportional comparisons, and linear regression for m and c. --- R/benchmarking.R | 134 +++++++++++++++++++++++++++++----------------- R/compareLayers.R | 2 +- 2 files changed, 86 insertions(+), 50 deletions(-) diff --git a/R/benchmarking.R b/R/benchmarking.R index c82683b..84b6607 100644 --- a/R/benchmarking.R +++ b/R/benchmarking.R @@ -28,18 +28,18 @@ lm_eqn <- function(linear.model) { #' #' @param obs A numeric vector of observed values #' @param mod A numeric vector of modelled values (same size as obs) -#' @param area A numeric vector of the areas by which to weight the values (same size as obs) +#' @param weights A numeric vector of weights the values, typically the gridcell areas (same size as obs) #' #' @details No check currently done on vector lengths #' #' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} #' @keywords internal #' @return A numeric -calcNME <- function(mod, obs, area) { +calcNME <- function(mod, obs, weights) { - if(missing(area) || is.null(area)) return( sum(abs(mod - obs), na.rm=TRUE) / sum(abs(obs - mean(obs)), na.rm=TRUE)) + if(missing(weights) || is.null(weights)) return( sum(abs(mod - obs), na.rm=TRUE) / sum(abs(obs - mean(obs)), na.rm=TRUE)) else { - return( sum(abs(mod - obs) * area, na.rm=TRUE) / sum(abs(obs - mean(obs)) * area, na.rm=TRUE) ) + return( sum(abs(mod - obs) * weights, na.rm=TRUE) / sum(abs(obs - mean(obs)) * weights, na.rm=TRUE) ) } } @@ -50,17 +50,17 @@ calcNME <- function(mod, obs, area) { #' #' @param mod A numeric vector of observed values #' @param obs A numeric vector of modelled values (same size as mod) -#' @param area A numeric vector of the areas by which to weight the values (same size as obs) +#' @param weights A numeric vector of weights the values, typically the gridcell areas (same size as obs) #' #' @details No check currently done on vector lengths #' #' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} #' @keywords internal #' @return A numeric -calcNMSE <- function(mod, obs, area) { +calcNMSE <- function(mod, obs, weights) { - if(missing(area) || is.null(area)) return( sum((mod - obs)^2, na.rm=TRUE) / sum((obs - mean(obs))^2 , na.rm=TRUE) ) - else return( sum((mod - obs)^2 * area, na.rm=TRUE) / sum((obs - mean(obs))^2 * area, na.rm=TRUE)) + if(missing(weights) || is.null(weights)) return( sum((mod - obs)^2, na.rm=TRUE) / sum((obs - mean(obs))^2 , na.rm=TRUE) ) + else return( sum((mod - obs)^2 * weights, na.rm=TRUE) / sum((obs - mean(obs))^2 * weights, na.rm=TRUE)) } @@ -93,16 +93,16 @@ continuousComparison <- function(x, layers1, layers2, additional, verbose = TRUE x.dims <- getDimInfo(x) if(!"Lon" %in% x.dims || !"Lat" %in% x.dims) { - warning("Comparison stats will not be weighted because Lon/Lat not present") - area.vec <- NULL + warning("Comparison stats will not be area weighted because Lon/Lat not present") + area_vec <- NULL } else { x <- addArea(x, unit = "km^2", tolerance = tolerance) - area.vec <- x[["Area"]] + area_vec <- x[["Area"]] } } - else area.vec <- NULL + else area_vec <- NULL ### STANDARD PACKAGE BENCHMARKS WHICH CAN RUN SIMPLY ON TWO VECTORS @@ -122,44 +122,43 @@ continuousComparison <- function(x, layers1, layers2, additional, verbose = TRUE #### KELLEY ET AL 2013 METRICS # Unnormalised metrics: ME, MSE and RSME - if(is.null(area.vec)) { + if(is.null(area_vec)) { ME <- mean(abs(vector1 - vector2)) MSE <- mean((vector1 - vector2)^2, na.rm=TRUE) } else { - ME <- sum(abs(vector1 - vector2) * area.vec, na.rm=TRUE) / sum(area.vec) - MSE <- sum((vector1 - vector2)^2 * area.vec, na.rm=TRUE) / sum(area.vec) + ME <- sum(abs(vector1 - vector2) * area_vec, na.rm=TRUE) / sum(area_vec) + MSE <- sum((vector1 - vector2)^2 * area_vec, na.rm=TRUE) / sum(area_vec) } RMSE <- MSE^0.5 # Normalised metrics: NME and NMSE (step 1) - NME <- calcNME(mod = vector1, obs = vector2, area = area.vec) - NMSE <- calcNMSE(mod = vector1, obs = vector2, area = area.vec) + NME <- calcNME(mod = vector1, obs = vector2, weights = area_vec) + NMSE <- calcNMSE(mod = vector1, obs = vector2, weights = area_vec) # and step 2 for NME and NMSE vector1_step2 <- vector1 - mean(vector1) vector2_step2 <- vector2 - mean(vector2) - NME_2 <- calcNME(mod = vector1_step2, obs = vector2_step2, area = area.vec) - NMSE_2 <- calcNMSE(mod = vector1_step2, obs = vector2_step2, area = area.vec) + NME_2 <- calcNME(mod = vector1_step2, obs = vector2_step2, weights = area_vec) + NMSE_2 <- calcNMSE(mod = vector1_step2, obs = vector2_step2, weights = area_vec) # and step 3 for NME and NMSE vector1_step3_NME <- vector1_step2 / sum(abs(vector1_step2 - mean(vector1_step2)))/ length(vector1_step2) vector2_step3_NME <- vector2_step2 / sum(abs(vector2_step2 - mean(vector2_step2)))/ length(vector2_step2) - NME_3 <- calcNME(mod = vector1_step3_NME, obs = vector2_step3_NME, area = area.vec) + NME_3 <- calcNME(mod = vector1_step3_NME, obs = vector2_step3_NME, weights = area_vec) vector1_step3_NMSE <- vector1_step2 / stats::var(vector1_step2) vector2_step3_NMSE <- vector2_step2 / stats::var(vector2_step2) - NMSE_3 <- calcNMSE(mod = vector1_step3_NMSE, obs = vector2_step3_NMSE, area = area.vec) + NMSE_3 <- calcNMSE(mod = vector1_step3_NMSE, obs = vector2_step3_NMSE, weights = area_vec) #### MORE 'STANDARD' METRICS MORE BASED ON LINEAR REGRESSION AND NOT FOCUSSED ON MODEL-OBSERVATION COMPARISON - if(!is.null(area.vec)) { - if(verbose) message("NOTE: metrics r, r2, m, and c are NOT weighted by gridcell area, the other metrics are.") - warning("NOTE: metrics r, r2, m, and c are NOT weighted by gridcell area, the other metrics are.") - + if(verbose) message("NOTE: metrics r and r2 are NOT weighted by gridcell area, the other metrics are.") + warning("NOTE: metrics r and r2 are NOT weighted by gridcell area, the other metrics are.") } + # r2_eff - Nash-Sutcliffe model efficiency (actually is focussed on model-obs Comparisons) r2_eff <- 1 - NMSE @@ -169,7 +168,12 @@ continuousComparison <- function(x, layers1, layers2, additional, verbose = TRUE r2 <- r^2 # calculate a simple linear regression - simple.regression <- stats::lm(formula = mod ~ obs, data = data.frame("mod" = vector1, "obs" = vector2)) + if(is.null(area_vec)) { + simple.regression <- stats::lm(formula = mod ~ obs, data = data.frame("mod" = vector1, "obs" = vector2)) + } + else{ + simple.regression <- stats::lm(formula = mod ~ obs, data = data.frame("mod" = vector1, "obs" = vector2, "wghts" = area_vec), weights = wghts) + } c <- stats::coef(simple.regression)[1] m <- stats::coef(simple.regression)[2] @@ -259,12 +263,25 @@ continuousComparison <- function(x, layers1, layers2, additional, verbose = TRUE #' @keywords internal #' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} #' @export -proportionsComparison <- function(x, layers1, layers2, additional, verbose = TRUE, area = TRUE){ +proportionsComparison <- function(x, layers1, layers2, additional, verbose = TRUE, area = TRUE, tolerance = 0.01){ + + # add the area if selected if(area) { - if(verbose) message("Gridcell area weighting not currently implemented for proportionsComparison") - warning("Gridcell area weighting not currently implemented for proportionsComparison") + + x.dims <- getDimInfo(x) + + if(!"Lon" %in% x.dims || !"Lat" %in% x.dims) { + warning("Comparison stats will not be area weighted because Lon/Lat not present") + area_vec <- NULL + } + else { + x <- addArea(x, unit = "km^2", tolerance = tolerance) + area_vec <- x[["Area"]] + } + } + else area_vec <- NULL # check the layers are present if(!sum(layers1 %in% names(x)) == length(layers1)) stop("Some of argument layers1 are not a column in x") @@ -292,20 +309,23 @@ proportionsComparison <- function(x, layers1, layers2, additional, verbose = TRU SCD <- 0 for(layer.index in 1:ncol(dt1)){ - # for Manhattan Metric difference.vector <- abs(dt1[[layer.index]] - dt2[[layer.index]]) - MM <- MM + sum(difference.vector) + if(is.null(area_vec)) MM <- MM + sum(difference.vector) + else MM <- MM + sum(difference.vector * area_vec) # for Square Chord Distance - difference.vector <- ((dt1[[layer.index]])^0.5 - (dt2[[layer.index]])^0.5)^2 - SCD <- SCD + sum(difference.vector) + if(is.null(area_vec)) difference.vector <- ((dt1[[layer.index]])^0.5 - (dt2[[layer.index]])^0.5)^2 + else SCD <- SCD + sum(difference.vector * area_vec) } - - MM <- MM/nrow(dt1) - SCD <- SCD/nrow(dt1) - + if(is.null(area_vec)) { + MM <- MM/nrow(dt1) + SCD <- SCD/nrow(dt1) + } else { + MM <- MM/(nrow(dt1) * area_vec * ncol(dt1)) # check if we really need the ncol(dt1) here + SCD <- SCD/(nrow(dt1) * area_vec * ncol(dt1)) # check if we really need the ncol(dt1) here + } stats <- list("MM" = MM, "SCD" = SCD @@ -371,7 +391,7 @@ proportionsComparison <- function(x, layers1, layers2, additional, verbose = TRU #' @keywords internal #' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} #' @export -categoricalComparison<- function(x, layers1, layers2, additional, verbose = TRUE, area = TRUE){ +categoricalComparison<- function(x, layers1, layers2, additional, verbose = TRUE, area = TRUE, tolerance = 0.01){ if(area) { if(verbose) message("Gridcell area weighting not currently implemented for categoricalComparison") @@ -534,12 +554,25 @@ categoricalComparison<- function(x, layers1, layers2, additional, verbose = TRUE #' @keywords internal #' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} #' @export -seasonalComparison <- function(x, layers1, layers2, additional, verbose = TRUE, area = TRUE){ +seasonalComparison <- function(x, layers1, layers2, additional, verbose = TRUE, area = TRUE, tolerance = 0.01){ + + # add the area if selected if(area) { - if(verbose) message("Gridcell area weighting not currently implemented for seasonalComparison") - warning("Gridcell area weighting not currently implemented for seasonalComparison") + + x.dims <- getDimInfo(x) + + if(!"Lon" %in% x.dims || !"Lat" %in% x.dims) { + warning("Comparison stats will not be area weighted because Lon/Lat not present") + area_vec <- NULL + } + else { + x <- addArea(x, unit = "km^2", tolerance = tolerance) + area_vec <- x[["Area"]] + } + } + else area_vec <- NULL C_1 = C_2 = L_x_1 = L_x_2 = L_y_1 = L_y_2 = Lat = Lon = Month = P_1 = P_2 = Sigma_x_1 = Sigma_x_2 = Theta_t = NULL @@ -590,23 +623,23 @@ seasonalComparison <- function(x, layers1, layers2, additional, verbose = TRUE, vector2 <- vector2[!is.na(vector2)] # Normalised metrics: NME and NMSE (step 1) - NME <- calcNME(mod = vector1, obs = vector2) - NMSE <- calcNMSE(mod = vector1, obs = vector2) + NME <- calcNME(mod = vector1, obs = vector2, weights = area_vec) + NMSE <- calcNMSE(mod = vector1, obs = vector2, weights = area_vec) # and step 2 for NME and NMSE vector1_step2 <- vector1 - mean(vector1) vector2_step2 <- vector2 - mean(vector2) - NME_2 <- calcNME(mod = vector1_step2, obs = vector2_step2) - NMSE_2 <- calcNMSE(mod = vector1_step2, obs = vector2_step2) + NME_2 <- calcNME(mod = vector1_step2, obs = vector2_step2, weights = area_vec) + NMSE_2 <- calcNMSE(mod = vector1_step2, obs = vector2_step2, weights = area_vec) # and step 3 for NME and NMSE vector1_step3_NME <- vector1_step2 / sum(abs(vector1_step2 - mean(vector1_step2)))/ length(vector1_step2) vector2_step3_NME <- vector2_step2 / sum(abs(vector2_step2 - mean(vector2_step2)))/ length(vector2_step2) - NME_3 <- calcNME(mod = vector1_step3_NME, obs = vector2_step3_NME) + NME_3 <- calcNME(mod = vector1_step3_NME, obs = vector2_step3_NME, weights = area_vec) vector1_step3_NMSE <- vector1_step2 / stats::var(vector1_step2) vector2_step3_NMSE <- vector2_step2 / stats::var(vector2_step2) - NMSE_3 <- calcNMSE(mod = vector1_step3_NMSE, obs = vector2_step3_NMSE) + NMSE_3 <- calcNMSE(mod = vector1_step3_NMSE, obs = vector2_step3_NMSE, weights = area_vec) #### PHASE # Preamble - extract vectors and remove NAs from both vectors @@ -616,12 +649,15 @@ seasonalComparison <- function(x, layers1, layers2, additional, verbose = TRUE, # first remove where there are NAs in phase1 phase2 <- phase2[!is.na(phase1)] phase1 <- phase1[!is.na(phase1)] + area_vec <- area_vec[!is.na(phase1)] # now for phase2 phase1 <- phase1[!is.na(phase2)] phase2 <- phase2[!is.na(phase2)] + area_vec <- area_vec[!is.na(phase2)] - MPD <- (1/pi) * sum(acos (cos(phase1 - phase2))) / length(phase1) - + #### MEAN PHASE DIFFERENCE + if(is.null(area_vec)) MPD <- sum( (1/pi) * acos(cos(phase1 - phase2))) / length(phase1) + else MPD <- sum( (1/pi) * acos(cos(phase1 - phase2)) * area_vec) / sum(area_vec) #### COMPILE STATS stats <- list("NME_conc" = NME, diff --git a/R/compareLayers.R b/R/compareLayers.R index 6a7adf6..b21f089 100644 --- a/R/compareLayers.R +++ b/R/compareLayers.R @@ -26,7 +26,7 @@ #' Default is no rounding (value is NULL) and so is fine for most regular spaced grids. However, setting this can be useful to force matching of #' coordinates with many decimal places which may have lost a small amount of precision and so don't match exactly. #' @param show.stats Logical, if TRUE print the summary statistics -#' @param area Logical, if TRUE (default) weight the comparison metrics by gridcell area (not yet implemented for seasonal, proportions or categorical comparisons) +#' @param area Logical, if TRUE (default) weight the comparison metrics by gridcell area (not yet implemented for categorical comparisons) #' @param custom.metrics A named list of functions (defined by the user) to calculate additional custom metrics. The functions must take a data.table and #' two character vectors of layer names to be compared (in order in the case of multi-layer comparisons). Spatial-temporal-annual column names of Lon, Lat, Year, Month and Day #' can be assumed in the data.table. The name of the item in the list is used as the metric name. From 558a77c6db7b987416c53e3354fc38c7c5ba52ef Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Thu, 6 Feb 2025 15:14:19 +0000 Subject: [PATCH 13/20] Added "user.processing.applied" slot to STAInfo This will be entirely user controlled. Also minor bugfixs - lingering area.vec printing of objects of Period class. --- R/benchmarking.R | 2 +- R/classes.R | 6 ++++-- R/periods.R | 2 +- R/show-methods.R | 8 ++++---- 4 files changed, 10 insertions(+), 8 deletions(-) diff --git a/R/benchmarking.R b/R/benchmarking.R index 84b6607..09af8d2 100644 --- a/R/benchmarking.R +++ b/R/benchmarking.R @@ -153,7 +153,7 @@ continuousComparison <- function(x, layers1, layers2, additional, verbose = TRUE #### MORE 'STANDARD' METRICS MORE BASED ON LINEAR REGRESSION AND NOT FOCUSSED ON MODEL-OBSERVATION COMPARISON - if(!is.null(area.vec)) { + if(!is.null(area_vec)) { if(verbose) message("NOTE: metrics r and r2 are NOT weighted by gridcell area, the other metrics are.") warning("NOTE: metrics r and r2 are NOT weighted by gridcell area, the other metrics are.") } diff --git a/R/classes.R b/R/classes.R index 8f83d32..c22e15e 100644 --- a/R/classes.R +++ b/R/classes.R @@ -114,7 +114,8 @@ setClass("STAInfo", spatial.aggregate.method = "character", subannual.resolution = "character", subannual.aggregate.method = "character", - subannual.original = "character" + subannual.original = "character", + user.processing.applied = "character" ), prototype = list(first.year = numeric(0), last.year = numeric(0), @@ -124,7 +125,8 @@ setClass("STAInfo", spatial.aggregate.method = "none", subannual.resolution = character(0), subannual.aggregate.method = "none", - subannual.original = character(0) + subannual.original = character(0), + user.processing.applied = character(0) ) ) diff --git a/R/periods.R b/R/periods.R index 82b074e..a40cd12 100644 --- a/R/periods.R +++ b/R/periods.R @@ -167,7 +167,7 @@ all.periods <- list(Jan = new("Period", name = "Annual", abbreviation = "Ann", index = seq(1,12,1), - padded.index = "Annual", + padded.index = c("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12"), contains = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug","Sep", "Oct", "Nov", "Dec"), days = 365, days.leap = 366, diff --git a/R/show-methods.R b/R/show-methods.R index 3fbcbb6..996885a 100644 --- a/R/show-methods.R +++ b/R/show-methods.R @@ -60,9 +60,9 @@ setMethod("show", signature(object="Period"), function(object) { cat(paste0("id = ", "\"", object@id, "\"", "\n")) cat(paste0("name = ", "\"", object@name, "\"", "\n")) cat(paste0("abbreviation = ", "\"", object@abbreviation, "\"", "\n")) - cat(paste0("index = ", object@index, "\n")) - cat(paste0("padded.index = ", "\"", object@padded.index, "\"", "\n")) - cat(paste0("contains = ", object@contains, "\n")) + cat(paste0("index = ", paste(object@index, collapse = ","), "\n")) + cat(paste0("padded.index = ", "\"", paste(object@padded.index, collapse = "\",\""), "\"", "\n")) + cat(paste0("contains = ", "\"",paste(object@contains, collapse = "\",\""), "\"", "\n")) cat(paste0("days = ", object@days, "\n")) cat(paste0("days.leap = ", object@days.leap, "\n")) @@ -118,7 +118,7 @@ setMethod("show", signature(object="STAInfo"), function(object) { cat(paste0("\t\tSubannual original = ", object@subannual.original, "\n")) cat(paste0("\t\tSubannual aggregation = ", object@subannual.aggregate.method, "\n")) cat(paste0("\t\tSubannual resolution = ", object@subannual.resolution, "\n")) - + cat(paste0("\t\tUser processing applied = ", object@user.processing.applied, "\n")) }) From c8f030ca2f957f10dfb0a698b5999b0a497e4dc7 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Thu, 6 Feb 2025 16:08:42 +0000 Subject: [PATCH 14/20] Changed @user.processing.applied to @custom.processing. Also some updated Rd files. --- R/benchmarking.R | 2 ++ R/checkSTAMatches.R | 7 +++++++ R/classes.R | 12 ++++++++---- R/show-methods.R | 2 +- man/Field-class.Rd | 4 ++++ man/STAInfo-class.Rd | 7 +++++-- man/calcNME.Rd | 4 ++-- man/calcNMSE.Rd | 4 ++-- man/categoricalComparison.Rd | 3 ++- man/compareLayers.Rd | 2 +- man/proportionsComparison.Rd | 3 ++- man/seasonalComparison.Rd | 3 ++- 12 files changed, 38 insertions(+), 15 deletions(-) diff --git a/R/benchmarking.R b/R/benchmarking.R index 09af8d2..68555d1 100644 --- a/R/benchmarking.R +++ b/R/benchmarking.R @@ -83,6 +83,8 @@ calcNMSE <- function(mod, obs, weights) { #' @export continuousComparison <- function(x, layers1, layers2, additional, verbose = TRUE, area = TRUE, tolerance = 0.01){ + wghts <- NULL + # check the layers are present if(!layers1 %in% layers(x)) stop("Argument layers1 is not a column in x") if(!layers2 %in% layers(x)) stop("Argument layers2 is not a column in x") diff --git a/R/checkSTAMatches.R b/R/checkSTAMatches.R index 306b3b2..d70def2 100644 --- a/R/checkSTAMatches.R +++ b/R/checkSTAMatches.R @@ -129,6 +129,13 @@ checkSTAMatches <- function(sta.requested, sta.found, verbose) { if(verbose) message("* Subannual matched.") + + # check if file on disk has had no extra processing custom processing + if(length(sta.found@custom.processing) != 0) { + message(paste0("Attention: File on disk has had custome processing (", paste(sta.found@custom.processing, collapse = ","), "so I am not using it and reading the entire raw data again.")) + return(FALSE) + } + return(TRUE) diff --git a/R/classes.R b/R/classes.R index c22e15e..968f086 100644 --- a/R/classes.R +++ b/R/classes.R @@ -91,13 +91,15 @@ setClass("Period", #' @param year.aggregate.method A character specifying how the years have been aggregated, for example "mean", or "sum" or "var". See aggregateYears. #' If no yearly aggregation has been applied it should be NULL. #' @param spatial.extent This can be of any type that can be used but DGVMTools::crop, and stores the current spatial extent. -#' But default (and with no cropping) it is simple teh raster::Extent object of the whole domain. -#' @param spatial.aggregate.method A character method specifying how the spatial extent has been aggregated, for eample "mean" or "sum", +#' But default (and with no cropping) it is simple the raster::Extent object of the whole domain. +#' @param spatial.aggregate.method A character method specifying how the spatial extent has been aggregated, for example "mean" or "sum", #' see aggregateSpatial. If no spatial aggregation has been applied it should be NULL. #' @param subannual.original A character string specifying the original sub-annual resolution of this data, eg. "Year", Month", "Day" #' @param subannual.resolution A character string specifying the current sub-annual resolution of this data, eg. "Year", Month", "Day" #' @param subannual.aggregate.method A character specifying how the subannual periods have been aggregated, for example "mean", "max", "sum" or "var". #' See aggregateSubannual(). If no sub-annual aggregation has been applied it should be NULL. +#' @param custom.processing A character string which may be used by the user to specify other processing that has been applied. +#' Not currently used by the the package, it is rather to give flexibility to users. #' #' @details This is mostly a behind-the-scenes class which bundles together a lot of dimension information in a tidy form. #' @@ -115,7 +117,7 @@ setClass("STAInfo", subannual.resolution = "character", subannual.aggregate.method = "character", subannual.original = "character", - user.processing.applied = "character" + custom.processing = "character" ), prototype = list(first.year = numeric(0), last.year = numeric(0), @@ -126,7 +128,7 @@ setClass("STAInfo", subannual.resolution = character(0), subannual.aggregate.method = "none", subannual.original = character(0), - user.processing.applied = character(0) + custom.processing = character(0) ) ) @@ -438,6 +440,8 @@ setClass("Scheme", #' @slot subannual.aggregate.method Method by which this Field has been subannually aggregated #' @slot subannual.original Original subannual resolution of this field #' @slot source A Source object which contains the metadata about the run which this Field belongs too. +#' @param custom.processing A character string which may be used by the user to specify other processing that has been applied. +#' Not currently used by the the package, it is rather to give flexibility to users. #' @exportClass Field #' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} diff --git a/R/show-methods.R b/R/show-methods.R index 996885a..b8ecdde 100644 --- a/R/show-methods.R +++ b/R/show-methods.R @@ -118,7 +118,7 @@ setMethod("show", signature(object="STAInfo"), function(object) { cat(paste0("\t\tSubannual original = ", object@subannual.original, "\n")) cat(paste0("\t\tSubannual aggregation = ", object@subannual.aggregate.method, "\n")) cat(paste0("\t\tSubannual resolution = ", object@subannual.resolution, "\n")) - cat(paste0("\t\tUser processing applied = ", object@user.processing.applied, "\n")) + cat(paste0("\t\tCustom processing = ", object@custom.processing, "\n")) }) diff --git a/man/Field-class.Rd b/man/Field-class.Rd index e2d7796..fa789ff 100644 --- a/man/Field-class.Rd +++ b/man/Field-class.Rd @@ -4,6 +4,10 @@ \name{Field-class} \alias{Field-class} \title{Field-class contains data} +\arguments{ +\item{custom.processing}{A character string which may be used by the user to specify other processing that has been applied. +Not currently used by the the package, it is rather to give flexibility to users.} +} \description{ Field is a key class of the package as it actually holds the data (most other classes are for metadata). A \code{\linkS4class{Field}} stores the data and metadata for one quantity that comes from a dataset or vegetation model run (including information about the run itself). For example LAI (Leaf Area Index), or evapotranspiration. diff --git a/man/STAInfo-class.Rd b/man/STAInfo-class.Rd index f00a453..dccc9d7 100644 --- a/man/STAInfo-class.Rd +++ b/man/STAInfo-class.Rd @@ -13,9 +13,9 @@ If no yearly aggregation has been applied it should be NULL.} \item{spatial.extent}{This can be of any type that can be used but DGVMTools::crop, and stores the current spatial extent. -But default (and with no cropping) it is simple teh raster::Extent object of the whole domain.} +But default (and with no cropping) it is simple the raster::Extent object of the whole domain.} -\item{spatial.aggregate.method}{A character method specifying how the spatial extent has been aggregated, for eample "mean" or "sum", +\item{spatial.aggregate.method}{A character method specifying how the spatial extent has been aggregated, for example "mean" or "sum", see aggregateSpatial. If no spatial aggregation has been applied it should be NULL.} \item{subannual.original}{A character string specifying the original sub-annual resolution of this data, eg. "Year", Month", "Day"} @@ -24,6 +24,9 @@ see aggregateSpatial. If no spatial aggregation has been applied it should be N \item{subannual.aggregate.method}{A character specifying how the subannual periods have been aggregated, for example "mean", "max", "sum" or "var". See aggregateSubannual(). If no sub-annual aggregation has been applied it should be NULL.} + +\item{custom.processing}{A character string which may be used by the user to specify other processing that has been applied. +Not currently used by the the package, it is rather to give flexibility to users.} } \description{ This class encapsulations all the Spatial (the 'S', longitude and latitude), Temporal (the 'T', monthly, daily etc.) and Annual (the 'A', years included) diff --git a/man/calcNME.Rd b/man/calcNME.Rd index d527a21..102a4b8 100644 --- a/man/calcNME.Rd +++ b/man/calcNME.Rd @@ -4,14 +4,14 @@ \alias{calcNME} \title{Calculate Normalised Mean Error} \usage{ -calcNME(mod, obs, area) +calcNME(mod, obs, weights) } \arguments{ \item{mod}{A numeric vector of modelled values (same size as obs)} \item{obs}{A numeric vector of observed values} -\item{area}{A numeric vector of the areas by which to weight the values (same size as obs)} +\item{weights}{A numeric vector of weights the values, typically the gridcell areas (same size as obs)} } \value{ A numeric diff --git a/man/calcNMSE.Rd b/man/calcNMSE.Rd index 47a9939..29be132 100644 --- a/man/calcNMSE.Rd +++ b/man/calcNMSE.Rd @@ -4,14 +4,14 @@ \alias{calcNMSE} \title{Calculate Normalised Mean Square Error} \usage{ -calcNMSE(mod, obs, area) +calcNMSE(mod, obs, weights) } \arguments{ \item{mod}{A numeric vector of observed values} \item{obs}{A numeric vector of modelled values (same size as mod)} -\item{area}{A numeric vector of the areas by which to weight the values (same size as obs)} +\item{weights}{A numeric vector of weights the values, typically the gridcell areas (same size as obs)} } \value{ A numeric diff --git a/man/categoricalComparison.Rd b/man/categoricalComparison.Rd index 4366435..b600c2f 100644 --- a/man/categoricalComparison.Rd +++ b/man/categoricalComparison.Rd @@ -10,7 +10,8 @@ categoricalComparison( layers2, additional, verbose = TRUE, - area = TRUE + area = TRUE, + tolerance = 0.01 ) } \arguments{ diff --git a/man/compareLayers.Rd b/man/compareLayers.Rd index 51a9f11..30f2d2e 100644 --- a/man/compareLayers.Rd +++ b/man/compareLayers.Rd @@ -48,7 +48,7 @@ that the both have 'no data' (typically grey areas) plotted on both maps.} \item{show.stats}{Logical, if TRUE print the summary statistics} -\item{area}{Logical, if TRUE (default) weight the comparison metrics by gridcell area (not yet implemented for seasonal, proportions or categorical comparisons)} +\item{area}{Logical, if TRUE (default) weight the comparison metrics by gridcell area (not yet implemented for categorical comparisons)} \item{custom.metrics}{A named list of functions (defined by the user) to calculate additional custom metrics. The functions must take a data.table and two character vectors of layer names to be compared (in order in the case of multi-layer comparisons). Spatial-temporal-annual column names of Lon, Lat, Year, Month and Day diff --git a/man/proportionsComparison.Rd b/man/proportionsComparison.Rd index 379af2c..7a35111 100644 --- a/man/proportionsComparison.Rd +++ b/man/proportionsComparison.Rd @@ -10,7 +10,8 @@ proportionsComparison( layers2, additional, verbose = TRUE, - area = TRUE + area = TRUE, + tolerance = 0.01 ) } \arguments{ diff --git a/man/seasonalComparison.Rd b/man/seasonalComparison.Rd index 339dd0a..e2e7af7 100644 --- a/man/seasonalComparison.Rd +++ b/man/seasonalComparison.Rd @@ -10,7 +10,8 @@ seasonalComparison( layers2, additional, verbose = TRUE, - area = TRUE + area = TRUE, + tolerance = 0.01 ) } \arguments{ From 7fb2507939172b03453603ed957de6f60ae905bc Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Fri, 7 Feb 2025 10:14:45 +0000 Subject: [PATCH 15/20] NEWS and README updated --- NEWS.md | 24 +++++++++++++++++++++--- README.md | 4 ++-- 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/NEWS.md b/NEWS.md index 3eef2de..4017faa 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,23 @@ +# DGVMTools v1.2.0 release (2025-02-7) + +This is primarily a feature release (`plotXYComparison()`) with some enhancements and bugfixes. + +## Features + +* Based on popular demand, the new `plotXYComparison()` function produces X-Y plots (scatter plots but also binned/density plots) from `Comparison` objects. +* Agreement metrics can be placed automatically on the plots when using `plotXYComparison()` and `plotSpatialComparison()` + + +## Enhancements + + * Seasonal and proportional comparison metrics and the coefficients (m,c) or a regression line for continuous comparisons can now be area weighted. + * `custom.processing` slot addded to STAInfo so the user can record any additional processing steps if they wish. + +## Bugfixes + + * The LPJ-GUESS PFT IBS have been reclassifed from Temperature to Boreal. + * Ordering of facets and legend entries should now work consistently across plot types (i.e. in the order that the Fields/Comparisons were specified). + # DGVMTools v1.1.0 release (2023-12-15) @@ -16,7 +36,7 @@ The primary purpose of this release is to ditch the dependencies on removed or d * `selectGridcels()` now takes `sf` objects instead of `maps` objects. The `rnaturalearth` package is a good place to get country outlines to use here, it is a great replacement for `maps`. * The `plotSubannual()` function now has arguments `size` and `linewidth` instead of `point.size` and `line.width` respectively. -## Other improvements +## Other improvements * Can now specify lons and lats to function addArea() which is useful for area calculations in sparse grids. ## Bugfixes @@ -26,8 +46,6 @@ The primary purpose of this release is to ditch the dependencies on removed or d - - # DGVMTools v1.0.0 release (2022-02-25) "Version 1.0 release" - no major features, but many refinements and improvements. Some potentially breaking changes, see below. diff --git a/README.md b/README.md index a0917db..81dd356 100644 --- a/README.md +++ b/README.md @@ -52,8 +52,8 @@ If you can't install any version of devtools, you can download the source code a ### News and Releases -Current release is v1.1.0. See [NEWS.md](NEWS.md). -A description paper is currently being prepared for peer-review and eventually release on CRAN is anticipated. +Current release is v1.2.0. See [NEWS.md](NEWS.md). +A description paper is currently being prepared for release as a pre-orint and then potentially a peer-reviewed article. --- From 93a3d8e1abdba3769b807f7baa3e935e0ed3a98a Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Wed, 26 Mar 2025 13:06:44 +0000 Subject: [PATCH 16/20] Bugfixes: initialise custom.processing to "" instead of character(0). And don't print full spatial extent in getField() (causes problems with FLUXNET because spatial.extent is a data.table). --- R/classes.R | 2 +- R/getField.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/classes.R b/R/classes.R index 968f086..045938e 100644 --- a/R/classes.R +++ b/R/classes.R @@ -128,7 +128,7 @@ setClass("STAInfo", subannual.resolution = character(0), subannual.aggregate.method = "none", subannual.original = character(0), - custom.processing = character(0) + custom.processing = "" ) ) diff --git a/R/getField.R b/R/getField.R index 1fecd7e..e0c9673 100644 --- a/R/getField.R +++ b/R/getField.R @@ -305,7 +305,7 @@ getField <- function(source, } else if(is.null(sta.info@spatial.extent)) { - if(verbose) message(paste("No spatial extent specified, using full spatial extent of simulation: Lon = (", actual.sta.info@spatial.extent@xmin, ",", actual.sta.info@spatial.extent@xmax, "), Lat = (" , actual.sta.info@spatial.extent@ymin, ",", actual.sta.info@spatial.extent@ymax, ").", sep = "")) + if(verbose) message(paste("No spatial extent specified, so not cropping and using full spatial extent of simulation of data")) } From 79a115fbd249ca55566e04ce1fd52262aa652686 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Wed, 26 Mar 2025 16:11:19 +0000 Subject: [PATCH 17/20] Added na.rm options for aggregateXXXXX functions. See #97. --- R/aggregateSpatial.R | 10 ++++++---- R/aggregateSubannual.R | 14 ++++++++------ R/aggregateYears.R | 6 ++++-- R/small-utility-functions.R | 4 +++- 4 files changed, 21 insertions(+), 13 deletions(-) diff --git a/R/aggregateSpatial.R b/R/aggregateSpatial.R index fe478c4..e2d77b1 100644 --- a/R/aggregateSpatial.R +++ b/R/aggregateSpatial.R @@ -14,6 +14,7 @@ #' @param x Field (or data.table) to be averaged #' @param method The method with which to spatially aggregate. Can be "weighted.mean", "w.mean", "mean", #' "weighted.sum", "w.sum", "sum", "mode", "median", "max", "min", "sd", "var" and "cv" (= coefficient of variation: sd/mean). +#' @param na.rm Logical, passed to aggregation function to control whether or not to remove NAs before aggregating - i.e. the standard R usage. #' @param verbose If TRUE give some progress update about the averaging. #' @param ... Extra arguments passed to addArea function if a weighted method is being used. Note in particular the lon_centres and lat_centres arguments #' if you are using a regular but sparsely populated grid. @@ -23,6 +24,7 @@ #' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} aggregateSpatial.uncompiled <- function(x, method = "mean", + na.rm = TRUE, verbose = FALSE, ...){ @@ -46,7 +48,7 @@ aggregateSpatial.uncompiled <- function(x, min = min, sd = stats::sd, var = stats::var, - cv = function(x) {stats::sd(x)/mean(x)}) + cv = function(x, na.rm) {stats::sd(x, na.rm)/mean(x, 0, na.rm)}) if(method == "weighted.mean") method = "w.mean" if(method == "weighted.sum") method = "w.sum" @@ -73,7 +75,7 @@ aggregateSpatial.uncompiled <- function(x, } if(verbose) message(paste("Spatially averaging (with area weighting) ...", sep = "")) - output.dt <- input.dt[,lapply(.SD, method.function, w=Area), by=by.dims] + output.dt <- input.dt[,lapply(.SD, method.function, w=Area, na.rm = na.rm), by=by.dims] output.dt[,Area:=NULL] } @@ -94,7 +96,7 @@ aggregateSpatial.uncompiled <- function(x, # check to see if Year is still a column name (it might have been averaged away) input.dt[, (col.names) := lapply(.SD, function(x) x * input.dt[['Area']] ), .SDcols = col.names] - output.dt <- input.dt[, lapply(.SD, method.function), by=by.dims] + output.dt <- input.dt[, lapply(.SD, method.function, na.rm = na.rm), by=by.dims] output.dt[,Area:=NULL] } @@ -103,7 +105,7 @@ aggregateSpatial.uncompiled <- function(x, else { if(verbose) message(paste("Spatially aggregating with function ", method," and no area-weighting ...", sep = "")) - output.dt <- input.dt[,lapply(.SD, method.function), by=by.dims] + output.dt <- input.dt[,lapply(.SD, method.function, na.rm = na.rm), by=by.dims] } diff --git a/R/aggregateSubannual.R b/R/aggregateSubannual.R index c06d82b..8a8599b 100644 --- a/R/aggregateSubannual.R +++ b/R/aggregateSubannual.R @@ -14,6 +14,7 @@ #' For technical reasons these need to be implemented in the package in the code however it should be easy to implement more, please just contact the author! #' @param target A character string defining the subannual period to which the data should be aggregate. Can be "Month", "Season" or "Year" (also "Annual" is valid). #' Default is year. +#' @param na.rm Logical, passed to aggregation function to control whether or not to remove NAs before aggregating - i.e. the standard R usage. #' @param verbose If TRUE give some progress update about the averaging. #' #' Input data can be a Field or data.table with appropriate columns. @@ -25,6 +26,7 @@ aggregateSubannual.uncompiled <- function(x, method = "mean", target = "Year", + na.rm = TRUE, verbose = FALSE){ # Messy solution to stop "notes" about undeclared global variables stemming from data.table syntax @@ -85,7 +87,7 @@ aggregateSubannual.uncompiled <- function(x, min = min, sd = stats::sd, var = stats::var, - cv = function(x) {stats::sd(x)/mean(x)}) + cv = function(x, na.rm) {stats::sd(x, na.rm)/mean(x, 0, na.rm)}) # sort out the input object class @@ -115,7 +117,7 @@ aggregateSubannual.uncompiled <- function(x, # FROM DAILY if("Day" %in% avail.dims) { if(verbose) message("Sub-annual aggregation from daily to annual") - output.dt <- input.dt[,lapply(.SD, method.function), by=by.dims] + output.dt <- input.dt[,lapply(.SD, method.function, na.rm = na.rm), by=by.dims] output.dt[,Day:=NULL] } @@ -126,7 +128,7 @@ aggregateSubannual.uncompiled <- function(x, # if not doing mean, simply apply the required function if(!identical(method.function, mean)){ - output.dt <- input.dt[,lapply(.SD, method.function), by=by.dims] + output.dt <- input.dt[,lapply(.SD, method.function, na.rm = na.rm), by=by.dims] output.dt[,Month:=NULL] } # else use the weighted mean, weighted by the days in the month @@ -146,7 +148,7 @@ aggregateSubannual.uncompiled <- function(x, # if not doing mean, simply apply the required function if(!identical(method.function, mean)){ - output.dt <- copy(input.dt)[,lapply(.SD, method.function), by=by.dims] + output.dt <- copy(input.dt)[,lapply(.SD, method.function, na.rm = na.rm), by=by.dims] output.dt[,Season:=NULL] } # else use the weighted mean by days in the season @@ -201,7 +203,7 @@ aggregateSubannual.uncompiled <- function(x, if(!identical(method.function, mean)){ output.dt <- output.dt[, Month:=NULL] - output.dt <- output.dt[,lapply(.SD, method.function), by=by.dims] + output.dt <- output.dt[,lapply(.SD, method.function, na.rm = na.rm), by=by.dims] } @@ -246,7 +248,7 @@ aggregateSubannual.uncompiled <- function(x, output.dt <- copy(input.dt)[, Month := days.to.months[Day]] output.dt[,Day:=NULL] by.dims <- append(by.dims, "Month") - output.dt <- output.dt[,lapply(.SD, method.function), by=by.dims] + output.dt <- output.dt[,lapply(.SD, method.function, na.rm = na.rm), by=by.dims] } else if("Month" %in% avail.dims) {warning("Aggregation to monthly requested but data already are already monthly, so no averging done and returning original data!") diff --git a/R/aggregateYears.R b/R/aggregateYears.R index 3efaf11..ce3e336 100644 --- a/R/aggregateYears.R +++ b/R/aggregateYears.R @@ -13,6 +13,7 @@ #' @param x A Field or data.table (with a "Year" column) #' @param method A character string describing the method by which to aggregate the data. Can currently be "mean", "mode", "median", "sum", "max", "min", "sd", "var" and "cv" (= coefficient of variation: sd/mean). #' For technical reasons these need to be implemented in the package in the code however it should be easy to implement more, please just contact the author! +#' @param na.rm Logical, passed to aggregation function to control whether or not to remove NAs before aggregating - i.e. the standard R usage. #' @param verbose If TRUE give some progress update about the averaging. #' @return A Field or data.table depending on the input object #' @keywords internal @@ -20,6 +21,7 @@ #' @author Matthew Forrest \email{matthew.forrest@@senckenberg.de} aggregateYears.uncompiled <- function(x, method = "mean", + na.rm = TRUE, verbose = FALSE){ # Messy solution to stop "notes" about undeclared global variables stemming from data.table syntax @@ -37,7 +39,7 @@ aggregateYears.uncompiled <- function(x, min = min, sd = stats::sd, var = stats::var, - cv = function(x) {stats::sd(x)/mean(x)}) + cv = function(x,na.rm) {stats::sd(x,na.rm)/mean(x,0,na.rm)}) # sort out the input object class @@ -54,7 +56,7 @@ aggregateYears.uncompiled <- function(x, by.dims <- avail.dims[-which(avail.dims == "Year")] # and actually do it - output.dt <- input.dt[, lapply(.SD, method.function), by=by.dims] + output.dt <- input.dt[, lapply(.SD, method.function, na.rm = na.rm), by=by.dims] output.dt[, Year := NULL] # try another way - THIS IS SLOWER!! diff --git a/R/small-utility-functions.R b/R/small-utility-functions.R index 26ba7ff..8fb8f00 100644 --- a/R/small-utility-functions.R +++ b/R/small-utility-functions.R @@ -22,11 +22,13 @@ #' encountered in the original vector. #' #' @param x vector from which to find the most common value +#' @param na.rm Logical, whether or not to remove NAs before calculating mode - i.e. the standard R usage. #' #' @keywords internal #' @return The mode, ie the most common value. In case of ties the return is first in the original vector #' -stats_mode <- function(x) { +stats_mode <- function(x, na.rm = TRUE) { + if(na.rm) x <- x[!is.na(x)] unique_x <- unique(x) unique_x[which.max(tabulate(match(x, unique_x)))] } From e97f337d24dd0e3ab1476eb4072598f1da303aa6 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Wed, 7 Jan 2026 13:06:20 +0000 Subject: [PATCH 18/20] Support linewidth aestheric on plotSubannual() --- DESCRIPTION | 2 +- R/plotSubannual.R | 30 ++++++++++++++++++------------ 2 files changed, 19 insertions(+), 13 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 78cf39b..7079974 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,7 +40,7 @@ License: GPL | file LICENSE URL: https://www.bik-f.de BugReports: https://github.com/MagicForrest/DGVMTools/issues NeedsCompilation: no -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 VignetteBuilder: knitr Encoding: UTF-8 Collate: diff --git a/R/plotSubannual.R b/R/plotSubannual.R index 58ee1e9..e60baeb 100644 --- a/R/plotSubannual.R +++ b/R/plotSubannual.R @@ -12,21 +12,21 @@ #' @param title A character string to override the default title. #' @param subtitle A character string to override the default subtitle. #' @param x.label,y.label Character strings (or expressions) for the x and y axes (optional) -#' @param col.by,linetype.by,alpha.by Character strings defining the aspects of the data which which should be used to set the colour, line type and alpha (transparency). +#' @param col.by,linetype.by,alpha.by,linewidth.by Character strings defining the aspects of the data which which should be used to set the colour, line type, line width and alpha (transparency). #' Can meaningfully take the values "Layer", "Source", "Site", "Region" or "Quantity". #' NOTE SPECIAL DEFAULT CASE: By default, \code{col.by} is set to "Year" which means that the years are plotted according to a colour gradient, and all other aspects of the #' the data are distinguished by different facet panels. To change this behaviour and colour the lines according to something different, set the "col.by" argument to one of the #' strings suggested above. -#' @param cols,linetypes,alphas A vector of colours, line types, or alpha values (respectively) to control the aesthetics of the lines. -#' Only "cols" makes sense without a corresponding "xxx.by" argument (see above). The vectors can/should be named to match particular col/linetype/alpha values +#' @param cols,linetypes,alphas,linewidths A vector of colours, line types, or alpha values (respectively) to control the aesthetics of the lines. +#' Only "cols" makes sense without a corresponding "xxx.by" argument (see above). The vectors can/should be named to match particular col/linetype/alpha/linewidth values #' to particular Layers/Sources/Sites/Quantities/Regions. -#' @param col.labels,linetype.labels,alpha.labels A vector of character strings which are used as the labels for the lines. Must have the same length as the +#' @param col.labels,linetype.labels,alpha.labels,linewidth.labels A vector of character strings which are used as the labels for the lines. Must have the same length as the #' number of Sources/Layers/Sites/Quantities in the plot. The vectors can/should be named to match particular col/linewtype/alpha values to particular Layers/Sources/Sites/Quantities/Region. -#' @param linewidth Numeric (as ggplot2), width of the lines on the plot, consistent with ggplot2. Note the width is doubled for the aggregate/summary line. #' @param size Numeric, size of the points for the aggregate/summary data, consistent with ggplot2. #' @param summary.function A function to summarise (aggregate) across year and plot on top. Obvious choice is \code{mean}, but there is flexibility to anything that operates on #' a vector of numerics - eg median, a 95th percentile, standard deviation. #' @param summary.function.label An optional character string to give a pretty label to the summary function legend. +#' @param summary.function.linewidth An optional number for the width of the summary.function (default is 1). #' @param text.multiplier A number specifying an overall multiplier for the text on the plot. #' Make it bigger if the text is too small on large plots and vice-versa. #' @param plot Boolean, if FALSE return a data.table with the final data instead of the ggplot object. This can be useful for inspecting the structure of the facetting columns, amongst other things. @@ -64,15 +64,18 @@ plotSubannual <- function(fields, # can be a Field or a list of Fields linetypes = NULL, linetype.by = NULL, linetype.labels = waiver(), + linewidths = NULL, + linewidth.by = NULL, + linewidth.labels = waiver(), alphas = NULL, alpha.by = NULL, alpha.labels = waiver(), - linewidth = 0.5, size = 3 , y.label = NULL, x.label = NULL, summary.function, summary.function.label = deparse(substitute(summary.function)), + summary.function.linewidth = 1, text.multiplier = NULL, plot = TRUE, ...) { @@ -281,12 +284,15 @@ plotSubannual <- function(fields, # can be a Field or a list of Fields col.sym <- if(is.character(col.by)) ensym(col.by) else NULL alpha.sym <- if(is.character(alpha.by)) ensym(alpha.by) else NULL linetype.sym <- if(is.character(linetype.by)) ensym(linetype.by) else NULL + linewidth.sym <- if(is.character(linewidth.by)) ensym(linewidth.by) else NULL + # build the basic plot p <- ggplot(as.data.frame(data.toplot), aes(x = .data[[subannual.dimension]], y = Value, group = PlotGroup, col = !! col.sym, alpha = !! alpha.sym, - linetype = !! linetype.sym)) + linetype = !! linetype.sym, + linewidth = !! linewidth.sym)) # build arguments for aesthetics to geom_line/geom_line and/or fixed arguments outside geom_args <- list() @@ -295,9 +301,8 @@ plotSubannual <- function(fields, # can be a Field or a list of Fields if(!is.null(cols) && is.null(col.by)) geom_args[["colour"]] <- cols if(!is.null(alphas) && is.null(alpha.by)) geom_args[["alpha"]] <- alphas if(!is.null(linetypes) && is.null(linetype.by)) geom_args[["linetype"]] <- linetypes + if(!is.null(linewidths) && is.null(linewidth.by)) geom_args[["linewidths"]] <- linewidths - # line width if a fixed value for all - geom_args[["linewidth"]] <- linewidth # call geom_line (with fixed aesthetics define above) p <- p + do.call(geom_line, geom_args) @@ -314,6 +319,7 @@ plotSubannual <- function(fields, # can be a Field or a list of Fields # these are simply defined by the arguments, no special cases if(!is.null(linetype.by) & !is.null(linetypes)) p <- p + scale_linetype_manual(values=linetypes, labels=linetype.labels) + if(!is.null(linewidth.by) & !is.null(linewidths)) p <- p + scale_linewidth_manual(values=linewidths, labels=linewidth.labels) if(!is.null(alpha.by) & !is.null(alphas)) p <- p + scale_alpha_manual(values=alphas, labels=alpha.labels) # set the theme to theme_bw, simplest way to set the background to white @@ -335,13 +341,13 @@ plotSubannual <- function(fields, # can be a Field or a list of Fields # honestly not sure exactly why this works and many other things I tried didn't work if(missing(linetype.by) || is.null(linetype.by)) { - p <- p + stat_summary(aes(group=col.by, linetype = "dummy string"), fun=summary.function, geom="line", color="black", linewidth = linewidth * 2) + p <- p + stat_summary(aes(group=col.by, linetype = "dummy string"), fun=summary.function, geom="line", color="black", linewidth = summary.function.linewidth) p <- p + scale_linetype_manual(values=c("dummy string"="solid"), labels = c("dummy string" = summary.function.label), name = element_blank()) } # if linetypes are already specified else{ - p <- p + stat_summary(aes(group=StatsGroup, linetype = .data[[linetype.by]]), fun=summary.function, geom="line", color="black", linewidth = linewidth * 2) + p <- p + stat_summary(aes(group=StatsGroup, linetype = .data[[linetype.by]]), fun=summary.function, geom="line", color="black", linewidth = summary.function.linewidth) # title the legend p <- p + labs(linetype=summary.function.label) } @@ -362,7 +368,7 @@ plotSubannual <- function(fields, # can be a Field or a list of Fields # also add linetype if necessary if(!missing(linetype.by) && !is.null(linetype.by)) { - p <- p + stat_summary(aes(group=StatsGroup, linetype = .data[[linetype.by]]), fun=summary.function, geom="line", color="black", linewidth = linewidth * 2) + p <- p + stat_summary(aes(group=StatsGroup, linetype = .data[[linetype.by]]), fun=summary.function, geom="line", color="black", linewidth = summary.function.linewidth) } } From b782a9b3937a01c00589b62873307ce18f14ca94 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Wed, 7 Jan 2026 13:09:38 +0000 Subject: [PATCH 19/20] Nothing functional - only documentation (.Rd files) and removing some blank lines. --- R/plotSpatialComparison.R | 2 -- man/aggregateSpatial.Rd | 4 +++- man/aggregateSpatial.uncompiled.Rd | 10 +++++++++- man/aggregateSubannual.Rd | 10 +++++++++- man/aggregateSubannual.uncompiled.Rd | 3 +++ man/aggregateYears.Rd | 4 +++- man/aggregateYears.uncompiled.Rd | 4 +++- man/plotSubannual.Rd | 17 ++++++++++------- man/stats_mode.Rd | 4 +++- 9 files changed, 43 insertions(+), 15 deletions(-) diff --git a/R/plotSpatialComparison.R b/R/plotSpatialComparison.R index b11ec11..8149e96 100644 --- a/R/plotSpatialComparison.R +++ b/R/plotSpatialComparison.R @@ -155,8 +155,6 @@ plotSpatialComparison <- function(comparisons, else { temp.dt[,c(difference.column.name) := get(expected.layers.1[layer.counter]) - get(expected.layers.2[layer.counter])] if(type == "percentage.difference") temp.dt[,c(difference.column.name) := 100 * get(difference.column.name) / get(expected.layers.2[layer.counter])] - - } } diff --git a/man/aggregateSpatial.Rd b/man/aggregateSpatial.Rd index 5879d1e..2667d6a 100644 --- a/man/aggregateSpatial.Rd +++ b/man/aggregateSpatial.Rd @@ -4,7 +4,7 @@ \alias{aggregateSpatial} \title{Spatially aggregate a Field} \usage{ -aggregateSpatial(x, method = "mean", verbose = FALSE, ...) +aggregateSpatial(x, method = "mean", na.rm = TRUE, verbose = FALSE, ...) } \arguments{ \item{x}{Field (or data.table) to be averaged} @@ -12,6 +12,8 @@ aggregateSpatial(x, method = "mean", verbose = FALSE, ...) \item{method}{The method with which to spatially aggregate. Can be "weighted.mean", "w.mean", "mean", "weighted.sum", "w.sum", "sum", "mode", "median", "max", "min", "sd", "var" and "cv" (= coefficient of variation: sd/mean).} +\item{na.rm}{Logical, passed to aggregation function to control whether or not to remove NAs before aggregating - i.e. the standard R usage.} + \item{verbose}{If TRUE give some progress update about the averaging.} \item{...}{Extra arguments passed to addArea function if a weighted method is being used. Note in particular the lon_centres and lat_centres arguments diff --git a/man/aggregateSpatial.uncompiled.Rd b/man/aggregateSpatial.uncompiled.Rd index a978f79..0120a81 100644 --- a/man/aggregateSpatial.uncompiled.Rd +++ b/man/aggregateSpatial.uncompiled.Rd @@ -4,7 +4,13 @@ \alias{aggregateSpatial.uncompiled} \title{Spatially aggregate a Field} \usage{ -aggregateSpatial.uncompiled(x, method = "mean", verbose = FALSE, ...) +aggregateSpatial.uncompiled( + x, + method = "mean", + na.rm = TRUE, + verbose = FALSE, + ... +) } \arguments{ \item{x}{Field (or data.table) to be averaged} @@ -12,6 +18,8 @@ aggregateSpatial.uncompiled(x, method = "mean", verbose = FALSE, ...) \item{method}{The method with which to spatially aggregate. Can be "weighted.mean", "w.mean", "mean", "weighted.sum", "w.sum", "sum", "mode", "median", "max", "min", "sd", "var" and "cv" (= coefficient of variation: sd/mean).} +\item{na.rm}{Logical, passed to aggregation function to control whether or not to remove NAs before aggregating - i.e. the standard R usage.} + \item{verbose}{If TRUE give some progress update about the averaging.} \item{...}{Extra arguments passed to addArea function if a weighted method is being used. Note in particular the lon_centres and lat_centres arguments diff --git a/man/aggregateSubannual.Rd b/man/aggregateSubannual.Rd index 546a947..67fd82a 100644 --- a/man/aggregateSubannual.Rd +++ b/man/aggregateSubannual.Rd @@ -4,7 +4,13 @@ \alias{aggregateSubannual} \title{Sub-annual aggregation} \usage{ -aggregateSubannual(x, method = "mean", target = "Year", verbose = FALSE) +aggregateSubannual( + x, + method = "mean", + target = "Year", + na.rm = TRUE, + verbose = FALSE +) } \arguments{ \item{x}{data.table or Field} @@ -15,6 +21,8 @@ For technical reasons these need to be implemented in the package in the code ho \item{target}{A character string defining the subannual period to which the data should be aggregate. Can be "Month", "Season" or "Year" (also "Annual" is valid). Default is year.} +\item{na.rm}{Logical, passed to aggregation function to control whether or not to remove NAs before aggregating - i.e. the standard R usage.} + \item{verbose}{If TRUE give some progress update about the averaging. Input data can be a Field or data.table with appropriate columns.} diff --git a/man/aggregateSubannual.uncompiled.Rd b/man/aggregateSubannual.uncompiled.Rd index dd8f012..835c429 100644 --- a/man/aggregateSubannual.uncompiled.Rd +++ b/man/aggregateSubannual.uncompiled.Rd @@ -8,6 +8,7 @@ aggregateSubannual.uncompiled( x, method = "mean", target = "Year", + na.rm = TRUE, verbose = FALSE ) } @@ -20,6 +21,8 @@ For technical reasons these need to be implemented in the package in the code ho \item{target}{A character string defining the subannual period to which the data should be aggregate. Can be "Month", "Season" or "Year" (also "Annual" is valid). Default is year.} +\item{na.rm}{Logical, passed to aggregation function to control whether or not to remove NAs before aggregating - i.e. the standard R usage.} + \item{verbose}{If TRUE give some progress update about the averaging. Input data can be a Field or data.table with appropriate columns.} diff --git a/man/aggregateYears.Rd b/man/aggregateYears.Rd index ec638b3..d2e4d8b 100644 --- a/man/aggregateYears.Rd +++ b/man/aggregateYears.Rd @@ -4,7 +4,7 @@ \alias{aggregateYears} \title{Aggregate years} \usage{ -aggregateYears(x, method = "mean", verbose = FALSE) +aggregateYears(x, method = "mean", na.rm = TRUE, verbose = FALSE) } \arguments{ \item{x}{A Field or data.table (with a "Year" column)} @@ -12,6 +12,8 @@ aggregateYears(x, method = "mean", verbose = FALSE) \item{method}{A character string describing the method by which to aggregate the data. Can currently be "mean", "mode", "median", "sum", "max", "min", "sd", "var" and "cv" (= coefficient of variation: sd/mean). For technical reasons these need to be implemented in the package in the code however it should be easy to implement more, please just contact the author!} +\item{na.rm}{Logical, passed to aggregation function to control whether or not to remove NAs before aggregating - i.e. the standard R usage.} + \item{verbose}{If TRUE give some progress update about the averaging.} } \value{ diff --git a/man/aggregateYears.uncompiled.Rd b/man/aggregateYears.uncompiled.Rd index 1cf3735..c8f2e93 100644 --- a/man/aggregateYears.uncompiled.Rd +++ b/man/aggregateYears.uncompiled.Rd @@ -4,7 +4,7 @@ \alias{aggregateYears.uncompiled} \title{Aggregate years} \usage{ -aggregateYears.uncompiled(x, method = "mean", verbose = FALSE) +aggregateYears.uncompiled(x, method = "mean", na.rm = TRUE, verbose = FALSE) } \arguments{ \item{x}{A Field or data.table (with a "Year" column)} @@ -12,6 +12,8 @@ aggregateYears.uncompiled(x, method = "mean", verbose = FALSE) \item{method}{A character string describing the method by which to aggregate the data. Can currently be "mean", "mode", "median", "sum", "max", "min", "sd", "var" and "cv" (= coefficient of variation: sd/mean). For technical reasons these need to be implemented in the package in the code however it should be easy to implement more, please just contact the author!} +\item{na.rm}{Logical, passed to aggregation function to control whether or not to remove NAs before aggregating - i.e. the standard R usage.} + \item{verbose}{If TRUE give some progress update about the averaging.} } \value{ diff --git a/man/plotSubannual.Rd b/man/plotSubannual.Rd index 75c6cdd..f027fdc 100644 --- a/man/plotSubannual.Rd +++ b/man/plotSubannual.Rd @@ -16,15 +16,18 @@ plotSubannual( linetypes = NULL, linetype.by = NULL, linetype.labels = waiver(), + linewidths = NULL, + linewidth.by = NULL, + linewidth.labels = waiver(), alphas = NULL, alpha.by = NULL, alpha.labels = waiver(), - linewidth = 0.5, size = 3, y.label = NULL, x.label = NULL, summary.function, summary.function.label = deparse(substitute(summary.function)), + summary.function.linewidth = 1, text.multiplier = NULL, plot = TRUE, ... @@ -42,21 +45,19 @@ Leave empty or NULL to plot all gridsizrecells (but note that if this involves t \item{subtitle}{A character string to override the default subtitle.} -\item{cols, linetypes, alphas}{A vector of colours, line types, or alpha values (respectively) to control the aesthetics of the lines. -Only "cols" makes sense without a corresponding "xxx.by" argument (see above). The vectors can/should be named to match particular col/linetype/alpha values +\item{cols, linetypes, alphas, linewidths}{A vector of colours, line types, or alpha values (respectively) to control the aesthetics of the lines. +Only "cols" makes sense without a corresponding "xxx.by" argument (see above). The vectors can/should be named to match particular col/linetype/alpha/linewidth values to particular Layers/Sources/Sites/Quantities/Regions.} -\item{col.by, linetype.by, alpha.by}{Character strings defining the aspects of the data which which should be used to set the colour, line type and alpha (transparency). +\item{col.by, linetype.by, alpha.by, linewidth.by}{Character strings defining the aspects of the data which which should be used to set the colour, line type, line width and alpha (transparency). Can meaningfully take the values "Layer", "Source", "Site", "Region" or "Quantity". NOTE SPECIAL DEFAULT CASE: By default, \code{col.by} is set to "Year" which means that the years are plotted according to a colour gradient, and all other aspects of the the data are distinguished by different facet panels. To change this behaviour and colour the lines according to something different, set the "col.by" argument to one of the strings suggested above.} -\item{col.labels, linetype.labels, alpha.labels}{A vector of character strings which are used as the labels for the lines. Must have the same length as the +\item{col.labels, linetype.labels, alpha.labels, linewidth.labels}{A vector of character strings which are used as the labels for the lines. Must have the same length as the number of Sources/Layers/Sites/Quantities in the plot. The vectors can/should be named to match particular col/linewtype/alpha values to particular Layers/Sources/Sites/Quantities/Region.} -\item{linewidth}{Numeric (as ggplot2), width of the lines on the plot, consistent with ggplot2. Note the width is doubled for the aggregate/summary line.} - \item{size}{Numeric, size of the points for the aggregate/summary data, consistent with ggplot2.} \item{x.label, y.label}{Character strings (or expressions) for the x and y axes (optional)} @@ -66,6 +67,8 @@ a vector of numerics - eg median, a 95th percentile, standard deviation.} \item{summary.function.label}{An optional character string to give a pretty label to the summary function legend.} +\item{summary.function.linewidth}{An optional number for the width of the summary.function (default is 1).} + \item{text.multiplier}{A number specifying an overall multiplier for the text on the plot. Make it bigger if the text is too small on large plots and vice-versa.} diff --git a/man/stats_mode.Rd b/man/stats_mode.Rd index 6ef1076..cc67c7c 100644 --- a/man/stats_mode.Rd +++ b/man/stats_mode.Rd @@ -4,10 +4,12 @@ \alias{stats_mode} \title{Statistical mode} \usage{ -stats_mode(x) +stats_mode(x, na.rm = TRUE) } \arguments{ \item{x}{vector from which to find the most common value} + +\item{na.rm}{Logical, whether or not to remove NAs before calculating mode - i.e. the standard R usage.} } \value{ The mode, ie the most common value. In case of ties the return is first in the original vector From 22a3bbfeda6e6118c23ffae7950c348c4004d987 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Tue, 11 Aug 2026 15:35:44 +0200 Subject: [PATCH 20/20] Unit tests for using NULL to specify first.year and last.year, which currently FAIL. Woking on fix... --- tests/testthat/test_DGVMTools.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/testthat/test_DGVMTools.R b/tests/testthat/test_DGVMTools.R index 515dcfd..dbaf9f4 100644 --- a/tests/testthat/test_DGVMTools.R +++ b/tests/testthat/test_DGVMTools.R @@ -270,6 +270,12 @@ context("Selections and Cropping") GUESS.Field.selected.years.1 <- getField(GUESS.Europe.test.Source, "mlai", first.year = 2001, last.year = 2005) GUESS.Field.selected.years.2 <- selectYears(x = GUESS.mlai.Field.full, first = 2001, last = 2005) +# years with NULL +GUESS.Field.selected.years.null.first.year <- getField(GUESS.Europe.test.Source, "mlai", first.year = NULL, last.year = 2005) +GUESS.Field.selected.years.null.last.year <- getField(GUESS.Europe.test.Source, "mlai", first.year = 2001, last.year = NULL) +GUESS.Field.selected.years.null.both.years <- getField(GUESS.Europe.test.Source, "mlai", first.year = NULL, last.year = NULL) + + # months (not available in getField but test by numbers and abbreviation) GUESS.Field.selected.months.1 <- selectMonths(x = GUESS.mlai.Field.full, months = c(1,4,12) ) GUESS.Field.selected.months.2 <- selectMonths(x = GUESS.mlai.Field.full, months = c("Jan","Apr","Dec") ) @@ -330,6 +336,9 @@ test_that("Selections and Cropping",{ # check they give Fields expect_is(GUESS.Field.selected.years.1, "Field") expect_is(GUESS.Field.selected.years.2, "Field") + expect_is(GUESS.Field.selected.years.null.first.year, "Field") + expect_is(GUESS.Field.selected.years.null.last.year , "Field") + expect_is(GUESS.Field.selected.years.null.both.years, "Field") expect_is(GUESS.Field.selected.months.1, "Field") expect_is(GUESS.Field.selected.months.2, "Field") expect_is(GUESS.Field.selected.seasons.1, "Field")