├── .github ├── .gitignore ├── ISSUE_TEMPLATE.md ├── CODE_OF_CONDUCT.md ├── workflows │ ├── test-coverage.yaml │ ├── pkgdown.yaml │ ├── pr-commands.yaml │ └── R-CMD-check.yaml ├── SUPPORT.md └── CONTRIBUTING.md ├── revdep ├── failures.md ├── problems.md ├── checks.rds ├── cran.md ├── timing.md └── README.md ├── data ├── htseg1.rda ├── htseg2.rda └── infantgts.rda ├── inst └── docs │ └── hts.pdf ├── man ├── figures │ ├── logo.png │ ├── gts-eg-1.png │ ├── gts-eg-2.png │ ├── gts-eg-3.png │ ├── hts-eg1-1.png │ ├── hts-eg1-2.png │ ├── hts-eg1-3.png │ ├── hts-eg2-1.png │ └── hts-eg2-2.png ├── helper-functions.Rd ├── window.gts.Rd ├── infantgts.Rd ├── allts.Rd ├── htseg1.Rd ├── aggts.Rd ├── smatrix.Rd ├── plot.gts.Rd ├── hts-package.Rd ├── accuracy.gts.Rd ├── hts-class.Rd ├── combinef.Rd ├── gts-class.Rd ├── MinT.Rd └── forecast.gts.Rd ├── tests ├── testthat.R └── testthat │ ├── test-forecast.R │ ├── test-aggts.R │ ├── test-smatrix.R │ ├── test-combinef.R │ ├── test-gts.R │ └── test-hts.R ├── CRAN-SUBMISSION ├── src ├── Makevars ├── Makevars.win ├── cgm_RcppEigen.cpp └── RcppExports.cpp ├── CRAN-RELEASE ├── R ├── RcppExports.R ├── imports.R ├── combineg.R ├── window-gts.R ├── combinefm.R ├── middleout.R ├── smatrix.R ├── topdown.R ├── aggts.R ├── hts-package.R ├── accuracy-gts.R ├── plot-gts.R ├── tracemin.R ├── MinTbpv.R ├── recursive.R ├── bpv.R ├── hts.R ├── combinef.R ├── MinT.R ├── gts.R └── forecast-gts.R ├── .Rbuildignore ├── .gitignore ├── codecov.yml ├── cran-comments.md ├── _pkgdown.yml ├── Makefile ├── NAMESPACE ├── DESCRIPTION ├── README.Rmd ├── NEWS.md └── README.md /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /revdep/failures.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /revdep/problems.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /data/htseg1.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/data/htseg1.rda -------------------------------------------------------------------------------- /data/htseg2.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/data/htseg2.rda -------------------------------------------------------------------------------- /inst/docs/hts.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/inst/docs/hts.pdf -------------------------------------------------------------------------------- /revdep/checks.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/revdep/checks.rds -------------------------------------------------------------------------------- /data/infantgts.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/data/infantgts.rda -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/man/figures/logo.png -------------------------------------------------------------------------------- /man/figures/gts-eg-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/man/figures/gts-eg-1.png -------------------------------------------------------------------------------- /man/figures/gts-eg-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/man/figures/gts-eg-2.png -------------------------------------------------------------------------------- /man/figures/gts-eg-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/man/figures/gts-eg-3.png -------------------------------------------------------------------------------- /man/figures/hts-eg1-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/man/figures/hts-eg1-1.png -------------------------------------------------------------------------------- /man/figures/hts-eg1-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/man/figures/hts-eg1-2.png -------------------------------------------------------------------------------- /man/figures/hts-eg1-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/man/figures/hts-eg1-3.png -------------------------------------------------------------------------------- /man/figures/hts-eg2-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/man/figures/hts-eg2-1.png -------------------------------------------------------------------------------- /man/figures/hts-eg2-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/earowang/hts/HEAD/man/figures/hts-eg2-2.png -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | Sys.setenv("R_TESTS" = "") 2 | if(require(testthat) & require(hts)) 3 | test_check("hts") 4 | -------------------------------------------------------------------------------- /CRAN-SUBMISSION: -------------------------------------------------------------------------------- 1 | Version: 6.0.3 2 | Date: 2024-07-30 12:58:12 UTC 3 | SHA: 51b9dbf2f6e28f2b9830bb35bff65e1f8383b18e 4 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | ## Use the R_HOME indirection to support installations of multiple R version 2 | PKG_LIBS=$(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 3 | -------------------------------------------------------------------------------- /CRAN-RELEASE: -------------------------------------------------------------------------------- 1 | This package was submitted to CRAN on 2021-05-30. 2 | Once it is accepted, delete this file and tag the release (commit 0108924). 3 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | 2 | ## This assume that we can call Rscript to ask Rcpp about its locations 3 | ## Use the R_HOME indirection to support installations of multiple R version 4 | PKG_LIBS=$(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 5 | -------------------------------------------------------------------------------- /revdep/cran.md: -------------------------------------------------------------------------------- 1 | ## revdepcheck results 2 | 3 | We checked 3 reverse dependencies, comparing R CMD check results across CRAN and dev versions of this package. 4 | 5 | * We saw 0 new problems 6 | * We failed to check 0 packages 7 | 8 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | cgm_c <- function(As, bs) { 5 | .Call('_hts_cgm_c', PACKAGE = 'hts', As, bs) 6 | } 7 | 8 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.travis\.yml$ 4 | ^docs$ 5 | ^_pkgdown\.yml$ 6 | ^README\.Rmd$ 7 | ^Makefile$ 8 | ^cran-comments\.md$ 9 | ^revdep$ 10 | ^.github$ 11 | ^pkgdown$ 12 | ^CRAN-RELEASE$ 13 | ^codecov\.yml$ 14 | ^\.github$ 15 | ^CRAN-SUBMISSION$ 16 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | symbols.rds 4 | .Rhistory 5 | .Rproj.user 6 | hts.Rproj 7 | *.bbl 8 | *.blg 9 | *.dvi 10 | *.out 11 | *.aux 12 | *.log 13 | *.fdb_latexmk 14 | hts.tex 15 | inst/doc 16 | docs 17 | pkgdown/ 18 | revdep/library 19 | revdep/checks 20 | revdep/data.sqlite 21 | -------------------------------------------------------------------------------- /tests/testthat/test-forecast.R: -------------------------------------------------------------------------------- 1 | # A unit test for forecast.gts() function 2 | test_that("tests for 3 dots", { 3 | f1 <- forecast(htseg2, h = 4, algorithms = "lu") 4 | f2 <- forecast(htseg2, h = 4, ic = "aic", algorithms = "lu") 5 | 6 | expect_false(all(f1$bts == f2$bts)) 7 | }) 8 | -------------------------------------------------------------------------------- /revdep/timing.md: -------------------------------------------------------------------------------- 1 | # Check times 2 | 3 | | |package |version | check_time| 4 | |:--|:-------|:-------|----------:| 5 | |4 |tsibble |0.1.3 | 65.9| 6 | |2 |gtop |0.2.0 | 45.3| 7 | |3 |thief |0.3 | 36.4| 8 | |1 |corset |0.1-4 | 15.4| 9 | 10 | 11 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /R/imports.R: -------------------------------------------------------------------------------- 1 | #' @importFrom graphics lines par plot strwidth text 2 | #' @import grDevices 3 | #' @importFrom utils combn 4 | #' @import methods 5 | #' @importFrom stats window as.ts fitted frequency is.ts na.omit residuals time ts tsp tsp<- 6 | #' @import Matrix 7 | #' @importFrom SparseM as.matrix.csr 8 | #' @import forecast 9 | #' @import parallel 10 | #' @useDynLib hts 11 | NULL 12 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Comments 2 | 3 | This is a resubmission to fix CRAN errors. 4 | 5 | ## R CMD check results 6 | 7 | 0 errors | 0 warnings | 0 notes 8 | 9 | ## Reverse dependencies 10 | 11 | We checked 3 reverse dependencies, comparing R CMD check results across CRAN and dev versions of this package. 12 | 13 | * We saw 0 new problems 14 | * We failed to check 0 packages 15 | 16 | -------------------------------------------------------------------------------- /R/combineg.R: -------------------------------------------------------------------------------- 1 | SLM <- function(fcasts, S, weights = NULL) { 2 | class(fcasts) <- stats::tsp(fcasts) <- NULL 3 | fcasts <- t(stats::na.omit(t(fcasts))) # In case of "NA" 4 | if (is.null(weights)) { 5 | coef <- SparseM::slm.fit(S, fcasts)$coefficients 6 | } else { 7 | coef <- SparseM::slm.wfit(S, fcasts, weights = weights)$coefficients 8 | } 9 | fitted.v <- as.matrix(S %*% coef) 10 | return(fitted.v) 11 | } 12 | -------------------------------------------------------------------------------- /man/helper-functions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/gts.R, R/hts.R 3 | \name{get_groups} 4 | \alias{get_groups} 5 | \alias{get_nodes} 6 | \title{Get nodes/groups from an hts/gts object} 7 | \usage{ 8 | get_groups(y) 9 | 10 | get_nodes(y) 11 | } 12 | \arguments{ 13 | \item{y}{An hts or gts object 14 | series.} 15 | } 16 | \description{ 17 | Get nodes/groups from an hts/gts object 18 | } 19 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | template: 2 | params: 3 | bootswatch: united 4 | 5 | development: 6 | mode: auto 7 | 8 | authors: 9 | Rob Hyndman: 10 | href: http://robjhyndman.com 11 | Earo Wang: 12 | href: http://earo.me 13 | 14 | navbar: 15 | type: default 16 | left: 17 | - text: "Reference" 18 | href: reference/index.html 19 | - text: "Vignettes" 20 | href: https://CRAN.R-project.org/package=hts/vignettes/hts.pdf 21 | - text: "News" 22 | href: news/index.html 23 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | Please briefly describe your problem and what output you expect. If you have a question, please don't use this form. Instead, ask on or . 2 | 3 | Please include a minimal reproducible example (AKA a reprex). If you've never heard of a [reprex](http://reprex.tidyverse.org/) before, start by reading . 4 | 5 | --- 6 | 7 | Brief description of the problem 8 | 9 | ```r 10 | # insert reprex here 11 | ``` 12 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | document: 2 | Rscript -e "devtools::document()" 3 | 4 | readme: 5 | Rscript -e "rmarkdown::render('README.Rmd')" 6 | 7 | build: 8 | Rscript -e "devtools::build()" 9 | 10 | check: 11 | Rscript -e "devtools::check()" 12 | 13 | install: 14 | Rscript -e "devtools::install(build_vignettes = TRUE)" 15 | 16 | revdep-check: 17 | Rscript -e "devtools::revdep_check(); devtools::revdep_check_save_summary(); devtools::revdep_check_print_problems()" 18 | 19 | winbuild: 20 | Rscript -e "devtools::build_win(version = 'R-devel', quiet = TRUE)" 21 | 22 | pkgdown: 23 | Rscript -e "pkgdown::build_site(run_dont_run = TRUE)" 24 | -------------------------------------------------------------------------------- /R/window-gts.R: -------------------------------------------------------------------------------- 1 | #' Time window of a gts object 2 | #' 3 | #' Extracts a subset of the time series from a grouped time series object. 4 | #' 5 | #' 6 | #' @param x An object of class \code{\link[hts]{gts}}. 7 | #' @param ... All other arguments are passed to \code{\link[stats]{window.ts}}. 8 | #' @author Rob J Hyndman 9 | #' @keywords ts 10 | #' @method window gts 11 | #' @examples 12 | #' 13 | #' window(htseg2, start = 2000, end = 2001) 14 | #' 15 | #' @export 16 | window.gts <- function(x, ...) { 17 | # Select a snapshot of hts or gts 18 | x$bts <- stats::window(x$bts, ...) 19 | tsp(x) <- stats::tsp(x) 20 | return(x) 21 | } 22 | -------------------------------------------------------------------------------- /tests/testthat/test-aggts.R: -------------------------------------------------------------------------------- 1 | # A unit test for aggts() function 2 | context("Tests on input") 3 | test_that("tests for a non-gts object", { 4 | set.seed(1234) 5 | mts <- ts(matrix(5 + sort(rnorm(500)), nrow = 50, ncol = 10)) 6 | 7 | expect_that(aggts(mts), throws_error()) 8 | }) 9 | 10 | context("Tests on output") 11 | test_that("tests for a non-gts object", { 12 | set.seed(1234) 13 | mts <- ts(matrix(5 + sort(rnorm(500)), nrow = 50, ncol = 10)) 14 | node.list <- list(3, c(2, 3, 1), c(2, 2, 1, 1, 1, 3)) 15 | hts <- hts(mts, nodes = node.list) 16 | out <- dim(aggts(hts)) 17 | 18 | expect_that(out, equals(c(50, 20))) 19 | }) 20 | -------------------------------------------------------------------------------- /man/window.gts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/window-gts.R 3 | \name{window.gts} 4 | \alias{window.gts} 5 | \title{Time window of a gts object} 6 | \usage{ 7 | \method{window}{gts}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{An object of class \code{\link[hts]{gts}}.} 11 | 12 | \item{...}{All other arguments are passed to \code{\link[stats]{window.ts}}.} 13 | } 14 | \description{ 15 | Extracts a subset of the time series from a grouped time series object. 16 | } 17 | \examples{ 18 | 19 | window(htseg2, start = 2000, end = 2001) 20 | 21 | } 22 | \author{ 23 | Rob J Hyndman 24 | } 25 | \keyword{ts} 26 | -------------------------------------------------------------------------------- /revdep/README.md: -------------------------------------------------------------------------------- 1 | # Platform 2 | 3 | |field |value | 4 | |:--------|:----------------------------| 5 | |version |R version 3.6.1 (2019-07-05) | 6 | |os |macOS Catalina 10.15.3 | 7 | |system |x86_64, darwin15.6.0 | 8 | |ui |RStudio | 9 | |language |(EN) | 10 | |collate |en_AU.UTF-8 | 11 | |ctype |en_AU.UTF-8 | 12 | |tz |Pacific/Auckland | 13 | |date |2020-03-29 | 14 | 15 | # Dependencies 16 | 17 | |package |old |new |Δ | 18 | |:-------|:-----|:----------|:--| 19 | |hts |5.1.5 |5.1.5.9000 |* | 20 | 21 | # Revdeps 22 | 23 | -------------------------------------------------------------------------------- /man/infantgts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/hts-package.R 3 | \docType{data} 4 | \name{infantgts} 5 | \alias{infantgts} 6 | \title{Regional infant mortality counts across Australia from 1933 to 2003.} 7 | \format{ 8 | Objects of class \code{\link[hts]{gts}}. 9 | } 10 | \description{ 11 | These are infant mortality counts. This data set is an example of 12 | \code{gts}, where the total infant mortality count in Australia can be first 13 | disaggregated by sex then by state, or vice versa. 14 | } 15 | \examples{ 16 | 17 | plot(infantgts) 18 | 19 | } 20 | \references{ 21 | R. J. Hyndman, R. A. Ahmed, G. Athanasopoulos and H.L. Shang 22 | (2011) Optimal combination forecasts for hierarchical time series. 23 | \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 24 | } 25 | \keyword{datasets} 26 | -------------------------------------------------------------------------------- /man/allts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/aggts.R 3 | \name{allts} 4 | \alias{allts} 5 | \title{Extract all time series from a gts object} 6 | \usage{ 7 | allts(y, forecasts = TRUE) 8 | } 9 | \arguments{ 10 | \item{y}{An object of class \code{\link[hts]{gts}}.} 11 | 12 | \item{forecasts}{If \code{y} contains forecasts and historical data, then 13 | \code{forecasts} indicates whether to return the forecasts or the historical 14 | data. Otherwise it is ignored.} 15 | } 16 | \description{ 17 | The time series from all levels of a hierarchical/grouped time series or a 18 | forecasted hierarchical/grouped time series are returned as a multivariate 19 | time series. 20 | } 21 | \examples{ 22 | 23 | allts(htseg1) 24 | 25 | } 26 | \seealso{ 27 | \code{\link[hts]{aggts}} 28 | } 29 | \author{ 30 | Rob J Hyndman 31 | } 32 | \keyword{ts} 33 | -------------------------------------------------------------------------------- /man/htseg1.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/hts-package.R 3 | \docType{data} 4 | \name{htseg1} 5 | \alias{htseg1} 6 | \alias{htseg2} 7 | \title{Simple examples of hierarchical time series.} 8 | \format{ 9 | Objects of class \code{\link[hts]{hts}}. 10 | } 11 | \description{ 12 | These are simulated data. \code{htseg1} has three levels with a total of 8 13 | series each of length 10. \code{htseg2} has four levels with a total of 17 14 | series each of length 16. 15 | } 16 | \examples{ 17 | 18 | plot(htseg1) 19 | 20 | } 21 | \references{ 22 | R. J. Hyndman, R. A. Ahmed, G. Athanasopoulos and H.L. Shang 23 | (2011) Optimal combination forecasts for hierarchical time series. 24 | \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 25 | \url{https://robjhyndman.com/publications/hierarchical/} 26 | } 27 | \keyword{datasets} 28 | -------------------------------------------------------------------------------- /tests/testthat/test-smatrix.R: -------------------------------------------------------------------------------- 1 | # A unit test for the inverse of row sums of smatrix 2 | test_that("tests for hts", { 3 | set.seed(1234) 4 | mts <- ts(matrix(5 + sort(rnorm(500)), nrow = 50, ncol = 10)) 5 | node.list <- list(3, c(2, 3, 1), c(2, 2, 1, 1, 1, 3)) 6 | hts <- hts(mts, nodes = node.list) 7 | s <- 1/rowSums(smatrix(hts)) 8 | 9 | expect_that(InvS4h(node.list), equals(s)) 10 | }) 11 | 12 | test_that("tests for gts", { 13 | set.seed(1234) 14 | mts <- ts(5 + matrix(sort(rnorm(2700)), nrow = 100, ncol = 27), 15 | start = c(2001, 1), frequency = 12) 16 | g <- matrix(c(rep(1:3, each = 9), rep(c(rep(1, 3), rep(2, 3), rep(3, 3)), 3), 17 | rep(1:3, 9)), nrow = 3, byrow = TRUE) 18 | gts <- gts(mts, groups = g) 19 | s <- 1/rowSums(smatrix(gts)) 20 | out <- InvS4g(gts$groups) 21 | names(out) <- NULL 22 | 23 | expect_that(out, equals(s)) 24 | }) 25 | -------------------------------------------------------------------------------- /src/cgm_RcppEigen.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | //#include 5 | //#include 6 | using namespace Eigen; 7 | using namespace Rcpp; 8 | 9 | using Eigen::SparseMatrix; 10 | using Eigen::MappedSparseMatrix; 11 | using Eigen::Map; 12 | using Eigen::MatrixXd; 13 | using Eigen::VectorXd; 14 | using Rcpp::as; 15 | using Eigen::ConjugateGradient; 16 | typedef Eigen::MappedSparseMatrix MSpMat; 17 | 18 | // [[Rcpp::depends(RcppEigen)]] 19 | // [[Rcpp::export]] 20 | Eigen::MatrixXd cgm_c(SEXP As, SEXP bs) { 21 | const MSpMat A = as(As); 22 | //const Map A(as > (As)); 23 | const Map b(as > (bs)); 24 | ConjugateGradient > cg; 25 | cg.setTolerance(1e-06); 26 | //ConjugateGradient cg; 27 | //cg.compute(A); 28 | MatrixXd x=cg.compute(A).solve(b); 29 | return x; 30 | } 31 | -------------------------------------------------------------------------------- /man/aggts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/aggts.R 3 | \name{aggts} 4 | \alias{aggts} 5 | \title{Extract selected time series from a gts object} 6 | \usage{ 7 | aggts(y, levels, forecasts = TRUE) 8 | } 9 | \arguments{ 10 | \item{y}{An object of class \code{{gts}}.} 11 | 12 | \item{levels}{Integer(s) or string(s) giving the specified level(s).} 13 | 14 | \item{forecasts}{If \code{y} contains forecasts and historical data, then 15 | \code{forecasts} indicates whether to return the forecasts or the historical 16 | data. Otherwise it is ignored.} 17 | } 18 | \description{ 19 | The time series from selected levels of a hierarchical/grouped time series 20 | or a forecasted hierarchical/grouped time series are returned as a 21 | multivariate time series. 22 | } 23 | \examples{ 24 | 25 | aggts(htseg1, levels = c(0, 2)) 26 | aggts(infantgts, levels = "State") 27 | 28 | } 29 | \seealso{ 30 | \code{\link[hts]{allts}} 31 | } 32 | \author{ 33 | Earo Wang 34 | } 35 | \keyword{ts} 36 | -------------------------------------------------------------------------------- /man/smatrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/smatrix.R 3 | \name{smatrix} 4 | \alias{smatrix} 5 | \title{Summing matrix for hierarchical or grouped time series} 6 | \usage{ 7 | smatrix(xts) 8 | } 9 | \arguments{ 10 | \item{xts}{Hierarchical or grouped time series of class \code{gts}.} 11 | } 12 | \value{ 13 | A numerical matrix. 14 | } 15 | \description{ 16 | This function returns the summing matrix for a hierarchical or grouped time 17 | series, as defined in Hyndman et al. (2011). 18 | } 19 | \examples{ 20 | 21 | smatrix(htseg1) 22 | 23 | } 24 | \references{ 25 | Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. 26 | (2011). Optimal combination forecasts for hierarchical time series. 27 | \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 28 | \url{https://robjhyndman.com/publications/hierarchical/} 29 | } 30 | \seealso{ 31 | \code{\link[hts]{hts}}, \code{\link[hts]{gts}}, 32 | \code{\link[hts]{combinef}} 33 | } 34 | \author{ 35 | Earo Wang 36 | } 37 | \keyword{ts} 38 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | #include 6 | 7 | using namespace Rcpp; 8 | 9 | #ifdef RCPP_USE_GLOBAL_ROSTREAM 10 | Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); 11 | Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); 12 | #endif 13 | 14 | // cgm_c 15 | Eigen::MatrixXd cgm_c(SEXP As, SEXP bs); 16 | RcppExport SEXP _hts_cgm_c(SEXP AsSEXP, SEXP bsSEXP) { 17 | BEGIN_RCPP 18 | Rcpp::RObject rcpp_result_gen; 19 | Rcpp::RNGScope rcpp_rngScope_gen; 20 | Rcpp::traits::input_parameter< SEXP >::type As(AsSEXP); 21 | Rcpp::traits::input_parameter< SEXP >::type bs(bsSEXP); 22 | rcpp_result_gen = Rcpp::wrap(cgm_c(As, bs)); 23 | return rcpp_result_gen; 24 | END_RCPP 25 | } 26 | 27 | static const R_CallMethodDef CallEntries[] = { 28 | {"_hts_cgm_c", (DL_FUNC) &_hts_cgm_c, 2}, 29 | {NULL, NULL, 0} 30 | }; 31 | 32 | RcppExport void R_init_hts(DllInfo *dll) { 33 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 34 | R_useDynamicSymbols(dll, FALSE); 35 | } 36 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(accuracy,gts) 4 | S3method(forecast,gts) 5 | S3method(plot,gts) 6 | S3method(print,gts) 7 | S3method(print,hts) 8 | S3method(summary,gts) 9 | S3method(summary,hts) 10 | S3method(window,gts) 11 | export(MinT) 12 | export(accuracy.gts) 13 | export(aggts) 14 | export(allts) 15 | export(combinef) 16 | export(forecast.gts) 17 | export(get_groups) 18 | export(get_nodes) 19 | export(gts) 20 | export(hts) 21 | export(is.gts) 22 | export(is.hts) 23 | export(plot.gts) 24 | export(print.gts) 25 | export(print.hts) 26 | export(smatrix) 27 | export(summary.gts) 28 | export(summary.hts) 29 | import(Matrix) 30 | import(forecast) 31 | import(grDevices) 32 | import(methods) 33 | import(parallel) 34 | importFrom(SparseM,as.matrix.csr) 35 | importFrom(graphics,lines) 36 | importFrom(graphics,par) 37 | importFrom(graphics,plot) 38 | importFrom(graphics,strwidth) 39 | importFrom(graphics,text) 40 | importFrom(stats,"tsp<-") 41 | importFrom(stats,as.ts) 42 | importFrom(stats,fitted) 43 | importFrom(stats,frequency) 44 | importFrom(stats,is.ts) 45 | importFrom(stats,na.omit) 46 | importFrom(stats,residuals) 47 | importFrom(stats,time) 48 | importFrom(stats,ts) 49 | importFrom(stats,tsp) 50 | importFrom(stats,window) 51 | importFrom(utils,combn) 52 | useDynLib(hts) 53 | -------------------------------------------------------------------------------- /.github/CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Code of Conduct 2 | 3 | As contributors and maintainers of this project, we pledge to respect all people who 4 | contribute through reporting issues, posting feature requests, updating documentation, 5 | submitting pull requests or patches, and other activities. 6 | 7 | We are committed to making participation in this project a harassment-free experience for 8 | everyone, regardless of level of experience, gender, gender identity and expression, 9 | sexual orientation, disability, personal appearance, body size, race, ethnicity, age, or religion. 10 | 11 | Examples of unacceptable behavior by participants include the use of sexual language or 12 | imagery, derogatory comments or personal attacks, trolling, public or private harassment, 13 | insults, or other unprofessional conduct. 14 | 15 | Project maintainers have the right and responsibility to remove, edit, or reject comments, 16 | commits, code, wiki edits, issues, and other contributions that are not aligned to this 17 | Code of Conduct. Project maintainers who do not follow the Code of Conduct may be removed 18 | from the project team. 19 | 20 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by 21 | opening an issue or contacting one or more of the project maintainers. 22 | 23 | This Code of Conduct is adapted from the Contributor Covenant 24 | (http://contributor-covenant.org), version 1.0.0, available at 25 | http://contributor-covenant.org/version/1/0/0/ 26 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - master 5 | pull_request: 6 | branches: 7 | - master 8 | 9 | name: test-coverage 10 | 11 | jobs: 12 | test-coverage: 13 | runs-on: macOS-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | steps: 17 | - uses: actions/checkout@v2 18 | 19 | - uses: r-lib/actions/setup-r@master 20 | 21 | - uses: r-lib/actions/setup-pandoc@master 22 | 23 | - name: Query dependencies 24 | run: | 25 | install.packages('remotes') 26 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 27 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 28 | shell: Rscript {0} 29 | 30 | - name: Cache R packages 31 | uses: actions/cache@v1 32 | with: 33 | path: ${{ env.R_LIBS_USER }} 34 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 35 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 36 | 37 | - name: Install dependencies 38 | run: | 39 | install.packages(c("remotes")) 40 | remotes::install_deps(dependencies = TRUE) 41 | remotes::install_cran("covr") 42 | shell: Rscript {0} 43 | 44 | - name: Test coverage 45 | run: covr::codecov() 46 | shell: Rscript {0} 47 | -------------------------------------------------------------------------------- /R/combinefm.R: -------------------------------------------------------------------------------- 1 | # helper function to block principal pivoting algorithm 2 | # can only be used with OLS, WLS (any positive weights) 3 | # Author: Shanika Wickramasuriya 4 | # Paper: Optimal non-negative forecast reconciliation 5 | 6 | # Arguments 7 | # fcasts: a vector of h-steps-ahead forecasts for all levels of the hierarchical time series. 8 | # smat: updated original s-matrix (based on the active set constraints) 9 | # weights: updated weights to be used in OLS or WLS 10 | # alg: algorithm such as "lu", "chol" or "cg" 11 | 12 | combinefm <- function(fcasts, smat, weights, alg) 13 | { 14 | totalts <- nrow(smat) 15 | if (!is.matrix(fcasts)) { 16 | fcasts <- t(fcasts) 17 | } 18 | if (ncol(fcasts) != totalts) { 19 | stop("Argument fcasts requires all the forecasts.") 20 | } 21 | 22 | fcasts <- t(fcasts) 23 | if (alg == "chol") { 24 | if (!is.null(weights)) { 25 | weights <- methods::as(1/weights, "matrix.diag.csr") 26 | } 27 | allf <- CHOL(fcasts = fcasts, S = smat, weights = weights, allow.changes = TRUE) 28 | } else { 29 | if (!is.null(weights)) { 30 | seqts <- 1:totalts 31 | weights <- sparseMatrix(i = seqts, j = seqts, x = 1/weights) 32 | } 33 | if (alg == "lu") { 34 | allf <- LU(fcasts = fcasts, S = smat, weights = weights, allow.changes = TRUE) 35 | } else if (alg == "cg") { 36 | allf <- CG(fcasts = fcasts, S = smat, weights = weights, allow.changes = TRUE) 37 | } 38 | } 39 | return(allf) 40 | } 41 | 42 | 43 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: hts 2 | Title: Hierarchical and Grouped Time Series 3 | Version: 6.0.3 4 | Authors@R: c( 5 | person("Rob", "Hyndman", role = "aut", comment = "Package creator"), 6 | person("Alan", "Lee", role = "aut", comment = "Fast computation using recursive methods"), 7 | person("Earo", "Wang", role = c("aut", "cre"), email = "earo.wang@gmail.com"), 8 | person("Shanika", "Wickramasuriya", role = "aut", comment = "Reconciliation via trace minimization") 9 | ) 10 | Description: Provides methods for analysing and forecasting hierarchical and 11 | grouped time series. The available forecast methods include bottom-up, 12 | top-down, optimal combination reconciliation (Hyndman et al. 2011) 13 | , and trace minimization reconciliation 14 | (Wickramasuriya et al. 2018) . 15 | Depends: 16 | R (>= 3.2.0), 17 | forecast (>= 8.12) 18 | Imports: 19 | SparseM, 20 | Matrix, 21 | parallel, 22 | utils, 23 | methods, 24 | graphics, 25 | grDevices, 26 | stats 27 | Suggests: 28 | testthat, 29 | rmarkdown, 30 | covr 31 | LinkingTo: 32 | Rcpp (>= 0.11.0), 33 | RcppEigen 34 | LazyLoad: yes 35 | LazyData: yes 36 | ByteCompile: TRUE 37 | URL: https://pkg.earo.me/hts/ 38 | BugReports: https://github.com/earowang/hts/issues 39 | License: GPL (>= 2) 40 | RoxygenNote: 7.2.3 41 | Roxygen: list(markdown = TRUE, roclets=c('rd', 'collate', 'namespace')) 42 | Encoding: UTF-8 43 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: master 4 | 5 | name: pkgdown 6 | 7 | jobs: 8 | pkgdown: 9 | runs-on: macOS-latest 10 | env: 11 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 12 | steps: 13 | - uses: actions/checkout@v2 14 | 15 | - uses: r-lib/actions/setup-r@master 16 | 17 | - uses: r-lib/actions/setup-pandoc@master 18 | 19 | - name: Query dependencies 20 | run: | 21 | install.packages('remotes') 22 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 23 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 24 | shell: Rscript {0} 25 | 26 | - name: Cache R packages 27 | uses: actions/cache@v1 28 | with: 29 | path: ${{ env.R_LIBS_USER }} 30 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 31 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 32 | 33 | - name: Install dependencies 34 | run: | 35 | remotes::install_deps(dependencies = TRUE) 36 | install.packages("pkgdown") 37 | shell: Rscript {0} 38 | 39 | - name: Install package 40 | run: R CMD INSTALL . 41 | 42 | - name: Deploy package 43 | run: | 44 | git config --local user.email "actions@github.com" 45 | git config --local user.name "GitHub Actions" 46 | Rscript -e 'pkgdown::deploy_to_branch(new_process = FALSE)' 47 | -------------------------------------------------------------------------------- /tests/testthat/test-combinef.R: -------------------------------------------------------------------------------- 1 | # A unit test for combinef() function 2 | context("Tests on inputs") 3 | 4 | test_that("tests for hts at the bottom level", { 5 | set.seed(1234) 6 | mts <- ts(matrix(5 + sort(rnorm(500)), nrow = 50, ncol = 10)) 7 | node.list <- list(3, c(2, 3, 1), c(2, 2, 1, 1, 1, 3)) 8 | 9 | expect_that(combinef(mts, nodes = node.list, algorithms = "lu"), 10 | throws_error()) 11 | }) 12 | 13 | context("Tests on outputs") 14 | 15 | test_that("tests for hts", { 16 | set.seed(1234) 17 | mts <- ts(matrix(5 + sort(rnorm(50)), nrow = 5, ncol = 10)) 18 | node.list <- list(3, c(2, 3, 1), c(2, 2, 1, 1, 1, 3)) 19 | hts <- hts(mts, nodes = node.list) 20 | allf <- allts(hts) 21 | out1 <- combinef(allf, nodes = node.list, keep = "bottom", algorithms = "lu") 22 | out2 <- combinef(allf, nodes = node.list, keep = "gts", algorithms = "lu") 23 | 24 | expect_that(dim(out1), equals(c(5, 10))) 25 | expect_true(is.hts(out2)) 26 | }) 27 | 28 | test_that("tests for gts", { 29 | set.seed(1234) 30 | mts <- ts(5 + matrix(sort(rnorm(270)), nrow = 10, ncol = 27), 31 | start = c(2001, 1), frequency = 12) 32 | g <- matrix(c(rep(1:3, each = 9), rep(c(rep(1, 3), rep(2, 3), rep(3, 3)), 3), 33 | rep(1:3, 9)), nrow = 3, byrow = TRUE) 34 | gts <- gts(mts, groups = g) 35 | out1 <- combinef(allts(gts), groups = gts$groups, keep = "bottom", 36 | algorithms = "lu") 37 | out2 <- combinef(allts(gts), groups = g, keep = "gts", algorithms = "lu") 38 | 39 | expect_that(dim(out1), equals(c(10, 27))) 40 | expect_that(dim(out2$bts), equals(c(10, 27))) 41 | }) 42 | -------------------------------------------------------------------------------- /man/plot.gts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plot-gts.R 3 | \name{plot.gts} 4 | \alias{plot.gts} 5 | \title{Plot grouped or hierarchical time series} 6 | \usage{ 7 | \method{plot}{gts}(x, include, levels, labels = TRUE, col = NULL, color_lab = FALSE, ...) 8 | } 9 | \arguments{ 10 | \item{x}{An object of class \code{\link[hts]{gts}}.} 11 | 12 | \item{include}{Number of values from historical time series to include in 13 | the plot of forecasted group/hierarchical time series.} 14 | 15 | \item{levels}{Integer(s) or string(s) giving the specified levels(s) to be 16 | plotted} 17 | 18 | \item{labels}{If \code{TRUE}, plot the labels next to each series} 19 | 20 | \item{col}{Vector of colours, passed to \code{plot.ts} and to \code{lines}} 21 | 22 | \item{color_lab}{If \code{TRUE}, colour the direct labels to match line 23 | colours. If \code{FALSE} will be as per \code{par()$fg}.} 24 | 25 | \item{\dots}{Other arguments passing to \code{\link[graphics]{plot.default}}} 26 | } 27 | \description{ 28 | Method for plotting grouped or hierarchical time series and their forecasts. 29 | } 30 | \examples{ 31 | 32 | plot(htseg1, levels = c(0, 2)) 33 | plot(infantgts, include = 10, levels = "State") 34 | plot(infantgts, include = 10, levels = "State", 35 | col = colours()[100:107], lty = 1:8, color_lab = TRUE) 36 | 37 | } 38 | \references{ 39 | Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. 40 | (2011). Optimal combination forecasts for hierarchical time series. 41 | \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 42 | \url{https://robjhyndman.com/publications/hierarchical/} 43 | } 44 | \seealso{ 45 | \code{\link[hts]{aggts}} 46 | } 47 | \author{ 48 | Rob J Hyndman and Earo Wang 49 | } 50 | \keyword{hplot} 51 | -------------------------------------------------------------------------------- /.github/workflows/pr-commands.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | issue_comment: 3 | types: [created] 4 | name: Commands 5 | jobs: 6 | document: 7 | if: startsWith(github.event.comment.body, '/document') 8 | name: document 9 | runs-on: macOS-latest 10 | env: 11 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 12 | steps: 13 | - uses: actions/checkout@v2 14 | - uses: r-lib/actions/pr-fetch@master 15 | with: 16 | repo-token: ${{ secrets.GITHUB_TOKEN }} 17 | - uses: r-lib/actions/setup-r@master 18 | - name: Install dependencies 19 | run: Rscript -e 'install.packages(c("remotes", "roxygen2"))' -e 'remotes::install_deps(dependencies = TRUE)' 20 | - name: Document 21 | run: Rscript -e 'roxygen2::roxygenise()' 22 | - name: commit 23 | run: | 24 | git config --local user.email "actions@github.com" 25 | git config --local user.name "GitHub Actions" 26 | git add man/\* NAMESPACE 27 | git commit -m 'Document' 28 | - uses: r-lib/actions/pr-push@master 29 | with: 30 | repo-token: ${{ secrets.GITHUB_TOKEN }} 31 | style: 32 | if: startsWith(github.event.comment.body, '/style') 33 | name: style 34 | runs-on: macOS-latest 35 | env: 36 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 37 | steps: 38 | - uses: actions/checkout@v2 39 | - uses: r-lib/actions/pr-fetch@master 40 | with: 41 | repo-token: ${{ secrets.GITHUB_TOKEN }} 42 | - uses: r-lib/actions/setup-r@master 43 | - name: Install dependencies 44 | run: Rscript -e 'install.packages("styler")' 45 | - name: Style 46 | run: Rscript -e 'styler::style_pkg()' 47 | - name: commit 48 | run: | 49 | git config --local user.email "actions@github.com" 50 | git config --local user.name "GitHub Actions" 51 | git add \*.R 52 | git commit -m 'Style' 53 | - uses: r-lib/actions/pr-push@master 54 | with: 55 | repo-token: ${{ secrets.GITHUB_TOKEN }} 56 | -------------------------------------------------------------------------------- /.github/SUPPORT.md: -------------------------------------------------------------------------------- 1 | # Getting help with tsibble 2 | 3 | Thanks for using tsibble. Before filing an issue, there are a few places 4 | to explore and pieces to put together to make the process as smooth as possible. 5 | 6 | Start by making a minimal **repr**oducible **ex**ample using the 7 | [reprex](http://reprex.tidyverse.org/) package. If you haven't heard of or used 8 | reprex before, you're in for a treat! Seriously, reprex will make all of your 9 | R-question-asking endeavors easier (which is a pretty insane ROI for the five to 10 | ten minutes it'll take you to learn what it's all about). For additional reprex 11 | pointers, check out the [Get help!](https://www.tidyverse.org/help/) section of 12 | the tidyverse site. 13 | 14 | Armed with your reprex, the next step is to figure out [where to ask](https://www.tidyverse.org/help/#where-to-ask). 15 | 16 | * If it's a question: start with [community.rstudio.com](https://community.rstudio.com/), 17 | and/or StackOverflow. There are more people there to answer questions. 18 | * If it's a bug: you're in the right place, file an issue. 19 | * If you're not sure: let the community help you figure it out! If your 20 | problem _is_ a bug or a feature request, you can easily return here and 21 | report it. 22 | 23 | Before opening a new issue, be sure to [search issues and pull requests](https://github.com/tidyverse/tsibble/issues) to make sure the 24 | bug hasn't been reported and/or already fixed in the development version. By 25 | default, the search will be pre-populated with `is:issue is:open`. You can 26 | [edit the qualifiers](https://help.github.com/articles/searching-issues-and-pull-requests/) 27 | (e.g. `is:pr`, `is:closed`) as needed. For example, you'd simply 28 | remove `is:open` to search _all_ issues in the repo, open or closed. 29 | 30 | 31 | If you _are_ in the right place, and need to file an issue, please review the 32 | ["File issues"](https://www.tidyverse.org/contribute/#issues) paragraph from 33 | the tidyverse contributing guidelines. 34 | 35 | Thanks for your help! 36 | -------------------------------------------------------------------------------- /tests/testthat/test-gts.R: -------------------------------------------------------------------------------- 1 | # A unit test for gts() function 2 | context("Tests on output") 3 | 4 | test_that("tests for labels", { 5 | set.seed(1234) 6 | mts <- ts(5 + matrix(sort(rnorm(2700)), nrow = 100, ncol = 27), 7 | start = c(2001, 1), frequency = 12) 8 | g <- matrix(c(rep(1:3, each = 9), rep(c(rep(1, 3), rep(2, 3), rep(3, 3)), 3), 9 | rep(1:3, 9)), nrow = 3, byrow = TRUE) 10 | output <- paste0("G", 1:3) 11 | expect_that(names(gts(mts, g)$labels), equals(output)) 12 | }) 13 | 14 | test_that("tests for specified labels", { 15 | set.seed(1234) 16 | mts <- ts(5 + matrix(sort(rnorm(2700)), nrow = 100, ncol = 27), 17 | start = c(2001, 1), frequency = 12) 18 | g <- matrix(c(rep(1:3, each = 9), rep(c(rep(1, 3), rep(2, 3), rep(3, 3)), 3), 19 | rep(1:3, 9)), nrow = 3, byrow = TRUE) 20 | rownames(g) <- c("Sex", "Purpose", "Frames") 21 | expect_that(names(gts(mts, g)$labels), equals(rownames(g))) 22 | }) 23 | 24 | test_that("tests for gmatrix", { 25 | set.seed(1234) 26 | mts <- ts(5 + matrix(sort(rnorm(2700)), nrow = 100, ncol = 27), 27 | start = c(2001, 1), frequency = 12) 28 | g <- matrix(c(rep(1:3, each = 9), rep(c(rep(1, 3), rep(2, 3), rep(3, 3)), 3), 29 | rep(1:3, 9)), nrow = 3, byrow = TRUE) 30 | gmat <- rbind(rep(1, 27), g, seq(1, 27)) 31 | class(gmat) <- "gmatrix" 32 | output <- gts(mts, g)$groups 33 | dimnames(output) <- NULL 34 | 35 | expect_that(output, equals(gmat)) 36 | }) 37 | 38 | test_that("tests for matrix with characters", { 39 | set.seed(1234) 40 | mts <- ts(5 + matrix(sort(rnorm(1600)), nrow = 100, ncol = 16), 41 | start = c(2001, 1), frequency = 12) 42 | gchar <- matrix(c(rep("Male", 8), rep("Female", 8), rep(LETTERS[3:10], 2)), 43 | nrow = 2, byrow = TRUE) 44 | g <- matrix(c(rep(1, 8), rep(2, 8), rep(1:8, 2)), nrow = 2, byrow = T) 45 | gmat <- rbind(rep(1, 16), g, seq(1, 16)) 46 | class(gmat) <- "gmatrix" 47 | output <- gts(mts, gchar)$groups 48 | dimnames(output) <- NULL 49 | 50 | expect_that(output, equals(gmat)) 51 | }) 52 | -------------------------------------------------------------------------------- /man/hts-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/hts-package.R 3 | \docType{package} 4 | \name{hts-package} 5 | \alias{hts-package} 6 | \title{Hierarchical and grouped time series} 7 | \description{ 8 | This package presents functions to create, plot and forecast hierarchical 9 | and grouped time series. In forecasting hierarchical and grouped time 10 | series, the base methods implemented include ETS, ARIMA and the naive 11 | (random walk) models. Forecasts for grouped time series are calibrated using 12 | bottom-up and optimal combination methods. Forecasts for hierarchical time 13 | series are distributed in the hierarchy using bottom-up, top-down, 14 | middle-out and optimal combination methods. Three top-down methods are 15 | available: the two Gross-Sohl methods and the forecast-proportion approach 16 | of Hyndman, Ahmed, and Athanasopoulos (2011). 17 | } 18 | \references{ 19 | G. Athanasopoulos, R. A. Ahmed and R. J. Hyndman (2009) 20 | Hierarchical forecasts for Australian domestic tourism, \emph{International 21 | Journal of Forecasting}, \bold{25}, 146-166. 22 | 23 | R. J. Hyndman, R. A. Ahmed, G. Athanasopoulos and H.L. Shang (2011) Optimal 24 | combination forecasts for hierarchical time series. \emph{Computational 25 | Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 26 | \url{https://robjhyndman.com/publications/hierarchical/} 27 | 28 | Hyndman, R. J., Lee, A., & Wang, E. (2016). Fast computation of reconciled 29 | forecasts for hierarchical and grouped time series. \emph{Computational Statistics and Data Analysis}, 30 | \bold{97}, 16-23. \url{https://robjhyndman.com/papers/hgts7.pdf} 31 | 32 | Wickramasuriya, S. L., Athanasopoulos, G., & Hyndman, R. J. (2018). 33 | Forecasting hierarchical and grouped time series through trace minimization. 34 | \emph{Journal of the American Statistical Association}, to appear \url{https://robjhyndman.com/papers/mint.pdf} 35 | } 36 | \author{ 37 | Rob J Hyndman, Alan Lee, Earo Wang and Shanika L Wickramasuriya with 38 | contributions from Roman A Ahmed and Han Lin Shang to earlier versions of the 39 | package 40 | } 41 | \keyword{package} 42 | -------------------------------------------------------------------------------- /tests/testthat/test-hts.R: -------------------------------------------------------------------------------- 1 | # A unit test for hts() function 2 | context("Tests on inputs") 3 | 4 | test_that("tests for y as a mts", { 5 | set.seed(1234) 6 | sts <- ts(rnorm(100), start = c(2001, 1), frequency = 12) 7 | node.list <- list(3, c(2, 3, 1), c(2, 2, 1, 1, 1, 3)) 8 | 9 | expect_that(hts(sts, node.list), throws_error()) 10 | }) 11 | 12 | test_that("tests for node as a list", { 13 | set.seed(1234) 14 | mts <- ts(matrix(5 + sort(rnorm(500)), nrow = 50, ncol = 10)) 15 | node.mat <- matrix(1:10, nrow = 2, ncol = 5) 16 | 17 | expect_that(hts(mts, node.mat), throws_error()) 18 | }) 19 | 20 | test_that("tests for node by default", { 21 | set.seed(1234) 22 | mts <- ts(matrix(5 + sort(rnorm(500)), nrow = 50, ncol = 10)) 23 | nodes <- list("Level 1" = 10) 24 | 25 | expect_that(hts(mts)$nodes, equals(nodes)) 26 | }) 27 | 28 | test_that("tests for the root node not specified", { 29 | set.seed(1234) 30 | mts <- ts(matrix(5 + sort(rnorm(500)), nrow = 50, ncol = 10)) 31 | node.list <- list(c(2, 3, 1), c(2, 2, 1, 1, 1, 3)) 32 | 33 | expect_that(hts(mts, node.list), throws_error()) 34 | }) 35 | 36 | test_that("tests for the terminal nodes wrong", { 37 | set.seed(1234) 38 | mts <- ts(matrix(5 + sort(rnorm(500)), nrow = 50, ncol = 10)) 39 | node.list <- list(1, c(2, 3, 1), c(2, 2, 1, 2, 1, 3)) 40 | 41 | expect_that(hts(mts, node.list), throws_error()) 42 | }) 43 | 44 | test_that("tests for the middle nodes wrong", { 45 | set.seed(1234) 46 | mts <- ts(matrix(5 + sort(rnorm(500)), nrow = 50, ncol = 10)) 47 | node.list <- list(1, c(2, 4, 1), c(2, 2, 1, 1, 1, 3)) 48 | 49 | expect_that(hts(mts, node.list), throws_error()) 50 | }) 51 | 52 | context("tests on output") 53 | 54 | test_that("tests for the gmatrix", { 55 | node.list <- list(3, c(2, 3, 1), c(2, 2, 1, 1, 1, 3)) 56 | g <- matrix(c(rep(1, 10), rep(1, 4), rep(2, 3), rep(3, 3), rep(1, 2), 57 | rep(2, 2), seq(3, 5), rep(6, 3), seq(1, 10)), ncol = 10, 58 | byrow = TRUE) 59 | class(g) <- "gmatrix" 60 | 61 | output <- GmatrixH(node.list) 62 | dimnames(output) <- NULL 63 | expect_that(output, equals(g)) 64 | }) 65 | -------------------------------------------------------------------------------- /R/middleout.R: -------------------------------------------------------------------------------- 1 | MiddleOut <- function(fcasts, nodes) { 2 | # Middle-out forecasts similar to tdfp 3 | levels <- c(0L, cumsum(sapply(nodes, sum))) 4 | # Split fcasts to a list 5 | l.levels <- length(levels) - 1L 6 | flist <- vector(length = l.levels, mode = "list") 7 | for (i in 1L:l.levels) { 8 | end <- levels[i + 1L] 9 | start <- levels[i] + 1L 10 | series <- seq(start, end) 11 | flist[[i]] <- fcasts[, series] 12 | } 13 | if (is.vector(flist[[1L]])) { # In case of h = 1 14 | new.flist <- vector(length = l.levels - 1L, mode = "list") 15 | for (j in 1L:(l.levels - 1L)) { 16 | repcount <- rep(1:length(nodes[[j + 1L]]), nodes[[j + 1L]]) 17 | new.flist[[j]] <- rowsum(flist[[j + 1L]], repcount) 18 | } 19 | tmp <- rep(new.flist[[1L]], nodes[[2L]]) 20 | # Calculate proportions 21 | prop <- flist[[2L]]/tmp 22 | mfcasts0 <- unlist(flist[[1L]]) 23 | mfcasts <- rep(mfcasts0, nodes[[2L]]) 24 | if (l.levels > 2L) { 25 | for (k in 2L:(l.levels - 1L)) { 26 | prop <- rep(prop, nodes[[k + 1L]]) 27 | newprop <- rep(new.flist[[k]], nodes[[k + 1L]]) 28 | mfcasts <- rep(mfcasts, nodes[[k + 1L]]) 29 | prop <- prop * flist[[k + 1L]]/newprop 30 | } 31 | } 32 | out <- t(mfcasts * prop) 33 | } else { 34 | new.flist <- vector(length = l.levels - 1L, mode = "list") 35 | for (j in 1L:(l.levels - 1L)) { 36 | repcount <- rep(1:length(nodes[[j + 1L]]), nodes[[j + 1L]]) 37 | new.flist[[j]] <- t(apply(flist[[j + 1L]], 1, 38 | function(x) rowsum(x, repcount))) 39 | } 40 | tmp <- t(apply(new.flist[[1L]], 1, function(x) rep(x, nodes[[2L]]))) 41 | prop <- flist[[2L]]/tmp 42 | mfcasts0 <- matrix(unlist(flist[[1L]]), ncol = ncol(flist[[1L]])) 43 | mfcasts <- t(apply(mfcasts0, 1, function(x) rep(x, nodes[[2L]]))) 44 | if (l.levels > 2L) { 45 | for (k in 2L:(l.levels - 1L)) { 46 | prop <- t(apply(prop, 1, function(x) rep(x, nodes[[k + 1L]]))) 47 | newprop <- t(apply(new.flist[[k]], 1, 48 | function(x) rep(x, nodes[[k + 1L]]))) 49 | mfcasts <- t(apply(mfcasts, 1, function(x) rep(x, nodes[[k + 1L]]))) 50 | prop <- prop * flist[[k + 1L]]/newprop 51 | } 52 | } 53 | out <- mfcasts * prop 54 | } 55 | return(out) 56 | } 57 | -------------------------------------------------------------------------------- /.github/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to tsibble 2 | 3 | This outlines how to propose a change to tsibble. For more detailed 4 | info about contributing to this, and other tidyverse packages, please see the 5 | [**development contributing guide**](https://rstd.io/tidy-contrib). 6 | 7 | ### Fixing typos 8 | 9 | Small typos or grammatical errors in documentation may be edited directly using 10 | the GitHub web interface, so long as the changes are made in the _source_ file. 11 | 12 | * YES: you edit a roxygen comment in a `.R` file below `R/`. 13 | * NO: you edit an `.Rd` file below `man/`. 14 | 15 | ### Prerequisites 16 | 17 | Before you make a substantial pull request, you should always file an issue and 18 | make sure someone from the team agrees that it’s a problem. If you’ve found a 19 | bug, create an associated issue and illustrate the bug with a minimal 20 | [reprex](https://www.tidyverse.org/help/#reprex). 21 | 22 | ### Pull request process 23 | 24 | * We recommend that you create a Git branch for each pull request (PR). 25 | * Look at the Travis and AppVeyor build status before and after making changes. 26 | The `README` should contain badges for any continuous integration services used 27 | by the package. 28 | * New code should follow the tidyverse [style guide](http://style.tidyverse.org). 29 | You can use the [styler](https://CRAN.R-project.org/package=styler) package to 30 | apply these styles, but please don't restyle code that has nothing to do with 31 | your PR. 32 | * We use [roxygen2](https://cran.r-project.org/package=roxygen2), with 33 | [Markdown syntax](https://cran.r-project.org/web/packages/roxygen2/vignettes/markdown.html), 34 | for documentation. 35 | * We use [testthat](https://cran.r-project.org/package=testthat). Contributions 36 | with test cases included are easier to accept. 37 | * For user-facing changes, add a bullet to the top of `NEWS.md` below the current 38 | development version header describing the changes made followed by your GitHub 39 | username, and links to relevant issue(s)/PR(s). 40 | 41 | ### Code of Conduct 42 | 43 | Please note that this project is released with a [Contributor Code of 44 | Conduct](CODE_OF_CONDUCT.md). By participating in this project you agree to 45 | abide by its terms. 46 | 47 | ### See tidyverse [development contributing guide](https://rstd.io/tidy-contrib) for further details. 48 | -------------------------------------------------------------------------------- /man/accuracy.gts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/accuracy-gts.R 3 | \name{accuracy.gts} 4 | \alias{accuracy.gts} 5 | \title{In-sample or out-of-sample accuracy measures for forecast grouped and 6 | hierarchical model} 7 | \usage{ 8 | \method{accuracy}{gts}(object, test, levels, ..., f = NULL) 9 | } 10 | \arguments{ 11 | \item{object}{An object of class \code{gts}, containing the forecasted 12 | hierarchical or grouped time series. In-sample accuracy at the bottom level 13 | returns when \code{test} is missing.} 14 | 15 | \item{test}{An object of class \code{gts}, containing the holdout 16 | hierarchical time series} 17 | 18 | \item{levels}{Return the specified level(s), when carrying out out-of-sample} 19 | 20 | \item{...}{Extra arguments to be ignored} 21 | 22 | \item{f}{Deprecated. Please use \code{object} instead.} 23 | } 24 | \value{ 25 | Matrix giving forecast accuracy measures. \item{ME}{Mean Error} 26 | \item{RMSE}{Root Mean Square Error} \item{MAE}{Mean Absolute Error} 27 | \item{MAPE}{Mean Absolute Percentage Error} \item{MPE}{Mean Percentage 28 | Error} \item{MASE}{Mean Absolute Scaled Error} 29 | } 30 | \description{ 31 | Returns a range of summary measures of the forecast accuracy. The function 32 | measures out-of-sample forecast accuracy based on (holdout data - forecasts) 33 | and in-sample accuracy at the bottom level when setting \code{keep.fitted = 34 | TRUE} in the \code{\link[hts]{forecast.gts}}. All measures are defined and 35 | discussed in Hyndman and Koehler (2006). 36 | } 37 | \details{ 38 | MASE calculation is scaled using MAE of in-sample naive forecasts for 39 | non-seasonal time series, and in-sample seasonal naive forecasts for 40 | seasonal time series. 41 | } 42 | \examples{ 43 | 44 | data <- window(htseg2, start = 1992, end = 2002) 45 | test <- window(htseg2, start = 2003) 46 | fcasts <- forecast(data, h = 5, method = "bu") 47 | accuracy(fcasts, test) 48 | accuracy(fcasts, test, levels = 1) 49 | 50 | } 51 | \references{ 52 | R. J. Hyndman and A. Koehler (2006), Another look at measures of 53 | forecast accuracy, \emph{International Journal of Forecasting}, \bold{22}, 54 | 679-688. 55 | } 56 | \seealso{ 57 | \code{\link[hts]{hts}}, \code{\link[hts]{plot.gts}}, 58 | \code{\link[hts]{forecast.gts}}, \code{\link[forecast]{accuracy}} 59 | } 60 | \author{ 61 | Rob J Hyndman and Earo Wang 62 | } 63 | \keyword{error} 64 | -------------------------------------------------------------------------------- /R/smatrix.R: -------------------------------------------------------------------------------- 1 | #' Summing matrix for hierarchical or grouped time series 2 | #' 3 | #' This function returns the summing matrix for a hierarchical or grouped time 4 | #' series, as defined in Hyndman et al. (2011). 5 | #' 6 | #' 7 | #' @param xts Hierarchical or grouped time series of class \code{gts}. 8 | #' @return A numerical matrix. 9 | #' @author Earo Wang 10 | #' @seealso \code{\link[hts]{hts}}, \code{\link[hts]{gts}}, 11 | #' \code{\link[hts]{combinef}} 12 | #' @references Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. 13 | #' (2011). Optimal combination forecasts for hierarchical time series. 14 | #' \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 15 | #' \url{https://robjhyndman.com/publications/hierarchical/} 16 | #' @keywords ts 17 | #' @examples 18 | #' 19 | #' smatrix(htseg1) 20 | #' 21 | #' @export smatrix 22 | smatrix <- function(xts) { 23 | # The summing matrix 24 | # 25 | # Args: 26 | # xts: hts/gts 27 | # 28 | # Returns: 29 | # S matrix in the dense mode 30 | if (!is.gts(xts)) { 31 | stop("Argument xts must be a gts object", call. = FALSE) 32 | } 33 | if (is.hts(xts)) { 34 | gmat <- GmatrixH(xts$nodes) 35 | } else { 36 | gmat <- xts$groups 37 | } 38 | return(as.matrix(SmatrixM(gmat))) 39 | } 40 | 41 | # This function returns a sparse matrix supported by Matrix pkg 42 | SmatrixM <- function(gmat) { 43 | # Sparse matrices stored in coordinate format 44 | # gmatrix contains all the information to generate smatrix 45 | num.bts <- ncol(gmat) 46 | sparse.S <- apply(gmat, 1L, function(x) { 47 | ia <- as.integer(x) 48 | ra <- as.integer(rep(1L, num.bts)) 49 | ja <- as.integer(1L:num.bts) 50 | s <- sparseMatrix(i = ia, j = ja, x = ra) 51 | }) 52 | sparse <- do.call("rbind", sparse.S) 53 | return(sparse) 54 | } 55 | 56 | # This function returns a sparse matrix supported by SparseM pkg 57 | Smatrix <- function(gmat) { 58 | # Sparse matrices stored in coordinate format 59 | # gmatrix contains all the information to generate smatrix 60 | num.bts <- ncol(gmat) 61 | sparse.S <- apply(gmat, 1L, function(x) { 62 | ia <- as.integer(x) 63 | uniq.g <- unique(ia) 64 | ra <- as.integer(rep(1L, num.bts)) 65 | ja <- as.integer(1L:num.bts) 66 | s <- as.matrix.csr(new("matrix.coo", ra = ra, ja = ja, ia = ia, 67 | dimension = as.integer(c(length(uniq.g), num.bts)))) 68 | }) 69 | sparse <- do.call("rbind", sparse.S) 70 | return(sparse) 71 | } 72 | -------------------------------------------------------------------------------- /R/topdown.R: -------------------------------------------------------------------------------- 1 | # Top-down approaches only for hts 2 | TdGsA <- function(fcasts, bts, topts) { 3 | # Top-down forecasts based on the average historical proportions. (Gross-Sohl 4 | # method A) 5 | div <- apply(bts, 2, function(x) x/topts) 6 | prop <- colMeans(div, na.rm = TRUE) 7 | out <- fcasts %*% prop 8 | return(out) 9 | } 10 | 11 | TdGsF <- function(fcasts, bts, topts) { 12 | # Top-down forecasts based on the proportions of the historical averages ( 13 | # Gross-Sohl method F) 14 | numerator <- colSums(bts, na.rm = TRUE) 15 | denominator <- sum(topts, na.rm = TRUE) 16 | prop <- numerator/denominator 17 | out <- fcasts %*% prop 18 | return(out) 19 | } 20 | 21 | TdFp <- function(fcasts, nodes) { 22 | # Top-down forecasts using forecast proportions 23 | levels <- cumsum(Mnodes(nodes)) 24 | # Split fcasts to a list 25 | l.levels <- length(levels) 26 | flist <- lapply(2L:l.levels, function(x) { 27 | fcasts[, seq(levels[x - 1L] + 1L, levels[x])] 28 | }) 29 | flist <- c(list(fcasts[, 1L]), flist) 30 | if (is.vector(flist[[2L]])) { # In case of h = 1 31 | new.flist <- vector(length = l.levels - 1L, mode = "list") 32 | for (j in 1L:(l.levels - 1L)) { 33 | repcount <- rep(1:length(nodes[[j]]), nodes[[j]]) 34 | new.flist[[j]] <- rowsum(flist[[j + 1L]], repcount) 35 | } 36 | 37 | # Calculate proportions 38 | prop <- c(flist[[2L]]) / c(new.flist[[1L]]) 39 | if (l.levels > 2L) { 40 | for (k in 2L:(l.levels - 1L)) { 41 | prop <- rep(prop, nodes[[k]]) 42 | newprop <- rep(new.flist[[k]], nodes[[k]]) 43 | prop <- prop * flist[[k + 1L]]/newprop 44 | } 45 | } 46 | out <- t(fcasts[, 1L] * prop) 47 | } else { 48 | # Create the sum of the h-step-ahead base forecasts at l level above node j 49 | new.flist <- vector(length = l.levels - 1L, mode = "list") 50 | for (j in 1L:(l.levels - 1L)) { 51 | repcount <- rep(1:length(nodes[[j]]), nodes[[j]]) 52 | new.flist[[j]] <- t(apply(flist[[j + 1L]], 1, 53 | function(x) rowsum(x, repcount))) 54 | } 55 | 56 | # Calculate proportions 57 | prop <- apply(flist[[2L]], 2, function(x) x/new.flist[[1L]]) 58 | if (l.levels > 2L) { 59 | for (k in 2L:(l.levels - 1L)) { 60 | prop <- t(apply(prop, 1, function(x) rep(x, nodes[[k]]))) 61 | newprop <- t(apply(new.flist[[k]], 1, function(x) rep(x, nodes[[k]]))) 62 | prop <- prop * flist[[k + 1L]]/newprop 63 | } 64 | } 65 | out <- fcasts[, 1L] * prop 66 | } 67 | return(out) 68 | } 69 | -------------------------------------------------------------------------------- /man/hts-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/hts.R 3 | \name{hts} 4 | \alias{hts} 5 | \alias{is.hts} 6 | \alias{print.hts} 7 | \alias{summary.hts} 8 | \title{Create a hierarchical time series} 9 | \usage{ 10 | hts(y, nodes, bnames = colnames(y), characters) 11 | 12 | is.hts(xts) 13 | 14 | \method{print}{hts}(x, ...) 15 | 16 | \method{summary}{hts}(object, ...) 17 | } 18 | \arguments{ 19 | \item{y}{A matrix or multivariate time series contain the bottom level 20 | series.} 21 | 22 | \item{nodes}{A list contains the number of child nodes associated with each 23 | level, which indicates the hierarchical structure. The default is a simple 24 | hierarchy with only 2 levels (i.e. total and bottom). If the argument 25 | \code{characters} is used, \code{nodes} will be automatically generated 26 | within the function.} 27 | 28 | \item{bnames}{The names of the bottom time series.} 29 | 30 | \item{characters}{Integers indicate the segments in which the bottom level 31 | names can be read in order to construct the corresponding node structure and 32 | its labels. For instance, suppose one of the bottom series is named 33 | "VICMelb" referring to the city of Melbourne within the state of Victoria. 34 | Then \code{characters} would be specified as \code{c(3, 4)} referring to 35 | states of 3 characters (e.g., "VIC") and cities of 4 characters (e.g., 36 | "Melb") All the bottom names must be of the same length, with number of 37 | characters for each segment the same for all series.} 38 | 39 | \item{xts}{\code{hts} object.} 40 | 41 | \item{x}{\code{hts} object.} 42 | 43 | \item{...}{Extra arguments passed to \code{print} and \code{summary}.} 44 | 45 | \item{object}{\code{hts} object.} 46 | } 47 | \value{ 48 | \item{bts}{Multivariate time series containing the bottom level 49 | series} \item{nodes}{Information about the nodes of a hierarchical time 50 | series} \item{labels}{Information about the labels that are used for 51 | plotting.} 52 | } 53 | \description{ 54 | Method for creating hierarchical time series. 55 | } 56 | \examples{ 57 | 58 | # Example 1 59 | # The hierarchical structure looks like 2 child nodes associated with level 1, 60 | # which are followed by 3 and 2 sub-child nodes respectively at level 2. 61 | nodes <- list(2, c(3, 2)) 62 | abc <- ts(5 + matrix(sort(rnorm(500)), ncol = 5, nrow = 100)) 63 | x <- hts(abc, nodes) 64 | 65 | # Example 2 66 | # Suppose we've got the bottom names that can be useful for constructing the node 67 | # structure and the labels at higher levels. We need to specify how to split them 68 | # in the argument "characters". 69 | library(hts) 70 | abc <- ts(5 + matrix(sort(rnorm(1000)), ncol = 10, nrow = 100)) 71 | colnames(abc) <- c("A10A", "A10B", "A10C", "A20A", "A20B", 72 | "B30A", "B30B", "B30C", "B40A", "B40B") 73 | y <- hts(abc, characters = c(1, 2, 1)) 74 | 75 | } 76 | \references{ 77 | Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. 78 | (2011). Optimal combination forecasts for hierarchical time series. 79 | \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 80 | \url{https://robjhyndman.com/publications/hierarchical/} 81 | } 82 | \seealso{ 83 | \code{\link[hts]{gts}}, \code{\link[hts]{accuracy.gts}}, 84 | \code{\link[hts]{forecast.gts}}, \code{\link[hts]{plot.gts}} 85 | } 86 | \author{ 87 | Earo Wang and Rob J Hyndman 88 | } 89 | \keyword{ts} 90 | -------------------------------------------------------------------------------- /R/aggts.R: -------------------------------------------------------------------------------- 1 | #' Extract selected time series from a gts object 2 | #' 3 | #' The time series from selected levels of a hierarchical/grouped time series 4 | #' or a forecasted hierarchical/grouped time series are returned as a 5 | #' multivariate time series. 6 | #' 7 | #' 8 | #' @param y An object of class \code{{gts}}. 9 | #' @param levels Integer(s) or string(s) giving the specified level(s). 10 | #' @param forecasts If \code{y} contains forecasts and historical data, then 11 | #' \code{forecasts} indicates whether to return the forecasts or the historical 12 | #' data. Otherwise it is ignored. 13 | #' @author Earo Wang 14 | #' @seealso \code{\link[hts]{allts}} 15 | #' @keywords ts 16 | #' @examples 17 | #' 18 | #' aggts(htseg1, levels = c(0, 2)) 19 | #' aggts(infantgts, levels = "State") 20 | #' 21 | #' @export aggts 22 | aggts <- function(y, levels, forecasts = TRUE) { 23 | # 1. Display all time series from top to bottom. 24 | # 2. Bottom-up method. 25 | # 26 | # Args: 27 | # y*: hts & gts objects. 28 | # levels: hts levels (gts groups) can be specified by users. Default is all 29 | # starting with level 0. 30 | # 31 | # Returns: 32 | # The time series selected by users. 33 | # 34 | # Error Handling: 35 | if (!is.gts(y)) { 36 | stop("Argument y must be either a hts or gts object.", call. = FALSE) 37 | } 38 | 39 | if (!forecasts) { 40 | y$bts <- y$histy 41 | } 42 | 43 | if (is.hts(y)) { 44 | gmat <- GmatrixH(y$nodes) 45 | labels <- y$labels 46 | } else { 47 | gmat <- y$groups 48 | labels <- c("Total", y$labels, list(colnames(y$bts))) 49 | } 50 | 51 | if (missing(levels)) { 52 | # Return all levels of the time series 53 | levels <- 1L:nrow(gmat) 54 | } else { 55 | if (is.character(levels)) { # Strings consistent with groups names 56 | levels <- which(names(y$labels) %in% levels) 57 | } 58 | # Return the specified levels 59 | levels <- as.integer(levels) + 1L 60 | } 61 | 62 | # A function to aggregate the bts 63 | rSum <- function(x) rowsum(t(y$bts), gmat[x, ], reorder = FALSE) 64 | 65 | ally <- lapply(levels, rSum) 66 | # Convert lists to matrices 67 | ally <- matrix(unlist(sapply(ally, t)), nrow = nrow(y$bts)) 68 | 69 | colnames(ally) <- unlist(labels[levels]) 70 | tsp.y <- stats::tsp(y$bts) 71 | ally <- ts(ally, start = tsp.y[1L], frequency = tsp.y[3L]) 72 | # Assign other attributes 73 | class(ally) <- class(y$bts) 74 | attr(ally, "msts") <- attr(y$bts, "msts") 75 | return(ally) 76 | } 77 | 78 | 79 | # A wrapper for aggts 80 | 81 | 82 | #' Extract all time series from a gts object 83 | #' 84 | #' The time series from all levels of a hierarchical/grouped time series or a 85 | #' forecasted hierarchical/grouped time series are returned as a multivariate 86 | #' time series. 87 | #' 88 | #' 89 | #' @param y An object of class \code{\link[hts]{gts}}. 90 | #' @param forecasts If \code{y} contains forecasts and historical data, then 91 | #' \code{forecasts} indicates whether to return the forecasts or the historical 92 | #' data. Otherwise it is ignored. 93 | #' @author Rob J Hyndman 94 | #' @seealso \code{\link[hts]{aggts}} 95 | #' @keywords ts 96 | #' @examples 97 | #' 98 | #' allts(htseg1) 99 | #' 100 | #' @export allts 101 | allts <- function(y, forecasts = TRUE) { 102 | if (!is.gts(y)) { 103 | stop("Argument y must be either a hts or gts object.", call. = FALSE) 104 | } 105 | aggts(y = y, forecasts = forecasts) 106 | } 107 | -------------------------------------------------------------------------------- /R/hts-package.R: -------------------------------------------------------------------------------- 1 | #' Hierarchical and grouped time series 2 | #' 3 | #' This package presents functions to create, plot and forecast hierarchical 4 | #' and grouped time series. In forecasting hierarchical and grouped time 5 | #' series, the base methods implemented include ETS, ARIMA and the naive 6 | #' (random walk) models. Forecasts for grouped time series are calibrated using 7 | #' bottom-up and optimal combination methods. Forecasts for hierarchical time 8 | #' series are distributed in the hierarchy using bottom-up, top-down, 9 | #' middle-out and optimal combination methods. Three top-down methods are 10 | #' available: the two Gross-Sohl methods and the forecast-proportion approach 11 | #' of Hyndman, Ahmed, and Athanasopoulos (2011). 12 | #' 13 | #' 14 | #' @name hts-package 15 | #' @docType package 16 | #' @author Rob J Hyndman, Alan Lee, Earo Wang and Shanika L Wickramasuriya with 17 | #' contributions from Roman A Ahmed and Han Lin Shang to earlier versions of the 18 | #' package 19 | #' 20 | #' @references G. Athanasopoulos, R. A. Ahmed and R. J. Hyndman (2009) 21 | #' Hierarchical forecasts for Australian domestic tourism, \emph{International 22 | #' Journal of Forecasting}, \bold{25}, 146-166. 23 | #' 24 | #' R. J. Hyndman, R. A. Ahmed, G. Athanasopoulos and H.L. Shang (2011) Optimal 25 | #' combination forecasts for hierarchical time series. \emph{Computational 26 | #' Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 27 | #' \url{https://robjhyndman.com/publications/hierarchical/} 28 | #' 29 | #' Hyndman, R. J., Lee, A., & Wang, E. (2016). Fast computation of reconciled 30 | #' forecasts for hierarchical and grouped time series. \emph{Computational Statistics and Data Analysis}, 31 | #' \bold{97}, 16-23. \url{https://robjhyndman.com/papers/hgts7.pdf} 32 | #' 33 | #' Wickramasuriya, S. L., Athanasopoulos, G., & Hyndman, R. J. (2018). 34 | #' Forecasting hierarchical and grouped time series through trace minimization. 35 | #' \emph{Journal of the American Statistical Association}, to appear \url{https://robjhyndman.com/papers/mint.pdf} 36 | #' @keywords package 37 | NULL 38 | 39 | 40 | 41 | 42 | 43 | #' Simple examples of hierarchical time series. 44 | #' 45 | #' These are simulated data. \code{htseg1} has three levels with a total of 8 46 | #' series each of length 10. \code{htseg2} has four levels with a total of 17 47 | #' series each of length 16. 48 | #' 49 | #' 50 | #' @name htseg1 51 | #' @aliases htseg1 htseg2 52 | #' @docType data 53 | #' @format Objects of class \code{\link[hts]{hts}}. 54 | #' @references R. J. Hyndman, R. A. Ahmed, G. Athanasopoulos and H.L. Shang 55 | #' (2011) Optimal combination forecasts for hierarchical time series. 56 | #' \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 57 | #' \url{https://robjhyndman.com/publications/hierarchical/} 58 | #' @keywords datasets 59 | #' @examples 60 | #' 61 | #' plot(htseg1) 62 | #' 63 | NULL 64 | 65 | 66 | 67 | 68 | 69 | #' Regional infant mortality counts across Australia from 1933 to 2003. 70 | #' 71 | #' These are infant mortality counts. This data set is an example of 72 | #' \code{gts}, where the total infant mortality count in Australia can be first 73 | #' disaggregated by sex then by state, or vice versa. 74 | #' 75 | #' 76 | #' @name infantgts 77 | #' @docType data 78 | #' @format Objects of class \code{\link[hts]{gts}}. 79 | #' @references R. J. Hyndman, R. A. Ahmed, G. Athanasopoulos and H.L. Shang 80 | #' (2011) Optimal combination forecasts for hierarchical time series. 81 | #' \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 82 | #' @keywords datasets 83 | #' @examples 84 | #' 85 | #' plot(infantgts) 86 | #' 87 | NULL 88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: 3 | github_document: 4 | html_preview: false 5 | --- 6 | 7 | 8 | 9 | ```{r, echo = FALSE} 10 | knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.path = "man/figures/") 11 | ``` 12 | 13 | # hts 14 | 15 | [![R build status](https://github.com/earowang/hts/workflows/R-CMD-check/badge.svg)](https://github.com/earowang/hts/actions?workflow=R-CMD-check) 16 | [![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/hts)](https://cran.r-project.org/package=hts) 17 | [![Downloads](http://cranlogs.r-pkg.org/badges/hts)](https://cran.r-project.org/package=hts) 18 | [![Lifecycle: retired](https://img.shields.io/badge/lifecycle-retired-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html) 19 | 20 | **hts** is retired, with minimum maintenance to keep it on CRAN. We recommend using the [fable](http://fable.tidyverts.org) package instead. 21 | 22 | The R package *hts* presents functions to create, plot and forecast hierarchical and grouped time series. 23 | 24 | ## Installation 25 | You can install the **stable** version on 26 | [R CRAN](https://cran.r-project.org/package=hts). 27 | 28 | ```r 29 | install.packages('hts', dependencies = TRUE) 30 | ``` 31 | 32 | You can also install the **development** version from 33 | [Github](https://github.com/earowang/hts) 34 | 35 | ```r 36 | # install.packages("devtools") 37 | devtools::install_github("earowang/hts") 38 | ``` 39 | 40 | ## Usage 41 | 42 | ### Example 1: hierarchical time series 43 | 44 | ```{r hts-eg1, echo = TRUE} 45 | library(hts) 46 | 47 | # hts example 1 48 | print(htseg1) 49 | summary(htseg1) 50 | aggts1 <- aggts(htseg1) 51 | aggts2 <- aggts(htseg1, levels = 1) 52 | aggts3 <- aggts(htseg1, levels = c(0, 2)) 53 | plot(htseg1, levels = 1) 54 | smatrix(htseg1) # Return the dense mode 55 | 56 | # Forecasts 57 | fcasts1.bu <- forecast( 58 | htseg1, h = 4, method = "bu", fmethod = "ets", parallel = TRUE 59 | ) 60 | aggts4 <- aggts(fcasts1.bu) 61 | summary(fcasts1.bu) 62 | fcasts1.td <- forecast( 63 | htseg1, h = 4, method = "tdfp", fmethod = "arima", keep.fitted = TRUE 64 | ) 65 | summary(fcasts1.td) # When keep.fitted = TRUE, return in-sample accuracy 66 | fcasts1.comb <- forecast( 67 | htseg1, h = 4, method = "comb", fmethod = "ets", keep.fitted = TRUE 68 | ) 69 | aggts4 <- aggts(fcasts1.comb) 70 | plot(fcasts1.comb, levels = 2) 71 | plot(fcasts1.comb, include = 5, levels = c(1, 2)) 72 | ``` 73 | 74 | ### Example 2: hierarchical time series 75 | 76 | ```{r hts-eg2, echo = TRUE} 77 | # hts example 2 78 | data <- window(htseg2, start = 1992, end = 2002) 79 | test <- window(htseg2, start = 2003) 80 | fcasts2.mo <- forecast( 81 | data, h = 5, method = "mo", fmethod = "ets", level = 1, 82 | keep.fitted = TRUE, keep.resid = TRUE 83 | ) 84 | accuracy.gts(fcasts2.mo, test) 85 | accuracy.gts(fcasts2.mo, test, levels = 1) 86 | fcasts2.td <- forecast( 87 | data, h = 5, method = "tdgsa", fmethod = "ets", 88 | keep.fitted = TRUE, keep.resid = TRUE 89 | ) 90 | plot(fcasts2.td, include = 5) 91 | plot(fcasts2.td, include = 5, levels = c(0, 2)) 92 | ``` 93 | 94 | ### Example 3: grouped time series 95 | 96 | ```{r gts-eg, echo = TRUE} 97 | # gts example 98 | plot(infantgts, levels = 1) 99 | 100 | fcasts3.comb <- forecast(infantgts, h = 4, method = "comb", fmethod = "ets") 101 | agg_gts1 <- aggts(fcasts3.comb, levels = 1) 102 | agg_gts2 <- aggts(fcasts3.comb, levels = 1, forecasts = FALSE) 103 | plot(fcasts3.comb) 104 | plot(fcasts3.comb, include = 5, levels = c(1, 2)) 105 | 106 | fcasts3.combsd <- forecast( 107 | infantgts, h = 4, method = "comb", fmethod = "ets", 108 | weights = "sd", keep.fitted = TRUE 109 | ) 110 | 111 | fcasts3.combn <- forecast( 112 | infantgts, h = 4, method = "comb", fmethod = "ets", 113 | weights = "nseries", keep.resid = TRUE 114 | ) 115 | ``` 116 | 117 | ## License 118 | 119 | This package is free and open source software, licensed under GPL (>= 2). 120 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - master 5 | pull_request: 6 | branches: 7 | - master 8 | 9 | name: R-CMD-check 10 | 11 | jobs: 12 | R-CMD-check: 13 | runs-on: ${{ matrix.config.os }} 14 | 15 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 16 | 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | config: 21 | - {os: macOS-latest, r: 'release'} 22 | - {os: windows-latest, r: 'release'} 23 | - {os: windows-latest, r: '3.6'} 24 | - {os: ubuntu-16.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest", http-user-agent: "R/4.0.0 (ubuntu-16.04) R (4.0.0 x86_64-pc-linux-gnu x86_64 linux-gnu) on GitHub Actions" } 25 | - {os: ubuntu-16.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 26 | - {os: ubuntu-16.04, r: 'oldrel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 27 | - {os: ubuntu-16.04, r: '3.5', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 28 | - {os: ubuntu-16.04, r: '3.4', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 29 | - {os: ubuntu-16.04, r: '3.3', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 30 | 31 | env: 32 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 33 | RSPM: ${{ matrix.config.rspm }} 34 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 35 | 36 | steps: 37 | - uses: actions/checkout@v2 38 | 39 | - uses: r-lib/actions/setup-r@master 40 | with: 41 | r-version: ${{ matrix.config.r }} 42 | http-user-agent: ${{ matrix.config.http-user-agent }} 43 | 44 | - uses: r-lib/actions/setup-pandoc@master 45 | - uses: r-lib/actions/setup-tinytex@master 46 | 47 | - name: Query dependencies 48 | run: | 49 | install.packages('remotes') 50 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 51 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 52 | shell: Rscript {0} 53 | 54 | - name: Cache R packages 55 | if: runner.os != 'Windows' 56 | uses: actions/cache@v1 57 | with: 58 | path: ${{ env.R_LIBS_USER }} 59 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 60 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 61 | 62 | - name: Install system dependencies 63 | if: runner.os == 'Linux' 64 | run: | 65 | while read -r cmd 66 | do 67 | eval sudo $cmd 68 | done < <(Rscript -e 'cat(remotes::system_requirements("ubuntu", "16.04"), sep = "\n")') 69 | 70 | - name: Install dependencies 71 | run: | 72 | remotes::install_deps(dependencies = TRUE) 73 | remotes::install_cran("rcmdcheck") 74 | tinytex::tlmgr_install(c("ae", "mathtools", "microtype", "pgf")) 75 | shell: Rscript {0} 76 | 77 | - name: Session info 78 | run: | 79 | options(width = 100) 80 | pkgs <- installed.packages()[, "Package"] 81 | sessioninfo::session_info(pkgs, include_base = TRUE) 82 | shell: Rscript {0} 83 | 84 | - name: Check 85 | env: 86 | _R_CHECK_CRAN_INCOMING_: false 87 | run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran", "--no-build-vignettes"), error_on = "warning", check_dir = "check") 88 | shell: Rscript {0} 89 | 90 | - name: Show testthat output 91 | if: always() 92 | run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true 93 | shell: bash 94 | 95 | - name: Upload check results 96 | if: failure() 97 | uses: actions/upload-artifact@main 98 | with: 99 | name: ${{ runner.os }}-r${{ matrix.config.r }}-results 100 | path: check 101 | -------------------------------------------------------------------------------- /man/combinef.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/combinef.R 3 | \name{combinef} 4 | \alias{combinef} 5 | \title{Optimally combine forecasts from a hierarchical or grouped time series} 6 | \usage{ 7 | combinef( 8 | fcasts, 9 | nodes = NULL, 10 | groups = NULL, 11 | weights = NULL, 12 | nonnegative = FALSE, 13 | algorithms = c("lu", "cg", "chol", "recursive", "slm"), 14 | keep = c("gts", "all", "bottom"), 15 | parallel = FALSE, 16 | num.cores = 2, 17 | control.nn = list() 18 | ) 19 | } 20 | \arguments{ 21 | \item{fcasts}{Matrix of forecasts for all levels of the hierarchical time 22 | series. Each row represents one forecast horizon and each column represents 23 | one time series from the hierarchy.} 24 | 25 | \item{nodes}{If the object class is \code{hts}, a list contains the number 26 | of child nodes referring to \code{hts}.} 27 | 28 | \item{groups}{If the object class is \code{gts}, a gmatrix is required, 29 | which is the same as \code{groups} in the function \code{gts}.} 30 | 31 | \item{weights}{A numeric vector. The default is \code{NULL} which means that 32 | ordinary least squares is implemented.} 33 | 34 | \item{nonnegative}{Logical. Should the reconciled forecasts be non-negative?} 35 | 36 | \item{algorithms}{An algorithm to be used for computing reconciled 37 | forecasts. See \code{\link{forecast.gts}} for details.} 38 | 39 | \item{keep}{Return a \code{gts} object or the the reconciled forecasts at 40 | the bottom level.} 41 | 42 | \item{parallel}{Logical. Import parallel package to allow parallel processing.} 43 | 44 | \item{num.cores}{Numeric. Specify how many cores are going to be used.} 45 | 46 | \item{control.nn}{A list of control parameters to be passed on to the 47 | block principal pivoting algorithm. See 'Details'.} 48 | } 49 | \value{ 50 | Return the (non-negative) reconciled \code{gts} object or forecasts at the bottom 51 | level. 52 | } 53 | \description{ 54 | Using the methods of Hyndman et al. (2016) and Hyndman et al. (2011), this function optimally combines 55 | the forecasts at all levels of a hierarchical time series. The 56 | \code{\link{forecast.gts}} calls this function when the \code{comb} method 57 | is selected. 58 | } 59 | \details{ 60 | The \code{control.nn} argument is a list that can supply any of the following components: 61 | \describe{ 62 | \item{\code{ptype}}{Permutation method to be used: \code{"fixed"} or \code{"random"}. Defaults to \code{"fixed"}.} 63 | \item{\code{par}}{The number of full exchange rules that may be tried. Defaults to 10.} 64 | \item{\code{gtol}}{The tolerance of the convergence criteria. Defaults to \code{sqrt(.Machine$double.eps)}.} 65 | } 66 | } 67 | \examples{ 68 | 69 | # hts example 70 | \dontrun{ 71 | h <- 12 72 | ally <- aggts(htseg1) 73 | allf <- matrix(NA, nrow = h, ncol = ncol(ally)) 74 | for(i in 1:ncol(ally)) 75 | allf[,i] <- forecast(auto.arima(ally[,i]), h = h)$mean 76 | allf <- ts(allf, start = 51) 77 | y.f <- combinef(allf, get_nodes(htseg1), weights = NULL, keep = "gts", algorithms = "lu") 78 | plot(y.f) 79 | } 80 | 81 | \dontrun{ 82 | h <- 12 83 | ally <- abs(aggts(htseg2)) 84 | allf <- matrix(NA, nrow = h, ncol = ncol(ally)) 85 | for(i in 1:ncol(ally)) 86 | allf[,i] <- forecast(auto.arima(ally[,i], lambda = 0, biasadj = TRUE), h = h)$mean 87 | b.f <- combinef(allf, get_nodes(htseg2), weights = NULL, keep = "bottom", 88 | algorithms = "lu") 89 | b.nnf <- combinef(allf, get_nodes(htseg2), weights = NULL, keep = "bottom", 90 | algorithms = "lu", nonnegative = TRUE) 91 | } 92 | 93 | # gts example 94 | \dontrun{ 95 | abc <- ts(5 + matrix(sort(rnorm(200)), ncol = 4, nrow = 50)) 96 | g <- rbind(c(1,1,2,2), c(1,2,1,2)) 97 | y <- gts(abc, groups = g) 98 | h <- 12 99 | ally <- aggts(y) 100 | allf <- matrix(NA,nrow = h,ncol = ncol(ally)) 101 | for(i in 1:ncol(ally)) 102 | allf[,i] <- forecast(auto.arima(ally[,i]),h = h)$mean 103 | allf <- ts(allf, start = 51) 104 | y.f <- combinef(allf, groups = get_groups(y), keep ="gts", algorithms = "lu") 105 | plot(y.f) 106 | } 107 | } 108 | \references{ 109 | Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. 110 | (2011). Optimal combination forecasts for hierarchical time series. 111 | \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. \url{https://robjhyndman.com/publications/hierarchical/} 112 | 113 | Hyndman, R. J., Lee, A., & Wang, E. (2016). Fast computation of reconciled 114 | forecasts for hierarchical and grouped time series. \emph{Computational Statistics and Data Analysis}, 115 | \bold{97}, 16--32. \url{https://robjhyndman.com/publications/hgts/} 116 | 117 | Wickramasuriya, S. L., Turlach, B. A., & Hyndman, R. J. (to appear). Optimal non-negative forecast reconciliation. 118 | \emph{Statistics and Computing}. \url{https://robjhyndman.com/publications/nnmint/} 119 | } 120 | \seealso{ 121 | \code{\link[hts]{hts}}, \code{\link[hts]{forecast.gts}} 122 | } 123 | \author{ 124 | Alan Lee, Rob J Hyndman, Earo Wang and Shanika L Wickramasuriya 125 | } 126 | \keyword{ts} 127 | -------------------------------------------------------------------------------- /R/accuracy-gts.R: -------------------------------------------------------------------------------- 1 | #' In-sample or out-of-sample accuracy measures for forecast grouped and 2 | #' hierarchical model 3 | #' 4 | #' Returns a range of summary measures of the forecast accuracy. The function 5 | #' measures out-of-sample forecast accuracy based on (holdout data - forecasts) 6 | #' and in-sample accuracy at the bottom level when setting \code{keep.fitted = 7 | #' TRUE} in the \code{\link[hts]{forecast.gts}}. All measures are defined and 8 | #' discussed in Hyndman and Koehler (2006). 9 | #' 10 | #' MASE calculation is scaled using MAE of in-sample naive forecasts for 11 | #' non-seasonal time series, and in-sample seasonal naive forecasts for 12 | #' seasonal time series. 13 | #' 14 | #' @param object An object of class \code{gts}, containing the forecasted 15 | #' hierarchical or grouped time series. In-sample accuracy at the bottom level 16 | #' returns when \code{test} is missing. 17 | #' @param test An object of class \code{gts}, containing the holdout 18 | #' hierarchical time series 19 | #' @param levels Return the specified level(s), when carrying out out-of-sample 20 | #' @param ... Extra arguments to be ignored 21 | #' @param f Deprecated. Please use `object` instead. 22 | #' @return Matrix giving forecast accuracy measures. \item{ME}{Mean Error} 23 | #' \item{RMSE}{Root Mean Square Error} \item{MAE}{Mean Absolute Error} 24 | #' \item{MAPE}{Mean Absolute Percentage Error} \item{MPE}{Mean Percentage 25 | #' Error} \item{MASE}{Mean Absolute Scaled Error} 26 | #' @author Rob J Hyndman and Earo Wang 27 | #' @seealso \code{\link[hts]{hts}}, \code{\link[hts]{plot.gts}}, 28 | #' \code{\link[hts]{forecast.gts}}, \code{\link[forecast]{accuracy}} 29 | #' @references R. J. Hyndman and A. Koehler (2006), Another look at measures of 30 | #' forecast accuracy, \emph{International Journal of Forecasting}, \bold{22}, 31 | #' 679-688. 32 | #' @keywords error 33 | #' @method accuracy gts 34 | #' @examples 35 | #' 36 | #' data <- window(htseg2, start = 1992, end = 2002) 37 | #' test <- window(htseg2, start = 2003) 38 | #' fcasts <- forecast(data, h = 5, method = "bu") 39 | #' accuracy(fcasts, test) 40 | #' accuracy(fcasts, test, levels = 1) 41 | #' 42 | #' @export 43 | #' @export accuracy.gts 44 | accuracy.gts <- function(object, test, levels, ..., f = NULL) { 45 | # Compute in-sample or out-of-sample accuracy measures 46 | # 47 | # Args: 48 | # f: forcasts 49 | # test: Test set. If it's missing, default is in-sample accuracy for the 50 | # bottom level, when keep.fitted is set to TRUE in the forecast.gts(). 51 | # levels: If computing out-of-sample accuracy, users can select whatever 52 | # levels they like. 53 | # 54 | # Returns: 55 | # Accuracy measures 56 | # 57 | # Error Handling: 58 | if(!is.null(f)){ 59 | warning("Using `f` as the argument for `accuracy()` is deprecated. Please use `object` instead.") 60 | object <- f 61 | } 62 | if (!is.gts(object)) { 63 | stop("Argument f must be a grouped time series.", call. = FALSE) 64 | } 65 | if (!missing(test) && !is.gts(test)) { 66 | stop("Argument test must be a grouped time series.", call. = FALSE) 67 | } 68 | 69 | if (missing(test)) 70 | { 71 | if(is.null(object$fitted)) 72 | stop("No fitted values available for historical times, and no actual values available for future times", call. = FALSE) 73 | 74 | x <- unclass(object$histy) # Unclass mts to matrix 75 | res <- x - unclass(object$fitted) # f$residuals may contain errors 76 | levels <- ifelse(is.hts(object), length(object$nodes), 77 | nrow(object$groups) - 1L) 78 | } 79 | else { 80 | fcasts <- unclass(aggts(object, levels, forecasts = TRUE)) 81 | x <- unclass(aggts(test, levels)) 82 | tspf <- tsp(fcasts) 83 | tspx <- tsp(x) 84 | start <- max(tspf[1], tspx[1]) 85 | end <- min(tspf[2], tspx[2]) 86 | start <- min(start, end) 87 | end <- max(start, end) 88 | fcasts <- window(fcasts, start = start, end = end) 89 | x <- window(x, start = start, end = end) 90 | res <- x - fcasts 91 | } 92 | 93 | if(is.null(object$histy)) 94 | histy <- NULL 95 | else 96 | histy <- aggts(object, levels, forecasts = FALSE) 97 | if (!is.null(histy)) { 98 | m <- max(1, round(stats::frequency(histy))) 99 | if(m > 1 & NROW(histy) < 2*m) { 100 | warning("Not enough historical data to use seasonal naive method for MASE. Using naive method instead.") 101 | m <- 1 102 | } 103 | scale <- colMeans(abs(diff(histy, lag = m)), na.rm = TRUE) 104 | q <- sweep(res, 2, scale, "/") 105 | mase <- colMeans(abs(q), na.rm = TRUE) 106 | } 107 | pe <- res/x * 100 # percentage error 108 | 109 | me <- colMeans(res, na.rm = TRUE) 110 | rmse <- sqrt(colMeans(res^2, na.rm = TRUE)) 111 | mae <- colMeans(abs(res), na.rm = TRUE) 112 | mape <- colMeans(abs(pe), na.rm = TRUE) 113 | mpe <- colMeans(pe, na.rm = TRUE) 114 | 115 | out <- rbind(me, rmse, mae, mape, mpe) 116 | rownames(out) <- c("ME", "RMSE", "MAE", "MAPE", "MPE") 117 | if (exists("mase")) { 118 | out <- rbind(out, mase) 119 | rownames(out)[6L] <- "MASE" 120 | } 121 | if (exists("fcasts")) { 122 | colnames(out) <- colnames(fcasts) 123 | } 124 | return(out) 125 | } 126 | -------------------------------------------------------------------------------- /R/plot-gts.R: -------------------------------------------------------------------------------- 1 | #' Plot grouped or hierarchical time series 2 | #' 3 | #' Method for plotting grouped or hierarchical time series and their forecasts. 4 | #' 5 | #' 6 | #' @param x An object of class \code{\link[hts]{gts}}. 7 | #' @param include Number of values from historical time series to include in 8 | #' the plot of forecasted group/hierarchical time series. 9 | #' @param levels Integer(s) or string(s) giving the specified levels(s) to be 10 | #' plotted 11 | #' @param labels If \code{TRUE}, plot the labels next to each series 12 | #' @param col Vector of colours, passed to \code{plot.ts} and to \code{lines} 13 | #' @param color_lab If \code{TRUE}, colour the direct labels to match line 14 | #' colours. If \code{FALSE} will be as per \code{par()$fg}. 15 | #' @param \dots Other arguments passing to \code{\link[graphics]{plot.default}} 16 | #' @author Rob J Hyndman and Earo Wang 17 | #' @seealso \code{\link[hts]{aggts}} 18 | #' @references Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. 19 | #' (2011). Optimal combination forecasts for hierarchical time series. 20 | #' \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 21 | #' \url{https://robjhyndman.com/publications/hierarchical/} 22 | #' @keywords hplot 23 | #' @method plot gts 24 | #' @examples 25 | #' 26 | #' plot(htseg1, levels = c(0, 2)) 27 | #' plot(infantgts, include = 10, levels = "State") 28 | #' plot(infantgts, include = 10, levels = "State", 29 | #' col = colours()[100:107], lty = 1:8, color_lab = TRUE) 30 | #' 31 | #' @export 32 | #' @export plot.gts 33 | 34 | plot.gts <- function(x, include, levels, labels = TRUE, 35 | col = NULL, color_lab = FALSE, ...) { 36 | # Do plotting 37 | # 38 | # Args: 39 | # x: hts or gts 40 | # include: No. of historical data included in the plot. 41 | # levels: which level or group to display. 42 | # labels: text labels 43 | # 44 | # Return: 45 | # hts or gts plots 46 | # 47 | # Error Handling: 48 | if (!is.gts(x)) { 49 | stop("Argument x must be either hts or gts object.", call. = FALSE) 50 | } 51 | 52 | if (!is.null(x$histy)) { 53 | histx <- aggts(x, levels, forecasts = FALSE) 54 | fcasts <- aggts(x, levels, forecasts = TRUE) 55 | } else { 56 | histx <- aggts(x, levels) 57 | } 58 | 59 | if (missing(include)) { 60 | histx <- histx 61 | include <- nrow(histx) 62 | } else { 63 | tspx <- stats::tsp(histx) 64 | histx <- stats::window(histx, start = tspx[2L] - include/tspx[3L] + 1L/tspx[3L]) 65 | } 66 | 67 | if (missing(levels)) { 68 | if (is.hts(x)) { 69 | levels <- 0L:length(x$nodes) 70 | } else { 71 | levels <- 0L:(nrow(x$groups) - 1L) 72 | } 73 | } 74 | 75 | l.levels <- length(levels) 76 | if (is.character(levels)) { 77 | levels <- which(names(x$labels) %in% levels) 78 | } 79 | levels <- as.integer(levels) + 1L 80 | 81 | dots.list <- match.call(expand.dots = FALSE)$`...` 82 | opar <- par(mfrow = c(l.levels, 1L), mar = c(3, 4, 4, 2)) 83 | on.exit(par(opar)) 84 | 85 | if (is.hts(x)) { 86 | m <- Mnodes(x$nodes)[levels] 87 | } else { 88 | m <- Mlevel(x$groups)[levels] 89 | x$labels <- c(Total = "Total", x$labels, Bottom = list(colnames(x$bts))) 90 | } 91 | 92 | cs <- c(0L, cumsum(m)) 93 | 94 | for (i in 1L:l.levels) { 95 | end <- cs[i + 1L] 96 | start <- cs[i] + 1L 97 | series <- seq(start, end) 98 | if(is.null(col)){ 99 | cols <- grDevices::rainbow(length(series)) 100 | } else { 101 | cols <- col 102 | } 103 | if(!is.null(x$histy)) { 104 | ylim <- range(histx[, series], fcasts[, series], na.rm = TRUE) 105 | xlim <- range(time(histx), time(fcasts), na.rm = TRUE) 106 | } else { 107 | ylim <- range(histx[, series], na.rm = TRUE) 108 | xlim <- range(time(histx), na.rm=TRUE) 109 | } 110 | if (labels) { 111 | strlabels <- max(strwidth(x$labels[levels], units = "figure")) 112 | xlim[1L] <- xlim[1L] - strlabels * diff(xlim) / par()$fin[1] 113 | } 114 | if (is.null(dots.list$xlim)) { 115 | plot(histx[, series, drop = FALSE], col = cols, xlim = xlim, ylim = ylim, 116 | xlab = "", ylab = "", main = names(x$labels)[levels][i], 117 | plot.type = "single", 118 | type = ifelse(length(1:include) == 1L, "p", "l"), 119 | ...) 120 | } else { 121 | plot(histx[, series, drop = FALSE], col = cols, ylim = ylim, 122 | xlab = "", ylab = "", main = names(x$labels)[levels][i], 123 | plot.type = "single", 124 | type = ifelse(length(1:include) == 1L, "p", "l"), 125 | ...) 126 | } 127 | 128 | if (!is.null(x$histy)) { 129 | for (j in 1L:length(series)) { 130 | lines(fcasts[, series[j], drop = FALSE], lty = 2, col = cols[j], 131 | type = ifelse(nrow(fcasts) == 1L, "p", "l")) 132 | } 133 | } 134 | 135 | if (labels) { 136 | if(color_lab){ 137 | lab_col <- cols 138 | } else { 139 | lab_col <- par()$fg 140 | } 141 | text(x = stats::tsp(histx)[1L] - 0.02*diff(xlim), y = histx[1L, series], 142 | labels = unlist(x$labels[levels][i]), 143 | cex = 0.9, adj = 1, col = lab_col) 144 | } 145 | } 146 | } 147 | -------------------------------------------------------------------------------- /man/gts-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/gts.R 3 | \name{gts} 4 | \alias{gts} 5 | \alias{print.gts} 6 | \alias{summary.gts} 7 | \alias{is.gts} 8 | \title{Create a grouped time series} 9 | \usage{ 10 | gts(y, groups, gnames = rownames(groups), characters) 11 | 12 | is.gts(xts) 13 | 14 | \method{print}{gts}(x, ...) 15 | 16 | \method{summary}{gts}(object, ...) 17 | } 18 | \arguments{ 19 | \item{y}{A matrix or multivariate time series contains the bottom level 20 | series.} 21 | 22 | \item{groups}{Group matrix indicates the group structure, with one column 23 | for each series when completely disaggregated, and one row for each grouping 24 | of the time series. It allows either a numerical matrix or a matrix 25 | consisting of strings that can be used for labelling. If the argument 26 | \code{characters} is used, then \code{groups} will be automatically 27 | generated within the function.} 28 | 29 | \item{gnames}{Specify the group names.} 30 | 31 | \item{characters}{A vector of integers, or a list containing vectors of 32 | integers, indicating the segments in which bottom level names can be read in 33 | order to construct the corresponding grouping matrix and its labels. A 34 | \code{list} class is used when a grouped time series includes one or more 35 | hierarchies. For example, a grouped time series may involve a geographical 36 | grouping and a product grouping, with each of them associated with a 2-level 37 | hierarchy. In this situation, a bottom level name such as "VICMelbAB" would 38 | indicate the state "VIC" (3 characters) followed by the city "Melb" (4 39 | characters), then the product category "A" (1 character) followed by the 40 | sub-product category "B" (1 character). In this example, the specification 41 | of \code{characters} is \code{list(c(3, 4), c(1, 1))}, where the first 42 | element \code{c(3, 4)} corresponds to the geographical hierarchy and the 43 | second element corresponds to the product hierarchy. In the special case 44 | where there is a non-hierarchical grouped time series, a vector of integers 45 | is also possible. For example, a grouped time series may involve state, age 46 | and sex grouping variables. In this situation, a bottom level name such as 47 | "VIC1F" would indicate the state "VIC", age group "1" and sex "F". Because 48 | none of these is hierarchical, we could specify \code{characters = list(3, 49 | 1, 1)}, or as a simple numeric vector: \code{characters = c(3, 1, 1)}. This 50 | implies its non-hierarchical structure and its characters segments. Again, 51 | all bottom level names must be of the same length. Currently, the use of 52 | \code{characters} only supports 2-way cross-products for grouping variables. 53 | Specifying \code{groups} is more general (but more complicated), as any 54 | combination of grouping variables can be used.} 55 | 56 | \item{xts}{\code{gts} object.} 57 | 58 | \item{x}{\code{gts} object.} 59 | 60 | \item{...}{Extra arguments passed to \code{print} and \code{summary}.} 61 | 62 | \item{object}{\code{gts} object.} 63 | } 64 | \value{ 65 | \item{bts}{Multivariate time series contains the bottom level 66 | series} \item{groups}{Information about the groups of a grouped time series} 67 | \item{labels}{Information about the labels that are used for plotting.} 68 | } 69 | \description{ 70 | Method for creating grouped time series. 71 | } 72 | \examples{ 73 | 74 | # Example 1 illustrating the usage of the "groups" argument 75 | abc <- ts(5 + matrix(sort(rnorm(1600)), ncol = 16, nrow = 100)) 76 | sex <- rep(c("female", "male"), each = 8) 77 | state <- rep(c("NSW", "VIC", "QLD", "SA", "WA", "NT", "ACT", "TAS"), 2) 78 | gc <- rbind(sex, state) # a matrix consists of strings. 79 | gn <- rbind(rep(1:2, each = 8), rep(1:8, 2)) # a numerical matrix 80 | rownames(gc) <- rownames(gn) <- c("Sex", "State") 81 | x <- gts(abc, groups = gc) 82 | y <- gts(abc, groups = gn) 83 | 84 | # Example 2 with two simple hierarchies (geography and product) to show the argument "characters" 85 | bnames1 <- c("VICMelbAA", "VICMelbAB", "VICGeelAA", "VICGeelAB", 86 | "VICMelbBA", "VICMelbBB", "VICGeelBA", "VICGeelBB", 87 | "NSWSyndAA", "NSWSyndAB", "NSWWollAA", "NSWWollAB", 88 | "NSWSyndBA", "NSWSyndBB", "NSWWollBA", "NSWWollBB") 89 | bts1 <- matrix(ts(rnorm(160)), ncol = 16) 90 | colnames(bts1) <- bnames1 91 | x1 <- gts(bts1, characters = list(c(3, 4), c(1, 1))) 92 | 93 | # Example 3 with a non-hierarchical grouped time series of 3 grouping variables (state, age and sex) 94 | bnames2 <- c("VIC1F", "VIC1M", "VIC2F", "VIC2M", "VIC3F", "VIC3M", 95 | "NSW1F", "NSW1M", "NSW2F", "NSW2M", "NSW3F", "NSW3M") 96 | bts2 <- matrix(ts(rnorm(120)), ncol = 12) 97 | colnames(bts2) <- bnames2 98 | x2 <- gts(bts2, characters = c(3, 1, 1)) 99 | 100 | } 101 | \references{ 102 | Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. 103 | (2011). Optimal combination forecasts for hierarchical time series. 104 | \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 105 | \url{https://robjhyndman.com/publications/hierarchical/} 106 | } 107 | \seealso{ 108 | \code{\link[hts]{hts}}, \code{\link[hts]{accuracy.gts}}, 109 | \code{\link[hts]{forecast.gts}}, \code{\link[hts]{plot.gts}} 110 | } 111 | \author{ 112 | Earo Wang and Rob J Hyndman 113 | } 114 | \keyword{ts} 115 | -------------------------------------------------------------------------------- /man/MinT.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/MinT.R 3 | \name{MinT} 4 | \alias{MinT} 5 | \title{Trace minimization for hierarchical or grouped time series} 6 | \usage{ 7 | MinT( 8 | fcasts, 9 | nodes = NULL, 10 | groups = NULL, 11 | residual, 12 | covariance = c("shr", "sam"), 13 | nonnegative = FALSE, 14 | algorithms = c("lu", "cg", "chol"), 15 | keep = c("gts", "all", "bottom"), 16 | parallel = FALSE, 17 | num.cores = 2, 18 | control.nn = list() 19 | ) 20 | } 21 | \arguments{ 22 | \item{fcasts}{Matrix of forecasts for all levels of a hierarchical or 23 | grouped time series. Each row represents one forecast horizon and each 24 | column represents one time series of aggregated or disaggregated forecasts.} 25 | 26 | \item{nodes}{If the object class is hts, a list contains the number of child 27 | nodes referring to hts.} 28 | 29 | \item{groups}{If the object is gts, a gmatrix is required, which is the same 30 | as groups in the function gts.} 31 | 32 | \item{residual}{Matrix of insample residuals for all the aggregated and 33 | disaggregated time series. The columns must be in the same order as 34 | \code{fcasts}.} 35 | 36 | \item{covariance}{Type of the covariance matrix to be used. Shrinking 37 | towards a diagonal unequal variances (\code{"shr"}) or sample covariance matrix 38 | (\code{"sam"}).} 39 | 40 | \item{nonnegative}{Logical. Should the reconciled forecasts be non-negative?} 41 | 42 | \item{algorithms}{Algorithm used to compute inverse of the matrices.} 43 | 44 | \item{keep}{Return a gts object or the reconciled forecasts at the bottom 45 | level.} 46 | 47 | \item{parallel}{Logical. Import parallel package to allow parallel processing.} 48 | 49 | \item{num.cores}{Numeric. Specify how many cores are going to be used.} 50 | 51 | \item{control.nn}{A list of control parameters to be passed on to the 52 | block principal pivoting algorithm. See 'Details'.} 53 | } 54 | \value{ 55 | Return the reconciled \code{gts} object or forecasts at the bottom 56 | level. 57 | } 58 | \description{ 59 | Using the method of Wickramasuriya et al. (2019), this function combines the 60 | forecasts at all levels of a hierarchical or grouped time series. The 61 | \code{\link{forecast.gts}} calls this function when the \code{MinT} method 62 | is selected. 63 | } 64 | \details{ 65 | The \code{control.nn} argument is a list that can supply any of the following components: 66 | \describe{ 67 | \item{\code{ptype}}{Permutation method to be used: \code{"fixed"} or \code{"random"}. Defaults to \code{"fixed"}.} 68 | \item{\code{par}}{The number of full exchange rules that may be tried. Defaults to 10.} 69 | \item{\code{gtol}}{The tolerance of the convergence criteria. Defaults to \code{sqrt(.Machine$double.eps)}.} 70 | } 71 | } 72 | \examples{ 73 | 74 | # hts example 75 | \dontrun{ 76 | h <- 12 77 | ally <- aggts(htseg1) 78 | n <- nrow(ally) 79 | p <- ncol(ally) 80 | allf <- matrix(NA, nrow = h, ncol = p) 81 | res <- matrix(NA, nrow = n, ncol = p) 82 | for(i in 1:p) 83 | { 84 | fit <- auto.arima(ally[, i]) 85 | allf[, i] <- forecast(fit, h = h)$mean 86 | res[, i] <- na.omit(ally[, i] - fitted(fit)) 87 | } 88 | allf <- ts(allf, start = 51) 89 | y.f <- MinT(allf, get_nodes(htseg1), residual = res, covariance = "shr", 90 | keep = "gts", algorithms = "lu") 91 | plot(y.f) 92 | y.f_cg <- MinT(allf, get_nodes(htseg1), residual = res, covariance = "shr", 93 | keep = "all", algorithms = "cg") 94 | } 95 | 96 | \dontrun{ 97 | h <- 12 98 | ally <- abs(aggts(htseg2)) 99 | allf <- matrix(NA, nrow = h, ncol = ncol(ally)) 100 | res <- matrix(NA, nrow = nrow(ally), ncol = ncol(ally)) 101 | for(i in 1:ncol(ally)) { 102 | fit <- auto.arima(ally[, i], lambda = 0, biasadj = TRUE) 103 | allf[,i] <- forecast(fit, h = h)$mean 104 | res[,i] <- na.omit(ally[, i] - fitted(fit)) 105 | } 106 | b.f <- MinT(allf, get_nodes(htseg2), residual = res, covariance = "shr", 107 | keep = "bottom", algorithms = "lu") 108 | b.nnf <- MinT(allf, get_nodes(htseg2), residual = res, covariance = "shr", 109 | keep = "bottom", algorithms = "lu", nonnegative = TRUE, parallel = TRUE) 110 | } 111 | 112 | # gts example 113 | \dontrun{ 114 | abc <- ts(5 + matrix(sort(rnorm(200)), ncol = 4, nrow = 50)) 115 | g <- rbind(c(1,1,2,2), c(1,2,1,2)) 116 | y <- gts(abc, groups = g) 117 | h <- 12 118 | ally <- aggts(y) 119 | n <- nrow(ally) 120 | p <- ncol(ally) 121 | allf <- matrix(NA,nrow = h,ncol = ncol(ally)) 122 | res <- matrix(NA, nrow = n, ncol = p) 123 | for(i in 1:p) 124 | { 125 | fit <- auto.arima(ally[, i]) 126 | allf[, i] <- forecast(fit, h = h)$mean 127 | res[, i] <- na.omit(ally[, i] - fitted(fit)) 128 | } 129 | allf <- ts(allf, start = 51) 130 | y.f <- MinT(allf, groups = get_groups(y), residual = res, covariance = "shr", 131 | keep = "gts", algorithms = "lu") 132 | plot(y.f) 133 | } 134 | } 135 | \references{ 136 | Wickramasuriya, S. L., Athanasopoulos, G., & Hyndman, R. J. (2019). 137 | Optimal forecast reconciliation for hierarchical and grouped time series through trace minimization. 138 | \emph{Journal of the American Statistical Association}, \bold{114}(526), 804--819. \url{https://robjhyndman.com/publications/mint/} 139 | 140 | Wickramasuriya, S. L., Turlach, B. A., & Hyndman, R. J. (to appear). Optimal non-negative forecast reconciliation. 141 | \emph{Statistics and Computing}. \url{https://robjhyndman.com/publications/nnmint/} 142 | 143 | Hyndman, R. J., Lee, A., & Wang, E. (2016). Fast computation of reconciled 144 | forecasts for hierarchical and grouped time series. \emph{Computational 145 | Statistics and Data Analysis}, \bold{97}, 16--32. 146 | \url{https://robjhyndman.com/publications/hgts/} 147 | } 148 | \seealso{ 149 | \code{\link[hts]{hts}}, \code{\link[hts]{gts}}, 150 | \code{\link[hts]{forecast.gts}}, \code{\link[hts]{combinef}} 151 | } 152 | \author{ 153 | Shanika L Wickramasuriya 154 | } 155 | \keyword{ts} 156 | -------------------------------------------------------------------------------- /R/tracemin.R: -------------------------------------------------------------------------------- 1 | # 3 algorithms for forecasting reconciliation through trace minimization 2 | # Only used for BLUF 3 | # Author: Shanika Wickramasuriya 4 | # Paper: Forecasting hierarchical and grouped time series through trace 5 | # minimization 6 | # All these functions return a reverse reconciled matrix with all ts. 7 | 8 | #LU decomposition is fast but sometimes instable. Use QR decomposition if LU decomposition fails 9 | solveLUQR <- function(lhs.l, rhs.l) { 10 | tryCatch(solve(lhs.l, rhs.l), error=function(cond){ 11 | 12 | #browser() 13 | warning("An error in LU decomposition occurred, the message was the following:\n", 14 | cond$message, "\n Trying QR decomposition instead...") 15 | solve(qr(lhs.l), rhs.l) 16 | }) 17 | } 18 | 19 | # LU factorization (Matrix pkg) 20 | LU <- function(fcasts, S, weights, allow.changes = FALSE) { 21 | nts <- nrow(S) 22 | nbts <- ncol(S) 23 | nagg <- nts - nbts 24 | seqagg <- 1L:nagg 25 | 26 | if (!allow.changes) { 27 | utmat <- cbind2(sparseMatrix(i = seqagg, j = seqagg, x = 1), 28 | -1 * S[1L:nagg, , drop = TRUE]) 29 | } else { 30 | # Identifying rows with one 1 element to make the Identity matrix in S 31 | indx <- rowSums(S) 32 | idx <- tail(which(indx == 1L), nbts) 33 | 34 | # Permulation vector to rearrange rows of S, rows/col of W and forecasts 35 | pvec <- c(setdiff(1:nts, idx) , idx) 36 | S2 <- S[pvec, ] 37 | weights <- weights[pvec, pvec] 38 | fcasts <- fcasts[pvec, ] 39 | utmat <- cbind2(sparseMatrix(i = seqagg, j = seqagg, x = 1), 40 | -1 * S2[1L:nagg, , drop = TRUE]) 41 | } 42 | jmat <- sparseMatrix(i = 1L:nbts, j = (nagg + 1L):nts, x = rep(1L, nbts), 43 | dims = c(nbts, nts)) 44 | rhs.l <- methods::as(utmat %*% fcasts, "CsparseMatrix") 45 | if (is.null(weights)) { 46 | lhs.l <- utmat %*% t(utmat) 47 | lhs.l <- (t(lhs.l) + lhs.l)/2 48 | lin.sol <- solveLUQR(lhs.l, rhs.l) 49 | p1 <- jmat %*% fcasts - (jmat %*% t(utmat) %*% lin.sol) 50 | } else { 51 | lhs.l <- utmat %*% weights %*% t(utmat) 52 | lhs.l <- (t(lhs.l) + lhs.l)/2 53 | lin.sol <- solveLUQR(lhs.l, rhs.l) 54 | p1 <- jmat %*% fcasts - (jmat %*% weights %*% t(utmat) %*% lin.sol) 55 | } 56 | if (!allow.changes) { 57 | comb <- as.matrix(S %*% p1) 58 | } else { 59 | comb <- numeric() 60 | comb[pvec] <- as.matrix(S2 %*% p1) 61 | } 62 | return(comb) 63 | } 64 | 65 | # Conjugate Gradient (Matrix and RcppEigen pkgs) 66 | CG <- function(fcasts, S, weights, allow.changes = FALSE) { 67 | nts <- nrow(S) 68 | nbts <- ncol(S) 69 | nagg <- nts - nbts 70 | seqagg <- 1L:nagg 71 | if (!allow.changes) { 72 | utmat <- cbind2(Matrix::sparseMatrix(i = seqagg, j = seqagg, x = 1), 73 | -1 * S[1L:nagg, ]) 74 | } else { 75 | # Identifying rows with one 1 element to make the Identity matrix in S 76 | indx <- rowSums(S) 77 | idx <- tail(which(indx == 1L), nbts) 78 | 79 | # Permulation vector to rearrange rows of S, rows/col of W and forecasts 80 | pvec <- c(setdiff(1:nts, idx) , idx) 81 | S2 <- S[pvec, ] 82 | weights <- weights[pvec, pvec] 83 | fcasts <- fcasts[pvec, ] 84 | utmat <- cbind2(Matrix::sparseMatrix(i = seqagg, j = seqagg, x = 1), 85 | -1 * S2[1L:nagg, ]) 86 | } 87 | jmat <- Matrix::sparseMatrix(i = 1L:nbts, j = (nagg + 1L):nts, x = rep(1L, nbts), 88 | dims = c(nbts, nts)) 89 | rhs.l <- as.matrix(utmat %*% fcasts) 90 | if (is.null(weights)) { 91 | lhs.l <- utmat %*% t(utmat) 92 | lin.sol <- as.matrix(cgm_c(lhs.l, rhs.l)) # cgm_c is a C++ function 93 | p1 <- jmat %*% fcasts - (jmat %*% t(utmat) %*% lin.sol) 94 | } else { 95 | lhs.l <- utmat %*% weights %*% t(utmat) 96 | lin.sol <- as.matrix(cgm_c(lhs.l, rhs.l)) 97 | p1 <- jmat %*% fcasts - (jmat %*% weights %*% t(utmat) %*% lin.sol) 98 | } 99 | if (!allow.changes) { 100 | comb <- as.matrix(S %*% p1) 101 | } else { 102 | comb <- numeric() 103 | comb[pvec] <- as.matrix(S2 %*% p1) 104 | } 105 | return(comb) 106 | } 107 | 108 | # Cholesky factorization 109 | CHOL <- function(fcasts, S, weights, allow.changes = FALSE) { 110 | fcasts <- t(stats::na.omit(t(fcasts))) 111 | nts <- nrow(S) 112 | nbts <- ncol(S) 113 | nagg <- nts - nbts 114 | seqagg <- 1L:nagg 115 | if (!allow.changes) { 116 | utmat <- cbind(methods::as(nagg, "matrix.diag.csr"), -1 * S[1L:nagg, ]) 117 | } else { 118 | # Identifying rows with one 1 element to make the Identity matrix in S 119 | Sm <- as(S, "dgCMatrix") 120 | indx <- rowSums(Sm) 121 | idx <- tail(which(indx == 1L), nbts) 122 | 123 | # Permulation vector to rearrange rows of S, rows/col of W and forecasts 124 | pvec <- c(setdiff(1:nts, idx) , idx) 125 | S2 <- S[pvec, ] 126 | weights <- weights[pvec, pvec] 127 | fcasts <- fcasts[pvec, ] 128 | utmat <- cbind(methods::as(nagg, "matrix.diag.csr"), -1 * S2[1L:nagg, ]) 129 | } 130 | jmat <- methods::new("matrix.csr", ra = rep(1L, nbts), ja = seq((nagg + 1L), nts), 131 | ia = 1L:(nbts + 1L), dimension = as.integer(c(nbts, nts))) 132 | rhs.l <- utmat %*% fcasts 133 | if (is.null(weights)) { 134 | lhs.l <- utmat %*% t(utmat) 135 | lhs.l <- (t(lhs.l) + lhs.l)/2 136 | lin.sol <- backsolve(chol(lhs.l), rhs.l) 137 | p1 <- jmat %*% fcasts - (jmat %*% t(utmat) %*% lin.sol) 138 | } else { 139 | lhs.l <- utmat %*% weights %*% t(utmat) 140 | lhs.l <- (t(lhs.l) + lhs.l)/2 141 | lin.sol <- backsolve(chol(lhs.l), rhs.l) 142 | p1 <- jmat %*% fcasts - (jmat %*% weights %*% t(utmat) %*% lin.sol) 143 | } 144 | if (!allow.changes) { 145 | comb <- as.matrix(S %*% p1) 146 | } else { 147 | comb <- numeric() 148 | comb[pvec] <- as.matrix(S2 %*% p1) 149 | } 150 | return(comb) 151 | } 152 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # hts 6.0.3 2 | 3 | * Cran maintenance 4 | 5 | # hts 6.0.2 6 | 7 | * Removed dependency on matrixcalc 8 | 9 | # hts 6.0.1 10 | 11 | * Fixed bug in `forecast(nonnegative = TRUE)` for erroring "object not found". (#58, @apantovic) 12 | 13 | # hts 6.0.0 14 | 15 | * Added the support for non-negative forecast reconciliation. (@ShanikaLW) 16 | * Officially retired in favour of `fable`. 17 | * Depended on `forecast (>= v8.12)` due to the change in `accuracy()` signature. 18 | * Fixed bug in `forecast(weights = "wls")` for removing the squared root, as it's been done in following functions. 19 | 20 | # hts 5.1.5 21 | 22 | * Fixed hts authorship in the DESCRIPTION file 23 | * Updated reference 24 | * Replaced `rBind` with `rbind` due to Matrix new release 25 | * Depends on R (>= 3.2.0) 26 | 27 | # hts 5.1.4 28 | 29 | * The `hts` and `gts` don't actually fit into `mts`, `ts` and `matrix` classes, and hence `mts`, `ts` and `matrix` classes are dropped. 30 | * Added helper functions `get_nodes` for `hts` and `get_groups` for `gts`. 31 | * Fixed `forecast(method = "tdfp", h = 1)` issue ([#32](https://github.com/earowang/hts/issues/32)). 32 | * Fixed `forecast(FUN = hybridModel)` when `newxreg` is present ([#28](https://github.com/earowang/hts/issues/28)). 33 | 34 | # hts 5.1.0 35 | 36 | * Earo Wang took over maintenance of the package from Rob J Hyndman. 37 | * Replaced `ChangeLog` with a `NEWS.md` file to track changes to the package. 38 | * Used `roxygen2` to generate and manage reference. Thanks to Yihui's `Rd2roxygen` package for hassle-free conversion. 39 | * Enabled `pkgdown` support. 40 | * Allowed more control of colour in `plot.gts` (Thanks to @ellisp for the pull request #25). 41 | * Exported the `is.hts` and `is.gts` functions (as per [#29](https://github.com/earowang/hts/issues/29)). 42 | * Registered `accurary` as an S3 method from `forecast::accuracy`. 43 | 44 | # hts 5.0 45 | 46 | * Added mint option in forecast.gts (written by Shanika Wickramasuriya) 47 | * Allowed arbitrary ordering of bottom level time series in hts() 48 | * Added QR decomposition if LU decomposition fails 49 | * Bug fixes 50 | 51 | # hts 4.5 52 | 53 | * Fixed bugs in accuracy.gts(). 54 | * Fixed bug in forecast.gts() detecting the right default forecasting horizon. 55 | * Fixed bug in gts() for a gts with one grouping variable. 56 | * Speeded up Smatrix(). 57 | * Make SparseM package as dependency. 58 | * Better handle missing values. 59 | * Speeded up combinef() for Alan's algorithm. 60 | * Added 3 new algorithms to the optimally reconciled approach. 61 | * Fixed bug in forecast.gts() when using external regressors with parallel. 62 | * Fixed time attributes of fitted and residual series. 63 | 64 | # hts 4.4 65 | 66 | * Allowed multiple seasonal objects "msts" in hts() and gts(). 67 | * Fixed bug of MASE in accuracy.gts(). 68 | * Allowed user's defined forecasting function in forecast.gts(). 69 | 70 | # hts 4.3 71 | 72 | * Fixed bug of the arg "include" in plot.gts, when there are not yearly data. 73 | * Fixed bug in combinef(), when it handles a simple hierarchy with 2 levels. 74 | * Improved arg "characters" in hts() to automate the node structure. 75 | * Added a new arg "characters" in gts(), which will automate the grouping matrix. 76 | * Added a new reference to combinef() man. 77 | * Made 'sd' the default weight in forecast.gts(). 78 | 79 | # hts 4.2 80 | 81 | * Fixed Next.Generic error in accuracy.gts. 82 | * Adjust weights = sd. 83 | 84 | # hts 4.1 85 | 86 | * Set the default parallel processes to 2. 87 | * Fixed three dots in parallel computing for forecast.gts. 88 | * Speeded up the topdown approaches. 89 | 90 | # hts 4.0 91 | 92 | * Speeded up all existing functions. 93 | * Restructured hts function. Argument g is replaced with nodes. Added bnames and 94 | characters to allow custom names. 95 | * Added argument gnames to gts function. 96 | * Argument groups in gts function allows the gmatrix with characters. 97 | * Added function aggts in which users can specify whatever levels they like. 98 | * Renamed Smatrix to smatrix. 99 | * Added summary.gts function. 100 | * Added more arguments to forecast.gts such as keep.fitted, keep.resid, lambda, 101 | weights. 102 | * When setting method = "mo" in forecasts.gts, argument level started with 0 103 | rather than 1. 104 | * Import parallel package in order to support for parallel processing. 105 | * Added more criterions to accuracy.gts function. When keep.fitted = TRUE in 106 | forecast.gts function, accuracy.gts can also return in-sample error measures 107 | at the bottom level. 108 | * Dropped argument criterions in accuracy.gts function. 109 | * Added argument weights to combinef function. When it's a hts object, argument 110 | nodes is used instead of the summing matrix. 111 | * combinef function returns either a gts object or time series at the bottom 112 | level. Dropped arguments return and hierarchical. 113 | * Argument levels in plot.gts function allows more flexibilities. 114 | 115 | # hts 3.01 116 | 117 | * Added the infantgts data 118 | * Added the vignette 119 | 120 | # hts 3.00 121 | 122 | * Restructured gts objects and dropped hts objects. A flag indicates if gts is 123 | hierarchical. 124 | * gts objects can now contain forecasts as well as historical data. 125 | * Updated plot.gts function with an option to show historical data as well as 126 | forecasts 127 | * Added the window.gts function 128 | * Moved SparseM from Depends to Imports 129 | 130 | # hts 2.02 131 | 132 | * Bug fixes to cope with much bigger hierarchies 133 | 134 | # hts 2.01 135 | 136 | * Changed hierarchical naming convention to allow much bigger hierarchies. 137 | 138 | # hts 2.0 139 | 140 | * Added grouped time series (gts) objects, and re-wrote many functions in order 141 | to handle them. 142 | * hts objects are now a subset of gts objects. 143 | * Some old hts methods have been replaced by gts methods. 144 | * Rob J Hyndman took over maintenance of the package from Han Lin Shang 145 | -------------------------------------------------------------------------------- /R/MinTbpv.R: -------------------------------------------------------------------------------- 1 | # helper function to block principal pivoting algorithm 2 | # can only be used with MinT (sample or shrinkage) 3 | # Author: Shanika Wickramasuriya 4 | # Paper: Optimal non-negative forecast reconciliation 5 | 6 | # Arguments 7 | # fcasts: a vector of h-steps-ahead forecasts for all levels of the hierarchical time series. 8 | # smat: updated original s-matrix (based on the active set constraints) 9 | # vmat: updated covariance matrix to be used. 10 | # alg: algorithm such as "lu", "chol" or "cg" 11 | 12 | MinTm <- function(fcasts, smat, vmat, alg) 13 | { 14 | totalts <- nrow(smat) 15 | if (!is.matrix(fcasts)) { 16 | fcasts <- t(fcasts) 17 | } 18 | if (ncol(fcasts) != totalts) { 19 | stop("Argument fcasts requires all the forecasts.") 20 | } 21 | fcasts <- t(fcasts) 22 | if (alg == "chol") { 23 | allf <- CHOL(fcasts = fcasts, S = smat, weights = vmat, allow.changes = TRUE) 24 | } else if (alg == "lu") { 25 | allf <- LU(fcasts = fcasts, S = smat, weights = vmat, allow.changes = TRUE) 26 | } else { 27 | allf <- CG(fcasts = fcasts, S = smat, weights = vmat, allow.changes = TRUE) 28 | } 29 | return(allf) 30 | } 31 | 32 | # Arguments 33 | # fcasts: a vector of h-steps-ahead forecasts for all levels of the hierarchical time series. 34 | # nodes: Hierarchical structure 35 | # groups: Grouping structure 36 | # res: in-sample residuals of the base forecasts 37 | # covar: covariance matrix (sam vs shr) 38 | # alg: algorithm such as "lu", "chol" or "cg" 39 | # control.nn: A list of control parameters to be used in the non-negative algorithm. 40 | # This includes ptype (fixed or random), par, and gtol (tolerance of the convergence criteria) 41 | 42 | MinTbpv <- function(fcasts, nodes = NULL, groups = NULL, res, covar, 43 | alg, control.nn = list()) 44 | { 45 | # ptype <- match.arg(ptype) 46 | con <- list(ptype = "fixed", pbar = 10, gtol = sqrt(.Machine$double.eps)) 47 | nmsC <- names(con) 48 | con[(namc <- names(control.nn))] <- control.nn 49 | if (length(noNms <- namc[!namc %in% nmsC])) 50 | warning("unknown names in control.nn: ", paste(noNms, 51 | collapse = ", ")) 52 | 53 | if (is.null(groups)) { # hts class 54 | gmat <- GmatrixH(nodes) 55 | if (alg == "chol") { 56 | smat <- Smatrix(gmat) 57 | } else if (alg == "lu" || alg == "cg") { 58 | smat <- SmatrixM(gmat) 59 | } 60 | totalts <- nrow(smat) 61 | if (!is.matrix(fcasts)) { 62 | fcasts <- t(fcasts) 63 | } 64 | if (ncol(fcasts) != totalts) { 65 | stop("Argument fcasts requires all the forecasts.") 66 | } 67 | nb <- ncol(smat) # number of bottom level series 68 | nt <- nrow(smat) # total no of series 69 | nxb <- nt - nb # no of series, except the bottom level 70 | ifcasts <- MinT(fcasts = fcasts, nodes = nodes, groups = groups, residual = res, covariance = covar, algorithms = alg, keep = "all") 71 | b <- ifcasts[(nxb + 1):nt] # initial solution-bottom level 72 | } else if (is.null(nodes)) { # gts class 73 | rownames(groups) <- NULL 74 | gmat <- GmatrixG(groups) 75 | if (alg == "chol") { 76 | smat <- Smatrix(gmat) 77 | } else if (alg == "lu" || alg == "cg") { 78 | smat <- SmatrixM(gmat) 79 | } 80 | totalts <- nrow(smat) 81 | if (!is.matrix(fcasts)) { 82 | fcasts <- t(fcasts) 83 | } 84 | if (ncol(fcasts) != totalts) { 85 | stop("Argument fcasts requires all the forecasts.") 86 | } 87 | nb <- ncol(smat) # number of bottom level series 88 | nt <- nrow(smat) # total no of series 89 | nxb <- nt - nb # no of series, except the bottom level 90 | ifcasts <- MinT(fcasts = fcasts, nodes = nodes, groups = groups, residual = res, algorithms = alg, keep = "all") # initial solution 91 | b <- ifcasts[(nxb + 1):nt] # initial solution-bottom level 92 | } 93 | 94 | if (all(b > -con$gtol)) { 95 | bf <- t(b) 96 | return(bf) 97 | } else { 98 | b <- numeric(nb) 99 | if (covar == "sam") { 100 | w.1 <- crossprod(res) / nt 101 | if (is.posdef(w.1) == FALSE) { 102 | stop("MinT needs covariance matrix to be positive definite", call. = FALSE) 103 | } 104 | } else if (covar == "shr") { 105 | tar <- lowerD(res) 106 | shrink <- shrink.estim(res, tar) 107 | w.1 <- shrink[[1]] 108 | if (is.posdef(w.1) == FALSE) { 109 | stop("MinT needs covariance matrix to be positive definite", call. = FALSE) 110 | } 111 | } 112 | if (alg == "chol") { 113 | w.1 <- as.matrix.csr(w.1) 114 | } else if (alg == "lu" || alg == "cg") { 115 | w.1 <- methods::as(w.1, "sparseMatrix") 116 | } 117 | w <- solve(w.1) 118 | z <- t(smat) %*% w # z %*% t(z) = t(s) %*% L %*% s 119 | wy <- w %*% t(fcasts) 120 | y <- t(smat) %*% wy # t(s) %*% L %*% yhat 121 | sb <- smat %*% as.matrix(b) 122 | 123 | tol <- sqrt(.Machine$double.eps) 124 | grad <- as.matrix(z %*% sb) - y 125 | maxp <- con$pbar 126 | ninf <- nb + 1 127 | 128 | if (con$ptype == "fixed") { 129 | alpha <- 1:nb 130 | } else if (con$ptype == "random") { 131 | alpha <- sample(1:nb, nb, replace = FALSE) 132 | } 133 | 134 | fset <- numeric(0) 135 | gset <- 1:nb 136 | 137 | bf <- b[fset] 138 | gradg <- grad[gset] 139 | 140 | # To avoid nondegenerate problem (as done by Jason Cantarella) 141 | idxf <- abs(bf) < tol 142 | idxg <- abs(gradg) < tol 143 | bf[idxf] <- 0L 144 | gradg[idxg] <- 0L 145 | 146 | # convergence criteria 147 | converged <- all(bf > -con$gtol) & all(gradg > -con$gtol) 148 | 149 | while (!converged) { 150 | i1 <- fset[which(bf < -tol)] 151 | i2 <- gset[which(gradg < -tol)] 152 | ivec <- union(i1, i2) 153 | 154 | if (length(ivec) < ninf) { 155 | ninf <- length(ivec) 156 | maxp <- con$pbar 157 | } else if (maxp >= 1) { 158 | maxp <- maxp - 1 159 | } else { 160 | if (con$ptype == "fixed") { 161 | cat("You are entering a slow zone! It might take some time to converge! \n") 162 | r <- max(ivec) 163 | } else if (con$ptype == "random") { 164 | cat("You are entering a slow zone! It might take some time to converge! \n") 165 | r <- alpha[max(which(alpha %in% ivec))] 166 | } 167 | if (is.element(r, i1)) { 168 | i1 <- r 169 | i2 <- numeric(0) 170 | } else { 171 | i1 <- numeric(0) 172 | i2 <- r 173 | } 174 | } 175 | 176 | # updating f and g 177 | fset <- union(fset[!fset %in% i1], i2) 178 | gset <- union(gset[!gset %in% i2], i1) 179 | 180 | if (length(gset) == 0) { 181 | tmp <- MinTm(fcasts = fcasts, smat = smat, vmat = w.1, alg = alg) 182 | allf <- as.numeric(tmp) 183 | } else { 184 | usmat <- smat[, -gset] 185 | tmp <- MinTm(fcasts = fcasts, smat = usmat, vmat = w.1, alg = alg) 186 | allf <- as.numeric(tmp) 187 | } 188 | 189 | b <- tail(allf, nb) 190 | sb <- smat %*% as.matrix(b) 191 | grad <- as.matrix(z %*% sb) - y 192 | bf <- b[fset] 193 | gradg <- grad[gset] 194 | 195 | # To avoid nondegenerate problem (as done by Jason Cantarella) 196 | idxf <- abs(bf) < tol 197 | idxg <- abs(gradg) < tol 198 | bf[idxf] <- 0L 199 | gradg[idxg] <- 0L 200 | converged <- all(bf > -con$gtol) & all(gradg > -con$gtol) 201 | } 202 | 203 | bf <- t(b) 204 | } 205 | return(bf) 206 | } 207 | 208 | -------------------------------------------------------------------------------- /man/forecast.gts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/forecast-gts.R 3 | \name{forecast.gts} 4 | \alias{forecast.gts} 5 | \alias{forecast.hts} 6 | \title{Forecast a hierarchical or grouped time series} 7 | \usage{ 8 | \method{forecast}{gts}( 9 | object, 10 | h = ifelse(frequency(object$bts) > 1L, 2L * frequency(object$bts), 10L), 11 | method = c("comb", "bu", "mo", "tdgsa", "tdgsf", "tdfp"), 12 | weights = c("wls", "ols", "mint", "nseries"), 13 | fmethod = c("ets", "arima", "rw"), 14 | algorithms = c("lu", "cg", "chol", "recursive", "slm"), 15 | covariance = c("shr", "sam"), 16 | nonnegative = FALSE, 17 | control.nn = list(), 18 | keep.fitted = FALSE, 19 | keep.resid = FALSE, 20 | positive = FALSE, 21 | lambda = NULL, 22 | level, 23 | FUN = NULL, 24 | xreg = NULL, 25 | newxreg = NULL, 26 | parallel = FALSE, 27 | num.cores = 2, 28 | ... 29 | ) 30 | } 31 | \arguments{ 32 | \item{object}{Hierarchical or grouped time series object of class 33 | \code{{gts}}} 34 | 35 | \item{h}{Forecast horizon} 36 | 37 | \item{method}{Method for distributing forecasts within the hierarchy. See 38 | details} 39 | 40 | \item{weights}{Weights used for "optimal combination" method: 41 | \code{weights="ols"} uses an unweighted combination (as described in Hyndman 42 | et al 2011); \code{weights="wls"} uses weights based on forecast variances 43 | (as described in Hyndman et al 2016); \code{weights="mint"} uses a full 44 | covariance estimate to determine the weights (as described in Wickramasuriya et al 45 | 2019); \code{weights="nseries"} uses weights based on the number of series 46 | aggregated at each node.} 47 | 48 | \item{fmethod}{Forecasting method to use for each series.} 49 | 50 | \item{algorithms}{An algorithm to be used for computing the combination 51 | forecasts (when \code{method=="comb"}). The combination forecasts are based 52 | on an ill-conditioned regression model. "lu" indicates LU decomposition is 53 | used; "cg" indicates a conjugate gradient method; "chol" corresponds to a 54 | Cholesky decomposition; "recursive" indicates the recursive hierarchical 55 | algorithm of Hyndman et al (2016); "slm" uses sparse linear regression. Note 56 | that \code{algorithms = "recursive"} and \code{algorithms = "slm"} cannot be 57 | used if \code{weights="mint"}.} 58 | 59 | \item{covariance}{Type of the covariance matrix to be used with 60 | \code{weights="mint"}: either a shrinkage estimator (\code{"shr"}) with 61 | shrinkage towards the diagonal; or a sample covariance matrix 62 | (\code{"sam"}).} 63 | 64 | \item{nonnegative}{Logical. Should the reconciled forecasts be non-negative?} 65 | 66 | \item{control.nn}{A list of control parameters to be passed on to the 67 | block principal pivoting algorithm. See 'Details'.} 68 | 69 | \item{keep.fitted}{If \code{TRUE}, keep fitted values at the bottom level.} 70 | 71 | \item{keep.resid}{If \code{TRUE}, keep residuals at the bottom level.} 72 | 73 | \item{positive}{If \code{TRUE}, forecasts are forced to be strictly positive (by 74 | setting \code{lambda=0}).} 75 | 76 | \item{lambda}{Box-Cox transformation parameter.} 77 | 78 | \item{level}{Level used for "middle-out" method (only used when \code{method 79 | = "mo"}).} 80 | 81 | \item{FUN}{A user-defined function that returns an object which can be 82 | passed to the \code{forecast} function. It is applied to all series in order 83 | to generate base forecasts. When \code{FUN} is not \code{NULL}, 84 | \code{fmethod}, \code{positive} and \code{lambda} are all ignored. Suitable 85 | values for \code{FUN} are \code{\link[forecast]{tbats}} and 86 | \code{\link[forecast]{stlf}} for example.} 87 | 88 | \item{xreg}{When \code{fmethod = "arima"}, a vector or matrix of external 89 | regressors used for modelling, which must have the same number of rows as 90 | the original univariate time series} 91 | 92 | \item{newxreg}{When \code{fmethod = "arima"}, a vector or matrix of external 93 | regressors used for forecasting, which must have the same number of rows as 94 | the \code{h} forecast horizon} 95 | 96 | \item{parallel}{If \code{TRUE}, import \code{parallel} package to allow parallel 97 | processing.} 98 | 99 | \item{num.cores}{If \code{parallel = TRUE}, specify how many cores are going to be 100 | used.} 101 | 102 | \item{...}{Other arguments passed to \code{\link[forecast]{ets}}, 103 | \code{\link[forecast]{auto.arima}} or \code{FUN}.} 104 | } 105 | \value{ 106 | A forecasted hierarchical/grouped time series of class \code{gts}. 107 | } 108 | \description{ 109 | Methods for forecasting hierarchical or grouped time series. 110 | } 111 | \details{ 112 | Base methods implemented include ETS, ARIMA and the naive (random walk) 113 | models. Forecasts are distributed in the hierarchy using bottom-up, 114 | top-down, middle-out and optimal combination methods. 115 | 116 | Three top-down methods are available: the two Gross-Sohl methods and the 117 | forecast-proportion approach of Hyndman, Ahmed, and Athanasopoulos (2011). 118 | The "middle-out" method \code{"mo"} uses bottom-up (\code{"bu"}) for levels 119 | higher than \code{level} and top-down forecast proportions (\code{"tdfp"}) 120 | for levels lower than \code{level}. 121 | 122 | For non-hierarchical grouped data, only bottom-up and combination methods 123 | are possible, as any method involving top-down disaggregation requires a 124 | hierarchical ordering of groups. 125 | 126 | When \code{xreg} and \code{newxreg} are passed, the same covariates are 127 | applied to every series in the hierarchy. 128 | 129 | The \code{control.nn} argument is a list that can supply any of the following components: 130 | \describe{ 131 | \item{\code{ptype}}{Permutation method to be used: \code{"fixed"} or \code{"random"}. Defaults to \code{"fixed"}.} 132 | \item{\code{par}}{The number of full exchange rules that may be tried. Defaults to 10.} 133 | \item{\code{gtol}}{The tolerance of the convergence criteria. Defaults to \code{sqrt(.Machine$double.eps)}.} 134 | } 135 | } 136 | \note{ 137 | In-sample fitted values and resiuals are not returned if \code{method = "comb"} and \code{nonnegative = TRUE}. 138 | } 139 | \examples{ 140 | 141 | forecast(htseg1, h = 10, method = "bu", fmethod = "arima") 142 | 143 | \dontrun{ 144 | forecast( 145 | htseg2, h = 10, method = "comb", algorithms = "lu", 146 | FUN = function(x) tbats(x, use.parallel = FALSE) 147 | ) 148 | } 149 | 150 | } 151 | \references{ 152 | Athanasopoulos, G., Ahmed, R. A., & Hyndman, R. J. (2009). 153 | Hierarchical forecasts for Australian domestic tourism, \emph{International 154 | Journal of Forecasting}, \bold{25}, 146-166. 155 | 156 | Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. (2011). Optimal 157 | combination forecasts for hierarchical time series. \emph{Computational 158 | Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 159 | \url{https://robjhyndman.com/publications/hierarchical/} 160 | 161 | Hyndman, R. J., Lee, A., & Wang, E. (2016). Fast computation of reconciled 162 | forecasts for hierarchical and grouped time series. \emph{Computational 163 | Statistics and Data Analysis}, \bold{97}, 16--32. 164 | \url{https://robjhyndman.com/publications/hgts/} 165 | 166 | Wickramasuriya, S. L., Athanasopoulos, G., & Hyndman, R. J. (2019). 167 | Optimal forecast reconciliation for hierarchical and grouped time series through trace minimization. 168 | \emph{Journal of the American Statistical Association}, \bold{114}(526), 804--819. \url{https://robjhyndman.com/publications/mint/} 169 | 170 | Wickramasuriya, S. L., Turlach, B. A., & Hyndman, R. J. (to appear). Optimal non-negative forecast reconciliation. 171 | \emph{Statistics and Computing}. \url{https://robjhyndman.com/publications/nnmint/} 172 | 173 | Gross, C., & Sohl, J. (1990). Dissagregation methods to expedite product 174 | line forecasting, \emph{Journal of Forecasting}, \bold{9}, 233--254. 175 | } 176 | \seealso{ 177 | \code{\link[hts]{hts}}, \code{\link[hts]{gts}}, 178 | \code{\link[hts]{plot.gts}}, \code{\link[hts]{accuracy.gts}} 179 | } 180 | \author{ 181 | Earo Wang, Rob J Hyndman and Shanika L Wickramasuriya 182 | } 183 | \keyword{ts} 184 | -------------------------------------------------------------------------------- /R/recursive.R: -------------------------------------------------------------------------------- 1 | # Combination approach 2 | # Author: Alan Lee; largely improved by Earo Wang 3 | 4 | UpdateC <- function(c.list) { 5 | k <- length(c.list) 6 | div <- 1L 7 | nvec <- numeric(k) 8 | comb.vec <- NULL 9 | for (i in 1:k) { 10 | m <- c.list[[i]][[2L]] 11 | cc <- c.list[[i]][[1L]] 12 | nvec[i] <- dim(cc)[1L] 13 | div <- div - sum(m * (cc %*% m)) 14 | comb.vec <- c(comb.vec, m) 15 | } 16 | d <- sum(comb.vec) 17 | div <- div + d 18 | sum.nvec <- sum(nvec) 19 | c.star <- matrix(, sum.nvec, sum.nvec) 20 | hi <- cumsum(nvec) 21 | lo <- cumsum(c(1L, nvec[-length(nvec)])) 22 | for (i in 1:k) { 23 | cm1 <- as.vector(c.list[[i]][[1L]] %*% c.list[[i]][[2L]]) 24 | row.range <- lo[i]:hi[i] 25 | for (j in 1:k) { 26 | cm2 <- as.vector(c.list[[j]][[1L]] %*% c.list[[j]][[2]]) 27 | cinsert <- outer(1 - cm1, 1 - cm2)/div 28 | if (i == j) { 29 | cinsert <- c.list[[i]][[1L]] + cinsert 30 | } 31 | col.range <- lo[j]:hi[j] 32 | c.star[row.range, col.range] <- cinsert 33 | } 34 | } 35 | return(list(C = c.star, nvec = comb.vec)) 36 | } 37 | 38 | CombineH <- function(fcasts, nodes) { 39 | class(fcasts) <- "matrix" # drop "ts" object to process faster 40 | # Split fcasts to a list 41 | levels <- cumsum(Mnodes(nodes)) 42 | l.levels <- length(levels) 43 | flist <- lapply(2L:l.levels, function(x) { 44 | fcasts[, seq(levels[x - 1L] + 1L, levels[x]), drop = FALSE] 45 | }) 46 | flist <- c(list(fcasts[, 1L, drop = FALSE]), flist) 47 | rm(fcasts) 48 | 49 | # Start with the last level 50 | lenl <- length(levels) 51 | lenn <- length(nodes) 52 | last.nodes <- nodes[[lenn]] 53 | last.len <- length(last.nodes) 54 | cmat <- lapply(1:last.len, function(x) 55 | list(matrix(1/(last.nodes[x] + 1)), last.nodes[x])) 56 | idx <- c(0, cumsum(last.nodes)) 57 | smat <- lapply(1L:last.len, function(x) 58 | flist[[lenl]][, (idx[x] + 1L):idx[x + 1L], drop = FALSE] 59 | + flist[[lenl - 1L]][, x]) 60 | 61 | if (lenn == 1L) { # A simple hierarchy with only 2 levels 62 | cmat <- UpdateC(cmat[1L])$C 63 | smat <- apply(smat[[1L]], 2, function(x) x + flist[[1L]]) 64 | sums <- rowsum(t(smat), rep(1L:last.len, last.nodes)) 65 | comb <- smat - rep(cmat %*% sums, last.nodes) 66 | } else { # more than 2 levels 67 | # Recursively update C matrix from L - 1 to 1 68 | for (i in 1L:(lenn - 1L)) { 69 | newn <- nodes[[lenn - i]] 70 | newl <- length(newn) 71 | new.cmat <- vector(length = newl, mode = "list") 72 | new.smat <- vector(length = newl, mode = "list") 73 | idx <- c(0L, cumsum(newn)) 74 | for (j in 1L:newl) { 75 | new.cmat[[j]] <- UpdateC(cmat[(idx[j] + 1L):idx[j + 1L]]) 76 | sblock <- smat[(idx[j] + 1L):idx[j + 1L]] 77 | sblock <- do.call("cbind", sblock) 78 | new.smat[[j]] <- flist[[lenl - i - 1L]][, j] + sblock 79 | } 80 | cmat <- new.cmat 81 | smat <- new.smat 82 | } 83 | cmat <- cmat[[1L]]$C 84 | comb <- t(apply(smat[[1L]], 1, function(x) { 85 | sums <- rowsum(x, rep(1L:last.len, last.nodes)) 86 | return(x - rep(cmat %*% sums, last.nodes)) 87 | })) 88 | } 89 | 90 | colnames(comb) <- NULL 91 | return(comb) 92 | } 93 | 94 | 95 | # Combination with weights 96 | UpdateCw <- function(c.list, d1.vec, d0) { 97 | l.c <- length(c.list) 98 | comb.vec <- NULL 99 | nvec <- numeric(l.c) 100 | div <- d0 101 | for (i in 1L:l.c) { 102 | m <- c.list[[i]][[2L]] 103 | cmat <- c.list[[i]][[1L]] 104 | d <- d1.vec[m] 105 | nvec[i] <- length(m) 106 | div <- div + sum(d) - sum(d * (cmat %*% d)) 107 | comb.vec <- c(comb.vec, m) 108 | } 109 | 110 | len.comb <- length(comb.vec) 111 | c.star <- matrix(, nrow = len.comb, ncol = len.comb) 112 | hi <- cumsum(nvec) 113 | lo <- cumsum(c(1L, nvec[-length(nvec)])) 114 | 115 | for (i in 1L:l.c) { 116 | di <- d1.vec[c.list[[i]][[2L]]] 117 | cd1 <- as.vector(c.list[[i]][[1L]] %*% di) 118 | row.range <- lo[i]:hi[i] 119 | for (j in 1L:l.c) { 120 | col.range <- lo[j]:hi[j] 121 | dj <- d1.vec[c.list[[j]][[2L]]] 122 | cd2 <- as.vector(c.list[[j]][[1L]] %*% dj) 123 | cinsert <- outer(1L - cd1, 1L - cd2)/div 124 | if (i == j) { 125 | cinsert <- c.list[[i]][[1L]] + cinsert 126 | } 127 | c.star[row.range, col.range] <- cinsert 128 | } 129 | } 130 | return(list(cmat = c.star, m = comb.vec)) 131 | } 132 | 133 | CombineHw <- function(fcasts, nodes, weights) { 134 | class(fcasts) <- "matrix" # drop "ts" object to process faster 135 | h <- nrow(fcasts) 136 | # Split fcasts to a list 137 | levels <- cumsum(Mnodes(nodes)) 138 | l.levels <- length(levels) 139 | flist <- lapply(2L:l.levels, function(x) { 140 | fcasts[, seq(levels[x - 1L] + 1L, levels[x]), drop = FALSE] 141 | }) 142 | flist <- c(list(fcasts[, 1L, drop = FALSE]), flist) 143 | rm(fcasts) 144 | # Split weights to a list 145 | wlist <- lapply(2L:l.levels, function(x) { 146 | weights[seq(levels[x - 1L] + 1L, levels[x])] 147 | }) 148 | wlist <- c(list(weights[1L]), wlist) 149 | 150 | # Start with the last level 151 | lenl <- length(levels) 152 | lenn <- length(nodes) 153 | last.nodes <- nodes[[lenn]] 154 | last.len <- length(last.nodes) 155 | lastg <- rep(1L:last.len, last.nodes) 156 | dlist <- split(1/wlist[[l.levels]], lastg) 157 | d1vec <- sapply(dlist, sum) 158 | d0 <- 1/wlist[[l.levels - 1L]] 159 | cmat <- lapply(1:last.len, function(x) 160 | list(matrix(1L/(d0[x] + sum(dlist[[x]]))), x)) 161 | idx <- c(0, cumsum(last.nodes)) 162 | smat <- lapply(1L:last.len, function(x) { 163 | yy <- sweep(flist[[lenl]][, (idx[x] + 1L):idx[x + 1L], 164 | drop = FALSE], 2, 165 | wlist[[lenl]][(idx[x] + 1L):idx[x + 1L]], "*") 166 | tmp.yy <- sweep(flist[[lenl - 1L]][, x, drop = FALSE], 2, 167 | wlist[[lenl - 1L]][x], "*") 168 | return(apply(yy, 2, function(x) x + tmp.yy)) 169 | }) 170 | 171 | if (lenn == 1L) { # A simple hierarchy with only 2 levels 172 | cmat <- UpdateCw(cmat[1L], d1vec, d0)$cmat 173 | dvec <- unlist(dlist) 174 | smat <- apply(smat[[1L]], 2, function(x) x + flist[[1L]] * wlist[[1L]]) 175 | sums <- rowsum(t(smat), rep(1L:last.len, last.nodes)) 176 | comb <- (smat - rep(cmat %*% sums, last.nodes)) * dvec 177 | } else { # more than 2 levels 178 | # Recursively update C matrix from L - 1 to 1 179 | for (i in 1L:(lenn - 1L)) { 180 | d0 <- 1/wlist[[lenl - i - 1L]] 181 | newn <- nodes[[lenn - i]] 182 | newl <- length(newn) 183 | new.cmat <- vector(length = newl, mode = "list") 184 | new.smat <- vector(length = newl, mode = "list") 185 | idx <- c(0L, cumsum(newn)) 186 | for (j in 1L:newl) { 187 | new.cmat[[j]] <- UpdateCw(cmat[(idx[j] + 1L):idx[j + 1L]], d1vec, 188 | d0[j]) 189 | tmpw <- wlist[[lenl - i - 1L]][j] 190 | tmps <- sweep(flist[[lenl - i - 1L]][, j, drop = FALSE], 2, 191 | tmpw, "*") 192 | sblock <- smat[(idx[j] + 1L):idx[j + 1L]] 193 | if (h == 1) { 194 | sblock <- unlist(sblock) 195 | new.smat[[j]] <- sblock + tmps 196 | } else { 197 | sblock <- do.call("cbind", sblock) 198 | new.smat[[j]] <- apply(sblock, 2, function(x) x + tmps) 199 | } 200 | } 201 | cmat <- new.cmat 202 | smat <- new.smat 203 | } 204 | cmat <- cmat[[1L]]$cmat 205 | dvec <- unlist(dlist) 206 | if (h == 1) { 207 | sums <- rowsum(smat[[1L]] * dvec, rep(1L:last.len, last.nodes)) 208 | comb <- (smat[[1L]] - rep(cmat %*% sums, last.nodes)) * dvec 209 | } else { 210 | comb <- t(apply(smat[[1L]], 1, function(x) { 211 | sums <- rowsum(x * dvec, rep(1L:last.len, last.nodes)) 212 | return((x - rep(cmat %*% sums, last.nodes)) * dvec) 213 | })) 214 | } 215 | } 216 | 217 | colnames(comb) <- NULL 218 | return(comb) 219 | } 220 | 221 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # hts 5 | 6 | [![R build 7 | status](https://github.com/earowang/hts/workflows/R-CMD-check/badge.svg)](https://github.com/earowang/hts/actions?workflow=R-CMD-check) 8 | [![CRAN\_Status\_Badge](http://www.r-pkg.org/badges/version/hts)](https://cran.r-project.org/package=hts) 9 | [![Downloads](http://cranlogs.r-pkg.org/badges/hts)](https://cran.r-project.org/package=hts) 10 | [![Lifecycle: 11 | retired](https://img.shields.io/badge/lifecycle-retired-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html) 12 | 13 | **hts** is retired, with minimum maintenance to keep it on CRAN. We 14 | recommend using the [fable](http://fable.tidyverts.org) package instead. 15 | 16 | The R package *hts* presents functions to create, plot and forecast 17 | hierarchical and grouped time series. 18 | 19 | ## Installation 20 | 21 | You can install the **stable** version on [R 22 | CRAN](https://cran.r-project.org/package=hts). 23 | 24 | ``` r 25 | install.packages('hts', dependencies = TRUE) 26 | ``` 27 | 28 | You can also install the **development** version from 29 | [Github](https://github.com/earowang/hts) 30 | 31 | ``` r 32 | # install.packages("devtools") 33 | devtools::install_github("earowang/hts") 34 | ``` 35 | 36 | ## Usage 37 | 38 | ### Example 1: hierarchical time series 39 | 40 | ``` r 41 | library(hts) 42 | #> Loading required package: forecast 43 | #> Registered S3 method overwritten by 'quantmod': 44 | #> method from 45 | #> as.zoo.data.frame zoo 46 | 47 | # hts example 1 48 | print(htseg1) 49 | #> Hierarchical Time Series 50 | #> 3 Levels 51 | #> Number of nodes at each level: 1 2 5 52 | #> Total number of series: 8 53 | #> Number of observations per series: 10 54 | #> Top level series: 55 | #> Time Series: 56 | #> Start = 1992 57 | #> End = 2001 58 | #> Frequency = 1 59 | #> [1] 48.74808 49.48047 49.93238 50.24070 50.60846 50.84851 51.70922 51.94330 60 | #> [9] 52.57796 53.21496 61 | summary(htseg1) 62 | #> Hierarchical Time Series 63 | #> 3 Levels 64 | #> Number of nodes at each level: 1 2 5 65 | #> Total number of series: 8 66 | #> Number of observations per series: 10 67 | #> Top level series: 68 | #> Time Series: 69 | #> Start = 1992 70 | #> End = 2001 71 | #> Frequency = 1 72 | #> [1] 48.74808 49.48047 49.93238 50.24070 50.60846 50.84851 51.70922 51.94330 73 | #> [9] 52.57796 53.21496 74 | #> 75 | #> Labels: 76 | #> [1] "Level 0" "Level 1" "Level 2" 77 | aggts1 <- aggts(htseg1) 78 | aggts2 <- aggts(htseg1, levels = 1) 79 | aggts3 <- aggts(htseg1, levels = c(0, 2)) 80 | plot(htseg1, levels = 1) 81 | ``` 82 | 83 | ![](man/figures/hts-eg1-1.png) 84 | 85 | ``` r 86 | smatrix(htseg1) # Return the dense mode 87 | #> [,1] [,2] [,3] [,4] [,5] 88 | #> [1,] 1 1 1 1 1 89 | #> [2,] 1 1 1 0 0 90 | #> [3,] 0 0 0 1 1 91 | #> [4,] 1 0 0 0 0 92 | #> [5,] 0 1 0 0 0 93 | #> [6,] 0 0 1 0 0 94 | #> [7,] 0 0 0 1 0 95 | #> [8,] 0 0 0 0 1 96 | 97 | # Forecasts 98 | fcasts1.bu <- forecast( 99 | htseg1, h = 4, method = "bu", fmethod = "ets", parallel = TRUE 100 | ) 101 | aggts4 <- aggts(fcasts1.bu) 102 | summary(fcasts1.bu) 103 | #> Hierarchical Time Series 104 | #> 3 Levels 105 | #> Number of nodes at each level: 1 2 5 106 | #> Total number of series: 8 107 | #> Number of observations in each historical series: 10 108 | #> Number of forecasts per series: 4 109 | #> Top level series of forecasts: 110 | #> Time Series: 111 | #> Start = 2002 112 | #> End = 2005 113 | #> Frequency = 1 114 | #> [1] 53.2149 53.2149 53.2149 53.2149 115 | #> 116 | #> Method: Bottom-up forecasts 117 | #> Forecast method: ETS 118 | fcasts1.td <- forecast( 119 | htseg1, h = 4, method = "tdfp", fmethod = "arima", keep.fitted = TRUE 120 | ) 121 | summary(fcasts1.td) # When keep.fitted = TRUE, return in-sample accuracy 122 | #> Hierarchical Time Series 123 | #> 3 Levels 124 | #> Number of nodes at each level: 1 2 5 125 | #> Total number of series: 8 126 | #> Number of observations in each historical series: 10 127 | #> Number of forecasts per series: 4 128 | #> Top level series of forecasts: 129 | #> Time Series: 130 | #> Start = 2002 131 | #> End = 2005 132 | #> Frequency = 1 133 | #> [1] 53.71128 54.20760 54.70392 55.20024 134 | #> 135 | #> Method: Top-down forecasts using forecasts proportions 136 | #> Forecast method: Arima 137 | #> In-sample error measures at the bottom level: 138 | #> AA AB AC BA BB 139 | #> ME 0.0007719336 0.0009183738 0.001003812 0.001043247 0.001087807 140 | #> RMSE 0.1298400018 0.0515879830 0.040306867 0.037462277 0.105015065 141 | #> MAE 0.0978321731 0.0436089571 0.033210387 0.027003846 0.081906948 142 | #> MAPE 1.1275970221 0.4534439625 0.323535559 0.251066115 0.691364891 143 | #> MPE 0.0367879336 0.0069220593 0.006785872 0.007787895 -0.011087494 144 | #> MASE 0.6825678136 0.5197483057 0.774250880 0.447950006 0.493684443 145 | fcasts1.comb <- forecast( 146 | htseg1, h = 4, method = "comb", fmethod = "ets", keep.fitted = TRUE 147 | ) 148 | aggts4 <- aggts(fcasts1.comb) 149 | plot(fcasts1.comb, levels = 2) 150 | ``` 151 | 152 | ![](man/figures/hts-eg1-2.png) 153 | 154 | ``` r 155 | plot(fcasts1.comb, include = 5, levels = c(1, 2)) 156 | ``` 157 | 158 | ![](man/figures/hts-eg1-3.png) 159 | 160 | ### Example 2: hierarchical time series 161 | 162 | ``` r 163 | # hts example 2 164 | data <- window(htseg2, start = 1992, end = 2002) 165 | test <- window(htseg2, start = 2003) 166 | fcasts2.mo <- forecast( 167 | data, h = 5, method = "mo", fmethod = "ets", level = 1, 168 | keep.fitted = TRUE, keep.resid = TRUE 169 | ) 170 | accuracy.gts(fcasts2.mo, test) 171 | #> Total A B A10 A20 B30 172 | #> ME -0.1463168 -0.2229191 0.07660233 -0.2283919 0.005472780 -0.01989880 173 | #> RMSE 0.1500119 0.2452066 0.14257606 0.2523329 0.009805797 0.02928379 174 | #> MAE 0.1463168 0.2229191 0.11693106 0.2283919 0.009268225 0.02409282 175 | #> MAPE 9.3179712 7.5314777 2.36244104 8.7993966 2.460560011 1.71428541 176 | #> MPE -9.3179712 7.5314777 1.45433283 8.7993966 -1.631079601 -1.39920296 177 | #> MASE 0.4617075 1.2506962 0.84324674 1.5148807 0.337389275 0.52860991 178 | #> B40 A10A A10B A10C A20A A20B 179 | #> ME 0.09650113 -0.05448806 -0.1733829 -0.0005209908 0.007965591 -0.002492811 180 | #> RMSE 0.17060895 0.06809235 0.1867174 0.0100661166 0.012682474 0.008654148 181 | #> MAE 0.14102388 0.05448806 0.1733829 0.0088897199 0.010413971 0.007052515 182 | #> MAPE 3.98260313 4.37476593 21.6158413 1.5612291069 3.334410408 13.402921842 183 | #> MPE 2.54768302 4.37476593 21.6158413 0.0605205225 -2.607467068 -2.981389244 184 | #> MASE 1.51492018 0.51577051 5.3650162 0.6942763126 0.820393749 0.477277465 185 | #> B30A B30B B30C B40A B40B 186 | #> ME 0.01212900 -0.01099794 -0.02102986 -0.04273559 0.1392367 187 | #> RMSE 0.01311771 0.01422607 0.02442915 0.06656885 0.2344656 188 | #> MAE 0.01212900 0.01099794 0.02102986 0.04273559 0.1811449 189 | #> MAPE 4.13200908 2.39939647 3.26532975 3.09570196 8.2253477 190 | #> MPE 4.13200908 -2.39939647 -3.26532975 -3.09570196 5.9207223 191 | #> MASE 0.49670326 1.22312029 1.72843722 0.82335272 4.3982548 192 | accuracy.gts(fcasts2.mo, test, levels = 1) 193 | #> A B 194 | #> ME -0.2229191 0.07660233 195 | #> RMSE 0.2452066 0.14257606 196 | #> MAE 0.2229191 0.11693106 197 | #> MAPE 7.5314777 2.36244104 198 | #> MPE 7.5314777 1.45433283 199 | #> MASE 1.2506962 0.84324674 200 | fcasts2.td <- forecast( 201 | data, h = 5, method = "tdgsa", fmethod = "ets", 202 | keep.fitted = TRUE, keep.resid = TRUE 203 | ) 204 | plot(fcasts2.td, include = 5) 205 | ``` 206 | 207 | ![](man/figures/hts-eg2-1.png) 208 | 209 | ``` r 210 | plot(fcasts2.td, include = 5, levels = c(0, 2)) 211 | ``` 212 | 213 | ![](man/figures/hts-eg2-2.png) 214 | 215 | ### Example 3: grouped time series 216 | 217 | ``` r 218 | # gts example 219 | plot(infantgts, levels = 1) 220 | ``` 221 | 222 | ![](man/figures/gts-eg-1.png) 223 | 224 | ``` r 225 | fcasts3.comb <- forecast(infantgts, h = 4, method = "comb", fmethod = "ets") 226 | agg_gts1 <- aggts(fcasts3.comb, levels = 1) 227 | agg_gts2 <- aggts(fcasts3.comb, levels = 1, forecasts = FALSE) 228 | plot(fcasts3.comb) 229 | ``` 230 | 231 | ![](man/figures/gts-eg-2.png) 232 | 233 | ``` r 234 | plot(fcasts3.comb, include = 5, levels = c(1, 2)) 235 | ``` 236 | 237 | ![](man/figures/gts-eg-3.png) 238 | 239 | ``` r 240 | fcasts3.combsd <- forecast( 241 | infantgts, h = 4, method = "comb", fmethod = "ets", 242 | weights = "sd", keep.fitted = TRUE 243 | ) 244 | 245 | fcasts3.combn <- forecast( 246 | infantgts, h = 4, method = "comb", fmethod = "ets", 247 | weights = "nseries", keep.resid = TRUE 248 | ) 249 | ``` 250 | 251 | ## License 252 | 253 | This package is free and open source software, licensed under GPL (>= 254 | 2). 255 | -------------------------------------------------------------------------------- /R/bpv.R: -------------------------------------------------------------------------------- 1 | # block principal pivoting algorithm 2 | # can only be used with OLS, WLS (any positive weights) 3 | # Author: Shanika Wickramasuriya 4 | # Paper: Optimal non-negative forecast reconciliation 5 | 6 | # Arguments 7 | # fcasts: a vector of h-steps-ahead forecasts for all levels of the hierarchical time series. 8 | # nodes: Hierarchical structure 9 | # groups: Grouping structure 10 | # weights: weights to be used in OLS or WLS 11 | # control.nn: A list of control parameters to be used in the non-negative algorithm. 12 | # This includes ptype (fixed or random), par, and gtol (tolerance of the convergence criteria) 13 | 14 | bpv <- function(fcasts, nodes = NULL, groups = NULL, weights = NULL, alg, control.nn = list()) 15 | { 16 | con <- list(ptype = "fixed", pbar = 10, gtol = sqrt(.Machine$double.eps)) 17 | nmsC <- names(con) 18 | con[(namc <- names(control.nn))] <- control.nn 19 | if (length(noNms <- namc[!namc %in% nmsC])) 20 | warning("unknown names in control.nn: ", paste(noNms, 21 | collapse = ", ")) 22 | 23 | if (is.null(groups)) { # hts class 24 | gmat <- GmatrixH(nodes) 25 | if (alg == "chol") { 26 | smat <- Smatrix(gmat) 27 | } else if (alg == "lu" || alg == "cg") { 28 | smat <- SmatrixM(gmat) 29 | } 30 | totalts <- nrow(smat) 31 | if (!is.matrix(fcasts)) { 32 | fcasts <- t(fcasts) 33 | } 34 | if (ncol(fcasts) != totalts) { 35 | stop("Argument fcasts requires all the forecasts.") 36 | } 37 | nb <- ncol(smat) # number of bottom level series 38 | nt <- nrow(smat) # total no of series 39 | nxb <- nt - nb # no of series, except the bottom level 40 | ifcasts <- combinef(fcasts = fcasts, nodes = nodes, weights = weights, algorithms = alg, keep = "all") 41 | b <- ifcasts[(nxb + 1):nt] # initial solution-bottom level 42 | } else if (is.null(nodes)) { # gts class 43 | rownames(groups) <- NULL 44 | gmat <- GmatrixG(groups) 45 | if (alg == "chol") { 46 | smat <- Smatrix(gmat) 47 | } else if (alg == "lu" || alg == "cg") { 48 | smat <- SmatrixM(gmat) 49 | } 50 | totalts <- nrow(smat) 51 | if (!is.matrix(fcasts)) { 52 | fcasts <- t(fcasts) 53 | } 54 | if (ncol(fcasts) != totalts) { 55 | stop("Argument fcasts requires all the forecasts.") 56 | } 57 | nb <- ncol(smat) # number of bottom level series 58 | nt <- nrow(smat) # total no of series 59 | nxb <- nt - nb # no of series, except the bottom level 60 | ifcasts <- combinef(fcasts = fcasts, groups = groups, weights = weights, algorithms = alg, keep = "all") # initial solution 61 | b <- ifcasts[(nxb + 1):nt] # initial solution-bottom level 62 | } 63 | 64 | if (alg == "chol") { 65 | if (!is.null(weights)) { 66 | sqwt <- sqrt(weights) 67 | w <- methods::as(1/sqwt, "matrix.diag.csr") # w^2 = L 68 | z <- t(smat) %*% w # Sparse. z %*% t(z) = t(s) %*% L %*% s 69 | wy <- sqwt * t(fcasts) 70 | y <- z %*% wy # t(s) %*% L %*% yhat 71 | } else { 72 | z <- t(smat) # Sparse. z %*% t(z) = t(s) %*% s 73 | y <- z %*% t(fcasts) # t(s) %*% yhat 74 | } 75 | } else if (alg == "lu" || alg == "cg") { 76 | if (!is.null(weights)) 77 | { 78 | sqwt <- sqrt(weights) 79 | seqts <- seq(nrow(smat)) 80 | w <- sparseMatrix(i = seqts, j = seqts, x = sqwt) #w^2 = L 81 | z <- t(smat) %*% w # Sparse. z %*% t(z) = t(s) %*% L %*% s 82 | wy <- sqwt * t(fcasts) 83 | y <- z %*% wy # t(s) %*% L %*% yhat 84 | } else { 85 | z <- t(smat) # Sparse. z %*% t(z) = t(s) %*% s 86 | y <- z %*% t(fcasts) # t(s) %*% yhat 87 | } 88 | } 89 | 90 | tol <- sqrt(.Machine$double.eps) 91 | tzb <- t(z) %*% as.matrix(b) 92 | grad <- as.matrix(z %*% tzb - y) 93 | maxp <- con$pbar 94 | ninf <- nb + 1 95 | 96 | if (con$ptype == "fixed") { 97 | alpha <- 1:nb 98 | } else if (con$ptype == "random") { 99 | alpha <- sample(1:nb, nb, replace = FALSE) 100 | } 101 | 102 | fset <- 1:nb 103 | gset <- numeric(0) 104 | 105 | bf <- b[fset] 106 | gradg <- grad[gset] 107 | 108 | # To avoid nondegenerate problem (as done by Jason Cantarella) 109 | idxf <- abs(bf) < tol 110 | idxg <- abs(gradg) < tol 111 | bf[idxf] <- 0L 112 | gradg[idxg] <- 0L 113 | 114 | # convergence criteria 115 | converged <- all(bf > -con$gtol) & all(gradg > -con$gtol) 116 | 117 | if (converged) { 118 | bf <- t(b) 119 | return(bf) 120 | } else { 121 | while (!converged) { 122 | i1 <- fset[which(bf < -tol)] 123 | i2 <- gset[which(gradg < -tol)] 124 | ivec <- union(i1, i2) 125 | 126 | if (length(ivec) < ninf) { 127 | ninf <- length(ivec) 128 | maxp <- con$pbar 129 | } else if (maxp >= 1) { 130 | maxp <- maxp - 1 131 | } else { 132 | if (con$ptype == "fixed") { 133 | cat("You are entering a slow zone! It might take some time to converge! \n") 134 | r <- max(ivec) 135 | } else if (con$ptype == "random") { 136 | cat("You are entering a slow zone! It might take some time to converge! \n") 137 | r <- alpha[max(which(alpha %in% ivec))] 138 | } 139 | if (is.element(r, i1)) { 140 | i1 <- r 141 | i2 <- numeric(0) 142 | } else { 143 | i1 <- numeric(0) 144 | i2 <- r 145 | } 146 | } 147 | 148 | # updating f and g 149 | fset <- union(fset[!fset %in% i1], i2) 150 | gset <- union(gset[!gset %in% i2], i1) 151 | 152 | if (is.null(groups)) { # class hts 153 | allf <- numeric(nt) 154 | uwts <- weights 155 | 156 | if (length(gset) == 0) { 157 | ufcasts <- fcasts 158 | tmp <- combinefm(fcasts = ufcasts, smat = smat, weights = uwts, alg = alg) 159 | allf <- as.numeric(tmp) 160 | } else { 161 | usmat <- as(smat[, -gset], "sparseMatrix") 162 | zidx <- setdiff(1:nt, unique(summary(usmat)$i)) # identifying rows with zeros 163 | if (length(zidx) != 0) 164 | { 165 | idxR <- unique(c(gset + nxb, zidx)) # series with zeros in the summing matrix and active constraints 166 | ufcasts <- fcasts[-idxR] 167 | if (!is.null(weights)) { 168 | uwts <- uwts[-idxR] 169 | } 170 | if (ncol(usmat) == 1) { 171 | tmp <- rep(mean(ufcasts), length(ufcasts)) 172 | } else { 173 | usmat <- as(usmat[-idxR, ], "sparseMatrix") 174 | tmp <- combinefm(fcasts = ufcasts, smat = usmat, 175 | weights = uwts, alg = alg) 176 | } 177 | allf[sort(setdiff(c(1:nxb, (fset + nxb)), zidx))] <- as.numeric(tmp) 178 | 179 | } else { 180 | idxR <- gset + nxb 181 | ufcasts <- fcasts[-idxR] 182 | if (!is.null(weights)) { 183 | uwts <- uwts[-idxR] 184 | } 185 | if (ncol(usmat) == 1) { 186 | tmp <- rep(mean(ufcasts), length(ufcasts)) 187 | } else { 188 | tmp <- combinefm(fcasts = ufcasts, smat = usmat, 189 | weights = uwts, alg = alg) 190 | } 191 | allf[c(1:nxb, (fset + nxb))] <- as.numeric(tmp) 192 | } 193 | } 194 | } else if (is.null(nodes)) { # class gts 195 | allf <- numeric(nt) 196 | uwts <- weights 197 | 198 | if (length(gset) == 0) { 199 | ufcasts <- fcasts 200 | tmp <- combinefm(fcasts = ufcasts, smat = smat, weights = uwts, alg = alg) 201 | allf <- as.numeric(tmp) 202 | } else { 203 | usmat <- as(smat[, -gset], "sparseMatrix") 204 | zidx <- setdiff(1:nt, unique(summary(usmat)$i)) # identifying rows with zeros 205 | if (length(zidx) != 0) 206 | { 207 | idxR <- unique(c(gset + nxb, zidx)) # series with zeros in the summing matrix and active constraints 208 | ufcasts <- fcasts[-idxR] 209 | if (!is.null(weights)) { 210 | uwts <- uwts[-idxR] 211 | } 212 | if(ncol(usmat) == 1) { 213 | tmp <- rep(mean(ufcasts), length(ufcasts)) 214 | } else { 215 | usmat <- as(usmat[-idxR, ], "sparseMatrix") 216 | tmp <- combinefm(fcasts = ufcasts, smat = usmat, 217 | weights = uwts, alg = alg) 218 | } 219 | allf[sort(setdiff(c(1:nxb, (fset + nxb)), zidx))] <- as.numeric(tmp) 220 | 221 | } else { 222 | idxR <- gset + nxb 223 | ufcasts <- fcasts[-idxR] 224 | if (!is.null(weights)) { 225 | uwts <- uwts[-idxR] 226 | } 227 | if (ncol(usmat) == 1) { 228 | tmp <- rep(mean(ufcasts), length(ufcasts)) 229 | } else { 230 | tmp <- combinefm(fcasts = ufcasts, smat = usmat, 231 | weights = uwts, alg = alg) 232 | } 233 | allf[c(1:nxb, (fset + nxb))] <- as.numeric(tmp) 234 | } 235 | } 236 | } 237 | 238 | b <- tail(allf, nb) 239 | tzb <- t(z) %*% as.matrix(b) 240 | grad <- as.matrix(z %*% tzb) - y 241 | bf <- b[fset] 242 | gradg <- grad[gset] 243 | 244 | # To avoid nondegenerate problem (as done by Jason Cantarella) 245 | idxf <- abs(bf) < tol 246 | idxg <- abs(gradg) < tol 247 | bf[idxf] <- 0L 248 | gradg[idxg] <- 0L 249 | converged <- all(bf > -con$gtol) & all(gradg > -con$gtol) 250 | } 251 | } 252 | 253 | bf <- t(b) 254 | return(bf) 255 | } 256 | 257 | -------------------------------------------------------------------------------- /R/hts.R: -------------------------------------------------------------------------------- 1 | #' Create a hierarchical time series 2 | #' 3 | #' Method for creating hierarchical time series. 4 | #' 5 | #' 6 | #' @rdname hts-class 7 | #' @param y A matrix or multivariate time series contain the bottom level 8 | #' series. 9 | #' @param nodes A list contains the number of child nodes associated with each 10 | #' level, which indicates the hierarchical structure. The default is a simple 11 | #' hierarchy with only 2 levels (i.e. total and bottom). If the argument 12 | #' \code{characters} is used, \code{nodes} will be automatically generated 13 | #' within the function. 14 | #' @param bnames The names of the bottom time series. 15 | #' @param characters Integers indicate the segments in which the bottom level 16 | #' names can be read in order to construct the corresponding node structure and 17 | #' its labels. For instance, suppose one of the bottom series is named 18 | #' "VICMelb" referring to the city of Melbourne within the state of Victoria. 19 | #' Then \code{characters} would be specified as \code{c(3, 4)} referring to 20 | #' states of 3 characters (e.g., "VIC") and cities of 4 characters (e.g., 21 | #' "Melb") All the bottom names must be of the same length, with number of 22 | #' characters for each segment the same for all series. 23 | #' @param ... Extra arguments passed to \code{print} and \code{summary}. 24 | #' @return \item{bts}{Multivariate time series containing the bottom level 25 | #' series} \item{nodes}{Information about the nodes of a hierarchical time 26 | #' series} \item{labels}{Information about the labels that are used for 27 | #' plotting.} 28 | #' @author Earo Wang and Rob J Hyndman 29 | #' @seealso \code{\link[hts]{gts}}, \code{\link[hts]{accuracy.gts}}, 30 | #' \code{\link[hts]{forecast.gts}}, \code{\link[hts]{plot.gts}} 31 | #' @references Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. 32 | #' (2011). Optimal combination forecasts for hierarchical time series. 33 | #' \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 34 | #' \url{https://robjhyndman.com/publications/hierarchical/} 35 | #' @keywords ts 36 | #' @examples 37 | #' 38 | #' # Example 1 39 | #' # The hierarchical structure looks like 2 child nodes associated with level 1, 40 | #' # which are followed by 3 and 2 sub-child nodes respectively at level 2. 41 | #' nodes <- list(2, c(3, 2)) 42 | #' abc <- ts(5 + matrix(sort(rnorm(500)), ncol = 5, nrow = 100)) 43 | #' x <- hts(abc, nodes) 44 | #' 45 | #' # Example 2 46 | #' # Suppose we've got the bottom names that can be useful for constructing the node 47 | #' # structure and the labels at higher levels. We need to specify how to split them 48 | #' # in the argument "characters". 49 | #' library(hts) 50 | #' abc <- ts(5 + matrix(sort(rnorm(1000)), ncol = 10, nrow = 100)) 51 | #' colnames(abc) <- c("A10A", "A10B", "A10C", "A20A", "A20B", 52 | #' "B30A", "B30B", "B30C", "B40A", "B40B") 53 | #' y <- hts(abc, characters = c(1, 2, 1)) 54 | #' 55 | #' @export hts 56 | hts <- function(y, nodes, bnames = colnames(y), characters) { 57 | # Construct the hierarchical time series. 58 | # 59 | # Args: 60 | # y*: The bottom time series assigned by the user. Same lengths and no NA. 61 | # nodes: A list contains the number of child nodes for each level except 62 | # for the bottom one. If missing, it's assumed to have only one level. 63 | # bnames: The names of the bottom time series. 64 | # characters: Define how to split the "bnames" in order to construct the 65 | # level labels. Otherwise, use the defaul labelling system. The arg also 66 | # implies the node structure. 67 | # 68 | # Returns: 69 | # A hierarchical time series. 70 | # 71 | # Error handling: 72 | if (!is.ts(y)) { 73 | y <- stats::as.ts(y) 74 | } 75 | nbts <- ncol(y) 76 | 77 | if (is.null(nbts) || nbts <= 1L) { 78 | stop("Argument y must be a multivariate time series.", call. = FALSE) 79 | } 80 | if (missing(characters)) { # Arg "characters" not specified 81 | message("Since argument characters are not specified, the default labelling system is used.") 82 | if (missing(nodes)) { 83 | nodes <- list(nbts) 84 | } 85 | if (!is.list(nodes)) { 86 | stop("Argument nodes must be a list.", call. = FALSE) 87 | } 88 | if (length(nodes[[1L]]) != 1L) { 89 | stop("The root node cannot be empty.", call. = FALSE) 90 | } 91 | if (sum(nodes[[length(nodes)]]) != nbts) { 92 | stop("The number of terminal nodes is not consistent with the number of bottom time series.", call. = FALSE) 93 | } 94 | if (length(nodes) > 1L) { 95 | for (i in 1L:(length(nodes) - 1L)) { 96 | if (sum(nodes[[i]]) != length(nodes[[i + 1]])) { 97 | error <- sprintf("The number of nodes for the level %i is not equal to the number of series of level %i.", i - 1L, i) 98 | stop(error, call. = FALSE) 99 | } 100 | } 101 | } 102 | 103 | # Construct the level labels 104 | if (is.null(bnames)) { 105 | labels <- HierName(nodes) # HierName() defined below 106 | colnames(y) <- unlist(labels[length(labels)]) 107 | } else { # Keep bts names if specified 108 | hn <- HierName(nodes) 109 | last.label <- paste("Level", length(nodes)) 110 | b.list <- list(bnames) 111 | names(b.list) <- last.label 112 | labels <- c(hn[-length(hn)], b.list) 113 | # if (length(hn) == 1L) { # In case of a simple hierarchy of 2 levels 114 | # labels <- c(hn, b.list) 115 | # } else { 116 | # labels <- c(hn[-length(hn)], b.list) 117 | # } 118 | } 119 | } else { # Specified "characters" automates the node structure 120 | if (!all(nchar(bnames)[1L] == nchar(bnames)[-1L])) { 121 | stop("The bottom names must be of the same length.", call. = FALSE) 122 | } 123 | if (any(nchar(bnames) != sum(characters))) { 124 | warning("The argument characters is not fully specified for the bottom names.") 125 | } 126 | c.nodes <- CreateNodes(bnames, characters) 127 | nodes <- c.nodes$nodes 128 | labels <- c.nodes$labels 129 | y <- y[, c.nodes$index] 130 | } 131 | 132 | # Obtain other information 133 | names(nodes) <- paste("Level", 1L:length(nodes)) 134 | 135 | output <- structure( 136 | list(bts = y, nodes = nodes, labels = labels), 137 | class = c("hts", "gts") 138 | ) 139 | return(output) 140 | } 141 | 142 | #' Get nodes/groups from an hts/gts object 143 | #' 144 | #' @rdname helper-functions 145 | #' @param y An hts or gts object 146 | #' series. 147 | #' @export 148 | get_nodes <- function(y) { 149 | if(!is.hts(y)) stop("'y' must be an hts object.", call. = FALSE) 150 | return(y$nodes) 151 | } 152 | 153 | 154 | # A function to convert the nodes list to gmatrix 155 | GmatrixH <- function(xlist) { 156 | l.xlist <- length(xlist) 157 | num.bts <- sum(xlist[[l.xlist]]) 158 | nlist <- unlist(lapply(xlist, length)) 159 | # Create an empty matrix to contain the gmatrix 160 | gmat <- matrix(, nrow = l.xlist, ncol = num.bts) 161 | # Insert the bottom level 162 | gmat[nrow(gmat), ] <- seq(1L, num.bts) 163 | # Insert the middle levels in the reverse order 164 | if (l.xlist > 1L) { 165 | repcount <- xlist[[l.xlist]] 166 | for (i in (l.xlist - 1L):1L) { 167 | gmat[i, ] <- rep(1L:nlist[i + 1], repcount) 168 | repcount <- rowsum(repcount, rep(1L:nlist[i], xlist[[i]])) 169 | } 170 | } 171 | # Insert the top level 172 | gmat <- rbind(rep(1L, num.bts), gmat) 173 | 174 | dimnames(gmat) <- list(paste("Level", 0L:(nrow(gmat) - 1L)), colnames(xlist)) 175 | class(gmat) <- "gmatrix" 176 | return(gmat) 177 | } 178 | 179 | 180 | # A function to return the NO. of nodes at each level 181 | Mnodes <- function(xlist) { 182 | m <- c(unlist(lapply(xlist, length)), sum(xlist[[length(xlist)]])) 183 | return(m) 184 | } 185 | 186 | 187 | # A function to get the inverse of row sums of Smatrix 188 | InvS4h <- function(xlist) { 189 | gmat <- GmatrixH(xlist) 190 | uniq <- apply(gmat, 1, unique) 191 | len <- nrow(gmat) 192 | inv.s <- vector(length = len, mode = "list") 193 | for (i in 1L:len) { 194 | inv.s[[i]] <- sapply(uniq[[i]], function(x) length(gmat[i, gmat[i, ] == x])) 195 | } 196 | inv.s <- 1/unlist(inv.s) 197 | return(inv.s) 198 | } 199 | 200 | 201 | # A function to set the default hierarchical names 202 | HierName <- function(xlist) { 203 | l.xlist <- length(xlist) 204 | names.list <- list(length = l.xlist) 205 | names.list[[1L]] <- LETTERS[1L:xlist[[1L]]] 206 | if (l.xlist > 1L) { 207 | for (i in 2L:l.xlist) { 208 | # Grab the individual letters at each level 209 | ind <- unlist(sapply(xlist[[i]], function(x) LETTERS[1:x])) 210 | # Recursively paste 211 | names.list[[i]] <- paste0(rep(names.list[[i - 1]], xlist[[i]]), ind) 212 | } 213 | names(names.list) <- paste("Level", 1L:l.xlist) 214 | } 215 | names.list <- c("Level 0" = "Total", names.list) 216 | return(names.list) 217 | } 218 | 219 | 220 | # A function to create nodes based on segmentation of bottom names 221 | # it also generate index for bottom time series 222 | CreateNodes <- function(bnames, characters) { 223 | characters <- as.integer(characters) 224 | end <- cumsum(characters) 225 | start <- end - characters + 1L 226 | token <- sapply(end, function(x) substring(bnames, 1L, x)) 227 | nc.token <- ncol(token) 228 | unique.str <- apply(token, 2, unique) 229 | nodes <- lapply(2L:nc.token, function(x) { 230 | prefix <- substr(unique.str[[x]], start = 1L, 231 | stop = end[x - 1L]) 232 | return(table(prefix, dnn = NULL)) 233 | }) 234 | nodes <- c(length(unique.str[[1L]]), nodes) 235 | # Construct labels based on characters 236 | names(unique.str) <- paste("Level", 1L:nc.token) 237 | extract.levels <- lapply(unique.str, function(x) levels(factor(x))) 238 | labels <- c("Level 0" = "Total", extract.levels) 239 | # Generate index for bottom time series 240 | idx <- match(extract.levels[[nc.token]], token[, nc.token]) 241 | out <- list(nodes = nodes, labels = labels, index = idx) 242 | return(out) 243 | } 244 | 245 | #' @rdname hts-class 246 | #' @param xts \code{hts} object. 247 | #' @export 248 | # A function to check whether it's the "hts" class. 249 | is.hts <- function(xts) { 250 | is.element("hts", class(xts)) 251 | } 252 | 253 | #' @rdname hts-class 254 | #' @param x \code{hts} object. 255 | #' @method print hts 256 | #' @export 257 | #' @export print.hts 258 | # Print "hts" on the screen 259 | print.hts <- function(x, ...) { 260 | mn <- Mnodes(x$nodes) 261 | cat("Hierarchical Time Series \n") 262 | cat(length(mn), "Levels \n") 263 | cat("Number of nodes at each level:", mn, "\n") 264 | cat("Total number of series:", sum(mn), "\n") 265 | 266 | if (is.null(x$histy)) { # Original series 267 | cat("Number of observations per series:", nrow(x$bts), "\n") 268 | cat("Top level series: \n") 269 | } else { 270 | cat("Number of observations in each historical series:", 271 | nrow(x$histy), "\n") 272 | cat("Number of forecasts per series:", nrow(x$bts), "\n") 273 | cat("Top level series of forecasts: \n") 274 | } 275 | topts <- ts(rowSums(x$bts), start = stats::tsp(x$bts)[1L], 276 | frequency = stats::tsp(x$bts)[3L]) 277 | print(topts) 278 | } 279 | 280 | #' @rdname hts-class 281 | #' @param object \code{hts} object. 282 | #' @method summary hts 283 | #' @export 284 | #' @export summary.hts 285 | summary.hts <- function(object, ...) { 286 | NextMethod() 287 | } 288 | -------------------------------------------------------------------------------- /R/combinef.R: -------------------------------------------------------------------------------- 1 | #' Optimally combine forecasts from a hierarchical or grouped time series 2 | #' 3 | #' Using the methods of Hyndman et al. (2016) and Hyndman et al. (2011), this function optimally combines 4 | #' the forecasts at all levels of a hierarchical time series. The 5 | #' \code{\link{forecast.gts}} calls this function when the \code{comb} method 6 | #' is selected. 7 | #' 8 | #' 9 | #' @param fcasts Matrix of forecasts for all levels of the hierarchical time 10 | #' series. Each row represents one forecast horizon and each column represents 11 | #' one time series from the hierarchy. 12 | #' @param nodes If the object class is \code{hts}, a list contains the number 13 | #' of child nodes referring to \code{hts}. 14 | #' @param groups If the object class is \code{gts}, a gmatrix is required, 15 | #' which is the same as \code{groups} in the function \code{gts}. 16 | #' @param weights A numeric vector. The default is \code{NULL} which means that 17 | #' ordinary least squares is implemented. 18 | #' @param nonnegative Logical. Should the reconciled forecasts be non-negative? 19 | #' @param algorithms An algorithm to be used for computing reconciled 20 | #' forecasts. See \code{\link{forecast.gts}} for details. 21 | #' @param keep Return a \code{gts} object or the the reconciled forecasts at 22 | #' the bottom level. 23 | #' @param parallel Logical. Import parallel package to allow parallel processing. 24 | #' @param num.cores Numeric. Specify how many cores are going to be used. 25 | #' @param control.nn A list of control parameters to be passed on to the 26 | #' block principal pivoting algorithm. See 'Details'. 27 | #' @return Return the (non-negative) reconciled \code{gts} object or forecasts at the bottom 28 | #' level. 29 | #' 30 | #' @details 31 | #' The \code{control.nn} argument is a list that can supply any of the following components: 32 | #' \describe{ 33 | #' \item{\code{ptype}}{Permutation method to be used: \code{"fixed"} or \code{"random"}. Defaults to \code{"fixed"}.} 34 | #' \item{\code{par}}{The number of full exchange rules that may be tried. Defaults to 10.} 35 | #' \item{\code{gtol}}{The tolerance of the convergence criteria. Defaults to \code{sqrt(.Machine$double.eps)}.} 36 | #' } 37 | #' @author Alan Lee, Rob J Hyndman, Earo Wang and Shanika L Wickramasuriya 38 | #' @seealso \code{\link[hts]{hts}}, \code{\link[hts]{forecast.gts}} 39 | #' @references Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. 40 | #' (2011). Optimal combination forecasts for hierarchical time series. 41 | #' \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. \url{https://robjhyndman.com/publications/hierarchical/} 42 | #' 43 | #' Hyndman, R. J., Lee, A., & Wang, E. (2016). Fast computation of reconciled 44 | #' forecasts for hierarchical and grouped time series. \emph{Computational Statistics and Data Analysis}, 45 | #' \bold{97}, 16--32. \url{https://robjhyndman.com/publications/hgts/} 46 | #' 47 | #' Wickramasuriya, S. L., Turlach, B. A., & Hyndman, R. J. (to appear). Optimal non-negative forecast reconciliation. 48 | #' \emph{Statistics and Computing}. \url{https://robjhyndman.com/publications/nnmint/} 49 | #' @keywords ts 50 | #' @examples 51 | #' 52 | #' # hts example 53 | #' \dontrun{ 54 | #' h <- 12 55 | #' ally <- aggts(htseg1) 56 | #' allf <- matrix(NA, nrow = h, ncol = ncol(ally)) 57 | #' for(i in 1:ncol(ally)) 58 | #' allf[,i] <- forecast(auto.arima(ally[,i]), h = h)$mean 59 | #' allf <- ts(allf, start = 51) 60 | #' y.f <- combinef(allf, get_nodes(htseg1), weights = NULL, keep = "gts", algorithms = "lu") 61 | #' plot(y.f) 62 | #' } 63 | #' 64 | #' \dontrun{ 65 | #' h <- 12 66 | #' ally <- abs(aggts(htseg2)) 67 | #' allf <- matrix(NA, nrow = h, ncol = ncol(ally)) 68 | #' for(i in 1:ncol(ally)) 69 | #' allf[,i] <- forecast(auto.arima(ally[,i], lambda = 0, biasadj = TRUE), h = h)$mean 70 | #' b.f <- combinef(allf, get_nodes(htseg2), weights = NULL, keep = "bottom", 71 | #' algorithms = "lu") 72 | #' b.nnf <- combinef(allf, get_nodes(htseg2), weights = NULL, keep = "bottom", 73 | #' algorithms = "lu", nonnegative = TRUE) 74 | #' } 75 | #' 76 | #' # gts example 77 | #' \dontrun{ 78 | #' abc <- ts(5 + matrix(sort(rnorm(200)), ncol = 4, nrow = 50)) 79 | #' g <- rbind(c(1,1,2,2), c(1,2,1,2)) 80 | #' y <- gts(abc, groups = g) 81 | #' h <- 12 82 | #' ally <- aggts(y) 83 | #' allf <- matrix(NA,nrow = h,ncol = ncol(ally)) 84 | #' for(i in 1:ncol(ally)) 85 | #' allf[,i] <- forecast(auto.arima(ally[,i]),h = h)$mean 86 | #' allf <- ts(allf, start = 51) 87 | #' y.f <- combinef(allf, groups = get_groups(y), keep ="gts", algorithms = "lu") 88 | #' plot(y.f) 89 | #' } 90 | #' @export combinef 91 | combinef <- function(fcasts, nodes = NULL, groups = NULL, weights = NULL, nonnegative = FALSE, 92 | algorithms = c("lu", "cg", "chol", "recursive", "slm"), 93 | keep = c("gts", "all", "bottom"), parallel = FALSE, num.cores = 2, control.nn = list()) { 94 | # Construct optimal combination forecasts 95 | # 96 | # Args: 97 | # fcasts: all hts/gts forecasts 98 | # nodes: nodes for hts 99 | # groups: gts 100 | # weights: users need to specify the weights 101 | # nonnegative: non-negativity of the reconciled forecasts 102 | # algorithms: different algorithms to obtain reconciled forecasts 103 | # keep: choose to return a gts object/all ts/bottom time series 104 | # parallel: import parallel package to allow parallel processing 105 | # num.cores: specify how many cores are going to be used 106 | # control.nn: other arguments to be passed to non-negative algorithm 107 | # 108 | # Return: 109 | # Optimal (non-negative) reconciled forecasts 110 | 111 | if (is.null(nodes) && is.null(groups)) { 112 | stop("Please specify the hierarchical or the grouping structure.", call. = FALSE) 113 | } 114 | 115 | if (!xor(is.null(nodes), is.null(groups))) { 116 | stop("Please specify either nodes or groups argument, not both.", call. = FALSE) 117 | } 118 | 119 | alg <- match.arg(algorithms) 120 | keep <- match.arg(keep) 121 | fcasts <- stats::as.ts(fcasts) 122 | tspx <- stats::tsp(fcasts) 123 | cnames <- colnames(fcasts) 124 | 125 | 126 | if (alg %in% c("recursive", "slm") && nonnegative) { 127 | stop("The non-negative algorithm doesn't support slm or recursive", call. = FALSE) 128 | } 129 | 130 | if (!nonnegative) { 131 | if (is.null(groups)) { # hts class 132 | if (alg == "slm") { 133 | stop("The slm algorithm does not support an hts object.", call. = FALSE) 134 | } 135 | totalts <- sum(Mnodes(nodes)) 136 | if (!is.matrix(fcasts)) { 137 | fcasts <- t(fcasts) 138 | } 139 | h <- nrow(fcasts) 140 | if (ncol(fcasts) != totalts) { 141 | stop("Argument fcasts requires all the forecasts.", call. = FALSE) 142 | } 143 | if (alg == "recursive") { # only nodes to be needed 144 | # CombineH only returns bottom time series 145 | if(is.null(weights)) { 146 | bf <- CombineH(fcasts, nodes) # w/o weights 147 | } else { 148 | bf <- CombineHw(fcasts, nodes, weights) # with weights 149 | } 150 | } else { 151 | # Other algorithms return all time series 152 | gmat <- GmatrixH(nodes) 153 | fcasts <- t(fcasts) 154 | if (alg == "chol") { 155 | smat <- Smatrix(gmat) 156 | if (!is.null(weights)) { 157 | weights <- methods::as(1/weights, "matrix.diag.csr") 158 | } 159 | allf <- CHOL(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 160 | } else { 161 | smat <- SmatrixM(gmat) 162 | if (!is.null(weights)) { 163 | seqts <- 1:totalts 164 | weights <- sparseMatrix(i = seqts, j = seqts, x = 1/weights) 165 | } 166 | if (alg == "lu") { 167 | allf <- LU(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 168 | } else if (alg == "cg") { 169 | allf <- CG(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 170 | } 171 | } 172 | } 173 | 174 | if (keep == "all") { 175 | if (alg == "recursive") { 176 | gmat <- GmatrixH(nodes) 177 | levels <- 1L:nrow(gmat) 178 | # A function to aggregate the bts 179 | if (h == 1 && !is.null(weights)) { 180 | rSum <- function(x) rowsum(as.matrix(bf), gmat[x, ], reorder = FALSE) 181 | } else { 182 | rSum <- function(x) rowsum(t(bf), gmat[x, ], reorder = FALSE) 183 | } 184 | ally <- lapply(levels, rSum) 185 | # Convert lists to matrices 186 | out <- matrix(unlist(sapply(ally, t)), nrow = h) 187 | } else { 188 | out <- t(allf) 189 | } 190 | } else { 191 | if (alg != "recursive") { 192 | bottom <- totalts - (ncol(smat):1L) + 1L 193 | bf <- t(allf[bottom, ]) 194 | } 195 | if (keep == "gts") { 196 | bf <- ts(bf, start = tspx[1L], frequency = tspx[3L]) 197 | out <- suppressMessages(hts(bf, nodes = nodes)) 198 | } else { 199 | out <- bf 200 | } 201 | } 202 | } else if (is.null(nodes)) { # gts class 203 | if (alg == "recursive") { 204 | stop("The recursive algorithm does not support a gts object.", call. = FALSE) 205 | } 206 | # To call Smatrix() properly 207 | rownames(groups) <- NULL 208 | gmat <- GmatrixG(groups) 209 | totalts <- sum(Mlevel(gmat)) 210 | if (ncol(fcasts) != totalts) { 211 | stop("Argument fcasts requires all the forecasts.", call. = FALSE) 212 | } 213 | fcasts <- t(fcasts) 214 | if (alg == "chol") { 215 | smat <- Smatrix(gmat) 216 | if (!is.null(weights)) { 217 | weights <- methods::as(1/weights, "matrix.diag.csr") 218 | } 219 | allf <- CHOL(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 220 | } else if (alg == "slm") { 221 | smat <- Smatrix(gmat) 222 | allf <- SLM(fcasts = fcasts, S = smat, weights = weights) 223 | } else { 224 | smat <- SmatrixM(gmat) 225 | if (!is.null(weights)) { 226 | seqts <- 1:totalts 227 | weights <- sparseMatrix(i = seqts, j = seqts, x = 1/weights) 228 | } 229 | if (alg == "lu") { 230 | allf <- LU(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 231 | } else if (alg == "cg") { 232 | allf <- CG(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 233 | } 234 | } 235 | 236 | if (keep == "all") { 237 | out <- t(allf) 238 | } else { 239 | bottom <- totalts - (ncol(smat):1L) + 1L 240 | bf <- t(allf[bottom, ]) 241 | if (keep == "gts") { 242 | colnames(bf) <- cnames[bottom] 243 | bf <- ts(bf, start = tspx[1L], frequency = tspx[3L]) 244 | out <- suppressMessages(gts(bf, groups = groups)) 245 | } else { 246 | out <- bf 247 | } 248 | } 249 | } 250 | } else { 251 | if (any(fcasts < 0)) { 252 | fcasts[fcasts < 0] <- 0 253 | warning("Negative base forecasts are truncated to zero.") 254 | } 255 | 256 | lst.fc <- split(fcasts, row(fcasts)) 257 | if (parallel) { 258 | if (is.null(num.cores)) { 259 | num.cores <- detectCores() 260 | } 261 | cl <- makeCluster(num.cores) 262 | bf <- parSapplyLB(cl = cl, X = lst.fc, bpv, nodes = nodes, groups = groups, weights = weights, alg = alg, control.nn = control.nn, simplify = TRUE) 263 | stopCluster(cl = cl) 264 | } else { 265 | bf <- sapply(lst.fc, bpv, nodes = nodes, groups = groups, weights = weights, alg = alg, control.nn = control.nn) 266 | } 267 | 268 | bf <- ts(t(bf), start = tspx[1L], frequency = tspx[3L]) 269 | if (is.null(groups)) { 270 | if (keep == "bottom") { 271 | out <- bf 272 | } else { 273 | out <- suppressMessages(hts(bf, nodes = nodes)) 274 | if (keep == "all") { 275 | out <- aggts(out) 276 | } 277 | } 278 | } else { 279 | if (keep == "bottom") { 280 | out <- bf 281 | } else { 282 | colnames(bf) <- tail(cnames, ncol(bf)) 283 | out <- suppressMessages(gts(bf, groups = groups)) 284 | if (keep == "all") { 285 | out <- aggts(out) 286 | } 287 | } 288 | } 289 | } 290 | 291 | return(out) 292 | } 293 | -------------------------------------------------------------------------------- /R/MinT.R: -------------------------------------------------------------------------------- 1 | ## Arguments 2 | 3 | # x: Matrix of insample residuals for all time series in the hierarchy. Each column referring to one time series. 4 | 5 | # Target matrix for shrinking towards a diagonal matrix 6 | lowerD <- function(x) 7 | { 8 | n <- nrow(x) 9 | return(diag(apply(x, 2, crossprod) / n)) 10 | } 11 | 12 | ## Arguments 13 | 14 | # x: Matrix of insample residuals for all time series in the hierarchy. Each column referring to one time series. 15 | # tar: Lower dimensional matrix. 16 | 17 | # Shrinked covariance matrix - Schafer and strimmer approach 18 | shrink.estim <- function(x, tar) 19 | { 20 | if (is.matrix(x) == TRUE && is.numeric(x) == FALSE) 21 | stop("The data matrix must be numeric!", call. = FALSE) 22 | p <- ncol(x) 23 | n <- nrow(x) 24 | covm <- crossprod(x) / n 25 | corm <- cov2cor(covm) 26 | xs <- scale(x, center = FALSE, scale = sqrt(diag(covm))) 27 | v <- (1/(n * (n - 1))) * (crossprod(xs^2) - 1/n * (crossprod(xs))^2) 28 | diag(v) <- 0 29 | corapn <- cov2cor(tar) 30 | d <- (corm - corapn)^2 31 | lambda <- sum(v)/sum(d) 32 | lambda <- max(min(lambda, 1), 0) 33 | shrink.cov <- lambda * tar + (1 - lambda) * covm 34 | return(list(shrink.cov, c("The shrinkage intensity lambda is:", 35 | round(lambda, digits = 4)))) 36 | } 37 | 38 | # MinT - Trace minimization approach 39 | 40 | 41 | #' Trace minimization for hierarchical or grouped time series 42 | #' 43 | #' Using the method of Wickramasuriya et al. (2019), this function combines the 44 | #' forecasts at all levels of a hierarchical or grouped time series. The 45 | #' \code{\link{forecast.gts}} calls this function when the \code{MinT} method 46 | #' is selected. 47 | #' 48 | #' @param fcasts Matrix of forecasts for all levels of a hierarchical or 49 | #' grouped time series. Each row represents one forecast horizon and each 50 | #' column represents one time series of aggregated or disaggregated forecasts. 51 | #' @param nodes If the object class is hts, a list contains the number of child 52 | #' nodes referring to hts. 53 | #' @param groups If the object is gts, a gmatrix is required, which is the same 54 | #' as groups in the function gts. 55 | #' @param residual Matrix of insample residuals for all the aggregated and 56 | #' disaggregated time series. The columns must be in the same order as 57 | #' \code{fcasts}. 58 | #' @param covariance Type of the covariance matrix to be used. Shrinking 59 | #' towards a diagonal unequal variances (\code{"shr"}) or sample covariance matrix 60 | #' (\code{"sam"}). 61 | #' @param nonnegative Logical. Should the reconciled forecasts be non-negative? 62 | #' @param algorithms Algorithm used to compute inverse of the matrices. 63 | #' @param keep Return a gts object or the reconciled forecasts at the bottom 64 | #' level. 65 | #' @param parallel Logical. Import parallel package to allow parallel processing. 66 | #' @param num.cores Numeric. Specify how many cores are going to be used. 67 | #' @param control.nn A list of control parameters to be passed on to the 68 | #' block principal pivoting algorithm. See 'Details'. 69 | #' @return Return the reconciled \code{gts} object or forecasts at the bottom 70 | #' level. 71 | #' @details 72 | #' The \code{control.nn} argument is a list that can supply any of the following components: 73 | #' \describe{ 74 | #' \item{\code{ptype}}{Permutation method to be used: \code{"fixed"} or \code{"random"}. Defaults to \code{"fixed"}.} 75 | #' \item{\code{par}}{The number of full exchange rules that may be tried. Defaults to 10.} 76 | #' \item{\code{gtol}}{The tolerance of the convergence criteria. Defaults to \code{sqrt(.Machine$double.eps)}.} 77 | #' } 78 | #' @author Shanika L Wickramasuriya 79 | #' @seealso \code{\link[hts]{hts}}, \code{\link[hts]{gts}}, 80 | #' \code{\link[hts]{forecast.gts}}, \code{\link[hts]{combinef}} 81 | #' @references Wickramasuriya, S. L., Athanasopoulos, G., & Hyndman, R. J. (2019). 82 | #' Optimal forecast reconciliation for hierarchical and grouped time series through trace minimization. 83 | #' \emph{Journal of the American Statistical Association}, \bold{114}(526), 804--819. \url{https://robjhyndman.com/publications/mint/} 84 | #' 85 | #' Wickramasuriya, S. L., Turlach, B. A., & Hyndman, R. J. (to appear). Optimal non-negative forecast reconciliation. 86 | #' \emph{Statistics and Computing}. \url{https://robjhyndman.com/publications/nnmint/} 87 | #' 88 | #' Hyndman, R. J., Lee, A., & Wang, E. (2016). Fast computation of reconciled 89 | #' forecasts for hierarchical and grouped time series. \emph{Computational 90 | #' Statistics and Data Analysis}, \bold{97}, 16--32. 91 | #' \url{https://robjhyndman.com/publications/hgts/} 92 | #' @keywords ts 93 | #' @examples 94 | #' 95 | #' # hts example 96 | #' \dontrun{ 97 | #' h <- 12 98 | #' ally <- aggts(htseg1) 99 | #' n <- nrow(ally) 100 | #' p <- ncol(ally) 101 | #' allf <- matrix(NA, nrow = h, ncol = p) 102 | #' res <- matrix(NA, nrow = n, ncol = p) 103 | #' for(i in 1:p) 104 | #' { 105 | #' fit <- auto.arima(ally[, i]) 106 | #' allf[, i] <- forecast(fit, h = h)$mean 107 | #' res[, i] <- na.omit(ally[, i] - fitted(fit)) 108 | #' } 109 | #' allf <- ts(allf, start = 51) 110 | #' y.f <- MinT(allf, get_nodes(htseg1), residual = res, covariance = "shr", 111 | #' keep = "gts", algorithms = "lu") 112 | #' plot(y.f) 113 | #' y.f_cg <- MinT(allf, get_nodes(htseg1), residual = res, covariance = "shr", 114 | #' keep = "all", algorithms = "cg") 115 | #' } 116 | #' 117 | #' \dontrun{ 118 | #' h <- 12 119 | #' ally <- abs(aggts(htseg2)) 120 | #' allf <- matrix(NA, nrow = h, ncol = ncol(ally)) 121 | #' res <- matrix(NA, nrow = nrow(ally), ncol = ncol(ally)) 122 | #' for(i in 1:ncol(ally)) { 123 | #' fit <- auto.arima(ally[, i], lambda = 0, biasadj = TRUE) 124 | #' allf[,i] <- forecast(fit, h = h)$mean 125 | #' res[,i] <- na.omit(ally[, i] - fitted(fit)) 126 | #' } 127 | #' b.f <- MinT(allf, get_nodes(htseg2), residual = res, covariance = "shr", 128 | #' keep = "bottom", algorithms = "lu") 129 | #' b.nnf <- MinT(allf, get_nodes(htseg2), residual = res, covariance = "shr", 130 | #' keep = "bottom", algorithms = "lu", nonnegative = TRUE, parallel = TRUE) 131 | #' } 132 | #' 133 | #' # gts example 134 | #' \dontrun{ 135 | #' abc <- ts(5 + matrix(sort(rnorm(200)), ncol = 4, nrow = 50)) 136 | #' g <- rbind(c(1,1,2,2), c(1,2,1,2)) 137 | #' y <- gts(abc, groups = g) 138 | #' h <- 12 139 | #' ally <- aggts(y) 140 | #' n <- nrow(ally) 141 | #' p <- ncol(ally) 142 | #' allf <- matrix(NA,nrow = h,ncol = ncol(ally)) 143 | #' res <- matrix(NA, nrow = n, ncol = p) 144 | #' for(i in 1:p) 145 | #' { 146 | #' fit <- auto.arima(ally[, i]) 147 | #' allf[, i] <- forecast(fit, h = h)$mean 148 | #' res[, i] <- na.omit(ally[, i] - fitted(fit)) 149 | #' } 150 | #' allf <- ts(allf, start = 51) 151 | #' y.f <- MinT(allf, groups = get_groups(y), residual = res, covariance = "shr", 152 | #' keep = "gts", algorithms = "lu") 153 | #' plot(y.f) 154 | #' } 155 | #' @export MinT 156 | MinT <- function (fcasts, nodes = NULL, groups = NULL, residual, covariance = c("shr", "sam"), 157 | nonnegative = FALSE, algorithms = c("lu", "cg", "chol"), 158 | keep = c("gts", "all", "bottom"), parallel = FALSE, num.cores = 2, control.nn = list()) 159 | { 160 | if (is.null(nodes) && is.null(groups)) { 161 | stop("Please specify the hierarchical or the grouping structure.", call. = FALSE) 162 | } 163 | 164 | if (!xor(is.null(nodes), is.null(groups))) { 165 | stop("Please specify either nodes or groups argument, not both.", call. = FALSE) 166 | } 167 | 168 | alg <- match.arg(algorithms) 169 | keep <- match.arg(keep) 170 | covar <- match.arg(covariance) 171 | res <- residual 172 | fcasts <- stats::as.ts(fcasts) 173 | tspx <- stats::tsp(fcasts) 174 | cnames <- colnames(fcasts) 175 | 176 | if (!nonnegative) { 177 | if (missing(residual)) 178 | { 179 | stop("MinT needs insample residuals.", call. = FALSE) 180 | } 181 | if (covar=="sam") 182 | { 183 | n <- nrow(res) 184 | w.1 <- crossprod(res) / n 185 | if(is.posdef(w.1)==FALSE) 186 | { 187 | stop("MinT needs covariance matrix to be positive definite.", call. = FALSE) 188 | } 189 | } else { 190 | tar <- lowerD(res) 191 | shrink <- shrink.estim(res, tar) 192 | w.1 <- shrink[[1]] 193 | lambda <- shrink[[2]] 194 | if (is.posdef(w.1)==FALSE) 195 | { 196 | stop("MinT needs covariance matrix to be positive definite.", call. = FALSE) 197 | } 198 | } 199 | 200 | if (is.null(groups)) { # hts class 201 | totalts <- sum(Mnodes(nodes)) 202 | if (!is.matrix(fcasts)) { 203 | fcasts <- t(fcasts) 204 | } 205 | h <- nrow(fcasts) 206 | if (ncol(fcasts) != totalts) { 207 | stop("Argument fcasts requires all the forecasts.", call. = FALSE) 208 | } 209 | gmat <- GmatrixH(nodes) 210 | fcasts <- t(fcasts) 211 | if (alg == "chol") { 212 | smat <- Smatrix(gmat) 213 | if (!is.null(w.1)) { 214 | w.1 <- as.matrix.csr(w.1) 215 | } 216 | allf <- CHOL(fcasts = fcasts, S = smat, weights = w.1, allow.changes = FALSE) 217 | } 218 | else { 219 | smat <- SmatrixM(gmat) 220 | if (!is.null(w.1)) { 221 | weights <- methods::as(w.1, "sparseMatrix") 222 | } 223 | if (alg == "lu") { 224 | allf <- LU(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 225 | } 226 | else if (alg == "cg") { 227 | allf <- CG(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 228 | } 229 | } 230 | 231 | if (keep == "all") { 232 | out <- t(allf) 233 | } 234 | else { 235 | bottom <- totalts - (ncol(smat):1L) + 1L 236 | bf <- t(allf[bottom, ]) 237 | if (keep == "gts") { 238 | bf <- ts(bf, start = tspx[1L], frequency = tspx[3L]) 239 | out <- suppressMessages(hts(bf, nodes = nodes)) 240 | } 241 | else { 242 | out <- bf 243 | } 244 | } 245 | } 246 | else if (is.null(nodes)) { 247 | rownames(groups) <- NULL 248 | gmat <- GmatrixG(groups) 249 | totalts <- sum(Mlevel(gmat)) 250 | if (ncol(fcasts) != totalts) { 251 | stop("Argument fcasts requires all the forecasts.", call. = FALSE) 252 | } 253 | fcasts <- t(fcasts) 254 | if (alg == "chol") { 255 | smat <- Smatrix(gmat) 256 | if (!is.null(w.1)) { 257 | weights <- as.matrix.csr(w.1) 258 | } 259 | allf <- CHOL(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 260 | } 261 | else { 262 | smat <- SmatrixM(gmat) 263 | if (!is.null(w.1)) { 264 | weights <- methods::as(w.1, "sparseMatrix") 265 | } 266 | if (alg == "lu") { 267 | allf <- LU(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 268 | } 269 | else if (alg == "cg") { 270 | allf <- CG(fcasts = fcasts, S = smat, weights = weights, allow.changes = FALSE) 271 | } 272 | } 273 | if (keep == "all") { 274 | out <- t(allf) 275 | } 276 | else { 277 | bottom <- totalts - (ncol(smat):1L) + 1L 278 | bf <- t(allf[bottom, ]) 279 | if (keep == "gts") { 280 | colnames(bf) <- cnames[bottom] 281 | bf <- ts(bf, start = tspx[1L], frequency = tspx[3L]) 282 | out <- suppressMessages(gts(bf, groups = groups)) 283 | } 284 | else { 285 | out <- bf 286 | } 287 | } 288 | } 289 | } else { 290 | if (any(fcasts < 0)) { 291 | fcasts[fcasts < 0] <- 0 292 | warning("Negative base forecasts are truncated to zero.") 293 | } 294 | 295 | lst.fc <- split(fcasts, row(fcasts)) 296 | if (parallel) { 297 | if (is.null(num.cores)) { 298 | num.cores <- detectCores() 299 | } 300 | cl <- makeCluster(num.cores) 301 | bf <- parSapplyLB(cl = cl, X = lst.fc, MinTbpv, nodes = nodes, groups = groups, res = res, covar = covar, alg = alg, control.nn = control.nn, simplify = TRUE) 302 | stopCluster(cl = cl) 303 | } else { 304 | bf <- sapply(lst.fc, MinTbpv, nodes = nodes, groups = groups, res = res, covar = covar, alg = alg, control.nn = control.nn) 305 | } 306 | bf <- ts(t(bf), start = tspx[1L], frequency = tspx[3L]) 307 | if (is.null(groups)) { 308 | if (keep == "bottom") { 309 | out <- bf 310 | } else { 311 | out <- suppressMessages(hts(bf, nodes = nodes)) 312 | if (keep == "all") { 313 | out <- aggts(out) 314 | } 315 | } 316 | } else { 317 | if (keep == "bottom") { 318 | out <- bf 319 | } else { 320 | colnames(bf) <- tail(cnames, ncol(bf)) 321 | out <- suppressMessages(gts(bf, groups = groups)) 322 | if (keep == "all") { 323 | out <- aggts(out) 324 | } 325 | } 326 | } 327 | } 328 | return(out) 329 | } 330 | 331 | is.posdef <- function (x, tol = 1e-08) { 332 | n <- NROW(x) 333 | if(n != NCOL(x)) 334 | stop("x is not a square matrix") 335 | if(sum(c(abs(x - t(x)))) > 1e-8) 336 | stop("x is not a symmetric matrix") 337 | eigenvalues <- eigen(x, only.values = TRUE)$values 338 | eigenvalues[abs(eigenvalues) < tol] <- 0 339 | all(eigenvalues >= 0) 340 | } 341 | -------------------------------------------------------------------------------- /R/gts.R: -------------------------------------------------------------------------------- 1 | #' Create a grouped time series 2 | #' 3 | #' Method for creating grouped time series. 4 | #' 5 | #' @rdname gts-class 6 | #' @aliases gts print.gts summary.gts 7 | #' @param y A matrix or multivariate time series contains the bottom level 8 | #' series. 9 | #' @param groups Group matrix indicates the group structure, with one column 10 | #' for each series when completely disaggregated, and one row for each grouping 11 | #' of the time series. It allows either a numerical matrix or a matrix 12 | #' consisting of strings that can be used for labelling. If the argument 13 | #' \code{characters} is used, then \code{groups} will be automatically 14 | #' generated within the function. 15 | #' @param gnames Specify the group names. 16 | #' @param characters A vector of integers, or a list containing vectors of 17 | #' integers, indicating the segments in which bottom level names can be read in 18 | #' order to construct the corresponding grouping matrix and its labels. A 19 | #' \code{list} class is used when a grouped time series includes one or more 20 | #' hierarchies. For example, a grouped time series may involve a geographical 21 | #' grouping and a product grouping, with each of them associated with a 2-level 22 | #' hierarchy. In this situation, a bottom level name such as "VICMelbAB" would 23 | #' indicate the state "VIC" (3 characters) followed by the city "Melb" (4 24 | #' characters), then the product category "A" (1 character) followed by the 25 | #' sub-product category "B" (1 character). In this example, the specification 26 | #' of \code{characters} is \code{list(c(3, 4), c(1, 1))}, where the first 27 | #' element \code{c(3, 4)} corresponds to the geographical hierarchy and the 28 | #' second element corresponds to the product hierarchy. In the special case 29 | #' where there is a non-hierarchical grouped time series, a vector of integers 30 | #' is also possible. For example, a grouped time series may involve state, age 31 | #' and sex grouping variables. In this situation, a bottom level name such as 32 | #' "VIC1F" would indicate the state "VIC", age group "1" and sex "F". Because 33 | #' none of these is hierarchical, we could specify \code{characters = list(3, 34 | #' 1, 1)}, or as a simple numeric vector: \code{characters = c(3, 1, 1)}. This 35 | #' implies its non-hierarchical structure and its characters segments. Again, 36 | #' all bottom level names must be of the same length. Currently, the use of 37 | #' \code{characters} only supports 2-way cross-products for grouping variables. 38 | #' Specifying \code{groups} is more general (but more complicated), as any 39 | #' combination of grouping variables can be used. 40 | #' @param ... Extra arguments passed to \code{print} and \code{summary}. 41 | #' @return \item{bts}{Multivariate time series contains the bottom level 42 | #' series} \item{groups}{Information about the groups of a grouped time series} 43 | #' \item{labels}{Information about the labels that are used for plotting.} 44 | #' @author Earo Wang and Rob J Hyndman 45 | #' @seealso \code{\link[hts]{hts}}, \code{\link[hts]{accuracy.gts}}, 46 | #' \code{\link[hts]{forecast.gts}}, \code{\link[hts]{plot.gts}} 47 | #' @references Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. 48 | #' (2011). Optimal combination forecasts for hierarchical time series. 49 | #' \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 50 | #' \url{https://robjhyndman.com/publications/hierarchical/} 51 | #' @keywords ts 52 | #' @examples 53 | #' 54 | #' # Example 1 illustrating the usage of the "groups" argument 55 | #' abc <- ts(5 + matrix(sort(rnorm(1600)), ncol = 16, nrow = 100)) 56 | #' sex <- rep(c("female", "male"), each = 8) 57 | #' state <- rep(c("NSW", "VIC", "QLD", "SA", "WA", "NT", "ACT", "TAS"), 2) 58 | #' gc <- rbind(sex, state) # a matrix consists of strings. 59 | #' gn <- rbind(rep(1:2, each = 8), rep(1:8, 2)) # a numerical matrix 60 | #' rownames(gc) <- rownames(gn) <- c("Sex", "State") 61 | #' x <- gts(abc, groups = gc) 62 | #' y <- gts(abc, groups = gn) 63 | #' 64 | #' # Example 2 with two simple hierarchies (geography and product) to show the argument "characters" 65 | #' bnames1 <- c("VICMelbAA", "VICMelbAB", "VICGeelAA", "VICGeelAB", 66 | #' "VICMelbBA", "VICMelbBB", "VICGeelBA", "VICGeelBB", 67 | #' "NSWSyndAA", "NSWSyndAB", "NSWWollAA", "NSWWollAB", 68 | #' "NSWSyndBA", "NSWSyndBB", "NSWWollBA", "NSWWollBB") 69 | #' bts1 <- matrix(ts(rnorm(160)), ncol = 16) 70 | #' colnames(bts1) <- bnames1 71 | #' x1 <- gts(bts1, characters = list(c(3, 4), c(1, 1))) 72 | #' 73 | #' # Example 3 with a non-hierarchical grouped time series of 3 grouping variables (state, age and sex) 74 | #' bnames2 <- c("VIC1F", "VIC1M", "VIC2F", "VIC2M", "VIC3F", "VIC3M", 75 | #' "NSW1F", "NSW1M", "NSW2F", "NSW2M", "NSW3F", "NSW3M") 76 | #' bts2 <- matrix(ts(rnorm(120)), ncol = 12) 77 | #' colnames(bts2) <- bnames2 78 | #' x2 <- gts(bts2, characters = c(3, 1, 1)) 79 | #' 80 | #' @export 81 | gts <- function(y, groups, gnames = rownames(groups), characters) { 82 | # Construct the grouped time series. 83 | # 84 | # Args: 85 | # y*: The bottom time series assigned by the user. 86 | # groups: A matrix contains the distinctive No. for each group at each row. 87 | # gnames: Specify the group names. 88 | # characters: Specify how to split the bottom names in order to generate 89 | # the grouping matrix 90 | # 91 | # Returns: 92 | # A grouped time series. 93 | # 94 | # Error handling: 95 | if (!is.ts(y)) { 96 | y <- stats::as.ts(y) 97 | } 98 | 99 | if (ncol(y) <= 1L) { 100 | stop("Argument y must be a multivariate time series.", call. = FALSE) 101 | } 102 | bnames <- colnames(y) 103 | nc.y <- ncol(y) 104 | if (missing(characters)) { 105 | if (missing(groups)) { 106 | groups <- matrix(c(rep(1L, nc.y), seq(1L, nc.y)), nrow = 2L, 107 | byrow = TRUE) 108 | } else if (!is.matrix(groups)) { 109 | stop("Argument groups must be a matrix.", call. = FALSE) 110 | } else if (!is.character(groups[1L, ])) { # Check groups numeric matrix 111 | if (all(groups[1L, ] == 1L)) { # if the first row is all 1's 112 | groups <- groups[-1L, , drop = FALSE] 113 | } 114 | tmp.last <- nrow(groups) 115 | if (all(groups[tmp.last, ] == seq(1L, nc.y))) { # if the last row is a seq 116 | groups <- groups[-tmp.last, , drop = FALSE] 117 | } 118 | } 119 | # Check whether groups is unique 120 | # But R takes so long to check due to the inefficiency with strings 121 | # bgroup <- unique(apply(groups, 2, paste, collapse = "")) 122 | # if (ncol(groups) != ncol(y) && length(bgroup) != ncol(y)) { 123 | # stop("Argument groups is misspecified.") 124 | # } 125 | } else { 126 | if (length(characters) == 1L) { 127 | stop("The argument characters must have length greater than one.", call. = FALSE) 128 | } 129 | if (!all(nchar(bnames)[1L] == nchar(bnames)[-1L])) { 130 | stop("The bottom names must be of the same length.", call. = FALSE) 131 | } 132 | if (any(nchar(bnames) != sum(unlist(characters)))) { 133 | warning("The argument characters is not fully specified for the bottom names.") 134 | } 135 | groups <- CreateGmat(bnames, characters) 136 | } 137 | # Construct gmatrix 138 | gmat <- GmatrixG(groups) # GmatrixG() defined below 139 | 140 | # Construct gnames 141 | nr.gmat <- nrow(gmat) 142 | if (nr.gmat == 2L) { 143 | name.list <- NULL 144 | } else if (is.null(gnames)) { 145 | message("Argument gnames is missing and the default labels are used.") 146 | gnames <- paste0("G", 1L:(nr.gmat - 2L)) 147 | } 148 | colnames(gmat) <- bnames 149 | rownames(gmat) <- c("Total", gnames, "Bottom") 150 | 151 | # Keep the names at each group 152 | if (nr.gmat > 2L) { 153 | times <- Mlevel(groups) 154 | full.groups <- mapply(rep, as.list(gnames), times, SIMPLIFY = FALSE) 155 | subnames <- apply(groups, 1, unique) 156 | if (is.matrix(subnames)) { 157 | # Convert a matrix to a list 158 | subnames <- split(subnames, rep(1L:ncol(subnames), each = nrow(subnames))) 159 | } 160 | name.list <- mapply(paste0, full.groups, "/", subnames, SIMPLIFY = FALSE) 161 | names(name.list) <- gnames 162 | } 163 | 164 | return(structure( 165 | list(bts = y, groups = gmat, labels = name.list), 166 | class = c("gts") 167 | )) 168 | } 169 | 170 | 171 | #' @rdname helper-functions 172 | #' @export 173 | get_groups <- function(y) { 174 | if(all(is.hts(y) && is.gts(y))) stop("'y' must be grouped time series.", call. = FALSE) 175 | return(y$groups) 176 | } 177 | 178 | 179 | # A function to convert groups to gmatrix 180 | GmatrixG <- function(xmat) { 181 | if (is.character(xmat)) { 182 | # Convert character to integer 183 | gmat <- t(apply(xmat, 1, function(x) as.integer(factor(x, unique(x))))) 184 | } else { 185 | gmat <- xmat 186 | } 187 | # Insert the first & last rows 188 | nc.xmat <- ncol(xmat) 189 | gmat <- rbind( 190 | if (all(gmat[1,] == rep(1L, nc.xmat))) NULL else rep(1L, nc.xmat), 191 | gmat, 192 | if (all(gmat[NROW(gmat),] == seq(1L, nc.xmat))) NULL else seq(1L, nc.xmat) 193 | ) 194 | #gmat <- gmat[!duplicated(gmat), , drop = FALSE] # Remove possible duplicated... make smarter above. 195 | return(structure(gmat, class = "gmatrix")) 196 | } 197 | 198 | 199 | # A function to calculate No. of groups at each level 200 | Mlevel <- function(xgroup) { 201 | m <- apply(xgroup, 1, function(x) length(unique(x))) 202 | return(m) 203 | } 204 | 205 | 206 | # A function to get the inverse of row sums of S matrix 207 | InvS4g <- function(xgroup) { 208 | mlevel <- Mlevel(xgroup) 209 | len <- length(mlevel) 210 | repcount <- mlevel[len]/mlevel 211 | inv.s <- 1/unlist(mapply(rep, repcount, mlevel, SIMPLIFY = FALSE)) 212 | return(inv.s) 213 | } 214 | 215 | 216 | # A function to generate the gmatrix based on bottom names 217 | CreateGmat <- function(bnames, characters) { 218 | total.len <- length(characters) 219 | sub.len <- c(0L, lapply(characters, length)) 220 | cs <- cumsum(unlist(sub.len)) 221 | int.char <- unlist(characters) 222 | end <- cumsum(int.char) 223 | start <- end - int.char + 1L 224 | tmp.token <- sapply(bnames, function(x) substring(x, start, end)) 225 | # Grab the individual group 226 | token <- vector(length = total.len, mode = "list") 227 | for (i in 1L:total.len) { 228 | token[[i]] <- matrix(, nrow = sub.len[[i + 1L]], ncol = ncol(tmp.token)) 229 | } 230 | for (i in 1L:total.len) { 231 | token[[i]][1L, ] <- tmp.token[cs[i] + 1L, ] 232 | if (sub.len[[i + 1L]] >= 2L) { 233 | for (j in 2L:sub.len[[i + 1L]]) { 234 | token[[i]][j, ] <- paste0(token[[i]][j - 1L, ], tmp.token[cs[i] + j, ]) 235 | } 236 | } 237 | } 238 | # Take combinations of any two groups 239 | cn <- combn(1L:total.len, 2) 240 | ncl <- ncol(cn) 241 | groups <- vector(length = ncl, mode = "list") 242 | for (i in 1L:ncl) { 243 | bigroups <- list(token[[cn[, i][1L]]], token[[cn[, i][2L]]]) 244 | nr1 <- nrow(bigroups[[1L]]) 245 | nr2 <- nrow(bigroups[[2L]]) 246 | nr <- nr1 * nr2 247 | tmp.groups <- vector(length = nr1, mode = "list") 248 | for (j in 1L:nr1) { 249 | tmp.groups[[j]] <- paste0(bigroups[[1L]][j, ], bigroups[[2L]][1L, ]) 250 | if (nr2 >= 2L) { 251 | for (k in 2L:nr2) { 252 | tmp.groups[[j]] <- rbind(tmp.groups[[j]], paste0(bigroups[[1L]][j, ], 253 | bigroups[[2L]][k, ])) 254 | } 255 | } 256 | } 257 | groups[[i]] <- tmp.groups[[1L]] 258 | if (nr1 >= 2L) { 259 | for (h in 2L:nr1) { 260 | groups[[i]] <- rbind(groups[[i]], tmp.groups[[h]]) 261 | } 262 | } 263 | } 264 | # Combine the individual ones and their combinations 265 | new.list <- c(token, groups) 266 | gmatrix <- new.list[[1L]] 267 | for (i in 2L:length(new.list)) { 268 | gmatrix <- rbind(gmatrix, new.list[[i]]) 269 | } 270 | gmatrix <- gmatrix[!duplicated(gmatrix), , drop = FALSE] 271 | # Remove bottom names if it has 272 | check <- try(which(gmatrix == bnames, arr.ind = TRUE)[1L, 1L], silent = TRUE) 273 | if (!inherits(check, "try-error")) { 274 | gmatrix <- gmatrix[-check, ] 275 | } 276 | return(gmatrix) 277 | } 278 | 279 | #' @rdname gts-class 280 | #' @param xts \code{gts} object. 281 | #' @export 282 | # A function to check whether it's the "gts" class. 283 | is.gts <- function(xts) { 284 | is.element("gts", class(xts)) 285 | } 286 | 287 | #' @rdname gts-class 288 | #' @param x \code{gts} object. 289 | #' @method print gts 290 | #' @export 291 | #' @export print.gts 292 | # Print "gts" on the screen 293 | print.gts <- function(x, ...) { 294 | cat("Grouped Time Series \n") 295 | nlevels <- Mlevel(x$groups) 296 | cat(length(nlevels), "Levels \n") 297 | cat("Number of groups at each level:", nlevels, "\n") 298 | cat("Total number of series:", sum(nlevels), "\n") 299 | 300 | if (is.null(x$histy)) { # Original series 301 | cat("Number of observations per series:", nrow(x$bts), "\n") 302 | cat("Top level series: \n") 303 | } else { 304 | cat("Number of observations in each historical series:", 305 | nrow(x$histy), "\n") 306 | cat("Number of forecasts per series:", nrow(x$bts), "\n") 307 | cat("Top level series of forecasts: \n") 308 | } 309 | topts <- ts(rowSums(x$bts), start = stats::tsp(x$bts)[1L], 310 | frequency = stats::tsp(x$bts)[3L]) 311 | print(topts) 312 | } 313 | 314 | #' @rdname gts-class 315 | #' @param object \code{gts} object. 316 | #' @method summary gts 317 | #' @export 318 | #' @export summary.gts 319 | summary.gts <- function(object, ...) { 320 | print(object) 321 | if (is.null(object$histy)) { 322 | cat("\n") 323 | cat("Labels: \n") 324 | print(names(object$labels)) 325 | } else { 326 | method <- switch(object$method, 327 | comb = "Optimal combination forecasts", 328 | bu = "Bottom-up forecasts", 329 | mo = "Middle-out forecasts", 330 | tdgsa = "Top-down forecasts based on the average historical proportions", 331 | tdgsf = "Top-down forecasts based on the proportion of historical averages", 332 | tdfp = "Top-down forecasts using forecasts proportions") 333 | fmethod <- switch(object$fmethod, ets = "ETS", arima = "Arima", 334 | rw = "Random walk") 335 | cat("\n") 336 | cat(paste("Method:", method), "\n") 337 | cat(paste("Forecast method:", fmethod), "\n") 338 | if (!is.null(object$fitted)) { 339 | cat("In-sample error measures at the bottom level: \n") 340 | print(accuracy.gts(object)) 341 | } 342 | } 343 | } 344 | -------------------------------------------------------------------------------- /R/forecast-gts.R: -------------------------------------------------------------------------------- 1 | #' Forecast a hierarchical or grouped time series 2 | #' 3 | #' Methods for forecasting hierarchical or grouped time series. 4 | #' 5 | #' Base methods implemented include ETS, ARIMA and the naive (random walk) 6 | #' models. Forecasts are distributed in the hierarchy using bottom-up, 7 | #' top-down, middle-out and optimal combination methods. 8 | #' 9 | #' Three top-down methods are available: the two Gross-Sohl methods and the 10 | #' forecast-proportion approach of Hyndman, Ahmed, and Athanasopoulos (2011). 11 | #' The "middle-out" method \code{"mo"} uses bottom-up (\code{"bu"}) for levels 12 | #' higher than \code{level} and top-down forecast proportions (\code{"tdfp"}) 13 | #' for levels lower than \code{level}. 14 | #' 15 | #' For non-hierarchical grouped data, only bottom-up and combination methods 16 | #' are possible, as any method involving top-down disaggregation requires a 17 | #' hierarchical ordering of groups. 18 | #' 19 | #' When \code{xreg} and \code{newxreg} are passed, the same covariates are 20 | #' applied to every series in the hierarchy. 21 | #' 22 | #' The \code{control.nn} argument is a list that can supply any of the following components: 23 | #' \describe{ 24 | #' \item{\code{ptype}}{Permutation method to be used: \code{"fixed"} or \code{"random"}. Defaults to \code{"fixed"}.} 25 | #' \item{\code{par}}{The number of full exchange rules that may be tried. Defaults to 10.} 26 | #' \item{\code{gtol}}{The tolerance of the convergence criteria. Defaults to \code{sqrt(.Machine$double.eps)}.} 27 | #' } 28 | #' 29 | #' @aliases forecast.gts forecast.hts 30 | #' @param object Hierarchical or grouped time series object of class 31 | #' \code{{gts}} 32 | #' @param h Forecast horizon 33 | #' @param method Method for distributing forecasts within the hierarchy. See 34 | #' details 35 | #' @param weights Weights used for "optimal combination" method: 36 | #' \code{weights="ols"} uses an unweighted combination (as described in Hyndman 37 | #' et al 2011); \code{weights="wls"} uses weights based on forecast variances 38 | #' (as described in Hyndman et al 2016); \code{weights="mint"} uses a full 39 | #' covariance estimate to determine the weights (as described in Wickramasuriya et al 40 | #' 2019); \code{weights="nseries"} uses weights based on the number of series 41 | #' aggregated at each node. 42 | #' @param fmethod Forecasting method to use for each series. 43 | #' @param algorithms An algorithm to be used for computing the combination 44 | #' forecasts (when \code{method=="comb"}). The combination forecasts are based 45 | #' on an ill-conditioned regression model. "lu" indicates LU decomposition is 46 | #' used; "cg" indicates a conjugate gradient method; "chol" corresponds to a 47 | #' Cholesky decomposition; "recursive" indicates the recursive hierarchical 48 | #' algorithm of Hyndman et al (2016); "slm" uses sparse linear regression. Note 49 | #' that \code{algorithms = "recursive"} and \code{algorithms = "slm"} cannot be 50 | #' used if \code{weights="mint"}. 51 | #' @param covariance Type of the covariance matrix to be used with 52 | #' \code{weights="mint"}: either a shrinkage estimator (\code{"shr"}) with 53 | #' shrinkage towards the diagonal; or a sample covariance matrix 54 | #' (\code{"sam"}). 55 | #' @param nonnegative Logical. Should the reconciled forecasts be non-negative? 56 | #' @param control.nn A list of control parameters to be passed on to the 57 | #' block principal pivoting algorithm. See 'Details'. 58 | #' @param keep.fitted If \code{TRUE}, keep fitted values at the bottom level. 59 | #' @param keep.resid If \code{TRUE}, keep residuals at the bottom level. 60 | #' @param positive If \code{TRUE}, forecasts are forced to be strictly positive (by 61 | #' setting \code{lambda=0}). 62 | #' @param lambda Box-Cox transformation parameter. 63 | #' @param level Level used for "middle-out" method (only used when \code{method 64 | #' = "mo"}). 65 | #' @param FUN A user-defined function that returns an object which can be 66 | #' passed to the \code{forecast} function. It is applied to all series in order 67 | #' to generate base forecasts. When \code{FUN} is not \code{NULL}, 68 | #' \code{fmethod}, \code{positive} and \code{lambda} are all ignored. Suitable 69 | #' values for \code{FUN} are \code{\link[forecast]{tbats}} and 70 | #' \code{\link[forecast]{stlf}} for example. 71 | #' @param xreg When \code{fmethod = "arima"}, a vector or matrix of external 72 | #' regressors used for modelling, which must have the same number of rows as 73 | #' the original univariate time series 74 | #' @param newxreg When \code{fmethod = "arima"}, a vector or matrix of external 75 | #' regressors used for forecasting, which must have the same number of rows as 76 | #' the \code{h} forecast horizon 77 | #' @param parallel If \code{TRUE}, import \code{parallel} package to allow parallel 78 | #' processing. 79 | #' @param num.cores If \code{parallel = TRUE}, specify how many cores are going to be 80 | #' used. 81 | #' @param ... Other arguments passed to \code{\link[forecast]{ets}}, 82 | #' \code{\link[forecast]{auto.arima}} or \code{FUN}. 83 | #' @return A forecasted hierarchical/grouped time series of class \code{gts}. 84 | #' @note In-sample fitted values and resiuals are not returned if \code{method = "comb"} and \code{nonnegative = TRUE}. 85 | #' @author Earo Wang, Rob J Hyndman and Shanika L Wickramasuriya 86 | #' @seealso \code{\link[hts]{hts}}, \code{\link[hts]{gts}}, 87 | #' \code{\link[hts]{plot.gts}}, \code{\link[hts]{accuracy.gts}} 88 | #' @references Athanasopoulos, G., Ahmed, R. A., & Hyndman, R. J. (2009). 89 | #' Hierarchical forecasts for Australian domestic tourism, \emph{International 90 | #' Journal of Forecasting}, \bold{25}, 146-166. 91 | #' 92 | #' Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L. (2011). Optimal 93 | #' combination forecasts for hierarchical time series. \emph{Computational 94 | #' Statistics and Data Analysis}, \bold{55}(9), 2579--2589. 95 | #' \url{https://robjhyndman.com/publications/hierarchical/} 96 | #' 97 | #' Hyndman, R. J., Lee, A., & Wang, E. (2016). Fast computation of reconciled 98 | #' forecasts for hierarchical and grouped time series. \emph{Computational 99 | #' Statistics and Data Analysis}, \bold{97}, 16--32. 100 | #' \url{https://robjhyndman.com/publications/hgts/} 101 | #' 102 | #' Wickramasuriya, S. L., Athanasopoulos, G., & Hyndman, R. J. (2019). 103 | #' Optimal forecast reconciliation for hierarchical and grouped time series through trace minimization. 104 | #' \emph{Journal of the American Statistical Association}, \bold{114}(526), 804--819. \url{https://robjhyndman.com/publications/mint/} 105 | #' 106 | #' Wickramasuriya, S. L., Turlach, B. A., & Hyndman, R. J. (to appear). Optimal non-negative forecast reconciliation. 107 | #' \emph{Statistics and Computing}. \url{https://robjhyndman.com/publications/nnmint/} 108 | #' 109 | #' Gross, C., & Sohl, J. (1990). Dissagregation methods to expedite product 110 | #' line forecasting, \emph{Journal of Forecasting}, \bold{9}, 233--254. 111 | #' @keywords ts 112 | #' @method forecast gts 113 | #' @examples 114 | #' 115 | #' forecast(htseg1, h = 10, method = "bu", fmethod = "arima") 116 | #' 117 | #' \dontrun{ 118 | #' forecast( 119 | #' htseg2, h = 10, method = "comb", algorithms = "lu", 120 | #' FUN = function(x) tbats(x, use.parallel = FALSE) 121 | #' ) 122 | #' } 123 | #' 124 | #' @export 125 | #' @export forecast.gts 126 | forecast.gts <- function( 127 | object, 128 | h = ifelse(frequency(object$bts) > 1L, 2L * frequency(object$bts), 10L), 129 | method = c("comb", "bu", "mo","tdgsa", "tdgsf", "tdfp"), 130 | weights = c("wls", "ols", "mint", "nseries"), 131 | fmethod = c("ets", "arima", "rw"), 132 | algorithms = c("lu", "cg", "chol", "recursive", "slm"), 133 | covariance = c("shr", "sam"), 134 | nonnegative = FALSE, control.nn = list(), 135 | keep.fitted = FALSE, keep.resid = FALSE, 136 | positive = FALSE, lambda = NULL, level, FUN = NULL, 137 | xreg = NULL, newxreg = NULL, parallel = FALSE, num.cores = 2, ... 138 | ) { 139 | # Forecast hts or gts objects 140 | # 141 | # Args: 142 | # object*: Only hts/gts can be passed onto this function. 143 | # h: h-step forecasts. 144 | # method: Aggregated approaches. 145 | # fmethod: Forecast methods. 146 | # keep: Users specify what they'd like to keep at the bottom level. 147 | # positive & lambda: Use Box-Cox transformation. 148 | # level: Specify level for the middle-out approach, starting with level 0. 149 | # 150 | # Return: 151 | # Point forecasts with other info chosen by the user. 152 | method <- match.arg(method) 153 | # Recode old weights arguments 154 | if(length(weights)==1L) 155 | { 156 | if(weights=="sd") 157 | weights <- "wls" 158 | else if(weights=="none") 159 | weights <- "ols" 160 | } 161 | weights <- match.arg(weights) 162 | covariance <- match.arg(covariance) 163 | alg <- match.arg(algorithms) 164 | if (is.null(FUN)) { 165 | fmethod <- match.arg(fmethod) 166 | } 167 | # Error Handling: 168 | if (!is.gts(object)) { 169 | stop("Argument object must be either a hts or gts object.", call. = FALSE) 170 | } 171 | if (h < 1L) { 172 | stop("Argument h must be positive.", call. = FALSE) 173 | } 174 | if (!is.hts(object) && 175 | is.element(method, c("mo", "tdgsf", "tdgsa", "tdfp"))) { 176 | stop("Argument method is not appropriate for a non-hierarchical time series.", call. = FALSE) 177 | } 178 | if (method == "mo" && missing(level)) { 179 | stop("Please specify argument level for the middle-out method.", call. = FALSE) 180 | } 181 | if (is.element(method, c("bu", "mo","tdgsa", "tdgsf", "tdfp")) && nonnegative) { 182 | stop("Non-negative algorithm is only implemented for combination forecasts.", call. = FALSE) 183 | } 184 | 185 | # Set up lambda for arg "positive" when lambda is missing 186 | if (is.null(lambda)) { 187 | if (positive) { 188 | if (any(object$bts <= 0L, na.rm=FALSE)) { 189 | stop("All data must be positive.", call. = FALSE) 190 | } else { 191 | lambda <- 0 192 | } 193 | } else { 194 | lambda <- NULL 195 | } 196 | } 197 | 198 | # Remember the original keep.fitted argument for later 199 | keep.fitted0 <- keep.fitted 200 | if (method=="comb" && (weights == "mint" || weights == "wls")) { 201 | keep.fitted <- TRUE 202 | } 203 | 204 | # Set up "level" for middle-out 205 | if (method == "mo") { 206 | len <- length(object$nodes) 207 | if (level < 0L || level > len) { 208 | stop("Argument level is out of the range.", call. = FALSE) 209 | } else if (level == 0L) { 210 | method <- "tdfp" 211 | } else if (level == len) { 212 | method <- "bu" 213 | } else { 214 | mo.nodes <- object$nodes[level:len] 215 | level <- seq(level, len) 216 | } 217 | } 218 | 219 | # Set up forecast methods 220 | if (any(method == c("comb", "tdfp"))) { # Combination or tdfp 221 | y <- aggts(object) # Grab all ts 222 | } else if (method == "bu") { # Bottom-up approach 223 | y <- object$bts # Only grab the bts 224 | } else if (any(method == c("tdgsa", "tdgsf")) && method != "tdfp") { 225 | y <- aggts(object, levels = 0) # Grab the top ts 226 | } else if (method == "mo") { 227 | y <- aggts(object, levels = level) 228 | } 229 | 230 | # loop function to grab pf, fitted, resid 231 | loopfn <- function(x, ...) { 232 | out <- list() 233 | if (is.null(FUN)) { 234 | if (fmethod == "ets") { 235 | models <- ets(x, lambda = lambda, ...) 236 | out$pfcasts <- forecast(models, h = h, PI = FALSE)$mean 237 | } else if (fmethod == "arima") { 238 | models <- auto.arima(x, lambda = lambda, xreg = xreg, 239 | parallel = FALSE, ...) 240 | out$pfcasts <- forecast(models, h = h, xreg = newxreg)$mean 241 | } else if (fmethod == "rw") { 242 | models <- rwf(x, h = h, lambda = lambda, ...) 243 | out$pfcasts <- models$mean 244 | } 245 | } else { # user defined function to produce point forecasts 246 | models <- FUN(x, ...) 247 | if (is.null(newxreg)) { 248 | out$pfcasts <- forecast(models, h = h)$mean 249 | } else { 250 | out$pfcasts <- forecast(models, h = h, xreg = newxreg)$mean 251 | } 252 | } 253 | if (keep.fitted) { 254 | out$fitted <- stats::fitted(models) 255 | } 256 | if (keep.resid) { 257 | out$resid <- stats::residuals(models) 258 | } 259 | return(out) 260 | } 261 | 262 | if (parallel) { # parallel == TRUE 263 | if (is.null(num.cores)) { 264 | num.cores <- detectCores() 265 | } 266 | # Parallel start new process 267 | lambda <- lambda 268 | xreg <- xreg 269 | newxreg <- newxreg 270 | cl <- makeCluster(num.cores) 271 | loopout <- parSapplyLB(cl = cl, X = y, FUN = function(x) loopfn(x, ...), 272 | simplify = FALSE) 273 | stopCluster(cl = cl) 274 | } else { # parallel = FALSE 275 | loopout <- lapply(y, function(x) loopfn(x, ...)) 276 | } 277 | 278 | pfcasts <- sapply(loopout, function(x) x$pfcasts) 279 | 280 | if (any(pfcasts < 0) && nonnegative) { 281 | pfcasts[pfcasts < 0] <- 0 282 | warning("Negative base forecasts are truncated to zero.") 283 | } 284 | 285 | if (keep.fitted) { 286 | fits <- sapply(loopout, function(x) x$fitted) 287 | } 288 | if (keep.resid) { 289 | resid <- sapply(loopout, function(x) x$resid) 290 | } 291 | 292 | if (is.vector(pfcasts)) { # if h = 1, sapply returns a vector 293 | pfcasts <- t(pfcasts) 294 | } 295 | 296 | # Set up basic info 297 | tsp.y <- stats::tsp(y) 298 | bnames <- colnames(object$bts) 299 | 300 | if (method == "comb") { # Assign class 301 | class(pfcasts) <- class(object) 302 | if (keep.fitted) { 303 | class(fits) <- class(object) 304 | } 305 | if (keep.resid) { 306 | class(resid) <- class(object) 307 | } 308 | if (weights == "nseries") { 309 | if (is.hts(object)) { 310 | wvec <- InvS4h(object$nodes) 311 | } else { 312 | wvec <- InvS4g(object$groups) 313 | } 314 | } else if (weights == "wls") { 315 | tmp.resid <- y - fits # it ensures resids are additive errors 316 | wvec <- 1/colMeans(tmp.resid^2, na.rm = TRUE) 317 | } 318 | else if (weights == "mint") { 319 | tmp.resid <- stats::na.omit(y - fits) 320 | } 321 | } 322 | 323 | # An internal function to call combinef correctly 324 | Comb <- function(x, ...) { 325 | if (is.hts(x)) { 326 | return(combinef(x, nodes = object$nodes, ... )) 327 | } else { 328 | return(combinef(x, groups = object$groups, ...)) 329 | } 330 | } 331 | 332 | # An internal function to call MinT correctly 333 | mint <- function(x, ...) { 334 | if (is.hts(x)) { 335 | return(MinT(x, nodes = object$nodes, ... )) 336 | } else { 337 | return(MinT(x, groups = object$groups, ...)) 338 | } 339 | } 340 | 341 | if (method == "comb") { 342 | if (weights == "ols") { 343 | bfcasts <- Comb(pfcasts, nonnegative = nonnegative, 344 | parallel = parallel, num.cores = num.cores, 345 | keep = "bottom", algorithms = alg, control.nn = control.nn) 346 | } else if (any(weights == c("wls", "nseries"))) { 347 | bfcasts <- Comb(pfcasts, weights = wvec, nonnegative = nonnegative, 348 | parallel = parallel, num.cores = num.cores, 349 | keep = "bottom", algorithms = alg, control.nn = control.nn) 350 | } else { # weights=="mint" 351 | bfcasts <- mint(pfcasts, residual = tmp.resid, 352 | covariance = covariance, nonnegative = nonnegative, 353 | parallel = parallel, num.cores = num.cores, 354 | keep = "bottom", algorithms = alg, control.nn = control.nn) 355 | } 356 | if (keep.fitted0 && !nonnegative) { 357 | if (weights == "ols") { 358 | fits <- Comb(fits, keep = "bottom", algorithms = alg) 359 | } else if (any(weights == c("wls", "nseries"))) { 360 | fits <- Comb(fits, weights = wvec, keep = "bottom", 361 | algorithms = alg) 362 | } else if(weights=="mint") { 363 | fits <- mint(fits, residual = tmp.resid, 364 | covariance = covariance, keep = "bottom", algorithms = alg) 365 | } 366 | } 367 | if (keep.resid && !nonnegative) { 368 | if (weights == "ols") { 369 | resid <- Comb(resid, keep = "bottom", algorithms = alg) 370 | } else if (any(weights == c("wls", "nseries"))) { 371 | resid <- Comb(resid, weights = wvec, keep = "bottom", 372 | algorithms = alg) 373 | } else if (weights=="mint") { 374 | resid <- mint(resid, residual = tmp.resid, 375 | covariance = covariance, keep = "bottom", algorithms = alg) 376 | } 377 | } 378 | } else if (method == "bu") { 379 | bfcasts <- pfcasts 380 | } else if (method == "tdgsa") { 381 | bfcasts <- TdGsA(pfcasts, object$bts, y) 382 | if (keep.fitted0) { 383 | fits <- TdGsA(fits, object$bts, y) 384 | } 385 | if (keep.resid) { 386 | resid <- TdGsA(resid, object$bts, y) 387 | } 388 | } else if (method == "tdgsf") { 389 | bfcasts <- TdGsF(pfcasts, object$bts, y) 390 | if (keep.fitted0) { 391 | fits <- TdGsF(fits, object$bts, y) 392 | } 393 | if (keep.resid) { 394 | resid <- TdGsF(resid, object$bts, y) 395 | } 396 | } else if (method == "tdfp") { 397 | bfcasts <- TdFp(pfcasts, object$nodes) 398 | if (keep.fitted0) { 399 | fits <- TdFp(fits, object$nodes) 400 | } 401 | if (keep.resid) { 402 | resid <- TdFp(resid, object$nodes) 403 | } 404 | } else if (method == "mo") { 405 | bfcasts <- MiddleOut(pfcasts, mo.nodes) 406 | if (keep.fitted0) { 407 | fits <- MiddleOut(fits, mo.nodes) 408 | } 409 | if (keep.resid) { 410 | resid <- MiddleOut(resid, mo.nodes) 411 | } 412 | } 413 | 414 | # In case that accuracy.gts() is called later, since NA's have been omitted 415 | # to ensure slm/chol to run without errors. 416 | if (method == "comb" && fmethod == "rw" && !nonnegative 417 | && keep.fitted0 == TRUE && (alg == "slm" || alg == "chol")) { 418 | fits <- rbind(rep(NA, ncol(fits)), fits) 419 | } 420 | 421 | bfcasts <- ts(bfcasts, start = tsp.y[2L] + 1L/tsp.y[3L], 422 | frequency = tsp.y[3L]) 423 | colnames(bfcasts) <- bnames 424 | class(bfcasts) <- class(object$bts) 425 | attr(bfcasts, "msts") <- attr(object$bts, "msts") 426 | 427 | if (keep.fitted0 && !nonnegative) { 428 | bfits <- ts(fits, start = tsp.y[1L], frequency = tsp.y[3L]) 429 | colnames(bfits) <- bnames 430 | } 431 | if (keep.resid && !nonnegative) { 432 | bresid <- ts(resid, start = tsp.y[1L], frequency = tsp.y[3L]) 433 | colnames(bresid) <- bnames 434 | } 435 | 436 | # Output 437 | out <- list(bts = bfcasts, histy = object$bts, labels = object$labels, 438 | method = method, fmethod = fmethod) 439 | if (keep.fitted0 && !nonnegative) { 440 | out$fitted <- bfits 441 | } 442 | if (keep.resid && !nonnegative) { 443 | out$residuals <- bresid 444 | } 445 | if (is.hts(object)) { 446 | out$nodes <- object$nodes 447 | } else { 448 | out$groups <- object$groups 449 | } 450 | 451 | return(structure(out, class = class(object))) 452 | } 453 | --------------------------------------------------------------------------------