R/Chartsub.R

In lessR: Less Code with More Comprehensive Results

# ---- Drop casewise missing across x, y, by, facet -----------------------
# Called from: Chart.R

.drop_casewise_missing <- function(x.call = NULL,
                                   y.call = NULL,
                                   by.call = NULL,
                                   facet.call = NULL) {
  # Build a combined data.frame of all columns we care about
  blocks <- list()

  if (!is.null(x.call)) {
    # vector, matrix, or data.frame
    x_df <- as.data.frame(x.call)
    blocks[["x"]] <- x_df
  }

  if (!is.null(y.call)) {
    blocks[["y"]] <- data.frame(..y = y.call)
  }

  if (!is.null(by.call)) {
    # vector, matrix, or data.frame (incl. cbind(Gender, Plan))
    by_df <- as.data.frame(by.call)
    blocks[["by"]] <- by_df
  }

  if (!is.null(facet.call)) {
    # vector, matrix, or data.frame (incl. two facet vars)
    facet_df <- as.data.frame(facet.call)
    blocks[["facet"]] <- facet_df
  }

  if (!length(blocks)) return(NULL)

  df <- do.call(cbind, blocks)
  stats::complete.cases(df)
}



# ===== Chart() plotly sub-functions (moved from zzz_plotly.R) =====


# Helper: build plotly chart title from main/main.miss + variable names
# Returns: character string (auto-built), user-supplied string, or NULL
.build_chart_title <- function(main, main.miss, x_name=NULL, by_name=NULL,
                                facet_name=NULL, y_name=NULL, stat=NULL) {

  if (!is.null(y_name) && y_name == "Count") y_name <- NULL

  if (!main.miss && !is.null(main))
    main[1]                          # user supplied a title
  else if (main.miss)
    .plotly_build_title(             # auto-build from variable names
      x_name     = x_name,
      by_name    = by_name,
      facet_name = facet_name,
      y_name     = y_name,
      stat       = stat
    )
  else
    NULL                             # main=NULL explicitly supplied — no title
}


# Helper: reshape Chart()'s tidy (x.call, y.call, by.call) into the table
# shape piechart.plotly / bubble.plotly want to render. Returns:
#   - 1-D named numeric vector (no by.call)
#   - 2-D matrix with dimnames list(by=, x=) (by.call supplied)
.build_plotly_tbl <- function(x.call, y.call, by.call) {

  if (is.null(y.call)) {
    # counts — tabulate row occurrences
    if (is.null(by.call))
      return(xtabs(~ x.call, drop.unused.levels = FALSE))
    else
      return(xtabs(~ by.call + x.call, drop.unused.levels = FALSE))
  }

  # y already aggregated to one value per (by, x) cell — just reshape
  if (is.null(by.call)) {
    return(setNames(as.numeric(y.call), as.character(x.call)))
  }
  by.fac <- if (is.factor(by.call)) droplevels(by.call)
            else factor(by.call, levels = unique(by.call))
  x_fac  <- if (is.factor(x.call))  droplevels(x.call)
            else factor(x.call, levels = unique(x.call))
  tbl    <- xtabs(as.numeric(y.call) ~ by.fac + x_fac,
                  drop.unused.levels = TRUE)
  dimnames(tbl) <- list(by = levels(by.fac), x = levels(x_fac))
  tbl
}


