gganimate animate multiple paths based on time - r

I have parsed some data on grenade throws from the videogame Counter Strike. The sample data beloew reveals that I have positions on where the grenade is thrown from and where the grenade detonates and when the grenade is thrown.
df <- data.frame(pos_x = c(443.6699994744587,459.4566921116250, 443.5131582404877, 565.8823313012402, 725.3048665125078, 437.3428992800084, 475.7286794460795, 591.4138769182258),
pos_y = c(595.8564633895517, 469.8560006170301, 558.8543552036199, 390.5840189222542, 674.7983854380914, 688.0909476552858, 468.4987145207733, 264.6016042780749),
plot_group = c(1, 1, 2, 2, 3, 3, 4, 4),
round_throw_time = c(31.734375, 31.734375, 24.843750, 24.843750, 35.281250, 35.281250, 30.437500, 30.437500),
pos_type = c("Player position", "HE detonate", "Player position", "HE detonate", "Player position", "HE detonate", "Player position", "HE detonate"))
And using ggplot2 I can plot the static trajectories of the grenades like shown here
But I would like to animate the grenade trajectories and iniate the animation of each trajectory in the order that round_throw_time prescribes it and moving from player position to detonate position.
So far I have attempted this:
ggplot(df, aes(pos_x, pos_y, group = plot_group)) +
annotation_custom(grid::rasterGrob(img, width = unit(1,"npc"), height =
unit(1,"npc")), 0, w, 0, -h) +
scale_x_continuous(expand = c(0,0),limits = c(0,w)) +
scale_y_reverse(expand = c(0,0),limits = c(h,0)) +
geom_point(color = "red") +
transition_states(states=pos_type, transition_length = 1, state_length = 1)
But I'm kinda lost when it comes to adding the trajectory lines and how to reset the animation instead of the point just moving back to their origin.
Any tips would be greatly appreciated!
The image I plot onto can be downloaded here
http://simpleradar.com/downloads/infernoV2.zip

