R/facet_stereo.R

Defines functions facet_stereo

Documented in facet_stereo

#' 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
  }
)

Try the ggforce package in your browser

Any scripts or data that you put into this service are public.

ggforce documentation built on Oct. 4, 2022, 5:07 p.m.