.build_xtab <- function(x, y = NULL, by = NULL, facet = NULL,
                        stat = NULL, is.agg = FALSE, digits_d = 2) {
  # construct summary table x.tbl from x, optional by / facet and optional y

  # resolve stat function
  STAT <- tolower(stat %||% "sum")
  stat_fun <- switch(
    STAT,
    mean   = function(z) mean(z,          na.rm = TRUE),
    sum    = function(z) sum(z,           na.rm = TRUE),
    median = function(z) stats::median(z, na.rm = TRUE),
    min    = function(z) min(z,           na.rm = TRUE),
    max    = function(z) max(z,           na.rm = TRUE),
    sd     = function(z) stats::sd(z,     na.rm = TRUE),
    stop("Unsupported stat: '", stat, "'. Use mean, sum, median, min, max, or sd.")
  )

  ## helper: coerce a generic grouping object (vector, matrix, data.frame, list)
  ## into a data.frame with at least one column, or NULL
  to_group_df <- function(obj, prefix = "g") {
    if (is.null(obj)) return(NULL)

    if (is.data.frame(obj))
      df <- obj
    else if (is.matrix(obj))
      df <- as.data.frame(obj)
    else if (is.list(obj) && !is.atomic(obj)) # list of equal-length vectors
      df <- as.data.frame(obj)
    else   # single vector
      df <- data.frame(obj)

    if (is.null(colnames(df)))
      colnames(df) <- paste0(prefix, seq_len(ncol(df)))

    df
  }  # end to_group_df()

  ## ------------------------------------------------------------
  ## 1) RAW DATA: build table from x / y / groupings
  ## ------------------------------------------------------------
  if (!is.agg) {

    by_df    <- to_group_df(by,    prefix = "by")
    facet_df <- to_group_df(facet, prefix = "facet")

    # combine all grouping columns (by + facet); may be NULL
    if (is.null(by_df) && is.null(facet_df))
      group_df <- NULL
    else if (is.null(by_df))
      group_df <- facet_df
    else if (is.null(facet_df))
      group_df <- by_df
    else
      group_df <- cbind(by_df, facet_df)

    if (is.null(y)) {  # counts
      if (is.null(group_df)) {
        # simple one-way table of x
        x.tbl <- xtabs(~ x, drop.unused.levels = FALSE)
      }
      else {
        # multi-way table over all grouping columns + x
        df <- data.frame(group_df, x = x)
        form <- reformulate(c(names(group_df), "x"))
        x.tbl <- xtabs(form, data = df, drop.unused.levels = FALSE)
      }

    }
    else {  # numeric summary
      if (is.null(group_df)) {  # numeric y summarized by x only
        agg <- tapply(as.numeric(y), x, stat_fun)
        x.tbl <- agg[!is.na(names(agg))]
      } else {
        df   <- data.frame(group_df, x = x, y = as.numeric(y))
        grps <- c(lapply(names(group_df), function(nm) df[[nm]]), list(x = df$x))
        agg  <- tapply(df$y, grps, stat_fun)
        if (identical(STAT, "sum")) agg[is.na(agg)] <- 0
        x.tbl <- agg
      }
    }
  }  # end !is.agg

  else {
    ## ------------------------------------------------------------
    ## 2) ALREADY AGGREGATED DATA: treat x as table / vector
    ## ------------------------------------------------------------
    if (is.null(y)) {
      # x is (or should be) already in table-like form
      if (is.table(x))
        x.tbl <- x
      else
        x.tbl <- as.table(x)
    }
    else {
      # aggregated y supplied explicitly; restore to table form
      # here we assume caller has already shaped x/y/by/facet as needed
      by_df    <- to_group_df(by,    prefix = "by")
      facet_df <- to_group_df(facet, prefix = "facet")

      if (is.null(by_df) && is.null(facet_df)) {
        agg <- tapply(as.numeric(y), x, stat_fun)
        x.tbl <- agg[!is.na(names(agg))]
      }
      else {
        if (is.null(by_df) && !is.null(facet_df)) {
          group_df <- facet_df
        }
        else if (!is.null(by_df) && is.null(facet_df)) {
          group_df <- by_df
        }
        else
          group_df <- cbind(by_df, facet_df)
        df <- data.frame(group_df, x = x, y = y)
        form <- reformulate(c(names(group_df), "x"), response = "y")
        x.tbl <- xtabs(form, data = df, drop.unused.levels = FALSE)
      }
    }
  }

  x.tbl
}


# ----- dot-plot origin/gridT chooser ------------------------------------
# Choose a chart-friendly origin and pretty tick positions for a dot plot's
# value axis. Returns list(origin=., gridT=.). Called once by Chart() per
# dot-plot call; dot.plotly() then renders against the supplied values.
#
# vals      : numeric vector of plotted values (NAs allowed; ignored)
# origin_in : user-supplied origin (NULL = auto-choose)
# is_counts : TRUE forces count-style behavior (origin defaults to 0,
#             no nudge-below-first-tick); NULL = infer from vals (TRUE
#             when all finite values are non-negative integers)
.dot_origin_grid <- function(vals, origin_in = NULL, is_counts = NULL) {
  fv <- vals[is.finite(vals)]

  if (length(fv) == 0L) {
    return(list(
      origin = if (is.null(origin_in)) 0 else origin_in,
      gridT  = pretty(c(0, 1))
    ))
  }

  if (is.null(is_counts))
    is_counts <- all(fv >= 0) && all(fv == floor(fv))

  origin <- origin_in
  if (is.null(origin)) {
    if (is_counts) {
      origin <- 0
    } else {
      fv2  <- if (all(fv < 0)) -fv else fv
      mn.v <- min(fv2); mx.v <- max(fv2)
      if (mn.v > 0 && (mx.v - mn.v) / mn.v <= 2.40)
        origin <- mn.v
    }
  }
  gridT <- pretty(c(if (!is.null(origin)) origin else min(fv), fv))
  # nudge one step below first tick for continuous data, not counts
  if (is.null(origin_in) && !is_counts && length(gridT) > 1L) {
    step   <- gridT[2L] - gridT[1L]
    origin <- gridT[1L] - step
    gridT  <- pretty(c(origin, fv))
  }
  list(origin = origin, gridT = gridT)
}


