R/zzz.R

In lessR: Less Code with More Comprehensive Results

# debug cat
p <- function(x) {

  xstr <- deparse(substitute(x))
  cat(paste(xstr,":", sep=""), x, "\n")

}

pn <- function(x) {

  xstr <- deparse(substitute(x))
  cat("\n", paste(xstr,":", sep=""), x, "\n")
}


# -------------------------------------------------------------------------

# get maximum number of 0's to right of decimal point for variable x
#   that is less than 1, locate the significant digits
#   called only by .decdig
# Called from: hst.stats.R, zzz.R (internal: .decdig)
.lead0 <- function(x) {
  n.max.z <- 0
  dec.pt <- getOption("OutDec")

  for (i in 1:length(x)) {
    fx <- format(x[i])
    nc <- nchar(fx)
    loc <- regexpr(dec.pt, fx, fixed=TRUE)
    if (loc > -1) {  # there is a decimal point in the ith value
      n.z <- 0
      for (j.value in (loc+1):nc) {  # process one value
        if (substr(fx, j.value, j.value) == "0"  &&  x[i] < 1) {
          n.z <- n.z + 1
        }
        else
          break  # reached a non-0 value
      }
    if (n.z > n.max.z) n.max.z <- n.z
    }
  }
  return(n.max.z)
}


# get decimal digits to display for variable x, then apply
# Called from: pivot.R
.decdig <- function(x, digits_d=NULL) {
  dec.pt <- getOption("OutDec")
  ok <- is.finite(x)  # get rid of missing data
  x.var <- x[ok]  # evaluate digits on x.var w/o NA's
  loc.d <- regexpr(dec.pt, trimws(format(x.var)), fixed=TRUE)

  if (is.null(digits_d)) {
    if (all(loc.d == -1))  # no ., so integer with no decimal digits
       dgs <- 0
    else {
      lead0 <- .lead0(x.var)  # n of 0's to right of . for x < 1
      dgs <- ifelse (lead0>0, lead0+1, 3)  # 0's to right of .
      if (min(loc.d) > 2) dgs <- 3  # multiple digits to left of .
      x <- round(x, dgs)   # rounding removes trailing 0's
    }  # end decimal digits
  }  # end null digits_d

  else {  # digits_d has been set
    dgs <- ifelse (all(loc.d == -1), 0, digits_d)
    x <- round(x, dgs)
  }

  return(x)
}


# maximum number of decimal digits in the values of a variable
# takes much time, quite noticeable for large data sets, so restrict n
# Called from: bx.stats.R, Chart.R, cr.data.frame.R, hst.main.R, Model.R,
#              plt.forecast.R, plt.main.R, plt.txt.R, ss.numeric.R,
#              ttest.R, X.R, XY.R, zzz.R (internal)
.max.dd <- function(x) {

  max.dd <- 0
  n.reps <- min(200, length(x))
  for (i in 1:n.reps) {  # length(x) is number of data values
    if (!is.na(x[i])) {
      xc <- format(x[i])  # as.character(51.45-48.98) does not work
      ipos <- 0  # position of decimal point
      for (i in 1:nchar(xc)) if (substr(xc,i,i)==".") ipos <- i
      n.dec <- ifelse (ipos > 0, nchar(xc)-ipos, 0)  # n chars to right of .
      if (n.dec > max.dd) max.dd <- n.dec
    }
  }

  return(max.dd)
}


# round to specified number of digits, include trailing zeros
# Called from: package-wide (50+ R files; primary numeric-formatter)
.fmt <- function(k, d=getOption("digits_d"), w=0, j="right") {
  format(sprintf("%.*f", d, k), width=w, justify=j, scientific=FALSE)
}


# prettyNum(): display large number with separating commas, rounding to d
# digits: Total number of significant digits, affects rounding for large numbers
# nsmall: From format(), ensures at least this many decimal places in the output
# Called from: plt.forecast.R, plt.txt.R
.fmt_pn <- function(k, d=getOption("digits_d")) {
  prettyNum(k, big.mark=",", nsmall=d, format="f", scientific=FALSE)
}


# format(): display large number with separating commas, rounding to d
# provides consistent formatting for a vector of numbers
# Called from: plt.forecast.R, plt.txt.R, reg.1fitBasic.R
.fmt_cm <- function(k, d=getOption("digits_d")) {
  format(round(k, d+1), big.mark=",", nsmall=d, scientific=FALSE)
}


# truncate 1st character of number, rounding to d
# Called from: plt.bubble.R, zzz.R (internal: .fmt)
.fmt0 <- function(k, d=getOption("digits_d"), w=0) {
  a <- format(sprintf("%.*f", d, k), width=w, justify="right", scientific=FALSE)
  a <- substr(a,2,nchar(a))
  return(a)  # needed to return a without assigning, such as xx = .fmt0(x,3)
}


# right-adjust an integer, padded on the left with spaces according to w`
# Called from: details.R, logit.5Confuse.R, Logit.R, Nest.R, param.VBS.R,
#              prntbl.R, reg.1ancova.R, reg.1anvBasic.R, reg.2Relations.R,
#              reg.Kfold.R, ss.factor.R, ss.numeric.R, xNum.R, XY.R,
#              zzz.R (internal)
.fmti <- function(k, w=0) {
  format(sprintf("%i", k), width=w, justify="right")
}


# right-adjust a real number, padded on the left with spaces according to w`
# Called from: ANOVAz1.R, ANOVAz2.R, bc.main.R, bx.stats.R, corCFA.R,
#              details.R, dpmat.main.R, getColors.R, hst.stats.R,
#              logit.5Confuse.R, Logit.R, Nest.R, param.VBS.R, plt.MD.R,
#              prntbl.R, reg.1ancova.R, reg.1anvBasic.R,
#              reg.1modelBasic.R, reg.2Relations.R, reg.Kfold.R,
#              ss.factor.R, ss.numeric.R, ss.real.R, to.R, tt.2graph.R,
#              XY.R, zzz.R (internal)
.fmtc <- function(k, w=0, j="right") {
  format(sprintf("%s", k), width=w, justify=j)
}



# Called from: corRead.R, corReorder.R, corScree.R, CountAll.R, details.R,
#              logit.3Residual.R, logit.4Pred.R, logit.5Confuse.R,
#              Model.R, plt.txt.R, Read.R, rec.zmain.R, recode.R, see.R,
#              Subset.R, ttp2graph.R, zzz.R (internal)
.dash <- function(ndash, cc, newline=TRUE) {
  if (missing(cc)) cc <- "-"
  for (i in 1:(ndash)) cat(cc)
  if (newline) cat("\n")
}


# Called from: corCFA.R, cr.main.R, hst.stats.R, param.VBS.R, prntbl.R,
#              reg.1ancova.R, reg.1anvBasic.R, reg.1bckBasic.R,
#              reg.1modelBasic.R, reg.2Relations.R, reg.3txtResidual.R,
#              reg.4Pred.R, Regression.R, ss.factor.R, ss.real.R, XY.R,
#              zzz.R (internal: .dash)
.dash2 <- function(ndash, cc="-") {
  tx <- ""
  if (!is.null(cc)) for (i in 1:(ndash)) tx <- paste(tx, cc, sep="")
  return(tx)
}


# abbreviate column labels for cross-tab and related tables
# Called from: bc.main.R, dpmat.main.R, ss.factor.R, ss.real.R
.abbrev <- function(nms, mx.len=8) {

  if (max(nchar(nms)) > mx.len) {
    nms <- gsub("Strongly", "Strng", nms)
    nms <- gsub("Slightly", "Slght", nms)
    nms <- abbreviate(nms, mx.len)
  }

  # value returned is of type character
  return(nms)
}


# is date function
# Called from: plt.lattice.R, plt.main.R, XY.R
.is.date <- function(x) {
# check:  isdate <- class(x) %in% c("Date", "POSIXct", "POSIXlt")

  isdate <- ifelse("Date" %in% class(x), TRUE, FALSE)

  if (!isdate[1])  # an ordered factor has more than 1 class
    isdate <- ifelse(grepl("POSIX",  class(x), fixed=TRUE)[1], TRUE, FALSE)

  return(isdate)
}


# Called from: bc.data.frame.R, corReorder.R, corScree.R, ttest.R, X.R
.plotList <- function(plot.i, plot.title) {
  mxttl <- 0
  for (i in 1:plot.i)
    if (nchar(plot.title[i]) > mxttl) mxttl <- nchar(plot.title[i])
  mxttl <- mxttl + 8
  cat("\n")
  .dash(mxttl, newline=FALSE)
  for (i in 1:plot.i) {
    cat("\n", "Plot ", i,": ", plot.title[i], sep="")
  }
  cat("\n")
  .dash(mxttl, newline=FALSE)
  cat("\n\n")

}

# Called from: ANOVA.R, Regression.R
.plotList2 <- function(plot.i, plot.title) {
  tx <- character(length = 0)

  mxttl <- 0
  for (i in 1:plot.i)
    if (nchar(plot.title[i]) > mxttl) mxttl <- nchar(plot.title[i])
  mxttl <- mxttl + 8

  tx[length(tx)+1] <- .dash2(mxttl)
  for (i in 1:plot.i)
    tx[length(tx)+1] <- paste("Plot ", i,": ", plot.title[i], sep="")
  tx[length(tx)+1] <- .dash2(mxttl)

  return(tx)
}


# Called from: bc.data.frame.R, bc.main.R, Logit.R, pivot.R, plt.bins.R,
#              plt.txt.R, Read.R, Regression.R, XY.R, zzz_plotly.R,
#              zzz.R (internal)
.is.integer <- function(x, tol= .Machine$double.eps^0.5) {

  if (is.numeric(x)) {
    x <- na.omit(x)
    int.flg <- ifelse (abs(x-round(x)) < tol, TRUE, FALSE)  # each i of vector
    result.flg <- ifelse (all(int.flg), TRUE, FALSE)
  }
  else
    result.flg <- FALSE

  return(result.flg)
}


# function to process filter param values, especially categorical
# Called from: STL.R, zzz.R (internal: .apply_filter)
.filter <- function(txt) {

  if (substr(txt, 1, 1) == "\"") {  # parameter value is in quotes
    txt <- sub("include", "%in%", txt, fixed=TRUE)
    if (grepl(" exclude ", txt, fixed=TRUE))
      txt <- paste("!(", txt, ")", sep="")
    txt <- sub("exclude", "%in%", txt, fixed=TRUE)
    txt <- gsub("\"", "", txt, fixed=TRUE)  # remove the quotes
  }  # end expression in quotes

  return(txt)
}


# df.or.global() -------------------------------------------------------
# Determines whether a named variable should be read from the global
#   environment (data=NULL) or from a data frame
#
# Parameters
#   var.name  character  deparsed variable name (from deparse(substitute()))
#   df.name   character  deparsed data-frame name ("NULL" when data=NULL)
#   role      character  label for messages, e.g. "x", "by", "facet", "size"
#   fun.name  character  calling function name for the example in messages
#
# Returns
#   TRUE  if the variable should be read from the global environment
#   FALSE if it should be read from the data frame
#
# Side-effects
#   stop()    if variable is missing from wherever it should be
#   message() if variable looks like it was meant to be global but data=NULL
#             was not set (transition warning for users of old behaviour)

