# need d as global because data=d in function def does not
#  have a value assigned to d, d <- mydata does do that, even if conditional
#  generates a Note
if (getRversion() >= "3.6.0")
  globalVariables(c("d", "mydata", "l", "mylabels", "mycor"))

## zzz.R  — lessR startup ----------------------------------------------------


.onAttach <- function(libname, pkgname) {
  packageStartupMessage(
    "\n",
    "lessR 4.5.4                          feedback: gerbing@pdx.edu \n",
    "--------------------------------------------------------------\n",
    "> d <- Read(\"\")  Read data file, many formats available, e.g., Excel\n",
    "  d is the default data frame, data= in analysis routines optional\n",
    "\n",
    "Find examples of reading, writing, and manipulating data, graphics,\n",
    "testing means and proportions, regression, factor analysis,\n",
    "customization, forecasting, and aggregation to pivot tables.\n",
    "  Enter: browseVignettes(\"lessR\")\n",
    "\n",
    "Although most previous function calls still work, most\n",
    "visualization functions are now reorganized to three functions:\n",
    paste0(
      "   Chart(): type = \"bar\", \"pie\", \"radar\", \"bubble\", \"dot\",\n",
      "                   \"sunburst\", \"treemap\", \"icicle\"\n"
    ),
    "   X(): type=\"histogram\", \"density\", \"vbs\", and more\n",
    paste0(
      "   XY(): type=\"scatter\" for a scatterplot, or ",
      "\"contour\", \"smooth\"\n"
    ),
    "There is also Flows() for Sankey flow diagrams.\n",
    "\n",
    "View lessR updates, now including modern time series forecasting.\n",
    "  Enter: news(package=\"lessR\"), or ?Chart, ?X, or ?XY\n",
    "\n",
    "Interactive data analysis for constructing visualizations.\n",
    "  Enter: interact()\n"
  )
}


.onLoad <- function(libname, pkgname) {

  if (requireNamespace("conflicted", quietly = TRUE)) {
    conflicted::conflict_prefer("style",    "lessR", quiet=TRUE)
    conflicted::conflict_prefer("STL",      "lessR", quiet=TRUE)
    conflicted::conflict_prefer("order_by", "lessR", quiet=TRUE)
    conflicted::conflict_prefer("recode",   "lessR", quiet=TRUE)
    conflicted::conflict_prefer("rename",   "lessR", quiet=TRUE)
  }

  options(theme    = "colors")
  options(sub_theme = "default")

  options(panel_fill  = "white")
  options(window_fill = getOption("panel_fill"))
  options(panel_color = "gray45")
  options(panel_lwd   = 1.0)
  options(panel_lty   = "solid")

  options(bar_fill = NULL)
  options(bar_fill_discrete =
    c("#4398D0","#B28B2A","#5FA140","#D57388","#9A84D6","#00A898",
      "#C97E5B","#909711","#00A3BA","#D26FAF","#00A76F","#BD76CB"))
  options(bar_fill_cont      = rgb(150,170,195, maxColorValue=255))
  options(trans_bar_fill     = 0.10)
  options(bar_color          = rgb(132,150,175, maxColorValue=255))
  options(bar_color_discrete = "transparent")
  options(bar_color_cont     = rgb(132,150,175, maxColorValue=255))

  options(pt_fill       = rgb(50,78,92, maxColorValue=255))
  options(trans_pt_fill = 0.10)
  options(pt_color      = rgb(50,78,92, maxColorValue=255))

  options(out_fill   = "firebrick4")
  options(out_color  = "firebrick4")
  options(out2_fill  = "firebrick2")
  options(out2_color = "firebrick2")

  options(violin_fill  = "#7485975A")
  options(violin_color = "gray15")
  options(box_fill     = rgb(65,155,210, maxColorValue=255))
  options(box_color    = "gray15")
  options(line_color   = "gray15")

  options(bubble_text_color = "#F7F2E6")
  options(ellipse_fill      = "#92806F28")
  options(ellipse_color     = "gray20")
  options(ellipse_lwd       = 1)

  options(se_fill   = "#1A1A1A19")
  options(fit_color = rgb(92,64,50, maxColorValue=255))
  options(fit_lwd   = 2)

  options(heat          = "gray30")
  options(segment_color = "gray40")
  options(ID_color      = "gray50")

  options(main_color = "gray15")
  options(main_cex   = 1)
  options(lab_color  = "gray15")  # axis titles
  options(lab_x_color = NULL)
  options(lab_y_color = NULL)
  options(lab_cex     = 0.98)
  options(lab_x_cex   = NULL)
  options(lab_y_cex   = NULL)

  options(axis_color   = "gray15")  # tick labels
  options(axis_x_color = NULL)
  options(axis_y_color = NULL)
  options(axis_lwd     = 1)
  options(axis_x_lwd   = NULL)
  options(axis_y_lwd   = NULL)
  options(axis_lty     = "solid")
  options(axis_x_lty   = NULL)
  options(axis_y_lty   = NULL)
  options(axis_cex     = 0.75)
  options(axis_x_cex   = NULL)
  options(axis_y_cex   = NULL)
  options(axis_text_color   = "gray20")
  options(axis_x_text_color = NULL)
  options(axis_y_text_color = NULL)
  options(rotate_x = 0)
  options(rotate_y = 0)
  options(offset   = 0.5)

  options(grid_color   = "gray85")
  options(grid_x_color = NULL)
  options(grid_y_color = NULL)
  options(grid_lwd     = 0.5)
  options(grid_x_lwd   = NULL)
  options(grid_y_lwd   = NULL)
  options(grid_lty     = "solid")
  options(grid_x_lty   = NULL)
  options(grid_y_lty   = NULL)

  options(strip_fill       = "#7F7F7F37")
  options(strip_color      = "gray40")
  options(strip_text_color = "gray15")

  options(add_fill  = "#D9D9D920")
  options(add_trans = 0.0)
  options(add_color = "gray50")
  options(add_cex   = 0.75)
  options(add_lwd   = 0.5)
  options(add_lty   = "solid")

  options(n_cat   = 1)
  options(suggest = TRUE)
  options(note    = TRUE)
  options(quiet   = FALSE)
  options(brief   = FALSE)

  options(lessR.use_plotly = TRUE)
  options(explain   = TRUE)
  options(interpret = TRUE)
  options(results   = TRUE)
  options(document  = TRUE)
  options(code      = TRUE)

  options(out.signifstars = FALSE)
  options(scipen          = 30)

  options(mc_doScale_quiet = TRUE)
}


