File: axis_canvas.R

package info (click to toggle)
r-cran-cowplot 1.1.3%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 1,564 kB
  • sloc: sh: 13; makefile: 5
file content (199 lines) | stat: -rw-r--r-- 8,169 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
#' Insert an axis-like grob on either side of a plot panel in a [ggplot2] plot.
#'
#' The function `insert_xaxis_grob()` inserts a grob at the top or bottom of the plot panel in a [ggplot2] plot.
#'
#' For usage examples, see [axis_canvas()].
#' @param plot The plot into which the grob will be inserted.
#' @param grob The grob to insert. This will generally have been obtained via [get_panel()]
#'   from a ggplot2 object, in particular one generated with [axis_canvas()]. If a ggplot2
#'   plot is provided instead of a grob, then [get_panel()] is called to extract the
#'   panel grob.
#' @param width The width of the grob, in grid units. Used by `insert_yaxis_grob()`.
#' @param height The height of the grob, in grid units. Used by `insert_xaxis_grob()`.
#' @param position The position of the grob. Can be `"right"` or `"left"` for `insert_yaxis_grob()`
#'   and `"top"` or `"botton"` for `insert_xaxis_grob()`.
#' @param clip Set to "off" to turn off clipping of the inserted grob.
#' @export
insert_xaxis_grob <- function(plot, grob, height = grid::unit(0.2, "null"),
                              position = c("top", "bottom"), clip = "on")
{
  # if a plot is provided instead of a grob we extract the panel from that plot
  if (methods::is(grob, "ggplot")){
    grob <- get_panel(grob)
  }

  gt <- as_gtable(plot)

  pp <- gt$layout[gt$layout$name == "panel",]
  if (nrow(pp) != 1)
  {
    stop("Can only insert grob on plots with exactly one panel.")
  }

  if (position[1] == "top") {
    g <- gtable::gtable_add_rows(gt, height, pp$t-1)
    g <- gtable::gtable_add_grob(g, grob, pp$t, pp$l, pp$t, pp$r, clip = clip, name="xaxis-grob-t")
  }
  else {
    g <- gtable::gtable_add_rows(gt, height, pp$b)
    g <- gtable::gtable_add_grob(g, grob, pp$b+1, pp$l, pp$b+1, pp$r, clip = clip, name="xaxis-grob-b")
  }
}

#' The function `insert_yaxis_grob()` inserts a grob to the right or left of the plot panel in a [ggplot2] plot.
#'
#' @rdname insert_xaxis_grob
#' @export
insert_yaxis_grob <- function(plot, grob, width = grid::unit(0.2, "null"),
                              position = c("right", "left"), clip = "on")
{
  # if a plot is provided instead of a grob we extract the panel from that plot
  if (methods::is(grob, "ggplot")){
    grob <- get_panel(grob)
  }

  gt <- as_gtable(plot)

  pp <- gt$layout[gt$layout$name == "panel",]
  if (nrow(pp) != 1)
  {
    stop("Can only insert grob on plots with exactly one panel.")
  }

  if (position[1] == "right") {
    g <- gtable::gtable_add_cols(gt, width, pp$r)
    g <- gtable::gtable_add_grob(g, grob, pp$t, pp$r+1, pp$b, pp$r+1, clip = clip, name="yaxis-grob-r")
  }
  else {
    g <- gtable::gtable_add_cols(gt, width, pp$l-1)
    g <- gtable::gtable_add_grob(g, grob, pp$t, pp$l, pp$b, pp$l, clip = clip, name="yaxis-grob-l")
  }
}

