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