feR: Basic functions that I use all the time

#' @TODO: Añadir un comando para separar tablas unas de otras en el print, de forma que se puedan poner cabeceras de markdown



#' describe
#'
#' `describe()` give descriptive statistics about the vector/data.frame
#' passed as argument.
#'
#' If it is a vector it will discriminate between **numeric** and **factor**
#' (it will even try to guess if a numeric variable is a factor) and will
#' give the correct descriptive statistics.
#'
#' @param x DESCRIPTION.
#' @param ... DESCRIPTION.
#' @param x.name DESCRIPTION.
#' @param y DESCRIPTION.
#' @param y.name DESCRIPTION.
#' @param digits DESCRIPTION.
#' @param guess.factor DESCRIPTION.
#' @param max.factor.cat DESCRIPTION.
#' @param na.rm DESCRIPTION.
#' @param ci DESCRIPTION.
#' @param total.by.row DESCRIPTION.
#' @param total.by.column DESCRIPTION.
#' @param show.general DESCRIPTION.
#' @param DEBUG DESCRIPTION.
#'
#' @return RETURN_DESCRIPTION
#' @examples
#' # ADD_EXAMPLES_HERE
#'
#' @export
describe <- function(x, y = NULL,
                     x.name = NULL,
                     y.name = NULL,
                     ...,
                     digits = 4,
                     guess.factor = TRUE,
                     max.factor.cat = 10,
                     na.rm = TRUE,
                     ci = 0.95,

                     #----------------------- factors
                     total.by.row = TRUE,
                     total.by.column = FALSE,
                     show.na = FALSE,
                     table.format.prefix = " (",
                     table.format.sufix = ")",
                     table.format.sep =", ",
                     table.format.n="%n",
                     table.format.row="%r",
                     table.format.col="%c",
                     as.percentage=TRUE,

                     #----------------------- printing options
                     show.general = TRUE,
                     show.title = TRUE,
                     show.markdown.division = TRUE,
                     markdown.title.prefix = "##",

                     #------------------------ convencience
                     stop.on.error = TRUE,


                     #----------------------- comparisons


                     #----------------------- coding
                     DEBUG = FALSE) {

  #--------------------------------- GET FULL ARGUMENTS LIST--------------------
  passed.args <- as.list(match.call(expand.dots = TRUE)[-1])
  if (!missing(x)) passed.args$x <- x
  if (!missing(y)) passed.args$y <- y
  if (is.null(x.name)) passed.args$x.name = feR:::.var.name(deparse(substitute(x, env = environment())))
  if (is.null(y.name)) passed.args$y.name =  feR:::.var.name(deparse(substitute(y, env = environment())))
  #-----------------------------------------------------------------------------
  final.args <- get.fun.args(passed.args, "describe")
  #-----------------------------------------------------------------------------


  if (DEBUG) feR:::.show.args(final.args,"describe")


  if (guess.factor) final.args$x <- do.call(feR::guess.factor, final.args)
  result <- do.call(feR:::.describe, final.args)


  fable.args <- get.fun.args(passed.args, "feR::fable")



  for (a in names(final.args)) {
    attr(result,a) <- final.args[[a]]
  }
  for (a in names(fable.args)) {
    attr(result,a) <- fable.args[[a]]
  }

  attr(result, "digits") <- digits
  attr(result, "show.general") <- show.general
  attr(result, "show.title") <- show.title
  attr(result, "show.markdown.division") <- show.markdown.division
  attr(result, "markdown.title.prefix") <- markdown.title.prefix
  # attr(result, "X.NAME") <- x.name
  if (!is.null(y)) {
    if (!is.null(y.name)) attr(result, "y.name") <- y.name
    else attr(result, "y.name") <- "y.name"
  } else attr(result,"y.name") <- NULL

  return(result)
}


.describe <- function(x, ..., DEBUG = FALSE, show.general = TRUE) {
  if (is.character(x)) x <- factor(x)
  if (is.logical(x)) x <- factor(x)
  UseMethod(".describe", x)
}


