diff --git a/.Rbuildignore b/.Rbuildignore index 6e0d1c58..12b3974a 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,27 +1,31 @@ + +.travis.yml ^.*\.Rproj$ +^CITATION\.cff$ +^LICENSE.md$ +^Meta$ +^README-.*\.png$ +^README\.Rmd$ +^\.DS_Store$ ^\.Rproj\.user$ - ^\.git$ ^\.github$ - -^README\.Rmd$ -^README-.*\.png$ - -^Meta$ -^docs$ -^doc$ -^pkgdown$ -^_pkgdown\.yml$ - +^\.httr-oauth$ ^\.lintr$ - +^\.zenodo\.json$ +^_pkgdown.yml$ +^_pkgdown\.yml$ ^appveyor\.yml$ -.travis.yml - -cran-comments.md - -^\.DS_Store$ - -^revdep$ -^reconf\.sh$ +^checklist.yml$ +^codecov\.yml$ +^data-raw$ +^dev$ +^doc$ +^docs$ +^man-roxygen$ +^organisation.yml$ +^pkgdown$ ^pom\.xml$ +^reconf\.sh$ +^revdep$ +cran-comments.md diff --git a/.github/CODE_OF_CONDUCT.md b/.github/CODE_OF_CONDUCT.md new file mode 100644 index 00000000..3236635c --- /dev/null +++ b/.github/CODE_OF_CONDUCT.md @@ -0,0 +1,25 @@ +# Contributor Code of Conduct + +As contributors and maintainers of this project, we pledge to respect all people who +contribute through reporting issues, posting feature requests, updating documentation, +submitting pull requests or patches, and other activities. + +We are committed to making participation in this project a harassment-free experience for +everyone, regardless of level of experience, gender, gender identity and expression, +sexual orientation, disability, personal appearance, body size, race, ethnicity, age, or religion. + +Examples of unacceptable behaviour by participants include the use of sexual language or +imagery, derogatory comments or personal attacks, trolling, public or private harassment, +insults, or other unprofessional conduct. + +Project maintainers have the right and responsibility to remove, edit, or reject comments, +commits, code, wiki edits, issues, and other contributions that are not aligned to this +Code of Conduct. Project maintainers who do not follow the Code of Conduct may be removed +from the project team. + +Instances of abusive, harassing, or otherwise unacceptable behaviour may be reported by +opening an issue or contacting one or more of the project maintainers. + +This Code of Conduct is adapted from the Contributor Covenant +(http://contributor-covenant.org), version 1.0.0, available at +http://contributor-covenant.org/version/1/0/0/ diff --git a/.github/CONTRIBUTING.md b/.github/CONTRIBUTING.md new file mode 100644 index 00000000..8c4a0bf5 --- /dev/null +++ b/.github/CONTRIBUTING.md @@ -0,0 +1,39 @@ +# CONTRIBUTING # + +### Fixing typos + +Small typos or grammatical errors in documentation may be edited directly using the GitHub web interface, so long as the changes are made in the _source_ file. +E.g. edit a `roxygen2` comment in a `.R` file below `R/`, not in an `.Rd` file below `man/`. + +### Prerequisites + +Before you make a substantial pull request, you should always file an issue and make sure someone from the team agrees that it’s a problem. +If you’ve found a bug, create an associated issue and illustrate the bug with a minimal [reproducible example](https://www.tidyverse.org/help/#reprex). + +### Pull request process + +* We recommend that you create a Git branch for each pull request (PR). +* Look at the GitHub Actions build status before and after making changes. +The `README` should contain badges for any continuous integration services used by the package. +* We require the `tidyverse` [style guide](http://style.tidyverse.org). +You can use the [`lintr`](https://CRAN.R-project.org/package=lintr) package to check these styles and the [`styler`](https://CRAN.R-project.org/package=styler) package to apply these styles, but please don't restyle code that has nothing to do with your PR. +* We use [`roxygen2`](https://cran.r-project.org/package=roxygen2). +* We use [`testthat`](https://cran.r-project.org/package=testthat). +Contributions with test cases included are easier to accept. +* For user-facing changes, add a bullet to the top of `NEWS.md` below the current development version (UNRELEASED) header describing the changes made followed by your GitHub username, and links to relevant issue(s)/PR(s). + +### Code of Conduct + +Please note that this project is released with a [Contributor Code of Conduct](CODE_OF_CONDUCT.md). +By contributing to this project you agree to abide by its terms. + +### Prefer to Email? + +Email the person listed as maintainer in the `DESCRIPTION` file of this repo. + +Though note that private discussions over email don't help others - of course +email is totally warranted if it's a sensitive problem of any kind. + +### Thanks for contributing! + +This contributing guide is adapted from the `tidyverse` contributing guide available at https://raw.githubusercontent.com/r-lib/usethis/master/inst/templates/tidy-contributing.md diff --git a/.gitignore b/.gitignore index 11424ef0..3363316b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,58 +1,59 @@ -# History files -.Rhistory -.Rapp.history - -# Session Data files -.RData -.RDataTmp - -# User-specific files -.Ruserdata # Example code in package build process -*-Ex.R - +# Hidden file from mac-os +# History files +# OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 # Output files from R CMD build -/*.tar.gz - # Output files from R CMD check -/*.Rcheck/ - +# R Environment Variables +# RStudio Connect folder # RStudio files -.Rproj.user/ - -# produced vignettes -vignettes/*.html -vignettes/*.pdf -Meta/ -inst/doc/ -doc/ - -# OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 -.httr-oauth - -# knitr and R markdown default cache directories -*_cache/ -/cache/ - +# Session Data files # Temporary files created by R markdown -*.utf8.md +# User-specific files +# knitr and R markdown default cache directories +# pkgdown site +# produced README.html +# produced vignettes +# translation temp files +*-Ex.R +*.dbf +*.doc* +*.gddoc +*.gdsheet +*.gpkg +*.html *.knit.md - -# R Environment Variables +*.mdb +*.shp* +*.shx +*.utf8.md +*.xls* +*_cache/ +*_files +.DS_Store +.RData +.RDataTmp +.Rapp.history .Renviron - -# pkgdown site +.Rhistory +.Rproj.user +.Rproj.user/ +.Ruserdata +.httr-oauth +/*.Rcheck/ +/*.tar.gz +/cache/ +Meta/ +README.html +doc/ +docs docs/ - -# translation temp files +inst/doc/ +libs +output po/*~ - -# RStudio Connect folder +renv/library rsconnect/ - -# Hidden file from mac-os -.DS_Store - -# produced README.html -README.html +vignettes/*.html +vignettes/*.pdf diff --git a/.lintr b/.lintr index b6fce4f3..4f6b2470 100644 --- a/.lintr +++ b/.lintr @@ -1,18 +1,33 @@ -linters: linters_with_defaults( - indentation_linter = NULL, +linters: lintr::all_linters( + indentation_linter = lintr::indentation_linter(indent = 4L), + # line_length_linter = lintr::line_length_linter(80L), + line_length_linter = lintr::line_length_linter(200L), brace_linter = NULL, infix_spaces_linter = NULL, paren_body_linter = NULL, - #function_left_parentheses_linter = NULL, spaces_left_parentheses_linter = NULL, commas_linter = NULL, quotes_linter = NULL, object_length_linter = NULL, semicolon_linter = NULL, cyclocomp_linter = NULL, - object_usage_linter = NULL, object_name_linter = NULL, - line_length_linter = NULL, - commented_code_linter = NULL + commented_code_linter = NULL, + extraction_operator_linter = NULL, + implicit_integer_linter = NULL, + nonportable_path_linter = NULL, + undesirable_function_linter = NULL, + unnecessary_lambda_linter = NULL, + paste_linter = NULL, + function_argument_linter = NULL, + condition_message_linter = NULL, + unnecessary_concatenation_linter = NULL, + fixed_regex_linter = NULL, + strings_as_factors_linter = NULL, + todo_comment_linter = NULL, + if_not_else_linter = NULL, + unnecessary_nested_if_linter = NULL, + undesirable_operator_linter = NULL, + object_usage_linter = NULL ) encoding: "UTF-8" diff --git a/CITATION.cff b/CITATION.cff new file mode 100644 index 00000000..5b11859c --- /dev/null +++ b/CITATION.cff @@ -0,0 +1,157 @@ +# -------------------------------------------- +# CITATION file created with {cffr} R package +# See also: https://docs.ropensci.org/cffr/ +# -------------------------------------------- + +cff-version: 1.2.0 +message: 'To cite package "rjd3toolkit" in publications use:' +type: software +title: 'rjd3toolkit: Utility Functions around ''JDemetra+ 3.0''' +version: 3.2.4.9000 +abstract: R Interface to 'JDemetra+ 3.x' () time series + analysis software. It provides functions allowing to model time series (create outlier + regressors, user-defined calendar regressors, UCARIMA models...), to test the presence + of trading days or seasonal effects and also to set specifications in pre-adjustment + and benchmarking when using rjd3x13 or rjd3tramoseats. +authors: +- family-names: Palate + given-names: Jean + email: palatejean@gmail.com +- family-names: Quartier-la-Tente + given-names: Alain + email: alain.quartier@yahoo.fr + orcid: https://orcid.org/0000-0001-7890-3857 +- family-names: Barthelemy + given-names: Tanguy + email: tanguy.barthelemy@insee.fr +- family-names: Smyk + given-names: Anna + email: anna.smyk@insee.fr +repository-code: https://github.com/rjdverse/rjd3toolkit +url: https://rjdverse.github.io/rjd3toolkit/ +contact: +- family-names: Barthelemy + given-names: Tanguy + email: tanguy.barthelemy@insee.fr +keywords: +- jdemetra +- package +- r +- r-package +- rstats +- seasonal-adjustment +- timeseries +references: +- type: software + title: 'R: A Language and Environment for Statistical Computing' + notes: Depends + url: https://www.R-project.org/ + authors: + - name: R Core Team + institution: + name: R Foundation for Statistical Computing + address: Vienna, Austria + year: '2024' + version: '>= 4.1.0' +- type: software + title: checkmate + abstract: 'checkmate: Fast and Versatile Argument Checks' + notes: Imports + url: https://mllg.github.io/checkmate/ + repository: https://CRAN.R-project.org/package=checkmate + authors: + - family-names: Lang + given-names: Michel + email: michellang@gmail.com + orcid: https://orcid.org/0000-0001-9754-0393 + year: '2024' + doi: 10.32614/CRAN.package.checkmate +- type: software + title: graphics + abstract: 'R: A Language and Environment for Statistical Computing' + notes: Imports + authors: + - name: R Core Team + institution: + name: R Foundation for Statistical Computing + address: Vienna, Austria + year: '2024' +- type: software + title: methods + abstract: 'R: A Language and Environment for Statistical Computing' + notes: Imports + authors: + - name: R Core Team + institution: + name: R Foundation for Statistical Computing + address: Vienna, Austria + year: '2024' +- type: software + title: rJava + abstract: 'rJava: Low-Level R to Java Interface' + notes: Imports + url: http://www.rforge.net/rJava/ + repository: https://CRAN.R-project.org/package=rJava + authors: + - family-names: Urbanek + given-names: Simon + email: simon.urbanek@r-project.org + year: '2024' + doi: 10.32614/CRAN.package.rJava + version: '>= 1.0-6' +- type: software + title: RProtoBuf + abstract: 'RProtoBuf: R Interface to the ''Protocol Buffers'' ''API'' (Version 2 + or 3)' + notes: Imports + url: https://dirk.eddelbuettel.com/code/rprotobuf.html + repository: https://CRAN.R-project.org/package=RProtoBuf + authors: + - family-names: Francois + given-names: Romain + - family-names: Eddelbuettel + given-names: Dirk + - family-names: Stokely + given-names: Murray + - family-names: Ooms + given-names: Jeroen + year: '2024' + doi: 10.32614/CRAN.package.RProtoBuf + version: '>= 0.4.20' +- type: software + title: stats + abstract: 'R: A Language and Environment for Statistical Computing' + notes: Imports + authors: + - name: R Core Team + institution: + name: R Foundation for Statistical Computing + address: Vienna, Austria + year: '2024' +- type: software + title: utils + abstract: 'R: A Language and Environment for Statistical Computing' + notes: Imports + authors: + - name: R Core Team + institution: + name: R Foundation for Statistical Computing + address: Vienna, Austria + year: '2024' +- type: software + title: spelling + abstract: 'spelling: Tools for Spell Checking in R' + notes: Suggests + url: https://ropensci.r-universe.dev/spelling + repository: https://CRAN.R-project.org/package=spelling + authors: + - family-names: Ooms + given-names: Jeroen + email: jeroenooms@gmail.com + orcid: https://orcid.org/0000-0002-4035-0289 + - family-names: Hester + given-names: Jim + email: james.hester@rstudio.com + year: '2024' + doi: 10.32614/CRAN.package.spelling + diff --git a/DESCRIPTION b/DESCRIPTION index 3a09f64a..1a9c7e31 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rjd3toolkit Type: Package Title: Utility Functions around 'JDemetra+ 3.0' -Version: 3.2.4 +Version: 3.3.0 Authors@R: c( person(given = "Jean", family = "Palate", role = c("aut"), @@ -29,15 +29,17 @@ Imports: checkmate, methods SystemRequirements: Java (>= 17) -License: EUPL +License: file LICENSE URL: https://github.com/rjdverse/rjd3toolkit, https://rjdverse.github.io/rjd3toolkit/ LazyData: TRUE Suggests: knitr, - rmarkdown + rmarkdown, + spelling RoxygenNote: 7.3.2 Roxygen: list(markdown = TRUE) BugReports: https://github.com/rjdverse/rjd3toolkit/issues +VignetteBuilder: knitr Encoding: UTF-8 Collate: 'utils.R' @@ -65,4 +67,4 @@ Collate: 'timeseries.R' 'variables.R' 'zzz.R' -VignetteBuilder: knitr + diff --git a/NAMESPACE b/NAMESPACE index b6845f85..e2a96762 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -79,6 +79,7 @@ export(.jd2r_ucarima) export(.jd2r_variables) export(.jd3_object) export(.jdomain) +export(.likelihood) export(.p2jd_calendar) export(.p2jd_calendars) export(.p2jd_context) @@ -166,6 +167,7 @@ export(.r2p_ts) export(.r2p_tscollection) export(.r2p_tsdata) export(.r2p_uservars) +export(.tsmoniker) export(DATE_MAX) export(DATE_MIN) export(add_outlier) @@ -213,7 +215,6 @@ export(intervention_variable) export(jarquebera) export(julianeaster_variable) export(kurtosis) -export(likelihood) export(ljungbox) export(long_term_mean) export(lp_variable) @@ -247,10 +248,12 @@ export(sarima_model) export(sarima_properties) export(sarima_random) export(seasonality_canovahansen) +export(seasonality_canovahansen_trigs) export(seasonality_combined) export(seasonality_f) export(seasonality_friedman) export(seasonality_kruskalwallis) +export(seasonality_modified_qs) export(seasonality_periodogram) export(seasonality_qs) export(set_arima) @@ -270,8 +273,9 @@ export(statisticaltest) export(stock_td) export(tc_variable) export(td) -export(td_ch) +export(td_canovahansen) export(td_f) +export(td_timevarying) export(testofruns) export(testofupdownruns) export(to_ts) @@ -280,7 +284,6 @@ export(trigonometric_variables) export(ts_adjust) export(ts_interpolate) export(tsdata_of) -export(tsmoniker) export(ucarima_canonical) export(ucarima_estimate) export(ucarima_model) diff --git a/NEWS.md b/NEWS.md index 8396a540..29602042 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,6 +8,14 @@ to [Semantic Versioning](https://semver.org/spec/v3.2.3.html). ## [Unreleased] +## [3.3.0] - 2024-10-28 + +### Changed + +* New JARS +* Improve Canova-Hansen tests for seasonality and trading days (new options, more output) +* Document (UC)ARIMA models + ## [3.2.4] - 2024-07-12 @@ -31,7 +39,8 @@ to [Semantic Versioning](https://semver.org/spec/v3.2.3.html). ## [3.2.2] - 2024-03-15 -[Unreleased]: https://github.com/rjdverse/rjd3toolkit/compare/v3.2.4...HEAD +[Unreleased]: https://github.com/rjdverse/rjd3toolkit/compare/v3.3.0...HEAD +[3.3.0]: https://github.com/rjdverse/rjd3toolkit/releases/tag/v3.2.4...v3.3.. [3.2.4]: https://github.com/rjdverse/rjd3toolkit/releases/tag/v3.2.3...v3.2.4 [3.2.3]: https://github.com/rjdverse/rjd3toolkit/releases/tag/v3.2.2...v3.2.3 [3.2.2]: https://github.com/rjdverse/rjd3toolkit/releases/tag/v3.2.2 diff --git a/R/arima.R b/R/arima.R index 47445daf..f984a2ae 100644 --- a/R/arima.R +++ b/R/arima.R @@ -5,20 +5,40 @@ NULL #' Seasonal ARIMA model (Box-Jenkins) #' #' @param period period of the model. -#' @param phi coefficients of the regular auto-regressive polynomial (\eqn{1 + \phi_1B + \phi_2B + ...}). True signs. +#' @param phi coefficients of the regular auto-regressive polynomial +#' (\eqn{1 + \phi_1B + \phi_2B + ...}). True signs. #' @param d regular differencing order. -#' @param theta coefficients of the regular moving average polynomial (\eqn{1 + \theta_1B + \theta_2B + ...}). True signs. -#' @param bphi coefficients of the seasonal auto-regressive polynomial. True signs. +#' @param theta coefficients of the regular moving average polynomial +#' (\eqn{1 + \theta_1B + \theta_2B + ...}). True signs. +#' @param bphi coefficients of the seasonal auto-regressive polynomial. True +#' signs. #' @param bd seasonal differencing order. -#' @param btheta coefficients of the seasonal moving average polynomial. True signs. +#' @param btheta coefficients of the seasonal moving average polynomial. True +#' signs. #' @param name name of the model. #' #' @return A `"JD3_SARIMA"` model. #' @export -sarima_model<-function(name="sarima", period, phi=NULL, d=0, theta=NULL, bphi=NULL, bd=0, btheta=NULL){ - return(structure( - list(name = name, period = period, phi = phi, d = d, theta = theta, - bphi = bphi, bd = bd, btheta = btheta), class="JD3_SARIMA")) +sarima_model <- function(name = "sarima", + period, + phi = NULL, + d = 0, + theta = NULL, + bphi = NULL, + bd = 0, + btheta = NULL) { + output <- list( + name = name, + period = period, + phi = phi, + d = d, + theta = theta, + bphi = bphi, + bd = bd, + btheta = btheta + ) + class(output) <- "JD3_SARIMA" + return(output) } #' SARIMA Properties @@ -31,11 +51,11 @@ sarima_model<-function(name="sarima", period, phi=NULL, d=0, theta=NULL, bphi=NU #' mod1 <- sarima_model(period = 12, d = 1, bd = 1, theta = 0.2, btheta = 0.2) #' sarima_properties(mod1) #' @export -sarima_properties<-function(model, nspectrum=601, nacf=36){ - jmodel<-.r2jd_sarima(model) - spectrum<-.jcall("jdplus/toolkit/base/r/arima/SarimaModels", "[D", "spectrum", jmodel, as.integer(nspectrum)) - acf<-.jcall("jdplus/toolkit/base/r/arima/SarimaModels", "[D", "acf", jmodel, as.integer(nacf)) - return(list(acf=acf, spectrum=spectrum)) +sarima_properties <- function(model, nspectrum = 601, nacf = 36) { + jmodel <- .r2jd_sarima(model) + spectrum <- .jcall("jdplus/toolkit/base/r/arima/SarimaModels", "[D", "spectrum", jmodel, as.integer(nspectrum)) + acf <- .jcall("jdplus/toolkit/base/r/arima/SarimaModels", "[D", "acf", jmodel, as.integer(nacf)) + return(list(acf = acf, spectrum = spectrum)) } @@ -51,25 +71,28 @@ sarima_properties<-function(model, nspectrum=601, nacf=36){ #' #' @examples #' # Airline model -#' s_model <- sarima_model(period = 12, d =1, bd = 1, theta = 0.2, btheta = 0.2) +#' s_model <- sarima_model(period = 12, d = 1, bd = 1, theta = 0.2, btheta = 0.2) #' x <- sarima_random(s_model, length = 64, seed = 0) #' plot(x, type = "l") #' @export -sarima_random<-function(model, length, stde=1, tdegree=0, seed=-1){ - if (!inherits(model, "JD3_SARIMA")) - stop("Invalid model") - return(.jcall("jdplus/toolkit/base/r/arima/SarimaModels", "[D", "random", - as.integer(length), - as.integer(model$period), - .jarray(as.numeric(model$phi)), - as.integer(model$d), - .jarray(as.numeric(model$theta)), - .jarray(as.numeric(model$bphi)), - as.integer(model$bd), - .jarray(as.numeric(model$btheta)), - stde, - as.integer(tdegree), - as.integer(seed))) +sarima_random <- function(model, length, stde = 1, tdegree = 0, seed = -1) { + if (!inherits(model, "JD3_SARIMA")) { + stop("Invalid model") + } + return(.jcall( + "jdplus/toolkit/base/r/arima/SarimaModels", "[D", "random", + as.integer(length), + as.integer(model$period), + .jarray(as.numeric(model$phi)), + as.integer(model$d), + .jarray(as.numeric(model$theta)), + .jarray(as.numeric(model$bphi)), + as.integer(model$bd), + .jarray(as.numeric(model$btheta)), + stde, + as.integer(tdegree), + as.integer(seed) + )) } #' Decompose SARIMA Model into three components trend, seasonal, irregular @@ -78,22 +101,26 @@ sarima_random<-function(model, length, stde=1, tdegree=0, seed=-1){ #' @param rmod trend threshold. #' @param epsphi seasonal tolerance (in degrees). #' -#' @return +#' @return An UCARIMA model #' @export #' #' @examples -#' model <- sarima_model(period = 12, d =1, bd = 1, theta = -0.6, btheta = -0.5) +#' model <- sarima_model(period = 12, d = 1, bd = 1, theta = -0.6, btheta = -0.5) #' ucm <- sarima_decompose(model) #' -sarima_decompose<-function(model, rmod=0, epsphi=0){ - if (!inherits(model, "JD3_SARIMA")) - stop("Invalid model") - jmodel<-.r2jd_sarima(model) - jucm<-.jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/core/ucarima/UcarimaModel;", "decompose", - jmodel, as.numeric(rmod), as.numeric(epsphi)) - if (is.jnull(jucm)) return(NULL) - return(.jd2r_ucarima(jucm)) - +sarima_decompose <- function(model, rmod = 0, epsphi = 0) { + if (!inherits(model, "JD3_SARIMA")) { + stop("Invalid model") + } + jmodel <- .r2jd_sarima(model) + jucm <- .jcall( + "jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/core/ucarima/UcarimaModel;", "decompose", + jmodel, as.numeric(rmod), as.numeric(epsphi) + ) + if (is.jnull(jucm)) { + return(NULL) + } + return(.jd2r_ucarima(jucm)) } #' ARIMA Model @@ -108,49 +135,54 @@ sarima_decompose<-function(model, rmod=0, epsphi=0){ #' @export #' #' @examples -arima_model<-function(name="arima", ar=1, delta=1, ma=1, variance=1){ - return(structure(list(name=name, ar=ar, delta=delta, ma=ma, var=variance), class="JD3_ARIMA")) +#' model <- arima_model("trend", ar = c(1, -.8), delta = c(1, -1), ma = c(1, -.5), var = 100) +arima_model <- function(name = "arima", ar = 1, delta = 1, ma = 1, variance = 1) { + return(structure(list(name = name, ar = ar, delta = delta, ma = ma, var = variance), class = "JD3_ARIMA")) } -.jd2r_doubleseq<-function(jobj, jprop){ - jseq<-.jcall(jobj, "Ljdplus/toolkit/base/api/data/DoubleSeq;", jprop) - return(.jcall(jseq, "[D", "toArray")) +.jd2r_doubleseq <- function(jobj, jprop) { + jseq <- .jcall(jobj, "Ljdplus/toolkit/base/api/data/DoubleSeq;", jprop) + return(.jcall(jseq, "[D", "toArray")) } -.jd2r_sarima<-function(jsarima){ - q<-.jcall("jdplus/toolkit/base/r/arima/SarimaModels", "[B", "toBuffer", jsarima) - rq<-RProtoBuf::read(modelling.SarimaModel, q) - return(.p2r_sarima(rq)) +.jd2r_sarima <- function(jsarima) { + q <- .jcall("jdplus/toolkit/base/r/arima/SarimaModels", "[B", "toBuffer", jsarima) + rq <- RProtoBuf::read(modelling.SarimaModel, q) + return(.p2r_sarima(rq)) } #' @export #' @rdname jd3_utilities -.r2jd_sarima<-function(model){ - return(.jcall("jdplus/toolkit/base/r/arima/SarimaModels", "Ljdplus/toolkit/base/core/sarima/SarimaModel;", "of", - as.integer(model$period), - .jarray(as.numeric(model$phi)), - as.integer(model$d), - .jarray(as.numeric(model$theta)), - .jarray(as.numeric(model$bphi)), - as.integer(model$bd), - .jarray(as.numeric(model$btheta)))) +.r2jd_sarima <- function(model) { + return(.jcall( + "jdplus/toolkit/base/r/arima/SarimaModels", "Ljdplus/toolkit/base/core/sarima/SarimaModel;", "of", + as.integer(model$period), + .jarray(as.numeric(model$phi)), + as.integer(model$d), + .jarray(as.numeric(model$theta)), + .jarray(as.numeric(model$bphi)), + as.integer(model$bd), + .jarray(as.numeric(model$btheta)) + )) } -.jd2r_arima<-function(jarima){ - q<-.jcall("jdplus/toolkit/base/r/arima/ArimaModels", "[B", "toBuffer", jarima) - rq<-RProtoBuf::read(modelling.ArimaModel, q) - return(.p2r_arima(rq)) +.jd2r_arima <- function(jarima) { + q <- .jcall("jdplus/toolkit/base/r/arima/ArimaModels", "[B", "toBuffer", jarima) + rq <- RProtoBuf::read(modelling.ArimaModel, q) + return(.p2r_arima(rq)) } -.r2jd_arima<-function(model){ - return(.jcall("jdplus/toolkit/base/r/arima/ArimaModels", "Ljdplus/toolkit/base/core/arima/ArimaModel;", "of", - .jarray(as.numeric(model$ar)), - .jarray(as.numeric(model$delta)), - .jarray(as.numeric(model$ma)), - as.numeric(model$var), FALSE)) +.r2jd_arima <- function(model) { + return(.jcall( + "jdplus/toolkit/base/r/arima/ArimaModels", "Ljdplus/toolkit/base/core/arima/ArimaModel;", "of", + .jarray(as.numeric(model$ar)), + .jarray(as.numeric(model$delta)), + .jarray(as.numeric(model$ma)), + as.numeric(model$var), FALSE + )) } #' Sum ARIMA Models @@ -170,154 +202,202 @@ arima_model<-function(name="arima", ar=1, delta=1, ma=1, variance=1){ #' polynomial and innovation variance of the sum. #' #' @examples -#' mod1 = arima_model(ar = c(0.1, 0.2), delta = 0, ma = 0) -#' mod2 = arima_model(ar = 0, delta = 0, ma = c(0.4)) +#' mod1 <- arima_model(ar = c(0.1, 0.2), delta = 0, ma = 0) +#' mod2 <- arima_model(ar = 0, delta = 0, ma = c(0.4)) #' arima_sum(mod1, mod2) #' @export -arima_sum<-function(...){ - components<-list(...) - return(arima_lsum(components)) +arima_sum <- function(...) { + components <- list(...) + return(arima_lsum(components)) } -arima_lsum<-function(components){ - q<-.jarray(lapply(components, .r2jd_arima), "jdplus/toolkit/base/core/arima/ArimaModel") - jsum<-.jcall("jdplus/toolkit/base/r/arima/ArimaModels", "Ljdplus/toolkit/base/core/arima/ArimaModel;", "sum", q) - return(.jd2r_arima(jsum)) +arima_lsum <- function(components) { + q <- .jarray(lapply(components, .r2jd_arima), "jdplus/toolkit/base/core/arima/ArimaModel") + jsum <- .jcall("jdplus/toolkit/base/r/arima/ArimaModels", "Ljdplus/toolkit/base/core/arima/ArimaModel;", "sum", q) + return(.jd2r_arima(jsum)) } -#' Remove an arima model from an existing one +#' Remove an arima model from an existing one. More exactly, m_diff = m_left - m_right iff m_left = m_right + m_diff. #' -#' @param left Left operand -#' @param right Right operand -#' @param simplify Simplify the results +#' @param left Left operand (JD3_ARIMA object) +#' @param right Right operand (JD3_ARIMA object) +#' @param simplify Simplify the results if possible (common roots in the auto-regressive and in the moving average polynomials, including unit roots) #' #' @return a `"JD3_ARIMA"` model. #' @export #' -#' @details #' #' @examples -#' mod1 = arima_model(delta = c(1,-2,1)) -#' mod2 = arima_model(variance=.01) -#' diff<- arima_difference(mod1, mod2) -#' -arima_difference<-function(left, right, simplify=TRUE){ - jleft<-.r2jd_arima(left) - jright<-.r2jd_arima(right) - jdiff<-.jcall(jleft, "Ljdplus/toolkit/base/core/arima/ArimaModel;", "minus", jright, as.logical(simplify)) - return(.jd2r_arima(jdiff)) +#' mod1 <- arima_model(delta = c(1, -2, 1)) +#' mod2 <- arima_model(variance = .01) +#' diff <- arima_difference(mod1, mod2) +#' sum <- arima_sum(diff, mod2) +#' # sum should be equal to mod1 +#' +arima_difference <- function(left, right, simplify = TRUE) { + jleft <- .r2jd_arima(left) + jright <- .r2jd_arima(right) + jdiff <- .jcall(jleft, "Ljdplus/toolkit/base/core/arima/ArimaModel;", "minus", jright, as.logical(simplify)) + return(.jd2r_arima(jdiff)) } -#' ARIMA Properties +#' Properties of an ARIMA model; the (pseudo-)spectrum and the auto-covariances of the model are returned #' #' @param model a `"JD3_ARIMA"` model (created with [arima_model()]). -#' @param nspectrum number of points in \[0, pi\] to calculate the spectrum. -#' @param nacf maximum lag at which to calculate the acf. +#' @param nspectrum number of points to calculate the spectrum; th points are uniformly distributed in \[0, pi\] +#' @param nac maximum lag at which to calculate the auto-covariances; if the model is non-stationary, the auto-covariances are computed on its stationary transformation. +#' @returns A list with tha auto-covariances and with the (pseudo-)spectrum #' #' @examples -#' mod1 = arima_model(ar = c(0.1, 0.2), delta = 0, ma = 0) +#' mod1 <- arima_model(ar = c(0.1, 0.2), delta = c(1, -1), ma = 0) #' arima_properties(mod1) #' @export -arima_properties<-function(model, nspectrum=601, nacf=36){ - jmodel<-.r2jd_arima(model) - spectrum<-.jcall("jdplus/toolkit/base/r/arima/ArimaModels", "[D", "spectrum", jmodel, as.integer(nspectrum)) - acf<-.jcall("jdplus/toolkit/base/r/arima/ArimaModels", "[D", "acf", jmodel, as.integer(nacf)) - return(list(acf=acf, spectrum=spectrum)) +arima_properties <- function(model, nspectrum = 601, nac = 36) { + jmodel <- .r2jd_arima(model) + spectrum <- .jcall("jdplus/toolkit/base/r/arima/ArimaModels", "[D", "spectrum", jmodel, as.integer(nspectrum)) + acf <- .jcall("jdplus/toolkit/base/r/arima/ArimaModels", "[D", "acf", jmodel, as.integer(nac)) + return(list(acf = acf, spectrum = spectrum)) } -#' Title +#' Creates an UCARIMA model, which is composed of ARIMA models with independent +#' innovations. #' -#' @param model -#' @param components -#' @param complements Complements of (some) components +#' @param model The reduced model. Usually not provided. +#' @param components The ARIMA models representing the components +#' @param complements Complements of (some) components. Usually not provided +#' @param checkmodel When the model is provided and *checkmodel* is TRUE, we +#' check that it indeed corresponds to the reduced form of the components; +#' similar controls are applied on complements. Currently not implemented #' -#' @return +#' @return A list with the reduced model, the components and their complements #' @export #' #' @examples -ucarima_model<-function(model=NULL, components, complements=NULL, checkmodel=FALSE){ - if (is.null(model)) - model<-arima_lsum(components) - else if (! is(model, "JD3_ARIMA") && ! is(model, "JD3_SARIMA")) stop("Invalid model") +#' mod1 <- arima_model("trend", delta = c(1, -2, 1)) +#' mod2 <- arima_model("noise", var = 1600) +#' hp <- ucarima_model(components = list(mod1, mod2)) +#' print(hp$model) +ucarima_model <- function(model = NULL, + components, + complements = NULL, + checkmodel = FALSE) { + if (is.null(model)) { + model <- arima_lsum(components) + } else if (!is(model, "JD3_ARIMA") && !is(model, "JD3_SARIMA")) { + stop("Invalid model") + } - # TODO: checkmodel - return(structure(list(model=model, components=components, complements=complements), class="JD3_UCARIMA")) + # TODO: checkmodel + output <- list(model = model, components = components, complements = complements) + class(output) <- "JD3_UCARIMA" + return(output) } -.r2jd_ucarima<-function(ucm){ - jmodel<-.r2jd_arima(ucm$model) - jcmps<-.jarray(lapply(ucm$components, .r2jd_arima), "jdplus/toolkit/base/core/arima/ArimaModel") - return(.jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/core/ucarima/UcarimaModel;", "of", jmodel, jcmps)) +.r2jd_ucarima <- function(ucm) { + jmodel <- .r2jd_arima(ucm$model) + jcmps <- .jarray( + lapply(ucm$components, .r2jd_arima), + "jdplus/toolkit/base/core/arima/ArimaModel" + ) + return(.jcall( + "jdplus/toolkit/base/r/arima/UcarimaModels", + "Ljdplus/toolkit/base/core/ucarima/UcarimaModel;", + "of", + jmodel, jcmps + )) } #' @export #' @rdname jd3_utilities -.jd2r_ucarima<-function(jucm){ -# model<-.jcall(jucm, "Ljdplus/toolkit/base/core/arima/ArimaModel;", "sum") -# jcmps<-.jcall(jucm, "[Ljdplus/toolkit/base/core/arima/ArimaModel;", "getComponents") -# return(ucarima_model(.jd2r_arima(model), lapply(jcmps, .jd2r_arima))) - q<-.jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "[B", "toBuffer", jucm) - rq<-RProtoBuf::read(modelling.UcarimaModel, q) - return(.p2r_ucarima(rq)) +.jd2r_ucarima <- function(jucm) { + # model<-.jcall(jucm, "Ljdplus/toolkit/base/core/arima/ArimaModel;", "sum") + # jcmps<-.jcall(jucm, "[Ljdplus/toolkit/base/core/arima/ArimaModel;", "getComponents") + # return(ucarima_model(.jd2r_arima(model), lapply(jcmps, .jd2r_arima))) + q <- .jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "[B", "toBuffer", jucm) + rq <- RProtoBuf::read(modelling.UcarimaModel, q) + return(.p2r_ucarima(rq)) } #' Wiener Kolmogorov Estimators #' -#' @param ucm UCARIMA model returned by [ucarima_model()]. -#' @param cmp -#' @param signal -#' @param nspectrum -#' @param nwk +#' @param ucm An UCARIMA model returned by [ucarima_model()]. +#' @param cmp Index of the component for which we want to compute the filter +#' @param signal TRUE for the signal (component), FALSE for the noise (complement) +#' @param nspectrum Number of points used to compute the (pseudo-) spectrum of the estimator +#' @param nwk Number of weights of the Wiener-Kolmogorov filter returned in the result #' -#' @return +#' @return A list with the (pseudo-)spectrum, the weights of the filter and the squared-gain function (with the same number of points as the spectrum) #' @export #' #' @examples -ucarima_wk<-function(ucm, cmp, signal=TRUE, nspectrum=601, nwk=300){ - jucm<-.r2jd_ucarima(ucm) - jwks<-.jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/core/ucarima/WienerKolmogorovEstimators;", "wienerKolmogorovEstimators", jucm) - jwk<-.jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/core/ucarima/WienerKolmogorovEstimator;", "finalEstimator", jwks, as.integer(cmp-1), signal) - - spectrum<-.jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "[D", "spectrum", jwk, as.integer(nspectrum)) - wk<-.jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "[D", "filter", jwk, as.integer(nwk)) - gain<-.jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "[D", "gain", jwk, as.integer(nspectrum)) - - return(structure(list(spectrum=spectrum, filter=wk, gain2=gain*gain), class="JD3_UCARIMA_WK")) +#' mod1 <- arima_model("trend", delta = c(1, -2, 1)) +#' mod2 <- arima_model("noise", var = 1600) +#' hp <- ucarima_model(components = list(mod1, mod2)) +#' wk1 <- ucarima_wk(hp, 1, nwk = 50) +#' wk2 <- ucarima_wk(hp, 2) +#' plot(wk1$filter, type = "h") +ucarima_wk <- function(ucm, cmp, signal = TRUE, nspectrum = 601, nwk = 300) { + jucm <- .r2jd_ucarima(ucm) + jwks <- .jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/core/ucarima/WienerKolmogorovEstimators;", "wienerKolmogorovEstimators", jucm) + jwk <- .jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/core/ucarima/WienerKolmogorovEstimator;", "finalEstimator", jwks, as.integer(cmp - 1), signal) + + spectrum <- .jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "[D", "spectrum", jwk, as.integer(nspectrum)) + wk <- .jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "[D", "filter", jwk, as.integer(nwk)) + gain <- .jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "[D", "gain", jwk, as.integer(nspectrum)) + + return(structure(list(spectrum = spectrum, filter = wk, gain2 = gain * gain), class = "JD3_UCARIMA_WK")) } -#' Title +#' Makes a UCARIMA model canonical; more specifically, put all the noise of the components in one dedicated component #' -#' @inheritParams ucarima_wk -#' @param adjust +#' @param ucm An UCARIMA model returned by [ucarima_model()]. +#' @param cmp Index of the component that will contain the noises; 0 if a new component with all the noises will be added to the model +#' @param adjust If TRUE, some noise could be added to the model to ensure that all the components has positive (pseudo-)spectrum #' -#' @return +#' @return A new UCARIMA model #' @export #' #' @examples -ucarima_canonical<-function(ucm, cmp=0, adjust=TRUE){ - jucm<-.r2jd_ucarima(ucm) - jnucm<-.jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/core/ucarima/UcarimaModel;", "doCanonical", - jucm, as.integer(cmp-1), as.logical(adjust)) - return(.jd2r_ucarima(jnucm)) +#' mod1 <- arima_model("trend", delta = c(1, -2, 1)) +#' mod2 <- arima_model("noise", var = 1600) +#' hp <- ucarima_model(components = list(mod1, mod2)) +#' hpc <- ucarima_canonical(hp, cmp = 2) +ucarima_canonical <- function(ucm, cmp = 0, adjust = TRUE) { + jucm <- .r2jd_ucarima(ucm) + jnucm <- .jcall( + "jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/core/ucarima/UcarimaModel;", "doCanonical", + jucm, as.integer(cmp - 1), as.logical(adjust) + ) + return(.jd2r_ucarima(jnucm)) } #' Estimate UCARIMA Model #' #' @inheritParams ucarima_wk -#' @param x univariate time series -#' @param stdev +#' @param x Univariate time series +#' @param stdev TRUE if standard deviation of the components are computed #' -#' @return matrix containing the different components. +#' @return A matrix containing the different components and their standard deviations if stdev is TRUE. #' @export #' #' @examples -ucarima_estimate<-function(x, ucm, stdev=TRUE){ - jucm<-.r2jd_ucarima(ucm) - jcmps<-.jcall("jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "estimate", - as.numeric(x), jucm, as.logical(stdev)) - return(.jd2r_matrix(jcmps)) +#' mod1 <- arima_model("trend", delta = c(1, -2, 1)) +#' mod2 <- arima_model("noise", var = 16) +#' hp <- ucarima_model(components = list(mod1, mod2)) +#' s <- log(aggregate(retail$AutomobileDealers)) +#' all <- ucarima_estimate(s, hp, stdev = TRUE) +#' plot(s, type = "l") +#' t <- ts(all[, 1], frequency = frequency(s), start = start(s)) +#' lines(t, col = "blue") +ucarima_estimate <- function(x, ucm, stdev = TRUE) { + jucm <- .r2jd_ucarima(ucm) + jcmps <- .jcall( + "jdplus/toolkit/base/r/arima/UcarimaModels", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "estimate", + as.numeric(x), jucm, as.logical(stdev) + ) + return(.jd2r_matrix(jcmps)) } #' Estimate SARIMA Model @@ -335,45 +415,51 @@ ucarima_estimate<-function(x, ucm, stdev=TRUE){ #' #' @examples #' y <- ABS$X0.2.09.10.M -#' sarima_estimate(y, order = c(0,1,1), seasonal = c(0,1,1)) -sarima_estimate<-function(x, order=c(0,0,0), seasonal = list(order=c(0,0,0), period=NA), mean=FALSE, xreg=NULL, eps = 1e-9){ - if (!is.list(seasonal) && is.numeric(seasonal) && length(seasonal) == 3) { - seasonal <- list(order = seasonal, - period = NA) - } - if (is.na(seasonal$period)) - seasonal$period <- frequency(x) - jxreg<-.r2jd_matrix(xreg) - jestim<-.jcall("jdplus/toolkit/base/r/arima/SarimaModels", "Ljdplus/toolkit/base/core/regarima/RegArimaEstimation;", "estimate", - as.numeric(x), as.integer(order), as.integer(seasonal$period), as.integer(seasonal$order), as.logical(mean), jxreg, .jnull("[D"), as.numeric(eps)) - bytes<-.jcall("jdplus/toolkit/base/r/arima/SarimaModels", "[B", "toBuffer", jestim) - p<-RProtoBuf::read(regarima.RegArimaModel$Estimation, bytes) - res <- .p2r_regarima_estimation(p) - - if (length(res$b) > 0) { - - names_xreg <- colnames(xreg) - if (is.null (names_xreg) && !is.null (xreg)){ - if (is.matrix(xreg)) { - # unnamed matrix regressors - names_xreg <- sprintf("xreg_%i", seq_len(ncol(xreg))) - } else { - # vector external regressor - names_xreg <- "xreg_1" - } +#' sarima_estimate(y, order = c(0, 1, 1), seasonal = c(0, 1, 1)) +sarima_estimate <- function(x, order = c(0, 0, 0), seasonal = list(order = c(0, 0, 0), period = NA), mean = FALSE, xreg = NULL, eps = 1e-9) { + if (!is.list(seasonal) && is.numeric(seasonal) && length(seasonal) == 3) { + seasonal <- list( + order = seasonal, + period = NA + ) + } + if (is.na(seasonal$period)) { + seasonal$period <- frequency(x) } - if (mean) { - names_xreg <- c("intercept", names_xreg) + jxreg <- .r2jd_matrix(xreg) + jestim <- .jcall( + "jdplus/toolkit/base/r/arima/SarimaModels", "Ljdplus/toolkit/base/core/regarima/RegArimaEstimation;", "estimate", + as.numeric(x), as.integer(order), as.integer(seasonal$period), as.integer(seasonal$order), as.logical(mean), jxreg, .jnull("[D"), as.numeric(eps) + ) + bytes <- .jcall("jdplus/toolkit/base/r/arima/SarimaModels", "[B", "toBuffer", jestim) + p <- RProtoBuf::read(regarima.RegArimaModel$Estimation, bytes) + res <- .p2r_regarima_estimation(p) + + if (length(res$b) > 0) { + names_xreg <- colnames(xreg) + if (is.null(names_xreg) && !is.null(xreg)) { + if (is.matrix(xreg)) { + # unnamed matrix regressors + names_xreg <- sprintf("xreg_%i", seq_len(ncol(xreg))) + } else { + # vector external regressor + names_xreg <- "xreg_1" + } + } + if (mean) { + names_xreg <- c("intercept", names_xreg) + } + names(res$b) <- names_xreg } - names(res$b) <- names_xreg - } - names(res$parameters$val) <- c(sprintf("phi(%i)", seq_len(order[1])), - sprintf("bphi(%i)", seq_len(seasonal$order[1])), - sprintf("theta(%i)", seq_len(order[3])), - sprintf("btheta(%i)", seq_len(seasonal$order[3]))) - res$orders <- list(order = order, seasonal = seasonal) - class(res) <- c("JD3_SARIMA_ESTIMATE", "JD3_REGARIMA_RSLTS") - return(res) + names(res$parameters$val) <- c( + sprintf("phi(%i)", seq_len(order[1])), + sprintf("bphi(%i)", seq_len(seasonal$order[1])), + sprintf("theta(%i)", seq_len(order[3])), + sprintf("btheta(%i)", seq_len(seasonal$order[3])) + ) + res$orders <- list(order = order, seasonal = seasonal) + class(res) <- c("JD3_SARIMA_ESTIMATE", "JD3_REGARIMA_RSLTS") + return(res) } #' Title @@ -391,16 +477,30 @@ sarima_estimate<-function(x, order=c(0,0,0), seasonal = list(order=c(0,0,0), per #' #' @examples #' y <- ABS$X0.2.09.10.M -#' sarima_hannan_rissanen(y, order = c(0,1,1), seasonal = c(0,1,1)) -sarima_hannan_rissanen<-function(x, order=c(0,0,0), seasonal = list(order=c(0,0,0), period=NA), initialization=c("Ols", "Levinson", "Burg"), biasCorrection=TRUE, finalCorrection=TRUE){ - if (!is.list(seasonal) && is.numeric(seasonal) && length(seasonal) == 3) { - initialization<-match.arg(initialization) - seasonal <- list(order = seasonal, - period = NA) - } - if (is.na(seasonal$period)) - seasonal$period <- frequency(x) - jmodel<-.jcall("jdplus/toolkit/base/r/arima/SarimaModels", "Ljdplus/toolkit/base/core/sarima/SarimaModel;", "hannanRissanen", - as.numeric(x), as.integer(order), as.integer(seasonal$period), as.integer(seasonal$order), as.character(initialization), as.logical(biasCorrection), as.logical(finalCorrection)) - return(.jd2r_sarima(jmodel)) +#' sarima_hannan_rissanen(y, order = c(0, 1, 1), seasonal = c(0, 1, 1)) +sarima_hannan_rissanen <- function(x, + order = c(0, 0, 0), + seasonal = list(order = c(0, 0, 0), period = NA), + initialization = c("Ols", "Levinson", "Burg"), + biasCorrection = TRUE, + finalCorrection = TRUE) { + if (!is.list(seasonal) && is.numeric(seasonal) && length(seasonal) == 3) { + initialization <- match.arg(initialization) + seasonal <- list( + order = seasonal, + period = NA + ) + } + if (is.na(seasonal$period)) { + seasonal$period <- frequency(x) + } + jmodel <- .jcall( + "jdplus/toolkit/base/r/arima/SarimaModels", + "Ljdplus/toolkit/base/core/sarima/SarimaModel;", + "hannanRissanen", + as.numeric(x), as.integer(order), as.integer(seasonal$period), + as.integer(seasonal$order), as.character(initialization), + as.logical(biasCorrection), as.logical(finalCorrection) + ) + return(.jd2r_sarima(jmodel)) } diff --git a/R/calendars.R b/R/calendars.R index 3ad75c65..dc413cd9 100644 --- a/R/calendars.R +++ b/R/calendars.R @@ -4,51 +4,54 @@ #' @include protobuf.R jd2r.R NULL -HOLIDAY<-'JD3_HOLIDAY' -FIXEDDAY<-'JD3_FIXEDDAY' -FIXEDWEEKDAY<-'JD3_FIXEDWEEKDAY' -EASTERDAY<-'JD3_EASTERDAY' -SPECIALDAY<-'JD3_SPECIALDAY' -SINGLEDAY<-'JD3_SINGLEDAY' - -.r2p_validityPeriod<-function(start, end){ - vp<-jd3.ValidityPeriod$new() +HOLIDAY <- "JD3_HOLIDAY" +FIXEDDAY <- "JD3_FIXEDDAY" +FIXEDWEEKDAY <- "JD3_FIXEDWEEKDAY" +EASTERDAY <- "JD3_EASTERDAY" +SPECIALDAY <- "JD3_SPECIALDAY" +SINGLEDAY <- "JD3_SINGLEDAY" + +.r2p_validityPeriod <- function(start, end) { + vp <- jd3.ValidityPeriod$new() if (is.null(start)) { - pstart<-DATE_MIN + pstart <- DATE_MIN } else { - pstart<-parseDate(start) + pstart <- parseDate(start) } - if (is.null(end)){ - pend<-DATE_MAX + if (is.null(end)) { + pend <- DATE_MAX } else { - pend<-parseDate(end) + pend <- parseDate(end) } - vp$start<-pstart - vp$end<-pend + vp$start <- pstart + vp$end <- pend return(vp) } -.p2r_validityPeriod<-function(vp){ - pstart<-vp$start - if (pstart == DATE_MIN) - start<-NULL - else - start<-as.Date(sprintf("%04i-%02i-%02i", pstart$year, pstart$month, pstart$day)) +.p2r_validityPeriod <- function(vp) { + pstart <- vp$start + if (pstart == DATE_MIN) { + start <- NULL + } else { + start <- as.Date(sprintf("%04i-%02i-%02i", pstart$year, pstart$month, pstart$day)) + } - pend<-vp$end - if (pend == DATE_MAX) - end<-NULL - else - end<-as.Date(sprintf("%04i-%02i-%02i", pend$year, pend$month, pend$day)) - if (is.null(start) && is.null(end)) + pend <- vp$end + if (pend == DATE_MAX) { + end <- NULL + } else { + end <- as.Date(sprintf("%04i-%02i-%02i", pend$year, pend$month, pend$day)) + } + if (is.null(start) && is.null(end)) { return(NULL) - else - return(list(start=start, end=end)) + } else { + return(list(start = start, end = end)) + } } -.length_ts <- function(s){ - if (is.mts(s)){ +.length_ts <- function(s) { + if (is.mts(s)) { nrow(s) } else { length(s) @@ -69,32 +72,33 @@ SINGLEDAY<-'JD3_SINGLEDAY' #' #' @examples #' day <- fixed_day(7, 21, .9) -#' day # July 21st, with weight=0.9, on the whole sample +#' day # July 21st, with weight=0.9, on the whole sample #' day <- fixed_day(12, 25, .5, validity = list(start = "2010-01-01")) #' day # December 25th, with weight=0.5, from January 2010 -#' day <- fixed_day(12, 25, .5, validity = list(start="1968-02-01", end = "2010-01-01")) +#' day <- fixed_day(12, 25, .5, validity = list(start = "1968-02-01", end = "2010-01-01")) #' day # December 25th, with weight=0.9, from February 1968 until January 2010 #' @seealso \code{\link{national_calendar}}, \code{\link{special_day}},\code{\link{easter_day}} #' @references #' More information on calendar correction in JDemetra+ online documentation: #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} -fixed_day<-function(month, day, weight=1, validity=NULL){ - return(structure(list(month=month, day=day, weight=weight, validity=validity), class=c(FIXEDDAY, HOLIDAY))) +fixed_day <- function(month, day, weight = 1, validity = NULL) { + return(structure(list(month = month, day = day, weight = weight, validity = validity), class = c(FIXEDDAY, HOLIDAY))) } -.p2r_fixedday<-function(p){ - return(structure(list(month=p$month, day=p$day, weight=p$weight, validity=.p2r_validityPeriod(p$validity)), class=FIXEDDAY)) +.p2r_fixedday <- function(p) { + return(structure(list(month = p$month, day = p$day, weight = p$weight, validity = .p2r_validityPeriod(p$validity)), class = FIXEDDAY)) } -.r2p_fixedday<-function(r){ - fd<-jd3.FixedDay$new() - fd$month<-r$month - fd$day<-r$day - fd$weight<-r$weight - if (is.null(r$validity)) - fd$validity<-.r2p_validityPeriod(NULL, NULL) - else - fd$validity<-.r2p_validityPeriod(r$validity$start, r$validity$end) +.r2p_fixedday <- function(r) { + fd <- jd3.FixedDay$new() + fd$month <- r$month + fd$day <- r$day + fd$weight <- r$weight + if (is.null(r$validity)) { + fd$validity <- .r2p_validityPeriod(NULL, NULL) + } else { + fd$validity <- .r2p_validityPeriod(r$validity$start, r$validity$end) + } return(fd) } @@ -124,24 +128,25 @@ fixed_day<-function(month, day, weight=1, validity=NULL){ #' More information on calendar correction in JDemetra+ online documentation: #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} #' -fixed_week_day<-function(month, week, dayofweek, weight=1, validity=NULL){ - return(structure(list(month=month, week=week, dayofweek=dayofweek, weight=weight, validity=validity), class=c(FIXEDWEEKDAY, HOLIDAY))) +fixed_week_day <- function(month, week, dayofweek, weight = 1, validity = NULL) { + return(structure(list(month = month, week = week, dayofweek = dayofweek, weight = weight, validity = validity), class = c(FIXEDWEEKDAY, HOLIDAY))) } -.p2r_fixedweekday<-function(p){ - return(fixed_week_day(p$month, week=p$position, dayofweek=p$weekday, weight=p$weight, validity=.p2r_validityPeriod(p$validity))) +.p2r_fixedweekday <- function(p) { + return(fixed_week_day(p$month, week = p$position, dayofweek = p$weekday, weight = p$weight, validity = .p2r_validityPeriod(p$validity))) } -.r2p_fixedweekday<-function(r){ - fd<-jd3.FixedWeekDay$new() - fd$month<-r$month +.r2p_fixedweekday <- function(r) { + fd <- jd3.FixedWeekDay$new() + fd$month <- r$month fd$position <- r$week fd$weekday <- r$dayofweek - fd$weight<-r$weight - if (is.null(r$validity)) - fd$validity<-.r2p_validityPeriod(NULL, NULL) - else - fd$validity<-.r2p_validityPeriod(r$validity$start, r$validity$end) + fd$weight <- r$weight + if (is.null(r$validity)) { + fd$validity <- .r2p_validityPeriod(NULL, NULL) + } else { + fd$validity <- .r2p_validityPeriod(r$validity$start, r$validity$end) + } return(fd) } @@ -155,35 +160,38 @@ fixed_week_day<-function(month, week, dayofweek, weight=1, validity=NULL){ #' @param julian Boolean indicating if Julian calendar must be used. #' #' @examples -#' easter_day(1) #Easter Monday +#' easter_day(1) # Easter Monday #' easter_day(-2) # Easter Good Friday #' # Corpus Christi 60 days after Easter #' # Sunday in Julian calendar with weight 0.5, from January 2000 to December 2020 -#' easter_day(offset=60,julian=TRUE,weight=0.5, -#' validity = list(start="2000-01-01", end = "2020-12-01")) +#' easter_day( +#' offset = 60, julian = TRUE, weight = 0.5, +#' validity = list(start = "2000-01-01", end = "2020-12-01") +#' ) #' @seealso \code{\link{national_calendar}}, \code{\link{fixed_day}},\code{\link{special_day}},\code{\link{fixed_week_day}} #' @references #' More information on calendar correction in JDemetra+ online documentation: #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} #' #' @export -easter_day<-function(offset, julian=FALSE, weight=1, validity=NULL){ - return(structure(list(offset=offset, julian=julian, weight=weight, validity=validity), class=c(EASTERDAY, HOLIDAY))) +easter_day <- function(offset, julian = FALSE, weight = 1, validity = NULL) { + return(structure(list(offset = offset, julian = julian, weight = weight, validity = validity), class = c(EASTERDAY, HOLIDAY))) } -.p2r_easterday<-function(p){ +.p2r_easterday <- function(p) { return(easter_day(p$offset, p$julian, p$weight, .p2r_validityPeriod(p$validity))) } -.r2p_easterday<-function(r){ - fd<-jd3.EasterRelatedDay$new() - fd$offset<-r$offset - fd$julian<-r$julian - fd$weight<-r$weight - if (is.null(r$validity)) - fd$validity<-.r2p_validityPeriod(NULL, NULL) - else - fd$validity<-.r2p_validityPeriod(r$validity$start, r$validity$end) +.r2p_easterday <- function(r) { + fd <- jd3.EasterRelatedDay$new() + fd$offset <- r$offset + fd$julian <- r$julian + fd$weight <- r$weight + if (is.null(r$validity)) { + fd$validity <- .r2p_validityPeriod(NULL, NULL) + } else { + fd$validity <- .r2p_validityPeriod(r$validity$start, r$validity$end) + } return(fd) } @@ -204,18 +212,18 @@ easter_day<-function(offset, julian=FALSE, weight=1, validity=NULL){ #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} #' #' @export -single_day<-function(date, weight=1){ - return(structure(list(date=date, weight=weight), class=c(SINGLEDAY, HOLIDAY))) +single_day <- function(date, weight = 1) { + return(structure(list(date = date, weight = weight), class = c(SINGLEDAY, HOLIDAY))) } -.p2r_singleday<-function(p){ +.p2r_singleday <- function(p) { return(single_day(.p2r_date(p$date), p$weight)) } -.r2p_singleday<-function(r){ - sd<-jd3.SingleDate$new() - sd$date<-parseDate(r$date) - sd$weight<-r$weight +.r2p_singleday <- function(r) { + sd <- jd3.SingleDate$new() + sd$date <- parseDate(r$date) + sd$weight <- r$weight return(sd) } @@ -258,45 +266,51 @@ single_day<-function(date, weight=1){ #' # To add Easter Monday #' special_day("EASTERMONDAY") #' # To define a holiday for the day after Christmas, with validity and weight -#' special_day("CHRISTMAS", offset = 1, weight = 0.8, -#' validity = list(start="2000-01-01", end = "2020-12-01")) +#' special_day("CHRISTMAS", +#' offset = 1, weight = 0.8, +#' validity = list(start = "2000-01-01", end = "2020-12-01") +#' ) #' @seealso \code{\link{national_calendar}}, \code{\link{fixed_day}}, \code{\link{easter_day}} #' @references #' More information on calendar correction in JDemetra+ online documentation: #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} -special_day<-function(event, offset=0, weight=1, validity=NULL){ - return(structure(list(event=event, offset=offset, weight=weight, validity=validity), class=c(SPECIALDAY, HOLIDAY))) +special_day <- function(event, offset = 0, weight = 1, validity = NULL) { + return(structure(list(event = event, offset = offset, weight = weight, validity = validity), class = c(SPECIALDAY, HOLIDAY))) } -.p2r_specialday<-function(p){ +.p2r_specialday <- function(p) { return(special_day(.enum_extract(jd3.CalendarEvent, p$event), p$offset, p$weight, .p2r_validityPeriod(p$validity))) } -.r2p_specialday<-function(r){ - pd<-jd3.PrespecifiedHoliday$new() - pd$event<-.enum_of(jd3.CalendarEvent, r$event, "HOLIDAY") - pd$offset<-r$offset - pd$weight<-r$weight - if (is.null(r$validity)) - pd$validity<-.r2p_validityPeriod(NULL, NULL) - else - pd$validity<-.r2p_validityPeriod(r$validity$start, r$validity$end) +.r2p_specialday <- function(r) { + pd <- jd3.PrespecifiedHoliday$new() + pd$event <- .enum_of(jd3.CalendarEvent, r$event, "HOLIDAY") + pd$offset <- r$offset + pd$weight <- r$weight + if (is.null(r$validity)) { + pd$validity <- .r2p_validityPeriod(NULL, NULL) + } else { + pd$validity <- .r2p_validityPeriod(r$validity$start, r$validity$end) + } return(pd) } #' @export #' @rdname jd3_utilities -.p2jd_calendar<-function(pcalendar){ - bytes<-pcalendar$serialize(NULL) - jcal<-.jcall("jdplus/toolkit/base/r/calendar/Calendars", "Ljdplus/toolkit/base/api/timeseries/calendars/Calendar;", - "calendarOf", bytes) +.p2jd_calendar <- function(pcalendar) { + bytes <- pcalendar$serialize(NULL) + jcal <- .jcall( + "jdplus/toolkit/base/r/calendar/Calendars", "Ljdplus/toolkit/base/api/timeseries/calendars/Calendar;", + "calendarOf", bytes + ) return(jcal) } -.group_names <- function(x, contrasts = TRUE){ - if (!is.matrix(x)) +.group_names <- function(x, contrasts = TRUE) { + if (!is.matrix(x)) { return(x) - col_names <- seq_len(ncol(x)) - !contrasts #if !contrast then it starts from 0 + } + col_names <- seq_len(ncol(x)) - !contrasts # if !contrast then it starts from 0 colnames(x) <- sprintf("group_%i", col_names) x } @@ -318,7 +332,7 @@ special_day<-function(event, offset=0, weight=1, validity=NULL){ #' @param groups Groups of days. The length of the array must be 7. It indicates to what group each week day #' belongs. The first item corresponds to Mondays and the last one to Sundays. The group used for contrasts (usually Sundays) is identified by 0. #' The other groups are identified by 1, 2,... n (<= 6). For instance, usual trading days are defined by c(1,2,3,4,5,6,0), -#' week days by c(1,1,1,1,1,0,0), week days, Saturdays, Sundays by c(1,1,1,1,1,2,0) etc... +#' week days by c(1,1,1,1,1,0,0), week days, Saturdays, Sundays by c(1,1,1,1,1,2,0) etc. #' @param contrasts If true, the variables are defined by contrasts with the 0-group. Otherwise, raw number of days is provided. #' @return Time series (object of class \code{c("ts","mts","matrix")}) corresponding to each group, starting with the 0-group (\code{contrasts = FALSE}) #' or the 1-group (\code{contrasts = TRUE}). @@ -330,20 +344,22 @@ special_day<-function(event, offset=0, weight=1, validity=NULL){ #' @examples #' # Monthly regressors for Trading Days: each type of day is different #' # contrasts to Sundays (6 series) -#' regs_td<- td(12,c(2020,1),60, groups = c(1, 2, 3, 4, 5, 6, 0), contrasts = TRUE) +#' regs_td <- td(12, c(2020, 1), 60, groups = c(1, 2, 3, 4, 5, 6, 0), contrasts = TRUE) #' # Quarterly regressors for Working Days: week days are similar #' # contrasts to week-end days (1 series) -#' regs_wd<- td(4,c(2020,1),60, groups = c(1, 1, 1, 1, 1, 0, 0), contrasts = TRUE) -td<-function(frequency, start, length, s, groups=c(1,2,3,4,5,6,0), contrasts=TRUE){ +#' regs_wd <- td(4, c(2020, 1), 60, groups = c(1, 1, 1, 1, 1, 0, 0), contrasts = TRUE) +td <- function(frequency, start, length, s, groups = c(1, 2, 3, 4, 5, 6, 0), contrasts = TRUE) { if (!missing(s) && is.ts(s)) { frequency <- stats::frequency(s) start <- stats::start(s) length <- .length_ts(s) } - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - igroups<-as.integer(groups) - jm<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", - "td", jdom, igroups, contrasts) + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + igroups <- as.integer(groups) + jm <- .jcall( + "jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", + "td", jdom, igroups, contrasts + ) data <- .jd2r_matrix(jm) data <- .group_names(data, contrasts = contrasts) return(ts(data, start = start, frequency = frequency)) @@ -377,29 +393,30 @@ td<-function(frequency, start, length, s, groups=c(1,2,3,4,5,6,0), contrasts=TRU #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} #' @examples #' BE <- national_calendar(list( -#' fixed_day(7,21), -#' special_day("NEWYEAR"), -#' special_day("CHRISTMAS"), -#' special_day("MAYDAY"), -#' special_day("EASTERMONDAY"), -#' special_day("ASCENSION"), -#' special_day("WHITMONDAY"), -#' special_day("ASSUMPTION"), -#' special_day("ALLSAINTSDAY"), -#' special_day("ARMISTICE"))) -#' q<-holidays(BE, "2021-01-01", 366*10, type="All") -#' plot(apply(q,1, max)) +#' fixed_day(7, 21), +#' special_day("NEWYEAR"), +#' special_day("CHRISTMAS"), +#' special_day("MAYDAY"), +#' special_day("EASTERMONDAY"), +#' special_day("ASCENSION"), +#' special_day("WHITMONDAY"), +#' special_day("ASSUMPTION"), +#' special_day("ALLSAINTSDAY"), +#' special_day("ARMISTICE") +#' )) +#' q <- holidays(BE, "2021-01-01", 366 * 10, type = "All") +#' plot(apply(q, 1, max)) #' @export holidays <- function(calendar, start, length, - nonworking=c(6,7), - type=c("Skip", "All", "NextWorkingDay", "PreviousWorkingDay"), - single=FALSE) { - type<-match.arg(type) - pcal<-.r2p_calendar(calendar) - jcal<-.p2jd_calendar(pcal) - jm<-.jcall( + nonworking = c(6, 7), + type = c("Skip", "All", "NextWorkingDay", "PreviousWorkingDay"), + single = FALSE) { + type <- match.arg(type) + pcal <- .r2p_calendar(calendar) + jcal <- .p2jd_calendar(pcal) + jm <- .jcall( obj = "jdplus/toolkit/base/r/calendar/Calendars", returnSig = "Ljdplus/toolkit/base/api/math/matrices/Matrix;", method = "holidays", @@ -432,24 +449,28 @@ holidays <- function(calendar, #' @export #' @examples #' BE <- national_calendar(list( -#' fixed_day(7,21), -#' special_day("NEWYEAR"), -#' special_day("CHRISTMAS"), -#' special_day("MAYDAY"), -#' special_day("EASTERMONDAY"), -#' special_day("ASCENSION"), -#' special_day("WHITMONDAY"), -#' special_day("ASSUMPTION"), -#' special_day("ALLSAINTSDAY"), -#' special_day("ARMISTICE"))) -#' lt<-long_term_mean(BE,12, -#' groups = c(1,1,1,1,1,0,0), -#' holiday = 7) -long_term_mean <-function(calendar,frequency,groups=c(1,2,3,4,5,6,0), holiday=7){ - pcal<-.r2p_calendar(calendar) - jcal<-.p2jd_calendar(pcal) - jm<-.jcall("jdplus/toolkit/base/r/calendar/Calendars", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", - "longTermMean", jcal, as.integer(frequency), as.integer(groups), as.integer(holiday)) +#' fixed_day(7, 21), +#' special_day("NEWYEAR"), +#' special_day("CHRISTMAS"), +#' special_day("MAYDAY"), +#' special_day("EASTERMONDAY"), +#' special_day("ASCENSION"), +#' special_day("WHITMONDAY"), +#' special_day("ASSUMPTION"), +#' special_day("ALLSAINTSDAY"), +#' special_day("ARMISTICE") +#' )) +#' lt <- long_term_mean(BE, 12, +#' groups = c(1, 1, 1, 1, 1, 0, 0), +#' holiday = 7 +#' ) +long_term_mean <- function(calendar, frequency, groups = c(1, 2, 3, 4, 5, 6, 0), holiday = 7) { + pcal <- .r2p_calendar(calendar) + jcal <- .p2jd_calendar(pcal) + jm <- .jcall( + "jdplus/toolkit/base/r/calendar/Calendars", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", + "longTermMean", jcal, as.integer(frequency), as.integer(groups), as.integer(holiday) + ) res <- .jd2r_matrix(jm) return(.group_names(res, contrasts = FALSE)) } @@ -470,10 +491,10 @@ long_term_mean <-function(calendar,frequency,groups=c(1,2,3,4,5,6,0), holiday=7) #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} # #' @examples -#' #Dates from 2018(included) to 2023 (included) +#' # Dates from 2018(included) to 2023 (included) #' easter_dates(2018, 2023) -easter_dates<-function(year0, year1, julian = FALSE){ - dates<-.jcall("jdplus/toolkit/base/r/calendar/Calendars", "[S", "easter", as.integer(year0), as.integer(year1), as.logical(julian)) +easter_dates <- function(year0, year1, julian = FALSE) { + dates <- .jcall("jdplus/toolkit/base/r/calendar/Calendars", "[S", "easter", as.integer(year0), as.integer(year1), as.logical(julian)) return(sapply(dates, as.Date)) } @@ -492,70 +513,82 @@ easter_dates<-function(year0, year1, julian = FALSE){ #' More information on calendar correction in JDemetra+ online documentation: #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} #' @export -stock_td<-function(frequency, start, length, s, w = 31){ +stock_td <- function(frequency, start, length, s, w = 31) { if (!missing(s) && is.ts(s)) { frequency <- stats::frequency(s) start <- stats::start(s) length <- .length_ts(s) } jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) - jm<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "stockTradingDays", jdom, as.integer(w)) + jm <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "stockTradingDays", jdom, as.integer(w)) data <- .jd2r_matrix(jm) colnames(data) <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday") - return(ts(data, frequency = frequency, start= start)) + return(ts(data, frequency = frequency, start = start)) } -.r2p_holiday<-function(r){ - if (is(r, SPECIALDAY)){return(.r2p_specialday(r))} - if (is(r, FIXEDDAY)){return(.r2p_fixedday(r))} - if (is(r, EASTERDAY)){return(.r2p_easterday(r))} - if (is(r, FIXEDWEEKDAY)){return(.r2p_fixedweekday(r))} - if (is(r, SINGLEDAY)){return(.r2p_singleday(r))} +.r2p_holiday <- function(r) { + if (is(r, SPECIALDAY)) { + return(.r2p_specialday(r)) + } + if (is(r, FIXEDDAY)) { + return(.r2p_fixedday(r)) + } + if (is(r, EASTERDAY)) { + return(.r2p_easterday(r)) + } + if (is(r, FIXEDWEEKDAY)) { + return(.r2p_fixedweekday(r)) + } + if (is(r, SINGLEDAY)) { + return(.r2p_singleday(r)) + } return(NULL) } -.p2r_calendar<-function(p){ +.p2r_calendar <- function(p) { return(structure( - list(days=c(lapply(p$fixed_days, function(z) .p2r_fixedday(z)), - lapply(p$fixed_week_days, function(z) .p2r_fixedweekday(z)), - lapply(p$easter_related_days, function(z) .p2r_easterday(z)), - lapply(p$prespecified_holidays, function(z) .p2r_specialday(z)), - lapply(p$single_dates, function(z) .p2r_singleday(z)), - mean_correction=p$mean_correction) - ), class=c('JD3_CALENDAR', 'JD3_CALENDARDEFINITION'))) + list(days = c(lapply(p$fixed_days, function(z) .p2r_fixedday(z)), + lapply(p$fixed_week_days, function(z) .p2r_fixedweekday(z)), + lapply(p$easter_related_days, function(z) .p2r_easterday(z)), + lapply(p$prespecified_holidays, function(z) .p2r_specialday(z)), + lapply(p$single_dates, function(z) .p2r_singleday(z)), + mean_correction = p$mean_correction + )), + class = c("JD3_CALENDAR", "JD3_CALENDARDEFINITION") + )) } #' @export #' @rdname jd3_utilities -.r2p_calendar<-function(r){ - p<-jd3.Calendar$new() - if (length(r$days)>0){ - #select fixed days - sel<-which(sapply(r$days,function(z) is(z, FIXEDDAY))) - p$fixed_days<-lapply(r$days[sel], function(z) .r2p_fixedday(z)) - #select fixed week days - sel<-which(sapply(r$days,function(z) is(z, FIXEDWEEKDAY))) - p$fixed_week_days<-lapply(r$days[sel], function(z) .r2p_fixedweekday(z)) +.r2p_calendar <- function(r) { + p <- jd3.Calendar$new() + if (length(r$days) > 0) { + # select fixed days + sel <- which(sapply(r$days, function(z) is(z, FIXEDDAY))) + p$fixed_days <- lapply(r$days[sel], function(z) .r2p_fixedday(z)) + # select fixed week days + sel <- which(sapply(r$days, function(z) is(z, FIXEDWEEKDAY))) + p$fixed_week_days <- lapply(r$days[sel], function(z) .r2p_fixedweekday(z)) # select easter days - sel<-which(sapply(r$days,function(z) is(z, EASTERDAY))) - p$easter_related_days<-lapply(r$days[sel], function(z) .r2p_easterday(z)) + sel <- which(sapply(r$days, function(z) is(z, EASTERDAY))) + p$easter_related_days <- lapply(r$days[sel], function(z) .r2p_easterday(z)) # select special days - sel<-which(sapply(r$days,function(z) is(z, SPECIALDAY))) - p$prespecified_holidays<-lapply(r$days[sel], function(z) .r2p_specialday(z)) + sel <- which(sapply(r$days, function(z) is(z, SPECIALDAY))) + p$prespecified_holidays <- lapply(r$days[sel], function(z) .r2p_specialday(z)) # select single days - sel<-which(sapply(r$days,function(z) is(z, SINGLEDAY))) - p$single_dates<-lapply(r$days[sel], function(z) .r2p_singleday(z)) + sel <- which(sapply(r$days, function(z) is(z, SINGLEDAY))) + p$single_dates <- lapply(r$days[sel], function(z) .r2p_singleday(z)) } - p$mean_correction<-r$mean_correction + p$mean_correction <- r$mean_correction return(p) } #' Create a Chained Calendar #' -#'@description -#'Allows to combine two calendars, one before and one after a given date. +#' @description +#' Allows to combine two calendars, one before and one after a given date. #' -#'@details +#' @details #' A chained calendar is an useful option when major changes in the composition of the holidays take place. #' In such a case two calendars describing the situation before and after the change of regime can be defined #' and bound together, one before the break and one after the break. @@ -568,28 +601,28 @@ stock_td<-function(frequency, start, length, s, w = 31){ #' More information on calendar correction in JDemetra+ online documentation: #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} #' @examples -#' Belgium <- national_calendar(list(special_day("NEWYEAR"),fixed_day(7,21))) -#' France <- national_calendar(list(special_day("NEWYEAR"),fixed_day(7,14))) -#' chained_cal<-chained_calendar(France, Belgium, "2000-01-01") +#' Belgium <- national_calendar(list(special_day("NEWYEAR"), fixed_day(7, 21))) +#' France <- national_calendar(list(special_day("NEWYEAR"), fixed_day(7, 14))) +#' chained_cal <- chained_calendar(France, Belgium, "2000-01-01") #' #' @export -chained_calendar<-function(calendar1, calendar2, break_date){ +chained_calendar <- function(calendar1, calendar2, break_date) { return(structure(list( - calendar1=calendar1, - calendar2=calendar2, - break_date=break_date - ), class=c('JD3_CHAINEDCALENDAR', 'JD3_CALENDARDEFINITION'))) + calendar1 = calendar1, + calendar2 = calendar2, + break_date = break_date + ), class = c("JD3_CHAINEDCALENDAR", "JD3_CALENDARDEFINITION"))) } -.p2r_chainedcalendar<-function(p){ +.p2r_chainedcalendar <- function(p) { return(chained_calendar(p$calendar1, p$calendar2, .p2r_date(p$break_date))) } -.r2p_chainedcalendar<-function(r){ - pc<-jd3.ChainedCalendar$new() - pc$calendar1<-.r2p_calendardef(r$calendar1) - pc$calendar2<-.r2p_calendardef(r$calendar2) - pc$break_date<-parseDate(r$break_date) +.r2p_chainedcalendar <- function(r) { + pc <- jd3.ChainedCalendar$new() + pc$calendar1 <- .r2p_calendardef(r$calendar1) + pc$calendar2 <- .r2p_calendardef(r$calendar2) + pc$break_date <- parseDate(r$break_date) return(pc) } @@ -613,44 +646,59 @@ chained_calendar<-function(calendar1, calendar2, break_date){ #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} #' @export #' @examples -#' Belgium <- national_calendar(list(special_day("NEWYEAR"),fixed_day(7,21))) -#' France <- national_calendar(list(special_day("NEWYEAR"),fixed_day(7,14))) -#' composite_calendar<- weighted_calendar(list(France,Belgium), weights = c(1,2)) -weighted_calendar<-function(calendars, weights){ +#' Belgium <- national_calendar(list(special_day("NEWYEAR"), fixed_day(7, 21))) +#' France <- national_calendar(list(special_day("NEWYEAR"), fixed_day(7, 14))) +#' composite_calendar <- weighted_calendar(list(France, Belgium), weights = c(1, 2)) +weighted_calendar <- function(calendars, weights) { # checkmate::assertNames(calendars) checkmate::assertNumeric(weights) if (length(calendars) != length(weights)) stop("Calendars and weights should have the same length") - return(structure(list(calendars=calendars, weights=weights), class=c('JD3_WEIGHTEDCALENDAR', 'JD3_CALENDARDEFINITION'))) + return(structure(list(calendars = calendars, weights = weights), class = c("JD3_WEIGHTEDCALENDAR", "JD3_CALENDARDEFINITION"))) } -.p2r_wcalendar<-function(p){ - calendars<-sapply(p, function(item){return(item$calendar)}) - weights<-sapply(p, function(item){return(item$weights)}) +.p2r_wcalendar <- function(p) { + calendars <- sapply(p, function(item) { + return(item$calendar) + }) + weights <- sapply(p, function(item) { + return(item$weights) + }) return(weighted_calendar(calendars, weights)) - } -.r2p_wcalendar<-function(r){ - pwc<-jd3.WeightedCalendar$new() - n<-length(r$calendars) - pwc$items<-lapply(1:n, function(i){return(list(calendar=r$calendars[[i]], weight=r$weights[i]))}) +.r2p_wcalendar <- function(r) { + pwc <- jd3.WeightedCalendar$new() + n <- length(r$calendars) + pwc$items <- lapply(1:n, function(i) { + return(list(calendar = r$calendars[[i]], weight = r$weights[i])) + }) pwc } -.p2r_calendardef<-function(p){ - if (p$has('calendar')) return(.p2r_calendar(p$calendar)) - if (p$has('chained_calendar')) return(.p2r_chainedcalendar(p$chained_calendar)) - if (p$has('weighted_calendar')) return(.p2r_wcalendar(p$weighted_calendar)) +.p2r_calendardef <- function(p) { + if (p$has("calendar")) { + return(.p2r_calendar(p$calendar)) + } + if (p$has("chained_calendar")) { + return(.p2r_chainedcalendar(p$chained_calendar)) + } + if (p$has("weighted_calendar")) { + return(.p2r_wcalendar(p$weighted_calendar)) + } return(NULL) } -.r2p_calendardef<-function(r){ - p<-jd3.CalendarDefinition$new() - if (is(r, 'JD3_CALENDAR')){p$calendar<-.r2p_calendar(r)} - else if (is(r, 'JD3_CHAINEDCALENDAR')){p$chained_calendar<-.r2p_chainedcalendar(r)} - else if (is(r, 'JD3_WEIGHTEDCALENDAR')){p$weighted_calendar<-.r2p_wcalendar(r)} +.r2p_calendardef <- function(r) { + p <- jd3.CalendarDefinition$new() + if (is(r, "JD3_CALENDAR")) { + p$calendar <- .r2p_calendar(r) + } else if (is(r, "JD3_CHAINEDCALENDAR")) { + p$chained_calendar <- .r2p_chainedcalendar(r) + } else if (is(r, "JD3_WEIGHTEDCALENDAR")) { + p$weighted_calendar <- .r2p_wcalendar(r) + } return(p) } @@ -658,44 +706,48 @@ weighted_calendar<-function(calendars, weights){ #' Create a National Calendar #' #' @description -#'Will create a calendar as a list of days corresponding to the required holidays. -#'The holidays have to be generated by one of these functions: `fixed_day()`, -#'`fixed_week_day()`, `easter_day()`, `special_day()` or `single_day()`. +#' Will create a calendar as a list of days corresponding to the required holidays. +#' The holidays have to be generated by one of these functions: `fixed_day()`, +#' `fixed_week_day()`, `easter_day()`, `special_day()` or `single_day()`. #' #' #' @param days list of holidays to be taken into account in the calendar -#' +#' @param mean_correction TRUE if the variables generated by this calendar will +#' contain long term mean corrections (default). FALSE otherwise. #' #' @examples -#' #Fictional calendar using all possibilities to set the required holidays +#' # Fictional calendar using all possibilities to set the required holidays #' MyCalendar <- national_calendar(list( -#' fixed_day(7,21), -#' special_day("NEWYEAR"), -#' special_day("CHRISTMAS"), -#' fixed_week_day(7, 2, 3), # second Wednesday of July -#' special_day("MAYDAY"), -#' easter_day(1), # Easter Monday -#' easter_day(-2), # Good Friday -#' single_day("2001-09-11"), # appearing once -#' special_day("ASCENSION"), -#' easter_day(offset=60, julian=FALSE, weight=0.5, -#' validity = list(start="2000-01-01", end = "2020-12-01")), # Corpus Christi -#' special_day("WHITMONDAY"), -#' special_day("ASSUMPTION"), -#' special_day("ALLSAINTSDAY"), -#' special_day("ARMISTICE"))) +#' fixed_day(7, 21), +#' special_day("NEWYEAR"), +#' special_day("CHRISTMAS"), +#' fixed_week_day(7, 2, 3), # second Wednesday of July +#' special_day("MAYDAY"), +#' easter_day(1), # Easter Monday +#' easter_day(-2), # Good Friday +#' single_day("2001-09-11"), # appearing once +#' special_day("ASCENSION"), +#' easter_day( +#' offset = 60, julian = FALSE, weight = 0.5, +#' validity = list(start = "2000-01-01", end = "2020-12-01") +#' ), # Corpus Christi +#' special_day("WHITMONDAY"), +#' special_day("ASSUMPTION"), +#' special_day("ALLSAINTSDAY"), +#' special_day("ARMISTICE") +#' )) #' @return returns an object of class \code{c("JD3_CALENDAR","JD3_CALENDARDEFINITION")} #' @seealso \code{\link{chained_calendar}}, \code{\link{weighted_calendar}} #' @references #' More information on calendar correction in JDemetra+ online documentation: #' \url{https://jdemetra-new-documentation.netlify.app/} #' @export -national_calendar <- function(days, mean_correction=TRUE){ - if (! is.list(days)) stop ('Days should be a list of holidays') - return(structure(list(days=days, mean_correction=mean_correction), class=c('JD3_CALENDAR', 'JD3_CALENDARDEFINITION'))) +national_calendar <- function(days, mean_correction = TRUE) { + if (!is.list(days)) stop("Days should be a list of holidays") + return(structure(list(days = days, mean_correction = mean_correction), class = c("JD3_CALENDAR", "JD3_CALENDARDEFINITION"))) } -#' Trading day regressors with pre-defined holidays +#' @title Trading day regressors with pre-defined holidays #' #' @description #' Allows to generate trading day regressors (as many as defined groups), taking into account @@ -717,7 +769,7 @@ national_calendar <- function(days, mean_correction=TRUE){ #' @export #' @examples #' BE <- national_calendar(list( -#' fixed_day(7,21), +#' fixed_day(7, 21), #' special_day("NEWYEAR"), #' special_day("CHRISTMAS"), #' special_day("MAYDAY"), @@ -726,25 +778,30 @@ national_calendar <- function(days, mean_correction=TRUE){ #' special_day("WHITMONDAY"), #' special_day("ASSUMPTION"), #' special_day("ALLSAINTSDAY"), -#' special_day("ARMISTICE"))) -#' calendar_td(BE, 12, c(1980,1), 240, holiday=7, groups=c(1,1,1,2,2,3,0), -#' contrasts = FALSE) +#' special_day("ARMISTICE") +#' )) +#' calendar_td(BE, 12, c(1980, 1), 240, +#' holiday = 7, groups = c(1, 1, 1, 2, 2, 3, 0), +#' contrasts = FALSE +#' ) #' @seealso \code{\link{national_calendar}}, \code{\link{td}} #' @references #' More information on calendar correction in JDemetra+ online documentation: #' \url{https://jdemetra-new-documentation.netlify.app/} -calendar_td<-function(calendar,frequency, start, length, s, groups=c(1,2,3,4,5,6,0), holiday=7, contrasts=TRUE){ - if (! is(calendar, 'JD3_CALENDAR')) stop('Invalid calendar') +calendar_td <- function(calendar, frequency, start, length, s, groups = c(1, 2, 3, 4, 5, 6, 0), holiday = 7, contrasts = TRUE) { + if (!is(calendar, "JD3_CALENDAR")) stop("Invalid calendar") if (!missing(s) && is.ts(s)) { frequency <- stats::frequency(s) start <- stats::start(s) length <- .length_ts(s) } - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - pcal<-.r2p_calendar(calendar) - jcal<-.p2jd_calendar(pcal) - jm<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", - "htd", jcal, jdom, as.integer(groups), as.integer(holiday), contrasts) + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + pcal <- .r2p_calendar(calendar) + jcal <- .p2jd_calendar(pcal) + jm <- .jcall( + "jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", + "htd", jcal, jdom, as.integer(groups), as.integer(holiday), contrasts + ) output <- .jd2r_matrix(jm) output <- .group_names(output, contrasts = contrasts) return(ts(output, start = start, frequency = frequency)) @@ -761,52 +818,55 @@ NULL #' @export #' @rdname print.calendars -print.JD3_FIXEDDAY<-function(x, ...){ - cat('Fixed day: month=', x$month, ', day=', x$day, sep='') +print.JD3_FIXEDDAY <- function(x, ...) { + cat("Fixed day: month=", x$month, ", day=", x$day, sep = "") .print_weight(x) .print_validityperiod(x) } .print_weight <- function(x, ...) { - if (x$weight != 1) - cat(' , weight=', x$weight, sep='') + if (x$weight != 1) { + cat(" , weight=", x$weight, sep = "") + } } .print_validityperiod <- function(x, ...) { - if (!is.null(x$validity$start)) - cat(sprintf(' , from=%s', x$validity$start)) - if (!is.null(x$validity$end)) - cat(sprintf(' , to=%s', x$validity$end)) + if (!is.null(x$validity$start)) { + cat(sprintf(" , from=%s", x$validity$start)) + } + if (!is.null(x$validity$end)) { + cat(sprintf(" , to=%s", x$validity$end)) + } } -DAYS<-c('Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday', 'Sunday') +DAYS <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday") #' @export #' @rdname print.calendars -print.JD3_FIXEDWEEKDAY<-function(x, ...){ - cat('Fixed week day: month=', x$month, ', day of the week=', DAYS[x$dayofweek], ', week=', x$week, sep='') +print.JD3_FIXEDWEEKDAY <- function(x, ...) { + cat("Fixed week day: month=", x$month, ", day of the week=", DAYS[x$dayofweek], ", week=", x$week, sep = "") .print_weight(x) .print_validityperiod(x) } #' @export #' @rdname print.calendars -print.JD3_EASTERDAY<-function(x, ...){ - cat('Easter related day: offset=', x$offset, sep='') +print.JD3_EASTERDAY <- function(x, ...) { + cat("Easter related day: offset=", x$offset, sep = "") .print_weight(x) .print_validityperiod(x) } #' @export #' @rdname print.calendars -print.JD3_SPECIALDAY<-function(x, ...){ - cat('Prespecified holiday: event=', x$event, sep='') - if (x$offset != 0)cat(' , offset=', x$offset, sep='') +print.JD3_SPECIALDAY <- function(x, ...) { + cat("Prespecified holiday: event=", x$event, sep = "") + if (x$offset != 0) cat(" , offset=", x$offset, sep = "") .print_weight(x) .print_validityperiod(x) } #' @export #' @rdname print.calendars -print.JD3_SINGLEDAY<-function(x, ...){ - cat('Single date: ', x$date, sep='') +print.JD3_SINGLEDAY <- function(x, ...) { + cat("Single date: ", x$date, sep = "") .print_weight(x) } @@ -817,7 +877,7 @@ print.JD3_CALENDAR <- function(x, ...) { for (day in x$day) { cat("\t- ") print(day) - cat('\n') + cat("\n") } cat("\nMean correction: ", ifelse(x$mean_correction, "Yes", "No"), "\n", sep = "") @@ -825,8 +885,7 @@ print.JD3_CALENDAR <- function(x, ...) { } #' @export -print.JD3_CHAINEDCALENDAR <- function (x, ...) -{ +print.JD3_CHAINEDCALENDAR <- function(x, ...) { cat("First calendar before ", x$break_date, "\n", sep = "") print(x$calendar1) @@ -839,8 +898,7 @@ print.JD3_CHAINEDCALENDAR <- function (x, ...) } #' @export -print.JD3_WEIGHTEDCALENDAR <- function (x, ...) -{ +print.JD3_WEIGHTEDCALENDAR <- function(x, ...) { for (index_cal in seq_along(x$weights)) { cat("Calendar n", index_cal, "\n", sep = "") cat("weight: ", x$weight[index_cal], "\n", sep = "") diff --git a/R/calendarts.R b/R/calendarts.R index 569f22fb..6c972d66 100644 --- a/R/calendarts.R +++ b/R/calendarts.R @@ -5,19 +5,27 @@ #' @export #' #' @examples -#' obs<-list( -#' list(start=as.Date("1980-01-01"), end=as.Date("1999-12-31"), value=2000), -#' list(start=as.Date("2000-01-01"), end=as.Date("2010-01-01"), value=1000) +#' obs <- list( +#' list(start = as.Date("1980-01-01"), end = as.Date("1999-12-31"), value = 2000), +#' list(start = as.Date("2000-01-01"), end = as.Date("2010-01-01"), value = 1000) #' ) -#' jobj<-r2jd_calendarts(obs) -r2jd_calendarts<-function(calendarobs){ - if (is.null(calendarobs) || !is.list(calendarobs)){ - return(NULL) - } - starts<-sapply(calendarobs, function(z){as.character(z$start)}) - ends<-sapply(calendarobs, function(z){as.character(z$end)}) - values<-sapply(calendarobs, function(z){as.numeric(z$value)}) - jts<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/CalendarTimeSeries;", "of", - .jarray(starts, "Ljava/lang/String;"), .jarray(ends, "Ljava/lang/String;"), .jarray(values)) - return(jts) +#' jobj <- r2jd_calendarts(obs) +r2jd_calendarts <- function(calendarobs) { + if (is.null(calendarobs) || !is.list(calendarobs)) { + return(NULL) + } + starts <- sapply(calendarobs, function(z) { + as.character(z$start) + }) + ends <- sapply(calendarobs, function(z) { + as.character(z$end) + }) + values <- sapply(calendarobs, function(z) { + as.numeric(z$value) + }) + jts <- .jcall( + "jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/CalendarTimeSeries;", "of", + .jarray(starts, "Ljava/lang/String;"), .jarray(ends, "Ljava/lang/String;"), .jarray(values) + ) + return(jts) } diff --git a/R/decomposition.R b/R/decomposition.R index 4c535273..28fe0287 100644 --- a/R/decomposition.R +++ b/R/decomposition.R @@ -6,98 +6,108 @@ NULL #' @rdname sa_decomposition #' @export -sadecomposition<-function(y, sa, t, s, i, mul){ - if (! is.logical(mul))stop("Invalid SA decomposition") - if (is.null(y))stop("Invalid SA decomposition") - if (! is.ts(y))stop("Invalid SA decomposition") - n<-length(y) - if (is.null(s)){ - if (mul){ - s<-ts(rep(1,1,n), start = start(y), frequency = frequency(y)) - } else { - s <- ts(rep(0,1,n), start = start(y), frequency = frequency(y)) - } - } else if (! is.ts(s))stop("Invalid SA decomposition") - if (is.null(i)){ - if (mul){ - i<-ts(rep(1,1,n), start = start(y), frequency = frequency(y)) - } else { - i<-ts(rep(0,1,n), start = start(y), frequency = frequency(y)) - } - } else if (! is.ts(i))stop("Invalid SA decomposition") +sadecomposition <- function(y, sa, t, s, i, mul) { + if (!is.logical(mul)) stop("Invalid SA decomposition") + if (is.null(y)) stop("Invalid SA decomposition") + if (!is.ts(y)) stop("Invalid SA decomposition") + n <- length(y) + if (is.null(s)) { + if (mul) { + s <- ts(rep(1, 1, n), start = start(y), frequency = frequency(y)) + } else { + s <- ts(rep(0, 1, n), start = start(y), frequency = frequency(y)) + } + } else if (!is.ts(s)) stop("Invalid SA decomposition") + if (is.null(i)) { + if (mul) { + i <- ts(rep(1, 1, n), start = start(y), frequency = frequency(y)) + } else { + i <- ts(rep(0, 1, n), start = start(y), frequency = frequency(y)) + } + } else if (!is.ts(i)) stop("Invalid SA decomposition") - if (! is.ts(sa))stop("Invalid SA decomposition") - if (! is.ts(t))stop("Invalid SA decomposition") + if (!is.ts(sa)) stop("Invalid SA decomposition") + if (!is.ts(t)) stop("Invalid SA decomposition") - return(structure(list(series=y, sa=sa, trend=t, seas=s, irr=i, multiplicative=mul), class=c("JD3_SADECOMPOSITION", "JD3"))) + return(structure(list(series = y, sa = sa, trend = t, seas = s, irr = i, multiplicative = mul), class = c("JD3_SADECOMPOSITION", "JD3"))) } #' @rdname sa_decomposition #' @export -print.JD3_SADECOMPOSITION<-function(x, n_last_obs = frequency(x$series), ...){ - cat("Last values\n") - print(tail( - .preformat.ts(ts.union(series=x$series,sa=x$sa,trend=x$trend,seas=x$seas,irr=x$irr),...), - n_last_obs - ) - ) +print.JD3_SADECOMPOSITION <- function(x, n_last_obs = frequency(x$series), ...) { + cat("Last values\n") + print(tail( + .preformat.ts(ts.union(series = x$series, sa = x$sa, trend = x$trend, seas = x$seas, irr = x$irr), ...), + n_last_obs + )) } #' @rdname sa_decomposition #' @export plot.JD3_SADECOMPOSITION <- function(x, first_date = NULL, last_date = NULL, - type_chart = c("sa-trend", "seas-irr"), - caption = c("sa-trend" = "Y, Sa, trend", - "seas-irr" = "Sea., irr.")[type_chart], - colors = c(y = "#F0B400", t = "#1E6C0B", sa = "#155692", - s = "#1E6C0B", i = "#155692"), - ...){ - - type_chart <- match.arg(type_chart) + type_chart = c("sa-trend", "seas-irr"), + caption = c( + "sa-trend" = "Y, Sa, trend", + "seas-irr" = "Sea., irr." + )[type_chart], + colors = c( + y = "#F0B400", t = "#1E6C0B", sa = "#155692", + s = "#1E6C0B", i = "#155692" + ), + ...) { + type_chart <- match.arg(type_chart) - data_plot <- ts.union(y=x$series,sa=x$sa,t=x$trend,s=x$seas,i=x$irr) - if (!missing(first_date)) { - data_plot <- window(data_plot, start = first_date) - } - if (!missing(last_date)) { - data_plot <- window(data_plot, end = last_date) - } + data_plot <- ts.union(y = x$series, sa = x$sa, t = x$trend, s = x$seas, i = x$irr) + if (!missing(first_date)) { + data_plot <- window(data_plot, start = first_date) + } + if (!missing(last_date)) { + data_plot <- window(data_plot, end = last_date) + } - if ("sa-trend" %in% type_chart) { - # Graph 1: Sa, trend, and y - series_graph <- c("y", "t", "sa") + if ("sa-trend" %in% type_chart) { + # Graph 1: Sa, trend, and y + series_graph <- c("y", "t", "sa") - lty <- rep(1, length(series_graph)) - # lty[grep("_f$", series_graph)] <- 1 - # col <- colors[gsub("_.*$", "", series_graph)] - # par(mar = c(5, 4, 4, 2) + 0.1) - ts.plot(data_plot[, series_graph], + lty <- rep(1, length(series_graph)) + # lty[grep("_f$", series_graph)] <- 1 + # col <- colors[gsub("_.*$", "", series_graph)] + # par(mar = c(5, 4, 4, 2) + 0.1) + ts.plot(data_plot[, series_graph], col = colors[series_graph], main = caption[1], lty = lty, - ...) - legend("bottomleft", legend = c("Series", "Trend","Seasonally adjusted"), - col = colors[series_graph], lty = 1, - pch = NA_integer_, - inset = c(0,1), xpd = TRUE, bty = "n") - } + ... + ) + legend("bottomleft", + legend = c("Series", "Trend", "Seasonally adjusted"), + col = colors[series_graph], lty = 1, + pch = NA_integer_, + inset = c(0, 1), xpd = TRUE, bty = "n" + ) + } - if ("seas-irr" %in% type_chart) { - # Graph 2: Calendar, seasonal and irregular - series_graph <- c("s", "i") - lty <- rep(1, length(series_graph)) - # lty[grep("_f$", series_graph, invert = TRUE)] <- 1 - # col <- colors[gsub("_.*$", "", series_graph)] - ts.plot(data_plot[, series_graph], + if ("seas-irr" %in% type_chart) { + # Graph 2: Calendar, seasonal and irregular + series_graph <- c("s", "i") + lty <- rep(1, length(series_graph)) + # lty[grep("_f$", series_graph, invert = TRUE)] <- 1 + # col <- colors[gsub("_.*$", "", series_graph)] + ts.plot(data_plot[, series_graph], col = colors[series_graph], main = caption[1], lty = lty, - ...) - legend("bottomleft", legend = c("Seas (component)", - "Irregular"), - col= colors[series_graph], lty = 1, - pch = NA_integer_, - inset=c(0,1), xpd=TRUE, bty="n") + ... + ) + legend("bottomleft", + legend = c( + "Seas (component)", + "Irregular" + ), + col = colors[series_graph], lty = 1, + pch = NA_integer_, + inset = c(0, 1), xpd = TRUE, bty = "n" + ) } - invisible() + invisible() } diff --git a/R/differencing.R b/R/differencing.R index dbfc7d49..e592a257 100644 --- a/R/differencing.R +++ b/R/differencing.R @@ -1,21 +1,24 @@ #' @include protobuf.R jd2r.R NULL -.p2r_differencing<-function(p){ - if (is.null(p)){ - return(NULL) - } else { - del<-sapply(p$differences, function(z){(return(c(z$lag,z$order)))}) - del<-`rownames<-`(del, c("lag", "order")) - return(list(ddata=p$stationary_series, - mean=p$mean_correction, - differences=del)) - } +.p2r_differencing <- function(p) { + if (is.null(p)) { + return(NULL) + } else { + del <- sapply(p$differences, function(z) { + (return(c(z$lag, z$order))) + }) + del <- `rownames<-`(del, c("lag", "order")) + return(list( + ddata = p$stationary_series, + mean = p$mean_correction, + differences = del + )) + } } #' Automatic stationary transformation #' -#' Stationary transformation of a series by simple differencing of lag 1. #' Automatic processing (identification of the order of the differencing) based on auto-correlations and on mean correction. #' The series should not be seasonal. #' Source: Tramo @@ -25,108 +28,119 @@ NULL #' #' @return #' Stationary transformation -#' * ddata: data after differencing -#' * mean: mean correction -#' * differences: -#' * lag: ddata(t)=data(t)-data(t-lag) -#' * order: order of the differencing +#' * \code{ddata}: data after differencing +#' * \code{mean}: mean correction +#' * \code{differences}: +#' * \code{lag}: \eqn{ddata(t)=data(t)-data(t-lag)} +#' * \code{order}: order of the differencing #' @md #' @export #' #' @examples -#' do_stationary(log(ABS$X0.2.09.10.M),12) -do_stationary<-function(data, period){ - if (is.ts(data) && missing(period)) - period <- frequency(data) - jst<-.jcall("jdplus/toolkit/base/r/modelling/Differencing", "Ljdplus/toolkit/base/core/modelling/StationaryTransformation;", "doStationary", - as.numeric(data), as.integer(period)) - q<-.jcall("jdplus/toolkit/base/r/modelling/Differencing", "[B", "toBuffer", jst) - p<-RProtoBuf::read(modelling.StationaryTransformation, q) - res <- .p2r_differencing(p) - if (is.ts(data)) - res$ddata <- ts(res$ddata, end = end(data), frequency = frequency(data)) - return(res) +#' do_stationary(log(ABS$X0.2.09.10.M), 12) +do_stationary <- function(data, period) { + if (is.ts(data) && missing(period)) { + period <- frequency(data) + } + jst <- .jcall( + "jdplus/toolkit/base/r/modelling/Differencing", "Ljdplus/toolkit/base/core/modelling/StationaryTransformation;", "doStationary", + as.numeric(data), as.integer(period) + ) + q <- .jcall("jdplus/toolkit/base/r/modelling/Differencing", "[B", "toBuffer", jst) + p <- RProtoBuf::read(modelling.StationaryTransformation, q) + res <- .p2r_differencing(p) + if (is.ts(data)) { + res$ddata <- ts(res$ddata, end = end(data), frequency = frequency(data)) + } + return(res) } #' Automatic differencing #' -#' The series is differentiated till its variance is decreasing. +#' The series is differenced till its variance is decreasing. #' #' @param data Series being differenced. #' @param period Period considered in the automatic differencing. #' @param mad Use of MAD in the computation of the variance (true by default). #' @param centile Percentage of the data used for computing the variance (90 by default). -#' @param k tolerance in the decrease of the variance. The algorithm stops if the new varance is higher than k*the old variance. +#' @param k tolerance in the decrease of the variance. The algorithm stops if the new variance is higher than k*the old variance. k should be equal or slightly higher than 1 (1.2 by default) #' #' @return #' Stationary transformation -#' * ddata: data after differencing -#' * mean: mean correction -#' * differences: -#' * lag: ddata(t)=data(t)-data(t-lag) -#' * order: order of the differencing +#' * \code{ddata}: data after differencing +#' * \code{mean}: mean correction +#' * \code{differences}: +#' * \code{lag}: \eqn{ddata(t)=data(t)-data(t-lag)} +#' * \code{order}: order of the differencing #' @export #' #' @examples -#' differencing_fast(log(ABS$X0.2.09.10.M),12) -#' -differencing_fast<-function(data, period, mad=TRUE, centile=90, k=1.2){ - if (is.ts(data) && missing(period)) - period <- frequency(data) - jst<-.jcall("jdplus/toolkit/base/r/modelling/Differencing", "Ljdplus/toolkit/base/core/modelling/StationaryTransformation;", "fastDifferencing", - as.numeric(data), as.integer(period), as.logical(mad), centile, k) - q<-.jcall("jdplus/toolkit/base/r/modelling/Differencing", "[B", "toBuffer", jst) - p<-RProtoBuf::read(modelling.StationaryTransformation, q) - res <- .p2r_differencing(p) - if (is.ts(data)) - res$ddata <- ts(res$ddata, end = end(data), frequency = frequency(data)) - return(res) +#' differencing_fast(log(ABS$X0.2.09.10.M), 12) +#' +differencing_fast <- function(data, period, mad = TRUE, centile = 90, k = 1.2) { + if (is.ts(data) && missing(period)) { + period <- frequency(data) + } + jst <- .jcall( + "jdplus/toolkit/base/r/modelling/Differencing", "Ljdplus/toolkit/base/core/modelling/StationaryTransformation;", "fastDifferencing", + as.numeric(data), as.integer(period), as.logical(mad), centile, k + ) + q <- .jcall("jdplus/toolkit/base/r/modelling/Differencing", "[B", "toBuffer", jst) + p <- RProtoBuf::read(modelling.StationaryTransformation, q) + res <- .p2r_differencing(p) + if (is.ts(data)) { + res$ddata <- ts(res$ddata, end = end(data), frequency = frequency(data)) + } + return(res) } #' Differencing of a series #' #' @param data The series to be differenced. #' @param lags Lags of the differencing. -#' @param mean Mean correction. +#' @param mean Apply a mean correction at the end of the differencing process. #' #' @return The differenced series. #' @export #' #' @examples -#' differences(retail$BookStores, c(1,1,12), FALSE) +#' differences(retail$BookStores, c(1, 1, 12), FALSE) #' -differences<-function(data, lags=1, mean=TRUE){ - UseMethod("differences", data) +differences <- function(data, lags = 1, mean = TRUE) { + UseMethod("differences", data) } #' @export -differences.default<-function(data, lags=1, mean=TRUE){ - res <- .jcall("jdplus/toolkit/base/r/modelling/Differencing", "[D", "differences", - as.numeric(data), .jarray(as.integer(lags)), mean) - if (is.ts(data)) - res <- ts(res, end = end(data), frequency = frequency(data)) - return(res) +differences.default <- function(data, lags = 1, mean = TRUE) { + res <- .jcall( + "jdplus/toolkit/base/r/modelling/Differencing", "[D", "differences", + as.numeric(data), .jarray(as.integer(lags)), mean + ) + if (is.ts(data)) { + res <- ts(res, end = end(data), frequency = frequency(data)) + } + return(res) } #' @export -differences.matrix<-function(data, lags=1, mean=TRUE){ - result <- data[-(1:sum(lags)),] - for (i in seq_len(ncol(data))){ - result[, i] <- differences(data[,i], lags = lags, mean = mean) - } - result +differences.matrix <- function(data, lags = 1, mean = TRUE) { + result <- data[-(1:sum(lags)), ] + for (i in seq_len(ncol(data))) { + result[, i] <- differences(data[, i], lags = lags, mean = mean) + } + result } #' @export -differences.data.frame<-function(data, lags=1, mean=TRUE){ - result <- data[-(1:sum(lags)),] - for (i in seq_len(ncol(data))){ - result[, i] <- differences(data[,i], lags = lags, mean = mean) - } - result +differences.data.frame <- function(data, lags = 1, mean = TRUE) { + result <- data[-(1:sum(lags)), ] + for (i in seq_len(ncol(data))) { + result[, i] <- differences(data[, i], lags = lags, mean = mean) + } + result } #' Range-Mean Regression #' #' Function to perform a range-mean regression, trimmed to avoid outlier distortion. -#' The slope is used in TRAMO to select whether the original series will be transformed into log or maintain in level. +#' The can be used to select whether the original series will be transformed into log or maintain in level. #' #' @param data data to test. #' @param period periodicity of the data. @@ -160,26 +174,28 @@ differences.data.frame<-function(data, lags=1, mean=TRUE){ #' @return T-Stat of the slope of the range-mean regression. #' #' @examples -#' y = ABS$X0.2.09.10.M +#' y <- ABS$X0.2.09.10.M #' # Multiplicative pattern #' plot(y) -#' period = 12 -#' rm_t = rangemean_tstat(y, period = period, groupsize = period) +#' period <- 12 +#' rm_t <- rangemean_tstat(y, period = period, groupsize = period) #' rm_t # higher than 0 #' # Can be tested: #' pt(rm_t, period - 2, lower.tail = FALSE) #' # Or : -#' 1-cdf_t(period-2, rm_t) +#' 1 - cdf_t(period - 2, rm_t) #' #' # Close to 0 -#' rm_t_log = rangemean_tstat(log(y), period = period, groupsize = period) +#' rm_t_log <- rangemean_tstat(log(y), period = period, groupsize = period) #' rm_t_log #' pt(rm_t_log, period - 2, lower.tail = FALSE) #' @export -rangemean_tstat<-function(data, period=0, groupsize = 0, trim = 0){ - if (is.ts(data) && missing(period)) - period <- frequency(data) - return(.jcall("jdplus/toolkit/base/r/modelling/AutoModelling", "D", "rangeMean", - as.numeric(data), as.integer(period), as.integer(groupsize), as.integer(trim))) - +rangemean_tstat <- function(data, period = 0, groupsize = 0, trim = 0) { + if (is.ts(data) && missing(period)) { + period <- frequency(data) + } + return(.jcall( + "jdplus/toolkit/base/r/modelling/AutoModelling", "D", "rangeMean", + as.numeric(data), as.integer(period), as.integer(groupsize), as.integer(trim) + )) } diff --git a/R/display.R b/R/display.R index c4036d18..287a04e8 100644 --- a/R/display.R +++ b/R/display.R @@ -5,225 +5,265 @@ NULL #' JD3 print functions #' #' @param x the object to print. -#' @param digits minimum number of significant digits to be used for most numbers. +#' @param digits minimum number of significant digits to be used for most +#' numbers. +#' @param summary_info boolean indicating if a message suggesting the use of the +#' summary function for more details should be printed. By default used the +#' option `"summary_info"` it used, which initialized to `TRUE`. #' @param ... further unused parameters. #' @name jd3_print #' @rdname jd3_print #' @export -print.JD3_ARIMA<-function(x, ...){ - m <- x - if (m$var > 0 || length(m$delta)>1){ - cat(m$name, "\n\n") - if (length(m$ar)>1) cat("AR: ", m$ar, "\n") - if (length(m$delta)>1)cat("DIF: ", m$delta, "\n") - if (length(m$ma)>1)cat("MA: ", m$ma, "\n") - cat("var: ", m$var, "\n\n") - } - invisible(x) +print.JD3_ARIMA <- function(x, ...) { + m <- x + if (m$var > 0 || length(m$delta) > 1) { + cat(m$name, "\n\n") + if (length(m$ar) > 1) cat("AR:", m$ar, "\n") + if (length(m$delta) > 1) cat("DIF:", m$delta, "\n") + if (length(m$ma) > 1) cat("MA:", m$ma, "\n") + cat("var: ", m$var, "\n\n") + } + invisible(x) } #' @rdname jd3_print #' @export -print.JD3_UCARIMA<-function(x,...){ - ucm <- x - print(ucm$model) - lapply(ucm$components, function(z){print(z)}) - invisible(x) +print.JD3_UCARIMA <- function(x, ...) { + ucm <- x + print(ucm$model) + lapply(ucm$components, function(z) { + print(z) + }) + invisible(x) } -.arima_node<-function(p,d,q){ - s<-paste(p,d,q,sep=',') - return(paste0('(', s, ')')) +.arima_node <- function(p, d, q) { + s <- paste(p, d, q, sep = ",") + return(paste0("(", s, ")")) } #' @rdname jd3_print #' @export -print.JD3_SARIMA<-function(x, ...){ - m <- x - cat("SARIMA model: ", .arima_node(length(m$phi), m$d, length(m$theta)), .arima_node(length(m$bphi), m$bd, length(m$btheta)), m$period, "\n") - if (length(m$phi)>0) cat("phi: ", m$phi, "\n") - if (length(m$theta)>0)cat("theta: ", m$theta, "\n") - if (length(m$bphi)>0) cat("bphi: ", m$bphi, "\n") - if (length(m$btheta)>0)cat("btheta: ", m$btheta, "\n") +print.JD3_SARIMA <- function(x, ...) { + m <- x + cat("SARIMA model: ", .arima_node(length(m$phi), m$d, length(m$theta)), .arima_node(length(m$bphi), m$bd, length(m$btheta)), m$period, "\n") + if (length(m$phi) > 0) cat("phi:", m$phi, "\n") + if (length(m$theta) > 0) cat("theta:", m$theta, "\n") + if (length(m$bphi) > 0) cat("bphi:", m$bphi, "\n") + if (length(m$btheta) > 0) cat("btheta:", m$btheta, "\n") } #' @rdname jd3_print #' @export -print.JD3_SARIMA_ESTIMATION<-function(x, digits = max(3L, getOption("digits") - 3L), ...){ - tables <- .sarima_coef_table(x, ...) - orders <- tables$sarima_orders - - cat("SARIMA model: ", - .arima_node(orders$p, orders$d, orders$q), - .arima_node(orders$bp, orders$bd, orders$bq)) - if (!is.null(orders$period)) # when sarima_estimate() is used - cat(sprintf(" [%i]", orders$period)) - - cat("\n") - - cat("\nCoefficients\n") - if (is.null(tables$coef_table)){ - cat("No SARIMA variables\n") - } else if (ncol(tables$coef_table) == 2){ - print(tables$coef_table) - } else { - printCoefmat(tables$coef_table[-2], digits = digits, - P.values= FALSE, - na.print = "NA", ...) - } - invisible(x) +print.JD3_SARIMA_ESTIMATION <- function(x, digits = max(3L, getOption("digits") - 3L), ...) { + tables <- .sarima_coef_table(x, ...) + orders <- tables$sarima_orders + + cat( + "SARIMA model:", + .arima_node(orders$p, orders$d, orders$q), + .arima_node(orders$bp, orders$bd, orders$bq) + ) + if (!is.null(orders$period)) { # when sarima_estimate() is used + cat(sprintf(" [%i]", orders$period)) + } + + cat("\n") + + cat("\nSARIMA coefficients:\n") + if (is.null(tables$coef_table)) { + cat("No SARIMA variables\n") + } else { + coef <- tables$coef_table[, 1] + names(coef) <- rownames(tables$coef_table) + print(coef, digits = digits, na.print = "NA", ...) + } + invisible(x) } #' @export -summary.JD3_SARIMA_ESTIMATION<-function(object, ...){ - tables <- .sarima_coef_table(object, ...) - class(tables) <- "summary.JD3_SARIMA_ESTIMATION" - tables +summary.JD3_SARIMA_ESTIMATION <- function(object, ...) { + tables <- .sarima_coef_table(object, ...) + class(tables) <- "summary.JD3_SARIMA_ESTIMATION" + tables } #' @importFrom stats printCoefmat #' @export -print.summary.JD3_SARIMA_ESTIMATION<-function(x, digits = max(3L, getOption("digits") - 3L), signif.stars = getOption("show.signif.stars"), ...){ - orders <- x$sarima_orders - - cat("SARIMA model: ", - .arima_node(orders$p, orders$d, orders$q), - .arima_node(orders$bp, orders$bd, orders$bq)) - if (!is.null(orders$period)) # when sarima_estimate() is used - cat(sprintf(" [%i]", orders$period)) - - cat("\n") - cat("\nCoefficients\n") - if (is.null(x$coef_table)){ - cat("No SARIMA variables\n") - } else if (ncol(x$coef_table) == 2){ - print(x$coef_table) - } else { - printCoefmat(x$coef_table[-2], digits = digits, signif.stars = signif.stars, - na.print = "NA", ...) - } - invisible(x) +print.summary.JD3_SARIMA_ESTIMATION <- function(x, digits = max(3L, getOption("digits") - 3L), signif.stars = getOption("show.signif.stars"), ...) { + orders <- x$sarima_orders + + cat( + "SARIMA model:", + .arima_node(orders$p, orders$d, orders$q), + .arima_node(orders$bp, orders$bd, orders$bq) + ) + if (!is.null(orders$period)) { # when sarima_estimate() is used + cat(sprintf(" [%i]", orders$period)) + } + + cat("\n") + cat("\nCoefficients\n") + if (is.null(x$coef_table)) { + cat("No SARIMA variables\n") + } else if (ncol(x$coef_table) == 2) { + print(x$coef_table, ...) + } else { + printCoefmat(x$coef_table[-2], + digits = digits, signif.stars = signif.stars, + na.print = "NA", ... + ) + } + invisible(x) } -.sarima_coef_table <- function(x, ...){ - UseMethod(".sarima_coef_table", x) +.sarima_coef_table <- function(x, ...) { + UseMethod(".sarima_coef_table", x) } -.sarima_coef_table.default <- function(x, cov = NULL, ndf = NULL,...){ - m <- x - if (! is.null(m$phi)) p<-dim(m$phi)[2]else p<-0 - if (! is.null(m$theta)) q<-dim(m$theta)[2]else q<-0 - if (! is.null(m$bphi)) bp<-dim(m$bphi)[2]else bp<-0 - if (! is.null(m$btheta)) bq<-dim(m$btheta)[2]else bq<-0 - sarima_orders <- list(p = p, d = m$d, q = q, bp = bp, bd = m$bd, bq = bq) - names<-NULL - if (p > 0){names<-c(names,paste0("phi(", 1:p, ')')) } - if (q > 0){names<-c(names,paste0("theta(", 1:q, ')')) } - if (bp > 0){names<-c(names,paste0("bphi(", 1:bp, ')')) } - if (bq > 0){names<-c(names,paste0("btheta(", 1:bq,')')) } - if (! is.null(names)){ - all<-t(cbind(m$phi, m$theta, m$bphi, m$btheta)) - fr<-as.data.frame(all, row.names = names) - for(i in colnames(fr)){ - fr[,i] <- unlist(fr[,i]) +.sarima_coef_table.default <- function(x, cov = NULL, ndf = NULL, ...) { + m <- x + if (!is.null(m$phi)) p <- dim(m$phi)[2] else p <- 0 + if (!is.null(m$theta)) q <- dim(m$theta)[2] else q <- 0 + if (!is.null(m$bphi)) bp <- dim(m$bphi)[2] else bp <- 0 + if (!is.null(m$btheta)) bq <- dim(m$btheta)[2] else bq <- 0 + sarima_orders <- list(p = p, d = m$d, q = q, bp = bp, bd = m$bd, bq = bq) + names <- NULL + if (p > 0) { + names <- c(names, paste0("phi(", 1:p, ")")) + } + if (q > 0) { + names <- c(names, paste0("theta(", 1:q, ")")) + } + if (bp > 0) { + names <- c(names, paste0("bphi(", 1:bp, ")")) + } + if (bq > 0) { + names <- c(names, paste0("btheta(", 1:bq, ")")) } - if (!is.null(cov) && !is.null(ndf)){ - fr$pvalue <- fr$t <- fr$stde <- NA - stde<-sqrt(diag(cov)) - sel<-fr$type=='ESTIMATED' - t<-fr$value[sel]/stde - pval<-2*pt(abs(t), ndf, lower.tail = FALSE) - fr$stde[sel]<-stde - fr$t[sel]<-t - fr$pvalue[sel]<-pval - colnames(fr) <- c("Estimate", "Type", "Std. Error", - "T-stat", "Pr(>|t|)") + if (!is.null(names)) { + all <- t(cbind(m$phi, m$theta, m$bphi, m$btheta)) + fr <- as.data.frame(all, row.names = names) + for (i in colnames(fr)) { + fr[, i] <- unlist(fr[, i]) + } + if (!is.null(cov) && !is.null(ndf)) { + fr$pvalue <- fr$t <- fr$stde <- NA + stde <- sqrt(diag(cov)) + sel <- fr$type == "ESTIMATED" + t <- fr$value[sel] / stde + pval <- 2 * pt(abs(t), ndf, lower.tail = FALSE) + fr$stde[sel] <- stde + fr$t[sel] <- t + fr$pvalue[sel] <- pval + colnames(fr) <- c( + "Estimate", "Type", "Std. Error", + "T-stat", "Pr(>|t|)" + ) + } else { + colnames(fr) <- c("Estimate", "Type") + } } else { - colnames(fr) <- c("Estimate", "Type") + fr <- NULL } - } else { - fr <- NULL - } - list(sarima_orders = sarima_orders, - coef_table = fr) + list( + sarima_orders = sarima_orders, + coef_table = fr + ) } -.sarima_coef_table.JD3_REGARIMA_RSLTS <- function(x, cov = NULL, ndf = NULL,...) { - .sarima_coef_table(x$description$arima, cov = cov, ndf = ndf, ...) +.sarima_coef_table.JD3_REGARIMA_RSLTS <- function(x, cov = NULL, ndf = NULL, ...) { + .sarima_coef_table(x$description$arima, cov = cov, ndf = ndf, ...) } -.sarima_coef_table.JD3_SARIMA_ESTIMATE <- function(x,...){ - ndf<-x$likelihood$neffectiveobs-x$likelihood$nparams - sarima_orders <- list(p = x$orders$order[1], - d = x$orders$order[2], - q = x$orders$order[3], - bp = x$orders$seasonal$order[1], - bd = x$orders$seasonal$order[2], - bq = x$orders$seasonal$order[3], - period = x$orders$seasonal$period) - estimate <- x$parameters$val - - if (length(estimate) > 0){ - stde <- sqrt(diag(x$parameters$cov)) - t<-estimate/stde - pval<-2*pt(abs(t), ndf, lower.tail = FALSE) - table <- data.frame(estimate, "ESTIMATED", stde, t, pval) - colnames(table) <- c("Estimate", "Type", "Std. Error", - "T-stat", "Pr(>|t|)") - } else { - table <- NULL - } - list(sarima_orders = sarima_orders, - coef_table = table) +.sarima_coef_table.JD3_SARIMA_ESTIMATE <- function(x, ...) { + ndf <- x$likelihood$neffectiveobs - x$likelihood$nparams + sarima_orders <- list( + p = x$orders$order[1], + d = x$orders$order[2], + q = x$orders$order[3], + bp = x$orders$seasonal$order[1], + bd = x$orders$seasonal$order[2], + bq = x$orders$seasonal$order[3], + period = x$orders$seasonal$period + ) + estimate <- x$parameters$val + + if (length(estimate) > 0) { + stde <- sqrt(diag(x$parameters$cov)) + t <- estimate / stde + pval <- 2 * pt(abs(t), ndf, lower.tail = FALSE) + table <- data.frame(estimate, "ESTIMATED", stde, t, pval, + stringsAsFactors = FALSE) + colnames(table) <- c( + "Estimate", "Type", "Std. Error", + "T-stat", "Pr(>|t|)" + ) + } else { + table <- NULL + } + list( + sarima_orders = sarima_orders, + coef_table = table + ) } #' @rdname jd3_print #' @export -print.JD3_SPAN <- function(x, ...){ - span <- x - type <- span$type - d0 <- span$d0 - d1 <- span$d1 - n0 <- span$n0 - n1 <- span$n1 - - if (type == "ALL") { x <- "All"} - else if (type == "FROM") { x <- paste("From", d0, sep = " ")} - else if (type == "TO") { x <- paste("Until", d1, sep = " ")} - else if (type == "BETWEEN") { x <- paste(d0, d1, sep = " - ")} - else if (type == "FIRST") { x <- paste("First", n0, "periods", sep = " ")} - else if (type == "LAST") { x <- paste("Last", n1, "periods", sep = " ")} - else if (type == "EXCLUDING") { x <- paste("All but first", n0, "periods and last", n1, "periods", sep = " ")} - else { x <- "Undefined"} - - cat(x, "\n") - - return(invisible(x)) +print.JD3_SPAN <- function(x, ...) { + span <- x + type <- span$type + d0 <- span$d0 + d1 <- span$d1 + n0 <- span$n0 + n1 <- span$n1 + + if (type == "ALL") { + x <- "All" + } else if (type == "FROM") { + x <- paste("From", d0, sep = " ") + } else if (type == "TO") { + x <- paste("Until", d1, sep = " ") + } else if (type == "BETWEEN") { + x <- paste(d0, d1, sep = " - ") + } else if (type == "FIRST") { + x <- paste("First", n0, "periods", sep = " ") + } else if (type == "LAST") { + x <- paste("Last", n1, "periods", sep = " ") + } else if (type == "EXCLUDING") { + x <- paste("All but first", n0, "periods and last", n1, "periods", sep = " ") + } else { + x <- "Undefined" + } + + cat(x, "\n") + + return(invisible(x)) } #' @rdname jd3_print #' @export -print.JD3_LIKELIHOOD<-function(x, ...){ - ll <- x - cat("Number of observations: ", ll$nobs, "\n") - cat("Number of effective observations: ", ll$neffectiveobs, "\n") - cat("Number of parameters: ", ll$nparams, "\n\n") - cat("Loglikelihood: ", ll$ll, "\n") - if (ll$ll != ll$adjustedll)cat("Adjusted loglikelihood: ", ll$adjustedll, "\n\n") - cat("Standard error of the regression (ML estimate): ", sqrt(ll$ssq/ll$neffectiveobs), "\n") - cat("AIC: ", ll$aic, "\n") - cat("AICC: ", ll$aicc, "\n") - cat("BIC: ", ll$bic, "\n\n") - invisible(x) +print.JD3_LIKELIHOOD <- function(x, ...) { + ll <- x + cat("Number of observations:", ll$nobs, "\n") + cat("Number of effective observations:", ll$neffectiveobs, "\n") + cat("Number of parameters:", ll$nparams, "\n\n") + cat("Loglikelihood:", ll$ll, "\n") + if (ll$ll != ll$adjustedll) cat("Adjusted loglikelihood:", ll$adjustedll, "\n\n") + cat("Standard error of the regression (ML estimate):", sqrt(ll$ssq / ll$neffectiveobs), "\n") + cat("AIC:", ll$aic, "\n") + cat("AICC:", ll$aicc, "\n") + cat("BIC:", ll$bic, "\n\n") + invisible(x) } #' @export -summary.JD3_LIKELIHOOD<-function(object, ...){ +summary.JD3_LIKELIHOOD <- function(object, ...) { res <- list( nobs = object$nobs, neffectiveobs = object$neffectiveobs, nparams = object$nparams, ll = object$ll, adjustedll = object$adjustedll, - se = sqrt(object$ssq/object$neffectiveobs), + se = sqrt(object$ssq / object$neffectiveobs), aic = object$aic, aicc = object$aicc, bic = object$bic @@ -232,167 +272,216 @@ summary.JD3_LIKELIHOOD<-function(object, ...){ res } #' @export -print.summary.JD3_LIKELIHOOD<-function(x, ...){ - cat("Number of observations: ", x$nobs, - ", Number of effective observations: ", x$neffectiveobs, - ", Number of parameters: ", x$nparams, "\n") - cat("Loglikelihood: ", x$ll) - if (x$ll != x$adjustedll)cat(", Adjusted loglikelihood: ", x$adjustedll) - cat("\nStandard error of the regression (ML estimate): ", x$se, "\n") - cat("AIC: ", x$aic, ", ") - cat("AICc: ", x$aicc, ", ") - cat("BIC: ", x$bic, "\n") - invisible(x) +print.summary.JD3_LIKELIHOOD <- function(x, ...) { + cat("Number of observations: ", x$nobs, + ", Number of effective observations: ", x$neffectiveobs, + ", Number of parameters: ", x$nparams, "\n", + sep = "" + ) + cat("Loglikelihood:", x$ll) + if (x$ll != x$adjustedll) cat(", Adjusted loglikelihood:", x$adjustedll) + cat("\nStandard error of the regression (ML estimate):", x$se, "\n") + cat("AIC: ", x$aic, ", ", + "AICc: ", x$aicc, ", ", + "BIC: ", x$bic, "\n", + sep = "" + ) + invisible(x) } #' @rdname jd3_print #' @export -print.JD3_REGARIMA_RSLTS<-function(x, digits = max(3L, getOption("digits") - 3L), ...){ - cat("Log-transformation:",if (x$description$log) {"yes"} else {"no"}, - "\n", sep=" ") +print.JD3_REGARIMA_RSLTS <- function(x, digits = max(3L, getOption("digits") - 3L), summary_info = getOption("summary_info"), ...) { + cat("Log-transformation:", if (x$description$log) { + "yes" + } else { + "no" + }, + "\n", + sep = " " + ) - ndf<-x$estimation$likelihood$neffectiveobs-x$estimation$likelihood$nparams - print(x$description$arima, cov = x$estimation$parameters$cov, + ndf <- x$estimation$likelihood$neffectiveobs - x$estimation$likelihood$nparams + print(x$description$arima, + cov = x$estimation$parameters$cov, ndf = ndf, digits = digits, - ...) - xregs <- .regarima_coef_table(x, ...) - cat("\n") - if (!is.null(xregs)){ - cat("Regression model:\n") - printCoefmat(xregs[-2], digits = digits, P.values= FALSE, na.print = "NA", ...) - } else { - cat("No regression variables\n") - } - print(x$estimation$likelihood, ...) - invisible(x) + ... + ) + xregs <- .regarima_coef_table(x, ...) + cat("\n") + if (!is.null(xregs)) { + cat("Regression model:\n") + xregs_coef <- xregs[, 1] + names(xregs_coef) <- rownames(xregs) + print(xregs_coef, digits = digits, na.print = "NA", ...) + } else { + cat("No regression variables\n") + } + if (summary_info) { + cat("\nFor a more detailed output, use the 'summary()' function.\n") + } + + invisible(x) } #' @export -print.JD3_SARIMA_ESTIMATE<-function(x, digits = max(3L, getOption("digits") - 3L), ...){ - - tables <- .sarima_coef_table(x, ...) - orders <- tables$sarima_orders - - cat("SARIMA model: ", - .arima_node(orders$p, orders$d, orders$q), - .arima_node(orders$bp, orders$bd, orders$bq)) - if (!is.null(orders$period)) # when sarima_estimate() is used - cat(sprintf(" [%i]", orders$period)) - - cat("\n") - - cat("\nCoefficients\n") - if (is.null(tables$coef_table)){ - cat("No SARIMA variables\n") - } else if (ncol(tables$coef_table) == 2){ - print(tables$coef_table) - } else { - printCoefmat(tables$coef_table[-2], digits = digits, - P.values= FALSE, - na.print = "NA", ...) - } - xregs <- .regarima_coef_table(x, ...) - cat("\n") - if (!is.null(xregs)){ - cat("Regression model:\n") - printCoefmat(xregs[-2], digits = digits, P.values= FALSE, na.print = "NA", ...) - } else { - cat("No regression variables\n") - } - # print(x$likelihood, ...) # likelihood not printed but in summary method - invisible(x) +print.JD3_SARIMA_ESTIMATE <- function(x, digits = max(3L, getOption("digits") - 3L), summary_info = getOption("summary_info"), ...) { + tables <- .sarima_coef_table(x, ...) + orders <- tables$sarima_orders + + cat( + "SARIMA model:", + .arima_node(orders$p, orders$d, orders$q), + .arima_node(orders$bp, orders$bd, orders$bq) + ) + if (!is.null(orders$period)) { # when sarima_estimate() is used + cat(sprintf(" [%i]", orders$period)) + } + + cat("\n") + + cat("\nCoefficients\n") + if (is.null(tables$coef_table)) { + cat("No SARIMA variables\n") + } else { + coef <- tables$coef_table[, 1] + names(coef) <- rownames(tables$coef_table) + print(coef, digits = digits, na.print = "NA", ...) + } + xregs <- .regarima_coef_table(x, ...) + cat("\n") + if (!is.null(xregs)) { + cat("Regression model:\n") + xregs_coef <- xregs[, 1] + names(xregs_coef) <- rownames(xregs) + print(xregs_coef, digits = digits, na.print = "NA", ...) + } else { + cat("No regression variables\n") + } + if (summary_info) { + cat("\nFor a more detailed output, use the 'summary()' function.\n") + } + invisible(x) } -.regarima_coef_table <- function(x,...){ - UseMethod(".regarima_coef_table", x) +.regarima_coef_table <- function(x, ...) { + UseMethod(".regarima_coef_table", x) } -.regarima_coef_table.default <- function(x,...){ - q <- x - if (length(q$description$variables)>0){ - regs<-do.call("rbind", lapply(q$description$variables, function(z){z$coef})) - xregs<-cbind(regs, stde=NA, t=NA, pvalue=NA) - stde<-sqrt(diag(q$estimation$bvar)) - sel<-xregs$type=='ESTIMATED' - t<-xregs$value[sel]/stde - ndf<-q$estimation$likelihood$neffectiveobs-q$estimation$likelihood$nparams - pval<-2*pt(abs(t), ndf, lower.tail = FALSE) - xregs$stde[sel]<-stde - xregs$t[sel]<-t - xregs$pvalue[sel]<-pval - colnames(xregs) <- c("Estimate", "Type", "Std. Error", - "T-stat", "Pr(>|t|)") - xregs - } else { - NULL - } +.regarima_coef_table.default <- function(x, ...) { + q <- x + if (length(q$description$variables) > 0) { + regs <- do.call("rbind", lapply(q$description$variables, function(z) { + z$coef + })) + xregs <- cbind(regs, stde = NA, t = NA, pvalue = NA) + stde <- sqrt(diag(q$estimation$bvar)) + sel <- xregs$type == "ESTIMATED" + t <- xregs$value[sel] / stde + ndf <- q$estimation$likelihood$neffectiveobs - q$estimation$likelihood$nparams + pval <- 2 * pt(abs(t), ndf, lower.tail = FALSE) + xregs$stde[sel] <- stde + xregs$t[sel] <- t + xregs$pvalue[sel] <- pval + colnames(xregs) <- c( + "Estimate", "Type", "Std. Error", + "T-stat", "Pr(>|t|)" + ) + xregs + } else { + NULL + } } -.regarima_coef_table.JD3_SARIMA_ESTIMATE <- function(x,...){ - ndf<-x$likelihood$neffectiveobs-x$likelihood$nparams - - estimate <- x$b - if (length(estimate) > 0){ - stde <- sqrt(diag(x$bvar)) - t<-estimate/stde - pval<-2*pt(abs(t), ndf, lower.tail = FALSE) - table <- data.frame(estimate, "ESTIMATED", stde, t, pval) - colnames(table) <- c("Estimate", "Type", "Std. Error", - "T-stat", "Pr(>|t|)") - } else { - table <- NULL - } - table +.regarima_coef_table.JD3_SARIMA_ESTIMATE <- function(x, ...) { + ndf <- x$likelihood$neffectiveobs - x$likelihood$nparams + + estimate <- x$b + if (length(estimate) > 0) { + stde <- sqrt(diag(x$bvar)) + t <- estimate / stde + pval <- 2 * pt(abs(t), ndf, lower.tail = FALSE) + table <- data.frame(estimate, "ESTIMATED", stde, t, pval, + stringsAsFactors = FALSE) + colnames(table) <- c( + "Estimate", "Type", "Std. Error", + "T-stat", "Pr(>|t|)" + ) + } else { + table <- NULL + } + table } #' @export -summary.JD3_REGARIMA_RSLTS<-function(object, ...){ - log <- object$description$log - ndf<-object$estimation$likelihood$neffectiveobs-object$estimation$likelihood$nparams+1 - sarima_sum <- summary(object$description$arima, cov = object$estimation$parameters$cov, - ndf = ndf, ...) - xregs <- .regarima_coef_table(object, ...) - likelihood <- summary(object$estimation$likelihood) - res <- list(log = log, - sarima = sarima_sum, - xregs = xregs, - likelihood = likelihood) - class(res) <- "summary.JD3_REGARIMA_RSLTS" - res +summary.JD3_REGARIMA_RSLTS <- function(object, ...) { + log <- object$description$log + ndf <- object$estimation$likelihood$neffectiveobs - object$estimation$likelihood$nparams + 1 + sarima_sum <- summary(object$description$arima, + cov = object$estimation$parameters$cov, + ndf = ndf, ... + ) + xregs <- .regarima_coef_table(object, ...) + likelihood <- summary(object$estimation$likelihood) + res <- list( + log = log, + sarima = sarima_sum, + xregs = xregs, + likelihood = likelihood + ) + class(res) <- "summary.JD3_REGARIMA_RSLTS" + res } #' @export -summary.JD3_SARIMA_ESTIMATE <-function(object, ...){ - sarima_sum <- .sarima_coef_table(object, ...) - class(sarima_sum) <- "summary.JD3_SARIMA_ESTIMATION" - likelihood <- summary(object$likelihood) - res <- list(log = NULL, - sarima = sarima_sum, - xregs = .regarima_coef_table(object, ...), - likelihood = likelihood) - class(res) <- "summary.JD3_REGARIMA_RSLTS" - return(res) +summary.JD3_SARIMA_ESTIMATE <- function(object, ...) { + sarima_sum <- .sarima_coef_table(object, ...) + class(sarima_sum) <- "summary.JD3_SARIMA_ESTIMATION" + likelihood <- summary(object$likelihood) + res <- list( + log = NULL, + sarima = sarima_sum, + xregs = .regarima_coef_table(object, ...), + likelihood = likelihood + ) + class(res) <- "summary.JD3_REGARIMA_RSLTS" + return(res) } #' @export -print.summary.JD3_REGARIMA_RSLTS <- function(x, digits = max(3L, getOption("digits") - 3L), signif.stars = getOption("show.signif.stars"), ...){ - if (!is.null(x$log)) - cat("Log-transformation:",if (x$log) {"yes"} else {"no"},"\n",sep=" ") - - print(x$sarima, digits = digits, signif.stars = signif.stars, ...) - cat("\n") - if (!is.null(x$xregs)){ - cat("Regression model:\n") - printCoefmat(x$xregs[-2], digits = digits, signif.stars = signif.stars, - na.print = "NA", ...) - } else { - cat("No regression variables\n") - } - print(x$likelihood, ...) - invisible(x) +print.summary.JD3_REGARIMA_RSLTS <- function(x, digits = max(3L, getOption("digits") - 3L), signif.stars = getOption("show.signif.stars"), ...) { + if (!is.null(x$method)) { # Used to add the method when regarima/tramo function is used + cat("Method:", x$method, "\n") + } + + if (!is.null(x$log)) { + cat("Log-transformation:", if (x$log) { + "yes" + } else { + "no" + }, "\n", sep = " ") + } + + print(x$sarima, digits = digits, signif.stars = signif.stars, ...) + cat("\n") + if (!is.null(x$xregs)) { + cat("Regression model:\n") + printCoefmat(x$xregs[-2], + digits = digits, signif.stars = signif.stars, + na.print = "NA", ... + ) + } else { + cat("No regression variables\n") + } + print(x$likelihood, ...) + invisible(x) } #' @export -diagnostics.JD3_REGARIMA_RSLTS<-function(x, ...){ - if (is.null(x)) return(NULL) - residuals_test <- x$diagnostics - residuals_test <- data.frame(Statistic = sapply(residuals_test, function(test) test[["value"]]), - P.value = sapply(residuals_test, function(test) test[["pvalue"]]), - Description = sapply(residuals_test, function(test) attr(test, "distribution"))) - residuals_test +diagnostics.JD3_REGARIMA_RSLTS <- function(x, ...) { + if (is.null(x)) { + return(NULL) + } + residuals_test <- x$diagnostics + residuals_test <- data.frame( + Statistic = sapply(residuals_test, function(test) test[["value"]]), + P.value = sapply(residuals_test, function(test) test[["pvalue"]]), + Description = sapply(residuals_test, function(test) attr(test, "distribution")) + ) + residuals_test } diff --git a/R/distributions.R b/R/distributions.R index fede4c7f..567eb0e4 100644 --- a/R/distributions.R +++ b/R/distributions.R @@ -16,22 +16,22 @@ #' @rdname studentdistribution #' @order 3 #' @export -random_t<-function(df, n){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "randomsT", df, as.integer(n)) +random_t <- function(df, n) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "randomsT", df, as.integer(n)) } #' @rdname studentdistribution #' @order 1 #' @export -density_t<-function(df, x){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "densityT", df, .jarray(as.numeric(x))) +density_t <- function(df, x) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "densityT", df, .jarray(as.numeric(x))) } #' @rdname studentdistribution #' @order 2 #' @export -cdf_t<-function(df, x){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "cdfT", df, .jarray(as.numeric(x))) +cdf_t <- function(df, x) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "cdfT", df, .jarray(as.numeric(x))) } #' The Chi-Squared Distribution @@ -44,22 +44,22 @@ cdf_t<-function(df, x){ #' @rdname chi2distribution #' @order 3 #' @export -random_chi2<-function(df, n){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "randomsChi2", df, as.integer(n)) +random_chi2 <- function(df, n) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "randomsChi2", df, as.integer(n)) } #' @rdname chi2distribution #' @order 1 #' @export -density_chi2<-function(df, x){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "densityChi2", df, .jarray(as.numeric(x))) +density_chi2 <- function(df, x) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "densityChi2", df, .jarray(as.numeric(x))) } #' @rdname chi2distribution #' @order 2 #' @export -cdf_chi2<-function(df, x){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "cdfChi2", df, .jarray(as.numeric(x))) +cdf_chi2 <- function(df, x) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "cdfChi2", df, .jarray(as.numeric(x))) } #' The Gamma Distribution @@ -73,22 +73,22 @@ cdf_chi2<-function(df, x){ #' @rdname gammadistribution #' @order 3 #' @export -random_gamma<-function(shape, scale, n){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "randomsGamma", shape, scale, as.integer(n)) +random_gamma <- function(shape, scale, n) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "randomsGamma", shape, scale, as.integer(n)) } #' @rdname gammadistribution #' @order 1 #' @export -density_gamma<-function(shape, scale, x){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "densityGamma", shape, scale, .jarray(as.numeric(x))) +density_gamma <- function(shape, scale, x) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "densityGamma", shape, scale, .jarray(as.numeric(x))) } #' @rdname gammadistribution #' @order 2 #' @export -cdf_gamma<-function(shape, scale, x){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "cdfGamma", shape, scale, .jarray(as.numeric(x))) +cdf_gamma <- function(shape, scale, x) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "cdfGamma", shape, scale, .jarray(as.numeric(x))) } #' The Inverse-Gamma Distribution @@ -101,22 +101,22 @@ cdf_gamma<-function(shape, scale, x){ #' @rdname invgammadistribution #' @order 3 #' @export -random_inverse_gamma<-function(shape, scale, n){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "randomsInverseGamma", shape, scale, as.integer(n)) +random_inverse_gamma <- function(shape, scale, n) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "randomsInverseGamma", shape, scale, as.integer(n)) } #' @rdname invgammadistribution #' @order 1 #' @export -density_inverse_gamma<-function(shape, scale, x){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "densityInverseGamma", shape, scale, .jarray(as.numeric(x))) +density_inverse_gamma <- function(shape, scale, x) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "densityInverseGamma", shape, scale, .jarray(as.numeric(x))) } #' @rdname invgammadistribution #' @order 2 #' @export -cdf_inverse_gamma<-function(shape, scale, x){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "cdfInverseGamma", shape, scale, .jarray(as.numeric(x))) +cdf_inverse_gamma <- function(shape, scale, x) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "cdfInverseGamma", shape, scale, .jarray(as.numeric(x))) } #' The Inverse-Gaussian Distribution @@ -129,20 +129,20 @@ cdf_inverse_gamma<-function(shape, scale, x){ #' @rdname invgaussiandistribution #' @order 3 #' @export -random_inverse_gaussian<-function(shape, scale, n){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "randomsInverseGaussian", shape, scale, as.integer(n)) +random_inverse_gaussian <- function(shape, scale, n) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "randomsInverseGaussian", shape, scale, as.integer(n)) } #' @rdname invgaussiandistribution #' @order 1 #' @export -density_inverse_gaussian<-function(shape, scale, x){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "densityInverseGaussian", shape, scale, .jarray(as.numeric(x))) +density_inverse_gaussian <- function(shape, scale, x) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "densityInverseGaussian", shape, scale, .jarray(as.numeric(x))) } #' @rdname invgaussiandistribution #' @order 2 #' @export -cdf_inverse_gaussian<-function(shape, scale, x){ - .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "cdfInverseGaussian", shape, scale, .jarray(as.numeric(x))) +cdf_inverse_gaussian <- function(shape, scale, x) { + .jcall("jdplus/toolkit/base/r/stats/Distributions", "[D", "cdfInverseGaussian", shape, scale, .jarray(as.numeric(x))) } diff --git a/R/generics.R b/R/generics.R index b65c4cc1..f4755dec 100644 --- a/R/generics.R +++ b/R/generics.R @@ -1,19 +1,18 @@ - #' Generic Diagnostics Function #' #' @param x the object to extract diagnostics. #' @param ... further arguments. #' #' @export -diagnostics<-function(x, ...){ - UseMethod("diagnostics", x) +diagnostics <- function(x, ...) { + UseMethod("diagnostics", x) } #' @rdname diagnostics #' @export -diagnostics.JD3<-function(x, ...){ - cat("No diagnostic\n") +diagnostics.JD3 <- function(x, ...) { + cat("No diagnostic\n") } @@ -24,8 +23,8 @@ diagnostics.JD3<-function(x, ...){ #' @param x,... parameters. #' #' @export -sa_preprocessing<-function(x, ...){ - UseMethod("sa_preprocessing", x) +sa_preprocessing <- function(x, ...) { + UseMethod("sa_preprocessing", x) } @@ -41,7 +40,7 @@ sa_preprocessing<-function(x, ...){ #' @param type_chart the chart to plot: `"sa-trend"` (by default) plots the input time series, #' the seasonally adjusted and the trend; `"seas-irr"` plots the seasonal and the irregular components. #' @param caption the caption of the plot. -#' @param colors the colors used in the plot. +#' @param colors the colours used in the plot. #' @param ... further arguments. #' #' @return \code{"JD3_SADECOMPOSITION"} object. @@ -50,8 +49,8 @@ NULL #' @export #' @rdname sa_decomposition -sa_decomposition<-function(x, ...){ - UseMethod("sa_decomposition", x) +sa_decomposition <- function(x, ...) { + UseMethod("sa_decomposition", x) } #' Deprecated functions @@ -63,7 +62,7 @@ sa_decomposition<-function(x, ...){ #' @name deprecated-rjd3toolkit #' @export #' @export -sa.decomposition<-function(x, ...){ - .Deprecated("sa_decomposition") - UseMethod("sa_decomposition", x) +sa.decomposition <- function(x, ...) { + .Deprecated("sa_decomposition") + UseMethod("sa_decomposition", x) } diff --git a/R/jd2r.R b/R/jd2r.R index 2f03d73b..2d7e1d57 100644 --- a/R/jd2r.R +++ b/R/jd2r.R @@ -3,80 +3,102 @@ NULL #> NULL -.jd2r_test<-function(jtest){ - if (is.jnull(jtest)) - return(NULL) - else { - desc<-.jcall(jtest, "S", "getDescription") - val<-.jcall(jtest, "D", "getValue") - pval<-.jcall(jtest, "D", "getPvalue") - return(statisticaltest(val, pval, desc)) - } +.jd2r_test <- function(jtest) { + if (is.jnull(jtest)) { + return(NULL) + } else { + desc <- .jcall(jtest, "S", "getDescription") + val <- .jcall(jtest, "D", "getValue") + pval <- .jcall(jtest, "D", "getPvalue") + return(statisticaltest(val, pval, desc)) + } } + +.jd2r_regression_item <- function(s) { + desc <- .jcall(s, "S", "getDescription") + val <- .jcall(s, "D", "getCoefficient") + stderr <- .jcall(s, "D", "getStdError") + pval <- .jcall(s, "D", "getPvalue") + res <- matrix(c(val, stderr, val / stderr, pval), nrow = 1) + colnames(res) <- c("Estimate", "Std. Error", "T-stat", "Pr(>|t|)") + rownames(res) <- desc + res +} #' @export #' @rdname jd3_utilities -.r2jd_tsdata<-function(s){ - if (is.null(s)){ - return(NULL) - } - freq<-frequency(s) - start<-start(s) - .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/TsData;", "of", - as.integer(freq), as.integer(start[1]), as.integer(start[2]), as.double(s)) +.r2jd_tsdata <- function(s) { + if (is.null(s)) { + return(NULL) + } + freq <- frequency(s) + start <- start(s) + .jcall( + "jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/TsData;", "of", + as.integer(freq), as.integer(start[1]), as.integer(start[2]), as.double(s) + ) } #' @export #' @rdname jd3_utilities -.r2jd_tsdomain<-function(period, startYear, startPeriod, length){ - .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/TsDomain;", "of", - as.integer(period), as.integer(startYear), as.integer(startPeriod), as.integer(length)) +.r2jd_tsdomain <- function(period, startYear, startPeriod, length) { + .jcall( + "jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/TsDomain;", "of", + as.integer(period), as.integer(startYear), as.integer(startPeriod), as.integer(length) + ) } #' @export #' @rdname jd3_utilities -.jd2r_tsdata<-function(s){ - if (is.jnull(s)){ - return(NULL) - } - jx<-.jcall(s, "Ljdplus/toolkit/base/api/data/DoubleSeq;", "getValues") - x<-.jcall(jx, "[D", "toArray") - if (is.null(x)) return(NULL) - if (length(x) == 0) return(NULL) - pstart<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[I", "startPeriod", s) - ts(x,start=pstart[2:3], frequency=pstart[1]) +.jd2r_tsdata <- function(s) { + if (is.jnull(s)) { + return(NULL) + } + jx <- .jcall(s, "Ljdplus/toolkit/base/api/data/DoubleSeq;", "getValues") + x <- .jcall(jx, "[D", "toArray") + if (is.null(x)) { + return(NULL) + } + if (length(x) == 0) { + return(NULL) + } + pstart <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[I", "startPeriod", s) + ts(x, start = pstart[2:3], frequency = pstart[1]) } #' @export #' @rdname jd3_utilities -.jd2r_mts<-function(s){ - if (is.jnull(s)){ - return(NULL) - } - jx<-.jcall(s, "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "toMatrix") - x<-.jd2r_matrix(jx) - if (is.jnull(x)) return(NULL) - pstart<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[I", "startPeriod", s) - ts(x,start=pstart[2:3], frequency=pstart[1]) +.jd2r_mts <- function(s) { + if (is.jnull(s)) { + return(NULL) + } + jx <- .jcall(s, "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "toMatrix") + x <- .jd2r_matrix(jx) + if (is.jnull(x)) { + return(NULL) + } + pstart <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[I", "startPeriod", s) + ts(x, start = pstart[2:3], frequency = pstart[1]) } -.extract_jts<-function(collection, index){ - js<- .jcall(collection, "Ljdplus/toolkit/base/api/timeseries/Ts;", "get", as.integer(index-1)) - return(js) +.extract_jts <- function(collection, index) { + js <- .jcall(collection, "Ljdplus/toolkit/base/api/timeseries/Ts;", "get", as.integer(index - 1)) + return(js) } #' @export #' @rdname jd3_utilities -.jd2r_lts<-function(s){ - if (is.jnull(s)){ +.jd2r_lts <- function(s) { + if (is.jnull(s)) { return(NULL) } - size<-.jcall(s, "I", "length") - if (size == 0) + size <- .jcall(s, "I", "length") + if (size == 0) { return(NULL) + } all <- lapply( X = 1:size, - FUN = function(idx){ + FUN = function(idx) { return(.jd2r_ts(.extract_jts(s, idx))) } ) @@ -85,78 +107,91 @@ NULL #' @export #' @rdname jd3_utilities -.jd2r_matrix<-function(s){ - if (is.jnull(s)){ - return(NULL) - } - nr<-.jcall(s, "I", "getRowsCount") - nc<-.jcall(s, "I", "getColumnsCount") - d<-.jcall(s, "[D", "toArray") - return(array(d, dim=c(nr, nc))) +.jd2r_matrix <- function(s) { + if (is.jnull(s)) { + return(NULL) + } + nr <- .jcall(s, "I", "getRowsCount") + nc <- .jcall(s, "I", "getColumnsCount") + d <- .jcall(s, "[D", "toArray") + return(array(d, dim = c(nr, nc))) } #' @export #' @rdname jd3_utilities -.r2jd_matrix<-function(s){ - if (is.null(s)) - return(.jnull("jdplus/toolkit/base/api/math/matrices/Matrix")) - if (!is.matrix(s)){ - s<-matrix(s, nrow=length(s), ncol=1) - } - sdim<-dim(s) - return(.jcall("jdplus/toolkit/base/api/math/matrices/Matrix","Ljdplus/toolkit/base/api/math/matrices/Matrix;", "of", as.double(s), as.integer(sdim[1]), as.integer(sdim[2]))) +.r2jd_matrix <- function(s) { + if (is.null(s)) { + return(.jnull("jdplus/toolkit/base/api/math/matrices/Matrix")) + } + if (!is.matrix(s)) { + s <- matrix(s, nrow = length(s), ncol = 1) + } + sdim <- dim(s) + return(.jcall("jdplus/toolkit/base/api/math/matrices/Matrix", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "of", .jarray(as.double(s)), as.integer(sdim[1]), as.integer(sdim[2]))) } -.j2r_ldt<-function(ldt){ - if (is.jnull(ldt)) - return(NULL) - dt<-.jcall(ldt, "Ljava/time/LocalDate;", "toLocalDate") - return(as.Date(.jcall(dt, "S", "toString"))) +.j2r_ldt <- function(ldt) { + if (is.jnull(ldt)) { + return(NULL) + } + dt <- .jcall(ldt, "Ljava/time/LocalDate;", "toLocalDate") + return(as.Date(.jcall(dt, "S", "toString"))) } -.j2r_dt<-function(dt){ - if (is.jnull(dt)) - return(NULL) - return(as.Date(.jcall(dt, "S", "toString"))) +.j2r_dt <- function(dt) { + if (is.jnull(dt)) { + return(NULL) + } + return(as.Date(.jcall(dt, "S", "toString"))) } -.r2j_dt<-function(dt){ - jdt<-.jnew("java/lang/String", as.character(dt)) - return(.jcall("java/time/LocalDate", "Ljava/time/LocalDate;", "parse", .jcast(jdt, "java/lang/CharSequence"))) +.r2j_dt <- function(dt) { + jdt <- .jnew("java/lang/String", as.character(dt)) + return(.jcall("java/time/LocalDate", "Ljava/time/LocalDate;", "parse", .jcast(jdt, "java/lang/CharSequence"))) } -.r2j_ldt<-function(dt){ - jdt<-.r2j_dt(dt) - return(.jcall(jdt, "Ljava/time/LocalDateTime;", "atStartOfDay")) +.r2j_ldt <- function(dt) { + jdt <- .r2j_dt(dt) + return(.jcall(jdt, "Ljava/time/LocalDateTime;", "atStartOfDay")) } -.jd2r_parameters <- function(jparams){ - if (is.jnull(jparams)) - return(NULL) - param<-.jcastToArray(jparams) - len <- length(param) - if (len==0) - return(NULL) - param_name <- deparse(substitute(jparams)) - Type <- sapply(param, function(x) .jcall(.jcall(x, "Ljdplus/toolkit/base/api/data/ParameterType;", "getType"), "S", "name")) - Value <- sapply(param, function(x) .jcall(x, "D", "getValue")) - data_param <- data.frame(Type = Type, Value = Value) - rownames(data_param) <- sprintf("%s(%i)", - param_name, - 1:len) - data_param +.jd2r_parameters <- function(jparams) { + if (is.jnull(jparams)) { + return(NULL) + } + param <- .jcastToArray(jparams) + len <- length(param) + if (len == 0) { + return(NULL) + } + param_name <- deparse(substitute(jparams)) + Type <- sapply(param, function(x) .jcall(.jcall(x, "Ljdplus/toolkit/base/api/data/ParameterType;", "getType"), "S", "name")) + Value <- sapply(param, function(x) .jcall(x, "D", "getValue")) + data_param <- data.frame(Type = Type, Value = Value) + rownames(data_param) <- sprintf( + "%s(%i)", + param_name, + 1:len + ) + data_param } #' @export #' @rdname jd3_utilities -.jdomain<-function(period, start, end){ - if (period == 0)return(.jnull("jdplus/toolkit/base/api/timeseries/TsDomain")) - if (is.null(start)) - start<-c(1900,1) - if (is.null(end)) - end<-c(2100, 1) - n<-period*(end[1]-start[1])+end[2]-start[2] - jdom<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/TsDomain;", "of" - , as.integer(period), as.integer(start[1]), as.integer(start[2]), as.integer(n)) - return(jdom) +.jdomain <- function(period, start, end) { + if (period == 0) { + return(.jnull("jdplus/toolkit/base/api/timeseries/TsDomain")) + } + if (is.null(start)) { + start <- c(1900, 1) + } + if (is.null(end)) { + end <- c(2100, 1) + } + n <- period * (end[1] - start[1]) + end[2] - start[2] + jdom <- .jcall( + "jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/TsDomain;", "of", + as.integer(period), as.integer(start[1]), as.integer(start[2]), as.integer(n) + ) + return(jdom) } diff --git a/R/jd3rslts.R b/R/jd3rslts.R index 6b41c5d6..603dd5d4 100644 --- a/R/jd3rslts.R +++ b/R/jd3rslts.R @@ -2,189 +2,204 @@ #' @export #' @rdname jd3_utilities -.proc_numeric<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (!is.jnull(s)) - .jcall(s, "D", "doubleValue") - else - return (NaN) +.proc_numeric <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (!is.jnull(s)) { + .jcall(s, "D", "doubleValue") + } else { + return(NaN) + } } #' @export #' @rdname jd3_utilities -.proc_vector<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(s)) - return(NULL) - .jevalArray(s) +.proc_vector <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(s)) { + return(NULL) + } + .jevalArray(s) } #' @export #' @rdname jd3_utilities -.proc_int<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(s)) - return(-1) - .jcall(s, "I", "intValue") +.proc_int <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(s)) { + return(-1) + } + .jcall(s, "I", "intValue") } #' @export #' @rdname jd3_utilities -.proc_bool<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(s)) - return(FALSE) - .jcall(s, "Z", "booleanValue") +.proc_bool <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(s)) { + return(FALSE) + } + .jcall(s, "Z", "booleanValue") } #' @export #' @rdname jd3_utilities -.proc_ts<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(s)) - return (NULL) - if (.jinstanceof(s, "jdplus/toolkit/base/api/timeseries/TsData")) - return(.jd2r_tsdata(.jcast(s,"jdplus/toolkit/base/api/timeseries/TsData"))) - else - return (NULL) +.proc_ts <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(s)) { + return(NULL) + } + if (.jinstanceof(s, "jdplus/toolkit/base/api/timeseries/TsData")) { + return(.jd2r_tsdata(.jcast(s, "jdplus/toolkit/base/api/timeseries/TsData"))) + } else { + return(NULL) + } } #' @export #' @rdname jd3_utilities -.proc_str<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(s)) - return(NULL) - .jcall(s, "S", "toString") +.proc_str <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(s)) { + return(NULL) + } + .jcall(s, "S", "toString") } #' @export #' @rdname jd3_utilities -.proc_desc<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(s)) - return(NULL) - .jevalArray(s) +.proc_desc <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(s)) { + return(NULL) + } + .jevalArray(s) } #' @export #' @rdname jd3_utilities -.proc_test<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(s)) - return(NULL) - desc<-.jcall(s, "S", "getDescription") - val<-.jcall(s, "D", "getValue") - pval<-.jcall(s, "D", "getPvalue") - all<-c(val, pval) - attr(all, "description")<-desc - all +.proc_test <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(s)) { + return(NULL) + } + desc <- .jcall(s, "S", "getDescription") + val <- .jcall(s, "D", "getValue") + pval <- .jcall(s, "D", "getPvalue") + all <- c(val, pval) + attr(all, "description") <- desc + all } #' @export #' @rdname jd3_utilities -.proc_parameter<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(s)) - return(NULL) - val<-.jcall(s, "D", "getValue") - return (val) +.proc_parameter <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(s)) { + return(NULL) + } + val <- .jcall(s, "D", "getValue") + return(val) } #' @export #' @rdname jd3_utilities -.proc_parameters<-function(rslt, name){ - jd_p<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(jd_p)) - return(NULL) - p<-.jcastToArray(jd_p) - len<-length(p) - all<-array(0, dim=c(len)) - for (i in 1:len){ - all[i]<-.jcall(p[[i]], "D", "getValue") - } - all +.proc_parameters <- function(rslt, name) { + jd_p <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(jd_p)) { + return(NULL) + } + p <- .jcastToArray(jd_p) + len <- length(p) + all <- array(0, dim = c(len)) + for (i in 1:len) { + all[i] <- .jcall(p[[i]], "D", "getValue") + } + all } #' @export #' @rdname jd3_utilities -.proc_matrix<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(s)) - return(NULL) - return (.jd2r_matrix(s)) +.proc_matrix <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(s)) { + return(NULL) + } + return(.jd2r_matrix(s)) } #' @export #' @rdname jd3_utilities -.proc_data<-function(rslt, name){ - s<-.jcall(rslt, "Ljava/lang/Object;", "getData", name) - if (is.jnull(s)) - return (NULL) - if (.jinstanceof(s, "jdplus/toolkit/base/api/timeseries/TsData")) - return(.jd2r_tsdata(.jcast(s,"jdplus/toolkit/base/api/timeseries/TsData"))) - else if (.jinstanceof(s, "java/lang/Number")) - return (.jcall(s, "D", "doubleValue")) - else if (.jinstanceof(s, "jdplus/toolkit/base/api/math/matrices/Matrix")) - return(.jd2r_matrix(.jcast(s,"jdplus/toolkit/base/api/math/matrices/Matrix"))) - else if (.jinstanceof(s, "jdplus/toolkit/base/api/data/Parameter")){ - val<-.jcall(s, "D", "getValue") - return (c(val)) - } else if (.jinstanceof(s, "[Ljdplus/toolkit/base/api/data/Parameter;")){ - p<-.jcastToArray(s) - len<-length(p) - all<-array(0, dim=c(len)) - for (i in 1:len){ - all[i]<-.jcall(p[[i]], "D", "getValue") - } - return (all) - } else if (.jcall(.jcall(s, "Ljava/lang/Class;", "getClass"), "Z", "isArray")) - return (.jevalArray(s, silent=TRUE)) - else if (.jinstanceof(s, "jdplus/toolkit/base/api/stats/StatisticalTest")) { - return (.jd2r_test(s)) - } - else - return (.jcall(s, "S", "toString")) +.proc_data <- function(rslt, name) { + s <- .jcall(rslt, "Ljava/lang/Object;", "getData", name) + if (is.jnull(s)) { + return(NULL) + } + if (.jinstanceof(s, "jdplus/toolkit/base/api/timeseries/TsData")) { + return(.jd2r_tsdata(.jcast(s, "jdplus/toolkit/base/api/timeseries/TsData"))) + } else if (.jinstanceof(s, "java/lang/Number")) { + return(.jcall(s, "D", "doubleValue")) + } else if (.jinstanceof(s, "jdplus/toolkit/base/api/math/matrices/Matrix")) { + return(.jd2r_matrix(.jcast(s, "jdplus/toolkit/base/api/math/matrices/Matrix"))) + } else if (.jinstanceof(s, "jdplus/toolkit/base/api/data/Parameter")) { + val <- .jcall(s, "D", "getValue") + return(c(val)) + } else if (.jinstanceof(s, "[Ljdplus/toolkit/base/api/data/Parameter;")) { + p <- .jcastToArray(s) + len <- length(p) + all <- array(0, dim = c(len)) + for (i in 1:len) { + all[i] <- .jcall(p[[i]], "D", "getValue") + } + return(all) + } else if (.jcall(.jcall(s, "Ljava/lang/Class;", "getClass"), "Z", "isArray")) { + return(.jevalArray(s, silent = TRUE)) + } else if (.jinstanceof(s, "jdplus/toolkit/base/api/stats/StatisticalTest")) { + return(.jd2r_test(s)) + } else if (.jinstanceof(s, "jdplus/toolkit/base/api/timeseries/regression/RegressionItem")) { + return(.jd2r_regression_item(s)) + } else { + return(.jcall(s, "S", "toString")) + } } #' @export #' @rdname jd3_utilities -.proc_dictionary<-function(name){ - jmapping<-.jcall(name, "Ljdplus/toolkit/base/api/information/InformationMapping;", "getMapping") - jmap<-.jnew("java/util/LinkedHashMap") - .jcall(jmapping, "V", "fillDictionary", .jnull("java/lang/String"), .jcast(jmap, "java/util/Map"), TRUE) - jkeys<-.jcall(jmap, "Ljava/util/Set;", "keySet") - size<-.jcall(jkeys, "I", "size") - keys<-array(dim=size) - if (size >0){ - jiter<-.jcall(jkeys, "Ljava/util/Iterator;", "iterator") - for (i in 1:size){ - keys[i] <- .jcall(.jcall(jiter, "Ljava/lang/Object;", "next"), "Ljava/lang/String;", "toString") - } - } - return (keys) +.proc_dictionary <- function(name) { + jmapping <- .jcall(name, "Ljdplus/toolkit/base/api/information/InformationMapping;", "getMapping") + jmap <- .jnew("java/util/LinkedHashMap") + .jcall(jmapping, "V", "fillDictionary", .jnull("java/lang/String"), .jcast(jmap, "java/util/Map"), TRUE) + jkeys <- .jcall(jmap, "Ljava/util/Set;", "keySet") + size <- .jcall(jkeys, "I", "size") + keys <- array(dim = size) + if (size > 0) { + jiter <- .jcall(jkeys, "Ljava/util/Iterator;", "iterator") + for (i in 1:size) { + keys[i] <- .jcall(.jcall(jiter, "Ljava/lang/Object;", "next"), "Ljava/lang/String;", "toString") + } + } + return(keys) } #' @export #' @rdname jd3_utilities -.proc_dictionary2<-function(jobj){ - jmap<-.jcall(jobj, "Ljava/util/Map;", "getDictionary") - jkeys<-.jcall(jmap, "Ljava/util/Set;", "keySet") - size<-.jcall(jkeys, "I", "size") - keys<-array(dim=size) - if (size > 0){ - jiter<-.jcall(jkeys, "Ljava/util/Iterator;", "iterator") - for (i in 1:size){ - keys[i] <- .jcall(.jcall(jiter, "Ljava/lang/Object;", "next"), "Ljava/lang/String;", "toString") - } - } - return (keys) +.proc_dictionary2 <- function(jobj) { + jmap <- .jcall(jobj, "Ljava/util/Map;", "getDictionary") + jkeys <- .jcall(jmap, "Ljava/util/Set;", "keySet") + size <- .jcall(jkeys, "I", "size") + keys <- array(dim = size) + if (size > 0) { + jiter <- .jcall(jkeys, "Ljava/util/Iterator;", "iterator") + for (i in 1:size) { + keys[i] <- .jcall(.jcall(jiter, "Ljava/lang/Object;", "next"), "Ljava/lang/String;", "toString") + } + } + return(keys) } #' @export #' @rdname jd3_utilities -.proc_likelihood<-function(jrslt, prefix){ - return (list( - ll=.proc_numeric(jrslt, paste(prefix,"ll", sep="")), - ssq=.proc_numeric(jrslt, paste(prefix,"ssqerr", sep="")), - nobs=.proc_int(jrslt, paste(prefix,"nobs", sep="")), - neffective=.proc_int(jrslt, paste(prefix,"neffective", sep="")), - nparams=.proc_int(jrslt, paste(prefix,"nparams", sep="")), - df=.proc_int(jrslt, paste(prefix,"df", sep="")), - aic=.proc_numeric(jrslt, paste(prefix,"aic", sep="")), - aicc=.proc_numeric(jrslt, paste(prefix,"aicc", sep="")), - bic=.proc_numeric(jrslt, paste(prefix,"bic", sep="")), - bic2=.proc_numeric(jrslt, paste(prefix,"bic2", sep="")), - bicc=.proc_numeric(jrslt, paste(prefix,"bicc", sep="")), - hannanquinn=.proc_numeric(jrslt, paste(prefix,"hannanquinn", sep=""))) - ) +.proc_likelihood <- function(jrslt, prefix) { + return(list( + ll = .proc_numeric(jrslt, paste(prefix, "ll", sep = "")), + ssq = .proc_numeric(jrslt, paste(prefix, "ssqerr", sep = "")), + nobs = .proc_int(jrslt, paste(prefix, "nobs", sep = "")), + neffective = .proc_int(jrslt, paste(prefix, "neffective", sep = "")), + nparams = .proc_int(jrslt, paste(prefix, "nparams", sep = "")), + df = .proc_int(jrslt, paste(prefix, "df", sep = "")), + aic = .proc_numeric(jrslt, paste(prefix, "aic", sep = "")), + aicc = .proc_numeric(jrslt, paste(prefix, "aicc", sep = "")), + bic = .proc_numeric(jrslt, paste(prefix, "bic", sep = "")), + bic2 = .proc_numeric(jrslt, paste(prefix, "bic2", sep = "")), + bicc = .proc_numeric(jrslt, paste(prefix, "bicc", sep = "")), + hannanquinn = .proc_numeric(jrslt, paste(prefix, "hannanquinn", sep = "")) + )) } diff --git a/R/modellingcontext.R b/R/modellingcontext.R index d78b8a66..17cacf63 100644 --- a/R/modellingcontext.R +++ b/R/modellingcontext.R @@ -1,10 +1,10 @@ #' @include calendars.R NULL -JD3_DYNAMICTS<-'JD3_DYNAMICTS' -JD3_TSMONIKER<-'JD3_TSMONIKER' -JD3_TS<-'JD3_TS' -JD3_TSCOLLECTION<-'JD3_TSCOLLECTION' +JD3_DYNAMICTS <- "JD3_DYNAMICTS" +JD3_TSMONIKER <- "JD3_TSMONIKER" +JD3_TS <- "JD3_TS" +JD3_TSCOLLECTION <- "JD3_TSCOLLECTION" #' Title #' @@ -15,232 +15,273 @@ JD3_TSCOLLECTION<-'JD3_TSCOLLECTION' #' @export #' #' @examples -tsmoniker<-function(source, id){ - return(structure(list(source=source, id=id), class=c(JD3_TSMONIKER))) +.tsmoniker <- function(source, id) { + return(structure(list(source = source, id = id), class = c(JD3_TSMONIKER))) } #' @export #' @rdname jd3_utilities -.r2p_moniker<-function(r){ - p<-jd3.TsMoniker$new() - p$source<-r$source - p$id<-r$id - return(p) +.r2p_moniker <- function(r) { + p <- jd3.TsMoniker$new() + p$source <- r$source + p$id <- r$id + return(p) } #' @export #' @rdname jd3_utilities -.p2r_moniker<-function(p){ - if (is.null(p)) return(NULL) - return(tsmoniker(p$source, p$id)) +.p2r_moniker <- function(p) { + if (is.null(p)) { + return(NULL) + } + return(.tsmoniker(p$source, p$id)) } #' @export #' @rdname jd3_utilities -.r2p_datasupplier<-function(name, r){ - p<-jd3.TsDataSuppliers$Item$new() - p$name<-name - if (is.ts(r)) p$data<-.r2p_tsdata(r) - else if (is(r, JD3_DYNAMICTS)) p$dynamic_data<-.r2p_dynamic_ts(r) - else return(NULL) - return(p) +.r2p_datasupplier <- function(name, r) { + p <- jd3.TsDataSuppliers$Item$new() + p$name <- name + if (is.ts(r)) { + p$data <- .r2p_tsdata(r) + } else if (is(r, JD3_DYNAMICTS)) { + p$dynamic_data <- .r2p_dynamic_ts(r) + } else { + return(NULL) + } + return(p) } -dynamic_ts<-function(moniker, data){ - return(structure(list(moniker=moniker, data=data), class=c(JD3_DYNAMICTS))) +dynamic_ts <- function(moniker, data) { + return(structure(list(moniker = moniker, data = data), class = c(JD3_DYNAMICTS))) } -.ts<-function(name, moniker, metadata, data){ - return(structure(list(name=name, moniker=moniker, metadata=metadata, data=data), class=c(JD3_TS))) +.ts <- function(name, moniker, metadata, data) { + return(structure(list(name = name, moniker = moniker, metadata = metadata, data = data), class = c(JD3_TS))) } -.tscollection<-function(name, moniker, metadata, series){ - return(structure(list(name=name, moniker=moniker, metadata=metadata, series=series), class=c(JD3_TSCOLLECTION))) +.tscollection <- function(name, moniker, metadata, series) { + return(structure(list(name = name, moniker = moniker, metadata = metadata, series = series), class = c(JD3_TSCOLLECTION))) } #' @export #' @rdname jd3_utilities -.p2r_metadata<-function(p){ - n<-length(p) - if (n > 0){ - lv<-lapply(p, function(v){return(v$value)}) - ns<-sapply(p, function(v){return(v$key)}) - names(lv)<-ns - return(lv) - } - return(NULL) +.p2r_metadata <- function(p) { + n <- length(p) + if (n > 0) { + lv <- lapply(p, function(v) { + return(v$value) + }) + ns <- sapply(p, function(v) { + return(v$key) + }) + names(lv) <- ns + return(lv) + } + return(NULL) } -.entry<-function(key, value, type){ - p<-type$new() - p$key<-key - p$value<-value - return(p) +.entry <- function(key, value, type) { + p <- type$new() + p$key <- key + p$value <- value + return(p) } #' @export #' @rdname jd3_utilities -.r2p_metadata<-function(r, type){ - n<-names(r) - pm<-lapply(n, function(item){ return(.entry(item, r[[item]], type)) }) - return(pm) +.r2p_metadata <- function(r, type) { + n <- names(r) + pm <- lapply(n, function(item) { + return(.entry(item, r[[item]], type)) + }) + return(pm) } #' @export #' @rdname jd3_utilities -.p2r_ts<-function(p){ - if (is.null(p)) return(NULL) - s<-.p2r_tsdata(p$data) - m<-.p2r_moniker(p$moniker) - md<-.p2r_metadata(p$metadata) - return(.ts(p$name, m, md, s)) +.p2r_ts <- function(p) { + if (is.null(p)) { + return(NULL) + } + s <- .p2r_tsdata(p$data) + m <- .p2r_moniker(p$moniker) + md <- .p2r_metadata(p$metadata) + return(.ts(p$name, m, md, s)) } #' @export #' @rdname jd3_utilities -.r2p_ts<-function(r){ - p<-jd3.Ts$new() - p$name<-r$name - p$moniker<-.r2p_moniker(r$moniker) - p$metadata<-.r2p_metadata(r$metadata,jd3.Ts$MetadataEntry) - p$data<- .r2p_tsdata(r$data) - return(p) +.r2p_ts <- function(r) { + p <- jd3.Ts$new() + p$name <- r$name + p$moniker <- .r2p_moniker(r$moniker) + p$metadata <- .r2p_metadata(r$metadata, jd3.Ts$MetadataEntry) + p$data <- .r2p_tsdata(r$data) + return(p) } #' @export #' @rdname jd3_utilities -.p2r_tscollection<-function(p){ - if (is.null(p)) - return(NULL) - else { - rs<-lapply(p$series, function(s){return(.p2r_ts(s))}) - names<-lapply(rs, function(s){return(s$name)}) - rs<-`names<-`(rs, names) - return(.tscollection(p$name, .p2r_moniker(p$moniker), .p2r_metadata(p$metadata), rs)) - } +.p2r_tscollection <- function(p) { + if (is.null(p)) { + return(NULL) + } else { + rs <- lapply(p$series, function(s) { + return(.p2r_ts(s)) + }) + names <- lapply(rs, function(s) { + return(s$name) + }) + rs <- `names<-`(rs, names) + return(.tscollection(p$name, .p2r_moniker(p$moniker), .p2r_metadata(p$metadata), rs)) + } } #' @export #' @rdname jd3_utilities -.r2p_tscollection<-function(r){ - p<-jd3.TsCollection$new() - p$name<-r$name - p$moniker<-.r2p_moniker(r$moniker) - p$metadata<-.r2p_metadata(r$metadata,jd3.TsCollection$MetadataEntry) - p$series<- lapply(r$series, function(s){return(.r2p_ts(s))}) - return(p) +.r2p_tscollection <- function(r) { + p <- jd3.TsCollection$new() + p$name <- r$name + p$moniker <- .r2p_moniker(r$moniker) + p$metadata <- .r2p_metadata(r$metadata, jd3.TsCollection$MetadataEntry) + p$series <- lapply(r$series, function(s) { + return(.r2p_ts(s)) + }) + return(p) } #' @export #' @rdname jd3_utilities -.r2jd_ts<-function(s){ - if (is.null(s)) - return(.jnull("jdplus/toolkit/base/api/timeseries/Ts")) - ps<-.r2p_ts(s) - bytes<-RProtoBuf::serialize(ps, NULL) - return(.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "tsOfBytes", bytes)) +.r2jd_ts <- function(s) { + if (is.null(s)) { + return(.jnull("jdplus/toolkit/base/api/timeseries/Ts")) + } + ps <- .r2p_ts(s) + bytes <- RProtoBuf::serialize(ps, NULL) + return(.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "tsOfBytes", bytes)) } #' @export #' @rdname jd3_utilities -.jd2r_ts<-function(js){ - if (is.jnull(js)) - return(NULL) - q<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[B", "toBuffer", js) - p<-RProtoBuf::read(jd3.Ts, q) - return(.p2r_ts(p)) +.jd2r_ts <- function(js) { + if (is.jnull(js)) { + return(NULL) + } + q <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[B", "toBuffer", js) + p <- RProtoBuf::read(jd3.Ts, q) + return(.p2r_ts(p)) } #' @export #' @rdname jd3_utilities -.r2jd_tscollection<-function(s){ - if (is.null(s)) - return(.jnull("jdplus/toolkit/base/api/timeseries/TsCollection")) - ps<-.r2p_tscollection(s) - bytes<-RProtoBuf::serialize(ps, NULL) - return(.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "tsCollectionOfBytes", bytes)) +.r2jd_tscollection <- function(s) { + if (is.null(s)) { + return(.jnull("jdplus/toolkit/base/api/timeseries/TsCollection")) + } + ps <- .r2p_tscollection(s) + bytes <- RProtoBuf::serialize(ps, NULL) + return(.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "tsCollectionOfBytes", bytes)) } #' @export #' @rdname jd3_utilities -.jd2r_tscollection<-function(js){ - if (is.jnull(js)) - return(NULL) - q<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[B", "toBuffer", js) - p<-RProtoBuf::read(jd3.TsCollection, q) - return(.p2r_tscollection(p)) +.jd2r_tscollection <- function(js) { + if (is.jnull(js)) { + return(NULL) + } + q <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[B", "toBuffer", js) + p <- RProtoBuf::read(jd3.TsCollection, q) + return(.p2r_tscollection(p)) } -.r2p_dynamic_ts<-function(r){ - p<-jd3.DynamicTsData$new() - p$current<- .r2p_tsdata(r$data) - p$moniker<-.r2p_moniker(r$moniker) - return(p) +.r2p_dynamic_ts <- function(r) { + p <- jd3.DynamicTsData$new() + p$current <- .r2p_tsdata(r$data) + p$moniker <- .r2p_moniker(r$moniker) + return(p) } -.p2r_dynamic_ts<-function(p){ - if (is.null(p)) return(NULL) - s<-.p2r_tsdata(p$current) - m<-.p2r_moniker(p$moniker) - return(dynamic_ts(m, s)) +.p2r_dynamic_ts <- function(p) { + if (is.null(p)) { + return(NULL) + } + s <- .p2r_tsdata(p$current) + m <- .p2r_moniker(p$moniker) + return(dynamic_ts(m, s)) } -.r2p_dynamic_ts<-function(r){ - p<-jd3.DynamicTsData$new() - p$current<- .r2p_tsdata(r$data) - p$moniker<-.r2p_moniker(r$moniker) - return(p) +.r2p_dynamic_ts <- function(r) { + p <- jd3.DynamicTsData$new() + p$current <- .r2p_tsdata(r$data) + p$moniker <- .r2p_moniker(r$moniker) + return(p) } #' @export #' @rdname jd3_utilities -.p2r_datasupplier<-function(p){ - if (p$has('dynamic_data')) return(.p2r_dynamic_ts(p$dynamic_data)) - if (p$has('data')) return(.p2r_tsdata(p$data)) - return(NULL) +.p2r_datasupplier <- function(p) { + if (p$has("dynamic_data")) { + return(.p2r_dynamic_ts(p$dynamic_data)) + } + if (p$has("data")) { + return(.p2r_tsdata(p$data)) + } + return(NULL) } #' @export #' @rdname jd3_utilities -.r2p_datasuppliers<-function(r){ - if (! is.list(r)) stop("Suppliers should be a list") - ns<-names(r) - if (is.null(ns)) - stop("All the variables of the list should be named") - n<-length(ns) - all<-lapply(1:n, function(z){.r2p_datasupplier(ns[z], r[[z]])}) - p<-jd3.TsDataSuppliers$new() - p$items<-all - return(p) +.r2p_datasuppliers <- function(r) { + if (!is.list(r)) stop("Suppliers should be a list") + ns <- names(r) + if (is.null(ns)) { + stop("All the variables of the list should be named") + } + n <- length(ns) + all <- lapply(1:n, function(z) { + .r2p_datasupplier(ns[z], r[[z]]) + }) + p <- jd3.TsDataSuppliers$new() + p$items <- all + return(p) } #' @export #' @rdname jd3_utilities -.p2r_datasuppliers<-function(p){ - n<-length(p$items) - if (n == 0){return(list())} - l<-lapply(1:n, function(i){return(.p2r_datasupplier(p$items[[i]]))}) - ns<-sapply(1:n, function(i){return(p$items[[i]]$name)}) - names(l)<-ns - return(l) +.p2r_datasuppliers <- function(p) { + n <- length(p$items) + if (n == 0) { + return(list()) + } + l <- lapply(1:n, function(i) { + return(.p2r_datasupplier(p$items[[i]])) + }) + ns <- sapply(1:n, function(i) { + return(p$items[[i]]$name) + }) + names(l) <- ns + return(l) } #' @export #' @rdname jd3_utilities -.p2jd_variables<-function(p){ - bytes<-p$serialize(NULL) - jcal <- .jcall("jdplus/toolkit/base/r/util/Modelling", "Ljdplus/toolkit/base/api/timeseries/regression/TsDataSuppliers;", - "variablesOf", - bytes) +.p2jd_variables <- function(p) { + bytes <- p$serialize(NULL) + jcal <- .jcall( + "jdplus/toolkit/base/r/util/Modelling", "Ljdplus/toolkit/base/api/timeseries/regression/TsDataSuppliers;", + "variablesOf", + bytes + ) return(jcal) } #' @export #' @rdname jd3_utilities -.jd2p_variables<-function(jd){ - bytes<-.jcall("jdplus/toolkit/base/r/util/Modelling", "[B", "toBuffer", jd) - p<-RProtoBuf::read(jd3.TsDataSuppliers, bytes) +.jd2p_variables <- function(jd) { + bytes <- .jcall("jdplus/toolkit/base/r/util/Modelling", "[B", "toBuffer", jd) + p <- RProtoBuf::read(jd3.TsDataSuppliers, bytes) return(p) } @@ -248,24 +289,24 @@ dynamic_ts<-function(moniker, data){ #' @export #' @rdname jd3_utilities -.jd2r_variables<-function(jcals){ - p<-.jd2p_variables(jcals) +.jd2r_variables <- function(jcals) { + p <- .jd2p_variables(jcals) return(.p2r_datasuppliers(p)) } #' @export #' @rdname jd3_utilities -.r2jd_variables<-function(r){ - p<-.r2p_datasuppliers(r) +.r2jd_variables <- function(r) { + p <- .r2p_datasuppliers(r) return(.p2jd_variables(p)) } -#' Create context +#' @title Create context #' @description #' Function allowing to include calendars and external regressors in a format that makes them usable #' in an estimation processes (seasonal adjustment or pre-processing). The regressors can be created with functions available in the package -#' or come from any other source, provided they are "TS" class objects. +#' or come from any other source, provided they are \code{ts} class objects. #' @param calendars list of calendars. #' @param variables list of variables. #' @@ -275,14 +316,16 @@ dynamic_ts<-function(moniker, data){ #' @examples #' # creating one or several external regressors (TS objects), which will #' # be gathered in one or several groups -#' iv1<-intervention_variable(12, c(2000, 1), 60, -#' starts = "2001-01-01", ends = "2001-12-01") -#' iv2<- intervention_variable(12, c(2000, 1), 60, -#' starts = "2001-01-01", ends = "2001-12-01", delta = 1) +#' iv1 <- intervention_variable(12, c(2000, 1), 60, +#' starts = "2001-01-01", ends = "2001-12-01" +#' ) +#' iv2 <- intervention_variable(12, c(2000, 1), 60, +#' starts = "2001-01-01", ends = "2001-12-01", delta = 1 +#' ) #' # regressors as a list of two groups reg1 and reg2 -#' vars<-list(reg1=list(x = iv1),reg2=list(x = iv2) ) +#' vars <- list(reg1 = list(x = iv1), reg2 = list(x = iv2)) #' # creating the modelling context -#' my_context<-modelling_context(variables=vars) +#' my_context <- modelling_context(variables = vars) #' # customize a default specification #' # init_spec <- rjd3x13::x13_spec("RSA5c") #' # new_spec<- add_usrdefvar(init_spec,name = "reg1.iv1", regeffect="Trend") @@ -292,193 +335,209 @@ dynamic_ts<-function(moniker, data){ #' @references #' More information on auxiliary variables in JDemetra+ online documentation: #' \url{https://jdemetra-new-documentation.netlify.app/} -modelling_context<-function(calendars=NULL, variables=NULL){ - if (is.null(calendars))calendars<-list() - if (is.null(variables))variables<-list() - if (! is.list(calendars)) stop("calendars should be a list of calendars") - if (length(calendars)>0) if (length(calendars) != length(which(sapply(calendars,function(z) is(z, 'JD3_CALENDARDEFINITION'))))) stop("calendars should be a list of calendars") - if (! is.list(variables)) stop("variables should be a list of vars") - if (length(variables) != 0){ - list_var <- sapply(variables, is.list) - mts_var <- sapply(variables, is.mts) - ts_var <- (!list_var) & (!mts_var) - if (any(mts_var)) { - # case of a simple mts dictionary - for (i in which(mts_var)) { - all_var <- lapply(seq_len(ncol(variables[[i]])), function(j) { - variables[[i]][, j] - }) - names(all_var) <- colnames(variables[[i]]) - variables[[i]] <- all_var - } - } - if (any (ts_var)) { - # case of a simple ts dictionary - # Use 'r' as the name of the dictionary - variables <- c(variables[!ts_var], list(r = variables[ts_var])) - } - if (sum(names(variables) == "r") >= 2){ - # handle case with multiple r groups defined - combined_var <- do.call(c, variables[names(variables) == "r"]) - names(combined_var) <- unlist(lapply(variables[names(variables) == "r"], names)) - combined_var <- list(r = combined_var) - variables <- c(variables[names(variables) != "r"], combined_var) +modelling_context <- function(calendars = NULL, variables = NULL) { + if (is.null(calendars)) calendars <- list() + if (is.null(variables)) variables <- list() + if (!is.list(calendars)) stop("calendars should be a list of calendars") + if (length(calendars) > 0) if (length(calendars) != length(which(sapply(calendars, function(z) is(z, "JD3_CALENDARDEFINITION"))))) stop("calendars should be a list of calendars") + if (!is.list(variables)) stop("variables should be a list of vars") + if (length(variables) != 0) { + list_var <- sapply(variables, is.list) + mts_var <- sapply(variables, is.mts) + ts_var <- (!list_var) & (!mts_var) + if (any(mts_var)) { + # case of a simple mts dictionary + for (i in which(mts_var)) { + all_var <- lapply(seq_len(ncol(variables[[i]])), function(j) { + variables[[i]][, j] + }) + names(all_var) <- colnames(variables[[i]]) + variables[[i]] <- all_var + } + } + if (any(ts_var)) { + # case of a simple ts dictionary + # Use 'r' as the name of the dictionary + variables <- c(variables[!ts_var], list(r = variables[ts_var])) + } + if (sum(names(variables) == "r") >= 2) { + # handle case with multiple r groups defined + combined_var <- do.call(c, variables[names(variables) == "r"]) + names(combined_var) <- unlist(lapply(variables[names(variables) == "r"], names)) + combined_var <- list(r = combined_var) + variables <- c(variables[names(variables) != "r"], combined_var) + } } - } - return(list(calendars=calendars, variables=variables)) + return(list(calendars = calendars, variables = variables)) } #' @export #' @rdname jd3_utilities -.p2r_context<-function(p){ - n<-length(p$calendars) - lcal <- lvar <- NULL - if (n > 0){ - lcal<-lapply(1:n, function(i){return(.p2r_calendardef(p$calendars[[i]]$value))}) - ns<-sapply(1:n, function(i){return(p$calendars[[i]]$key)}) - names(lcal)<-ns - } - n<-length(p$variables) - if (n > 0){ - lvar<-lapply(1:n, function(i){return(.p2r_datasuppliers(p$variables[[i]]$value))}) - ns<-sapply(1:n, function(i){return(p$variables[[i]]$key)}) - names(lvar)<-ns - } - return(list(calendars=lcal, variables=lvar)) +.p2r_context <- function(p) { + n <- length(p$calendars) + lcal <- lvar <- NULL + if (n > 0) { + lcal <- lapply(1:n, function(i) { + return(.p2r_calendardef(p$calendars[[i]]$value)) + }) + ns <- sapply(1:n, function(i) { + return(p$calendars[[i]]$key) + }) + names(lcal) <- ns + } + n <- length(p$variables) + if (n > 0) { + lvar <- lapply(1:n, function(i) { + return(.p2r_datasuppliers(p$variables[[i]]$value)) + }) + ns <- sapply(1:n, function(i) { + return(p$variables[[i]]$key) + }) + names(lvar) <- ns + } + return(list(calendars = lcal, variables = lvar)) } #' @export #' @rdname jd3_utilities -.r2p_context<-function(r){ - p<-jd3.ModellingContext$new() - n<-length(r$calendars) - if (n > 0){ - ns<-names(r$calendars) - # To take into account empty calendars - length_cal <- sapply(r$calendars, length) - - lcal<-lapply((1:n)[length_cal!=0], function(i){ - entry<-jd3.ModellingContext$CalendarsEntry$new() - entry$key<-ns[i] - entry$value<-.r2p_calendardef(r$calendars[[i]]) - return(entry) - }) - if (length(lcal) > 0) { - p$calendars<-lcal +.r2p_context <- function(r) { + p <- jd3.ModellingContext$new() + n <- length(r$calendars) + if (n > 0) { + ns <- names(r$calendars) + # To take into account empty calendars + length_cal <- lengths(r$calendars) + + lcal <- lapply((1:n)[length_cal != 0], function(i) { + entry <- jd3.ModellingContext$CalendarsEntry$new() + entry$key <- ns[i] + entry$value <- .r2p_calendardef(r$calendars[[i]]) + return(entry) + }) + if (length(lcal) > 0) { + p$calendars <- lcal + } } - } - n<-length(r$variables) - if (n > 0){ - ns<-names(r$variables) - length_var <- sapply(r$variables, length) - lvar<-lapply((1:n)[length_var!=0], function(i){ - entry<-jd3.ModellingContext$VariablesEntry$new() - entry$key<-ns[i] - entry$value<-.r2p_datasuppliers(r$variables[[i]]) - return(entry) - }) - if (length(lvar) > 0) { - p$variables <- lvar + n <- length(r$variables) + if (n > 0) { + ns <- names(r$variables) + length_var <- lengths(r$variables) + lvar <- lapply((1:n)[length_var != 0], function(i) { + entry <- jd3.ModellingContext$VariablesEntry$new() + entry$key <- ns[i] + entry$value <- .r2p_datasuppliers(r$variables[[i]]) + return(entry) + }) + if (length(lvar) > 0) { + p$variables <- lvar + } } - } - return(p) + return(p) } #' @export #' @rdname jd3_utilities -.p2jd_context<-function(p){ - bytes<-p$serialize(NULL) - jcal <- .jcall("jdplus/toolkit/base/r/util/Modelling", "Ljdplus/toolkit/base/api/timeseries/regression/ModellingContext;", - "of", - bytes) - return(jcal) +.p2jd_context <- function(p) { + bytes <- p$serialize(NULL) + jcal <- .jcall( + "jdplus/toolkit/base/r/util/Modelling", "Ljdplus/toolkit/base/api/timeseries/regression/ModellingContext;", + "of", + bytes + ) + return(jcal) } #' @export #' @rdname jd3_utilities -.jd2p_context<-function(jd){ - bytes<-.jcall("jdplus/toolkit/base/r/util/Modelling", "[B", "toBuffer", jd) - p<-RProtoBuf::read(jd3.ModellingContext, bytes) - return(p) +.jd2p_context <- function(jd) { + bytes <- .jcall("jdplus/toolkit/base/r/util/Modelling", "[B", "toBuffer", jd) + p <- RProtoBuf::read(jd3.ModellingContext, bytes) + return(p) } #' @export #' @rdname jd3_utilities -.jd2r_modellingcontext<-function(jcontext){ - p<-.jd2p_context(jcontext) - return(.p2r_context(p)) +.jd2r_modellingcontext <- function(jcontext) { + p <- .jd2p_context(jcontext) + return(.p2r_context(p)) } #' @export #' @rdname jd3_utilities -.r2jd_modellingcontext<-function(r){ - p<-.r2p_context(r) - return(.p2jd_context(p)) +.r2jd_modellingcontext <- function(r) { + p <- .r2p_context(r) + return(.p2jd_context(p)) } #' @export #' @rdname jd3_utilities -.p2r_calendars<-function(p){ - n<-length(p$calendars) +.p2r_calendars <- function(p) { + n <- length(p$calendars) lcal <- NULL - if (n > 0){ - lcal<-lapply(1:n, function(i){return(.p2r_calendardef(p$calendars[[i]]$value))}) - ns<-sapply(1:n, function(i){return(p$calendars[[i]]$key)}) - names(lcal)<-ns + if (n > 0) { + lcal <- lapply(1:n, function(i) { + return(.p2r_calendardef(p$calendars[[i]]$value)) + }) + ns <- sapply(1:n, function(i) { + return(p$calendars[[i]]$key) + }) + names(lcal) <- ns } return(lcal) } #' @export #' @rdname jd3_utilities -.r2p_calendars<-function(r){ - p<-jd3.Calendars$new() - ns<-names(r) - n<-length(ns) +.r2p_calendars <- function(r) { + p <- jd3.Calendars$new() + ns <- names(r) + n <- length(ns) # To take into account empty calendars - length_cal <- sapply(r, length) - - p$calendars<-lapply((1:n)[length_cal!=0], function(i){ - entry<-jd3.Calendars$CalendarsEntry$new() - entry$key<-ns[i] - entry$value<-.r2p_calendardef(r[[i]]) - return(entry) - }) + length_cal <- lengths(r) + + p$calendars <- lapply((1:n)[length_cal != 0], function(i) { + entry <- jd3.Calendars$CalendarsEntry$new() + entry$key <- ns[i] + entry$value <- .r2p_calendardef(r[[i]]) + return(entry) + }) return(p) } #' @export #' @rdname jd3_utilities -.p2jd_calendars<-function(p){ - bytes<-p$serialize(NULL) - jcal <- .jcall("jdplus/toolkit/base/r/util/Modelling", "Ljdplus/toolkit/base/api/timeseries/calendars/CalendarManager;", - "calendarsOf", - bytes) +.p2jd_calendars <- function(p) { + bytes <- p$serialize(NULL) + jcal <- .jcall( + "jdplus/toolkit/base/r/util/Modelling", "Ljdplus/toolkit/base/api/timeseries/calendars/CalendarManager;", + "calendarsOf", + bytes + ) return(jcal) } #' @export #' @rdname jd3_utilities -.jd2p_calendars<-function(jd){ - bytes<-.jcall("jdplus/toolkit/base/r/util/Modelling", "[B", "toBuffer", jd) - p<-RProtoBuf::read(jd3.Calendars, bytes) +.jd2p_calendars <- function(jd) { + bytes <- .jcall("jdplus/toolkit/base/r/util/Modelling", "[B", "toBuffer", jd) + p <- RProtoBuf::read(jd3.Calendars, bytes) return(p) } #' @export #' @rdname jd3_utilities -.jd2r_calendars<-function(jcals){ - p<-.jd2p_calendars(jcals) +.jd2r_calendars <- function(jcals) { + p <- .jd2p_calendars(jcals) return(.p2r_calendars(p)) } #' @export #' @rdname jd3_utilities -.r2jd_calendars<-function(r){ - p<-.r2p_calendars(r) +.r2jd_calendars <- function(r) { + p <- .r2p_calendars(r) return(.p2jd_calendars(p)) } diff --git a/R/procresults.R b/R/procresults.R index 93f5771f..3ed74cdf 100644 --- a/R/procresults.R +++ b/R/procresults.R @@ -1,17 +1,18 @@ #' @include jd3rslts.R NULL -OBJ<-'JD3_Object' -RSLT<-'JD3_ProcResults' +OBJ <- "JD3_Object" +RSLT <- "JD3_ProcResults" #' @export #' @rdname jd3_utilities -.jd3_object<-function(jobjRef, subclasses=NULL, result=FALSE){ - if (result) - classes<-c(OBJ, RSLT, subclasses) - else - classes<-c(OBJ, subclasses) - return(structure(list(internal=jobjRef), class=classes)) +.jd3_object <- function(jobjRef, subclasses = NULL, result = FALSE) { + if (result) { + classes <- c(OBJ, RSLT, subclasses) + } else { + classes <- c(OBJ, subclasses) + } + return(structure(list(internal = jobjRef), class = classes)) } @@ -24,43 +25,48 @@ RSLT<-'JD3_ProcResults' #' @param userdefined vector containing the names of the object to extract. #' #' @export -dictionary<-function(object){ - if (! is(object, RSLT)) - stop("No dictionary for this type of object") - if (is.jnull(object$internal)){ - stop("No java object") - } else { - if (.jinstanceof(object$internal, "jdplus/toolkit/base/api/information/Explorable")){ - .proc_dictionary2(object$internal) +dictionary <- function(object) { + if (!is(object, RSLT)) { + stop("No dictionary for this type of object") + } + if (is.jnull(object$internal)) { + stop("No java object") } else { - .proc_dictionary(.jclass(object$internal)) + if (.jinstanceof(object$internal, "jdplus/toolkit/base/api/information/Explorable")) { + .proc_dictionary2(object$internal) + } else { + .proc_dictionary(.jclass(object$internal)) + } } - } } #' @rdname dictionary #' @export -result<-function(object, id){ - if (! is(object, RSLT)) - stop("No result for this type of object") - if (is.jnull(object$internal)){ - stop("No java object") - } else { - .proc_data(object$internal, id) +result <- function(object, id) { + if (!is(object, RSLT)) { + stop("No result for this type of object") + } + if (is.jnull(object$internal)) { + stop("No java object") + } else { + .proc_data(object$internal, id) } } #' @rdname dictionary #' @export -user_defined <- function(object, userdefined = NULL){ - if (is.null(userdefined)){ - result <- list() - } else { - result <- lapply(userdefined, - function(var) result(object, var)) - if (is.null(names(userdefined))) - names(result) <- userdefined - } - class(result) <- c("user_defined") - result +user_defined <- function(object, userdefined = NULL) { + if (is.null(userdefined)) { + result <- list() + } else { + result <- lapply( + userdefined, + function(var) result(object, var) + ) + if (is.null(names(userdefined))) { + names(result) <- userdefined + } + } + class(result) <- c("user_defined") + result } diff --git a/R/protobuf.R b/R/protobuf.R index abd02d78..82c12fa7 100644 --- a/R/protobuf.R +++ b/R/protobuf.R @@ -7,66 +7,82 @@ NULL #' #' These functions are used in all JDemetra+ 3.0 packages to easily interact between R and Java objects. #' -#' @param p,r,spec,model,jucm,start,end,name,s,period,startYear,startPeriod,length,type,code,prefix,span,rspan,full,rslt,jobj,jrslt,jd,jcontext,jobjRef,subclasses,result,pcalendar parameters. -#' +#' @param p,r,spec,jucm,start,end,name,period,type,code,prefix,span,rspan,full,rslt,jd,jcontext,jobjRef,jcals,subclasses,result,pcalendar parameters. +#' @param s Time series +#' @param js Java time series +#' @param model Model +#' @param startPeriod Initial period in the time domain(1 for the first period) +#' @param startYear Initial year in the time domain +#' @param model Model +#' @param length Length +#' @param jobj Java object +#' @param jrslt Reference to a Java object +#' @param source Source of the time series information +#' @param id Identifier of the time series information (source-dependent) #' @name jd3_utilities NULL #> NULL #' @export #' @rdname jd3_utilities -.enum_sextract<-function(type, p){ - return(type$value(number=p)$name()) +.enum_sextract <- function(type, p) { + return(type$value(number = p)$name()) } #' @export #' @rdname jd3_utilities -.enum_sof<-function(type, code){ - return(type$value(name=code)$number()) +.enum_sof <- function(type, code) { + return(type$value(name = code)$number()) } #' @export #' @rdname jd3_utilities -.enum_extract<-function(type, p){ - name<-type$value(number=p)$name() - return(substring(name, regexpr("_", name)+1)) +.enum_extract <- function(type, p) { + name <- type$value(number = p)$name() + return(substring(name, regexpr("_", name) + 1)) } #' @export #' @rdname jd3_utilities -.enum_of<-function(type, code, prefix){ - i<-type$value(name=paste(prefix, code, sep='_'))$number() +.enum_of <- function(type, code, prefix) { + i <- type$value(name = paste(prefix, code, sep = "_"))$number() return(i) } #' @export #' @rdname jd3_utilities -.r2p_parameter<-function(r){ - p<-jd3.Parameter$new() - if (is.null(r)) { - p$value<-0 - p$type<-.enum_of(jd3.ParameterType, "UNUSED", "PARAMETER") - } else { - p$value<-r$value - p$type<-.enum_of(jd3.ParameterType, r$type, "PARAMETER") - } - return(p) +.r2p_parameter <- function(r) { + p <- jd3.Parameter$new() + if (is.null(r)) { + p$value <- 0 + p$type <- .enum_of(jd3.ParameterType, "UNUSED", "PARAMETER") + } else { + p$value <- r$value + p$type <- .enum_of(jd3.ParameterType, r$type, "PARAMETER") + } + return(p) } #' @export #' @rdname jd3_utilities -.p2r_parameter<-function(p){ - if (! p$has("type")) return(NULL) - return(list(value = p$value, type=.enum_extract(jd3.ParameterType, p$type))) +.p2r_parameter <- function(p) { + if (!p$has("type")) { + return(NULL) + } + return(list(value = p$value, type = .enum_extract(jd3.ParameterType, p$type))) } #' @export #' @rdname jd3_utilities -.r2p_parameters<-function(r){ - n<-length(r) - if (n == 0) return(NULL) - p<-apply(r, 2, function(z){.r2p_parameter(z)}) - return(p) +.r2p_parameters <- function(r) { + n <- length(r) + if (n == 0) { + return(NULL) + } + p <- apply(r, 2, function(z) { + .r2p_parameter(z) + }) + return(p) } # .r2p_parameters<-function(data, type){ @@ -81,173 +97,209 @@ NULL #' @export #' @rdname jd3_utilities -.r2p_lparameters<-function(r){ - # r is a list of lists with value/type entries - n<-length(r) - if (n == 0) return(NULL) - p<-lapply(r, function(z){.r2p_parameter(z)}) - return(p) +.r2p_lparameters <- function(r) { + # r is a list of lists with value/type entries + n <- length(r) + if (n == 0) { + return(NULL) + } + p <- lapply(r, function(z) { + .r2p_parameter(z) + }) + return(p) } #' @export #' @rdname jd3_utilities -.p2r_parameters<-function(p){ - n<-length(p) - if (n == 0) return(NULL) - r<-sapply(p, function(z){list(value=z$value, type=.enum_extract(jd3.ParameterType, z$type))}) - return(r) +.p2r_parameters <- function(p) { + n <- length(p) + if (n == 0) { + return(NULL) + } + r <- sapply(p, function(z) { + list(value = z$value, type = .enum_extract(jd3.ParameterType, z$type)) + }) + return(r) } #' @export #' @rdname jd3_utilities -.p2r_parameters_rslt<-function(p){ - if (is.null(p)) - return(NULL) - if (length(p) == 0) - return(NULL) - value<-sapply(p, function(z){z$value}) - type<-sapply(p, function(z){.enum_extract(jd3.ParameterType, z$type)}) - return(data.frame(value=value, type=type)) +.p2r_parameters_rslt <- function(p) { + if (is.null(p)) { + return(NULL) + } + if (length(p) == 0) { + return(NULL) + } + value <- sapply(p, function(z) { + z$value + }) + type <- sapply(p, function(z) { + .enum_extract(jd3.ParameterType, z$type) + }) + return(data.frame(value = value, type = type)) } #' @export #' @rdname jd3_utilities -.p2r_parameters_rsltx<-function(p){ - if (is.null(p)) - return(NULL) - if (length(p) == 0) - return(NULL) - value<-sapply(p, function(z){z$value}) - type<-sapply(p, function(z){.enum_extract(jd3.ParameterType, z$type)}) - description<-sapply(p, function(z){z$description}) +.p2r_parameters_rsltx <- function(p) { + if (is.null(p)) { + return(NULL) + } + if (length(p) == 0) { + return(NULL) + } + value <- sapply(p, function(z) { + z$value + }) + type <- sapply(p, function(z) { + .enum_extract(jd3.ParameterType, z$type) + }) + description <- sapply(p, function(z) { + z$description + }) - rslt<-data.frame(value=value, type=type) - row.names(rslt)<-description + rslt <- data.frame(value = value, type = type) + row.names(rslt) <- description - return(rslt) + return(rslt) } #' @export #' @rdname jd3_utilities -.p2r_test<-function(p){ - if (is.null(p)) - return(NULL) - p <- p$as.list() - return(statisticaltest(p$value, p$pvalue, p$description)) +.p2r_test <- function(p) { + if (is.null(p)) { + return(NULL) + } + p <- p$as.list() + return(statisticaltest(p$value, p$pvalue, p$description)) } #' @export #' @rdname jd3_utilities -.p2r_matrix<-function(p){ - m<-matrix(data=p$values, nrow = p$nrows, ncol = p$ncols) - `attr<-`(m, "name", p$name) - return(m) +.p2r_matrix <- function(p) { + m <- matrix(data = p$values, nrow = p$nrows, ncol = p$ncols) + `attr<-`(m, "name", p$name) + return(m) } -.r2p_matrix<-function(r){ - p<-jd3.Matrix$new() - p$name<-attr(r, "name") - p$nrows<-nrow(r) - p$ncols<-ncol(r) - p$values<-as.numeric(r) - return(p) +.r2p_matrix <- function(r) { + p <- jd3.Matrix$new() + p$name <- attr(r, "name") + p$nrows <- nrow(r) + p$ncols <- ncol(r) + p$values <- as.numeric(r) + return(p) } #' @export #' @rdname jd3_utilities -.p2r_tsdata<-function(p){ - if (length(p$values) == 0) - return(NULL) - s<-ts(data=p$values, frequency = p$annual_frequency, start = c(p$start_year, p$start_period)) - s<-`attr<-`(s, "name", p$name) - return(s) +.p2r_tsdata <- function(p) { + if (length(p$values) == 0) { + return(NULL) + } + s <- ts(data = p$values, frequency = p$annual_frequency, start = c(p$start_year, p$start_period)) + s <- `attr<-`(s, "name", p$name) + return(s) } #' @export #' @rdname jd3_utilities -.r2p_tsdata<-function(r){ - p<-jd3.TsData$new() - p$name<-attr(r, "name") - p$annual_frequency<-frequency(r) - s<-start(r) - p$start_year<-s[1] - p$start_period<-s[2] - p$values<-as.numeric(r) - return(p) +.r2p_tsdata <- function(r) { + p <- jd3.TsData$new() + p$name <- attr(r, "name") + p$annual_frequency <- frequency(r) + s <- start(r) + p$start_year <- s[1] + p$start_period <- s[2] + p$values <- as.numeric(r) + return(p) } #' @export #' @rdname jd3_utilities -.p2r_parameters_estimation<-function(p){ - if (is.null(p)) - return(NULL) - return(list(val=p$value, score=p$score, cov=.p2r_matrix(p$covariance), description=p$description)) +.p2r_parameters_estimation <- function(p) { + if (is.null(p)) { + return(NULL) + } + return(list(val = p$value, score = p$score, cov = .p2r_matrix(p$covariance), description = p$description)) } #' @export #' @rdname jd3_utilities -.p2r_likelihood<-function(p){ - return(likelihood(p$nobs, p$neffectiveobs, p$nparams, - p$log_likelihood, p$adjusted_log_likelihood, - p$aic, p$aicc, p$bic, p$bicc, p$ssq)) +.p2r_likelihood <- function(p) { + return(.likelihood( + p$nobs, p$neffectiveobs, p$nparams, + p$log_likelihood, p$adjusted_log_likelihood, + p$aic, p$aicc, p$bic, p$bicc, p$ssq + )) } #' @export #' @rdname jd3_utilities -.p2r_date<-function(p){ - if (p$has('year')){ - return(ymd(p$year, p$month, p$day)) - } else { - return(NULL) - } +.p2r_date <- function(p) { + if (p$has("year")) { + return(ymd(p$year, p$month, p$day)) + } else { + return(NULL) + } } #' @export #' @rdname jd3_utilities -.r2p_date<-function(s){ - if (is.null(s)) return(jd3.Date$new()) - else return(parseDate(s)) +.r2p_date <- function(s) { + if (is.null(s)) { + return(jd3.Date$new()) + } else { + return(parseDate(s)) + } } # Span #' @export #' @rdname jd3_utilities -.p2r_span<-function(span){ - type<-.enum_extract(jd3.SelectionType, span$type) - dt0<-.p2r_date(span$d0) - dt1<-.p2r_date(span$d1) +.p2r_span <- function(span) { + type <- .enum_extract(jd3.SelectionType, span$type) + dt0 <- .p2r_date(span$d0) + dt1 <- .p2r_date(span$d1) - return(structure(list(type=type, d0=dt0, d1=dt1, n0=span$n0, n1=span$n1), class= "JD3_SPAN")) + return(structure(list(type = type, d0 = dt0, d1 = dt1, n0 = span$n0, n1 = span$n1), class = "JD3_SPAN")) } #' @export #' @rdname jd3_utilities -.r2p_span<-function(rspan){ - pspan<-jd3.TimeSelector$new() - pspan$type<-.enum_of(jd3.SelectionType, rspan$type, "SPAN") - pspan$n0<-rspan$n0 - pspan$n1<-rspan$n1 - pspan$d0<-.r2p_date(rspan$d0) - pspan$d1<-.r2p_date(rspan$d1) - return(pspan) +.r2p_span <- function(rspan) { + pspan <- jd3.TimeSelector$new() + pspan$type <- .enum_of(jd3.SelectionType, rspan$type, "SPAN") + pspan$n0 <- rspan$n0 + pspan$n1 <- rspan$n1 + pspan$d0 <- .r2p_date(rspan$d0) + pspan$d1 <- .r2p_date(rspan$d1) + return(pspan) } -.p2r_sarima<-function(p){ - return(sarima_model(p$name, p$period, p$phi, p$d, p$theta, - p$bphi, p$bd, p$btheta)) +.p2r_sarima <- function(p) { + return(sarima_model( + p$name, p$period, p$phi, p$d, p$theta, + p$bphi, p$bd, p$btheta + )) } #' @export #' @rdname jd3_utilities -.p2r_arima<-function(p){ - return(arima_model(p$name, p$ar, p$delta, p$ma, p$innovation_variance)) +.p2r_arima <- function(p) { + return(arima_model(p$name, p$ar, p$delta, p$ma, p$innovation_variance)) } #' @export #' @rdname jd3_utilities -.p2r_ucarima<-function(p){ - model<-.p2r_arima(p$model) - return(ucarima_model(model,lapply(p$components, function(z){.p2r_arima(z)}), lapply(p$complements, function(z){.p2r_arima(z)}), FALSE)) +.p2r_ucarima <- function(p) { + model <- .p2r_arima(p$model) + return(ucarima_model(model, lapply(p$components, function(z) { + .p2r_arima(z) + }), lapply(p$complements, function(z) { + .p2r_arima(z) + }), FALSE)) } @@ -255,348 +307,409 @@ NULL # Sarima #' @export #' @rdname jd3_utilities -.p2r_spec_sarima<-function(spec){ - return(structure( - list( - period=spec$period, - d=spec$d, - bd=spec$bd, - phi=.p2r_parameters(spec$phi), - theta=.p2r_parameters(spec$theta), - bphi=.p2r_parameters(spec$bphi), - btheta=.p2r_parameters(spec$btheta) - ), - class="JD3_SARIMA_ESTIMATION")) +.p2r_spec_sarima <- function(spec) { + return(structure( + list( + period = spec$period, + d = spec$d, + bd = spec$bd, + phi = .p2r_parameters(spec$phi), + theta = .p2r_parameters(spec$theta), + bphi = .p2r_parameters(spec$bphi), + btheta = .p2r_parameters(spec$btheta) + ), + class = "JD3_SARIMA_ESTIMATION" + )) } #' @export #' @rdname jd3_utilities -.r2p_spec_sarima<-function(r){ - p<-regarima.SarimaSpec$new() - p$period<-r$period - p$d<-r$d - p$bd<-r$bd - p$phi<-.r2p_parameters(r$phi) - p$theta<-.r2p_parameters(r$theta) - p$bphi<-.r2p_parameters(r$bphi) - p$btheta<-.r2p_parameters(r$btheta) - return(p) +.r2p_spec_sarima <- function(r) { + p <- regarima.SarimaSpec$new() + p$period <- r$period + p$d <- r$d + p$bd <- r$bd + p$phi <- .r2p_parameters(r$phi) + p$theta <- .r2p_parameters(r$theta) + p$bphi <- .r2p_parameters(r$bphi) + p$btheta <- .r2p_parameters(r$btheta) + return(p) } -.p2r_outlier<-function(p){ - return(list( - name=p$name, - pos=.p2r_date(p$position), - code=p$code, - coef=.p2r_parameter(p$coefficient) - )) +.p2r_outlier <- function(p) { + return(list( + name = p$name, + pos = .p2r_date(p$position), + code = p$code, + coef = .p2r_parameter(p$coefficient) + )) } -.r2p_outlier<-function(r){ - p<-modelling.Outlier$new() - p$name<-r$name - p$code<-r$code - p$position<-.r2p_date(r$pos) - p$coefficient<-.r2p_parameter(r$coef) - return(p) +.r2p_outlier <- function(r) { + p <- modelling.Outlier$new() + p$name <- r$name + p$code <- r$code + p$position <- .r2p_date(r$pos) + p$coefficient <- .r2p_parameter(r$coef) + return(p) } #' @export #' @rdname jd3_utilities -.p2r_outliers<-function(p){ - if (length(p) == 0){return(NULL)} - return(lapply(p, function(z){.p2r_outlier(z)})) +.p2r_outliers <- function(p) { + if (length(p) == 0) { + return(NULL) + } + return(lapply(p, function(z) { + .p2r_outlier(z) + })) } #' @export #' @rdname jd3_utilities -.r2p_outliers<-function(r){ - if (length(r) == 0){return(list())} - return(lapply(r, function(z){.r2p_outlier(z)})) +.r2p_outliers <- function(r) { + if (length(r) == 0) { + return(list()) + } + return(lapply(r, function(z) { + .r2p_outlier(z) + })) } -.p2r_sequence<-function(p){ +.p2r_sequence <- function(p) { return(list( - start=.p2r_date(p$start), - end=.p2r_date(p$end) - )) + start = .p2r_date(p$start), + end = .p2r_date(p$end) + )) } -.r2p_sequence<-function(r){ - p<-modelling.InterventionVariable$Sequence$new() - p$start<-.r2p_date(r$start) - p$end<-.r2p_date(r$end) +.r2p_sequence <- function(r) { + p <- modelling.InterventionVariable$Sequence$new() + p$start <- .r2p_date(r$start) + p$end <- .r2p_date(r$end) return(p) } #' @export #' @rdname jd3_utilities -.p2r_sequences<-function(p){ - if (length(p) == 0){return(NULL)} - return(lapply(p, function(z){.p2r_sequence(z)})) +.p2r_sequences <- function(p) { + if (length(p) == 0) { + return(NULL) + } + return(lapply(p, function(z) { + .p2r_sequence(z) + })) } #' @export #' @rdname jd3_utilities -.r2p_sequences<-function(r){ - if (length(r) == 0){return(list())} - return(lapply(r, function(z){.r2p_sequence(z)})) +.r2p_sequences <- function(r) { + if (length(r) == 0) { + return(list()) + } + return(lapply(r, function(z) { + .r2p_sequence(z) + })) } #' @export #' @rdname jd3_utilities -.p2r_iv<-function(p){ +.p2r_iv <- function(p) { return(list( - name=p$name, - sequences=.p2r_sequences(p$sequences), - delta=p$delta, - seasonaldelta=p$seasonal_delta, - coef=.p2r_parameter(p$coefficient), - regeffect=.regeffect(p$metadata) + name = p$name, + sequences = .p2r_sequences(p$sequences), + delta = p$delta, + seasonaldelta = p$seasonal_delta, + coef = .p2r_parameter(p$coefficient), + regeffect = .regeffect(p$metadata) )) } #' @export #' @rdname jd3_utilities -.r2p_iv<-function(r){ - p<-modelling.InterventionVariable$new() - p$name<-r$name - p$sequences<-.r2p_sequences(r$sequences) - p$coefficient<-.r2p_parameter(r$coef) - p$metadata<-modelling.InterventionVariable.MetadataEntry$new(key = "regeffect", value=r$regeffect) +.r2p_iv <- function(r) { + p <- modelling.InterventionVariable$new() + p$name <- r$name + p$sequences <- .r2p_sequences(r$sequences) + p$coefficient <- .r2p_parameter(r$coef) + p$metadata <- modelling.InterventionVariable.MetadataEntry$new(key = "regeffect", value = r$regeffect) return(p) } #' @export #' @rdname jd3_utilities -.p2r_ivs<-function(p){ - if (length(p) == 0){return(NULL)} - return(lapply(p, function(z){.p2r_iv(z)})) +.p2r_ivs <- function(p) { + if (length(p) == 0) { + return(NULL) + } + return(lapply(p, function(z) { + .p2r_iv(z) + })) } #' @export #' @rdname jd3_utilities -.r2p_ivs<-function(r){ - if (length(r) == 0){return(list())} - return(lapply(r, function(z){.r2p_iv(z)})) +.r2p_ivs <- function(r) { + if (length(r) == 0) { + return(list()) + } + return(lapply(r, function(z) { + .r2p_iv(z) + })) } -.p2r_ramp<-function(p){ - return(list( - name=p$name, - start=.p2r_date(p$start), - end=.p2r_date(p$end), - coef=.p2r_parameter(p$coefficient) - )) +.p2r_ramp <- function(p) { + return(list( + name = p$name, + start = .p2r_date(p$start), + end = .p2r_date(p$end), + coef = .p2r_parameter(p$coefficient) + )) } -.r2p_ramp<-function(r){ - p<-modelling.Ramp$new() - p$name<-r$name - p$start<-.r2p_date(r$start) - p$end<-.r2p_date(r$end) - p$coefficient<-.r2p_parameter(r$coef) - return(p) +.r2p_ramp <- function(r) { + p <- modelling.Ramp$new() + p$name <- r$name + p$start <- .r2p_date(r$start) + p$end <- .r2p_date(r$end) + p$coefficient <- .r2p_parameter(r$coef) + return(p) } #' @export #' @rdname jd3_utilities -.p2r_ramps<-function(p){ - if (length(p) == 0){return(NULL)} - return(lapply(p, function(z){.p2r_ramp(z)})) +.p2r_ramps <- function(p) { + if (length(p) == 0) { + return(NULL) + } + return(lapply(p, function(z) { + .p2r_ramp(z) + })) } #' @export #' @rdname jd3_utilities -.r2p_ramps<-function(r){ - if (length(r) == 0){return(list())} - return(lapply(r, function(z){.r2p_ramp(z)})) +.r2p_ramps <- function(r) { + if (length(r) == 0) { + return(list()) + } + return(lapply(r, function(z) { + .r2p_ramp(z) + })) } -.regeffect<-function(map){ - if (length(map) == 0) - return("Undefined") - r<-which(sapply(map, function(z){z$key == "regeffect"})) - if (length(r) == 0) return("Undefined") - return(map[[min(r)]]$value) +.regeffect <- function(map) { + if (length(map) == 0) { + return("Undefined") + } + r <- which(sapply(map, function(z) { + z$key == "regeffect" + })) + if (length(r) == 0) { + return("Undefined") + } + return(map[[min(r)]]$value) } -.p2r_uservar<-function(p){ - l<-p$lag - return(list( - id=p$id, - name=p$name, - lag=l, - coef=.p2r_parameter(p$coefficient), - regeffect=.regeffect(p$metadata) - )) -} - -.r2p_uservar<-function(r){ - p<-modelling.TsVariable$new() - p$name<-r$name - p$id<-r$id - p$lag<-r$lag - p$coefficient<-.r2p_parameter(r$coef) - p$metadata<-modelling.TsVariable.MetadataEntry$new(key = "regeffect", value=r$regeffect) - return(p) -} -#' @export -#' @rdname jd3_utilities -.p2r_uservars<-function(p){ - if (length(p) == 0){return(NULL)} - return(lapply(p, function(z){.p2r_uservar(z)})) -} -#' @export -#' @rdname jd3_utilities -.r2p_uservars<-function(r){ - if (length(r) == 0){return(list())} - return(lapply(r, function(z){.r2p_uservar(z)})) -} -#' @export -#' @rdname jd3_utilities -.p2r_variables<-function(p){ - return(lapply(p, function(v){.p2r_variable(v)})) -} - -.p2r_variable<-function(p){ - name<-p$name - type<-.enum_extract(modelling.VariableType, p$var_type) - coef<-.p2r_parameters_rsltx(p$coefficients) - return(list(name=name, type=type, coef=coef)) -} - - -.p2r_component<-function(p){ - s<-p$data$values - n<-length(s) - if (n == 0) return(NULL) - freq<-p$data$annual_frequency - start<-c(p$data$start_year, p$data$start_period) - nb<-p$nbcasts - nf<-p$nfcasts - - val<-ts(s[(nb+1):(n-nf)], frequency = freq, start=.ts_move(start, freq, nb)) - rslt<-list(data=val) - if (nb > 0){ - bcasts<-ts(s[1:nb], frequency = freq, start=start) - rslt[['bcasts']]<-bcasts - } - if (nf > 0){ - fcasts<-ts(s[(n-nf+1):n], frequency = freq, start=.ts_move(start, freq, n-nf)) - rslt[['fcasts']]<-fcasts - } - return(rslt) -} - -.p2r_sa_component<-function(p){ - e<-p$stde - if (length(e) == 0) return(.p2r_component(p)) - - s<-p$data$values - n<-length(s) - if (n == 0) return(NULL) - freq<-p$data$annual_frequency - start<-c(p$data$start_year, p$data$start_period) - nb<-p$nbcasts - nf<-p$nfcasts - dstart<-.ts_move(start, freq, nb) - fstart<-.ts_move(start, freq, n-nf) - - idx<-(nb+1):(n-nf) - data<-ts(s[idx], frequency = freq, dstart) - edata<-ts(e[idx], frequency = freq, dstart) - - rslt<-list(data=data, data.stde=edata) - if (nb > 0){ - idx<-1:nb - bcasts<-ts(s[idx], frequency = freq, start=start) - ebcasts<-ts(e[idx], frequency = freq, start=start) - rslt[['bcasts']]<-bcasts - rslt[['bcasts.stde']]<-ebcasts - } - if (nf > 0){ - idx<-(n-nf+1):n - fcasts<-ts(s[idx], frequency = freq, start=fstart) - efcasts<-ts(e[idx], frequency = freq, start=fstart) - rslt[['fcasts']]<-fcasts - rslt[['fcasts.stde']]<-efcasts - } - - return(rslt) -} - -#' @export -#' @rdname jd3_utilities -.p2r_sa_decomposition<-function(p, full=FALSE){ - if (full){ - return(list(mode = .enum_extract(sa.DecompositionMode, p$mode), - series=.p2r_sa_component(p$series), - sa=.p2r_sa_component(p$seasonally_adjusted), - t=.p2r_sa_component(p$trend), - s=.p2r_sa_component(p$seasonal), - i=.p2r_sa_component(p$irregular) - )) - } else { - return(list(mode = .enum_extract(sa.DecompositionMode, p$mode), - series=.p2r_component(p$series), - sa=.p2r_component(p$seasonally_adjusted), - t=.p2r_component(p$trend), - s=.p2r_component(p$seasonal), - i=.p2r_component(p$irregular) +.p2r_uservar <- function(p) { + l <- p$lag + return(list( + id = p$id, + name = p$name, + lag = l, + coef = .p2r_parameter(p$coefficient), + regeffect = .regeffect(p$metadata) )) - } } +.r2p_uservar <- function(r) { + p <- modelling.TsVariable$new() + p$name <- r$name + p$id <- r$id + p$lag <- r$lag + p$coefficient <- .r2p_parameter(r$coef) + p$metadata <- modelling.TsVariable.MetadataEntry$new(key = "regeffect", value = r$regeffect) + return(p) +} #' @export #' @rdname jd3_utilities -.p2r_sa_diagnostics<-function(p){ - return(list(vardecomposition =p$variance_decomposition$as.list(), - seas.ftest.i=.p2r_test(p$seasonal_ftest_on_irregular), - seas.ftest.sa=.p2r_test(p$seasonal_ftest_on_sa), - seas.qstest.i=.p2r_test(p$seasonal_qtest_on_irregular), - seas.qstest.sa=.p2r_test(p$seasonal_qtest_on_sa), - td.ftest.i=.p2r_test(p$td_ftest_on_irregular), - td.ftest.sa=.p2r_test(p$td_ftest_on_sa) - )) - -} - - -.ts_move<-function(period, freq, delta){ - if (delta == 0)return(period) - if (freq == 1)return(c(period[1]+delta, 1)) - x<-period[1]*freq+(period[2]+delta-1) - return(c(x %/% freq, (x %% freq)+1)) +.p2r_uservars <- function(p) { + if (length(p) == 0) { + return(NULL) + } + return(lapply(p, function(z) { + .p2r_uservar(z) + })) +} +#' @export +#' @rdname jd3_utilities +.r2p_uservars <- function(r) { + if (length(r) == 0) { + return(list()) + } + return(lapply(r, function(z) { + .r2p_uservar(z) + })) +} +#' @export +#' @rdname jd3_utilities +.p2r_variables <- function(p) { + return(lapply(p, function(v) { + .p2r_variable(v) + })) +} + +.p2r_variable <- function(p) { + name <- p$name + type <- .enum_extract(modelling.VariableType, p$var_type) + coef <- .p2r_parameters_rsltx(p$coefficients) + return(list(name = name, type = type, coef = coef)) +} + + +.p2r_component <- function(p) { + s <- p$data$values + n <- length(s) + if (n == 0) { + return(NULL) + } + freq <- p$data$annual_frequency + start <- c(p$data$start_year, p$data$start_period) + nb <- p$nbcasts + nf <- p$nfcasts + + val <- ts(s[(nb + 1):(n - nf)], frequency = freq, start = .ts_move(start, freq, nb)) + rslt <- list(data = val) + if (nb > 0) { + bcasts <- ts(s[1:nb], frequency = freq, start = start) + rslt[["bcasts"]] <- bcasts + } + if (nf > 0) { + fcasts <- ts(s[(n - nf + 1):n], frequency = freq, start = .ts_move(start, freq, n - nf)) + rslt[["fcasts"]] <- fcasts + } + return(rslt) +} + +.p2r_sa_component <- function(p) { + e <- p$stde + if (length(e) == 0) { + return(.p2r_component(p)) + } + + s <- p$data$values + n <- length(s) + if (n == 0) { + return(NULL) + } + freq <- p$data$annual_frequency + start <- c(p$data$start_year, p$data$start_period) + nb <- p$nbcasts + nf <- p$nfcasts + dstart <- .ts_move(start, freq, nb) + fstart <- .ts_move(start, freq, n - nf) + + idx <- (nb + 1):(n - nf) + data <- ts(s[idx], frequency = freq, dstart) + edata <- ts(e[idx], frequency = freq, dstart) + + rslt <- list(data = data, data.stde = edata) + if (nb > 0) { + idx <- 1:nb + bcasts <- ts(s[idx], frequency = freq, start = start) + ebcasts <- ts(e[idx], frequency = freq, start = start) + rslt[["bcasts"]] <- bcasts + rslt[["bcasts.stde"]] <- ebcasts + } + if (nf > 0) { + idx <- (n - nf + 1):n + fcasts <- ts(s[idx], frequency = freq, start = fstart) + efcasts <- ts(e[idx], frequency = freq, start = fstart) + rslt[["fcasts"]] <- fcasts + rslt[["fcasts.stde"]] <- efcasts + } + + return(rslt) +} + +#' @export +#' @rdname jd3_utilities +.p2r_sa_decomposition <- function(p, full = FALSE) { + if (full) { + output <- list( + mode = .enum_extract(sa.DecompositionMode, p$mode), + series = .p2r_sa_component(p$series), + sa = .p2r_sa_component(p$seasonally_adjusted), + t = .p2r_sa_component(p$trend), + s = .p2r_sa_component(p$seasonal), + i = .p2r_sa_component(p$irregular) + ) + } else { + output <- list( + mode = .enum_extract(sa.DecompositionMode, p$mode), + series = .p2r_component(p$series), + sa = .p2r_component(p$seasonally_adjusted), + t = .p2r_component(p$trend), + s = .p2r_component(p$seasonal), + i = .p2r_component(p$irregular) + ) + } + return(output) +} + +#' @export +#' @rdname jd3_utilities +.p2r_sa_diagnostics <- function(p) { + output <- list( + vardecomposition = p$variance_decomposition$as.list(), + seas.ftest.i = .p2r_test(p$seasonal_ftest_on_irregular), + seas.ftest.sa = .p2r_test(p$seasonal_ftest_on_sa), + seas.qstest.i = .p2r_test(p$seasonal_qtest_on_irregular), + seas.qstest.sa = .p2r_test(p$seasonal_qtest_on_sa), + td.ftest.i = .p2r_test(p$td_ftest_on_irregular), + td.ftest.sa = .p2r_test(p$td_ftest_on_sa) + ) + return(output) +} + +.ts_move <- function(period, freq, delta) { + if (delta == 0) { + return(period) + } + if (freq == 1) { + return(c(period[1] + delta, 1)) + } + x <- period[1] * freq + (period[2] + delta - 1) + return(c(x %/% freq, (x %% freq) + 1)) } # Benchmarking #' @export #' @rdname jd3_utilities -.p2r_spec_benchmarking<-function(p){ - return(list( - enabled=p$enabled, - target=.enum_extract(sa.BenchmarkingTarget, p$target), - lambda=p$lambda, - rho=p$rho, - bias=.enum_extract(sa.BenchmarkingBias, p$bias), - forecast=p$forecast - )) +.p2r_spec_benchmarking <- function(p) { + return(list( + enabled = p$enabled, + target = .enum_extract(sa.BenchmarkingTarget, p$target), + lambda = p$lambda, + rho = p$rho, + bias = .enum_extract(sa.BenchmarkingBias, p$bias), + forecast = p$forecast + )) } #' @export #' @rdname jd3_utilities -.r2p_spec_benchmarking<-function(r){ - p<-sa.BenchmarkingSpec$new() - p$enabled<-r$enabled - p$target<-.enum_of(sa.BenchmarkingTarget, r$target, "BENCH") - p$lambda<-r$lambda - p$rho<-r$rho - p$bias<-.enum_of(sa.BenchmarkingBias, r$bias, "BENCH") - p$forecast<-r$forecast - return(p) +.r2p_spec_benchmarking <- function(r) { + p <- sa.BenchmarkingSpec$new() + p$enabled <- r$enabled + p$target <- .enum_of(sa.BenchmarkingTarget, r$target, "BENCH") + p$lambda <- r$lambda + p$rho <- r$rho + p$bias <- .enum_of(sa.BenchmarkingBias, r$bias, "BENCH") + p$forecast <- r$forecast + return(p) } diff --git a/R/regarima_generic.R b/R/regarima_generic.R index 9049ea8b..72bb70aa 100644 --- a/R/regarima_generic.R +++ b/R/regarima_generic.R @@ -1,77 +1,90 @@ # Method "JD3_REGARIMA_RSLTS" for the function coef #' @importFrom stats coef df.residual logLik residuals vcov nobs #' @export -coef.JD3_REGARIMA_RSLTS <- function(object, component = c("regression", "arima", "both"), ...){ - if (is.null(object)) - return(NULL) +coef.JD3_REGARIMA_RSLTS <- function(object, component = c("regression", "arima", "both"), ...) { + if (is.null(object)) { + return(NULL) + } - component <- match.arg(component) - if (component == "regression") { - coefs <- .regarima_coef_table(object) - } else if (component == "arima") { - coefs <- .sarima_coef_table(object)$coef_table - } else { - coefs <- rbind(.sarima_coef_table(object)$coef_table[,1:2], - .regarima_coef_table(object)[,1:2]) - } - res <- coefs[,1] - names(res) <- rownames(coefs) - res + component <- match.arg(component) + if (component == "regression") { + coefs <- .regarima_coef_table(object) + } else if (component == "arima") { + coefs <- .sarima_coef_table(object)$coef_table + } else { + coefs <- rbind( + .sarima_coef_table(object)$coef_table[, 1:2], + .regarima_coef_table(object)[, 1:2] + ) + } + res <- coefs[, 1] + names(res) <- rownames(coefs) + res } # Method "JD3_REGARIMA_RSLTS" for the function logLik #' @export logLik.JD3_REGARIMA_RSLTS <- function(object, ...) { - if (!is.null(object$estimation)) # for sarima_estimate outputs - object <- object$estimation - if (is.null(object) || - is.null(object$likelihood$ll)) { - res <- NA - } else { - res <- structure(object$likelihood$ll, - df = object$likelihood$nparams, - nall = object$likelihood$nobs, - nobs = object$likelihood$neffectiveobs) - } - class(res) <- "logLik" - res + if (!is.null(object$estimation)) { # for sarima_estimate outputs + object <- object$estimation + } + if (is.null(object) + || is.null(object$likelihood$ll)) { + res <- NA + } else { + res <- structure(object$likelihood$ll, + df = object$likelihood$nparams, + nall = object$likelihood$nobs, + nobs = object$likelihood$neffectiveobs + ) + } + class(res) <- "logLik" + res } #' @export -vcov.JD3_REGARIMA_RSLTS <- function(object, component = c("regression", "arima"), ...){ - if (!is.null(object$estimation)) # for sarima_estimate outputs - object <- object$estimation +vcov.JD3_REGARIMA_RSLTS <- function(object, component = c("regression", "arima"), ...) { + if (!is.null(object$estimation)) { # for sarima_estimate outputs + object <- object$estimation + } - if (is.null(object)) - return(NULL) - component <- match.arg(component) - if (component == "regression") { - object$bvar - } else { - object$parameters$cov - } + if (is.null(object)) { + return(NULL) + } + component <- match.arg(component) + if (component == "regression") { + object$bvar + } else { + object$parameters$cov + } } #' @export -df.residual.JD3_REGARIMA_RSLTS <- function(object, ...){ - if (is.null(object)) - return(NULL) - if (!is.null(object$estimation)) # for sarima_estimate outputs - object <- object$estimation - object$likelihood$neffectiveobs - object$likelihood$nparams +df.residual.JD3_REGARIMA_RSLTS <- function(object, ...) { + if (is.null(object)) { + return(NULL) + } + if (!is.null(object$estimation)) { # for sarima_estimate outputs + object <- object$estimation + } + object$likelihood$neffectiveobs - object$likelihood$nparams } #' @export -nobs.JD3_REGARIMA_RSLTS <- function(object, ...){ - if (is.null(object)) - return(NULL) - if (!is.null(object$estimation)) # for sarima_estimate outputs - object <- object$estimation - object$likelihood$neffectiveobs +nobs.JD3_REGARIMA_RSLTS <- function(object, ...) { + if (is.null(object)) { + return(NULL) + } + if (!is.null(object$estimation)) { # for sarima_estimate outputs + object <- object$estimation + } + object$likelihood$neffectiveobs } #' @export -residuals.JD3_REGARIMA_RSLTS <- function(object, ...){ - if (is.null(object)) - return(NULL) - if (!is.null(object$estimation)) # for sarima_estimate outputs - object <- object$estimation - object$res +residuals.JD3_REGARIMA_RSLTS <- function(object, ...) { + if (is.null(object)) { + return(NULL) + } + if (!is.null(object$estimation)) { # for sarima_estimate outputs + object <- object$estimation + } + object$res } diff --git a/R/regarima_rslts.R b/R/regarima_rslts.R index 2296a889..a4e96c11 100644 --- a/R/regarima_rslts.R +++ b/R/regarima_rslts.R @@ -3,40 +3,44 @@ NULL #' @export #' @rdname jd3_utilities -.p2r_regarima_rslts<-function(p){ - return(structure(list( - description=.p2r_regarima_description(p$description), - estimation=.p2r_regarima_estimation(p$estimation), - diagnostics=.p2r_regarima_diagnostics(p$diagnostics)), - class="JD3_REGARIMA_RSLTS") - ) +.p2r_regarima_rslts <- function(p) { + output <- list( + description = .p2r_regarima_description(p$description), + estimation = .p2r_regarima_estimation(p$estimation), + diagnostics = .p2r_regarima_diagnostics(p$diagnostics) + ) + class(output) <- "JD3_REGARIMA_RSLTS" + return(output) } -.p2r_regarima_description<-function(p){ - return(list( - log=p$log, - preadjustment = .enum_extract(modelling.LengthOfPeriod, p$preadjustment), - arima=.p2r_spec_sarima(p$arima), - variables=.p2r_variables(p$variables) - )) +.p2r_regarima_description <- function(p) { + return(list( + log = p$log, + preadjustment = .enum_extract(modelling.LengthOfPeriod, p$preadjustment), + arima = .p2r_spec_sarima(p$arima), + variables = .p2r_variables(p$variables) + )) } -.p2r_regarima_estimation<-function(p){ - return(list( - y=p$y, - X=.p2r_matrix(p$x), - parameters=.p2r_parameters_estimation(p$parameters), - b=p$b, - bvar=.p2r_matrix(p$bcovariance), - likelihood=.p2r_likelihood(p$likelihood), - res=p$residuals - )) +.p2r_regarima_estimation <- function(p) { + return(list( + y = p$y, + X = .p2r_matrix(p$x), + parameters = .p2r_parameters_estimation(p$parameters), + b = p$b, + bvar = .p2r_matrix(p$bcovariance), + likelihood = .p2r_likelihood(p$likelihood), + res = p$residuals + )) } - -.p2r_regarima_diagnostics<-function(p){ - tlist<-lapply(p$residuals_tests, function(z){.p2r_test(z$value)}) - tnames<-lapply(p$residuals_tests, function(z){z$key}) - testonresiduals<-`names<-`(tlist, tnames) - return(testonresiduals) +.p2r_regarima_diagnostics <- function(p) { + tlist <- lapply(p$residuals_tests, function(z) { + .p2r_test(z$value) + }) + tnames <- lapply(p$residuals_tests, function(z) { + z$key + }) + testonresiduals <- `names<-`(tlist, tnames) + return(testonresiduals) } diff --git a/R/spec_benchmarking.R b/R/spec_benchmarking.R index 86629ebf..bd4792a1 100644 --- a/R/spec_benchmarking.R +++ b/R/spec_benchmarking.R @@ -1,23 +1,34 @@ #' Set Benchmarking Specification #' #' @description -#' Function allowing to perform a benchmarking procedure after the decomposition step in a seasonal -#' adjustment (disabled by default). Here benchmarking refers to a procedure ensuring consistency over the year between -#' seasonally adjusted and raw (or calendar adjusted) data, as seasonal adjustment can cause discrepancies between the annual totals of seasonally adjusted series +#' Function allowing to perform a benchmarking procedure after the decomposition +#' step in a seasonal adjustment (disabled by default). Here benchmarking refers +#' to a procedure ensuring consistency over the year between seasonally +#' adjusted and raw (or calendar adjusted) data, as seasonal adjustment can +#' cause discrepancies between the annual totals of seasonally adjusted series #' and the corresponding annual totals of raw (or calendar adjusted) series. #' -#' @param x the specification to customize, must be a "SPEC" class object (see details). +#' @param x the specification to customize, must be a "SPEC" class object (see +#' details). #' @param enabled Boolean to enable the user to perform benchmarking. #' @param target specifies the target series for the benchmarking procedure, -#' which can be the raw series (\code{"Normal"}); or the series adjusted for calendar effects (\code{"CalendarAdjusted"}). -#' @param rho the value of the AR(1) parameter (set between 0 and 1) in the function used for benchmarking. Default =1. -#' @param lambda a parameter in the function used for benchmarking that relates to the weights in the regression equation; it is typically equal to 0, 1/2 or 1. -#' @param forecast Boolean indicating if the forecasts of the seasonally adjusted series and of the target variable (\code{target}) are used in the benchmarking computation so that the benchmarking constrain is also applied to the forecasting period. +#' which can be the raw series (\code{"Normal"}); or the series adjusted for +#' calendar effects (\code{"CalendarAdjusted"}). +#' @param rho the value of the AR(1) parameter (set between 0 and 1) in the +#' function used for benchmarking. Default =1. +#' @param lambda a parameter in the function used for benchmarking that relates +#' to the weights in the regression equation; it is typically equal to 0, 1/2 +#' or 1. +#' @param forecast Boolean indicating if the forecasts of the seasonally +#' adjusted series and of the target variable (\code{target}) are used in the +#' benchmarking computation so that the benchmarking constrain is also applied +#' to the forecasting period. #' @param bias TODO #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} -#' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" -#' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object +#' generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated +#' with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with +#' \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with #' \code{rjd3tramoseats::spec_tramo()}). #' @examples #' # init_spec <- rjd3x13::x13_spec("RSA5c") @@ -38,7 +49,7 @@ set_benchmarking <- function(x, enabled = NA, lambda = NA, forecast = NA, bias = c(NA, "None")) { - UseMethod("set_benchmarking", x) + UseMethod("set_benchmarking", x) } #' @export set_benchmarking.default <- function(x, enabled = NA, @@ -47,28 +58,32 @@ set_benchmarking.default <- function(x, enabled = NA, lambda = NA, forecast = NA, bias = c(NA, "None")) { - target <- match.arg(toupper(target[1]), - c(NA, "CALENDARADJUSTED", "ORIGINAL")) - bias <- match.arg(toupper(bias)[1], - c(NA, "NONE")) - if (!is.na(enabled) && is.logical(enabled)) { - x$enabled <- enabled - } - if (!is.na(target)) { - x$target <- sprintf("TARGET_%s", target) - } - if (!is.na(lambda)) { - x$lambda <- lambda - } - if (!is.na(rho)) { - x$rho <- rho - } - if (!is.na(bias)) { - x$bias <- sprintf("BIAS_%s", bias) - } - if (!is.na(forecast) && is.logical(forecast)) { - x$forecast <- forecast - } + target <- match.arg( + toupper(target[1]), + c(NA, "CALENDARADJUSTED", "ORIGINAL") + ) + bias <- match.arg( + toupper(bias)[1], + c(NA, "NONE") + ) + if (!is.na(enabled) && is.logical(enabled)) { + x$enabled <- enabled + } + if (!is.na(target)) { + x$target <- sprintf("TARGET_%s", target) + } + if (!is.na(lambda)) { + x$lambda <- lambda + } + if (!is.na(rho)) { + x$rho <- rho + } + if (!is.na(bias)) { + x$bias <- sprintf("BIAS_%s", bias) + } + if (!is.na(forecast) && is.logical(forecast)) { + x$forecast <- forecast + } - x + x } diff --git a/R/spec_regarima.R b/R/spec_regarima.R index 42d80863..875e1700 100644 --- a/R/spec_regarima.R +++ b/R/spec_regarima.R @@ -1,23 +1,27 @@ #' Manage Outliers/Ramps in Specification #' -#' Generic function to add outliers or Ramp regressors (\code{add_outlier()} and \code{add_ramp()}) -#' to a specification or to remove them (\code{remove_outlier()} and \code{remove_ramp()}). +#' Generic function to add outliers or Ramp regressors (\code{add_outlier()} and +#' \code{add_ramp()}) to a specification or to remove them +#' (\code{remove_outlier()} and \code{remove_ramp()}). #' -#' @param x the specification to customize, must be a "SPEC" class object (see details). +#' @param x the specification to customize, must be a "SPEC" class object (see +#' details). #' @param type,date type and date of the outliers. Possible \code{type} are: -#' \code{"AO"} = additive, \code{"LS"} = level shift, \code{"TC"} = transitory change and -#' \code{"SO"} = seasonal outlier. +#' \code{"AO"} = additive, \code{"LS"} = level shift, \code{"TC"} = transitory +#' change and \code{"SO"} = seasonal outlier. #' @param start,end dates of the ramp regressor. #' @param name the name of the variable (to format print). -#' @param coef the coefficient if needs to be fixed. If equal to 0 the outliers/ramps coefficients -#' are estimated. +#' @param coef the coefficient if needs to be fixed. If equal to 0 the +#' outliers/ramps coefficients are estimated. #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} -#' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" -#' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with -#' \code{rjd3tramoseats::spec_tramo()}). -#' If a Seasonal adjustment process is performed, each type of Outlier will be allocated to a pre-defined -#' component after the decomposition: "AO" and "TC" to the irregular, "LS" and Ramps to the trend. +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object +#' generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated +#' with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with +#' \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with +#' \code{rjd3tramoseats::spec_tramo()}). If a Seasonal adjustment process is +#' performed, each type of Outlier will be allocated to a pre-defined component +#' after the decomposition: "AO" and "TC" to the irregular, "LS" and Ramps to +#' the trend. #' @examples #' # init_spec <- rjd3x13::x13_spec("RSA5c") #' # new_spec<-rjd3toolkit::add_outlier(init_spec, type="AO", date="2012-01-01") @@ -32,53 +36,65 @@ add_outlier <- function(x, type, date, name = sprintf("%s (%s)", type, date), - coef = 0){ - UseMethod("add_outlier", x) + coef = 0) { + UseMethod("add_outlier", x) } #' @export add_outlier.default <- function(x, type, date, name = sprintf("%s (%s)", type, date), - coef = 0){ - type <- match.arg(toupper(type), - choices = c("AO", "TC", "LS", "SO"), - several.ok = TRUE) - # data.frame to recycle arguments - new_out <- data.frame(type, date, name, coef) - new_out <- as.list(new_out) - new_out <- mapply(.create_outlier, - as.list(new_out)[[1]], - as.list(new_out)[[2]], - as.list(new_out)[[3]], - as.list(new_out)[[4]], - SIMPLIFY = FALSE) - names(new_out) <- NULL - x$regression$outliers <- c(x$regression$outliers, - new_out) - all_out <- t(simplify2array(x$regression$outliers)[c("pos","code"),]) - dupl_out <- duplicated(all_out,fromLast = TRUE) - if (any(dupl_out)){ - warning("Duplicated outliers removed: last outliers kept") - x$regression$outliers <- x$regression$outliers[!dupl_out] - } - x + coef = 0) { + type <- match.arg(toupper(type), + choices = c("AO", "TC", "LS", "SO"), + several.ok = TRUE + ) + # data.frame to recycle arguments + new_out <- data.frame(type, date, name, coef) + new_out <- as.list(new_out) + new_out <- mapply(.create_outlier, + as.list(new_out)[[1]], + as.list(new_out)[[2]], + as.list(new_out)[[3]], + as.list(new_out)[[4]], + SIMPLIFY = FALSE + ) + names(new_out) <- NULL + x$regression$outliers <- c( + x$regression$outliers, + new_out + ) + all_out <- t(simplify2array(x$regression$outliers)[c("pos", "code"), ]) + dupl_out <- duplicated(all_out, fromLast = TRUE) + if (any(dupl_out)) { + warning("Duplicated outliers removed: last outliers kept") + x$regression$outliers <- x$regression$outliers[!dupl_out] + } + x } -.create_outlier<-function(code, pos, name = NULL, coef=NULL){ - res <- list(name=name, pos=pos, code=code, coef = .fixed_parameter(coef)) - return (res) +.create_outlier <- function(code, pos, name = NULL, coef = NULL) { + res <- list(name = name, pos = pos, code = code, coef = .fixed_parameter(coef)) + return(res) } -.fixed_parameters<-function(coef){ - ncoef<-length(coef) - if (ncoef == 0)return (NULL) - l<-lapply(coef, function(v){list(value=v, type='FIXED')}) - return (l) +.fixed_parameters <- function(coef) { + ncoef <- length(coef) + if (ncoef == 0) { + return(NULL) + } + l <- lapply(coef, function(v) { + list(value = v, type = "FIXED") + }) + return(l) } -.fixed_parameter<-function(coef){ - if (is.null(coef)) return (NULL) - if (coef == 0) return (NULL) - return (list(value=coef, type='FIXED')) +.fixed_parameter <- function(coef) { + if (is.null(coef)) { + return(NULL) + } + if (coef == 0) { + return(NULL) + } + return(list(value = coef, type = "FIXED")) } @@ -88,42 +104,45 @@ add_outlier.default <- function(x, remove_outlier <- function(x, type = NULL, date = NULL, - name = NULL){ - UseMethod("remove_outlier", x) + name = NULL) { + UseMethod("remove_outlier", x) } #' @export remove_outlier.default <- function(x, type = NULL, date = NULL, - name = NULL){ - if (is.null(x$regression$outliers)) - return (x) - out_mat <- simplify2array(x$regression$outliers)[c("code", "pos", "name"),, drop = FALSE] - if (is.null(type)) { - out_mat["code",] <- "" - } else { - type <- match.arg(toupper(type), - choices = c("AO", "TC", "LS", "SO"), - several.ok = TRUE) - } - if (is.null(date)) { - out_mat["pos",] <- "" - } - if (is.null(name)) { - out_mat["name",] <- "" - } - out_id <- apply(out_mat,2, paste0, collapse = "") - rm_out_id <- rbind(type = type, date = date, name = name) - if (is.null(rm_out_id)) - return (x) - rm_out_id <- apply(rm_out_id,2, paste0, collapse = "") + name = NULL) { + if (is.null(x$regression$outliers)) { + return(x) + } + out_mat <- simplify2array(x$regression$outliers)[c("code", "pos", "name"), , drop = FALSE] + if (is.null(type)) { + out_mat["code", ] <- "" + } else { + type <- match.arg(toupper(type), + choices = c("AO", "TC", "LS", "SO"), + several.ok = TRUE + ) + } + if (is.null(date)) { + out_mat["pos", ] <- "" + } + if (is.null(name)) { + out_mat["name", ] <- "" + } + out_id <- apply(out_mat, 2, paste0, collapse = "") + rm_out_id <- rbind(type = type, date = date, name = name) + if (is.null(rm_out_id)) { + return(x) + } + rm_out_id <- apply(rm_out_id, 2, paste0, collapse = "") - remove_out <- out_id %in% rm_out_id - x$regression$outliers <- x$regression$outliers[!remove_out] - if (length(x$regression$outliers) == 0) { - x$regression["outliers"] <- list(NULL) - } - x + remove_out <- out_id %in% rm_out_id + x$regression$outliers <- x$regression$outliers[!remove_out] + if (length(x$regression$outliers) == 0) { + x$regression["outliers"] <- list(NULL) + } + x } #' @rdname add_outlier #' @export @@ -131,109 +150,120 @@ add_ramp <- function(x, start, end, name = sprintf("rp.%s - %s", start, end), - coef = 0){ - UseMethod("add_ramp", x) + coef = 0) { + UseMethod("add_ramp", x) } #' @export add_ramp.default <- function(x, start, end, name = sprintf("rp.%s - %s", start, end), - coef = 0){ - # data.frame to recycle arguments - new_ramp <- data.frame(start, end, name, coef) - new_ramp <- as.list(new_ramp) - new_ramp <- mapply(.create_ramp, - as.list(new_ramp)[[1]], - as.list(new_ramp)[[2]], - as.list(new_ramp)[[3]], - as.list(new_ramp)[[4]], - SIMPLIFY = FALSE) - names(new_ramp) <- NULL - x$regression$ramps <- c(x$regression$ramps, - new_ramp) - all_out <- t(simplify2array(x$regression$ramps)[c("start", "end"),]) - dupl_out <- duplicated(all_out,fromLast = TRUE) - if (any(dupl_out)){ - warning("Duplicated ramps removed") - x$regression$ramps <- x$regression$ramps[!dupl_out] - } - x + coef = 0) { + # data.frame to recycle arguments + new_ramp <- data.frame(start, end, name, coef) + new_ramp <- as.list(new_ramp) + new_ramp <- mapply(.create_ramp, + as.list(new_ramp)[[1]], + as.list(new_ramp)[[2]], + as.list(new_ramp)[[3]], + as.list(new_ramp)[[4]], + SIMPLIFY = FALSE + ) + names(new_ramp) <- NULL + x$regression$ramps <- c( + x$regression$ramps, + new_ramp + ) + all_out <- t(simplify2array(x$regression$ramps)[c("start", "end"), ]) + dupl_out <- duplicated(all_out, fromLast = TRUE) + if (any(dupl_out)) { + warning("Duplicated ramps removed") + x$regression$ramps <- x$regression$ramps[!dupl_out] + } + x } -.create_ramp<-function(start, end, name = NULL, coef=NULL){ - res <- list(name=name, start=start, end=end, coef = .fixed_parameter(coef)) - return (res) +.create_ramp <- function(start, end, name = NULL, coef = NULL) { + res <- list(name = name, start = start, end = end, coef = .fixed_parameter(coef)) + return(res) } #' @rdname add_outlier #' @export remove_ramp <- function(x, start = NULL, end = NULL, - name = NULL){ - UseMethod("remove_ramp", x) + name = NULL) { + UseMethod("remove_ramp", x) } #' @export remove_ramp.default <- function(x, start = NULL, end = NULL, - name = NULL){ - if (is.null(x$regression$ramps)) - return (x) - rp_mat <- simplify2array(x$regression$ramps)[c("start", "end", "name"),, drop = FALSE] - if (is.null(start)) { - rp_mat["start",] <- "" - } - if (is.null(end)) { - rp_mat["end",] <- "" - } - if (is.null(name)) { - rp_mat["name",] <- "" - } - rp_id <- apply(rp_mat,2, paste0, collapse = "") - rm_rp_id <- rbind(start = start, end = end, name = name) - if (is.null(rm_rp_id)) - return (x) - rm_rp_id <- apply(rm_rp_id,2, paste0, collapse = "") + name = NULL) { + if (is.null(x$regression$ramps)) { + return(x) + } + rp_mat <- simplify2array(x$regression$ramps)[c("start", "end", "name"), , drop = FALSE] + if (is.null(start)) { + rp_mat["start", ] <- "" + } + if (is.null(end)) { + rp_mat["end", ] <- "" + } + if (is.null(name)) { + rp_mat["name", ] <- "" + } + rp_id <- apply(rp_mat, 2, paste0, collapse = "") + rm_rp_id <- rbind(start = start, end = end, name = name) + if (is.null(rm_rp_id)) { + return(x) + } + rm_rp_id <- apply(rm_rp_id, 2, paste0, collapse = "") - remove_rp <- rp_id %in% rm_rp_id - x$regression$ramps <- x$regression$ramps[!remove_rp] - if (length(x$regression$ramps) == 0) { - x$regression["ramps"] <- list(NULL) - } - x + remove_rp <- rp_id %in% rm_rp_id + x$regression$ramps <- x$regression$ramps[!remove_rp] + if (length(x$regression$ramps) == 0) { + x$regression["ramps"] <- list(NULL) + } + x } #' Set estimation sub-span and quality check specification #' #' @description -#' Function allowing to check if the series can be processed and to define a sub-span on which -#' estimation will be performed -#' +#' Function allowing to check if the series can be processed and to define a +#' sub-span on which estimation will be performed #' #' @inheritParams add_outlier #' #' @param type,d0,d1,n0,n1 parameters to specify the sub-span . #' -#' \code{d0} and \code{d1} characters in the format "YYYY-MM-DD" to specify first/last date -#' of the span when \code{type} equals to \code{"From"}, \code{"To"} or \code{"Between"}. +#' \code{d0} and \code{d1} characters in the format "YYYY-MM-DD" to specify +#' first/last date of the span when \code{type} equals to \code{"From"}, +#' \code{"To"} or \code{"Between"}. #' Date corresponding to \code{d0} will be included in the sub-span #' Date corresponding to \code{d1} will be excluded from the sub span #' -#' \code{n0} and \code{n1} numeric to specify the number of periods at the beginning/end of the series -#' to be used for defining the sub-span -#' (\code{type} equals to \code{"First"}, \code{"Last"}) or to exclude (\code{type} equals to \code{"Excluding"}). +#' \code{n0} and \code{n1} numeric to specify the number of periods at the +#' beginning/end of the series to be used for defining the sub-span +#' (\code{type} equals to \code{"First"}, \code{"Last"}) or to exclude +#' (\code{type} equals to \code{"Excluding"}). #' -#' @param preliminary.check a Boolean to check the quality of the input series and exclude highly problematic ones -#' (e.g. the series with a number of identical observations and/or missing values above pre-specified threshold values). +#' @param preliminary.check a Boolean to check the quality of the input series +#' and exclude highly problematic ones (e.g. the series with a number of +#' identical observations and/or missing values above pre-specified threshold +#' values). #' #' @param preprocessing (REGARIMA/X13 Specific) a Boolean to enable/disable the pre-processing. #' Option disabled for the moment. +#' #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} -#' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" -#' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object +#' generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated +#' with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with +#' \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with #' \code{rjd3tramoseats::spec_tramo()}). +#' #' @examples #' # init_spec <- rjd3x13::x13_spec("RSA5c") #' # estimation on sub-span between two dates (date d1 is excluded) @@ -263,8 +293,8 @@ set_basic <- function(x, n0 = 0, n1 = 0, preliminary.check = NA, - preprocessing = NA){ - UseMethod("set_basic", x) + preprocessing = NA) { + UseMethod("set_basic", x) } #' @export set_basic.default <- function(x, @@ -274,47 +304,54 @@ set_basic.default <- function(x, n0 = 0, n1 = 0, preliminary.check = NA, - preprocessing = NA){ - basic <- x$basic - is_tramo <- inherits(x, "JD3_TRAMO_SPEC") + preprocessing = NA) { + basic <- x$basic + is_tramo <- inherits(x, "JD3_TRAMO_SPEC") - basic$span <- set_span(basic$span, - type = type, - d0 = d0, d1 = d1, - n0 = n0, n1 = n1) - if (!missing(preprocessing) && !is.na(preprocessing) && !is_tramo){ - basic$preprocessing <- preprocessing - } - if (!missing(preliminary.check) && !is.na(preliminary.check)){ - # basic$preliminaryCheck <- preliminary.check - } - x$basic <- basic - x + basic$span <- set_span(basic$span, + type = type, + d0 = d0, d1 = d1, + n0 = n0, n1 = n1 + ) + if (!missing(preprocessing) && !is.na(preprocessing) && !is_tramo) { + basic$preprocessing <- preprocessing + } + if (!missing(preliminary.check) && !is.na(preliminary.check)) { + # basic$preliminaryCheck <- preliminary.check + } + x$basic <- basic + x } #' Set Numeric Estimation Parameters and Modelling Span #' #' @description -#' Function allowing to define numeric boundaries for estimation and to define a sub-span on which -#' reg-arima (tramo) modelling will be performed (pre-processing step) +#' Function allowing to define numeric boundaries for estimation and to define +#' a sub-span on which reg-arima (tramo) modelling will be performed +#' (pre-processing step) #' #' @inheritParams set_basic #' -#' @param tol a numeric, convergence tolerance. The absolute changes in the log-likelihood function -#' are compared to this value to check for the convergence of the estimation iterations. -#' (The default setting is 0.0000001) +#' @param tol a numeric, convergence tolerance. The absolute changes in the +#' log-likelihood function are compared to this value to check for the +#' convergence of the estimation iterations. (The default setting is 0.0000001) #' -#' @param exact.ml (TRAMO specific) \code{logical}, the exact maximum likelihood estimation. If \code{TRUE}, the program performs an exact -#' maximum likelihood estimation. If \code{FASLE}, the Unconditional Least Squares method is used.(Default=TRUE) +#' @param exact.ml (TRAMO specific) \code{logical}, the exact maximum likelihood +#' estimation. If \code{TRUE}, the program performs an exact maximum likelihood +#' estimation. If \code{FASLE}, the Unconditional Least Squares method is used. +#' (Default=TRUE) #' -#' @param unit.root.limit (TRAMO specific) \code{numeric}, the final unit root limit. The threshold value for the final unit root test -#' for identification of differencing orders. If the magnitude of an AR root for the final model is smaller than this number, -#' then a unit root is assumed, the order of the AR polynomial is reduced by one and the appropriate order of the differencing -#' (non-seasonal, seasonal) is increased.(Default value: 0.96) +#' @param unit.root.limit (TRAMO specific) \code{numeric}, the final unit root +#' limit. The threshold value for the final unit root test for identification of +#' differencing orders. If the magnitude of an AR root for the final model is +#' smaller than this number, then a unit root is assumed, the order of the AR +#' polynomial is reduced by one and the appropriate order of the differencing +#' (non-seasonal, seasonal) is increased.(Default value: 0.96) #' #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} -#' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" -#' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object +#' generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated +#' with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with +#' \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with #' \code{rjd3tramoseats::spec_tramo()}). #' #' @examples @@ -336,8 +373,8 @@ set_estimate <- function(x, tol = NA, # TRAMO SPECIFIC exact.ml = NA, - unit.root.limit = NA){ - UseMethod("set_estimate", x) + unit.root.limit = NA) { + UseMethod("set_estimate", x) } #' @export set_estimate.default <- function(x, @@ -349,26 +386,27 @@ set_estimate.default <- function(x, tol = NA, # TRAMO SPECIFIC exact.ml = NA, - unit.root.limit = NA){ - estimate <- x$estimate - is_tramo <- inherits(x, "JD3_TRAMO_SPEC") - estimate$span <- set_span(estimate$span, - type = type, - d0 = d0, d1 = d1, - n0 = n0, n1 = n1) - if (!missing(tol) && !is.na(tol)) { - estimate$tol <- tol - } - # TRAMO-SEATS SPECIFIC - if (!missing(exact.ml) && !is.na(exact.ml) && is_tramo) { - estimate$ml <- exact.ml - } - if (!missing(unit.root.limit) && !is.na(unit.root.limit) && is_tramo) { - estimate$ubp <- unit.root.limit - } - # END TRAMO-SEATS SPECIFIC - x$estimate <- estimate - x + unit.root.limit = NA) { + estimate <- x$estimate + is_tramo <- inherits(x, "JD3_TRAMO_SPEC") + estimate$span <- set_span(estimate$span, + type = type, + d0 = d0, d1 = d1, + n0 = n0, n1 = n1 + ) + if (!missing(tol) && !is.na(tol)) { + estimate$tol <- tol + } + # TRAMO-SEATS SPECIFIC + if (!missing(exact.ml) && !is.na(exact.ml) && is_tramo) { + estimate$ml <- exact.ml + } + if (!missing(unit.root.limit) && !is.na(unit.root.limit) && is_tramo) { + estimate$ubp <- unit.root.limit + } + # END TRAMO-SEATS SPECIFIC + x$estimate <- estimate + x } #' Set Outlier Detection Parameters #' @@ -402,7 +440,7 @@ set_estimate.default <- function(x, #' for parameter estimation in the intermediate steps. If \code{TRUE}, an exact likelihood estimation method is used. #' When \code{FALSE}, the fast Hannan-Rissanen method is used. #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} #' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" #' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with #' \code{rjd3tramoseats::spec_tramo()}). @@ -434,8 +472,8 @@ set_outlier <- function(x, maxiter = NA, lsrun = NA, # TRAMO SPECIFIC - eml.est = NA){ - UseMethod("set_outlier", x) + eml.est = NA) { + UseMethod("set_outlier", x) } #' @export set_outlier.default <- function(x, @@ -452,71 +490,74 @@ set_outlier.default <- function(x, maxiter = NA, lsrun = NA, # TRAMO SPECIFIC - eml.est = NA){ - outlier <- x$outlier - outlier$span <- set_span(outlier$span, - type = span.type, - d0 = d0, d1 = d1, - n0 = n0, n1 = n1) - # to set specific TRAMO/REGARIMA values - is_tramo <- inherits(x, "JD3_TRAMO_SPEC") + eml.est = NA) { + outlier <- x$outlier + outlier$span <- set_span(outlier$span, + type = span.type, + d0 = d0, d1 = d1, + n0 = n0, n1 = n1 + ) + # to set specific TRAMO/REGARIMA values + is_tramo <- inherits(x, "JD3_TRAMO_SPEC") - va_name <- ifelse(is_tramo, "va", "defva") - tcr_name <- ifelse(is_tramo, "tcrate", "monthlytcrate") + va_name <- ifelse(is_tramo, "va", "defva") + tcr_name <- ifelse(is_tramo, "tcrate", "monthlytcrate") - if (missing(critical.value) || any(is.na(critical.value))){ - critical.value <- outlier[[va_name]] - } else { - outlier[[va_name]] <- critical.value[1] - } - if (is.null(outliers.type) || length(outliers.type) == 0){ - if (is_tramo) { - outlier$enabled <- FALSE + if (missing(critical.value) || anyNA(critical.value)) { + critical.value <- outlier[[va_name]] } else { - outlier$outliers <- list() + outlier[[va_name]] <- critical.value[1] + } + if (is.null(outliers.type) || length(outliers.type) == 0) { + if (is_tramo) { + outlier$enabled <- FALSE + } else { + outlier$outliers <- list() + } + } else if (!missing(outliers.type) && !all(is.na(outliers.type))) { + outliers.type <- match.arg(toupper(outliers.type), + choices = c("AO", "LS", "TC", "SO"), + several.ok = TRUE + ) + outliers.type <- unique(outliers.type) + if (is_tramo) { + outlier$enabled <- TRUE + for (out.name in c("ao", "ls", "ts", "so")) { + outlier[[out.name]] <- out.name %in% tolower(outliers.type) + } + } else { + critical.value <- rep(critical.value, length(outliers.type)) + outlier$outliers <- lapply(seq_along(outliers.type), function(i) { + list(type = outliers.type[i], va = critical.value[i]) + }) + } + } + + if (!is.na(tc.rate)) { + outlier[[tcr_name]] <- tc.rate } - } else if (!missing(outliers.type) && !all(is.na(outliers.type))){ - outliers.type <- match.arg(toupper(outliers.type), - choices = c("AO", "LS", "TC", "SO"), - several.ok = TRUE) - outliers.type <- unique(outliers.type) if (is_tramo) { - outlier$enabled <- TRUE - for (out.name in c("ao", "ls", "ts", "so")) { - outlier[[out.name]] <- out.name %in% tolower(outliers.type) - } + # TRAMO SPECIFIC PARAMETERS + if (!is.na(eml.est) && is_tramo) { + outlier$ml <- eml.est + } } else { - critical.value <- rep(critical.value, length(outliers.type)) - outlier$outliers <- lapply(seq_along(outliers.type), function(i){ - list(type = outliers.type[i], va = critical.value[i]) - }) + # REGARIMA SPECIFIC PARAMETERS + if (!missing(method) && !is.null(method) && !all(is.na(method))) { + method <- match.arg(toupper(method)[1], + choices = c("ADDONE", "ADDALL") + ) + outlier$method <- method + } + if (!is.na(maxiter)) { + outlier$maxiter <- maxiter + } + if (!is.na(lsrun)) { + outlier$lsrun <- lsrun + } } - } - - if (!is.na(tc.rate)) { - outlier[[tcr_name]] <- tc.rate - } - if (is_tramo) { - # TRAMO SPECIFIC PARAMETERS - if (!is.na(eml.est) && is_tramo) { - outlier$ml <- eml.est - } - } else { - # REGARIMA SPECIFIC PARAMETERS - if (!missing(method) && !is.null(method) && !all(is.na(method))) { - method <- match.arg(toupper(method)[1], - choices = c("ADDONE", "ADDALL")) - outlier$method <- method - } - if (!is.na(maxiter)) { - outlier$maxiter <- maxiter - } - if (!is.na(lsrun)) { - outlier$lsrun <- lsrun - } - } - x$outlier <- outlier - x + x$outlier <- outlier + x } #' Set Arima Model Identification in Pre-Processing Specification @@ -578,7 +619,7 @@ set_outlier.default <- function(x, #' @param amicompare (TRAMO Specific) \code{logical}. If `TRUE`, the program compares the model identified by the automatic procedure to the default model (\eqn{ARIMA(0,1,1)(0,1,1)}) #' and the model with the best fit is selected. Criteria considered are residual diagnostics, the model structure and the number of outliers. #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} #' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" #' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with #' \code{rjd3tramoseats::spec_tramo()}). @@ -609,8 +650,8 @@ set_automodel <- function(x, fct = NA, balanced = NA, # TRAMO SPECIFIC - amicompare=NA){ - UseMethod("set_automodel", x) + amicompare = NA) { + UseMethod("set_automodel", x) } #' @export set_automodel.default <- function(x, @@ -629,64 +670,64 @@ set_automodel.default <- function(x, fct = NA, balanced = NA, # TRAMO SPECIFIC - amicompare = NA){ - automodel <- x$automodel - - is_tramo <- inherits(x, "JD3_TRAMO_SPEC") - reducecv_col <- ifelse(is_tramo, "pc", "predcv") - lblim_col <- ifelse(is_tramo, "pcr", "ljungbox") - if (!is.na(enabled) && is.logical(enabled)){ - automodel$enabled <- enabled - } + amicompare = NA) { + automodel <- x$automodel - if (!is.na(ub1)){ - automodel$ub1 <- ub1 - } - if (!is.na(ub2)){ - automodel$ub2 <- ub2 - } - if (!is.na(cancel)){ - automodel$cancel <- cancel - } - if (!is.na(fct)){ - automodel$fct <- fct - } - if (!is.na(ljungboxlimit)){ - automodel[[lblim_col]] <- ljungboxlimit - } - if (!is.na(reducecv)){ - automodel[[reducecv_col]] <- reducecv - } - if (!is.na(acceptdefault) && is.logical(acceptdefault)){ - automodel$acceptdef <- acceptdefault - } + is_tramo <- inherits(x, "JD3_TRAMO_SPEC") + reducecv_col <- ifelse(is_tramo, "pc", "predcv") + lblim_col <- ifelse(is_tramo, "pcr", "ljungbox") + if (!is.na(enabled) && is.logical(enabled)) { + automodel$enabled <- enabled + } - if (!is.na(tsig)){ - automodel$tsig <- tsig - } - if (is_tramo) { - # TRAMO SPECIFIC - if (!is.na(amicompare) && is.logical(amicompare)){ - automodel$amicompare <- amicompare + if (!is.na(ub1)) { + automodel$ub1 <- ub1 + } + if (!is.na(ub2)) { + automodel$ub2 <- ub2 } - } else { - # REGARIMA SPECIFIC - if (!is.na(ubfinal)){ - automodel$ubfinal <- ubfinal + if (!is.na(cancel)) { + automodel$cancel <- cancel } - if (!is.na(checkmu) && is.logical(checkmu)){ - automodel$checkmu <- checkmu + if (!is.na(fct)) { + automodel$fct <- fct } - if (!is.na(mixed) && is.logical(mixed)){ - automodel$mixed <- mixed + if (!is.na(ljungboxlimit)) { + automodel[[lblim_col]] <- ljungboxlimit } - if (!is.na(balanced) && is.logical(balanced)){ - automodel$balanced <- balanced + if (!is.na(reducecv)) { + automodel[[reducecv_col]] <- reducecv + } + if (!is.na(acceptdefault) && is.logical(acceptdefault)) { + automodel$acceptdef <- acceptdefault } - } - x$automodel <- automodel - x + if (!is.na(tsig)) { + automodel$tsig <- tsig + } + if (is_tramo) { + # TRAMO SPECIFIC + if (!is.na(amicompare) && is.logical(amicompare)) { + automodel$amicompare <- amicompare + } + } else { + # REGARIMA SPECIFIC + if (!is.na(ubfinal)) { + automodel$ubfinal <- ubfinal + } + if (!is.na(checkmu) && is.logical(checkmu)) { + automodel$checkmu <- checkmu + } + if (!is.na(mixed) && is.logical(mixed)) { + automodel$mixed <- mixed + } + if (!is.na(balanced) && is.logical(balanced)) { + automodel$balanced <- balanced + } + } + + x$automodel <- automodel + x } #' Set ARIMA Model Structure in Pre-Processing Specification #' @@ -712,7 +753,7 @@ set_automodel.default <- function(x, #' \code{"Fixed"} = the coefficients are fixed at the value provided by the user, #' \code{"Initial"} = the value defined by the user is used as the initial condition. #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} #' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" #' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with #' \code{rjd3tramoseats::spec_tramo()}). @@ -743,8 +784,8 @@ set_arima <- function(x, bd = NA, bq = NA, coef = NA, - coef.type = c(NA, "Undefined", "Fixed", "Initial")){ - UseMethod("set_arima", x) + coef.type = c(NA, "Undefined", "Fixed", "Initial")) { + UseMethod("set_arima", x) } #' @export set_arima.default <- function(x, @@ -757,104 +798,110 @@ set_arima.default <- function(x, bd = NA, bq = NA, coef = NA, - coef.type = c(NA, "Undefined", "Fixed", "Initial")){ - arima <- x$arima - if (x$automodel$enabled){ - warning("autmodel enabled: the parameters will not impact the final parameters") - } - if (!is.na(d)){ - arima$d <- d - } - if (!is.na(bd)){ - arima$bd <- bd - } - if (missing(coef.type) || is.null(coef.type)){ - coef.type <- "UNDEFINED" - } else { - coef.type <- match.arg(toupper(coef.type), - choices = c(NA, "UNDEFINED", "FIXED", "INITIAL"), - several.ok = TRUE) - coef.type[is.na(coef.type)] <- "UNDEFINED" - } - if (missing(coef) || is.null(coef)){ - coef <- 0 - } else { - coef[is.na(coef)] <- 0 - } - - if (any(!is.na(c(p, bp, q, bq)))) { - np <- ifelse(is.na(p), 0, p) - nbp <- ifelse(is.na(bp), 0, bp) - nq <- ifelse(is.na(q), 0, q) - nbq <- ifelse(is.na(bq), 0, bq) - if (np + nq + nbp + nbq == 0) { - arima_params <- NULL + coef.type = c(NA, "Undefined", "Fixed", "Initial")) { + arima <- x$arima + if (x$automodel$enabled) { + warning("autmodel enabled: the parameters will not impact the final parameters") + } + if (!is.na(d)) { + arima$d <- d + } + if (!is.na(bd)) { + arima$bd <- bd + } + if (missing(coef.type) || is.null(coef.type)) { + coef.type <- "UNDEFINED" + } else { + coef.type <- match.arg(toupper(coef.type), + choices = c(NA, "UNDEFINED", "FIXED", "INITIAL"), + several.ok = TRUE + ) + coef.type[is.na(coef.type)] <- "UNDEFINED" + } + if (missing(coef) || is.null(coef)) { + coef <- 0 } else { - arima_params <- data.frame(arima_order = c(rep("p", np), - rep("phi", nq), - rep("bp", nbp), - rep("bphi", nbq)), - value = coef, - type = coef.type) - arima_params$value <- as.list(arima_params$value) - arima_params$type <- as.list(arima_params$type) + coef[is.na(coef)] <- 0 } + if (!all(is.na(c(p, bp, q, bq)))) { + np <- ifelse(is.na(p), 0, p) + nbp <- ifelse(is.na(bp), 0, bp) + nq <- ifelse(is.na(q), 0, q) + nbq <- ifelse(is.na(bq), 0, bq) + if (np + nq + nbp + nbq == 0) { + arima_params <- NULL + } else { + arima_params <- data.frame( + arima_order = c( + rep("p", np), + rep("phi", nq), + rep("bp", nbp), + rep("bphi", nbq) + ), + value = coef, + type = coef.type + ) + arima_params$value <- as.list(arima_params$value) + arima_params$type <- as.list(arima_params$type) + } - if (!is.na(p)) { - if (p == 0) { - arima["phi"] <- NULL - } else { - arima$phi <- t(arima_params[1:p, c("value", "type")]) - colnames(arima$phi) <- NULL - arima_params <- arima_params[-c(1:p),] - } - } - if (!is.na(q)) { - if (q == 0) { - arima["theta"] <- NULL - } else { - arima$theta <- t(arima_params[1:q, c("value", "type")]) - colnames(arima$theta) <- NULL - arima_params <- arima_params[-c(1:q),] - } - } - if (!is.na(bp)) { - if (bp == 0) { - arima["bphi"] <- NULL - } else { - arima$bphi <- t(arima_params[1:bp, c("value", "type")]) - colnames(arima$bphi) <- NULL - arima_params <- arima_params[-c(1:bp),] - } - } - if (!is.na(bq)) { - if (bq == 0) { - arima["btheta"] <- NULL - } else { - arima$btheta <- t(arima_params[1:bq, c("value", "type")]) - colnames(arima$btheta) <- NULL - } - } - } - x$arima <- arima - regression <- x$regression - if (missing(mean.type) || any(is.na(mean.type))) { - mean.type <- "UNDEFINED" - } else { - mean.type <- match.arg(toupper(mean.type)[1], - choices = c("UNDEFINED", "FIXED", "INITIAL")) - } - if (is.null(mean) || is.na(mean)) { - regression["mean"] <- list(NULL) - } else { - regression$mean$value <- mean - regression$mean$type <- mean.type - } - x$regression <- regression + if (!is.na(p)) { + if (p == 0) { + arima["phi"] <- NULL + } else { + arima$phi <- t(arima_params[1:p, c("value", "type")]) + colnames(arima$phi) <- NULL + arima_params <- arima_params[-c(1:p), ] + } + } + if (!is.na(q)) { + if (q == 0) { + arima["theta"] <- NULL + } else { + arima$theta <- t(arima_params[1:q, c("value", "type")]) + colnames(arima$theta) <- NULL + arima_params <- arima_params[-c(1:q), ] + } + } + if (!is.na(bp)) { + if (bp == 0) { + arima["bphi"] <- NULL + } else { + arima$bphi <- t(arima_params[1:bp, c("value", "type")]) + colnames(arima$bphi) <- NULL + arima_params <- arima_params[-c(1:bp), ] + } + } + if (!is.na(bq)) { + if (bq == 0) { + arima["btheta"] <- NULL + } else { + arima$btheta <- t(arima_params[1:bq, c("value", "type")]) + colnames(arima$btheta) <- NULL + } + } + } + x$arima <- arima - x + regression <- x$regression + if (missing(mean.type) || anyNA(mean.type)) { + mean.type <- "UNDEFINED" + } else { + mean.type <- match.arg(toupper(mean.type)[1], + choices = c("UNDEFINED", "FIXED", "INITIAL") + ) + } + if (is.null(mean) || is.na(mean)) { + regression["mean"] <- list(NULL) + } else { + regression$mean$value <- mean + regression$mean$type <- mean.type + } + x$regression <- regression + + x } @@ -862,14 +909,17 @@ set_arima.default <- function(x, #' #' #' @description -#' Function allowing to select the trading-days regressors to be used for calendar correction in the -#' pre-processing step of a seasonal adjustment procedure. The default is \code{"TradingDays"}, with easter specific effect enabled. -#' (see \code{\link{set_easter}}) +#' Function allowing to select the trading-days regressors to be used for +#' calendar correction in the pre-processing step of a seasonal adjustment +#' procedure. The default is \code{"TradingDays"}, with easter specific effect +#' enabled. (see \code{\link{set_easter}}) #' -#' All the built-in regressors are meant to correct for type -#' of day effect but don't take into account any holiday. To do so user-defined regressors have to be built. +#' All the built-in regressors are meant to correct for type of day effect but +#' don't take into account any holiday. To do so user-defined regressors have to +#' be built. #' #' @inheritParams set_basic +#' #' @param option to specify the set of trading days regression variables: #' \code{"TradingDays"} = six contrast variables, each type of day (from Monday to Saturday) vs Sundays; #' \code{"WorkingDays"} = one working (week days)/non-working (week-ends) day contrast variable; @@ -878,6 +928,7 @@ set_arima.default <- function(x, #' \code{"TD4"} = three contrast variables: week-days (Mondays to Thursdays) vs Sundays, Fridays vs Sundays, Saturdays vs Sundays; #' \code{"None"} = no correction for trading days; #' \code{"UserDefined"} = userdefined trading days regressors. +#' #' @param calendar.name name (string) of the user-defined calendar to be taken into account when generating #' built-in regressors set in 'option' (if not 'UserDefined).(see examples) #' @param uservariable a vector of characters to specify the name of user-defined calendar regressors. @@ -905,9 +956,13 @@ set_arima.default <- function(x, #' #' @param coef vector of coefficients for the trading-days regressors. #' -#' @param automatic defines whether the calendar effects should be added to the model manually (\code{"Unused"}) or automatically. -#' During the automatic selection, the choice of the number of calendar variables can be based on the F-Test (\code{"FTest"}, TRAMO specific), the Wald Test (\code{"WaldTest"}), or by minimizing AIC or BIC; -#' the model with higher F value is chosen, provided that it is higher than \code{pftd}). +#' @param automatic defines whether the calendar effects should be added to the +#' model manually (\code{"Unused"}) or automatically. During the automatic +#' selection, the choice of the number of calendar variables can be based on +#' the F-Test (\code{"FTest"}, TRAMO specific), the Wald Test +#' (\code{"WaldTest"}), or by minimizing AIC or BIC; the model with higher +#' F-value is chosen, provided that it is higher than \code{pftd}). +#' #' @param pftd (TRAMO SPECIFIC) \code{numeric}. The p-value used to assess the significance of the pre-tested calendar effects. #' #' @param autoadjust a logical indicating if the program corrects automatically the raw series for @@ -921,7 +976,7 @@ set_arima.default <- function(x, #' @param leapyear.coef coefficient of the leap year regressor. #' @param coef.type,leapyear.coef.type vector defining if the coefficients are fixed or estimated. #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} #' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" #' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with #' \code{rjd3tramoseats::spec_tramo()}). @@ -945,21 +1000,22 @@ set_arima.default <- function(x, #' # Pre-defined regressors based on user-defined calendar #' ### create a calendar #' BE <- national_calendar(list( -#' fixed_day(7,21), -#' special_day("NEWYEAR"), -#' special_day("CHRISTMAS"), -#' special_day("MAYDAY"), -#' special_day("EASTERMONDAY"), -#' special_day("ASCENSION"), -#' special_day("WHITMONDAY"), -#' special_day("ASSUMPTION"), -#' special_day("ALLSAINTSDAY"), -#' special_day("ARMISTICE"))) +#' fixed_day(7, 21), +#' special_day("NEWYEAR"), +#' special_day("CHRISTMAS"), +#' special_day("MAYDAY"), +#' special_day("EASTERMONDAY"), +#' special_day("ASCENSION"), +#' special_day("WHITMONDAY"), +#' special_day("ASSUMPTION"), +#' special_day("ALLSAINTSDAY"), +#' special_day("ARMISTICE") +#' )) #' ## put into a context -#' my_context<-modelling_context(calendars = list(cal=BE)) +#' my_context <- modelling_context(calendars = list(cal = BE)) #' ## create a specification -#' #init_spec <- rjd3x13::x13_spec("RSA5c") -#'## modify the specification +#' # init_spec <- rjd3x13::x13_spec("RSA5c") +#' ## modify the specification #' # new_spec<-set_tradingdays(init_spec, #' # option = "TradingDays", calendar.name="cal") #' ## estimate with context @@ -979,23 +1035,23 @@ set_arima.default <- function(x, #' # estimate with context #' # sa<-rjd3x13::x13(y_raw,new_spec, context=my_context) #' @export -set_tradingdays<- function(x, - option = c(NA, "TradingDays", "WorkingDays", "TD3", "TD3c", "TD4", "None", "UserDefined"), - calendar.name = NA, - uservariable = NA, - stocktd = NA, - test = c(NA, "None", "Remove", "Add", "Separate_T", "Joint_F"), - coef = NA, - coef.type = c(NA, "Fixed", "Estimated"), - automatic = c(NA, "Unused", "FTest", "WaldTest", "Aic", "Bic"), - # TRAMO SPECIFIC - pftd = NA, - # LEAP YEAR - autoadjust = NA, - leapyear = c(NA, "LeapYear", "LengthOfPeriod", "None"), - leapyear.coef = NA, - leapyear.coef.type = c(NA, "Fixed", "Estimated")){ - UseMethod("set_tradingdays", x) +set_tradingdays <- function(x, + option = c(NA, "TradingDays", "WorkingDays", "TD3", "TD3c", "TD4", "None", "UserDefined"), + calendar.name = NA, + uservariable = NA, + stocktd = NA, + test = c(NA, "None", "Remove", "Add", "Separate_T", "Joint_F"), + coef = NA, + coef.type = c(NA, "Fixed", "Estimated"), + automatic = c(NA, "Unused", "FTest", "WaldTest", "Aic", "Bic"), + # TRAMO SPECIFIC + pftd = NA, + # LEAP YEAR + autoadjust = NA, + leapyear = c(NA, "LeapYear", "LengthOfPeriod", "None"), + leapyear.coef = NA, + leapyear.coef.type = c(NA, "Fixed", "Estimated")) { + UseMethod("set_tradingdays", x) } #' @export @@ -1014,153 +1070,171 @@ set_tradingdays.default <- function(x, autoadjust = NA, leapyear = c(NA, "LeapYear", "LengthOfPeriod", "None"), leapyear.coef = NA, - leapyear.coef.type = c(NA, "Estimated", "Fixed")){ - td <- x$regression$td + leapyear.coef.type = c(NA, "Estimated", "Fixed")) { + td <- x$regression$td - is_tramo <- inherits(x, "JD3_TRAMO_SPEC") + is_tramo <- inherits(x, "JD3_TRAMO_SPEC") - if (!missing(option) && !any(is.na(option))){ - option <- match.arg(toupper(option)[1], - choices = c("TRADINGDAYS", "WORKINGDAYS", "NONE","USERDEFINED", - "TD3", "TD3C", "TD4", "HOLIDAYS")) - td$td <- switch(option, - WORKINGDAYS = "TD2", - TRADINGDAYS = "TD7", - USERDEFINED = "TD_NONE", - NONE = "TD_NONE", - option) - td$users <- character() - } + if (!missing(option) && !anyNA(option)) { + option <- match.arg(toupper(option)[1], + choices = c( + "TRADINGDAYS", "WORKINGDAYS", "NONE", "USERDEFINED", + "TD3", "TD3C", "TD4", "HOLIDAYS" + ) + ) + td$td <- switch(option, + WORKINGDAYS = "TD2", + TRADINGDAYS = "TD7", + USERDEFINED = "TD_NONE", + NONE = "TD_NONE", + option + ) + td$users <- character() + } - if (!missing(calendar.name) && !any(is.na(calendar.name))){ - td$holidays <- calendar.name - } - if (!is.null(uservariable) && - !any(is.na(uservariable)) && - length(uservariable) > 0){ - td$td <- "TD_NONE" - td$holidays <- "" + if (!missing(calendar.name) && !anyNA(calendar.name)) { + td$holidays <- calendar.name + } + if (!is.null(uservariable) + && !anyNA(uservariable) + && length(uservariable) > 0) { + td$td <- "TD_NONE" + td$holidays <- "" - td$users <- uservariable + td$users <- uservariable - if (missing(coef) || is.null(coef)){ - coef <- 0 - coef.type <- "ESTIMATED" - } - } - if (!missing(stocktd) && !is.na(stocktd)){ - td$users <- character() - td$td <- "TD_NONE" - td$holidays <- "" - td$w <- stocktd - } - if (!missing(autoadjust) && !is.na(autoadjust)){ - td$autoadjust <- autoadjust - } + if (missing(coef) || is.null(coef)) { + coef <- 0 + coef.type <- "ESTIMATED" + } + } + if (!missing(stocktd) && !is.na(stocktd)) { + td$users <- character() + td$td <- "TD_NONE" + td$holidays <- "" + td$w <- stocktd + } + if (!missing(autoadjust) && !is.na(autoadjust)) { + td$autoadjust <- autoadjust + } - if (!is.null(test) && !any(is.na(test))){ - if (is_tramo) { - test <- match.arg(toupper(test)[1], - choices = c("SEPARATE_T", "JOINT_F", "NONE")) - td$test <- sprintf("TEST_%s", - switch(test, - NONE = "NO", - test)) - } else { - test <- match.arg(toupper(test)[1], - choices = c("REMOVE", "ADD", "NONE")) - td$test <- switch(test, - NONE = "NO", - test) - } - } - if (!missing(automatic) && !any(is.na(automatic))){ + if (!is.null(test) && !anyNA(test)) { + if (is_tramo) { + test <- match.arg(toupper(test)[1], + choices = c("SEPARATE_T", "JOINT_F", "NONE") + ) + td$test <- sprintf( + "TEST_%s", + switch(test, + NONE = "NO", + test + ) + ) + } else { + test <- match.arg(toupper(test)[1], + choices = c("REMOVE", "ADD", "NONE") + ) + td$test <- switch(test, + NONE = "NO", + test + ) + } + } + if (!missing(automatic) && !anyNA(automatic)) { + if (is_tramo) { + automatic <- match.arg(toupper(automatic)[1], + choices = c("UNUSED", "FTEST", "WALDTEST", "AIC", "BIC") + ) + td$auto <- switch(automatic, + UNUSED = "AUTO_NO", + FTEST = "AUTO_FTEST", + AIC = "AUTO_AIC", + BIC = "AUTO_BIC", + WALDTEST = "AUTO_WALDTEST" + ) + } else { + automatic <- match.arg(toupper(automatic)[1], + choices = c("UNUSED", "WALDTEST", "AIC", "BIC") + ) + td$auto <- switch(automatic, + UNUSED = "AUTO_NO", + AIC = "AUTO_AIC", + BIC = "AUTO_BIC", + WALDTEST = "AUTO_WALD" + ) + } + } if (is_tramo) { - automatic <- match.arg(toupper(automatic)[1], - choices = c("UNUSED", "FTEST", "WALDTEST", "AIC", "BIC")) - td$auto <- switch(automatic, - UNUSED = "AUTO_NO", - FTEST = "AUTO_FTEST", - AIC = "AUTO_AIC", - BIC = "AUTO_BIC", - WALDTEST = "AUTO_WALDTEST") - } else { - automatic <- match.arg(toupper(automatic)[1], - choices = c("UNUSED", "WALDTEST", "AIC", "BIC")) - td$auto <- switch(automatic, - UNUSED = "AUTO_NO", - AIC = "AUTO_AIC", - BIC = "AUTO_BIC", - WALDTEST = "AUTO_WALD") + if (!missing(pftd) && !anyNA(pftd)) { + td$ptest <- pftd + } } - } - if (is_tramo) { - if (!missing(pftd) && !any(is.na(pftd))){ - td$ptest <- pftd + if (!is.null(leapyear) && !anyNA(leapyear)) { + leapyear <- match.arg(toupper(leapyear), + choices = c("LEAPYEAR", "LENGTHOFPERIOD", "NONE") + ) + if (leapyear != "LENGTHOFPERIOD" || (leapyear == "LENGTHOFPERIOD" && !is_tramo)) { + # LENGTHOFPERIOD not available on TRAMO + td$lp <- leapyear + } } - } - if (!is.null(leapyear) && !any(is.na(leapyear))) { - leapyear <- match.arg(toupper(leapyear), - choices = c("LEAPYEAR", "LENGTHOFPERIOD", "NONE")) - if (leapyear != "LENGTHOFPERIOD" || (leapyear == "LENGTHOFPERIOD" && !is_tramo)) { - # LENGTHOFPERIOD not available on TRAMO - td$lp <- leapyear - } - } - - if (missing(coef) || is.null(coef)){ - # coef <- 0 - } else { - if (missing(coef.type) || is.null(coef.type)){ - coef.type <- "FIXED" + if (missing(coef) || is.null(coef)) { + # coef <- 0 } else { - coef.type <- match.arg(toupper(coef.type), - choices = c(NA, "ESTIMATED", "FIXED"), - several.ok = TRUE) - coef.type[is.na(coef.type)] <- "FIXED" - } - ntd <- switch(td$td, - TD2 = 1, - TD3 = 2, - TD3C = 3, - TD4 = 3, - TD7 = 6, - length(td$users)) - if (length(coef) == 1){ - coef <- rep(coef, ntd) - } - tdcoefficients <- data.frame(value = coef, - type = coef.type) - tdcoefficients$value <- as.list(tdcoefficients$value) - tdcoefficients$type <- as.list(tdcoefficients$type) + if (missing(coef.type) || is.null(coef.type)) { + coef.type <- "FIXED" + } else { + coef.type <- match.arg(toupper(coef.type), + choices = c(NA, "ESTIMATED", "FIXED"), + several.ok = TRUE + ) + coef.type[is.na(coef.type)] <- "FIXED" + } + ntd <- switch(td$td, + TD2 = 1, + TD3 = 2, + TD3C = 3, + TD4 = 3, + TD7 = 6, + length(td$users) + ) + if (length(coef) == 1) { + coef <- rep(coef, ntd) + } + tdcoefficients <- data.frame( + value = coef, + type = coef.type + ) + tdcoefficients$value <- as.list(tdcoefficients$value) + tdcoefficients$type <- as.list(tdcoefficients$type) - td$tdcoefficients <- t(tdcoefficients) - if (td$test != "NO" && any(coef.type == "FIXED")) { - warning("You must set the test parameter to NONE to specify coef") + td$tdcoefficients <- t(tdcoefficients) + if (td$test != "NO" && any(coef.type == "FIXED")) { + warning("You must set the test parameter to NONE to specify coef") + } } - - } - if (missing(leapyear.coef) || is.null(leapyear.coef)){ - # coef <- 0 - } else { - if (missing(leapyear.coef.type) || is.null(leapyear.coef.type)){ - leapyear.coef.type <- "FIXED" + if (missing(leapyear.coef) || is.null(leapyear.coef)) { + # coef <- 0 } else { - leapyear.coef.type <- match.arg(toupper(leapyear.coef.type), - choices = c(NA, "ESTIMATED", "FIXED")) - leapyear.coef.type[is.na(leapyear.coef.type)] <- "FIXED" - } - td$lpcoefficient$value <- leapyear.coef - td$lpcoefficient$type <- leapyear.coef.type - if (td$test != "NO" && any(coef.type == "FIXED")) { - warning("You must set the test parameter to NONE to specify leapyear.coef") + if (missing(leapyear.coef.type) || is.null(leapyear.coef.type)) { + leapyear.coef.type <- "FIXED" + } else { + leapyear.coef.type <- match.arg(toupper(leapyear.coef.type), + choices = c(NA, "ESTIMATED", "FIXED") + ) + leapyear.coef.type[is.na(leapyear.coef.type)] <- "FIXED" + } + td$lpcoefficient$value <- leapyear.coef + td$lpcoefficient$type <- leapyear.coef.type + if (td$test != "NO" && any(coef.type == "FIXED")) { + warning("You must set the test parameter to NONE to specify leapyear.coef") + } } - } - x$regression$td <- td - x + x$regression$td <- td + x } #' Set Easter effect correction in Pre-Processing Specification @@ -1191,7 +1265,7 @@ set_tradingdays.default <- function(x, #' \code{"IncludeEaster"} = influences the entire period (\code{n}) up to and including Easter Sunday; #' \code{"IncludeEasterMonday"} = influences the entire period (\code{n}) up to and including Easter Monday. #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} #' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" #' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with #' \code{rjd3tramoseats::spec_tramo()}). @@ -1208,15 +1282,15 @@ set_tradingdays.default <- function(x, #' # type = "IncludeEasterMonday") #' # sa<-rjd3x13::x13(ABS$X0.2.09.10.M,new_spec) #' @export -set_easter<- function(x, enabled = NA, - julian = NA, - duration = NA, - test = c(NA, "Add", "Remove", "None"), - coef = NA, - coef.type = c(NA, "Estimated", "Fixed"), - # TRAMO SPECIFIC - type = c(NA, "Unused", "Standard", "IncludeEaster", "IncludeEasterMonday")){ - UseMethod("set_easter", x) +set_easter <- function(x, enabled = NA, + julian = NA, + duration = NA, + test = c(NA, "Add", "Remove", "None"), + coef = NA, + coef.type = c(NA, "Estimated", "Fixed"), + # TRAMO SPECIFIC + type = c(NA, "Unused", "Standard", "IncludeEaster", "IncludeEasterMonday")) { + UseMethod("set_easter", x) } #' @export set_easter.default <- function(x, enabled = NA, @@ -1226,73 +1300,77 @@ set_easter.default <- function(x, enabled = NA, coef = NA, coef.type = c(NA, "Estimated", "Fixed"), # TRAMO SPECIFIC - type = c(NA, "Unused", "Standard", "IncludeEaster", "IncludeEasterMonday")){ - easter <- x$regression$easter + type = c(NA, "Unused", "Standard", "IncludeEaster", "IncludeEasterMonday")) { + easter <- x$regression$easter - # to set specific TRAMO/REGARIMA values - is_tramo <- inherits(x, "JD3_TRAMO_SPEC") + # to set specific TRAMO/REGARIMA values + is_tramo <- inherits(x, "JD3_TRAMO_SPEC") - if (!is.null(test) && !any(is.na(test))){ - if (is_tramo) { - if (!is.logical(test)) { - test <- match.arg(toupper(test)[1], - choices = c("REMOVE", "ADD", "NONE")) != "NONE" - } - easter$test <- test - } else { - test <- match.arg(toupper(test)[1], - choices = c("REMOVE", "ADD", "NONE")) - easter$test <- switch(test, - NONE = "NO", - test) - } - } - if (!missing(enabled) && !is.na(enabled)){ - easter$type <- ifelse(enabled, "STANDARD", "UNUSED") - } - if (is_tramo && !is.null(type) && !any(is.na(type))) { - # TRAMO SPECIFIC - type <- match.arg(toupper(type)[1], - choices = c("UNUSED", "STANDARD", "INCLUDEEASTER", "INCLUDEEASTERMONDAY")) - easter$type <- type - } - if (!missing(julian) && !is.na(julian)){ - if (is_tramo) { - easter$julian <- julian - } else { - easter$type <- ifelse(julian, "JULIAN", easter$type) + if (!is.null(test) && !anyNA(test)) { + if (is_tramo) { + if (!is.logical(test)) { + test <- match.arg(toupper(test)[1], + choices = c("REMOVE", "ADD", "NONE") + ) != "NONE" + } + easter$test <- test + } else { + test <- match.arg(toupper(test)[1], + choices = c("REMOVE", "ADD", "NONE") + ) + easter$test <- switch(test, + NONE = "NO", + test + ) + } } - } - if (easter$type == "UNUSED"){ - if (is_tramo) { - easter$test <- FALSE - } else { - easter$test <- "NO" + if (!missing(enabled) && !is.na(enabled)) { + easter$type <- ifelse(enabled, "STANDARD", "UNUSED") } - } - if (!missing(duration) && !is.na(duration)){ - easter$duration <- duration - } - if (missing(coef) ||is.null(coef) || is.na(coef)) { - - } else { - if (missing(coef.type) || any(is.na(coef.type))) { - coef.type <- "FIXED" - } else { - coef.type <- match.arg(toupper(coef.type)[1], - choices = c("ESTIMATED", "FIXED")) + if (is_tramo && !is.null(type) && !anyNA(type)) { + # TRAMO SPECIFIC + type <- match.arg(toupper(type)[1], + choices = c("UNUSED", "STANDARD", "INCLUDEEASTER", "INCLUDEEASTERMONDAY") + ) + easter$type <- type + } + if (!missing(julian) && !is.na(julian)) { + if (is_tramo) { + easter$julian <- julian + } else { + easter$type <- ifelse(julian, "JULIAN", easter$type) + } } + if (easter$type == "UNUSED") { + if (is_tramo) { + easter$test <- FALSE + } else { + easter$test <- "NO" + } + } + if (!missing(duration) && !is.na(duration)) { + easter$duration <- duration + } + if (missing(coef) || is.null(coef) || is.na(coef)) { - if (coef.type == "ESTIMATED") { - easter["coefficient"] <- list(NULL) } else { - easter$coefficient$value <- coef - easter$coefficient$type <- coef.type - } + if (missing(coef.type) || anyNA(coef.type)) { + coef.type <- "FIXED" + } else { + coef.type <- match.arg(toupper(coef.type)[1], + choices = c("ESTIMATED", "FIXED") + ) + } - } - x$regression$easter <- easter - x + if (coef.type == "ESTIMATED") { + easter["coefficient"] <- list(NULL) + } else { + easter$coefficient$value <- coef + easter$coefficient$type <- coef.type + } + } + x$regression$easter <- easter + x } #' Set Log-level Transformation and Decomposition scheme in Pre-Processing Specification @@ -1309,10 +1387,10 @@ set_easter.default <- function(x, enabled = NA, #' @param aicdiff (REGARIMA/X-13 specific) a numeric defining the difference in AICC needed to accept no transformation when the automatic #' transformation selection is chosen (considered only when \code{fun = "Auto"}). Default= -2. #' @param fct (TRAMO specific) \code{numeric} controlling the bias in the log/level pre-test: -#' \code{transform.fct}> 1 favors levels, \code{transform.fct}< 1 favors logs. +#' \code{transform.fct}> 1 favours levels, \code{transform.fct}< 1 favours logs. #' Considered only when \code{fun = "Auto"}. #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} #' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" #' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with #' \code{rjd3tramoseats::spec_tramo()}). @@ -1328,15 +1406,15 @@ set_easter.default <- function(x, enabled = NA, #' # sa<-rjd3x13::x13(ABS$X0.2.09.10.M,new_spec) #' #' @export -set_transform<- function(x, - fun = c(NA, "Auto", "Log", "None"), - adjust = c(NA, "None", "LeapYear", "LengthOfPeriod"), - outliers = NA, - # REGARIMA SPECIFIC - aicdiff = NA, - # TRAMO SPECIFIC - fct = NA){ - UseMethod("set_transform", x) +set_transform <- function(x, + fun = c(NA, "Auto", "Log", "None"), + adjust = c(NA, "None", "LeapYear", "LengthOfPeriod"), + outliers = NA, + # REGARIMA SPECIFIC + aicdiff = NA, + # TRAMO SPECIFIC + fct = NA) { + UseMethod("set_transform", x) } #' @export set_transform.default <- function(x, @@ -1346,41 +1424,46 @@ set_transform.default <- function(x, # REGARIMA SPECIFIC aicdiff = NA, # TRAMO SPECIFIC - fct = NA){ - transform <- x$transform + fct = NA) { + transform <- x$transform - fun <- match.arg(toupper(fun[1]), - c(NA, "AUTO", "LOG", "NONE")) - # to set specific TRAMO/REGARIMA values - is_tramo <- inherits(x, "JD3_TRAMO_SPEC") + fun <- match.arg( + toupper(fun[1]), + c(NA, "AUTO", "LOG", "NONE") + ) + # to set specific TRAMO/REGARIMA values + is_tramo <- inherits(x, "JD3_TRAMO_SPEC") - if (!is.na(fun)){ - transform$fn <- switch(fun, - "NONE" = "LEVEL", - fun) - } - adjust <- match.arg(toupper(adjust[1]), - c(NA, "NONE", "LEAPYEAR", "LENGTHOFPERIOD")) - if (!is.na(adjust)){ - transform$adjust <- adjust - } + if (!is.na(fun)) { + transform$fn <- switch(fun, + NONE = "LEVEL", + fun + ) + } + adjust <- match.arg( + toupper(adjust[1]), + c(NA, "NONE", "LEAPYEAR", "LENGTHOFPERIOD") + ) + if (!is.na(adjust)) { + transform$adjust <- adjust + } - if (!is.na(outliers)) { - transform$outliers <- outliers - } - if (is_tramo) { - # TRAMO SPECIFIC PARAMETER - if (!is.na(fct)){ - transform$fct <- fct - } - } else { - if (!is.na(aicdiff)){ - transform$aicdiff <- aicdiff - } - } + if (!is.na(outliers)) { + transform$outliers <- outliers + } + if (is_tramo) { + # TRAMO SPECIFIC PARAMETER + if (!is.na(fct)) { + transform$fct <- fct + } + } else { + if (!is.na(aicdiff)) { + transform$aicdiff <- aicdiff + } + } - x$transform <- transform - x + x$transform <- transform + x } #' Add a User-Defined Variable to Pre-Processing Specification. @@ -1401,7 +1484,7 @@ set_transform.default <- function(x, #' @param regeffect component to which the effect of the user-defined variable will be assigned. #' By default (`"Undefined"`), see details. #' @details -#' \code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +#' \code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} #' (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" #' generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with #' \code{rjd3tramoseats::spec_tramo()}). @@ -1414,24 +1497,26 @@ set_transform.default <- function(x, #' - "Seasonal": after the decomposition the effect is allocated to the seasonal component, like a Seasonal-outlier #' - "Series": after the decomposition the effect is allocated to #' the raw series: \eqn{yc_t=y_t+ effect} -#' - "Seasonally Adjusted": after the decomposition the effect is allocated to +#' - "SeasonallyAdjusted": after the decomposition the effect is allocated to #' the seasonally adjusted series: \eqn{sa_t=T+I+effect} #' @examples #' # creating one or several external regressors (TS objects), #' # which will be gathered in one or several groups -#' iv1<-intervention_variable(12, c(2000, 1), 60, -#' starts = "2001-01-01", ends = "2001-12-01") -#' iv2<- intervention_variable(12, c(2000, 1), 60, -#' starts = "2001-01-01", ends = "2001-12-01", delta = 1) +#' iv1 <- intervention_variable(12, c(2000, 1), 60, +#' starts = "2001-01-01", ends = "2001-12-01" +#' ) +#' iv2 <- intervention_variable(12, c(2000, 1), 60, +#' starts = "2001-01-01", ends = "2001-12-01", delta = 1 +#' ) #' # configuration 1: regressors in the same default group (named "r") -#' variables<-list("iv1"=iv1, "iv2"=iv2) +#' variables <- list("iv1" = iv1, "iv2" = iv2) #' # to use those regressors, input : name=r.iv1 and r.iv2 in add_usrdefvar function #' # configuration 2: group names are user-defined #' # here: regressors as a list of two groups (lists) reg1 and reg2 -#' vars<-list(reg1=list(iv1 = iv1),reg2=list(iv2 = iv2) ) +#' vars <- list(reg1 = list(iv1 = iv1), reg2 = list(iv2 = iv2)) #' # to use those regressors, input : name=reg1.iv1 and name=reg2.iv2 in add_usrdefvar function #' # creating the modelling context -#' my_context<-modelling_context(variables=vars) +#' my_context <- modelling_context(variables = vars) #' # customize a default specification #' # init_spec <- rjd3x13::x13_spec("RSA5c") #' # regressors have to be added one by one @@ -1446,35 +1531,35 @@ set_transform.default <- function(x, #' \url{https://jdemetra-new-documentation.netlify.app/} #' @export add_usrdefvar <- function(x, - group="r", - name, - label = paste0(group,".",name), - lag = 0, - coef = NULL, - regeffect=c("Undefined", "Trend", "Seasonal", "Irregular", "Series", "SeasonallyAdjusted")) { - UseMethod("add_usrdefvar", x) + group = "r", + name, + label = paste0(group, ".", name), + lag = 0, + coef = NULL, + regeffect = c("Undefined", "Trend", "Seasonal", "Irregular", "Series", "SeasonallyAdjusted")) { + UseMethod("add_usrdefvar", x) } #' @export add_usrdefvar.default <- function(x, - group="r", + group = "r", name, - label=paste0(group,".",name), + label = paste0(group, ".", name), lag = 0, coef = NULL, - regeffect=c("Undefined", "Trend", "Seasonal", "Irregular", "Series", "SeasonallyAdjusted")) { - x$regression$users[[length(x$regression$users) + 1]] <- - .create_variable(id =paste0(group,".",name), label = label, lag = lag, coef = coef, regeffect = regeffect) - x + regeffect = c("Undefined", "Trend", "Seasonal", "Irregular", "Series", "SeasonallyAdjusted")) { + x$regression$users[[length(x$regression$users) + 1]] <- + .create_variable(id = paste0(group, ".", name), label = label, lag = lag, coef = coef, regeffect = regeffect) + x } # read in protofile -.create_variable<-function(id, label=NULL, lag = 0, coef = NULL, regeffect=c("Undefined", "Trend", "Seasonal", "Irregular", "Series", "SeasonallyAdjusted")){ - regeffect <- match.arg(regeffect) - if (is.null(label)) { - label<-id - } - res <- list(id = id, name=label, lag=lag, coef = .fixed_parameter(coef), regeffect=regeffect) - return (res) +.create_variable <- function(id, label = NULL, lag = 0, coef = NULL, regeffect = c("Undefined", "Trend", "Seasonal", "Irregular", "Series", "SeasonallyAdjusted")) { + regeffect <- match.arg(regeffect) + if (is.null(label)) { + label <- id + } + res <- list(id = id, name = label, lag = lag, coef = .fixed_parameter(coef), regeffect = regeffect) + return(res) } @@ -1483,69 +1568,70 @@ set_span <- function(x, d0 = NULL, d1 = NULL, n0 = 0, - n1 = 0){ - if (!missing(type) && !is.null(type) && !is.na(type[1])){ - type <- match.arg(toupper(type), - choices = c("ALL", "FROM", "TO", "BETWEEN", "LAST", "FIRST", "EXCLUDING")) - if (type == "ALL") { - x$type <- type - x$d1 <- x$d1 <- NULL - x$n0 <- x$n1 <- 0 - } else if (type == "FROM"){ - if (is.null(d0)){ - warning("d0 parameter must be defined") - } else { - x$type <- type - x$d0 <- d0 - x$d1 <- NULL - x$n0 <- x$n1 <- 0 - } - } else if (type == "TO"){ - if (is.na(d1)){ - warning("d1 parameter must be defined") - } else { - x$type <- type - x$d1 <- d1 - x$d0 <- NULL - x$n0 <- x$n1 <- 0 - } - } else if (type=="BETWEEN"){ - if (is.na(d0) || is.na(d1)){ - warning("d0 and d1 parameters must be defined") - } else { - x$type <- type - x$d0 <- d0 - x$d1 <- d1 - x$n0 <- x$n1 <- 0 - } - } else if (type=="FIRST"){ - if (is.na(n0)){ - warning("n0 parameter must be defined") - } else { - x$type <- type - x$d0 <- x$d1 <- NULL - x$n0 <- n0 - x$n1 <- 0 - } - } else if (type=="LAST"){ - if (is.na(n1)){ - warning("n1 parameter must be defined") - } else { - x$type <- type - x$d0 <- x$d1 <- NULL - x$n0 <- 0 - x$n1 <- n1 - } - } else if (type=="EXCLUDING"){ - if (is.na(n0) || is.na(n1)){ - warning("n0 and n1 parameters must be defined") - } else { - x$type <- type - x$d0 <- x$d1 <- NULL - x$n0 <- n0 - x$n1 <- n1 - } - } - } - x + n1 = 0) { + if (!missing(type) && !is.null(type) && !is.na(type[1])) { + type <- match.arg(toupper(type), + choices = c("ALL", "FROM", "TO", "BETWEEN", "LAST", "FIRST", "EXCLUDING") + ) + if (type == "ALL") { + x$type <- type + x$d1 <- x$d1 <- NULL + x$n0 <- x$n1 <- 0 + } else if (type == "FROM") { + if (is.null(d0)) { + warning("d0 parameter must be defined") + } else { + x$type <- type + x$d0 <- d0 + x$d1 <- NULL + x$n0 <- x$n1 <- 0 + } + } else if (type == "TO") { + if (is.na(d1)) { + warning("d1 parameter must be defined") + } else { + x$type <- type + x$d1 <- d1 + x$d0 <- NULL + x$n0 <- x$n1 <- 0 + } + } else if (type == "BETWEEN") { + if (is.na(d0) || is.na(d1)) { + warning("d0 and d1 parameters must be defined") + } else { + x$type <- type + x$d0 <- d0 + x$d1 <- d1 + x$n0 <- x$n1 <- 0 + } + } else if (type == "FIRST") { + if (is.na(n0)) { + warning("n0 parameter must be defined") + } else { + x$type <- type + x$d0 <- x$d1 <- NULL + x$n0 <- n0 + x$n1 <- 0 + } + } else if (type == "LAST") { + if (is.na(n1)) { + warning("n1 parameter must be defined") + } else { + x$type <- type + x$d0 <- x$d1 <- NULL + x$n0 <- 0 + x$n1 <- n1 + } + } else if (type == "EXCLUDING") { + if (is.na(n0) || is.na(n1)) { + warning("n0 and n1 parameters must be defined") + } else { + x$type <- type + x$d0 <- x$d1 <- NULL + x$n0 <- n0 + x$n1 <- n1 + } + } + } + x } diff --git a/R/splines.R b/R/splines.R index 66979482..b4ebe608 100644 --- a/R/splines.R +++ b/R/splines.R @@ -9,11 +9,11 @@ #' @export #' #' @examples -periodic_splines<-function(order=4, period=1, knots, pos){ - - jm<-.jcall("jdplus/toolkit/base/r/math/BSplines", "Ljdplus/toolkit/base/core//math/matrices/Matrix;", - "periodic", as.integer(order), as.numeric(period), .jarray(as.numeric(knots)), .jarray(as.numeric(pos))) - res <- .jd2r_matrix(jm) - return(res) - +periodic_splines <- function(order = 4, period = 1, knots, pos) { + jm <- .jcall( + "jdplus/toolkit/base/r/math/BSplines", "Ljdplus/toolkit/base/core//math/matrices/Matrix;", + "periodic", as.integer(order), as.numeric(period), .jarray(as.numeric(knots)), .jarray(as.numeric(pos)) + ) + res <- .jd2r_matrix(jm) + return(res) } diff --git a/R/tests_regular.R b/R/tests_regular.R index 2598ee39..99097454 100644 --- a/R/tests_regular.R +++ b/R/tests_regular.R @@ -18,31 +18,31 @@ NULL #' \item{\code{distribution}} the statistical distribution used. #' } #' @examples -#' udr_test = testofupdownruns(random_t(5, 1000)) +#' udr_test <- testofupdownruns(random_t(5, 1000)) #' udr_test # default print #' print(udr_test, details = TRUE) # with the distribution #' #' @export -statisticaltest<-function(val, pval, dist=NULL){ - if (pval<0){ - pval <- 0 - } else if (pval>1){ - pval <- 1 - } - return(structure(list(value=val, pvalue=pval), distribution=dist, class=c("JD3_TEST", "JD3"))) +statisticaltest <- function(val, pval, dist = NULL) { + if (pval < 0) { + pval <- 0 + } else if (pval > 1) { + pval <- 1 + } + return(structure(list(value = val, pvalue = pval), distribution = dist, class = c("JD3_TEST", "JD3"))) } #' @rdname statisticaltest #' @export -print.JD3_TEST<-function(x, details=FALSE, ...){ - cat('Value: ', x$value, '\n') - cat('P-Value: ', sprintf('%.4f', x$pvalue), '\n') - if (details){ - dist<-attr(x, "distribution") - if (! is.null(dist)){ - cat('[', dist, ']\n') +print.JD3_TEST <- function(x, details = FALSE, ...) { + cat("Value:", x$value, "\n") + cat("P-Value:", sprintf("%.4f", x$pvalue), "\n") + if (details) { + dist <- attr(x, "distribution") + if (!is.null(dist)) { + cat("[", dist, "]\n") + } } - } } @@ -55,7 +55,7 @@ print.JD3_TEST<-function(x, details=FALSE, ...){ #' @param k number of auto-correlations used in the test #' @param nhp number of hyper parameters (to correct the degree of freedom) #' @param lag number of lags used between two auto-correlations. -#' @param sign if `sign = 1`, only positive auto-corrrelations are considered in the test. +#' @param sign if `sign = 1`, only positive auto-correlations are considered in the test. #' If `sign = -1`, only negative auto-correlations are considered. #' If `sign = 0`, all auto-correlations are integrated in the test. #' @param mean Mean correction. If \code{TRUE}, the auto-correlations are computed as usual. @@ -64,13 +64,15 @@ print.JD3_TEST<-function(x, details=FALSE, ...){ #' @return A \code{c("JD3_TEST", "JD3")} object (see [statisticaltest()] for details). #' #' @examples -#' ljungbox(random_t(2, 100), lag = 24, k =1) -#' ljungbox(ABS$X0.2.09.10.M, lag = 24, k =1) +#' ljungbox(random_t(2, 100), lag = 24, k = 1) +#' ljungbox(ABS$X0.2.09.10.M, lag = 24, k = 1) #' @export -ljungbox<-function(data, k=1, lag=1, nhp=0, sign=0, mean=TRUE){ - jtest<-.jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "ljungBox", - as.numeric(data), as.integer(k), as.integer(lag), as.integer(nhp), as.integer(sign), as.logical(mean)) - return(.jd2r_test(jtest)) +ljungbox <- function(data, k = 1, lag = 1, nhp = 0, sign = 0, mean = TRUE) { + jtest <- .jcall( + "jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "ljungBox", + as.numeric(data), as.integer(k), as.integer(lag), as.integer(nhp), as.integer(sign), as.logical(mean) + ) + return(.jd2r_test(jtest)) } #' Normality Tests @@ -84,7 +86,7 @@ ljungbox<-function(data, k=1, lag=1, nhp=0, sign=0, mean=TRUE){ #' @return A \code{c("JD3_TEST", "JD3")} object (see \code{\link{statisticaltest}} for details). #' #' @examples -#' x <- rnorm(100) # null +#' x <- rnorm(100) # null #' bowmanshenton(x) #' doornikhansen(x) #' jarquebera(x) @@ -98,24 +100,26 @@ NULL #' @export #' @describeIn normality_tests Bowman-Shenton test -bowmanshenton<-function(data){ - jtest<-.jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "bowmanShenton",as.numeric(data)) - return(.jd2r_test(jtest)) +bowmanshenton <- function(data) { + jtest <- .jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "bowmanShenton", as.numeric(data)) + return(.jd2r_test(jtest)) } #' @export #' @describeIn normality_tests Doornik-Hansen test -doornikhansen<-function(data){ - jtest<-.jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "doornikHansen",as.numeric(data)) - return(.jd2r_test(jtest)) +doornikhansen <- function(data) { + jtest <- .jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "doornikHansen", as.numeric(data)) + return(.jd2r_test(jtest)) } #' @export #' @describeIn normality_tests Jarque-Bera test -jarquebera<-function(data, k=0, sample=TRUE){ - jtest<-.jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "jarqueBera", - as.numeric(data), as.integer(k), as.logical(sample)) - return(.jd2r_test(jtest)) +jarquebera <- function(data, k = 0, sample = TRUE) { + jtest <- .jcall( + "jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "jarqueBera", + as.numeric(data), as.integer(k), as.logical(sample) + ) + return(.jd2r_test(jtest)) } #' Runs Tests around the mean or the median @@ -131,7 +135,7 @@ jarquebera<-function(data, k=0, sample=TRUE){ #' #' @examples #' x <- random_t(5, 1000) -#'# random values +#' # random values #' testofruns(x) #' testofupdownruns(x) #' # non-random values @@ -141,18 +145,22 @@ NULL #' @describeIn runstests Runs test around mean or median #' @export -testofruns<-function(data, mean=TRUE, number=TRUE){ - jtest<-.jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "testOfRuns", - as.numeric(data), as.logical(mean), as.logical(number)) - return(.jd2r_test(jtest)) +testofruns <- function(data, mean = TRUE, number = TRUE) { + jtest <- .jcall( + "jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "testOfRuns", + as.numeric(data), as.logical(mean), as.logical(number) + ) + return(.jd2r_test(jtest)) } #' @describeIn runstests up and down runs test #' @export -testofupdownruns<-function(data, number=TRUE){ - jtest<-.jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "testOfUpDownRuns", - as.numeric(data), as.logical(number)) - return(.jd2r_test(jtest)) +testofupdownruns <- function(data, number = TRUE) { + jtest <- .jcall( + "jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "testOfUpDownRuns", + as.numeric(data), as.logical(number) + ) + return(.jd2r_test(jtest)) } #' Autocorrelation Functions @@ -162,58 +170,66 @@ testofupdownruns<-function(data, number=TRUE){ #' @param nar number of AR lags used to compute inverse autocorrelations. #' #' @examples -#' x = ABS$X0.2.09.10.M +#' x <- ABS$X0.2.09.10.M #' autocorrelations(x) #' autocorrelations_partial(x) #' autocorrelations_inverse(x) #' @export -autocorrelations<-function(data, mean=TRUE, n=15){ - res <- .jcall("jdplus/toolkit/base/r/stats/Tests", "[D", "autocorrelations", - as.numeric(data), as.logical(mean), as.integer(n)) - names(res) <- seq_len(n) - return(res) +autocorrelations <- function(data, mean = TRUE, n = 15) { + res <- .jcall( + "jdplus/toolkit/base/r/stats/Tests", "[D", "autocorrelations", + as.numeric(data), as.logical(mean), as.integer(n) + ) + names(res) <- seq_len(n) + return(res) } #' @export #' @rdname autocorrelations -autocorrelations_partial<-function(data, mean=TRUE, n=15){ - res <- .jcall("jdplus/toolkit/base/r/stats/Tests", "[D", "partialAutocorrelations", - as.numeric(data), as.logical(mean), as.integer(n)) - names(res) <- seq_len(n) - return(res) +autocorrelations_partial <- function(data, mean = TRUE, n = 15) { + res <- .jcall( + "jdplus/toolkit/base/r/stats/Tests", "[D", "partialAutocorrelations", + as.numeric(data), as.logical(mean), as.integer(n) + ) + names(res) <- seq_len(n) + return(res) } #' @export #' @rdname autocorrelations -autocorrelations_inverse<-function(data, nar=30, n=15){ - res <- .jcall("jdplus/toolkit/base/r/stats/Tests", "[D", "inverseAutocorrelations", - as.numeric(data), as.integer(nar), as.integer(n)) - names(res) <- seq_len(n) - return(res) +autocorrelations_inverse <- function(data, nar = 30, n = 15) { + res <- .jcall( + "jdplus/toolkit/base/r/stats/Tests", "[D", "inverseAutocorrelations", + as.numeric(data), as.integer(nar), as.integer(n) + ) + names(res) <- seq_len(n) + return(res) } #' @export #' @describeIn normality_tests Skewness test -skewness<-function(data){ - jtest<-.jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "skewness",as.numeric(data)) - return(.jd2r_test(jtest)) +skewness <- function(data) { + jtest <- .jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "skewness", as.numeric(data)) + return(.jd2r_test(jtest)) } #' @export #' @describeIn normality_tests Kurtosis test -kurtosis<-function(data){ - jtest<-.jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "kurtosis",as.numeric(data)) - return(.jd2r_test(jtest)) +kurtosis <- function(data) { + jtest <- .jcall("jdplus/toolkit/base/r/stats/Tests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "kurtosis", as.numeric(data)) + return(.jd2r_test(jtest)) } -#' Title +#' Compute a robust median absolute deviation (MAD) #' -#' @param data -#' @param centile -#' @param medianCorrected +#' @param data The data for which we compute the robust deviation +#' @param centile The centile used to exclude extreme values (only the "centile" part of the data are is to compute the mad) +#' @param medianCorrected TRUE if the series is corrected for its median, FALSE if the median is supposed to be 0 #' -#' @return +#' @return The median absolute deviation #' @export #' #' @examples -mad<-function(data, centile=50, medianCorrected=TRUE){ - return(.jcall("jdplus/toolkit/base/r/stats/Tests", "D", "mad",as.numeric(data), as.numeric(centile), as.logical(medianCorrected))) +#' y <- rnorm(1000) +#' m <- rjd3toolkit::mad(y, centile = 70) +mad <- function(data, centile = 50, medianCorrected = TRUE) { + return(.jcall("jdplus/toolkit/base/r/stats/Tests", "D", "mad", as.numeric(data), as.numeric(centile), as.logical(medianCorrected))) } diff --git a/R/tests_seasonality.R b/R/tests_seasonality.R index 61cca5b4..166e4b7d 100644 --- a/R/tests_seasonality.R +++ b/R/tests_seasonality.R @@ -2,30 +2,72 @@ NULL -#' QS Seasonality Test -#' -#' QS (modified seasonal Ljung-Box) test. +#' QS (seasonal Ljung-Box) test. #' #' @param data the input data. -#' @param period Tested periodicity. -#' @param nyears Number of number of periods number of cycles considered in the test, at the end of the series: +#' @param period Tested periodicity. Can be missing if the input is a time series +#' @param nyears Number of periods or number of cycles considered in the test, at the end of the series: #' in periods (positive value) or years (negative values). #' By default (\code{nyears = 0}), the entire sample is used. +#' @param type 1 for positive autocorrelations, -1 for negative autocorrelations, +#' 0 for all autocorrelations. By default (\code{type = 1}) #' #' @return A `c("JD3_TEST", "JD3")` object (see [statisticaltest()] for details). #' @export #' #' @examples -#' seasonality_qs(ABS$X0.2.09.10.M, 12) +#' s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' seasonality_qs(s) #' seasonality_qs(random_t(2, 1000), 7) -seasonality_qs<-function(data, period, nyears=0){ - if (is.ts(data) && missing(period)) - period <- frequency(data) - jtest<-.jcall("jdplus/sa/base/r/SeasonalityTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "qsTest", - as.numeric(data), as.integer(period), as.integer(nyears)) - return(.jd2r_test(jtest)) +seasonality_qs <- function(data, period = NA, nyears = 0, type = 1) { + if (is.ts(data) && missing(period)) { + period <- frequency(data) + } + jtest <- .jcall( + "jdplus/sa/base/r/SeasonalityTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "qsTest", + as.numeric(data), as.integer(period), as.integer(nyears), as.integer((type)) + ) + return(.jd2r_test(jtest)) +} + +#' Modified QS Seasonality Test (Maravall) +#' +#' +#' @param data the input data. +#' @param period Tested periodicity. Can be missing if the input is a time series +#' @param nyears Number of periods or number of cycles considered in the test, at the end of the series: +#' in periods (positive value) or years (negative values). +#' By default (\code{nyears = 0}), the entire sample is used. +#' +#' @return The value of the test +#' @export +#' +#' @examples +#' s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' seasonality_modified_qs(s) +#' @details +#' Thresholds for p-values: p.9=2.49, p.95=3.83, p.99=7.06, p.999=11.88. +#' Computed on 100.000.000 random series (different lengths). +#' Remark: the length of the series has some impact on the p-values, mainly on +#' short series. Not critical. + +seasonality_modified_qs <- function(data, period = NA, nyears = 0) { + if (is.ts(data) && missing(period)) { + period <- frequency(data) + } + test <- .jcall( + "jdplus/sa/base/r/SeasonalityTests", "D", "modifiedQsTest", + as.numeric(data), as.integer(period), as.integer(nyears) + ) + return(test) } + +# PVALUES: P.9=2.49, P.95=3.83, P.99=7.06, P.999=11.88 +# Computed on 100.000.000 random series (different lengths) +# Remark: the length of the series has some impact on the p-values, mainly on +# short series. Not critical. + #' Kruskall-Wallis Seasonality Test #' #' @@ -36,14 +78,18 @@ seasonality_qs<-function(data, period, nyears=0){ #' @export #' #' @examples -#' seasonality_kruskalwallis(ABS$X0.2.09.10.M, 12) +#' s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' seasonality_kruskalwallis(s) #' seasonality_kruskalwallis(random_t(2, 1000), 7) -seasonality_kruskalwallis<-function(data, period, nyears=0){ - if (is.ts(data) && missing(period)) - period <- frequency(data) - jtest<-.jcall("jdplus/sa/base/r/SeasonalityTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "kruskalWallisTest", - as.numeric(data), as.integer(period), as.integer(nyears)) - return(.jd2r_test(jtest)) +seasonality_kruskalwallis <- function(data, period, nyears = 0) { + if (is.ts(data) && missing(period)) { + period <- frequency(data) + } + jtest <- .jcall( + "jdplus/sa/base/r/SeasonalityTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "kruskalWallisTest", + as.numeric(data), as.integer(period), as.integer(nyears) + ) + return(.jd2r_test(jtest)) } #' Periodogram Seasonality Test @@ -55,14 +101,18 @@ seasonality_kruskalwallis<-function(data, period, nyears=0){ #' @export #' #' @examples -#' seasonality_periodogram(ABS$X0.2.09.10.M, 12) +#' s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' seasonality_periodogram(s) #' seasonality_periodogram(random_t(2, 1000), 7) -seasonality_periodogram<-function(data, period, nyears=0){ - if (is.ts(data) && missing(period)) - period <- frequency(data) - jtest<-.jcall("jdplus/sa/base/r/SeasonalityTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "periodogramTest", - as.numeric(data), as.integer(period), as.integer(nyears)) - return(.jd2r_test(jtest)) +seasonality_periodogram <- function(data, period = NA, nyears = 0) { + if (is.ts(data) && missing(period)) { + period <- frequency(data) + } + jtest <- .jcall( + "jdplus/sa/base/r/SeasonalityTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "periodogramTest", + as.numeric(data), as.integer(period), as.integer(nyears) + ) + return(.jd2r_test(jtest)) } #' Friedman Seasonality Test @@ -74,12 +124,18 @@ seasonality_periodogram<-function(data, period, nyears=0){ #' @export #' #' @examples -seasonality_friedman<-function(data, period, nyears=0){ - if (is.ts(data) && missing(period)) - period <- frequency(data) - jtest<-.jcall("jdplus/sa/base/r/SeasonalityTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "friedmanTest", - as.numeric(data), as.integer(period), as.integer(nyears)) - return(.jd2r_test(jtest)) +#' s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' seasonality_friedman(s) +#' seasonality_friedman(random_t(2, 1000), 12) +seasonality_friedman <- function(data, period = NA, nyears = 0) { + if (is.ts(data) && missing(period)) { + period <- frequency(data) + } + jtest <- .jcall( + "jdplus/sa/base/r/SeasonalityTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "friedmanTest", + as.numeric(data), as.integer(period), as.integer(nyears) + ) + return(.jd2r_test(jtest)) } #' F-test on seasonal dummies @@ -91,18 +147,21 @@ seasonality_friedman<-function(data, period, nyears=0){ #' @export #' #' @examples -#' seasonality_f(ABS$X0.2.09.10.M, 12) +#' seasonality_f(ABS$X0.2.09.10.M, model = "D1") #' seasonality_f(random_t(2, 1000), 7) -seasonality_f<-function(data, - period, - model=c("AR", "D1", "WN"), - nyears=0){ - if (is.ts(data) && missing(period)) - period <- frequency(data) - model<-match.arg(model) - jtest<-.jcall("jdplus/sa/base/r/SeasonalityTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "fTest", - as.numeric(data), as.integer(period), model, as.integer(nyears)) - return(.jd2r_test(jtest)) +seasonality_f <- function(data, + period = NA, + model = c("AR", "D1", "WN"), + nyears = 0) { + if (is.ts(data) && missing(period)) { + period <- frequency(data) + } + model <- match.arg(model) + jtest <- .jcall( + "jdplus/sa/base/r/SeasonalityTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "fTest", + as.numeric(data), as.integer(period), model, as.integer(nyears) + ) + return(.jd2r_test(jtest)) } @@ -117,35 +176,87 @@ seasonality_f<-function(data, #' @export #' #' @examples -#' seasonality_combined(ABS$X0.2.09.10.M, 12) +#' s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' seasonality_combined(s) #' seasonality_combined(random_t(2, 1000), 7) -seasonality_combined<-function(data, period, firstperiod=cycle(data)[1], mul=TRUE){ - if (is.ts(data) && missing(period)) - period <- frequency(data) - jctest<-.jcall("jdplus/sa/base/r/SeasonalityTests", "Ljdplus/sa/base/core/tests/CombinedSeasonality;", "combinedTest", - as.numeric(data), as.integer(period), as.integer(firstperiod-1), as.logical(mul)) - q<-.jcall("jdplus/sa/base/r/SeasonalityTests", "[B", "toBuffer", jctest) - p<-RProtoBuf::read(sa.CombinedSeasonalityTest, q) - return(list( - seasonality=.enum_extract(sa.IdentifiableSeasonality, p$seasonality), - kruskalwallis=.p2r_test(p$kruskal_wallis), - stable=.p2r_anova(p$stable_seasonality), - evolutive=.p2r_anova(p$evolutive_seasonality))) +seasonality_combined <- function(data, period = NA, firstperiod = cycle(data)[1], mul = TRUE) { + if (is.ts(data) && missing(period)) { + period <- frequency(data) + } + jctest <- .jcall( + "jdplus/sa/base/r/SeasonalityTests", "Ljdplus/sa/base/core/tests/CombinedSeasonality;", "combinedTest", + as.numeric(data), as.integer(period), as.integer(firstperiod - 1), as.logical(mul) + ) + q <- .jcall("jdplus/sa/base/r/SeasonalityTests", "[B", "toBuffer", jctest) + p <- RProtoBuf::read(sa.CombinedSeasonalityTest, q) + + output <- list( + seasonality = .enum_extract(sa.IdentifiableSeasonality, p$seasonality), + kruskalwallis = .p2r_test(p$kruskal_wallis), + stable = .p2r_anova(p$stable_seasonality), + evolutive = .p2r_anova(p$evolutive_seasonality) + ) + return(output) } -#' Seasonal Canova-Hansen test +#' Canova-Hansen test using trigonometric variables #' #' @inheritParams seasonality_qs -#' @param p0 Initial periodicity (included). -#' @param p1 Final periodicity (included). -#' @param np Number of periodicities equally spaced in \eqn{[p_0,p_1]}. +#' @param periods Periodicities. +#' @param lag1 Lagged variable in the regression model. +#' @param kernel Kernel used to compute the robust Newey-West covariance matrix. +#' @param order The truncation parameter used to compute the robust Newey-West covariance matrix. #' @param original `TRUE` for original algorithm, `FALSE` for solution proposed by T. Proietti (based on Ox code). #' #' @export #' #' @examples -seasonality_canovahansen<-function(data, p0, p1, np, original=FALSE){ - jtest<-.jcall("jdplus/sa/base/r/SeasonalityTests", "[D", "canovaHansenTest", - as.numeric(data), as.numeric(p0), as.numeric(p1), as.integer(np), as.logical(original)) - return(jtest) +#' s <- log(ABS$X0.2.20.10.M) +#' freqs <- seq(0.01, 0.5, 0.001) +#' plot(seasonality_canovahansen_trigs(s, 1 / freqs, original = FALSE), type = "l") +seasonality_canovahansen_trigs <- function(data, periods, lag1 = TRUE, + kernel = c("Bartlett", "Square", "Welch", "Tukey", "Hamming", "Parzen"), + order = NA, original = FALSE) { + kernel <- match.arg(kernel) + if (is.na(order)) order <- -1 + + jtest <- .jcall( + "jdplus/sa/base/r/SeasonalityTests", "[D", "canovaHansenTrigs", + as.numeric(data), .jarray(periods), + as.logical(lag1), kernel, as.integer(order), as.logical(original) + ) + return(jtest) +} + +#' Canova-Hansen seasonality test +#' +#' @inheritParams seasonality_qs +#' @param type Trigonometric variables, seasonal dummies or seasonal contrasts. +#' @param lag1 Lagged variable in the regression model. +#' @param kernel Kernel used to compute the robust Newey-West covariance matrix. +#' @param order The truncation parameter used to compute the robust Newey-West covariance matrix. +#' @param start Position of the first observation of the series +#' @return list with the FTest on seasonal variables, the joint test and the details for the stability of the different seasonal variables +#' @export +#' +#' +#' @examples +#' s <- log(ABS$X0.2.20.10.M) +#' seasonality_canovahansen(s, 12, type = "Contrast") +#' seasonality_canovahansen(s, 12, type = "Trigonometric") +seasonality_canovahansen <- function(data, period, type = c("Contrast", "Dummy", "Trigonometric"), lag1 = TRUE, + kernel = c("Bartlett", "Square", "Welch", "Tukey", "Hamming", "Parzen"), + order = NA, start = 1) { + type <- match.arg(type) + kernel <- match.arg(kernel) + if (is.na(order)) order <- -1 + + q <- .jcall( + "jdplus/sa/base/r/SeasonalityTests", "[D", "canovaHansen", + as.numeric(data), as.integer(period), + type, as.logical(lag1), + kernel, as.integer(order), as.integer(start - 1) + ) + last <- length(q) + return(list(seasonality = list(value = q[last - 1], pvalue = q[last]), joint = q[last - 2], details = q[-c(last - 2, last - 1, last)])) } diff --git a/R/tests_td.R b/R/tests_td.R index 8de9858f..8dc009b9 100644 --- a/R/tests_td.R +++ b/R/tests_td.R @@ -46,25 +46,63 @@ NULL #' @examples #' td_f(ABS$X0.2.09.10.M) #' @export -td_f<-function(s, model=c("D1", "DY", "DYD1", "WN", "AIRLINE", "R011", "R100"), nyears=0){ - model<-match.arg(model) - jts<-.r2jd_tsdata(s) - jtest<-.jcall("jdplus/toolkit/base/r/modelling/TradingDaysTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "fTest", - jts, model, as.integer(nyears)) - return(.jd2r_test(jtest)) +td_f <- function(s, model = c("D1", "DY", "DYD1", "WN", "AIRLINE", "R011", "R100"), nyears = 0) { + model <- match.arg(model) + jts <- .r2jd_tsdata(s) + jtest <- .jcall( + "jdplus/toolkit/base/r/modelling/TradingDaysTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "fTest", + jts, model, as.integer(nyears) + ) + return(.jd2r_test(jtest)) } -#' Canova-Hansen Trading Days test +#' Canova-Hansen test for stable trading days #' #' @inheritParams td_f -#' @param differencing differencing lags. +#' @param differencing Differencing lags. +#' @param kernel Kernel used to compute the robust covariance matrix. +#' @param order The truncation parameter used to compute the robust covariance matrix. #' -#' @return +#' @return list with the ftest on td, the joint test and the details for the stability of the different days (starting with Mondays). #' @export #' #' @examples -td_ch<-function(s, differencing){ - jts<-.r2jd_tsdata(s) - return(.jcall("jdplus/toolkit/base/r/modelling/TradingDaysTests", "[D", "chTest", - jts, .jarray(as.integer(differencing)))) +#' s <- log(ABS$X0.2.20.10.M) +#' td_canovahansen(s, c(1, 12)) +td_canovahansen <- function(s, differencing, kernel = c("Bartlett", "Square", "Welch", "Tukey", "Hamming", "Parzen"), + order = NA) { + kernel <- match.arg(kernel) + if (is.na(order)) order <- -1 + jts <- .r2jd_tsdata(s) + q <- .jcall( + "jdplus/toolkit/base/r/modelling/TradingDaysTests", "[D", "canovaHansen", + jts, .jarray(as.integer(differencing)), kernel, as.integer(order) + ) + + last <- length(q) + return(list(td = list(value = q[last - 1], pvalue = q[last]), joint = q[last - 2], details = q[-c(last - 2, last - 1, last)])) +} + +#' Likelihood ratio test on time varying trading days +#' +#' @param s The tested time series +#' @param groups The groups of days used to generate the regression variables. +#' @param contrasts The covariance matrix of the multivariate random walk model +#' used for the time-varying coefficients are related to the contrasts if TRUE, +#' on the actual number of days (all the days are driven by the same variance) if FALSE. +#' +#' @return A Chi2 test +#' @export +#' +#' @examples +#' s <- log(ABS$X0.2.20.10.M) +#' td_timevarying(s) +td_timevarying <- function(s, groups = c(1, 2, 3, 4, 5, 6, 0), contrasts = FALSE) { + jts <- .r2jd_tsdata(s) + igroups <- as.integer(groups) + jtest <- .jcall( + "jdplus/toolkit/base/r/modelling/TradingDaysTests", "Ljdplus/toolkit/base/api/stats/StatisticalTest;", "timeVaryingTradingDaysTest", + jts, igroups, as.logical(contrasts) + ) + return(.jd2r_test(jtest)) } diff --git a/R/timeseries.R b/R/timeseries.R index 45d0a159..8a5ad8e5 100644 --- a/R/timeseries.R +++ b/R/timeseries.R @@ -17,53 +17,52 @@ NULL #' @export #' #' @examples -#' s = ABS$X0.2.09.10.M +#' s <- ABS$X0.2.09.10.M #' # Annual sum #' aggregate(s, nfreq = 1, conversion = "Sum") # first and last years removed #' aggregate(s, nfreq = 1, conversion = "Sum", complete = FALSE) #' # Quarterly mean #' aggregate(s, nfreq = 4, conversion = "Average") -aggregate<-function(s, nfreq=1, - conversion=c("Sum", "Average", "First", "Last", "Min", "Max"), - complete=TRUE) { - UseMethod("aggregate", s) +aggregate <- function(s, nfreq = 1, + conversion = c("Sum", "Average", "First", "Last", "Min", "Max"), + complete = TRUE) { + UseMethod("aggregate", s) } #' @export -aggregate.default<-function(s, nfreq=1, - conversion=c("Sum", "Average", "First", "Last", "Min", "Max"), - complete=TRUE){ - conversion <- match.arg(conversion) - if (is.null(s)){ - return(NULL) - } - jd_s<-.r2jd_tsdata(s) - jd_agg<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/TsData;", "aggregate", jd_s, as.integer(nfreq), conversion, complete) - if (is.jnull(jd_agg)){ - return(NULL) - } - else { - return(.jd2r_tsdata(jd_agg)) - } +aggregate.default <- function(s, nfreq = 1, + conversion = c("Sum", "Average", "First", "Last", "Min", "Max"), + complete = TRUE) { + conversion <- match.arg(conversion) + if (is.null(s)) { + return(NULL) + } + jd_s <- .r2jd_tsdata(s) + jd_agg <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/TsData;", "aggregate", jd_s, as.integer(nfreq), conversion, complete) + if (is.jnull(jd_agg)) { + return(NULL) + } else { + return(.jd2r_tsdata(jd_agg)) + } } #' @export -aggregate.matrix <- function(s, nfreq=1, - conversion=c("Sum", "Average", "First", "Last", "Min", "Max"), - complete=TRUE) { - res <- do.call(cbind, lapply(seq_len(ncol(s)), function(i){ - aggregate(s[,i], nfreq = nfreq, conversion = conversion, complete = complete) - })) - colnames(res) <- colnames(s) - res +aggregate.matrix <- function(s, nfreq = 1, + conversion = c("Sum", "Average", "First", "Last", "Min", "Max"), + complete = TRUE) { + res <- do.call(cbind, lapply(seq_len(ncol(s)), function(i) { + aggregate(s[, i], nfreq = nfreq, conversion = conversion, complete = complete) + })) + colnames(res) <- colnames(s) + res } #' @export -aggregate.data.frame <- function(s, nfreq=1, - conversion=c("Sum", "Average", "First", "Last", "Min", "Max"), - complete=TRUE) { - res <- base::list2DF(lapply(seq_len(ncol(s)), function(i){ - aggregate(s[,i], nfreq = nfreq, conversion = conversion, complete = complete) - })) - colnames(res) <- colnames(s) - res +aggregate.data.frame <- function(s, nfreq = 1, + conversion = c("Sum", "Average", "First", "Last", "Min", "Max"), + complete = TRUE) { + res <- base::list2DF(lapply(seq_len(ncol(s)), function(i) { + aggregate(s[, i], nfreq = nfreq, conversion = conversion, complete = complete) + })) + colnames(res) <- colnames(s) + res } #' Removal of missing values at the beginning/end @@ -77,20 +76,18 @@ aggregate.data.frame <- function(s, nfreq=1, #' y <- window(ABS$X0.2.09.10.M, start = 1982, end = 2018, extend = TRUE) #' y #' clean_extremities(y) -clean_extremities<-function(s){ - if (is.null(s)){ - return(NULL) - } - jd_s<-.r2jd_tsdata(s) - jd_scleaned<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/TsData;", "cleanExtremities", jd_s) - - if (is.jnull(jd_scleaned)){ - return(NULL) - } - else { - return(.jd2r_tsdata(jd_scleaned)) - } +clean_extremities <- function(s) { + if (is.null(s)) { + return(NULL) + } + jd_s <- .r2jd_tsdata(s) + jd_scleaned <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/TsData;", "cleanExtremities", jd_s) + if (is.jnull(jd_scleaned)) { + return(NULL) + } else { + return(.jd2r_tsdata(jd_scleaned)) + } } @@ -103,48 +100,49 @@ clean_extremities<-function(s){ #' @return The interpolated series #' @export #' -ts_interpolate<-function(s, method=c("airline", "average")){ - UseMethod("ts_interpolate", s) +ts_interpolate <- function(s, method = c("airline", "average")) { + UseMethod("ts_interpolate", s) } #' @export -ts_interpolate.default<-function(s, method=c("airline", "average")){ - method<-match.arg(method) - if (is.null(s)){ - return(NULL) - } - jd_s<-.r2jd_tsdata(s) - if (method == "airline"){ - jd_si<-.jcall("jdplus/toolkit/base/r/modelling/Interpolation", "Ljdplus/toolkit/base/api/timeseries/TsData;", "airlineInterpolation", jd_s) - return(.jd2r_tsdata(jd_si)) - } else if (method == "average"){ - jd_si<-.jcall("jdplus/toolkit/base/r/modelling/Interpolation", "Ljdplus/toolkit/base/api/timeseries/TsData;", "averageInterpolation", jd_s) - return(.jd2r_tsdata(jd_si)) - } else - return(NULL) +ts_interpolate.default <- function(s, method = c("airline", "average")) { + method <- match.arg(method) + if (is.null(s)) { + return(NULL) + } + jd_s <- .r2jd_tsdata(s) + if (method == "airline") { + jd_si <- .jcall("jdplus/toolkit/base/r/modelling/Interpolation", "Ljdplus/toolkit/base/api/timeseries/TsData;", "airlineInterpolation", jd_s) + return(.jd2r_tsdata(jd_si)) + } else if (method == "average") { + jd_si <- .jcall("jdplus/toolkit/base/r/modelling/Interpolation", "Ljdplus/toolkit/base/api/timeseries/TsData;", "averageInterpolation", jd_s) + return(.jd2r_tsdata(jd_si)) + } else { + return(NULL) + } } #' @export -ts_interpolate.matrix <- function(s, method=c("airline", "average")){ - result <- s - for (i in seq_len(ncol(s))){ - result[, i] <- ts_interpolate(s[,i], method = method) - } - result +ts_interpolate.matrix <- function(s, method = c("airline", "average")) { + result <- s + for (i in seq_len(ncol(s))) { + result[, i] <- ts_interpolate(s[, i], method = method) + } + result } #' @export -ts_interpolate.data.frame <- function(s, method=c("airline", "average")){ - result <- s - for (i in seq_len(ncol(s))){ - result[, i] <- ts_interpolate(s[,i], method = method) - } - result +ts_interpolate.data.frame <- function(s, method = c("airline", "average")) { + result <- s + for (i in seq_len(ncol(s))) { + result[, i] <- ts_interpolate(s[, i], method = method) + } + result } #' Multiplicative adjustment of a time series for leap year / length of periods #' #' @param s The original time series #' @param method -#' LeapYear: correction for leap year -#' LengthOfPeriod: correction for the length of periods +#' \code{"LeapYear"}: correction for leap year +#' \code{"LengthOfPeriod"}: correction for the length of periods #' @param reverse Adjustment or reverse operation #' @return The interpolated series #' @@ -155,94 +153,95 @@ ts_interpolate.data.frame <- function(s, method=c("airline", "average")){ #' ts_adjust(y) #' # with reverse we can find the #' all.equal(ts_adjust(ts_adjust(y), reverse = TRUE), y) -ts_adjust<-function(s, method=c("LeapYear", "LengthOfPeriod"), reverse = FALSE){ - UseMethod("ts_adjust", s) +ts_adjust <- function(s, method = c("LeapYear", "LengthOfPeriod"), reverse = FALSE) { + UseMethod("ts_adjust", s) } #' @export -ts_adjust.default<-function(s, method=c("LeapYear", "LengthOfPeriod"), reverse = FALSE){ - method<-match.arg(method) - if (is.null(s)){ - return(NULL) - } - jd_s<-.r2jd_tsdata(s) - jd_st<-.jcall("jdplus/toolkit/base/r/modelling/Transformation", "Ljdplus/toolkit/base/api/timeseries/TsData;", "adjust", jd_s, method, as.logical(reverse)) - if (is.jnull(jd_st)){ - return(NULL) - } - else { - return(.jd2r_tsdata(jd_st)) - } +ts_adjust.default <- function(s, method = c("LeapYear", "LengthOfPeriod"), reverse = FALSE) { + method <- match.arg(method) + if (is.null(s)) { + return(NULL) + } + jd_s <- .r2jd_tsdata(s) + jd_st <- .jcall("jdplus/toolkit/base/r/modelling/Transformation", "Ljdplus/toolkit/base/api/timeseries/TsData;", "adjust", jd_s, method, as.logical(reverse)) + if (is.jnull(jd_st)) { + return(NULL) + } else { + return(.jd2r_tsdata(jd_st)) + } } #' @export -ts_adjust.matrix <- function(s, method=c("LeapYear", "LengthOfPeriod"), reverse = FALSE){ - result <- s - for (i in seq_len(ncol(s))){ - result[, i] <- ts_adjust(s[,i], method = method, reverse = reverse) - } - result +ts_adjust.matrix <- function(s, method = c("LeapYear", "LengthOfPeriod"), reverse = FALSE) { + result <- s + for (i in seq_len(ncol(s))) { + result[, i] <- ts_adjust(s[, i], method = method, reverse = reverse) + } + result } #' @export -ts_adjust.data.frame <- function(s, method=c("LeapYear", "LengthOfPeriod"), reverse = FALSE){ - result <- s - for (i in seq_len(ncol(s))){ - result[, i] <- ts_adjust(s[,i], method = method, reverse = reverse) - } - result +ts_adjust.data.frame <- function(s, method = c("LeapYear", "LengthOfPeriod"), reverse = FALSE) { + result <- s + for (i in seq_len(ncol(s))) { + result[, i] <- ts_adjust(s[, i], method = method, reverse = reverse) + } + result } -#' Title +#' Provides a list of dates corresponding to each period of the given time series #' -#' @param ts -#' @param pos +#' @param ts A time series +#' @param pos The position of the first considered period. #' -#' @return +#' @return A list of the starting dates of each period #' @export #' -#' @examples -daysOf<-function(ts, pos=0){ - start<-start(ts) - jdom<-.r2jd_tsdomain(frequency(ts), start[1], start[2], length(ts)) - days<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[S", "daysOf",jdom, as.integer(pos)) - return(as.Date(days)) +#' @examples daysOf(retail$BookStores) +daysOf <- function(ts, pos = 1) { + start <- start(ts) + jdom <- .r2jd_tsdomain(frequency(ts), start[1], start[2], length(ts)) + days <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[S", "daysOf", jdom, as.integer(pos - 1)) + return(as.Date(days)) } -#' Title +#' Creates a time series object #' -#' @param source -#' @param id -#' @param type +#' @param source Source of the time series +#' @param id Identifier of the time series (source-dependent) +#' @param type Type of the requested information (Data, Metadata...). +#' All by default. #' -#' @return +#' @return An object of type "JD3_TS". List containing the identifiers, +#' the data and the metadata #' @export -#' -#' @examples -to_ts<-function(source, id, type="All"){ - jmoniker<-.jcall("jdplus/toolkit/base/api/timeseries/TsMoniker", "Ljdplus/toolkit/base/api/timeseries/TsMoniker;", "of", source, id) - jts<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTs", jmoniker, type) - bytes<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[B", "toBuffer", jts) - p<-RProtoBuf::read(jd3.Ts, bytes) - return(.p2r_ts(p)) +to_ts <- function(source, id, type = "All") { + jmoniker <- .jcall("jdplus/toolkit/base/api/timeseries/TsMoniker", "Ljdplus/toolkit/base/api/timeseries/TsMoniker;", "of", source, id) + jts <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTs", jmoniker, type) + bytes <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[B", "toBuffer", jts) + p <- RProtoBuf::read(jd3.Ts, bytes) + return(.p2r_ts(p)) } -#' Title +#' Creates a collection of time series #' -#' @param source -#' @param id -#' @param type +#' @param source Source of the collection of time series +#' @param id Identifier of the collection of time series (source-dependent) +#' @param type Type of the requested information (Data, Metadata...). +#' All by default. #' -#' @return +#' @return An object of type "JD3_TSCOLLECTION". List containing the identifiers, +#' the metadata and all the series. #' @export #' #' @examples -to_tscollection<-function(source, id, type="All"){ - jmoniker<-.jcall("jdplus/toolkit/base/api/timeseries/TsMoniker", "Ljdplus/toolkit/base/api/timeseries/TsMoniker;", "of", source, id) - jtscoll<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTsCollection", jmoniker, type) - bytes<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[B", "toBuffer", jtscoll) - p<-RProtoBuf::read(jd3.TsCollection, bytes) - return(.p2r_tscollection(p)) +to_tscollection <- function(source, id, type = "All") { + jmoniker <- .jcall("jdplus/toolkit/base/api/timeseries/TsMoniker", "Ljdplus/toolkit/base/api/timeseries/TsMoniker;", "of", source, id) + jtscoll <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTsCollection", jmoniker, type) + bytes <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[B", "toBuffer", jtscoll) + p <- RProtoBuf::read(jd3.TsCollection, bytes) + return(.p2r_tscollection(p)) } -#' Promote a R time series to a "full" ts of jdemetra +#' Promote a R time series to a "full" \code{ts} of JDemetra+ #' #' @param s R time series #' @param name name of the series @@ -251,36 +250,36 @@ to_tscollection<-function(source, id, type="All"){ #' @export #' #' @examples -#' s<-ABS$X0.2.09.10.M -#' t<-data_to_ts(s,"test") -data_to_ts<-function(s, name){ - jts<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTs", .r2jd_tsdata(s), name) - bytes<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[B", "toBuffer", jts) - p<-RProtoBuf::read(jd3.Ts, bytes) - return(.p2r_ts(p)) +#' s <- ABS$X0.2.09.10.M +#' t <- data_to_ts(s, "test") +data_to_ts <- function(s, name) { + jts <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTs", .r2jd_tsdata(s), name) + bytes <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "[B", "toBuffer", jts) + p <- RProtoBuf::read(jd3.Ts, bytes) + return(.p2r_ts(p)) } #' @export #' @rdname jd3_utilities -.r2jd_tmp_ts<-function(s, name){ - jts<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTs", .r2jd_tsdata(s), name) - return(jts) +.r2jd_tmp_ts <- function(s, name) { + jts <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTs", .r2jd_tsdata(s), name) + return(jts) } #' @export #' @rdname jd3_utilities -.r2jd_make_ts<-function(source, id, type="All"){ - jmoniker<-.jcall("jdplus/toolkit/base/api/timeseries/TsMoniker", "Ljdplus/toolkit/base/api/timeseries/TsMoniker;", "of", source, id) - jts<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTs", jmoniker, type) - return(jts) +.r2jd_make_ts <- function(source, id, type = "All") { + jmoniker <- .jcall("jdplus/toolkit/base/api/timeseries/TsMoniker", "Ljdplus/toolkit/base/api/timeseries/TsMoniker;", "of", source, id) + jts <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTs", jmoniker, type) + return(jts) } #' @export #' @rdname jd3_utilities -.r2jd_make_tscollection<-function(source, id, type="All"){ - jmoniker<-.jcall("jdplus/toolkit/base/api/timeseries/TsMoniker", "Ljdplus/toolkit/base/api/timeseries/TsMoniker;", "of", source, id) - jtscoll<-.jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTsCollection", jmoniker, type) - return(jtscoll) +.r2jd_make_tscollection <- function(source, id, type = "All") { + jmoniker <- .jcall("jdplus/toolkit/base/api/timeseries/TsMoniker", "Ljdplus/toolkit/base/api/timeseries/TsMoniker;", "of", source, id) + jtscoll <- .jcall("jdplus/toolkit/base/r/timeseries/TsUtility", "Ljdplus/toolkit/base/api/timeseries/Ts;", "makeTsCollection", jmoniker, type) + return(jtscoll) } #' Title @@ -288,19 +287,23 @@ data_to_ts<-function(s, name){ #' @param values Values of the time series #' @param dates Dates of the values (could be any date inside the considered period) #' -#' @return A ts object. The frequency will be identified automatically and missing values will be added in need be. +#' @return A \code{ts} object. The frequency will be identified automatically and missing values will be added in need be. #' The identified frequency will be the lowest frequency that match the figures. #' The provided data can contain missing values (NA) #' @export #' #' @examples #' # Annual series -#' s<-tsdata_of(c(1,2,3,4), c("1990-01-01", "1995-01-01", "1996-01-01", "2000-11-01")) +#' s <- tsdata_of(c(1, 2, 3, 4), c("1990-01-01", "1995-01-01", "1996-01-01", +#' "2000-11-01")) #' # Quarterly series -#' t<-tsdata_of(c(1,2,3,NA,4), c("1990-01-01", "1995-01-01", "1996-01-01", "2000-08-01", "2000-11-01")) -tsdata_of<-function(values, dates){ - jtsdata<-.jcall("jdplus/toolkit/base/r/timeseries/TsDataCollector", "Ljdplus/toolkit/base/api/timeseries/TsData;", - "of", as.numeric(values), as.character(dates)) +#' t <- tsdata_of(c(1, 2, 3, NA, 4), c("1990-01-01", "1995-01-01", "1996-01-01", +#' "2000-08-01", "2000-11-01")) +tsdata_of <- function(values, dates) { + jtsdata <- .jcall( + "jdplus/toolkit/base/r/timeseries/TsDataCollector", "Ljdplus/toolkit/base/api/timeseries/TsData;", + "of", as.numeric(values), as.character(dates) + ) return(.jd2r_tsdata(jtsdata)) } @@ -314,8 +317,8 @@ tsdata_of<-function(values, dates){ #' @export #' #' @examples -compare_annual_totals<-function(raw, sa){ - jsa<-.r2jd_tsdata(sa) - jraw<-.r2jd_tsdata(raw) +compare_annual_totals <- function(raw, sa) { + jsa <- .r2jd_tsdata(sa) + jraw <- .r2jd_tsdata(raw) return(.jcall("jdplus/sa/base/r/SaUtility", "D", "compareAnnualTotals", jraw, jsa)) } diff --git a/R/utils.R b/R/utils.R index f46727f5..b68020e1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -2,39 +2,60 @@ #' @importFrom methods is NULL -ymd<-function(y, m, d=1){ - return(as.Date(sprintf("%04i-%02i-%02i", y, m, d))) +#' Retail trade statistics in Australia +#' +#' @source ABS +"ABS" + +#' US Retail trade statistics +#' +#' @source US-Census Bureau +"retail" + +#' Belgian exports to European countries +#' +#' @source NBB +"Exports" + +#' Belgian imports from European countries +#' +#' @source NBB +"Imports" + + +ymd <- function(y, m, d = 1) { + return(as.Date(sprintf("%04i-%02i-%02i", y, m, d))) } -yearOf<-function(s){ - return(as.integer(substr(s, 1, 4))) +yearOf <- function(s) { + return(as.integer(substr(s, 1, 4))) } -monthOf<-function(s){ - return(as.integer(substr(s, 6, 7))) +monthOf <- function(s) { + return(as.integer(substr(s, 6, 7))) } -dayOf<-function(s){ - return(as.integer(substr(s, 9, 10))) +dayOf <- function(s) { + return(as.integer(substr(s, 9, 10))) } -dateOf<-function(year, month, day){ - d<-jd3.Date$new() - d$year<-year - d$month<-month - d$day<-day - return(d) +dateOf <- function(year, month, day) { + d <- jd3.Date$new() + d$year <- year + d$month <- month + d$day <- day + return(d) } -parseDate<-function(s){ - d<-jd3.Date$new() - d$year<-yearOf(s) - d$month<-monthOf(s) - d$day<-dayOf(s) - return(d) +parseDate <- function(s) { + d <- jd3.Date$new() + d$year <- yearOf(s) + d$month <- monthOf(s) + d$day <- dayOf(s) + return(d) } #' Title #' #' @export -reload_dictionaries<-function(){ - .jcall("jdplus/toolkit/base/api/information/InformationExtractors", "V", "reloadExtractors") +reload_dictionaries <- function() { + .jcall("jdplus/toolkit/base/api/information/InformationExtractors", "V", "reloadExtractors") } @@ -42,41 +63,43 @@ reload_dictionaries<-function(){ NULL -.p2r_anova<-function(p){ - return(list(SSM=p$SSM, dfM=p$dfm, SSR=p$SSR, dfR=p$dfr, test=test_anova(p$SSM, p$dfm, p$SSR, p$dfr))) +.p2r_anova <- function(p) { + return(list(SSM = p$SSM, dfM = p$dfm, SSR = p$SSR, dfR = p$dfr, test = test_anova(p$SSM, p$dfm, p$SSR, p$dfr))) } -test_anova<-function(ssm, dfm, ssr, dfr){ - val<-(ssm/dfm)*(dfr/ssr) - desc<-paste0("F(",dfm,",",dfr,")") - pval<-1-pf(val, dfm, dfr) - return(statisticaltest(val, pval, desc)) +test_anova <- function(ssm, dfm, ssr, dfr) { + val <- (ssm / dfm) * (dfr / ssr) + desc <- paste0("F(", dfm, ",", dfr, ")") + pval <- 1 - pf(val, dfm, dfr) + return(statisticaltest(val, pval, desc)) } -#' Title +#' Information on the (log-)likelihood #' -#' @param nobs -#' @param neffectiveobs -#' @param nparams -#' @param ll -#' @param adjustedll -#' @param aic -#' @param aicc -#' @param bic -#' @param bicc -#' @param ssq +#' @param nobs Number of observation +#' @param neffectiveobs Number of effective observations. NA if it is the same as nobs. +#' @param nparams Number of hyper-parameters +#' @param ll Log-likelihood +#' @param adjustedll Adjusted log-likelihood when the series has been transformed +#' @param aic AIC +#' @param aicc AICC +#' @param bic BIC +#' @param bicc BIC corrected for the length +#' @param ssq Sum of the squared residuals #' -#' @return #' @export #' #' @examples -likelihood<-function(nobs, neffectiveobs=NA, nparams=0, ll, adjustedll=NA, aic, aicc, bic, bicc, ssq){ - - if (is.na(neffectiveobs)) neffectiveobs<-obs - if (is.na(adjustedll)) adjustedll<-ll +.likelihood <- function(nobs, neffectiveobs = NA, nparams = 0, ll, adjustedll = NA, aic, aicc, bic, bicc, ssq) { + if (is.na(neffectiveobs)) neffectiveobs <- nobs + if (is.na(adjustedll)) adjustedll <- ll - return(structure(list(nobs=nobs, neffectiveobs=neffectiveobs, nparams=nparams, - ll=ll, adjustedll=adjustedll, - aic=aic, aicc=aicc, bic=bic, bicc=bicc, ssq=ssq), - class = "JD3_LIKELIHOOD")) + return(structure( + list( + nobs = nobs, neffectiveobs = neffectiveobs, nparams = nparams, + ll = ll, adjustedll = adjustedll, + aic = aic, aicc = aicc, bic = bic, bicc = bicc, ssq = ssq + ), + class = "JD3_LIKELIHOOD" + )) } diff --git a/R/variables.R b/R/variables.R index 01d66583..daaa5c8b 100644 --- a/R/variables.R +++ b/R/variables.R @@ -16,33 +16,33 @@ NULL #' More information on calendar correction in JDemetra+ online documentation: #' \url{https://jdemetra-new-documentation.netlify.app/a-calendar-correction} #' @examples -#' #Monthly regressor, five-year long, duration 8 days, effect finishing on Easter Monday -#' ee<-easter_variable(12, c(2020,1),length=5*12,duration=8, endpos=1) +#' # Monthly regressor, five-year long, duration 8 days, effect finishing on Easter Monday +#' ee <- easter_variable(12, c(2020, 1), length = 5 * 12, duration = 8, endpos = 1) #' @export -easter_variable<-function(frequency, start, length, s, duration=6, endpos=-1, - correction=c("Simple", "PreComputed", "Theoretical", "None")){ - correction<-match.arg(correction) - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "easter", jdom, as.integer(duration), as.integer(endpos), correction) - return(ts(data, frequency = frequency, start= start)) +easter_variable <- function(frequency, start, length, s, duration = 6, endpos = -1, + correction = c("Simple", "PreComputed", "Theoretical", "None")) { + correction <- match.arg(correction) + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + data <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "easter", jdom, as.integer(duration), as.integer(endpos), correction) + return(ts(data, frequency = frequency, start = start)) } #' @rdname easter_variable #' @export -julianeaster_variable<-function(frequency, start, length, s, duration=6){ - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "julianEaster", jdom, as.integer(duration)) - return(ts(data, frequency = frequency, start= start)) +julianeaster_variable <- function(frequency, start, length, s, duration = 6) { + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + data <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "julianEaster", jdom, as.integer(duration)) + return(ts(data, frequency = frequency, start = start)) } #' Leap Year regressor @@ -61,19 +61,19 @@ julianeaster_variable<-function(frequency, start, length, s, duration=6){ #' #' @examples #' # Leap years occur in year 2000, 2004, 2008 and 2012 -#' lp_variable(4, start = c(2000, 1), length = 4*13) -#' lper<-lp_variable(12,c(2000,1),length=10*12,type ="LengthOfPeriod") -lp_variable<-function(frequency, start, length, s, type=c("LeapYear", "LengthOfPeriod")){ - type<-match.arg(type) - lp<-type == "LeapYear" - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "leapYear", jdom, as.logical(lp)) - return(ts(data, frequency = frequency, start= start)) +#' lp_variable(4, start = c(2000, 1), length = 4 * 13) +#' lper <- lp_variable(12, c(2000, 1), length = 10 * 12, type = "LengthOfPeriod") +lp_variable <- function(frequency, start, length, s, type = c("LeapYear", "LengthOfPeriod")) { + type <- match.arg(type) + lp <- type == "LeapYear" + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + data <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "leapYear", jdom, as.logical(lp)) + return(ts(data, frequency = frequency, start = start)) } #' Generating Outlier regressors @@ -103,79 +103,83 @@ lp_variable<-function(frequency, start, length, s, type=c("LeapYear", "LengthOfP #' @export #' #' @examples -#' #Outliers in February 2002 -#' ao <- ao_variable(12, c(2000,1), length = 12*4, date = "2002-02-01") -#' ls <- ls_variable(12, c(2000,1), length = 12*4, date = "2002-02-01") -#' tc <- tc_variable(12, c(2000,1), length = 12*4, date = "2002-02-01") -#' so <- so_variable(12, c(2000,1), length = 12*4, date = "2002-02-01") -#' plot.ts(ts.union(ao, ls, tc, so), plot.type = "single", -#' col = c("black", "orange", "green", "gray")) +#' # Outliers in February 2002 +#' ao <- ao_variable(12, c(2000, 1), length = 12 * 4, date = "2002-02-01") +#' ls <- ls_variable(12, c(2000, 1), length = 12 * 4, date = "2002-02-01") +#' tc <- tc_variable(12, c(2000, 1), length = 12 * 4, date = "2002-02-01") +#' so <- so_variable(12, c(2000, 1), length = 12 * 4, date = "2002-02-01") +#' plot.ts(ts.union(ao, ls, tc, so), +#' plot.type = "single", +#' col = c("black", "orange", "green", "gray") +#' ) #' @name outliers_variables #' @rdname outliers_variables -ao_variable<-function(frequency, start, length, s, pos, date=NULL){ - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - if (is.null(date)){ - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "ao", jdom, as.integer(pos-1)) - } else { - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "ao", jdom, as.character(date)) - } - return(ts(data, frequency = frequency, start= start)) +ao_variable <- function(frequency, start, length, s, pos, date = NULL) { + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + if (is.null(date)) { + data <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "ao", jdom, as.integer(pos - 1)) + } else { + data <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "ao", jdom, as.character(date)) + } + return(ts(data, frequency = frequency, start = start)) } #' @export #' @rdname outliers_variables -tc_variable<-function(frequency, start, length, s, pos, date=NULL, rate=0.7){ - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - if (is.null(date)){ - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "tc", jdom, as.integer(pos-1), rate) - } else { - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "tc", jdom, as.character(date), rate) - } - return(ts(data, frequency = frequency, start= start)) +tc_variable <- function(frequency, start, length, s, pos, date = NULL, rate = 0.7) { + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + if (is.null(date)) { + data <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "tc", jdom, as.integer(pos - 1), rate) + } else { + data <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "tc", jdom, as.character(date), rate) + } + return(ts(data, frequency = frequency, start = start)) } #' @export #' @rdname outliers_variables -ls_variable<-function(frequency, start, length, s, pos, date=NULL, zeroended=TRUE){ - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - if (is.null(date)){ - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "ls", jdom, as.integer(pos-1), as.logical(zeroended)) - } else { - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "ls", jdom, as.character(date), as.logical(zeroended)) - } - return(ts(data, frequency = frequency, start= start)) +ls_variable <- function(frequency, start, length, s, pos, date = NULL, zeroended = TRUE) { + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + if (is.null(date)) { + data <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "ls", jdom, as.integer(pos - 1), as.logical(zeroended)) + } else { + data <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "ls", jdom, as.character(date), as.logical(zeroended)) + } + return(ts(data, frequency = frequency, start = start)) } #' @export #' @rdname outliers_variables -so_variable<-function(frequency, start, length, s, pos, date=NULL, zeroended=TRUE){ - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - if (is.null(date)){ - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "so", jdom, as.integer(pos-1), as.logical(zeroended)) - } else { - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "so", jdom, as.character(date), - as.logical(zeroended)) - } - return(ts(data, frequency = frequency, start= start)) +so_variable <- function(frequency, start, length, s, pos, date = NULL, zeroended = TRUE) { + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + if (is.null(date)) { + data <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "so", jdom, as.integer(pos - 1), as.logical(zeroended)) + } else { + data <- .jcall( + "jdplus/toolkit/base/r/modelling/Variables", "[D", "so", jdom, as.character(date), + as.logical(zeroended) + ) + } + return(ts(data, frequency = frequency, start = start)) } #' Ramp regressor @@ -198,28 +202,32 @@ so_variable<-function(frequency, start, length, s, pos, date=NULL, zeroended=TRU #' #' @examples #' # Ramp variable from January 2001 to September 2001 -#' rp <- ramp_variable(12, c(2000,1), length = 12*4, range = c(13, 21)) +#' rp <- ramp_variable(12, c(2000, 1), length = 12 * 4, range = c(13, 21)) #' # Or equivalently -#' rp<-ramp_variable(12, c(2000,1), length = 12*4, range = c("2001-01-01", "2001-09-02")) +#' rp <- ramp_variable(12, c(2000, 1), length = 12 * 4, range = c("2001-01-01", "2001-09-02")) #' plot.ts(rp) -ramp_variable<-function(frequency, start, length, s, range){ - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - if (length(range) != 2) stop("Invalid range") - if (is.character(range)){ - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "ramp", jdom, - as.character(range[1]), - as.character(range[2])) - } else { - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "ramp", jdom, - as.integer(range[1]-1), - as.integer(range[2]-1)) - } - return(ts(data, frequency = frequency, start= start)) +ramp_variable <- function(frequency, start, length, s, range) { + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + if (length(range) != 2) stop("Invalid range") + if (is.character(range)) { + data <- .jcall( + "jdplus/toolkit/base/r/modelling/Variables", "[D", "ramp", jdom, + as.character(range[1]), + as.character(range[2]) + ) + } else { + data <- .jcall( + "jdplus/toolkit/base/r/modelling/Variables", "[D", "ramp", jdom, + as.integer(range[1] - 1), + as.integer(range[2] - 1) + ) + } + return(ts(data, frequency = frequency, start = start)) } #' Intervention variable @@ -244,17 +252,19 @@ ramp_variable<-function(frequency, start, length, s, range){ #' the cumulative sum of temporary level shifts, once differenced the regressor will become a classical level shift. #' #' @examples -#' iv1<-intervention_variable(12, c(2000, 1), 60, -#' starts = "2001-01-01", ends = "2001-12-01") +#' iv1 <- intervention_variable(12, c(2000, 1), 60, +#' starts = "2001-01-01", ends = "2001-12-01" +#' ) #' plot(iv1) -#' iv2<- intervention_variable(12, c(2000, 1), 60, -#' starts = "2001-01-01", ends = "2001-12-01", delta = 1) -#' plot (iv2) +#' iv2 <- intervention_variable(12, c(2000, 1), 60, +#' starts = "2001-01-01", ends = "2001-12-01", delta = 1 +#' ) +#' plot(iv2) #' # using one variable in a a seasonal adjustment process #' # regressors as a list of two groups reg1 and reg2 -#' vars<-list(reg1=list(x = iv1),reg2=list(x = iv2) ) +#' vars <- list(reg1 = list(x = iv1), reg2 = list(x = iv2)) #' # creating the modelling context -#' my_context<-modelling_context(variables=vars) +#' my_context <- modelling_context(variables = vars) #' # customize a default specification #' # init_spec <- rjd3x13::x13_spec("RSA5c") #' # new_spec<- add_usrdefvar(init_spec,id = "reg1.iv1", regeffect="Trend") @@ -266,68 +276,72 @@ ramp_variable<-function(frequency, start, length, s, range){ #' \url{https://jdemetra-new-documentation.netlify.app/} #' @export -intervention_variable<-function(frequency, start, length, s, starts, ends, delta=0, seasonaldelta=0){ - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - if (length(starts) != length(ends)) stop("Invalid spans in intervention variable") +intervention_variable <- function(frequency, start, length, s, starts, ends, delta = 0, seasonaldelta = 0) { + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + if (length(starts) != length(ends)) stop("Invalid spans in intervention variable") - jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length) - if (is.character(starts) && is.character(ends)){ - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "interventionVariable", jdom, - delta, - seasonaldelta, - .jarray(as.character(starts)), - .jarray(as.character(ends))) - } else { - data<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "[D", "interventionVariable", jdom, - delta, - seasonaldelta, - .jarray(as.integer(starts-1)), - .jarray(as.integer(ends-1))) - } - return(ts(data, frequency = frequency, start= start)) + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + if (is.character(starts) && is.character(ends)) { + data <- .jcall( + "jdplus/toolkit/base/r/modelling/Variables", "[D", "interventionVariable", jdom, + delta, + seasonaldelta, + .jarray(as.character(starts)), + .jarray(as.character(ends)) + ) + } else { + data <- .jcall( + "jdplus/toolkit/base/r/modelling/Variables", "[D", "interventionVariable", jdom, + delta, + seasonaldelta, + .jarray(as.integer(starts - 1)), + .jarray(as.integer(ends - 1)) + ) + } + return(ts(data, frequency = frequency, start = start)) } #' Periodic dummies and contrasts #' -#'@inheritParams outliers_variables -#'@details +#' @inheritParams outliers_variables +#' @details #' The function periodic.dummies creates as many time series as types of periods in a year (4 or 12) #' with the value one only for one given type of period (ex Q1) -#' The function periodic.contrasts is based on periodic.dummies but adds -1 to the period preeceding a 1. -#'@examples +#' The periodic.contrasts function is based on periodic.dummies but adds -1 to the period preceding a 1. +#' @examples #' # periodic dummies for a quarterly series -#' p<-periodic.dummies(4, c(2000,1), 60) -#' #periodic contrasts for a quarterly series -#'q<-periodic.contrasts(4, c(2000,1), 60) -#'q[1:9,] -#'@export -periodic.dummies <-function(frequency, start, length, s){ - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) - jm<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "periodicDummies", jdom) - data <- .jd2r_matrix(jm) - return(ts(data, frequency = frequency, start= start)) +#' p <- periodic.dummies(4, c(2000, 1), 60) +#' # periodic contrasts for a quarterly series +#' q <- periodic.contrasts(4, c(2000, 1), 60) +#' q[1:9, ] +#' @export +periodic.dummies <- function(frequency, start, length, s) { + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + jm <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "periodicDummies", jdom) + data <- .jd2r_matrix(jm) + return(ts(data, frequency = frequency, start = start)) } -#'@export -#'@rdname periodic.dummies -periodic.contrasts <-function(frequency, start, length, s){ - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) - jm<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "periodicContrasts", jdom) - data <- .jd2r_matrix(jm) - return(ts(data, frequency = frequency, start= start)) +#' @export +#' @rdname periodic.dummies +periodic.contrasts <- function(frequency, start, length, s) { + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + jm <- .jcall("jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "periodicContrasts", jdom) + data <- .jd2r_matrix(jm) + return(ts(data, frequency = frequency, start = start)) } #' Trigonometric variables #' @@ -375,24 +389,28 @@ periodic.contrasts <-function(frequency, start, length, s){ #' #' @export trigonometric_variables <- function(frequency, start, length, s, - seasonal_frequency = NULL){ - if (!missing(s) && is.ts(s)) { - frequency<-stats::frequency(s) - start<-stats::start(s) - length<-.length_ts(s) - } - jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) + seasonal_frequency = NULL) { + if (!missing(s) && is.ts(s)) { + frequency <- stats::frequency(s) + start <- stats::start(s) + length <- .length_ts(s) + } + jdom <- .r2jd_tsdomain(frequency, start[1], start[2], length) - if (!is.null(seasonal_frequency)) - seasonal_frequency <- as.integer(seasonal_frequency) - jm<-.jcall("jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "trigonometricVariables", - jdom, .jarray(seasonal_frequency)) - data <- .jd2r_matrix(jm) + if (!is.null(seasonal_frequency)) { + seasonal_frequency <- as.integer(seasonal_frequency) + } + jm <- .jcall( + "jdplus/toolkit/base/r/modelling/Variables", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "trigonometricVariables", + jdom, .jarray(seasonal_frequency) + ) + data <- .jd2r_matrix(jm) - if (ncol(data) %% 2 == 1) - data <- cbind(data, 0) + if (ncol(data) %% 2 == 1) { + data <- cbind(data, 0) + } - return(ts(data, frequency = frequency, start = start)) + return(ts(data, frequency = frequency, start = start)) } # Denote by \eqn{l} the value of \code{length}, diff --git a/R/zzz.R b/R/zzz.R index e98f9ffb..86a6e43f 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -3,11 +3,11 @@ NULL #' @rdname jd3_utilities #' @export -DATE_MIN<-NULL +DATE_MIN <- NULL #' @export #' @rdname jd3_utilities -DATE_MAX<-NULL +DATE_MAX <- NULL #' @importFrom RProtoBuf read readProtoFiles2 #' @importFrom rJava .jpackage .jcall .jnull .jarray .jevalArray .jcast .jcastToArray .jinstanceof is.jnull .jnew .jclass @@ -16,20 +16,22 @@ NULL .onLoad <- function(libname, pkgname) { - result <- .jpackage(pkgname, lib.loc=libname) - if (!result) stop("Loading java packages failed") + result <- .jpackage(pkgname, lib.loc = libname) + if (!result) stop("Loading java packages failed") - # what's your java version? Need >= 17 - jversion <- .jcall('java.lang.System','S','getProperty','java.version') - if (jversion < "17") { - stop(paste("Your java version is ", jversion, - ". N or higher.", sep="")) - } + # what's your java version? Need >= 17 + jversion <- .jcall("java.lang.System", "S", "getProperty", "java.version") + if (jversion < "17") { + stop(sprintf("Your java version is %s. 17 or higher is needed.", jversion)) + } - proto.dir <- system.file("proto", package = pkgname) - readProtoFiles2(protoPath = proto.dir) + proto.dir <- system.file("proto", package = pkgname) + readProtoFiles2(protoPath = proto.dir) - DATE_MIN<<-dateOf(1,1,1) - DATE_MAX<<-dateOf(9999, 12, 31) + DATE_MIN <<- dateOf(1, 1, 1) + DATE_MAX <<- dateOf(9999, 12, 31) + if (is.null(getOption("summary_info"))) { + options(summary_info = TRUE) + } } diff --git a/README.Rmd b/README.Rmd index b0b7cd94..a6747014 100644 --- a/README.Rmd +++ b/README.Rmd @@ -6,10 +6,10 @@ output: github_document ```{r, include = FALSE} knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>", - fig.path = "man/figures/README-", - out.width = "100%" + collapse = TRUE, + comment = "#>", + fig.path = "man/figures/README-", + out.width = "100%" ) ``` diff --git a/dev/config_attachment.yaml b/dev/config_attachment.yaml new file mode 100644 index 00000000..46e24ecc --- /dev/null +++ b/dev/config_attachment.yaml @@ -0,0 +1,12 @@ +path.n: NAMESPACE +path.d: DESCRIPTION +dir.r: R +dir.v: vignettes +dir.t: tests +extra.suggests: ~ +pkg_ignore: ~ +document: yes +normalize: yes +inside_rmd: no +must.exist: yes +check_if_suggests_is_installed: yes diff --git a/inst/WORDLIST b/inst/WORDLIST new file mode 100644 index 00000000..53b7617b --- /dev/null +++ b/inst/WORDLIST @@ -0,0 +1,99 @@ + +ALLSAINTSDAY +ASHWEDNESDAY +CORPUSCHRISTI +EASTERMONDAY +GOODFRIDAY +JULIANEASTER +MAUNDYTHURSDAY +NEWYEAR +SHROVEMONDAY +SHROVETUESDAY +WHITMONDAY + +Doornik +Hannan +Rissanen +Jarque +Kruskall +Ladiray +Ljung +LjungBox +Quenneville +Proietti +Shenton +Wurttemberg +Kolmogorov +Bera + +JDemetra +JD + +ar +arima +arma +Arima +SARIMA +UCARIMA +REGARIMA +RegARIMA +RegArima +regarima + +rjd +rjdtramoseats +tramo +TRAMO +TRAMOSEATS +Tramo +tramoseats + +AICC +AO +Anhalt +BPhi +BTheta +Benchmarking +CMD +CalendarTimeSeries +Changelog +Differencing +EUPL +GH +Canova +Modelling +Periodicities +Pre +PreComputed +QS +ReduceCV +UC +UserDefined +YYYY +acf +backcasts +bd +benchmarking +bp +checkmodel +datesin +differencing +docstrings +easter +len +modelling +moduli +nd +pos +pre +stdev +st +th +tha +userdefined +xCV +Stat +obs +java +DD +etc diff --git a/inst/java/jdplus-sa-base-api-3.2.4.jar b/inst/java/jdplus-sa-base-api-3.3.0.jar similarity index 86% rename from inst/java/jdplus-sa-base-api-3.2.4.jar rename to inst/java/jdplus-sa-base-api-3.3.0.jar index 23e6cf63..c516a2f2 100644 Binary files a/inst/java/jdplus-sa-base-api-3.2.4.jar and b/inst/java/jdplus-sa-base-api-3.3.0.jar differ diff --git a/inst/java/jdplus-sa-base-core-3.2.4.jar b/inst/java/jdplus-sa-base-core-3.3.0.jar similarity index 77% rename from inst/java/jdplus-sa-base-core-3.2.4.jar rename to inst/java/jdplus-sa-base-core-3.3.0.jar index aecee5fa..94e16283 100644 Binary files a/inst/java/jdplus-sa-base-core-3.2.4.jar and b/inst/java/jdplus-sa-base-core-3.3.0.jar differ diff --git a/inst/java/jdplus-sa-base-protobuf-3.2.4.jar b/inst/java/jdplus-sa-base-protobuf-3.3.0.jar similarity index 92% rename from inst/java/jdplus-sa-base-protobuf-3.2.4.jar rename to inst/java/jdplus-sa-base-protobuf-3.3.0.jar index 6704966a..70533ec3 100644 Binary files a/inst/java/jdplus-sa-base-protobuf-3.2.4.jar and b/inst/java/jdplus-sa-base-protobuf-3.3.0.jar differ diff --git a/inst/java/jdplus-sa-base-r-3.2.4.jar b/inst/java/jdplus-sa-base-r-3.3.0.jar similarity index 58% rename from inst/java/jdplus-sa-base-r-3.2.4.jar rename to inst/java/jdplus-sa-base-r-3.3.0.jar index cee72439..d482a94e 100644 Binary files a/inst/java/jdplus-sa-base-r-3.2.4.jar and b/inst/java/jdplus-sa-base-r-3.3.0.jar differ diff --git a/inst/java/jdplus-toolkit-base-api-3.2.4.jar b/inst/java/jdplus-toolkit-base-api-3.3.0.jar similarity index 90% rename from inst/java/jdplus-toolkit-base-api-3.2.4.jar rename to inst/java/jdplus-toolkit-base-api-3.3.0.jar index 382a6810..86ff935c 100644 Binary files a/inst/java/jdplus-toolkit-base-api-3.2.4.jar and b/inst/java/jdplus-toolkit-base-api-3.3.0.jar differ diff --git a/inst/java/jdplus-toolkit-base-core-3.2.4.jar b/inst/java/jdplus-toolkit-base-core-3.3.0.jar similarity index 88% rename from inst/java/jdplus-toolkit-base-core-3.2.4.jar rename to inst/java/jdplus-toolkit-base-core-3.3.0.jar index 7d4f75bc..7dbad324 100644 Binary files a/inst/java/jdplus-toolkit-base-core-3.2.4.jar and b/inst/java/jdplus-toolkit-base-core-3.3.0.jar differ diff --git a/inst/java/jdplus-toolkit-base-protobuf-3.2.4.jar b/inst/java/jdplus-toolkit-base-protobuf-3.3.0.jar similarity index 95% rename from inst/java/jdplus-toolkit-base-protobuf-3.2.4.jar rename to inst/java/jdplus-toolkit-base-protobuf-3.3.0.jar index 8d88704d..799e5105 100644 Binary files a/inst/java/jdplus-toolkit-base-protobuf-3.2.4.jar and b/inst/java/jdplus-toolkit-base-protobuf-3.3.0.jar differ diff --git a/inst/java/jdplus-toolkit-base-r-3.2.4.jar b/inst/java/jdplus-toolkit-base-r-3.3.0.jar similarity index 80% rename from inst/java/jdplus-toolkit-base-r-3.2.4.jar rename to inst/java/jdplus-toolkit-base-r-3.3.0.jar index 73e373f2..7ea412ea 100644 Binary files a/inst/java/jdplus-toolkit-base-r-3.2.4.jar and b/inst/java/jdplus-toolkit-base-r-3.3.0.jar differ diff --git a/inst/java/protobuf-java-3.25.3.jar b/inst/java/protobuf-java-3.25.5.jar similarity index 93% rename from inst/java/protobuf-java-3.25.3.jar rename to inst/java/protobuf-java-3.25.5.jar index e45c5f15..d7664885 100644 Binary files a/inst/java/protobuf-java-3.25.3.jar and b/inst/java/protobuf-java-3.25.5.jar differ diff --git a/inst/proto/sa.proto b/inst/proto/sa.proto index c7bd624c..4756649e 100644 --- a/inst/proto/sa.proto +++ b/inst/proto/sa.proto @@ -18,13 +18,15 @@ enum ComponentType{ } enum DecompositionMode { - UNKNOWN = 0; + UNKNOWN = 0; /* Y = T + S + I) */ ADDITIVE = 1; /* Y = T * S * I) */ MULTIPLICATIVE = 2; + /* LOG(Y) = T + S + I */ + LOGADDITIVE = 3; /* Y = T * (S + I - 1) */ - PSEUDOADDITIVE = 3; + PSEUDOADDITIVE = 4; } message SaDecomposition{ @@ -103,4 +105,4 @@ message CombinedSeasonalityTest{ jd3.StatisticalTest kruskal_wallis = 2; jd3.OneWayAnova stable_seasonality = 3; jd3.OneWayAnova evolutive_seasonality = 4; -} \ No newline at end of file +} diff --git a/man/ABS.Rd b/man/ABS.Rd new file mode 100644 index 00000000..226027df --- /dev/null +++ b/man/ABS.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\docType{data} +\name{ABS} +\alias{ABS} +\title{Retail trade statistics in Australia} +\format{ +An object of class \code{data.frame} with 425 rows and 22 columns. +} +\source{ +ABS +} +\usage{ +ABS +} +\description{ +Retail trade statistics in Australia +} +\keyword{datasets} diff --git a/man/Exports.Rd b/man/Exports.Rd new file mode 100644 index 00000000..ef7601ae --- /dev/null +++ b/man/Exports.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\docType{data} +\name{Exports} +\alias{Exports} +\title{Belgian exports to European countries} +\format{ +An object of class \code{list} of length 34. +} +\source{ +NBB +} +\usage{ +Exports +} +\description{ +Belgian exports to European countries +} +\keyword{datasets} diff --git a/man/Imports.Rd b/man/Imports.Rd new file mode 100644 index 00000000..1670c137 --- /dev/null +++ b/man/Imports.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\docType{data} +\name{Imports} +\alias{Imports} +\title{Belgian imports from European countries} +\format{ +An object of class \code{list} of length 34. +} +\source{ +NBB +} +\usage{ +Imports +} +\description{ +Belgian imports from European countries +} +\keyword{datasets} diff --git a/man/add_outlier.Rd b/man/add_outlier.Rd index c77c8ec8..825815c3 100644 --- a/man/add_outlier.Rd +++ b/man/add_outlier.Rd @@ -16,30 +16,34 @@ add_ramp(x, start, end, name = sprintf("rp.\%s - \%s", start, end), coef = 0) remove_ramp(x, start = NULL, end = NULL, name = NULL) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{type, date}{type and date of the outliers. Possible \code{type} are: -\code{"AO"} = additive, \code{"LS"} = level shift, \code{"TC"} = transitory change and -\code{"SO"} = seasonal outlier.} +\code{"AO"} = additive, \code{"LS"} = level shift, \code{"TC"} = transitory +change and \code{"SO"} = seasonal outlier.} \item{name}{the name of the variable (to format print).} -\item{coef}{the coefficient if needs to be fixed. If equal to 0 the outliers/ramps coefficients -are estimated.} +\item{coef}{the coefficient if needs to be fixed. If equal to 0 the +outliers/ramps coefficients are estimated.} \item{start, end}{dates of the ramp regressor.} } \description{ -Generic function to add outliers or Ramp regressors (\code{add_outlier()} and \code{add_ramp()}) -to a specification or to remove them (\code{remove_outlier()} and \code{remove_ramp()}). +Generic function to add outliers or Ramp regressors (\code{add_outlier()} and +\code{add_ramp()}) to a specification or to remove them +(\code{remove_outlier()} and \code{remove_ramp()}). } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} -(or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" -generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with -\code{rjd3tramoseats::spec_tramo()}). -If a Seasonal adjustment process is performed, each type of Outlier will be allocated to a pre-defined -component after the decomposition: "AO" and "TC" to the irregular, "LS" and Ramps to the trend. +\code{x} specification parameter must be a JD3_X13_SPEC" class object +generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated +with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with +\code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with +\code{rjd3tramoseats::spec_tramo()}). If a Seasonal adjustment process is +performed, each type of Outlier will be allocated to a pre-defined component +after the decomposition: "AO" and "TC" to the irregular, "LS" and Ramps to +the trend. } \examples{ # init_spec <- rjd3x13::x13_spec("RSA5c") diff --git a/man/add_usrdefvar.Rd b/man/add_usrdefvar.Rd index ce510277..0500b300 100644 --- a/man/add_usrdefvar.Rd +++ b/man/add_usrdefvar.Rd @@ -16,7 +16,8 @@ add_usrdefvar( ) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{group, name}{the name of the regressor in the format \code{"group.name"}, by default \code{"r.name"} by default if \code{group} NULL \code{"group.name"} has to be the same as in \code{\link{modelling_context}} (see examples)} @@ -39,7 +40,7 @@ a specification, the external regressor(s) will also have to be added to a model before being used in an estimation process. see \code{\link{modelling_context}} and example. } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +\code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with \code{rjd3tramoseats::spec_tramo()}). @@ -53,26 +54,28 @@ for the decomposition. \item "Seasonal": after the decomposition the effect is allocated to the seasonal component, like a Seasonal-outlier \item "Series": after the decomposition the effect is allocated to the raw series: \eqn{yc_t=y_t+ effect} -\item "Seasonally Adjusted": after the decomposition the effect is allocated to +\item "SeasonallyAdjusted": after the decomposition the effect is allocated to the seasonally adjusted series: \eqn{sa_t=T+I+effect} } } \examples{ # creating one or several external regressors (TS objects), # which will be gathered in one or several groups -iv1<-intervention_variable(12, c(2000, 1), 60, -starts = "2001-01-01", ends = "2001-12-01") -iv2<- intervention_variable(12, c(2000, 1), 60, -starts = "2001-01-01", ends = "2001-12-01", delta = 1) +iv1 <- intervention_variable(12, c(2000, 1), 60, + starts = "2001-01-01", ends = "2001-12-01" +) +iv2 <- intervention_variable(12, c(2000, 1), 60, + starts = "2001-01-01", ends = "2001-12-01", delta = 1 +) # configuration 1: regressors in the same default group (named "r") -variables<-list("iv1"=iv1, "iv2"=iv2) +variables <- list("iv1" = iv1, "iv2" = iv2) # to use those regressors, input : name=r.iv1 and r.iv2 in add_usrdefvar function # configuration 2: group names are user-defined # here: regressors as a list of two groups (lists) reg1 and reg2 -vars<-list(reg1=list(iv1 = iv1),reg2=list(iv2 = iv2) ) +vars <- list(reg1 = list(iv1 = iv1), reg2 = list(iv2 = iv2)) # to use those regressors, input : name=reg1.iv1 and name=reg2.iv2 in add_usrdefvar function # creating the modelling context -my_context<-modelling_context(variables=vars) +my_context <- modelling_context(variables = vars) # customize a default specification # init_spec <- rjd3x13::x13_spec("RSA5c") # regressors have to be added one by one diff --git a/man/aggregate.Rd b/man/aggregate.Rd index 4d340dbe..d9ef5fbd 100644 --- a/man/aggregate.Rd +++ b/man/aggregate.Rd @@ -30,7 +30,7 @@ A new time series of frequency \code{nfreq}. Makes a frequency change of this series. } \examples{ -s = ABS$X0.2.09.10.M +s <- ABS$X0.2.09.10.M # Annual sum aggregate(s, nfreq = 1, conversion = "Sum") # first and last years removed aggregate(s, nfreq = 1, conversion = "Sum", complete = FALSE) diff --git a/man/arima_difference.Rd b/man/arima_difference.Rd index 2203d46a..2bfcc560 100644 --- a/man/arima_difference.Rd +++ b/man/arima_difference.Rd @@ -2,26 +2,28 @@ % Please edit documentation in R/arima.R \name{arima_difference} \alias{arima_difference} -\title{Remove an arima model from an existing one} +\title{Remove an arima model from an existing one. More exactly, m_diff = m_left - m_right iff m_left = m_right + m_diff.} \usage{ arima_difference(left, right, simplify = TRUE) } \arguments{ -\item{left}{Left operand} +\item{left}{Left operand (JD3_ARIMA object)} -\item{right}{Right operand} +\item{right}{Right operand (JD3_ARIMA object)} -\item{simplify}{Simplify the results} +\item{simplify}{Simplify the results if possible (common roots in the auto-regressive and in the moving average polynomials, including unit roots)} } \value{ a \code{"JD3_ARIMA"} model. } \description{ -Remove an arima model from an existing one +Remove an arima model from an existing one. More exactly, m_diff = m_left - m_right iff m_left = m_right + m_diff. } \examples{ -mod1 = arima_model(delta = c(1,-2,1)) -mod2 = arima_model(variance=.01) -diff<- arima_difference(mod1, mod2) +mod1 <- arima_model(delta = c(1, -2, 1)) +mod2 <- arima_model(variance = .01) +diff <- arima_difference(mod1, mod2) +sum <- arima_sum(diff, mod2) +# sum should be equal to mod1 } diff --git a/man/arima_model.Rd b/man/arima_model.Rd index e9671b25..874f7e8f 100644 --- a/man/arima_model.Rd +++ b/man/arima_model.Rd @@ -23,3 +23,6 @@ a \code{"JD3_ARIMA"} model. \description{ ARIMA Model } +\examples{ +model <- arima_model("trend", ar = c(1, -.8), delta = c(1, -1), ma = c(1, -.5), var = 100) +} diff --git a/man/arima_properties.Rd b/man/arima_properties.Rd index 4d0386d0..f6576cb1 100644 --- a/man/arima_properties.Rd +++ b/man/arima_properties.Rd @@ -2,21 +2,24 @@ % Please edit documentation in R/arima.R \name{arima_properties} \alias{arima_properties} -\title{ARIMA Properties} +\title{Properties of an ARIMA model; the (pseudo-)spectrum and the auto-covariances of the model are returned} \usage{ -arima_properties(model, nspectrum = 601, nacf = 36) +arima_properties(model, nspectrum = 601, nac = 36) } \arguments{ \item{model}{a \code{"JD3_ARIMA"} model (created with \code{\link[=arima_model]{arima_model()}}).} -\item{nspectrum}{number of points in [0, pi] to calculate the spectrum.} +\item{nspectrum}{number of points to calculate the spectrum; th points are uniformly distributed in [0, pi]} -\item{nacf}{maximum lag at which to calculate the acf.} +\item{nac}{maximum lag at which to calculate the auto-covariances; if the model is non-stationary, the auto-covariances are computed on its stationary transformation.} +} +\value{ +A list with tha auto-covariances and with the (pseudo-)spectrum } \description{ -ARIMA Properties +Properties of an ARIMA model; the (pseudo-)spectrum and the auto-covariances of the model are returned } \examples{ -mod1 = arima_model(ar = c(0.1, 0.2), delta = 0, ma = 0) +mod1 <- arima_model(ar = c(0.1, 0.2), delta = c(1, -1), ma = 0) arima_properties(mod1) } diff --git a/man/arima_sum.Rd b/man/arima_sum.Rd index 49221879..31b4ac36 100644 --- a/man/arima_sum.Rd +++ b/man/arima_sum.Rd @@ -25,7 +25,7 @@ polynomials is then computed and factorized, to get the moving average polynomial and innovation variance of the sum. } \examples{ -mod1 = arima_model(ar = c(0.1, 0.2), delta = 0, ma = 0) -mod2 = arima_model(ar = 0, delta = 0, ma = c(0.4)) +mod1 <- arima_model(ar = c(0.1, 0.2), delta = 0, ma = 0) +mod2 <- arima_model(ar = 0, delta = 0, ma = c(0.4)) arima_sum(mod1, mod2) } diff --git a/man/autocorrelations.Rd b/man/autocorrelations.Rd index 345f9557..7d50de23 100644 --- a/man/autocorrelations.Rd +++ b/man/autocorrelations.Rd @@ -26,7 +26,7 @@ If \code{FALSE}, we consider that the (known) mean is 0 and that the series has Autocorrelation Functions } \examples{ -x = ABS$X0.2.09.10.M +x <- ABS$X0.2.09.10.M autocorrelations(x) autocorrelations_partial(x) autocorrelations_inverse(x) diff --git a/man/calendar_td.Rd b/man/calendar_td.Rd index b572304c..596762d5 100644 --- a/man/calendar_td.Rd +++ b/man/calendar_td.Rd @@ -29,7 +29,7 @@ parameters \code{frequency}, \code{start} and \code{length} are ignored.} \item{groups}{Groups of days. The length of the array must be 7. It indicates to what group each week day belongs. The first item corresponds to Mondays and the last one to Sundays. The group used for contrasts (usually Sundays) is identified by 0. The other groups are identified by 1, 2,... n (<= 6). For instance, usual trading days are defined by c(1,2,3,4,5,6,0), -week days by c(1,1,1,1,1,0,0), week days, Saturdays, Sundays by c(1,1,1,1,1,2,0) etc...} +week days by c(1,1,1,1,1,0,0), week days, Saturdays, Sundays by c(1,1,1,1,1,2,0) etc.} \item{holiday}{Day to aggregate holidays with. (holidays are considered as that day). 1 for Monday... 7 for Sunday. Doesn't necessary belong to the 0-group.} @@ -55,7 +55,7 @@ Regressors are corrected for long-term mean if \code{contrasts = TRUE}. } \examples{ BE <- national_calendar(list( - fixed_day(7,21), + fixed_day(7, 21), special_day("NEWYEAR"), special_day("CHRISTMAS"), special_day("MAYDAY"), @@ -64,9 +64,12 @@ BE <- national_calendar(list( special_day("WHITMONDAY"), special_day("ASSUMPTION"), special_day("ALLSAINTSDAY"), - special_day("ARMISTICE"))) -calendar_td(BE, 12, c(1980,1), 240, holiday=7, groups=c(1,1,1,2,2,3,0), -contrasts = FALSE) + special_day("ARMISTICE") +)) +calendar_td(BE, 12, c(1980, 1), 240, + holiday = 7, groups = c(1, 1, 1, 2, 2, 3, 0), + contrasts = FALSE +) } \references{ More information on calendar correction in JDemetra+ online documentation: diff --git a/man/chained_calendar.Rd b/man/chained_calendar.Rd index 455c5d04..ff0b026e 100644 --- a/man/chained_calendar.Rd +++ b/man/chained_calendar.Rd @@ -23,9 +23,9 @@ In such a case two calendars describing the situation before and after the chang and bound together, one before the break and one after the break. } \examples{ -Belgium <- national_calendar(list(special_day("NEWYEAR"),fixed_day(7,21))) -France <- national_calendar(list(special_day("NEWYEAR"),fixed_day(7,14))) -chained_cal<-chained_calendar(France, Belgium, "2000-01-01") +Belgium <- national_calendar(list(special_day("NEWYEAR"), fixed_day(7, 21))) +France <- national_calendar(list(special_day("NEWYEAR"), fixed_day(7, 14))) +chained_cal <- chained_calendar(France, Belgium, "2000-01-01") } \references{ diff --git a/man/data_to_ts.Rd b/man/data_to_ts.Rd index 37166753..25c52fef 100644 --- a/man/data_to_ts.Rd +++ b/man/data_to_ts.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/timeseries.R \name{data_to_ts} \alias{data_to_ts} -\title{Promote a R time series to a "full" ts of jdemetra} +\title{Promote a R time series to a "full" \code{ts} of JDemetra+} \usage{ data_to_ts(s, name) } @@ -12,9 +12,9 @@ data_to_ts(s, name) \item{name}{name of the series} } \description{ -Promote a R time series to a "full" ts of jdemetra +Promote a R time series to a "full" \code{ts} of JDemetra+ } \examples{ -s<-ABS$X0.2.09.10.M -t<-data_to_ts(s,"test") +s <- ABS$X0.2.09.10.M +t <- data_to_ts(s, "test") } diff --git a/man/daysOf.Rd b/man/daysOf.Rd index b154f8d5..f5dbbafc 100644 --- a/man/daysOf.Rd +++ b/man/daysOf.Rd @@ -2,13 +2,21 @@ % Please edit documentation in R/timeseries.R \name{daysOf} \alias{daysOf} -\title{Title} +\title{Provides a list of dates corresponding to each period of the given time series} \usage{ -daysOf(ts, pos = 0) +daysOf(ts, pos = 1) } \arguments{ -\item{pos}{} +\item{ts}{A time series} + +\item{pos}{The position of the first considered period.} +} +\value{ +A list of the starting dates of each period } \description{ -Title +Provides a list of dates corresponding to each period of the given time series +} +\examples{ +daysOf(retail$BookStores) } diff --git a/man/differences.Rd b/man/differences.Rd index c0fec301..7da82211 100644 --- a/man/differences.Rd +++ b/man/differences.Rd @@ -11,7 +11,7 @@ differences(data, lags = 1, mean = TRUE) \item{lags}{Lags of the differencing.} -\item{mean}{Mean correction.} +\item{mean}{Apply a mean correction at the end of the differencing process.} } \value{ The differenced series. @@ -20,6 +20,6 @@ The differenced series. Differencing of a series } \examples{ -differences(retail$BookStores, c(1,1,12), FALSE) +differences(retail$BookStores, c(1, 1, 12), FALSE) } diff --git a/man/differencing_fast.Rd b/man/differencing_fast.Rd index 65678278..195013ef 100644 --- a/man/differencing_fast.Rd +++ b/man/differencing_fast.Rd @@ -15,24 +15,24 @@ differencing_fast(data, period, mad = TRUE, centile = 90, k = 1.2) \item{centile}{Percentage of the data used for computing the variance (90 by default).} -\item{k}{tolerance in the decrease of the variance. The algorithm stops if the new varance is higher than k*the old variance.} +\item{k}{tolerance in the decrease of the variance. The algorithm stops if the new variance is higher than k*the old variance. k should be equal or slightly higher than 1 (1.2 by default)} } \value{ Stationary transformation \itemize{ -\item ddata: data after differencing -\item mean: mean correction -\item differences: +\item \code{ddata}: data after differencing +\item \code{mean}: mean correction +\item \code{differences}: \itemize{ -\item lag: ddata(t)=data(t)-data(t-lag) -\item order: order of the differencing +\item \code{lag}: \eqn{ddata(t)=data(t)-data(t-lag)} +\item \code{order}: order of the differencing } } } \description{ -The series is differentiated till its variance is decreasing. +The series is differenced till its variance is decreasing. } \examples{ -differencing_fast(log(ABS$X0.2.09.10.M),12) +differencing_fast(log(ABS$X0.2.09.10.M), 12) } diff --git a/man/do_stationary.Rd b/man/do_stationary.Rd index c9ed90a9..b4ae123b 100644 --- a/man/do_stationary.Rd +++ b/man/do_stationary.Rd @@ -14,21 +14,20 @@ do_stationary(data, period) \value{ Stationary transformation \itemize{ -\item ddata: data after differencing -\item mean: mean correction -\item differences: +\item \code{ddata}: data after differencing +\item \code{mean}: mean correction +\item \code{differences}: \itemize{ -\item lag: ddata(t)=data(t)-data(t-lag) -\item order: order of the differencing +\item \code{lag}: \eqn{ddata(t)=data(t)-data(t-lag)} +\item \code{order}: order of the differencing } } } \description{ -Stationary transformation of a series by simple differencing of lag 1. Automatic processing (identification of the order of the differencing) based on auto-correlations and on mean correction. The series should not be seasonal. Source: Tramo } \examples{ -do_stationary(log(ABS$X0.2.09.10.M),12) +do_stationary(log(ABS$X0.2.09.10.M), 12) } diff --git a/man/dot-likelihood.Rd b/man/dot-likelihood.Rd new file mode 100644 index 00000000..69855ee7 --- /dev/null +++ b/man/dot-likelihood.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{.likelihood} +\alias{.likelihood} +\title{Information on the (log-)likelihood} +\usage{ +.likelihood( + nobs, + neffectiveobs = NA, + nparams = 0, + ll, + adjustedll = NA, + aic, + aicc, + bic, + bicc, + ssq +) +} +\arguments{ +\item{nobs}{Number of observation} + +\item{neffectiveobs}{Number of effective observations. NA if it is the same as nobs.} + +\item{nparams}{Number of hyper-parameters} + +\item{ll}{Log-likelihood} + +\item{adjustedll}{Adjusted log-likelihood when the series has been transformed} + +\item{aic}{AIC} + +\item{aicc}{AICC} + +\item{bic}{BIC} + +\item{bicc}{BIC corrected for the length} + +\item{ssq}{Sum of the squared residuals} +} +\description{ +Information on the (log-)likelihood +} diff --git a/man/tsmoniker.Rd b/man/dot-tsmoniker.Rd similarity index 79% rename from man/tsmoniker.Rd rename to man/dot-tsmoniker.Rd index c9dec48b..7d552bed 100644 --- a/man/tsmoniker.Rd +++ b/man/dot-tsmoniker.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/modellingcontext.R -\name{tsmoniker} -\alias{tsmoniker} +\name{.tsmoniker} +\alias{.tsmoniker} \title{Title} \usage{ -tsmoniker(source, id) +.tsmoniker(source, id) } \arguments{ \item{source}{Source of the time series.} diff --git a/man/easter_dates.Rd b/man/easter_dates.Rd index d07629c6..fd400d06 100644 --- a/man/easter_dates.Rd +++ b/man/easter_dates.Rd @@ -20,7 +20,7 @@ Allows to display the date of Easter Sunday for each year, in the defined period displayed in "YYYY-MM-DD" format and as a number of days since January 1st 1970. } \examples{ -#Dates from 2018(included) to 2023 (included) +# Dates from 2018(included) to 2023 (included) easter_dates(2018, 2023) } \references{ diff --git a/man/easter_day.Rd b/man/easter_day.Rd index a14c7990..f5f1d046 100644 --- a/man/easter_day.Rd +++ b/man/easter_day.Rd @@ -19,12 +19,14 @@ easter_day(offset, julian = FALSE, weight = 1, validity = NULL) Allows to define a holiday which date is related to Easter Sunday. } \examples{ -easter_day(1) #Easter Monday +easter_day(1) # Easter Monday easter_day(-2) # Easter Good Friday # Corpus Christi 60 days after Easter # Sunday in Julian calendar with weight 0.5, from January 2000 to December 2020 -easter_day(offset=60,julian=TRUE,weight=0.5, -validity = list(start="2000-01-01", end = "2020-12-01")) +easter_day( + offset = 60, julian = TRUE, weight = 0.5, + validity = list(start = "2000-01-01", end = "2020-12-01") +) } \references{ More information on calendar correction in JDemetra+ online documentation: diff --git a/man/easter_variable.Rd b/man/easter_variable.Rd index e4456d2a..ac9154fd 100644 --- a/man/easter_variable.Rd +++ b/man/easter_variable.Rd @@ -40,8 +40,8 @@ A time series (object of class \code{"ts"}) Allows to generate a regressor taking into account the (Julian) Easter effect in monthly or quarterly time series. } \examples{ -#Monthly regressor, five-year long, duration 8 days, effect finishing on Easter Monday -ee<-easter_variable(12, c(2020,1),length=5*12,duration=8, endpos=1) +# Monthly regressor, five-year long, duration 8 days, effect finishing on Easter Monday +ee <- easter_variable(12, c(2020, 1), length = 5 * 12, duration = 8, endpos = 1) } \references{ More information on calendar correction in JDemetra+ online documentation: diff --git a/man/figures/logo.png b/man/figures/logo.png index 4bf3330a..faf7a066 100644 Binary files a/man/figures/logo.png and b/man/figures/logo.png differ diff --git a/man/figures/logo.svg b/man/figures/logo.svg index 2011218d..e7a8ac39 100644 --- a/man/figures/logo.svg +++ b/man/figures/logo.svg @@ -3,26 +3,27 @@ @@ -31,246 +32,252 @@ - - - - + - - - - - - - - + - - - - - - - - - - - - - - + - - - - + - - - - - - - - + - - - - + + + + + + - - + + + + - - - - - - - - + + + + + + + - - + + - - + + + + - - - + + - - + + + + + + - - - - - - - - - - - + - rjd3toolkit + + + + + + + + + + + + - github.com/rjdverse/rjd3toolkit + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - + - + - + - + - + - + - + diff --git a/man/fixed_day.Rd b/man/fixed_day.Rd index 86d5a66f..c6f02f73 100644 --- a/man/fixed_day.Rd +++ b/man/fixed_day.Rd @@ -22,10 +22,10 @@ like Christmas which is always celebrated on December 25th. } \examples{ day <- fixed_day(7, 21, .9) -day # July 21st, with weight=0.9, on the whole sample +day # July 21st, with weight=0.9, on the whole sample day <- fixed_day(12, 25, .5, validity = list(start = "2010-01-01")) day # December 25th, with weight=0.5, from January 2010 -day <- fixed_day(12, 25, .5, validity = list(start="1968-02-01", end = "2010-01-01")) +day <- fixed_day(12, 25, .5, validity = list(start = "1968-02-01", end = "2010-01-01")) day # December 25th, with weight=0.9, from February 1968 until January 2010 } \references{ diff --git a/man/holidays.Rd b/man/holidays.Rd index f6abedea..4c550140 100644 --- a/man/holidays.Rd +++ b/man/holidays.Rd @@ -44,18 +44,19 @@ This kind of non-aggregated regressors are used for calendar correction in daily } \examples{ BE <- national_calendar(list( - fixed_day(7,21), - special_day("NEWYEAR"), - special_day("CHRISTMAS"), - special_day("MAYDAY"), - special_day("EASTERMONDAY"), - special_day("ASCENSION"), - special_day("WHITMONDAY"), - special_day("ASSUMPTION"), - special_day("ALLSAINTSDAY"), - special_day("ARMISTICE"))) -q<-holidays(BE, "2021-01-01", 366*10, type="All") -plot(apply(q,1, max)) + fixed_day(7, 21), + special_day("NEWYEAR"), + special_day("CHRISTMAS"), + special_day("MAYDAY"), + special_day("EASTERMONDAY"), + special_day("ASCENSION"), + special_day("WHITMONDAY"), + special_day("ASSUMPTION"), + special_day("ALLSAINTSDAY"), + special_day("ARMISTICE") +)) +q <- holidays(BE, "2021-01-01", 366 * 10, type = "All") +plot(apply(q, 1, max)) } \references{ More information on calendar correction in JDemetra+ online documentation: diff --git a/man/intervention_variable.Rd b/man/intervention_variable.Rd index 78ef25aa..73561828 100644 --- a/man/intervention_variable.Rd +++ b/man/intervention_variable.Rd @@ -48,17 +48,19 @@ by the parameters \code{starts} and \code{ends}. With \code{delta = 1} and \code the cumulative sum of temporary level shifts, once differenced the regressor will become a classical level shift. } \examples{ -iv1<-intervention_variable(12, c(2000, 1), 60, - starts = "2001-01-01", ends = "2001-12-01") +iv1 <- intervention_variable(12, c(2000, 1), 60, + starts = "2001-01-01", ends = "2001-12-01" +) plot(iv1) -iv2<- intervention_variable(12, c(2000, 1), 60, - starts = "2001-01-01", ends = "2001-12-01", delta = 1) -plot (iv2) +iv2 <- intervention_variable(12, c(2000, 1), 60, + starts = "2001-01-01", ends = "2001-12-01", delta = 1 +) +plot(iv2) # using one variable in a a seasonal adjustment process # regressors as a list of two groups reg1 and reg2 -vars<-list(reg1=list(x = iv1),reg2=list(x = iv2) ) +vars <- list(reg1 = list(x = iv1), reg2 = list(x = iv2)) # creating the modelling context -my_context<-modelling_context(variables=vars) +my_context <- modelling_context(variables = vars) # customize a default specification # init_spec <- rjd3x13::x13_spec("RSA5c") # new_spec<- add_usrdefvar(init_spec,id = "reg1.iv1", regeffect="Trend") diff --git a/man/jd3_print.Rd b/man/jd3_print.Rd index aefeaba0..964a81a5 100644 --- a/man/jd3_print.Rd +++ b/man/jd3_print.Rd @@ -23,14 +23,24 @@ \method{print}{JD3_LIKELIHOOD}(x, ...) -\method{print}{JD3_REGARIMA_RSLTS}(x, digits = max(3L, getOption("digits") - 3L), ...) +\method{print}{JD3_REGARIMA_RSLTS}( + x, + digits = max(3L, getOption("digits") - 3L), + summary_info = getOption("summary_info"), + ... +) } \arguments{ \item{x}{the object to print.} \item{...}{further unused parameters.} -\item{digits}{minimum number of significant digits to be used for most numbers.} +\item{digits}{minimum number of significant digits to be used for most +numbers.} + +\item{summary_info}{boolean indicating if a message suggesting the use of the +summary function for more details should be printed. By default used the +option \code{"summary_info"} it used, which initialized to \code{TRUE}.} } \description{ JD3 print functions diff --git a/man/jd3_utilities.Rd b/man/jd3_utilities.Rd index 5a87fdbd..8156f03f 100644 --- a/man/jd3_utilities.Rd +++ b/man/jd3_utilities.Rd @@ -337,7 +337,27 @@ DATE_MIN DATE_MAX } \arguments{ -\item{p, r, spec, model, jucm, start, end, name, s, period, startYear, startPeriod, length, type, code, prefix, span, rspan, full, rslt, jobj, jrslt, jd, jcontext, jobjRef, subclasses, result, pcalendar}{parameters.} +\item{s}{Time series} + +\item{startYear}{Initial year in the time domain} + +\item{startPeriod}{Initial period in the time domain(1 for the first period)} + +\item{length}{Length} + +\item{p, r, spec, jucm, start, end, name, period, type, code, prefix, span, rspan, full, rslt, jd, jcontext, jobjRef, jcals, subclasses, result, pcalendar}{parameters.} + +\item{model}{Model} + +\item{jobj}{Java object} + +\item{jrslt}{Reference to a Java object} + +\item{js}{Java time series} + +\item{source}{Source of the time series information} + +\item{id}{Identifier of the time series information (source-dependent)} } \description{ These functions are used in all JDemetra+ 3.0 packages to easily interact between R and Java objects. diff --git a/man/likelihood.Rd b/man/likelihood.Rd deleted file mode 100644 index 90ea9caf..00000000 --- a/man/likelihood.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{likelihood} -\alias{likelihood} -\title{Title} -\usage{ -likelihood( - nobs, - neffectiveobs = NA, - nparams = 0, - ll, - adjustedll = NA, - aic, - aicc, - bic, - bicc, - ssq -) -} -\arguments{ -\item{ssq}{} -} -\description{ -Title -} diff --git a/man/ljungbox.Rd b/man/ljungbox.Rd index 1947fd1d..4bae32c9 100644 --- a/man/ljungbox.Rd +++ b/man/ljungbox.Rd @@ -15,7 +15,7 @@ ljungbox(data, k = 1, lag = 1, nhp = 0, sign = 0, mean = TRUE) \item{nhp}{number of hyper parameters (to correct the degree of freedom)} -\item{sign}{if \code{sign = 1}, only positive auto-corrrelations are considered in the test. +\item{sign}{if \code{sign = 1}, only positive auto-correlations are considered in the test. If \code{sign = -1}, only negative auto-correlations are considered. If \code{sign = 0}, all auto-correlations are integrated in the test.} @@ -29,6 +29,6 @@ A \code{c("JD3_TEST", "JD3")} object (see \code{\link[=statisticaltest]{statisti Compute Ljung-Box test to check the independence of a data. } \examples{ -ljungbox(random_t(2, 100), lag = 24, k =1) -ljungbox(ABS$X0.2.09.10.M, lag = 24, k =1) +ljungbox(random_t(2, 100), lag = 24, k = 1) +ljungbox(ABS$X0.2.09.10.M, lag = 24, k = 1) } diff --git a/man/long_term_mean.Rd b/man/long_term_mean.Rd index cba3803a..c263b27c 100644 --- a/man/long_term_mean.Rd +++ b/man/long_term_mean.Rd @@ -19,7 +19,7 @@ long_term_mean( \item{groups}{Groups of days. The length of the array must be 7. It indicates to what group each week day belongs. The first item corresponds to Mondays and the last one to Sundays. The group used for contrasts (usually Sundays) is identified by 0. The other groups are identified by 1, 2,... n (<= 6). For instance, usual trading days are defined by c(1,2,3,4,5,6,0), -week days by c(1,1,1,1,1,0,0), week days, Saturdays, Sundays by c(1,1,1,1,1,2,0) etc...} +week days by c(1,1,1,1,1,0,0), week days, Saturdays, Sundays by c(1,1,1,1,1,2,0) etc.} \item{holiday}{Day to aggregate holidays with. (holidays are considered as that day). 1 for Monday... 7 for Sunday. Doesn't necessary belong to the 0-group.} @@ -39,17 +39,19 @@ A long-term mean is a probability based computation of the average value for eve } \examples{ BE <- national_calendar(list( -fixed_day(7,21), -special_day("NEWYEAR"), -special_day("CHRISTMAS"), -special_day("MAYDAY"), -special_day("EASTERMONDAY"), -special_day("ASCENSION"), -special_day("WHITMONDAY"), -special_day("ASSUMPTION"), -special_day("ALLSAINTSDAY"), -special_day("ARMISTICE"))) -lt<-long_term_mean(BE,12, - groups = c(1,1,1,1,1,0,0), - holiday = 7) + fixed_day(7, 21), + special_day("NEWYEAR"), + special_day("CHRISTMAS"), + special_day("MAYDAY"), + special_day("EASTERMONDAY"), + special_day("ASCENSION"), + special_day("WHITMONDAY"), + special_day("ASSUMPTION"), + special_day("ALLSAINTSDAY"), + special_day("ARMISTICE") +)) +lt <- long_term_mean(BE, 12, + groups = c(1, 1, 1, 1, 1, 0, 0), + holiday = 7 +) } diff --git a/man/lp_variable.Rd b/man/lp_variable.Rd index 7fccf57f..7646b59a 100644 --- a/man/lp_variable.Rd +++ b/man/lp_variable.Rd @@ -32,8 +32,8 @@ Allows to generate a regressor correcting for the leap year or length-of-period } \examples{ # Leap years occur in year 2000, 2004, 2008 and 2012 -lp_variable(4, start = c(2000, 1), length = 4*13) -lper<-lp_variable(12,c(2000,1),length=10*12,type ="LengthOfPeriod") +lp_variable(4, start = c(2000, 1), length = 4 * 13) +lper <- lp_variable(12, c(2000, 1), length = 10 * 12, type = "LengthOfPeriod") } \references{ More information on calendar correction in JDemetra+ online documentation: diff --git a/man/mad.Rd b/man/mad.Rd index 24b0a374..ec1d66e0 100644 --- a/man/mad.Rd +++ b/man/mad.Rd @@ -2,13 +2,24 @@ % Please edit documentation in R/tests_regular.R \name{mad} \alias{mad} -\title{Title} +\title{Compute a robust median absolute deviation (MAD)} \usage{ mad(data, centile = 50, medianCorrected = TRUE) } \arguments{ -\item{medianCorrected}{} +\item{data}{The data for which we compute the robust deviation} + +\item{centile}{The centile used to exclude extreme values (only the "centile" part of the data are is to compute the mad)} + +\item{medianCorrected}{TRUE if the series is corrected for its median, FALSE if the median is supposed to be 0} +} +\value{ +The median absolute deviation } \description{ -Title +Compute a robust median absolute deviation (MAD) +} +\examples{ +y <- rnorm(1000) +m <- rjd3toolkit::mad(y, centile = 70) } diff --git a/man/modelling_context.Rd b/man/modelling_context.Rd index e2015d63..48ac647b 100644 --- a/man/modelling_context.Rd +++ b/man/modelling_context.Rd @@ -17,19 +17,21 @@ list of calendars and variables \description{ Function allowing to include calendars and external regressors in a format that makes them usable in an estimation processes (seasonal adjustment or pre-processing). The regressors can be created with functions available in the package -or come from any other source, provided they are "TS" class objects. +or come from any other source, provided they are \code{ts} class objects. } \examples{ # creating one or several external regressors (TS objects), which will # be gathered in one or several groups -iv1<-intervention_variable(12, c(2000, 1), 60, -starts = "2001-01-01", ends = "2001-12-01") -iv2<- intervention_variable(12, c(2000, 1), 60, -starts = "2001-01-01", ends = "2001-12-01", delta = 1) +iv1 <- intervention_variable(12, c(2000, 1), 60, + starts = "2001-01-01", ends = "2001-12-01" +) +iv2 <- intervention_variable(12, c(2000, 1), 60, + starts = "2001-01-01", ends = "2001-12-01", delta = 1 +) # regressors as a list of two groups reg1 and reg2 -vars<-list(reg1=list(x = iv1),reg2=list(x = iv2) ) +vars <- list(reg1 = list(x = iv1), reg2 = list(x = iv2)) # creating the modelling context -my_context<-modelling_context(variables=vars) +my_context <- modelling_context(variables = vars) # customize a default specification # init_spec <- rjd3x13::x13_spec("RSA5c") # new_spec<- add_usrdefvar(init_spec,name = "reg1.iv1", regeffect="Trend") diff --git a/man/national_calendar.Rd b/man/national_calendar.Rd index 08bfe1d2..445e676f 100644 --- a/man/national_calendar.Rd +++ b/man/national_calendar.Rd @@ -8,6 +8,9 @@ national_calendar(days, mean_correction = TRUE) } \arguments{ \item{days}{list of holidays to be taken into account in the calendar} + +\item{mean_correction}{TRUE if the variables generated by this calendar will +contain long term mean corrections (default). FALSE otherwise.} } \value{ returns an object of class \code{c("JD3_CALENDAR","JD3_CALENDARDEFINITION")} @@ -18,23 +21,26 @@ The holidays have to be generated by one of these functions: \code{fixed_day()}, \code{fixed_week_day()}, \code{easter_day()}, \code{special_day()} or \code{single_day()}. } \examples{ -#Fictional calendar using all possibilities to set the required holidays +# Fictional calendar using all possibilities to set the required holidays MyCalendar <- national_calendar(list( - fixed_day(7,21), - special_day("NEWYEAR"), - special_day("CHRISTMAS"), - fixed_week_day(7, 2, 3), # second Wednesday of July - special_day("MAYDAY"), - easter_day(1), # Easter Monday - easter_day(-2), # Good Friday - single_day("2001-09-11"), # appearing once - special_day("ASCENSION"), - easter_day(offset=60, julian=FALSE, weight=0.5, - validity = list(start="2000-01-01", end = "2020-12-01")), # Corpus Christi - special_day("WHITMONDAY"), - special_day("ASSUMPTION"), - special_day("ALLSAINTSDAY"), - special_day("ARMISTICE"))) + fixed_day(7, 21), + special_day("NEWYEAR"), + special_day("CHRISTMAS"), + fixed_week_day(7, 2, 3), # second Wednesday of July + special_day("MAYDAY"), + easter_day(1), # Easter Monday + easter_day(-2), # Good Friday + single_day("2001-09-11"), # appearing once + special_day("ASCENSION"), + easter_day( + offset = 60, julian = FALSE, weight = 0.5, + validity = list(start = "2000-01-01", end = "2020-12-01") + ), # Corpus Christi + special_day("WHITMONDAY"), + special_day("ASSUMPTION"), + special_day("ALLSAINTSDAY"), + special_day("ARMISTICE") +)) } \references{ More information on calendar correction in JDemetra+ online documentation: diff --git a/man/normality_tests.Rd b/man/normality_tests.Rd index d97ce53c..13b1f5db 100644 --- a/man/normality_tests.Rd +++ b/man/normality_tests.Rd @@ -46,7 +46,7 @@ Set of functions to test the normality of a time series. }} \examples{ -x <- rnorm(100) # null +x <- rnorm(100) # null bowmanshenton(x) doornikhansen(x) jarquebera(x) diff --git a/man/outliers_variables.Rd b/man/outliers_variables.Rd index 5b984ea5..6f14f976 100644 --- a/man/outliers_variables.Rd +++ b/man/outliers_variables.Rd @@ -52,11 +52,13 @@ A seasonal outlier (SO, \code{so_variable}) is defined as (if \code{zeroended = -\frac{1}{s-1} & \text{otherwise }\end{cases}} } \examples{ -#Outliers in February 2002 -ao <- ao_variable(12, c(2000,1), length = 12*4, date = "2002-02-01") -ls <- ls_variable(12, c(2000,1), length = 12*4, date = "2002-02-01") -tc <- tc_variable(12, c(2000,1), length = 12*4, date = "2002-02-01") -so <- so_variable(12, c(2000,1), length = 12*4, date = "2002-02-01") -plot.ts(ts.union(ao, ls, tc, so), plot.type = "single", - col = c("black", "orange", "green", "gray")) +# Outliers in February 2002 +ao <- ao_variable(12, c(2000, 1), length = 12 * 4, date = "2002-02-01") +ls <- ls_variable(12, c(2000, 1), length = 12 * 4, date = "2002-02-01") +tc <- tc_variable(12, c(2000, 1), length = 12 * 4, date = "2002-02-01") +so <- so_variable(12, c(2000, 1), length = 12 * 4, date = "2002-02-01") +plot.ts(ts.union(ao, ls, tc, so), + plot.type = "single", + col = c("black", "orange", "green", "gray") +) } diff --git a/man/periodic.dummies.Rd b/man/periodic.dummies.Rd index 076561a8..f91e5a7b 100644 --- a/man/periodic.dummies.Rd +++ b/man/periodic.dummies.Rd @@ -24,12 +24,12 @@ Periodic dummies and contrasts \details{ The function periodic.dummies creates as many time series as types of periods in a year (4 or 12) with the value one only for one given type of period (ex Q1) -The function periodic.contrasts is based on periodic.dummies but adds -1 to the period preeceding a 1. +The periodic.contrasts function is based on periodic.dummies but adds -1 to the period preceding a 1. } \examples{ # periodic dummies for a quarterly series -p<-periodic.dummies(4, c(2000,1), 60) -#periodic contrasts for a quarterly series -q<-periodic.contrasts(4, c(2000,1), 60) -q[1:9,] +p <- periodic.dummies(4, c(2000, 1), 60) +# periodic contrasts for a quarterly series +q <- periodic.contrasts(4, c(2000, 1), 60) +q[1:9, ] } diff --git a/man/r2jd_calendarts.Rd b/man/r2jd_calendarts.Rd index 86c203c9..255b717d 100644 --- a/man/r2jd_calendarts.Rd +++ b/man/r2jd_calendarts.Rd @@ -13,9 +13,9 @@ r2jd_calendarts(calendarobs) Create Java CalendarTimeSeries } \examples{ -obs<-list( -list(start=as.Date("1980-01-01"), end=as.Date("1999-12-31"), value=2000), -list(start=as.Date("2000-01-01"), end=as.Date("2010-01-01"), value=1000) +obs <- list( + list(start = as.Date("1980-01-01"), end = as.Date("1999-12-31"), value = 2000), + list(start = as.Date("2000-01-01"), end = as.Date("2010-01-01"), value = 1000) ) -jobj<-r2jd_calendarts(obs) +jobj <- r2jd_calendarts(obs) } diff --git a/man/ramp_variable.Rd b/man/ramp_variable.Rd index df7545bd..e1062a4b 100644 --- a/man/ramp_variable.Rd +++ b/man/ramp_variable.Rd @@ -33,8 +33,8 @@ A ramp between two dates \eqn{t_0} and \eqn{t_1} is defined as: } \examples{ # Ramp variable from January 2001 to September 2001 -rp <- ramp_variable(12, c(2000,1), length = 12*4, range = c(13, 21)) +rp <- ramp_variable(12, c(2000, 1), length = 12 * 4, range = c(13, 21)) # Or equivalently -rp<-ramp_variable(12, c(2000,1), length = 12*4, range = c("2001-01-01", "2001-09-02")) +rp <- ramp_variable(12, c(2000, 1), length = 12 * 4, range = c("2001-01-01", "2001-09-02")) plot.ts(rp) } diff --git a/man/rangemean_tstat.Rd b/man/rangemean_tstat.Rd index a16ed264..7abc9dca 100644 --- a/man/rangemean_tstat.Rd +++ b/man/rangemean_tstat.Rd @@ -31,7 +31,7 @@ T-Stat of the slope of the range-mean regression. } \description{ Function to perform a range-mean regression, trimmed to avoid outlier distortion. -The slope is used in TRAMO to select whether the original series will be transformed into log or maintain in level. +The can be used to select whether the original series will be transformed into log or maintain in level. } \details{ First, the data is divided into \eqn{n} groups of successive observations of length \eqn{l} (\code{groupsize}). @@ -49,19 +49,19 @@ The function \code{rangemean_tstat} returns the T-statistic associated to \eqn{\ If it is significantly higher than 0, log transformation is recommended. } \examples{ -y = ABS$X0.2.09.10.M +y <- ABS$X0.2.09.10.M # Multiplicative pattern plot(y) -period = 12 -rm_t = rangemean_tstat(y, period = period, groupsize = period) +period <- 12 +rm_t <- rangemean_tstat(y, period = period, groupsize = period) rm_t # higher than 0 # Can be tested: pt(rm_t, period - 2, lower.tail = FALSE) # Or : -1-cdf_t(period-2, rm_t) +1 - cdf_t(period - 2, rm_t) # Close to 0 -rm_t_log = rangemean_tstat(log(y), period = period, groupsize = period) +rm_t_log <- rangemean_tstat(log(y), period = period, groupsize = period) rm_t_log pt(rm_t_log, period - 2, lower.tail = FALSE) } diff --git a/man/retail.Rd b/man/retail.Rd new file mode 100644 index 00000000..91f9d321 --- /dev/null +++ b/man/retail.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\docType{data} +\name{retail} +\alias{retail} +\title{US Retail trade statistics} +\format{ +An object of class \code{list} of length 62. +} +\source{ +US-Census Bureau +} +\usage{ +retail +} +\description{ +US Retail trade statistics +} +\keyword{datasets} diff --git a/man/sa_decomposition.Rd b/man/sa_decomposition.Rd index 4631ba5f..ae15ca53 100644 --- a/man/sa_decomposition.Rd +++ b/man/sa_decomposition.Rd @@ -39,7 +39,7 @@ the seasonally adjusted and the trend; \code{"seas-irr"} plots the seasonal and \item{caption}{the caption of the plot.} -\item{colors}{the colors used in the plot.} +\item{colors}{the colours used in the plot.} } \value{ \code{"JD3_SADECOMPOSITION"} object. diff --git a/man/sarima_decompose.Rd b/man/sarima_decompose.Rd index 1e7d7c64..a6697686 100644 --- a/man/sarima_decompose.Rd +++ b/man/sarima_decompose.Rd @@ -13,11 +13,14 @@ sarima_decompose(model, rmod = 0, epsphi = 0) \item{epsphi}{seasonal tolerance (in degrees).} } +\value{ +An UCARIMA model +} \description{ Decompose SARIMA Model into three components trend, seasonal, irregular } \examples{ -model <- sarima_model(period = 12, d =1, bd = 1, theta = -0.6, btheta = -0.5) +model <- sarima_model(period = 12, d = 1, bd = 1, theta = -0.6, btheta = -0.5) ucm <- sarima_decompose(model) } diff --git a/man/sarima_estimate.Rd b/man/sarima_estimate.Rd index 818726d9..4703ca92 100644 --- a/man/sarima_estimate.Rd +++ b/man/sarima_estimate.Rd @@ -32,5 +32,5 @@ Estimate SARIMA Model } \examples{ y <- ABS$X0.2.09.10.M -sarima_estimate(y, order = c(0,1,1), seasonal = c(0,1,1)) +sarima_estimate(y, order = c(0, 1, 1), seasonal = c(0, 1, 1)) } diff --git a/man/sarima_hannan_rissanen.Rd b/man/sarima_hannan_rissanen.Rd index d0faa56a..2c247b71 100644 --- a/man/sarima_hannan_rissanen.Rd +++ b/man/sarima_hannan_rissanen.Rd @@ -32,5 +32,5 @@ Title } \examples{ y <- ABS$X0.2.09.10.M -sarima_hannan_rissanen(y, order = c(0,1,1), seasonal = c(0,1,1)) +sarima_hannan_rissanen(y, order = c(0, 1, 1), seasonal = c(0, 1, 1)) } diff --git a/man/sarima_model.Rd b/man/sarima_model.Rd index 2e64694e..f42d3623 100644 --- a/man/sarima_model.Rd +++ b/man/sarima_model.Rd @@ -20,17 +20,21 @@ sarima_model( \item{period}{period of the model.} -\item{phi}{coefficients of the regular auto-regressive polynomial (\eqn{1 + \phi_1B + \phi_2B + ...}). True signs.} +\item{phi}{coefficients of the regular auto-regressive polynomial +(\eqn{1 + \phi_1B + \phi_2B + ...}). True signs.} \item{d}{regular differencing order.} -\item{theta}{coefficients of the regular moving average polynomial (\eqn{1 + \theta_1B + \theta_2B + ...}). True signs.} +\item{theta}{coefficients of the regular moving average polynomial +(\eqn{1 + \theta_1B + \theta_2B + ...}). True signs.} -\item{bphi}{coefficients of the seasonal auto-regressive polynomial. True signs.} +\item{bphi}{coefficients of the seasonal auto-regressive polynomial. True +signs.} \item{bd}{seasonal differencing order.} -\item{btheta}{coefficients of the seasonal moving average polynomial. True signs.} +\item{btheta}{coefficients of the seasonal moving average polynomial. True +signs.} } \value{ A \code{"JD3_SARIMA"} model. diff --git a/man/sarima_random.Rd b/man/sarima_random.Rd index 21111699..59b9e314 100644 --- a/man/sarima_random.Rd +++ b/man/sarima_random.Rd @@ -24,7 +24,7 @@ Simulate Seasonal ARIMA } \examples{ # Airline model -s_model <- sarima_model(period = 12, d =1, bd = 1, theta = 0.2, btheta = 0.2) +s_model <- sarima_model(period = 12, d = 1, bd = 1, theta = 0.2, btheta = 0.2) x <- sarima_random(s_model, length = 64, seed = 0) plot(x, type = "l") } diff --git a/man/seasonality_canovahansen.Rd b/man/seasonality_canovahansen.Rd index 32ec7040..1d823440 100644 --- a/man/seasonality_canovahansen.Rd +++ b/man/seasonality_canovahansen.Rd @@ -2,21 +2,41 @@ % Please edit documentation in R/tests_seasonality.R \name{seasonality_canovahansen} \alias{seasonality_canovahansen} -\title{Seasonal Canova-Hansen test} +\title{Canova-Hansen seasonality test} \usage{ -seasonality_canovahansen(data, p0, p1, np, original = FALSE) +seasonality_canovahansen( + data, + period, + type = c("Contrast", "Dummy", "Trigonometric"), + lag1 = TRUE, + kernel = c("Bartlett", "Square", "Welch", "Tukey", "Hamming", "Parzen"), + order = NA, + start = 1 +) } \arguments{ \item{data}{the input data.} -\item{p0}{Initial periodicity (included).} +\item{period}{Tested periodicity. Can be missing if the input is a time series} -\item{p1}{Final periodicity (included).} +\item{type}{Trigonometric variables, seasonal dummies or seasonal contrasts.} -\item{np}{Number of periodicities equally spaced in \eqn{[p_0,p_1]}.} +\item{lag1}{Lagged variable in the regression model.} -\item{original}{\code{TRUE} for original algorithm, \code{FALSE} for solution proposed by T. Proietti (based on Ox code).} +\item{kernel}{Kernel used to compute the robust Newey-West covariance matrix.} + +\item{order}{The truncation parameter used to compute the robust Newey-West covariance matrix.} + +\item{start}{Position of the first observation of the series} +} +\value{ +list with the FTest on seasonal variables, the joint test and the details for the stability of the different seasonal variables } \description{ -Seasonal Canova-Hansen test +Canova-Hansen seasonality test +} +\examples{ +s <- log(ABS$X0.2.20.10.M) +seasonality_canovahansen(s, 12, type = "Contrast") +seasonality_canovahansen(s, 12, type = "Trigonometric") } diff --git a/man/seasonality_canovahansen_trigs.Rd b/man/seasonality_canovahansen_trigs.Rd new file mode 100644 index 00000000..f6644c87 --- /dev/null +++ b/man/seasonality_canovahansen_trigs.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tests_seasonality.R +\name{seasonality_canovahansen_trigs} +\alias{seasonality_canovahansen_trigs} +\title{Canova-Hansen test using trigonometric variables} +\usage{ +seasonality_canovahansen_trigs( + data, + periods, + lag1 = TRUE, + kernel = c("Bartlett", "Square", "Welch", "Tukey", "Hamming", "Parzen"), + order = NA, + original = FALSE +) +} +\arguments{ +\item{data}{the input data.} + +\item{periods}{Periodicities.} + +\item{lag1}{Lagged variable in the regression model.} + +\item{kernel}{Kernel used to compute the robust Newey-West covariance matrix.} + +\item{order}{The truncation parameter used to compute the robust Newey-West covariance matrix.} + +\item{original}{\code{TRUE} for original algorithm, \code{FALSE} for solution proposed by T. Proietti (based on Ox code).} +} +\description{ +Canova-Hansen test using trigonometric variables +} +\examples{ +s <- log(ABS$X0.2.20.10.M) +freqs <- seq(0.01, 0.5, 0.001) +plot(seasonality_canovahansen_trigs(s, 1 / freqs, original = FALSE), type = "l") +} diff --git a/man/seasonality_combined.Rd b/man/seasonality_combined.Rd index dcd763ed..33e61429 100644 --- a/man/seasonality_combined.Rd +++ b/man/seasonality_combined.Rd @@ -4,12 +4,17 @@ \alias{seasonality_combined} \title{"X12" Test On Seasonality} \usage{ -seasonality_combined(data, period, firstperiod = cycle(data)[1], mul = TRUE) +seasonality_combined( + data, + period = NA, + firstperiod = cycle(data)[1], + mul = TRUE +) } \arguments{ \item{data}{the input data.} -\item{period}{Tested periodicity.} +\item{period}{Tested periodicity. Can be missing if the input is a time series} \item{firstperiod}{Position in a cycle of the first obs. For example, for a monthly, \code{firstperiod = 1} means January. @@ -24,6 +29,7 @@ If \code{data} is not a \code{"ts"} object, \code{firstperiod = 1} by default.} Combined test on the presence of identifiable seasonality (see Ladiray and Quenneville, 1999). } \examples{ -seasonality_combined(ABS$X0.2.09.10.M, 12) +s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +seasonality_combined(s) seasonality_combined(random_t(2, 1000), 7) } diff --git a/man/seasonality_f.Rd b/man/seasonality_f.Rd index a166a123..ac255314 100644 --- a/man/seasonality_f.Rd +++ b/man/seasonality_f.Rd @@ -4,16 +4,16 @@ \alias{seasonality_f} \title{F-test on seasonal dummies} \usage{ -seasonality_f(data, period, model = c("AR", "D1", "WN"), nyears = 0) +seasonality_f(data, period = NA, model = c("AR", "D1", "WN"), nyears = 0) } \arguments{ \item{data}{the input data.} -\item{period}{Tested periodicity.} +\item{period}{Tested periodicity. Can be missing if the input is a time series} \item{model}{the model to use for the residuals.} -\item{nyears}{Number of number of periods number of cycles considered in the test, at the end of the series: +\item{nyears}{Number of periods or number of cycles considered in the test, at the end of the series: in periods (positive value) or years (negative values). By default (\code{nyears = 0}), the entire sample is used.} } @@ -27,6 +27,6 @@ F-test on seasonal dummies Estimation of a model with seasonal dummies. Joint F-test on the coefficients of the dummies. } \examples{ -seasonality_f(ABS$X0.2.09.10.M, 12) +seasonality_f(ABS$X0.2.09.10.M, model = "D1") seasonality_f(random_t(2, 1000), 7) } diff --git a/man/seasonality_friedman.Rd b/man/seasonality_friedman.Rd index 9d7daeb8..f5cb3996 100644 --- a/man/seasonality_friedman.Rd +++ b/man/seasonality_friedman.Rd @@ -4,14 +4,14 @@ \alias{seasonality_friedman} \title{Friedman Seasonality Test} \usage{ -seasonality_friedman(data, period, nyears = 0) +seasonality_friedman(data, period = NA, nyears = 0) } \arguments{ \item{data}{the input data.} -\item{period}{Tested periodicity.} +\item{period}{Tested periodicity. Can be missing if the input is a time series} -\item{nyears}{Number of number of periods number of cycles considered in the test, at the end of the series: +\item{nyears}{Number of periods or number of cycles considered in the test, at the end of the series: in periods (positive value) or years (negative values). By default (\code{nyears = 0}), the entire sample is used.} } @@ -24,3 +24,8 @@ Friedman Seasonality Test \details{ Non parametric test ("ANOVA"-type). } +\examples{ +s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +seasonality_friedman(s) +seasonality_friedman(random_t(2, 1000), 12) +} diff --git a/man/seasonality_kruskalwallis.Rd b/man/seasonality_kruskalwallis.Rd index 867423f9..c8090e9f 100644 --- a/man/seasonality_kruskalwallis.Rd +++ b/man/seasonality_kruskalwallis.Rd @@ -9,9 +9,9 @@ seasonality_kruskalwallis(data, period, nyears = 0) \arguments{ \item{data}{the input data.} -\item{period}{Tested periodicity.} +\item{period}{Tested periodicity. Can be missing if the input is a time series} -\item{nyears}{Number of number of periods number of cycles considered in the test, at the end of the series: +\item{nyears}{Number of periods or number of cycles considered in the test, at the end of the series: in periods (positive value) or years (negative values). By default (\code{nyears = 0}), the entire sample is used.} } @@ -25,6 +25,7 @@ Kruskall-Wallis Seasonality Test Non parametric test on the ranks. } \examples{ -seasonality_kruskalwallis(ABS$X0.2.09.10.M, 12) +s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +seasonality_kruskalwallis(s) seasonality_kruskalwallis(random_t(2, 1000), 7) } diff --git a/man/seasonality_modified_qs.Rd b/man/seasonality_modified_qs.Rd new file mode 100644 index 00000000..1bd7b358 --- /dev/null +++ b/man/seasonality_modified_qs.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tests_seasonality.R +\name{seasonality_modified_qs} +\alias{seasonality_modified_qs} +\title{Modified QS Seasonality Test (Maravall)} +\usage{ +seasonality_modified_qs(data, period = NA, nyears = 0) +} +\arguments{ +\item{data}{the input data.} + +\item{period}{Tested periodicity. Can be missing if the input is a time series} + +\item{nyears}{Number of periods or number of cycles considered in the test, at the end of the series: +in periods (positive value) or years (negative values). +By default (\code{nyears = 0}), the entire sample is used.} +} +\value{ +The value of the test +} +\description{ +Modified QS Seasonality Test (Maravall) +} +\details{ +Thresholds for p-values: p.9=2.49, p.95=3.83, p.99=7.06, p.999=11.88. +Computed on 100.000.000 random series (different lengths). +Remark: the length of the series has some impact on the p-values, mainly on +short series. Not critical. +} +\examples{ +s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +seasonality_modified_qs(s) +} diff --git a/man/seasonality_periodogram.Rd b/man/seasonality_periodogram.Rd index 5e6899b3..1b6038b7 100644 --- a/man/seasonality_periodogram.Rd +++ b/man/seasonality_periodogram.Rd @@ -4,14 +4,14 @@ \alias{seasonality_periodogram} \title{Periodogram Seasonality Test} \usage{ -seasonality_periodogram(data, period, nyears = 0) +seasonality_periodogram(data, period = NA, nyears = 0) } \arguments{ \item{data}{the input data.} -\item{period}{Tested periodicity.} +\item{period}{Tested periodicity. Can be missing if the input is a time series} -\item{nyears}{Number of number of periods number of cycles considered in the test, at the end of the series: +\item{nyears}{Number of periods or number of cycles considered in the test, at the end of the series: in periods (positive value) or years (negative values). By default (\code{nyears = 0}), the entire sample is used.} } @@ -25,6 +25,7 @@ Periodogram Seasonality Test Tests on the sum of a periodogram at seasonal frequencies. } \examples{ -seasonality_periodogram(ABS$X0.2.09.10.M, 12) +s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +seasonality_periodogram(s) seasonality_periodogram(random_t(2, 1000), 7) } diff --git a/man/seasonality_qs.Rd b/man/seasonality_qs.Rd index 3791a28d..40a17e80 100644 --- a/man/seasonality_qs.Rd +++ b/man/seasonality_qs.Rd @@ -2,26 +2,30 @@ % Please edit documentation in R/tests_seasonality.R \name{seasonality_qs} \alias{seasonality_qs} -\title{QS Seasonality Test} +\title{QS (seasonal Ljung-Box) test.} \usage{ -seasonality_qs(data, period, nyears = 0) +seasonality_qs(data, period = NA, nyears = 0, type = 1) } \arguments{ \item{data}{the input data.} -\item{period}{Tested periodicity.} +\item{period}{Tested periodicity. Can be missing if the input is a time series} -\item{nyears}{Number of number of periods number of cycles considered in the test, at the end of the series: +\item{nyears}{Number of periods or number of cycles considered in the test, at the end of the series: in periods (positive value) or years (negative values). By default (\code{nyears = 0}), the entire sample is used.} + +\item{type}{1 for positive autocorrelations, -1 for negative autocorrelations, +0 for all autocorrelations. By default (\code{type = 1})} } \value{ A \code{c("JD3_TEST", "JD3")} object (see \code{\link[=statisticaltest]{statisticaltest()}} for details). } \description{ -QS (modified seasonal Ljung-Box) test. +QS (seasonal Ljung-Box) test. } \examples{ -seasonality_qs(ABS$X0.2.09.10.M, 12) +s <- do_stationary(log(ABS$X0.2.09.10.M))$ddata +seasonality_qs(s) seasonality_qs(random_t(2, 1000), 7) } diff --git a/man/set_arima.Rd b/man/set_arima.Rd index 66e01348..e372c88b 100644 --- a/man/set_arima.Rd +++ b/man/set_arima.Rd @@ -19,7 +19,8 @@ set_arima( ) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{mean}{to fix the coefficient of the mean. If \code{mean = 0}, the mean is disabled.} @@ -47,7 +48,7 @@ Function allowing to customize the ARIMA model structure when the automatic modelling is disabled.(see example) } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +\code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with \code{rjd3tramoseats::spec_tramo()}). diff --git a/man/set_automodel.Rd b/man/set_automodel.Rd index bca1cfe1..3cf3d5a0 100644 --- a/man/set_automodel.Rd +++ b/man/set_automodel.Rd @@ -23,7 +23,8 @@ set_automodel( ) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{enabled}{\code{logical}. If \code{TRUE}, the automatic modelling of the ARIMA model is enabled. If \code{FALSE}, the parameters of the ARIMA model can be specified.} @@ -90,7 +91,7 @@ and the model with the best fit is selected. Criteria considered are residual di Function allowing to customize Arima model identification procedure. } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +\code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with \code{rjd3tramoseats::spec_tramo()}). diff --git a/man/set_basic.Rd b/man/set_basic.Rd index dcae4a5d..1df19cc4 100644 --- a/man/set_basic.Rd +++ b/man/set_basic.Rd @@ -16,33 +16,39 @@ set_basic( ) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{type, d0, d1, n0, n1}{parameters to specify the sub-span . -\code{d0} and \code{d1} characters in the format "YYYY-MM-DD" to specify first/last date -of the span when \code{type} equals to \code{"From"}, \code{"To"} or \code{"Between"}. +\code{d0} and \code{d1} characters in the format "YYYY-MM-DD" to specify +first/last date of the span when \code{type} equals to \code{"From"}, +\code{"To"} or \code{"Between"}. Date corresponding to \code{d0} will be included in the sub-span Date corresponding to \code{d1} will be excluded from the sub span -\code{n0} and \code{n1} numeric to specify the number of periods at the beginning/end of the series -to be used for defining the sub-span -(\code{type} equals to \code{"First"}, \code{"Last"}) or to exclude (\code{type} equals to \code{"Excluding"}).} +\code{n0} and \code{n1} numeric to specify the number of periods at the +beginning/end of the series to be used for defining the sub-span +(\code{type} equals to \code{"First"}, \code{"Last"}) or to exclude +(\code{type} equals to \code{"Excluding"}).} -\item{preliminary.check}{a Boolean to check the quality of the input series and exclude highly problematic ones -(e.g. the series with a number of identical observations and/or missing values above pre-specified threshold values).} +\item{preliminary.check}{a Boolean to check the quality of the input series +and exclude highly problematic ones (e.g. the series with a number of +identical observations and/or missing values above pre-specified threshold +values).} \item{preprocessing}{(REGARIMA/X13 Specific) a Boolean to enable/disable the pre-processing. Option disabled for the moment.} } \description{ -Function allowing to check if the series can be processed and to define a sub-span on which -estimation will be performed +Function allowing to check if the series can be processed and to define a +sub-span on which estimation will be performed } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} -(or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" -generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with +\code{x} specification parameter must be a JD3_X13_SPEC" class object +generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated +with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with +\code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with \code{rjd3tramoseats::spec_tramo()}). } \examples{ diff --git a/man/set_benchmarking.Rd b/man/set_benchmarking.Rd index b2913f26..c49aae85 100644 --- a/man/set_benchmarking.Rd +++ b/man/set_benchmarking.Rd @@ -15,31 +15,42 @@ set_benchmarking( ) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{enabled}{Boolean to enable the user to perform benchmarking.} \item{target}{specifies the target series for the benchmarking procedure, -which can be the raw series (\code{"Normal"}); or the series adjusted for calendar effects (\code{"CalendarAdjusted"}).} +which can be the raw series (\code{"Normal"}); or the series adjusted for +calendar effects (\code{"CalendarAdjusted"}).} -\item{rho}{the value of the AR(1) parameter (set between 0 and 1) in the function used for benchmarking. Default =1.} +\item{rho}{the value of the AR(1) parameter (set between 0 and 1) in the +function used for benchmarking. Default =1.} -\item{lambda}{a parameter in the function used for benchmarking that relates to the weights in the regression equation; it is typically equal to 0, 1/2 or 1.} +\item{lambda}{a parameter in the function used for benchmarking that relates +to the weights in the regression equation; it is typically equal to 0, 1/2 +or 1.} -\item{forecast}{Boolean indicating if the forecasts of the seasonally adjusted series and of the target variable (\code{target}) are used in the benchmarking computation so that the benchmarking constrain is also applied to the forecasting period.} +\item{forecast}{Boolean indicating if the forecasts of the seasonally +adjusted series and of the target variable (\code{target}) are used in the +benchmarking computation so that the benchmarking constrain is also applied +to the forecasting period.} \item{bias}{TODO} } \description{ -Function allowing to perform a benchmarking procedure after the decomposition step in a seasonal -adjustment (disabled by default). Here benchmarking refers to a procedure ensuring consistency over the year between -seasonally adjusted and raw (or calendar adjusted) data, as seasonal adjustment can cause discrepancies between the annual totals of seasonally adjusted series +Function allowing to perform a benchmarking procedure after the decomposition +step in a seasonal adjustment (disabled by default). Here benchmarking refers +to a procedure ensuring consistency over the year between seasonally +adjusted and raw (or calendar adjusted) data, as seasonal adjustment can +cause discrepancies between the annual totals of seasonally adjusted series and the corresponding annual totals of raw (or calendar adjusted) series. } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} -(or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" -generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with +\code{x} specification parameter must be a JD3_X13_SPEC" class object +generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated +with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with +\code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with \code{rjd3tramoseats::spec_tramo()}). } \examples{ diff --git a/man/set_easter.Rd b/man/set_easter.Rd index 9d13af68..7d8dd3c5 100644 --- a/man/set_easter.Rd +++ b/man/set_easter.Rd @@ -16,7 +16,8 @@ set_easter( ) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{enabled}{a logical indicating if the program considers the Easter effect in the pre-processing model. Default = TRUE.} @@ -49,7 +50,7 @@ Possible procedures are: \code{"Estimated"} = coefficient is estimated, Set Easter effect correction in Pre-Processing Specification } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +\code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with \code{rjd3tramoseats::spec_tramo()}). diff --git a/man/set_estimate.Rd b/man/set_estimate.Rd index 2ebe48ac..03886b0e 100644 --- a/man/set_estimate.Rd +++ b/man/set_estimate.Rd @@ -17,39 +17,48 @@ set_estimate( ) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{type, d0, d1, n0, n1}{parameters to specify the sub-span . -\code{d0} and \code{d1} characters in the format "YYYY-MM-DD" to specify first/last date -of the span when \code{type} equals to \code{"From"}, \code{"To"} or \code{"Between"}. +\code{d0} and \code{d1} characters in the format "YYYY-MM-DD" to specify +first/last date of the span when \code{type} equals to \code{"From"}, +\code{"To"} or \code{"Between"}. Date corresponding to \code{d0} will be included in the sub-span Date corresponding to \code{d1} will be excluded from the sub span -\code{n0} and \code{n1} numeric to specify the number of periods at the beginning/end of the series -to be used for defining the sub-span -(\code{type} equals to \code{"First"}, \code{"Last"}) or to exclude (\code{type} equals to \code{"Excluding"}).} +\code{n0} and \code{n1} numeric to specify the number of periods at the +beginning/end of the series to be used for defining the sub-span +(\code{type} equals to \code{"First"}, \code{"Last"}) or to exclude +(\code{type} equals to \code{"Excluding"}).} -\item{tol}{a numeric, convergence tolerance. The absolute changes in the log-likelihood function -are compared to this value to check for the convergence of the estimation iterations. -(The default setting is 0.0000001)} +\item{tol}{a numeric, convergence tolerance. The absolute changes in the +log-likelihood function are compared to this value to check for the +convergence of the estimation iterations. (The default setting is 0.0000001)} -\item{exact.ml}{(TRAMO specific) \code{logical}, the exact maximum likelihood estimation. If \code{TRUE}, the program performs an exact -maximum likelihood estimation. If \code{FASLE}, the Unconditional Least Squares method is used.(Default=TRUE)} +\item{exact.ml}{(TRAMO specific) \code{logical}, the exact maximum likelihood +estimation. If \code{TRUE}, the program performs an exact maximum likelihood +estimation. If \code{FASLE}, the Unconditional Least Squares method is used. +(Default=TRUE)} -\item{unit.root.limit}{(TRAMO specific) \code{numeric}, the final unit root limit. The threshold value for the final unit root test -for identification of differencing orders. If the magnitude of an AR root for the final model is smaller than this number, -then a unit root is assumed, the order of the AR polynomial is reduced by one and the appropriate order of the differencing +\item{unit.root.limit}{(TRAMO specific) \code{numeric}, the final unit root +limit. The threshold value for the final unit root test for identification of +differencing orders. If the magnitude of an AR root for the final model is +smaller than this number, then a unit root is assumed, the order of the AR +polynomial is reduced by one and the appropriate order of the differencing (non-seasonal, seasonal) is increased.(Default value: 0.96)} } \description{ -Function allowing to define numeric boundaries for estimation and to define a sub-span on which -reg-arima (tramo) modelling will be performed (pre-processing step) +Function allowing to define numeric boundaries for estimation and to define +a sub-span on which reg-arima (tramo) modelling will be performed +(pre-processing step) } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} -(or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" -generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with +\code{x} specification parameter must be a JD3_X13_SPEC" class object +generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated +with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with +\code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with \code{rjd3tramoseats::spec_tramo()}). } \examples{ diff --git a/man/set_outlier.Rd b/man/set_outlier.Rd index c2581fd2..fa078da4 100644 --- a/man/set_outlier.Rd +++ b/man/set_outlier.Rd @@ -21,7 +21,8 @@ set_outlier( ) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{span.type, d0, d1, n0, n1}{parameters to specify the sub-span on which outliers will be detected. @@ -58,7 +59,7 @@ Function allowing to customize the automatic outlier detection process built in in the pre-processing step (regarima or tramo) } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +\code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with \code{rjd3tramoseats::spec_tramo()}). diff --git a/man/set_tradingdays.Rd b/man/set_tradingdays.Rd index 0cc5e5ea..f6cd2338 100644 --- a/man/set_tradingdays.Rd +++ b/man/set_tradingdays.Rd @@ -23,7 +23,8 @@ set_tradingdays( ) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{option}{to specify the set of trading days regression variables: \code{"TradingDays"} = six contrast variables, each type of day (from Monday to Saturday) vs Sundays; @@ -65,9 +66,12 @@ if at least one t-statistic is greater than 2.6 or if two t-statistics are great \item{coef.type, leapyear.coef.type}{vector defining if the coefficients are fixed or estimated.} -\item{automatic}{defines whether the calendar effects should be added to the model manually (\code{"Unused"}) or automatically. -During the automatic selection, the choice of the number of calendar variables can be based on the F-Test (\code{"FTest"}, TRAMO specific), the Wald Test (\code{"WaldTest"}), or by minimizing AIC or BIC; -the model with higher F value is chosen, provided that it is higher than \code{pftd}).} +\item{automatic}{defines whether the calendar effects should be added to the +model manually (\code{"Unused"}) or automatically. During the automatic +selection, the choice of the number of calendar variables can be based on +the F-Test (\code{"FTest"}, TRAMO specific), the Wald Test +(\code{"WaldTest"}), or by minimizing AIC or BIC; the model with higher +F-value is chosen, provided that it is higher than \code{pftd}).} \item{pftd}{(TRAMO SPECIFIC) \code{numeric}. The p-value used to assess the significance of the pre-tested calendar effects.} @@ -82,15 +86,17 @@ of trading day regressors.} \item{leapyear.coef}{coefficient of the leap year regressor.} } \description{ -Function allowing to select the trading-days regressors to be used for calendar correction in the -pre-processing step of a seasonal adjustment procedure. The default is \code{"TradingDays"}, with easter specific effect enabled. -(see \code{\link{set_easter}}) - -All the built-in regressors are meant to correct for type -of day effect but don't take into account any holiday. To do so user-defined regressors have to be built. +Function allowing to select the trading-days regressors to be used for +calendar correction in the pre-processing step of a seasonal adjustment +procedure. The default is \code{"TradingDays"}, with easter specific effect +enabled. (see \code{\link{set_easter}}) + +All the built-in regressors are meant to correct for type of day effect but +don't take into account any holiday. To do so user-defined regressors have to +be built. } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +\code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with \code{rjd3tramoseats::spec_tramo()}). @@ -111,20 +117,21 @@ generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" gene # Pre-defined regressors based on user-defined calendar ### create a calendar BE <- national_calendar(list( -fixed_day(7,21), - special_day("NEWYEAR"), - special_day("CHRISTMAS"), - special_day("MAYDAY"), - special_day("EASTERMONDAY"), - special_day("ASCENSION"), - special_day("WHITMONDAY"), - special_day("ASSUMPTION"), - special_day("ALLSAINTSDAY"), - special_day("ARMISTICE"))) + fixed_day(7, 21), + special_day("NEWYEAR"), + special_day("CHRISTMAS"), + special_day("MAYDAY"), + special_day("EASTERMONDAY"), + special_day("ASCENSION"), + special_day("WHITMONDAY"), + special_day("ASSUMPTION"), + special_day("ALLSAINTSDAY"), + special_day("ARMISTICE") +)) ## put into a context -my_context<-modelling_context(calendars = list(cal=BE)) +my_context <- modelling_context(calendars = list(cal = BE)) ## create a specification -#init_spec <- rjd3x13::x13_spec("RSA5c") +# init_spec <- rjd3x13::x13_spec("RSA5c") ## modify the specification # new_spec<-set_tradingdays(init_spec, # option = "TradingDays", calendar.name="cal") diff --git a/man/set_transform.Rd b/man/set_transform.Rd index 0d179283..ecdfe84d 100644 --- a/man/set_transform.Rd +++ b/man/set_transform.Rd @@ -14,7 +14,8 @@ set_transform( ) } \arguments{ -\item{x}{the specification to customize, must be a "SPEC" class object (see details).} +\item{x}{the specification to customize, must be a "SPEC" class object (see +details).} \item{fun}{the transformation of the input series: \code{"None"} = no transformation of the series; \code{"Log"} = takes the log of the series; \code{"Auto"} = the program tests for the log-level specification.} @@ -30,14 +31,14 @@ in the test for the log-level specification (\code{fun = "Auto"}). By default to transformation selection is chosen (considered only when \code{fun = "Auto"}). Default= -2.} \item{fct}{(TRAMO specific) \code{numeric} controlling the bias in the log/level pre-test: -\code{transform.fct}> 1 favors levels, \code{transform.fct}< 1 favors logs. +\code{transform.fct}> 1 favours levels, \code{transform.fct}< 1 favours logs. Considered only when \code{fun = "Auto"}.} } \description{ Set Log-level Transformation and Decomposition scheme in Pre-Processing Specification } \details{ -\code{x} specification param must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} +\code{x} specification parameter must be a JD3_X13_SPEC" class object generated with \code{rjd3x13::x13_spec()} (or "JD3_REGARIMA_SPEC" generated with \code{rjd3x13::spec_regarima()} or "JD3_TRAMOSEATS_SPEC" generated with \code{rjd3tramoseats::spec_tramoseats()} or "JD3_TRAMO_SPEC" generated with \code{rjd3tramoseats::spec_tramo()}). diff --git a/man/special_day.Rd b/man/special_day.Rd index f2601b2b..73ae50c0 100644 --- a/man/special_day.Rd +++ b/man/special_day.Rd @@ -49,8 +49,10 @@ CHRISTMAS \tab Fixed holiday, falls on December, 25th. # To add Easter Monday special_day("EASTERMONDAY") # To define a holiday for the day after Christmas, with validity and weight -special_day("CHRISTMAS", offset = 1, weight = 0.8, -validity = list(start="2000-01-01", end = "2020-12-01")) +special_day("CHRISTMAS", + offset = 1, weight = 0.8, + validity = list(start = "2000-01-01", end = "2020-12-01") +) } \references{ More information on calendar correction in JDemetra+ online documentation: diff --git a/man/statisticaltest.Rd b/man/statisticaltest.Rd index f94f642d..0eedf9ee 100644 --- a/man/statisticaltest.Rd +++ b/man/statisticaltest.Rd @@ -30,7 +30,7 @@ statisticaltest(val, pval, dist = NULL) Generic function to format the results of 'JDemetra+' tests. } \examples{ -udr_test = testofupdownruns(random_t(5, 1000)) +udr_test <- testofupdownruns(random_t(5, 1000)) udr_test # default print print(udr_test, details = TRUE) # with the distribution diff --git a/man/td.Rd b/man/td.Rd index ff2d4530..c6cf2f5c 100644 --- a/man/td.Rd +++ b/man/td.Rd @@ -25,7 +25,7 @@ parameters \code{frequency}, \code{start} and \code{length} are ignored.} \item{groups}{Groups of days. The length of the array must be 7. It indicates to what group each week day belongs. The first item corresponds to Mondays and the last one to Sundays. The group used for contrasts (usually Sundays) is identified by 0. The other groups are identified by 1, 2,... n (<= 6). For instance, usual trading days are defined by c(1,2,3,4,5,6,0), -week days by c(1,1,1,1,1,0,0), week days, Saturdays, Sundays by c(1,1,1,1,1,2,0) etc...} +week days by c(1,1,1,1,1,0,0), week days, Saturdays, Sundays by c(1,1,1,1,1,2,0) etc.} \item{contrasts}{If true, the variables are defined by contrasts with the 0-group. Otherwise, raw number of days is provided.} } @@ -46,10 +46,10 @@ the reference group (0). \examples{ # Monthly regressors for Trading Days: each type of day is different # contrasts to Sundays (6 series) -regs_td<- td(12,c(2020,1),60, groups = c(1, 2, 3, 4, 5, 6, 0), contrasts = TRUE) +regs_td <- td(12, c(2020, 1), 60, groups = c(1, 2, 3, 4, 5, 6, 0), contrasts = TRUE) # Quarterly regressors for Working Days: week days are similar # contrasts to week-end days (1 series) -regs_wd<- td(4,c(2020,1),60, groups = c(1, 1, 1, 1, 1, 0, 0), contrasts = TRUE) +regs_wd <- td(4, c(2020, 1), 60, groups = c(1, 1, 1, 1, 1, 0, 0), contrasts = TRUE) } \references{ More information on calendar correction in JDemetra+ online documentation: diff --git a/man/td_canovahansen.Rd b/man/td_canovahansen.Rd new file mode 100644 index 00000000..7dff89b6 --- /dev/null +++ b/man/td_canovahansen.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tests_td.R +\name{td_canovahansen} +\alias{td_canovahansen} +\title{Canova-Hansen test for stable trading days} +\usage{ +td_canovahansen( + s, + differencing, + kernel = c("Bartlett", "Square", "Welch", "Tukey", "Hamming", "Parzen"), + order = NA +) +} +\arguments{ +\item{s}{a \code{ts} object that corresponds to the input time series to test.} + +\item{differencing}{Differencing lags.} + +\item{kernel}{Kernel used to compute the robust covariance matrix.} + +\item{order}{The truncation parameter used to compute the robust covariance matrix.} +} +\value{ +list with the ftest on td, the joint test and the details for the stability of the different days (starting with Mondays). +} +\description{ +Canova-Hansen test for stable trading days +} +\examples{ +s <- log(ABS$X0.2.20.10.M) +td_canovahansen(s, c(1, 12)) +} diff --git a/man/td_ch.Rd b/man/td_ch.Rd deleted file mode 100644 index 14d3cdc9..00000000 --- a/man/td_ch.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tests_td.R -\name{td_ch} -\alias{td_ch} -\title{Canova-Hansen Trading Days test} -\usage{ -td_ch(s, differencing) -} -\arguments{ -\item{s}{a \code{ts} object that corresponds to the input time series to test.} - -\item{differencing}{differencing lags.} -} -\description{ -Canova-Hansen Trading Days test -} diff --git a/man/td_timevarying.Rd b/man/td_timevarying.Rd new file mode 100644 index 00000000..99451fd5 --- /dev/null +++ b/man/td_timevarying.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tests_td.R +\name{td_timevarying} +\alias{td_timevarying} +\title{Likelihood ratio test on time varying trading days} +\usage{ +td_timevarying(s, groups = c(1, 2, 3, 4, 5, 6, 0), contrasts = FALSE) +} +\arguments{ +\item{s}{The tested time series} + +\item{groups}{The groups of days used to generate the regression variables.} + +\item{contrasts}{The covariance matrix of the multivariate random walk model +used for the time-varying coefficients are related to the contrasts if TRUE, +on the actual number of days (all the days are driven by the same variance) if FALSE.} +} +\value{ +A Chi2 test +} +\description{ +Likelihood ratio test on time varying trading days +} +\examples{ +s <- log(ABS$X0.2.20.10.M) +td_timevarying(s) +} diff --git a/man/to_ts.Rd b/man/to_ts.Rd index 5a299ad7..3023ecf3 100644 --- a/man/to_ts.Rd +++ b/man/to_ts.Rd @@ -2,13 +2,22 @@ % Please edit documentation in R/timeseries.R \name{to_ts} \alias{to_ts} -\title{Title} +\title{Creates a time series object} \usage{ to_ts(source, id, type = "All") } \arguments{ -\item{type}{} +\item{source}{Source of the time series} + +\item{id}{Identifier of the time series (source-dependent)} + +\item{type}{Type of the requested information (Data, Metadata...). +All by default.} +} +\value{ +An object of type "JD3_TS". List containing the identifiers, +the data and the metadata } \description{ -Title +Creates a time series object } diff --git a/man/to_tscollection.Rd b/man/to_tscollection.Rd index cd7fd7dd..f4f9764a 100644 --- a/man/to_tscollection.Rd +++ b/man/to_tscollection.Rd @@ -2,13 +2,22 @@ % Please edit documentation in R/timeseries.R \name{to_tscollection} \alias{to_tscollection} -\title{Title} +\title{Creates a collection of time series} \usage{ to_tscollection(source, id, type = "All") } \arguments{ -\item{type}{} +\item{source}{Source of the collection of time series} + +\item{id}{Identifier of the collection of time series (source-dependent)} + +\item{type}{Type of the requested information (Data, Metadata...). +All by default.} +} +\value{ +An object of type "JD3_TSCOLLECTION". List containing the identifiers, +the metadata and all the series. } \description{ -Title +Creates a collection of time series } diff --git a/man/ts_adjust.Rd b/man/ts_adjust.Rd index 99560251..f474864f 100644 --- a/man/ts_adjust.Rd +++ b/man/ts_adjust.Rd @@ -9,8 +9,8 @@ ts_adjust(s, method = c("LeapYear", "LengthOfPeriod"), reverse = FALSE) \arguments{ \item{s}{The original time series} -\item{method}{LeapYear: correction for leap year -LengthOfPeriod: correction for the length of periods} +\item{method}{\code{"LeapYear"}: correction for leap year +\code{"LengthOfPeriod"}: correction for the length of periods} \item{reverse}{Adjustment or reverse operation} } diff --git a/man/tsdata_of.Rd b/man/tsdata_of.Rd index 06cb886f..a7343ab9 100644 --- a/man/tsdata_of.Rd +++ b/man/tsdata_of.Rd @@ -12,7 +12,7 @@ tsdata_of(values, dates) \item{dates}{Dates of the values (could be any date inside the considered period)} } \value{ -A ts object. The frequency will be identified automatically and missing values will be added in need be. +A \code{ts} object. The frequency will be identified automatically and missing values will be added in need be. The identified frequency will be the lowest frequency that match the figures. The provided data can contain missing values (NA) } @@ -21,7 +21,9 @@ Title } \examples{ # Annual series -s<-tsdata_of(c(1,2,3,4), c("1990-01-01", "1995-01-01", "1996-01-01", "2000-11-01")) +s <- tsdata_of(c(1, 2, 3, 4), c("1990-01-01", "1995-01-01", "1996-01-01", + "2000-11-01")) # Quarterly series -t<-tsdata_of(c(1,2,3,NA,4), c("1990-01-01", "1995-01-01", "1996-01-01", "2000-08-01", "2000-11-01")) +t <- tsdata_of(c(1, 2, 3, NA, 4), c("1990-01-01", "1995-01-01", "1996-01-01", + "2000-08-01", "2000-11-01")) } diff --git a/man/ucarima_canonical.Rd b/man/ucarima_canonical.Rd index 66ac6477..7b2cbd4f 100644 --- a/man/ucarima_canonical.Rd +++ b/man/ucarima_canonical.Rd @@ -2,15 +2,26 @@ % Please edit documentation in R/arima.R \name{ucarima_canonical} \alias{ucarima_canonical} -\title{Title} +\title{Makes a UCARIMA model canonical; more specifically, put all the noise of the components in one dedicated component} \usage{ ucarima_canonical(ucm, cmp = 0, adjust = TRUE) } \arguments{ -\item{ucm}{UCARIMA model returned by \code{\link[=ucarima_model]{ucarima_model()}}.} +\item{ucm}{An UCARIMA model returned by \code{\link[=ucarima_model]{ucarima_model()}}.} -\item{adjust}{} +\item{cmp}{Index of the component that will contain the noises; 0 if a new component with all the noises will be added to the model} + +\item{adjust}{If TRUE, some noise could be added to the model to ensure that all the components has positive (pseudo-)spectrum} +} +\value{ +A new UCARIMA model } \description{ -Title +Makes a UCARIMA model canonical; more specifically, put all the noise of the components in one dedicated component +} +\examples{ +mod1 <- arima_model("trend", delta = c(1, -2, 1)) +mod2 <- arima_model("noise", var = 1600) +hp <- ucarima_model(components = list(mod1, mod2)) +hpc <- ucarima_canonical(hp, cmp = 2) } diff --git a/man/ucarima_estimate.Rd b/man/ucarima_estimate.Rd index 09d314b8..3bd36807 100644 --- a/man/ucarima_estimate.Rd +++ b/man/ucarima_estimate.Rd @@ -7,15 +7,25 @@ ucarima_estimate(x, ucm, stdev = TRUE) } \arguments{ -\item{x}{univariate time series} +\item{x}{Univariate time series} -\item{ucm}{UCARIMA model returned by \code{\link[=ucarima_model]{ucarima_model()}}.} +\item{ucm}{An UCARIMA model returned by \code{\link[=ucarima_model]{ucarima_model()}}.} -\item{stdev}{} +\item{stdev}{TRUE if standard deviation of the components are computed} } \value{ -matrix containing the different components. +A matrix containing the different components and their standard deviations if stdev is TRUE. } \description{ Estimate UCARIMA Model } +\examples{ +mod1 <- arima_model("trend", delta = c(1, -2, 1)) +mod2 <- arima_model("noise", var = 16) +hp <- ucarima_model(components = list(mod1, mod2)) +s <- log(aggregate(retail$AutomobileDealers)) +all <- ucarima_estimate(s, hp, stdev = TRUE) +plot(s, type = "l") +t <- ts(all[, 1], frequency = frequency(s), start = start(s)) +lines(t, col = "blue") +} diff --git a/man/ucarima_model.Rd b/man/ucarima_model.Rd index 9d6a2498..3bc363bf 100644 --- a/man/ucarima_model.Rd +++ b/man/ucarima_model.Rd @@ -2,13 +2,32 @@ % Please edit documentation in R/arima.R \name{ucarima_model} \alias{ucarima_model} -\title{Title} +\title{Creates an UCARIMA model, which is composed of ARIMA models with independent +innovations.} \usage{ ucarima_model(model = NULL, components, complements = NULL, checkmodel = FALSE) } \arguments{ -\item{complements}{Complements of (some) components} +\item{model}{The reduced model. Usually not provided.} + +\item{components}{The ARIMA models representing the components} + +\item{complements}{Complements of (some) components. Usually not provided} + +\item{checkmodel}{When the model is provided and \emph{checkmodel} is TRUE, we +check that it indeed corresponds to the reduced form of the components; +similar controls are applied on complements. Currently not implemented} +} +\value{ +A list with the reduced model, the components and their complements } \description{ -Title +Creates an UCARIMA model, which is composed of ARIMA models with independent +innovations. +} +\examples{ +mod1 <- arima_model("trend", delta = c(1, -2, 1)) +mod2 <- arima_model("noise", var = 1600) +hp <- ucarima_model(components = list(mod1, mod2)) +print(hp$model) } diff --git a/man/ucarima_wk.Rd b/man/ucarima_wk.Rd index 6950d422..0559c8bc 100644 --- a/man/ucarima_wk.Rd +++ b/man/ucarima_wk.Rd @@ -7,10 +7,27 @@ ucarima_wk(ucm, cmp, signal = TRUE, nspectrum = 601, nwk = 300) } \arguments{ -\item{ucm}{UCARIMA model returned by \code{\link[=ucarima_model]{ucarima_model()}}.} +\item{ucm}{An UCARIMA model returned by \code{\link[=ucarima_model]{ucarima_model()}}.} -\item{nwk}{} +\item{cmp}{Index of the component for which we want to compute the filter} + +\item{signal}{TRUE for the signal (component), FALSE for the noise (complement)} + +\item{nspectrum}{Number of points used to compute the (pseudo-) spectrum of the estimator} + +\item{nwk}{Number of weights of the Wiener-Kolmogorov filter returned in the result} +} +\value{ +A list with the (pseudo-)spectrum, the weights of the filter and the squared-gain function (with the same number of points as the spectrum) } \description{ Wiener Kolmogorov Estimators } +\examples{ +mod1 <- arima_model("trend", delta = c(1, -2, 1)) +mod2 <- arima_model("noise", var = 1600) +hp <- ucarima_model(components = list(mod1, mod2)) +wk1 <- ucarima_wk(hp, 1, nwk = 50) +wk2 <- ucarima_wk(hp, 2) +plot(wk1$filter, type = "h") +} diff --git a/man/weighted_calendar.Rd b/man/weighted_calendar.Rd index 09626936..79b45af3 100644 --- a/man/weighted_calendar.Rd +++ b/man/weighted_calendar.Rd @@ -25,9 +25,9 @@ For example, in Germany public holidays are determined by the federal states. Therefore, Epiphany is celebrated only in Baden-Wurttemberg, Bavaria and in Saxony-Anhalt, while from 1994 Day of Repentance and Prayer is celebrated only in Saxony. } \examples{ -Belgium <- national_calendar(list(special_day("NEWYEAR"),fixed_day(7,21))) -France <- national_calendar(list(special_day("NEWYEAR"),fixed_day(7,14))) -composite_calendar<- weighted_calendar(list(France,Belgium), weights = c(1,2)) +Belgium <- national_calendar(list(special_day("NEWYEAR"), fixed_day(7, 21))) +France <- national_calendar(list(special_day("NEWYEAR"), fixed_day(7, 14))) +composite_calendar <- weighted_calendar(list(France, Belgium), weights = c(1, 2)) } \references{ More information on calendar correction in JDemetra+ online documentation: diff --git a/pkgdown/favicon/apple-touch-icon-120x120.png b/pkgdown/favicon/apple-touch-icon-120x120.png index 7b60e221..8cf381dc 100644 Binary files a/pkgdown/favicon/apple-touch-icon-120x120.png and b/pkgdown/favicon/apple-touch-icon-120x120.png differ diff --git a/pkgdown/favicon/apple-touch-icon-152x152.png b/pkgdown/favicon/apple-touch-icon-152x152.png index 88972477..28214b09 100644 Binary files a/pkgdown/favicon/apple-touch-icon-152x152.png and b/pkgdown/favicon/apple-touch-icon-152x152.png differ diff --git a/pkgdown/favicon/apple-touch-icon-180x180.png b/pkgdown/favicon/apple-touch-icon-180x180.png index 0b1bbbff..59b7da8c 100644 Binary files a/pkgdown/favicon/apple-touch-icon-180x180.png and b/pkgdown/favicon/apple-touch-icon-180x180.png differ diff --git a/pkgdown/favicon/apple-touch-icon-60x60.png b/pkgdown/favicon/apple-touch-icon-60x60.png index 4aea1f36..569bcc0f 100644 Binary files a/pkgdown/favicon/apple-touch-icon-60x60.png and b/pkgdown/favicon/apple-touch-icon-60x60.png differ diff --git a/pkgdown/favicon/apple-touch-icon-76x76.png b/pkgdown/favicon/apple-touch-icon-76x76.png index 9755d5c0..5e68a997 100644 Binary files a/pkgdown/favicon/apple-touch-icon-76x76.png and b/pkgdown/favicon/apple-touch-icon-76x76.png differ diff --git a/pkgdown/favicon/apple-touch-icon.png b/pkgdown/favicon/apple-touch-icon.png index fc9586a6..0c7d476a 100644 Binary files a/pkgdown/favicon/apple-touch-icon.png and b/pkgdown/favicon/apple-touch-icon.png differ diff --git a/pkgdown/favicon/favicon-16x16.png b/pkgdown/favicon/favicon-16x16.png index faa9be74..dd583bc8 100644 Binary files a/pkgdown/favicon/favicon-16x16.png and b/pkgdown/favicon/favicon-16x16.png differ diff --git a/pkgdown/favicon/favicon-32x32.png b/pkgdown/favicon/favicon-32x32.png index 146ba93b..5e6ba8b4 100644 Binary files a/pkgdown/favicon/favicon-32x32.png and b/pkgdown/favicon/favicon-32x32.png differ diff --git a/pkgdown/favicon/favicon.ico b/pkgdown/favicon/favicon.ico index 00c64f17..d0489ed0 100644 Binary files a/pkgdown/favicon/favicon.ico and b/pkgdown/favicon/favicon.ico differ diff --git a/pom.xml b/pom.xml index 80ac145e..2b7f6803 100644 --- a/pom.xml +++ b/pom.xml @@ -11,7 +11,7 @@ Usage: mvn -Pcopy-jars - 3.2.4 + 3.3.0 diff --git a/tests/spelling.R b/tests/spelling.R new file mode 100644 index 00000000..cf7f9e80 --- /dev/null +++ b/tests/spelling.R @@ -0,0 +1,7 @@ +if (requireNamespace("spelling", quietly = TRUE)) { + spelling::spell_check_test( + vignettes = TRUE, + error = FALSE, + skip_on_cran = TRUE + ) +}