R/export_workspace.R

In RJDemetra: Interface to 'JDemetra+' Seasonal Adjustment Software

#' Create a workspace or a multi-processing
#'
#' Functions to create a 'JDemetra+' workspace (\code{new_workspace()}) and
#' to add a new multi-processing (\code{new_multiprocessing()}).
#'
#' @param workspace a workspace object
#' @param name character name of the new multiprocessing
#'
#' @return \code{new_workspace()} returns an object of class \code{workspace} and
#' \code{new_multiprocessing()} returns an object of class \code{multiprocessing}.
#'
#' @seealso \code{\link{load_workspace}}, \code{\link{save_workspace}},
#' \code{\link{add_sa_item}}
#'
#' @examples
#' # To create and export an empty 'JDemetra+' workspace
#' wk <- new_workspace()
#' mp <- new_multiprocessing(wk, "sa1")
#'
#'
#' @name new_workspace
#' @rdname new_workspace
#' @export
new_workspace <- function() {
  dictionary = .jnull("jdr/spec/ts/Utility$Dictionary")
  wk <- .jcall("ec/tstoolkit/jdr/ws/Workspace",
               "Lec/tstoolkit/jdr/ws/Workspace;",
               "create", dictionary)
  wk <- new("workspace", wk)
  return(wk)
}
#' @name new_workspace
#' @rdname new_workspace
#' @export
new_multiprocessing <- function(workspace, name) {
  mp <- .jcall(workspace, "Lec/tstoolkit/jdr/ws/MultiProcessing;", "newMultiProcessing", name)
  mp <- new("multiprocessing", mp)
  return(invisible(mp))
}



#' Save a workspace
#'
#' Function to save a \code{workspace} object into a 'JDemetra+' workspace.
#'
#' @param workspace the workspace object to export
#' @param file the path where to export the 'JDemetra+' workspace (.xml file).
#' By default, if not specified, a dialog box opens.
#'
#' @seealso \code{\link{load_workspace}}
#'
#' @examples \donttest{
#' dir <- tempdir()
#' # Creation and export of an empty 'JDemetra+' workspace
#' wk <- new_workspace()
#' new_multiprocessing(wk, "sa1")
#' save_workspace(wk, file.path(dir, "workspace.xml"))
#'}
#'
#' @return A boolean indicating whether the export is successful.
#' @export
save_workspace <- function(workspace, file) {
  if (missing(file) || is.null(file)) {
    if (Sys.info()[['sysname']] == "Windows") {
      file <- utils::choose.files(default = "demetra_m.xml",
                                  caption = "Select a workspace for the output",
                                  filters = c("JDemetra+ workspace (.xml)", "*.xml"))
    }else{
      file <- NULL # base::file.choose()
    }
    if (length(file) == 0)
      stop("You must choose a file !")
  }
  if (length(grep("\\.xml$",file)) == 0)
    stop("The file must be a .xml !")

  full_file_name <- full_path(file)

  result <- .jcall(workspace, "Z", "save", full_file_name)

  invisible(result)
}

full_path <- function(path) {
  base::file.path(
    base::normalizePath(dirname(path), mustWork = TRUE, winslash = "/"),
    base::basename(path),
    fsep = "/")
}


#' Add a seasonally adjusted series to a multi-processing
#'
#' Function to add a new seasonally adjusted object (class \code{"SA"} or \code{"jSA"}) to a \code{workspace} object.
#'
#' @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 name the name of the seasonally adjusted series in the multiprocessing.
#' By default the name of the \code{sa_obj} is used.
#'
#' @seealso \code{\link{load_workspace}}, \code{\link{save_workspace}}
#'
#' @examples\donttest{
#' dir <- tempdir()
#' # Adjustment of a series with the x13 and Tramo-Seats methods
#' spec_x13 <- x13_spec(spec = "RSA5c", easter.enabled = FALSE)
#' sa_x13 <- x13(ipi_c_eu[, "FR"], spec = spec_x13)
#' spec_ts <- tramoseats_spec(spec = "RSA5")
#' sa_ts <- jtramoseats(ipi_c_eu[, "FR"], spec = spec_ts)
#'
#' # Creation of a new workspace..
#' wk <- new_workspace()
#' # and of the multiprocessing "sa1" that will contain the series
#' new_multiprocessing(wk, "sa1")
#' # Addition of the adjusted series to the workspace via the sa1 multiprocessing
#' add_sa_item(wk, "sa1", sa_x13, "X13")
#' add_sa_item(wk, "sa1", sa_ts, "TramoSeats")
#'
#' # Export of the new filled workspace
#' save_workspace(wk, file.path(dir, "workspace.xml"))
#' }
#'
#' @export
add_sa_item <- function(workspace, multiprocessing, sa_obj, name){
  if (is.character(multiprocessing)) {
    nb_mp_objects <- count(workspace)
    mp_objects <- lapply(seq_len(nb_mp_objects),
                         function(i) {
                           get_object(workspace, i)
                         })
    mp_names <- sapply(mp_objects, get_name)
    multiprocessing <- match(multiprocessing, mp_names)
    if (is.na(multiprocessing))
      stop("The multiprocessing ",multiprocessing," doesn't exist !")
  }
  if (!is.numeric(multiprocessing))
    stop("The parameter for the multiprocessing must be a character or a numeric")

  if (missing(name))
    name <- deparse(substitute(sa_obj))

  sa_obj <- complete_dictionary(workspace, sa_obj)
  jspec <- get_jspec(sa_obj)
  y <- get_ts(sa_obj)

  if (!is.character(name) || length(name) != 1)
    stop("The name of the SA element to add is mispecified")

  mp_obj <- get_object(workspace, multiprocessing)
  .jcall(mp_obj, "V", "add", name, ts_r2jd(y), jspec)
}

