Nothing
R/dot.plotly.R
In lessR: Less Code with More Comprehensive Results
Defines functions
dot.plotly
.dot_title
.dot_cat_axis
.dot_val_axis
.dot_segment_trace
.dot_marker_trace
.dot_marker_list
.dot_marker_style
# ----- shared helpers (private to dot.plotly) ---------------------------
# Used by the three dot.plotly paths (paired, faceted, single-series).
# Convert numeric shape codes to plotly symbol names and pre-compute
# the per-point marker geometry. Returns a list with symbol/px/color/border.
.dot_marker_style <- function(shape, pt.size, fill, border, pt_opacity) {
symbol <- switch(as.character(shape),
"21"="circle","22"="square","23"="diamond",
"24"="triangle-up","25"="triangle-down","circle"
)
px <- as.numeric(pt.size) * 10
if (!is.finite(px) || px <= 0) px <- 5
list(
symbol = symbol,
px = px,
color = .maketrans_plotly(fill[1], alpha = pt_opacity),
border = .to_hex(border[1])
)
}
# Assemble the marker= list a plotly scatter trace expects.
# Pass color_override to use a per-series color (paired dot).
.dot_marker_list <- function(ms, n, color_override = NULL) {
list(
symbol = ms$symbol,
size = rep(ms$px, n),
sizemode = "diameter",
color = color_override %||% ms$color,
opacity = 1,
line = list(color = ms$border, width = 1)
)
}
# Add a markers trace. cats/vals are placed on x/y per orientation
# ("v" = cats on x; "h" = cats on y).
.dot_marker_trace <- function(plt, cats, vals, marker, orientation,
hover.tmpl = NULL, name = NULL,
showlegend = FALSE) {
if (orientation == "v") { xv <- cats; yv <- vals }
else { xv <- vals; yv <- cats }
args <- list(plt, type = "scatter", mode = "markers",
x = xv, y = yv, marker = marker,
showlegend = showlegend, inherit = FALSE)
if (!is.null(hover.tmpl)) args$hovertemplate <- hover.tmpl
if (!is.null(name)) args$name <- name
do.call(plotly::add_trace, args)
}
# Add an NA-separated lines trace for the origin→value stems.
# cats/vals MUST be pre-filtered to finite values. seg.start is the
# axis position where each stem begins (caller decides the policy).
.dot_segment_trace <- function(plt, cats, vals, seg.color,
orientation, seg.start) {
n <- length(vals)
if (n == 0L) return(plt)
if (orientation == "v") {
seg.x <- as.vector(rbind(cats, cats, NA))
seg.y <- as.vector(rbind(rep(seg.start, n), vals, NA_real_))
} else {
seg.x <- as.vector(rbind(rep(seg.start, n), vals, NA_real_))
seg.y <- as.vector(rbind(cats, cats, NA))
}
plotly::add_trace(plt,
type = "scatter", mode = "lines",
x = seg.x, y = seg.y,
line = list(color = seg.color, width = 1),
hoverinfo = "skip",
showlegend = FALSE,
inherit = FALSE
)
}
# Build the numeric (value) axis spec. Sets range from origin_x + gridT
# and optionally applies axis/text colors.
.dot_val_axis <- function(label, gridT, origin_x,
axis_color = NULL, text_color = NULL) {
ax <- axis_num(label, gridT, NULL)
if (!is.null(origin_x) && !is.null(gridT)) {
step <- if (length(gridT) > 1L) gridT[2L] - gridT[1L] else 0
ax$range <- c(min(origin_x, min(gridT)), max(gridT) + step)
ax$autorange <- FALSE
}
if (!is.null(axis_color)) {
ax$linecolor <- .to_hex(axis_color)
ax$tickcolor <- .to_hex(axis_color)
}
if (!is.null(text_color))
ax$tickfont$color <- .to_hex(text_color)
ax
}
# Build the category axis spec, freezing the order to the supplied cats.
.dot_cat_axis <- function(label, cats) {
c(
axis_cat(label),
list(
categoryorder = "array",
categoryarray = cats,
tickmode = "array",
tickvals = cats,
ticktext = cats
)
)
}
# Shared plotly layout title= spec for the dot chart.
.dot_title <- function(main) {
if (is.null(main)) NULL
else list(text = main, x = 0.5, xanchor = "center",
y = 0.98, yanchor = "top",
font = list(size = round(
16 * getOption("main_size", 1))))
}
dot.plotly <- function(
x, # category labels (vector) or paired-dot data frame
y, # numeric values (vector or data frame for paired)
orientation = "v", # "v" = vertical (cats on x-axis)
# "h" = horizontal (cats on y-axis)
fill, border, shape, pt.size,
x_lab = "", # x-axis label
y_lab = "", # y-axis label
digits_d = 2,
pt_opacity = 0.95,
gridT = NULL, # tick positions for grid lines on the value axis
origin_x = NULL, # x-axis origin; NULL = auto (from gridT min)
height = NULL, # plot height in inches; NULL lets plotly auto-size
facet = NULL, # factor vector: one facet level per observation
# (cats/vals MUST already be aggregated + sorted)
facet_name = NULL, # display name for the facet variable
facet_opts = .plotly_facet_opts(), # n_row/n_col read here (grid layout)
main = NULL, # chart title (faceted path only)
segments_x = TRUE, # draw segment from origin to each dot (horizontal orientation)
segments_y = TRUE, # draw segment from origin to each dot (vertical orientation)
style_opts = .plotly_style()
) {
# internal aliases preserve descriptive names throughout the function body
cats <- x
vals <- y
title.size <- round(16 * getOption("main_size", 1))
# ---- paired dot plot (vals is a data frame with 2+ columns) -------------
# Layout: single panel, cats on y, values on x (orientation "h").
# Each y-column becomes a series with its own marker color + legend entry.
if (is.data.frame(vals)) {
cats.all <- as.character(cats)
n <- length(cats.all)
ms <- .dot_marker_style(shape = 21, pt.size = pt.size,
fill = fill, border = border,
pt_opacity = pt_opacity)
seg.color.hex <- .to_hex(style_opts$segment_color)
axis.x.clr <- style_opts$axis_x_color %||% style_opts$axis_color
axis.text.clr <- style_opts$axis_text_color
plt <- plotly::plot_ly()
for (si in seq_len(ncol(vals))) {
vals.si <- as.numeric(vals[[si]])
clr <- .maketrans_plotly(fill[si], alpha = pt_opacity)
if (isTRUE(segments_x))
plt <- .dot_segment_trace(plt, cats.all, vals.si, seg.color.hex,
"h", seg.start = origin_x)
plt <- .dot_marker_trace(plt, cats.all, vals.si,
marker = .dot_marker_list(ms, length(vals.si),
color_override = clr),
orientation = "h",
name = names(vals)[si],
showlegend = TRUE)
}
val.ax <- .dot_val_axis(x_lab, gridT, origin_x,
axis_color = axis.x.clr,
text_color = axis.text.clr)
cat.ax <- .dot_cat_axis(y_lab, cats.all)
plt <- plotly::layout(plt,
xaxis = val.ax,
yaxis = cat.ax,
shapes = c(x_grid(gridT), plot_border()),
margin = list(
t = if (!is.null(main)) round(title.size * 2.2) else 30),
title = .dot_title(main),
legend = list(font = list(size = round(
16 * getOption("axis_size", 0.9)))),
template = NULL
)
plt$x$layout$plot_bgcolor <- .to_hex(style_opts$panel_fill)
plt$x$layout$paper_bgcolor <- .to_hex(style_opts$window_fill)
plt <- .finalize_plotly_widget(plt, kind = "sp",
x_name = x_lab, by_name = "", add_title = FALSE,
nudge_viewer = (.allow.interactive() &&
!isTRUE(getOption("knitr.in.progress"))))
return(invisible(plt))
}
# ---- faceted dot plot ---------------------------------------------------
# Layout: subplot grid of single panels; each panel is one facet level.
# Per-panel segment start is clamped at-or-below panel min so dots never
# sit to the left of (or below) their stem.
if (!is.null(facet)) {
fac.char <- as.character(facet)
fac.levels <- sort(unique(fac.char[!is.na(fac.char)]))
n.fac <- length(fac.levels)
ms <- .dot_marker_style(shape, pt.size, fill, border,
pt_opacity)
# color keyed by category name so hues match across facet panels
cat.levels <- unique(as.character(cats[!is.na(cats)]))
col.map <- setNames(
.maketrans_plotly(.to_hex(rep_len(fill,
length(cat.levels))),
alpha = pt_opacity),
cat.levels)
seg.color <- .to_hex(style_opts$segment_color)
axis.x.clr <- style_opts$axis_x_color %||% style_opts$axis_color
axis.text.clr <- style_opts$axis_text_color
val.fmt <- .get.tick.fmt(vals[is.finite(vals)], digits_d)
val.spec <- if (nzchar(val.fmt)) paste0(":", val.fmt) else ""
if (orientation == "v") {
cat.label <- if (nzchar(x_lab)) x_lab else "Category"
val.label <- if (nzchar(y_lab)) y_lab else "Value"
hover.tmpl <- paste0(cat.label, ": %{x}<br>",
val.label, ": %{y", val.spec, "}",
"<extra></extra>")
} else {
cat.label <- if (nzchar(y_lab)) y_lab else "Category"
val.label <- if (nzchar(x_lab)) x_lab else "Value"
hover.tmpl <- paste0(val.label, ": %{x", val.spec, "}<br>",
cat.label, ": %{y}",
"<extra></extra>")
}
draw.seg <- if (orientation == "h") isTRUE(segments_x)
else isTRUE(segments_y)
panels <- vector("list", n.fac)
for (i in seq_along(fac.levels)) {
fac.lab <- fac.levels[i]
keep <- fac.char == fac.lab & !is.na(fac.char)
cats.i <- as.character(cats[keep])
vals.i <- as.numeric(vals[keep])
fin <- is.finite(vals.i)
pnl <- plotly::plot_ly()
if (any(fin) && draw.seg) {
# never above the panel's data minimum — avoid backward stems
panel.min <- min(vals.i[fin], na.rm = TRUE)
seg.start <- if (!is.null(origin_x)) min(origin_x, panel.min)
else 0L
pnl <- .dot_segment_trace(pnl, cats.i[fin], vals.i[fin], seg.color,
orientation, seg.start)
}
pnl <- .dot_marker_trace(pnl, cats.i, vals.i,
marker = .dot_marker_list(ms, length(vals.i),
color_override = unname(col.map[cats.i])),
orientation = orientation,
hover.tmpl = hover.tmpl)
val.lbl <- if (orientation == "h") x_lab else y_lab
cat.lbl <- if (orientation == "h") y_lab else x_lab
val.ax <- .dot_val_axis(if (i == 1L) val.lbl else "", gridT, origin_x,
axis_color = axis.x.clr,
text_color = axis.text.clr)
cat.ax <- .dot_cat_axis(cat.lbl, cats.i)
pnl <- plotly::layout(pnl,
xaxis = if (orientation == "h") val.ax else cat.ax,
yaxis = if (orientation == "h") cat.ax else val.ax,
template = NULL)
pnl$x$layout$plot_bgcolor <- .to_hex(style_opts$panel_fill)
pnl$x$layout$paper_bgcolor <- .to_hex(style_opts$window_fill)
panels[[i]] <- pnl
}
n.col.use <- facet_opts$n_col %||% min(n.fac, 3L)
n.row.use <- ceiling(n.fac / n.col.use)
plt <- plotly::subplot(panels,
nrows = n.row.use, shareX = TRUE, shareY = FALSE,
titleX = TRUE, titleY = FALSE, margin = 0.06)
# subplot() assigns domains automatically; extract them and hand to the
# shared facet-layout helper so annotation formatting matches hier/radar.
sub.domains <- lapply(seq_along(fac.levels), function(i) {
sfx <- if (i == 1L) "" else as.character(i)
xax <- plt$x$layout[[paste0("xaxis", sfx)]]
yax <- plt$x$layout[[paste0("yaxis", sfx)]]
list(x = xax$domain %||% c(0, 1),
y = yax$domain %||% c(0, 1))
})
ann <- .plotly_facet_layout(
facet_levels = fac.levels,
facet_name = if (!is.null(facet_name) && nzchar(facet_name))
facet_name else "",
domains = sub.domains,
yanchor = "bottom",
ann_adjust = function(i, a, d) {
a$y <- min(d$y[2] + 0.04, 0.99); a
}
)$annotations
# bare-label panels (facet_name was empty) — drop the leading ": "
if (is.null(facet_name) || !nzchar(facet_name))
ann <- lapply(seq_along(ann), function(i) {
ann[[i]]$text <- fac.levels[i]; ann[[i]]
})
plt <- plotly::layout(plt,
annotations = ann,
margin = list(
t = if (!is.null(main)) round(title.size * 2.2) else 40,
b = 8, l = 20, r = 20),
showlegend = FALSE,
title = .dot_title(main),
paper_bgcolor = .to_hex(style_opts$window_fill)
)
plt <- .finalize_plotly_widget(plt, kind="sp",
x_name=x_lab, by_name="",
add_title=FALSE,
nudge_viewer=(.allow.interactive() &&
!isTRUE(getOption("knitr.in.progress"))))
return(invisible(plt))
}
# ---- single-series dot plot ---------------------------------------------
# Layout: single panel, vertical or horizontal orientation.
pt_opacity <- max(0, min(1, as.numeric(pt_opacity[1])))
if (!is.finite(pt_opacity)) pt_opacity <- 0.95
cats <- as.character(cats)
vals <- as.numeric(vals)
# align lengths: ax.info$axL* may carry extra padding ticks beyond the data
cats <- cats[seq_along(vals)]
# Keep all categories on the axis — including those with NA vals — so that
# e.g. row_names with missing y shows all names, just no dot for missing.
# Remove only rows where the category label itself is NA.
keep.cats <- !is.na(cats)
cats <- cats[keep.cats]
vals <- vals[keep.cats]
cats.all <- cats # full list for categoryarray
if (length(cats) == 0L) return(plotly::plot_ly())
ms <- .dot_marker_style(shape, pt.size, fill, border, pt_opacity)
seg.color <- .to_hex(style_opts$segment_color)
# hover template — cat is %{x} or %{y} depending on orientation
val.fmt <- .get.tick.fmt(vals, digits_d)
val.spec <- if (nzchar(val.fmt)) paste0(":", val.fmt) else ""
if (orientation == "v") {
cat.label <- if (nzchar(x_lab)) x_lab else "Category"
val.label <- if (nzchar(y_lab)) y_lab else "Value"
hover.tmpl <- paste0(cat.label, ": %{x}<br>",
val.label, ": %{y", val.spec, "}<extra></extra>")
} else {
cat.label <- if (nzchar(y_lab)) y_lab else "Category"
val.label <- if (nzchar(x_lab)) x_lab else "Value"
hover.tmpl <- paste0(val.label, ": %{x", val.spec, "}<br>",
cat.label, ": %{y}<extra></extra>")
}
plt <- plotly::plot_ly()
# segments first so dots sit on top
draw.seg <- if (orientation == "h") isTRUE(segments_x)
else isTRUE(segments_y)
if (draw.seg) {
fin <- is.finite(vals)
plt <- .dot_segment_trace(plt, cats[fin], vals[fin], seg.color,
orientation,
seg.start = origin_x %||% 0L)
}
# one palette color per category, same hues as the bar chart
pt.cols <- .maketrans_plotly(.to_hex(rep_len(fill, length(vals))),
alpha = pt_opacity)
plt <- .dot_marker_trace(plt, cats, vals,
marker = .dot_marker_list(ms, length(vals),
color_override = pt.cols),
orientation = orientation,
hover.tmpl = hover.tmpl)
# axes: grid lines run perpendicular to the value axis
grid.shapes <- if (!is.null(gridT)) {
if (orientation == "v") y_grid(gridT) else x_grid(gridT)
} else list()
cat.ax <- .dot_cat_axis(if (orientation == "v") x_lab else y_lab, cats.all)
val.ax <- .dot_val_axis(if (orientation == "h") x_lab else y_lab,
gridT, origin_x)
if (orientation == "h") {
plt <- plotly::layout(plt,
xaxis = val.ax, yaxis = cat.ax,
shapes = c(grid.shapes, plot_border()),
margin = list(l = 70,
t = if (!is.null(main)) round(title.size * 2.2) else 30),
title = .dot_title(main),
template = NULL)
} else {
plt <- plotly::layout(plt,
xaxis = cat.ax, yaxis = val.ax,
shapes = c(grid.shapes, plot_border()),
margin = list(
t = if (!is.null(main)) round(title.size * 2.2) else 30,
b = 12),
title = .dot_title(main),
template = NULL)
}
if (!is.null(height)) plt$height <- as.integer(height * 96L)
plt$x$layout$plot_bgcolor <- .to_hex(style_opts$panel_fill)
plt$x$layout$paper_bgcolor <- .to_hex(style_opts$window_fill)
if (is.null(plt$x$layout$margin)) plt$x$layout$margin <- list()
b.default <- plt$x$layout$margin$b %||% 40
plt$x$layout$margin$b <- max(b.default, if (nzchar(x_lab)) 60 else 0)
plt <- .finalize_plotly_widget(
plt,
kind = "sp",
x_name = x_lab,
by_name = "",
add_title = FALSE,
nudge_viewer = TRUE
)
invisible(plt)
}
Try the lessR package in your browser
Any scripts or data that you put into this service are public.
lessR documentation built on June 21, 2026, 5:06 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions dot.plotly .dot_title .dot_cat_axis .dot_val_axis .dot_segment_trace .dot_marker_trace .dot_marker_list .dot_marker_style
# ----- shared helpers (private to dot.plotly) ---------------------------
# Used by the three dot.plotly paths (paired, faceted, single-series).
# Convert numeric shape codes to plotly symbol names and pre-compute
# the per-point marker geometry. Returns a list with symbol/px/color/border.
.dot_marker_style <- function(shape, pt.size, fill, border, pt_opacity) {
symbol <- switch(as.character(shape),
"21"="circle","22"="square","23"="diamond",
"24"="triangle-up","25"="triangle-down","circle"
)
px <- as.numeric(pt.size) * 10
if (!is.finite(px) || px <= 0) px <- 5
list(
symbol = symbol,
px = px,
color = .maketrans_plotly(fill[1], alpha = pt_opacity),
border = .to_hex(border[1])
)
}
# Assemble the marker= list a plotly scatter trace expects.
# Pass color_override to use a per-series color (paired dot).
.dot_marker_list <- function(ms, n, color_override = NULL) {
list(
symbol = ms$symbol,
size = rep(ms$px, n),
sizemode = "diameter",
color = color_override %||% ms$color,
opacity = 1,
line = list(color = ms$border, width = 1)
)
}
# Add a markers trace. cats/vals are placed on x/y per orientation
# ("v" = cats on x; "h" = cats on y).
.dot_marker_trace <- function(plt, cats, vals, marker, orientation,
hover.tmpl = NULL, name = NULL,
showlegend = FALSE) {
if (orientation == "v") { xv <- cats; yv <- vals }
else { xv <- vals; yv <- cats }
args <- list(plt, type = "scatter", mode = "markers",
x = xv, y = yv, marker = marker,
showlegend = showlegend, inherit = FALSE)
if (!is.null(hover.tmpl)) args$hovertemplate <- hover.tmpl
if (!is.null(name)) args$name <- name
do.call(plotly::add_trace, args)
}
# Add an NA-separated lines trace for the origin→value stems.
# cats/vals MUST be pre-filtered to finite values. seg.start is the
# axis position where each stem begins (caller decides the policy).
.dot_segment_trace <- function(plt, cats, vals, seg.color,
orientation, seg.start) {
n <- length(vals)
if (n == 0L) return(plt)
if (orientation == "v") {
seg.x <- as.vector(rbind(cats, cats, NA))
seg.y <- as.vector(rbind(rep(seg.start, n), vals, NA_real_))
} else {
seg.x <- as.vector(rbind(rep(seg.start, n), vals, NA_real_))
seg.y <- as.vector(rbind(cats, cats, NA))
}
plotly::add_trace(plt,
type = "scatter", mode = "lines",
x = seg.x, y = seg.y,
line = list(color = seg.color, width = 1),
hoverinfo = "skip",
showlegend = FALSE,
inherit = FALSE
)
}
# Build the numeric (value) axis spec. Sets range from origin_x + gridT
# and optionally applies axis/text colors.
.dot_val_axis <- function(label, gridT, origin_x,
axis_color = NULL, text_color = NULL) {
ax <- axis_num(label, gridT, NULL)
if (!is.null(origin_x) && !is.null(gridT)) {
step <- if (length(gridT) > 1L) gridT[2L] - gridT[1L] else 0
ax$range <- c(min(origin_x, min(gridT)), max(gridT) + step)
ax$autorange <- FALSE
}
if (!is.null(axis_color)) {
ax$linecolor <- .to_hex(axis_color)
ax$tickcolor <- .to_hex(axis_color)
}
if (!is.null(text_color))
ax$tickfont$color <- .to_hex(text_color)
ax
}
# Build the category axis spec, freezing the order to the supplied cats.
.dot_cat_axis <- function(label, cats) {
c(
axis_cat(label),
list(
categoryorder = "array",
categoryarray = cats,
tickmode = "array",
tickvals = cats,
ticktext = cats
)
)
}
# Shared plotly layout title= spec for the dot chart.
.dot_title <- function(main) {
if (is.null(main)) NULL
else list(text = main, x = 0.5, xanchor = "center",
y = 0.98, yanchor = "top",
font = list(size = round(
16 * getOption("main_size", 1))))
}
dot.plotly <- function(
x, # category labels (vector) or paired-dot data frame
y, # numeric values (vector or data frame for paired)
orientation = "v", # "v" = vertical (cats on x-axis)
# "h" = horizontal (cats on y-axis)
fill, border, shape, pt.size,
x_lab = "", # x-axis label
y_lab = "", # y-axis label
digits_d = 2,
pt_opacity = 0.95,
gridT = NULL, # tick positions for grid lines on the value axis
origin_x = NULL, # x-axis origin; NULL = auto (from gridT min)
height = NULL, # plot height in inches; NULL lets plotly auto-size
facet = NULL, # factor vector: one facet level per observation
# (cats/vals MUST already be aggregated + sorted)
facet_name = NULL, # display name for the facet variable
facet_opts = .plotly_facet_opts(), # n_row/n_col read here (grid layout)
main = NULL, # chart title (faceted path only)
segments_x = TRUE, # draw segment from origin to each dot (horizontal orientation)
segments_y = TRUE, # draw segment from origin to each dot (vertical orientation)
style_opts = .plotly_style()
) {
# internal aliases preserve descriptive names throughout the function body
cats <- x
vals <- y
title.size <- round(16 * getOption("main_size", 1))
# ---- paired dot plot (vals is a data frame with 2+ columns) -------------
# Layout: single panel, cats on y, values on x (orientation "h").
# Each y-column becomes a series with its own marker color + legend entry.
if (is.data.frame(vals)) {
cats.all <- as.character(cats)
n <- length(cats.all)
ms <- .dot_marker_style(shape = 21, pt.size = pt.size,
fill = fill, border = border,
pt_opacity = pt_opacity)
seg.color.hex <- .to_hex(style_opts$segment_color)
axis.x.clr <- style_opts$axis_x_color %||% style_opts$axis_color
axis.text.clr <- style_opts$axis_text_color
plt <- plotly::plot_ly()
for (si in seq_len(ncol(vals))) {
vals.si <- as.numeric(vals[[si]])
clr <- .maketrans_plotly(fill[si], alpha = pt_opacity)
if (isTRUE(segments_x))
plt <- .dot_segment_trace(plt, cats.all, vals.si, seg.color.hex,
"h", seg.start = origin_x)
plt <- .dot_marker_trace(plt, cats.all, vals.si,
marker = .dot_marker_list(ms, length(vals.si),
color_override = clr),
orientation = "h",
name = names(vals)[si],
showlegend = TRUE)
}
val.ax <- .dot_val_axis(x_lab, gridT, origin_x,
axis_color = axis.x.clr,
text_color = axis.text.clr)
cat.ax <- .dot_cat_axis(y_lab, cats.all)
plt <- plotly::layout(plt,
xaxis = val.ax,
yaxis = cat.ax,
shapes = c(x_grid(gridT), plot_border()),
margin = list(
t = if (!is.null(main)) round(title.size * 2.2) else 30),
title = .dot_title(main),
legend = list(font = list(size = round(
16 * getOption("axis_size", 0.9)))),
template = NULL
)
plt$x$layout$plot_bgcolor <- .to_hex(style_opts$panel_fill)
plt$x$layout$paper_bgcolor <- .to_hex(style_opts$window_fill)
plt <- .finalize_plotly_widget(plt, kind = "sp",
x_name = x_lab, by_name = "", add_title = FALSE,
nudge_viewer = (.allow.interactive() &&
!isTRUE(getOption("knitr.in.progress"))))
return(invisible(plt))
}
# ---- faceted dot plot ---------------------------------------------------
# Layout: subplot grid of single panels; each panel is one facet level.
# Per-panel segment start is clamped at-or-below panel min so dots never
# sit to the left of (or below) their stem.
if (!is.null(facet)) {
fac.char <- as.character(facet)
fac.levels <- sort(unique(fac.char[!is.na(fac.char)]))
n.fac <- length(fac.levels)
ms <- .dot_marker_style(shape, pt.size, fill, border,
pt_opacity)
# color keyed by category name so hues match across facet panels
cat.levels <- unique(as.character(cats[!is.na(cats)]))
col.map <- setNames(
.maketrans_plotly(.to_hex(rep_len(fill,
length(cat.levels))),
alpha = pt_opacity),
cat.levels)
seg.color <- .to_hex(style_opts$segment_color)
axis.x.clr <- style_opts$axis_x_color %||% style_opts$axis_color
axis.text.clr <- style_opts$axis_text_color
val.fmt <- .get.tick.fmt(vals[is.finite(vals)], digits_d)
val.spec <- if (nzchar(val.fmt)) paste0(":", val.fmt) else ""
if (orientation == "v") {
cat.label <- if (nzchar(x_lab)) x_lab else "Category"
val.label <- if (nzchar(y_lab)) y_lab else "Value"
hover.tmpl <- paste0(cat.label, ": %{x}<br>",
val.label, ": %{y", val.spec, "}",
"<extra></extra>")
} else {
cat.label <- if (nzchar(y_lab)) y_lab else "Category"
val.label <- if (nzchar(x_lab)) x_lab else "Value"
hover.tmpl <- paste0(val.label, ": %{x", val.spec, "}<br>",
cat.label, ": %{y}",
"<extra></extra>")
}
draw.seg <- if (orientation == "h") isTRUE(segments_x)
else isTRUE(segments_y)
panels <- vector("list", n.fac)
for (i in seq_along(fac.levels)) {
fac.lab <- fac.levels[i]
keep <- fac.char == fac.lab & !is.na(fac.char)
cats.i <- as.character(cats[keep])
vals.i <- as.numeric(vals[keep])
fin <- is.finite(vals.i)
pnl <- plotly::plot_ly()
if (any(fin) && draw.seg) {
# never above the panel's data minimum — avoid backward stems
panel.min <- min(vals.i[fin], na.rm = TRUE)
seg.start <- if (!is.null(origin_x)) min(origin_x, panel.min)
else 0L
pnl <- .dot_segment_trace(pnl, cats.i[fin], vals.i[fin], seg.color,
orientation, seg.start)
}
pnl <- .dot_marker_trace(pnl, cats.i, vals.i,
marker = .dot_marker_list(ms, length(vals.i),
color_override = unname(col.map[cats.i])),
orientation = orientation,
hover.tmpl = hover.tmpl)
val.lbl <- if (orientation == "h") x_lab else y_lab
cat.lbl <- if (orientation == "h") y_lab else x_lab
val.ax <- .dot_val_axis(if (i == 1L) val.lbl else "", gridT, origin_x,
axis_color = axis.x.clr,
text_color = axis.text.clr)
cat.ax <- .dot_cat_axis(cat.lbl, cats.i)
pnl <- plotly::layout(pnl,
xaxis = if (orientation == "h") val.ax else cat.ax,
yaxis = if (orientation == "h") cat.ax else val.ax,
template = NULL)
pnl$x$layout$plot_bgcolor <- .to_hex(style_opts$panel_fill)
pnl$x$layout$paper_bgcolor <- .to_hex(style_opts$window_fill)
panels[[i]] <- pnl
}
n.col.use <- facet_opts$n_col %||% min(n.fac, 3L)
n.row.use <- ceiling(n.fac / n.col.use)
plt <- plotly::subplot(panels,
nrows = n.row.use, shareX = TRUE, shareY = FALSE,
titleX = TRUE, titleY = FALSE, margin = 0.06)
# subplot() assigns domains automatically; extract them and hand to the
# shared facet-layout helper so annotation formatting matches hier/radar.
sub.domains <- lapply(seq_along(fac.levels), function(i) {
sfx <- if (i == 1L) "" else as.character(i)
xax <- plt$x$layout[[paste0("xaxis", sfx)]]
yax <- plt$x$layout[[paste0("yaxis", sfx)]]
list(x = xax$domain %||% c(0, 1),
y = yax$domain %||% c(0, 1))
})
ann <- .plotly_facet_layout(
facet_levels = fac.levels,
facet_name = if (!is.null(facet_name) && nzchar(facet_name))
facet_name else "",
domains = sub.domains,
yanchor = "bottom",
ann_adjust = function(i, a, d) {
a$y <- min(d$y[2] + 0.04, 0.99); a
}
)$annotations
# bare-label panels (facet_name was empty) — drop the leading ": "
if (is.null(facet_name) || !nzchar(facet_name))
ann <- lapply(seq_along(ann), function(i) {
ann[[i]]$text <- fac.levels[i]; ann[[i]]
})
plt <- plotly::layout(plt,
annotations = ann,
margin = list(
t = if (!is.null(main)) round(title.size * 2.2) else 40,
b = 8, l = 20, r = 20),
showlegend = FALSE,
title = .dot_title(main),
paper_bgcolor = .to_hex(style_opts$window_fill)
)
plt <- .finalize_plotly_widget(plt, kind="sp",
x_name=x_lab, by_name="",
add_title=FALSE,
nudge_viewer=(.allow.interactive() &&
!isTRUE(getOption("knitr.in.progress"))))
return(invisible(plt))
}
# ---- single-series dot plot ---------------------------------------------
# Layout: single panel, vertical or horizontal orientation.
pt_opacity <- max(0, min(1, as.numeric(pt_opacity[1])))
if (!is.finite(pt_opacity)) pt_opacity <- 0.95
cats <- as.character(cats)
vals <- as.numeric(vals)
# align lengths: ax.info$axL* may carry extra padding ticks beyond the data
cats <- cats[seq_along(vals)]
# Keep all categories on the axis — including those with NA vals — so that
# e.g. row_names with missing y shows all names, just no dot for missing.
# Remove only rows where the category label itself is NA.
keep.cats <- !is.na(cats)
cats <- cats[keep.cats]
vals <- vals[keep.cats]
cats.all <- cats # full list for categoryarray
if (length(cats) == 0L) return(plotly::plot_ly())
ms <- .dot_marker_style(shape, pt.size, fill, border, pt_opacity)
seg.color <- .to_hex(style_opts$segment_color)
# hover template — cat is %{x} or %{y} depending on orientation
val.fmt <- .get.tick.fmt(vals, digits_d)
val.spec <- if (nzchar(val.fmt)) paste0(":", val.fmt) else ""
if (orientation == "v") {
cat.label <- if (nzchar(x_lab)) x_lab else "Category"
val.label <- if (nzchar(y_lab)) y_lab else "Value"
hover.tmpl <- paste0(cat.label, ": %{x}<br>",
val.label, ": %{y", val.spec, "}<extra></extra>")
} else {
cat.label <- if (nzchar(y_lab)) y_lab else "Category"
val.label <- if (nzchar(x_lab)) x_lab else "Value"
hover.tmpl <- paste0(val.label, ": %{x", val.spec, "}<br>",
cat.label, ": %{y}<extra></extra>")
}
plt <- plotly::plot_ly()
# segments first so dots sit on top
draw.seg <- if (orientation == "h") isTRUE(segments_x)
else isTRUE(segments_y)
if (draw.seg) {
fin <- is.finite(vals)
plt <- .dot_segment_trace(plt, cats[fin], vals[fin], seg.color,
orientation,
seg.start = origin_x %||% 0L)
}
# one palette color per category, same hues as the bar chart
pt.cols <- .maketrans_plotly(.to_hex(rep_len(fill, length(vals))),
alpha = pt_opacity)
plt <- .dot_marker_trace(plt, cats, vals,
marker = .dot_marker_list(ms, length(vals),
color_override = pt.cols),
orientation = orientation,
hover.tmpl = hover.tmpl)
# axes: grid lines run perpendicular to the value axis
grid.shapes <- if (!is.null(gridT)) {
if (orientation == "v") y_grid(gridT) else x_grid(gridT)
} else list()
cat.ax <- .dot_cat_axis(if (orientation == "v") x_lab else y_lab, cats.all)
val.ax <- .dot_val_axis(if (orientation == "h") x_lab else y_lab,
gridT, origin_x)
if (orientation == "h") {
plt <- plotly::layout(plt,
xaxis = val.ax, yaxis = cat.ax,
shapes = c(grid.shapes, plot_border()),
margin = list(l = 70,
t = if (!is.null(main)) round(title.size * 2.2) else 30),
title = .dot_title(main),
template = NULL)
} else {
plt <- plotly::layout(plt,
xaxis = cat.ax, yaxis = val.ax,
shapes = c(grid.shapes, plot_border()),
margin = list(
t = if (!is.null(main)) round(title.size * 2.2) else 30,
b = 12),
title = .dot_title(main),
template = NULL)
}
if (!is.null(height)) plt$height <- as.integer(height * 96L)
plt$x$layout$plot_bgcolor <- .to_hex(style_opts$panel_fill)
plt$x$layout$paper_bgcolor <- .to_hex(style_opts$window_fill)
if (is.null(plt$x$layout$margin)) plt$x$layout$margin <- list()
b.default <- plt$x$layout$margin$b %||% 40
plt$x$layout$margin$b <- max(b.default, if (nzchar(x_lab)) 60 else 0)
plt <- .finalize_plotly_widget(
plt,
kind = "sp",
x_name = x_lab,
by_name = "",
add_title = FALSE,
nudge_viewer = TRUE
)
invisible(plt)
}
Try the lessR package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.