Rでお遊び：2月14日だからハートをプロット「plot_a

GitHubでハートをプロットする「plot_a_heart」コマンドが紹介されていました。オリジナルのコードに追記しggplot2パッケージを利用してテキスト追加、塗りつぶしを可能にしました。気になるあの人へプロットをプレゼントしてみてはいかがでしょうか。

オリジナルのコードはplotコマンドを利用した赤線のハートを表示する内容です。

・jrozra200/plot_a_heart
　https://github.com/jrozra200/plot_a_heart

実行コマンドはR version 4.2.2で確認しています。

実行コマンド

詳細はコメント、パッケージのヘルプを確認してください。

#Githubからソースを読み込み
install.packages("devtools")
devtools::source_url("https://raw.githubusercontent.com/jrozra200/plot_a_heart/master/plot_a_heart.R")
#ハートをプロット
plot_a_heart()
#参考:オリジナルコードとggplot2で描写コードを追加
#塗色:fillオプション
#塗りの透明度:alphaオプション
#テキスト色:textcolorオプション
#テキストの設定;textオプション;初期値"ハート"
#文字種の設定;base_familyオプション;初期値"Meiryo UI"
GGplot_a_heart <- function(fill = "red", alpha = 0.2,
                           text = "ハート", textcolor = "red", base_family = "Meiryo UI"){
  ## R-Code to generate a plot for the following equation
  ## y = x^(2/3) +/- sqrt(1 - x^2), which draws a heart
  ## In plain language, y equals x to the two-thirds plus or minus the 
  ## square-root of one minus x squared
  
  
  ## Generate the x data to be plotted - this creates 20,001 x values
  ## x cannot be less than -1 or greater than 1 (lower or higher will 
  ## create negative values in the square root... a no-no in math)
  tmp <- -1.0
  x <- data.frame()
  
  for (i in 1:20001){
    x[i,1] <- tmp
    tmp <- tmp + (1 / 10000)
  }
  
  ## I've created two y variables - one to handle the "plus" in the plus-
  ## or-minus statement and one to handle the minus.
  y1 <- data.frame()
  y2 <- data.frame()
  
  ## This loop generates the y values - the reason for the if statment is 
  ## for some reason, R did not like the negative values getting raised 
  ## to the 2/3 power
  for(i in 1:20001){
    y1[i,1] <- if(x[i,1] < 0){
      (-x[i,1])^(2/3) + sqrt(1 - x[i,1]^2)
    } else {
      (x[i,1])^(2/3) + sqrt(1 - x[i,1]^2)
    }
    
    y2[i,1] <- if(x[i,1] < 0){
      (-x[i,1])^(2/3) - sqrt(1 - x[i,1]^2)
    } else {
      (x[i,1])^(2/3) - sqrt(1 - x[i,1]^2)
    }
  }
  
  ## combine the values into a single data frame and name them
  final <- cbind(x, y1, y2)
  names(final) <- c("x", "ypos", "yneg")
  
  ## plot the result! I've removed the axes and frame to allow for a 
  ## nicer picture
  #plot(x = final$x, y = final$ypos, ylim = c(-1, 1.5), col = "red", 
  #     xlab = "", ylab = "", axes = FALSE, frame.plot = FALSE)
  #points(x = final$x, y = final$yneg, col = "red")
  
  #ggplotで描写を追記
  ggplot(final, aes(x = x, y = ypos)) +
    geom_ribbon(data = final,
                fill = fill,
                alpha = alpha,
                aes(x = x, y = ypos, ymin = min(final$ypos), ymax = final$ypos)) +
    geom_ribbon(data = final,
                fill = fill,
                alpha = alpha,
                aes(x = x, y = yneg, ymin = final$yneg, ymax = max(final$yneg))) +
    annotate("text", label = text, x = 0, y = max(final$yneg)*.8,
             color = textcolor, size = 10, family = base_family) +
    theme(line = element_blank(),
          text = element_blank(),
          rect = element_blank())
}
#コマンドの実行
library(ggplot2)
#macでの出力を想定しbase_familyに"HiraKakuProN-W3"設定
GGplot_a_heart(fill = "#a87963", alpha = 0.3, text = "義理チョコです。\n愛を込めて",
               textcolor = "red", base_family = "HiraKakuProN-W3")

出力例

・オリジナルの出力

・改造後の出力

少しでも、あなたのウェブや実験の解析が楽になりますように！！