# 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)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.