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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
| > SubRegressionBased <- function(y_l, X, n.bc, n.fc, conversion = "sum",
+ method = "chow-lin-maxlog", fr = 4,
+ truncated.rho = 0,
+ fixed.rho = 0.5, tol = 1e-16,
+ lower = -0.999, upper = 0.999){
# performs temporal disaggregation for regression based methods
# Args:
# y_l: vector of the low-frequency left-hand side variable
# X: matrix of high-frequency indicators
# conversion: type of conversion ("sum", "average", "first", "last")
# method: method
# fixed.rho: set a predefined rho
# fr: ratio of high-frequency units per low-frequency unit
# tol: desired accuracy, passed on to optim()
# lower, upper: scalar indicating the limits of the rho parameter
# Returns:
# A list, containing the output of CalcGLS() and the following elements:
# values vector, interpolated (and extrapolated) high frequency
# series
# fitted.values vector, low-frequency residuals fitted values of the
# regression
# p vector, preliminary high frequency series
# residuals vector, low-frequency residuals
# rho scalar, autoregressive parameter
# truncated logical, whether rho has been truncated to 0
# dimensions of y_l and X
+ n_l <- length(y_l)
+ n <- dim(X)[1]
+ m <- dim(X)[2]
# conversion matrix expanded with zeros
+ C <- CalcC(n_l, conversion, fr, n.bc = n.bc, n.fc = n.fc)
+ pm <- CalcPowerMatrix(n)
# sanity test
+ stopifnot(identical(dim(C)[2], dim(X)[1]))
# aggregated values
+ X_l <- C %*% X
+ truncated <- FALSE
+ if (method == "chow-lin-maxlog"){
+ Objective <- function(rho){
+ -CalcGLS(y = y_l, X = X_l, vcov = C%*%CalcQ(rho, pm)%*%t(C),
+ stats = FALSE)$logl
+ }
+ } else if (method == "chow-lin-minrss-ecotrim"){
+ Objective <- function(rho){
+ CalcGLS(y = y_l, X = X_l, vcov = C%*%CalcR(rho, pm)%*%t(C), logl = FALSE,
+ stats = FALSE)$rss
+ }
+ } else if (method == "chow-lin-minrss-quilis"){
+ Objective <- function(rho){
+ CalcGLS(y = y_l, X = X_l, vcov = C%*%CalcQ(rho, pm)%*%t(C), logl = FALSE,
+ stats = FALSE)$rss
+ }
+ } else if (method == "litterman-maxlog"){
+ Objective <- function(rho){
+ -CalcGLS(y = y_l, X = X_l, vcov = C%*%CalcQ_Lit(X, rho)%*%t(C),
+ stats = FALSE)$logl
+ }
+ } else if (method == "litterman-minrss"){
+ Objective <- function(rho){
+ CalcGLS(y = y_l, X = X_l, vcov = C%*%CalcQ_Lit(X, rho)%*%t(C),
+ logl = FALSE, stats = FALSE)$rss
+ }
+ }
+ if (method %in% c("chow-lin-maxlog", "chow-lin-minrss-ecotrim",
+ "chow-lin-minrss-quilis", "litterman-maxlog",
+ "litterman-minrss")){
+ optimize.results <- optimize(Objective, lower = lower , upper = upper, tol = tol,
+ maximum = FALSE)
+ rho <- optimize.results$minimum
+ if (rho < truncated.rho){
+ rho <- truncated.rho
+ truncated <- TRUE
+ }
+
+ } else if (method == "fernandez"){
+ rho <- 0
+ } else if (method == "ols"){
+ rho <- 0
+ } else if (method %in% c("chow-lin-fixed", "litterman-fixed")){
+ rho <- fixed.rho
+ }
+ if (method %in% c("fernandez", "litterman-maxlog", "litterman-minrss",
+ "litterman-fixed")){
+ Q <- CalcQ_Lit(X = X, rho = rho)
+ } else if (method %in% c("chow-lin-maxlog", "chow-lin-minrss-ecotrim",
+ "chow-lin-minrss-quilis", "chow-lin-fixed", "ols")){
+ Q <- CalcQ(rho = rho, pm = pm)
+ }
+
+ Q_l <- C %*% Q %*% t(C)
+
+ # final GLS estimation (aggregated)
+ z <- CalcGLS(y = y_l, X = X_l, vcov = Q_l)
+
+ # Check if X is singular
+ if(qr(X)$rank < min(dim(X))) {warning("\nX is singular!\n")}
+
+ # preliminary series
+ p <- as.numeric(X %*% z$coefficients)
+
+ # distribution matrix
+ D <- Q %*% t(C) %*% z$vcov_inv
+
+ # low frequency residuals
+ u_l <- as.numeric(y_l - C %*% p)
+
+ # final series
+ y <- as.numeric(p + D %*% u_l)
+
+ # output
+ z$vcov_inv <- NULL # no need to keep
+ z$values <- y
+ z$fitted.values <- C %*% p
+ z$p <- p
+ z$residuals <- u_l
+ z$rho <- rho
+ z$truncated <- truncated
+ z
+ } |