#' @exportS3Method NULL
complete_dictionary <- function(workspace, sa_obj){
  UseMethod("complete_dictionary", sa_obj)
}
#' @exportS3Method NULL
complete_dictionary.SA <- function(workspace, sa_obj){
  userdef <- sa_obj$regarima$specification$regression$userdef
  ud_var <- userdef$variables
  if (is.null(ud_var) || !userdef$specification["variables"] || all(is.na(ud_var$series)))
    return(sa_obj)

  context_dictionary <- .jcall(workspace,"Lec/tstoolkit/algorithm/ProcessingContext;", "getContext")
  ts_variable_managers <- .jcall(context_dictionary,"Lec/tstoolkit/utilities/NameManager;", "getTsVariableManagers")
  ts_variables <- .jnew("ec/tstoolkit/timeseries/regression/TsVariables")
  jd_r_variables <- .jcall(ts_variable_managers, "Ljava/lang/Object;", "get", "r")
  if (is.null(jd_r_variables)) {
    .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 <- .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 <- .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)) {
        .jcall(jd_r_variables, "V", "set", name, .jcast(tsvar, "java/lang/Object"))
      } else {
        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) {
            .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(
              .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]))
            .jcall(jd_r_variables, "V", "set", name, .jcast(tsvar, "java/lang/Object"))
          }
        }
      }
    }
  }else{
    name <- model_var_names
    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)) {
      .jcall(jd_r_variables, "V", "set", name, .jcast(tsvar, "java/lang/Object"))
    } else {
      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) {
          .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(
            .jcall(jd_r_variables, "[S", "getNames"),
            name),
            sep = "_")
        }

        model_var_names <- 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))
          .jcall(jd_r_variables, "V", "set", name, .jcast(tsvar, "java/lang/Object"))
        }
      }
    }
  }
  rownames(sa_obj$regarima$specification$regression$userdef$variables$description) <-
    model_var_names

  return(sa_obj)
}
#' @exportS3Method NULL
complete_dictionary.jSA <- function(workspace, sa_obj){
  model_dictionary <- sa_obj$dictionary
  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 <- .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)) {
    .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 = .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 <- .jcall(current_variables, "Ljava/lang/Object;", "get", name)
    dictionary_var <- .jcall(jd_r_variables, "Ljava/lang/Object;", "get", name)
    if (is.null(dictionary_var)) {
      .jcall(jd_r_variables, "V", "set", name, .jcast(var, "java/lang/Object"))
    } else {
      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) {
          .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(
            .jcall(jd_r_variables, "[S", "getNames"),
            name),
            sep = "_")
        }
        .jcall(current_variables, "V", "remove", name)
        name <- tail(model_var_names, 1)
        .jcall(var, "V", "setName", name)
        .jcall(current_variables, "V", "set", name, .jcast(var, "java/lang/Object"))
        if (!any(same_data))
          .jcall(jd_r_variables, "V", "set", name, .jcast(var, "java/lang/Object"))

        variables_names[i,2] <- name
      }
    }
  }

  if (identical(variables_names[,1], variables_names[,2]))
    return(sa_obj) # no name has been change


  core <- get_jspec(sa_obj)$clone()

  if (.jinstanceof(core, "ec/satoolkit/tramoseats/TramoSeatsSpecification")) {
    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")
      spec <- .jnew("jdr/spec/x13/X13Spec", core)
    } else{
      spec = sa_obj$spec
    }
  }
  jregression <- spec$getRegression()
  jtd <- jregression$getCalendar()$getTradingDays()
  user_td <- .jcall(jtd, "[S", "getUserVariables")
  n_userdefined_var <- .jcall(jregression,"I","getUserDefinedVariablesCount")

  if (n_userdefined_var > 0) {
    ud_vars <- lapply(seq_len(n_userdefined_var), function(i){
      .jcall(jregression,
             "Ljdr/spec/ts/Utility$UserDefinedVariable;",
             "getUserDefinedVariable",
             as.integer(i - 1))
    })
    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]
    .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])

    }
  }

  if (length(user_td) > 0) {
    var_names <- gsub("^r\\.","", user_td)
    new_names <- variables_names[var_names, 2]
    .jcall(jtd,"V","setUserVariables", .jarray(paste0("r.",new_names)))
  }

  sa_obj$dictionary <- .jcall(model_dictionary, "Ljdr/spec/ts/Utility$Dictionary;", "fromContext", context)
  sa_obj$spec <- spec

  return(sa_obj)
}