R/jmvtab.h.R

Defines functions jmvtab

Documented in jmvtab

# This file is automatically generated, you probably don't want to edit this

jmvtabOptions <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
    "jmvtabOptions",
    inherit = jmvcore::Options,
    public = list(
        initialize = function(
            row_vars = NULL,
            col_vars = NULL,
            tab_vars = NULL,
            wt = NULL,
            pct = "no",
            color = "no",
            chi2 = TRUE,
            OR = "no",
            na = "keep",
            lvs = "all",
            other_if_less_than = 0,
            cleannames = TRUE,
            ref = "auto",
            ref2 = "first",
            comp = "tab",
            ci = "auto",
            conf_level = 0.95,
            ci_print = "ci",
            totaltab = "line",
            wrap_rows = 35,
            wrap_cols = 15,
            display = "auto",
            add_n = TRUE,
            add_pct = FALSE,
            subtext = "",
            digits = 0, ...) {

            super$initialize(
                package="tabxplor",
                name="jmvtab",
                requiresData=TRUE,
                ...)

            private$..row_vars <- jmvcore::OptionVariable$new(
                "row_vars",
                row_vars,
                permitted=list(
                    "numeric",
                    "factor"),
                default=NULL,
                suggested=list(
                    "nominal",
                    "ordinal"))
            private$..col_vars <- jmvcore::OptionVariables$new(
                "col_vars",
                col_vars,
                suggested=list(
                    "nominal",
                    "ordinal",
                    "continuous"),
                permitted=list(
                    "numeric",
                    "factor"),
                default=NULL)
            private$..tab_vars <- jmvcore::OptionVariables$new(
                "tab_vars",
                tab_vars,
                suggested=list(
                    "nominal",
                    "ordinal"),
                permitted=list(
                    "factor"),
                default=NULL)
            private$..wt <- jmvcore::OptionVariable$new(
                "wt",
                wt,
                suggested=list(
                    "continuous"),
                permitted=list(
                    "numeric"),
                default=NULL)
            private$..pct <- jmvcore::OptionList$new(
                "pct",
                pct,
                options=list(
                    "no",
                    "row",
                    "col",
                    "all",
                    "all_tabs"),
                default="no")
            private$..color <- jmvcore::OptionList$new(
                "color",
                color,
                options=list(
                    "no",
                    "diff",
                    "diff_ci",
                    "after_ci",
                    "contrib",
                    "OR"),
                default="no")
            private$..chi2 <- jmvcore::OptionBool$new(
                "chi2",
                chi2,
                default=TRUE)
            private$..OR <- jmvcore::OptionList$new(
                "OR",
                OR,
                options=list(
                    "no",
                    "OR",
                    "OR_pct"),
                default="no")
            private$..na <- jmvcore::OptionList$new(
                "na",
                na,
                options=list(
                    "keep",
                    "drop",
                    "drop_all"),
                default="keep")
            private$..lvs <- jmvcore::OptionList$new(
                "lvs",
                lvs,
                options=list(
                    "all",
                    "first",
                    "auto"),
                default="all")
            private$..other_if_less_than <- jmvcore::OptionNumber$new(
                "other_if_less_than",
                other_if_less_than,
                min=0,
                default=0)
            private$..cleannames <- jmvcore::OptionBool$new(
                "cleannames",
                cleannames,
                default=TRUE)
            private$..ref <- jmvcore::OptionString$new(
                "ref",
                ref,
                default="auto")
            private$..ref2 <- jmvcore::OptionString$new(
                "ref2",
                ref2,
                default="first")
            private$..comp <- jmvcore::OptionList$new(
                "comp",
                comp,
                options=list(
                    "tab",
                    "all"),
                default="tab")
            private$..ci <- jmvcore::OptionList$new(
                "ci",
                ci,
                options=list(
                    "auto",
                    "cell",
                    "diff"),
                default="auto")
            private$..conf_level <- jmvcore::OptionNumber$new(
                "conf_level",
                conf_level,
                min=0,
                max=1,
                default=0.95)
            private$..ci_print <- jmvcore::OptionList$new(
                "ci_print",
                ci_print,
                options=list(
                    "ci",
                    "moe"),
                default="ci")
            private$..totaltab <- jmvcore::OptionList$new(
                "totaltab",
                totaltab,
                options=list(
                    "line",
                    "table",
                    "no"),
                default="line")
            private$..wrap_rows <- jmvcore::OptionNumber$new(
                "wrap_rows",
                wrap_rows,
                min=0,
                default=35)
            private$..wrap_cols <- jmvcore::OptionNumber$new(
                "wrap_cols",
                wrap_cols,
                min=0,
                default=15)
            private$..display <- jmvcore::OptionList$new(
                "display",
                display,
                options=list(
                    "auto",
                    "n",
                    "wn",
                    "pct",
                    "diff",
                    "ctr",
                    "mean",
                    "var",
                    "ci",
                    "pct_ci",
                    "mean_ci",
                    "OR",
                    "OR_pct"),
                default="auto")
            private$..add_n <- jmvcore::OptionBool$new(
                "add_n",
                add_n,
                default=TRUE)
            private$..add_pct <- jmvcore::OptionBool$new(
                "add_pct",
                add_pct,
                default=FALSE)
            private$..subtext <- jmvcore::OptionString$new(
                "subtext",
                subtext,
                default="")
            private$..digits <- jmvcore::OptionNumber$new(
                "digits",
                digits,
                min=0,
                max=10,
                default=0)

            self$.addOption(private$..row_vars)
            self$.addOption(private$..col_vars)
            self$.addOption(private$..tab_vars)
            self$.addOption(private$..wt)
            self$.addOption(private$..pct)
            self$.addOption(private$..color)
            self$.addOption(private$..chi2)
            self$.addOption(private$..OR)
            self$.addOption(private$..na)
            self$.addOption(private$..lvs)
            self$.addOption(private$..other_if_less_than)
            self$.addOption(private$..cleannames)
            self$.addOption(private$..ref)
            self$.addOption(private$..ref2)
            self$.addOption(private$..comp)
            self$.addOption(private$..ci)
            self$.addOption(private$..conf_level)
            self$.addOption(private$..ci_print)
            self$.addOption(private$..totaltab)
            self$.addOption(private$..wrap_rows)
            self$.addOption(private$..wrap_cols)
            self$.addOption(private$..display)
            self$.addOption(private$..add_n)
            self$.addOption(private$..add_pct)
            self$.addOption(private$..subtext)
            self$.addOption(private$..digits)
        }),
    active = list(
        row_vars = function() private$..row_vars$value,
        col_vars = function() private$..col_vars$value,
        tab_vars = function() private$..tab_vars$value,
        wt = function() private$..wt$value,
        pct = function() private$..pct$value,
        color = function() private$..color$value,
        chi2 = function() private$..chi2$value,
        OR = function() private$..OR$value,
        na = function() private$..na$value,
        lvs = function() private$..lvs$value,
        other_if_less_than = function() private$..other_if_less_than$value,
        cleannames = function() private$..cleannames$value,
        ref = function() private$..ref$value,
        ref2 = function() private$..ref2$value,
        comp = function() private$..comp$value,
        ci = function() private$..ci$value,
        conf_level = function() private$..conf_level$value,
        ci_print = function() private$..ci_print$value,
        totaltab = function() private$..totaltab$value,
        wrap_rows = function() private$..wrap_rows$value,
        wrap_cols = function() private$..wrap_cols$value,
        display = function() private$..display$value,
        add_n = function() private$..add_n$value,
        add_pct = function() private$..add_pct$value,
        subtext = function() private$..subtext$value,
        digits = function() private$..digits$value),
    private = list(
        ..row_vars = NA,
        ..col_vars = NA,
        ..tab_vars = NA,
        ..wt = NA,
        ..pct = NA,
        ..color = NA,
        ..chi2 = NA,
        ..OR = NA,
        ..na = NA,
        ..lvs = NA,
        ..other_if_less_than = NA,
        ..cleannames = NA,
        ..ref = NA,
        ..ref2 = NA,
        ..comp = NA,
        ..ci = NA,
        ..conf_level = NA,
        ..ci_print = NA,
        ..totaltab = NA,
        ..wrap_rows = NA,
        ..wrap_cols = NA,
        ..display = NA,
        ..add_n = NA,
        ..add_pct = NA,
        ..subtext = NA,
        ..digits = NA)
)