First of all, this is awesome.
First approach using shadow_wake and no other data prep
I commented out the pieces that weren't defined in the question. I added wrap = F to make the animation reset (rather than rewind) at the end, and shadow_wake to capture the trajectory.
# The factors of pos_type are backwards (b/c alphabetical), so R thinks the detonation
# comes before the player position. Here we reverse that.
df$pos_type <- forcats::fct_rev(df$pos_type)
ggplot(df, aes(pos_x, pos_y, group = plot_group)) +
# annotation_custom(grid::rasterGrob(img, width = unit(1,"npc"), height =
# unit(1,"npc")), 0, w, 0, -h) +
scale_x_continuous(expand = c(0,0)) + # ,limits = c(0,w)) +
scale_y_reverse(expand = c(0,0)) + # ,limits = c(h,0)) +
geom_point(color = "red") +
transition_states(states=pos_type, transition_length = 1, state_length = 1, wrap = F) +
shadow_wake(wake_length = 1)
Second approach, adding initial position and geom_segment
We could also add the trajectory as a segment, if we give each frame a reference to the player position:
df %>%
# Add reference to first coordinates for each plot_group
left_join(by = "plot_group",
df %>%
group_by(plot_group) %>%
filter(pos_type == "Player position") %>%
mutate(pos_x1 = pos_x, pos_y1 = pos_y) %>%
select(plot_group, pos_x1, pos_y1)
) %>%
ggplot(aes(pos_x, pos_y, group = plot_group)) +
# annotation_custom(grid::rasterGrob(img, width = unit(1,"npc"), height =
# unit(1,"npc")), 0, w, 0, -h) +
scale_x_continuous(expand = c(0,0)) + # ,limits = c(0,w)) +
scale_y_reverse(expand = c(0,0)) + # ,limits = c(h,0)) +
geom_point(color = "red") +
geom_segment(color = "gray70", aes(xend = pos_x1, yend = pos_y1)) +
transition_states(states=pos_type, transition_length = 1, state_length = 1, wrap = F)
Third variation, showing trajectories by start time
Similar to 2nd, but I add each trajectory's distance, travel time, and start time. I assume here that the detonation is the end time, and work back to when the trajectory started.
(I first tried transition_time, but couldn't get it to work without buggy behavior after the first trajectory.)
# trajectory speed
dist_per_time = 50
df2 <- df %>%
# Add reference to first coordinates for each plot_group
left_join(by = "plot_group",
df %>%
group_by(plot_group) %>%
filter(pos_type == "Player position") %>%
mutate(pos_x1 = pos_x, pos_y1 = pos_y) %>%
select(plot_group, pos_x1, pos_y1)
) %>%
left_join(by = c("plot_group", "pos_type"),
df %>%
group_by(plot_group) %>%
mutate(x_d = (range(pos_x)[1] - range(pos_x)[2]),
y_d = (range(pos_y)[1] - range(pos_y)[2]),
dist = sqrt(x_d^2 + y_d^2),
event_time = round_throw_time - if_else(pos_type == "Player position",
dist / dist_per_time,
0),
event_time = round(event_time, 1)) %>%
select(plot_group, pos_type, dist, event_time)
) %>%
### EDIT - added below to make timing explicit and fix code which
# was broken in current version of gganimate # 2019-11-15
# Thanks #Deep North for tip.
group_by(plot_group) %>%
mutate(event_time_per_grp = event_time - first(event_time)) %>%
ungroup() %>%
mutate(event_time_cuml = cumsum(event_time))
ggplot(df2, aes(pos_x, pos_y, group = plot_group)) +
# annotation_custom(grid::rasterGrob(img, width = unit(1,"npc"), height =
# unit(1,"npc")), 0, w, 0, -h) +
scale_x_continuous(expand = c(0,0)) + # ,limits = c(0,w)) +
scale_y_reverse(expand = c(0,0)) + # ,limits = c(h,0)) +
geom_point(color = "red") +
geom_segment(color = "gray70", aes(xend = pos_x1, yend = pos_y1)) +
transition_reveal(event_time_cuml) ### EDIT, see above

Related

Different objects are not showing up on my ggplot2

I'm studying the returns to college admission for marginal student and i'm trying to make a ggplot2 of the following data which is, average salaries of students who finished or didn't finish their masters in medicin and the average 'GPA' (foreign equivalent) distance to the 'acceptance score':
SalaryAfter <- c(287.780,305.181,323.468,339.082,344.738,370.475,373.257,
372.682,388.939,386.994)
DistanceGrades <- c("<=-1.0","[-0.9,-0.5]","[-0.4,-0.3]","-0,2","-0.1",
"0.0","0.1","[0.2,0.3]","[0.4,0.5]",">=0.5")
I have to do a Regression Discontinuity Design (RDD), so to do the regression - as far as i understand it - i have to rewrite the DistanceGrades to numeric so i just created a variable z
z <- -5:4
where 0 is the cutoff (ie. 0 is equal to "0.0" in DistanceGrades).
I then make a dataframe
df <- data.frame(z,SalaryAfter)
Now my attempt to create the plot gets a bit messy (i use the package 'fpp3', but i suppose that it is just the ggplot2 and maybe dyplr packages)
df %>%
select(z, SalaryAfter) %>%
mutate(D = as.factor(ifelse(z >= -0.1, 1, 0))) %>%
ggplot(aes(x = z, y = SalaryAfter, color = D)) +
geom_point(stat = "identity") +
geom_smooth(method = "lm") +
geom_vline(xintercept = 0) +
theme(panel.grid = element_line(color = "white",
size = 0.75,
linetype = 1)) +
xlim(-6,5) +
xlab("Distance to acceptance score") +
labs(title = "Figur 1.1", subtitle = "Salary for every distance to the acceptance score")
Which plots:
What i'm trying to do is firstly, split the data with a dummy variable D=1 if z>0 and D=0 if z<0. Then i plot it with a linear regression and a vertical line at z=0. Lastly i write the title and subtilte. Now i have two problems:
The x axis is displaying -5, -2.5, ... but i would like for it to show all the integers, the rational numbers have no relation to the z variable which is discrete. I have tried to fix this with several different methods, but none of them have worked, i can't remember all the ways i have tried (theme(panel.grid...),scale_x_discrete and many more), but the outcome has all been pretty similar. They all cause the x-axis to be completely removed such that there is no numbers and sometimes it even removes the axis title.
i would like for the regression channel for the first part of the data to extend to z=0
When i try to solve both of these problems i again get similar results, most of the things i try is not producing an error message when i run the code, but they either do nothing to my plot or they remove some of the existing elements which leaves me made of questions. I suppose that the error is caused by some of the elements not working together but i have no idea.
Try this:
library(tidyverse)
SalaryAfter <- c(287.780,305.181,323.468,339.082,344.738,370.475,373.257,
372.682,388.939,386.994)
DistanceGrades <- c("<=-1.0","[-0.9,-0.5]","[-0.4,-0.3]","-0,2","-0.1",
"0.0","0.1","[0.2,0.3]","[0.4,0.5]",">=0.5")
z <- -5:4
df <- data.frame(z,SalaryAfter) %>%
select(z, SalaryAfter) %>%
mutate(D = as.factor(ifelse(z >= -0.1, 1, 0)))
# Fit a lm model for the left part of the panel
fit_data <- lm(SalaryAfter~z, data = filter(df, z <= -0.1)) %>%
predict(., newdata = data.frame(z = seq(-5, 0, 0.1)), interval = "confidence") %>%
as.data.frame() %>%
mutate(z = seq(-5, 0, 0.1), D = factor(0, levels = c(0, 1)))
# Plot
ggplot(mapping = aes(color = D)) +
geom_ribbon(data = filter(fit_data, z <= 0 & -1 <= z),
aes(x = z, ymin = lwr, ymax = upr),
fill = "grey70", color = "transparent", alpha = 0.5) +
geom_line(data = fit_data, aes(x = z, y = fit), size = 1) +
geom_point(data = df, aes(x = z, y = SalaryAfter), stat = "identity") +
geom_smooth(data = df, aes(x = z, y = SalaryAfter), method = "lm") +
geom_vline(xintercept = 0) +
theme(panel.grid = element_line(color = "white",
size = 0.75,
linetype = 1)) +
scale_x_continuous(limits = c(-6, 5), breaks = -6:5) +
xlab("Distance to acceptance score") +
labs(title = "Figure 1.1", subtitle = "Salary for every distance to the acceptance score")

Avoid overlap of points on a timeline (1-D repeling)

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)