# Called from: Chart.R, Correlation.R, label.R, STL.R, SummaryStats.R,
#              ttest.R, values.R, X.R, XY.R,
#              zzz.R (internal: .resolve_named_var)
df.or.global <- function(var.name, df.name, role="x", fun.name="X") {

  # var.name is "NULL" when the argument was not supplied (deparse returns "NULL")
  # or genuinely NULL; nothing to resolve in either case
  if (is.null(var.name) || identical(var.name, "NULL"))
    return(invisible(df.name == "NULL"))

  in.global <- df.name == "NULL"

  if (!in.global && !is.null(var.name)) {

    var.in.global.env <- exists(var.name, envir=.GlobalEnv)
    df.exists         <- exists(df.name,  envir=.GlobalEnv)

    # Case 1: data frame doesn't exist but variable does — targeted stop
    if (var.in.global.env && !df.exists)
      stop(call.=FALSE, "\n------\n",
           "Variable '", var.name, "' (", role, ") exists in the global ",
           "environment\n",
           "  but no data frame '", df.name, "' was found.\n\n",
           "To use a global variable, add  data=NULL  to your call:\n",
           "  ", fun.name, "(", var.name, ", data=NULL)\n\n")

    # Case 2: both exist but variable is not in the data frame — soft warning
    if (var.in.global.env && df.exists &&
        !(var.name %in% names(get(df.name, envir=.GlobalEnv))))
      message("\n>>> Variable '", var.name, "' (", role, ") not found in ",
              "data frame '", df.name, "' but exists in the global ",
              "environment.\n",
              "    To use a global variable, add  data=NULL  to your call.\n",
              "    Example:  ", fun.name, "(", var.name, ", data=NULL)")
  }

  # Case 3: data=NULL but variable absent from global env — stop
  if (in.global && !is.null(var.name) &&
      !exists(var.name, envir=.GlobalEnv))
    stop(call.=FALSE, "\n------\n",
         "Variable '", var.name, "' not found.\n\n",
         "It is not in the global environment and no data frame was ",
         "specified.\n\n",
         "  To read a variable from a data frame, omit  data=NULL.\n",
         "  To use a global variable, ensure it is defined first.\n")

  invisible(in.global)
}


# ----- resolve a named variable to a vector -----------------------------
# Body of the get.col() closures used in X()'s and XY()'s facet-resolution
# blocks. Routes through df.or.global() for friendly error reporting and
# validates via .xcheck() before extracting from data; falls back to the
# caller's environment when data was NULL.
# Called from: X.R, XY.R (each as the body of a local get.col() closure)
.resolve_named_var <- function(nm, df.name, data, caller.env,
                               role = "x", fun.name = "X") {
  in.global <- df.or.global(nm, df.name,
                            role = role, fun.name = fun.name)
  if (!in.global) {
    .xcheck(nm, df.name, names(data))
    data[[nm]]
  } else {
    get(nm, envir = caller.env)
  }
}


# ----- apply the user-supplied `filter` expression to a data frame -------
# Body of the filter-subset block shared by Chart(), X(), and XY().
# The caller MUST do `deparse(substitute(filter))` and `parent.frame()`
# itself (NSE has to run in the caller's frame) and pass the results in.
# Called from: Chart.R, X.R, XY.R (shared filter-subset block)
.apply_filter <- function(data, filter_txt, caller_env,
                          x.in.global, quiet) {
  if (x.in.global) {
    cat("\n"); stop(call. = FALSE, "\n------\n",
      "Parameter  filter  not applicable if no data frame\n\n")
  }
  txt <- .filter(filter_txt)

  # label each row TRUE/FALSE: numeric → row indices; expression → predicate
  intYN <- try(eval(parse(text = txt), envir = caller_env), silent = TRUE)
  if (is.numeric(intYN)) {
    r <- rep(FALSE, nrow(data))
    r[intYN] <- TRUE
  } else {
    r <- eval(str2expression(txt), envir = data, enclos = caller_env)
    r <- r & !is.na(r)              # missing → FALSE
  }

  nr.before <- nrow(data)
  if (any(r))
    data <- data[r, , drop = FALSE]
  if (!quiet) {
    cat("\nfilter: ", txt, "\n-----\n")
    cat("Rows of data before filtering: ", nr.before, "\n")
    cat("Rows of data after filtering:  ", nrow(data), "\n\n")
  }
  data
}


# ----- aggregation function from stat name -------------------------------
# Build the per-group aggregator used across Chart()'s faceted dot path
# and the .hier/.radar/.build_plotly_tbl helpers. The caller's stat is
# already validated by match.arg() in Chart()/X()/XY() upstream, so no
# defensive branch for unknown names.
# Called from: Chart.R, zzz_plotly.R (.hier_color_resolve,
#              .hier_aggregate, .radar_aggregate, .build_plotly_tbl)
.stat_fun <- function(stat) {
  switch(tolower(stat %||% "sum"),
    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)
  )
}


# display label for a stat= value, the companion of .stat_fun()
# Called from: agg.R (.agg), Chart.R (multi-column y aggregation)
.stat_lbl <- function(stat) {
  switch(tolower(stat),
    sum       = "Sum",
    mean      = "Mean",
    sd        = "Standard Deviation",
    deviation = "Mean Deviation",
    min       = "Minimum",
    median    = "Median",
    max       = "Maximum")
}


# get list of data frames in global environment
# include both R data frames and tidyverse tibbles
# Called from: ANOVA.R, Chart.R, CountAll.R, details.R, Logit.R, Model.R,
#              Regression.R, rename.R, rescale.R, SummaryStats.R,
#              train_test.R, ttest.R, Write.R, X.R, XY.R,
#              zzz.R (internal: .nodf)
.getdfs <- function() {

  inGlb <- ls(name=.GlobalEnv)
  if (length(inGlb) > 0) {
    dfs <- character(length=0)
    k <- 0
    for (i in 1:length(inGlb)) {
      if (any(class(get(inGlb[i])) == "data.frame")) {
        k <- k + 1
        dfs[k] <- inGlb[i]
      }
    }
  }
  else
    dfs <- NULL

  return(dfs)
}


# Called from: ANOVA.R, Chart.R, Regression.R, rescale.R, SummaryStats.R,
#              ttest.R, X.R, XY.R
.nodf <- function(dname) {

  # see if df exists (d default), if x from data, not in style Env
  if (!exists(dname, where=.GlobalEnv)) {  # search Global and inside
    dfs <- .getdfs()  # list of data frames in style env
    txtA <- ifelse (dname == "d", ", the default data table name, ", " ")

    if ("D" %in% dfs)
      txtM <- paste("Because you have a data table called D,\n",
        " perhaps you meant to call it d, if so, just re-read \n",
        " into d instead of D")
    else
      txtM <- paste(
        "If a data table is not named the default d, then to\n",
        "  analyze the variables in that data table, in the function call\n",
        "  for the analysis specify the actual data table name with\n",
        "  the data option\n",
        "For the data table called ", dfs[1], "\n",
        "  add the following to your function call:  , data=", dfs[1], "\n\n",
        "Or, just re-read the data into the d data table\n\n", sep="")

    if (length(dfs) == 0) {
      cat("\n"); stop(call.=FALSE, "\n------\n",
        "An analysis is of data values for one or more variables found\n",
        "  in a rectangular data table, with the data values for a \n",
        "  variable located in a column.\n\n",
        "You have not yet read data into a data table for analysis,\n",
        "  so the data table called ", dname, txtA, "is\n",
        "  not available for analysis.\n\n",
        "Read the data into an R data table with the Read function, usually\n",
        "  reading the data into an R data table called d.\n\n",
        "To read a data file on your computer system into the d data\n",
        "  table, in which you browse your file folders to locate the\n",
        "  desired date file, enter:\n",
        "     d <- Read(\"\")\n\n",
        "To specify a data table from your computer or the web, enter:\n",
        "     d <- Read(\"path name\") \n",
        "  or \n",
        "     d <- Read(\"web address\") \n",
        "In the web address include the http:// at the beginning\n",
        "  and also include the quotes around the web address.\n\n")
    }

    else if (length(dfs) == 1) {
      nm <- parse(text=paste("names(", dfs[1],")"))
      nm <- eval(nm)
      for (i in 1:length(nm)) nm[i] <- paste(nm[i], " ")
      cat("\n"); stop(call.=FALSE, "\n------\n",
        "Data table ", dname, txtA, "does not exist\n\n",
        "You have read data into one data table, ", dfs[1], ", but that\n",
        "  is not the data table ", dname, " that was to be analyzed\n\n",
        "Following are the names of the variables that are available\n",
        "  for analysis in the ", dfs[1], " data table\n\n",
        "  ", nm, "\n\n",
        txtM, "\n\n")
    }

    else if (length(dfs) > 1) {
      dts <- ""
      for (i in 1:length(dfs)) dts <- paste(dts, dfs[i])
      if (dname == "d") {
        cat("\n"); stop(call.=FALSE, "\n------\n",
          "Data table ", dname, txtA, "does not exist\n\n",
          "Data tables you read and/or created: ", dts, "\n\n",
          "Perhaps you have a data table that contains the variables\n",
          "  of interest to be analyzed, but it is not named ", dname, "\n",
          "Can specify the actual name with the data option\n",
          "For example, for a data table named ", dfs[1], "\n",
          "  add the following to your function call:  , data=", dfs[1], "\n\n",
          "Or, just re-read the data into the d data table\n\n")
        }
      else {
        cat("\n"); stop(call.=FALSE, "\n------\n",
          "Data table ", dname, txtA, "does not exist\n\n",
          "Perhaps you have a data table that contains the variables\n",
          "  of interest to be analyzed, but it is not named ", dname, "\n\n",
          "Data tables you have already read and/or created: ", dts, "\n\n",
          "Use an available data table, or read data into a new table\n\n")
      }
    }
  }
}


# Updated .in.global() -- now a pure expression validator only.
# Detection of whether a variable lives in global vs. a data frame has been
# removed: that is now determined solely by whether the caller set data=NULL
# (x.in.global <- df.name == "NULL").  The only job here is to stop early if
# the user passes an expression (e.g. rnorm(50), data[,1], df$x) where a
# plain variable name is required.
# Called from: Chart.R, SummaryStats.R, ttest.R, X.R, XY.R,
#              zzz.R (internal)
.in.global <- function(var.name, quiet) {
  if ((grepl("(", var.name, fixed=TRUE) ||
       grepl("[", var.name, fixed=TRUE) ||
       grepl("$", var.name, fixed=TRUE))
      && substr(var.name, 1, 1) != "c") {
    txtA <- paste("A referenced variable in a lessR function can only be\n",
                  "a variable name.\n\n", sep="")
    txtB <- "For example, this does not work:\n  > Histogram(rnorm(50))\n\n"
    txtC <- "Instead do this:\n  > Y <- rnorm(50)\n  > Histogram(Y)"
    cat("\n"); stop(call.=FALSE, "\n------\n", txtA, txtB, txtC, "\n")
  }
  invisible(NULL)  # no return value needed; callers no longer use it
}


# .xcheck() -- check that each variable name in var.name exists in the data
# frame dname whose column names are nms.  Unchanged logic; fixed:
#   - seq_along() replaces 1:length()
#   - scalar if/else replaces ifelse()
# Called from: Chart.R, Correlation.R, recode.R, Regression.R, rescale.R,
#              SummaryStats.R, ttest.R, values.R, X.R, XY.R,
#              zzz.R (internal: .resolve_named_var)
.quoted_varname <- function(x_name, arg_name) {
  if (startsWith(x_name, '"')) {
    nm <- gsub('"', '', x_name)
    stop(call. = FALSE, "\n------\n",
      "Variable name must not be in quotes.\n",
      "  Instead of  ", arg_name, "=\"", nm,
      "\"  write  ", arg_name, "=", nm, "\n\n")
  }
}


