From 3ee2318945e4a4fe9e9aaf28ce695019972bb714 Mon Sep 17 00:00:00 2001 From: Nicolau Manubens Date: Fri, 14 Jul 2017 21:06:48 +0200 Subject: [PATCH 1/9] Small fix in Subset. --- Subset.R | 93 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 Subset.R diff --git a/Subset.R b/Subset.R new file mode 100644 index 00000000..c82b0c67 --- /dev/null +++ b/Subset.R @@ -0,0 +1,93 @@ +Subset <- function(x, along, indices, drop = FALSE) { + # Check x + if (!is.array(x)) { + stop("Input array 'x' must be a numeric array.") + } + + # Take the input array dimension names + dim_names <- attr(x, 'dimensions') + if (!is.character(dim_names)) { + dim_names <- names(dim(x)) + } + if (!is.character(dim_names)) { + if (any(sapply(along, is.character))) { + stop("The input array 'x' doesn't have labels for the dimensions but the parameter 'along' contains dimension names.") + } + } + + # Check along + if (any(sapply(along, function(x) !is.numeric(x) && !is.character(x)))) { + stop("All provided dimension indices in 'along' must be integers or character strings.") + } + if (any(sapply(along, is.character))) { + req_dimnames <- along[which(sapply(along, is.character))] + if (length(unique(req_dimnames)) < length(req_dimnames)) { + stop("The parameter 'along' must not contain repeated dimension names.") + } + along[which(sapply(along, is.character))] <- match(req_dimnames, dim_names) + if (any(is.na(along))) { + stop("Could not match all dimension names in 'indices' with dimension names in input array 'x'.") + } + along <- as.numeric(along) + } + + # Check indices + if (!is.list(indices)) { + indices <- list(indices) + } + + # Check parameter drop + dims_to_drop <- c() + if (is.character(drop)) { + if (drop == 'all') { + drop <- TRUE + } else if (any(drop %in% c('selected', 'non-selected', 'none'))) { + if (drop == 'selected') { + dims_to_drop <- along[which(sapply(indices, length) == 1)] + } else if (drop == 'non-selected') { + dims_to_drop <- dim(x) == 1 + dims_to_drop[along] <- FALSE + dims_to_drop <- which(dims_to_drop) + } + drop <- FALSE + } else { + stop("Parameter 'drop' must be one of TRUE, FALSE, 'all', 'selected', 'non-selected', 'none'.") + } + } else if (!is.logical(drop)) { + stop("Parameter 'drop' must be one of TRUE, FALSE, 'all', 'selected', 'non-selected', 'none'.") + } + + # Take the subset + nd <- length(dim(x)) + index <- as.list(rep(TRUE, nd)) + index[along] <- indices + subset <- eval(as.call(c(as.name("["), as.name("x"), index, drop = drop))) + # If dropped all dimensions, need to drop dimnames too + if (is.character(dim_names) && drop == TRUE) { + dim_names_to_remove <- unique(c(along[which(sapply(indices, length) == 1)], + which(dim(x) == 1))) + if (length(dim_names_to_remove) > 0) { + dim_names <- dim_names[-dim_names_to_remove] + } + } + + # Amend the final dimensions and put dimnames and attributes + metadata <- attributes(x) + metadata[['dim']] <- dim(subset) + if (length(dims_to_drop) > 0) { + metadata[['dim']] <- metadata[['dim']][-dims_to_drop] + if (is.character(dim_names)) { + names(metadata[['dim']]) <- dim_names[-dims_to_drop] + if ('dimensions' %in% names(attributes(x))) { + metadata[['dimensions']] <- dim_names[-dims_to_drop] + } + } + } else if (is.character(dim_names)) { + names(metadata[['dim']]) <- dim_names + if ('dimensions' %in% names(attributes(x))) { + metadata[['dimensions']] <- dim_names + } + } + attributes(subset) <- metadata + subset +} -- GitLab From 5348ff304d8c2ad7459ef5968c1b5c2eef68989c Mon Sep 17 00:00:00 2001 From: Nicolau Manubens Date: Mon, 18 Sep 2017 19:10:52 +0200 Subject: [PATCH 2/9] Bugfix in .MergeArrays. --- R/Utils.R | 54 +++++++++++++++++++++++++++++++----------------------- 1 file changed, 31 insertions(+), 23 deletions(-) diff --git a/R/Utils.R b/R/Utils.R index 603d4716..31f9ae07 100644 --- a/R/Utils.R +++ b/R/Utils.R @@ -1565,33 +1565,41 @@ # 'a' 'b' 'c' 'e' 'd' 'f' 'g' # 2 4 3 7 5 9 11 .MergeArrays <- function(array1, array2, along) { - if (!(identical(names(dim(array1)), names(dim(array2))) && - identical(dim(array1)[-which(names(dim(array1)) == along)], - dim(array2)[-which(names(dim(array2)) == along)]))) { - new_dims <- .MergeArrayDims(dim(array1), dim(array2)) - dim(array1) <- new_dims[[1]] - dim(array2) <- new_dims[[2]] - for (j in 1:length(dim(array1))) { - if (names(dim(array1))[j] != along) { - if (dim(array1)[j] != dim(array2)[j]) { - if (which.max(c(dim(array1)[j], dim(array2)[j])) == 1) { - na_array_dims <- dim(array2) - na_array_dims[j] <- dim(array1)[j] - dim(array2)[j] - na_array <- array(dim = na_array_dims) - array2 <- abind(array2, na_array, along = j) - names(dim(array2)) <- names(na_array_dims) - } else { - na_array_dims <- dim(array1) - na_array_dims[j] <- dim(array2)[j] - dim(array1)[j] - na_array <- array(dim = na_array_dims) - array1 <- abind(array1, na_array, along = j) - names(dim(array1)) <- names(na_array_dims) + if (!(is.null(array1) || is.null(array2))) { + if (!(identical(names(dim(array1)), names(dim(array2))) && + identical(dim(array1)[-which(names(dim(array1)) == along)], + dim(array2)[-which(names(dim(array2)) == along)]))) { + new_dims <- .MergeArrayDims(dim(array1), dim(array2)) + dim(array1) <- new_dims[[1]] + dim(array2) <- new_dims[[2]] + for (j in 1:length(dim(array1))) { + if (names(dim(array1))[j] != along) { + if (dim(array1)[j] != dim(array2)[j]) { + if (which.max(c(dim(array1)[j], dim(array2)[j])) == 1) { + na_array_dims <- dim(array2) + na_array_dims[j] <- dim(array1)[j] - dim(array2)[j] + na_array <- array(dim = na_array_dims) + array2 <- abind(array2, na_array, along = j) + names(dim(array2)) <- names(na_array_dims) + } else { + na_array_dims <- dim(array1) + na_array_dims[j] <- dim(array2)[j] - dim(array1)[j] + na_array <- array(dim = na_array_dims) + array1 <- abind(array1, na_array, along = j) + names(dim(array1)) <- names(na_array_dims) + } } } } } + if (!(along %in% names(dim(array2)))) { + stop("The dimension specified in 'along' is not present in the ", + "provided arrays.") + } + array1 <- abind(array1, array2, along = which(names(dim(array1)) == along)) + names(dim(array1)) <- names(dim(array2)) + } else if (is.null(array1)) { + array1 <- array2 } - array1 <- abind(array1, array2, along = which(names(dim(array1)) == along)) - names(dim(array1)) <- names(dim(array2)) array1 } -- GitLab From 0f63c1344094b7a04cdff37d0c93240f88710db5 Mon Sep 17 00:00:00 2001 From: Nicolau Manubens Date: Wed, 20 Sep 2017 10:09:25 +0200 Subject: [PATCH 3/9] Small message fix. --- R/Load.R | 37 +++++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 16 deletions(-) diff --git a/R/Load.R b/R/Load.R index 05649661..3af26479 100644 --- a/R/Load.R +++ b/R/Load.R @@ -18,21 +18,24 @@ Load <- function(var, exp = NULL, obs = NULL, sdates, nmember = NULL, } load_parameters <- lapply(parameter_names, get, envir = environment()) names(load_parameters) <- parameter_names - parameters_to_show <- c('var', 'exp', 'obs', 'sdates', 'grid', 'output', 'storefreq') + parameters_to_show <- c('var', 'exp', 'obs', 'sdates', 'nmember', 'leadtimemin', + 'leadtimemax', 'latmin', 'latmax', 'lonmin', 'lonmax', + 'output', 'grid', 'storefreq') load_parameters <- c(load_parameters[parameters_to_show], load_parameters[-match(parameters_to_show, names(load_parameters))]) - message(paste("* The load call you issued is:\n* Load(", - paste(strwrap( - paste(unlist(lapply(names(load_parameters[1:length(parameters_to_show)]), - function(x) paste(x, '=', - if (x == 'sdates' && length(load_parameters[[x]]) > 4) { - paste0("c('", load_parameters[[x]][1], "', '", load_parameters[[x]][2], - "', ..., '", tail(load_parameters[[x]], 1), "')") - } else { - paste(deparse(load_parameters[[x]]), collapse = '') - }))), - collapse = ', '), width = getOption('width') - 9, indent = 0, exdent = 8), collapse = '\n*'), - ", ...)\n* See the full call in '$load_parameters' after Load() finishes.", sep = '')) - + if (!silent) { + message(paste("* The load call you issued is:\n* Load(", + paste(strwrap( + paste(unlist(lapply(names(load_parameters[1:length(parameters_to_show)]), + function(x) paste(x, '=', + if (x == 'sdates' && length(load_parameters[[x]]) > 4) { + paste0("c('", load_parameters[[x]][1], "', '", load_parameters[[x]][2], + "', ..., '", tail(load_parameters[[x]], 1), "')") + } else { + paste(deparse(load_parameters[[x]]), collapse = '') + }))), + collapse = ', '), width = getOption('width') - 9, indent = 0, exdent = 8), collapse = '\n*'), + ", ...)\n* See the full call in '$load_parameters' after Load() finishes.", sep = '')) + } # .message("* The load call you issued is:") # .message("* Load(") # .message( @@ -379,8 +382,10 @@ Load <- function(var, exp = NULL, obs = NULL, sdates, nmember = NULL, replace_globs <- path_glob_permissive %in% c('no', 'partial') # If not all data has been provided in 'exp' and 'obs', configuration file is read. - if (length(exps_to_fetch) > 0 || length(obs_to_fetch) > 0) { - .message("Some 'path's not explicitly provided in 'exp' and 'obs', so will now proceed to open the configuration file.") + if ((length(exps_to_fetch) > 0 || length(obs_to_fetch) > 0)) { + if (!silent) { + .message("Some 'path's not explicitly provided in 'exp' and 'obs', so will now proceed to open the configuration file.") + } data_info <- ConfigFileOpen(configfile, silent, TRUE) # Check that the var, exp and obs parameters are right and keep the entries -- GitLab From 31881282359b4db54366e61c6beee1168e254d79 Mon Sep 17 00:00:00 2001 From: Nicolau Manubens Date: Wed, 25 Oct 2017 12:20:38 +0200 Subject: [PATCH 4/9] Fix in Subset. --- R/Subset.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/Subset.R b/R/Subset.R index a084a1c2..d10629c5 100644 --- a/R/Subset.R +++ b/R/Subset.R @@ -80,6 +80,10 @@ Subset <- function(x, along, indices, drop = FALSE) { names(metadata[['dim']]) <- dim_names[-dims_to_drop] metadata[['dimensions']] <- dim_names[-dims_to_drop] } + if (length(metadata[['dim']]) == 0) { + metadata['dim'] <- list(NULL) + metadata['dimensions'] <- list(NULL) + } } else if (is.character(dim_names)) { names(metadata[['dim']]) <- dim_names metadata[['dimensions']] <- dim_names -- GitLab From f8a573ebc7b9d58ae085fdbbb1de58399ccc0362 Mon Sep 17 00:00:00 2001 From: ahunter Date: Wed, 17 Jan 2018 08:58:50 +0100 Subject: [PATCH 5/9] Major bugfix for drift correction in Clim --- R/Clim.R | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/R/Clim.R b/R/Clim.R index 615f845a..4fdfa038 100644 --- a/R/Clim.R +++ b/R/Clim.R @@ -47,8 +47,8 @@ Clim <- function(var_exp, var_obs, memb = TRUE, kharin = FALSE, NDV = FALSE) { trend_obs <- array(dim = dim(var_exp)) trend_exp <- array(dim = dim(var_exp)) for (jdate in 1:dimexp[3]) { - trend_exp[, , jdate, , , , ] <- tmp_exp$trend[, , 4, , , , ] - + jdate * tmp_exp$trend[, , 2, , , , ] + trend_exp[, , jdate, , , , ] <- tmp_exp$trend[, , 4, , , , ] + + jdate * tmp_exp$trend[, , 2, , , , ] tmp_obs2 <- MeanListDim(tmp_obs$trend,c(2, 1)) trend_obs[, , jdate, , , , ] <- InsertDim(InsertDim(tmp_obs2[4, , , , ] + jdate * tmp_obs2[2, , , , ], 1, dimexp[1]), @@ -66,13 +66,13 @@ Clim <- function(var_exp, var_obs, memb = TRUE, kharin = FALSE, NDV = FALSE) { reg_obs <- array(dim = dim(var_exp)) reg_exp <- array(dim = dim(var_exp)) for (jdate in 1:dimexp[3]) { - reg_exp[, , jdate, , , , ] <- tmp_exp$regression[, , 4, , , , ] - + iniexp[, , jdate, , , , ] * + reg_exp[, , jdate, , , , ] <- tmp_exp$regression[, , 4, , , , ] + + iniexp[, , jdate, , , , ] * tmp_exp$regression[, , 2, , , , ] tmp_obs2 <- MeanListDim(tmp_obs$regression,c(2, 1)) - reg_obs[, , jdate, , , , ] <- InsertDim(InsertDim(tmp_obs2[4, , , , ] - + MeanListDim(iniobs,c(2, 1))[jdate, , , , ] - * tmp_obs2[2, , , , ], 1, dimexp[1]), + reg_obs[, , jdate, , , , ] <- InsertDim(InsertDim(tmp_obs2[4, , , , ] + + MeanListDim(iniobs,c(2, 1))[jdate, , , , ] * + tmp_obs2[2, , , , ], 1, dimexp[1]), 2, dimexp[2]) } out_clim_exp <- reg_exp - reg_obs + InsertDim(InsertDim(InsertDim( -- GitLab From 9fa567df31f2f91aefab14950d5b4ca8e30d0e05 Mon Sep 17 00:00:00 2001 From: Nicolau Manubens Date: Fri, 1 Jun 2018 16:01:18 +0200 Subject: [PATCH 6/9] Small extension to documentation of PlotLayout. --- man/PlotLayout.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/PlotLayout.Rd b/man/PlotLayout.Rd index 9e0c2cb7..34331a37 100644 --- a/man/PlotLayout.Rd +++ b/man/PlotLayout.Rd @@ -41,7 +41,7 @@ Multi-dimensional array with at least the dimensions expected by the specified p Parameters to be sent to the plotting function 'fun'. If multiple arrays are provided in 'var' and multiple functions are provided in 'fun', the parameters provided through \dots will be sent to all the plot functions, as common parameters. To specify concrete arguments for each of the plot functions see parameter 'special_args'. } \item{special_args}{ -List of sub-lists, each sub-list having extra arguments for each of the plot functions provided in 'fun'. +List of sub-lists, each sub-list having specific extra arguments for each of the plot functions provided in 'fun'. If you want to fix a different value for each plot in the layout you can do so by a) splitting your array into a list of sub-arrays (each with the data for one plot) and providing it as parameter 'var', b) providing a list of named sub-lists in 'special_args', where the names of each sub-list match the names of the parameters to be adjusted, and each value in a sub-list contains the value of the corresponding parameter. } \item{nrow}{ Numeric value to force the number of rows in the automatically generated layout. If higher than the required, this will yield blank cells in the layout (which can then be populated). If lower than the required the function will stop. By default it is configured to arrange the layout in a shape as square as possible. Blank cells can be manually populated after with customized plots (see SwitchTofigure). -- GitLab From fad6a9113dab40182db0e0f75f552b4feb899928 Mon Sep 17 00:00:00 2001 From: Nicolau Manubens Date: Fri, 1 Jun 2018 16:59:30 +0200 Subject: [PATCH 7/9] Added feature for skipping label drawing in ColorBar (PlotEquiMap/StereoMap). --- R/ColorBar.R | 10 +++++++++- man/ColorBar.Rd | 2 +- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/R/ColorBar.R b/R/ColorBar.R index 4f92a2a1..d47c3103 100644 --- a/R/ColorBar.R +++ b/R/ColorBar.R @@ -223,6 +223,10 @@ ColorBar <- function(brks = NULL, cols = NULL, vertical = TRUE, stop("Parameter 'subsampleg' must be numeric.") } subsampleg <- round(subsampleg) + draw_labels <- TRUE + if ((subsampleg) < 1) { + draw_labels <- FALSE + } # Check plot if (!is.logical(plot)) { @@ -433,7 +437,11 @@ ColorBar <- function(brks = NULL, cols = NULL, vertical = TRUE, labels <- c(labels, extra_labels) tick_reorder <- sort(at, index.return = TRUE) at <- tick_reorder$x - labels <- labels[tick_reorder$ix] + if (draw_labels) { + labels <- labels[tick_reorder$ix] + } else { + labels <- FALSE + } axis(d, at = at, tick = draw_ticks, labels = labels, cex.axis = cex_labels, tcl = cex_ticks) par(saved_pars) } diff --git a/man/ColorBar.Rd b/man/ColorBar.Rd index fb7cc7e5..51ca5670 100644 --- a/man/ColorBar.Rd +++ b/man/ColorBar.Rd @@ -33,7 +33,7 @@ TRUE/FALSE for vertical/horizontal colour bar (disregarded if plot = FALSE). } \item{subsampleg}{ The first of each subsampleg breaks will be ticked on the colorbar.\cr -Takes by default an approximation of a value that yields a readable tick arrangement (extreme breaks always ticked). See the code of the function for details or use 'extra_labels' for customized tick arrangements. +Takes by default an approximation of a value that yields a readable tick arrangement (extreme breaks always ticked). If set to 0 or lower, no labels are drawn. See the code of the function for details or use 'extra_labels' for customized tick arrangements. } \item{bar_limits}{ Vector of two numeric values with the extremes of the range of values represented in the colour bar. If 'var_limits' go beyond this interval, the drawing of triangle extremes is triggered at the corresponding sides, painted in 'col_inf' and 'col_sup'. Either of them can be set as NA and will then take as value the corresponding extreme in 'var_limits' (hence a triangle end won't be triggered for these sides). Takes as default the extremes of 'brks' if available, else the same values as 'var_limits'. -- GitLab From 1dc0f11f808141a67f927f331cdf13de319b483e Mon Sep 17 00:00:00 2001 From: Nicolau Manubens Date: Tue, 8 Jan 2019 19:11:04 +0100 Subject: [PATCH 8/9] Fix in CDORemap for cases where grid file is specified and only dimvars are created by ncdf4 when reading the temporary interpolated file. --- R/CDORemap.R | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/R/CDORemap.R b/R/CDORemap.R index 55f12904..ecf4fcdb 100644 --- a/R/CDORemap.R +++ b/R/CDORemap.R @@ -533,8 +533,33 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, found_lat_dim <- found_dim_names[which(found_dim_names %in% .KnownLatNames())[1]] found_lon_dim_size <- length(ncdf_remapped$dim[[found_lon_dim]]$vals) found_lat_dim_size <- length(ncdf_remapped$dim[[found_lat_dim]]$vals) - found_lons <- ncvar_get(ncdf_remapped, 'lon', collapse_degen = FALSE) - found_lats <- ncvar_get(ncdf_remapped, 'lat', collapse_degen = FALSE) + found_var_names <- names(ncdf_remapped$var) + found_lon_var_name <- which(found_var_names %in% .KnownLonNames()) + found_lat_var_name <- which(found_var_names %in% .KnownLatNames()) + if (length(found_lon_var_name) > 0) { + found_lon_var_name <- found_var_names[found_lon_var_name[1]] + } else { + found_lon_var_name <- NULL + } + if (length(found_lat_var_name) > 0) { + found_lat_var_name <- found_var_names[found_lat_var_name[1]] + } else { + found_lat_var_name <- NULL + } + if (length(found_lon_var_name) > 0) { + found_lons <- ncvar_get(ncdf_remapped, found_lon_var_name, + collapse_degen = FALSE) + } else { + found_lons <- ncdf_remapped$dim[[found_lon_dim]]$vals + dim(found_lons) <- found_lon_dim_size + } + if (length(found_lat_var_name) > 0) { + found_lats <- ncvar_get(ncdf_remapped, found_lat_var_name, + collapse_degen = FALSE) + } else { + found_lats <- ncdf_remapped$dim[[found_lat_dim]]$vals + dim(found_lats) <- found_lat_dim_size + } if (length(dim(lons)) == length(dim(found_lons))) { new_lon_name <- lon_dim } else { -- GitLab From 36330c1b3b4125cf6f86c74efe05b441c97b6722 Mon Sep 17 00:00:00 2001 From: Nicolau Manubens Date: Wed, 9 Jan 2019 22:16:15 +0100 Subject: [PATCH 9/9] Fix in CDORemap for cases where attribute netcdf dimensions provided with lons and lats. --- R/CDORemap.R | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/R/CDORemap.R b/R/CDORemap.R index ecf4fcdb..85603e53 100644 --- a/R/CDORemap.R +++ b/R/CDORemap.R @@ -60,7 +60,7 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, } } names(array_dims) <- c(new_lat_dim_name, new_lon_dim_name) - data_array <- array(NA, array_dims) + data_array <- array(as.numeric(NA), array_dims) } if (!(is.logical(data_array) || is.numeric(data_array)) || !is.array(data_array)) { stop("Parameter 'data_array' must be a numeric array.") @@ -498,6 +498,12 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, } names(attr(lons, 'variables')) <- lon_var_name names(attr(lats, 'variables')) <- lat_var_name + if (!is.null(attr(lons, 'variables')[[1]][['dim']])) { + attr(lons, 'variables')[[1]][['dim']] <- NULL + } + if (!is.null(attr(lats, 'variables')[[1]][['dim']])) { + attr(lats, 'variables')[[1]][['dim']] <- NULL + } lons_lats_taken <- FALSE for (i in 1:total_slices) { tmp_file <- tempfile('R_CDORemap_', write_dir, fileext = '.nc') -- GitLab