#' Generates a canvas onto which one can draw axis-like objects.
#'
#' This function takes an existing [ggplot2] plot and copies one or both of the axis into a new plot.
#' The main idea is to use this in conjunction with [insert_xaxis_grob()] or [insert_yaxis_grob()] to
#' draw custom axis-like objects or margin annotations. Importantly, while this function works for
#' both continuous and discrete scales, notice that discrete scales are converted into continuous scales
#' in the returned axis canvas. The levels of the discrete scale are placed at continuous values of
#' 1, 2, 3, etc. See Examples for an example of how to convert a discrete scale into a continuous
#' scale.
#' @param plot The plot defining the x and/or y axis range for the axis canvas.
#' @param axis Specifies which axis to copy from `plot`. Can be `"x"`, `"y"`, or `"xy"`.
#' @param data (optional) Data to be displayed in this layer.
#' @param mapping (optional) Aesthetic mapping to be used in this layer.
#' @param xlim (optional) Vector of two numbers specifying the limits of the x axis. Ignored
#' if the x axis is copied over from `plot`.
#' @param ylim (optional) Vector of two numbers specifying the limits of the y axis. Ignored
#' if the y axis is copied over from `plot`.
#' @param coord_flip (optional) If `true`, flips the coordinate system and applies x limits to
#'   the y axis and vice versa. Useful in combination with [ggplot2]'s [coord_flip()] function.
#' @examples
#' # annotate line graphs with labels on the right
#' library(dplyr)
#' library(tidyr)
#' library(ggplot2)
#' theme_set(theme_half_open())
#' x <- seq(0, 10, .1)
#' d <- data.frame(x,
#'                 linear = x,
#'                 squared = x*x/5,
#'                 cubed = x*x*x/25) %>%
#'   gather(fun, y, -x)
#'
#' pmain <- ggplot(d, aes(x, y, group = fun)) + geom_line()  +
#'   scale_x_continuous(expand = c(0, 0))
#'
#' paxis <- axis_canvas(pmain, axis = "y") +
#'   geom_text(data = filter(d, x == max(x)), aes(y = y, label = paste0(" ", fun)),
#'             x = 0, hjust = 0, vjust = 0.5)
#' ggdraw(insert_yaxis_grob(pmain, paxis, grid::unit(.25, "null")))
#'
#' # discrete scale with integrated color legend
#' pmain <- ggplot(iris, aes(x = Species, y = Sepal.Length, fill = Species)) +
#'   geom_violin(trim = FALSE) + guides(fill = "none") +
#'   scale_x_discrete(labels = NULL) +
#'   theme_minimal()
#'
#' label_data <- data.frame(x = 1:nlevels(iris$Species),
#'                          Species = levels(iris$Species))
#' paxis <- axis_canvas(pmain, axis = "x", data = label_data, mapping = aes(x = x)) +
#'   geom_tile(aes(fill = Species, y = 0.5), width = 0.9, height = 0.3) +
#'   geom_text(aes(label = Species, y = 0.5), hjust = 0.5, vjust = 0.5, size = 11/.pt)
#' ggdraw(insert_xaxis_grob(pmain, paxis, grid::unit(.07, "null"),
#'                          position = "bottom"))
#'
#' # add marginal density distributions to plot
#' pmain <- ggplot(iris, aes(x=Sepal.Length, y=Sepal.Width, color=Species)) + geom_point()
#'
#' xdens <- axis_canvas(pmain, axis = "x") +
#'   geom_density(data=iris, aes(x=Sepal.Length, fill=Species), alpha=0.7, size=.2)
#'
#' # need to set `coord_flip = TRUE` if you plan to use `coord_flip()`
#' ydens <- axis_canvas(pmain, axis = "y", coord_flip = TRUE) +
#'   geom_density(data=iris, aes(x=Sepal.Width, fill=Species), alpha=0.7, size=.2) +
#'   coord_flip()
#'
#' p1 <- insert_xaxis_grob(pmain, xdens, grid::unit(.2, "null"), position = "top")
#' p2 <- insert_yaxis_grob(p1, ydens, grid::unit(.2, "null"), position = "right")
#' ggdraw(p2)
#' @export
axis_canvas <- function(plot, axis = "y", data = NULL, mapping = aes(), xlim = NULL, ylim = NULL, coord_flip = FALSE) {
  xlimits = switch(axis,
                   x = get_scale_limits(layer_scales(plot)$x),
                   xy = get_scale_limits(layer_scales(plot)$x),
                   yx = get_scale_limits(layer_scales(plot)$x),
                   xlim)

  ylimits = switch(axis,
                   y = get_scale_limits(layer_scales(plot)$y),
                   xy = get_scale_limits(layer_scales(plot)$y),
                   yx = get_scale_limits(layer_scales(plot)$y),
                   ylim)

  if (coord_flip) {
    temp <- xlimits
    xlimits <- ylimits
    ylimits <- temp
  }

  ggplot(data = data, mapping = mapping) +
    scale_x_continuous(limits = xlimits, expand = c(0, 0)) +
    scale_y_continuous(limits = ylimits, expand = c(0, 0)) +
    theme_nothing()
}

get_scale_limits <- function(scale)
{
  if (scale$is_empty()) {
    c(0, 1)
  }
  else if (scale$is_discrete()) {
    range_c <- scale$range_c$range
    range_d <- scale$range$range
    if (is.waive(scale$expand)) expand <- c(0, 0.6)
    else expand <- scale$expand

    if (is.null(range_d)) { # only continuous
      scales::expand_range(range_c, expand[1], expand[2])
    }
    else if (is.null(range_c)) { # only discrete
      scales::expand_range(c(1, length(range_d)), expand[1], expand[2])
    }
    else { # both
      range(scales::expand_range(range_c, expand[1], 0),
            scales::expand_range(c(1, length(range_d)), 0, expand[2]))
    }
  }
  else {
    range <- scale$range$range
    if (!is.null(scale$limits)) range <- scale$limits

    if (is.waive(scale$expand)) expand <- c(0.05, 0)
    else expand <- scale$expand

    scales::expand_range(range, expand[1], expand[2])
  }
}