.xcheck <- function(var.name, dname, nms) {
  expr   <- parse(text=var.name)
  var.nm <- all.vars(expr)
  for (i in seq_along(var.nm)) {
    if (grepl("(", var.nm[i], fixed=TRUE) || grepl("[", var.nm[i], fixed=TRUE)) {
      txtA <- paste("A referenced variable in a lessR function can only be\n",
                    "a variable name\n\n", sep="")
      txtB <- paste("e.g., for the Histogram function, this does not work:\n",
                    "  > Histogram(rnorm(50))\n\n", sep="")
      txtC <- "Instead do this:\n  > Y <- rnorm(50)\n  > Histogram(Y)"
      cat("\n"); stop(call.=FALSE, "\n", "------\n", txtA, txtB, txtC, "\n\n")
    }
    ind <- which(nms == var.nm[i])
    if (length(ind) == 0) {
      dfs  <- .getdfs()
      txt1 <- ", the default name \n\n"
      txt2 <- "Either make sure to use the correct variable name, or\n"
      txt3 <- "specify the data table that contains the variable with: data=\n"
      txt  <- if (dname == "d") paste(txt1, txt2, txt3, sep="") else "\n"
      nm   <- paste(nms, " ")
      if (dname == "d")
        txtDef <- ", which is the default data table name\n"
      else
        txtDef <- ""
      if (length(dfs) == 1) {
        cat("\n"); stop(call.=FALSE, "\n------\n",
          "You are attempting to analyze the variable ", var.nm[i], " in the\n",
          "  data table called ", dname, txtDef, "\n",
          "Unfortunately, variable ", var.nm[i], " does not exist in ", dname,
          "\n\n",
          "The following variables are currently in the ", dname,
          " data table,\n",
          "  available for analysis:\n\n", "  ", nm, "\n\n")
      }
      else if (length(dfs) > 1) {
        nm2 <- eval(parse(text=paste("names(", dfs[1], ")")))
        nm2 <- paste(nm2, " ")
        cat("\n"); stop(call.=FALSE, "\n------\n",
          "You are attempting to analyze the variable ", var.nm[i], " in the\n",
          "  data table called ", dname, txtDef, "\n",
          "Unfortunately, variable ", var.nm[i], " does not exist in ",
          dname, "\n\n",
          "The following variables are currently in the ", dname,
          " data table,\n",
          "  available for analysis:\n\n",
          "  ", nm, "\n\n",
          "You do have another data table, but it is named ", dfs[1], "\n",
          "The following variables are currently in the ", dfs[1],
          " data table,\n",
          "  available for analysis:\n\n",
          "  ", nm2, "\n\n",
          "If a data table is not named the default d, then to\n",
          "  analyze the variables in that data table, in the function call\n",
          "  for the analysis specify the actual data table name with\n",
          "  the data option\n",
          "For the data table called ", dfs[1], "\n",
          "  add the following to your function call:  , data=", dfs[1],
          "\n\n", sep="")
      }
    }
  }
}



# see if cor matrix exists as stand-alone or embedded in list structure
# Called from: corEFA.R, corProp.R, corReflect.R, corReorder.R, corScree.R
.cor.exists <- function(cor.nm) {

  if (!grepl("$R", cor.nm, fixed=TRUE))  # no $R in name
    is.there <- cor.nm %in% ls(name=.GlobalEnv)

  else {
    nm <- sub("$R", "", cor.nm, fixed=TRUE)  # remove $R from name
    if (!(nm %in% ls(name=.GlobalEnv)))  # root list exists?
      is.there <- FALSE
    else
      is.there  <- exists("R", where=eval(parse(text=nm)))  #  R inside?
  }
  if (!is.there) {
    cat("\n"); stop(call.=FALSE, "\n","------\n",
      "No correlation matrix entered.\n\n",
      "No object called ", cor.nm, " exists.\n\n",
      "Either enter the correct name, or calculate with: Correlation()\n",
      "Or read the correlation matrix with: corRead()\n\n", sep="")
  }

}




# Called from: ANOVA.R, reg.1bckBasic.R
.varlist <- function(n.pred, ind, var.name, pred.lbl, n.obs, n.keep,
                      lvls=NULL) {
  tx <- character(length = 0)

  if (ind == 1)
    txt <- "Response Variable: "
  else {
    if (n.pred > 1)
      txt <- paste(pred.lbl, " Variable ", toString(ind-1), ": ", sep="")
    else
      txt <- paste(pred.lbl, " Variable: ", sep="")
  }
  if (pred.lbl == "Factor"  &&  ind > 1) tx[length(tx)+1] <- ""
  tx[length(tx)+1] <- paste(txt, var.name, sep="")

  dname <- getOption("dname")

  if (dname %in% ls(name=.GlobalEnv))
    l <- attr(get(dname, pos=.GlobalEnv), which="variable.labels")
  else
    l <- NULL
  if (dname %in% ls(name=.GlobalEnv))
    myunits <- attr(get(dname, pos=.GlobalEnv), which="variable.units")
  else
    myunits <- NULL

  if (!is.null(l)) {
    lbl <- l[which(names(l) == var.name)]
    unt <- myunits[which(names(myunits) == var.name)]
    if (!is.null(unt)) if (nzchar(unt))  if(!is.na(unt))
      lbl <- paste(lbl, " (", unt, ")", sep="")
    if (!is.null(lbl))
      tx[length(tx)] <- paste(tx[length(tx)], ", ", as.character(lbl), sep="")
  }

  if (!is.null(lvls)) {
    tx2 <- "  Levels:"
    for (i in 1:length(lvls)) tx2 <- paste(tx2, lvls[i])
    tx[length(tx)+1] <- tx2
  }

  if (ind == n.pred+1) {
    tx[length(tx)+1] <- ""
    tx[length(tx)+1] <- paste("Number of cases (rows) of data: ", n.obs)
    tx[length(tx)+1] <- paste("Number of cases retained for analysis: ", n.keep)
  }

  return(tx)
}


# Called from: bx.stats.R, ss.factor.R, ss.numeric.R, X.R
.title2 <- function(x.name, y.name, x.lbl, y.lbl, isnullby, new.ln=FALSE) {
  txt1 <- x.name
  if (!is.null(x.lbl)) txt1 <- paste(txt1, ": ", x.lbl, sep="")

  if (isnullby) {
    txt1 <- if ("shiny" %in% .packages()) "Summary Stats" else x.name
    txt1 <- paste("---", txt1, "---")
    if (new.ln) txt1 <- paste(txt1, "\n", sep="")
  }
  else {
    txt2 <- y.name
    if (!is.null(y.lbl)) txt2 <- paste(txt2, ": ", y.lbl, sep="")
  }

  tx <- character(length=0)
  tx[length(tx)+1] <- txt1
  if (!isnullby) {
    tx[length(tx)+1] <- "\n  - by levels of - \n"
    tx[length(tx)] <- paste(tx[length(tx)], txt2, sep="")  # no leading blank
  }
  return(tx)
}


# get variable labels if they exist
# Called from: bar.lattice.R, bc.main.R, Chart.R, corCFA.R, cr.main.R,
#              dn.main.R, dpmat.main.R, hst.main.R, label.R, Model.R,
#              plt.lattice.R, plt.main.R, plt.txt.R, ss.data.frame.R,
#              ss.numeric.R, SummaryStats.R, tt.1group.R, tt.2group.R, X.R
.getlabels <- function(xlab=NULL, ylab=NULL, main=NULL, sub=NULL,
                       y.nm=FALSE, by.nm=FALSE, facet1.nm=FALSE,
                       lab_x_size=NULL, lab_y_size=NULL, labels=l,
                       graph.win=TRUE, flip=FALSE, ...) {

  if (graph.win) {
    fig.width <-  par("fin")[1]
    fig.ht <-  par("fin")[2]
    marg.x <- par("mai")[2] + par("mai")[4]
    axis_x <- fig.width - marg.x
    marg.y <- par("mai")[1] + par("mai")[3]
    axis_y <- fig.ht - marg.y
    cut.x <- 0.94 * axis_x
    cut.y <- 1.21 * axis_y  # multiplier empirically derived
  }
  else {  # do not open a graphics window if no plot
    cut.x <- 3.75
    cut.y <- 3.75
  }


  # strwidth function not working in regular R, lab_size has no affect
  regR <- FALSE
  in.RStudio <- ifelse (options("device") != "RStudioGD", FALSE, TRUE)
  in.knitr <- ifelse (is.null(options()$knitr.in.progress), FALSE, TRUE)
  if (!in.RStudio && !in.knitr) regR <- TRUE

  x.name <- getOption("xname")
  if (y.nm)
    y.name <- getOption("yname")  # y.name is specified
  else if (!by.nm && !facet1.nm)
    y.name <- getOption("yname")  # y.name by default
  else if (by.nm && !facet1.nm)
    y.name <- getOption("byname")
  else if (!by.nm && facet1.nm)
    y.name <- getOption("facet1name")

  x.lbl <- NULL
  y.lbl <- NULL

  # let deprecated mylabels work as default
  dfs <- .getdfs()
  mylabels.ok <- FALSE
  if (!is.null(dfs)) {
    if ("mylabels" %in% dfs  &&  !("l" %in% dfs)) {
      l <- mylabels
      l.name <- "mylabels"
      mylabels.ok <- TRUE
    }
  }
  if (!mylabels.ok)
    l.name <- deparse(substitute(labels))

  # l has row names, with 1st var as "label" and, if present, 2nd as "unit"
  if (l.name %in% ls(name=.GlobalEnv)) {
    l <- get(l.name, pos=.GlobalEnv)

    i.row <- which(row.names(l) == x.name)
    if (length(i.row) > 0) if (is.numeric(i.row))
      if (!is.na(l[i.row,1])) x.lbl <- l[i.row,1]

    i.row <- which(row.names(l) == y.name)
    if (length(i.row) > 0) if (is.numeric(i.row))
      if (!is.na(l[i.row,1])) y.lbl <- l[i.row,1]
  }

  else {  # labels embedded in data
    dname <- getOption("dname")  # not set for dependent option on tt
    if (!is.null(dname)) {
      if (dname %in% ls(name=.GlobalEnv)) {
        l <- attr(get(dname, pos=.GlobalEnv), which="variable.labels")
#       myunits <- attr(get(dname, pos=.GlobalEnv), which="variable.units")
      }
      else
        l <- NULL
    }
    else
      l <- NULL

    if (!is.null(l)) {
      x.lbl <- l[which(names(l) == x.name)]
      if (length(x.lbl) == 0) x.lbl <- NULL
      y.lbl <- l[which(names(l) == y.name)]
      if (length(y.lbl) == 0) y.lbl <- NULL
    }
  }  # end labels embedded in data

  # ------------------------
  # get x.lab
  st.nya <- ifelse (getOption("sub_theme") == "wsj", TRUE, FALSE)
  if (is.null(x.lbl) && is.null(xlab)) {
    x.lab <- x.name
  }
  else {
    if (!is.null(xlab))
      x.lab <- xlab  # xlab specified
    else if (!is.null(x.lbl))
      x.lab <- x.lbl
  }
  if (is.null(xlab)) if (st.nya) x.lab <- ""

  # get y.lab
  if (is.null(y.lbl) && is.null(ylab)) {
      y.lab <- y.name
  }
  else {
    if (!is.null(ylab))
      y.lab <- ylab  # ylab specified
    else if (!is.null(y.lbl))
      y.lab <- y.lbl
  }
  if (is.null(ylab)) if (st.nya) y.lab <- ""

  if (flip) {  # horiz=TRUE: swap display labels but NOT x.name
    temp <- ylab;  ylab <- xlab;  xlab <- temp
    temp <- y.lab;  y.lab <- x.lab;  x.lab <- temp
    temp <- y.lbl;  y.lbl <- x.lbl;  x.lbl <- temp
    temp <- lab_y_size;  lab_y_size <- lab_x_size;  lab_x_size <- temp
    # Intentionally one-sided: y.name takes old x.name so the by-axis
    # label shows the variable name in horiz orientation.  x.name is
    # NOT swapped because it is returned as gl$xn and used by callers
    # for data lookup (e.g. df[[x.name]]).  Swapping it to byname
    # (which may be NULL) would cause downstream crashes.
    y.name <- x.name
  }

  # ------------------------
  # x-axis and legend labels

  if ((!is.null(x.lbl) || !is.null(xlab)) && !st.nya) {
    # power.ttest: len > 1;  # add var name to label?
    if (length(x.lab) == 1  &&  !is.null(lab_x_size)  &&  graph.win) {
      var.nm <- ifelse (is.null(x.lbl) && !is.null(x.name), FALSE, TRUE)
      if (!is.null(xlab)) var.nm <- FALSE  # xlab is the complete label
      al <- .adjlbl(x.lab, lab_x_size, cut=cut.x, x.name, var.nm, units="inches")
      x.lab <- al$lab
    }
  }  # end get x.lab

  # ------------------------
  # y-axis and legend labels

    if (!is.null(y.lab)  &&  !st.nya) { # power.ttest: len > 1
    if (length(y.lab) == 1  &&  !is.null(lab_y_size)  &&  graph.win) {
      var.nm <- ifelse (is.null(y.lbl) && !is.null(y.name), FALSE, TRUE)
      if (!is.null(ylab)) var.nm <- FALSE  # ylab is the complete label
      al <- .adjlbl(y.lab, lab_y_size, cut=cut.y, y.name, var.nm, units="inches")
      y.lab <- al$lab
    }
  }  # end process y-axis label


  if (!missing(main)) {
    if (!is.null(main))
      main.lab <- main
    else
      main.lab <- NULL
  }
  else
    main.lab <- NULL

  if (!missing(sub)) {
    sub.lab <- ifelse (!is.null(sub), sub, NULL)
  }
  else
    sub.lab <- NULL

  return(list(xn=x.name, xl=x.lbl, xb=x.lab, yn=y.name, yl=y.lbl, yb=y.lab,
     mb=main.lab, sb=sub.lab, lab_x_size=lab_x_size, lab_y_size=lab_y_size))
}  # end .getlabels




