R/math.describe.factor.R

In feranpre/feR: Basic functions that I use all the time

#' @export
.describe.feR_math.factor <- function(x, y = NULL, ...,
                                      digits = 4,
                                      totals = "row", #... row, column, col o both, ambos
                                      show.na = FALSE,
                                      DEBUG = FALSE) {
  if (DEBUG) cat("\n[.describe.feR_math.factor] Called ----")

  total.by.row = FALSE
  total.by.column = FALSE
  if (totals == "row" || totals == "both" || totals == "all" || totals == "ambos")  total.by.row = TRUE
  if (totals == "column" || totals == "col" || totals == "both" || totals == "all" || totals == "ambos")  total.by.column = TRUE


  args <- list(...)

  if ("x.name" %in% names(args)) x.name = args[["x.name"]]
  else x.name = "var"

  if (class(x) != "factor") x <- factor(x)
  categorias.x <- levels(x)
  if (length(categorias.x) == 0) {
    if (exists("x.name")) result <- data.frame(ERROR = paste("No hay categorías válidas en la variable:",x.name))
    else result <- data.frame(ERROR = "No hay categorías válidas en la variable")
    return(result)
  }

  na_option = "no" #... for the table
  if (show.na) {
    categorias.x <- c(categorias.x, "NA")
    na_option = "always"
  }

  # cat("HAY Y: ",!is.null(y))

  if (is.null(y)) {


    #........................................................... NO Y
    if (DEBUG) cat("\n[.describe.feR_math.factor] No y")

    result <- data.frame("group" = categorias.x)
    t.n <- table(x, useNA = na_option)
    result$n <- round(as.data.frame(t.n)$Freq, digits = digits)
    result$rel.freq <- round(prop.table(t.n)*100, digits = digits)
  } else {
    #........................................................... SI Y

    if ("y.name" %in% names(args)) y.name = args[["y.name"]]
    else y.name = "group"
    if (DEBUG) cat("\n[.describe.feR_math.factor] By",y.name)

    if (class(y) != "factor") y <- factor(y)
    categorias.y <- levels(y)
    if (length(categorias.y) == 0) {
      result <- data.frame(ERROR = paste("No hay categorías válidas en la variable ",y.name))
      return(result)
    }


    if (show.na) categorias.y <- c(categorias.y, "NA")

    t.n <- table(x, y, useNA = na_option)

    result_n <- data.frame(rbind(t.n))

    rownames(result_n) <- categorias.x
    colnames(result_n) <- categorias.y


    #............. CALCULATING PERCENTAGES BY ROW
    if (total.by.row) {
      result_rel_freq.row <- data.frame(rbind(prop.table(t.n, margin = 1)))

      colnames(result_rel_freq.row) <- categorias.y
      rownames(result_rel_freq.row) <- categorias.x

      result_rel_freq.row$total.row <- rowSums(result_rel_freq.row,na.rm = TRUE)
      result_n$total.row <- rowSums(result_n,na.rm = TRUE)

      # result_rel_freq.row <- cbind(categorias.x,result_rel_freq.row)
      # names(result_rel_freq.row)[1] <- y.name

      if (total.by.column) { #this rows are required for the mergin but will be destroyed later
        result_rel_freq.row <- rbind(result_rel_freq.row, rep(NA,ncol(result_rel_freq.row)))
        rownames(result_rel_freq.row)[nrow(result_rel_freq.row)] <- "total.column"
      }

    }

    #............. CALCULATING PERCENTAGES BY COLUMN
    if (total.by.column) {
      result_rel_freq.column <- data.frame(rbind(prop.table(t.n, margin = 2)))
      colnames(result_rel_freq.column) <- categorias.y
      rownames(result_rel_freq.column) <- categorias.x

      result_rel_freq.column <- rbind(result_rel_freq.column, colSums(result_rel_freq.column, na.rm = TRUE))
      rownames(result_rel_freq.column)[nrow(result_rel_freq.column)] <- "total.column"

      result_n <- rbind(result_n, colSums(result_n, na.rm = TRUE))
      rownames(result_n)[nrow(result_n)] <- "total.column"



      if (total.by.row) {
        result_rel_freq.column <- cbind(result_rel_freq.column, rep(NA,nrow(result_rel_freq.column)))
        names(result_rel_freq.column)[ncol(result_rel_freq.column)] <- "total.row"
      }

    }

    # result_n <- cbind(categorias.x,result_n)
    # names(result_n)[1] <- y.name

    result <- result_n
    if (total.by.row) {
      result_rel_freq.row <- round(result_rel_freq.row, digits = digits)
      attr(result,"prop.row") <- result_rel_freq.row
    }
    if (total.by.column) {
      result_rel_freq.column <- round(result_rel_freq.column, digits = digits)
      attr(result,"prop.column") <- result_rel_freq.column
    }
    attr(result,"n") <- result_n


  }

  if (exists("y.name")) attr(result,"y.name") <- y.name
  if (exists("x.name")) attr(result,"x.name") <- x.name
  attr(result, "totals") <- totals
  attr(result, "total.by.row") <- total.by.row
  attr(result, "total.by.column") <- total.by.column
  # print(as.data.frame(result))
  return(result)
}