R/oln_table+.R

In igutierrezm/mypkgr: Diccionario de variables del OLN

# Crea un listado de tablas, una por cada especificación en args
oln_table_create <- function(args) {
  # Prólogo ====================================================================

  # Inicializaciones
  chart  <- list()  # resultados
  bylist <- list()  # desagregaciones

  # Deduce el número de especificaciones
  n <- length(args) - 4

  # Completa y corrige los argumentos variables
  for (i in 1:n) {
    # Inicializa el resultado para la i-ésima especificación
    chart[[i]] <- data.frame()

    # Convierte la subpoblación en una expresión
    args[[i]]$subpop <-
      args[[i]]$subpop %>%
      (function(x) parse(text = as.character(x)[2]))

    # Identifica todas las agregaciones posibles (como character-vectors)
    bylist[[i]] <-
      args[[i]]$by       %>%
      all.vars()         %>%
      sets::as.set()     %>%
      sets::set_power()  %>%
      as.list()          %>%
      lapply(function(x) as.character(x) %>% paste(collapse = '+'))
    # ¿Por qué no puedo usar as.character en lapply? Preguntar a Camila.

    # Corrige la agregación vacía
    bylist[[i]][[1]] <- "n_"

    # Identifica todas las agregaciones posibles (como fórmulas)
    bylist[[i]] <-
      bylist[[i]] %>%
      lapply(function(x) paste0(x, collapse = '+')) %>%
      lapply(function(x) paste0("~", x)) %>%
      lapply(as.formula)
  }

  # Cuerpo =====================================================================

  # Notar la jerarquía del loop: año => mes => especificación => agregación
  for (year in args$years) {
    for (month in args$months) {
      # Identifica la BBDD
      if (args$src == "casen") pattern <- "%s/feather/CASEN %d.feather"
      if (args$src == "ene")   pattern <- "%s/feather/ENE %d %02d.feather"
      if (args$src == "esi")   pattern <- "%s/feather/ESI %d.feather"
      path <- sprintf(pattern, args$data, year, month)
      if (!file.exists(path)) next

      # Identifica los outputs
      outputs <- c("psu_", "strata_", "pw_")
      for (i in 1:n) {
        outputs <-
          args[[i]]                 %>%
          lapply(all.vars)          %>%
          unlist(use.names = FALSE) %>%
          c(outputs)                %>%
          unique()
      }

      # Identifica y carga los inputs
      inputs <- mypkgr::oln_find_inputs(outputs, args$src, year, month)
      df <- feather::read_feather(path, columns = inputs)

      # Genera los outputs
      df <- df %>%
        mypkgr::oln_generate(outputs, args$src, year, month) %>%
        dplyr::select(dplyr::one_of(outputs)) %>%
        dplyr::mutate(n_ = 1)

      # Declara el diseño muestral
      df <- survey::svydesign(~psu_,
                              strata  = ~strata_,
                              weights = ~pw_,
                              data    = df)

      # Realiza la estimación, según especificación y desagregación
      for (i in 1:n) {
        for (by in bylist[[i]]) {
          chart0 <-
            svyby(args[[i]]$formula,
                  by,
                  args[[i]]$FUN,
                  design = subset(df, eval(args[[i]]$subpop, df$variables)),
                  na.rm             = TRUE,
                  drop.empty.groups = FALSE,
                  quantiles         = args$quantiles)

          # Ordena el resultado
          chart0 <- mypkgr::oln_table_reshape(chart0, args[[i]])

          # Añade los índices temporales
          chart0 <- dplyr::mutate(chart0, year = year, month = month)

          # Anexa el resultado
          chart[[i]] <-
            list(chart0, chart[[i]]) %>%
            data.table::rbindlist(fill = TRUE)
        }
      }
    }
  }

  # Epílogo ====================================================================

  # Ajustes cosméticos
  for (i in 1:n) {
    # Reetiqueta los NA de los dominios como totales
    for (by in all.vars(args[[i]][["by"]])) {
      # Captura las etiquetas de la variable
      labs <- levels(chart[[i]][[by]])

      # Refactoriza la variable
      chart[[i]][[by]] <-
        chart[[i]][[by]] %>%
        factor(levels  = c(labs, NA),
               labels  = c(labs, "Total"),
               exclude = NULL)
    }

    # Elimina las variables temporales
    chart[[i]] <- chart[[i]] %>%
      tibble::as.tibble() %>%
      dplyr::select(-n_)
  }


  # Reporta el resultado
  return(chart)
}

# Ordena los resultados de oln_table_create
oln_table_reshape <- function(df, args) {
  # Convierte args$formula en character
  fm <- as.character(args$formula)[2]

  # Deduce las variables asociadas al bh
  nm_bh <- attr(df, "svyby")$variables
  n <- length(nm_bh)

  # Deduce las variables asociadas al se y a los dominios
  if (n == 1) nm_se <- "se"
  if (n >= 2) nm_se <- sprintf("se.%s", nm_bh)
  nm_over <- names(df) %>% setdiff(nm_bh) %>% setdiff(nm_se)

  # Divide df en dos bloques
  df_bh <- dplyr::select(df, dplyr::one_of(c(nm_over, nm_bh)))
  df_se <- dplyr::select(df, dplyr::one_of(c(nm_over, nm_se)))

  # Lo que sigue solo tiene sentido si n > 1
  if (n > 1) {
    # Ordena los resultados de cada bloque
    df_bh <- tidyr::gather_(df_bh, fm, "bh", nm_bh, factor_key = TRUE)
    df_se <- tidyr::gather_(df_se, fm, "se", nm_se, factor_key = TRUE)

    # Ajusta las etiquetas de key
    labs_bh <- df_bh[[fm]] %>% levels() %>% substring(nchar(fm) + 1)
    labs_se <- df_se[[fm]] %>% levels() %>% substring(nchar(fm) + 4)
    df_bh[[fm]] <- factor(df_bh[[fm]], labels = labs_bh)
    df_se[[fm]] <- factor(df_se[[fm]], labels = labs_se)
  }

  # Combina las BBDD
  df <- suppressMessages(dplyr::inner_join(df_bh, df_se))

  # Agrega el cv
  df[["cv"]] <- 100 * df[["se"]] / abs(df[["bh"]])

  # Presenta los resultados
  return(df)
}