# get the lines of the axis label, prefix with variable name
# Called from: zzz.R (internal: .getlabels)
.adjlbl <-
function(lab, labcex, cut, nm, var.nm, units) {

  # add variable name to label
  if (grepl("Count", lab, fixed=TRUE)) var.nm <- FALSE
  if (grepl("Proportion", lab, fixed=TRUE)) var.nm <- FALSE
  if (grepl("Alternative", lab, fixed=TRUE)) var.nm <- FALSE
  if (var.nm) {
    lab <- paste(nm, ": ", lab, sep="")
  }
  strw <- strwidth(lab, units=units, cex=labcex)
  n.lab_ln <- (strw %/% cut) + 1
  if (n.lab_ln < 1) {
    cat("\n"); stop(call.=FALSE, "\n","------\n",
      "No room for axis labels, increase the size of the plot window.\n\n")
  }

  if (strw > cut) {
    line <- character(length=n.lab_ln)
    s <- unlist(strsplit(lab, " "))
    il <- 1
    for (iw in 1:(length(s))) {
      if (strwidth(line[il], units=units, cex=labcex) > cut)
        il <- il + 1
      line[il] <- paste(line[il], s[iw])
    }
    # trim a possible trailing blank line
    if (line[n.lab_ln] == "") line <- line[1:(n.lab_ln-1)]

    if (length(line) == 1) {
      lab <- line
    }
    else if (length(line) == 2) {  # break label down the middle
      brk <- nchar(lab) %/% 2
      while (substr(lab,brk,brk) != " ") brk <- brk-1  # break at word boundary
      line1 <- substr(lab, 1, brk)
      line2 <- substr(lab, brk+1, nchar(lab))
      lab <- paste(line1, "\n",  line2)
    }
    else if (length(line) > 2) {  # use re-constructed lines
      lab <- ""
      for (i in 1:length(line)) {
        lab <- paste(lab, line[i])
        if (i < length(line)) lab <- paste(lab, "\n", sep="")
      }
    }
  }

  return(list(lab=lab))
}


# axis labels
# Called from: ANOVAz1.R, dn.main.R, dpmat.main.R, hst.main.R,
#              logit.4Pred.R, plt.main.R, reg.3resfitResidual.R,
#              reg.5ancova.R, reg.5Plot.R, ttp2graph.R
.axlabs <- function(x.lab, y.lab, main.lab, sub.lab,
                    x.val=NULL, xy_ticks=TRUE, offset=0.5,
                    lab_x_size=NULL, lab_y_size=NULL, main_size=NULL,
                    n.lab_x.ln=1, n.lab_y.ln=1, xlab_adj=0, ylab_adj=0,
                    ...) {
#   max.lbl <- max(nchar(axTicks(2)))

  lab_x_color <- ifelse(is.null(getOption("lab_x_color")),
    getOption("lab_color"), getOption("lab_x_color"))
  lab_y_color <- ifelse(is.null(getOption("lab_y_color")),
    getOption("lab_color"), getOption("lab_y_color"))

  if (is.null(lab_x_size)) {  # temp until all .axes calls provide lab_x_size
    lab_x_size <- ifelse(is.null(getOption("lab_x_size")),
      getOption("lab_size"), getOption("lab_x_size"))
  }
  if (is.null(lab_y_size)) {
    lab_y_size <- ifelse(is.null(getOption("lab_y_size")),
      getOption("lab_size"), getOption("lab_y_size"))
  }

  adj <- .RSadj(lab_size=lab_x_size); lab_x_size <- adj$lab_size
  adj <- .RSadj(lab_size=lab_y_size); lab_y_size <- adj$lab_size
  lblx.lns <- par("mar")[1] - 1.15

  lbly.lns <- par("mar")[2] - 1.2 - 0.4*(n.lab_y.ln - 1)

  regR <- FALSE  # regular R by itself adjustment
  in.RStudio <- ifelse (identical(getOption("device"),"RStudioGD"), TRUE, FALSE)
  in.knitr <- ifelse (!is.null(options()$knitr.in.progress), TRUE, FALSE)
  if (!in.RStudio && !in.knitr) regR <- TRUE
  if (regR) ylab_adj <- ylab_adj + .2 

  title(xlab=x.lab, line=lblx.lns-xlab_adj,
        col.lab=lab_x_color, cex.lab=lab_x_size)
  if (!is.null(sub.lab))
    title(sub=sub.lab, line=lblx.lns+1-xlab_adj, cex.sub=0.75,
          col.lab=lab_x_color, ...)
  title(ylab=y.lab, line=lbly.lns,
        col.lab=lab_y_color, cex.lab=lab_y_size)
  if (!is.null(main.lab)) {
    mc <- if (!is.null(main_size)) main_size
          else getOption("main_size", 1.1)
    title(main=main.lab, cex.main=mc,
          col.main=getOption("main_color"), ...)
  }
}


# get number of lines in value labels
# Called from: bc.main.R, plt.main.R
.get.val.ln <- function (val.lab, var.name) {

  ln.val <- integer(length=length(val.lab))

  for (i in seq_along(val.lab)) {
    if (!is.na(val.lab[i])) {
      val.lab[i] <- gsub(" ", "\n", val.lab[i])  # space to new line
      val.lab[i] <- gsub("~", " ", val.lab[i])  # ~ to space
      ln.br <- 0
      for (j in 1:nchar(val.lab[i]))
        if (substr(val.lab[i], j, j)=="\n") ln.br <- ln.br + 1
      ln.val[i] <- ln.br + 1
    }
    else
      val.lab[i] <- "<NA>"  # when y is given and a value of x is missing
  }
  mx.val.ln <- max(ln.val)  # largest number of value label lines

  if (is.infinite(mx.val.ln)) {
    cat("\n"); stop(call.=FALSE, "\n","------\n",
      "No value labels, ", var.name, " not properly specified\n\n")
  }

  return(list(val.lab=val.lab, mx.val.ln=mx.val.ln))
}


# Called from: bc.main.R, dn.main.R, dpmat.main.R, hst.main.R,
#              logit.4Pred.R, plt.contour.R, plt.main.R, tt.1graph.R,
#              tt.2graph.R, zzz.R (internal)
.axes_dim <- function() {

  axis_x_color <- ifelse(is.null(getOption("axis_x_color")),
    getOption("axis_color"), getOption("axis_x_color"))
  axis_y_color <- ifelse(is.null(getOption("axis_y_color")),
    getOption("axis_color"), getOption("axis_y_color"))

  axis_x_lwd <- ifelse(is.null(getOption("axis_x_lwd")),
    getOption("axis_lwd"), getOption("axis_x_lwd"))
  axis_y_lwd <- ifelse(is.null(getOption("axis_y_lwd")),
    getOption("axis_lwd"), getOption("axis_y_lwd"))

  axis_x_lty <- ifelse(is.null(getOption("axis_x_lty")),
    getOption("axis_lty"), getOption("axis_x_lty"))
  axis_y_lty <- ifelse(is.null(getOption("axis_y_lty")),
    getOption("axis_lty"), getOption("axis_y_lty"))

  axis_x_size <- ifelse(is.null(getOption("axis_x_size")),
    getOption("axis_size"), getOption("axis_x_size"))
  adj <- .RSadj(axis_size=axis_x_size); axis_x_size <- adj$axis_size
  axis_y_size <- ifelse(is.null(getOption("axis_y_size")),
    getOption("axis_size"), getOption("axis_y_size"))
  adj <- .RSadj(axis_size=axis_y_size); axis_y_size <- adj$axis_size

  axis_x_text_color <- ifelse(is.null(getOption("axis_x_text_color")),
    getOption("axis_text_color"), getOption("axis_x_text_color"))
  axis_y_text_color <- ifelse(is.null(getOption("axis_y_text_color")),
    getOption("axis_text_color"), getOption("axis_y_text_color"))

  return(list(axis_x_color=axis_x_color, axis_y_color=axis_y_color,
              axis_x_lwd=axis_x_lwd, axis_y_lwd=axis_y_lwd,
              axis_x_lty=axis_x_lty, axis_y_lty=axis_y_lty,
              axis_x_size=axis_x_size, axis_y_size=axis_y_size,
              axis_x_text_color=axis_x_text_color,
              axis_y_text_color=axis_y_text_color))
}




# format axis labels, such as using "K" notation
# Called from: bar.lattice.R, bc.main.R, dn.main.R, hst.main.R,
#              plt.contour.R, plt.lattice.R, zzz.R (internal: .axes)
.axis.format <- function(axT, axis_fmt, axis_x_pre, axis_y_pre) {
  lbls <- na.omit(axT)  # Remove NA values

  if ("K" %in% axis_fmt) { # if values >= 1 billion, use scientific notation
    if (any(abs(axT) >= 1e9))
      lbls <- trimws(format(lbls, scientific = TRUE))
    else { # Safe "multiple of 100" check without %% (tolerance-based)
      is_mult_100 <- all(abs(axT / 100 - round(axT / 100)) < 1e-10)
      if (is_mult_100 && all(abs(axT)[abs(axT) > 0] > 1000))
        lbls <- trimws(paste0(lbls / 1000, "K"))
      else
        if (any(axT > 9999))  # do not want , if numbers < 10000, e.g. years
          lbls <- trimws(format(lbls, nsmall = 0, big.mark = ",",
                         decimal.mark = "."))
    }
  }

  if ("," %in% axis_fmt)
    lbls <- trimws(format(lbls, nsmall=0, big.mark=",", decimal.mark="."))

  if ("." %in% axis_fmt)
    lbls <- trimws(format(lbls, nsmall=0, big.mark=".", decimal.mark=","))

  if (axis_y_pre == "no") {
    if (nzchar(axis_x_pre)) 
      lbls=paste(axis_x_pre, lbls, sep="")
  }

  if (axis_x_pre == "no") {
    if (nzchar(axis_y_pre)) 
      lbls=paste(axis_y_pre, lbls, sep="")
  }

  return(lbls)
}


