Bubble chart with round country flag symbols in ggplot/ggimage - r

I try to make a bubble chart with ggplot/ggimage by including the country flag. Here is a reproducible example:
library(dplyr)
library(ggplot)
library(ggimage)
A <- data.frame(X = c(1,4,5), Y = c(10, 1, 5), Z = c(1, 2, 3)/30, Country = c("FR", "BE", "IT"), CountryFlag = paste0("https://flagcdn.com/h20/", str_to_lower(Country), ".png"))
A_plot <- ggplot(A, mapping = aes(x = X, y = Y, size = I(Z), image = CountryFlag)) +
geom_image()
X11(); print(A_plot)
Except downloading the rounded flags, is that possible to transform the flag as rounded or is it possible to insert the country in a bubble. I tried the following code but it doesn't work:
library(dplyr)
library(ggplot)
library(ggimage)
A <- data.frame(X = c(1,4,5), Y = c(10, 1, 5), Z = c(1, 2, 3), Country = c("FR", "BE", "IT"), CountryFlag = paste0("https://flagcdn.com/h20/", str_to_lower(Country), ".png"))
A_plot <- ggplot(A, mapping = aes(x = X, y = Y, size = Z, image = CountryFlag)) +
geom_point(alpha = 0.5, col = "lightblue") +
geom_image()
X11(); print(A_plot)
I get the error:
Error in `[<-`(`*tmp*`, !is.na(alpha), 4, value = alpha[!is.na(alpha)]) :
(subscript) logical subscript too long
In addition: Warning message:
In rep(colour, length.out = length(alpha)) :
'x' is NULL so the result will be NULL
Any suggestion is welcome.

Here's a function that adds a circular mask to each flag. If we start with your plot,
A_plot
We get the urls and create some local filenames:
flags <- A_plot$data$CountryFlag
png_files <- sapply(strsplit(flags, "/"), function(x) x[length(x)])
Now we create some images with a circular mask and save them locally:
OK <- Map(function(flag, png) {
im <- magick::image_read(flag)
im <- magick::image_resize(im, magick::geometry_size_percent(500, 2000))
ii <- magick::image_info(im)
width <- ii$width
fig <- magick::image_draw(magick::image_blank(height, height))
symbols(width/2, width/2, circles=(width/2), bg='black', inches=FALSE, add=TRUE)
im2 <- magick::image_composite(im, fig, operator='copyopacity')
magick::image_write(im2, png)
}, flag = flags, png = png_files)
Now write these file paths as our image locations in the plot object:
A_plot$data$CountryFlag <- png_files
Which changes our plot to:
A_plot
For completeness, we should tidy up after ourselves once the plot is drawn:
sapply(png_files, unlink)

Funnily enough, someone just asked a question which pointed to a package for an easy way to get exactly what you want. The {ggflags} package (not on CRAN!) introduces geom_flag, which uses readily available round flag icons from the EmojiOne set as points.
library(tidyverse)
# devtools::install_github("jimjam-slam/ggflags")
library(ggflags)
Country <- c("FR", "BE", "IT")
A <- data.frame(
X = c(1, 4, 5), Y = c(10, 1, 5), Z = c(1, 2, 3), Country = tolower(Country))
ggplot(A, mapping = aes(x = X, y = Y, size = Z*3, country = Country)) +
geom_flag()+
# you can then set the scale as usual by using scale_size
scale_size_identity(guide = guide_legend())
Created on 2022-04-03 by the reprex package (v2.0.1)

Related

Error in if (RasterGeom/length(geoms) > 0.5) "above" else "below" : the condition has length > 1

