-
Notifications
You must be signed in to change notification settings - Fork 36
/
smatrix.R
71 lines (69 loc) · 2.14 KB
/
smatrix.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
#' Summing matrix for hierarchical or grouped time series
#'
#' This function returns the summing matrix for a hierarchical or grouped time
#' series, as defined in Hyndman et al. (2011).
#'
#'
#' @param xts Hierarchical or grouped time series of class \code{gts}.
#' @return A numerical matrix.
#' @author Earo Wang
#' @seealso \code{\link[hts]{hts}}, \code{\link[hts]{gts}},
#' \code{\link[hts]{combinef}}
#' @references Hyndman, R. J., Ahmed, R. A., Athanasopoulos, G., & Shang, H. L.
#' (2011). Optimal combination forecasts for hierarchical time series.
#' \emph{Computational Statistics and Data Analysis}, \bold{55}(9), 2579--2589.
#' \url{https://robjhyndman.com/publications/hierarchical/}
#' @keywords ts
#' @examples
#'
#' smatrix(htseg1)
#'
#' @export smatrix
smatrix <- function(xts) {
# The summing matrix
#
# Args:
# xts: hts/gts
#
# Returns:
# S matrix in the dense mode
if (!is.gts(xts)) {
stop("Argument xts must be a gts object", call. = FALSE)
}
if (is.hts(xts)) {
gmat <- GmatrixH(xts$nodes)
} else {
gmat <- xts$groups
}
return(as.matrix(SmatrixM(gmat)))
}
# This function returns a sparse matrix supported by Matrix pkg
SmatrixM <- function(gmat) {
# Sparse matrices stored in coordinate format
# gmatrix contains all the information to generate smatrix
num.bts <- ncol(gmat)
sparse.S <- apply(gmat, 1L, function(x) {
ia <- as.integer(x)
ra <- as.integer(rep(1L, num.bts))
ja <- as.integer(1L:num.bts)
s <- sparseMatrix(i = ia, j = ja, x = ra)
})
sparse <- do.call("rbind", sparse.S)
return(sparse)
}
# This function returns a sparse matrix supported by SparseM pkg
Smatrix <- function(gmat) {
# Sparse matrices stored in coordinate format
# gmatrix contains all the information to generate smatrix
num.bts <- ncol(gmat)
sparse.S <- apply(gmat, 1L, function(x) {
ia <- as.integer(x)
uniq.g <- unique(ia)
ra <- as.integer(rep(1L, num.bts))
ja <- as.integer(1L:num.bts)
s <- as.matrix.csr(new("matrix.coo", ra = ra, ja = ja, ia = ia,
dimension = as.integer(c(length(uniq.g), num.bts))))
})
sparse <- do.call("rbind", sparse.S)
return(sparse)
}