Add benchmarking

DESCRIPTION

@@ -34,4 +34,4 @@ Suggests:
 URL: https://rjdverse.github.io/rjdemetra/, https://github.com/rjdverse/rjdemetra
 BugReports: https://github.com/rjdverse/rjdemetra/issues
 Encoding: UTF-8
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2

NAMESPACE

@@ -107,6 +107,7 @@ export(regarima_tramoseats)
 export(regarima_x13)
 export(s_arima)
 export(s_arimaCoef)
+export(s_benchmarking)
 export(s_easter)
 export(s_estimate)
 export(s_fcst)

NEWS.md

@@ -2,10 +2,14 @@
 
 - URL to github repository updated (github.com/jdemetra replaced by github.com/rjdverse).
 
-- results of `user_defined_variables()` were updated.
+- results of `user_defined_variables()` updated.
 
 - README correction.
 
+- benchmarking option added to `x13_spec()` and `tramoseats_spec()` and in output of `x13()` and `tramoseats()`.
+
+- .jars updated.
+
 # RJDemetra 0.2.6
 
 - possibility to export last msr for monthly data (issue #122).

R/benchmarking_spec.R

@@ -0,0 +1,204 @@
+benchmarking_spec_def <- function(spec,
+                                  benchmarking.enabled = NA,
+                                  benchmarking.target = c(NA, "Original", "CalendarAdjusted"),
+                                  benchmarking.useforecast = NA,
+                                  benchmarking.rho = NA_real_,
+                                  benchmarking.lambda = NA_real_)
+
+{
+  default_spec <- data.frame(benchmarking.enabled = FALSE, benchmarking.target = "CalendarAdjusted",
+                             benchmarking.useforecast = FALSE, benchmarking.rho = 1, benchmarking.lambda = 1)
+  if(identical(spec, "X11")) {
+    benchmarking.mod <- rbind(
+      default_spec,
+      default_spec,
+      NA)
+    return(spec_benchmarking(benchmarking.mod))
+  }
+
+  benchmarking.target <- match.arg(benchmarking.target)
+
+
+  list.logical <- list("benchmarking.enabled", "benchmarking.useforecast")
+  list.numeric <- list("benchmarking.rho", "benchmarking.lambda")
+
+  var.list <- list()
+  for (i in 1:length(list.logical)) {
+    eval(parse(text = paste("if( !is.logical(",list.logical[i],")) {",
+                            list.logical[i],
+                            " = NA; var.list=append(var.list,'",
+                            list.logical[i],
+                            "')}",
+                            sep = "")))
+  }
+  if (length(var.list) > 0) {
+    warning(paste("Variable(s)",
+                  deparse(as.character(var.list)),
+                  " should be logical. They are ignored."),
+            call. = FALSE)
+  }
+
+  var.list <- list()
+  for (i in 1:length(list.numeric)) {
+    eval(parse(text = paste("if( !is.numeric(",
+                            list.numeric[i],
+                            ")) {",
+                            list.numeric[i],
+                            " = NA; var.list=append(var.list,'",
+                            list.numeric[i],
+                            "')}",
+                            sep = "")))
+  }
+  if (length(var.list) > 0) {
+    warning(paste("Variable(s)",
+                  deparse(as.character(var.list)),
+                  " should be numeric. They are ignored."),
+            call. = FALSE)
+  }
+
+  benchmarking <- data.frame(
+    benchmarking.enabled = benchmarking.enabled, benchmarking.target = benchmarking.target,
+    benchmarking.useforecast = benchmarking.useforecast, benchmarking.rho = benchmarking.rho,
+    benchmarking.lambda = benchmarking.lambda)
+  benchmarking.mod <- rbind(
+    default_spec,
+    benchmarking,
+    NA)
+  return(spec_benchmarking(benchmarking.mod))
+}
+
+spec_benchmarking <- function(benchmarking){
+
+  for (i in c("benchmarking.enabled", "benchmarking.target", "benchmarking.useforecast",
+              "benchmarking.rho", "benchmarking.lambda")){
+    benchmarking[3,i] <- if (!is.na(benchmarking[2,i])) {benchmarking[2,i]} else {benchmarking[1,i]}
+  }
+  if (!benchmarking[3,"benchmarking.enabled"]) {
+    benchmarking[3, "benchmarking.target"] <- "CalendarAdjusted"
+    benchmarking[3, "benchmarking.useforecast"] <- FALSE
+    benchmarking[3, "benchmarking.rho"] <- 1
+    benchmarking[3, "benchmarking.lambda"] <- 1
+  }
+
+  rownames(benchmarking) <- c("Predefined","User_modif","Final")
+  class(benchmarking) <- c("benchmarking_spec", "data.frame")
+  return(benchmarking)
+}
+
+benchmarking_spec<- function(spec,
+            benchmarking.enabled = NA,
+            benchmarking.target = c(NA, "Original", "CalendarAdjusted"),
+            benchmarking.useforecast = NA,
+            benchmarking.rho = NA_real_,
+            benchmarking.lambda = NA_real_)
+
+{
+  benchmarking.target <- match.arg(benchmarking.target)
+
+  list.logical <- list("benchmarking.enabled", "benchmarking.useforecast")
+  list.numeric <- list("benchmarking.rho", "benchmarking.lambda")
+
+  var.list <- list()
+  for (i in 1:length(list.logical)) {
+    eval(parse(text = paste("if( !is.logical(",list.logical[i],")) {",
+                            list.logical[i],
+                            " = NA; var.list=append(var.list,'",
+                            list.logical[i],
+                            "')}",
+                            sep = "")))
+  }
+  if (length(var.list) > 0) {
+    warning(paste("Variable(s)",
+                  deparse(as.character(var.list)),
+                  " should be logical. They are ignored."),
+            call. = FALSE)
+  }
+
+  var.list <- list()
+  for (i in 1:length(list.numeric)) {
+    eval(parse(text = paste("if( !is.numeric(",
+                            list.numeric[i],
+                            ")) {",
+                            list.numeric[i],
+                            " = NA; var.list=append(var.list,'",
+                            list.numeric[i],
+                            "')}",
+                            sep = "")))
+  }
+  if (length(var.list) > 0) {
+    warning(paste("Variable(s)",
+                  deparse(as.character(var.list)),
+                  " should be numeric. They are ignored."),
+            call. = FALSE)
+  }
+
+  benchmarking <- data.frame(
+    benchmarking.enabled = benchmarking.enabled, benchmarking.target = benchmarking.target,
+    benchmarking.useforecast = benchmarking.useforecast, benchmarking.rho = benchmarking.rho,
+    benchmarking.lambda = benchmarking.lambda)
+  benchmarking.spec <- s_benchmarking(spec)
+  benchmarking.mod <- rbind(benchmarking.spec, benchmarking, NA)
+  return(spec_benchmarking(benchmarking.mod))
+}
+
+
+spec_benchmarking_r2jd <- function(rspec = NA, jdspec = NA){
+  benchmarking <- s_benchmarking(rspec)
+  jbench <- .jcall(jdspec,"Ljdr/spec/sa/SaBenchmarkingSpec;","getBenchmarking")
+
+  .jcall(jbench, "V", "setEnabled", benchmarking[["benchmarking.enabled"]])
+  if (benchmarking[["benchmarking.enabled"]]) {
+    .jcall(jbench, "V", "setTarget", benchmarking[["benchmarking.target"]])
+    .jcall(jbench, "V", "setUseForecast", benchmarking[["benchmarking.useforecast"]])
+    .jcall(jbench, "V", "setRho", benchmarking[["benchmarking.rho"]])
+    .jcall(jbench, "V", "setLambda", benchmarking[["benchmarking.lambda"]])
+  }
+
+  return(jbench)
+}
+
+spec_benchmarking_jd2r <- function(jrobj){
+  jbench <- .jcall(jrobj, "Ljdr/spec/sa/SaBenchmarkingSpec;", "getBenchmarking")
+  benchmarking.target <- .jcall(jbench, "Ljava/lang/String;", "getTarget")
+  benchmarking.enabled <- .jcall(jbench, "Z", "isEnabled")
+  benchmarking.useforecast <- .jcall(jbench, "Z", "isUseForecast")
+  benchmarking.rho <- .jcall(jbench, "D", "getRho")
+  benchmarking.lambda <- .jcall(jbench, "D", "getLambda")
+
+  data.frame(
+    benchmarking.enabled = benchmarking.enabled, benchmarking.target = benchmarking.target,
+    benchmarking.useforecast = benchmarking.useforecast, benchmarking.rho = benchmarking.rho,
+    benchmarking.lambda = benchmarking.lambda)
+}
+
+benchmarking <- function(jrobj,spec){
+  specification <- spec[3,]
+  rownames(specification) <- ""
+  if(specification[["benchmarking.enabled"]]) {
+    original <- result(jrobj, "benchmarking.original")
+    result <- result(jrobj, "benchmarking.result")
+    Differences <- original - result
+    bench_res <- ts.union(original, result, Differences)
+  } else {
+    bench_res <- NULL
+  }
+  z <- list(specification = specification, benchmarking = bench_res)
+  class(z) <- c("benchmarking")
+  return(z)
+}
+
+benchmarking_def <- function(jrobj,jspec){
+  specification <- spec_benchmarking_jd2r(jspec)
+  rownames(specification) <- ""
+  if(specification[["benchmarking.enabled"]]) {
+    original <- result(jrobj, "benchmarking.original")
+    result <- result(jrobj, "benchmarking.result")
+    Differences <- original - result
+    bench_res <- ts.union(original, result, Differences)
+  } else {
+    bench_res <- NULL
+  }
+  z <- list(specification = specification, benchmarking = bench_res)
+  class(z) <- c("benchmarking")
+  return(z)
+}

R/get_jspec.R

@@ -15,17 +15,19 @@ get_jspec.X13 <- function(x, ...){
   } else {
     jrspec <- .jcall("jdr/spec/x13/X13Spec", "Ljdr/spec/x13/X13Spec;", "of", "RSA0")
   }
-  jdictionary <- spec_regarima_X13_r2jd(spec,jrspec)
-  seasma <- specX11_r2jd(spec,jrspec, freq = frequency(x$final$series))
+  spec_regarima_X13_r2jd(spec,jrspec)
+  specX11_r2jd(spec,jrspec, freq = frequency(x$final$series))
+  spec_benchmarking_r2jd(spec, jrspec)
   jspec <- .jcall(jrspec, "Lec/satoolkit/x13/X13Specification;", "getCore")
   jspec
 }
 #' @export
 get_jspec.TRAMO_SEATS <- function(x, ...){
   spec <- tramoseats_spec(x, ...)
   jrspec <- .jcall("jdr/spec/tramoseats/TramoSeatsSpec", "Ljdr/spec/tramoseats/TramoSeatsSpec;", "of", "RSA0")
-  jdictionary <- spec_TRAMO_r2jd(spec,jrspec)
-  spec_seats <- specSeats_r2jd(spec,jrspec)
+  spec_TRAMO_r2jd(spec,jrspec)
+  specSeats_r2jd(spec,jrspec)
+  spec_benchmarking_r2jd(spec, jrspec)
   jspec <- .jcall(jrspec, "Lec/satoolkit/tramoseats/TramoSeatsSpecification;", "getCore")
   jspec
 }

