用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 / 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包，如果你不是很了解这个包，可以看以前写的推文系列：
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语言‘撸’一个文字跑马灯去表白
经过小编修改，具体代码如下。主要是面向对象编程来写的，这里就不做过多解释了，大家自己看看吧！效果图如下：
#' @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页的速率播放
