feR: Basic functions that I use all the time

#' @export
compare  <- function(x,y,...,
                     x.name= NULL,
                     y.name = NULL,
                     show.desc = T, show.var = T,
                     p.sig = 0.05, p.sig.small = 0.01, p.sig.very.small = 0.001,
                     digits = 2,
                     guess.factor = TRUE,
                     show.title = TRUE,
                     markdown.title.prefix = "##",
                     stop.on.error = TRUE,
                     DEBUG=FALSE) {

  if (missing(y)) stop("falta variable y")


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

  #-----------------------------------------------------------------------------


  if (guess.factor) {
    final.args$x <- guess.factor(x, DEBUG = DEBUG)
    final.args$y <- guess.factor(y, DEBUG = DEBUG)
  }

  result <- do.call(feR:::.compare,final.args)
  if (length(result) == 1) {
    if (is.na(result)) return(NULL)
  }

  attr(result,"x.name") <- x.name
  attr(result,"y.name") <- y.name
  attr(result, "show.title") <- show.title
  attr(result, "markdown.title.prefix") <- markdown.title.prefix
  attr(result, "digits") <- digits
  return(result)



}


.compare <- function(x,y,...,
                     show.markdown.division = TRUE,
                     markdown.division.prefix = "##",
                     stop.on.error = TRUE){
  UseMethod(".compare")
}


.compare.factor <- function(x,y, ...,
                            x.name=  NULL,
                            y.name =  NULL,
                            show.desc = T,
                            p.sig = 0.05, p.sig.small = 0.01, p.sig.very.small = 0.001,
                            digits = 2,
                            guess.factor = TRUE,
                            show.markdown.division = TRUE,
                            markdown.division.prefix = "##",
                            stop.on.error = TRUE,
                            DEBUG=FALSE) {



  #--------------------------------- GET FULL ARGUMENTS LIST--------------------
  fun.args <- formals(chi_test)
  fun.args$... <- NULL
  passed.args <- as.list(match.call(expand.dots = TRUE)[-1])
  final.chi.args <- as.list(modifyList(fun.args, passed.args))
  final.chi.args <- final.chi.args[names(final.chi.args) %in% names(fun.args)]
  if (!missing(x)) final.chi.args$x <- x
  if (!missing(y)) final.chi.args$y <- y
  if (is.null(x.name)) final.chi.args$x.name = feR:::.var.name(deparse(substitute(x)))
  if (is.null(y.name)) final.chi.args$y.name =  feR:::.var.name(deparse(substitute(y)))
  #-----------------------------------------------------------------------------

  chi.t <- do.call(feR::chi_test,final.chi.args)
  chi.t.expected <- attr(chi.t,"EXPECTED")




  if (sum(chi.t.expected < 5) > 0) {
    #.... fisher args
    fun.formal <- formals(fisher_test)
    fun.args$... <- NULL
    final.fisher.args <- as.list(modifyList(fun.args, passed.args))
    final.fisher.args <- final.fisher.args[names(final.fisher.args) %in% names(fun.args)]
    if (!missing(x)) final.fisher.args$x <- x
    if (!missing(y)) final.fisher.args$y <- y
    if (is.null(x.name)) final.fisher.args$x.name = feR:::.var.name(deparse(substitute(x)))
    if (is.null(y.name)) final.fisher.args$y.name =  feR:::.var.name(deparse(substitute(y)))

    final.test <- do.call(feR::fisher_test,final.fisher.args)
  } else final.test = chi.t

  # class(final.test) <- c("feR_comp_prop", class(final.test))
  if (show.desc) {
    #--------------------------------- GET FULL ARGUMENTS LIST--------------------
    fun.args <- formals(describe)
    fun.args$... <- NULL
    final.args <- as.list(modifyList(fun.args, passed.args))
    final.args <- final.args[names(final.args) %in% names(fun.args)]
    if(!missing(x)) final.chi.args$x <- x
    if(!missing(y)) final.chi.args$y <- y
    if (is.null(x.name)) final.chi.args$x.name = feR:::.var.name(deparse(substitute(x)))
    if (is.null(y.name)) final.chi.args$y.name =  feR:::.var.name(deparse(substitute(y)))
    #-----------------------------------------------------------------------------

    attr(final.test,"DESC") = describe(x,y)
  }

  attr(final.test, "SHOW.DESCRIPTIVES") <- show.desc
  # attr(final.test, "DESCRIPTIVES") <- do.call(feR::describe, args)
  attr(final.test, "show.markdown.division") <- show.markdown.division
  attr(final.test, "markdown.division.prefix") <- markdown.division.prefix
  attr(final.test, "digits") <- digits

  final.test
}