jmvtabResults <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
    "jmvtabResults",
    inherit = jmvcore::Group,
    active = list(
        html_table = function() private$.items[["html_table"]],
        chi2_table = function() private$.items[["chi2_table"]],
        plot = function() private$.items[["plot"]]),
    private = list(),
    public=list(
        initialize=function(options) {
            super$initialize(
                options=options,
                name="",
                title="Crosstables")
            self$add(jmvcore::Html$new(
                options=options,
                name="html_table",
                title="Table"))
            self$add(jmvcore::Table$new(
                options=options,
                name="chi2_table",
                title="Chi2 Test",
                rows=0,
                columns=list(
                    list(
                        `name`="row_var", 
                        `title`="row_var", 
                        `type`="text"))))
            self$add(jmvcore::Image$new(
                options=options,
                name="plot",
                title="",
                width=1080,
                height=0,
                renderFun=".plot"))}))

jmvtabBase <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
    "jmvtabBase",
    inherit = jmvcore::Analysis,
    public = list(
        initialize = function(options, data=NULL, datasetId="", analysisId="", revision=0) {
            super$initialize(
                package = "tabxplor",
                name = "jmvtab",
                version = c(1,0,0),
                options = options,
                results = jmvtabResults$new(options=options),
                data = data,
                datasetId = datasetId,
                analysisId = analysisId,
                revision = revision,
                pause = NULL,
                completeWhenFilled = FALSE,
                requiresMissings = FALSE,
                weightsSupport = 'full')
        }))

