.bar.lattice <-
function(x, facet1, facet2, nrows, ncols, asp, prop,
         fill, color,
         trans, size.pt, xlab, ylab, main,
         rotate_x, offset,
         axis_fmt, axis_x_pre, axis_y_pre,
         width, height, pdf_file,
         segments_x, breaks,
         bin_start=NULL, bin_width=NULL, bin_end=NULL,
         T.type, quiet) {


  if (!quiet)
    cat("[Trellis graphics from Deepayan Sarkar's lattice package]\n\n")

  panel_fill <- getOption("panel_fill")
  panel_color <- getOption("panel_color")

  grid_x_color <- getOption("grid_x_color")
  if (is.null(grid_x_color)) grid_x_color <- getOption("grid_color")
  grid_y_color <- getOption("grid_y_color")
  if (is.null(grid_y_color)) grid_y_color <- getOption("grid_color")

  grid_x_lwd <- getOption("grid_x_lwd")
  if (is.null(grid_x_lwd)) grid_x_lwd <- getOption("grid_lwd")
  grid_y_lwd <- getOption("grid_y_lwd")
  if (is.null(grid_y_lwd)) grid_y_lwd <- getOption("grid_lwd")

  grid_x_lty <- getOption("grid_x_lty")
  if (is.null(grid_x_lty)) grid_x_lty <- getOption("grid_lty")
  grid_y_lty <- getOption("grid_y_lty")
  if (is.null(grid_y_lty)) grid_y_lty <- getOption("grid_lty")

  axis_x_color <- getOption("axis_x_color")
  if (is.null(axis_x_color)) axis_x_color <- getOption("axis_color")
  axis_y_color <- getOption("axis_y_color")
  if (is.null(axis_y_color)) axis_y_color <- getOption("axis_color")
  # axis color is panel_color unless axis_color is changed from default
  theme <- getOption("theme")
  sub_theme <- getOption("sub_theme")
  if (sub_theme != "black")  {
     panel_color <- ifelse (axis_x_color != "gray15", axis_x_color, "#DED9CD")
     if (panel_color == "#DED9CD")
       panel_color <- ifelse (axis_y_color != "gray15", axis_y_color, "#DED9CD")
  }
  else {
     panel_color <- ifelse (axis_x_color != "gray55", axis_x_color, "gray55")
     if (panel_color == "gray55")
       panel_color <- ifelse (axis_y_color != "gray55", axis_y_color, "gray55")
  }

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

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

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

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


  # if applicable, open graphics window of specified dimensions
  in.RStudio <- identical(getOption("device"), "RStudioGD")
  in.knitr <- !is.null(options()$knitr.in.progress)
  if (!in.RStudio && !in.knitr) dev.new(width=width, height=height)

  # get variable labels if exist plus axes labels
  if (is.null(ylab)) {
    was.null <- TRUE
    ylab <- ifelse (!prop, "Count of", "Proportion of")
  }
  else
    was.null <- FALSE

  # get lab_x_size  lab_y_size
  lab_size <- getOption("lab_size")
  lab_x_size <- getOption("lab_x_size")
  lab_y_size <- getOption("lab_y_size")
  if (is.null(lab_x_size)) lab_x_size <- lab_size
  adj <- .RSadj(lab_size=lab_x_size); lab_x_size <- adj$lab_size
  if (is.null(lab_y_size)) lab_y_size <- lab_size
  adj <- .RSadj(lab_size=lab_y_size); lab_y_size <- adj$lab_size
  gl <- .getlabels(xlab, ylab, main, lab_x_size=lab_x_size,
                   lab_y_size=lab_y_size)
  x.name <- gl$xn; x.lbl <- gl$xl; x.lab <- gl$xb
  y.name <- gl$yn; y.lbl <- gl$yl
  y.lab <- ifelse (was.null, paste(gl$yb, x.name), gl$yb)
  main.lab <- gl$mb
  sub.lab <- gl$sb
  lab_x_size <- gl$lab_x_size
  lab_y_size <- gl$lab_y_size

  # lattice does horizontal bar or dot chart, so reverse axis labels
  if (T.type %in% c("bar", "dot")) {
    tmp.lab <- x.lab
    x.lab <- y.lab
    y.lab <- tmp.lab
    tmp.cex <- lab_x_size
    lab_x_size <- lab_y_size
    lab_y_size <- tmp.cex
    if (is.null(trans)) trans <- getOption("trans_pt_fill")
  }

  # ------------------------------------------------
  # calculate the histogram or bar chart or dot plot
  # set conditioning variables, facet1 and facet2

  h.type <- ifelse(prop, "percent", "count")  # histogram type
  #h.type <- "density"   # need to integrate density as a 3rd option
  if (T.type == "hist") {
    # derive breaks from bin_start/bin_width/bin_end if any are supplied
    if (!is.null(bin_width) || !is.null(bin_start) || !is.null(bin_end)) {
      if (is.null(bin_start))
        bin_start <- pretty(c(min(x, na.rm=TRUE),
                              max(x, na.rm=TRUE)))[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, na.rm=TRUE)
      brks <- seq(bin_start, bin_end, bin_width)
      seq.end <- bin_end
      while (max(brks) < bin_end) {
        seq.end <- seq.end + bin_width
        brks <- seq(bin_start, seq.end, bin_width)
      }
      breaks <- brks
    }
    if (is.null(facet2))
      p <- lattice::histogram(~ x | facet1, type=h.type, breaks=breaks,
          scales=list(
            x = list(labels=.axis.format(pretty(x),
                                         axis_fmt, axis_x_pre, "no"),
                     at=pretty(x), tck=.8)
          ))
    else
      p <- lattice::histogram(~ x | facet1 * facet2, type=h.type,
          breaks=breaks,
          scales=list(
            x = list(labels=.axis.format(pretty(x),
                                         axis_fmt, axis_x_pre, "no"),
                     at=pretty(x), tck=.8)
          ))
    # see if there is a color range for fill, if so then get the colors
    # if breaks were possible, use unlist(p)$panel.args.common.breaks
    n.bar <- p$panel.args.common$nint
  }

  else if (T.type %in% c("bar", "dot")) {
    mytab <- table(x, facet1)
    if (prop) mytab <- prop.table(mytab, margin=2)
    mytabDF <- as.data.frame.table(mytab, responseName="Count")
    p <- lattice::barchart(x ~ Count | facet1, data = mytabDF,
          scales = list(
            x = list(labels=.axis.format(pretty(mytabDF$Count),
                                         axis_fmt, axis_x_pre, "no"),
                     at=pretty(mytabDF$Count), tck=.8)
          ))
    n.bar <- nrow(mytab)
  }

  # process a potential color range (such as "blues")
  clr <- NULL
  if (is.null(fill))  fill <- getOption("bar_fill_discrete")
  clr <- .color_range(fill, n.bar)  # if range, return colors
  fill <- clr  # NOTE:  somewhere  fill  is still being used instead of clr


  # customize layout cols and rows, need only specify one
  if (!is.null(nrows) ||  !is.null(ncols)) {
    n.panels <- ifelse (is.null(facet2), nlevels(facet1),
                                         nlevels(facet1)*nlevels(facet2))
    if (is.null(ncols)) ncols <- (n.panels %/% nrows) + (n.panels %% nrows > 0)
    if (is.null(nrows)) nrows <- (n.panels %/% ncols) + (n.panels %% ncols > 0)
    p <- update(p, layout=c(ncols, nrows))
  }

  # scale down the point size, grid line width for the multi-panel dot plots
  n.pnl <- nlevels(facet1)
  if (!is.null(facet2)) n.pnl <- n.pnl * nlevels(facet2)
  size.mult <- ifelse (n.pnl > 3, 0.70, 0.833)
  size.pt <- size.pt * size.mult
  if (n.pnl > 3 &&  grid_y_lwd > 0.99) grid_y_lwd <- .5 * grid_y_lwd

  # separate panels with a border even if turned off when only one plot
  panel_frame_color <- ifelse(panel_color == "transparent",
                              "gray50", panel_color)

  # even if no axis in single plot, multi-panel needs an axis to separate
  # scales, as currently configured, does not separate values from the axis
  g.x_color <- grid_x_color
  if (g.x_color ==  "transparent") g.x_color <- grid_y_color
  g.y_color <- grid_y_color
  if (g.y_color ==  "transparent") g.y_color <- grid_x_color

  a.x.text_color <- axis_x_text_color
  if (a.x.text_color ==  "transparent") a.x.text_color <-axis_y_text_color
  a.y.text_color <- axis_y_text_color
  if (a.y.text_color ==  "transparent") a.y.text_color <- axis_x_text_color

  l.x_color <- lab_x_color
  if (l.x_color == "transparent") l.x_color <-lab_y_color
  l.y_color <- lab_y_color
  if (l.y_color == "transparent") l.y_color <- lab_x_color

  # more physical space of the axis from the axis labels unless too many rows
  if (is.null(nrows)) nrows <- 1
  if (nrows < 7) {
    pad <- 2.08 - 0.56*log(nrows)
    p <- update(p,
         par.settings=list(
           layout_heights=list(axis_xlab_padding=pad)))
  }

  top.pad <- ifelse (is.null(main), 0, 1)
  if (!is.null(facet1)) top.pad <- 1
  axs.top <- ifelse (is.null(main), .5, 1)

  # move strip to left for a single column
  show_strip <- TRUE;  strip.lft <- FALSE
  if (!is.null(ncols)) if (ncols == 1)
    strip.lft <- TRUE

  # specify strip attributes
  strip = if (show_strip) {
    p <- update(p,
         strip = lattice::strip.custom(
           par.strip.text = list(
             cex=axis_x_size,
             col=getOption("strip_text_color"),
             bg=list(col=getOption("strip_fill")),
             strip.border=list(col=getOption("strip_color"), lwd=0.5),
             strip.left=strip.lft
      )))}
  else
    FALSE

  # specify general plot attributes
  p <- update(p,
         aspect=asp,
         xlab=list(label=x.lab, cex=lab_x_size, col=l.x_color),
         ylab=list(label=y.lab, cex=lab_y_size, col=l.y_color),
         main=list(label=main.lab, cex=getOption("main_size", 1.1),
                   col=getOption("lab_color")),
         par.settings=list(
           background=list(col=getOption("window_fill")),
           panel.background=list(col=panel_fill),
           layout_heights=list(top.padding=top.pad, axis_top=axs.top),
           axis_line=list(col=panel_frame_color,
             lty=getOption("axis_lty"), lwd=getOption("axis_lwd"))),
         scales=list(
           x = list(cex=axis_x_size, rot=rotate_x,
                    col=a.x.text_color),
           y = list(cex=axis_y_size, rot=getOption("rotate_y"),
                    col=a.y.text_color)),

         panel = function(x, y, ...) {
            panel.grid(h=0, v=-1, col=g.x_color,
                        lwd=grid_x_lwd, lty=grid_x_lty)
            if (T.type == "hist") {
              panel.grid(h=-1, v=0, col=g.y_color,
                         lwd=grid_y_lwd, lty=grid_y_lty)
              panel.histogram(x, col=fill, border=color, ...)
              #panel.dnFill(x, fill=rgb(.3,.3,.9,.2), color="darkblue",
                           #ref=TRUE, origin=0, ...)
              #panel.mathdensity(dmath = dnorm, col.line = "grey60",
                           #args = list(mean=mean(x),sd=sd(x)), ...)
            }
            else if (T.type == "dot") {
              if (segments_x) {
                panel.points(x, y, pch=21, cex=size.pt,
                   col=getOption("pt_fill"), fill=getOption("pt_fill"), ...)
                panel.segments(0, y, x, y, col=getOption("pt_fill"), ...)
              }
              else {
                panel.dotplot(x, y, type="p", col=color, fill=fill,
                   col.line=fill, ...)  # called from Plot
              }
            }
            else if (T.type == "bar")
              panel.barchart(x, y, col=fill, border=color, ...)
          }
        )


  # display
  # Note: programmatic PDF save is not reliable for lattice/trellis graphics
  # due to grid's internal device state. Use RStudio > Plots > Export > Save as PDF.
  if (!is.null(pdf_file))
    message("Writing directly to a PDF file does not work in this context.\n",
            "To save as PDF, use RStudio > Plots > Export > Save as PDF.")
  axis.text.old <- lattice::trellis.par.get("axis.text")
  lattice::trellis.par.set("axis.text",
    utils::modifyList(axis.text.old, list(cex=axis_x_size)))
  print(p)
  lattice::trellis.par.set("axis.text", axis.text.old)

  # text output
  if (!quiet) {

    if (T.type == "hist"  &&  is.null(facet2)) {
      stuff <- .ss.numeric(x, facet1, digits_d=getOption("digits_d"),
                           brief=TRUE, y.name=getOption("facet1name"))
      txsts <- stuff$tx
      class(txsts) <- "out"
      output <- list(out_stats=txsts)
      class(output) <- "out_all"
      print(output)
    }

    else if (T.type == "bar"  &&  is.null(facet2)) {
        stats <- .ss.factor(x, by=facet1, brief=TRUE, digits_d=getOption("digits_d"),
                            x.name=x.name, y.name=getOption("facet1name"),
                            x.lbl=x.lbl, y.lbl=y.lbl)
        if (!is.null(stats)) {
          txttl <- stats$txttl
          txfrq <- stats$txfrq
          txXV <- stats$txXV

          class(txttl) <- "out"
          class(txXV) <- "out"
          output <- list(out_ttl=txttl, out_frq=txfrq, out_chi=txXV)
          class(output) <- "out_all"
          print(output)
      }

    }
  }

  cat("\n")

}