# ----- print the summary table behind a pie or bubble chart --------------
# High-level DISPATCHER for the text output that accompanies Chart()'s
# pie/bubble plots. Takes a 1-D / 2-D table from .build_plotly_tbl() and
# decides what kind of summary to print:
#   - count tables (y was NULL)  → delegates to .ss.factor() and prints
#                                  title + frequencies + chi-square test
#                                  via the "out_all" S3 class
#   - numeric stat tables        → just base print(x.tbl)
#   - 3+ dimensional tables      → labeled cat() + print(x.tbl)
# Returns nothing; side-effect is console output.
.print_chart_summary <- function(x.tbl, x_name, x.lbl = NULL,
                                 by_name = NULL, y_name = NULL,
                                 stat = NULL, digits_d = 2) {

  # helper: is this table "count-like"? (y was NULL, so caller passes y_name = "Count")
  is.count <- is.null(y_name) || identical(y_name, "Count")

  nd <- length(dim(x.tbl))

  if (is.count) {  # x.tbl is count-like values
    # --- 1D / 2D paths still get the .ss.factor treatment ----------------
    if (is.null(dim(x.tbl))) {
      # 1D: named vector of counts -> coerce to table with dimname "x"
      dn <- list(names(x.tbl))
      x.tbl <- as.table(array(unname(x.tbl),
                              dim       = length(x.tbl),
                              dimnames  = dn))
      names(dimnames(x.tbl)) <- "x"
      nd <- 1L
    }
    else {
      # Already has dims: if first dim has no name, call it "x"
      dn_names <- names(dimnames(x.tbl))
      if (is.null(dn_names) || !nzchar(dn_names[1L])) {
        dn_names <- if (is.null(dn_names)) character(nd) else dn_names
        dn_names[1L] <- "x"
        names(dimnames(x.tbl)) <- dn_names
      }
    }

    if (nd <= 2L) {
      # Use existing .ss.factor summaries for 1D or 2D counts
      stats <- .ss.factor(
        x.tbl,
        by    = NULL,
        brief = TRUE,
        digits_d = digits_d,
        x_name, by_name, x.lbl=NULL, y.lbl = NULL
      )

      ## >>> changed logic here: key off nd, not by_name <<<
      if (nd == 1L) {
        # 1D counts
        title <- stats$title
        freq  <- stats$counts
        test  <- stats$chi
      } else {  # nd == 2L
        # 2D counts (including facet-only case)
        title <- stats$txttl
        freq  <- stats$txfrq
        test  <- stats$txXV
      }
      ## <<< end change <<<

      class(title) <- "out"
      class(freq)  <- "out"
      class(test)  <- "out"

      output <- list(
        out_title  = title,
        out_counts = freq,
        out_chi    = test
      )
      class(output) <- "out_all"
      print(output)
    }
    else {
      # 3+ dimensional count table: just print the multiway table
      cat("\nMulti-way count table:\n\n")
      print(x.tbl)
    }

  } else {
    # --------------------------------------------------------------------
    # NOT counts: display numeric summary table
    # --------------------------------------------------------------------
    has_by <- !is.null(by_name)

    # For 1D/2D numeric tables, preserve old printing behavior
    if (nd <= 2L) {
      if (has_by) {
        # Ensure dimnames have (by_name, x_name)
        dimnames(x.tbl) <- setNames(dimnames(x.tbl), c(by_name, x_name))
      }

      x.t <- x.tbl
      attributes(x.t) <-
        attributes(x.tbl)[c("dim", "dimnames", "names", "row.names", "class")]
      if (!is.null(names(dimnames(x.t)))) names(dimnames(x.t)) <- NULL

      print(x.t)  # a table
    }
    else {
      # 3+ dimensional numeric table: print as-is
      cat("\nMulti-way numeric summary table:\n\n")
      print(x.tbl)
    }
  }

  cat("\n")  # space after all the text output
}