Re-labeling one axis on a dual-axis chart

I have a chart which shows lap position progression over a 2 lap race from starting position to end position.
I would like to amend the chart to have the drivers name on the left y-axis, which aligns with their starting position (i.e from top to bottom, the names would read bill, who started first, maria, who started second, and claudio, who started third) and their end position number would be on the right side (from top to bottom, first to third)
I have been working on this for a while but can't figure it out. Also, as shown, I'd like the chart to go from 1 at the top to 3 at the bottom, but I can't get rid of the negative for some reason. Many thanks for anybody that can help:
## reprex
library(ggplot2)
library(scales)
dat <- data.frame(name = c(rep("bill", 3), rep("maria", 3), rep("claudio", 3)),
lap = rep(0:2, 3),
pos = c(1, 1, 2,
2, 3, 1,
3, 2, 3))
dat %>%
ggplot(aes(x = lap, y = -pos, color = name)) +
geom_line() +
scale_y_continuous(breaks = pretty_breaks(3),
sec.axis = dup_axis()) +
scale_x_continuous(breaks = pretty_breaks(3))
Desired end result:
You can label the primary axis using a labeller function that finds which driver was at each position on lap 0, and add a sec_axis instead of a dup_axis.
You can also use scale_y_reverse rather than using -pos to order the axis correctly:
dat %>%
ggplot(aes(x = lap, y = pos, color = name)) +
geom_line() +
scale_y_reverse(breaks = 1:3,
labels = function(x) {
dat$name[dat$lap == 0][order(dat$pos[dat$lap == 0])][x]
},
sec.axis = sec_axis(function(x) x,
breaks = 1:3, labels = label_ordinal())) +
scale_x_continuous(breaks = pretty_breaks(3))
You could also stick with your -pos to reorder your y-axis and then simply reorder the breaks and labels the same way. Less elegant than Allan Cameron solution, though.
Cheers
ggplot(dat, aes(x = lap, y = -as.numeric(pos), color = Driver, group = Driver)) +
geom_line(show.legend = F) +
scale_y_continuous(name = "Driver",
breaks = -(1:nlevels(dat$Driver)),
labels = unique(dat$Driver),
sec.axis = sec_axis(~.,
name = "End Position",
breaks = -(1:length(levels(as.factor(dat$pos)))),
labels = levels(as.factor(dat$pos))))+
scale_x_continuous(breaks = pretty_breaks(3))

