R/dcc6_fixed.R

In gibonet/distrr: Estimate and Manage Empirical Distributions

## #' @inheritParams dcc6


#' @param fixed_variable name of the variable for which you do not want to estimate the total
#' 
#' @rdname dcc6
#' @export
dcc6_fixed <- function(.data, 
                       .variables, 
                       .funs_list = list(n = ~dplyr::n()), 
                       .total = "Totale", 
                       order_type = extract_unique5, 
                       .all = TRUE, 
                       fixed_variable = NULL) {
  
  
  if (is.null(fixed_variable)) {
    cube <- dcc6(.data, .variables, .funs_list, .total, order_type, .all = .all)
  } else {
    # Some checks
    stopifnot(fixed_variable %in% .variables)
    stopifnot(is.character(fixed_variable) & length(fixed_variable) == 1)
    
    if (!is.factor(.data[[fixed_variable]])) {
      .data[[fixed_variable]] <- as.character(.data[[fixed_variable]])
      fixed_values <- sort(unique(.data[[fixed_variable]]))
    } else {
      fixed_values <- levels(.data[[fixed_variable]])
    }
    
    fixed_values <- fixed_values[!is.na(fixed_values)]
    
    # Data preparation, before the computations for the cube creation
    d <- prepare_data(
      .data = .data, 
      .variables = .variables, 
      .total = .total,
      order_type = order_type
    )
    
    # Computations for the cube creation
    l <- d[["l"]]; data_new <- d[["data_new"]]; l_lev <- d[["l_lev"]]
    
    cube_list <- vector(mode = "list", length = length(fixed_values))
    
    pb <- utils::txtProgressBar(style = 3, max = l)
    for (i in seq_along(cube_list)) {
      to_keep <- paste0(fixed_variable, " == '", fixed_values[i], "'")
      
      cube_list[[i]] <- data_new |>
        filter2_(.dots = to_keep) |>
        joint_all_funs_(
          .variables = .variables[!.variables %in% fixed_variable], 
          .funs_list = .funs_list, 
          .total = .total, 
          .all = .all,
          showProgress = FALSE
        )
      
      utils::setTxtProgressBar(pb, i)
      
      cube_list[[i]][[fixed_variable]] <- fixed_values[i]
    }
    close(pb)
    
    cube <- dplyr::bind_rows(cube_list)
    
    cols <- colnames(cube)
    no_vars <- cols[!cols %in% .variables]
    cols <- c(.variables, no_vars)
    
    cube <- cube |> select2_(cols)
    
    # Last operations, after the creation of the data cube.
    # Reordering columns, creating factors, arranging rows, ...
    cube <- finish_cube(
      joint_all = cube, 
      .variables = .variables,
      l_lev = l_lev, 
      l = l
    )
    
    cube[[fixed_variable]] <- droplevels(cube[[fixed_variable]])
    
    
    attributes(cube)[[".variables"]] <- .variables
    attributes(cube)[["fixed_variable"]] <- fixed_variable
    
    if (!.all) {
      cube <- remove_total(
        cube, 
        .variables = .variables,
        .total = .total
      )
    }
    
  }
  
  cube
}