diff --git a/.Rbuildignore b/.Rbuildignore index c07187b8..12b3974a 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,28 +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 aeedb8e6..38e55d1f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,44 +1,45 @@ -Package: rjd3toolkit Type: Package +Package: rjd3toolkit Title: Utility Functions around 'JDemetra+ 3.0' Version: 3.2.4.9000 Authors@R: c( - person(given = "Jean", - family = "Palate", role = c("aut"), - email = "palatejean@gmail.com"), - person(given = "Alain", - family = "Quartier-la-Tente", role = c("aut"), - email = "alain.quartier@yahoo.fr", + person("Jean", "Palate", , "palatejean@gmail.com", role = "aut"), + person("Alain", "Quartier-la-Tente", , "alain.quartier@yahoo.fr", role = "aut", comment = c(ORCID = "0000-0001-7890-3857")), - person(given = "Tanguy", - family = "Barthelemy", role = c("aut", "cre", "art"), - email ="tanguy.barthelemy@insee.fr"), - person(given = "Anna", - family = "Smyk", role = c("aut"), - email ="anna.smyk@insee.fr") - ) -Description: 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. + person("Tanguy", "Barthelemy", , "tanguy.barthelemy@insee.fr", role = c("aut", "cre", "art")), + person("Anna", "Smyk", , "anna.smyk@insee.fr", role = "aut") + ) +Description: 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. +License: file LICENSE +URL: https://github.com/rjdverse/rjd3toolkit, + https://rjdverse.github.io/rjd3toolkit/ +BugReports: https://github.com/rjdverse/rjd3toolkit/issues Depends: R (>= 4.1.0) Imports: - RProtoBuf (>= 0.4.20), - rJava (>= 1.0-6), checkmate, - methods -SystemRequirements: Java (>= 17) -License: file LICENSE -URL: https://github.com/rjdverse/rjd3toolkit, https://rjdverse.github.io/rjd3toolkit/ -LazyData: TRUE + graphics, + methods, + rJava (>= 1.0-6), + RProtoBuf (>= 0.4.20), + stats, + utils Suggests: - knitr, - rmarkdown -RoxygenNote: 7.3.2 -Roxygen: list(markdown = TRUE) -BugReports: https://github.com/rjdverse/rjd3toolkit/issues + spelling +VignetteBuilder: + knitr Encoding: UTF-8 +Language: en-GB +LazyData: TRUE +Roxygen: list(markdown = TRUE) +RoxygenNote: 7.3.2 +SystemRequirements: Java (>= 17) Collate: 'utils.R' 'jd2r.R' @@ -65,4 +66,3 @@ Collate: 'timeseries.R' 'variables.R' 'zzz.R' -VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index dac4e67f..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) @@ -283,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/R/arima.R b/R/arima.R index 349cbfc5..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 @@ -82,18 +105,22 @@ sarima_random<-function(model, length, stde=1, tdegree=0, seed=-1){ #' @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,50 +135,54 @@ sarima_decompose<-function(model, rmod=0, epsphi=0){ #' @export #' #' @examples -#' 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")) +#' 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 @@ -171,19 +202,19 @@ 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. More exactly, m_diff = m_left - m_right iff m_left = m_right + m_diff. @@ -197,17 +228,17 @@ arima_lsum<-function(components){ #' #' #' @examples -#' mod1 = arima_model(delta = c(1,-2,1)) -#' mod2 = arima_model(variance=.01) +#' 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_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)) } @@ -219,55 +250,73 @@ arima_difference<-function(left, right, simplify=TRUE){ #' @returns A list with tha auto-covariances and with the (pseudo-)spectrum #' #' @examples -#' mod1 <- arima_model(ar = c(0.1, 0.2), delta = c(1,-1), 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, 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)) +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)) } -#' Creates an UCARIMA model, which is composed of ARIMA models with independent innovations. +#' Creates an UCARIMA model, which is composed of ARIMA models with independent +#' innovations. #' #' @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 +#' @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 A list with the reduced model, the components and their complements #' @export #' #' @examples -#' mod1 <- arima_model("trend", delta = c(1,-2,1)) +#' mod1 <- arima_model("trend", delta = c(1, -2, 1)) #' mod2 <- arima_model("noise", var = 1600) -#' hp<-ucarima_model(components=list(mod1, mod2)) +#' 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") +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)) } @@ -277,28 +326,28 @@ ucarima_model<-function(model=NULL, components, complements=NULL, checkmodel=FAL #' @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 +#' @param nwk Number of weights of the Wiener-Kolmogorov filter returned in the result #' #' @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 -#' mod1 <- arima_model("trend", delta = c(1,-2,1)) +#' 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")) +#' 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")) } #' Makes a UCARIMA model canonical; more specifically, put all the noise of the components in one dedicated component @@ -311,16 +360,17 @@ ucarima_wk<-function(ucm, cmp, signal=TRUE, nspectrum=601, nwk=300){ #' @export #' #' @examples -#' mod1 <- arima_model("trend", delta = c(1,-2,1)) +#' 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)) +#' 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 @@ -333,19 +383,21 @@ ucarima_canonical<-function(ucm, cmp=0, adjust=TRUE){ #' @export #' #' @examples -#' mod1 <- arima_model("trend", delta = c(1,-2,1)) +#' mod1 <- arima_model("trend", delta = c(1, -2, 1)) #' mod2 <- arima_model("noise", var = 16) -#' hp <- ucarima_model(components=list(mod1, mod2)) +#' 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)) +#' 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 @@ -363,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 @@ -419,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 5c32552f..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,9 +706,9 @@ 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 @@ -668,35 +716,38 @@ weighted_calendar<-function(calendars, weights){ #' 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 @@ -718,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"), @@ -727,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)) @@ -762,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) } @@ -818,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 = "") @@ -826,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) @@ -840,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 0339b47d..e592a257 100644 --- a/R/differencing.R +++ b/R/differencing.R @@ -1,16 +1,20 @@ #' @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 @@ -24,27 +28,31 @@ 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 @@ -59,27 +67,31 @@ do_stationary<-function(data, period){ #' #' @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 @@ -92,34 +104,37 @@ differencing_fast<-function(data, period, mad=TRUE, centile=90, k=1.2){ #' @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 @@ -159,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 199bff75..15518e5e 100644 --- a/R/display.R +++ b/R/display.R @@ -5,224 +5,264 @@ NULL #' JD3 print functions #' #' @param x the object to print. -#' @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 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("\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) +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) + 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 @@ -231,175 +271,215 @@ 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", 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) +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), summary_info = getOption("summary_info"), ...){ - 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") - 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) + ... + ) + 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), 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) +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) + 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$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) +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 387c21e5..2d7e1d57 100644 --- a/R/jd2r.R +++ b/R/jd2r.R @@ -3,15 +3,15 @@ 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)) + } } @@ -20,74 +20,85 @@ NULL 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) + 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))) } ) @@ -96,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", .jarray(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 7acd65a7..603dd5d4 100644 --- a/R/jd3rslts.R +++ b/R/jd3rslts.R @@ -2,191 +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 if (.jinstanceof(s, "jdplus/toolkit/base/api/timeseries/regression/RegressionItem")){ - return(.jd2r_regression_item(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 775f6bc6..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 bfd6bd1d..82c12fa7 100644 --- a/R/protobuf.R +++ b/R/protobuf.R @@ -25,58 +25,64 @@ 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){ @@ -91,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)) } @@ -265,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) -} - -#' @export -#' @rdname jd3_utilities -.p2r_ramps<-function(p){ - if (length(p) == 0){return(NULL)} - return(lapply(p, function(z){.p2r_ramp(z)})) +.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 -.r2p_ramps<-function(r){ - if (length(r) == 0){return(list())} - return(lapply(r, function(z){.r2p_ramp(z)})) +.p2r_ramps <- function(p) { + if (length(p) == 0) { + return(NULL) + } + return(lapply(p, function(z) { + .p2r_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) -} - -.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)})) +.r2p_ramps <- function(r) { + if (length(r) == 0) { + return(list()) + } + return(lapply(r, function(z) { + .r2p_ramp(z) + })) } -.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) +.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) } -#' @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 c301e7f2..fbda555b 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()}). @@ -1419,19 +1502,21 @@ set_transform.default <- function(x, #' @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 0ab34e6a..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,46 +170,52 @@ 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)) } #' Compute a robust median absolute deviation (MAD) @@ -214,8 +228,8 @@ kurtosis<-function(data){ #' @export #' #' @examples -#' 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))) +#' 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 d7dc9868..166e4b7d 100644 --- a/R/tests_seasonality.R +++ b/R/tests_seasonality.R @@ -16,15 +16,18 @@ NULL #' @export #' #' @examples -#' s<-do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' 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=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)) +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) @@ -40,7 +43,7 @@ seasonality_qs<-function(data, period=NA, nyears=0, type=1){ #' @export #' #' @examples -#' s<-do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' 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. @@ -48,11 +51,14 @@ seasonality_qs<-function(data, period=NA, nyears=0, type=1){ #' 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)) +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)) + } + test <- .jcall( + "jdplus/sa/base/r/SeasonalityTests", "D", "modifiedQsTest", + as.numeric(data), as.integer(period), as.integer(nyears) + ) return(test) } @@ -72,15 +78,18 @@ seasonality_modified_qs<-function(data, period=NA, nyears=0){ #' @export #' #' @examples -#' s<-do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' 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 @@ -92,15 +101,18 @@ seasonality_kruskalwallis<-function(data, period, nyears=0){ #' @export #' #' @examples -#' s<-do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' 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=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)) +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 @@ -112,15 +124,18 @@ seasonality_periodogram<-function(data, period=NA, nyears=0){ #' @export #' #' @examples -#' s<-do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' 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)) +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 @@ -132,18 +147,21 @@ seasonality_friedman<-function(data, period=NA, nyears=0){ #' @export #' #' @examples -#' seasonality_f(ABS$X0.2.09.10.M, model="D1") +#' seasonality_f(ABS$X0.2.09.10.M, model = "D1") #' seasonality_f(random_t(2, 1000), 7) -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)) +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)) } @@ -158,21 +176,27 @@ seasonality_f<-function(data, #' @export #' #' @examples -#' s<-do_stationary(log(ABS$X0.2.09.10.M))$ddata +#' 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=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) - 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) } #' Canova-Hansen test using trigonometric variables @@ -187,19 +211,20 @@ seasonality_combined<-function(data, period=NA, firstperiod=cycle(data)[1], mul= #' @export #' #' @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') -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)) +#' 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) } @@ -216,20 +241,22 @@ seasonality_canovahansen_trigs<-function(data, periods, lag1=TRUE, #' #' #' @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)])) +#' 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 fd08887c..8dc009b9 100644 --- a/R/tests_td.R +++ b/R/tests_td.R @@ -46,12 +46,14 @@ 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 test for stable trading days @@ -65,18 +67,20 @@ td_f<-function(s, model=c("D1", "DY", "DYD1", "WN", "AIRLINE", "R011", "R100"), #' @export #' #' @examples -#' 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)) +#' 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)])) + 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 @@ -91,13 +95,14 @@ td_canovahansen<-function(s, differencing, kernel=c("Bartlett", "Square", "Welch #' @export #' #' @examples -#' s<-log(ABS$X0.2.20.10.M) +#' 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)) +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 604cb0fd..46332928 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,39 +153,38 @@ 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 } #' Provides a list of dates corresponding to each period of the given time series @@ -199,11 +196,11 @@ ts_adjust.data.frame <- function(s, method=c("LeapYear", "LengthOfPeriod"), reve #' @export #' #' @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)) +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)) } #' Creates a time series object @@ -216,12 +213,12 @@ daysOf<-function(ts, pos=1){ #' @return An object of type "JD3_TS". List containing the identifiers, #' the data and the metadata #' @export -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)) } #' Creates a collection of time series @@ -236,15 +233,15 @@ to_ts<-function(source, id, type="All"){ #' @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 @@ -253,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 @@ -290,19 +287,21 @@ 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)) } @@ -316,8 +315,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 13d90025..b68020e1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -23,39 +23,39 @@ NULL "Imports" -ymd<-function(y, m, d=1){ - return(as.Date(sprintf("%04i-%02i-%02i", y, m, d))) +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") } @@ -63,15 +63,15 @@ 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)) } #' Information on the (log-)likelihood @@ -90,13 +90,16 @@ test_anova<-function(ssm, dfm, ssr, dfr){ #' @export #' #' @examples -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")) +.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" + )) } 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 53418a96..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,22 +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(sprintf("Your java version is %s. 17 or higher is needed.", jversion)) - } + # 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) - - if(is.null(getOption("summary_info"))) - options(summary_info = TRUE) + 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/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..311c3301 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()}). diff --git a/man/calendar_td.Rd b/man/calendar_td.Rd index b572304c..9837dc89 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.} diff --git a/man/data_to_ts.Rd b/man/data_to_ts.Rd index 37166753..1fb6a60c 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,7 +12,7 @@ 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 diff --git a/man/differencing_fast.Rd b/man/differencing_fast.Rd index 93d1ac20..d977c5b7 100644 --- a/man/differencing_fast.Rd +++ b/man/differencing_fast.Rd @@ -20,12 +20,12 @@ differencing_fast(data, period, mad = TRUE, centile = 90, k = 1.2) \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 } } } diff --git a/man/do_stationary.Rd b/man/do_stationary.Rd index 292307bf..7a0170dc 100644 --- a/man/do_stationary.Rd +++ b/man/do_stationary.Rd @@ -14,12 +14,12 @@ 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 } } } diff --git a/man/likelihood.Rd b/man/dot-likelihood.Rd similarity index 93% rename from man/likelihood.Rd rename to man/dot-likelihood.Rd index 46bb75bc..69855ee7 100644 --- a/man/likelihood.Rd +++ b/man/dot-likelihood.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R -\name{likelihood} -\alias{likelihood} +\name{.likelihood} +\alias{.likelihood} \title{Information on the (log-)likelihood} \usage{ -likelihood( +.likelihood( nobs, neffectiveobs = NA, nparams = 0, 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/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/jd3_print.Rd b/man/jd3_print.Rd index d658114c..964a81a5 100644 --- a/man/jd3_print.Rd +++ b/man/jd3_print.Rd @@ -35,9 +35,12 @@ \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}.} +\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/ljungbox.Rd b/man/ljungbox.Rd index 1947fd1d..8ceda81e 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.} diff --git a/man/long_term_mean.Rd b/man/long_term_mean.Rd index cba3803a..04f50341 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.} diff --git a/man/modelling_context.Rd b/man/modelling_context.Rd index e2015d63..b00e4868 100644 --- a/man/modelling_context.Rd +++ b/man/modelling_context.Rd @@ -17,7 +17,7 @@ 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 diff --git a/man/periodic.dummies.Rd b/man/periodic.dummies.Rd index 076561a8..c5e55739 100644 --- a/man/periodic.dummies.Rd +++ b/man/periodic.dummies.Rd @@ -24,7 +24,7 @@ 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 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_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/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..02ab1eb0 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()}). 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/td.Rd b/man/td.Rd index ff2d4530..a93e9d4b 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.} } 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..6d1a4621 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) } diff --git a/man/ucarima_model.Rd b/man/ucarima_model.Rd index ba221ac4..c7f7ae2e 100644 --- a/man/ucarima_model.Rd +++ b/man/ucarima_model.Rd @@ -2,7 +2,8 @@ % Please edit documentation in R/arima.R \name{ucarima_model} \alias{ucarima_model} -\title{Creates an UCARIMA model, which is composed of ARIMA models with independent innovations.} +\title{Creates an UCARIMA model, which is composed of ARIMA models with independent +innovations.} \usage{ ucarima_model(model = NULL, components, complements = NULL, checkmodel = FALSE) } @@ -13,13 +14,16 @@ ucarima_model(model = NULL, components, complements = NULL, checkmodel = FALSE) \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} +\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{ -Creates an UCARIMA model, which is composed of ARIMA models with independent innovations. +Creates an UCARIMA model, which is composed of ARIMA models with independent +innovations. } \examples{ mod1 <- arima_model("trend", delta = c(1,-2,1)) diff --git a/man/ucarima_wk.Rd b/man/ucarima_wk.Rd index 1fdce244..54616b1e 100644 --- a/man/ucarima_wk.Rd +++ b/man/ucarima_wk.Rd @@ -15,7 +15,7 @@ ucarima_wk(ucm, cmp, signal = TRUE, nspectrum = 601, nwk = 300) \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} +\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) 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/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 + ) +}