NNS 11.0 Beta

Author: OVVO-Financial

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: NNS
 Type: Package
 Title: Nonlinear Nonparametric Statistics
-Version: 10.9.7
-Date: 2024-12-26
+Version: 11.0
+Date: 2025-01-03
 Authors@R: c(
   person("Fred", "Viole", role=c("aut","cre"), email="[email protected]"),
   person("Roberto", "Spadim", role=c("ctb"))

NNS_10.9.7.tar.gz

@@ -67,13 +67,13 @@ NNS.ARMA <- function(variable,
                      seasonal.plot = TRUE,
                      pred.int = NULL){
 
-
+  
   if(is.numeric(seasonal.factor) && dynamic) stop('Hmmm...Seems you have "seasonal.factor" specified and "dynamic = TRUE".  Nothing dynamic about static seasonal factors!  Please set "dynamic = FALSE" or "seasonal.factor = FALSE"')
-
+  
   if(any(class(variable)%in%c("tbl","data.table"))) variable <- as.vector(unlist(variable))
 
   if(sum(is.na(variable)) > 0) stop("You have some missing values, please address.")
-
+  
   method <- tolower(method)
   if(method == "means") shrink <- FALSE
 
@@ -99,7 +99,7 @@ NNS.ARMA <- function(variable,
 
   Estimates <- numeric(length = h)
 
- 
+  
   if(is.numeric(seasonal.factor)){
     seasonal.plot = FALSE
     M <- matrix(seasonal.factor, ncol=1)
@@ -147,9 +147,9 @@ NNS.ARMA <- function(variable,
     if(is.character(weights)) Weights <- rep(1/length(lag), length(lag))
 
   }
-
+  
   lin.resid <- list()
-
+  
   # Regression for each estimate in h
   for (j in 1:h) {
     # Regenerate seasonal.factor if dynamic
@@ -218,7 +218,7 @@ NNS.ARMA <- function(variable,
       Lin.Regression.Estimates <- unlist(Lin.Regression.Estimates)
 
       if (method != "means") lin.resid <- mean(abs(Lin.Regression.Estimates - mean(Lin.Regression.Estimates)))
- 
+      
       if (method %in% c("means", "shrink")) {
         Regression.Estimates_means <- sapply(Component.series, mean)
         if (shrink) Lin.Regression.Estimates <- (Lin.Regression.Estimates + Regression.Estimates_means) / 2 else Lin.Regression.Estimates <- Regression.Estimates_means
@@ -231,15 +231,15 @@ NNS.ARMA <- function(variable,
     if (method == "lin") Estimates[j] <- sum(Lin.estimates * Weights)
 
     if (method == 'both') Estimates[j] <- mean(c(Lin.estimates, Nonlin.estimates))
-  
+    
     if (method == "nonlin")  Estimates[j] <- sum(Nonlin.estimates * Weights)
-  
+    
 
     variable <- c(variable, Estimates[j])
     FV <- variable
   } # j loop
-
-
+  
+  
   if(!is.null(pred.int)){
     PIs <- do.call(cbind, NNS.MC(Estimates, lower_rho = 0, upper_rho = 1, by = .2, exp = 2)$replicates)
     lin.resid <- mean(unlist(lin.resid))
@@ -283,7 +283,7 @@ NNS.ARMA <- function(variable,
               col = rgb(1, 192/255, 203/255, alpha = 0.5),
               border = NA)
 
-
+      
       lines(OV, type = 'l', lwd = 2, col = 'steelblue')
 
       lines((training.set + 1) : (training.set + h), Estimates, type = 'l', lwd = 2, lty = 1, col = 'red')

NNS_10.9.7.zip

@@ -14,6 +14,7 @@
 #' @param linear.approximation logical; \code{TRUE} (default) Uses the best linear output from \code{NNS.reg} to generate a nonlinear and mixture regression for comparison.  \code{FALSE} is a more exhaustive search over the objective space.
 #' @param pred.int numeric [0, 1]; 0.95 (default) Returns the associated prediction intervals for the final estimate.  Constructed using the maximum entropy bootstrap \link{NNS.meboot} on the final estimates.
 #' @param print.trace logical; \code{TRUE} (default) Prints current iteration information.  Suggested as backup in case of error, best parameters to that point still known and copyable!
+#' @param ncores integer; value specifying the number of cores to be used in the parallelized  procedure. If NULL (default), the number of cores to be used is equal to the number of cores of the machine - 1.
 #' @param plot logical; \code{FALSE} (default)
 #'
 #' @return Returns a list containing:
@@ -36,6 +37,7 @@
 #'
 #' \item{} The number of combinations will grow prohibitively large, they should be kept as small as possible.  \code{seasonal.factor} containing an element too large will result in an error.  Please reduce the maximum \code{seasonal.factor}.
 #'
+#' \item{} Set \code{(ncores = 1)} if routine is used within a parallel architecture.
 #'}
 #'
 #'
@@ -68,6 +70,7 @@ NNS.ARMA.optim <- function(variable,
                            obj.fn =  expression( mean((predicted - actual)^2) / (NNS::Co.LPM(1, predicted, actual, target_x = mean(predicted), target_y = mean(actual)) + NNS::Co.UPM(1, predicted, actual, target_x = mean(predicted), target_y = mean(actual)) )  ),
                            objective = "min",
                            linear.approximation = TRUE,
+                           ncores = NULL,
                            pred.int = 0.95,
                            print.trace = TRUE,
                            plot = FALSE){
@@ -123,6 +126,28 @@ NNS.ARMA.optim <- function(variable,
     seasonal.combs <- current.seasonals <- vector(mode = "list")
     current.estimate <- numeric()
 
+    if (j == "lin") {
+      # Determine the number of cores to use
+      num_cores <- if (is.null(ncores)) {
+        max(2L, parallel::detectCores() - 1L)
+      } else {
+        ncores
+      }
+      
+      # Manage cluster creation
+      cl <- NULL
+      if (num_cores > 1) {
+        cl <- tryCatch(
+          parallel::makeForkCluster(num_cores),
+          error = function(e) parallel::makeCluster(num_cores)
+        )
+        doParallel::registerDoParallel(cl)
+        invisible(data.table::setDTthreads(1))  # Restrict threading for parallelization
+      } else {
+        foreach::registerDoSEQ()
+        invisible(data.table::setDTthreads(0))  # Default threading
+      }
+    }
 
     for(i in 1 : length(seasonal.factor)){
       if(i == 1){
@@ -150,15 +175,53 @@ NNS.ARMA.optim <- function(variable,
 
       if(is.null(ncol(seasonal.combs[[i]])) || dim(seasonal.combs[[i]])[2]==0) break 
 
-      if(j=="lin"){
-
-        nns.estimates.indiv <- lapply(1 : ncol(seasonal.combs[[i]]), function(k) {
-          actual <- tail(variable, h_eval)
-          if(print.trace) message("Testing seasonal.factor ", paste(unlist(seasonal.combs[[i]][ , k]), ","), "\r", appendLF = FALSE)
-          predicted <- NNS.ARMA(variable, training.set = training.set, h = h_eval, seasonal.factor =  seasonal.combs[[i]][ , k], method = "lin", plot = FALSE, negative.values = negative.values)
-          
-          return(eval(obj.fn))
-        })
+      # if(j=="lin"){
+      #   
+      #   nns.estimates.indiv <- lapply(1 : ncol(seasonal.combs[[i]]), function(k) {
+      #     actual <- tail(variable, h_eval)
+      #     if(print.trace) message("Testing seasonal.factor ", paste(unlist(seasonal.combs[[i]][ , k]), ","), "\r", appendLF = FALSE)
+      #     predicted <- NNS.ARMA(variable, training.set = training.set, h = h_eval, seasonal.factor =  seasonal.combs[[i]][ , k], method = "lin", plot = FALSE, negative.values = negative.values)
+      #     
+      #     return(eval(obj.fn))
+      #   })
+      # }
+      if (j == "lin") {
+        # Parallel or sequential computation based on num_cores
+        nns.estimates.indiv <- if (num_cores > 1) {
+          parallel::clusterExport(
+            cl,
+            varlist = c("variable", "h_eval", "training.set", "seasonal.combs", "i", "obj.fn", "negative.values", "NNS.ARMA", "print.trace"),
+            envir = environment()
+          )
+          parallel::parLapply(cl, 1:ncol(seasonal.combs[[i]]), function(k) {
+            actual <- tail(variable, h_eval)
+            predicted <- NNS.ARMA(
+              variable,
+              training.set = training.set,
+              h = h_eval,
+              seasonal.factor = seasonal.combs[[i]][, k],
+              method = "lin",
+              plot = FALSE
+            )
+            eval(obj.fn)
+          })
+        } else {
+          lapply(1:ncol(seasonal.combs[[i]]), function(k) {
+            actual <- tail(variable, h_eval)
+            predicted <- NNS.ARMA(
+              variable,
+              training.set = training.set,
+              h = h_eval,
+              seasonal.factor = seasonal.combs[[i]][, k],
+              method = "lin",
+              plot = FALSE
+            )
+            eval(obj.fn)
+          })
+        }
+        
+        # Ensure output is unlisted
+        nns.estimates.indiv <- unlist(nns.estimates.indiv)
       }
 
       if(j=="nonlin" && linear.approximation){
@@ -174,14 +237,14 @@ NNS.ARMA.optim <- function(variable,
       if(j=="both" && linear.approximation){
         # Find the min (obj.fn) for a given seasonals sequence
         actual <- tail(variable, h_eval)
-       
+        
         lin.predicted <- NNS.ARMA(variable, training.set = training.set, h = h_eval, seasonal.factor = unlist(overall.seasonals[[1]]), method = "lin", plot = FALSE, negative.values = negative.values)
         predicted <- both.predicted <- (lin.predicted + nonlin.predicted) / 2
-
+        
         nns.estimates.indiv <- eval(obj.fn)
       }
 
-
+      
       nns.estimates.indiv <- unlist(nns.estimates.indiv)
 
       if(objective=='min') nns.estimates.indiv[is.na(nns.estimates.indiv)] <- Inf else nns.estimates.indiv[is.na(nns.estimates.indiv)] <- -Inf
@@ -235,6 +298,16 @@ NNS.ARMA.optim <- function(variable,
 
     } # for i in 1:length(seasonal factor)
 
+    if (j == "lin") {
+      # Clean up cluster
+      if (!is.null(cl)) {
+        parallel::stopCluster(cl)
+        doParallel::stopImplicitCluster()
+        invisible(data.table::setDTthreads(0))  # Restore threading
+        invisible(gc(verbose = FALSE))  # Clean up memory
+      }
+    }
+    
     previous.seasonals[[which(c("lin",'nonlin','both')==j)]] <- current.seasonals
     previous.estimates[[which(c("lin",'nonlin','both')==j)]] <- current.estimate
 
@@ -287,7 +360,7 @@ NNS.ARMA.optim <- function(variable,
       }
     } else {
       nns.weights <- NULL
-
+      
       errors <- predicted - actual
       bias <- gravity(na.omit(errors))
       if(is.na(bias)) bias <- 0
@@ -401,7 +474,7 @@ NNS.ARMA.optim <- function(variable,
     model.results <- NNS.ARMA(OV, h = h_oos, seasonal.factor = nns.periods, method = nns.method, plot = FALSE, negative.values = negative.values, weights = nns.weights, shrink = nns.shrink) - bias
   }
 
-
+  
   lower_PIs <- model.results - abs(LPM.VaR((1-pred.int)/2, 0, errors)) - abs(bias)
   upper_PIs <- model.results + abs(UPM.VaR((1-pred.int)/2, 0, errors)) + abs(bias)
 
@@ -411,7 +484,7 @@ NNS.ARMA.optim <- function(variable,
     lower_PIs <- pmax(0, lower_PIs)
     upper_PIs <- pmax(0, upper_PIs)
   }
-
+  
   if(plot){
     if(is.null(h_oos)) xlim <- c(1, max((training.set + h))) else xlim <- c(1, max((n + h)))
 
@@ -449,7 +522,7 @@ NNS.ARMA.optim <- function(variable,
       legend("topleft", legend = c("Variable", "Internal Validation", "Forecast"), 
              col = c("steelblue", "red", "red"), lty = c(1, 2, 1), bty = "n", lwd = 2)
     } 
-      
+    
 
 
 

NNS_11.0.tar.gz

@@ -35,19 +35,82 @@ factor_2_dummy_FR <- function(x){
 }
 
 ### Generator for 1:length(lag) vectors in NNS.ARMA
-generate.vectors <- function(x, l){
-  Component.index <- Component.series <- list()
- 
-  for (i in 1:length(l)){
-    CS <- rev(x[seq(length(x)+1, 1, -l[i])])
-    CS <- CS[!is.na(CS)]
-    Component.series[[paste('Series.', i, sep = "")]] <- CS
-    Component.index[[paste('Index.', i, sep = "")]] <- (1 : length(CS))
-  }
+generate.vectors <- function(x, l) {
+  Component.series <- lapply(l, function(lag) {
+    rev.series <- rev(x[seq(length(x) + 1, 1, -lag)])
+    rev.series[!is.na(rev.series)]
+  })
+  
+  Component.index <- lapply(Component.series, seq_along)
+  
   return(list(Component.index = Component.index, Component.series = Component.series))
 }
 
 
+generate.lin.vectors <- function(x, l, h = 1) {
+  original.index <- seq_along(x)
+  augmented.index <- c(original.index, tail(original.index,1) + (1:h))
+  max_fcast <- min(h, l)  
+  # Generate lagged components by applying lag across the augmented index
+  Component.series <- lapply(1:max_fcast, function(i) {
+    start.index <- length(x) + i  # Shift by 1 each time
+    rev.series <- rev(x[seq(start.index, 1, -l)])  # Reverse the sequence with a lag of 12
+    rev.series[!is.na(rev.series)]  # Remove any NA values
+  })
+  
+  Component.index <- lapply(Component.series, seq_along)
+  
+  # Initialize forecast.index and forecast.values
+  forecast.index <- vector("list", length(l))
+  forecast.values <- vector("list", length(l))
+  
+  # Generate forecast.index for 1:h
+  max_fcast <- min(h, l)
+  forecast.index <- create_recycled_list(1:h, max_fcast)
+  forecast.index <- forecast.index[!sapply(forecast.index, is.null)]
+  
+  
+  # Generate forecast values based on the last value in Component.index
+  forecast.values.raw <- lapply(1:h, function(i) {
+    # Recycle the index if h > l
+    recycled_index <- (i - 1) %% l + 1  # Cycle through 1 to l
+    
+    # Get the last value from the corresponding Component.index
+    last_value <- tail(Component.index[[recycled_index]], 1)
+    
+    # Calculate the forecast increment
+    forecast_increment <- ceiling(i / l)
+    
+    # Generate the forecast value
+    forecast_value <- last_value + forecast_increment
+    return(forecast_value)
+  })
+
+  forecast.values <- create_recycled_list(unlist(forecast.values.raw), l)
+  forecast.values <- forecast.values[!sapply(forecast.values, is.null)]
+  
+  return(list(
+    Component.index = Component.index,
+    Component.series = Component.series,
+    forecast.values = forecast.values,
+    forecast.index = forecast.index
+  ))
+}
+
+create_recycled_list <- function(values, list_length) {
+  # Initialize an empty list to store the values
+  result <- vector("list", list_length)
+  
+  # Recycle the values by repeating them across the list length
+  for (i in seq_along(values)) {
+    index <- (i - 1) %% list_length + 1
+    result[[index]] <- c(result[[index]], values[i])
+  }
+  
+  return(result)
+}
+
+
 ### Weight and lag function for seasonality in NNS.ARMA
 ARMA.seas.weighting <- function(sf,mat){
   M <- mat

NNS_11.0.zip

@@ -201,6 +201,7 @@ NNS.VAR <- function(variables,
                           obj.fn = obj.fn,
                           objective = objective,
                           print.trace = FALSE,
+                          ncores = 1,
                           negative.values = min(variable_interpolation)<0, h = h)
 
       variable_extrapolation <- b$results

R/ARMA.R

@@ -3,7 +3,7 @@
 
 
 
-[![packageversion](https://img.shields.io/badge/NNS%20version-10.9.7-blue.svg?style=flat-square)](https://github.com/OVVO-Financial/NNS/commits/NNS-Beta-Version)   [![Licence](https://img.shields.io/badge/licence-GPL--3-blue.svg)](https://www.gnu.org/licenses/gpl-3.0.en.html)
+[![packageversion](https://img.shields.io/badge/NNS%20version-11.0-blue.svg?style=flat-square)](https://github.com/OVVO-Financial/NNS/commits/NNS-Beta-Version)   [![Licence](https://img.shields.io/badge/licence-GPL--3-blue.svg)](https://www.gnu.org/licenses/gpl-3.0.en.html)
 
 <h2 style="margin: 0; padding: 0; border: none; height: 40px;"></h2>
 
@@ -56,7 +56,7 @@ Please see https://github.com/OVVO-Financial/NNS/blob/NNS-Beta-Version/examples/
     title = {NNS: Nonlinear Nonparametric Statistics},
     author = {Fred Viole},
     year = {2016},
-    note = {R package version 10.9.7},
+    note = {R package version 11.0},
     url = {https://CRAN.R-project.org/package=NNS},
   }
 ```