Added chosen values for tuning parameter lambda and kappa in output-list

DESCRIPTION

@@ -36,6 +36,6 @@ Config/testthat/edition: 3
 Encoding: UTF-8
 LazyData: true
 NeedsCompilation: Yes
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 URL: https://github.com/lehmasve/hdflex
 BugReports: https://github.com/lehmasve/hdflex/issues

R/stsc.R

@@ -9,11 +9,11 @@
 #' @param y A matrix of dimension `T * 1` or numeric vector of length `T`
 #' containing the observations of the target variable.
 #' @param X A matrix with `T` rows containing
-#' the lagged 'simple' signals in each column.
-#' Use NULL if no 'simple' signal shall be included.
+#' the lagged 'P' signals in each column.
+#' Use NULL if no 'P' signal shall be included.
 #' @param Ext_F A matrix with `T` rows containing
-#' external point forecasts for y in each column.
-#' Use NULL if no external point forecasts shall be included.
+#' (external) 'F' signals for y in each column.
+#' Use NULL if no (external) 'F' signal shall be included.
 #' @param sample_length An integer that denotes the number of observations used
 #' to initialize the observational variance and the coefficients' variance
 #' in the TV-C models.
@@ -33,7 +33,7 @@
 #' of RiskMetrics (Reuters, 1996).
 #' @param burn_in_tvc An integer value `>= 1` that denotes the number of
 #' observations used to 'initialize' the TV-C models.
-#' After 'burn_in_tvc' observations, the ranking for the candidate models
+#' After 'burn_in_tvc' observations, the ranking for the candidate forecasting models
 #' and aggregated predictive densities are resetted.
 #' `burn_in_tvc = 1` means no burn-in period is applied.
 #' @param bias A boolean to indicate whether the TVC-Models should
@@ -42,7 +42,7 @@
 #' take it 'as is' (FALSE -> constant intercept of 0.0).
 #' @param gamma_grid A numerical vector that contains discount factors
 #' between 0 and 1 to exponentially down-weight the past predictive performance
-#' of the candidate models.
+#' of the candidate forecasting models.
 #' @param psi_grid An integer vector that controls
 #' the (possible) sizes of the subsets.
 #' @param delta A numeric value between 0 and 1 denoting the discount factor
@@ -54,7 +54,7 @@
 #' aggregated predictive densities is resetted.
 #' `burn_in_dsc = 1` means no burn-in period is applied.
 #' @param method An integer of the set `1, 2, 3, 4, 5` that denotes
-#' the method used to rank the candidate models (TV-C models)
+#' the method used to rank the candidate forecasting models (TV-C models)
 #' and subset combinations according to their performance.
 #' Default is `method = 1` which ranks according to their
 #' generated sum of discounted predictive log-likelihoods (DPLLs),
@@ -66,7 +66,7 @@
 #' @param equal_weight A boolean that denotes whether equal weights are used to
 #' combine the candidate forecasts within a subset. If `FALSE`, the weights are
 #' calculated using the softmax-function on the ranking scores of
-#' the candidate models. The method proposed in Adaemmer et al (2023) uses
+#' the candidate forecasting models. The method proposed in Adaemmer et al (2023) uses
 #' equal weights to combine the candidate forecasts.
 #' @param incl An (optional) integer vector that denotes signals that
 #' must be included in the subset combinations. E.g. `incl = c(1, 3)`
@@ -91,8 +91,11 @@
 #' * (1) a vector with the first moments (point forecasts) of the STSC-Model,
 #' * (2) a vector with the second moments (variance) of the STSC-Model,
 #' * (3) a vector that contains the selected values for gamma,
-#' * (4) a vector that contains the selected values for psi and
-#' * (5) a matrix that indicates the selected signals for every point in time.
+#' * (4) a vector that contains the selected values for psi,
+#' * (5) a matrix that contains the selected signals,
+#' * (6) a matrix that contains the selected values for lambda and
+#' * (7) a matrix that contains the selected values for kappa
+#' for every point in time.
 #'
 #' @seealso \url{https://github.com/lehmasve/hdflex#readme}
 #' @author Philipp Adämmer, Sven Lehmann, Rainer Schüssler
