Skip to content

Commit

Permalink
Working geom. Need some polishing and orientation options.
Browse files Browse the repository at this point in the history
  • Loading branch information
Clement-Viguier committed Aug 3, 2018
1 parent 6afb869 commit 4a15fbe
Show file tree
Hide file tree
Showing 8 changed files with 556 additions and 38 deletions.
Binary file added Images/moving_label.gif
Loading
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
7 changes: 7 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
@@ -1,6 +1,13 @@
# Generated by roxygen2: do not edit by hand

export(GeomRiverLabel)
export(geom_river_label)
export(place_along)
export(point_along)
export(point_on)
export(position_letter)
import(dplyr)
import(ggplot2)
import(grid)
importFrom(ggplot2,ggproto)
importFrom(plyr,ddply)
145 changes: 145 additions & 0 deletions R/geom_river_label.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,145 @@
#' Text
#'
#'
#' @eval rd_aesthetics("geom", "text")
#' @section `geom_label`:
#' Currently `geom_label` does not support the `angle` aesthetic and
#' is considerably slower than `geom_text`. The `fill` aesthetic
#' controls the background colour of the label.
#'
#' @section Alignment:
#' You can modify text alignment with the `vjust` and `hjust`
#' aesthetics. These can either be a number between 0 (right/bottom) and
#' 1 (top/left) or a character (`"left"`, `"middle"`, `"right"`, `"bottom"`,
#' `"center"`, `"top"`). There are two special alignments: `"inward"` and
#' `"outward"`. Inward always aligns text towards the center, and outward
#' aligns it away from the center.
#'
#' @inheritParams layer
#' @inheritParams geom_point
#' @import ggplot2 grid dplyr
#' @importFrom ggplot2 ggproto
#' @importFrom plyr ddply
#' @param parse If `TRUE`, the labels will be parsed into expressions and
#' displayed as described in `?plotmath`.
#' @param nudge_x,nudge_y Horizontal and vertical adjustment to nudge labels by.
#' Useful for offsetting text from points, particularly on discrete scales.
#' @export
#' @examples
#'
geom_river_label <- function(mapping = NULL, data = NULL,
stat = "identity", position = "identity",
...,
parse = FALSE,
nudge_x = 0,
nudge_y = 0,
na.rm = FALSE,
centred = TRUE,
show.legend = NA,
inherit.aes = TRUE)
{
if (!missing(nudge_x) || !missing(nudge_y)) {
if (!missing(position)) {
stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE)
}

position <- position_nudge(nudge_x, nudge_y)
}

layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomRiverLabel,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
parse = parse,
na.rm = na.rm,
centred = centred,
...
)
)
}


#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomRiverLabel <- ggproto("GeomRiverLabel", Geom,
required_aes = c("x", "y", "label"),

default_aes = aes(
colour = "black", size = 3.88, angle = 0, hjust = 0.5,
vjust = 0.5, alpha = NA, family = "", fontface = 1, lineheight = 1.2,
offset = 0, dist = 10, vpos = 5, win = 30
),

draw_panel = function(data, panel_params, coord, parse = FALSE,
na.rm = FALSE, centred = TRUE, check_overlap = FALSE) {

# Compute by default aes (offset, dist, win) based on the length of the paths

# Compute the labels per group:
data <- plyr::ddply(data, "group", function(df, centred) {
# COmpute the position of each letter
data2 <- place_along(text = df$label[1], df$x, df$y, offset = df$offset[1], dist = df$dist[1], vpos = df$vpos[1], win =df$win[1], centred = centred)
data2$angle2 <- data2$angle * 180 / pi # convert to degrees
# merge with original data to keep the aes
data2$group <- df$group[1]
data2 <- merge(data2, select(df, -x, -y, -label))
return(data2)
}, centred)

# Apply the rest of the GeomText as normal
lab <- data$label
if (parse) {
lab <- parse(text = as.character(lab))
}

data <- coord$transform(data, panel_params)
if (is.character(data$vjust)) {
data$vjust <- compute_just(data$vjust, data$y)
}
if (is.character(data$hjust)) {
data$hjust <- compute_just(data$hjust, data$x)
}

textGrob(
lab,
data$x, data$y, default.units = "native",
hjust = data$hjust, vjust = data$vjust,
rot = data$angle + data$angle2,
gp = gpar(
col = alpha(data$colour, data$alpha),
fontsize = data$size * .pt,
fontfamily = data$family,
fontface = data$fontface,
lineheight = data$lineheight
),
check.overlap = check_overlap
)
},