# Called from: ANOVA.R, Nest.R, Regression.R
.getdigits <- function(x, min_digits) {
  digits_d <- .max.dd(x) + 1
  if (digits_d < min_digits) digits_d <- min_digits
  return(digits_d)
}


# get axis() and text()
# Called from: ANOVAz1.R, bc.main.R, dn.main.R, dpmat.main.R, hst.main.R,
#              logit.4Pred.R, plt.main.R, reg.3resfitResidual.R,
#              reg.5ancova.R, reg.5Plot.R, tt.1graph.R, tt.2graph.R,
#              ttp2graph.R
.axes <- function(x.lvl, y.lvl, axT1, axT2,
         rotate_x=0, rotate_y=0, offset=0.5, 
         axis_fmt="K", axis_x_pre="", axis_y_pre="",
         y.only=FALSE, ...) {

  fnt <- ifelse (getOption("sub_theme") == "wsj", 2, 1) # bold
  usr <- par("usr")
  ax <- .axes_dim()  # get axis values parameters: color, lwd, lty, cex

  # x-axis
  # ------

  # numeric, uses axT1, axLn is the labels
  if (is.null(x.lvl)  &&  !is.null(axT1)) {
    if (!y.only) {  # do x axis in calling routine for time series
      axT1 <- axT1[which(axT1 >= usr[1]  &  axT1 <= usr[2])]
      axL1 <- .axis.format(axT1, axis_fmt, axis_x_pre, axis_y_pre="no")
      if (rotate_x==0) {  # mgp[2] for tic marks and value label separation
        axis(1, at=axT1, labels=axL1,
             col=ax$axis_x_color, col.axis=ax$axis_x_text_color,
             lwd=ax$axis_x_lwd, lty=ax$axis_x_lty, cex.axis=ax$axis_x_size)
      }
      else {  # rotate_x
        # text() for labels to achieve rotation with srt and offset
        # so par$mgp[2] does not work, instead adjust text(... y= ...)
        axis(1, at=axT1, labels=FALSE,
             col=ax$axis_x_color, col.axis=ax$axis_x_text_color,
             lwd=ax$axis_x_lwd, lty=ax$axis_x_lty, cex.axis=ax$axis_x_size)
        text(x=axT1, y=usr[3] - par("cxy")[2]/4.5, labels=axL1,
             pos=1, xpd=TRUE, cex=ax$axis_x_size, col=ax$axis_x_text_color,
             srt=rotate_x, offset=offset, font=fnt, ...)
      }  # end axis(), text()
    } # end not time series 
    else {
      axT1 <- NULL
      axL1 <- NULL
    }
  }  # end numeric

  # categorical, uses x.lvl
  else if (!is.null(x.lvl)) {
    axL1 <- x.lvl
    if (rotate_x==0) {  # mgp[2] for tic marks and value label separation active
      axis(1, at=axT1, labels=axL1,
           col=ax$axis_x_color, col.axis=ax$axis_x_color,
           lwd=ax$axis_x_lwd, lty=ax$axis_x_lty, cex.axis=ax$axis_x_size)
    }
    else {  # rotate_x
      axis(1, at=axT1, labels=FALSE, col=ax$axis_x_color,
          lwd=ax$axis_x_lwd, lty=ax$axis_x_lty)
      text(x=axT1, y=usr[3]- par("cxy")[2]/4.5, labels=axL1,
           pos=1, xpd=TRUE, cex=ax$axis_x_size, col=ax$axis_x_text_color,
           srt=rotate_x, offset=offset, font=fnt, ...)
    }
  }  # end categorical x

  else  # axT1 not processed  (bc just sends the numerical axis)
    axL1 <- NULL

  # y-axis
  # ------
  if (is.null(y.lvl)  &&  !is.null(axT2)) {  # numerical
    axT2 <- axT2[which(axT2 >= usr[3]  &  axT2 <= usr[4])]
    axL2 <- .axis.format(axT2, axis_fmt, axis_x_pre="no", axis_y_pre)
    axis(2, at=axT2, labels=FALSE, col=ax$axis_y_color,
        lwd=ax$axis_y_lwd, lty=ax$axis_y_lty)
    text(x=usr[1], y=axT2, labels=axL2,
         pos=2, xpd=TRUE, cex=ax$axis_y_size, col=ax$axis_y_text_color,
         srt=rotate_y, font=fnt, ...)
  }

  else if (!is.null(y.lvl)) {  # categorical
    axL2 <- y.lvl
    axis(2, at=axT2, labels=FALSE, col=ax$axis_y_color,
        lwd=ax$axis_y_lwd, lty=ax$axis_y_lty)
    text(x=usr[1], y=axT2, labels=axL2,
         pos=2, xpd=TRUE, cex=ax$axis_y_size, col=ax$axis_y_text_color,
         srt=rotate_y, font=fnt, ...)
  }

  else  # axT2 not processed  (bc just sends the numerical axis)
    axL2 <- NULL

  return(list(axT1=axT1, axL1=axL1, axT2=axT2, axL2=axL2))
}


# enlarge scale for R
# Called from: bar.lattice.R, bc.main.R, dn.main.R, dpmat.main.R,
#              hst.main.R, Model.R, plt.bubble.R, plt.by.legend.R,
#              plt.lattice.R, plt.main.R, plt.sym.legend.R, reg.5ancova.R,
#              reg.5Plot.R, tt.1graph.R, tt.1group.R, tt.2graph.R,
#              tt.2group.R, zzz.R (internal)
.RSadj <- function(radius=0.25, axis_size=NULL, cex.names=NULL, lab_size=NULL) {

  if (is.null(radius)) radius <- 0.25

  regR <- FALSE  # regular R by itself
  in.RStudio <- ifelse (options("device") == "RStudioGD", TRUE, FALSE)
  in.knitr <- ifelse (!is.null(options()$knitr.in.progress), TRUE, FALSE)
  if (!in.RStudio && !in.knitr) regR <- TRUE

  if (regR) {
    radius <- radius*1.6
  }

  if (!is.null(axis_size))
    size.axis <- ifelse (regR, axis_size*1.3, axis_size)
  else
    size.axis <- NULL

   if (!is.null(lab_size))
    size.lab <- ifelse (regR, lab_size*1.3, lab_size)
  else
   size.lab <- NULL

  return(list(radius=radius, axis_size=size.axis, lab_size=size.lab))
}


# Called from: ANOVAz1.R, ANOVAz2.R, bc.data.frame.R, Chart.R,
#              corReorder.R, corScree.R, logit.4Pred.R, prob_norm.R,
#              prob_tcut.R, prob_znorm.R, reg.3dnResidual.R,
#              reg.3resfitResidual.R, reg.5ancova.R, reg.5Plot.R,
#              reg.6mod.R, showColors.R, showPalettes.R, simCImean.R,
#              simCLT.R, simFlips.R, simMeans.R, STL.R, tt.1group.R,
#              tt.2group.R, ttest.R, ttestPower.R, Write.R, X.R, XY.R,
#              zzz.R (internal)
.showfile <- function(fname, txt) {
  dir.nm <- dirname(fname)

  if (dir.nm == ".") {  # no path name, just a file name
    if (getwd() == "/")
      workdir <- "top level (root) of your file system"
    else
      workdir <- getwd()
    txt.wrt <- "written at the current working directory"
  }
  else {
    workdir <- dir.nm
    txt.wrt <- "written" 
  }

  cat("\nThe", txt, txt.wrt, "\n")
  cat("       ", fname, " in:  ", workdir, "\n")
  cat("\n")
}


# Called from: ANOVA.R, corCFA.R, corEFA.R, Regression.R, X.R
.showfile2 <- function(fname, txt) {
  dir.nm <- dirname(fname)

  if (dir.nm == ".") {  # no path name, just a file name
    if (getwd() == "/")
      workdir <- "top level (root) of your file system"
    else
      workdir <- getwd()
    txt.wrt <- "written at the current working directory"
  }
  else {
    workdir <- dir.nm
    txt.wrt <- "written" 
  }

  tx <- c()
  tx[length(tx)+1] <- paste("\nThe", txt, txt.wrt)
  tx[length(tx)+1] <- paste("       ", fname, " in:  ", workdir)

  return(tx)
}


# Called from: param.VBS.R, X.R
# Bin a numeric vector into frequency counts, free of histogram-specific
# output. Single source for break construction, mirroring the inline logic in
# .hst.main() (which can adopt this helper later). Pass a numeric `breaks`
# vector to bin onto an existing set of breaks, so grouped data share bins.
# Returns mids, counts, breaks.
# Called from: freq_poly.plotly.R
.bin_counts <- function(x, breaks=NULL, bin_start=NULL, bin_width=NULL,
                        bin_end=NULL, x.name="x") {

  x <- x[is.finite(x)]

  # build breaks from user bin_start/bin_width/bin_end, else default Sturges
  if (is.null(breaks)) {
    if (!is.null(bin_width) || !is.null(bin_start) || !is.null(bin_end)) {
      if (is.null(bin_start))
        bin_start <- pretty(c(min(x), max(x)))[1]
      if (is.null(bin_width)) {
        h <- suppressWarnings(hist(x, plot=FALSE, breaks="Sturges"))
        bin_width <- h$breaks[2] - h$breaks[1]
      }
      if (is.null(bin_end)) bin_end <- max(x)
      if (bin_end < bin_start) {
        cat("\n"); stop(call.=FALSE, "\n------\n",
          "bin_start: ", bin_start, "\n", "bin_end: ", bin_end, "\n",
          "bin_end is smaller than bin_start, make bin_end larger.\n\n")
      }
      breaks <- seq(bin_start, bin_end, bin_width)
      seq.end <- bin_end
      while (max(breaks) < bin_end) {
        seq.end <- seq.end + bin_width
        breaks <- seq(bin_start, seq.end, bin_width)
      }
    }
    else
      breaks <- "Sturges"
  }

  # for numeric breaks, every data value must fall within a bin
  if (is.numeric(breaks)) {
    if (min(x) < min(breaks) || max(x) > max(breaks)) {
      cat("\n"); stop(call.=FALSE, "\n------\n",
        "Range of the data for ", x.name, ": ", min(x), " to ", max(x), "\n",
        "Range of the specified bins: ", min(breaks), " to ", max(breaks),
        "\n\n",
        "Each data value must be in a bin.\n",
        "Extend the bin range by setting bin_start and/or bin_end.\n\n")
    }
  }

  h <- suppressWarnings(
         hist(x, breaks=breaks, plot=FALSE, include.lowest=TRUE))
  list(mids=h$mids, counts=h$counts, breaks=h$breaks)
}


.band.width <- function(x, bw_iter=25, details=FALSE, ...) {

  if (details) {
    cat("\n")
    cat("iterate for smoother density bandwidth (bw)\n")
    cat("flips: number of times densities change sign\n")
    cat("--------------------------------------------\n")
  }

  x <- na.omit(x)
  bw <- bw.nrd0(x)
  irep <- 0
  if (details)
    cat(irep, .fmtc(" ", 10) , "   bw: ", .fmt(bw,4), "\n", sep="")

  repeat {
    irep <- irep + 1
    d.gen <- suppressWarnings(density(x, bw, ...))  # no missing data
    xd <- diff(d.gen$y)

    flip <- 0
    for (j in 2:length(xd))
      if (sign(xd[j-1]) != sign(xd[j])) flip <- flip + 1
    if (flip > 1  &&  irep <= bw_iter) {
      bw <- 1.1 * bw
      if (details)
        cat(irep, "  flips:", .fmti(flip,3), "  bw: ", .fmt(bw,4), "\n", sep="")
    }
    else
      break
  }  # end repeat

  return(bw)
}


