# Copyright (c) 2022 - 2026, Adrian Dusa
# All rights reserved.
# 
# Redistribution and use in source and binary forms, with or without
# modification, in whole or in part, are permitted provided that the
# following conditions are met:
#     * Redistributions of source code must retain the above copyright
#       notice, this list of conditions and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#     * The names of its contributors may NOT be used to endorse or promote
#       products derived from this software without specific prior written
#       permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

#' Weighted summaries
#' @name weighted
#' @order 1
#'
#' @title Compute weighted summaries for declared objects
#'
#' @description
#' Functions to compute weighted tables or summaries, based on a vector of
#' frequency weights. These are reimplementations of various existing functions,
#' adapted to objects of class \code{"declared"} (see Details below)
#'
#' @returns
#' A vector of (weighted) values.
#'
#' @details
#' A frequency table is usually performed for a categorical variable, displaying
#' the frequencies of the respective categories. Note that general variables
#' containing text are not necessarily factors, despite having a small number of
#' characters.
#'
#' A general table of frequencies, using the base function `table()`, ignores
#' the defined missing values (which are all stored as NAs). The
#' reimplementation of this function in `wtable()` takes care of this detail,
#' and presents frequencies for each separately defined missing values. Similar
#' reimplementations for the other functions have the same underlying objective.
#'
#' It is also possible to perform a frequency table for numerical variables, if
#' the number of values is limited (an arbitrary and debatable upper limit of 15
#' is used). An example of such variable can be the number of children, where
#' each value can be interpreted as a class, containing a single value (for
#' instance 0 meaning the category of people with no children).
#'
#' Objects of class `declared` are not pure categorical variables (R factors)
#' but they are nevertheless interpreted as if they were factors, to allow
#' producing frequency tables. Given the high similarity with package
#' **`haven`**, objects of class `haven_labelled_spss` are automatically
#' coerced to objects of class `declared` and treated accordingly.
#'
#' The argument `values` makes sense only when the input is of family class
#' `declared`, otherwise for regular (base R) factors the values are
#' just a sequence of numbers.
#'
#' The later introduced argument `observed` is useful in situations when a
#' variable has a very large number of potential values, and a smaller subset of
#' actually observed ones. As an example, the variable \dQuote{Occupation} has
#' hundreds of possible values in the ISCO08 codelist, and not all of them might
#' be actually observed. When activated, this argument restricts the printed
#' frequency table to the subset of observed values only.
#'
#' The argument `wt` refers only to frequency weights. Users should be
#' aware of the differences between frequency weights, analytic weights,
#' probability weights, design weights, post-stratification weights etc. For
#' purposes of inferential testing, Thomas Lumley's package **`survey`**
#' should be employed.
#'
#' If no frequency weights are provided, the result is identical to the
#' corresponding base functions.
#'
#' For all functions, the argument `na.rm` refers to the empty missing values
#' and its default is set to TRUE. The declared missing values are automatically
#' eliminated from the summary statistics, even if this argument is deactivated.
#'
#' @examples
#' set.seed(215)
#'
#' # a pure categorical variable
#' x <- factor(sample(letters[1:5], 215, replace = TRUE))
#' wtable(x)
#'
#'
#' # simulate number of children
#' x <- sample(0:4, 215, replace = TRUE)
#' wtable(x)
#'
#' # simulate a Likert type response scale from 1 to 7
#' values <- sample(c(1:7, -91), 215, replace = TRUE)
#' x <- declared(values, labels = c("Good" = 1, "Bad" = 7))
#' wtable(x)
#'
#'
#' # Defining missing values
#' missing_values(x) <- -91
#' wtable(x)
#'
#'
#' # Defined missing values with labels
#' values <- sample(c(1:7, -91, NA), 215, replace = TRUE)
#' x <- declared(
#'     values,
#'     labels = c("Good" = 1, "Bad" = 7, "Don't know" = -91),
#'     na_values = -91
#' )
#'
#' wtable(x)
#'
#' # Including the values in the table of frequencies
#' wtable(x, values = TRUE)
#'
#'
#' # An example involving multiple variables
#' DF <- data.frame(
#'     Area = declared(
#'         sample(1:2, 215, replace = TRUE, prob = c(0.45, 0.55)),
#'         labels = c(Rural = 1, Urban = 2)
#'     ),
#'     Gender = declared(
#'         sample(1:2, 215, replace = TRUE, prob = c(0.55, 0.45)),
#'         labels = c(Males = 1, Females = 2)
#'     ),
#'     Age = sample(18:90, 215, replace = TRUE),
#'     Children = sample(0:5, 215, replace = TRUE)
#' )
#'
#' wtable(DF$Gender)
#'
#' wsd(DF$Age)
#'
#' wmeasures(DF[c("Age", "Children")], what = c("n", "mean", "sd"))
#'
#'
#' # Weighting: observed proportions
#' op <- proportions(with(DF, table(Gender, Area)))
#'
#' # Theoretical proportions: 53% Rural, and 50.2% Females
#' tp <- rep(c(0.53, 0.47), each = 2) * rep(c(0.498, 0.502), 2)
#'
#' # Corrections by strata
#' fweights <- tp / op
#'
#' DF$fweight <- fweights[match(10 * DF$Area + DF$Gender, c(11, 12, 21, 22))]
#'
#' with(DF, wtable(Gender, wt = fweight))
#'
#' with(DF, wmean(Age, wt = fweight))
#'
#' with(DF, wquantile(Age, wt = fweight))
#' @author Adrian Dusa
#'
#' @param x A numeric vector for summaries, or declared / factor for frequency
#' tables
#'
#' @param y An optional variable, to create crosstabs; must have the same length
#' as x
#'
#' @param wt A numeric vector of frequency weights
#'
#' @param values Logical, print the values in the table rows
#'
#' @param valid Logical, print separate percent distribution for valid values,
#' if any missing values are present; for cross tables, use valid values only
#'
#' @param observed Logical, print the observed categories only
#'
#' @param vlabel Logical, print the variable label, if existing
#' @export
`wtable` <- function (
    x, y = NULL, wt = NULL, values = TRUE, valid = TRUE, observed = TRUE,
    vlabel = FALSE
) {

    funargs <- lapply(
        lapply(
            match.call(), deparse)[-1],
            function(x) gsub("'|\"|[[:space:]]", "", x
        )
    )

    nmx <- getName_ (funargs$x)

    if (inherits (x, "haven_labelled")) {
        x <- as.declared (x)
    }

    if (is.null (x) || !is.atomic (x)) {
        stopError_ ("'x' should be an atomic vector.")
    }

    xvallab <- yvallab <- NULL
    xna_values <- yna_values <- NULL
    xvalues <- yvalues <- TRUE
    missing_table <- NULL
    crosstab <- !is.null (y)

    if (!crosstab) {
        valid <- isTRUE (valid) && any (is.na (x))
    }

    xlabel <- attr (x, "label", exact = TRUE)
    allnax <- all (is.na (x))

    if (inherits (x, "declared")) {
        allnax <- all (is.empty (x))
        if (!allnax) {
            # names_values () arranges missing values at the end
            xvallab <- names_values (
                x,
                drop_na = isTRUE (valid) & crosstab,
                observed = observed
            )

            xna_values <- attr (xvallab, "missing")
            # x <- factor (as.character (x), levels = names (xvallab))
            # sometimes (e.g. ISCO codifications in ESS) there are identical labels
            # with different values, and factor () complains with overlapping levels

            xvalues <- !identical (names (xvallab), as.character (xvallab))
            # print (head(paste (as.character (x), undeclare (x), sep = "_-_")))
            x <- factor (
                paste (
                    undeclare (x, drop = TRUE),
                    as.character (undeclare (x)),
                    sep = "_-_"
                ),
                levels = paste (xvallab, names (xvallab), sep = "_-_")
            )
        }
        else {
            xvalues <- FALSE
            x <- undeclare (x, drop = TRUE)
        }
    }
    else {
        xvalues <- FALSE
        if (!allnax) {
            lvls <- levels (as.factor (x))
            xvallab <- seq (length (lvls))
            names (xvallab) <- lvls
        }
    }

    xy <- list (x = x)
    if (crosstab) {
        if (!is.atomic (y)) {
            stopError_ ("'y' should be an atomic vector.")
        }

        if (length (x) != length (y)) {
            stopError_ ("Lengths of 'x' and 'y' differ.")
        }

        ylabel <- attr (y, "label", exact = TRUE)
        allnay <- all (is.na (y))

        nmy <- getName_ (funargs$y)
        dimnms <- c(nmx, nmy)

        ncharx <- nchar (nmx)
        nchary <- nchar (nmy)
        if (length(c (ncharx + nchary)) > 0) {
            nchars <- max (nchar (c (nmx, nmy)))
        }

        if (length(ncharx) > 0 && ncharx > 0) {
            nmx <- padLeft_ (nmx, nchars - ncharx)
        }

        if (length(nchary) > 0 && nchary > 0) {
            nmy <- padLeft_ (nmy, nchars - nchary)
        }

        if (inherits (y, "declared")) {
            allnay <- all (is.empty (y))
            if (!allnay) {
                yvallab <- names_values (
                    y,
                    drop_na = crosstab && isTRUE (valid),
                    observed = observed
                )
                yna_values <- attr (yvallab, "missing")

                y <- factor (
                    paste (
                        undeclare (y, drop = TRUE),
                        as.character (undeclare (y)),
                        sep = "_-_"
                    ),
                    levels = paste (yvallab, names (yvallab), sep = "_-_")
                )
            }
            else {
                yvalues <- FALSE
                y <- undeclare (y, drop = TRUE)
            }
        }
        else {
            yvalues <- FALSE
            if (!allnay) {
                lvls <- levels (as.factor (y))
                yvallab <- seq (length (lvls))
                names (yvallab) <- lvls
            }
        }

        xy$y <- y
    }

    if (is.null (wt)) {
        wt <- rep (1, length (x))
    }


    if (
        !is.null (wt) && !(
            is.atomic (wt) && all (is.finite (na.omit (wt)))
        )
    ) {
        stopError_ ("'wt' should be an atomic vector with finite values.")
    }

    if (length (x) != length (wt)) {
        stopError_ ("Lengths of 'x' and 'wt' differ.")
    }


    orig <- round (tapply (wt, xy, sum, na.rm = TRUE), 0)
    orig[is.na (orig)] <- 0
    tbl <- as.matrix(orig)
    dimnames (tbl) <- unname (dimnames (tbl))

    rs <- rowSums (tbl)
    cs <- colSums (tbl)

    if (isTRUE (observed)) {
        if (crosstab) {
            xvallab <- xvallab[rs > 0]
            yvallab <- yvallab[cs > 0]
            orig <- orig[rs > 0, , drop = FALSE]
            orig <- orig[, cs > 0, drop = FALSE]
            tbl <- tbl[rs > 0, , drop = FALSE]
            tbl <- tbl[, cs > 0, drop = FALSE]
            rs <- rs[rs > 0]
            cs <- cs[cs > 0]
        }
        else {
            orig <- orig[rs > 0]
            tbl <- tbl[rs > 0, , drop = FALSE]
            xvallab <- xvallab[rs > 0]
        }
    }

    if (crosstab) {

        toprint <- orig <- tbl
        names (dimnames (orig))  <- dimnms

        toprint <- rbind (toprint, Total = colSums (toprint))
        toprint <- cbind (toprint, Total = rowSums (toprint))

        if (isTRUE (vlabel)) {
            if (!is.null (xlabel) & !is.null (ylabel)) {
                attr (toprint, "xlabel") <- paste(nmx, xlabel, sep = ": ")
                attr (toprint, "ylabel") <- paste(nmy, ylabel, sep = ": ")
            } else {
                message("Variable label(s) not available.")
            }
        }
        attr (toprint, "xvalues") <- isTRUE (values) & xvalues
        attr (toprint, "yvalues") <- isTRUE (values) & yvalues

        # class (toprint) <- c ("wtable", "matrix")
    }
    else {
        only_na <- length (x) > 0 && isTRUE (allnax)
        labels <- NULL
        if (nrow(tbl) > 0) {
            labels <- rownames (tbl)
            labels <- sapply (strsplit (labels, split = "_-_"), tail, 1)
        }

        if (any (is.na (x))) {
            tbl <- c (tbl, sum (is.na (x)))
            labels <- c (labels, NA)
        }

        if (isTRUE (observed)) {
            tbl <- tbl[tbl > 0]
        }

        missing <- rep (FALSE, length (tbl))
        if (length (xna_values) > 0) {
            missing[seq_along (xvallab)] <- is.element (xvallab, xna_values)
        }
        missing <- missing | is.na (labels)
        missing_table <- tbl[missing]
        if (length (missing_table) > 0) {
            names (missing_table) <- labels[missing]
            names (missing_table)[is.na (names (missing_table))] <- "NA"
        }

        toprint <- data.frame (fre = tbl)

        toprint$rel <- proportions (toprint$fre)
        toprint$per <- toprint$rel * 100

        if (valid & (length (missing) > 0 | any (is.na (labels)))) {
            vld <- toprint$fre
            nalabels <- is.element (xvallab, xna_values)
            vld[nalabels] <- NA
            vld[is.na (labels)] <- NA

            lna <- seq (length (nalabels))

            vld[seq (sum (!nalabels))] <- 100 * proportions (
                vld[seq (sum (!nalabels))]
            )

            toprint$vld <- NA
            toprint$vld[seq (length (vld))] <- vld
            toprint$cpd <- NA
            toprint$cpd[seq (length (vld))] <- cumsum (vld)
        }
        else {
            valid <- FALSE
            toprint$cpd <- cumsum (toprint$per)
        }

        if (isTRUE (vlabel)) {
            attr (toprint, "xlabel") <- paste(nmx, xlabel, sep = ": ")
        }
        attr (toprint, "labels") <- labels
        attr (toprint, "values") <- as.vector (xvallab)
        attr (toprint, "show_values") <- values & xvalues
        attr (toprint, "na_values") <- xna_values
        attr (toprint, "valid") <- valid

        orig <- tbl[!missing]
        if (length (xvallab) > 0) {
            xvallab <- xvallab[!is.element (xvallab, xna_values)]
        }

        if (only_na) {
            orig <- array (numeric (0), dim = c (0))
        }
    }

    if (is.matrix(orig)) {
        if (length (xvallab)) {
            rownames (orig) <- names (xvallab)
        }
        if (length (yvallab)) {
            colnames (orig) <- names (yvallab)
        }
    }
    else {
        orig <- array (orig, dim = length (orig))
        if (length (xvallab)) {
            dimnames (orig) <- list (names (xvallab))
        }
    }



    attr (orig, "toprint") <- toprint
    if (length (missing_table) > 0) {
        attr (orig, "missing") <- missing_table
    }
    class (orig) <- c ("wtable", "table")
    return (orig)
}

#' @rdname declared_internal
#' @keywords internal
#' @export
`w_table` <- function (...) {
    wtable(...)
}
