R/sweetpround-function.R

In darrellpenta/dissertate: Convenience functions for writing a dissertation (Cognitive Science, etc)

#' Sweeten a statistic: Helper for Stat Sweet
#' @importFrom magrittr %>%
#' @param .stat a numeric value representing a statistic
#' @param rnd_digit value to pass to round function, defaults to 2
#' @param interval  Which .stat should return is value as an interval cut-off?  (Default is \code{none}, so a .stat is returned representing the underlying number); \code{sig} will return intervals for values in the range: 0<>0.001<>.01<>.05, and otherwise return a sweet p; code will return the interval values in the range: 0<>0.001<>.01<>.05<>.10<>99. APA suggests reporting p values in a range for figures and tables in some cases. Automatically returned without leading zeros, so lead_zero is ignored when interval=TRUE
#' @param lead_zero (FALSE) Should the leading zero (before the decimal) be preserved? Defaults to FALSE, removing the zero in accordance with APA recommendations.
#' @param ... (ignored)
#' @return value for passing to sweetstat
#' @family sweetstat functions
#' @include statround-function.R
#' @rdname sweetpround
#' @export
#'

sweetpround <-
  function(.stat,
           rnd_digit,
           interval ="sig",
           lead_zero = FALSE,
           ...) {
    options(scipen = 999)

    statout <- function(.stat, rnd_digit = 2) {
      round_digit <-
        ifelse(missing(rnd_digit), 3L, as.integer(rnd_digit))

      .stat <-
        ifelse(
          .stat %in% c(NA,NA_character_,NA_complex_,NA_integer_,NA_real_,NaN,""," "),
          "",
          ifelse(
            .stat > 0.999999999999,
            as.character("0.999"),
            ifelse(
              0.0 <= .stat & .stat <= 0.0009999,
              as.character("0.001"),
              as.character(statround(.stat, rnd_digit = round_digit))
            )
          )
        )

      return(.stat)
    }
    trimlead <- function(.stat) {
      .stat <-
        ifelse(.stat %in% c(NA,NA_character_,NA_complex_,NA_integer_,NA_real_, NaN,NULL,""," "), "",
               paste0(".",strsplit(sub('0+$', '', .stat),  ".",  fixed = TRUE)[[1]][[2]]))

      .stat <-
        if(.stat != ""){
          if(nchar(strsplit(as.character(.stat),
                            ".",
                            fixed = TRUE)[[1]][2]) == 1){
            .stat <-paste0(.stat, "0")
            .stat
          } else{
            .stat
          }
        }else{
          .stat<-paste0("")
          .stat
        }

      return(.stat)
    }

all_interval <- function(.stat) {
      stat_range = findInterval(.stat, c(0, 0.001, 0.01, 0.05, 0.1, 99))

      codes = c("< .001",
                "< .01",
                "< .05",
                "< .10",
                "> .10")

      .stat <-
        codes[stat_range]
      return(.stat)
    }
sig_interval <- function(.stat, rnd=3) {

  stat_range <- findInterval(.stat, c(0, 0.001, 0.01, 0.05,99))

  codes <- c("$\\textless$ .001",
             "$\\textless$ .01",
             "$\\textless$ .05",
             as.character(paste0("$=$ ",trimlead(statout(.stat)))))
  .stat <-
    codes[stat_range]
  return(.stat)

}


if (!is.na(.stat))
      assertthat::validate_that(is.numeric(.stat), .stat >= 0)
stat <-
      .stat

    if (identical(interval, "all")) {
      stat <-
        all_interval(.stat = stat)
      return(stat)
    } else {
      stat <-
        sig_interval(.stat = stat, ... = ...)
      return(stat)
    }
    # } else {
    #   stat <-
    #     statout(value = stat, ... = ...)
    #   if (isTRUE(lead_zero)) {
    #     return(stat)
    #   } else {
    #     stat <-
    #       trimlead(stat)
    #     return(stat)
    #   }
    # }
  }