1#' Generic label placement function 2#' 3#' The simple label placer processes separate isolines independently and places 4#' labels for each line using a placer function that does the actual placement work. 5#' This label placer is not meant to be used by end users, but rather facilitates the 6#' development of new label placers, such as [`label_placer_minmax()`]. 7#' @param lines Isolines object for which labels should be placed. 8#' @param labels_data A data frame containing information about which labels should 9#' be placed. 10#' @param placer_fun A function that takes an individual isoline plus its associated 11#' break id as input and returns a data frame specifying label positions. The data 12#' frame should have three columns called `x`, `y`, and `theta`. `x` and `y` specify 13#' the label position, and `theta` specifies the label angle in radians. The data 14#' frame can have multiple rows, which results in the same label being placed in 15#' multiple locations. 16#' @keywords internal 17#' @export 18label_placer_simple <- function(lines, labels_data, placer_fun) { 19 # Calculate the label position for one set of isolines (one level). 20 # 21 # The line data is specified as a list of x, y, id. The parameters `index`, `break_index`, 22 # `break_id`, and `label` are provided simply so they can be added to the resulting data 23 # frame holding label positions 24 place_labels_impl <- function(line_data, index, break_index, break_id, label, placer_fun) { 25 # return empty row if either missing line data or missing label 26 if (length(line_data$x) == 0 || is.na(label)) { 27 return( 28 data.frame( 29 index = integer(0), 30 break_index = integer(0), 31 break_id = character(0), label = character(0), 32 x = numeric(0), y = numeric(0), theta = numeric(0), 33 stringsAsFactors = FALSE 34 ) 35 ) 36 } 37 38 # calculate label position 39 pos <- placer_fun(line_data, break_id) 40 41 # return results 42 if (nrow(pos) > 0) { 43 data.frame( 44 index = index, 45 break_index = break_index, 46 break_id = break_id, 47 label = label, 48 x = pos$x, y = pos$y, theta = pos$theta, 49 stringsAsFactors = FALSE 50 ) 51 } else { 52 data.frame( 53 index = integer(0), 54 break_index = integer(0), 55 break_id = character(0), 56 label = character(0), 57 x = numeric(0), y = numeric(0), theta = numeric(0), 58 stringsAsFactors = FALSE 59 ) 60 } 61 } 62 63 rows <- mapply( 64 place_labels_impl, 65 lines[labels_data$index], 66 labels_data$index, # index of labeled lines in original list of lines, for matching of graphical parameters 67 labels_data$break_index, # index into original list of breaks, for matching graphical parameters 68 labels_data$break_id, 69 labels_data$label, 70 MoreArgs = list(placer_fun = placer_fun), 71 SIMPLIFY = FALSE 72 ) 73 Reduce(rbind, rows) 74} 75 76 77 78#' Set up a label placement strategy 79#' 80#' These functions set up various label placement strategies. 81#' 82#' `label_placer_minmax()` places labels at the horizontal or vertical minima or maxima of 83#' the respective isolines. 84#' 85#' `label_placer_none()` places no labels at all. 86#' 87#' `label_placer_manual()` places labels at manually defined locations. 88#' 89#' `label_placer_middle()` places labels at the middle of each isoline. 90#' 91#' @param placement String consisting of any combination of the letters 92#' "t", "r", "b", "l" indicating the placement of labels at the top, 93#' to the right, at the bottom, to the left of the isoline. 94#' @param rot_adjuster Function that standardizes the rotation angles of the labels. 95#' See e.g. [`angle_halfcircle_bottom()`]. 96#' @param n Size of the point neighborhood over which the rotation angle should be 97#' calculated. 98#' @rdname label_placer 99#' @export 100label_placer_minmax <- function(placement = "tb", rot_adjuster = angle_halfcircle_bottom(), n = 2) { 101 force_all(placement, rot_adjuster, n) 102 103 placer_fun <- function(line_data, ...) { 104 # find location for labels 105 idx <- stats::na.omit( 106 c( 107 which( # placement "top" 108 isTRUE(grepl("t", placement, fixed = TRUE)) & line_data$y == max(line_data$y) 109 )[1], 110 which( # placement "bottom" 111 isTRUE(grepl("b", placement, fixed = TRUE)) & line_data$y == min(line_data$y) 112 )[1], 113 which( # placement "left" 114 isTRUE(grepl("l", placement, fixed = TRUE)) & line_data$x == min(line_data$x) 115 )[1], 116 which( # placement "right" 117 isTRUE(grepl("r", placement, fixed = TRUE)) & line_data$x == max(line_data$x) 118 )[1] 119 ) 120 ) 121 122 out <- data.frame(x = numeric(0), y = numeric(0), theta = numeric(0)) 123 124 for (i in seq_along(idx)) { 125 out[i, ] <- minmax_impl(line_data, idx[i], n) 126 } 127 128 # standardize rotation angles for text labels 129 out$theta <- rot_adjuster(out$theta) 130 131 out 132 } 133 134 # final placer function 135 function(lines, labels_data) { 136 label_placer_simple(lines, labels_data, placer_fun) 137 } 138} 139 140# function that does all the work for the minmax label placer. 141# requires a single index idx 142minmax_impl <- function(data, idx, n) { 143 # set of indices belonging to this label 144 idx_set <- which(data$id == data$id[idx]) 145 idx_min <- min(idx_set) 146 idx_max <- max(idx_set) 147 148 # if the first and the last point are the same we wrap, otherwise we truncate 149 if (data$x[idx_min] == data$x[idx_max] && data$y[idx_min] == data$y[idx_max]) { 150 idx_range <- (idx_max - idx_min) 151 i <- ((idx - n):(idx + n)-idx_min) %% idx_range + idx_min 152 } else { 153 i <- (max(idx - n, idx_min):min(idx + n, idx_max)) 154 } 155 156 x <- data$x[i] 157 y <- data$y[i] 158 xave <- mean(x) 159 yave <- mean(y) 160 m <- cbind(x - xave, y - yave) 161 v <- svd(m)$v 162 list(x = xave, y = yave, theta = atan2(v[2], v[1])) 163} 164 165#' @rdname label_placer 166#' @export 167label_placer_none <- function() { 168 function(...) { 169 data.frame( 170 index = integer(0), 171 break_index = integer(0), 172 break_id = character(0), label = character(0), 173 x = numeric(0), y = numeric(0), theta = numeric(0), 174 stringsAsFactors = FALSE 175 ) 176 } 177} 178 179#' @param breaks Character vector specifying the isolines to be labeled, 180#' as in [`isolines_grob()`]. 181#' @param x,y,theta Numeric vectors specifying the x and y positions and 182#' angles (in radians) for each label corresponding to each break. 183#' @rdname label_placer 184#' @export 185label_placer_manual <- function(breaks, x, y, theta) { 186 # recycle all inputs to the same length 187 # also has the side effect of forcing them 188 n <- max(length(breaks), length(x), length(y), length(theta)) 189 breaks <- rep_len(breaks, n) 190 x <- rep_len(x, n) 191 y <- rep_len(y, n) 192 theta <- rep_len(theta, n) 193 194 placer_fun <- function(line_data, break_id) { 195 idx <- (breaks == break_id) 196 data.frame(x = x[idx], y = y[idx], theta = theta[idx]) 197 } 198 199 # final placer function 200 function(lines, labels_data) { 201 label_placer_simple(lines, labels_data, placer_fun) 202 } 203} 204 205 206#' @rdname label_placer 207#' @export 208label_placer_middle <- function(rot_adjuster = angle_halfcircle_bottom()) { 209 placer_fun <- function(line_data, ...) { 210 out <- data.frame(x = numeric(0), y = numeric(0), theta = numeric(0)) 211 212 # It identifies each isoline subdivision. For an individual isoline the id column identifies the number of subdivisions. 213 line_sections <- unique(line_data$id) 214 215 # Then the label is printed at the middle of each isoline subdivision. 216 for (i in 1:length(line_sections)) { 217 x <- line_data$x[line_data$id == i] 218 y <- line_data$y[line_data$id == i] 219 220 middle_index <- as.integer(length(x) / 2) 221 222 x_mid <- x[middle_index] 223 y_mid <- y[middle_index] 224 225 xtheta <- c(x[middle_index - 1], x[middle_index], x[middle_index + 1]) 226 ytheta <- c(y[middle_index - 1], y[middle_index], y[middle_index + 1]) 227 228 m <- cbind(xtheta - mean(xtheta), ytheta - mean(ytheta)) 229 v <- svd(m)$v 230 231 out[i, ] <- list(x = x_mid, y = y_mid, theta = atan2(v[2], v[1])) 232 } 233 # standardize rotation angles for text labels 234 out$theta <- rot_adjuster(out$theta) 235 out 236 } 237 238 # final placer function 239 function(lines, labels_data) { 240 label_placer_simple(lines, labels_data, placer_fun) 241 } 242} 243 244#' Standardize label angles 245#' 246#' Function factories that return functions to standardize rotation angles to specific angle ranges. 247#' 248#' `angle_halfcircle_bottom()` standardizes angles to (-pi/2, pi/2]. 249#' 250#' `angle_halfcircle_right()` standardizes angles to (0, pi]. 251#' 252#' `angle_fixed()` sets all angles to a fixed value (0 by default). 253#' 254#' `angle_identity()` does not modify any angles. 255#' @param theta Fixed angle, in radians. 256#' @export 257angle_halfcircle_bottom <- function() { 258 function(theta) { 259 ifelse( 260 theta <= -pi/2, 261 theta + pi, 262 ifelse( 263 theta > pi/2, 264 theta - pi, 265 theta 266 ) 267 ) 268 } 269} 270 271#' @rdname angle_halfcircle_bottom 272#' @export 273angle_halfcircle_right <- function() { 274 function(theta) { 275 ifelse( 276 theta <= 0, 277 theta + pi, 278 ifelse( 279 theta > pi, 280 theta - pi, 281 theta 282 ) 283 ) 284 } 285} 286 287#' @rdname angle_halfcircle_bottom 288#' @export 289angle_fixed <- function(theta = 0) { 290 force(theta) 291 292 function(x) { 293 rep_len(theta, length(x)) 294 } 295} 296 297#' @rdname angle_halfcircle_bottom 298#' @export 299angle_identity <- function() { 300 function(x) { 301 x 302 } 303} 304