.newparam <- function(miss.old, nm.old, str.old, miss.new, nm.new, str.new) {
  if (!miss.old) {
    message(">>> Parameter  ",  str.old,
            "  will soon stop working. New name: ", str.new, "\n")
    return(nm.old)  # return symbol for old param variable, do not eval
  }
  else if (!miss.new)
    return(nm.new)  # return symbol for new param variable, do not eval
  else
    return(NULL)  # neither old nor new param were specified in function call
}


# 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
.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
.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
.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)
}


# get number of decimal digits of a scalar, trailing and leading 0's deleted
# called by bc.main()
.num.dec <- function(x) {
 if (abs(x - round(x)) > .Machine$double.eps^0.5)
   nchar(strsplit(as.character(x), ".", fixed=TRUE)[[1]][[2]])
 else
   return(0)
}


# round to specified number of digits, include trailing zeros
.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
.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
.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
.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`
.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`
.fmtc <- function(k, w=0, j="right") {
  format(sprintf("%s", k), width=w, justify=j)
}


# convert a scientific notation number to decimal number
.fmtNS <- function(k) {
  format(k, scientific=FALSE)
}


.dash <- function(ndash, cc, newline=TRUE) {
  if (missing(cc)) cc <- "-"
  for (i in 1:(ndash)) cat(cc)
  if (newline) cat("\n")
}


.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
.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
.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)
}


