Skip to content

Commit

Permalink
Improve auto labels in plot methods
Browse files Browse the repository at this point in the history
  • Loading branch information
@nfrerebeau
nfrerebeau committed Apr 2, 2024
1 parent e41f7c9 commit 38deda7
Show file tree
Hide file tree
Showing 14 changed files with 207 additions and 131 deletions.
1 change: 1 addition & 0 deletions NAMESPACE
View file
Expand Up @@ -19,6 +19,7 @@ export(plot_individuals)
export(plot_rows)
export(plot_variables)
export(plot_variance)
export(viz_labels)
exportClasses(CA)
exportClasses(MCA)
exportClasses(PCA)
Expand Down
8 changes: 8 additions & 0 deletions R/AllGenerics.R
View file
Expand Up @@ -528,6 +528,10 @@ NULL
#'
#' Plots row/individual principal coordinates.
#' @inheritParams viz_points
#' @param labels_max An [`integer`] specifying the number of labels to draw.
#' Only the labels of the \eqn{n} observations with highest \eqn{cos^2}{cos2}
#' values will be drawn. If `NULL`, all labels are drawn.
#' Only used if `labels` is `TRUE`.
#' @param ... Further [graphical parameters][graphics::par] (see details).
#' @details
#' Commonly used [graphical parameters][graphics::par] are:
Expand Down Expand Up @@ -569,6 +573,10 @@ setGeneric(
#'
#' Plots column/variable principal coordinates.
#' @inheritParams viz_points
#' @param labels_max An [`integer`] specifying the number of labels to draw.
#' Only the labels of the \eqn{n} variables contributing the most to the
#' factorial map will be drawn. If `NULL`, all labels are drawn.
#' Only used if `labels` is `TRUE`.
#' @details
#' Commonly used [graphical parameters][graphics::par] are:
#' \describe{
Expand Down
16 changes: 12 additions & 4 deletions R/biplot.R
View file
Expand Up @@ -213,12 +213,20 @@ viz_biplot <- function(coord_row, coord_col, ..., rows = TRUE, columns = TRUE,
if (!is.null(labels)) {
labels <- match.arg(labels, several.ok = TRUE)
if (any(labels == "rows") | any(labels == "individuals")) {
viz_labels(x = coord_row$x, y = coord_row$y, labels = coord_row$label,
top = NULL, col = coord_row$col, cex = coord_row$cex)
arkhe::label_auto(
x = coord_row$x, y = coord_row$y,
labels = coord_row$label,
cex = coord_row$cex,
col = coord_row$col
)
}
if (any(labels == "columns") | any(labels == "variables")) {
viz_labels(x = coord_col$x, y = coord_col$y, labels = coord_col$label,
top = NULL, col = coord_col$col, cex = coord_col$cex)
arkhe::label_auto(
x = coord_col$x, y = coord_col$y,
labels = coord_col$label,
cex = coord_col$cex,
col = coord_col$col
)
}
}

Expand Down
66 changes: 46 additions & 20 deletions R/dimensio-internal.R
View file
Expand Up @@ -139,6 +139,7 @@ drop_variable <- function(x, f, negate = FALSE, sup = NULL, extra = NULL,
#' \item{`y`}{Coordinates along y.}
#' \item{`z`}{Variable to be highlighted.}
#' \item{`label`}{Label.}
#' \item{`sup`}{Is supplementary?}
#' \item{`col`}{Color for lines and points.}
#' \item{`bg`}{Background color.}
#' \item{`pch`}{Symbol.}
Expand All @@ -148,25 +149,36 @@ drop_variable <- function(x, f, negate = FALSE, sup = NULL, extra = NULL,
#' }
#' @author N. Frerebeau
#' @keywords internal
prepare <- function(x, margin, ..., axes = c(1, 2), active = TRUE,
sup = TRUE, principal = TRUE, highlight = NULL,
prepare <- function(x, margin, axes = c(1, 2), active = TRUE,
sup = TRUE, principal = TRUE,
highlight = NULL, reorder = TRUE,
col = NULL, bg = NULL, pch = 16, cex = NULL,
lty = NULL, lwd = NULL, alpha = FALSE) {
## Prepare data
data <- augment(x, margin = margin, axes = axes, principal = principal)

## Subset
if (active & !sup) data <- data[!data$supplementary, , drop = FALSE]
if (!active & sup) data <- data[data$supplementary, , drop = FALSE]
n <- nrow(data)

## Highlight
data$observation <- "active"
data$observation[data$supplementary] <- "suppl."
## Reorder
## /!\ see build_results() /!\
origin <- get_order(x, margin = margin)
if (length(highlight) > 1) {
arkhe::assert_length(highlight, n)
highlight <- highlight[get_order(x, margin = margin)]
if (reorder) highlight <- highlight[origin]
}
if (reorder) {
if (length(col) == n) col <- col[origin]
if (length(bg) == n) bg <- bg[origin]
if (length(pch) == n) pch <- pch[origin]
if (length(lty) == n) lty <- lty[origin]
if (length(cex) == n) cex <- cex[origin]
if (length(lwd) == n) lwd <- lwd[origin]
}

## Recode
data$observation <- "active"
data$observation[data$supplementary] <- "suppl."

## Highlight
if (length(highlight) == 1) {
high <- NULL
if (has_extra(x)) {
Expand All @@ -184,39 +196,50 @@ prepare <- function(x, margin, ..., axes = c(1, 2), active = TRUE,
## Colors
col <- scale_color(x = highlight, col = col, alpha = alpha)
bg <- scale_color(x = highlight, col = bg, alpha = alpha)

if (length(pch) == 1) pch <- rep(pch, length.out = n)
if (length(lty) == 1) lty <- rep(lty, length.out = n)
if (length(cex) == 1) cex <- rep(cex, length.out = n)
if (length(lwd) == 1) lwd <- rep(lwd, length.out = n)
if (!is.double(highlight)) { # Discrete scales
## Symbol
if (length(pch) == 1) pch <- rep(pch, length.out = n)
pch <- scale_symbol(x = highlight, symb = pch, what = "pch")
## Size
cex <- cex %||% graphics::par("cex")
## Line type
lty <- scale_symbol(x = highlight, symb = lty, what = "lty")
## Size
cex <- cex %||% graphics::par("cex")
## Line width
lwd <- lwd %||% graphics::par("lwd")
} else { # Continuous scales
## Symbol
pch <- pch %||% graphics::par("pch")
## Size
cex <- scale_size(x = highlight, size = cex, what = "cex")
## Line type
lty <- lty %||% graphics::par("lty")
## Size
cex <- scale_size(x = highlight, size = cex, what = "cex")
## Line width
lwd <- scale_size(x = highlight, size = lwd, what = "lwd")
}

data.frame(
coord <- data.frame(
x = data[[1]],
y = data[[2]],
z = highlight %||% character(n),
label = data$label,
sup = data$supplementary,
col = col,
bg = bg,
pch = pch,
cex = cex,
lty = lty,
lwd = lwd
)

## Subset
if (active & !sup) coord <- coord[!coord$sup, , drop = FALSE]
if (!active & sup) coord <- coord[coord$sup, , drop = FALSE]

coord
}

#' Build a Legend
Expand All @@ -231,7 +254,7 @@ prepare <- function(x, margin, ..., axes = c(1, 2), active = TRUE,
#' @keywords internal
prepare_legend <- function(x, args, points = TRUE, lines = TRUE) {
h <- x$z

h <- h[!is.na(h)]
if (!is.null(h) && length(unique(h)) > 1 && is.list(args) && length(args) > 0) {
if (is.double(h)) {
## Continuous scale
Expand Down Expand Up @@ -275,10 +298,11 @@ prepare_legend <- function(x, args, points = TRUE, lines = TRUE) {
}

scale_color <- function(x, col = NULL, alpha = FALSE) {
if (is.null(x)) {
if (is.null(x) || all(is.na(x))) {
col <- col %||% graphics::par("col")
return(col)
}
if (length(col) == length(x)) return(col)

if (is.double(x)) {
## Continuous scale
Expand All @@ -292,18 +316,20 @@ scale_color <- function(x, col = NULL, alpha = FALSE) {
col
}
scale_symbol <- function(x, symb = NULL, what = "pch") {
if (is.null(x)) {
if (is.null(x) || all(is.na(x))) {
symb <- symb %||% graphics::par(what)
return(symb)
}
if (length(symb) == length(x)) return(symb)

arkhe::palette_shape(x = x, palette = symb)
}
scale_size <- function(x, size = NULL, what = "cex") {
if (is.null(x)) {
if (is.null(x) || all(is.na(x))) {
size <- size %||% graphics::par(what)
return(size)
}
if (length(size) == length(x)) return(size)

arkhe::palette_size(x = x, palette = size)
}
Expand Down
41 changes: 25 additions & 16 deletions R/viz_coordinates.R
View file
Expand Up @@ -10,12 +10,13 @@ setMethod(
f = "viz_rows",
signature = c(x = "MultivariateAnalysis"),
definition = function(x, ..., axes = c(1, 2), active = TRUE, sup = TRUE,
labels = FALSE, labels_top = 10, highlight = NULL,
labels = FALSE, labels_max = 10, highlight = NULL,
xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
panel.first = NULL, panel.last = NULL,
legend = list(x = "topleft")) {
viz_points(x, margin = 1, axes = axes, active = active, sup = sup,
labels = labels, labels_top = labels_top, highlight = highlight,
labels = labels, labels_max = labels_max,
labels_what = "cos2", highlight = highlight,
xlim = xlim, ylim = ylim, main = main, sub = sub,
panel.first = panel.first, panel.last = panel.last,
legend = legend, ...)
Expand Down Expand Up @@ -45,12 +46,13 @@ setMethod(
f = "viz_individuals",
signature = c(x = "PCA"),
definition = function(x, ..., axes = c(1, 2), active = TRUE, sup = TRUE,
labels = FALSE, labels_top = 10, highlight = NULL,
labels = FALSE, labels_max = 10, highlight = NULL,
xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
panel.first = NULL, panel.last = NULL,
legend = list(x = "topleft")) {
viz_points(x, margin = 1, axes = axes, active = active, sup = sup,
labels = labels, labels_top = labels_top, highlight = highlight,
labels = labels, labels_max = labels_max,
labels_what = "cos2", highlight = highlight,
xlim = xlim, ylim = ylim, main = main, sub = sub,
panel.first = panel.first, panel.last = panel.last,
legend = legend, ...)
Expand All @@ -66,12 +68,13 @@ setMethod(
f = "viz_columns",
signature = c(x = "MultivariateAnalysis"),
definition = function(x, ..., axes = c(1, 2), active = TRUE, sup = TRUE,
labels = FALSE, labels_top = 10, highlight = NULL,
labels = FALSE, labels_max = 10, highlight = NULL,
xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
panel.first = NULL, panel.last = NULL,
legend = list(x = "topleft")) {
viz_points(x, margin = 2, axes = axes, active = active, sup = sup,
labels = labels, labels_top = labels_top, highlight = highlight,
labels = labels, labels_max = labels_max,
labels_what = "contribution", highlight = highlight,
xlim = xlim, ylim = ylim, main = main, sub = sub,
panel.first = panel.first, panel.last = panel.last,
legend = legend, ...)
Expand Down Expand Up @@ -101,7 +104,7 @@ setMethod(
f = "viz_variables",
signature = c(x = "PCA"),
definition = function(x, ..., axes = c(1, 2), active = TRUE, sup = TRUE,
labels = TRUE, labels_top = 10, highlight = NULL,
labels = TRUE, labels_max = 10, highlight = NULL,
xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
panel.first = NULL, panel.last = NULL,
legend = list(x = "topleft")) {
Expand Down Expand Up @@ -147,9 +150,11 @@ setMethod(
)

## Labels
if (labels && nrow(coord) > 1) {
viz_labels(x = x, labels = coord$label, margin = 2, axes = axes,
top = labels_top, col = coord$col, cex = coord$cex)
if (!isFALSE(labels)) {
origin <- get_order(x, margin = 2)
viz_labels(x, margin = 2, axes = axes, active = active, sup = sup,
highlight = "contribution", top = labels_max,
col = coord$col, cex = coord$cex, reorder = FALSE)
}

## Evaluate post-plot and pre-axis expressions
Expand Down Expand Up @@ -189,12 +194,13 @@ setMethod(
f = "viz_variables",
signature = c(x = "CA"),
definition = function(x, ..., axes = c(1, 2), active = TRUE, sup = TRUE,
labels = FALSE, labels_top = 10, highlight = NULL,
labels = FALSE, labels_max = 10, highlight = NULL,
xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
panel.first = NULL, panel.last = NULL,
legend = list(x = "topleft")) {
viz_points(x, margin = 2, axes = axes, active = active, sup = sup,
labels = labels, labels_top = labels_top, highlight = highlight,
labels = labels, labels_max = labels_max,
labels_what = "contribution", highlight = highlight,
xlim = xlim, ylim = ylim, main = main, sub = sub,
panel.first = panel.first, panel.last = panel.last,
legend = legend, ...)
Expand All @@ -220,10 +226,12 @@ setMethod(
#'
#' @param x A [`CA-class`], [`MCA-class`] or [`PCA-class`] object.
#' @param labels A [`logical`] scalar: should labels be drawn?
#' @param labels_top An [`integer`] specifying the number of labels to draw.
#' @param labels_max An [`integer`] specifying the number of labels to draw.
#' Only the labels of the `top` \eqn{n} observations contributing the most to
#' the factorial map will be drawn. If `NULL`, all labels are drawn.
#' Only used if `labels` is `TRUE`.
#' @param labels_what A [`character`] string specifying how to select the
#' labels to be drawn.
#' @param xlim A length-two [`numeric`] vector giving the x limits of the plot.
#' The default value, `NULL`, indicates that the range of the
#' [finite][is.finite()] values to be plotted should be used.
Expand Down Expand Up @@ -251,7 +259,7 @@ setMethod(
#' @keywords internal
viz_points <- function(x, margin, axes, ...,
active = TRUE, sup = TRUE,
labels = FALSE, labels_top = 10,
labels = FALSE, labels_max = 10, labels_what = NULL,
highlight = NULL, xlim = NULL, ylim = NULL,
main = NULL, sub = NULL, xlab = NULL, ylab = NULL,
ann = graphics::par("ann"), frame.plot = TRUE,
Expand Down Expand Up @@ -293,8 +301,9 @@ viz_points <- function(x, margin, axes, ...,

## Labels
if (!isFALSE(labels)) {
viz_labels(x = x, labels = coord$label, margin = margin, axes = axes,
top = labels_top, col = coord$col, cex = coord$cex)
viz_labels(x, margin = margin, axes = axes, active = active, sup = sup,
highlight = labels_what, top = labels_max,
col = coord$col, cex = coord$cex, reorder = FALSE)
}

## Evaluate post-plot and pre-axis expressions
Expand Down

0 comments on commit 38deda7

Please sign in to comment.