# see if manage graphics or just sequentially plot
# Called from: ANOVA.R, ANOVAz1.R, ANOVAz2.R, bc.data.frame.R,
#              corReorder.R, corScree.R, CountAll.R, cr.data.frame.R,
#              Regression.R, simCLT.R, tt.1group.R, tt.2group.R, ttest.R,
#              X.R
.graphman <- function() {
  in.RStudio  <- identical(Sys.getenv("RSTUDIO"),  "1")
  in.Positron <- identical(Sys.getenv("POSITRON"), "1")
  in.knitr    <- isTRUE(getOption("knitr.in.progress"))
  !in.RStudio && !in.Positron && !in.knitr
}


# manages the graphics system (not in RStudio or knitr)
# Called from: ANOVAz1.R, ANOVAz2.R, bc.data.frame.R, corReorder.R,
#              corScree.R, cr.data.frame.R, regPlot.R, Regression.R,
#              simCLT.R, tt.1group.R, tt.2group.R, X.R,
#              zzz.R (internal: .opendev)
.graphwin <- function(wnew=1, d.w=NULL, d.h=NULL) {
  dl <- dev.list()
  dl2 <- dl[which(dl==2)]  # device #2
  dl.more <- dl[which(dl>2)]  # devices larger than #2

  # remove all open windows past device 2
  if (length(dl.more) > 0) {
    min_dd <- dl.more[which(dl.more==min(dl.more))]
    max.dd <- dl.more[which(dl.more==max(dl.more))]
    for (i in min_dd:max.dd) dev.off(which=i)
  }

  off.two <- ifelse (length(dl2) == 0, TRUE, FALSE)

  # open graphics windows
  # if not already present, generate a null window for #2 and then remove
  if (off.two) wnew <- wnew + 1
    for (i in 1:wnew) {
      if (is.null(d.w) && is.null(d.h))
        dev.new()
      else if (is.null(d.w))  # BPFM and 1 cat var have reduced height only
        dev.new(height=d.h)
      else
        dev.new(width=d.w, height=d.h)
    }
  if (off.two) dev.off(which=2)

}


# Called from: bc.data.frame.R, Chart.R, corCFA.R, corProp.R,
#              corReflect.R, logit.4Pred.R, prob_norm.R, prob_tcut.R,
#              prob_znorm.R, simCImean.R, simFlips.R, simMeans.R,
#              tt.1group.R, tt.2group.R, ttestPower.R, X.R, XY.R
.opendev <- function(pdf_file, width, height) {

  if (is.null(pdf_file)) {
    in.RStudio  <- identical(Sys.getenv("RSTUDIO"),  "1")
    in.Positron <- identical(Sys.getenv("POSITRON"), "1")
    in.knitr    <- isTRUE(getOption("knitr.in.progress"))
    if (!in.RStudio && !in.Positron && !in.knitr) {
      .graphwin(1, d.w=width, d.h=height)
      orig.params <- par(no.readonly=TRUE)
      on.exit(par(orig.params))
    }
  }
  else  # windows puts a blank first page without onefile=FALSE
    pdf(file=pdf_file, width=width, height=height, onefile=FALSE)

}


# num.cat var is integer with small number of unique values
# Called from: bc.data.frame.R, Chart.R, hst.main.R, ss.data.frame.R,
#              SummaryStats.R, X.R
.is.num.cat <- function(x, n_cat=10, max.n=100) {

  x <- sort(unique(na.omit(x)))
  nu.x <- length(x)

  # limit the sample size for the integer test
  if (.is.integer(sample(x, size=min(max.n,length(x))))  &&  nu.x<=n_cat) {
    eq.int <- TRUE
    d.x <- diff(x)  # check for equal intervals
    if (nu.x > 2) {
      for (i in 2:(length(x)-1)) {
        if ((abs(d.x[i-1] - d.x[i]) > 0.0000000001)) eq.int <- FALSE
      }
      status <- eq.int  # num.cat var has equal intervals
    }
    else
      status <- TRUE

  }
  else
    status <- FALSE

  return(status)

}


# Called from: bc.data.frame.R, SummaryStats.R, X.R
.ncat <- function(analysis, x.name, nu, n_cat, brief=FALSE) {

  cat("\n")
  cat(">>> ", x.name, " has only only ", nu, " equally spaced unique ",
      "integer values <= n_cat=", n_cat, "\n",
      "    so treat as categorical, convert to an R factor\n", sep="")

  if (!brief)
    cat("    For numeric, set n_cat smaller than ", nu,
        " with ", analysis, " or globally with  style", sep="")

  cat("\n")

}


# reorder fill, etc. to match the level order of the grouping factor by.call
# Called from: X.R, XY.R
.align_vector <- function(vec, by.call) {
  vec_name <- deparse(substitute(vec))

  if (!is.factor(by.call)) stop("by.call must be a factor")

  by_levels <- levels(by.call)

  # for named vec, reorder to match factor levels
  if (!is.null(names(vec))) {
    if (!all(by_levels %in% names(vec))) {
      cat("\n"); stop(call.=FALSE, "\n------\n",
        "All levels of  by  must be named in", sQuote(vec_name))
    }
    vec <- vec[by_levels]
  }

  # for unnamed vec, assume user provided it in level order;
  # length 1 recycles across all levels
  if (length(vec) == 1L) {
    vec <- rep(vec, length(by_levels))
  } else if (length(vec) != length(by_levels)) {
    cat("\n"); stop(call.=FALSE, "\n------\n",
      "Length of", sQuote(vec_name),
      "must match number of levels in by.call")
  }

  unname(vec)
}



# Called from: plt.contour.R, zzz.R (internal: .heatmap)
.corcolors <- function() {

  fill_low <- NULL
  fill_hi <- NULL

  thm <- (getOption("theme"))
  if (is.null(fill_low) && is.null(fill_hi)) {
    if (thm %in% c("colors", "dodgerblue", "blue", "lightbronze")) {
      fill_low <- "browns"
      fill_hi <- "blues"
      hmcols <- getColors(fill_low, fill_hi, l=c(10,90), n=100, output=FALSE)
    }
    if (thm %in% c("purple")) {
      fill_low <- "olives"
      fill_hi <- "purples"
      hmcols <- getColors(fill_low, fill_hi, l=c(10,90), n=100, output=FALSE)
    }
    else if (thm %in% c("darkred", "red", "rose", "slatered")) {
      fill_low <- "turquoises"
      fill_hi <- "reds"
      hmcols <- getColors(fill_low, fill_hi, l=c(10,90), n=100, output=FALSE)
    }
    else if (thm %in% c("darkgreen", "green")) {
      fill_low <- "violets"
      fill_hi <- "greens"
      hmcols <- getColors(fill_low, fill_hi, l=c(10,90), n=100, output=FALSE)
    }
    else if (thm %in% c("gold", "brown", "sienna", "orange")) {
      fill_low <- "blues"
      fill_hi <- "browns"
      hmcols <- getColors(fill_low, fill_hi, l=c(10,90), n=100, output=FALSE)
    }
    else if (thm %in% c("gray", "white", "light")) {
      fill_low <- "white"
      fill_hi <- "black"
      hmcols <- colorRampPalette(c("white", "gray75", "black"))(100)
    }
  }
  else if (is.null(fill_low) || is.null(fill_hi)) {
    fill_low <- "white"
    fill_hi <- "gray20"
    hmcols <- colorRampPalette(c("white", "gray75", "black"))(100)
  }

  return(list(fill_low=fill_low, fill_hi=fill_hi, hmcols=hmcols))
}


# Called from: corCFA.R, corProp.R, corReflect.R, corReorder.R,
#              cr.data.frame.R
.heatmap <- function(R, NItems, main, bm=NULL, rm=NULL, diag=NULL,
                     pdf_file=NULL, width=NULL, height=NULL) {

  if (!is.null(diag)) {
    for (i in 1:NItems) R[i,i] <- diag
    cat("\nNote: To provide more color separation for off-diagonal\n",
        "      elements, the diagonal elements of the matrix for\n",
        "      computing the heat map are set to 0.\n", sep="")
  }

  axis_x_size <- ifelse(is.null(getOption("axis_x_size")),
      getOption("axis_size"), getOption("axis_x_size"))
  axis_y_size <- ifelse(is.null(getOption("axis_y_size")),
      getOption("axis_size"), getOption("axis_y_size"))

  cnm <- colnames(R)
  max.num <- max(nchar(cnm))
  mrg <- 1.3 + .38*max.num
  if (is.null(bm)) bm <- mrg
  if (is.null(rm)) rm <- mrg
  if (axis_x_size > 1) bm <- bm + .5  # hack
  if (axis_y_size > 1) rm <- rm + .5

  cc <- .corcolors()  # get divergent color scale from color theme

  if (!is.null(pdf_file))
    pdf(file=pdf_file, width=width, height=height)

  heatmap(R[1:NItems,1:NItems], Rowv=NA, Colv="Rowv", symm=TRUE,
    col=cc$hmcols, margins=c(bm,rm), main=main,
    cexRow=axis_x_size+.2, cexCol=axis_y_size+.2)

  if (!is.null(pdf_file)) {  # terminate pdf graphics
    dev.off()
    .showfile(pdf_file, "heat map")
    cat("\n\n")
  }
}


# get rgb color from a color name with specified transparency
# Called from: bc.main.R, bubble.plotly.R, dn.main.R, dn.plotly.R,
#              dot.plotly.R, dpmat.main.R, Flows.R, getColors.R,
#              hs.plotly.R, hst.main.R, logit.4Pred.R, piechart.plotly.R,
#              plt.add.R, plt.bubble.R, plt.by.legend.R, plt.colors.R,
#              plt.lattice.R, plt.main.R, plt.mat.R, plt.plotly.R,
#              plt.sym.legend.R, radar.plotly.R, reg.5Plot.R, style.R,
#              X.R, XY.R, zzz_plotly.R
.maketrans <- function(col.name, trans.level) {
  sapply(col.name, function(clr) {
    rgb.vals <- grDevices::col2rgb(clr)
    r <- rgb.vals[1]; g <- rgb.vals[2]; b <- rgb.vals[3]
    grDevices::rgb(r, g, b, alpha = trans.level, maxColorValue = 256)
  }, USE.NAMES = FALSE)
}


# from theme, get the associated sequential, divergent or hues palette name
# Called from: ANOVAz2.R, bc.main.R, bubble.plotly.R, Chart.R, dn.main.R,
#              Flows.R, plt.colors.R, plt.fill.R, reg.5ancova.R, X.R
.get_fill <- function(theme=getOption("theme"), seq.pal=FALSE, diverge=FALSE) {

  if (!diverge) {
    # for ordinal variables, or color theme not default, get sequential palette
    # for not ordinal and default color theme, qualitative palette
    if (theme == "colors") {
      clrs <- ifelse (seq.pal, "blues", "hues")
    }
    else if (theme %in% c("gray", "white")) clrs <- "grays"
    else if (theme %in% c("lightbronze", "dodgerblue", "blue")) clrs <- "blues"
    else if (theme %in% c("gold", "brown", "sienna")) clrs <- "browns"
    else if (theme == "orange") clrs <- "rusts"
    else if (theme %in% c("darkred", "red", "rose", "slatered")) clrs <- "reds"
    else if (theme %in% c("darkgreen", "green")) clrs <- "greens"
    else if (theme == "purple") clrs <- "violets"
    else clrs <- "blues"
  }

  else {  # divergent palette
    if ((theme %in% c("gray", "white"))) {
      clrs <- c("grays", "grays")
    }
    else if ((theme %in% c("hues", "lightbronze", "dodgerblue", "blue",
                            "gold", "brown", "sienna", "orange")))
      clrs <- c("browns", "blues")
    else if ((theme %in% c("darkred", "red", "rose", "slatered")))
      clrs <- c("turquoises", "reds")
    else if ((theme %in% c("darkgreen", "green", "purple")))
      clrs <- c("violets", "greens")
    else
      clrs <- c("browns", "blues")
  }

  return(clrs)
}