.compare.numeric <- function(x,y,...,
                             x.name = NULL,
                             y.name = NULL,
                             p.sig = 0.05, DEBUG = F, show.desc = T, show.var = T,
                             digits = 2,
                             show.markdown.division = TRUE,
                             guess.factor = TRUE,
                             stop.on.error = T,
                             markdown.division.prefix = "##"){

  if (class(y) != "factor") y <- factor(y)

  #--------------------------------- GET FULL ARGUMENTS LIST--------------------
  fun.args <- formals(describe)
  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)]
  if (!missing(x)) final.args$x <- x
  if (!missing(y)) final.args$y <- y
  if (is.null(x.name)) final.args$x.name = feR:::.var.name(deparse(substitute(x)))
  if (is.null(y.name)) final.args$y.name =  feR:::.var.name(deparse(substitute(y)))
  #-----------------------------------------------------------------------------

  total.cat <- length(levels(factor(y)))

  if (total.cat < 2) {
    print(stop.on.error)
    error.text <- paste0("\n[.compare.numeric] Factor ",y.name," does not have enough categories (or observations in the categories) to be compared \n")
    if (stop.on.error ) stop(error.text)
    else {
      cat(error.text)
      return(NA)
    }
  }



  desc <- do.call(feR::describe, final.args)
  # is.normal = (sum(desc$p.norm.exact < p.sig) == 0) #.. if any p.norm.exact is below p.sig we need non.parametric tests
  is.normal = feR::is.normal(x,y)



  #--------------------------------- GET FULL ARGUMENTS LIST--------------------
  fun.args <- formals(test.equal.var)
  fun.args$... <- NULL
  final.args <- as.list(modifyList(fun.args, passed.args))
  final.args <- final.args[names(final.args) %in% names(fun.args)]
  if (!missing(x)) final.args$x <- x
  if (!missing(y)) final.args$y <- y
  if (is.null(x.name)) final.args$x.name = feR:::.var.name(deparse(substitute(x)))
  if (is.null(y.name)) final.args$y.name =  feR:::.var.name(deparse(substitute(y)))
  #-----------------------------------------------------------------------------
  #
  # print(desc)
  # print(is.normal)

  #--- test homocedasticity
  # bart <- bartlett.test(x ~ y)


  if (DEBUG) cat("[.compare.numeric] Normality ->",is.normal,"\n")



  bart <- do.call(feR::test.equal.var,final.args)
  if (length(bart) == 1 ) if (is.na(bart)) return(NA)
  is.var.equal <- are.var.equal(x,y, stop.on.error = stop.on.error)
    if (total.cat == 2) {
      #-------------------------------- two samples
      if (is.normal) {
        if (DEBUG) cat("[.compare.numeric] Homocedasticity ->",is.var.equal,"\n")
        #--------------------------------- GET FULL ARGUMENTS LIST--------------------
        fun.args <- formals(t_test)
        fun.args$... <- NULL
        final.args <- as.list(modifyList(fun.args, passed.args))
        final.args <- final.args[names(final.args) %in% names(fun.args)]
        if (!missing(x)) final.args$x <- x
        if (!missing(y)) final.args$y <- y
        if (is.null(x.name)) final.args$x.name = feR:::.var.name(deparse(substitute(x)))
        if (is.null(y.name)) final.args$y.name =  feR:::.var.name(deparse(substitute(y)))
        #-----------------------------------------------------------------------------

        if (is.var.equal) result <- do.call(feR:::t_test, final.args)
        else result <- do.call(feR:::welch_test, final.args)
      } else {

        #--------------------------------- GET FULL ARGUMENTS LIST--------------------
        fun.args <- formals(wilcoxon_test)
        fun.args$... <- NULL
        final.args <- as.list(modifyList(fun.args, passed.args))
        final.args <- final.args[names(final.args) %in% names(fun.args)]
        if (!missing(x)) final.args$x <- x
        if (!missing(y)) final.args$y <- y
        if (is.null(x.name)) final.args$x.name = feR:::.var.name(deparse(substitute(x)))
        if (is.null(y.name)) final.args$y.name =  feR:::.var.name(deparse(substitute(y)))
        #-----------------------------------------------------------------------------

        result <- do.call(feR:::wilcoxon_test, final.args)

      }
    } else {
      #-------------------------------- OVER two samples
      if (is.normal & is.var.equal) {
        result <- feR:::ANOVA(x, y)
      } else {
        result <- feR:::KW(x, y)
      }
    }



  if (exists("result")) {
    if (show.desc) {
      attr(result,"SHOW.DESCRIPTIVES") <- TRUE
      attr(result, "DESCRIPTIVES") <- desc
    } else {
      attr(result,"SHOW.DESCRIPTIVES") <- FALSE
    }

    if(show.var) {
      attr(result,"SHOW.VARIANCE") <- TRUE
      attr(result, "VARIANCE") <- bart
    } else {
      attr(result,"SHOW.VARIANCE") <- FALSE
    }

    attr(result,"digits") <- digits

    attr(result, "show.markdown.division") <- show.markdown.division
    attr(result, "markdown.division.prefix") <- markdown.division.prefix
    attr(result, "digits") <- digits

    return(result)
  }

  return(NA)
}


#' @export
is.feR_compare <- function(x) {
  comp <- c("feR_comp_prop","feR.comp_means")
  return(any(class(x) %in% comp))
}