Nothing
#' Create a stereogram plot
#'
#' This, arguably pretty useless function, lets you create plots with a sense of
#' depth by creating two slightly different versions of the plot that
#' corresponds to how the eyes would see it if the plot was 3 dimensional. To
#' experience the effect look at the plots through 3D hardware such as Google
#' Cardboard or by relaxing the eyes and focusing into the distance. The
#' depth of a point is calculated for layers having a depth aesthetic supplied.
#' The scaling of the depth can be controlled with [scale_depth()] as
#' you would control any aesthetic. Negative values will result in features
#' placed behind the paper plane, while positive values will result in
#' features hovering in front of the paper. While features within each layer is
#' sorted so those closest to you are plotted on top of those more distant, this
#' cannot be done between layers. Thus, layers are always plotted on top of
#' each others, even if the features in one layer lies behind features in a
#' layer behind it. The depth experience is inaccurate and should not be used
#' for conveying important data. Regard this more as a party-trick...
#'
#' @param IPD The interpupillary distance (in mm) used for calculating point
#' displacement. The default value is an average of both genders
#'
#' @param panel.size The final plot size in mm. As IPD this is used to calculate
#' point displacement. Don't take this value too literal but experiment until
#' you get a nice effect. Lower values gives higher displacement and thus
#' require the plots to be observed from a closer distance
#'
#' @inheritParams ggplot2::facet_wrap
#'
#' @family ggforce facets
#'
#' @export
#'
#' @examples
#' # You'll have to accept a warning about depth being an unknown aesthetic
#' ggplot(mtcars) +
#' geom_point(aes(mpg, disp, depth = cyl)) +
#' facet_stereo()
facet_stereo <- function(IPD = 63.5, panel.size = 200, shrink = TRUE) {
ggproto(NULL, FacetStereo,
shrink = shrink,
params = list(
IPD = IPD, panel.size = panel.size
)
)
}
#' @rdname ggforce-extensions
#' @format NULL
#' @usage NULL
#' @importFrom scales rescale
#' @importFrom gtable gtable_add_cols
#' @export
FacetStereo <- ggproto('FacetStereo', Facet,
compute_layout = function(data, params) {
data_frame0(PANEL = c(1L, 2L), SCALE_X = 1L, SCALE_Y = 1L)
},
map_data = function(data, layout, params) {
if (empty(data)) {
return(cbind(data, PANEL = integer(0)))
}
vec_rbind(
cbind(data, PANEL = 1L),
cbind(data, PANEL = 2L)
)
},
finish_data = function(data, layout, x_scales, y_scales, params) {
if ('depth' %in% names(data)) {
if ('.interp' %in% names(data)) {
data$depth2 <- vec_rbind(!!!lapply(split(data, data$PANEL), interpolateDataFrame))$depth
} else {
data$depth2 <- data$depth
}
group_order <- order(
sapply(split(data$depth2, data$group), quantile, probs = 0.9,
na.rm = TRUE)
)
data <- vec_rbind(!!!split(data, data$group)[group_order])
data[data$group == -1, ] <- data[data$group == -1, ][order(data$depth2[data$group == -1]), ]
data$group[data$group != -1] <- match(data$group[data$group != -1],
unique0(data$group[data$group != -1]))
x_range <- x_scales[[1]]$dimension(expand_default(x_scales[[1]]))
k <- ifelse(data$PANEL == 1, -1, 1) * params$IPD / 2
x_transform <- function(d) {
h <- rescale(d, to = c(-1, 1) * params$panel.size / 2, from = x_range)
new_pos <- h + (h - k) * data$depth2
rescale(new_pos, to = x_range, from = c(-1, 1) * params$panel.size / 2)
}
data <- transform_position(data, x_transform)
data$depth2 <- NULL
}
data
},
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord,
data, theme, params) {
axes <- render_axes(ranges, ranges, coord, theme, FALSE)
panelGrobs <- create_panels(panels, axes$x, axes$y)
spacing <- theme$panel.spacing.x %||% theme$panel.spacing
panel <- gtable_add_cols(panelGrobs[[1]], spacing)
cbind(panel, panelGrobs[[2]], size = 'first')
},
draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data,
theme, labels, params) {
panel_dim <- find_panel(panels)
xlab_height_top <- grobHeight(labels$x[[1]])
panels <- gtable_add_rows(panels, xlab_height_top, pos = 0)
panels <- gtable_add_grob(panels, labels$x[[1]],
name = 'xlab-t',
l = panel_dim$l, r = panel_dim$r, t = 1, clip = 'off'
)
xlab_height_bottom <- grobHeight(labels$x[[2]])
panels <- gtable_add_rows(panels, xlab_height_bottom, pos = -1)
panels <- gtable_add_grob(panels, labels$x[[2]],
name = 'xlab-b',
l = panel_dim$l, r = panel_dim$r, t = -1, clip = 'off'
)
panel_dim <- find_panel(panels)
ylab_width_left <- grobWidth(labels$y[[1]])
panels <- gtable_add_cols(panels, ylab_width_left, pos = 0)
panels <- gtable_add_grob(panels, labels$y[[1]],
name = 'ylab-l',
l = 1, b = panel_dim$b, t = panel_dim$t, clip = 'off'
)
ylab_width_right <- grobWidth(labels$y[[2]])
panels <- gtable_add_cols(panels, ylab_width_right, pos = -1)
panels <- gtable_add_grob(panels, labels$y[[2]],
name = 'ylab-r',
l = -1, b = panel_dim$b, t = panel_dim$t, clip = 'off'
)
panels
}
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.