简介
早上听完讲座才想起来，今天520了。那这样吧，小编给做了个小小的惊喜给读者们，年轻的盆友可以用这“小玩意”给自己心仪的对象表白了。
其实就是一个简单的ggplot绘制爱心，做一点细节处理，并加入相应文字啦！
如果有对象了（没有对象），你可以学学这个教程，举一反三。如果你想现在就拿去表白的话，直接复制节末完整代码即可。
教程
用R绘制爱心其实在网上有很多教程，小编主要参考使用ggplot2绘制心形[1]，在此基础上进行稍微的调整。
加载相应的包，其中showtext包主要解决图片显示中文存在的问题，具体可见推文：加载Windows系统字体到图上，解决PDF导出字体无法显示的问题
library(showtext) #中文问题 showtext.auto() library(tidyverse) library(ggplot2)
之后构造数据集，并将x，y归一化后的结果存到a，b中。
d <- data_frame(t = seq(-pi, 0, .01), x1 = 16 * (sin(t)) ^ 2, x2 = -x1, y = 13 * cos(t) - 5 * cos(2 * t) - 2 * cos(3 * t) - cos(4 * t)) %>% gather(side, x, x1, x2) a = (d$x - min(d$x))/(max(d$x) - min(d$x)) b = (d$y - min(d$y))/(max(d$y) - min(d$y))
接下来绘制爱心，主要使用geom_line()描述爱心边框，用geom_polygon()填充爱心内部颜色，后面的各个参数进行主题的变化。然后使用annotate()函数添加你想要的文字。最后可以使用ggsave()将其保存（我这里注释掉了）。整个图存到了g中，你可以在此将g输出即可得到对应的图片。
g = ggplot(data=d, aes(x=x, y=y)) + geom_line(aes(color=I('white'))) + #手动设置心形边框线颜色 geom_polygon(aes(fill='red'), show.legend = F) + #填充心形并隐藏图例 scale_x_continuous(labels = NULL) + scale_y_continuous(labels = NULL) + theme_bw() + #设定白色主题 theme(panel.grid.major = element_blank(), #删除网格线 panel.grid.minor = element_blank(), #删除网格线 panel.border = element_blank(), #删除边框线 axis.ticks = element_blank(), #删除刻度线 axis.title = element_blank()) + #去除x和y的标签名 annotate('text', x=median(a), y=median(b), label='脏茜茜的师妹',size=8,col='gray20') + annotate('text', x=median(a), y=median(b)-2.5, label='520快乐!',size=18,col='white') + annotate('text', x=median(a), y=median(b)-5, label='下个月3篇推送写好了没？',size=5,col='#eeb401')+ annotate('text', x=median(a), y=median(b)-6.5, label='再不写推送就把你开了',size=4,col='white') # ggsave('heart.png', plot = last_plot(), dpi = 300)
注：这里ggplot中的各个参数我在b站课程【
R语言可视化教程】中大部分都有提过，对应教程文稿可在公众号后台输入【可视化文稿】免费获得。所以就不做更加具体的讲解了。
这时，输出的图形是这样的：
![YHX)@{R[`4]@([HOGIGZHC7.png](https://ucc.alicdn.com/pic/developer-ecology/403955efb2a0462e8eb6136b19d27443.png?x-oss-process=image/resize,w_1400/format,webp "YHX)@{R[`4]@([HOGIGZHC7.png")
为了使图形更加有特色，你可以在改图片上继续添加新的元素。小编在此折腾了一下，给大家打开一点思路。
加入玫瑰花
以前看到公众号【微生信生物】写过一篇用R制作玫瑰花的推送，主要参考链接[2]。那我就站在巨人们的肩膀上进行拓展了，具体教程看R制作玫瑰花。我在这里将整个过程包装成了一个函数，方便使用。
library(tidyverse) rose_plot = function(){ f <- function(x) x^2 / 2 f1 <- function(x) x^2/5 geom_leaf <- function(x, xend, f, xoffset = 0, yoffset = 0, xflip = 1, yflip = 1, ...) { .x <- seq(x, xend, length.out = 100) .y <- f(.x) df <- tibble(x = c(.x, .y), y = c(.y, .x)) df$x <- xflip * df$x + xoffset df$y <- yflip * df$y + yoffset geom_polygon(aes(x = x, y = y), data = df, ...) } geom_rose <- function(n, mean = c(0, 0), ...) { .x <- mvtnorm::rmvnorm(n, mean) df <- tibble(x = .x[, 1], y = .x[, 2]) list( stat_density_2d( aes(x = x, y = y, fill = stat(level)), data = df, geom = "polygon", show.legend = FALSE, color = "grey80"), scale_fill_gradient2(...) ) } p <- ggplot() + coord_equal(1, c(-4, 2), c(-7, 3)) + geom_curve(aes(x = -1, y = -7, xend = 0, yend = 0), ncp = 1000, curvature = -0.3, size = 1, color = "olivedrab3") + geom_leaf(0, 2, f, -1.6, -4.5, 1, fill = "olivedrab3", color = "palegreen") + geom_leaf(0, 2, f, -1.6, -5, -1, fill = "olivedrab3", color = "palegreen") + geom_leaf(0, 2, f1, -1.25, -2.25, -0.5, fill = "olivedrab3", color = "palegreen")+ geom_leaf(0, 3, f1, -1.25, -2.25, 0.5, fill = "olivedrab3", color = "palegreen") + geom_rose(1000, mean = c(0, 0), low = "red", mid = "purple", high = "pink", midpoint = 0.075) + theme_void() return(p) }
然后输出以下代码即可获得玫瑰花图
p = rose_plot() p
之后将两个图形进行合并排版，这里使用patchwork包，如果你不是很了解这个包，可以看以前写的推文系列：R可视乎｜用R来拼图和排版，告别AI和PS；R可视乎｜用R来拼图和排版，告别AI和PS（二）；R可视乎｜用R来拼图和排版，告别AI和PS(三)
library(patchwork) g + inset_element( p,0, 0.15, 1, 0.35 )
这时图片出来啦！
完整代码
#============================================== #加载包 library(showtext) #中文问题 showtext.auto() library(tidyverse) library(ggplot2) # 设定数据集 d <- data_frame(t = seq(-pi, 0, .01), x1 = 16 * (sin(t)) ^ 2, x2 = -x1, y = 13 * cos(t) - 5 * cos(2 * t) - 2 * cos(3 * t) - cos(4 * t)) %>% gather(side, x, x1, x2) a = (d$x - min(d$x))/(max(d$x) - min(d$x)) b = (d$y - min(d$y))/(max(d$y) - min(d$y)) # 绘图 g = ggplot(data=d, aes(x=x, y=y)) + geom_line(aes(color=I('white'))) + #手动设置心形边框线颜色 geom_polygon(aes(fill='red'), show.legend = F) + #填充心形并隐藏图例 scale_x_continuous(labels = NULL) + scale_y_continuous(labels = NULL) + theme_bw() + #设定白色主题 theme(panel.grid.major = element_blank(), #删除网格线 panel.grid.minor = element_blank(), #删除网格线 panel.border = element_blank(), #删除边框线 axis.ticks = element_blank(), #删除刻度线 axis.title = element_blank()) + #去除x和y的标签名 annotate('text', x=median(a), y=median(b), label='脏茜茜的师妹',size=8,col='gray20') + annotate('text', x=median(a), y=median(b)-2.5, label='520快乐!',size=18,col='white') + annotate('text', x=median(a), y=median(b)-5, label='下个月3篇推送写好了没？',size=5,col='#eeb401')+ annotate('text', x=median(a), y=median(b)-6.5, label='再不写推送就把你开了',size=4,col='white') # ggsave('heart.png', plot = last_plot(), dpi = 300) ## 玫瑰花 library(tidyverse) rose_plot = function(){ f <- function(x) x^2 / 2 f1 <- function(x) x^2/5 geom_leaf <- function(x, xend, f, xoffset = 0, yoffset = 0, xflip = 1, yflip = 1, ...) { .x <- seq(x, xend, length.out = 100) .y <- f(.x) df <- tibble(x = c(.x, .y), y = c(.y, .x)) df$x <- xflip * df$x + xoffset df$y <- yflip * df$y + yoffset geom_polygon(aes(x = x, y = y), data = df, ...) } geom_rose <- function(n, mean = c(0, 0), ...) { .x <- mvtnorm::rmvnorm(n, mean) df <- tibble(x = .x[, 1], y = .x[, 2]) list( stat_density_2d( aes(x = x, y = y, fill = stat(level)), data = df, geom = "polygon", show.legend = FALSE, color = "grey80"), scale_fill_gradient2(...) ) } p <- ggplot() + coord_equal(1, c(-4, 2), c(-7, 3)) + geom_curve(aes(x = -1, y = -7, xend = 0, yend = 0), ncp = 1000, curvature = -0.3, size = 1, color = "olivedrab3") + geom_leaf(0, 2, f, -1.6, -4.5, 1, fill = "olivedrab3", color = "palegreen") + geom_leaf(0, 2, f, -1.6, -5, -1, fill = "olivedrab3", color = "palegreen") + geom_leaf(0, 2, f1, -1.25, -2.25, -0.5, fill = "olivedrab3", color = "palegreen")+ geom_leaf(0, 3, f1, -1.25, -2.25, 0.5, fill = "olivedrab3", color = "palegreen") + geom_rose(1000, mean = c(0, 0), low = "red", mid = "purple", high = "pink", midpoint = 0.075) + theme_void() return(p) } p = rose_plot() ## 拼图 library(patchwork) g + inset_element( p,0, 0.15, 1, 0.35 )
小编有话说
除此之外，小编搜集资料的时候发现了一个好玩的知乎推文教程：错过了520还可以一起过儿童节，如何用R语言‘撸’一个文字跑马灯去表白[3]
小编修改了下，具体代码如下。主要是面向对象编程来写的，这里就不做过多解释了，大家自己看看吧（有点难）！效果图如下（跑马灯式表白）：
#' @title projector projector <- R6::R6Class( classname = "projector", public = list( initialize = function(sildes) { # 构造函数 private$slides <- sprintf("\r%s",sildes) # 给每页文字的开始加上'\r'字符以覆盖上一页 private$length <- base::length(private$slides) # 记录所有的播放页数量 private$position <- 0 # 初始播放位置为第一页之前 private$slide <- private$slides[private$position] }, nextslide = function(){ # 播放下一页 private$position <- private$position + 1 # 获取下一页位置 if ( private$position > private$length ){ # 播放到最后一页后回到第一页 private$position <- private$position - private$length } private$slide <- private$slides[ private$position ] # 设置当前播放页为下一页 base::cat(private$slide) # 播放当前播发页 }, autoplay = function(fps = 10){ # 自动播放，播放速率每秒10页 while(T){ # 无限循环，可以用for改写控制循环次数 self$nextslide() # 播放下一页 base::Sys.sleep(1/fps) # 休眠控制播放速率 } } ), private = list( slide = NA,# 当前播放页 slides = c(), # 所有的播放页 length = 0,# 播放页的总数 position = 0# 当前播放位置 ) ) #' @title scroller scroller <- R6::R6Class("scroller", inherit = projector, public = list( initialize = function(film, width = 50 ) { # 重载基类的构造函数，根据输入的文字和宽度自动设置播放页 film <- paste0( base::strrep(" ",width), film,base::strrep(" ",width), collapse="" ) slides <- rep( base::strrep(" ",width) , nchar(film)-width+1 ) for( i in 1:length(slides) ){ slides[i] <- substr(film,i,i+width-1) } super$initialize(slides) } ) ) #' @test boy <- scroller$new("脏茜茜的师妹，下个月的3篇推送写好了没？月底不给我，我就把你开了！！！",50) # 设置播放页的宽度为50 boy$autoplay(10) # 以每秒10页的速率播放
说出你的爱吧！