Connect multiple points across multiple facets with a dashed line

I have following data. Each observation is a genomic coordinate with copy number changes (copy.number.type) which is found in some percentage of samples (per.found).
chr<-c('1','12','2','12','12','4','2','X','12','12','16','16','16','5'
,'4','16','X','16','16','4','1','5','2','4','5','X','X','X','4',
'1','16','16','1','4','4','12','2','X','1','16','16','2','1','12',
'2','2','4','4','2','1','5','X','4','2','12','16','2','X','4','5',
'4','X','5','5')
start <- c(247123880,91884413,88886155,9403011,40503634,10667741,88914884,
100632615,25804205,25803542,18925987,21501823,21501855,115902990,
26120955,22008406,432498,22008406,22008406,69306802,4144380,73083197,
47743372,34836043,16525257,315832,1558229,51048657,49635818,239952709,
69727769,27941625,80328938,49136485,49136654,96076105,133702693,315823,
16725215,69728318,88520557,89832606,202205081,124379013,16045662,89836880,
49657307,97117994,76547133,35051701,344973,1770075,49139874,77426085,
9406416,69727781,108238962,151006944,49121333,6669602,89419843,74214551,
91203955,115395615)
type <- c('Inversions','Deletions','Deletions','Deletions','Deletions','Duplications','Deletions','Deletions',
'Duplications','Deletions','Duplications','Inversions','Inversions','Deletions','Duplications',
'Deletions','Deletions','Deletions','Deletions','Inversions','Duplications','Inversions','Inversions',
'Inversions','Deletions','Deletions','Deletions','Insertions','Deletions','Inversions','Inversions',
'Inversions','Inversions','Deletions','Deletions','Inversions','Deletions','Deletions','Inversions',
'Inversions','Deletions','Deletions','Deletions','Insertions','Inversions','Deletions','Deletions',
'Deletions','Inversions','Deletions','Duplications','Inversions','Deletions','Deletions','Deletions',
'Inversions','Deletions','Inversions','Deletions','Inversions','Inversions','Inversions','Deletions','Deletions')
per.found <- c(-0.040,0.080,0.080,0.040,0.080,0.040,0.080,0.040,0.040,0.120,0.040,-0.080,-0.080,0.040,0.040,0.120,
0.040,0.120,0.120,-0.040,0.011,-0.011,-0.023,-0.023,0.011,0.023,0.011,0.011,0.011,-0.011,-0.034,
-0.011,-0.023,0.011,0.011,-0.011,0.023,0.023,-0.023,-0.034,0.011,0.023,0.011,0.011,-0.023,0.023,
0.011,0.011,-0.011,0.011,0.011,-0.023,0.011,0.057,0.011,-0.034,0.023,-0.011,0.011,-0.011,-0.023,
-0.023,0.011,0.011)
df <- data.frame(chromosome = chr, start.coordinate = start, copy.number.type = type, per.found = per.found )
I would like to create a line plot. I created a plot using ggplot (facets), but the problem is I can not connect the points between two facets. Is there any way to do that. I do not necessarily need to use facets if there is a way to annotate x axis scales by chromosome. In the following image the dotted line shows what I would like to have for all copy.number.type lines.
EDIT: Looking for simplified approach.
library(ggplot2)
ggplot(df, aes(x=start.coordinate,y=per.found, group=copy.number.type, color=copy.number.type))+
geom_line()+
geom_point()+
facet_grid(.~chromosome,scales = "free_x", space = "free_x")+
theme(axis.text.x = element_text(angle = 90, hjust = 1))
Desired output: As shown by the red dashed lines. I want to connect all the border points with a dashed line across facets.
Note: it may not make sense to connect the lines between the chromosomes.
But here is one way, by avoiding facets:
library(dplyr)
df2 <- df %>%
mutate(chromosome = factor(chromosome, c(1, 2, 4, 5, 12, 16, 'X'))) %>%
arrange(chromosome, start.coordinate)
chromosome_positions <- df2 %>%
group_by(chromosome) %>%
summarise(start = first(start.coordinate), end = last(start.coordinate)) %>%
mutate(
size = end - start,
new_start = cumsum(lag(size, default = 0)),
new_end = new_start + size
)
df3 <- df2 %>%
left_join(chromosome_positions, 'chromosome') %>%
mutate(new_x = start.coordinate + (new_start - start))
ggplot(df3, aes(x=new_x,y=per.found, group=copy.number.type, color=copy.number.type))+
geom_rect(
aes(xmin = new_start, xmax = new_end, ymin = -Inf, ymax = Inf, fill = chromosome),
chromosome_positions, inherit.aes = FALSE, alpha = 0.3
) +
geom_line() +
geom_point() +
geom_text(
aes(x = new_start + 0.5 * size, y = Inf, label = chromosome),
chromosome_positions, inherit.aes = FALSE, vjust = 1
) +
scale_fill_manual(values = rep(c('grey60', 'grey90'), 10), guide = 'none') +
scale_x_continuous(expand = c(0, 0))

