1#  File src/library/grid/R/components.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 1995-2018 The R Core Team
5#
6#  This program is free software; you can redistribute it and/or modify
7#  it under the terms of the GNU General Public License as published by
8#  the Free Software Foundation; either version 2 of the License, or
9#  (at your option) any later version.
10#
11#  This program is distributed in the hope that it will be useful,
12#  but WITHOUT ANY WARRANTY; without even the implied warranty of
13#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14#  GNU General Public License for more details.
15#
16#  A copy of the GNU General Public License is available at
17#  https://www.R-project.org/Licenses/
18
19grid.collection <- function(..., gp=gpar(), draw=TRUE, vp=NULL) {
20    .Defunct("gTree")
21}
22
23######################################
24# AXES
25######################################
26
27# Axes are extended from the "gTree" class
28# This means that the standard (e.g., draw.details)
29# methods for gTrees will apply
30
31# The children of an axis are fixed to be:
32
33# NOTE that the `at' parameter is numeric (i.e., NOT a unit) for
34# grid.xaxis and grid.yaxis.  These functions assume a unit for the `at'
35# values rather than letting the user specify a unit.
36
37validDetails.axis <- function(x) {
38  if (!is.null(x$at)) {
39    x$at <- as.numeric(x$at)
40    if (length(x$at) < 1 || !all(is.finite(x$at)))
41      stop("invalid 'at' location in 'axis'")
42  }
43  if (!is.logical(x$label)) {
44    # labels specified
45    # Can only spec labels if at is not NULL
46    if (is.null(x$at))
47      stop("invalid to specify axis labels when 'at' is NULL")
48    # Must be either language object or string
49    x$label <- as.graphicsAnnot(x$label)
50    # Must be same number of labels as "at" locations
51    if (length(x$label) != length(x$at))
52      stop("'labels' and 'at' locations must have same length")
53  }
54  x$main <- as.logical(x$main)
55  x
56}
57
58makeContent.xaxis <- function(x) {
59    # If x$at is NULL, then we must calculate the
60    # tick marks on-the-fly
61    if (is.null(x$at)) {
62        x$at <- grid.pretty(current.viewport()$xscale)
63        # Add the new output as children
64        x <- addGrob(x, make.xaxis.major(x$at, x$main))
65        x <- addGrob(x, make.xaxis.ticks(x$at, x$main))
66        x <- updateXlabels(x)
67        # Apply any edits relevant to children
68        x <- applyEdits(x, x$edits)
69    }
70    x
71}
72
73# NOTE that this can't be for all axes because it needs to
74# call make.XAXIS.ticks and make.XAXIS.labels
75editDetails.xaxis <- function(x, specs) {
76  slot.names <- names(specs)
77  if ("at" %in% slot.names) {
78    # NOTE that grid.edit has already set x$at to the new value
79    # We might set at to NULL to get ticks recalculated at redraw
80    if (is.null(x$at)) {
81      x <- removeGrob(x, "major", warn=FALSE)
82      x <- removeGrob(x, "ticks", warn=FALSE)
83      x <- removeGrob(x, "labels", warn=FALSE)
84    } else {
85      x <- addGrob(x, make.xaxis.major(x$at, x$main))
86      x <- addGrob(x, make.xaxis.ticks(x$at, x$main))
87      x <- updateXlabels(x)
88    }
89  }
90  if ("label" %in% slot.names) {
91    if (!is.null(x$at))
92      x <- updateXlabels(x)
93  }
94  if ("main" %in% slot.names)
95    if (!is.null(x$at)) {
96      x <- addGrob(x, make.xaxis.major(x$at, x$main))
97      x <- addGrob(x, make.xaxis.ticks(x$at, x$main))
98      x <- updateXlabels(x)
99    }
100  x
101}
102
103make.xaxis.major <- function(at, main) {
104  if (main)
105    y <- c(0, 0)
106  else
107    y <- c(1, 1)
108  linesGrob(unit(c(min(at), max(at)), "native"),
109            unit(y, "npc"), name="major")
110}
111
112make.xaxis.ticks <- function(at, main) {
113  if (main) {
114    tick.y0 <- unit(0, "npc")
115    tick.y1 <- unit(-.5, "lines")
116  }
117  else {
118    tick.y0 <- unit(1, "npc")
119    tick.y1 <- unit(1, "npc") + unit(.5, "lines")
120  }
121  segmentsGrob(unit(at, "native"), tick.y0,
122               unit(at, "native"), tick.y1,
123               name="ticks")
124}
125
126make.xaxis.labels <- function(at, label, main) {
127  # FIXME:  labels only character versions of "at"
128  if (main)
129    label.y <- unit(-1.5, "lines")
130  else
131    label.y <- unit(1, "npc") + unit(1.5, "lines")
132  if (is.logical(label))
133    labels <- as.character(at)
134  else
135    labels <- label
136  textGrob(labels, unit(at, "native"), label.y,
137           just="centre", rot=0,
138           check.overlap=TRUE, name="labels")
139}
140
141updateXlabels <- function(x) {
142  if (is.logical(x$label) && !x$label)
143    removeGrob(x, "labels", warn=FALSE)
144  else
145    addGrob(x, make.xaxis.labels(x$at, x$label, x$main))
146}
147
148xaxisGrob <- function(at=NULL, label=TRUE, main=TRUE,
149                      edits=NULL,
150                      name=NULL, gp=gpar(), vp=NULL) {
151  grid.xaxis(at=at, label=label, main=main,
152             edits=edits,
153             name=name, gp=gp, draw=FALSE, vp=vp)
154}
155
156# The "main" x-axis is on the bottom when vp$origin is "bottom.*"
157# and on the top when vp$origin is "top.*"
158grid.xaxis <- function(at=NULL, label=TRUE, main=TRUE,
159                       edits=NULL, name=NULL, gp=gpar(),
160                       draw=TRUE, vp=NULL) {
161  if (is.null(at)) {
162    # We do not have enough information to make the ticks and labels
163    major <- NULL
164    ticks <- NULL
165    labels <- NULL
166  } else {
167    major <- make.xaxis.major(at, main)
168    ticks <- make.xaxis.ticks(at, main)
169    if (is.logical(label) && length(label) == 0)
170	stop("logical 'label' supplied of length 0")
171    if (is.logical(label) && !label)
172      labels <- NULL
173    else
174      labels <- make.xaxis.labels(at, label, main)
175  }
176  xg <- applyEdits(gTree(at=at, label=label, main=main,
177                         children=gList(major, ticks, labels),
178                         edits=edits,
179                         name=name, gp=gp, vp=vp,
180                         cl=c("xaxis", "axis")),
181                   edits)
182  if (draw)
183    grid.draw(xg)
184  invisible(xg)
185}
186
187makeContent.yaxis <- function(x) {
188    # If x$at is NULL, then we must calculate the
189    # tick marks on-the-fly
190    if (is.null(x$at)) {
191        x$at <- grid.pretty(current.viewport()$yscale)
192        # Add the new output as children
193        x <- addGrob(x, make.yaxis.major(x$at, x$main))
194        x <- addGrob(x, make.yaxis.ticks(x$at, x$main))
195        x <- updateYlabels(x)
196        # Apply any edits relevant to children
197        x <- applyEdits(x, x$edits)
198    }
199    x
200}
201
202editDetails.yaxis <- function(x, specs) {
203  slot.names <- names(specs)
204  if ("at" %in% slot.names) {
205    if (is.null(x$at)) {
206      x <- removeGrob(x, "major", warn=FALSE)
207      x <- removeGrob(x, "ticks", warn=FALSE)
208      x <- removeGrob(x, "labels", warn=FALSE)
209    } else {
210      x <- addGrob(x, make.yaxis.major(x$at, x$main))
211      x <- addGrob(x, make.yaxis.ticks(x$at, x$main))
212      x <- updateYlabels(x)
213    }
214  }
215  if ("label" %in% slot.names) {
216    if (!is.null(x$at))
217      x <- updateYlabels(x)
218  }
219  if ("main" %in% slot.names)
220    if (!is.null(x$at)) {
221      x <- addGrob(x, make.yaxis.major(x$at, x$main))
222      x <- addGrob(x, make.yaxis.ticks(x$at, x$main))
223      x <- updateYlabels(x)
224    }
225  x
226}
227
228make.yaxis.major <- function(at, main) {
229  if (main)
230    x <- c(0, 0)
231  else
232    x <- c(1, 1)
233  linesGrob(unit(x, "npc"), unit(c(min(at), max(at)), "native"),
234            name="major")
235}
236
237make.yaxis.ticks <- function(at, main) {
238  if (main) {
239    tick.x0 <- unit(0, "npc")
240    tick.x1 <- unit(-.5, "lines")
241  }
242  else {
243    tick.x0 <- unit(1, "npc")
244    tick.x1 <- unit(1, "npc") + unit(.5, "lines")
245  }
246  segmentsGrob(tick.x0, unit(at, "native"),
247               tick.x1, unit(at, "native"),
248               name="ticks")
249}
250
251make.yaxis.labels <- function(at, label, main) {
252  if (main) {
253    hjust <- "right"
254    label.x <- unit(-1, "lines")
255  }
256  else {
257    hjust <- "left"
258    label.x <- unit(1, "npc") + unit(1, "lines")
259  }
260  just <- c(hjust, "centre")
261  if (is.logical(label))
262    labels <- as.character(at)
263  else
264    labels <- label
265  textGrob(labels, label.x, unit(at, "native"),
266           just=just, rot=0, check.overlap=TRUE, name="labels")
267}
268
269updateYlabels <- function(x) {
270  if (is.logical(x$label) && !x$label)
271    removeGrob(x, "labels", warn=FALSE)
272  else
273    addGrob(x, make.yaxis.labels(x$at, x$label, x$main))
274}
275
276yaxisGrob <- function(at=NULL, label=TRUE, main=TRUE,
277                      edits=NULL,
278                      name=NULL, gp=gpar(), vp=NULL) {
279  grid.yaxis(at=at, label=label, main=main, edits=edits,
280             name=name, gp=gp, draw=FALSE, vp=vp)
281}
282
283# The "main" y-axis is on the left when vp$origin is "*.left"
284# and on the right when vp$origin is "*.right"
285grid.yaxis <- function(at=NULL, label=TRUE, main=TRUE,
286                       edits=NULL,
287                       name=NULL, gp=gpar(),
288                       draw=TRUE, vp=NULL) {
289  if (is.null(at)) {
290    # We do not have enough information to make the ticks and labels
291    major <- NULL
292    ticks <- NULL
293    labels <- NULL
294  } else {
295    major <- make.yaxis.major(at, main)
296    ticks <- make.yaxis.ticks(at, main)
297    if (is.logical(label) && length(label) == 0)
298	stop("logical 'label' supplied of length 0")
299    if (is.logical(label) && !label)
300      labels <- NULL
301    else
302      labels <- make.yaxis.labels(at, label, main)
303  }
304  yg <- applyEdits(gTree(at=at, label=label, main=main,
305                         children=gList(major, ticks, labels),
306                         edits=edits,
307                         name=name, gp=gp, vp=vp,
308                         cl=c("yaxis", "axis")),
309                   edits)
310  if (draw)
311    grid.draw(yg)
312  invisible(yg)
313}
314
315######################################
316# Simple "side-effect" plotting functions
317######################################
318
319grid.grill <- function(h=unit(seq(0.25, 0.75, 0.25), "npc"),
320                       v=unit(seq(0.25, 0.75, 0.25), "npc"),
321                       default.units="npc",
322                       gp=gpar(col="grey"), vp=NULL) {
323  if (!is.unit(h))
324    h <- unit(h, default.units)
325  if (!is.unit(v))
326    v <- unit(v, default.units)
327  # FIXME:  Should replace for loop and call to grid.lines with call to grid.segments
328  # once the latter exists
329  if (!is.null(vp))
330    pushViewport(vp)
331  grid.segments(v, unit(0, "npc"), v, unit(1, "npc"), gp=gp)
332  grid.segments(unit(0, "npc"), h, unit(1, "npc"), h, gp=gp)
333  if (!is.null(vp))
334    popViewport()
335}
336
337