.charToDate <- function(char, punct) {

  txt <- character(length=4)
  txt[1] <- "\nTo see all possible formats, enter: ?strptime\n"
  txt[2] <- "Examples:  \"08/18/2024\" format is \"%m/%d/%Y\"\n"
  txt[3] <- "           \"18-08-24\"   format is \"%d-%m-%y\"\n"
  txt[4] <- "           \"August 18, 2024\" format is \"%B %d, %Y\"\n\n"

  dc <- strsplit(char, punct)  # Extract dc, date components
  c1 <- as.numeric(sapply(dc, function(x) x[1]))
  c2 <- as.numeric(sapply(dc, function(x) x[2]))
  c3 <- as.numeric(sapply(dc, function(x) x[3]))
  mx1 <- max(c1);  mx2 <- max(c2);  mx3 <- max(c3)
  unq1 <- length(unique(c1)); unq2 <- length(unique(c2))

  if (!is.na(mx1) && !is.na(mx2)) {  # non-numeric chars entered for a date
    fmt <- NULL

    # date format is correctly inferred if proper dates
    if (mx1 > 31)
      fmt <- paste("%Y", punct, "%m", punct, "%d", sep="")
    else if (mx1 > 12)
      fmt <- paste("%d", punct, "%m", punct, "%Y", sep="")
    else if (mx2 > 12)
      fmt <- paste("%m", punct, "%d", punct, "%Y", sep="")

    # guess at date format
    else if (unq2<=12 && (unq2 %in% c(2,4,12)))
      fmt <- paste("%d", punct, "%m", punct, "%Y", sep="")
    else if (unq1<=12 && (unq1 %in% c(2,4,12)))
      fmt <- paste("%m", punct, "%d", punct, "%Y", sep="")

    # allow for 2-digit year, is positioned  at 3rd component
    if (!is.null(fmt)) {
      if (substr(fmt,2,2) != "Y") {
        if (mx3 <= 99) fmt <- sub("Y", "y", fmt, fixed=TRUE)
       }
    }

    # obtain only valid dates
    dates <- try(as.Date(char, format=fmt), silent=FALSE)

    # process valid dates further to obtain the likely correct valid date
    if (!inherits(dates, "try-error") && all(!is.na(dates))) {  # no errors
        message("\nBest guess for the date format: ", fmt, "\n")
        message("If this format is wrong, specify with",
            " parameter: ts_format", txt, "\n")
        return(dates)  # Return converted dates
    }
  }  # all chars numeric

  else {  # some non-numeric chars in at least one date
    message("\n"); stop(call.=FALSE, "\n------\n",
      "At least one date contains non-numeric characters\n",
      "  where there should be a number.\n")
  }

  # date not recognized
  # only way to get here is if date did not work
  message("\n"); stop(call.=FALSE, "\n------\n",
    "The date format could not be properly inferred.\n\n",
    "Specify the date format with:  ts_format", txt, "\n")
}


.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")

}

.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)
}


.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
.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)
}


# .resolve.var() -------------------------------------------------------
# Determines whether a named variable should be read from the global
# environment (data=NULL) or from a data frame, and enforces that
# contract with helpful diagnostics.
#
# 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)

.resolve.var <- 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)
}




# get list of data frames in global environment
# include both R data frames and tidyverse tibbles
.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)
}


.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.
.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()
.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
.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="")
  }

}


.varlist <- function(n.pred, i, var.name, pred.lbl, n.obs, n.keep, lvls=NULL) {

  if (i == 1)
    txt <- "Response Variable:  "
  else
      txt <- paste(pred.lbl, " Variable ", toString(i-1), ": ", sep="")
  cat(txt, var.name)

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

  if (!is.null(l)) {
    lbl <- l[which(names(l) == var.name)]
    if (!is.null(lbl)) cat(", ", as.character(lbl))
  }

  if (!is.null(lvls)) if (i > 1) cat("\n  Levels:", lvls)
  cat("\n")

  if (i == n.pred+1) {
    cat("\n")
    cat("Number of cases (rows) of data: ", n.obs, "\n")
    cat("Number of cases retained for analysis: ", n.keep, "\n")
  }
}


.varlist2 <- 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)
}


.title <- function(x.name, y.name, x.lbl, y.lbl, isnullby) {

  txt1 <- x.name
  if (!is.null(x.lbl)) txt1 <- paste(txt1, ": ", x.lbl, sep="")

  if (isnullby) txt1 <- paste("---", txt1, "---")
  else {
    txt2 <- paste(y.name, sep="")
    if (!is.null(y.lbl)) txt2 <- paste(txt2, ": ", y.lbl, sep="")
  }

  cat("\n")
  cat(txt1, "\n")
  if (!isnullby) {
    cat("  - by levels of - \n")
    cat(txt2, "\n")
    ndash <- max(nchar(txt1),nchar(txt2))
    .dash(ndash)
  }
  cat("\n")

}


.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
.getlabels <- function(xlab=NULL, ylab=NULL, main=NULL, sub=NULL,
                       y.nm=FALSE, by.nm=FALSE, facet1.nm=FALSE,
                       lab_x_cex=NULL, lab_y_cex=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_cex 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_cex;  lab_y_cex <- lab_x_cex;  lab_x_cex <- 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_cex)  &&  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_cex, 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_cex)  &&  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_cex, 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_cex=lab_x_cex, lab_y_cex=lab_y_cex))
}  # end .getlabels




