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