Related
I am helping someone translate hand-drawn economics supply and demand functions into image files that can be included in a Word document. These have been going well using Hmisc::bezier and geom_path modeled after Andrew Heiss's recon plots and using his curve_intersect function. That is, until the author asked that one of the supply curves should pass through a specified set of coordinates. The Hmisc::bezier function only uses the first and last control point as absolute, and bends toward intermediate points so the specified intersection point does not match the curve. I tried creating a spline of 2 bezier curves with the bezier function from the bezier package (v1.1.2, https://cran.r-project.org/web/packages/bezier/bezier.pdf), but this fails with "Error in FUN(X[[i]], ...) : object 'x' not found", which I do not understand or know how to fix.
Please let me know where I am going wrong or if there is a better method! I will include the commented out attempts using various functions. Please excuse the amateurish code, as I am a relative newb at R and ggplot2.
This section not directly relevant to my question
# Graph figures for physical economics, negative oil prices paper
library(reconPlots)
library(dplyr)
library(ggplot2)
library(patchwork)
library(ggrepel)
library(bezier)
library(ggforce)
options(ggrepel.max.time = 1)
options(ggrepel.max.iter = 20000)
#Set seed value for ggrepel
set.seed(52)
# panel (a)
#Set values of curves using the bezier function, each pair of c() values
# is an xy coordinate, and the sets of coordinates control the shape of the
# curve
supply <- Hmisc::bezier(c(1, 5, 6), c(3, 4, 9)) %>%
as_data_frame()
demand <- Hmisc::bezier(c(0, 9, 9), c(6, 6, 6)) %>%
as_data_frame()
label_height <- Hmisc::bezier(c(0, 9, 9), c(8, 8, 8)) %>%
as_data_frame()
# Calculate the intersections of the two curves
intersections <- bind_rows(curve_intersect(supply, demand))
# Calculate point where the curve label(s) intersect a specified height
supply_label <- bind_rows(curve_intersect(supply, label_height))
labels <- data_frame(label = expression("PS"[CR]^DRL),
x = supply_label$x,
y = supply_label$y)
production <- ggplot(mapping = aes(x = x, y = y)) +
#Draw the supply curve. Demand is not drawn in this figure, but the
# intersections of an imaginary demand curve are used to illustrate P0
# and Q0, the intersection point, and the dotted lines
geom_path(data = supply, color = "#0073D9", size = 1) +
geom_segment(data = intersections,
aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
geom_segment(data = intersections,
aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
#Draw the supply curve label using the intersection calculated above, using
# GGrepel so that the labels do not overlap the curve line
geom_text_repel(data = labels
,aes(x = x, y = y, label = label)
,parse = TRUE
,direction = "x"
,force = 3
,force_pull = 0.1
,hjust = 0
,min.segment.length = 0
) +
#Draw the intersection point based on intersection function between supply
# and the phantom flat demand curve at height y=6
geom_point(data = intersections, size = 3) +
#Use scale functions to set y-axis label, axis intersection point labels,
# and limits of the viewing area
scale_x_continuous(expand = c(0, 0), breaks = intersections$x
,labels = expression(Q[CR]^{DRL-PS})
,limits=c(0,9)
) +
scale_y_continuous(expand = c(0, 0), breaks = c(intersections$y, 9)
,labels = c(expression(P[CR]==frac("$",brl))
,expression(P[CR]))
,limits=c(0,9)
) +
#Use labs function to set x-axis title and title of each graph using the
# caption function so that it displays on the bottom
labs(x = expression(frac(Barrels,Week)),
caption = expression(atop("(a) Driller Production Supply", "of Crude Oil"))
) +
#Set classic theme, x-axis title on right-hand side using larger font of
# relative size 1.2, graph title on left-hand side using same larger font
theme_classic() +
theme(axis.title.y = element_blank(),
axis.title.x = element_text(hjust = 1),
axis.text = element_text(size=rel(1.2)),
plot.caption = element_text(hjust = 0.5, size=rel(1.2))
) +
coord_equal()
# Save the intersections so we can set the same quantity, price for panel (c)
specified_intersections = intersections
# Panel (b)
supply <- Hmisc::bezier(c(3.99, 4), c(0, 9)) %>%
as_data_frame()
demand <- Hmisc::bezier(c(2, 3, 4, 5), c(9, 6.5, 6, 5.5)) %>%
as_data_frame()
demand_capacity <- Hmisc::bezier(c(5, 5), c(0, 5.5)) %>%
as_data_frame()
supply_capacity <- Hmisc::bezier(c(4.999, 5), c(0, 9)) %>%
as_data_frame()
supply_label_height <- Hmisc::bezier(c(0, 9), c(9, 9)) %>%
as_data_frame()
demand_label_height <- Hmisc::bezier(c(0, 9), c(8, 8)) %>%
as_data_frame()
capacity_label_height <- Hmisc::bezier(c(0, 9), c(9, 9)) %>%
as_data_frame()
# Calculate the intersections of the two curves
intersections <- bind_rows(curve_intersect(supply,
demand))
supply_label <- bind_rows(curve_intersect(supply
,supply_label_height))
demand_label <- bind_rows(curve_intersect(demand
,demand_label_height))
capacity_label <- bind_rows(curve_intersect(supply_capacity
,capacity_label_height))
labels <- data_frame(label = c(expression("OD"[CR]^DRL),expression("OS"[CR]^DRL)
,expression("Q"[CR]^CAP)
),
x = c(demand_label$x, supply_label$x
, capacity_label$x
),
y = c(demand_label$y, supply_label$y
, capacity_label$y
)
)
inventory <- ggplot(mapping = aes(x = x, y = y)) +
geom_path(data = supply, color = "#0073D9", size = 1) +
geom_path(data = demand, color = "#FF4036", size = 1) +
geom_path(data = demand_capacity, color = "#FF4036", size = 1) +
geom_path(data = supply_capacity, color = "#0073D9", size = 1, lty = "dashed") +
geom_segment(data = intersections,
aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
geom_text_repel(data = labels
,aes(x = x, y = y, label = label)
,parse = TRUE
,direction = "x"
,force = 3
,force_pull = 0.1
,hjust = c(0, 0, 1)
,min.segment.length = 0
) +
geom_point(data = intersections, size = 3) +
scale_x_continuous(expand = c(0, 0), breaks = c(intersections$x
, 5),
labels = c(expression(paste(Q[CR]^{DRL-OS},phantom(12345)))
,expression(Q[CR]^CAP)
)
, limits=c(0,9)) +
scale_y_continuous(expand = c(0, 0), breaks = c(intersections$y, 9),
labels = c(expression(P[CR]),expression(P[CR]))
, limits=c(0,9)) +
labs(x = "Barrels",
caption = expression(atop("(b) Driller Storage / Ownership", "of Crude Oil"))
) +
theme_classic() +
theme(axis.title.y = element_blank(),
axis.title.x = element_text(hjust = 1),
axis.text = element_text(size=rel(1.2)),
plot.caption = element_text(hjust = 0.5, size=rel(1.2))
) +
coord_equal()
Relevant section
# panel (c)
# ggforce package method
#supply <- list(c(1, 4, specified_intersections$x, 5, 7),
# c(3, 4, specified_intersections$y, 7, 9)) %>%
# as_data_frame()
# bezier package method: Fails with "Error in FUN(X[[i]], ...) : object 'x' not found"
t <- seq(0, 2, length=10)
p <- list(c(1, 4, specified_intersections$x, 7, 8),
c(3, 4, specified_intersections$y, 6, 9))
#p <- matrix(c(1,3, 4,4, specified_intersections$x,specified_intersections$y,
# 7,6, 8,9), nrow=5, ncol=2, byrow=TRUE)
supply <- bezier(t=t, p=p) %>%
as_data_frame()
# Original: Fails because it does not pass through the specified intersection
#supply <- Hmisc::bezier(c(1, specified_intersections$x, 8),
# c(3, specified_intersections$y, 9)) %>%
# as_data_frame()
# Hmisc method: Fails because there is no way to get the two curves to appear
# contiguous
#supply1 <- Hmisc::bezier(c(1, 4, specified_intersections$x),
# c(3, 4, specified_intersections$y)) %>%
# as_data_frame()
#supply2 <- Hmisc::bezier(c(specified_intersections$x, 6, 7),
# c(specified_intersections$y, 8, 9)) %>%
# as_data_frame()
#demand <- Hmisc::bezier(c(0, 9), c(specified_intersections$y, specified_intersections$y)) %>%
# as_data_frame()
label_height <- Hmisc::bezier(c(0, 9), c(8, 8)) %>%
as_data_frame()
# Calculate the intersections of the two curves
#intersections <- bind_rows(curve_intersect(supply, demand))
#supply_label <- bind_rows(curve_intersect(supply,
# label_height))
#labels <- data_frame(label = expression("SS"[CR]^DRL),
# x = supply_label$x,
# y = supply_label$y)
sales <- ggplot(mapping = aes(x = x, y = y)) +
# ggforce package method
# geom_bspline(data = supply, color = "#0073D9", size = 1) +
# Original geom_path method
geom_path(data = supply, color = "#0073D9", size = 1) +
# Supply 1 and 2 for Hmisc method
# geom_path(data = supply1, color = "#0073D9", size = 1) +
# geom_path(data = supply2, color = "#0073D9", size = 1) +
geom_segment(data = specified_intersections,
aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
geom_segment(data = specified_intersections,
aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
# geom_text_repel(data = labels
# ,aes(x = x, y = y, label = label)
# ,parse = TRUE
# ,direction = "x"
# ,force = 3
# ,force_pull = 0.1
# ,hjust = 0
# ,min.segment.length = 0
# ) +
geom_point(data = specified_intersections, size = 3) +
scale_x_continuous(expand = c(0, 0), breaks = specified_intersections$x,
labels = expression(Q[CR]^{DRL-SS}), limits=c(0,9)) +
scale_y_continuous(expand = c(0, 0), breaks = c(specified_intersections$y, 9),
labels = c(expression(P[CR]),expression(P[CR]))) +
labs(x = expression(frac(Barrels,Week)),
caption = expression(atop("(c) Driller Sales Supply", "of Crude Oil"))
) +
theme_classic() +
theme(axis.title.y = element_blank(),
axis.title.x = element_text(hjust = 1),
axis.text = element_text(size=rel(1.2)),
plot.caption = element_text(hjust = 0.5, size=rel(1.2))
) +
coord_equal()
patchwork <- (production | inventory | sales)
patchwork
Graphs before implementation of fixed coordinates. Need to move panel (c) intersection point to match panel (a)
I solved the "Error in FUN(X[[i]], ...) : object 'x' not found" by printing the supply variable and noticing that the bezier function names its rows V1,V2 and not x,y. I needed to set the aesthetics of the geom_path to the correct mapping.
Relevant Section, trimmed to only the bezier method
# panel (c)
# bezier package method
t <- seq(0, 2, length = 100)
p <- matrix(c(1,3, 4,4, specified_intersections$x,specified_intersections$y,
7,6, 8,9), nrow=5, ncol=2, byrow=TRUE)
supply <- bezier::bezier(t=t, p=p, deg=2) %>%
as_data_frame()
sales <- ggplot(mapping = aes(x = x, y = y)) +
# Original geom_path method
geom_path(data = supply, mapping = aes(x = V1, y = V2),
color = "#0073D9", size = 1, inherit.aes = FALSE) +
geom_segment(data = specified_intersections,
aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
geom_segment(data = specified_intersections,
aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
geom_point(data = specified_intersections, size = 3) +
scale_x_continuous(expand = c(0, 0), breaks = specified_intersections$x,
labels = expression(Q[CR]^{DRL-SS}), limits=c(0,9)) +
scale_y_continuous(expand = c(0, 0), breaks = c(specified_intersections$y, 9),
labels = c(expression(P[CR]),expression(P[CR]))) +
labs(x = expression(frac(Barrels,Week)),
caption = expression(atop("(c) Driller Sales Supply", "of Crude Oil"))
) +
theme_classic() +
theme(axis.title.y = element_blank(),
axis.title.x = element_text(hjust = 1),
axis.text = element_text(size=rel(1.2)),
plot.caption = element_text(hjust = 0.5, size=rel(1.2))
) +
coord_equal()
patchwork <- (production | inventory | sales)
patchwork
This does not solve my larger problem of needing a smooth curve that passes through a specified set of coordinates, as it produces two bezier curves that do not match.
I will do some research on using functions to specify bezier curves and find out if there is some mathematical or programmatic way to specify a bezier curve that passes through a set of fixed coordinates. If I find one, I'll edit this answer.
If anyone knows how to accomplish this, I would appreciate any help!
Kinked bezier curves
I want to add a line on the top and bottom of my plots (bottom line below the x label and axis) created using ggplot2. So far I have added a rectangle around the plot, but I do not want the lines on the sides.
x <- 1:10
y <- rnorm(10,mean = x)
df <- data.frame(x,y)
library(ggplot2)
ggplot(data = df, mapping = aes(x,y)) + geom_point() +
theme(plot.background = element_rect(size = 1, color = 'blue'))
I hope you guys have a solution.
Will something similar to this work?
x <- 1:10
y <- rnorm(10,mean = x)
df <- data.frame(x,y)
ggplot(data = df, mapping = aes(x,y)) + geom_point() +
annotate(geom = 'segment',
y = Inf,
yend = Inf,
x = -Inf,
xend = Inf,
size = 2) +
theme(axis.line.x = element_line(size = 1))
Not a perfect, but working solution. You have to plot huge "-" (size = 1000) outside plot area. This solution is not perfect as you have to manually adjust position of "-" on the y-axis.
df <- data.frame(x = 1:10, y = 1:10)
library(ggplot2)
ggplot(df, aes(x, y)) +
geom_point() +
# Y position adjusted manually
geom_text(aes(5, 2.9, label = "-"), color = "blue", size = 1000) +
# Y position adjusted manually
geom_text(aes(5, 21.2, label = "-"), color = "blue", size = 1000) +
# Plot outside plot area
coord_cartesian(ylim = c(0, 10), clip = "off")
I am not completely happy with the solution as I don't fully grasp
how to change the size of the lines
why they are not perfectly aligned with top and bottom when using patchwork::wrap_plots()
why it does not show the top line using ggpubr::ggarrange() or cowplot::plot_grid()
but based on this code, I suggest the following solution:
library(ggplot2)
df <- data.frame(x = 1:5, y = 1:5)
p <- ggplot(data = df) + aes(x, y) + geom_point()
top_line <- grid::grobTree(grid::linesGrob(x = grid::unit(c(0, 1), "npc"), y = grid::unit(1, "npc")))
bot_line <- grid::grobTree(grid::linesGrob(x = grid::unit(c(0, 1), "npc"), y = grid::unit(0, "npc")))
patchwork::wrap_plots(top_line, p, bot_line,
ncol = 1, nrow = 3,
heights = c(0, 1, 0))
ggpubr::ggarrange(top_line, p, bot_line,
ncol = 1, nrow = 3,
heights = c(0, 1, 0))
cowplot::plot_grid(top_line, p, bot_line,
ncol = 1, nrow = 3,
rel_heights = c(0, 1, 0))
Created on 2022-08-25 with reprex v2.0.2
I am trying to replicate the following picture in R, in particular with ggplot2
I was able to draw the red rss contour lines but I've no idea how to draw a diamond (like the one in the left picture). The "expected Output" should be a way to draw a diamond with a given side length.
EDIT: Here is a short reproducible example to add the diamond randomly inside the following plot:
mlb<- read.table('https://umich.instructure.com/files/330381/download?download_frd=1', as.is=T, header=T)
str(mlb)
fit<-lm(Height~Weight+Age-1, data = as.data.frame(scale(mlb[,4:6])))
points = data.frame(x=c(0,fit$coefficients[1]),y=c(0,fit$coefficients[2]),z=c("(0,0)","OLS Coef"))
Y=scale(mlb$Height)
X = scale(mlb[,c(5,6)])
beta1=seq(-0.556, 1.556, length.out = 100)
beta2=seq(-0.661, 0.3386, length.out = 100)
df <- expand.grid(beta1 = beta1, beta2 = beta2)
b = as.matrix(df)
df$sse <- rep(t(Y)%*%Y,100*100) - 2*b%*%t(X)%*%Y + diag(b%*%t(X)%*%X%*%t(b))
base <- ggplot() +
stat_contour(data=df, aes(beta1, beta2, z = sse),breaks = round(quantile(df$sse, seq(0, 0.2, 0.03)), 0),
size = 0.5,color="darkorchid2",alpha=0.8) +
scale_x_continuous(limits = c(-0.4,1))+
scale_y_continuous(limits = c(-0.55,0.4))+
geom_point(data = points,aes(x,y))+
geom_text(data = points,aes(x,y,label=z),vjust = 2,size=3.5)
base
You can draw shapes with geom_polygon.
library(ggplot2)
df <- data.frame(x = c(1, 0, -1, 0), y = c(0, 1, 0, -1))
ggplot(df) + geom_polygon(aes(x = x, y = y))
If you want to generate the coordinates from a center and a side length, you can transform a base matrix. You can also combine this with an existing plot by supplying the coordinates to the data argument of the geom instead of to ggplot() as shown. Change the sqrt2 scaling if you want the corner-to-center as the argument instead of the side length.
diamond <- function(side_length, center) {
base <- matrix(c(1, 0, 0, 1, -1, 0, 0, -1), nrow = 2) * sqrt(2) / 2
trans <- (base * side_length) + center
as.data.frame(t(trans))
}
ggplot() + geom_polygon(data = diamond(2, c(1, 2)), mapping = aes(x = V1, y = V2))
Here's an example of adding it in to your provided data. Note that I put it before (underneath) the text, and named the arguments to be clear (probably the source of that object coercible by fortify error.
mlb <- read.table("https://umich.instructure.com/files/330381/download?download_frd=1", as.is = T, header = T)
fit <- lm(Height ~ Weight + Age - 1, data = as.data.frame(scale(mlb[, 4:6])))
points <- data.frame(x = c(0, fit$coefficients[1]), y = c(0, fit$coefficients[2]), z = c("(0,0)", "OLS Coef"))
Y <- scale(mlb$Height)
X <- scale(mlb[, c(5, 6)])
beta1 <- seq(-0.556, 1.556, length.out = 100)
beta2 <- seq(-0.661, 0.3386, length.out = 100)
df <- expand.grid(beta1 = beta1, beta2 = beta2)
b <- as.matrix(df)
df$sse <- rep(t(Y) %*% Y, 100 * 100) - 2 * b %*% t(X) %*% Y + diag(b %*% t(X) %*% X %*% t(b))
ggplot(df) +
stat_contour(aes(beta1, beta2, z = sse),
breaks = round(quantile(df$sse, seq(0, 0.2, 0.03)), 0),
size = 0.5, color = "darkorchid2", alpha = 0.8
) +
geom_polygon(data = diamond(0.1, c(0, 0)), mapping = aes(x = V1, y = V2), fill = "cadetblue1") +
scale_x_continuous(limits = c(-0.4, 1)) +
scale_y_continuous(limits = c(-0.55, 0.4)) +
geom_point(data = points, aes(x, y)) +
geom_text(data = points, aes(x, y, label = z), vjust = 2, size = 3.5)
#> Warning: Removed 4215 rows containing non-finite values (stat_contour).
Created on 2018-08-01 by the reprex package (v0.2.0).
I am trying to draw a line across two ggplot histograms in a gtable_matrix, so that the mean of the values in the one histogram is overlaid across both plots.
However, I cannot get at the device coordinates of the plotting area. In base graphics, I would use grconvertX(), but where can I find the device coordinates of the plotting area of ggplot so I can convert numbers on my 'user' scale (0-10) to device coordinates?
In the example below, I have meticulously found the numbers to plug in to get the line at the correct location, but as soon as the plot is rescaled, or the axis labels change, or any other plot element changes, it breaks down. Probably won't work as intended on your machine either.
library(ggplot2)
library(grid)
library(gtable)
n_1 = 10
n_2 = 10
mean_1 = 5.5
sd_1 = 1
mean_2 = 7
sd_2 = 1
data = data.frame(y = c(
rnorm(n_1, mean_1, sd_1),
rnorm(n_2, mean_2, sd_2)
),
group = c(rep("1", n_1), rep("2", n_2)))
data$y[data$y > 10] <- 10
data$y[data$y < 0] <- 0
plots <- lapply(c("1", "2"), function(x) {
ggplotGrob(
ggplot(data[data$group == x,], aes(y)) +
geom_histogram(
breaks = seq(0, 10, length.out = 12),
fill = ifelse(x == "1", "blue", "red"),
colour = "black",
alpha = .2
) +
theme_classic() +
theme(axis.title.x = element_blank()) +
ylab(x) +
scale_x_continuous(expand = c(0, 0), limits = c(0, 10)) +
scale_y_continuous(expand = c(0, 0), limits = c(0, 4))
)
})
gt <- gtable_matrix(
"histograms",
matrix(plots, nrow = 2, byrow = TRUE),
widths = unit(1, "null"),
heights = unit(c(1, 1), "null")
)
left <- textGrob("Frequency", rot = 90, just = c(.5, .5))
gt <-
gtable_add_cols(gt, widths = grobWidth(left) + unit(0.5, "line"), 0)
gt <- gtable_add_grob(
gt,
left,
t = 1,
b = nrow(gt),
l = 1,
r = 1,
z = Inf
)
gt <- gtable_add_cols(gt, widths = unit(0.5, "line"))
grid.newpage()
grid.draw(gt)
pushViewport(viewport())
grid.lines(y = c(.05, .98),
x = (.11 + (5 / 10 * .861)),
gp = gpar(col = "red"))
popViewport()
Here's a stripped-down version with facets. You can decide whether this accomplishes enough of what you're looking for to drop the gtable stuff.
Use a geom_vline with the intercept set to the mean of your y-values; this will put it in the same place on each facet. I took out the strip text (strip.text = element_blank()) to mimic what you'd done with removing the titles of the two plots. Other than that, it's just a standard facet_wrap by groups.
library(tidyverse)
n_1 = 10
n_2 = 10
mean_1 = 5.5
sd_1 = 1
mean_2 = 7
sd_2 = 1
data = data.frame(y = c(
rnorm(n_1, mean_1, sd_1),
rnorm(n_2, mean_2, sd_2)
),
group = c(rep("1", n_1), rep("2", n_2)))
data$y[data$y > 10] <- 10
data$y[data$y < 0] <- 0
ggplot(data, aes(x = y, fill = group)) +
geom_histogram(breaks = seq(0, 10, length.out = 12)) +
geom_vline(aes(xintercept = mean(y))) +
facet_wrap(~ group, ncol = 1) +
theme_minimal() +
theme(strip.text = element_blank())
How can I make a plot like this with two different-sized half circles (or other shapes such as triangles etc.)?
I've looked into a few options: Another post suggested using some unicode symbol, that didn't work for me. And if I use a vector image, how can I properly adjust the size parameter so the 2 circles touch each other?
Sample data (I would like to make the size of the two half-circles equal to circle1size and circle2size):
df = data.frame(circle1size = c(1, 3, 2),
circle2size = c(3, 6, 5),
middlepointposition = c(1, 2, 3))
And ultimately is there a way to position the half-circles at different y-values too, to encode a 3rd dimension, like so?
Any advice is much appreciated.
What you're asking for is a bar plot in polar coordinates. This can be done easily in ggplot2. Note that we need to map y = sqrt(count) to get the area of the half circle proportional to the count.
df <- data.frame(x = c(1, 2),
type = c("Investors", "Assignees"),
count = c(19419, 1132))
ggplot(df, aes(x = x, y = sqrt(count), fill = type)) + geom_col(width = 1) +
scale_x_discrete(expand = c(0,0), limits = c(0.5, 2.5)) +
coord_polar(theta = "x", direction = -1)
Further styling would have to be applied to remove the gray background, remove the axes, change the color, etc., but that's all standard ggplot2.
Update 1: Improved version with multiple countries.
df <- data.frame(x = rep(c(1, 2), 3),
type = rep(c("Investors", "Assignees"), 3),
country = rep(c("Japan", "Germany", "Korea"), each = 2),
count = c(19419, 1132, 8138, 947, 8349, 436))
df$country <- factor(df$country, levels = c("Japan", "Germany", "Korea"))
ggplot(df, aes(x=x, y=sqrt(count), fill=type)) + geom_col(width =1) +
scale_x_continuous(expand = c(0, 0), limits = c(0.5, 2.5)) +
scale_y_continuous(expand = c(0, 0)) +
coord_polar(theta = "x", direction = -1) +
facet_wrap(~country) +
theme_void()
Update 2: Drawing the individual plots at different locations.
We can do some trickery to take the individual plots and plot them at different locations in an enclosing plot. This works, and is a generic method that can be done with any sort of plot, but it's probably overkill here. Anyways, here is the solution.
library(tidyverse) # for map
library(cowplot) # for draw_text, draw_plot, get_legend, insert_yaxis_grob
# data frame of country data
df <- data.frame(x = rep(c(1, 2), 3),
type = rep(c("Investors", "Assignees"), 3),
country = rep(c("Japan", "Germany", "Korea"), each = 2),
count = c(19419, 1132, 8138, 947, 8349, 436))
# list of coordinates
coord_list = list(Japan = c(1, 3), Germany = c(2, 1), Korea = c(3, 2))
# make list of individual plots
split(df, df$country) %>%
map( ~ ggplot(., aes(x=x, y=sqrt(count), fill=type)) + geom_col(width =1) +
scale_x_continuous(expand = c(0, 0), limits = c(0.5, 2.5)) +
scale_y_continuous(expand = c(0, 0), limits = c(0, 160)) +
draw_text(.$country[1], 1, 160, vjust = 0) +
coord_polar(theta = "x", start = 3*pi/2) +
guides(fill = guide_legend(title = "Type", reverse = T)) +
theme_void() + theme(legend.position = "none") ) -> plotlist
# extract the legend
legend <- get_legend(plotlist[[1]] + theme(legend.position = "right"))
# now plot the plots where we want them
width = 1.3
height = 1.3
p <- ggplot() + scale_x_continuous(limits = c(0.5, 3.5)) + scale_y_continuous(limits = c(0.5, 3.5))
for (country in names(coord_list)) {
p <- p + draw_plot(plotlist[[country]], x = coord_list[[country]][1]-width/2,
y = coord_list[[country]][2]-height/2,
width = width, height = height)
}
# plot without legend
p
# plot with legend
ggdraw(insert_yaxis_grob(p, legend))
Update 3: Completely different approach, using geom_arc_bar() from the ggforce package.
library(ggforce)
df <- data.frame(start = rep(c(-pi/2, pi/2), 3),
type = rep(c("Investors", "Assignees"), 3),
country = rep(c("Japan", "Germany", "Korea"), each = 2),
x = rep(c(1, 2, 3), each = 2),
y = rep(c(3, 1, 2), each = 2),
count = c(19419, 1132, 8138, 947, 8349, 436))
r <- 0.5
scale <- r/max(sqrt(df$count))
ggplot(df) +
geom_arc_bar(aes(x0 = x, y0 = y, r0 = 0, r = sqrt(count)*scale,
start = start, end = start + pi, fill = type),
color = "white") +
geom_text(data = df[c(1, 3, 5), ],
aes(label = country, x = x, y = y + scale*sqrt(count) + .05),
size =11/.pt, vjust = 0)+
guides(fill = guide_legend(title = "Type", reverse = T)) +
xlab("x axis") + ylab("y axis") +
coord_fixed() +
theme_bw()
If you don't need to have ggplot2 map aesthetics other than x and y you could try egg::geom_custom,
# devtools::install_github("baptiste/egg")
library(egg)
library(grid)
library(ggplot2)
d = data.frame(r1= c(1,3,2), r2=c(3,6,5), x=1:3, y=1:3)
gl <- Map(mushroomGrob, r1=d$r1, r2=d$r2, gp=list(gpar(fill=c("bisque","maroon"), col="white")))
d$grobs <- I(gl)
ggplot(d, aes(x,y)) +
geom_custom(aes(data=grobs), grob_fun=I) +
theme_minimal()
with the following grob,
mushroomGrob <- function(x=0.5, y=0.5, r1=0.2, r2=0.1, scale = 0.01, angle=0, gp=gpar()){
grob(x=x,y=y,r1=r1,r2=r2, scale=scale, angle=angle, gp=gp , cl="mushroom")
}
preDrawDetails.mushroom <- function(x){
pushViewport(viewport(x=x$x,y=x$y))
}
postDrawDetails.mushroom<- function(x){
upViewport()
}
drawDetails.mushroom <- function(x, recording=FALSE, ...){
th2 <- seq(0,pi, length=180)
th1 <- th2 + pi
d1 <- x$r1*x$scale*cbind(cos(th1+x$angle*pi/180),sin(th1+x$angle*pi/180))
d2 <- x$r2*x$scale*cbind(cos(th2+x$angle*pi/180),sin(th2+x$angle*pi/180))
grid.polygon(unit(c(d1[,1],d2[,1]), "snpc")+unit(0.5,"npc"),
unit(c(d1[,2],d2[,2]), "snpc")+unit(0.5,"npc"),
id=rep(1:2, each=length(th1)), gp=x$gp)
}
# grid.newpage()
# grid.draw(mushroomGrob(gp=gpar(fill=c("bisque","maroon"), col=NA)))