R/import.R

In InseeFrLab/rtauargus: Using Tau-Argus from R

# Fonctions utiles ------------------------------------------------------------

read_fixheader <- function(file,
                           fixed_header = NULL,
                           read_function = utils::read.csv,
                           ...) {

  ## lit un fichier avec potentiellement une colonne vide de trop
  ## dans l'en-tete (bug de Tau-Argus 4.1.4 notamment)
  ## si en-tete corrigé non fourni, le déduit de la première ligne du fichier

  if (is.null(fixed_header)) {
    # lit l'en-tete seulement
    header <-
      scan(
        text = readLines(file, n = 1),
        what = "character",
        sep = ",",
        na.strings = "",
        quiet = TRUE
      )
    fixed_header <- stats::na.omit(header)
  }

  # lit sauf ligne 1 en specifiant en-tete corrigé
  read_function(
    file,
    skip = 1,
    header = FALSE,
    col.names = fixed_header,
    ...
  )

}

# fonction read.csv avec parametres predefinis pour lire output TA
my_readcsv <-
  purrr::partial(
    utils::read.csv,
    stringsAsFactors = FALSE,
    na.strings = "-"
  )

read_ta_output <- function(file, type, expl_resp) {

  ## lit une sortie de Tau-Argus en fonction du type et des options
  ## renseignées

  if (type == "2") {

    res <- read_fixheader(file, read_function = my_readcsv)

  } else if (type == "4") {

    res <- my_readcsv(
      file,
      header = FALSE,
      col.names = c(expl_resp, "N", "Status", "Dom")
    )

  } else {

    warning(
      "impossible d'importer autre chose que ",
      "type \"2\" (csv file for pivot-table), ",
      "type \"4\" (SBS output-format).",
      call. = FALSE
    )
    res <- data.frame()

  }

  if (!is.null(res$Status)) res$Status <- as.character(res$Status)

  res

}

meta_import <- function(data,
                        explanatory,
                        response,
                        shadow,
                        cost,
                        apriori,
                        safetyrule,
                        suppress,
                        output_type,
                        output_options) {

  ## ajoute les meta donnees du batch (atrributs) à un tableau exporté

  # liés ?
  num_tab <- stringr::str_match(suppress, "\\((\\d+)")[ , 2]
  linked <- all(num_tab == 0)

  # remplace num tabl par point
  suppress <- sub("\\(\\d+,", "\\(.,", suppress)

  structure(
    data,
    explanatory_vars = explanatory,
    response_var     = response,
    shadow_var       = if (shadow != "") shadow,
    cost_var         = if (cost != "") cost,
    apriori          = if (!is.na(apriori)) apriori,
    safetyrule       = safetyrule,
    suppress         = suppress,
    linked           = linked,
    output_type      = output_type,
    output_options   = if (output_options != "") output_options
  )

}


# Fonction exportée -----------------------------------------------------------

#' Imports results from Tau-Argus
#'
#' Imports into R the results generated by Tau-Argus from the information
#' contained in an arb file. \cr
#' (Importe dans R les résultats générés par Tau-Argus à partir des informations
#' contenues dans un fichier arb.)
#'
#' Requires that the batch has been executed and finished without error. In order
#' to import immediately after the batch has been executed, this function will be
#' most often called via \code{link{run_arb}} (by setting
#' `import = TRUE`).
#'
#' It is only possible (for the moment) to import results of type "2"
#' (csv for pivot-table) and "4" (sbs). If it is not possible to import for
#' a given tabulation, an empty data.frame is returned (with a
#' message). \cr
#'
#' (Nécessite que le batch ait été exécuté et se soit terminé sans erreur. Afin
#' d'importer immédiatement après exécution du batch, cette fonction sera ainsi
#' le plus souvent appelée via [run_arb()] (en paramétrant
#' `import = TRUE`).
#'
#' Il n'est possible (pour l'instant) que d'importer les résultats de type "2"
#' (csv for pivot-table) et "4" (sbs). En cas d'impossibilité de l'import pour
#' une tabulation donnée, un data.frame vide est retourné (avec un message
#' d'avertissement).)
#'
#' @param arb_filename name of the arb file (with extension) containing the
#' information needed for the import. \cr
#' (nom du fichier arb (avec extension) contenant les
#'   informations nécessaires à l'import.)
#'
#' @return A list of one or more data.frames. Each data.frame corresponds to
#' to the result of a tabulation. The names of the tables filled in the
#' lines of the batch of the form `// <TABLE_ID> "..."` are recovered. \cr
#' (Une liste d'un ou plusieurs data.frames. Chaque data.frame correspond
#'   au résultat d'une tabulation. Les noms des tableaux renseignés dans les
#'   lignes du batch de la forme `// <TABLE_ID> "..."` sont récupérés.)
#'
#' @section Attributes:
#'
#' Each data.frame is associated with a set of attributes (metadata)
#' allowing to keep a trace of the specifications passed to Tau-Argus.
#'
#' Attributes systematically present :
#' `explanatory_vars`, `response_var`, `safetyrule`,
#' `suppress`, `linked`, `output_type`.
#'
#' Attributes present only if the corresponding option has been filled in by
#' the user: `shadow_var`, `cost_var`, `output_options`. \cr
#'
#' (À chaque data.frame est associé un ensemble d'attributs (métadonnées)
#' permettant de conserver une trace des spécifications passées à Tau-Argus.
#'
#' Attributs systématiquement présents :
#' `explanatory_vars`, `response_var`, `safetyrule`,
#' `suppress`, `linked`, `output_type`.
#'
#' Attributs présents uniquement si l'option correspondante a été renseignée par
#' l'utilisateur : `shadow_var`, `cost_var`, `output_options`.)
#'
#' @inheritSection micro_asc_rda See also
#'
#' @importFrom dplyr %>%
#' @importFrom purrr map_at
#' @importFrom purrr transpose
#'
#' @export

import <- function(arb_filename) {

  # extrait infos arb
  infos <- arb_contents(arb_filename)

  # présence fichiers
  manq <- !file.exists(infos$writetable$output_names)
  if (any(manq)) {
    stop(
      "fichiers texte introuvables ",
      "(echec Tau-Argus ou supprimes entre-temps) : \n    ",
      paste(infos$writetable$output_names[manq], collapse = "\n    ")
    )
  }

  # nom variables
  expl_resp <-
    infos$specifytable[c("explanatory", "response")] %>%
    transpose() %>%
    lapply(unlist, use.names = FALSE)

  # lecture fichiers
  res <- mapply(
    infos$writetable$output_names,
    infos$writetable$output_types,
    expl_resp,
    FUN = read_ta_output,
    USE.NAMES = FALSE,
    SIMPLIFY = FALSE
  )
  # id des tableaux
  if (!is.null(infos$tab_id)) names(res) <- infos$tab_id

  # apriori (pas de mix possible renseigné/non-renseigné)
  apriori <- rep(NA, length(res)) # init vecteur vide
  if (!is.null(infos$apriori)) apriori <- infos$apriori$file

  # ajout metadonnees batch
  # (specif table, safetyrule, suppress, output_type, output_options)
  mapply(
    res,
    infos$specifytable$explanatory,
    infos$specifytable$response,
    infos$specifytable$shadow,
    infos$specifytable$cost,
    apriori,
    infos$safetyrule,
    infos$suppress,
    infos$writetable$output_types,
    infos$writetable$output_options,
    FUN = meta_import,
    SIMPLIFY = FALSE
  )

}