When I run the following code (source : embed image: ggplot to plotly date issue):
library(ggplot2)
library(png)
library(RCurl)
library(plotly)
mydf <- data.frame(date =
as.Date(c("01/01/1998", "10/01/1998", "15/01/1998",
"25/01/1998", "01/02/1998", "12/02/1998", "20/02/1998"), "%d/%m/%Y"),
counts = c(12, 10, 2, 24, 15, 1, 14),
image = c(NA, "https://www.r-project.org/logo/Rlogo.png", NA, NA,
"https://www.r-project.org/logo/Rlogo.png", NA, NA))
mydf
# You should find some way to compute your desired image height and image width
yHeight <- (max(mydf$counts) - min(mydf$counts)) * 0.05
xWidth <- (max(as.numeric(mydf$date)) - min(as.numeric(mydf$date))) * 0.05
# create the base plot
gg2 <- ggplot(mydf, aes(date, counts)) +
geom_line()
# for each row in the df
for (x in 1:nrow(mydf)) {
row <- mydf[x, ]
if(!is.na(row$image)){
# read the image
img <- readPNG(getURLContent(row$image))
# add the image with annotation_raster
gg2 <- gg2 + annotation_raster(img,
xmin = as.numeric(row$date) - xWidth/2,
xmax = as.numeric(row$date) + xWidth/2,
ymin = row$counts - yHeight/2,
ymax = row$counts + yHeight/2)
}
}
ggplotly(gg2)
I have this error message:
Error in if (RasterGeom/length(geoms) > 0.5) "above" else "below" :
the condition has length > 1
(I cannot comment on an answer so I'm making a new question)
Thanks a lot
I couldn't find a way to resolve this problem, so I came up with a new solution to your original problem. There are two different ways to go about this, either with ggplot() and ggplotly() or just with plotly().
This doesn't use the packages png or RCurl. It does use the package magick, though.
First I changed the dates to POSIXct in your dataframe, so they work better with Plotly (which is to say so they work with Javascript). I only used the first part of your original graph, as well.
library(tidyverse)
library(plotly)
library(magick)
mydf$date <- as.POSIXct(mydf$date)
# create the base plot
gg2 <- ggplot(mydf, aes(date, counts)) +
geom_line()
Then I set up the image traces for the ggplotly object. First I wrote a function to find the number of days between dates, then I created the data formatted for Plotly.
# for the x domain; difference in days + 1
dt = function(d1 = min(mydf$date), d2){
x = length(seq(d1, d2, by = "day"))
return(x)
}
mdf = mydf %>% # image rows only
filter(!is.na(mydf$image))
ig = lapply(1:nrow(mdf),
function(i){
# get and setup image
img = image_read(mdf[i,]$image) %>% as.raster()
# get domain splitter for the x-axis (whole weeks)
ds = ceiling(dt(d2 = max(mydf$date))/7) * 7
# get position of current date on the x-axis
cs = dt(d2 = mdf[i, ]$date) + 2
list(source = raster2uri(img),
xref = "paper", yref = "y",
xanchor = "center", yanchor = "middle",
x = 1/ds * cs,
y = mdf[i, ]$counts,
sizex = 1.5, sizey = 1.5)
})
You can add this list of lists to the ggplotly object now.
ggplotly(gg2) %>%
layout(images = ig)
Alternatively, you could use Plotly directly.
plot_ly(data = mydf, x = ~date, y = ~counts,
mode = "lines+markers", type = "scatter") %>%
layout(images = ig)
Or if you don't want the markers (along with the line) in Plotly...
ig2 = lapply(1:nrow(mdf),
function(i){
# get and setup image
img = image_read(mdf[i,]$image) %>% as.raster()
# get domain splitter
ds = dt(d2 = max(mydf$date)) - 1 # exact fit
# get position of current date on the x-axis
cs = dt(d2 = mdf[i, ]$date) - 1 # exact fit
list(source = raster2uri(img),
xref = "paper", yref = "y",
xanchor = "center", yanchor = "middle",
x = 1/ds * cs,
y = mdf[i, ]$counts,
sizex = 1.5, sizey = 1.5)
})
plot_ly(data = mydf, x = ~date, y = ~counts,
mode = "lines", type = "scatter") %>%
layout(images = ig2)

Set / Link point and shape options for variables in ggplot2

I would like to link variables I have in a dataframe i.e. ('prop1', 'prop2', 'prop3') to specific colours and shapes in the plot. However, I also want to exclude data (using dplyr::filter) to customise the plot display WITHOUT changing the points and shapes used for a specific variable. A minimal example is given below.
library(ggplot2)
library(dplyr)
library(magrittr)
obj <- c("cmpd 1","cmpd 1","cmpd 1","cmpd 2","cmpd 2")
x <- c(1, 2, 4, 7, 3)
var <- c("prop1","prop2","prop3","prop2","prop3")
y <- c(1, 2, 3, 2.5, 4)
col <- c("#E69F00","#9E0142","#56B4E9","#9E0142","#56B4E9")
shp <- c(0,1,2,1,2)
df2 <- cbind.data.frame(obj,x,var,y,col,shp)
plot <- ggplot(data = df2 %>%
filter(obj %in% c(
"cmpd 1",
"cmpd 2"
)),
aes(x = x,
y = y,
colour = as.factor(var),
shape = as.factor(var))) +
geom_point(size=2) +
#scale_shape_manual(values=shp) +
#scale_color_manual(values=col) +
facet_grid(.~obj)
plot
However, when I redact cmpd1 (just hashing in code) the colour and shape of prop2 and prop3 for cmpd2 change (please see plot2).
To this end, I tried adding in scale_shape_manual and scale_color_manual to the code (currently hashed) and linked these to specific vars (col and shp) in the dataframe (df2), but the same problem arises that both the shape and color of these variables changes when excluding one of the conditions?
Any and all help appreciated.
Try something like this:
library(tidyverse)
obj <- c("cmpd 1","cmpd 1","cmpd 1","cmpd 2","cmpd 2")
x <- c(1, 2, 4, 7, 3)
var <- c("prop1","prop2","prop3","prop2","prop3")
y <- c(1, 2, 3, 2.5, 4)
df2 <- cbind.data.frame(obj,x,var,y)
col <- c("prop1" = "#E69F00",
"prop2" = "#9E0142",
"prop3" = "#56B4E9")
shp <- c("prop1" = 0,
"prop2" = 1,
"prop3" = 2)
plot <- ggplot(data = df2 %>%
filter(obj %in% c(
"cmpd 1",
"cmpd 2"
)),
aes(x = x,
y = y,
colour = var,
shape = var)) +
geom_point(size=2) +
scale_shape_manual(values=shp) +
scale_color_manual(values=col) +
facet_grid(.~obj)
plot

Clip {ggdist} ccdf-barplot

I'm making a complementary cumulative distribution function barplot with {ggdist}. When I export the plot to svg (or other vector representation), I notice that there is a zero-width stripe protruding from the polygon (see attached image). I rather not have this protruding stripe.
library(ggplot2)
library(ggdist)
df <- data.frame(
x = rep(c("A", "B"), each = 10),
y = c(rnorm(20, mean = rep(c(5, 7), each = 10)))
)
p <- ggplot(df, aes(x, y)) +
stat_ccdfinterval(geom = "slab") +
lims(y = c(0, NA))
ggsave("test.svg", plot = p, device = svglite::svglite)
The code above results in an svg file below, wherein I've highlighted the outline of the polygon with the stripe.
I'd like to get rid of that zero-width stripe. I tried setting the relevant aesthetic to NA at these points, but that also deletes one of the corners that is not part of the stripe.
ggplot(df, aes(x, y)) +
stat_ccdfinterval(
geom = "slab",
aes(thickness = after_stat(ifelse(f == 0, NA, f)))
) +
lims(y = c(0, NA))
Created on 2022-03-10 by the reprex package (v2.0.1)
I found a solution specific to this problem, but it might pan out differently if the orientation is horizontal or the cdf instead of the ccdf is used. In brief, we're still setting 0-thickness datapoints to NA, but we now do this only where the y aesthetic exceeds the groupwise maximum.
library(ggplot2)
library(ggdist)
df <- data.frame(
x = rep(c("A", "B"), each = 10),
y = c(rnorm(20, mean = rep(c(5, 7), each = 10)))
)
helper <- function(f, y, group) {
split(f, group) <- Map(
function(value, y) {
f <- value
max_y <- max(y[f != 0])
f[f == 0 & y > max_y] <- NA
f
},
value = split(f, group),
y = split(y, group)
)
f
}
ggplot(df, aes(x, y)) +
stat_ccdfinterval(
geom = "slab",
aes(thickness = after_stat(helper(f, y, group)))
) +
lims(y = c(0, NA))
Created on 2022-03-13 by the reprex package (v2.0.1)

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)