R/jtramoseats.R

@@ -18,6 +18,7 @@ jtramoseats.SA_spec <- function(series, spec,
   jrspec <- .jcall("jdr/spec/tramoseats/TramoSeatsSpec", "Ljdr/spec/tramoseats/TramoSeatsSpec;", "of", "RSA0")
   jdictionary <- spec_TRAMO_r2jd(spec,jrspec)
   specSeats_r2jd(spec,jrspec)
+  spec_benchmarking_r2jd(rspec = spec, jdspec = jrspec)
   jspec <- .jcall(jrspec, "Lec/satoolkit/tramoseats/TramoSeatsSpecification;", "getCore")
   jrslt <- .jcall("ec/tstoolkit/jdr/sa/Processor", "Lec/tstoolkit/jdr/sa/TramoSeatsResults;", "tramoseats", ts_r2jd(series), jspec, jdictionary )
   jrslt <- new (Class = "TramoSeats_java", internal = jrslt)

R/jx13.R

@@ -22,6 +22,7 @@ jx13.SA_spec <- function(series, spec, userdefined = NULL){
   }
   jdictionary <- spec_regarima_X13_r2jd(spec, jrspec)
   seasma <- specX11_r2jd(spec, jrspec, freq = frequency(series))
+  spec_benchmarking_r2jd(rspec = spec, jdspec = jrspec)
   jspec <- .jcall(jrspec, "Lec/satoolkit/x13/X13Specification;", "getCore")
   jrslt <- .jcall("ec/tstoolkit/jdr/sa/Processor", "Lec/tstoolkit/jdr/sa/X13Results;", "x13", ts_r2jd(series), jspec, jdictionary)
   jrslt <- new(Class = "X13_java", internal = jrslt)

R/saveSpec.R

@@ -103,22 +103,24 @@ save_spec = function (object, file = file.path(tempdir(), "spec.RData")) {
 
   if (inherits(object,c("SA","SA_spec")) & inherits(object,"X13")){
     decomp <- s_x11(object)
+    benchmarking <- s_benchmarking(object)
     cspec <- "SA_saveX13"
   } else if (inherits(object,c("SA","SA_spec")) & inherits(object,"TRAMO_SEATS")){
     decomp <- s_seats(object)
+    benchmarking <- s_benchmarking(object)
     cspec <- "SA_saveTS"
   } else if (inherits(object,"X13")) {
-    decomp <- NA
+    decomp <- benchmarking <- NA
     cspec <- "regarima_saveX13"
   } else {
-    decomp <- NA
+    decomp <- benchmarking <- NA
     cspec <- "regarima_saveTS"
   }
 
   spec <- list(estimate=estimate, transform=transform, usrdef = usrdef,predef.outliers=predef.outliers,
                predef.variables=predef.variables, trading.days=trading.days,easter= easter,
                outliers=outliers, arima.dsc=arima.dsc, predef.coef=predef.coef,
-               forecast = forecast,span=span, decomp=decomp)
+               forecast = forecast,span=span, decomp=decomp, benchmarking = benchmarking)
   class(spec) <- cspec
   save(spec, file = file)
 }