draw_key = draw_key_text
)


compute_just <- function(just, x) {
inward <- just == "inward"
just[inward] <- c("left", "middle", "right")[just_dir(x[inward])]
outward <- just == "outward"
just[outward] <- c("right", "middle", "left")[just_dir(x[outward])]

unname(c(left = 0, center = 0.5, right = 1,
bottom = 0, middle = 0.5, top = 1)[just])
}

just_dir <- function(x, tol = 0.001) {
out <- rep(2L, length(x))
out[x < 0.5 - tol] <- 1L
out[x > 0.5 + tol] <- 3L
out
}
56 changes: 39 additions & 17 deletions R/place_along.R
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@
#'
#' Place letter s along a path.
#'
#' @param label word to place along the path.
#' @param text text to place along the path.
#' @param x X coordinates of the path.
#' @param y y coordinates of the path.
#' @param offset distance from the starting point of the path.
Expand All @@ -19,11 +19,21 @@
#' x <- sort(floor(runif(50)*200)/20)
#' win <- 6
#' pos <- place_along("abcefg", x, y, 4, 1.5, 1.5, win = win, centred = 1)
#' ggplot(data.frame(x, y), aes(x,y))+ geom_path() + geom_text(data=pos, aes(label = letter, angle= angle * 180 / pi), size = 14) + geom_point(data = pos, aes(refx, refy)) + coord_fixed() #+ geom_arc(data = pos, aes(refx, refy), radius = win/2, width = 15 * 2 * pi)
#' ggplot(data.frame(x, y), aes(x,y))+ geom_path() + geom_text(data=pos, aes(label = label, angle= angle2 * 180 / pi), size = 14) + geom_point(data = pos, aes(refx, refy)) + coord_fixed() #+ geom_arc(data = pos, aes(refx, refy), radius = win/2, width = 15 * 2 * pi)
#'
#'
place_along <- function(label, x, y, offset, dist = 0.5, vpos = 0.2, win = 1, centred = T){
n <- nchar(label[1])
#'# Another example with real river data from the riverdist package
#'
#' river <- Gulk$lines[[14]]
#' river <- as.data.frame(river)
#' colnames(river) <- c("x", "y")
#' river
#' win <- 1000
#' pos <- place_along("Gulk", river$x, river$y, 4000, 1000, 500, win = win, centred = 1)
#' ggplot(river, aes(x,y))+ geom_path() + geom_text(data=pos, aes(label = letter, angle= angle * 180 / pi), size = 8) + geom_point(data = pos, aes(refx, refy)) + coord_fixed()
#'
place_along <- function(text, x, y, offset, dist = 0.5, vpos = 0.2, win = 1, centred = T){
n <- nchar(text[1])

df <- data.frame(x, y)

Expand All @@ -34,56 +44,68 @@ place_along <- function(label, x, y, offset, dist = 0.5, vpos = 0.2, win = 1, ce
filter(!is.na(l)) %>%
mutate(seg = 1:length(l))

print(segs)
# print(segs)
# print(typeof(segs))

# define ref point
ref <- point_on(offset, x, y)
if (length(ref) == 0){
ref <- c(x[1], y[1])
warning("Could not find the reference point. You may want to adjust the offset.")
}

positions <- data.frame(letter = unlist(strsplit(label, "")),
positions <- data.frame(label = unlist(strsplit(text, "")),
x = numeric(n),
y = numeric(n),
angle = numeric(n),
angle2 = numeric(n),
id = 1:n,
refx = numeric(n),
refy = numeric(n))

for (i in 1:n){
print(ref)
# print(ref)

# find segment corresponding to ref point
print(mutate(segs, t1 =(((xn <= ref[1]) & (x >= ref[1])) | ((xn >= ref[1]) & (x <= ref[1]))),
t2 = (((yn <= ref[2]) & (y >= ref[2])) | ((yn >= ref[2]) & (y <= ref[2]))),
t3 = (floor((ref[2] - yn) / (ref[1] - xn) - (y - ref[2])/(x - ref[1]) ) < 0.01)))
# print(mutate(segs, t1 =(((xn <= ref[1]) & (x >= ref[1])) | ((xn >= ref[1]) & (x <= ref[1]))),
# t2 = (((yn <= ref[2]) & (y >= ref[2])) | ((yn >= ref[2]) & (y <= ref[2]))),
# t3 = (floor((ref[2] - yn) / (ref[1] - xn) - (y - ref[2])/(x - ref[1]) ) < 0.01)))

segment <- filter(segs, (((xn <= ref[1]) & (x >= ref[1])) | ((xn >= ref[1]) & (x <= ref[1]))) &
(((yn <= ref[2]) & (y >= ref[2])) | ((yn >= ref[2]) & (y <= ref[2]))) #&
# (floor((ref[2] - yn) / (ref[1] - xn) - (y - ref[2])/(x - ref[1]) ) < 0.01)
)[1,]

print(segment)
# print(segment)

# define upstream path

up <- segs %>% filter(seg <= segment$seg) %>% select(xn, yn) %>% rename(x = xn, y = yn)
print((up))
print((up[dim(up)[1]:1,]))
# print((up))
# print((up[dim(up)[1]:1,]))
up <- rbind(ref, up[dim(up)[1]:1,])

# define downsteam path
down <- segs %>% filter(seg >= segment$seg) %>% select(x, y)
print(head(up))
# print(head(up))
down <- rbind(ref, down)

# compute letter position and angle
point <- position_letter(down$x, down$y, up$x, up$y, win = win, offset = vpos, centred = T)
print(point)
# print(point)
# print(ref)
# print(c(point, ref))

# save
positions[i, c("x", "y", "angle", "refx", "refy")] <- c(point, ref)
positions[i, c("x", "y", "angle2", "refx", "refy")] <- c(point, ref)


# define new ref point
ref <- point_on(dist, down$x, down$y)
if (length(ref) == 0){
ref <- c(x[1], y[1])
warning("Could not find the reference point. You may want to adjust the offset.")
}
}
positions$angle2[is.na(positions$angle2)] <- 0
return(positions)
}
62 changes: 54 additions & 8 deletions README.Rmd
Original file line number Diff line number Diff line change
Expand Up @@ -16,15 +16,61 @@ Before having functional labels and defining nice default parameters that give n

### TO DO LIST

- make it work with point: place points along the path in place of letters.
- include in geom
- make it work with entire labels
- make it work with letters
- $\checkmark$ make it work with point: place points along the path in place of letters;
- $\checkmark$ include in geom;
- $\Box$ make it work with entire labels as an option;
- $\checkmark$ make it work with letters;


### TO DO if the rest is done and clean

- make river specific geom (size~order)
- make interactive tool to test the parameters
- find good default parameters
- scale against text size or plot size ?
- $\Box$ make river specific geom (size~order);
- $\Box$ make interactive tool to test the parameters;
- $\Box$ find good default parameters;
- $\Box$ scale against text size or plot size ?;


## Demo

```{r gulk}
library(ggriverlab)
library(riverdist)
library(ggplot2)
river <- as.data.frame(Gulk$lines[4])
colnames(river) <- c("x", "y")
ggplot(river, aes(x,y)) + geom_path() + coord_fixed()
ggplot(river, aes(x,y)) + geom_path() + coord_fixed() + geom_river_label(aes(label = "Gulk", offset = 14000, dist = 1500, vpos = 2000, win = 3000))
# the full fiver
branches <- 1:14
branch_list <- lapply(branches, function(b, Gulk){
river <- as.data.frame(Gulk$lines[b])
colnames(river) <- c("x", "y")
river$branch <- b
return(river)
}, Gulk)
full_river<- do.call(rbind, branch_list)
ggplot(full_river, aes(x,y, group = branch, colour = branch)) + geom_path() + coord_fixed() + geom_river_label(aes(label = "Gulk", offset = 6000, dist = 2000, vpos = 3000, win = 3000))
```
```{r animate}
# install.packages('devtools')
# devtools::install_github('thomasp85/gganimate')
library(gganimate)
# generate data for the animation
offsets <- seq(2000, 21000, length.out = 10)
list_data <- lapply(offsets, function(os, river){
river$off <- os
return(river)
}, river)
data_offset <- do.call(rbind, list_data)
anim <- ggplot(data_offset, aes(x,y)) + geom_path() + coord_fixed() + geom_river_label(aes(label = "Gulk", offset = off, dist = 1500, vpos = 1500, win = 4000))+
transition_states(off, 1, 3)
```
245 changes: 235 additions & 10 deletions README.nb.html

Large diffs are not rendered by default.

40 changes: 40 additions & 0 deletions man/geom_river_label.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading

0 comments on commit 4a15fbe

Please sign in to comment.