Using geom_segment to create a timeline visualization

I am trying to create a chart like this one produced in the NYTimes using ggplot:
I think I'm getting close, but I'm not quite sure how to separate out some of my data so I get the right view. My data is political office holders that appear something like this:
name,year_elected,year_left,years_in_office,type,party
Person 1,1969,1969,1,Candidate,Unknown
Person 2,1969,1971,2,Candidate,Unknown
Person 3,1969,1973,4,Candidate,Unknown
Person 4,1969,1973,4,Candidate,Unknown
Person 5,1971,1974,3,Candidate,Unknown
Person 1,1971,1976,5,Candidate,Unknown
Person 2,1971,1980,9,Candidate,Unknown
Person 6,1973,1978,5,Candidate,Unknown
Person 7,1973,1980,7,Candidate,Unknown
Person 8,1975,1980,5,Candidate,Unknown
Person 9,1977,1978,1,Candidate,Unknown
And I've used the below code to get very close to this view, but I think an issue I'm running into is either drawing segments incorrectly (e.g., I don't seem to have a single segment for each candidate), or segments are overlapping/stacking. The key issue I'm running into is my list of office holders is around 60, but my chart is only drawing around 28 lines.
library(googlesheets)
library(tidyverse)
# I'm reading from a Google Spreadsheet
data <- gs_title("Council Members")
data_sj <- gs_read(ss = data, ws = "Sheet1")
ggplot(data, aes(year_elected, years_in_office)) +
geom_segment(aes(x = year_elected, y = 0,
xend = year_left, yend = years_in_office)) +
theme_minimal()
The above code gives me:
Thanks ahead of time for any pointers!
If your data frame is called d, then:
Transform it to data.table
Add jitter to year_electer
Add equivalent jitter to year_left
Add group (as an example) to color your samples
Use ggrepel to add text if there are many points.
Code:
library(data.table)
library(ggplot2)
library(ggrepel)
d[, year_elected2 := jitter(year_elected)]
d[, year_left2 := year_left + year_elected2 - year_elected + 0.01]
d[, group := TRUE]
d[factor(years_in_office %/% 9) == 1, group := FALSE]
ggplot(d, aes(year_elected2, years_in_office)) +
geom_segment(aes(x = year_elected2, xend = year_left2,
y = 0, yend = years_in_office, linetype = group),
alpha = 0.8, size = 1, color = "grey") +
geom_point(aes(year_left2), color = "black", size = 3.3) +
geom_point(aes(year_left2, color = group), size = 2.3) +
geom_text_repel(aes(year_left2, label = name), ) +
scale_colour_brewer(guide = FALSE, palette = "Dark2") +
scale_linetype_manual(guide = FALSE, values = c(2, 1)) +
labs(x = "Year elected",
y = "Years on office") +
theme_minimal(base_size = 10)
Result:
For the record and to address my comment on #PoGibas answer above, here's my tidyverse version:
data_transform <- data_sj %>%
mutate(year_elected_jitter = jitter(year_elected)) %>%
mutate(year_left_jitter = year_left + year_elected_jitter - year_elected + 0.01)
ggplot(data_transform, aes(year_elected, years_in_office, label = name)) +
geom_segment(aes(x = year_elected_jitter, y = 0, xend = year_left_jitter, yend = years_in_office, color = gender), size = 0.3) +
geom_text_repel(aes(year_left_jitter, label = name)) +
theme_minimal()

Resources