R/math.kruskal-wallis.R

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

#'
#' @examples
#'
#' KW(feRdata$age, feRdata$health)
#'
#' @aliases kruskal.test
#' @export
KW <- function(x, y,
                  x.name="x.name",
                  y.name="y.name",
                  p.sig=0.05, alternative="two.sided", check.assumptions = TRUE,
                  stop.on.error = TRUE, lang = "es", digits = 4,
                  post.hoc = TRUE, post.hoc.method = "auto"){

  x.name=feR:::.var.name(deparse(substitute(x)))
  y.name = feR:::.var.name(deparse(substitute(y)))

  if(is.null(y)) {
    e <- "y parameter is missing"
    if(stop.on.error) stop(e)
    else {
      message(e)
      return(NA)
    }
  }
  ci <- 1 - p.sig


  d <- data.frame(x=x, y=y)
  d <- na.omit(d)
  if(!is.factor(d$y)) d$y <- factor(d$y)

  x <- d$x
  y <- d$y

  tryCatch(feR:::.check.comp_means.parameters(x = x, y = y, ci = ci, alternative = "two.sided",
                                              lang = lang, method = "auto", anova = TRUE),
           error = function(e) {
             if (stop.on.error) stop(e)
             else return(NA)
           })

  if(!is.factor(y)) y = factor(y)

  if(length(levels(y))<3) {
    e = "There are not enough categories in 'y' variable"
    if (stop.on.error) stop(e)
    else {
      message(e)
      return(NA)
    }
  }

  test <- tryCatch(kruskal.test(x, y),
                   error = function(e) {
                     if(stop.on.error) stop(e)
                     else {
                       message(e)
                       return(NA)
                     }
                   }
                   )

  if(length(test)==1) if (is.na(test)) return(NA)

  result <- data.frame(method=test$method)
  result$df <- test$parameter
  result$stat.name <- "chi-squared"
  result$statistic <- test$statistic
  result$p.value <- test$p.value

  class(result) <- c("feR.kruskal","data.frame")

  attr(result, "original.test") <- test
  attr(result, "x") <- x
  attr(result, "y") <- y

  if(post.hoc) {
    ph <- KW.post.hoc(result, p.sig = p.sig, stop.on.error = stop.on.error,
                         lang = lang, digits = digits, method = method)
    attr(result,"post.hoc") <- ph
  }


  result
}


#'
#'
#' @importFrom FSA dunnTest
#'
#' @export
KW.post.hoc <- function(test.object,
                           p.sig=0.05,
                           stop.on.error = TRUE, lang = "es", digits = 4, method = "auto") {

  if(!is.feR.kruskal(test.object)) {
    e <- "test.object object was not feR.kruskal class. Stopping post-hoc"
    if(stop.on.error) stop(e)
    else {
      message(e)
      return(NA)
    }
  }

  x <- attr(test.object,"x")
  y <- attr(test.object,"y")

  r.temp <- FSA::dunnTest(x ~ y)

  result <- r.temp$res
  names(result) <- c("comparison","Z","p.value","adj.p.value")
  attr(result,"post-hoc.test") <- "Dunn test with Homles correction for p.value"
  class(result) <- c("feR.kruskal.post.hoc","data.frame")
  result

}



#' @export
print.feR.kruskal  <- function(obj) {
  # print(obj)
  print(knitr::kable(as.data.frame(obj)))

  if("post.hoc" %in% names(attributes(obj))) {
    print(attr(obj,"post.hoc"))
  }
}

#' @export
is.feR.kruskal <- function(obj) {
  if ("feR.kruskal" %in% class(obj)) return(TRUE)

  return(FALSE)
}


#' @export
as.data.frame.feR.kruskal <- function(obj){
  if(is.feR.kruskal(obj)) class(obj) <- "data.frame"

  obj
}


#.................................................................
# Kruskal-Wallis post-hoc
#.................................................................


#' @export
print.feR.kruskal.post.hoc <- function(obj){
  cat("\n Post-hoc test:",attr(obj,"post-hoc.test"),"\n")
  print(knitr::kable(as.data.frame(obj)))
}

#' @export
is.feR.kruskal.post.hoc <- function(obj) {
  if ("feR.kruskal.post.hoc" %in% class(obj)) return(TRUE)
  return(FALSE)
}


#' @export
as.data.frame.feR.kruskal.post.hoc <- function(obj){
  class(obj) <- "data.frame"
  obj
}