用R给心仪的对象表白吧

简介

早上听完讲座才想起来，今天520了。那这样吧，小编给做了个小小的惊喜给读者们，年轻的盆友可以用这“小玩意”给自己心仪的对象表白了。

其实就是一个简单的ggplot绘制爱心，做一点细节处理，并加入相应文字啦！

如果有对象了（没有对象），你可以学学这个教程，举一反三。如果你想现在就拿去表白的话，直接复制节末完整代码即可。

教程

用R绘制爱心其实在网上有很多教程，小编主要参考使用ggplot2绘制心形，在此基础上进行稍微的调整。

加载相应的包，其中showtext包主要解决图片显示中文存在的问题，具体可见推文：

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语言可视化教程】中大部分都有提过，对应教程文稿可在公众号后台输入【可视化文稿】免费获得。所以就不做更加具体的讲解了。

这时输出的图形是这样的：

为了使图形更加有特色，你可以在改图片上继续添加新的元素。小编在此折腾了一下，给大家打开一点思路：

加入玫瑰花

以前看到公众号【微生信生物】写过一篇用R制作玫瑰花的推送，主要参考链接。那我就站在巨人们的肩膀上进行拓展了，具体教程看R制作玫瑰花。我在这里将整个过程包装成了一个函数，方便使用。

library(tidyverse)
rose_plot = function(){f <- function(x) x^2 / 2f1 <- function(x) x^2/5geom_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 + xoffsetdf$y <- yflip * df$y + yoffsetgeom_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包，如果你不是很了解这个包，可以看以前写的推文系列：

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 / 2f1 <- function(x) x^2/5geom_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 + xoffsetdf$y <- yflip * df$y + yoffsetgeom_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语言‘撸’一个文字跑马灯去表白

小编修改了下，具体代码如下。主要是面向对象编程来写的，这里就不做过多解释了，大家自己看看吧（有点难）！效果图如下（跑马灯式表白）：

#' @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页的速率播放

233