I'm working with spatial data. I'd like to create an animation of a movement path, with older data fading out. I figured out how to create the fade-out effect with points, but it looks like there's no built-in support for transitions for geom_path (Error: path layers not currently supported by transition_components). But are there any clever workarounds that could be used? My full dataset is large (200K points) and the overlapping paths get out of hand...
toy data:
library(ggplot2)
library(gganimate)
df <- structure(list(Lon = c(-66.6319163369509, -66.5400363369509,
-65.3972830036509, -65.2810430036509, -65.1169763369509, -64.7409730036509,
-64.3898230036509, -64.3458230036509, -64.1435830036509, -64.1902230036509,
-64.5269330036509, -64.5508330036509, -64.9324130036509, -66.4002496703509,
-66.4605896703509, -66.6230763369509, -66.6636963369509, -66.6425830036509,
-66.5310230036509, -66.4582830036509, -66.2992030036509, -65.8810363369509,
-65.3338363369509, -65.2480363369509, -65.3705963369509, -65.8357874342282,
-66.7324643369709, -66.8768896703509, -66.8215363369509, -66.8320584884004
), Lat = c(63.9018749538395, 64.1357216205395, 64.4444682872395,
64.4580016205395, 64.4744549538395, 64.4951416205395, 64.5202416205395,
64.5237216205395, 64.5388016205395, 64.5400516205395, 64.5090116205395,
64.5069516205395, 64.4609016205395, 64.2904882872395, 64.1898016205395,
63.9022816205395, 63.9948082872395, 64.0236682872395, 64.1115882872395,
64.2171216205395, 64.3599949538395, 64.3979682872395, 64.4634216205395,
64.4719816205395, 64.4459016205395, 64.4008282316608, 63.8029216205395,
63.7730882872395, 63.8046816205395, 63.8239941445658), DateTime = structure(c(1451784300,
1451790981, 1451806092, 1451807038, 1451808331, 1451811238, 1451813999,
1451814338, 1451815898, 1451820189, 1451822838, 1451823018, 1451826048,
1451838029, 1451840610, 1451848380, 1451864271, 1451865064, 1451867591,
1451870472, 1451874641, 1451878100, 1451882678, 1451883331, 1451886921,
1451890867, 1451910187, 1451925099, 1451929401, 1451934427), class = c("POSIXct",
"POSIXt"), tzone = "GMT")), class = c("tbl_df", "tbl", "data.frame"
), row.names = c(NA, -30L))
df$TimeNum <- as.numeric(df$DateTime)
Plots:
##### successful fade - with points
p <- ggplot(df) +
geom_point(aes(x = Lon, y = Lat), size = 2) +
transition_components(TimeNum, exit_length = 20) +
ease_aes(x = 'sine-out', y = 'sine-out') +
shadow_wake(0.05, size = 2, alpha = TRUE, wrap = FALSE, #exclude_layer = c(2, 3),
falloff = 'sine-in', exclude_phase = 'enter')
animate(p, renderer = gifski_renderer(loop = F), duration = 10)
anim_save("try.gif")
##### successful plot with geom_path, but no fading - it gets REALLY busy with the
##### full dataset!
p1 <- ggplot(df) +
geom_path(aes(x = Lon, y = Lat), size = 2) +
transition_reveal(DateTime, keep_last = FALSE) +
labs(title = 'A: {frame_along}') +
exit_fade()
animate(p1, renderer = gifski_renderer(loop = F), duration = 10)
anim_save("try1.gif", width = 1000, height = 1000)
I'm not sure this is exactly what you're looking for, but you could use geom_segment instead of geom_path by adding the adjacent coordinate.
library(dplyr)
df1 <- df %>%
mutate(next_Lon = lead(Lon),
next_Lat = lead(Lat))
ggplot(df1) +
geom_segment(aes(x = Lon, y = Lat,
xend = next_Lon,
yend = next_Lat), size = 2) +
geom_point(aes(x = Lon, y = Lat), size = 2) +
transition_components(TimeNum, exit_length = 20) +
ease_aes(x = 'sine-out', y = 'sine-out') +
shadow_wake(0.05, size = 2, alpha = TRUE, wrap = FALSE, #exclude_layer = c(2, 3),
falloff = 'sine-in', exclude_phase = 'enter')
Related
I want to create a timeline plot that roughly resembles the example below: lots of overlap at some points, not a lot of overlap at others.
What I need: overlapping images should repel each other where necessary, eliminating or reducing overlap. Ideally I'd be able to implement either a vertical or horizontal repel.
library(tidyverse)
library(ggimage)
test_img <- list.files(system.file("extdata", package="ggimage"), pattern="png", full.names=TRUE)
set.seed(123)
df <-
tibble(date = as.Date(paste0("2020-", round(runif(45, 1, 2)), "-", round(runif(45, 1, 10)))),
group = paste0("Timeline ", rep(1:9, each = 5)),
img = sample(test_img, size = 45, replace = T) )
df %>%
ggplot() +
geom_line(aes(x = date, y = group, group = group), size = 5, alpha = 0.2) +
geom_image(aes(x = date, y = group, image = img, group = group), asp = 1)
Something similar to the repelling in ggbeeswarm::geom_beeswarm or ggrepel::geom_text_repel would be nice, but those don't support images. So I think I need to pre-apply some kind of 1-dimensional packing algorithm, implementing iterative pair-wise repulsion on my vector of dates within each group, to try to find a non-overlapping arrangement.
Any ideas? Thank you so much!
Created on 2021-10-30 by the reprex package (v2.0.1)
Here is the solution I’ve been able to come up with, repurposing the circleRepelLayout function from the awesome packcircles package
into the repel_vector vector function that takes in your overlapping vector and a "repel_radius", and returns, if possible, a non-overlapping version.
I demonstrate the solution with the richtext geom since this is a geom I’ve always wished had repel functionality.
library(packcircles)
library(tidyverse)
library(ggtext)
library(ggimage)
repel_vector <- function(vector, repel_radius = 1, repel_bounds = range(vector)){
stopifnot(is.numeric(vector))
repelled_vector <-
packcircles::circleRepelLayout(x = data.frame(vector, ypos = 1, repel_radius),
xysizecols = c("vector", "ypos", "repel_radius"),
xlim = repel_bounds, ylim = c(0,1),
wrap = FALSE) %>%
as.data.frame() %>%
.$layout.x
return(repelled_vector)
}
overlapping_vec <- c(1, 1.1, 1.2, 10, 10.1, 10.2)
repelled_vec_default <- repel_vector(overlapping_vec)
repelled_vec_tighter <- repel_vector(overlapping_vec, repel_radius = 0.35)
ggplot() +
annotate("richtext", x = overlapping_vec, y = 3, label = "**test**", alpha = 0.5) +
annotate("richtext", x = repelled_vec_default, y = 2, label = "**test**", alpha = 0.5) +
annotate("richtext", x = repelled_vec_tighter, y = 1, label = "**test**", alpha = 0.5) +
scale_y_continuous(breaks = 1:3, labels = c("Tighter repel", "Default repel", "Overlapping points"))
In theory you apply this to 2D repelling as well.
To solve the problem in my question, this can be applied like so:
test_img <- list.files(system.file("extdata", package="ggimage"), pattern="png", full.names=TRUE)
set.seed(123)
df <-
tibble(date = as.Date(paste0("2020-", round(runif(45, 1, 2)), "-", round(runif(45, 1, 10)))),
group = paste0("Timeline ", rep(1:9, each = 5)),
img = sample(test_img, size = 45, replace = T) ) %>%
group_by(group) %>%
mutate(repelled_date = repel_vector(as.numeric(date),
repel_radius = 4,
repel_bounds = range(as.numeric(date)) + c(-3,3)),
repelled_date = as.Date(repelled_date, origin = "1970-01-01"))
df %>%
ggplot() +
geom_line(aes(x = date, y = group, group = group), size = 5, alpha = 0.2) +
geom_image(aes(x = repelled_date, y = group, image = img, group = group), asp = 1)
Created on 2021-10-30 by the reprex package (v2.0.1)
I've got a data like below:
structure(list(bucket = structure(1:23, .Label = c("(1.23,6.1]",
"(6.1,10.9]", "(10.9,15.6]", "(15.6,20.4]", "(20.4,25.1]", "(25.1,29.9]",
"(29.9,34.6]", "(34.6,39.4]", "(39.4,44.2]", "(44.2,48.9]", "(48.9,53.7]",
"(53.7,58.4]", "(58.4,63.2]", "(63.2,68]", "(68,72.7]", "(72.7,77.5]",
"(77.5,82.2]", "(82.2,87]", "(87,91.7]", "(91.7,96.5]", "(96.5,101]",
"(101,106]", "(106,111]"), class = "factor"), value = c(0.996156321090158, 0.968144290236367, 0.882793110384066, 0.719390676388129, 0.497759597498133,
0.311721580067415, 0.181244079443301, 0.0988516758834657, 0.0527504526341006,
0.0278716018561911, 0.0145107725175315, 0.00785033086321829,
0.00405759957072942, 0.00213190168252939, 0.00109610249274952,
0.000578154695264754, 0.000301095727545301, 0.000155696457494707,
8.2897211122996e-05, 4.09225082176349e-05, 2.33782236798641e-05,
1.21665352966827e-05, 6.87373003802479e-06), bucket_id = 1:23), class = c("tbl_df",
"tbl", "data.frame"), row.names = c(NA, -23L))
Which I want to visualise as a circular stacked bar plot:
cutoff_values <- seq(0, 115, by = 5)
library(tidyverse)
ex %>%
mutate(r0 = cutoff_values[-length(cutoff_values)],
r = cutoff_values[-1]) %>%
mutate(x0 = 100,
y0 = 50) %>%
ggplot(aes(x0 = x0, y0 = y0, r0 = r0, r = r)) +
ggforce::geom_arc_bar(aes(start = 0, end = 2 * pi, fill = value),
colour = NA) +
theme_void() +
labs(fill = 'colour')
But I also need to be able to mark out some particular bucket with different filling at best. So I need to be able to preserve filling using value with continuous scale, but also fill one particular stratum (let's say bucket == 15) with another colour, leaving the other strata (buckets) as they are. Is it possible? What are the alternatives to mark out bucket 15th?
I believe that this can be done with the relayer package, which is still highly experimental. You can copy a subset of your data in a seperate geom and give it another fill aesthetic. This seperate geom can then be piped into rename_geom_aes() and you would have to set the scale_fill_*() for your renamed aesthetic. You'd probably get a warning about that the geom is ignoring unknown aesthetics, but I don't know if that can be helped.
Below is an example for making bucket 15 red.
library(tidyverse)
library(relayer) # https://github.com/clauswilke/relayer
ex <- df %>%
mutate(r0 = cutoff_values[-length(cutoff_values)],
r = cutoff_values[-1]) %>%
mutate(x0 = 100,
y0 = 50)
ggplot(ex, aes(x0 = x0, y0 = y0, r0 = r0, r = r)) +
ggforce::geom_arc_bar(aes(start = 0, end = 2 * pi, fill = value),
colour = NA) +
ggforce::geom_arc_bar(data = ex[ex$bucket_id == 15,], # Whatever bucket you want
aes(start = 0, end = 2 * pi, fill2 = as.factor(bucket_id))) %>%
rename_geom_aes(new_aes = c("fill" = "fill2")) +
scale_fill_manual(aesthetics = "fill2", values = "red", guide = "legend") +
theme_void() +
labs(fill = 'colour', fill2 = "highlight")
I want to highlight text based on the position in a string, for example if we have this text:
this is a really nice informative piece of text
Then I want to say let's draw a rectangle around positions 2 till 4:
t[his] is a really nice informative piece of text
I tried to do so in ggplot2 using the following code:
library(ggplot2)
library(dplyr)
box.data <- data.frame(
start = c(4,6,5,7,10,7),
type = c('BOX1.start', 'BOX1.start', 'BOX1.start','BOX1.end', 'BOX1.end', 'BOX1.end'),
text.id = c(1,2,3,1,2,3)
)
text.data <- data.frame(
x = rep(1,3),
text.id = c(1,2,3),
text = c('Thisissomerandomrandomrandomrandomtext1',
'Thisissomerandomrandomrandomrandomtext2',
'Thisissomerandomrandomrandomrandomtext3')
)
ggplot(data = text.data, aes(x = x, y = text.id)) +
scale_x_continuous(limits = c(1, nchar(as.character(text.data$text[1])))) +
geom_text(label = text.data$text, hjust = 0, size = 3) +
geom_line(data = box.data, aes(x = start, y = text.id, group = text.id, size = 3, alpha = 0.5, colour = 'red'))
This produces the following graph:
My method fails as a letter does not cover exactly one unit of the x-axis, is there any way to achieve this?
I just figured out that I can split the string in characters and plot these, perhaps it is useful for someone else.
library(ggplot2)
library(dplyr)
library(splitstackshape)
# First remember the plotting window, which equals the text length
text.size = nchar(as.character(text.data$text[1]))
# Split the string into single characters, and adjust the X-position to the string position
text.data <- cSplit(text.data, 'text', sep = '', direction = 'long', stripWhite = FALSE) %>%
group_by(text.id) %>%
mutate(x1 = seq(1,n()))
# Plot each character and add highlights
ggplot(data = text.data, aes(x = x1, y = text.id)) +
scale_x_continuous(limits = c(1, text.size)) +
geom_text(aes(x = text.data$x1, y = text.data$text.id, group = text.id, label = text)) +
geom_line(data = box.data, aes(x = start, y = text.id, group = text.id, size = 3, alpha = 0.5, colour = 'red'))
Which produces this plot:
Perhaps the marking should extend a little but upwards and downwards, but that's an easy fix.
I have a dataset of people arriving in a location, how long they stayed, and their home locations. I want to create an animated chart which 'flies' them to their destination, and returns them to their original point once their trip is over. But I'm not sure if this is possible with gganimate or not. At the moment I only seem to be able to do a "start" and "end" frame, though it's a little hard to tell whether it just doesn't have enough frames to do the intended action.
Here's something like what I have so far:
library(dplyr)
library(ggplot2)
library(ggmap)
library(gganimate)
#Coordinates
europecoords <- c(left = -23, bottom = 36, right = 27.87, top = 70.7)
londonareacoords <- c(left = -.7, bottom = 51, right = 0.2, top = 52)
londonpointcoords <- as.data.frame(list(lon = -.14, lat = 51.49))
#Get the map we'll use as the background
europe <- get_stamenmap(europecoords, zoom = 4, maptype = "toner-lite")
#Sample dataset configuration
numberofpoints <- 10
balance <- 0.1
#Set up an example dataset
ids <- seq(1:numberofpoints)
arrivalday <- sample(x = 30, size = numberofpoints, replace = TRUE)
staylength <- sample(x = 7, size = numberofpoints, replace = TRUE)
startlocationlondonarealon <- sample(x = seq(londonareacoords['left'] * 10, londonareacoords['right'] * 10), size = numberofpoints * balance, replace = TRUE) / 10
startlocationlondonarealat <- sample(x = seq(londonareacoords['bottom'] * 10, londonareacoords['top'] * 10), size = numberofpoints * balance, replace = TRUE) / 10
startlocationeuropelon <- sample(x = seq(europecoords['left'] * 10, europecoords['right'] * 10), size = (numberofpoints * (1 - balance)), replace = TRUE) / 10
startlocationeuropelat <- sample(x = seq(europecoords['bottom'] * 10, europecoords['top'] * 10), size = (numberofpoints * (1 - balance)), replace = TRUE) / 10
startlocationlon <- c(startlocationlondonarealon, startlocationeuropelon)
startlocationlat <- c(startlocationlondonarealat, startlocationeuropelat)
points <- as.data.frame(cbind(ID = ids, arrivalday, staylength, departureday = arrivalday + staylength, startlocationlon, startlocationlat))
#Map the sample dataset to check it looks reasonable
ggmap(europe) +
geom_point(data = points, aes(x = startlocationlon, y = startlocationlat), col = "blue", size = 2) +
geom_point(data = londonpointcoords, aes(x = lon, y = lat), col = "red")
#Separate the events out to rearrange, then glue them back together
event1 <- points %>%
mutate(Event = "Day Before Arrival", Date = arrivalday - 1) %>%
mutate(Lon = startlocationlon,
Lat = startlocationlat) %>%
select(ID, Event, Date, Lon, Lat)
event2 <- points %>%
mutate(Event = "Arrival Date", Date = arrivalday) %>%
mutate(Lon = londonpointcoords$lon[1],
Lat = londonpointcoords$lat[1]) %>%
select(ID, Event, Date, Lon, Lat)
event3 <- points %>%
mutate(Event = "Departure Date", Date = departureday) %>%
mutate(Lon = londonpointcoords$lon[1],
Lat = londonpointcoords$lat[1]) %>%
select(ID, Event, Date, Lon, Lat)
event4 <- points %>%
mutate(Event = "Day After Departure", Date = departureday + 1) %>%
mutate(Lon = startlocationlon,
Lat = startlocationlat) %>%
select(ID, Event, Date, Lon, Lat)
events <- rbind(event1, event2, event3, event4) %>%
mutate(Event = factor(Event, ordered = TRUE, levels = c("Day Before Arrival", "Arrival Date", "Departure Date", "Day After Departure"))) %>%
mutate(ID = factor(ID))
#Make an animation
ggmap(europe) +
geom_point(data = events, aes(x = Lon, y = Lat, group = ID, col = ID), size = 2) +
#geom_point(data = londonpointcoords, aes(x = lon, y = lat), col = "red") +
transition_manual(Date) +
labs(title = "Date: {frame}") +
NULL
But as I said, the points don't seem to be 'flying' as much as just appearing and disappearing. Should I be using a different data format? Transition type? Number of frames? (I'm having trouble finding documentation on any of the above, which is part of why I'm stuck...)
Final result
Code
library(ggplot2)
library(ggmap)
library(gganimate)
ggm <- ggmap(europe) +
geom_point(data = events,
aes(x = Lon, y = Lat,
colour = ID, group = ID, shape = Event),
size = 3, alpha = 0.8) +
transition_time(Date) +
labs(title = paste("Day", "{round(frame_time,0)}")) +
shadow_wake(wake_length = 0.1)
animate(ggm, fps = 24, duration = 16)
========================================================
Step-by-step
You have lots of moving parts there. Let's break it down a bit:
0. Load libraries
library(ggplot2)
library(ggmap)
library(gganimate)
library(ggrepel) # will be useful for data exploration in step 1
1. Data exploration
ggplot(data = events, aes(x = ID, y = Date, colour = Event)) +
geom_point()
We see, that the arrival and departure events are each quite close together for each plane. Also, there is always a gap of a couple of days inbetween. That seems reasonable.
Let's check the Date variable:
> length(unique(events$Date))
[1] 24
> min(events$Date)
[1] 2
> max(events$Date)
[1] 33
Okay, this means two things:
Our data points are unevenly spaced.
We don't have data for all Dates.
Both things will make the animation part quite challenging.
ggplot(data = unique(events[, 4:5]), aes(x = Lon, y = Lat)) +
geom_point()
Furthermore, we only have 11 unique locations (== airports). This will probaly lead to overlapping data. Let's plot it by day:
ggplot(data = unique(events[, 3:5]), aes(x = Lon, y = Lat, label = Date)) +
geom_point() +
geom_text_repel()
Yup, this will be fun... Lots of things happening at that airport in the middle.
2. Basic animation
gga <- ggplot(data = events, aes(x = Lon, y = Lat)) +
geom_point() +
transition_time(Date)
animate(gga)
We used transition_time() and not transition_states(), because the former is used for linear time variables (e.g., second, day, year) and automatic interpolation, while the latter gives more manual control to the user.
3. Let's add colour
gga <- ggplot(data = events, aes(x = Lon, y = Lat, colour = ID)) +
geom_point() +
transition_time(Date)
animate(gga)
It's starting to look like something!
4. Add title, transparency, increase size
gga <- ggplot(data = events, aes(x = Lon, y = Lat, col = ID)) +
geom_point(size = 3, alpha = 0.5) +
transition_time(Date) +
labs(title = paste("Day", "{round(frame_time, 0)}"))
Note the rounded {round(frame_time, 0)}. Try using {frame_time} and see what happens!
5. Add some pizzaz
gga <- ggplot(data = events, aes(x = Lon, y = Lat, col = ID, group = ID,
shape = Event)) +
geom_point(size = 3, alpha = 0.5) +
transition_time(Date) +
labs(title = paste("Day", "{round(frame_time, 0)}")) +
shadow_wake(wake_length = 0.05)
animate(gga)
Looks good, let's finish it up!
6. Add the map, make animation slower, tweak some details
ggm <- ggmap(europe) +
geom_point(data = events,
aes(x = Lon, y = Lat,
colour = ID, group = ID, shape = Event),
size = 3, alpha = 0.8) +
transition_time(Date) +
labs(title = paste("Day", "{round(frame_time,0)}")) +
shadow_wake(wake_length = 0.1)
animate(ggm, fps = 24, duration = 16)
Not too shabby, eh? As a side note: animate(ggm, nframes = 384) would have had the same effect on the animation as fps = 24 with duration = 16.
If you have any question please do not hesitate to shoot me a comment.
I will try my best to help or clarify things.
I'm getting the following error when using ggmap: Error in if (is.waive(data) || empty(data)) return(cbind(data, PANEL = integer(0))) :
missing value where TRUE/FALSE needed
I've been using ggmap for quite some time now, but can't figure out what the problem is - tried running it on different versions of R (3.3.2, 3.3.3), still getting the same problem. Other datasets with the same spatial extent plot ok...
toy dataset
sub <- structure(list(Lat = c(49.3292885463864, 49.3316446084215,
49.3300452342386, 49.3317620975044, 49.3304515659156, 49.3305117886863,
49.3283736754004, 49.3307167462002, 49.3318995940679, 49.333169419547,
49.3309562839252, 49.3317698899629, 49.3281374770165, 49.3316554590127,
49.3326735200194, 49.331519408234, 49.3280156106529, 49.3291709916829,
49.3328300103323, 49.3306140984074), Lon = c(-117.657207875892,
-117.672957375133, -117.66331506511, -117.672862630678, -117.66304525751,
-117.668207331581, -117.655158806988, -117.66229183045, -117.673965605927,
-117.673707660621, -117.662873110863, -117.673069192809, -117.655568553898,
-117.674182492008, -117.673907352374, -117.675914855, -117.65485127671,
-117.657316414995, -117.671748537091, -117.662937333234), z =
c(9.27369836928302, 2.39183027404169, -1.93395087707449, -3.18890166171755,
-0.97968656067399, 2.2968631268102, 8.25209737911514, -1.44955530148785,
-1.16576549902187, 0.341268832113262, -1.15519233610136, 10.2579242298728,
-4.65813764430002, 0.301315621593428, 5.25169173852741, -5.37463429849591,
4.70020657978266, -4.64139357200872, -1.38702225667279, 9.38668592801448)),
.Names = c("Lat", "Lon", "z"), row.names = c(266748L, 266749L, 266750L,
266756L, 266758L, 266760L, 266768L, 266770L, 266771L, 266772L, 266778L,
266782L, 266783L, 266784L, 266787L, 266791L, 266792L, 266796L,
266801L, 266802L), class = "data.frame")
code
library(ggmap)
library(ggplot2)
prep <- get_googlemap(center = c(-117.660, 49.329), zoom = 14,
maptype = 'satellite', scale = 2)
map <- ggmap(prep, size = c(100, 200),
extent='device', darken = 0, legend = "bottom",
base_layer = ggplot(data = sub, aes(x = Lon, y = Lat)))
map
map + geom_point(data = sub, aes(x = Lon, y = Lat, colour = z), size = 1)
EDIT
I need to use facets, which is why the base_layer call is there.
Why the base_layer bit?
This works fine for me:
map <- ggmap(prep, size = c(100, 200),
extent='device', darken = 0, legend = "bottom")
map + geom_point(data = sub, aes(x = Lon, y = Lat, colour = z), size = 1)
Update:
Works with facet_wrap, too!
sub$facet <- sample(x = 1:4, size = nrow(sub), replace = TRUE)
map2 <- ggmap(ggmap = get_googlemap(maptype = 'satellite',
center = c(-117.660, 49.329),
zoom = 14)) +
geom_point(data = sub, aes(x = Lon, y = Lat, colour = z), size = 1) +
facet_wrap(~ facet, nrow = 2)