Merge pull request #160 from rjdverse/develop

v0.2.8

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: RJDemetra
 Type: Package
 Title: Interface to 'JDemetra+' Seasonal Adjustment Software
-Version: 0.2.7
+Version: 0.2.8
 Authors@R: c(
   person("Alain", "Quartier-la-Tente", role = c("aut", "cre"),
                  email = "[email protected]",

NEWS.md

@@ -1,3 +1,16 @@
+# RJDemetra 0.2.8
+
+- Improvement of warning message importing the model when no data in a SaItem (#61).
+
+- `get_model`, `get_jmodel` and `get_jspec.sa_item` have now an argument `type` to define which specification to import (domain, estimation or point).
+By default the domain specification is extracted (as before).
+
+- Correction of bug of `add_sa_item()` of models created by `jtramoseats()` with external variables.
+
+- Correction of bug of `get_jmodel()` when model contains user-defined regressors (calendar or regressors) with fixed coefficients (#157).
+
+- Correction of bug for annual data for `regarima()` functions. 
+
 # RJDemetra 0.2.7
 
 - URL to github repository updated (github.com/jdemetra replaced by github.com/rjdverse).

R/export_workspace.R

@@ -96,7 +96,7 @@ full_path <- function(path) {
 #'
 #' @param workspace the workspace to add the seasonally adjusted series to.
 #' @param multiprocessing the name or index of the multiprocessing to add the seasonally adjusted series to.
-#' @param sa_obj the seasonally adjusted object to add
+#' @param sa_obj the seasonally adjusted object to add.
 #' @param name the name of the seasonally adjusted series in the multiprocessing.
 #' By default the name of the \code{sa_obj} is used.
 #'
@@ -164,71 +164,97 @@ complete_dictionary.SA <- function(workspace, sa_obj){
     return(sa_obj)
 
   context_dictionary <- .jcall(workspace,"Lec/tstoolkit/algorithm/ProcessingContext;", "getContext")
-  ts_variable_managers <- context_dictionary$getTsVariableManagers()
+  ts_variable_managers <- .jcall(context_dictionary,"Lec/tstoolkit/utilities/NameManager;", "getTsVariableManagers")
   ts_variables <- .jnew("ec/tstoolkit/timeseries/regression/TsVariables")
-  jd_r_variables <- ts_variable_managers$get("r")
+  jd_r_variables <- .jcall(ts_variable_managers, "Ljava/lang/Object;", "get", "r")
   if (is.null(jd_r_variables)) {
-    ts_variable_managers$set("r",
-                             .jnew("ec/tstoolkit/timeseries/regression/TsVariables"))
-    jd_r_variables <- ts_variable_managers$get("r")
+    .jcall(ts_variable_managers, "V", "set", "r",
+           .jcast(.jnew("ec/tstoolkit/timeseries/regression/TsVariables")))
+    jd_r_variables <- .jcall(ts_variable_managers, "Ljava/lang/Object;", "get", "r")
   }
-  jd_var_names <- jd_r_variables$getNames()
-
+  jd_var_names <- .jcall(jd_r_variables, "[S", "getNames")
   model_var_names <- rownames(ud_var$description)
 
   if (is.mts(ud_var$series)) {
     for (i in seq_along(model_var_names)) {
       name <- model_var_names[i]
-      dictionary_var <- jd_r_variables$get(name)
+      dictionary_var <- .jcall(jd_r_variables, "Ljava/lang/Object;", "get", name)
       tsvar <- .jnew("ec/tstoolkit/timeseries/regression/TsVariable",
                      name, ts_r2jd(ud_var$series[, i]))
       if (is.null(dictionary_var)) {
-        jd_r_variables$set(name, tsvar)
+        .jcall(jd_r_variables, "V", "set", name, .jcast(tsvar, "java/lang/Object"))
       } else {
-        if (!dictionary_var$getTsData()$equals(tsvar$getTsData())) {
-          same_prefix <- grep(paste0("^", name), jd_r_variables$getNames(), value = TRUE)
+        tsvar_ts_data <- .jcall(tsvar, "Lec/tstoolkit/timeseries/simplets/TsData;", "getTsData")
+        if (!.jcall(
+          .jcall(
+            dictionary_var,
+            "Lec/tstoolkit/timeseries/simplets/TsData;", "getTsData"
+          ), "Z", "equals", tsvar_ts_data
+        )) {
+          same_prefix <- grep(paste0("^", name),
+                              .jcall(jd_r_variables, "[S", "getNames"), value = TRUE)
           same_data <- sapply(same_prefix, function(x) {
-            jd_r_variables$get(x)$getTsData()$equals(tsvar$getTsData())
+            .jcall(
+              .jcall(
+              .jcall(jd_r_variables, "Ljava/lang/Object;", "get", x),
+              "Lec/tstoolkit/timeseries/simplets/TsData;", "getTsData"
+            ), "Z", "equals", tsvar_ts_data
+            )
           })
           if (any(same_data)) {
             # a name fix the same prefix  has the same data
             model_new_var_names <- same_prefix[which(same_data)]
           } else {
-            model_new_var_names <-  base::make.unique(c(jd_r_variables$getNames(),
-                                                    name),
-                                                  sep = "_")
+            model_new_var_names <-  base::make.unique(c(
+              .jcall(jd_r_variables, "[S", "getNames"),
+              name),
+              sep = "_")
           }
           model_var_names[i] <- name <- tail(model_new_var_names, 1)
           if (!any(same_data)){
             # If we didn't find any TsVariable with the same prefix with the same data,
             # we create a new one
             tsvar <- .jnew("ec/tstoolkit/timeseries/regression/TsVariable",
                            name, ts_r2jd(ud_var$series[, i]))
-            jd_r_variables$set(name, tsvar)
+            .jcall(jd_r_variables, "V", "set", name, .jcast(tsvar, "java/lang/Object"))
           }
         }
       }
     }
   }else{
     name <- model_var_names
-    dictionary_var <- jd_r_variables$get(name)
+    dictionary_var <- .jcall(jd_r_variables, "Ljava/lang/Object;", "get", name)
     tsvar <- .jnew("ec/tstoolkit/timeseries/regression/TsVariable",
                    name, ts_r2jd(ud_var$series))
     if (is.null(dictionary_var)) {
-      jd_r_variables$set(name, tsvar)
+      .jcall(jd_r_variables, "V", "set", name, .jcast(tsvar, "java/lang/Object"))
     } else {
-      if (!dictionary_var$getTsData()$equals(tsvar$getTsData())) {
-        same_prefix <- grep(paste0("^", name), jd_r_variables$getNames(), value = TRUE)
+      tsvar_ts_data <- .jcall(tsvar, "Lec/tstoolkit/timeseries/simplets/TsData;", "getTsData")
+      if (!.jcall(
+        .jcall(
+          dictionary_var,
+          "Lec/tstoolkit/timeseries/simplets/TsData;", "getTsData"
+        ), "Z", "equals", tsvar_ts_data
+      )) {
+        same_prefix <- grep(paste0("^", name),
+                            .jcall(jd_r_variables, "[S", "getNames"),
+                            value = TRUE)
         same_data <- sapply(same_prefix, function(x) {
-          jd_r_variables$get(x)$getTsData()$equals(tsvar$getTsData())
+          .jcall(
+            .jcall(
+              .jcall(jd_r_variables, "Ljava/lang/Object;", "get", x),
+              "Lec/tstoolkit/timeseries/simplets/TsData;", "getTsData"
+            ), "Z", "equals", tsvar_ts_data
+          )
         })
         if (any(same_data)) {
           # a name fix the same prefix  has the same data
           model_new_var_names <- same_prefix[which(same_data)]
         } else {
-          model_new_var_names <-  base::make.unique(c(jd_r_variables$getNames(),
-                                                  name),
-                                                sep = "_")
+          model_new_var_names <-  base::make.unique(c(
+            .jcall(jd_r_variables, "[S", "getNames"),
+            name),
+            sep = "_")
         }
 
         model_var_names <- name <- tail(model_new_var_names, 1)
@@ -237,7 +263,7 @@ complete_dictionary.SA <- function(workspace, sa_obj){
           # we create a new one
           tsvar <- .jnew("ec/tstoolkit/timeseries/regression/TsVariable",
                          name, ts_r2jd(ud_var$series))
-          jd_r_variables$set(name, tsvar)
+          .jcall(jd_r_variables, "V", "set", name, .jcast(tsvar, "java/lang/Object"))
         }
       }
     }
@@ -250,50 +276,67 @@ complete_dictionary.SA <- function(workspace, sa_obj){
 #' @exportS3Method NULL
 complete_dictionary.jSA <- function(workspace, sa_obj){
   model_dictionary <- sa_obj$dictionary
-  context <- model_dictionary$toContext()
-  current_variables <- context$getTsVariableManagers()$get("r")
-  if (is.null(current_variables) || current_variables$getCount() == 0)
+  context <- .jcall(model_dictionary, "Lec/tstoolkit/algorithm/ProcessingContext;", "toContext")
+  current_variables <- .jcall(
+    .jcall(context,"Lec/tstoolkit/utilities/NameManager;", "getTsVariableManagers"),
+    "Ljava/lang/Object;", "get", "r"
+  )
+  if (is.null(current_variables) || .jcall(current_variables, "I", "getCount") == 0)
     return(sa_obj)
 
   context_dictionary <- .jcall(workspace,"Lec/tstoolkit/algorithm/ProcessingContext;", "getContext")
-  ts_variable_managers <- context_dictionary$getTsVariableManagers()
-  jd_r_variables <- ts_variable_managers$get("r")
+  ts_variable_managers <- .jcall(context_dictionary,"Lec/tstoolkit/utilities/NameManager;", "getTsVariableManagers")
+  jd_r_variables <- .jcall(ts_variable_managers, "Ljava/lang/Object;", "get", "r")
+
   if (is.null(jd_r_variables)) {
-    ts_variable_managers$set("r",
-                             .jnew("ec/tstoolkit/timeseries/regression/TsVariables"))
-    jd_r_variables <- ts_variable_managers$get("r")
+    .jcall(ts_variable_managers, "V", "set", "r",
+           .jcast(.jnew("ec/tstoolkit/timeseries/regression/TsVariables")))
+    jd_r_variables <- .jcall(ts_variable_managers, "Ljava/lang/Object;", "get", "r")
   }
-  variables_names <- data.frame(current_names = current_variables$getNames(),
-             new_names = current_variables$getNames(),
-             stringsAsFactors = FALSE,
-             row.names = current_variables$getNames())
+  variables_names <- data.frame(
+    current_names = .jcall(current_variables, "[S", "getNames"),
+    new_names = .jcall(current_variables, "[S", "getNames"),
+    stringsAsFactors = FALSE,
+    row.names = .jcall(current_variables, "[S", "getNames"))
 
   for (i in seq_len(nrow(variables_names))) {
     name <- variables_names[i,1]
-    var <- current_variables$get(name)
-    dictionary_var <- jd_r_variables$get(name)
+    var <- .jcall(current_variables, "Ljava/lang/Object;", "get", name)
+    dictionary_var <- .jcall(jd_r_variables, "Ljava/lang/Object;", "get", name)
     if (is.null(dictionary_var)) {
-      jd_r_variables$set(name, var)
+      .jcall(jd_r_variables, "V", "set", name, .jcast(var, "java/lang/Object"))
     } else {
-      if (!dictionary_var$getTsData()$equals(var$getTsData())) {
-        same_prefix <- grep(paste0("^", name), jd_r_variables$getNames(), value = TRUE)
+      tsvar_ts_data <- .jcall(var, "Lec/tstoolkit/timeseries/simplets/TsData;", "getTsData")
+      if (!.jcall(
+        .jcall(
+          dictionary_var,
+          "Lec/tstoolkit/timeseries/simplets/TsData;", "getTsData"
+        ), "Z", "equals", tsvar_ts_data
+      )) {
+        same_prefix <- grep(paste0("^", name), .jcall(jd_r_variables, "[S", "getNames"), value = TRUE)
         same_data <- sapply(same_prefix, function(x) {
-          jd_r_variables$get(x)$getTsData()$equals(var$getTsData())
+          .jcall(
+            .jcall(
+              .jcall(jd_r_variables, "Ljava/lang/Object;", "get", x),
+              "Lec/tstoolkit/timeseries/simplets/TsData;", "getTsData"
+            ), "Z", "equals", tsvar_ts_data
+          )
         })
         if (any(same_data)) {
           # a name fix the same prefix  has the same data
           model_var_names <- same_prefix[which(same_data)]
         } else {
-          model_var_names <-  base::make.unique(c(jd_r_variables$getNames(),
-                                                  name),
-                                                sep = "_")
+          model_var_names <-  base::make.unique(c(
+            .jcall(jd_r_variables, "[S", "getNames"),
+            name),
+            sep = "_")
         }
-        current_variables$remove(name)
+        .jcall(current_variables, "V", "remove", name)
         name <- tail(model_var_names, 1)
-        var$setName(name)
-        current_variables$set(name, var)
+        .jcall(var, "V", "setName", name)
+        .jcall(current_variables, "V", "set", name, .jcast(var, "java/lang/Object"))
         if (!any(same_data))
-          jd_r_variables$set(name, var)
+          .jcall(jd_r_variables, "V", "set", name, .jcast(var, "java/lang/Object"))
 
         variables_names[i,2] <- name
       }
@@ -304,11 +347,11 @@ complete_dictionary.jSA <- function(workspace, sa_obj){
     return(sa_obj) # no name has been change
 
 
-  core <- sa_obj$spec$getCore()$clone()
+  core <- get_jspec(sa_obj)$clone()
 
   if (.jinstanceof(core, "ec/satoolkit/tramoseats/TramoSeatsSpecification")) {
-    core <- .jcast(spec, "ec/satoolkit/tramoseats/TramoSeatsSpecification")
-    spec <- .jnew("jdr/spec/tramoseats/TramoSeatsSpec",core)
+    core <- .jcast(core, "ec/satoolkit/tramoseats/TramoSeatsSpecification")
+    spec <- .jnew("jdr/spec/tramoseats/TramoSeatsSpec", core)
   }else{
     if (.jinstanceof(core, "ec/satoolkit/x13/X13Specification")) {
       core <- .jcast(core, "ec/satoolkit/x13/X13Specification")
@@ -319,7 +362,7 @@ complete_dictionary.jSA <- function(workspace, sa_obj){
   }
   jregression <- spec$getRegression()
   jtd <- jregression$getCalendar()$getTradingDays()
-  user_td <- jtd$getUserVariables()
+  user_td <- .jcall(jtd, "[S", "getUserVariables")
   n_userdefined_var <- .jcall(jregression,"I","getUserDefinedVariablesCount")
 
   if (n_userdefined_var > 0) {
@@ -329,11 +372,11 @@ complete_dictionary.jSA <- function(workspace, sa_obj){
              "getUserDefinedVariable",
              as.integer(i - 1))
     })
-    type <- sapply(ud_vars, function(x) x$getComponent())
-    coeff <- sapply(ud_vars, function(x) x$getCoefficient())
-    var_names <- sapply(ud_vars, function(x) gsub("^r\\.","", x$getName()))
+    type <- sapply(ud_vars, .jcall, "S", "getComponent")
+    coeff <- sapply(ud_vars, .jcall, "D", "getCoefficient")
+    var_names <- gsub("^r\\.","", sapply(ud_vars, .jcall, "S", "getName"))
     new_names <- variables_names[var_names, 2]
-    jregression$clearUserDefinedVariables()
+    .jcall(jregression,"V","clearUserDefinedVariables")
     for (i in seq_len(seq_len(n_userdefined_var))) {
       .jcall(jregression,"V","addUserDefinedVariable",
              new_names[i], type[i], coeff[i])
@@ -347,7 +390,7 @@ complete_dictionary.jSA <- function(workspace, sa_obj){
     .jcall(jtd,"V","setUserVariables", .jarray(paste0("r.",new_names)))
   }
 
-  sa_obj$dictionary <- model_dictionary$fromContext(context)
+  sa_obj$dictionary <- .jcall(model_dictionary, "Ljdr/spec/ts/Utility$Dictionary;", "fromContext", context)
   sa_obj$spec <- spec
 
   return(sa_obj)

R/get_jmodel.R

@@ -1,33 +1,40 @@
 #' @rdname get_model
 #' @name get_model
 #' @export
-get_jmodel <- function(x, workspace,
-                      userdefined = NULL,
-                      progress_bar = TRUE){
+get_jmodel <- function(
+    x, workspace,
+    userdefined = NULL,
+    progress_bar = TRUE,
+    type = c("Domain", "Estimation", "Point")){
   UseMethod("get_jmodel", x)
 }
 #' @export
-get_jmodel.workspace <- function(x, workspace,
-                                userdefined = NULL,
-                                progress_bar = TRUE){
+get_jmodel.workspace <- function(
+    x, workspace,
+    userdefined = NULL,
+    progress_bar = TRUE,
+    type = c("Domain", "Estimation", "Point")){
   multiprocessings <- get_all_objects(x)
   nb_mp <- length(multiprocessings)
 
   result <- lapply(seq_len(nb_mp), function(i){
     if (progress_bar)
       cat(sprintf("Multiprocessing %i on %i:\n", i, nb_mp))
     get_jmodel(multiprocessings[[i]],
-              workspace = x, userdefined = userdefined,
-              progress_bar = progress_bar)
+               workspace = x, userdefined = userdefined,
+               progress_bar = progress_bar,
+               type = type)
   })
   names(result) <- names(multiprocessings)
   result
 
 }
 #' @export
-get_jmodel.multiprocessing <- function(x, workspace,
-                                      userdefined = NULL,
-                                      progress_bar = TRUE){
+get_jmodel.multiprocessing <- function(
+    x, workspace,
+    userdefined = NULL,
+    progress_bar = TRUE,
+    type = c("Domain", "Estimation", "Point")){
   all_sa_objects <- get_all_objects(x)
   nb_sa_objs <- length(all_sa_objects)
 
@@ -36,7 +43,8 @@ get_jmodel.multiprocessing <- function(x, workspace,
 
   result <- lapply(seq_len(nb_sa_objs), function(i){
     res <- get_jmodel(all_sa_objects[[i]],
-                     workspace = workspace, userdefined = userdefined)
+                      workspace = workspace, userdefined = userdefined,
+                      type = type)
     if (progress_bar)
       setTxtProgressBar(pb, i)
     res
@@ -47,11 +55,13 @@ get_jmodel.multiprocessing <- function(x, workspace,
   result
 }
 #' @export
-get_jmodel.sa_item <- function(x, workspace,
-                              userdefined = NULL,
-                              progress_bar = TRUE){
+get_jmodel.sa_item <- function(
+    x, workspace,
+    userdefined = NULL,
+    progress_bar = TRUE,
+    type = c("Domain", "Estimation", "Point")){
 
-  jspec <- get_jspec(x)
+  jspec <- get_jspec(x, type = type)
   jresult <- sa_results(x)
   if(is.null(jresult))
     return(NULL)

R/get_jspec.R

@@ -32,8 +32,8 @@ get_jspec.TRAMO_SEATS <- function(x, ...){
   jspec
 }
 #' @export
-get_jspec.sa_item <- function(x, ...){
-  spec <- sa_spec(x)
+get_jspec.sa_item <- function(x, type = c("Domain", "Estimation", "Point"), ...){
+  spec <- sa_spec(x, type = type)
   if (.jinstanceof(spec, "ec/satoolkit/tramoseats/TramoSeatsSpecification")) {
     spec <- .jcast(spec, "ec/satoolkit/tramoseats/TramoSeatsSpecification")
     spec <- .jnew("jdr/spec/tramoseats/TramoSeatsSpec",spec)