Skip to content
GitLab
Commits (152)
Hide whitespace changes
Inline Side-by-side
.Rbuildignore
View file @ 0450e139
.*\.git$
.*\.gitignore$
.*\.gitlab$
.*\.tar.gz$
.*\.pdf$
./.nc$
.*^(?!data)\.RData$
.*\.gitlab-ci.yml$
.lintr
^tests$
#^inst/doc$
^inst/doc/UseCase2_PrecipitationDownscaling_RainFARM_RF100\.R$
^inst/doc/UseCase1_WindEvent_March2018\.R$
^inst/doc/UseCase2_PrecipitationDownscaling_RainFARM_RF4\.R$
^inst/doc/UseCase3_data_preparation_SCHEME_model\.R$
^inst/doc/launch_UseCase2_PrecipitationDownscaling_RF4\.sh$
^inst/doc/usecase/UseCase2_PrecipitationDownscaling_RainFARM_RF100\.R$
^inst/doc/usecase/UseCase1_WindEvent_March2018\.R$
^inst/doc/usecase/UseCase2_PrecipitationDownscaling_RainFARM_RF4\.R$
^inst/doc/usecase/UseCase3_data_preparation_SCHEME_model\.R$
^inst/doc/usecase/launch_UseCase2_PrecipitationDownscaling_RF4\.sh$
.gitlab-ci.yml
View file @ 0450e139
......@@ -9,3 +9,10 @@ build:
- R CMD build --resave-data .
- R CMD check --as-cran --no-manual --run-donttest CSTools_*.tar.gz
- R -e 'covr::package_coverage()'
lint-check:
stage: build
script:
- module load R/4.1.2-foss-2015a-bare
- echo "Run lintr on the package..."
- Rscript -e 'lintr::lint_package(path = ".")'
.lintr 0 → 100644
View file @ 0450e139
linters: linters_with_tags( # lintr_3.1.1
tags = c("package_development", "readability", "best_practices"),
line_length_linter = line_length_linter(100L),
T_and_F_symbol_linter = NULL,
quotes_linter = NULL,
commented_code_linter = NULL,
implicit_integer_linter = NULL,
vector_logic_linter = NULL,
extraction_operator_linter = NULL,
function_left_parentheses_linter = NULL,
semicolon_linter = NULL,
indentation_linter = NULL,
unnecessary_nested_if_linter = NULL,
if_not_else_linter = NULL,
object_length_linter = NULL,
infix_spaces_linter(exclude_operators = "~")
)
exclusions: list(
"inst",
"R/AnalogsPred_train.R",
"R/BEI_PDFBest.R",
"R/BEI_Weights.R",
"R/CST_AdamontAnalog.R",
"R/CST_AdamontQQCorr.R",
"R/Analogs.R",
"R/CST_AnalogsPredictors.R",
"R/CST_BEI_Weighting.R",
"R/CST_CategoricalEnsCombination.R",
"R/CST_DynBiasCorrection.R",
"R/CST_EnsClustering.R",
"R/PlotCombinedMap.R",
"R/PlotForecastPDF.R",
"R/PlotMostLikelyQuantileMap.R",
"R/PlotPDFsOLE.R",
"R/PlotTriangles4Categories.R",
"R/PlotWeeklyClim.R",
"tests/testthat/",
"tests/testthat.R"
)
DESCRIPTION
View file @ 0450e139
Package: CSTools
Title: Assessing Skill of Climate Forecasts on Seasonal-to-Decadal Timescales
Version: 5.0.1
Version: 5.2.0
Authors@R: c(
person("Nuria", "Perez-Zanon", , "nuria.perez@bsc.es", role = "aut", comment = c(ORCID = "0000-0001-8568-3071")),
person("Louis-Philippe", "Caron", , "louis-philippe.caron@bsc.es", role = "aut", comment = c(ORCID = "0000-0001-5221-0147")),
......@@ -62,6 +62,7 @@ Depends:
easyVerification
Imports:
s2dv,
startR,
rainfarmr,
multiApply (>= 2.1.1),
ClimProjDiags,
......@@ -78,17 +79,17 @@ Imports:
utils,
verification,
lubridate,
scales
scales,
easyNCDF
Suggests:
zeallot,
testthat,
knitr,
markdown,
rmarkdown,
startR
rmarkdown
VignetteBuilder: knitr
License: GPL-3
Encoding: UTF-8
LazyData: true
RoxygenNote: 7.2.0
RoxygenNote: 7.2.3
Config/testthat/edition: 3
NAMESPACE
View file @ 0450e139
......@@ -19,6 +19,7 @@ export(CST_BEI_Weighting)
export(CST_BiasCorrection)
export(CST_Calibration)
export(CST_CategoricalEnsCombination)
export(CST_ChangeDimNames)
export(CST_DynBiasCorrection)
export(CST_EnsClustering)
export(CST_InsertDim)
......@@ -69,6 +70,7 @@ export(s2dv_cube)
export(training_analogs)
import(RColorBrewer)
import(abind)
import(easyNCDF)
import(ggplot2)
import(lubridate)
import(multiApply)
......
NEWS.md
View file @ 0450e139
# CSTools 5.2.0 (Release date: 25-01-2024)
### Development
- New function CST_ChangeDimNames
- CST_SplitDim: added dimension names and split also Dates
- CST_SaveExp: save time bounds and global attributes; improved code
### Other
- Updated README
- Added citation file
# CSTools 5.1.1 (Release date: 19-10-2023)
### Fixes
- Added startR namespace in all CST_Start calls of the vignettes and sample data.
# CSTools 5.1.0 (Release date: 17-10-2023)
### Fixes
- Calibration() show warnings in atomic function when multiple cores are used.
- PlotForecastPDF fix background color in different machines.
- Correct CST_Subset indices for metadata.
- CST_Analogs: Add sdate_dim parameter and improve initial checks.
- Remove CST_Anomaly repeated checks in order to accept no member dimensions in obs.
- CST_SaveExp developments: improve warning, save metadata correctly.
- Improve print method in order that time_bounds are correctly displayed.
### Development
- PlotWeeklyClim to allow years outside the reference period.
- PlotWeeklyClim to allow setting y limits.
- New function CST_Start().
- PlotCombinedMap() has upper triangle_end; the color bars can have different breaks.
- New print method.
- CST_MultiEOF development treat spatial NAs.
- Correct PlotCombinedMap error.
- Substitute mentions of CST_Load by CST_Start.
- Modify necessary vignettes to the use of CST_Start.
# CSTools 5.0.1 (Release date: 06-06-2023)
- Resubmit to CRAN because it was archived due to dependency issue
**Fixes**
### Fixes
- Standardize the coordinates of 's2dv_cube' by setting the coordinates to vectors with NULL dimensions
- Include a check for SaveExp output filenames that only contain date information
- In SaveExp the dates parameter is allowed to have additional time dimensions of length 1
- Removed dot from the internal function named mergedatasets() used in CST_CategoricalEnsCombination
**New Features**
### Development
- New parameter 'startdates' in CST_SaveExp used to manually decide the name of the output files
**Other**
### Other
- Switch to testthat version 3
# CSTools 5.0.0 (Release date: 05-04-2023)
**Fixes**
### Fixes
- Correct vignettes: Analogs, MultiModelSkill and MultivarRMSE
- Add 'ncores' to s2dv function calls in CST_Anomaly
- Reduce computing time of examples and tests and improve documentation
**New features**
### Development
- Add dat_dim parameter in CST_BiasCorrection and CST_Calibration
- New plotting function for case studies temporal visualisation: PlotWeeklyClim
- Deprecate indices in dim_anom parameter of CST_Anomaly
......@@ -31,26 +70,28 @@
- New color set in PlotForecastPDF Vitigeoss colors
- New function CST_InsertDim
**Other**
### Other
- Added contribution from ArticXchange project due to PlotWeeklyClim
- Update NEWS.md with the correct format
- Change Licence
# CSTools 4.1.1 (Release date: 10-11-2022)
**Fixes**
### Fixes
- CST_Analogs corrected input of ClimProjDiags::Subset()
- PlotCombinedMap corrected use of 'cex_bar_titles' parameter
- CST_Anomaly added 'memb_dim', 'dat_dim' and 'ftime_dim' and improved use for 'dim_anom' parameters
# CSTools 4.1.0 (Release date: 25-10-2022)
**New features**
# CSTools 4.1.0 (Release date: 25-10-2022)
### Development
- Dependency on package 's2dverification' is changed to 's2dv'
- CST_BiasCorrection new parameters 'memb_dim', 'sdate_dim', 'ncores'
- CST_Calibration is able to calibrate forecast with new parameter 'exp_cor'
- CST_QuantileMapping uses cross-validation and provides option to remove NAs; new parameters 'memb_dim', 'sdate_dim', 'window_dim' and 'na.rm'; 'sample_dim' and 'sample_length' are removed
- s2dv_cube() new parameter 'time_dim'
**Fixes**
### Fixes
- as.s2dv_cube() detects latitude and longitude structure in startR_array object
- Data correction: 'lonlat_data' is renamed to 'lonlat_temp'; 'lonlat_prec' is corrected by one-day shift
- Typo and parameter correction in vignette 'MostLikelyTercile_vignette'
......@@ -58,20 +99,22 @@
- PlotMostLikelyQuantileMap() works with s2dv::PlotLayout
# CSTools 4.0.1 (Release date: 05-10-2021)
**New features**
### Development
- Dynamical Bias Correction method: `CST_ProxiesAttractors` and `CST_DynBiasCorrection` (optionally `Predictability`)
- CST_BiasCorrection and BiasCorrection allows to calibrate a forecast given the calibration in the hindcast by using parameter 'exp_cor'
- Use cases
- CST_SaveExp includes parameter extra_string
- PlotCombinedMap includes parameter cex_bar_titles
**Fixes**
### Fixes
- Calibration retains correlation absolute value
- Calibration fixed when cal.methodi == rpc-based, apply_to == sign, eval.method == 'leave-one-out' and the correlation is not significant
- PlotMostLikelyQuantileMap reoder latitudes of an array provided in 'dots' parameter
# CSTools 4.0.0 (Release date: 23-02-2021)
**New features**
### Development
- ADAMONT downscaling method: requires CST_AdamontAnalogs and CST_AdamontQQCor functions
- Analogs method using Predictors: requires training_analogs and CST_AnalogsPredictors
- PlotPDFsOLE includes parameters to modify legend style
......@@ -88,7 +131,7 @@
- Analogs vignette
- Data Storage and retrieval vignette
**Fixes**
### Fixes
- PlotForecastPDF correctly displays terciles labels
- CST_SaveExp correctly save time units
- CST_SplitDims returns ordered output following ascending order provided in indices when it is numeric
......@@ -100,7 +143,8 @@
- Decrease package size compresing vignettes figures and removing areave_data sample
# CSTools 3.1.0 (Release date: 02-07-2020)
**New features**
### Development
- EnsClustering vignette
- EnsClustering has a new parameter 'time_dim'
- CST_BiasCorrection has na.rm paramter
......@@ -111,7 +155,7 @@
- CST_RFTemp/RF_Temp functions available for downscaling temperature
- Weather Regimes vignette
**Fixes**
### Fixes
- CST_Anomaly handles exp, obs or both
- PlotForecastPDF vignette displays figures correctly
- Calibration function is exposed to users
......@@ -123,17 +167,19 @@
- CST_SaveExp uses multiApply and save time dimension correctly
# CSTools 3.0.0 (Release date: 10-02-2020)
**New features**
### Development
- CST_MergeDims and MergeDims
- Version working with R 3.4.2
- PlotForecastPDF handles independent terciles, extremes and observations for each panel
**Fixes**
### Fixes
- CST_Calibration handles missing values
- BEI functions handle missing values
# CSTools 2.0.0 (Release date: 25-11-2019)
**New features**
# CSTools 2.0.0 (Release date: 25-11-2019)
### Development
- CST_Analogs Analogs downscaling method,
- CST_MultiEOFS for multiple variables,
- Ensemble Clustering,
......@@ -151,13 +197,14 @@
- Adding reference to S2S4E H2020 project into the DESCRIPTION file
- Adding NEWS.md file
**Fixes**
### Fixes
- Minor fix in CST_BiasCorrection when checking parameter 'obs'
- Minor fix in data lonlat_prec to be of class 's2dv_cube'
- Minor fix in RainFARM vignette
### CSTools 1.0.1 (Release date: 19-06-2019)
**Fixes and new features**
### Fixes and development
- Correcting test of PlotForecastPDF for compatibility with ggplot2 release
- New function PlotCombinedMap
- Adding reference to MEDSCOPE ERA4CS Project into the DESCRIPTION file
......
R/CST_Analogs.R
View file @ 0450e139
......@@ -24,7 +24,7 @@
#'This function has not constrains of specific regions, variables to downscale,
#'or data to be used (seasonal forecast data, climate projections data,
#'reanalyses data). The regrid into a finner scale is done interpolating with
#'CST_Load. Then, this interpolation is corrected selecting the analogs in the
#'CST_Start. Then, this interpolation is corrected selecting the analogs in the
#'large and local scale in based of the observations. The function is an
#'adapted version of the method of Yiou et al 2013. For an advanced search of
#'Analogs (multiple Analogs, different criterias, further information from the
......@@ -54,6 +54,8 @@
#' analog of parameter 'expVar'.
#'@param obsVar An 's2dv_cube' containing the field of the same variable as the
#' passed in parameter 'expVar' for the same region.
#'@param sdate_dim A character string indicating the name of the start date
#' dimension. By default, it is set to 'sdate'.
#'@param region A vector of length four indicating the minimum longitude, the
#' maximum longitude, the minimum latitude and the maximum latitude.
#'@param criteria A character string indicating the criteria to be used for the
......@@ -77,7 +79,8 @@
#' and dates are taken from element \code{$attrs$Dates} from expL.
#'@param time_obsL A character string indicating the date of the observations
#' in the date format (i.e. "yyyy-mm-dd"). By default it is NULL and dates are
#' taken from element \code{$attrs$Dates} from obsL.
#' taken from element \code{$attrs$Dates} from obsL. It must have time
#' dimensions.
#'@param region A vector of length four indicating the minimum longitude,
#' the maximum longitude, the minimum latitude and the maximum latitude.
#'@param nAnalogs Number of Analogs to be selected to apply the criterias
......@@ -101,8 +104,7 @@
#' best analog, for instance for downscaling.
#'@param ncores The number of cores to use in parallel computation
#'
#'@seealso \code{\link{CST_Load}}, \code{\link[s2dv]{Load}} and
#'\code{\link[s2dv]{CDORemap}}
#'@seealso \code{\link{CST_Start}}, \code{\link[startR]{Start}}
#'
#'@return An 's2dv_cube' object containing an array with the dowscaled values of
#'the best analogs in element 'data'. If 'AnalogsInfo' is TRUE, 'data' is a list
......@@ -117,6 +119,7 @@
#' format = "%d-%m-%y")
#'dim(time_obsL) <- c(time = 10)
#'time_expL <- time_obsL[1]
#'dim(time_expL) <- c(time = 1)
#'lon <- seq(-1, 5, 1.5)
#'lat <- seq(30, 35, 1.5)
#'coords <- list(lon = seq(-1, 5, 1.5), lat = seq(30, 35, 1.5))
......@@ -131,9 +134,11 @@
#'
#'@import multiApply
#'@import abind
#'@import s2dv
#'@importFrom ClimProjDiags SelBox Subset
#'@export
CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL,
CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL,
sdate_dim = 'sdate', region = NULL,
criteria = 'Large_dist', excludeTime = NULL,
time_expL = NULL, time_obsL = NULL,
nAnalogs = NULL, AnalogsInfo = FALSE,
......@@ -141,16 +146,13 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL,
# Check 's2dv_cube'
if (!inherits(expL, "s2dv_cube") || !inherits(obsL, "s2dv_cube")) {
stop("Parameter 'expL' and 'obsL' must be of the class 's2dv_cube', ",
"as output by CSTools::CST_Load.")
stop("Parameter 'expL' and 'obsL' must be of the class 's2dv_cube'.")
}
if (!is.null(expVar) && !inherits(expVar, "s2dv_cube")) {
stop("Parameter 'expVar' must be of the class 's2dv_cube', ",
"as output by CSTools::CST_Load.")
stop("Parameter 'expVar' must be of the class 's2dv_cube'.")
}
if (!is.null(obsVar) && !inherits(obsVar, "s2dv_cube")) {
stop("Parameter 'obsVar' must be of the class 's2dv_cube', ",
"as output by CSTools::CST_Load.")
stop("Parameter 'obsVar' must be of the class 's2dv_cube'.")
}
# Check 'obsL' object structure
......@@ -215,7 +217,8 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL,
lonL = as.vector(obsL$coords[[lon_name]]),
latL = as.vector(obsL$coords[[lat_name]]),
expVar = expVar$data,
obsVar = obsVar$data, criteria = criteria,
obsVar = obsVar$data, sdate_dim = sdate_dim,
criteria = criteria,
excludeTime = excludeTime, region = region,
lonVar = as.vector(lonVar), latVar = as.vector(latVar),
nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo,
......@@ -228,6 +231,7 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL,
}
expL$data <- res
expL$dims <- dim(res)
if (!is.null(obsL$coords[[lon_name]]) | !is.null(obsL$coords[[lat_name]])) {
if (is.null(region)) {
......@@ -285,7 +289,7 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL,
#'ones. This function has not constrains of specific regions, variables to
#'downscale, or data to be used (seasonal forecast data, climate projections
#'data, reanalyses data). The regrid into a finner scale is done interpolating
#'with CST_Load. Then, this interpolation is corrected selecting the analogs in
#'with CST_Start. Then, this interpolation is corrected selecting the analogs in
#'the large and local scale in based of the observations. The function is an
#'adapted version of the method of Yiou et al 2013.
#'
......@@ -308,10 +312,12 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL,
#' the same latitudinal and longitudinal dimensions as parameter 'expL' and a
#' single temporal dimension with the maximum number of available observations.
#'@param time_obsL A character string indicating the date of the observations
#' in the format "dd-mm-yyyy". Reference time to search for analogs.
#' in the format "dd-mm-yyyy". Reference time to search for analogs. It must
#' have time dimensions.
#'@param time_expL An array of N named dimensions (coinciding with time
#' dimensions in expL) of character string(s) indicating the date(s) of the
#' experiment in the format "dd-mm-yyyy". Time(s) to find the analogs.
#' experiment in the format "dd-mm-yyyy". Time(s) to find the analogs. If it
#' is not an scalar it must have named dimensions.
#'@param lonL A vector containing the longitude of parameter 'expL'.
#'@param latL A vector containing the latitude of parameter 'expL'.
#'@param excludeTime An array of N named dimensions (coinciding with time
......@@ -326,6 +332,8 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL,
#' function will be the analog of parameter 'expVar'.
#'@param obsVar An array of N named dimensions containing the field of the
#' same variable as the passed in parameter 'expVar' for the same region.
#'@param sdate_dim A character string indicating the name of the start date
#' dimension. By default, it is set to 'sdate'.
#'@param AnalogsInfo A logical value. If it is TRUE it returns a list
#' with two elements: 1) the downscaled field and
#' 2) the AnalogsInfo which contains: a) the number of the best
......@@ -372,6 +380,7 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL,
#'obsSLP <- c(rnorm(1:180), expSLP * 1.2)
#'dim(obsSLP) <- c(time = 10, lat = 4, lon = 5)
#'time_obsSLP <- paste(rep("01", 10), rep("01", 10), 1994 : 2003, sep = "-")
#'dim(time_obsSLP) <- c(time = 10)
#'downscale_field <- Analogs(expL = expSLP, obsL = obsSLP,
#' time_obsL = time_obsSLP,time_expL = "01-01-1994")
#'
......@@ -417,11 +426,12 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL,
#' AnalogsInfo = TRUE)
#'@import multiApply
#'@import abind
#'@import s2dv
#'@importFrom ClimProjDiags SelBox Subset
#'@export
Analogs <- function(expL, obsL, time_obsL, time_expL = NULL,
lonL = NULL, latL = NULL, expVar = NULL,
obsVar = NULL, criteria = "Large_dist",
lonL = NULL, latL = NULL, expVar = NULL, obsVar = NULL,
sdate_dim = 'sdate', criteria = "Large_dist",
excludeTime = NULL, lonVar = NULL, latVar = NULL,
region = NULL, nAnalogs = NULL,
AnalogsInfo = FALSE, ncores = NULL) {
......@@ -536,12 +546,61 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL,
}
if (!inherits(time_obsL, "character")) {
warning('imposing time_obsL to be a character')
dims_time_obsL <- dim(time_obsL)
time_obsL <- format(as.Date(time_obsL), '%d-%m-%Y')
dim(time_obsL) <- dims_time_obsL
}
if (!inherits(time_expL, "character")) {
warning('imposing time_expL to be a character')
dims_time_expL <- dim(time_expL)
time_expL <- format(as.Date(time_expL), '%d-%m-%Y')
dim(time_expL) <- dims_time_expL
}
# time_obsL, time_expL (2)
if (is.null(names(dim(time_obsL)))) {
stop("Parameter 'time_obsL' must have named dimensions.")
}
if (!is.character(sdate_dim)) {
stop("Parameter 'sdate_dim' must be a character string.")
}
if (!sdate_dim %in% names(dim(time_obsL))) {
if (length(dim(time_obsL)) == 1) {
dim(time_obsL) <- c(dim(time_obsL), sdate = 1)
} else {
stop("Parameters 'time_obsL' must have 'sdate_dim' dimension name. ",
"If it has multiple time dimensions.")
}
}
if (length(time_expL) != 1) {
if (is.null(names(dim(time_expL)))) {
stop("Parameter 'time_expL' must have named dimensions.")
}
} else {
dim(time_expL) <- 1
}
if (!sdate_dim %in% names(dim(time_expL))) {
if (length(dim(time_expL)) == 1) {
dim(time_expL) <- c(dim(time_expL), sdate = 1)
} else {
stop("Parameters 'time_expL' must have 'sdate_dim' dimension name. ",
"If it has multiple time dimensions.")
}
}
if (length(dim(time_obsL)) == 2) {
if (which(sdate_dim %in% names(dim(time_obsL))) == 1) {
time_obsL <- Reorder(time_obsL, c(2,1))
}
} else {
warning("Parameter 'time_obsL' should have forecast time and start date dimension in this order.")
}
if (length(dim(time_expL)) == 2) {
if (which(sdate_dim %in% names(dim(time_expL))) == 1) {
time_expL <- Reorder(time_expL, c(2,1))
}
} else {
warning("Parameter 'time_expL' should have forecast time and start date dimension in this order.")
}
# excludeTime
if (!is.null(excludeTime)) {
if (!inherits(excludeTime, "character")) {
......@@ -549,23 +608,7 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL,
excludeTime <- format(as.Date(excludeTime),'%d-%m-%Y')
}
}
# time_obsL
if (is.null(time_obsL)) {
stop("Parameter 'time_obsL' cannot be NULL")
}
if (any(names(dim(obsL)) %in% 'ftime')) {
if (any(names(dim(obsL)) %in% 'time')) {
stop("Multiple temporal dimensions ('ftime' and 'time') found",
"in parameter 'obsL'.")
} else {
time_pos_obsL <- which(names(dim(obsL)) == 'ftime')
names(dim(obsL))[time_pos_obsL] <- 'time'
if (any(names(dim(expL)) %in% 'ftime')) {
time_pos_expL <- which(names(dim(expL)) == 'ftime')
names(dim(expL))[time_pos_expL] <- 'time'
}
}
}
# obsVar, expVar
if (!is.null(obsVar)) {
if (any(names(dim(obsVar)) %in% 'ftime')) {
if (any(names(dim(obsVar)) %in% 'time')) {
......@@ -581,6 +624,20 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL,
}
}
}
# obsL
if (any(names(dim(obsL)) %in% 'ftime')) {
if (any(names(dim(obsL)) %in% 'time')) {
stop("Multiple temporal dimensions ('ftime' and 'time') found",
"in parameter 'obsL'.")
} else {
time_pos_obsL <- which(names(dim(obsL)) == 'ftime')
names(dim(obsL))[time_pos_obsL] <- 'time'
if (any(names(dim(expL)) %in% 'ftime')) {
time_pos_expL <- which(names(dim(expL)) == 'ftime')
names(dim(expL))[time_pos_expL] <- 'time'
}
}
}
if ((any(names(dim(obsL)) %in% 'sdate')) &&
(any(names(dim(obsL)) %in% 'time'))) {
dims_obsL <- dim(obsL)
......@@ -604,7 +661,7 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL,
if (any(names(dim(obsL)) %in% 'time')) {
dims_obsL <- dim(obsL)
pos_time <- which(names(dim(obsL)) == 'time')
if(length(time_obsL) != dim(obsL)[pos_time]) {
if (length(time_obsL) != dim(obsL)[pos_time]) {
stop("'time_obsL' and 'obsL' must have same length in the temporal
dimension.")
}
......@@ -618,6 +675,7 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL,
}
}
}
# obsVar
if (!is.null(obsVar)) {
if (any(names(dim(obsVar)) %in% 'sdate')) {
if (any(names(dim(obsVar)) %in% 'time')) {
......
R/CST_Anomaly.R
View file @ 0450e139
......@@ -9,10 +9,10 @@
#'computation is carried out independently for experimental and observational
#'data products.
#'
#'@param exp An object of class \code{s2dv_cube} as returned by \code{CST_Load}
#'@param exp An object of class \code{s2dv_cube} as returned by \code{CST_Start}
#' function, containing the seasonal forecast experiment data in the element
#' named \code{$data}.
#'@param obs An object of class \code{s2dv_cube} as returned by \code{CST_Load}
#'@param obs An object of class \code{s2dv_cube} as returned by \code{CST_Start}
#' function, containing the observed data in the element named \code{$data}.
#'@param dim_anom A character string indicating the name of the dimension
#' along which the climatology will be computed. The default value is 'sdate'.
......@@ -57,7 +57,7 @@
#'anom <- CST_Anomaly(exp = exp, obs = obs, cross = FALSE, memb = TRUE)
#'
#'@seealso \code{\link[s2dv]{Ano_CrossValid}}, \code{\link[s2dv]{Clim}} and
#'\code{\link{CST_Load}}
#'\code{\link{CST_Start}}
#'
#'@import multiApply
#'@importFrom s2dv InsertDim Clim Ano_CrossValid Reorder
......@@ -69,8 +69,7 @@ CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate',
# Check 's2dv_cube'
if (!inherits(exp, 's2dv_cube') & !is.null(exp) ||
!inherits(obs, 's2dv_cube') & !is.null(obs)) {
stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube', ",
"as output by CSTools::CST_Load.")
stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube'.")
}
# exp and obs
if (is.null(exp$data) & is.null(obs$data)) {
......@@ -91,13 +90,10 @@ CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate',
any(is.null(names(dim(obs$data))))| any(nchar(names(dim(obs$data))) == 0)) {
stop("Parameter 'exp' and 'obs' must have dimension names in element 'data'.")
}
if (!all(names(dim(exp$data)) %in% names(dim(obs$data))) |
!all(names(dim(obs$data)) %in% names(dim(exp$data)))) {
stop("Parameter 'exp' and 'obs' must have same dimension names in element 'data'.")
}
dim_exp <- dim(exp$data)
dim_obs <- dim(obs$data)
dimnames_data <- names(dim_exp)
dimnames_exp <- names(dim_exp)
dimnames_obs <- names(dim_obs)
# dim_anom
if (!is.character(dim_anom)) {
stop("Parameter 'dim_anom' must be a character string.")
......@@ -129,19 +125,12 @@ CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate',
if (!is.character(memb_dim) | length(memb_dim) > 1) {
stop("Parameter 'memb_dim' must be a character string.")
}
if (!memb_dim %in% names(dim_exp) | !memb_dim %in% names(dim_obs)) {
stop("Parameter 'memb_dim' is not found in 'exp' or in 'obs' dimension.")
}
}
# dat_dim
if (!is.null(dat_dim)) {
if (!is.character(dat_dim)) {
stop("Parameter 'dat_dim' must be a character vector.")
}
if (!all(dat_dim %in% names(dim_exp)) | !all(dat_dim %in% names(dim_obs))) {
stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension in element 'data'. ",
"Set it as NULL if there is no dataset dimension.")
}
}
# filter_span
if (!is.null(filter_span)) {
......@@ -161,7 +150,7 @@ CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate',
if (!is.character(ftime_dim)) {
stop("Parameter 'ftime_dim' must be a character string.")
}
if (!ftime_dim %in% names(dim_exp) | !memb_dim %in% names(dim_obs)) {
if (!ftime_dim %in% names(dim_exp) | !ftime_dim %in% names(dim_obs)) {
stop("Parameter 'ftime_dim' is not found in 'exp' or in 'obs' dimension in element 'data'.")
}
}
......@@ -206,15 +195,17 @@ CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate',
ano <- NULL
# Permuting back dimensions to original order
clim_exp <- Reorder(clim_exp, dimnames_data)
clim_obs <- Reorder(clim_obs, dimnames_data)
clim_exp <- Reorder(clim_exp, dimnames_exp)
clim_obs <- Reorder(clim_obs, dimnames_obs)
ano$exp <- exp$data - clim_exp
ano$obs <- obs$data - clim_obs
}
exp$data <- ano$exp
exp$dims <- dim(ano$exp)
obs$data <- ano$obs
obs$dims <- dim(ano$obs)
# Outputs
# ~~~~~~~~~
......
R/CST_BiasCorrection.R
View file @ 0450e139
......@@ -5,14 +5,14 @@
#'described in Torralba et al. (2017). The adjusted forecasts have an equivalent
#'standard deviation and mean to that of the reference dataset.
#'
#'@param exp An object of class \code{s2dv_cube} as returned by \code{CST_Load}
#'@param exp An object of class \code{s2dv_cube} as returned by \code{CST_Start}
#' function, containing the seasonal forecast experiment data in the element
#' named \code{$data} with at least time and member dimensions.
#'@param obs An object of class \code{s2dv_cube} as returned by \code{CST_Load}
#'@param obs An object of class \code{s2dv_cube} as returned by \code{CST_Start}
#' function, containing the observed data in the element named \code{$data}
#' with at least time dimension.
#'@param exp_cor An object of class \code{s2dv_cube} as returned by
#' \code{CST_Load} function, containing the seasonal forecast experiment to be
#' \code{CST_Start} function, containing the seasonal forecast experiment to be
#' corrected with at least time dimension. If it is NULL, the 'exp' forecast
#' will be corrected. If there is only one corrected dataset, it should not
#' have dataset dimension. If there is a corresponding corrected dataset for
......@@ -44,9 +44,9 @@
#'
#'@examples
#'mod1 <- 1 : (1 * 3 * 4 * 5 * 6 * 7)
#'dim(mod1) <- c(dataset = 1, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7)
#'dim(mod1) <- c(dataset = 1, member = 3, sdate = 4, time = 5, lat = 6, lon = 7)
#'obs1 <- 1 : (1 * 1 * 4 * 5 * 6 * 7)
#'dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7)
#'dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, time = 5, lat = 6, lon = 7)
#'lon <- seq(0, 30, 5)
#'lat <- seq(0, 25, 5)
#'coords <- list(lat = lat, lon = lon)
......@@ -134,9 +134,9 @@ CST_BiasCorrection <- function(exp, obs, exp_cor = NULL, na.rm = FALSE,
#'
#'@examples
#'mod1 <- 1 : (1 * 3 * 4 * 5 * 6 * 7)
#'dim(mod1) <- c(dataset = 1, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7)
#'dim(mod1) <- c(dataset = 1, member = 3, sdate = 4, time = 5, lat = 6, lon = 7)
#'obs1 <- 1 : (1 * 1 * 4 * 5 * 6 * 7)
#'dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7)
#'dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, time = 5, lat = 6, lon = 7)
#'a <- BiasCorrection(exp = mod1, obs = obs1)
#'@import multiApply
#'@export
......
R/CST_Calibration.R
View file @ 0450e139
......@@ -18,16 +18,16 @@
#'(2014). It is equivalent to function \code{Calibration} but for objects
#'of class \code{s2dv_cube}.
#'
#'@param exp An object of class \code{s2dv_cube} as returned by \code{CST_Load}
#'@param exp An object of class \code{s2dv_cube} as returned by \code{CST_Start}
#' function with at least 'sdate' and 'member' dimensions, containing the
#' seasonal hindcast experiment data in the element named \code{data}. The
#' hindcast is used to calibrate the forecast in case the forecast is provided;
#' if not, the same hindcast will be calibrated instead.
#'@param obs An object of class \code{s2dv_cube} as returned by \code{CST_Load}
#'@param obs An object of class \code{s2dv_cube} as returned by \code{CST_Start}
#' function with at least 'sdate' dimension, containing the observed data in
#' the element named \code{$data}.
#'@param exp_cor An optional object of class \code{s2dv_cube} as returned by
#' \code{CST_Load} function with at least 'sdate' and 'member' dimensions,
#' \code{CST_Start} function with at least 'sdate' and 'member' dimensions,
#' containing the seasonal forecast experiment data in the element named
#' \code{data}. If the forecast is provided, it will be calibrated using the
#' hindcast and observations; if not, the hindcast will be calibrated instead.
......@@ -106,7 +106,7 @@
#'Quarterly Journal of the Royal Meteorological Society, 141(688), 807-818.
#'\doi{10.1002/qj.2397}
#'
#'@seealso \code{\link{CST_Load}}
#'@seealso \code{\link{CST_Start}}
#'
#'@examples
#'# Example 1:
......@@ -287,7 +287,7 @@ CST_Calibration <- function(exp, obs, exp_cor = NULL, cal.method = "mse_min",
#'Quarterly Journal of the Royal Meteorological Society, 141(688), 807-818.
#'\doi{10.1002/qj.2397}
#'
#'@seealso \code{\link{CST_Load}}
#'@seealso \code{\link{CST_Start}}
#'
#'@examples
#'mod1 <- 1 : (1 * 3 * 4 * 5 * 6 * 7)
......
R/CST_ChangeDimNames.R 0 → 100644
View file @ 0450e139
#'Change the name of one or more dimensions for an object of class s2dv_cube
#'
#'Change the names of the dimensions specified in 'original_names' to the names
#'in 'new_names'. The coordinate names and the dimensions of any attributes
#'are also modified accordingly.
#'
#'@author Agudetse Roures Victoria, \email{victoria.agudetse@bsc.es}
#'
#'@param data An object of class \code{s2dv_cube} whose dimension names
#' should be changed.
#'@param original_names A single character string or a vector indicating the
#' dimensions to be renamed.
#'@param new_names A single character string or a vector indicating the new
#' dimension names, in the same order as the dimensions in 'original_names'.
#'
#'@return An object of class \code{s2dv_cube} with similar data, coordinates and
#'attributes as the \code{data} input, but with modified dimension names.
#'
#'@examples
#'# Example with sample data:
#'# Check original dimensions and coordinates
#'lonlat_temp$exp$dims
#'names(lonlat_temp$exp$coords)
#'dim(lonlat_temp$exp$attrs$Dates)
#'# Change 'dataset' to 'dat' and 'ftime' to 'time'
#'exp <- CST_ChangeDimNames(lonlat_temp$exp,
#' original_names = c("dataset", "ftime"),
#' new_names = c("dat", "time"))
#'# Check new dimensions and coordinates
#'exp$dims
#'names(exp$coords)
#'dim(exp$attrs$Dates)
#'
#'@export
CST_ChangeDimNames <- function(data, original_names, new_names) {
if (!inherits(data, "s2dv_cube")) {
stop("Parameter 'data' must be an object of class 's2dv_cube'.")
}
if (!is.character(original_names)) {
stop("Parameter 'original_names' must be a character string or a ",
"vector of character strings.")
}
if (!is.character(new_names)) {
stop("Parameter 'new_names' must be a character string or a ",
"vector of character strings.")
}
if (!(length(original_names) == length(new_names))) {
stop("The number of dimension names in 'new_names' must be the same ",
"as in 'original_names'.")
}
if (!all(original_names %in% names(data$dims))) {
stop("Some of the dimensions in 'original_names' could not be found in ",
"'data'.")
}
for (index in 1:length(original_names)) {
original_name <- original_names[index]
new_name <- new_names[index]
# Step 1: Change dims
names(data$dims)[which(names(data$dims) == original_name)] <- new_name
# Step 2: Change coords
names(data$coords)[which(names(data$coords) == original_name)] <- new_name
# Step 3: Change attrs
# 3.1 - Dates
if (original_name %in% names(dim(data$attrs$Dates))) {
names(dim(data$attrs$Dates))[which(names(dim(data$attrs$Dates))
== original_name)] <- new_name
}
# 3.2 - Variable metadata
if (original_name %in% names(data$attrs$Variable$metadata)) {
names(data$attrs$Variable$metadata)[which(names(data$attrs$Variable$metadata)
== original_name)] <- new_name
}
# 3.3 - Source files
if (original_name %in% names(dim(data$attrs$source_files))) {
names(dim(data$attrs$source_files))[which(names(dim(data$attrs$source_files))
== original_name)] <- new_name
}
}
# Change data dimnames after renaming all dimensions
dim(data$data) <- data$dims
if (!is.null(attributes(data$data)$dimensions)) {
attributes(data$data)$dimensions <- names(data$dims)
}
# Change $Dates 'dim' attribute
attr(attributes(data$attrs$Dates)$dim, "names") <- names(dim(data$attrs$Dates))
return(data)
}
R/CST_MergeDims.R
View file @ 0450e139
......@@ -15,8 +15,6 @@
#' \code{merge_dims} will be used.
#'@param na.rm A logical indicating if the NA values should be removed or not.
#'
#'@import abind
#'@importFrom ClimProjDiags Subset
#'@examples
#'data <- 1 : c(2 * 3 * 4 * 5 * 6 * 7)
#'dim(data) <- c(time = 7, lat = 2, lon = 3, monthly = 4, member = 6,
......@@ -33,11 +31,35 @@ CST_MergeDims <- function(data, merge_dims = c('ftime', 'monthly'),
rename_dim = NULL, na.rm = FALSE) {
# Check 's2dv_cube'
if (!inherits(data, 's2dv_cube')) {
stop("Parameter 'data' must be of the class 's2dv_cube', ",
"as output by CSTools::CST_Load.")
stop("Parameter 'data' must be of the class 's2dv_cube'.")
}
if (is.null(rename_dim)) {
rename_dim <- merge_dims[1]
}
# data
data$data <- MergeDims(data$data, merge_dims = merge_dims,
rename_dim = rename_dim, na.rm = na.rm)
# dims
data$dims <- dim(data$data)
# rename_dim
if (length(rename_dim) > 1) {
rename_dim <- as.character(rename_dim[1])
}
# coords
data$coords[merge_dims] <- NULL
data$coords[[rename_dim]] <- 1:dim(data$data)[rename_dim]
attr(data$coords[[rename_dim]], 'indices') <- TRUE
# attrs
if (all(merge_dims %in% names(dim(data$attrs$Dates)))) {
data$attrs$Dates <- MergeDims(data$attrs$Dates, merge_dims = merge_dims,
rename_dim = rename_dim, na.rm = na.rm)
} else if (any(merge_dims %in% names(dim(data$attrs$Dates)))) {
warning("The dimensions of 'Dates' array will be different from ",
"the temporal dimensions in 'data'. Parameter 'merge_dims' ",
"only includes one temporal dimension of 'Dates'.")
}
return(data)
}
#'Function to Split Dimension
......@@ -56,12 +78,12 @@ CST_MergeDims <- function(data, merge_dims = c('ftime', 'monthly'),
#' \code{merge_dims} will be used.
#'@param na.rm A logical indicating if the NA values should be removed or not.
#'
#'@import abind
#'@importFrom ClimProjDiags Subset
#'@examples
#'data <- 1 : 20
#'dim(data) <- c(time = 10, lat = 2)
#'new_data <- MergeDims(data, merge_dims = c('time', 'lat'))
#'@import abind
#'@importFrom ClimProjDiags Subset
#'@export
MergeDims <- function(data, merge_dims = c('time', 'monthly'),
rename_dim = NULL, na.rm = FALSE) {
......
R/CST_QuantileMapping.R
View file @ 0450e139
......@@ -58,13 +58,11 @@ CST_QuantileMapping <- function(exp, obs, exp_cor = NULL, sdate_dim = 'sdate',
ncores = NULL, ...) {
# Check 's2dv_cube'
if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')) {
stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube', ",
"as output by CSTools::CST_Load.")
stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube'.")
}
if (!is.null(exp_cor)) {
if (!inherits(exp_cor, 's2dv_cube')) {
stop("Parameter 'exp_cor' must be of the class 's2dv_cube', ",
"as output by CSTools::CST_Load.")
stop("Parameter 'exp_cor' must be of the class 's2dv_cube'.")
}
}
......
R/CST_RFTemp.R
View file @ 0450e139
......@@ -144,7 +144,7 @@ CST_RFTemp <- function(data, oro, xlim = NULL, ylim = NULL, lapse = 6.5,
#'The output grid can be irregularly spaced in lon and/or lat.
#'@references Method described in ERA4CS MEDSCOPE milestone M3.2:
#'High-quality climate prediction data available to WP4 here:
#'\ url{https://www.medscope-project.eu/the-project/deliverables-reports/}
#'\url{https://www.medscope-project.eu/the-project/deliverables-reports/}
#'and in H2020 ECOPOTENTIAL Deliverable No. 8.1:
#'High resolution (1-10 km) climate, land use and ocean change scenarios here:
#'\url{https://ec.europa.eu/research/participants/documents/downloadPublic?documentIds=080166e5b6cd2324&appId=PPGMS}.
......
R/CST_SaveExp.R
View file @ 0450e139
......@@ -4,64 +4,88 @@
#'
#'@description This function allows to divide and save a object of class
#''s2dv_cube' into a NetCDF file, allowing to reload the saved data using
#'\code{Start} function from StartR package. If the original 's2dv_cube' object
#'has been created from \code{CST_Load()}, then it can be reloaded with
#'\code{Load()}.
#'\code{CST_Start} or \code{CST_Load} functions. It also allows to save any
#''s2dv_cube' object that follows the NetCDF attributes conventions.
#'
#'@param data An object of class \code{s2dv_cube}.
#'@param destination A character string containing the directory name in which
#' to save the data. NetCDF file for each starting date are saved into the
#' folder tree: \cr
#' destination/Dataset/variable/. By default the function
#' creates and saves the data into the working directory.
#' folder tree: 'destination/Dataset/variable/'. By default the function
#' saves the data into the working directory.
#'@param sdate_dim A character string indicating the name of the start date
#' dimension. By default, it is set to 'sdate'. It can be NULL if there is no
#' start date dimension.
#'@param ftime_dim A character string indicating the name of the forecast time
#' dimension. By default, it is set to 'time'. It can be NULL if there is no
#' forecast time dimension.
#' dimension. If 'Dates' are used, it can't be NULL. If there is no forecast
#' time dimension, 'Dates' will be set to NULL and will not be used. By
#' default, it is set to 'time'.
#'@param dat_dim A character string indicating the name of dataset dimension.
#' By default, it is set to 'dataset'. It can be NULL if there is no dataset
#' dimension.
#' It can be NULL if there is no dataset dimension. By default, it is set to
#' 'dataset'.
#'@param var_dim A character string indicating the name of variable dimension.
#' By default, it is set to 'var'. It can be NULL if there is no variable
#' dimension.
#'@param memb_dim A character string indicating the name of the member dimension.
#' By default, it is set to 'member'. It can be NULL if there is no member
#' dimension.
#' It can be NULL if there is no variable dimension. By default, it is set to
#' 'var'.
#'@param memb_dim A character string indicating the name of the member
#' dimension. It can be NULL if there is no member dimension. By default, it is
#' set to 'member'.
#'@param startdates A vector of dates that will be used for the filenames
#' when saving the data in multiple files. It must be a vector of the same
#' length as the start date dimension of data. It must be a vector of class
#' \code{Dates}, \code{'POSIXct'} or character with lenghts between 1 and 10.
#' If it is NULL, the coordinate corresponding the the start date dimension or
#' the first Date of each time step will be used as the name of the files.
#' It is NULL by default.
#' when saving the data in multiple files (single_file = FALSE). It must be a
#' vector of the same length as the start date dimension of data. It must be a
#' vector of class \code{Dates}, \code{'POSIXct'} or character with lenghts
#' between 1 and 10. If it is NULL, the coordinate corresponding the the start
#' date dimension or the first Date of each time step will be used as the name
#' of the files. It is NULL by default.
#'@param single_file A logical value indicating if all object is saved in a
#' single file (TRUE) or in multiple files (FALSE). When it is FALSE,
#' the array is separated for Datasets, variable and start date. It is FALSE
#' by default.
#'@param extra_string A character string to be include as part of the file name,
#' for instance, to identify member or realization. It would be added to the
#' file name between underscore characters.
#' the array is separated for datasets, variable and start date. When there are
#' no specified time dimensions, the data will be saved in a single file by
#' default. The output file name when 'single_file' is TRUE is a character
#' string containing: '<var>_<first_sdate>_<last_sdate>.nc'; when it is FALSE,
#' it is '<var>_<sdate>.nc'. It is FALSE by default.
#'@param drop_dims (optional) A vector of character strings indicating the
#' dimension names of length 1 that need to be dropped in order that they don't
#' appear in the netCDF file. Only is allowed to drop dimensions that are not
#' used in the computation. The dimensions used in the computation are the ones
#' specified in: sdate_dim, ftime_dim, dat_dim, var_dim and memb_dim. It is
#' NULL by default.
#'@param extra_string (Optional) A character string to be included as part of
#' the file name, for instance, to identify member or realization. When
#' single_file is TRUE, the 'extra_string' will substitute all the default
#' file name; when single_file is FALSE, the 'extra_string' will be added
#' in the file name as: '<var>_<extra_string>_<sdate>.nc'. It is NULL by
#' default.
#'@param units_hours_since (Optional) A logical value only available for the
#' case: 'Dates' have forecast time and start date dimension, 'single_file' is
#' TRUE and 'time_bounds' are not used. When it is TRUE, it saves the forecast
#' time with units of 'hours since'; if it is FALSE, the time units will be a
#' number of time steps with its corresponding frequency (e.g. n days, n months
#' or n hours). It is FALSE by default.
#'@param global_attrs (Optional) A list with elements containing the global
#' attributes to be saved in the NetCDF.
#'
#'@return Multiple or single NetCDF files containing the data array.\cr
#'\item{\code{single_file = TRUE}}{
#'\item{\code{single_file is TRUE}}{
#' All data is saved in a single file located in the specified destination
#' path with the following name:
#' <variable_name>_<extra_string>_<first_sdate>_<last_sdate>.nc. Multiple
#' variables are saved separately in the same file. The forecast time units
#' is extracted from the frequency of the time steps (hours, days, months).
#' The first value of forecast time is 1. If no frequency is found, the units
#' will be 'hours since' each start date and the time steps are assumed to be
#' equally spaced.
#' path with the following name (by default):
#' '<variable_name>_<first_sdate>_<last_sdate>.nc'. Multiple variables
#' are saved separately in the same file. The forecast time units
#' are calculated from each start date (if sdate_dim is not NULL) or from
#' the time step. If 'units_hours_since' is TRUE, the forecast time units
#' will be 'hours since <each start date>'. If 'units_hours_since' is FALSE,
#' the forecast time units are extracted from the frequency of the time steps
#' (hours, days, months); if no frequency is found, the units will be ’hours
#' since’. When the time units are 'hours since' the time ateps are assumed to
#' be equally spaced.
#'}
#'\item{\code{single_file = FALSE}}{
#'\item{\code{single_file is FALSE}}{
#' The data array is subset and stored into multiple files. Each file
#' contains the data subset for each start date, variable and dataset. Files
#' with different variables and Datasets are stored in separated directories
#' within the following directory tree: destination/Dataset/variable/.
#' The name of each file will be:
#' <variable_name>_<extra_string>_<sdate>.nc.
#' with different variables and datasets are stored in separated directories
#' within the following directory tree: 'destination/Dataset/variable/'.
#' The name of each file will be by default: '<variable_name>_<sdate>.nc'.
#' The forecast time units are calculated from each start date (if sdate_dim
#' is not NULL) or from the time step. The forecast time units will be 'hours
#' since <each start date>'.
#'}
#'
#'@seealso \code{\link[startR]{Start}}, \code{\link{as.s2dv_cube}} and
......@@ -69,26 +93,21 @@
#'
#'@examples
#'\dontrun{
#'data <- lonlat_temp$exp
#'destination <- "./"
#'CST_SaveExp(data = data, destination = destination, ftime_dim = 'ftime',
#' var_dim = NULL, ftime_dim = 'ftime', var_dim = NULL)
#'data <- lonlat_temp_st$exp
#'CST_SaveExp(data = data, ftime_dim = 'ftime', var_dim = 'var',
#' dat_dim = 'dataset', sdate_dim = 'sdate')
#'}
#'
#'@import ncdf4
#'@importFrom s2dv Reorder
#'@importFrom ClimProjDiags Subset
#'@import multiApply
#'@export
CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate',
ftime_dim = 'time', dat_dim = 'dataset',
var_dim = 'var', memb_dim = 'member',
startdates = NULL, single_file = FALSE,
extra_string = NULL) {
CST_SaveExp <- function(data, destination = "./", startdates = NULL,
sdate_dim = 'sdate', ftime_dim = 'time',
memb_dim = 'member', dat_dim = 'dataset',
var_dim = 'var', drop_dims = NULL,
single_file = FALSE, extra_string = NULL,
global_attrs = NULL, units_hours_since = FALSE) {
# Check 's2dv_cube'
if (!inherits(data, 's2dv_cube')) {
stop("Parameter 'data' must be of the class 's2dv_cube', ",
"as output by CSTools::CST_Load.")
stop("Parameter 'data' must be of the class 's2dv_cube'.")
}
# Check object structure
if (!all(c('data', 'attrs') %in% names(data))) {
......@@ -98,22 +117,11 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate',
if (!inherits(data$attrs, 'list')) {
stop("Level 'attrs' must be a list with at least 'Dates' element.")
}
if (!all(c('coords') %in% names(data))) {
warning("Element 'coords' not found. No coordinates will be used.")
}
# metadata
if (is.null(data$attrs$Variable$metadata)) {
warning("No metadata found in element Variable from attrs.")
} else {
if (!is.null(data$attrs$Variable$metadata)) {
if (!inherits(data$attrs$Variable$metadata, 'list')) {
stop("Element metadata from Variable element in attrs must be a list.")
}
if (!any(names(data$attrs$Variable$metadata) %in% names(data$coords))) {
warning("Metadata is not found for any coordinate.")
} else if (!any(names(data$attrs$Variable$metadata) %in%
data$attrs$Variable$varName)) {
warning("Metadata is not found for any variable.")
}
}
# Dates
if (is.null(data$attrs$Dates)) {
......@@ -127,49 +135,31 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate',
if (!is.character(sdate_dim)) {
stop("Parameter 'sdate_dim' must be a character string.")
}
if (length(sdate_dim) > 1) {
warning("Parameter 'sdate_dim' has length greater than 1 and ",
"only the first element will be used.")
sdate_dim <- sdate_dim[1]
}
} else if (length(dim(data$attrs$Dates)) == 1) {
sdate_dim <- 'sdate'
dim(data$data) <- c(sdate = 1, dim(data$data))
data$dims <- dim(data$data)
dim(data$attrs$Dates) <- c(sdate = 1, dim(data$attrs$Dates))
data$coords[[sdate_dim]] <- data$attrs$Dates[1]
}
# startdates
if (is.null(startdates)) {
startdates <- data$coords[[sdate_dim]]
} else {
if (!is.character(startdates)) {
warning(paste0("Parameter 'startdates' is not a character string, ",
"it will not be used."))
if (is.character(data$coords[[sdate_dim]])) {
startdates <- data$coords[[sdate_dim]]
}
if (!is.null(sdate_dim)) {
if (dim(data$data)[sdate_dim] != length(startdates)) {
warning(paste0("Parameter 'startdates' doesn't have the same length ",
"as dimension '", sdate_dim,"', it will not be used."))
startdates <- data$coords[[sdate_dim]]
}
}
}
SaveExp(data = data$data,
destination = destination,
Dates = data$attrs$Dates,
coords = data$coords,
Dates = data$attrs$Dates,
time_bounds = data$attrs$time_bounds,
startdates = startdates,
varname = data$attrs$Variable$varName,
metadata = data$attrs$Variable$metadata,
Datasets = data$attrs$Datasets,
startdates = startdates,
dat_dim = dat_dim, sdate_dim = sdate_dim,
ftime_dim = ftime_dim, var_dim = var_dim,
memb_dim = memb_dim,
sdate_dim = sdate_dim, ftime_dim = ftime_dim,
memb_dim = memb_dim,
dat_dim = dat_dim, var_dim = var_dim,
drop_dims = drop_dims,
single_file = single_file,
extra_string = extra_string,
single_file = single_file)
global_attrs = global_attrs,
units_hours_since = units_hours_since)
}
#'Save a multidimensional array with metadata to data in NetCDF format
#'@description This function allows to save a data array with metadata into a
......@@ -182,13 +172,26 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate',
#'@param data A multi-dimensional array with named dimensions.
#'@param destination A character string indicating the path where to store the
#' NetCDF files.
#'@param Dates A named array of dates with the corresponding sdate and forecast
#' time dimension.
#'@param coords A named list with elements of the coordinates corresponding to
#' the dimensions of the data parameter. The names and length of each element
#' must correspond to the names of the dimensions. If any coordinate is not
#' provided, it is set as an index vector with the values from 1 to the length
#' of the corresponding dimension.
#'@param Dates A named array of dates with the corresponding sdate and forecast
#' time dimension. If there is no sdate_dim, you can set it to NULL.
#' It must have ftime_dim dimension.
#'@param time_bounds (Optional) A list of two arrays of dates containing
#' the lower (first array) and the upper (second array) time bounds
#' corresponding to Dates. Each array must have the same dimensions as Dates.
#' If 'Dates' parameter is NULL, 'time_bounds' are not used. It is NULL by
#' default.
#'@param startdates A vector of dates that will be used for the filenames
#' when saving the data in multiple files (single_file = FALSE). It must be a
#' vector of the same length as the start date dimension of data. It must be a
#' vector of class \code{Dates}, \code{'POSIXct'} or character with lenghts
#' between 1 and 10. If it is NULL, the coordinate corresponding the the start
#' date dimension or the first Date of each time step will be used as the name
#' of the files. It is NULL by default.
#'@param varname A character string indicating the name of the variable to be
#' saved.
#'@param metadata A named list where each element is a variable containing the
......@@ -196,12 +199,6 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate',
#' lists for each variable.
#'@param Datasets A vector of character string indicating the names of the
#' datasets.
#'@param startdates A vector of dates that will be used for the filenames
#' when saving the data in multiple files. It must be a vector of the same
#' length as the start date dimension of data. It must be a vector of class
#' \code{Dates}, \code{'POSIXct'} or character with lenghts between 1 and 10.
#' If it is NULL, the first Date of each time step will be used as the name of
#' the files. It is NULL by default.
#'@param sdate_dim A character string indicating the name of the start date
#' dimension. By default, it is set to 'sdate'. It can be NULL if there is no
#' start date dimension.
......@@ -214,64 +211,89 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate',
#'@param var_dim A character string indicating the name of variable dimension.
#' By default, it is set to 'var'. It can be NULL if there is no variable
#' dimension.
#'@param memb_dim A character string indicating the name of the member dimension.
#' By default, it is set to 'member'. It can be NULL if there is no member
#' dimension.
#'@param memb_dim A character string indicating the name of the member
#' dimension. By default, it is set to 'member'. It can be NULL if there is no
#' member dimension.
#'@param drop_dims (optional) A vector of character strings indicating the
#' dimension names of length 1 that need to be dropped in order that they don't
#' appear in the netCDF file. Only is allowed to drop dimensions that are not
#' used in the computation. The dimensions used in the computation are the ones
#' specified in: sdate_dim, ftime_dim, dat_dim, var_dim and memb_dim. It is
#' NULL by default.
#'@param single_file A logical value indicating if all object is saved in a
#' unique file (TRUE) or in separated directories (FALSE). When it is FALSE,
#' the array is separated for Datasets, variable and start date. It is FALSE
#' by default.
#'@param extra_string A character string to be include as part of the file name,
#' for instance, to identify member or realization. It would be added to the
#' file name between underscore characters.
#' single file (TRUE) or in multiple files (FALSE). When it is FALSE,
#' the array is separated for datasets, variable and start date. When there are
#' no specified time dimensions, the data will be saved in a single file by
#' default. The output file name when 'single_file' is TRUE is a character
#' string containing: '<var>_<first_sdate>_<last_sdate>.nc'; when it is FALSE,
#' it is '<var>_<sdate>.nc'. It is FALSE by default.
#'@param extra_string (Optional) A character string to be included as part of
#' the file name, for instance, to identify member or realization. When
#' single_file is TRUE, the 'extra_string' will substitute all the default
#' file name; when single_file is FALSE, the 'extra_string' will be added
#' in the file name as: '<var>_<extra_string>_<sdate>.nc'. It is NULL by
#' default.
#'@param global_attrs (Optional) A list with elements containing the global
#' attributes to be saved in the NetCDF.
#'@param units_hours_since (Optional) A logical value only available for the
#' case: Dates have forecast time and start date dimension, single_file is
#' TRUE and 'time_bounds' is NULL. When it is TRUE, it saves the forecast time
#' with units of 'hours since'; if it is FALSE, the time units will be a number
#' of time steps with its corresponding frequency (e.g. n days, n months or n
#' hours). It is FALSE by default.
#'
#'@return Multiple or single NetCDF files containing the data array.\cr
#'\item{\code{single_file = TRUE}}{
#'\item{\code{single_file is TRUE}}{
#' All data is saved in a single file located in the specified destination
#' path with the following name:
#' <variable_name>_<extra_string>_<first_sdate>_<last_sdate>.nc. Multiple
#' variables are saved separately in the same file. The forecast time units
#' is extracted from the frequency of the time steps (hours, days, months).
#' The first value of forecast time is 1. If no frequency is found, the units
#' will be 'hours since' each start date and the time steps are assumed to be
#' equally spaced.
#' path with the following name (by default):
#' '<variable_name>_<first_sdate>_<last_sdate>.nc'. Multiple variables
#' are saved separately in the same file. The forecast time units
#' are calculated from each start date (if sdate_dim is not NULL) or from
#' the time step. If 'units_hours_since' is TRUE, the forecast time units
#' will be 'hours since <each start date>'. If 'units_hours_since' is FALSE,
#' the forecast time units are extracted from the frequency of the time steps
#' (hours, days, months); if no frequency is found, the units will be ’hours
#' since’. When the time units are 'hours since' the time ateps are assumed to
#' be equally spaced.
#'}
#'\item{\code{single_file = FALSE}}{
#'\item{\code{single_file is FALSE}}{
#' The data array is subset and stored into multiple files. Each file
#' contains the data subset for each start date, variable and dataset. Files
#' with different variables and Datasets are stored in separated directories
#' within the following directory tree: destination/Dataset/variable/.
#' The name of each file will be:
#' <variable_name>_<extra_string>_<sdate>.nc.
#' with different variables and datasets are stored in separated directories
#' within the following directory tree: 'destination/Dataset/variable/'.
#' The name of each file will be by default: '<variable_name>_<sdate>.nc'.
#' The forecast time units are calculated from each start date (if sdate_dim
#' is not NULL) or from the time step. The forecast time units will be 'hours
#' since <each start date>'.
#'}
#'
#'@examples
#'\dontrun{
#'data <- lonlat_temp$exp$data
#'lon <- lonlat_temp$exp$coords$lon
#'lat <- lonlat_temp$exp$coords$lat
#'data <- lonlat_temp_st$exp$data
#'lon <- lonlat_temp_st$exp$coords$lon
#'lat <- lonlat_temp_st$exp$coords$lat
#'coords <- list(lon = lon, lat = lat)
#'Datasets <- lonlat_temp$exp$attrs$Datasets
#'Datasets <- lonlat_temp_st$exp$attrs$Datasets
#'varname <- 'tas'
#'Dates <- lonlat_temp$exp$attrs$Dates
#'destination = './'
#'metadata <- lonlat_temp$exp$attrs$Variable$metadata
#'SaveExp(data = data, destination = destination, coords = coords,
#' Datasets = Datasets, varname = varname, Dates = Dates,
#' metadata = metadata, single_file = TRUE, ftime_dim = 'ftime',
#' var_dim = NULL)
#'Dates <- lonlat_temp_st$exp$attrs$Dates
#'metadata <- lonlat_temp_st$exp$attrs$Variable$metadata
#'SaveExp(data = data, coords = coords, Datasets = Datasets, varname = varname,
#' Dates = Dates, metadata = metadata, single_file = TRUE,
#' ftime_dim = 'ftime', var_dim = 'var', dat_dim = 'dataset')
#'}
#'
#'@import ncdf4
#'@import easyNCDF
#'@importFrom s2dv Reorder
#'@import multiApply
#'@importFrom ClimProjDiags Subset
#'@export
SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
SaveExp <- function(data, destination = "./", coords = NULL,
Dates = NULL, time_bounds = NULL, startdates = NULL,
varname = NULL, metadata = NULL, Datasets = NULL,
startdates = NULL, dat_dim = 'dataset', sdate_dim = 'sdate',
ftime_dim = 'time', var_dim = 'var', memb_dim = 'member',
single_file = FALSE, extra_string = NULL) {
sdate_dim = 'sdate', ftime_dim = 'time',
memb_dim = 'member', dat_dim = 'dataset', var_dim = 'var',
drop_dims = NULL, single_file = FALSE, extra_string = NULL,
global_attrs = NULL, units_hours_since = FALSE) {
## Initial checks
# data
if (is.null(data)) {
......@@ -281,45 +303,47 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
if (is.null(dimnames)) {
stop("Parameter 'data' must be an array with named dimensions.")
}
if (!is.null(attributes(data)$dimensions)) {
attributes(data)$dimensions <- NULL
}
# destination
if (!is.character(destination) | length(destination) > 1) {
stop("Parameter 'destination' must be a character string of one element ",
"indicating the name of the file (including the folder if needed) ",
"where the data will be saved.")
}
# Dates
if (!is.null(Dates)) {
if (!inherits(Dates, "POSIXct") & !inherits(Dates, "Date")) {
stop("Parameter 'Dates' must be of 'POSIXct' or 'Dates' class.")
}
if (is.null(dim(Dates))) {
stop("Parameter 'Dates' must have dimension names.")
# drop_dims
if (!is.null(drop_dims)) {
if (!is.character(drop_dims) | any(!drop_dims %in% names(dim(data)))) {
warning("Parameter 'drop_dims' must be character string containing ",
"the data dimension names to be dropped. It will not be used.")
} else if (!all(dim(data)[drop_dims] %in% 1)) {
warning("Parameter 'drop_dims' can only contain dimension names ",
"that are of length 1. It will not be used.")
} else if (any(drop_dims %in% c(ftime_dim, sdate_dim, dat_dim, memb_dim, var_dim))) {
warning("Parameter 'drop_dims' contains dimensions used in the computation. ",
"It will not be used.")
drop_dims <- NULL
} else {
data <- Subset(x = data, along = drop_dims,
indices = lapply(1:length(drop_dims), function(x) 1),
drop = 'selected')
dimnames <- names(dim(data))
}
}
# coords
if (!is.null(coords)) {
if (!all(names(coords) %in% dimnames)) {
coords <- coords[-which(!names(coords) %in% dimnames)]
}
for (i_coord in dimnames) {
if (i_coord %in% names(coords)) {
if (length(coords[[i_coord]]) != dim(data)[i_coord]) {
warning(paste0("Coordinate '", i_coord, "' has different lenght as ",
"its dimension and it will not be used."))
coords[[i_coord]] <- 1:dim(data)[i_coord]
}
} else {
warning(paste0("Coordinate '", i_coord, "' is not provided ",
"and it will be set as index in element coords."))
coords[[i_coord]] <- 1:dim(data)[i_coord]
}
if (!inherits(coords, 'list')) {
stop("Parameter 'coords' must be a named list of coordinates.")
}
if (is.null(names(coords))) {
stop("Parameter 'coords' must have names corresponding to coordinates.")
}
} else {
coords <- sapply(dimnames, function(x) 1:dim(data)[x])
}
# varname
if (is.null(varname)) {
warning("Parameter 'varname' is NULL. It will be assigned to 'X'.")
varname <- 'X'
} else if (length(varname) > 1) {
multiple_vars <- TRUE
......@@ -330,11 +354,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
stop("Parameter 'varname' must be a character string with the ",
"variable names.")
}
# metadata
if (is.null(metadata)) {
warning("Parameter 'metadata' is not provided so the metadata saved ",
"will be incomplete.")
}
# single_file
if (!inherits(single_file, 'logical')) {
warning("Parameter 'single_file' must be a logical value. It will be ",
......@@ -347,27 +366,22 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
stop("Parameter 'extra_string' must be a character string.")
}
}
# global_attrs
if (!is.null(global_attrs)) {
if (!inherits(global_attrs, 'list')) {
stop("Parameter 'global_attrs' must be a list.")
}
}
## Dimensions checks
# Spatial coordinates
if (!any(dimnames %in% .KnownLonNames()) |
!any(dimnames %in% .KnownLatNames())) {
warning("Spatial coordinates not found.")
lon_dim <- NULL
lat_dim <- NULL
} else {
lon_dim <- dimnames[which(dimnames %in% .KnownLonNames())]
lat_dim <- dimnames[which(dimnames %in% .KnownLatNames())]
if (length(lon_dim) > 1) {
warning("Found more than one longitudinal dimension. Only the first one ",
"will be used.")
lon_dim <- lon_dim[1]
}
if (length(lat_dim) > 1) {
warning("Found more than one latitudinal dimension. Only the first one ",
"will be used.")
lat_dim <- lat_dim[1]
}
}
# ftime_dim
if (!is.null(ftime_dim)) {
......@@ -375,12 +389,8 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
stop("Parameter 'ftime_dim' must be a character string.")
}
if (!all(ftime_dim %in% dimnames)) {
stop("Parameter 'ftime_dim' is not found in 'data' dimension.")
}
if (length(ftime_dim) > 1) {
warning("Parameter 'ftime_dim' has length greater than 1 and ",
"only the first element will be used.")
ftime_dim <- ftime_dim[1]
stop("Parameter 'ftime_dim' is not found in 'data' dimension. Set it ",
"as NULL if there is no forecast time dimension.")
}
}
# sdate_dim
......@@ -388,11 +398,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
if (!is.character(sdate_dim)) {
stop("Parameter 'sdate_dim' must be a character string.")
}
if (length(sdate_dim) > 1) {
warning("Parameter 'sdate_dim' has length greater than 1 and ",
"only the first element will be used.")
sdate_dim <- sdate_dim[1]
}
if (!all(sdate_dim %in% dimnames)) {
stop("Parameter 'sdate_dim' is not found in 'data' dimension.")
}
......@@ -416,11 +421,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
stop("Parameter 'dat_dim' is not found in 'data' dimension. Set it ",
"as NULL if there is no Datasets dimension.")
}
if (length(dat_dim) > 1) {
warning("Parameter 'dat_dim' has length greater than 1 and ",
"only the first element will be used.")
dat_dim <- dat_dim[1]
}
n_datasets <- dim(data)[dat_dim]
} else {
n_datasets <- 1
......@@ -434,11 +434,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
stop("Parameter 'var_dim' is not found in 'data' dimension. Set it ",
"as NULL if there is no variable dimension.")
}
if (length(var_dim) > 1) {
warning("Parameter 'var_dim' has length greater than 1 and ",
"only the first element will be used.")
var_dim <- var_dim[1]
}
n_vars <- dim(data)[var_dim]
} else {
n_vars <- 1
......@@ -453,30 +448,121 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
single_file <- TRUE
}
}
# Dates dimension check
# Dates (1): initial checks
if (!is.null(Dates)) {
if (all(names(dim(Dates)) == c(ftime_dim, sdate_dim)) |
all(names(dim(Dates)) == c(sdate_dim, ftime_dim))) {
if (is.null(startdates)) {
startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected')
} else if ((!inherits(startdates, "POSIXct") & !inherits(startdates, "Date")) &&
(!is.character(startdates) | (any(nchar(startdates) > 10) | any(nchar(startdates) < 1)))) {
warning("Parameter 'startdates' should be a character string containing ",
"the start dates in the format 'yyyy-mm-dd', 'yyyymmdd', 'yyyymm', ",
"'POSIXct' or 'Dates' class. Files will be named with Dates instead.")
startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected')
if (!is.null(format(startdates, "%Y%m%d"))) {
startdates <- format(startdates, "%Y%m%d")
}
if (!any(inherits(Dates, "POSIXct"), inherits(Dates, "Date"))) {
stop("Parameter 'Dates' must be of 'POSIXct' or 'Dates' class.")
}
if (is.null(dim(Dates))) {
stop("Parameter 'Dates' must have dimension names.")
}
if (all(is.null(ftime_dim), is.null(sdate_dim))) {
warning("Parameters 'ftime_dim' and 'sdate_dim' can't both be NULL ",
"if 'Dates' are used. 'Dates' will not be used.")
Dates <- NULL
}
# sdate_dim in Dates
if (!is.null(sdate_dim)) {
if (!sdate_dim %in% names(dim(Dates))) {
warning("Parameter 'sdate_dim' is not found in 'Dates' dimension. ",
"Dates will not be used.")
Dates <- NULL
}
}
# ftime_dim in Dates
if (!is.null(ftime_dim)) {
if (!ftime_dim %in% names(dim(Dates))) {
warning("Parameter 'ftime_dim' is not found in 'Dates' dimension. ",
"Dates will not be used.")
Dates <- NULL
}
} else if (all(dim(Dates)[!names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] == 1)) {
dim(Dates) <- dim(Dates)[names(dim(Dates)) %in% c(ftime_dim, sdate_dim)]
}
}
# time_bounds
if (!is.null(time_bounds)) {
if (!inherits(time_bounds, 'list')) {
stop("Parameter 'time_bounds' must be a list with two dates arrays.")
}
time_bounds_dims <- lapply(time_bounds, function(x) dim(x))
if (!identical(time_bounds_dims[[1]], time_bounds_dims[[2]])) {
stop("Parameter 'time_bounds' must have 2 arrays with same dimensions.")
}
if (is.null(Dates)) {
time_bounds <- NULL
} else {
stop("Parameter 'Dates' must have start date dimension and ",
"forecast time dimension.")
name_tb <- sort(names(time_bounds_dims[[1]]))
name_dt <- sort(names(dim(Dates)))
if (!identical(dim(Dates)[name_dt], time_bounds_dims[[1]][name_tb])) {
stop(paste0("Parameter 'Dates' and 'time_bounds' must have same length ",
"of all dimensions."))
}
}
}
# Dates (2): Check dimensions
if (!is.null(Dates)) {
if (any(dim(Dates)[!names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] != 1)) {
stop("Parameter 'Dates' can have only 'sdate_dim' and 'ftime_dim' ",
"dimensions of length greater than 1.")
}
# drop dimensions of length 1 different from sdate_dim and ftime_dim
dim(Dates) <- dim(Dates)[names(dim(Dates)) %in% c(ftime_dim, sdate_dim)]
# add ftime if needed
if (is.null(ftime_dim)) {
warning("A 'time' dimension of length 1 will be added to 'Dates'.")
dim(Dates) <- c(time = 1, dim(Dates))
dim(data) <- c(time = 1, dim(data))
dimnames <- names(dim(data))
ftime_dim <- 'time'
if (!is.null(time_bounds)) {
time_bounds <- lapply(time_bounds, function(x) {
dim(x) <- c(time = 1, dim(x))
return(x)
})
}
units_hours_since <- TRUE
}
# add sdate if needed
if (is.null(sdate_dim)) {
if (!single_file) {
dim(Dates) <- c(dim(Dates), sdate = 1)
dim(data) <- c(dim(data), sdate = 1)
dimnames <- names(dim(data))
sdate_dim <- 'sdate'
if (!is.null(time_bounds)) {
time_bounds <- lapply(time_bounds, function(x) {
dim(x) <- c(dim(x), sdate = 1)
return(x)
})
}
if (!is.null(startdates)) {
if (length(startdates) != 1) {
warning("Parameter 'startdates' must be of length 1 if 'sdate_dim' is NULL.",
"They won't be used.")
startdates <- NULL
}
}
}
units_hours_since <- TRUE
}
}
# startdates
if (!is.null(Dates)) {
# check startdates
if (is.null(startdates)) {
startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected')
} else if (any(nchar(startdates) > 10, nchar(startdates) < 1)) {
warning("Parameter 'startdates' should be a character string containing ",
"the start dates in the format 'yyyy-mm-dd', 'yyyymmdd', 'yyyymm', ",
"'POSIXct' or 'Dates' class. Files will be named with Dates instead.")
startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected')
}
} else if (!single_file) {
warning("Dates must be provided if 'data' must be saved in separated files. ",
"All data will be saved in a single file.")
single_file <- TRUE
}
# startdates
if (is.null(startdates)) {
if (is.null(sdate_dim)) {
startdates <- 'XXX'
......@@ -484,20 +570,21 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
startdates <- rep('XXX', dim(data)[sdate_dim])
}
} else {
if (is.null(sdate_dim)) {
if (length(startdates) != 1) {
warning("Parameter 'startdates' has length more than 1. Only first ",
"value will be used.")
startdates <- startdates[[1]]
if (any(inherits(startdates, "POSIXct"), inherits(startdates, "Date"))) {
startdates <- format(startdates, "%Y%m%d")
}
if (!is.null(sdate_dim)) {
if (dim(data)[sdate_dim] != length(startdates)) {
warning(paste0("Parameter 'startdates' doesn't have the same length ",
"as dimension '", sdate_dim,"', it will not be used."))
startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected')
startdates <- format(startdates, "%Y%m%d")
}
}
}
# Datasets
if (is.null(Datasets)) {
if (!single_file) {
warning("Parameter 'Datasets' is NULL. Files will be saved with a ",
"directory name of 'XXX'.")
}
Datasets <- rep('XXX', n_datasets )
}
if (inherits(Datasets, 'list')) {
......@@ -513,128 +600,74 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
Datasets <- Datasets[1:n_datasets]
}
## NetCDF dimensions definition
excluded_dims <- var_dim
if (!is.null(Dates)) {
excluded_dims <- c(excluded_dims, sdate_dim, ftime_dim)
}
if (!single_file) {
excluded_dims <- c(excluded_dims, dat_dim)
}
## Unknown dimensions check
alldims <- c(dat_dim, var_dim, sdate_dim, lon_dim, lat_dim, memb_dim, ftime_dim)
alldims <- c(dat_dim, var_dim, sdate_dim, lon_dim, lat_dim, ftime_dim, memb_dim)
if (!all(dimnames %in% alldims)) {
unknown_dims <- dimnames[which(!dimnames %in% alldims)]
# warning("Detected unknown dimension: ", paste(unknown_dims, collapse = ', '))
memb_dim <- c(memb_dim, unknown_dims)
alldims <- c(dat_dim, var_dim, sdate_dim, lon_dim, lat_dim, memb_dim, ftime_dim)
}
# Reorder
if (any(dimnames != alldims)) {
data <- Reorder(data, alldims)
dimnames <- names(dim(data))
if (!is.null(attr(data, 'dimensions'))) {
attr(data, 'dimensions') <- dimnames
}
}
## NetCDF dimensions definition
defined_dims <- NULL
extra_info_dim <- NULL
if (is.null(Dates)) {
filedims <- dimnames[which(!dimnames %in% c(dat_dim, var_dim))]
} else {
filedims <- dimnames[which(!dimnames %in% c(dat_dim, var_dim, sdate_dim, ftime_dim))]
}
filedims <- c(dat_dim, var_dim, sdate_dim, lon_dim, lat_dim, ftime_dim, memb_dim)
filedims <- filedims[which(!filedims %in% excluded_dims)]
# Delete unneded coords
coords[c(names(coords)[!names(coords) %in% filedims])] <- NULL
out_coords <- NULL
for (i_coord in filedims) {
dim_info <- list()
# vals
if (i_coord %in% names(coords)) {
if (is.numeric(coords[[i_coord]])) {
dim_info[['vals']] <- as.vector(coords[[i_coord]])
if (length(coords[[i_coord]]) != dim(data)[i_coord]) {
warning(paste0("Coordinate '", i_coord, "' has different lenght as ",
"its dimension and it will not be used."))
out_coords[[i_coord]] <- 1:dim(data)[i_coord]
} else if (is.numeric(coords[[i_coord]])) {
out_coords[[i_coord]] <- as.vector(coords[[i_coord]])
} else {
dim_info[['vals']] <- 1:dim(data)[i_coord]
out_coords[[i_coord]] <- 1:dim(data)[i_coord]
}
} else {
dim_info[['vals']] <- 1:dim(data)[i_coord]
}
# name
dim_info[['name']] <- i_coord
# len
dim_info[['len']] <- as.numeric(dim(data)[i_coord])
# unlim
dim_info[['unlim']] <- FALSE
# create_dimvar
dim_info[['create_dimvar']] <- TRUE
out_coords[[i_coord]] <- 1:dim(data)[i_coord]
}
dim(out_coords[[i_coord]]) <- dim(data)[i_coord]
## metadata
if (i_coord %in% names(metadata)) {
if ('variables' %in% names(attributes(metadata[[i_coord]]))) {
# from Start: 'lon' or 'lat'
attrs <- attributes(metadata[[i_coord]])[['variables']][[i_coord]]
i_coord_info <- attrs[!sapply(attrs, inherits, 'list')]
attrs <- attributes(metadata[[i_coord]])[['variables']]
attrs[[i_coord]]$dim <- NULL
attr(out_coords[[i_coord]], 'variables') <- attrs
} else if (inherits(metadata[[i_coord]], 'list')) {
# from Start and Load: main var
i_coord_info <- metadata[[i_coord]]
attr(out_coords[[i_coord]], 'variables') <- list(metadata[[i_coord]])
names(attributes(out_coords[[i_coord]])$variables) <- i_coord
} else if (!is.null(attributes(metadata[[i_coord]]))) {
# from Load
i_coord_info <- attributes(metadata[[i_coord]])
} else {
stop("Metadata is not correct.")
attrs <- attributes(metadata[[i_coord]])
# We remove because some attributes can't be saved
attrs <- NULL
attr(out_coords[[i_coord]], 'variables') <- list(attrs)
names(attributes(out_coords[[i_coord]])$variables) <- i_coord
}
# len
if ('size' %in% names(i_coord_info)) {
if (i_coord_info[['size']] != dim(data)[i_coord]) {
dim_info[['original_len']] <- i_coord_info[['size']]
i_coord_info[['size']] <- NULL
}
}
# units
if (!('units' %in% names(i_coord_info))) {
dim_info[['units']] <- ''
} else {
dim_info[['units']] <- i_coord_info[['units']]
i_coord_info[['units']] <- NULL
}
# calendar
if (!('calendar' %in% names(i_coord_info))) {
dim_info[['calendar']] <- NA
} else {
dim_info[['calendar']] <- i_coord_info[['calendar']]
i_coord_info[['calendar']] <- NULL
}
# longname
if ('long_name' %in% names(i_coord_info)) {
dim_info[['longname']] <- i_coord_info[['long_name']]
i_coord_info[['long_name']] <- NULL
} else if ('longname' %in% names(i_coord_info)) {
dim_info[['longname']] <- i_coord_info[['longname']]
i_coord_info[['longname']] <- NULL
} else {
if (i_coord %in% .KnownLonNames()) {
dim_info[['longname']] <- 'longitude'
} else if (i_coord %in% .KnownLatNames()) {
dim_info[['longname']] <- 'latitude'
}
}
# extra information
if (!is.null(names(i_coord_info))) {
extra_info_dim[[i_coord]] <- i_coord_info
}
} else {
# units
dim_info[['units']] <- "adim"
# longname
dim_info[['longname']] <- i_coord
# calendar
dim_info[['calendar']] <- NA
}
new_dim <- list(ncdim_def(name = dim_info[['name']], units = dim_info[['units']],
vals = dim_info[['vals']], unlim = dim_info[['unlim']],
create_dimvar = dim_info[['create_dimvar']],
calendar = dim_info[['calendar']],
longname = dim_info[['longname']]))
names(new_dim) <- i_coord
defined_dims <- c(defined_dims, new_dim)
}
}
defined_vars <- list()
if (!single_file) {
for (i in 1:n_datasets) {
path <- file.path(destination, Datasets[i], varname)
for (j in 1:n_vars) {
dir.create(path[j], recursive = TRUE)
if (!dir.exists(path[j])) {
dir.create(path[j], recursive = TRUE)
}
startdates <- gsub("-", "", startdates)
dim(startdates) <- c(length(startdates))
names(dim(startdates)) <- sdate_dim
......@@ -647,293 +680,240 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL,
} else {
data_subset <- Subset(data, c(dat_dim, var_dim), list(i, j), drop = 'selected')
}
target <- names(dim(data_subset))[which(!names(dim(data_subset)) %in% c(sdate_dim, ftime_dim))]
target_dims_data <- c(target, ftime_dim)
if (is.null(Dates)) {
input_data <- list(data_subset, startdates)
target_dims <- list(c(lon_dim, lat_dim, memb_dim, ftime_dim), NULL)
target_dims <- list(target_dims_data, NULL)
} else if (!is.null(time_bounds)) {
input_data <- list(data_subset, startdates, Dates,
time_bounds[[1]], time_bounds[[2]])
target_dims = list(target_dims_data, NULL,
ftime_dim, ftime_dim, ftime_dim)
} else {
input_data <- list(data_subset, startdates, Dates)
target_dims = list(c(lon_dim, lat_dim, memb_dim, ftime_dim), NULL, ftime_dim)
target_dims = list(target_dims_data, NULL, ftime_dim)
}
Apply(data = input_data,
target_dims = target_dims,
fun = .saveExp,
fun = .saveexp,
destination = path[j],
defined_dims = defined_dims,
coords = out_coords,
ftime_dim = ftime_dim,
varname = varname[j],
metadata_var = metadata[[varname[j]]],
extra_info_dim = extra_info_dim,
extra_string = extra_string)
extra_string = extra_string,
global_attrs = global_attrs)
}
}
} else {
# Datasets definition
# From here
if (!is.null(dat_dim)) {
new_dim <- list(ncdim_def(name = dat_dim, units = "adim",
vals = 1 : dim(data)[dat_dim],
longname = 'Datasets', create_dimvar = TRUE))
names(new_dim) <- dat_dim
defined_dims <- c(new_dim, defined_dims)
extra_info_dim[[dat_dim]] <- list(Datasets = paste(Datasets, collapse = ', '))
}
first_sdate <- last_sdate <- NULL
# time_bnds
if (!is.null(time_bounds)) {
time_bnds <- c(time_bounds[[1]], time_bounds[[2]])
}
# Dates
remove_metadata_dim <- TRUE
if (!is.null(Dates)) {
# sdate definition
sdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected')
differ <- as.numeric((sdates - sdates[1])/3600)
new_dim <- list(ncdim_def(name = sdate_dim, units = paste('hours since', sdates[1]),
vals = differ,
longname = sdate_dim, create_dimvar = TRUE))
names(new_dim) <- sdate_dim
defined_dims <- c(defined_dims, new_dim)
first_sdate <- sdates[1]
last_sdate <- sdates[length(sdates)]
# ftime definition
Dates <- Reorder(Dates, c(ftime_dim, sdate_dim))
differ_ftime <- apply(Dates, 2, function(x){as.numeric((x - x[1])/3600)})
dim(differ_ftime) <- dim(Dates)
differ_ftime_subset <- Subset(differ_ftime, along = sdate_dim, 1, drop = 'selected')
if (all(apply(differ_ftime, 1, function(x){length(unique(x)) == 1}))) {
if (all(diff(differ_ftime_subset/24) == 1)) {
if (is.null(sdate_dim)) {
sdates <- Dates[1]
# ftime definition
leadtimes <- as.numeric(difftime(Dates, sdates, units = "hours"))
} else {
# sdate definition
sdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected')
differ <- as.numeric(difftime(sdates, sdates[1], units = "hours"))
dim(differ) <- dim(data)[sdate_dim]
differ <- list(differ)
names(differ) <- sdate_dim
out_coords <- c(differ, out_coords)
attrs <- list(units = paste('hours since', sdates[1]),
calendar = 'proleptic_gregorian', longname = sdate_dim)
attr(out_coords[[sdate_dim]], 'variables')[[sdate_dim]] <- attrs
# ftime definition
Dates <- Reorder(Dates, c(ftime_dim, sdate_dim))
differ_ftime <- array(dim = dim(Dates))
for (i in 1:length(sdates)) {
differ_ftime[, i] <- as.numeric(difftime(Dates[, i], Dates[1, i],
units = "hours"))
}
dim(differ_ftime) <- dim(Dates)
leadtimes <- Subset(differ_ftime, along = sdate_dim, 1, drop = 'selected')
if (!all(apply(differ_ftime, 1, function(x){length(unique(x)) == 1}))) {
warning("Time steps are not equal for all start dates. Only ",
"forecast time values for the first start date will be saved ",
"correctly.")
}
}
if (all(!units_hours_since, is.null(time_bounds))) {
if (all(diff(leadtimes/24) == 1)) {
# daily values
dim_time <- list(ncdim_def(name = ftime_dim, units = 'days',
vals = round(differ_ftime_subset/24) + 1,
calendar = 'proleptic_gregorian',
longname = ftime_dim, unlim = TRUE))
names(dim_time) <- ftime_dim
defined_dims <- c(defined_dims, dim_time)
} else if (all(diff(differ_ftime_subset/24) %in% c(28, 29, 30, 31))) {
units <- 'days'
leadtimes_vals <- round(leadtimes/24) + 1
} else if (all(diff(leadtimes/24) %in% c(28, 29, 30, 31))) {
# monthly values
dim_time <- list(ncdim_def(name = ftime_dim, units = 'months',
vals = round(differ_ftime_subset/730) + 1,
calendar = 'proleptic_gregorian',
longname = ftime_dim, unlim = TRUE))
names(dim_time) <- ftime_dim
defined_dims <- c(defined_dims, dim_time)
units <- 'months'
leadtimes_vals <- round(leadtimes/(30.437*24)) + 1
} else {
# other frequency
dim_time <- list(ncdim_def(name = ftime_dim, units = 'hours',
vals = differ_ftime_subset + 1,
calendar = 'proleptic_gregorian',
longname = ftime_dim, unlim = TRUE))
names(dim_time) <- ftime_dim
defined_dims <- c(defined_dims, dim_time)
units <- 'hours'
leadtimes_vals <- leadtimes + 1
}
} else {
warning("Time steps are not equal for all start dates. Only ",
"forecast time values for the first start date will be saved ",
"correctly.")
dim_time <- list(ncdim_def(name = ftime_dim,
units = paste('hours since',
paste(sdates, collapse = ', ')),
vals = differ_ftime_subset,
calendar = 'proleptic_gregorian',
longname = ftime_dim, unlim = TRUE))
names(dim_time) <- ftime_dim
defined_dims <- c(defined_dims, dim_time)
units <- paste('hours since', paste(sdates, collapse = ', '))
leadtimes_vals <- leadtimes
}
}
# Add time_bnds
if (!is.null(time_bounds)) {
if (is.null(sdate_dim)) {
sdates <- Dates[1]
time_bnds <- c(time_bounds[[1]], time_bounds[[2]])
leadtimes_bnds <- as.numeric(difftime(time_bnds, sdates, units = "hours"))
dim(leadtimes_bnds) <- c(dim(Dates), bnds = 2)
} else {
# assuming they have sdate and ftime
time_bnds <- lapply(time_bounds, function(x) {
x <- Reorder(x, c(ftime_dim, sdate_dim))
return(x)
})
time_bnds <- c(time_bounds[[1]], time_bounds[[2]])
dim(time_bnds) <- c(dim(Dates), bnds = 2)
differ_bnds <- array(dim = c(dim(time_bnds)))
for (i in 1:length(sdates)) {
differ_bnds[, i, ] <- as.numeric(difftime(time_bnds[, i, ], Dates[1, i],
units = "hours"))
}
# NOTE (TODO): Add a warning when they are not equally spaced?
leadtimes_bnds <- Subset(differ_bnds, along = sdate_dim, 1, drop = 'selected')
}
# Add time_bnds
leadtimes_bnds <- Reorder(leadtimes_bnds, c('bnds', ftime_dim))
leadtimes_bnds <- list(leadtimes_bnds)
names(leadtimes_bnds) <- 'time_bnds'
out_coords <- c(leadtimes_bnds, out_coords)
attrs <- list(units = paste('hours since', paste(sdates, collapse = ', ')),
calendar = 'proleptic_gregorian',
long_name = 'time bounds', unlim = FALSE)
attr(out_coords[['time_bnds']], 'variables')$time_bnds <- attrs
}
# Add ftime var
dim(leadtimes_vals) <- dim(data)[ftime_dim]
leadtimes_vals <- list(leadtimes_vals)
names(leadtimes_vals) <- ftime_dim
out_coords <- c(leadtimes_vals, out_coords)
attrs <- list(units = units, calendar = 'proleptic_gregorian',
longname = ftime_dim,
dim = list(list(name = ftime_dim, unlim = TRUE)))
if (!is.null(time_bounds)) {
attrs$bounds = 'time_bnds'
}
attr(out_coords[[ftime_dim]], 'variables')[[ftime_dim]] <- attrs
for (j in 1:n_vars) {
remove_metadata_dim <- FALSE
metadata[[varname[j]]]$dim <- list(list(name = ftime_dim, unlim = TRUE))
}
# Reorder ftime_dim to last
if (length(dim(data)) != which(names(dim(data)) == ftime_dim)) {
order <- c(names(dim(data))[which(!names(dim(data)) %in% c(ftime_dim))], ftime_dim)
data <- Reorder(data, order)
}
}
# var definition
defined_vars <- list()
extra_info_var <- NULL
for (j in 1:n_vars) {
var_info <- list()
i_var_info <- metadata[[varname[j]]][!sapply(metadata[[varname[j]]], inherits, 'list')]
## Define metadata
# name
var_info[['name']] <- varname[j]
# units
if ('units' %in% names(i_var_info)) {
var_info[['units']] <- i_var_info[['units']]
i_var_info[['units']] <- NULL
varname_j <- varname[j]
metadata_j <- metadata[[varname_j]]
if (is.null(var_dim)) {
out_coords[[varname_j]] <- data
} else {
var_info[['units']] <- ''
out_coords[[varname_j]] <- Subset(data, var_dim, j, drop = 'selected')
}
# dim
var_info[['dim']] <- defined_dims
# missval
if ('missval' %in% names(i_var_info)) {
var_info[['missval']] <- i_var_info[['missval']]
i_var_info[['missval']] <- NULL
} else {
var_info[['missval']] <- NULL
if (!is.null(metadata_j)) {
if (remove_metadata_dim) metadata_j$dim <- NULL
attr(out_coords[[varname_j]], 'variables') <- list(metadata_j)
names(attributes(out_coords[[varname_j]])$variables) <- varname_j
}
# longname
if (any(c('longname', 'long_name') %in% names(i_var_info))) {
longname <- names(i_var_info)[which(names(i_var_info) %in% c('longname', 'long_name'))]
var_info[['longname']] <- i_var_info[[longname]]
i_var_info[[longname]] <- NULL
} else {
var_info[['longname']] <- varname[j]
# Add global attributes
if (!is.null(global_attrs)) {
attributes(out_coords[[varname_j]])$global_attrs <- global_attrs
}
# prec
if ('prec' %in% names(i_var_info)) {
var_info[['prec']] <- i_var_info[['prec']]
i_var_info[['prec']] <- NULL
} else {
prec <- typeof(data)
if (prec == 'character') {
var_info[['prec']] <- 'char'
}
if (any(prec %in% c('short', 'float', 'double', 'integer', 'char', 'byte'))) {
var_info[['prec']] <- prec
} else {
var_info[['prec']] <- 'double'
}
}
# extra information
if (!is.null(names(i_var_info))) {
extra_info_var[[varname[j]]] <- i_var_info
}
new_var <- list(ncvar_def(name = var_info[['name']],
units = var_info[['units']],
dim = var_info[['dim']],
missval = var_info[['missval']],
longname = var_info[['longname']],
prec = var_info[['prec']]))
names(new_var) <- varname[j]
defined_vars <- c(defined_vars, new_var)
}
if (is.null(extra_string)) {
first_sdate <- startdates[1]
last_sdate <- startdates[length(startdates)]
gsub("-", "", first_sdate)
file_name <- paste0(paste(c(varname,
gsub("-", "", first_sdate),
gsub("-", "", last_sdate)),
collapse = '_'), ".nc")
} else {
file_name <- paste0(paste(c(varname, extra_string,
gsub("-", "", first_sdate),
gsub("-", "", last_sdate)),
collapse = '_'), ".nc")
}
full_filename <- file.path(destination, file_name)
file_nc <- nc_create(full_filename, defined_vars)
if (is.null(var_dim)) {
ncvar_put(file_nc, varname, vals = data)
} else {
for (j in 1:n_vars) {
ncvar_put(file_nc, defined_vars[[j]]$name,
vals = Subset(data, var_dim, j, drop = 'selected'))
}
}
# Additional dimension attributes
for (dim in names(defined_dims)) {
if (dim %in% names(extra_info_dim)) {
for (info_dim in names(extra_info_dim[[dim]])) {
ncatt_put(file_nc, dim, info_dim, as.character(extra_info_dim[[dim]][[info_dim]]))
}
}
}
# Additional dimension attributes
for (var in names(defined_vars)) {
if (var %in% names(extra_info_var)) {
for (info_var in names(extra_info_var[[var]])) {
ncatt_put(file_nc, var, info_var, as.character(extra_info_var[[var]][[info_var]]))
}
nc <- substr(extra_string, nchar(extra_string)-2, nchar(extra_string))
if (nc == ".nc") {
file_name <- extra_string
} else {
file_name <- paste0(extra_string, ".nc")
}
}
nc_close(file_nc)
full_filename <- file.path(destination, file_name)
ArrayToNc(out_coords, full_filename)
}
}
.saveExp <- function(data, startdates = NULL, dates = NULL, destination = "./",
defined_dims, ftime_dim = 'time', varname = 'var',
metadata_var = NULL, extra_info_dim = NULL,
extra_string = NULL) {
# ftime_dim
.saveexp <- function(data, coords, destination = "./",
startdates = NULL, dates = NULL,
time_bnds1 = NULL, time_bnds2 = NULL,
ftime_dim = 'time', varname = 'var',
metadata_var = NULL, extra_string = NULL,
global_attrs = NULL) {
remove_metadata_dim <- TRUE
if (!is.null(dates)) {
differ <- as.numeric((dates - dates[1])/3600)
dim_time <- list(ncdim_def(name = ftime_dim, units = paste('hours since', dates[1]),
vals = differ, calendar = 'proleptic_gregorian',
longname = ftime_dim, unlim = TRUE))
names(dim_time) <- ftime_dim
defined_dims <- c(defined_dims, dim_time)
if (!any(is.null(time_bnds1), is.null(time_bnds2))) {
time_bnds <- c(time_bnds1, time_bnds2)
time_bnds <- as.numeric(difftime(time_bnds, dates[1], units = "hours"))
dim(time_bnds) <- c(dim(data)[ftime_dim], bnds = 2)
time_bnds <- Reorder(time_bnds, c('bnds', ftime_dim))
time_bnds <- list(time_bnds)
names(time_bnds) <- 'time_bnds'
coords <- c(time_bnds, coords)
attrs <- list(units = paste('hours since', dates[1]),
calendar = 'proleptic_gregorian',
longname = 'time bounds')
attr(coords[['time_bnds']], 'variables')$time_bnds <- attrs
}
# Add ftime_dim
differ <- as.numeric(difftime(dates, dates[1], units = "hours"))
dim(differ) <- dim(data)[ftime_dim]
differ <- list(differ)
names(differ) <- ftime_dim
coords <- c(differ, coords)
attrs <- list(units = paste('hours since', dates[1]),
calendar = 'proleptic_gregorian',
longname = ftime_dim,
dim = list(list(name = ftime_dim, unlim = TRUE)))
if (!is.null(time_bnds1)) {
attrs$bounds = 'time_bnds'
}
attr(coords[[ftime_dim]], 'variables')[[ftime_dim]] <- attrs
metadata_var$dim <- list(list(name = ftime_dim, unlim = TRUE))
remove_metadata_dim <- FALSE
}
# Add data
coords[[varname]] <- data
if (!is.null(metadata_var)) {
if (remove_metadata_dim) metadata_var$dim <- NULL
attr(coords[[varname]], 'variables') <- list(metadata_var)
names(attributes(coords[[varname]])$variables) <- varname
}
# Add global attributes
if (!is.null(global_attrs)) {
attributes(coords[[varname]])$global_attrs <- global_attrs
}
## Define var metadata
var_info <- NULL
extra_info_var <- NULL
i_var_info <- metadata_var[!sapply(metadata_var, inherits, 'list')]
# name
var_info[['name']] <- varname
# units
if ('units' %in% names(i_var_info)) {
var_info[['units']] <- i_var_info[['units']]
i_var_info[['units']] <- NULL
} else {
var_info[['units']] <- ''
}
# dim
var_info[['dim']] <- defined_dims
# missval
if ('missval' %in% names(i_var_info)) {
var_info[['missval']] <- i_var_info[['missval']]
i_var_info[['missval']] <- NULL
} else {
var_info[['missval']] <- NULL
}
# longname
if (any(c('longname', 'long_name') %in% names(i_var_info))) {
longname <- names(i_var_info)[which(names(i_var_info) %in% c('longname', 'long_name'))]
var_info[['longname']] <- i_var_info[[longname]]
i_var_info[[longname]] <- NULL
} else {
var_info[['longname']] <- varname
}
# prec
if ('prec' %in% names(i_var_info)) {
var_info[['prec']] <- i_var_info[['prec']]
i_var_info[['prec']] <- NULL
} else {
prec <- typeof(data)
if (prec == 'character') {
var_info[['prec']] <- 'char'
}
if (any(prec %in% c('short', 'float', 'double', 'integer', 'char', 'byte'))) {
var_info[['prec']] <- prec
} else {
var_info[['prec']] <- 'double'
}
}
# extra information
if (!is.null(names(i_var_info))) {
extra_info_var <- i_var_info
}
datanc <- ncvar_def(name = var_info[['name']],
units = var_info[['units']],
dim = var_info[['dim']],
missval = var_info[['missval']],
longname = var_info[['longname']],
prec = var_info[['prec']])
if (is.null(extra_string)) {
file_name <- paste0(varname, "_", startdates, ".nc")
} else {
file_name <- paste0(varname, "_", extra_string, "_", startdates, ".nc")
}
full_filename <- file.path(destination, file_name)
file_nc <- nc_create(full_filename, datanc)
ncvar_put(file_nc, datanc, data)
# Additional attributes
for (dim in names(defined_dims)) {
if (dim %in% names(extra_info_dim)) {
for (info_dim in names(extra_info_dim[[dim]])) {
ncatt_put(file_nc, dim, info_dim, as.character(extra_info_dim[[dim]][[info_dim]]))
}
}
}
# Additional dimension attributes
if (!is.null(extra_info_var)) {
for (info_var in names(extra_info_var)) {
ncatt_put(file_nc, varname, info_var, as.character(extra_info_var[[info_var]]))
}
}
nc_close(file_nc)
}
ArrayToNc(coords, full_filename)
}
\ No newline at end of file
R/CST_SplitDim.R
View file @ 0450e139
......@@ -10,7 +10,7 @@
#'
#'@param data A 's2dv_cube' object
#'@param split_dim A character string indicating the name of the dimension to
#' split.
#' split. It is set as 'time' by default.
#'@param indices A vector of numeric indices or dates. If left at NULL, the
#' dates provided in the s2dv_cube object (element Dates) will be used.
#'@param freq A character string indicating the frequency: by 'day', 'month' and
......@@ -21,6 +21,12 @@
#' dimension.
#'@param insert_ftime An integer indicating the number of time steps to add at
#' the begining of the time series.
#'@param ftime_dim A character string indicating the name of the forecast time
#' dimension. It is set as 'time' by default.
#'@param sdate_dim A character string indicating the name of the start date
#' dimension. It is set as 'sdate' by default.
#'@param return_indices A logical value that if it is TRUE, the indices
#' used in splitting the dimension will be returned. It is FALSE by default.
#'
#'@details Parameter 'insert_ftime' has been included for the case of using
#'daily data, requiring split the temporal dimensions by months (or similar) and
......@@ -51,63 +57,97 @@
#'new_data <- CST_SplitDim(data, indices = time, freq = 'year')
#'@import abind
#'@importFrom ClimProjDiags Subset
#'@importFrom s2dv Reorder
#'@export
CST_SplitDim <- function(data, split_dim = 'time', indices = NULL,
freq = 'monthly', new_dim_name = NULL,
insert_ftime = NULL) {
insert_ftime = NULL, ftime_dim = 'time',
sdate_dim = 'sdate', return_indices = FALSE) {
# Check 's2dv_cube'
if (!inherits(data, 's2dv_cube')) {
stop("Parameter 'data' must be of the class 's2dv_cube', ",
"as output by CSTools::CST_Load.")
stop("Parameter 'data' must be of the class 's2dv_cube'.")
}
if (!is.null(insert_ftime)) {
if (!is.numeric(insert_ftime)) {
stop("Parameter 'insert_ftime' should be an integer.")
}
if (length(insert_ftime) > 1) {
warning("Parameter 'insert_ftime' must be of length 1, and only the",
" first element will be used.")
insert_ftime <- insert_ftime[1]
}
# Check Dates
if (is.null(dim(data$attrs$Dates))) {
warning("Parameter 'Dates' must have dimensions, 'insert_ftime' won't ",
"be used.")
insert_ftime <- NULL
}
}
if (!is.null(insert_ftime)) {
# adding NAs at the begining of the data in ftime dim
ftimedim <- which(names(dim(data$data)) == ftime_dim)
dims <- dim(data$data)
dims[ftimedim] <- insert_ftime
empty_array <- array(NA, dims)
data$data <- abind(empty_array, data$data, along = ftimedim)
names(dim(data$data)) <- names(dims)
# Reorder dates
data$attrs$Dates <- Reorder(data$attrs$Dates, c(ftime_dim, sdate_dim))
dates <- data$attrs$Dates
dates_subset <- Subset(dates, sdate_dim, 1)
# adding dates to Dates for the new NAs introduced
if ((dates_subset[2] - dates_subset[1]) == 1) {
timefreq <- 'days'
} else {
if (length(insert_ftime) > 1) {
warning("Parameter 'insert_ftime' must be of length 1, and only the",
" first element will be used.")
insert_ftime <- insert_ftime[1]
}
# adding NAs at the begining of the data in ftime dim
ftimedim <- which(names(dim(data$data)) == 'ftime')
dims <- dim(data$data)
dims[ftimedim] <- insert_ftime
empty_array <- array(NA, dims)
data$data <- abind(empty_array, data$data, along = ftimedim)
names(dim(data$data)) <- names(dims)
# adding dates to Dates for the new NAs introduced
if ((data$attrs$Dates[2] - data$attrs$Dates[1]) == 1) {
timefreq <- 'days'
} else {
timefreq <- 'months'
warning("Time frequency of forecast time is considered monthly.")
}
start <- data$attrs$Dates
dim(start) <- c(ftime = length(start)/dims['sdate'], sdate = dims['sdate'])
# new <- array(NA, prod(dim(data$data)[c('ftime', 'sdate')]))
# Pending fix transform to UTC when concatenaiting
data$attrs$Dates <- do.call(c, lapply(1:dim(start)[2], function(x) {
seq(start[1,x] - as.difftime(insert_ftime,
units = timefreq),
start[dim(start)[1],x], by = timefreq, tz = "UTC")}))
timefreq <- 'months'
warning("Time frequency of forecast time is considered monthly.")
}
dim(dates) <- c(length(dates)/dims[sdate_dim], dims[sdate_dim])
names(dim(dates)) <- c(ftime_dim, sdate_dim)
# new <- array(NA, prod(dim(data$data)[c('ftime', 'sdate')]))
# Pending fix transform to UTC when concatenaiting
data$attrs$Dates <- do.call(c, lapply(1:dim(dates)[2], function(x) {
seq(dates[1,x] - as.difftime(insert_ftime,
units = timefreq),
dates[dim(dates)[1],x], by = timefreq, tz = "UTC")}))
}
if (is.null(indices)) {
if (any(split_dim %in% c('ftime', 'time', 'sdate'))) {
if (any(split_dim %in% c(ftime_dim, sdate_dim))) {
indices <- data$attrs$Dates
if (any(names(dim(data$data)) %in% 'sdate')) {
if (any(names(dim(data$data)) %in% sdate_dim)) {
if (!any(names(dim(data$data)) %in% split_dim)) {
stop("Parameter 'split_dims' must be one of the dimension ",
"names in parameter 'data'.")
}
indices <- indices[1 : dim(data$data)[which(names(dim(data$data)) == split_dim)]]
indices <- indices[1:dim(data$data)[which(names(dim(data$data)) == split_dim)]]
}
}
}
data$data <- SplitDim(data$data, split_dim = split_dim, indices = indices,
freq = freq, new_dim_name = new_dim_name)
return(data)
# Call the function
res <- SplitDim(data = data$data, split_dim = split_dim,
indices = indices, freq = freq,
new_dim_name = new_dim_name,
dates = data$attrs$Dates,
return_indices = return_indices)
if (inherits(res, 'list')) {
data$data <- res$data
# Split dim on Dates
if (!is.null(res$dates)) {
data$attrs$Dates <- res$dates
}
} else {
data$data <- res
}
data$dims <- dim(data$data)
# Coordinates
# TO DO: Subset splitted coordinate and add the new dimension coordinate.
if (return_indices) {
return(list(data = data, indices = res$indices))
} else {
return(data)
}
}
#'Function to Split Dimension
#'
......@@ -129,6 +169,11 @@ CST_SplitDim <- function(data, split_dim = 'time', indices = NULL,
#' the length in which to subset the dimension.
#'@param new_dim_name A character string indicating the name of the new
#' dimension.
#'@param dates An optional parameter containing an array of dates of class
#' 'POSIXct' with the corresponding time dimensions of 'data'. It is NULL
#' by default.
#'@param return_indices A logical value that if it is TRUE, the indices
#' used in splitting the dimension will be returned. It is FALSE by default.
#'@examples
#'data <- 1 : 20
#'dim(data) <- c(time = 10, lat = 2)
......@@ -145,7 +190,8 @@ CST_SplitDim <- function(data, split_dim = 'time', indices = NULL,
#'@importFrom ClimProjDiags Subset
#'@export
SplitDim <- function(data, split_dim = 'time', indices, freq = 'monthly',
new_dim_name = NULL) {
new_dim_name = NULL, dates = NULL,
return_indices = FALSE) {
# check data
if (is.null(data)) {
stop("Parameter 'data' cannot be NULL.")
......@@ -167,7 +213,7 @@ SplitDim <- function(data, split_dim = 'time', indices, freq = 'monthly',
"one and only the first element will be used.")
}
if (!any(names(dims) %in% split_dim)) {
stop("Parameter 'split_dims' must be one of the dimension ",
stop("Parameter 'split_dim' must be one of the dimension ",
"names in parameter 'data'.")
}
pos_split <- which(names(dims) == split_dim)
......@@ -210,8 +256,8 @@ SplitDim <- function(data, split_dim = 'time', indices, freq = 'monthly',
})
if ('try-error' %in% class(indices) |
sum(is.na(indices)) == length(indices)) {
stop("Dates provided in parameter 'indices' must be of class",
" 'POSIXct' or convertable to 'POSIXct'.")
stop("Dates provided in parameter 'indices' must be of class ",
"'POSIXct' or convertable to 'POSIXct'.")
}
}
}
......@@ -230,7 +276,7 @@ SplitDim <- function(data, split_dim = 'time', indices, freq = 'monthly',
} else if (freq == 'year') {
indices <- as.numeric(strftime(indices, format = "%Y"))
repited <- unique(indices)
} else if (freq == 'monthly' ) {
} else if (freq == 'monthly') {
indices <- as.numeric(strftime(indices, format = "%m%Y"))
repited <- unique(indices)
} else {
......@@ -255,15 +301,41 @@ SplitDim <- function(data, split_dim = 'time', indices, freq = 'monthly',
data <- lapply(repited, function(x) {rebuild(x, data, along = split_dim,
indices = indices, max_times)})
data <- abind(data, along = length(dims) + 1)
if (is.character(freq)) {
names(dim(data)) <- c(names(dims), freq)
} else {
names(dim(data)) <- c(names(dims), 'index')
# Add new dim name
if (is.null(new_dim_name)) {
if (is.character(freq)) {
new_dim_name <- freq
} else {
new_dim_name <- 'index'
}
}
if (!is.null(new_dim_name)) {
names(dim(data)) <- c(names(dims), new_dim_name)
names(dim(data)) <- c(names(dims), new_dim_name)
# Split also Dates
dates_exist <- FALSE
if (!is.null(dates)) {
if (any(split_dim %in% names(dim(dates)))) {
datesdims <- dim(dates)
dates <- lapply(repited, function(x) {rebuild(x, dates, along = split_dim,
indices = indices, max_times)})
dates <- abind(dates, along = length(datesdims) + 1)
dates <- as.POSIXct(dates, origin = '1970-01-01', tz = "UTC")
names(dim(dates)) <- c(names(datesdims), new_dim_name)
}
dates_exist <- TRUE
}
# Return objects
if (all(dates_exist, return_indices)) {
return(list(data = data, dates = dates, indices = indices))
} else if (all(dates_exist, !return_indices)) {
return(list(data = data, dates = dates))
} else if (all(!dates_exist, return_indices)) {
return(list(data = data, indices = indices))
} else {
return(data)
}
return(data)
}
rebuild <- function(x, data, along, indices, max_times) {
......
R/CST_Start.R
View file @ 0450e139
......@@ -9,7 +9,10 @@
#'`s2dv_cube` object.
#'
#'It receives any number of parameters (`...`) that are automatically forwarded
#'to the `startR::Start` function. See details in `?startR::Start`.
#'to the `startR::Start` function. See details in `?startR::Start`. The
#'auxiliary functions used to define dimensions need to be called within the
#'startR namespace (e.g. startR::indices(), startR::values(), startR::Sort(),
#'startR::CircularSort(), startR::CDORemapper(), ...).
#'
#'@param ... Parameters that are automatically forwarded to the `startR::Start`
#' function. See details in `?startR::Start`.
......
R/CST_Subset.R
View file @ 0450e139
......@@ -79,15 +79,15 @@ CST_Subset <- function(x, along, indices, drop = FALSE, var_dim = NULL,
}
# Subset data
x$data <- ClimProjDiags::Subset(x$data, along = along,
indices = indices,
drop = drop)
x$data <- Subset(x$data, along = along,
indices = indices,
drop = drop)
# Adjust dimensions
x$dims <- dim(x$data)
# Adjust coordinates
for (dimension in 1:length(along)) {
dim_name <- along[dimension]
index <- indices[[dimension]]
index <- indices[dimension]
# Only rename coordinates that have not been dropped
if (dim_name %in% names(x$dims)) {
# Subset coordinate by indices
......@@ -113,10 +113,10 @@ CST_Subset <- function(x, along, indices, drop = FALSE, var_dim = NULL,
}
if ((!is.null(x$attrs$source_files)) &&
(dim_name %in% names(dim(x$attrs$source_files)))) {
x$attrs$source_files <- ClimProjDiags::Subset(x$attrs$source_files,
along = dim_name,
indices = index,
drop = drop)
x$attrs$source_files <- Subset(x$attrs$source_files,
along = dim_name,
indices = index,
drop = drop)
}
}
# Remove metadata from variables that were dropped
......@@ -128,10 +128,10 @@ CST_Subset <- function(x, along, indices, drop = FALSE, var_dim = NULL,
if (!(length(time_along) == 0)) {
time_indices <- indices[match(time_along, along)]
original_dates <- x$attrs$Dates
x$attrs$Dates <- ClimProjDiags::Subset(x$attrs$Dates,
along = time_along,
indices = time_indices,
drop = drop)
x$attrs$Dates <- Subset(x$attrs$Dates,
along = time_along,
indices = time_indices,
drop = drop)
}
# Subset metadata
for (variable in 1:length(names(x$attrs$Variable$metadata))) {
......@@ -150,12 +150,12 @@ CST_Subset <- function(x, along, indices, drop = FALSE, var_dim = NULL,
# Function to subset with attributes
.subset_with_attrs <- function(x, ...) {
args_subset <- list(...)
if (is.null(dim(x)) | length(dim(x)) == 1) {
l <- x[args_subset[['indices']]]
if (any(is.null(dim(x)), length(dim(x)) == 1)) {
l <- x[args_subset[['indices']][[1]]]
} else {
l <- ClimProjDiags::Subset(x, along = args_subset[['along']],
indices = args_subset[['indices']],
drop = args_subset[['drop']])
l <- Subset(x, along = args_subset[['along']],
indices = args_subset[['indices']],
drop = args_subset[['drop']])
}
attr.names <- names(attributes(x))
attr.names <- attr.names[attr.names != 'names']
......
R/CST_WeatherRegimes.R
View file @ 0450e139
......@@ -72,8 +72,7 @@ CST_WeatherRegimes <- function(data, ncenters = NULL,
ncores = NULL) {
# Check 's2dv_cube'
if (!inherits(data, 's2dv_cube')) {
stop("Parameter 'data' must be of the class 's2dv_cube', ",
"as output by CSTools::CST_Load.")
stop("Parameter 'data' must be of the class 's2dv_cube'.")
}
# Check 'exp' object structure
if (!all(c('data', 'coords') %in% names(data))) {
......
R/PlotCombinedMap.R
View file @ 0450e139
......@@ -35,6 +35,35 @@
#' colour bar will be automatically interpolated to match the number of breaks.
#' Each item in this list can be named, and the name will be used as title for
#' the corresponding colour bar (equivalent to the parameter 'bar_titles').
#'@param bar_limits Parameter from s2dv::ColorBar. 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'.
#'@param triangle_ends Parameter from s2dv::ColorBar. Vector of two logical
#' elements, indicating whether to force the drawing of triangle ends at each
#' of the extremes of the colour bar. This choice is automatically made from
#' the provided 'brks', 'bar_limits', 'var_limits', 'col_inf' and 'col_sup',
#' but the behaviour can be manually forced to draw or not to draw the triangle
#' ends with this parameter. If 'cols' is provided, 'col_inf' and 'col_sup'
#' will take priority over 'triangle_ends' when deciding whether to draw the
#' triangle ends or not.
#'@param col_inf Parameter from s2dv::ColorBar. Colour to fill the inferior
#' triangle end with. Useful if specifying colours manually with parameter
#' 'cols', to specify the colour and to trigger the drawing of the lower
#' extreme triangle, or if 'cols' is not specified, to replace the colour
#' automatically generated by ColorBar().
#'@param col_sup Parameter from s2dv::ColorBar. Colour to fill the superior
#' triangle end with. Useful if specifying colours manually with parameter
#' 'cols', to specify the colour and to trigger the drawing of the upper
#' extreme triangle, or if 'cols' is not specified, to replace the colour
#' automatically generated by ColorBar().
#'@param bar_extra_margin Parameter from s2dv::ColorBar. Extra margins to be
#' added around the colour bar, in the format c(y1, x1, y2, x2). The units are
#' margin lines. Takes rep(0, 4) by default.
#'@param col_unknown_map Colour to use to paint the grid cells for which a map
#' is not possible to be chosen according to 'map_select_fun' or for those
#' values that go beyond 'display_range'. Takes the value 'white' by default.
......