# get the lines of the axis label, prefix with variable name
.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))
}


# convert a data frame to a character array preserving spacing for class output
# currently used only in Plot() VBS Trellis plots
.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))
}


# axis labels
.axlabs <- function(x.lab, y.lab, main.lab, sub.lab,
                    x.val=NULL, xy_ticks=TRUE, offset=0.5,
                    lab_x_cex=NULL, lab_y_cex=NULL, main_cex=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_cex)) {  # temp until all .axes calls provide lab_x_cex
    lab_x_cex <- ifelse(is.null(getOption("lab_x_cex")),
      getOption("lab_cex"), getOption("lab_x_cex"))
  }
  if (is.null(lab_y_cex)) {
    lab_y_cex <- ifelse(is.null(getOption("lab_y_cex")),
      getOption("lab_cex"), getOption("lab_y_cex"))
  }

  adj <- .RSadj(lab_cex=lab_x_cex); lab_x_cex <- adj$lab_cex
  adj <- .RSadj(lab_cex=lab_y_cex); lab_y_cex <- adj$lab_cex
  lblx.lns <- par("mar")[1] - 1.15

  # xlab_adj <- xlab_adj / ln.ht.x
  # ylab positioning
  ln.ht.y <- par("cin")[2] * lab_y_cex * par("lheight")  # line ht inches
  lby <- (.9*ln.ht.y) / 0.19
  lbly.lns <- par("mar")[2] - (0.3 + 1*n.lab_y.ln) * lby  # mar 2: lm lines
  ylab_adj <- ylab_adj / ln.ht.y

  regR <- FALSE  # regular R by itself adjustment
  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) ylab_adj <- ylab_adj + .2

  title(xlab=x.lab, line=lblx.lns-xlab_adj,
        col.lab=lab_x_color, cex.lab=lab_x_cex)
  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-ylab_adj+.1,
  title(ylab=y.lab, line=lbly.lns,
        col.lab=lab_y_color, cex.lab=lab_y_cex)
  if (!is.null(main.lab))
    title(main=main.lab, cex.main=lab_x_cex,
          col.main=getOption("main_color"), ...)
}


# get number of lines in value labels
.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))
}


.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_cex <- ifelse(is.null(getOption("axis_x_cex")),
    getOption("axis_cex"), getOption("axis_x_cex"))
  adj <- .RSadj(axis_cex=axis_x_cex); axis_x_cex <- adj$axis_cex
  axis_y_cex <- ifelse(is.null(getOption("axis_y_cex")),
    getOption("axis_cex"), getOption("axis_y_cex"))
  adj <- .RSadj(axis_cex=axis_y_cex); axis_y_cex <- adj$axis_cex

  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_cex=axis_x_cex, axis_y_cex=axis_y_cex,
              axis_x_text_color=axis_x_text_color, axis_y_text_color=axis_y_text_color))
}


# reduce "pretty" tick locations from a numeric vector for lattice
# call the formatting function of the axis labels, .axis.format()
.sparse.labels <- function(x, ax, n.axis.skip, axis_fmt = NULL,
                                 axis_pre, label_fn = NULL) {
  at <- pretty(x)

  # define the default label function: identity if none supplied
  if (is.null(label_fn)) {
    if (ax=="x")
      label_fn <- function(z) .axis.format(z, axis_fmt, axis_pre, "no")
    if (ax=="y")
      label_fn <- function(z) .axis.format(z, axis_fmt, "no", axis_pre)
  }

  if (length(at) <= n.axis.skip) {  # us all axis labels
    labels <- label_fn(at)
  } 
  else {  # reduce
    keep_idx <- seq(1, length(at), by=n.axis.skip+1)  # skip
    # keep_idx <- round(seq(1, length(at), length.out=n.axis.lbl)) # keep num
    labels <- rep("", length(at))
    labels[keep_idx] <- label_fn(at[keep_idx])
  }

  list(at=at, labels=labels)
}


# format axis labels, such as using "K" notation
.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)
}