#' Crosstables
#'
#' 
#' @param data A data.frame.
#' @param row_vars The row variable, which will be printed with one level per
#'   line. If numeric, it will be converted to factor.
#' @param col_vars One column is printed for each level of each column
#'   variable. For numeric variables means are calculated, in a single column.
#' @param tab_vars One subtable is made for each combination of levels of the
#'   tab variables. All tab variables are converted to factor. Leave empty to
#'   make a simple table.
#' @param wt A weight variable, of class numeric. Leave empty for unweighted
#'   results.
#' @param pct The type of percentages to calculate :  \itemize{    \item
#'   \code{"row"}: row percentages.    \item \code{"col"}: column percentages.
#'   \item \code{"all"}: frequencies for each subtable/group, if there is
#'   \code{tab_vars}.    \item \code{"all_tabs"}: frequencies for the whole (set
#'   of) table(s).  }
#' @param color The type of colors to print, as a single string. Vectorised
#'   over \code{row_vars}.  \itemize{    \item \code{"no"}: by default, no
#'   colors are printed.    \item \code{"diff"}: color percentages and means
#'   based on cells differences from    totals (or from first cells when
#'   \code{ref = "first"}).    \item \code{"diff_ci"}: color pct and means based
#'   on cells differences from totals    or first cells, removing coloring when
#'   the confidence interval of this difference    is higher than the difference
#'   itself.    \item \code{"after_ci"}: idem, but cut off the confidence
#'   interval from the    difference first.    \item \code{"contrib"}: color
#'   cells based on their contribution to variance    (except mean columns, from
#'   numeric variables).    \item \code{"OR"}: for \code{pct == "col"} or
#'   \code{pct == "row"},    color based on odds ratios (or relative risks
#'   ratios)  }
#' @param chi2 Set to \code{TRUE} to make a Chi2 and add summary stats. Also
#'   useful to color cells based on their contribution to variance.
#' @param OR With \code{pct = "row"} or \code{pct = "col"}, calculate and
#'   print odds ratios  (for binary variables) or relative risks ratios (for
#'   variables with 3 levels  or more). \itemize{  \item \code{"no"}: by
#'   default, no OR are calculated.  \item \code{"OR"}: print OR (instead of
#'   percentages).  \item \code{"OR_pct"}: print OR, with percentages in
#'   bracket. }
#' @param na The policy to adopt with missing values. It must be a single
#'   string.  \itemize{    \item \code{na = "keep"}: by default, prints
#'   \code{NA}'s as explicit \code{"NA"} level.    \item \code{na = "drop"}:
#'   removes \code{NA} levels before making each table    (tabs made with
#'   different column variables may have a different number of    observations,
#'   and won't exactly have the same total columns).    }
#' @param lvs The levels of \code{col_vars} to keep.  \itemize{    \item
#'   \code{"all"}: by default, all levels are kept.    \item \code{"first"}:
#'   only keep the first level of each \code{col_vars}    \item \code{"auto"}:
#'   keep the first level when \code{col_var} is only two levels,    keep all
#'   levels otherwise.    }
#' @param other_if_less_than When set to a positive integer, levels with less
#'   count than that will be merged into an "Others" level.
#' @param cleannames By default, clean levels names, by removing prefix
#'   numbers like "1-", and text in parenthesis. Set to \code{FALSE} to avoid
#'   this behaviour.
#' @param ref The reference cell to calculate differences and ratios   (used
#'   to print \code{colors}) :   \itemize{    \item \code{"auto"}: by default,
#'   cell difference from the corresponding total    (rows or cols depending on
#'   \code{pct = "row"} or \code{pct = "col"}) is    used for \code{diff} ; cell
#'   ratio from the first line (or col) is use for \code{OR}    (odds
#'   ratio/relative risks ratio).    \item \code{"tot"}: totals are always used.
#'   \item \code{"first"}: calculate cell difference or ratio from the first
#'   cell  of the row or column (useful to color temporal developments).
#'   \item \code{n}: when \code{ref} is an integer, the nth row (or column) is
#'   used for comparison.    \item \code{"regex"}: when \code{ref} is a string,
#'   it it used as a regular expression,    to match with the names of the rows
#'   (or columns). Be precise enough to match only one    column or row,
#'   otherwise you get a warning message.    \item \code{"no"}: not use ref and
#'   not calculate diffs to gain calculation time.  }
#' @param ref2 A second reference cell is needed to calculate odds ratios  (or
#'   relative risks ratios). The first cell of the row or column is used by
#'   default.  See \code{ref}  for the full list of possible values.
#' @param comp The comparison level : by subtables/groups, or for the whole
#'   table.
#' @param ci The type of confidence intervals to calculate, passed to
#'   \code{\link{tab_ci}}.     \itemize{      \item \code{"cell"}: absolute
#'   confidence intervals of cells percentages.      \item \code{"diff"}:
#'   confidence intervals of the difference between a cell and the      relative
#'   total cell (or relative first cell when \code{ref = "first"}).      \item
#'   \code{"auto"}: \code{ci = "diff"} for means and row/col percentages,
#'   \code{ci = "cell"} for frequencies ("all", "all_tabs").     } By default,
#'   for percentages, with \code{ci = "cell"} Wilson's method is used, and with
#'   \code{ci = "diff"} Wald's method along Agresti and Caffo's adjustment.
#'   Means use classic method.
#' @param conf_level The confidence level, as a single numeric between 0 and
#'   1. Default to 0.95 (95\%).
#' @param ci_print By default confidence interval are printed with the
#'   interval display. Set to "moe" to use pct +- moe instead.
#' @param totaltab The total table, if there are subtables/groups   (i.e. when
#'   \code{tab_vars} is provided). Vectorised over \code{row_vars}.  \itemize{
#'   \item \code{"line"}: by default, add a general total line (necessary for
#'   calculations with \code{comp = "all"})    \item \code{"table"}: add a
#'   complete total table   (i.e. \code{row_var} by \code{col_vars} without
#'   \code{tab_vars}).    \item \code{"no"}: not to draw any total table.   }
#' @param wrap_rows By default, rownames are wrapped when larger than 30
#'   characters.
#' @param wrap_cols By default, colnames are wrapped when larger than 12
#'   characters.
#' @param display The information to display in the table.
#' @param add_n For \code{pct = "row"} or \code{pct = "col"}, set to
#'   \code{FALSE} not to add another column or row with unweighted counts
#'   (\code{n}).
#' @param add_pct Set to \code{TRUE} to add a column with the frequencies of
#'   the row variable (for \code{pct = "row"}) or a row with the frequencies of
#'   the column variable (for  \code{pct = "col"})
#' @param subtext A character vector to print rows of legend under the table.
#' @param digits The number of digits to print, as a single integer, or an
#'   integer vector the same length as \code{col_vars}.
#' @return A results object containing:
#' \tabular{llllll}{
#'   \code{results$html_table} \tab \tab \tab \tab \tab a html \cr
#'   \code{results$chi2_table} \tab \tab \tab \tab \tab a table \cr
#'   \code{results$plot} \tab \tab \tab \tab \tab an image \cr
#' }
#'
#' Tables can be converted to data frames with \code{asDF} or \code{\link{as.data.frame}}. For example:
#'
#' \code{results$chi2_table$asDF}
#'
#' \code{as.data.frame(results$chi2_table)}
#'
#' @export
jmvtab <- function(
    data,
    row_vars = NULL,
    col_vars = NULL,
    tab_vars = NULL,
    wt = NULL,
    pct = "no",
    color = "no",
    chi2 = TRUE,
    OR = "no",
    na = "keep",
    lvs = "all",
    other_if_less_than = 0,
    cleannames = TRUE,
    ref = "auto",
    ref2 = "first",
    comp = "tab",
    ci = "auto",
    conf_level = 0.95,
    ci_print = "ci",
    totaltab = "line",
    wrap_rows = 35,
    wrap_cols = 15,
    display = "auto",
    add_n = TRUE,
    add_pct = FALSE,
    subtext = "",
    digits = 0) {

    if ( ! requireNamespace("jmvcore", quietly=TRUE))
        stop("jmvtab requires jmvcore to be installed (restart may be required)")

    if ( ! missing(row_vars)) row_vars <- jmvcore::resolveQuo(jmvcore::enquo(row_vars))
    if ( ! missing(col_vars)) col_vars <- jmvcore::resolveQuo(jmvcore::enquo(col_vars))
    if ( ! missing(tab_vars)) tab_vars <- jmvcore::resolveQuo(jmvcore::enquo(tab_vars))
    if ( ! missing(wt)) wt <- jmvcore::resolveQuo(jmvcore::enquo(wt))
    if (missing(data))
        data <- jmvcore::marshalData(
            parent.frame(),
            `if`( ! missing(row_vars), row_vars, NULL),
            `if`( ! missing(col_vars), col_vars, NULL),
            `if`( ! missing(tab_vars), tab_vars, NULL),
            `if`( ! missing(wt), wt, NULL))

    for (v in tab_vars) if (v %in% names(data)) data[[v]] <- as.factor(data[[v]])

    options <- jmvtabOptions$new(
        row_vars = row_vars,
        col_vars = col_vars,
        tab_vars = tab_vars,
        wt = wt,
        pct = pct,
        color = color,
        chi2 = chi2,
        OR = OR,
        na = na,
        lvs = lvs,
        other_if_less_than = other_if_less_than,
        cleannames = cleannames,
        ref = ref,
        ref2 = ref2,
        comp = comp,
        ci = ci,
        conf_level = conf_level,
        ci_print = ci_print,
        totaltab = totaltab,
        wrap_rows = wrap_rows,
        wrap_cols = wrap_cols,
        display = display,
        add_n = add_n,
        add_pct = add_pct,
        subtext = subtext,
        digits = digits)

    analysis <- jmvtabClass$new(
        options = options,
        data = data)

    analysis$run()

    analysis$results
}
BriceNocenti/tablr documentation built on April 12, 2025, 12:56 a.m.