R/CoefQuartVar.R

#' @title R6 Coefficient of Quartile Variation (cqv)
#' @name CoefQuartVar
#' @description The R6 class \code{CoefQuartVar} for the coefficient of
#'              quartile variation (cqv)
#' @param x An \code{R} object. Currently there are methods for numeric vectors
#' @param na.rm a logical value indicating whether \code{NA} values should be
#'              stripped before the computation proceeds.
#' @param digits integer indicating the number of decimal places to be used.
#' @details \describe{
#'         \item{\strong{Coefficient of Quartile Variation}}{
#'         \deqn{ cqv = ((q3-q1)/(q3 + q1))*100 , }  where \eqn{q3}
#'         and \eqn{q1} are third quartile (\emph{i.e.,} 75th percentile) and
#'         first quartile (\emph{i.e.,} 25th percentile), respectively.
#'         The \emph{cqv} is a measure of relative dispersion that is based on
#'         interquartile range \emph{(iqr)}. Since \eqn{cqv} is unitless, it
#'         is useful for comparison of variables with different units. It is
#'         also a measure of homogeneity [1, 2].
#'         }
#'         }
#' @examples
#' x <- c(
#'    0.2, 0.5, 1.1, 1.4, 1.8, 2.3, 2.5, 2.7, 3.5, 4.4,
#'    4.6, 5.4, 5.4, 5.7, 5.8, 5.9, 6.0, 6.6, 7.1, 7.9
#' )
#' CoefQuartVar$new(x)$est()
#' cqv_x <- CoefQuartVar$new(x, digits = 2)
#' cqv_x$est()
#' R6::is.R6(cqv_x)
#' @references [1] Bonett, DG., 2006, Confidence interval for a coefficient of
#'                 quartile variation, Computational Statistics & Data Analysis,
#'                 50(11), 2953-7, DOI: \href{http://doi.org/10.1016/j.csda.2005.05.007}{http://doi.org/10.1016/j.csda.2005.05.007}
#' @export
#' @import dplyr SciViews boot R6 utils
NULL
#' @importFrom stats quantile sd qchisq qnorm
#' @importFrom MBESS conf.limits.nct
NULL
CoefQuartVar <- R6::R6Class(
    classname = "CoefQuartVar",
    inherit = BootCoefQuartVar,
    public = list(
        # ---------------- determining defaults for arguments -----------------
        x = NA,
        na.rm = FALSE,
        digits = 1,
        star = 0,
        # --------- determining constructor defaults for arguments ------------
        initialize = function(
            x = NA,
            na.rm = FALSE,
            digits = 1,
            ...
        ) {
            # ---------------------- check NA or NAN -------------------------
            if (missing(x) || is.null(x)) {
                stop("object 'x' not found")
            } else if (!missing(x)) {
                self$x <- x
            }
            if (!missing(na.rm)) {
                self$na.rm <- na.rm
            }
            if (self$na.rm == TRUE) {
                self$x <- x[!is.na(x)]
            } else if (anyNA(x) & self$na.rm == FALSE) {
                stop(
                    "missing values and NaN's not allowed if 'na.rm' is FALSE"
                )
            }
            # ------------- stop if input x vector is not numeric -------------
            if (!is.numeric(x)) {
                stop("argument is not a numeric vector")
            }
            # ------------------- set digits with user input ------------------
            if (!missing(digits)) {
                self$digits <- digits
            }
            # ---------- initialize cqv estimate i.e., est() function ---------
            self$est()
        },
        # --------- public method of cqv estimate i.e., est() function --------
        est = function(...) {
            if (  # check if 0.75 percentile is non-zero to avoid NANs
                super$super_$initialize(
                    x = self$x, na.rm = self$na.rm, probs = 0.75
                ) != 0
            ) {
                return(
                    round(
                        (((super$super_$initialize(
                            x = self$x,
                            na.rm = self$na.rm,
                            probs = 0.75,
                            names = FALSE,
                            digits = self$digits
                        )) - (super$super_$initialize(
                            x = self$x,
                            na.rm = self$na.rm,
                            probs = 0.25,
                            names = FALSE,
                            digits = self$digits
                        ) )) / ((super$super_$initialize(
                            x = self$x,
                            na.rm = self$na.rm,
                            probs = 0.75,
                            names = FALSE,
                            digits = self$digits
                        )) + (super$super_$initialize(
                            x = self$x,
                            na.rm = self$na.rm,
                            probs = 0.25,
                            names = FALSE,
                            digits = self$digits
                        )))) * 100,
                        digits = self$digits
                    )
                )
            } else if (
                super$super_$initialize(
                    x = self$x, na.rm = self$na.rm, probs = 0.75
                ) == 0
            ) {
                warning(
        "cqv is NaN because both q3 and q1 are 0, max was used instead of q3"
                )
                return(
                    round(
                        ((max(x = self$x) - (super$super_$initialize(
                            x = self$x,
                            na.rm = self$na.rm,
                            probs = 0.25,
                            names = FALSE
                        ) )) / (max(x = self$x) + (super$super_$initialize(
                            x = self$x,
                            na.rm = self$na.rm,
                            probs = 0.25,
                            names = FALSE
                        )))) * 100,
                        digits = self$digits
                    )
                )
            }
        },
        # ------------------- adding some internal methods --------------------
        # --------------------- adding some internal fields -------------------
        a =  function(...) {
            ceiling(
            (length(self$x)/4) - (1.96 * (((3 * length(self$x))/16)^(0.5)))
        )
            },
        b = function(...) {round(
            (length(self$x)/4) + (1.96 * (((3 * length(self$x))/16)^(0.5))),
            digits = 0
        )
            },
        c = function(...) {length(self$x) + 1 - self$b()},
        d = function(...) {length(self$x) + 1 - self$a()},
        Ya = function(...) {dplyr::nth(self$x, self$a(), order_by = self$x)},
        Yb = function(...) {dplyr::nth(self$x, self$b(), order_by = self$x)},
        Yc = function(...) {dplyr::nth(self$x, self$c(), order_by = self$x)},
        Yd = function(...) {dplyr::nth(self$x, self$d(), order_by = self$x)},
        alphastar = function(...) {
            for (i in self$a():(self$b() - 1)) {
                self$star[i] <- (
                    (choose(length(self$x), i)) *
                        (0.25^(i)) * (0.75^(length(self$x) - i))
                )
                return(alphastar = 1 - sum(self$star[i], na.rm = self$na.rm))
            }
        }
    ),
    # ---- define super_ function to enable multiple levels of inheritance ----
    active = list(
        super_ = function() super
    )
)
MaaniBeigy/DescObs documentation built on May 23, 2019, 9:37 a.m.