R/r_banner.R

In pelishk/upax_library: Librería de análisis

#' función para generar banners de resultados
#'
#' Una función que genera las tablas y banners
#'
#' @param variable cadena con el nombre de la variable de la que se quiere el resultado
#' @param nombre nombre final que tiene la variable
#' @param tipo cadena con los tipos de tablas que se calcularán separados por espacios "p pp fp f"
#' @param ponderador cadena con el nombre del ponderador que se utilizará, default NA
#' @param datos dataframe con los datos
#' @param filtro cadena con la condición de filtrado que se desea aplicar "%>% filter(!is.na("variable"))"
#' @param banner vector de cadenas donde se especifican las variables de banner
#' @param banner_nombre vector de cadenas donde se especifican los nombres que tendrán las variables de banner
#' @param orden caracter que define el orden en el que se presentan los resultados en el caso de variables categóricas. n-orden natural. d-orden decreciente. c-orden creciente
#' @param extra1 cadena variable
#' @param extra2 cadena variable
#' @param extra3 cadena variable
#' @param extra4 cadena variable
#' @section Múltiple:
#' Para calcular resultados sobre una variable de respuesta múltiple debemos establecer obligatoriamente extra1 = "multiple", variable = "raiz" (la raíz compartida de todas las variables que contienen las respuestas), Adicionalmente se pueden utilizar los parámetros opcionales extra2 = 'cadena' que establece la cadena de las variables que queremos excluir, extra3 = 'nivel' que es el nivel que queremos que sea removido de las tablas de resultados, extra4 = 'nivel' que determina un nivel especial que se tomará en cuenta sólamente en la primer columna y en todas las demás será igual a cero. 



r_banner <- function(variable,nombre=NA,filtro,tipo='p',ponderador = NA,datos,banner,banner_nombre=NA, orden = 'n',extra = NA,extra2 = NA,extra3 = NA,extra4 = NA){
  
  # funciones
  
  if(is.na(nombre))nombre <- variable
  if(is.na(banner_nombre)) banner_nombre <- banner

  f_deja_una_sola_columna <- function(t){
    nombres <- t[,1]
    t <- t %>% dplyr::select(-1) %>% data.frame
    rownames(t) <- nombres
    return(t)
  }
  w_reduce_tablas <- function(df1,df2){
    
    
    
    resultado <- merge(df1,df2,by = 'row.names',all = T)
    
    resultado[is.na(resultado)] <- 0
    
    rownames(resultado) <- resultado[,1]
    
    resultado <- resultado[,-1]
    
    
    return(resultado)
    
    
  }
  f_resto <- function(variable,nombre,tipo,ponderador,datos,banner, banner_nombre, filtro, orden,extra, extra2, extra4){
    
    lista_tablas <- list()
    estructura_t  <- tryCatch(eval(parse(text = paste0('is.numeric(datos$',variable,')'))),error = function(e){FALSE})
      k=1
      for(i in banner){
      lista_datos <- eval(parse(text = paste0(
        'datos %>% group_split(',i,')'
      )))
      
      nombre_var <- banner_nombre[k] 
      niveles <- map(lista_datos,w_primer_elemento,i) %>% unlist
      
 
      if(estructura_t){
        lista_tablas[[i]] <- map(lista_datos,.f = r_tablas, variable = variable,tipo = tipo, nombre = nombre, ponderador = ponderador, filtro = filtro, extra = extra, extra2 = extra2, extra4 = extra4) %>% reduce(.,w_reduce_tablas)
      }else{
        lista_tablas[[i]] <- map(lista_datos,.f = r_tablas, variable = variable,tipo = tipo, nombre = nombre, ponderador = ponderador, filtro = filtro, extra = extra, extra2 = extra2, extra4 = extra4) %>% map(.,f_deja_una_sola_columna) %>%reduce(.,w_reduce_tablas)
          # map2(niveles,.,f_renombra,nombre_var) %>% f_intercala
      }
      
      
      names(lista_tablas[[i]]) <- paste0(i,'::',rep(niveles,each = nchar(tipo)),'::',word(names(lista_tablas[[i]]),1,sep = '\\.'))
      
      k <- k+1
    }
    
    return(lista_tablas)
    
  }
  f_renombra_total <- function(tabla){
    names(tabla)[-1] <- paste0('TOTAL::',names(tabla)[-1])
    return(tabla)
  }
  f_reduce_intermedio <- function(lista){
    resultado <- reduce(lista,cbind)
    return(resultado)
  }
  f_ordenar_resultado <- function(tabla,orden){
    
    if(orden == 'n'){
      resultado <- tabla
    }
    
    if(orden == 'd'){
      
      nombre1 <- names(tabla)[1]
      
      t1 <- tabla[which(tabla[,1] != 'Total'),]
      t2 <- tabla[which(tabla[,1] == 'Total'),]
      
      nombre <- names(tabla)[2]
      resultado <- eval(parse(text = paste0(
        't1 %>% arrange(-`',nombre,'`)'
      )))
      
      resultado <- rbind(resultado,t2)
    }
    
    if(orden == 'c'){
      nombre1 <- names(tabla)[1]
      
      t1 <- tabla[which(tabla[,1] != 'Total'),]
      t2 <- tabla[which(tabla[,1] == 'Total'),]
      
      nombre <- names(tabla)[2]
      resultado <- eval(parse(text = paste0(
        't1 %>% arrange(`',nombre,'`)'
      )))
      
      resultado <- rbind(resultado,t2)
    }
    
    return(resultado)
    
  }
  f_quita_renglon <- function(tabla,cualquita){
    nombre <- names(tabla)[1]
    eval(parse(text = paste0(
      'resultado <- tabla %>% filter(`',nombre,'` != "',cualquita,'")'
    )))
    return(resultado)
  }

  # estructura
  
  estructura <- tryCatch(eval(parse(text = paste0('is.numeric(datos$',variable,')'))),error = function(e){FALSE})
  
  # ejecución sobre los banners
  
  if(estructura){
    r_resto <- f_resto(variable = variable,nombre = nombre,tipo = tipo,ponderador = ponderador,datos = datos,banner = banner, banner_nombre = banner_nombre, filtro = filtro,extra = extra,extra2 = extra2, extra4 = extra4, orden = orden) %>% map(.,f_reduce_intermedio) %>% reduce(.,cbind)
  }else{
    r_resto <- f_resto(variable = variable,nombre = nombre,tipo = tipo,ponderador = ponderador,datos = datos,banner = banner, banner_nombre = banner_nombre, filtro = filtro,extra = extra,extra2 = extra2, extra4 = extra4, orden = orden) %>% reduce(.,cbind)
  }
  
  # ejecución sobre la tabla completa
  
  r_total <- r_tablas(variable = variable, nombre = nombre, tipo = tipo, ponderador = ponderador, datos = datos, filtro = filtro, extra = extra, extra2 = extra2, extra4 = extra4) %>% f_renombra_total
  resultado  <- cbind(r_total,r_resto)  %>% f_ordenar_resultado(.,orden = orden)
  
  
  
  # extras
  
  if(!is.na(extra)){
    if(!is.na(extra3)){
      resultado <- f_quita_renglon(resultado,extra3)
    }
  }
  

  
  
  return(resultado)
}