R/freq_poly.plotly.R

In lessR: Less Code with More Comprehensive Results

# Frequency polygon, plotly rendering. One overlaid polygon per by-group.
# Modeled on dn.plotly(); binning via .bin_counts(), so this function carries
# no dependency on the histogram code path.
# Called from: X.R
freq_poly.plotly <- function(
  x, by = NULL,                  # numeric x; optional grouping var
  x_name, by_name = NULL,        # names for hover/legend
  fill,                          # scalar or length-G color(s)
  x_lab, y_lab = NULL,           # axis labels (y derived from stat if NULL)
  main = NULL,
  ax = NULL, gridT1 = NULL, gridT2 = NULL,  # lessR axis helpers
  stat = "count",                # "count", "proportion", or "%"
  fill_area = TRUE,              # TRUE: translucent fill; FALSE: lines only
  breaks = NULL, bin_start = NULL, bin_width = NULL, bin_end = NULL,
  digits_d = 3,
  style_opts = .plotly_style()
) {

  # --- groups ------------------------------------------------------------
  if (is.null(by)) {
    groups <- "Series 1"; G <- 1L
  } else {
    if (is.factor(by)) groups <- levels(by)
    else               groups <- unique(by[!is.na(by)])
    G <- length(groups)
  }

  # --- shared breaks across all groups -----------------------------------
  # bins computed once over all data so every group's polygon is comparable
  full <- .bin_counts(x, breaks=breaks, bin_start=bin_start,
                      bin_width=bin_width, bin_end=bin_end, x.name=x_name)
  shared.breaks <- full$breaks
  mids <- full$mids

  # --- per-group counts on the shared breaks -----------------------------
  poly.list <- vector("list", G)
  ymax <- 0
  for (g in seq_len(G)) {
    xg <- if (G == 1L) x else x[by == groups[g]]
    xg <- xg[is.finite(xg)]
    b  <- .bin_counts(xg, breaks=shared.breaks, x.name=x_name)
    yv <- b$counts
    if (stat == "proportion") yv <- yv / sum(yv)        # within-group
    else if (stat == "%")     yv <- (yv / sum(yv)) * 100 # within-group
    poly.list[[g]] <- list(x = mids, y = yv)
    ymax <- max(ymax, yv, na.rm = TRUE)
  }

  # close the polygon at zero: one bin-width step beyond first/last midpoint
  step <- if (length(mids) > 1) mids[2L] - mids[1L] else 1

  # --- y label from stat -------------------------------------------------
  if (is.null(y_lab))
    y_lab <- switch(stat,
      "proportion" = paste("Proportion of", x_name),
      "%"          = paste("Percentage of", x_name),
                     paste("Count of", x_name))

  # --- ticks / labels ----------------------------------------------------
  gridT1 <- ax$axT1 %||% gridT1 %||% pretty(range(mids), n = 5)
  gridL1 <- ax$axL1 %||% format(gridT1, big.mark = ",", trim = TRUE)
  gridT2 <- ax$axT2 %||% gridT2 %||% pretty(c(0, ymax), n = 6)
  gridL2 <- ax$axL2 %||% format(gridT2, trim = TRUE)

  # --- colors / alpha ----------------------------------------------------
  alpha.fill <- .auto_opacity(G, "fill")
  alpha.line <- .auto_opacity(G, "lines")
  fill.rgba  <- .maketrans_plotly(rep_len(fill, G), alpha = alpha.fill)
  line.rgba  <- .maketrans_plotly(rep_len(fill, G), alpha = alpha.line)
  # vertex points (lines-only mode): line color at full opacity
  pt.rgba    <- .maketrans_plotly(rep_len(fill, G), alpha = 1)

  # --- hover builder -----------------------------------------------------
  .hover <- function(xx, yy) {
    paste0(
      x_name, ": ", format(signif(xx, 6)),
      "<br>", y_lab, ": ", format(round(yy, digits_d), trim = TRUE)
    )
  }

  # --- widget & traces ---------------------------------------------------
  plt <- plotly::plot_ly(type = "scatter", mode = "lines", showlegend = G > 1)

  for (g in seq_len(G)) {
    p  <- poly.list[[g]]
    nm <- if (G > 1) groups[g] else NULL
    xx <- c(p$x[1L] - step, p$x, p$x[length(p$x)] + step)
    yy <- c(0, p$y, 0)
    # lines only: mark the vertices, but not the two zero-closing endpoints
    pt.size <- if (fill_area) NULL
               else c(0, rep(7.5, length(p$x)), 0)
    plt <- plotly::add_trace(
      plt,
      x = xx, y = yy, name = nm,
      mode      = if (fill_area) "lines" else "lines+markers",
      line      = list(color = line.rgba[g], width = 2.2),
      marker    = if (fill_area) NULL
                  else list(color = pt.rgba[g], size = pt.size,
                            line = list(width = 0)),
      fill      = if (fill_area) "tozeroy" else "none",
      fillcolor = if (fill_area) fill.rgba[g] else NULL,
      hoverinfo = "text",
      hovertext = if (!is.null(nm) && length(by_name))
        paste0(by_name, ": ", groups[g], "<br>", .hover(xx, yy))
      else
        .hover(xx, yy)
    )
  }

  # --- axes & grids ------------------------------------------------------
  border.shapes <- plot_border()
  x.shapes      <- x_grid(gridT1)

  ax.x <- axis_num(x_lab, gridT1, gridL1)
  ax.y <- axis_num(y_lab, gridT2, gridL2)

  ax.x$tickmode <- "array"; ax.x$tickvals <- gridT1; ax.x$ticktext <- gridL1
  ax.y$tickmode <- "array"; ax.y$tickvals <- gridT2; ax.y$ticktext <- gridL2
  ax.y$showgrid  <- TRUE
  ax.y$gridcolor <- .to_hex(style_opts$grid_col)
  ax.y$gridwidth <- 1
  ax.y$griddash  <- "dot"

  if (is.character(ax.x$title)) {
    ax.x$title <- list(text = ax.x$title, standoff = 10)
  } else if (is.list(ax.x$title)) {
    ax.x$title$standoff <- 10
  }
  ax.x$automargin <- TRUE

  plt <- plotly::layout(
    plt,
    xaxis = ax.x,
    yaxis = ax.y,
    shapes = c(x.shapes, border.shapes),
    template = NULL
  )

  # --- background & legend -----------------------------------------------
  plt$x$layout$plot_bgcolor  <- .to_hex(style_opts$panel_fill)
  plt$x$layout$paper_bgcolor <- .to_hex(style_opts$window_fill)

  if (G > 1) {
    leg.border <- .to_hex(style_opts$legend_border)
    leg.bg     <- .to_hex(style_opts$window_fill)
    plt <- plotly::layout(plt, legend = list(
      title = list(
        text = if (length(by_name)) by_name else "",
        font = list(size = round(15 * getOption("lab_size", 1)))),
      font = list(size = round(16 * getOption("axis_size", 0.9))),
      bgcolor = leg.bg,
      bordercolor = leg.border,
      borderwidth = 1
    ))
  }

  # --- finalize ----------------------------------------------------------
  plt <- .finalize_plotly_widget(
    plt,
    kind = "freq_poly",
    x_name = x_name,
    by_name = if (G > 1) by_name else NULL,
    add_title = FALSE,
    nudge_viewer = (.allow.interactive() &&
                    !isTRUE(getOption("knitr.in.progress")))
  )

  invisible(plt)
}