# used only in .axis.format, and now not used at all
.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()
.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_cex)
      }
      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_cex)
        text(x=axT1, y=usr[3] - par("cxy")[2]/4.5, labels=axL1,
             pos=1, xpd=TRUE, cex=ax$axis_x_cex, 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_cex)
    }
    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_cex, 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_cex, 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_cex, 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
.RSadj <- function(radius=0.25, axis_cex=NULL, cex.names=NULL, lab_cex=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_cex))
    size.axis <- ifelse (regR, axis_cex*1.3, axis_cex)
  else
    size.axis <- NULL

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

  return(list(radius=radius, axis_cex=size.axis, lab_cex=size.lab))
}


.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")
}


.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)
}


.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)
}


.pdfname <- function(analysis, x.name, go.pdf, pdf.nm, pdf_file) {
  if (go.pdf) {
    if (pdf.nm)
      if (!grepl(".pdf", pdf_file))
        pdf.fnm <- paste(pdf_file, ".pdf", sep="")
      else
        pdf.fnm <- pdf_file
    else
      pdf.fnm <- paste(analysis, "_", x.name, ".pdf", sep="")
  }
  else
    pdf.fnm <- NULL

  return(pdf.fnm)
}


# see if manage graphics or just sequentially plot
.graphman <- function() {

  in.RStudio <- ifelse (options("device") != "RStudioGD", FALSE, TRUE)

  in.knitr <- ifelse (is.null(options()$knitr.in.progress), FALSE, TRUE)

  manage.gr <- ifelse (!in.RStudio && !in.knitr, TRUE, FALSE)

  return(manage.gr)
}


# manages the graphics system (not in RStudio or knitr)
.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)

}


.opendev <- function(pdf_file, width, height) {

  if (is.null(pdf_file)) {
    if (options("device") != "RStudioGD" &&
        is.null(options()$knitr.in.progress)) {
      .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
.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)

}


.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
.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
  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)
}



.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))
}


.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_cex <- ifelse(is.null(getOption("axis_x_cex")),
      getOption("axis_cex"), getOption("axis_x_cex"))
  axis_y_cex <- ifelse(is.null(getOption("axis_y_cex")),
      getOption("axis_cex"), getOption("axis_y_cex"))

  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_cex > 1) bm <- bm + .5  # hack
  if (axis_y_cex > 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_cex+.2, cexCol=axis_y_cex+.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
.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)
}


#.maketrans <- function(col.name, trans.level) {

#  col.trans <- numeric(length(col.name))

#  for (i in 1:length(col.name)) {
#    r.tr <- col2rgb(col.name[i])[1]
#    g.tr <- col2rgb(col.name[i])[2]
#    b.tr <- col2rgb(col.name[i])[3]
#  }

#  col.trans[i] <- rgb(r.tr, g.tr, b.tr, alpha=trans.level, maxColorValue=256)
#}

#  return(col.trans)
#}


# from theme, get the associated sequential, divergent or hues palette name
.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
.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()
.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
.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
.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
.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)
}


# called by BarChart() and PieChart()
# initial attempt at sequential scaling of fill color
.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
.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 <- 30 + ((1-x.normed)*70)
  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()


# from explicit getColors() call in fill parameter, get the colors
# get args and add n=
.do_getColors <- function(fill.name, n.clr) {

  gc.args <- substr(fill.name, 11, nchar(fill.name)-1)
  if (!grepl("output", fill.name, fixed=TRUE))   # "output" not exist
    txt <- paste("fill <- getColors(", gc.args, ", n=", n.clr,
                 ", output=FALSE)", sep="")  # default is FALSE
  else
    txt <- paste("fill <- getColors(", gc.args, ", n=", n.clr,
                 ")", sep="")  # output specified
  pp <- parse(text=txt)

  return(eval(pp))   # get fill
}


.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))
}


.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)
}


.to_str <- function(cc) {
  if (is.null(cc)) cc <- "NULL"
  return(cc)
}


.to256 <- function(trans_level)
   trn <- (1-getOption(trans_level))*256

.to256n <- function(trans_level)
   trn <- (1-trans_level) * 256


# change class call to class character
# otherwise length > 1, make a single character string
.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
.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
.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
.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
.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
.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)
  }
}


.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"
.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
}


.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 ----
  if (!is.null(digits_d)) {
    num_cols <- vapply(res, is.numeric, logical(1))
    num_cols[1] <- FALSE  # don't format the group label column

    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
}


# ---- Drop casewise missing across x, y, by, facet -----------------------

.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)
}


# 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")

}
