-
Notifications
You must be signed in to change notification settings - Fork 14
/
auxiliary_function_general_repel.R
106 lines (100 loc) · 4.95 KB
/
auxiliary_function_general_repel.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
#!/usr/bin/R
# -----------------------------------
# Auxiliary function for label repel:
# -----------------------------------
# library(ggrepel)
# library(rlang)
# importFrom(grid,convertHeight)
# importFrom(grid,convertWidth)
#' Repel labels from points and each other
#'
#' @param x
#' @param y
#' @param labels
#' @return Return new locations and facings for each label
#' @noRd
general_repel_text = function(x, y, labels, cex=1, pch=19, pt.cex=1,
seed=NULL, hjust=0.5, vjust=0.5,
force = 1, force_pull = 1, max.iter = 2000,
max.overlaps = 25,
xlim = c(NA, NA), ylim = c(NA, NA), direction = "both"){
require(ggrepel)
require(rlang)
if (length(hjust) != length(x)){ hjust = rep_len(hjust, length.out=length(x)) }
if (length(vjust) != length(x)){ vjust = rep_len(vjust, length.out=length(x)) }
# --------------
# Label padding:
# --------------
# Get strheight/strwidth
box_widths = strwidth(labels, cex=cex)
box_heights = strheight(labels, cex=cex)
# The padding around each bounding box (for now, based on the height)
box_padding_x <- .1 * mean(box_heights)
box_padding_y <- .1 * mean(box_heights)
# TODO: Allow specifying box.padding?
# box_padding_x <- convertWidth(x$box.padding, "native", valueOnly = TRUE)
# box_padding_y <- convertHeight(x$box.padding, "native", valueOnly = TRUE)
# --------------
# Point padding:
# --------------
# TODO: Get padding from pt.cex and pch:
# if (is.na(x$point.padding)) { x$point.padding = unit(0, "lines") }
# point_padding_x <- convertWidth(x$point.padding, "native", valueOnly = TRUE)
# point_padding_y <- convertHeight(x$point.padding, "native", valueOnly = TRUE)
point_padding_x <- strheight('a', cex=pt.cex)
point_padding_y <- strheight('a', cex=pt.cex)
# The padding around each point.
# if (length(x$point.size) == 1 && is.na(x$point.size)) { x$point.size = unit(0, "lines") }
# point_size <- convertWidth(x$point.size, "native", valueOnly = TRUE)
# point_size <- convertWidth(x$point.size, "native", valueOnly = TRUE)
# TODO: Fix this and calculate the real point size:
point_size = strheight('a', cex=pt.cex)
# Do not create text labels for empty strings.
valid_strings <- which(ggrepel:::not_empty(labels))
invalid_strings <- which(!ggrepel:::not_empty(labels))
# Create a dataframe with x1 y1 x2 y2
boxes <- lapply(valid_strings, function(i) {
hj <- hjust[i]
vj <- vjust[i]
gw = box_widths[i]
gh = box_heights[i]
c("x1" = x[i] - gw * hj - box_padding_x,
"y1" = y[i] - gh * vj - box_padding_y,
"x2" = x[i] + gw * (1 - hj) + box_padding_x,
"y2" = y[i] + gh * (1 - vj) + box_padding_y) })
# Make the repulsion reproducible if desired.
if (is.null(seed) || !is.na(seed)) { set.seed(seed) }
points_valid_first <- cbind(c(x[valid_strings], x[invalid_strings]),
c(y[valid_strings], y[invalid_strings]))
# Re-adjust point size (TODO: seems redundant - fix)
if (length(point_size) != length(x)) {
point_size <- rep_len(point_size, length.out=length(x))
}
point_size <- c(point_size[valid_strings], point_size[invalid_strings])
# Repel overlapping bounding boxes away from each other.
# repel <- ggrepel:::repel_boxes2(
# .Call("_ggrepel_repel_boxes", PACKAGE = "ggrepel", data_point
# point_padding_x, point_padding_y, boxes, xlim, ylim,
# hjust, vjust, force, maxiter, direction)
repel <- ggrepel:::repel_boxes2(data_points = points_valid_first,
point_size = point_size,
point_padding_x = point_padding_x,
point_padding_y = point_padding_y,
boxes = do.call(rbind, boxes),
# Params:
xlim = range(xlim),
ylim = range(ylim),
hjust = hjust %||% 0.5,
vjust = vjust %||% 0.5,
# NOTE: Defaults from ggrepel
force_pull = force * 1e-6,
force_push = force * 1e-6,
# force_pull = force_pull * 1e-2,
max_overlaps=max.overlaps,
max_iter = max.iter,
direction = direction)
return(data.frame(x=repel$x, y=repel$y,
# Position of original data points.
x.orig=x[valid_strings], y.orig=y[valid_strings],
lab=labels[valid_strings]))
}