@@ -550,27 +553,10 @@ stsc <- function(y,
   chosen_psi   <- para_grid[stsc_comb_mod + 1, 1]
   chosen_gamma <- para_grid[stsc_comb_mod + 1, 2]
 
-  # Create / Get Raw-Signal Names
-  if (!is.null(X)) {
-    if (!is.null(colnames(X))) {
-      x_names <- colnames(X)
-    } else {
-      x_names <- paste0("X", as.character(seq_len(ncol(X))))
-    }
-  }
-
-  # Create / Get Point-Forecast Names
-  if (!is.null(Ext_F)) {
-    if (!is.null(colnames(Ext_F))) {
-      f_names <- colnames(Ext_F)
-    } else {
-      f_names <- paste0("Ext_F", as.character(seq_len(ncol(Ext_F))))
-    }
-  }
-
-  # Combine Signal Names
-  signal_names <- c(if (exists("x_names")) x_names,
-                    if (exists("f_names")) f_names)
+  # P-Signal / F-Signal Names
+  x_names <- if (!is.null(X)) if (!is.null(colnames(X))) colnames(X) else paste0("X", seq_len(ncol(X)))
+  f_names <- if (!is.null(Ext_F)) if (!is.null(colnames(Ext_F))) colnames(Ext_F) else paste0("Ext_F", seq_len(ncol(Ext_F)))
+  signal_names <- c(if (exists("x_names")) x_names, if (exists("f_names")) f_names)
 
   # Create Signal-Parameter-Grid
   signal_grid <- expand.grid(signal_names,
@@ -579,21 +565,44 @@ stsc <- function(y,
                              stringsAsFactors = FALSE)
 
   # Set up matrix for selected signals
-  mat <- matrix(0,
-                nrow = nrow(y),
-                ncol = length(signal_names),
-                dimnames = list(NULL, signal_names))
-
-  # Fill matrix with selected signals
+  chosen_signals <- matrix(0,
+                           nrow = nrow(y),
+                           ncol = length(signal_names),
+                           dimnames = list(NULL, signal_names))
+
+  # Set up matrix for selected lambda
+  chosen_lambda <- matrix(0,
+                          nrow = nrow(y),
+                          ncol = length(lambda_grid),
+                          dimnames = list(NULL, lambda_grid))
+
+  # Set up matrix for selected kappa
+  chosen_kappa <- matrix(0,
+                         nrow = nrow(y),
+                         ncol = length(kappa_grid),
+                         dimnames = list(NULL, kappa_grid))
+  # Fill matrices
   for (t in seq(max(burn_in_tvc, burn_in_dsc) + 1, nrow(y))) {
+
+    # Select Signals
     col_names <- signal_grid[stsc_cand_mod[[t]] + 1, 1]
-    mat[t, col_names] <- 1
+    chosen_signals[t, col_names] <- 1
+
+    # Select Lambda
+    lambda_values <- as.matrix(table(signal_grid[stsc_cand_mod[[t]] + 1, 3]))
+    chosen_lambda[t, rownames(lambda_values)] <- lambda_values
+
+    # Select Kappa
+    kappa_values <- as.matrix(table(signal_grid[stsc_cand_mod[[t]] + 1, 2]))
+    chosen_kappa[t, rownames(kappa_values)] <- kappa_values
   }
 
   # Return Results
   return(list(Point_Forecast = stsc_forecast,
               Variance = stsc_variance,
               Gamma = chosen_gamma,
               Psi = chosen_psi,
-              Signals = mat))
+              Signals = chosen_signals,
+              Lambda = chosen_lambda,
+              Kappa = chosen_kappa))
 }

src/stsc.cpp

@@ -703,6 +703,26 @@ using namespace Rcpp;
        return diff;
    }
 
+// Helper Function -- Median with NAs
+   double compute_median(arma::rowvec vec) {
+
+      // Filter out NA values
+         arma::vec finiteVec = vec(arma::find_finite(vec));
+
+      // Check if empty
+         if (finiteVec.empty()) {
+           return arma::datum::nan; // Return NA if there are no finite values
+         }
+
+      // Calculate and return median
+         return arma::median(finiteVec);
+}
+
+// ###################################################################################
+// ###################################################################################
+// ###################################################################################
+
+
 // 3.) STSC 
 // Function I - Loop over t
 // [[Rcpp::export]]
