R可视乎|用R给心仪的对象表白吧

点击下方公众号，回复资料分享，收获惊喜

简介

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

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

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

加入玫瑰花

以前看到公众号【微生信生物】写过一篇用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页的速率播放

说出你的爱吧！

参考资料

[1]

使用ggplot2绘制心形: https://blog.csdn.net/kMD8d5R/article/details/79386837?utm_medium=distribute.pc_relevant.none-task-blog-baidujs_baidulandingword-0&spm=1001.2101.3001.4242

[2]

链接: https://eric.netlify.app/2017/11/24/using-a-multivariate-normal-to-draw-a-flower-in-ggplot2/

[3]

错过了520还可以一起过儿童节，如何用R语言‘撸’一个文字跑马灯去表白: https://zhuanlan.zhihu.com/p/142803620

推荐： 可以保存以下照片，在b站扫该二维码，或者b站搜索【庄闪闪】观看Rmarkdown系列的视频教程。Rmarkdown视频新增两节视频（写轮眼幻灯片制作）需要视频内的文档，可在公众号回复【rmarkdown】