R/svyby (trash).R

# #' Un wrapper a la función \code{survey::svyby}
# #'
# #' @param formula Una fórmula que especifica las variables a pasar a \code{FUN}.
# #' @param by      Una fórmula de factores que definen los dominios.
# #' @param design  Un objeto svydesign o svrepdesign.
# #' @param subpop  UNa expresión lógica que indica las filas a conservar,
# #'                los valores perdidos se toman como falsos.
# #' @param FUN     Una función que toma una fórmula y Un objeto
# #'                svydesign o svrepdesign como sus dos primeros argumentos.
# #' @param ...     Otros argumentos de \code{survey::svyby} \code{FUN}.
# #'
# #' @return Un objeto de clase svyby.
# #'
# #' @export
# #' @encoding   UTF-8
# svyby2 <- function(formula, by, design, subpop, FUN, ...) {
#   # Evalúa todos los argumentos que vienen como formulas
#   formula <- eval(formula)
#   subpop  <- eval(subpop)
#   by      <- eval(by)
#
#   # Convierte subpop en una expresión
#   subpop <- deparse(subpop)
#   subpop <- gsub("~", "", subpop)
#   subpop <- parse(text = subpop)
#
#   # Llama al comando survey::svyby
#   x <- survey::svyby(
#     # Argumentos principales de svyby
#     formula = formula,
#     by      = by,
#     design  = subset_ee(design, substitute(subpop)),
#     FUN     = FUN[[1]],
#     # Argumentos secundarios (pre-asignados) de svy
#     drop.empty.groups = FALSE,
#     # Argumentos secundarios (pre-asignados) de FUN
#     na.rm = TRUE,
#     ci    = TRUE,
#     # Otros argumentos
#     ...
#   )
#
#   # Guarda (como atributos) los parámetros principales de svyby
#   attr(x, "formula") <- deparse(substitute(formula))
#   attr(x, "subpop")  <- paste0("~", subpop)
#   attr(x, "FUN")     <- names(FUN)
#   attr(x, "by")      <- deparse(substitute(by))
#   dots <- list(...)
#   for (arg in names(dots)) {
#     attr(x, arg) <- dots[[arg]]
#   }
#
#   # Modifica la clase de x (heredando la original)
#   class(x) <- c("svyby2", class(x))
#
#   # Reporta el resultado
#   return(x)
# }
#
# # Una escotilla de escape para subset.survey.design y subset.svyrep.design
# subset_ee <- function(x, subset, ...) UseMethod("subset_ee")
# subset_ee.default <- function(x, subset, ...) {
#   r <- eval(subset, x$variables, parent.frame()) # Evalúa subset en x$variables
#   r <- r & !is.na(r)                             # Reemplaza NA por FALSE
#   x <- x[r, ]                                    # Filtra x
#   x$call <- sys.call(-1)                         # Actualiza x$call
#   return(x)                                      # Reporta el resultado
# }
#
# # Ordena y explicita los resultados de svyby2
# tidy <- function(x) UseMethod("tidy")
# tidy.svyby <- function(x) {
#   # Captura información útil de los attributes(x)
#   attrs   <- attributes(x)
#   vars    <- attrs$svyby$variables
#   nstats  <- attrs$svyby$nstats
#   formula <- attrs$formula
#
#   # Ajusta los nombres de las variables
#   if (nstats == 1) {
#     names(x)[ncol(x) - 1] <- "bh"
#   } else {
#     for (var0 in vars) {
#       var1 <- paste("bh", var0, sep = ".")
#       x[[var1]] <- x[[var0]]
#       x[[var0]] <- NULL
#     }
#   }
#
#   # Reordena x
#   if (nstats > 1) {
#     # Reúne las columnas en pares clave-valor
#     x <- tidyr::gather(x, key, value, matches("^(bh|se)+"))
#
#     # Corrige la clave (facilitará su separación)
#     x$key <- gsub("bh.", "bh~", x$key, fixed = TRUE)
#     x$key <- gsub("se.", "se~", x$key, fixed = TRUE)
#     x$key <- gsub(formula, "~", x$key, fixed = TRUE)
#
#     # Separa la clave
#     x <- tidyr::separate(x, key, c("stat", gsub("~", "", formula)), "~")
#
#     # Distribuye el par stat-value en dos columnas
#     x <- tidyr::spread(x, stat, value)
#   }
#
#   # Convierte los atributos claves de x en variables
#   for (attrib in c("formula", "subpop", "FUN", "by")) {
#     x[[attrib]] <- attrs[[attrib]]
#   }
#
#   # Rerdena las columnas
#   x <- dplyr::select(x, FUN, formula, by, subpop, everything())
#
#   # Presenta los resultados
#   return(x)
# }
igutierrezm/olndictr documentation built on May 31, 2019, 8:07 a.m.