@@ -867,7 +887,7 @@ using namespace Rcpp;
                   current_na_cm = new_na_cm;    
             for (unsigned int g=0; g<gamma_grid.n_elem; g++ ) {
                for (auto i : vec_diff) {
-                  score_cands(g)(i) = 0.0;
+                  score_cands(g)(i) = compute_median(arma::conv_to<arma::rowvec>::from(score_cands(g))); // 0.0;  // -> Insert Value !!!
                }  
             }
          }

src/stsc_parallel.cpp

@@ -761,6 +761,26 @@ using namespace RcppThread;
      return diff;
    }
 
+// Helper Function -- Median with NAs
+   double compute_median_par(arma::rowvec vec) {
+
+      // Filter out NA values
+         arma::vec finiteVec = vec(arma::find_finite(vec));
+
+      // Check if empty
+         if (finiteVec.empty()) {
+           return arma::datum::nan; // Return NA if there are no finite values
+         }
+
+      // Calculate and return median
+         return arma::median(finiteVec);
+}
+
+// ###################################################################################
+// ###################################################################################
+// ###################################################################################
+
+
 // 3.) STSC 
 // Function I - Loop over t
 // [[Rcpp::export]]
@@ -927,7 +947,7 @@ using namespace RcppThread;
            current_na_cm = new_na_cm;    
            for (unsigned int g=0; g<gamma_grid.n_elem; g++ ) {
              for (auto i : vec_diff) {
-               score_cands(g)(i) = 0.0;
+               score_cands(g)(i) = compute_median_par(arma::conv_to<arma::rowvec>::from(score_cands(g))); // 0.0;  // -> Insert Value !!!
              }  
            }
          }

tests/testthat/test-stsc.R

@@ -539,6 +539,27 @@ test_that("Test whether Code still works with different methods", {
                                  min_weight,
                                  max_weight))
 
+  testthat::expect_no_error(stsc(y,
+                               raw_signals,
+                               f_signals,
+                               sample_length,
+                               lambda_grid,
+                               kappa_grid,
+                               burn_in_tvc,
+                               bias,
+                               gamma_grid,
+                               psi_grid,
+                               delta,
+                               burn_in_dsc,
+                               method = 5,
+                               equal_weight,
+                               incl,
+                               parallel,
+                               n_threads,
+                               risk_aversion,
+                               min_weight,
+                               max_weight))
+
 })
 
 test_that("Test whether method is of given set", {
@@ -898,37 +919,48 @@ test_that("Test whether the output has the right format", {
                     min_weight,
                     max_weight)
 
-  # List Contains Five Elements
-  testthat::expect_equal(length(results), 5)
+  # List Contains seven Elements
+  testthat::expect_equal(length(results), 7)
 
-  # Number of Forecasts
+  # Point Forecasts
   checkmate::expect_numeric(results[[1]],
                             len = numb_obs,
                             finite = TRUE)
 
-  # Number of Variances
+  # Variances
   checkmate::expect_numeric(results[[2]],
                             len = numb_obs,
                             lower = 0,
                             finite = TRUE)
-  # Length of Gamma-Vector
+  # Gamma-Vector
   checkmate::expect_numeric(results[[3]],
                             len = numb_obs,
-                            lower = 0,
+                            lower = min(gamma_grid),
+                            upper = max(gamma_grid),
                             finite = TRUE)
-  # Length of Psi-Vector
+  # Psi-Vector
   checkmate::expect_numeric(results[[4]],
                             len = numb_obs,
-                            lower = 0,
+                            lower = min(psi_grid),
+                            upper = max(psi_grid),
                             finite = TRUE)
 
-  # Dimension of selected Candidate Forecasts
+  # Candidate Forecasting Models
   checkmate::expect_matrix(results[[5]],
                            mode = "integerish",
                            nrows = numb_obs,
                            ncols = (ncol(raw_signals) + ncol(f_signals)))
-})
 
+  # Lambda-Vector
+  checkmate::expect_matrix(results[[6]],
+                           nrows = numb_obs,
+                           ncols = length(lambda_grid))
+
+  # Kappa-Vector
+  checkmate::expect_matrix(results[[7]],
+                           nrows = numb_obs,
+                           ncols = length(kappa_grid))
+})
 
 ### Guarantee same results between tvc() & dsc() vs. stsc()
 test_that("Test whether the different implementations give same results", {