Nothing
#' @importFrom polyclip polyoffset polyminkowski polyclip
#' @importFrom grid convertX convertY
place_labels <- function(rects, polygons, bounds, anchors, ghosts) {
res <- vector('list', length(rects))
bbox <- list(
x = c(0, bounds[1], bounds[1], 0),
y = c(0, 0, bounds[2], bounds[2])
)
if (!is.null(ghosts) && length(ghosts$x) > 0) {
ghosts$x <- convertX(ghosts$x, 'mm', TRUE)
ghosts$y <- convertY(ghosts$y, 'mm', TRUE)
ghosts <- Map(
function(xmin, xmax, ymin, ymax) {
list(x = c(xmin, xmax, xmax, xmin), y = c(ymin, ymin, ymax, ymax))
},
xmin = ghosts$x - 2,
xmax = ghosts$x + 2,
ymin = ghosts$y - 2,
ymax = ghosts$y + 2
)
ghosts <- polyoffset(ghosts, 0)
polygons <- c(polygons, ghosts)
}
for (i in seq_along(rects)) {
if (all(rects[[i]] == 0)) next()
r <- rects[[i]] / 2 + 2
rect <- list(x = c(-r[1], r[1], r[1], -r[1]),
y = c(-r[2], -r[2], r[2], r[2]))
b <- polyminkowski(bbox, rect)
for (p in polygons) {
b <- polyclip(b, polyminkowski(p, rect)[1], 'union')
}
if (length(b) == 1) next()
b <- lapply(b[-1], function(p) cbind(p$x, p$y))
closest <- points_to_path(matrix(anchors[[i]], ncol = 2), b, TRUE)
res[[i]] <- closest$proj
rect$x <- rect$x + closest$proj[1]
rect$y <- rect$y + closest$proj[2]
polygons[[length(polygons) + 1]] <- polyoffset(rect, 10)
}
res
}
#' @importFrom polyclip polyoffset
#' @importFrom grid convertWidth convertHeight nullGrob polylineGrob
#' @importFrom stats runif
make_label <- function(labels, dims, polygons, ghosts, buffer, con_type,
con_border, con_cap, con_gp, anchor_mod, anchor_x,
anchor_y, arrow) {
polygons <- lapply(polygons, function(p) {
if (length(p$x) == 1 & length(p$y) == 1) {
list(
x = runif(200, p$x-0.00005, p$x+0.00005),
y = runif(200, p$y-0.00005, p$y+0.00005)
)
} else {
list(
x = p$x,
y = p$y
)
}
})
anchors <- lapply(seq_along(polygons), function(i) {
x <- mean(range(polygons[[i]]$x))
if (length(anchor_x) == length(polygons) && !is.na(anchor_x[i])) x <- anchor_x[i]
y <- mean(range(polygons[[i]]$y))
if (length(anchor_y) == length(polygons) && !is.na(anchor_y[i])) y <- anchor_y[i]
c(x, y)
})
p_big <- polyoffset(polygons, convertWidth(buffer, 'mm', TRUE))
area <- c(
convertWidth(unit(1, 'npc'), 'mm', TRUE),
convertHeight(unit(1, 'npc'), 'mm', TRUE)
)
labelpos <- place_labels(dims, p_big, area, anchors, ghosts)
if (all(lengths(labelpos) == 0)) {
return(list(nullGrob()))
}
labels <- Map(function(lab, pos) {
if (is.null(pos) || inherits(lab, 'null')) return(nullGrob())
lab$vp$x <- unit(pos[1], 'mm')
lab$vp$y <- unit(pos[2], 'mm')
lab
}, lab = labels, pos = labelpos)
connect <- inject(rbind(!!!Map(function(pol, pos, dim) {
if (is.null(pos)) return(NULL)
dim <- dim / anchor_mod
pos <- cbind(
c(pos[1] - dim[1], pos[1] + dim[1], pos[1] + dim[1], pos[1] - dim[1]),
c(pos[2] - dim[2], pos[2] - dim[2], pos[2] + dim[2], pos[2] + dim[2])
)
pos <- points_to_path(pos, list(cbind(pol$x, pol$y)), TRUE)
pos$projection[which.min(pos$distance), ]
}, pol = polygons, pos = labelpos, dim = dims)))
labeldims <- inject(rbind(!!!dims[lengths(labelpos) != 0])) / 2
labelpos <- inject(rbind(!!!labelpos))
if (con_type == 'none' || !con_type %in% c('elbow', 'straight')) {
connect <- nullGrob()
} else {
con_fun <- switch(con_type, elbow = elbow, straight = straight)
connect <- con_fun(
labelpos[, 1] - labeldims[, 1], labelpos[, 1] + labeldims[, 1],
labelpos[, 2] - labeldims[, 2], labelpos[, 2] + labeldims[, 2],
connect[, 1], connect[, 2]
)
if (con_border == 'one') {
connect <- with_borderline(
labelpos[, 1] - labeldims[, 1],
labelpos[, 1] + labeldims[, 1], connect
)
}
connect <- end_cap(connect, con_cap)
connect <- zip_points(connect)
if (!is.null(arrow)) arrow$ends <- 2L
connect <- polylineGrob(connect$x, connect$y,
id = connect$id,
default.units = 'mm', gp = con_gp, arrow = arrow
)
}
c(labels, list(connect))
}
#' @importFrom grid valid.just textGrob nullGrob viewport grobWidth grobHeight
#' rectGrob gpar grid.layout unit gTree gList grobDescent
labelboxGrob <- function(label, x = unit(0.5, 'npc'), y = unit(0.5, 'npc'),
description = NULL, width = NULL, min.width = 50,
default.units = 'mm', hjust = 0,
pad = margin(2, 2, 2, 2, 'mm'), gp = gpar(),
vp = NULL) {
gps <- split_label_gp(gp)
width <- as_mm(width, default.units)
min.width <- as_mm(min.width, default.units)
pad <- as_mm(pad, default.units)
pad[c(1, 3)] <- as_mm(pad[c(1, 3)], default.units, FALSE)
if (!is.null(label) && !is.na(label)) {
if (!is.null(width)) {
label <- wrap_text(label, gps$lab, width - pad[2] - pad[4])
}
just <- c(hjust[1], 0.5)
lab_grob <- textGrob(label, x = just[1], y = just[2], just = just,
gp = gps$lab)
} else {
lab_grob <- nullGrob()
}
if (!is.null(width)) {
final_width <- max(width, min.width) - pad[2] - pad[4]
} else {
if (as_mm(grobWidth(lab_grob)) > (min.width - pad[2] - pad[4])) {
final_width <- as_mm(grobWidth(lab_grob)) + pad[2] + pad[4]
} else {
final_width <- max(as_mm(grobWidth(lab_grob)), min.width) - pad[2] - pad[4]
}
}
if (!is.null(description) && !is.na(description)) {
description <- wrap_text(description, gps$desc, final_width)
just <- c(rep_len(hjust, 2)[2], 0.5)
desc_grob <- textGrob(description, x = just[1], y = just[2], just = just,
gp = gps$desc)
if (is.null(width)) {
final_width_desc <- min(final_width, as_mm(grobWidth(desc_grob)))
final_width <- as_mm(grobWidth(lab_grob))
if (final_width < final_width_desc) {
final_width <- final_width_desc
}
}
} else {
desc_grob <- nullGrob()
if (is.null(width)) final_width <- as_mm(grobWidth(lab_grob))
}
bg_grob <- rectGrob(gp = gps$rect)
lab_height <- as_mm(grobHeight(lab_grob), width = FALSE)
desc_height <- as_mm(grobHeight(desc_grob), width = FALSE)
sep_height <- if (lab_height > 0 && desc_height > 0) {
pad[1]
} else if (lab_height > 0) {
font_descent(gps$lab$fontfamily, gps$lab$fontface, gps$lab$fontsize, gps$lab$cex)
} else {
0
}
vp <- viewport(
x = x,
y = y,
width = unit(final_width + pad[2] + pad[4], 'mm'),
height = unit(pad[1] + pad[3] + lab_height + desc_height + sep_height,
'mm'),
layout = grid.layout(
5, 3,
widths = unit(c(pad[2], final_width, pad[4]), 'mm'),
heights = unit(c(pad[1], lab_height, sep_height, desc_height, pad[3]),
'mm')
)
)
lab_grob$vp <- viewport(layout.pos.col = 2, layout.pos.row = 2)
desc_grob$vp <- viewport(layout.pos.col = 2, layout.pos.row = 4)
gTree(children = gList(bg_grob, lab_grob, desc_grob), vp = vp,
cl = 'mark_label')
}
#' @export
#' @importFrom grid widthDetails
widthDetails.mark_label <- function(x) {
x$vp$width
}
#' @export
#' @importFrom grid heightDetails
heightDetails.mark_label <- function(x) {
x$vp$height
}
#' @importFrom grid textGrob grobWidth
wrap_text <- function(text, gp, width) {
text <- gsub('-', '- ', text)
text <- strsplit(text, split = ' ', fixed = TRUE)[[1]]
text <- paste0(text, ' ')
text <- sub('- ', '-', text)
txt <- ''
for (i in text) {
oldlab <- txt
txt <- paste0(txt, i)
tmpGrob <- textGrob(txt, gp = gp)
if (as_mm(grobWidth(tmpGrob)) > width) {
txt <- paste(trimws(oldlab), i, sep = '\n')
}
}
trimws(txt)
}
#' @importFrom grid unit is.unit convertWidth convertHeight
as_mm <- function(x, def, width = TRUE) {
if (is.null(x)) return(x)
if (!is.unit(x)) x <- unit(x, def)
if (width) {
convertWidth(x, 'mm', TRUE)
} else {
convertHeight(x, 'mm', TRUE)
}
}
#' @importFrom grid gpar
split_label_gp <- function(gp) {
rect_gp <- gpar(col = NA)
lab_gp <- gpar()
desc_gp <- gpar()
if (!is.null(gp$fill)) rect_gp$fill <- gp$fill
if (!is.null(gp$col)) {
col <- rep(gp$col, length.out = 2)
lab_gp$col <- col[1]
desc_gp$col <- col[2]
}
if (!is.null(gp$font)) {
font <- rep(gp$font, length.out = 2)
lab_gp$font <- font[1]
desc_gp$font <- font[2]
}
if (!is.null(gp$fontsize)) {
fontsize <- rep(gp$fontsize, length.out = 2)
lab_gp$fontsize <- fontsize[1]
desc_gp$fontsize <- fontsize[2]
}
if (!is.null(gp$fontfamily)) {
fontfamily <- rep(gp$fontfamily, length.out = 2)
lab_gp$fontfamily <- fontfamily[1]
desc_gp$fontfamily <- fontfamily[2]
}
if (!is.null(gp$fontface)) {
fontface <- rep(gp$fontface, length.out = 2)
lab_gp$fontface <- fontface[1]
desc_gp$fontface <- fontface[2]
}
if (!is.null(gp$lineheight)) {
lineheight <- rep(gp$lineheight, length.out = 2)
lab_gp$lineheight <- lineheight[1]
desc_gp$lineheight <- lineheight[2]
}
if (!is.null(gp$cex)) {
cex <- rep(gp$cex, length.out = 2)
lab_gp$cex <- cex[1]
desc_gp$cex <- cex[2]
}
list(rect = rect_gp, lab = lab_gp, desc = desc_gp)
}
straight <- function(xmin, xmax, ymin, ymax, x, y) {
conn_point <- get_end_points(xmin, xmax, ymin, ymax, x, y)
list(
as.matrix(conn_point),
cbind(x = x, y = y)
)
}
elbow <- function(xmin, xmax, ymin, ymax, x, y) {
lines <- straight(xmin, xmax, ymin, ymax, x, y)
end_pos <- lines[[1]] - lines[[2]]
end_angle <- atan2(end_pos[, 2], end_pos[, 1]) %% (2 * pi)
angle_bin <- end_angle %/% (pi / 4)
angle_lower <- end_angle %% (pi / 4) < 0.5
elbow <- lapply(seq_along(angle_bin), function(i) {
a_bin <- angle_bin[i]
a_lower <- angle_lower[i]
if (a_bin == 0 || a_bin == 4) {
if (a_lower) {
c(end_pos[i, 1] - end_pos[i, 2], 0)
} else {
c(end_pos[i, 2], end_pos[i, 2])
}
} else if (a_bin == 1 || a_bin == 5) {
if (a_lower) {
c(end_pos[i, 1], end_pos[i, 1])
} else {
c(0, end_pos[i, 2] - end_pos[i, 1])
}
} else if (a_bin == 2 || a_bin == 6) {
if (a_lower) {
c(0, end_pos[i, 2] + end_pos[i, 1])
} else {
c(end_pos[i, 1], -end_pos[i, 1])
}
} else if (a_bin == 3 || a_bin == 7) {
if (a_lower) {
c(-end_pos[i, 2], end_pos[i, 2])
} else {
c(end_pos[i, 1] + end_pos[i, 2], 0)
}
}
})
elbow <- inject(rbind(!!!elbow))
elbow <- elbow + lines[[2]]
colnames(elbow) <- c('x', 'y')
list(lines[[1]], elbow, lines[[2]])
}
with_borderline <- function(xmin, xmax, lines) {
new_start <- lines[[1]]
new_start[, 1] <- ifelse(new_start[, 1] == xmin, xmax, xmin)
c(list(new_start), lines)
}
end_cap <- function(lines, cap) {
from <- lines[[length(lines) - 1]]
to <- lines[[length(lines)]]
d <- to - from
l <- sqrt(rowSums((d)^2))
to <- from + d * (l - cap) / l
lines[[length(lines)]] <- to
lines
}
zip_points <- function(points) {
n_lines <- nrow(points[[1]])
n_joints <- length(points)
points <- as.data.frame(inject(rbind(!!!points)))
points$id <- rep(seq_len(n_lines), n_joints)
points[order(points$id), ]
}
get_end_points <- function(xmin, xmax, ymin, ymax, x, y) {
xmin_tmp <- xmin - x
xmax_tmp <- xmax - x
ymin_tmp <- ymin - y
ymax_tmp <- ymax - y
pos <- ifelse(
xmin_tmp < 0,
ifelse(ymin_tmp < 0, 'bottomleft', 'topleft'),
ifelse(ymin_tmp < 0, 'bottomright', 'topright')
)
pos <- ifelse(
ymin_tmp < 0 & ymax_tmp > 0,
ifelse(xmin_tmp < 0, 'left', 'right'),
ifelse(
xmin_tmp < 0 & xmax_tmp > 0,
ifelse(ymin_tmp < 0, 'bottom', 'top'),
pos
)
)
x_new <- vswitch(
pos,
left = xmax,
bottomleft = xmax,
topleft = xmax,
right = xmin,
bottomright = xmin,
topright = xmin,
top = ifelse(abs(xmin_tmp) < abs(xmax_tmp), xmin, xmax),
bottom = ifelse(abs(xmin_tmp) < abs(xmax_tmp), xmin, xmax)
)
y_new <- vswitch(
pos,
bottom = ymax,
bottomleft = ymax,
bottomright = ymax,
top = ymin,
topleft = ymin,
topright = ymin,
left = ifelse(abs(ymin_tmp) < abs(ymax_tmp), ymin, ymax),
right = ifelse(abs(ymin_tmp) < abs(ymax_tmp), ymin, ymax)
)
data_frame0(x = x_new, y = y_new)
}
vswitch <- function(x, ...) {
cases <- cbind(...)
cases[cbind(seq_along(x), match(x, colnames(cases)))]
}
font_descent <- function(fontfamily, fontface, fontsize, cex) {
italic <- fontface >= 3
bold <- fontface == 2 | fontface == 4
info <- systemfonts::font_info(fontfamily, italic, bold, fontsize * (cex %||% 1), res = 300)
as_mm(abs(info$max_descend)*72/300, 'pt', FALSE)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.