.describe.data.frame <- function(x, ..., digits = 4,
                                 stop.on.error = TRUE,
                                 show.general = TRUE,
                                 show.markdown.division = TRUE,
                                 markdown.division.prefix = "##",
                                 guess.factor = TRUE,
                                 DEBUG = FALSE) {

  args <- list(...)
  passed.args <- as.list(match.call()[-1])
  final.args <- as.list(modifyList(args, passed.args))
  args <- final.args



  args$stop.on.error = stop.on.error
  args$guess.factor = guess.factor
  args$digits = digits
  args$show.general = show.general
  args$show.markdown.division = show.markdown.division
  args$markdown.division.prefix = markdown.division.prefix

  if (!("x.name" %in% names(passed.args))) args$x.name <- passed.args$x.name
  if (!("y.name" %in% names(passed.args))) {
    if (("y" %in% names(passed.args))) args$y.name <- passed.args$y.name
    else args$y.name <- NULL
  }

  if (DEBUG) feR:::.show.args(args,".describe.data.frame")

  results <- list()

  # var.args <- args
  for (var.name in names(x)) {

    if (DEBUG) cat("\n[.describe.data.frame] Var in process:",var.name,"\n")
    # var.args <- args[names(args) %in% names(formals(feR:::.describe))]
    var.args <- args
    x.var <- x[, var.name]
    if (guess.factor) x.var <- feR::guess.factor(x.var)
    var.args$x <- x.var
    var.args$x.name <- var.name

    var <- do.call(feR:::.describe, var.args)
    results[[var.name]] <- var

  }


  attr(results, "x.name") <- args[["x.name"]]
  attr(results, "digits") <- digits
  attr(results, "show.general") <- show.general
  attr(results, "show.markdown.division") <- show.markdown.division
  attr(results, "markdown.division.prefix") <- markdown.division.prefix


  class(results) <- c("feR_describe_data_frame", class(results))
  return(results)
}

.describe.default <- function(x, ..., y = NULL, digits = 4,
                              show.general = TRUE,
                              show.markdown.division = TRUE,
                              markdown.division.prefix = "##",
                              DEBUG = FALSE) {
  return(data.frame(description = "Not possible"))
}



.describe.numeric <- function(x, y = NULL,
                              x.name=  NULL,
                              y.name = NULL,
                              ...,
                              digits = 4,
                              show.general = TRUE,
                              show.markdown.division = TRUE,
                              markdown.division.prefix = "##",
                              DEBUG = FALSE) {


  #--------------------------------- GET FULL ARGUMENTS LIST--------------------
  passed.args <- as.list(match.call(expand.dots = TRUE)[-1])
  if (!missing(x)) passed.args$x <- x
  if (!missing(y)) passed.args$y <- y
  if (is.null(x.name)) passed.args$x.name = feR:::.var.name(deparse(substitute(x, env = environment())))
  if (is.null(y.name)) passed.args$y.name = ifelse(!is.null(y),feR:::.var.name(deparse(substitute(y, env = environment()))),NULL)
  #-----------------------------------------------------------------------------
  final.args <- get.fun.args(passed.args, "describe")
  #-----------------------------------------------------------------------------
  desc.args <- get.fun.args(passed.args = final.args, FUN = "feR::desc_num")
  norm.args <- get.fun.args(passed.args = final.args, FUN = "feR::normal.test")

  if (is.null(y) || (length(levels(factor(y))) < 2)) { #.... no comparison group
    result.general <- do.call(feR::desc_num, desc.args)
    result.general.norm <- do.call(feR::normal.test, norm.args)
    result.general$norm.p.value <- ifelse(!is.null(result.general.norm$p.value) & !is.na(result.general.norm$p.value),
                                          result.general.norm$p.value,
                                          NA)
    attr(result.general,"nor.test") <- result.general.norm

  } else {
    #----- DESCRIBING GROUPS---------------
    #... there are GROUPS but no show.general was called (or it was already resolved)
    # if (DEBUG) cat("\n[",.current.call,"]GROUPS\n")

    result.temp <- tapply(x, factor(y), function(xValue) {
      temp.desc.args <- desc.args
      temp.desc.args$x <- xValue
      temp.desc.args$y <- NULL
      t.norm.args <- norm.args
      t.norm.args$x <- xValue

      if (sum(!is.na(xValue)) > 0) {
        r.temp <- do.call(feR::desc_num, temp.desc.args)
        r.temp.norm <- do.call(feR::normal.test, t.norm.args)
        r.temp$norm.p.value <- ifelse(!is.null(r.temp.norm$p.value) & !is.na(r.temp.norm$p.value),
                                      r.temp.norm$p.value,
                                              NA)
        attr(r.temp,"nor.test") <- r.temp.norm
        r.temp
      }
      else {
        cat("\nNo hay valores para alguno de los grupos")
        return(NA)
      }
    })

    # print(result.temp)

    result.groups <- data.frame()
    nor.test <- list()
    p.norm <- list()
    for (r in names(result.temp)) {
      r.temp <- result.temp[[r]]
      if (length(r.temp) == 1) {
        if (is.na(r.temp)) {
          cat("añadir grupo vacio")
        }

      } else {

        r.g <- cbind( r, as.data.frame(r.temp))
        names(r.g)[1] <- "grupo"


        result.groups <- rbind(result.groups, r.g)
        nor.test <- append(nor.test, attr(r.temp, "nor.test"))
        p.norm <- append(p.norm, attr(r.temp, "p.norm"))

        names(nor.test)[length(nor.test)] <- r
        names(p.norm)[length(p.norm)] <- r
      }

    } #... groups loop end

    class(result.groups) <- c("feR_describe_numeric_list", class(result.groups))

    attr(result.groups, "nor.test") <- nor.test
    # attr(result.groups, "p.norm") <- p.norm
    # attr(result.groups, "y.name") <- args[["y.name"]]

    #-------------- END ---- DESCRIBING GROUPS -------------


    if (show.general) { #... there are groups but a show.general was called too

      if (DEBUG) cat("\n[desc_num] show.general requested\n")
      # args.general <- desc.args
      # result.general <- do.call(feR::desc_num, args.general)
      result.general <- do.call(feR::desc_num_norm, desc.args)
      # print(attributes(result.general))
    }
  }  #.... end !is.null(y)




  class(result.general) <- c("feR_describe_numeric", class(result.general))

  if (exists("result.groups")) {
    result <- result.groups
    class(result.groups) <- c("feR_describe_numeric_list", class(result.groups))
    if (show.general & exists("result.general")) {
      attr(result, "result.general") <- result.general
    }
  } else {
    result <- result.general
  }


  # attr(result, "digits") <- digits
  # attr(result, "show.general") <- show.general
  # attr(result, "show.markdown.division") <- show.markdown.division
  # attr(result, "markdown.division.prefix") <- markdown.division.prefix
  attr(result, "x.name") <- final.args$x.name
  if (!is.null(y)) attr(result, "y.name") <- final.args$y.name

  return(result)
}