# see if fill or color is a predefined palette
# Called from: bc.main.R, X.R, XY.R, zzz.R (internal: .color_range)
.is.palette <- function(fillclr) {
  if (fillclr == "magma") fillclr <- "plasma"

  # names of color palettes generated by getColors
  nmC <- c("reds", "rusts", "browns", "olives", "greens", "emeralds",
          "turquoises", "aquas", "blues", "purples", "violets", "magentas",
          "grays", "hues")
  nmR <- c("rainbow", "heat", "terrain")
  nmV<- c("viridis", "cividis", "plasma", "spectral")
  nmO<- c("Okabe-Ito")
  nmD<- c("distinct")
  nmW<- c("BottleRocket1", "BottleRocket2", "Rushmore1",
          "Royal1", "Royal2", "Zissou1", "Darjeeling1", "Darjeeling2",
          "Chevalier1", "FantasticFox1", "Moonrise1", "Moonrise2",
          "Moonrise3", "Cavalcanti1", "GrandBudapest1", "GrandBudapest2",
          "IsleofDogs1", "IsleofDogs2")
  nmT <- c("Tableau")
  nm <- c(nmC, nmR, nmV, nmO, nmD, nmW, nmT)

  return(fillclr %in% nm)
}


# from a pre-defined color palette name, generate the palette without scaling
# if not a palette name, then return the name, i.e., do nothing
# typically used to convert color name to a color, such as from from get_fill()
# Called from: ANOVAz2.R, bar.lattice.R, bc.main.R, bubble.plotly.R,
#              Chart.R, dn.main.R, Flows.R, plt.colors.R, plt.fill.R,
#              style.R, X.R, zzz_plotly.R (.hier_color_resolve)
.color_range <- function(fill, n.clr) {

  # fill is a function such as hcl or is a named vector
  if (is.call(fill) || is.name(fill)) {
    clrs <- eval(fill)
  }

  # or evaluate the character string fill
  else {
    if (!is.null(fill[1])) {
      if (fill[1] == "colors") fill[1] <- "hues"   # new names
      if (fill[1] == "yellows")  fill[1] <- "browns"

      if (.is.palette(fill[1]))
        clrs <- getColors(fill[1], n=n.clr, output=FALSE)  # sequential palette
      else
        clrs <- fill  # not an identified name of a color range
      if (fill[1]=="grays" && n.clr==2) # Cleveland 2-var dot plot of difference
        clrs <- c("gray62", "gray40")

      if (length(fill) == 2) {  # divergent
        if (.is.palette(fill[2]))
          clrs <- getColors(fill[1], fill[2], n=n.clr, output=FALSE)
      }
    }  # fill[1] not NULL

    else  # fill[1] is NULL
      clrs <- NULL
  }

  return(clrs)
}


# get the hue according to the color theme
# Called from: bc.main.R, plt.main.R, zzz.R (internal: .scale.clr)
.get.h <- function(theme=getOption("theme")) {

       if (theme %in% c("gray", "white")) h <- 0  # any value for h works
  else if (theme %in% c("colors", "lightbronze", "dodgerblue", "blue")) h <- 240
  else if (theme %in% c("gold", "brown", "sienna")) h <- 60
  else if (theme == "orange") h <- 30
  else if (theme %in% c("darkred", "red", "rose", "slatered")) h <- 0
  else if (theme %in% c("darkgreen", "green")) h <- 120
  else if (theme == "purple") h <- 300
  else h <- 240

  return(h)
}

# get hue and chroma from an R rgb color name
# Called from: plt.main.R, zzz.R (internal: .scale.clr)
.getHC <- function(rgb.nm) {
  rgb1 <- t(grDevices::col2rgb(rgb.nm) / 255)  # rgb color from R color name
  luv  <- grDevices::convertColor(rgb1, from="sRGB", to="Luv")
# L <- luv[,"L"]
  u <- luv[,"u"]
  v <- luv[,"v"]
  c <- sqrt(u^2 + v^2)
  h <- (atan2(v, u) * 180 / pi) %% 360
  setNames(c(hue=h, chroma=c), c("hue","chroma"))
}


# get rgb color from R color name
# Called from: style.show.R, zzz_plotly.R
.to_rgb <- function(color) {

  clr <- color[1]  # box_fill is qualitative color scale

  if (is.null(color))
    rgb_color <- "NULL"
  else {  # preserve color name if it exists
    if (!(color[1] %in% colors()))
      rgb_color <- col2rgb(clr, alpha=TRUE)
    else
      rgb_color <- clr
  }
  return(rgb_color)
}


# initial attempt at sequential scaling of fill color
# Called from: Chart.R, X.R
.getColC <- function(x, chroma=55, fill_name) {

  if (getOption("theme") %in% c("gray", "white")) chroma <- 0

  if (!grepl(".v", fill_name, fixed=TRUE)) {
    xp <- pretty(x)
    xp.mn <- min(xp)
    xp.mx <- max(xp)
    xp.rn <- xp.mx - xp.mn

    x.nrm <- (x - xp.mn) / xp.rn

    lum <- 100 - (100*x.nrm)  # scale each value, light to dark flip
    expn <- (82 + (2 * length(x))) / 100
    if (expn > .96) expn <- .96  # hack
    lum <- (lum**expn) + 9  # compress, which darkens, then lighten a bit
    cc <- hcl(h=.get.h(), c=chroma, l=lum)
    clr <- cc
  }
  return(clr)
}

# better, more general scaling function
# fill_scaled is TRUE when called
# Called from: bc.main.R
.scale.clr <- function(x, fill, fill_split, fill_chroma, theme) {
  n.fill <- ifelse (is.null(fill), 0, length(fill))
  # rescale absolute distance from midpoint
  x.dist <- abs(x - fill_split)
  mx.xd <- max(x.dist)
  x.normed <- x.dist / mx.xd
  lum.range <- 27 + ((1-x.normed)*53)
  if (n.fill == 0 || n.fill > 2) {  # hue and chroma by defaulting to theme
    if (theme %in% c("gray", "white")) {
      chroma <- 0
      hue <- 0  # arbitrary
    }
    else {
      chroma <- fill_chroma
      hue <- .get.h(theme)
    }
    n.fill <- 1  # treat as single-color sequential
  }  # end not fill

  else if (n.fill == 1) {  # hue and chroma from fill name
    hc <- .getHC(fill)
    hue <- hc[1]
    chroma <- hc[2]
  }

  if (n.fill < 2)
    fill <- hcl(h=hue, c=chroma, l=lum.range)

  else if (n.fill == 2) {  # length of fill is 2, so divergent scale
    hc <- .getHC(fill[1])
    hue1 <- hc[1]
    chroma1 <- ifelse (hue1=="black", 0, hc[2])
    if (chroma1 > 100) chroma1 <- 100
    hc <- .getHC(fill[2])
    hue2 <- hc[1]
    chroma2 <- ifelse (hue2=="black", 0, hc[2])
    if (chroma2 > 100) chroma2 <- 100

    # need a sequential scale if only one who is black, chroma=0
    if ((chroma1!=0 && chroma2!=0) || (chroma1==0 && chroma2==0))
      fill <- colorspace::diverging_hcl(n=length(lum.range),
         h=c(hue1, hue2), c=c(chroma1,chroma2), l=lum.range, fixup=TRUE)
    else
      fill <- colorspace::sequential_hcl(
        n=length(lum.range), h=hue2, c=c(chroma1, chroma2), l=lum.range)
  }

  else {
    cat("\n"); stop(call.=FALSE, "\n","------\n",
      "With  fill_scaled  specify one or two fill colors,\n",
      "  for either a sequential or a divergent color palette.\n\n")
  }

  return(fill)
}  # end scale.clrs()


# Resolve a getColors(...) call to a concrete palette of length n.
# fill.name  — deparse(substitute(fill)) captured at function entry
# n          — desired palette length, from caller's chart context
# Called from: Chart.R, X.R, XY.R
.resolve_getColors_n <- function(fill.name, n) {
  gc.args   <- substr(fill.name, 11, nchar(fill.name) - 1)
  has_n     <- grepl("(^|,)\\s*n\\s*=", gc.args)
  has_output <- grepl("output", fill.name, fixed = TRUE)
  n_arg      <- if (has_n) "" else paste0(", n=", n)
  output_arg <- if (has_output) "" else ", output=FALSE"
  txt        <- paste0("fill <- getColors(", gc.args, n_arg, output_arg, ")")
  eval(parse(text = txt))
}


# Called from: piechart.plotly.R
.auto_text_color <- function(cols, bg = "white", threshold = 0.5) {
  # cols: vector of hex ("#RRGGBB"), rgba("r,g,b,a"), or R color names
  # bg:   fallback if col2rgb fails
  # threshold: luminance cutoff for black/white switch

  parse_one <- function(col) {
    col <- as.character(col)

    if (grepl("^rgba?\\(", col)) {
      # rgba(r,g,b,...) form
      nums <- suppressWarnings(as.numeric(strsplit(gsub("[rgba() ]",
                               "", col), ",")[[1]]))
      r <- nums[1]; g <- nums[2]; b <- nums[3]
    } else {
      # try normal R color or hex
      rgb <- tryCatch(
        grDevices::col2rgb(col)[, 1],
        error = function(e) grDevices::col2rgb(bg)[, 1]
      )
      r <- rgb[1]; g <- rgb[2]; b <- rgb[3]
    }

    # normalize to [0,1]
    r <- r/255; g <- g/255; b <- b/255

    # linearize (sRGB companding)
    lin <- function(u) ifelse(u <= 0.03928, u/12.92, ((u+0.055)/1.055)^2.4)
    rL <- lin(r); gL <- lin(g); bL <- lin(b)

    # relative luminance
    L <- 0.2126*rL + 0.7152*gL + 0.0722*bL

    if (is.na(L)) "black" else if (L < threshold) "white" else "black"
  }

  vapply(cols, parse_one, character(1))
}


# Called from: style.show.R
.to_num <- function(k, d=1, w=0) {
  if (!is.null(k))
    val <- format(sprintf("%.*f", d, k), width=w, justify="right",
                  scientific=FALSE)
  else
    val <- "NULL"
  return(val)
}


# Called from: style.show.R
.to_str <- function(cc) {
  if (is.null(cc)) cc <- "NULL"
  return(cc)
}


# Called from: style.R
.to256 <- function(trans_level)
   trn <- (1-getOption(trans_level))*256

# Called from: style.R
.to256n <- function(trans_level)
   trn <- (1-trans_level) * 256


# change class call to class character
# otherwise length > 1, make a single character string
# Called from: av.Rmd.R, Chart.R, corFA_Rmd.R, dist.Rmd.R, dn.main.R,
#              dpmat.main.R, hst.stats.R, param.VBS.R, plt.txt.R,
#              Read.R, reg.Rmd.R, Regression.R, XY.R
.fun_call.deparse <- function(fun_call) {

  fc.d <- deparse(fun_call)
  if (length(fc.d) > 1) {  # multiple lines
    fc <- fc.d[1]
    for (i in 2:length(fc.d)) fc <- paste(fc, fc.d[i], sep="")
  }
  else
    fc <- fc.d

  fc <- sub("     ", " ", fc, fixed=TRUE)
  fc <- sub("    ", " ", fc, fixed=TRUE)
  fc <- sub("  ", " ", fc, fixed=TRUE)

  return(fc)
}


