1
2#' View scale constructor
3#'
4#' View scales are an implementation of `Scale` objects that have fixed
5#' limits, dimension, breaks, labels, and minor breaks. They are used as
6#' the immutable result of the trained scales that have been assigned
7#' `limits` and a `continuous_range` from the coordinate system's
8#' implementation of scale expantion.
9#'
10#' @param scale The scale from which to construct a view scale.
11#' @param limits The final scale limits
12#' @param continuous_range The final dimensions of the scale
13#'
14#' @noRd
15view_scale_primary <- function(scale, limits = scale$get_limits(),
16                               continuous_range = scale$dimension(limits = limits)) {
17
18  if(!scale$is_discrete()) {
19    # continuous_range can be specified in arbitrary order, but
20    # continuous scales expect the one in ascending order.
21    breaks <- scale$get_breaks(sort(continuous_range))
22    minor_breaks <- scale$get_breaks_minor(b = breaks, limits = continuous_range)
23  } else {
24    breaks <- scale$get_breaks(limits)
25    minor_breaks <- scale$get_breaks_minor(b = breaks, limits = limits)
26  }
27
28  ggproto(NULL, ViewScale,
29    scale = scale,
30    guide = scale$guide,
31    position = scale$position,
32    aesthetics = scale$aesthetics,
33    name = scale$name,
34    scale_is_discrete = scale$is_discrete(),
35    limits = limits,
36    continuous_range = continuous_range,
37    breaks = breaks,
38    minor_breaks = minor_breaks
39  )
40}
41
42# this function is a hack that is difficult to avoid given the complex implementation of second axes
43view_scale_secondary <- function(scale, limits = scale$get_limits(),
44                                 continuous_range = scale$dimension(limits = limits)) {
45
46  if (is.null(scale$secondary.axis) || is.waive(scale$secondary.axis) || scale$secondary.axis$empty()) {
47    # if there is no second axis, return the primary scale with no guide
48    # this guide can be overridden using guides()
49    primary_scale <- view_scale_primary(scale, limits, continuous_range)
50    scale_flip_position(primary_scale)
51    primary_scale$guide <- guide_none()
52    primary_scale
53  } else {
54    scale$secondary.axis$init(scale)
55    break_info <- scale$secondary.axis$break_info(continuous_range, scale)
56    names(break_info) <- gsub("sec\\.", "", names(break_info))
57
58    # flip position from the original scale by default
59    # this can (should) be overridden in the guide
60    position <- switch(scale$position,
61      top = "bottom",
62      bottom = "top",
63      left = "right",
64      right = "left",
65      scale$position
66    )
67
68    ggproto(NULL, ViewScale,
69      scale = scale,
70      guide = scale$secondary.axis$guide,
71      position = position,
72      break_info = break_info,
73      # as far as scales are concerned, this is a regular scale with
74      # different breaks and labels in a different data space
75      aesthetics = scale$aesthetics,
76      name = scale$sec_name(),
77      make_title = function(self, title) self$scale$make_sec_title(title),
78
79      dimension = function(self) self$break_info$range,
80      get_limits = function(self) self$break_info$range,
81      get_breaks = function(self) self$break_info$major_source,
82      get_breaks_minor = function(self) self$break_info$minor_source,
83      break_positions = function(self) self$break_info$major,
84      break_positions_minor = function(self) self$break_info$minor,
85      get_labels = function(self, breaks = self$get_breaks()) self$break_info$labels,
86      rescale = function(x) rescale(x, from = break_info$range, to = c(0, 1))
87    )
88  }
89}
90
91view_scale_empty <- function() {
92  ggproto(NULL, ViewScale,
93    is_empty = function() TRUE,
94    is_discrete = function() NA,
95    dimension = function() c(0, 1),
96    get_limits = function() c(0, 1),
97    get_breaks = function() NULL,
98    get_breaks_minor = function() NULL,
99    get_labels = function(breaks = NULL) breaks,
100    rescale = function(x) abort("Not implemented"),
101    map = function(x) abort("Not implemented"),
102    make_title = function(title) title,
103    break_positions = function() NULL,
104    break_positions_minor = function() NULL
105  )
106}
107
108ViewScale <- ggproto("ViewScale", NULL,
109  # map, rescale, and make_title need a reference
110  # to the original scale
111  scale = ggproto(NULL, Scale),
112  guide = guide_none(),
113  position = NULL,
114  aesthetics = NULL,
115  name = waiver(),
116  scale_is_discrete = FALSE,
117  limits = NULL,
118  continuous_range = NULL,
119  breaks = NULL,
120  minor_breaks = NULL,
121
122  is_empty = function(self) {
123    is.null(self$get_breaks()) && is.null(self$get_breaks_minor())
124  },
125  is_discrete = function(self) self$scale_is_discrete,
126  dimension = function(self) self$continuous_range,
127  get_limits = function(self) self$limits,
128  get_breaks = function(self) self$breaks,
129  get_breaks_minor = function(self) self$minor_breaks,
130  get_labels = function(self, breaks = self$get_breaks()) self$scale$get_labels(breaks),
131  rescale = function(self, x) {
132    self$scale$rescale(x, self$limits, self$continuous_range)
133  },
134  map = function(self, x) {
135    if (self$is_discrete()) {
136      self$scale$map(x, self$limits)
137    } else {
138      self$scale$map(x, self$continuous_range)
139    }
140  },
141  make_title = function(self, title) {
142    self$scale$make_title(title)
143  },
144  break_positions = function(self) {
145    self$rescale(self$get_breaks())
146  },
147  break_positions_minor = function(self) {
148    b <- self$get_breaks_minor()
149    if (is.null(b)) {
150      return(NULL)
151    }
152
153    self$rescale(b)
154  }
155)
156