我最近逛Stack Overflow，偶然发现一个有趣的提问：Adding custom image to geom_polygon fill in ggplot，即如何将图片填充至特定形状中。其实运用2010版PPT中提供的布尔运算功能，也可完成上述问题。本着对ggplot2包的热爱，我依葫芦画瓢，试着从网上找了一位女神，用两种方法将照片镶嵌入心形线中，方便下次七夕节表白用。代码如下：
#需要载入以下包，请提前安装
pk <- c("dplyr","tidyr","ggplot2","png","sp")
sapply(pk, library, character.only = TRUE)
# 网上找的女神靓照，注意图片格式必须为png
pic_test <- readPNG("Mizushima_Tsumi.png")
# 心形线数据
t <- seq(0, 2 * pi, by = 0.01)
x <- 16 * sin(t)^3
y <- 13 * cos(t) - 5 * cos(2 * t) - 1.0 * cos(3 * t) - 0.8*cos(4 * t)
a <- (x - min(x))/(max(x) - min(x))
b <- (y - min(y))/(max(y) - min(y))
df_heart <- data.frame(x = a, y = b, group = "A")
#将光栅数据(raster image data)转换为数据框(plottable data frame)。
ggplot_rasterdf <- function(color_matrix, bottom = 0, top = 1, left = 0, right = 1) {
if (dim(color_matrix)[3] > 3) hasalpha <- T else hasalpha <- F
outMatrix <- matrix("#00000000", nrow = dim(color_matrix)[1], ncol = dim(color_matrix)[2])
for (i in 1:dim(color_matrix)[1])
for (j in 1:dim(color_matrix)[2])
outMatrix[i, j] <- rgb(color_matrix[i,j,1], color_matrix[i,j,2],
color_matrix[i,j,3], ifelse(hasalpha, color_matrix[i,j,4], 1))
colnames(outMatrix) <- seq(1, ncol(outMatrix))
rownames(outMatrix) <- seq(1, nrow(outMatrix))
as.data.frame(outMatrix) %>% mutate(Y = nrow(outMatrix):1) %>% gather(X, color, -Y) %>%
mutate(X = left + as.integer(as.character(X)) * (right-left)/ncol(outMatrix),
Y = bottom + Y * (top-bottom)/nrow(outMatrix))
}
pic_test_dat <- ggplot_rasterdf(pic_test,
left = min(df_heart[df_heart$group == "A",]$x),
right = max(df_heart[df_heart$group == "A",]$x),
bottom = min(df_heart[df_heart$group == "A",]$y),
top = max(df_heart[df_heart$group == "A",]$y))
#获取心形线内的数据，以便将数据填充(fill in polygon)。
pic_A_df <-
pic_test_dat[point.in.polygon(pic_test_dat$X, pic_test_dat$Y,
df_heart[df_heart$group == "A",]$x,
df_heart[df_heart$group == "A",]$y ) %>% as.logical,]
#ggplot2作图
df <- data.frame(x = c(0,1),y = c(0,1), group = "A")
ggplot(data = df) +
geom_tile(data = pic_A_df, aes(x = X, y = Y), fill = pic_A_df$color) +
geom_text(label = "Mizushima Tsumi ", angle = 30,
x = 0.2, y = 0.2, size = 4, colour = "red") +
theme(plot.background = element_blank(),
panel.background = element_blank(),
axis.ticks = element_blank(),
panel.grid.major = element_line(colour = NA),
panel.grid.minor = element_line(colour = NA),
axis.text.y = element_blank(),
axis.text.x = element_blank(),
legend.position = "NULL",
plot.title = element_text(vjust = -2,size = 20)
) +
xlab("") + ylab("")
可以尝试使用gridExtra包，绘制结果一致。我就不贴图了。
sapply(c("grid", "ggplot2", "png", "gridExtra"), library, character.only = TRUE)
#心形线
heart <- do.call(rbind,lapply(seq(0, 2*pi, by = 0.01),
function(t) c(x = 16 * sin(t)^3,
y = 13 * cos(t) - 5 * cos(2 * t) - 1.0 * cos(3 * t) - 0.8*cos(4 * t))))
heart <- data.frame(heart)
heart$x <- (heart$x - min(heart$x))/(max(heart$x) - min(heart$x))
heart$y <- (heart$y - min(heart$y))/(max(heart$y) - min(heart$y))
#导入图片
pic <- readPNG("Mizushima_Tsumi.png")
pic_raster <- rasterGrob(pic, interpolate = TRUE)
pic_raster$width <- unit(1, "npc")
pic_raster$height <- unit(1, "npc")
#作图
grid.newpage()
grid.draw(arrangeGrob(pic_raster))
grid.path(c(0, 0, 1, 1, heart[ ,1]),
c(0, 1, 1, 0, heart[ ,2]),
id = c(1, 1, 1, 1, rep(2, nrow(heart))),
rule = "evenodd",
gp = gpar(fill = "white", alpha = 1, col = "white"))
grid.text(label = "Mizushima Tsumi ",
x = 0.2, y = 0.2, rot = 30,
gp = gpar(col = "red", fontsize = 4 * .pt))