# get the value for a specified function argument
# Called from: av.Rmd.R, corFA_Rmd.R, dist.Rmd.R, reg.Rmd.R
.get.arg <- function(argm, fc) {

  loc <- regexec(argm, fc)
  strt1 <- loc[[1]]  # beginning of argument
  if (strt1 > 0) {
    j <- strt1
    while (substr(fc, start=j, stop=j) != "\"") j <- j + 1
    strt <- j
    j <- j + 1  # first " after ,
    while (substr(fc, start=j, stop=j) != "\"") j <- j + 1
    stp <- j  # second " after ,
    value <- substr(fc, start=strt, stop=stp)
  }
  else
    value <- ""

  return(value)
}


# remove argument and character value from a function call
# Called from: av.Rmd.R, corFA_Rmd.R, dist.Rmd.R, dpmat.main.R,
#              param.VBS.R, plt.txt.R, reg.Rmd.R, XY.R
.rm.arg <-  function(argm, fc) {

  loc <- regexec(argm, fc)[[1]]  # beginning of argument

  if (loc > 0) {

    first.arg <- ifelse (substr(fc, loc-1, loc-1) == "(", TRUE, FALSE)

    j <- loc
    if (!first.arg)  # is not first argument, start at preceding comma
      while (substr(fc, start=j, stop=j) != ",") if (j > 0) j <- j - 1
    strt <- j  #  closing parentheses or comma before argument

    while (substr(fc, start=j, stop=j) != "\"") if (j < 1000) j <- j + 1
    j <- j + 1  # first " after ,
    while (substr(fc, start=j, stop=j) != "\"") if (j < 1000) j <- j + 1
    stp <- j  # second " after ,

    if (first.arg) stp <- stp + 2  # remove trailing comma and space

    remv <- substr(fc, start=strt, stop=stp)
    fc_new <- sub(remv, "", fc, fixed=TRUE)

  }

  return(fc_new)
}


# remove argument and logical value from a function call
# Called from: plt.txt.R
.rm.arg.l <-  function(argm, fc) {

  loc <- regexec(argm, fc)[[1]]  # beginning of argument

  if (loc > 0) {

    first.arg <- ifelse (substr(fc, loc-1, loc-1) == "(", TRUE, FALSE)

    j <- loc
    if (!first.arg)  # is not first argument, start at preceding comma
      while (substr(fc, start=j, stop=j) != "," &&
             substr(fc, start=j, stop=j) != "")
         if (j < 1000) j <- j + 1
    stp <- j  #  closing parentheses or comma before argument
    if (first.arg) stp <- stp + 2  # remove trailing comma and space
    strt <- loc - 1

    remv <- substr(fc, start=strt, stop=stp)
    fc_new <- sub(remv, "", fc, fixed=TRUE)
    fc_new <- sub(",,", "", fc_new, fixed=TRUE)  # hack

  }

  return(fc_new)
}


# remove x=  and y= for suggestions for XY
# Called from: dpmat.main.R, param.VBS.R, plt.txt.R, XY.R
.rm.arg.2 <-  function(argm, fc) {

  fc <- sub(",,", ",", fc, fixed=TRUE)

  fc1 <- gsub(argm, "", fc, fixed=TRUE)  # remove all argm from fc
  fc2 <- gsub(",", ", ", fc1, fixed=TRUE)  # each , goes to , space
  fc3 <- gsub("  ", " ", fc2, fixed=TRUE)
  fc3 <- gsub(") #", ")  #", fc3, fixed=TRUE)  # restore blank before #

  if (grepl("(", argm, fixed=TRUE)) fc3 <- gsub("XY", "XY(", fc3)
  fc3 <- gsub("((", "(", fc3, fixed=TRUE)
  fc3 <- sub(", ,", ",", fc3, fixed=TRUE)

  return(fc3)
}


# remove argument and non-string value from a function call
# Called from: reg.Rmd.R
.rm.arg.ns <-  function(argm, fc) {

  loc <- regexec(argm, fc)[[1]]  # beginning of argument

  if (loc > 0) {

    first.arg <- ifelse (substr(fc, loc-1, loc-1) == "(", TRUE, FALSE)

    j <- loc
    if (!first.arg)  # is not first argument, start at preceding comma
      while (substr(fc, start=j, stop=j) != ",") if (j > 0) j <- j - 1
    strt <- j  #  closing parentheses or comma before argument

    dlm <- c(",", ")")

    j <- j + 1
    while (!(substr(fc, start=j, stop=j) %in% dlm))
      if (j < 1000) j <- j + 1

    stp <- j  # got a "," or a ")"
    stp <- stp - 1  # retain the "," or ")"

    if (first.arg) stp <- stp + 2  # remove trailing comma and space

    remv <- substr(fc, start=strt, stop=stp)
    fc_new <- sub(remv, "", fc, fixed=TRUE)

  return(fc_new)
  }
}


# Called from: plt.forecast.R, STL.R
.toFmtDate <- function(x.date, ts_unit) {
  if (ts_unit == "months")
    x.date <- as.character(zoo::as.yearmon(x.date))
  else if (ts_unit == "quarters")
    x.date <- as.character(zoo::as.yearqtr(x.date))
  else if (ts_unit == "years")
    x.date <- as.character(format(x.date, "%Y"))
  else
    x.date <- as.character(x.date)
}


# A base-R resolver for x, y, by, facet1, facet2, ID that supports the common forms:
# 	•	bare name: by = Gender
# 	•	character name: by = "Gender"
# 	•	numeric index: by = 3
# 	•	expression: by = cut(Age, 5) or by = interaction(Sex, Dept)
# 	•	missing / NULL

# It also lets you request coercion (e.g., make by/facets factors).

# The .resolve_one() approach works cleanly even when by = NULL (or facet1, facet2, ID, etc. are omitted). The helper is designed to always return the same shape of result, with present = FALSE if the argument was missing or NULL.

#  rby <- .resolve_one(data, by, want = "factor")
#  by.name <- rby$name; by.call <- rby$value


`%||%` <- function(a,b) if (is.null(a) || !length(a)) b else a

# want: "auto","factor","numeric","character","logical","no"
# Called from: bubble.plotly.R, Chart.R, Flows.R, hier.plotly.R,
#              plt.plotly.R, radar.plotly.R, reg.3txtResidual.R,
#              reg.Rmd.R, ss.pivot.R, X.R, XY.R, zzz_plotly.R
.resolve <- function(data, arg,
                     want = c("auto","factor","numeric","character","logical","no")) {
  want <- match.arg(want)
  out  <- list(present = FALSE, name = NULL, value = NULL)
  if (missing(arg) || is.null(arg)) return(out)

  expr <- substitute(arg)

  if (is.data.frame(data)) {
    if (is.character(arg) && length(arg) == 1L && arg %in% names(data)) {
      val <- data[[arg]]; nm <- arg
    } else if (is.numeric(arg) && length(arg) == 1L && is.finite(arg) &&
               arg >= 1 && arg <= ncol(data)) {
      val <- data[[arg]]; nm <- names(data)[arg] %||% paste0("V", arg)
    } else {
      # Evaluate inside a data mask; base functions available; no global leakage
      data_env <- list2env(data, parent = baseenv())
      val <- try(eval(expr, envir = data_env), silent = TRUE)
      if (inherits(val, "try-error")) return(out)
      nm <- deparse(expr, nlines = 1)
    }
  } else {
    # data = NULL → resolve in caller/global env
    val <- try(eval(expr, envir = parent.frame(), enclos = baseenv()), silent = TRUE)
    if (inherits(val, "try-error")) {
      if (is.character(arg) && length(arg) == 1L &&
          exists(arg, envir = parent.frame(), inherits = TRUE)) {
        val <- get(arg, envir = parent.frame(), inherits = TRUE); nm <- arg
      } else return(out)
    } else nm <- deparse(expr, nlines = 1)
  }

  val <- switch(want,
    auto      = val,
    factor    = if (is.factor(val)) val else factor(val),
    numeric   = suppressWarnings(as.numeric(val)),
    character = as.character(val),
    logical   = as.logical(val),
    no        = val
  )

  out$present <- TRUE; out$name <- nm; out$value <- val; out
}


# Called from: X.R, XY.R
.vbs_summary_table <- function(x_vec, grp_vec, grp.label, digits_d = NULL) {

  .vbs_stats <- function(z) {
    z <- z[!is.na(z)]
    c(
      n      = length(z),
      Mean   = mean(z),
      Median = median(z),
      SD     = stats::sd(z),
      IQR    = stats::IQR(z),
      Min    = min(z),
      Max    = max(z)
    )
  }

  ## ---- grouped vs ungrouped ----
  if (!is.null(grp_vec)) {
    tmp_list <- tapply(x_vec, grp_vec, .vbs_stats)
    mat      <- do.call(rbind, tmp_list)     # groups x stats
    grp_vals <- names(tmp_list)
  } else {
    mat      <- rbind(.vbs_stats(x_vec))     # 1 x stats
    grp_vals <- grp.label
  }

  ## Build data frame first
  res <- data.frame(
    grp = grp_vals,
    mat,
    row.names        = NULL,
    check.names      = FALSE,
    stringsAsFactors = FALSE
  )
  names(res)[1] <- grp.label

  ## ---- Apply .fmt() if digits_d specified ----
  # n is a count — always integer regardless of digits_d
  if ("n" %in% names(res))
    res[["n"]] <- .fmt(res[["n"]], d = 0)

  if (!is.null(digits_d)) {
    num_cols <- vapply(res, is.numeric, logical(1))
    num_cols[1] <- FALSE   # don't format the group label column
    if ("n" %in% names(res)) num_cols["n"] <- FALSE  # already done

    res[, num_cols] <- lapply(
      res[, num_cols, drop = FALSE],
      function(col) .fmt(col, d = digits_d)
    )
  }

  ## Convert to character array for output
  tx <- .df_char(res)
  class(tx) <- "out"
  tx
}


# convert a data frame to a character array preserving spacing for class output
# Called from: zzz.R (internal: .vbs_summary_table)
.df_char <- function(df) {
  # Format each column
  formatted <- lapply(df, function(col) {
    if (is.numeric(col)) {
      # Determine max number of decimal places
      decimals <- sapply(col, function(x) {
        if (is.na(x)) return(0)
        parts <- strsplit(format(x, scientific=FALSE), ".", fixed=TRUE)[[1]]
        if (length(parts) == 2) nchar(parts[2]) else 0
      })
      max_dec <- max(decimals, na.rm=TRUE)
      out <- formatC(col, format="f", digits=max_dec)
    } else {
      out <- as.character(col)
    }
    # Make NA values explicit
    out[is.na(col)] <- "NA"
    out
  })

  # Build character data frame
  char_df <- as.data.frame(formatted, stringsAsFactors=FALSE)

  # Compute column widths
  widths <- mapply(function(col, name) {
    vals <- c(name, col)
    max(nchar(vals, type="width"), na.rm=TRUE)
  }, char_df, names(char_df))

  # Pad each column
  padded <- mapply(function(col, w) {
    format(col, width=w, justify="right")
  }, char_df, widths, SIMPLIFY=FALSE)

  # Format headers
  headers <- mapply(function(name, w) format(name, width=w, justify="right"),
                    names(df), widths, USE.NAMES=FALSE)

  # Combine rows
  rows <- do.call(paste, c(padded, sep="  "))
  header_row <- paste(headers, collapse="  ")

  return(c(header_row, rows))
}