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
+ } |
Partager