@@ -144,6 +146,7 @@ load_spec <- function (file = "spec.RData") {
   s.forecast <- object$forecast
   span <- object$span
   s.decomp <- object$decomp
+  s.benchmarking <- object$benchmarking
 
   estimate<- rbind(s.estimate,rep(NA,length(s.estimate)),s.estimate)
   transform <- rbind(s.transform,rep(NA,length(s.transform)),s.transform)
@@ -153,15 +156,20 @@ load_spec <- function (file = "spec.RData") {
   outliers <- rbind(s.outliers,rep(NA,length(s.outliers)),s.outliers)
   arima.dsc <- rbind(s.arima.dsc,rep(NA,length(s.arima.dsc)),s.arima.dsc)
   forecast <- rbind(s.forecast,rep(NA,length(s.forecast)),s.forecast)
-
-  rownames(estimate)=c("Loaded","User_modif","Final")
-  rownames(transform)=c("Loaded","User_modif","Final")
-  rownames(usrdef)=c("Loaded","User_modif","Final")
-  rownames(trading.days)=c("Loaded","User_modif","Final")
-  rownames(easter)=c("Loaded","User_modif","Final")
-  rownames(outliers)=c("Loaded","User_modif","Final")
-  rownames(arima.dsc)=c("Loaded","User_modif","Final")
-  rownames(forecast)=c("Loaded","User_modif","Final")
+  benchmarking <- rbind(s.benchmarking,NA,s.benchmarking)
+  class(benchmarking) <- c("benchmarking_spec", "data.frame")
+  decomp <- rbind(s.decomp,rep(NA,length(s.decomp )),s.decomp)
+  rownames(estimate) <-
+    rownames(transform) <-
+    rownames(usrdef) <-
+    rownames(trading.days) <-
+    rownames(easter) <-
+    rownames(outliers) <-
+    rownames(arima.dsc) <-
+    rownames(forecast) <-
+    rownames(benchmarking) <-
+    rownames(decomp) <-
+    c("Loaded","User_modif","Final")
 
   userdef <-list(specification = usrdef, outliers = list(Predefined = s.predef.outliers, Final = s.predef.outliers),
                  variables = list(Predefined = s.predef.variables, Final = s.predef.variables))
@@ -179,18 +187,16 @@ load_spec <- function (file = "spec.RData") {
     return(regarima)
   } else if (inherits(object,"SA_saveX13")){
     class(regarima) <- c("regarima_spec","X13")
-    x11 <- rbind(s.decomp,rep(NA,length(s.decomp )),s.decomp)
-    rownames(x11)=c("Loaded","User_modif","Final")
+    x11 <- decomp
     class(x11) <- c("X11_spec","data.frame")
-    z <- list(regarima = regarima, x11 = x11)
+    z <- list(regarima = regarima, x11 = x11, benchmarking = benchmarking)
     class(z) <- c("SA_spec","X13")
     return(z)
   } else {
     class(regarima) <- c("regarima_spec","TRAMO_SEATS")
-    seats <- rbind(s.decomp,rep(NA,length(s.decomp )),s.decomp)
-    rownames(seats)=c("Loaded","User_modif","Final")
+    seats <- decomp
     class(seats) <- c("seats_spec","data.frame")
-    z <- list(regarima = regarima, seats = seats)
+    z <- list(regarima = regarima, seats = seats, benchmarking = benchmarking)
     class(z) <- c("SA_spec","TRAMO_SEATS")
     return(z)
   }

R/spec.R

@@ -476,6 +476,21 @@ s_x11 <- function(object = NA){
 #' @rdname specification
 #' @name specification
 #' @export
+s_benchmarking <- function(object = NA){
+  if (inherits(object, c("SA","SA_spec"))==FALSE)
+    stop("This function must only be used with \"SA\" and \"SA_spec\" objects", call. = FALSE)
+
+  if (inherits(object, "SA")){
+    return(object$benchmarking$specification)
+  } else {
+    obj <- object$benchmarking[3,]
+    rownames(obj) <- ""
+    return(obj)
+  }
+}
+#' @rdname specification
+#' @name specification
+#' @export
 s_seats <- function(object = NA){
   if (inherits(object, c("SA","SA_spec"))==FALSE)
     stop("This function must only be used with \"SA\" and \"SA_spec\" objects", call. = FALSE)