Equivalent of gganimate::transition_events on plotly

In R, using gganimate, one can make an animated plot where events appear and disappear with time. For example:
library(lubridate)
library(gganimate)
df=data.frame(
x=c(1,2,3,4),
y=c(1,2,3,4),
start=c(1,2,3,4),
end=c(5,6,7,8),
en=as_date(1),
ex=as_date(1))
ggplot(data=df, aes(x=x,y=y))+
geom_point()+
gganimate::transition_events(
start=start,
end=end,
enter_length = as.numeric(en),
exit_length = as.numeric(ex))
This produces a plot in which points appear according to column "start" and desappear according to column "end".
I wonder if there is an easy way to achieve the same in with plotly (preferably using ggplotly()), getting a slider to move along the time.
Here is an example using ggplotly. The result however isn't exactly the same:
library(plotly)
library(lubridate)
df = data.frame(
x = c(1, 2, 3, 4),
y = c(1, 2, 3, 4),
start = c(1, 2, 3, 4),
end = c(5, 6, 7, 8),
en = as_date(1),
ex = as_date(1)
)
frame_list <- Map(seq, from = df$start, to = df$end)
DF <- data.frame(x = rep(df$x, times = lengths(frame_list)),
y = rep(df$y, times = lengths(frame_list)),
frame = unlist(frame_list))
p <- ggplot(DF, aes(x, y)) +
geom_point(aes(size = y, frame = frame))
fig <- ggplotly(p)
fig %>%
animation_opts(
frame = 0,
easing = "linear",
redraw = FALSE,
mode = "immediate"
)
fig

Resources