R/math.describe.numeric.R

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

#' @export
desc_num_norm <- function(x, x.name = NULL,
                          digits = 4,
                          p.sig = 0.05,
                          p.sig.small = 0.01,
                          p.sig.very.small = 0.001,
                          na.rm = TRUE,
                          stop.on.error = TRUE,
                          lang = "es",
                          DEBUG = FALSE) {
  #--------------------------------- GET FULL ARGUMENTS LIST--------------------
  passed.args <- as.list(match.call(expand.dots = TRUE)[-1])
  if (!missing(x)) passed.args$x <- x
  if (is.null(x.name)) passed.args$x.name = feR:::.var.name(deparse(substitute(x, env = environment())))
  #-----------------------------------------------------------------------------
  temp.desc.args <- get.fun.args(passed.args, "desc_num")
  t.norm.args <- get.fun.args(passed.args, "normal.test")
  #-----------------------------------------------------------------------------

  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

}

#' @export
desc_num <- function(x, x.name = NULL,
                     digits = 4,
                     p.sig = 0.05,
                     p.sig.small = 0.01,
                     p.sig.very.small = 0.001,
                     na.rm = TRUE,
                     stop.on.error = TRUE,
                     lang = "es",
                     DEBUG = FALSE) {


  if (DEBUG) cat("\n[desc.num] Called\n")

  ci <- 1 - p.sig
  n.missing = sum(is.na(x))
  n.valid = length(x) - n.missing

  if (n.valid == 0) return(feR:::.error.msg(error = "X_N_TOO_LOW", lang = lang, stop.on.error = stop.on.error))

  if (na.rm) x <- x[!is.na(x)]

  is.x.normal = feR::is.normal(x)
  alpha_2 <- ci + ((1 - ci)/2) #... alpha halves for confidence interval


  min <- ifelse(n.valid > 1, min(x, na.rm = na.rm), NA)
  max <- ifelse(n.valid > 1, max(x, na.rm = na.rm), NA)
  mean <- ifelse(n.valid > 1, mean(x, na.rm = na.rm), NA)
  sd <- ifelse(n.valid > 1, sd(x, na.rm = na.rm), NA)
  median <- ifelse(n.valid > 1, median(x, na.rm = na.rm), NA)
  IQR <- ifelse(n.valid > 1, IQR(x, na.rm = na.rm), NA)
  se <- ifelse(n.valid > 1, sd(x, na.rm = na.rm)/sqrt(n.valid), NA)

  if (n.valid > 1) {

    if (is.x.normal) {
      error <- qnorm(alpha_2) * se
    } else {
      error <- qt(alpha_2, df = n.valid - 1) * se
    }
    ci.upper <- mean + error
    ci.lower <- mean - error
  } else {
    ci.upper <- NA
    ci.lower <- NA
  }


  result <- data.frame(n.valid = as.numeric(n.valid),
                       n.missing = n.missing,
                       min = min,
                       max = max,
                       mean = mean,
                       ci.upper = ci.upper,
                       ci.lower = ci.lower,
                       sd = sd,
                       se = se,
                       median = median,
                       IQR = IQR
  )


  class(result) <- append("feR_desc_num",class(result))
  if (!is.null(x.name)) attr(result, "x.name") <- x.name
  attr(result, "digits") <- digits
  return(result)
}




#..............................................................................
#..............................................................................
# S3 Methods
#..............................................................................
#..............................................................................


#' @export
data.frame.feR_desc_num <- function(obj) {
  class(obj) <- "data.frame"
  obj
}

#' @export
is.na.feR_desc_num <- function(obj){

  return(all(is.na(as.data.frame(obj))))
}


#' @export
#' @importFrom tidyr %>% gather
print.feR_desc_num <- function(obj){
  if (is.na(obj)) {
    print(NA)
  } else {
    if ("digits" %in% names(attributes(obj))) digits = attr(obj, "digits")
    else digits = 2
    df <- data.frame(obj %>% gather("stat", "value"))
    if (is.numeric(df$value)) df$value = round(df$value, digits = digits)
    names(df) <- c("stat","value")


    if ("x.name" %in% names(attributes(obj))) df = dplyr::bind_rows(c(stat = paste0("var -> ",attr(obj,"x.name"), collapse = ""),
                                                                      value = numeric(0)),df)

    print(knitr::kable(df))
  }
}


#' @export
is.feR_desc_num <- function(obj) {
  return( any(class(obj) == "feR_desc_num") )
}