#' @export
.describe.factor <- function(x, y = NULL, ...,
                             digits = 4,
                             totals = "row",
                             # total.by.row = TRUE,
                             # total.by.column = FALSE,
                             # show.markdown.division = TRUE,
                             # markdown.division.prefix = "##",
                             table.format.prefix = "(",
                             table.format.sufix = ")",
                             table.format.sep =", ",
                             table.format.n="%n",
                             table.format.row="%r",
                             table.format.col="%c",
                             as.percentage=TRUE,
                             DEBUG = FALSE) {
  if (DEBUG) cat("\n[.describe.factor] Called ----\n")

  #--------------------------------- GET FULL ARGUMENTS LIST--------------------
  passed.args <- as.list(match.call(expand.dots = TRUE)[-1])
  # print(names(passed.args))
  if (!missing(x)) passed.args$x <- x
  if (!missing(y)) passed.args$y <- y
  # if (is.null(x.name)) passed.args$x.name = feR:::.var.name(deparse(substitute(x)))
  # if (is.null(y.name)) passed.args$y.name =  feR:::.var.name(deparse(substitute(y)))
  #-----------------------------------------------------------------------------
  final.args <- get.fun.args(passed.args, "feR:::.describe.feR_math.factor")
  #-----------------------------------------------------------------------------


  #--------------------------------- GET FULL ARGUMENTS LIST--------------------
  # fun.args <- formals(.describe.feR_math.factor)
  # fun.args$... <- NULL
  # passed.args <- as.list(match.call(expand.dots = TRUE)[-1])
  # final.args <- as.list(modifyList(fun.args, passed.args))
  # final.args <- final.args[names(final.args) %in% names(fun.args)]
  # final.args <- lapply(final.args, eval)
  #-----------------------------------------------------------------------------
  #
  # args <- list(...)
  #
  # args$x <- x
  # args$DEBUG <- DEBUG
  # args$total.by.row = total.by.row
  # args$total.by.column = total.by.column
  #
  # if ("x.name" %in% names(args)) x.name = args[["x.name"]]
  # else x.name = "var"
  #
  # if (!is.null(y)) {
  #   args$y <- y
  #   if ("y.name" %in% names(args)) y.name = args[["y.name"]]
  #   else y.name = "group"
  # }
  #
  # if (DEBUG) cat("\n HAY Y: ",!is.null(y),"\n")


  result <- do.call(feR:::.describe.feR_math.factor, final.args)

  class(result) <- c("feR_describe_factor",class(result))

  attr(result,"table.format.prefix") = table.format.prefix
  attr(result,"table.format.sufix") = table.format.sufix
  attr(result,"table.format.sep") = table.format.sep
  attr(result,"table.format.n") = table.format.n
  attr(result,"table.format.row") = table.format.row
  attr(result,"table.format.col") = table.format.col
  attr(result,"as.percentage") = as.percentage

  # attr(result, "digits") <- digits
  # attr(result, "show.markdown.division") <- show.markdown.division
  # attr(result, "markdown.division.prefix") <- markdown.division.prefix
  # attr(result, "x.name") <- x.name
  # if (!is.null(y)) attr(result, "y.name") <- y.name

  return(result)

}


#' @export
is.feR_describe <- function(obj) {
  desc <- c("feR_desc_num","feR_describe_factor")
  return( any(class(obj) %in% desc) )
}