1. 编程圈首页
  2. 文库
  3. 后端开发

如何用R语言参破每个复仇者的口头禅?

盼望着,盼望着,《复联3》终于在国内上映。《复仇者联盟:无限战争》的表现也不负众望,国内上映3天后票房即达12亿元,目前豆瓣评分为8.5。

不用说你也知道,“复仇者联盟”里每个成员都性格迥异,所以说话用词都有各自鲜明的特点。那他们说话都爱用哪些词儿?

如何用R语言参破每个复仇者的口头禅?

国外有几位漫威的铁杆粉丝把每个复仇者的说话习惯用 R 语言可视化了出来,图中每个词对应的条形长度,代表了他比其他复仇者更爱说这个词的程度。

如何用R语言参破每个复仇者的口头禅?

我们可以看到,美队老爱喊别人名字,特别是托尼(emmmmmm...);黑豹经常念叨一些很高大上的词(比如朋友,国王),不像蜘蛛侠,满嘴嗯啊个不停(比如嘿,啊,呃),还跟个孩子似的;浩克和鹰眼说的最多的是黑寡妇,不过两人喊得称呼却不同(原因你猜);幻视和绯红女巫很有共同话题,所以这是俩人互生爱慕的原因?果然,雷神念叨最多的还是老弟洛基,而且老是想着“宇宙大事”,说的话都和第三部《无限战争》紧密相关;至于洛基嘛,意料之中的经常哔哔“权力”“王位”这些,但是跟洛基一样也渴望权力的奥创却说话不一样,人家说的词就很有诗意。

这么有意思的可视化图形是怎么做出来的呢?秘笈如下:

首先我们会用到以下 R 语言包:

library(dplyr)
library(grid)
library(gridExtra)
library(ggplot2)
library(reshape2)
library(cowplot)
library(jpeg)
library(extrafont)

有些人可能认为使用“清除所有”代码行很不好,但是在脚本顶部用它可以确保在执行脚本时,脚本不会依赖不小心遗留在工作区内的任何对象

rm(list = ls())

这是包含所有复仇者图像的文件夹:

dir_images <- "C:UsersMattDocumentsRAvengers"
setwd(dir_images)
如何用R语言参破每个复仇者的口头禅?

设置字体

windowsFonts(Franklin=windowsFont("Franklin Gothic Demi"))

各个复仇者名字的简化版

character_names <- c("black_panther","black_widow","bucky","captain_america",
                    "falcon","hawkeye","hulk","iron_man",
                    "loki","nick_fury","rhodey","scarlet_witch",
                    "spiderman","thor","ultron","vision")
image_filenames <- paste0(character_names, ".jpg")

读取和简化版复仇者名字对应的图像文件的函数

read_image <- function(filename){
 char_name <- gsub(pattern = ".jpg$", "", filename)
 img <- jpeg::readJPEG(filename)
 return(img)
}

将所有图像读取为一个列表

all_images <- lapply(image_filenames, read_image)

为这列图像分配名字,这样后面就可以被字符检索到了

names(all_images) <- character_names

其实使用图像名字很简单,比如下面这个例子

# clear the plot window
grid.newpage()
# draw to the plot window
grid.draw(rasterGrob(all_images[['vision']]))
如何用R语言参破每个复仇者的口头禅?

获取文本数据
这几位漫威粉并没有将他们自己的电影台词数据集分享出来,不过我们可以在 IMSDB 上下载,然后用文本分析技术稍作处理。如果原作者后面将自己的数据集公开,我们会第一时间分享。

加载本地数据集。

修正人物名字的大小写

capitalize <- Vectorize(function(string){
 substr(string,1,1) <- toupper(substr(string,1,1))
 return(string)
})

proper_noun_list <- c("clint","hydra","steve","tony",
                     "sam","stark","strucker","nat","natasha",
                     "hulk","tesseract", "vision",
                     "loki","avengers","rogers", "cap", "hill")

# Run the capitalization function
word_data <- word_data %>%
 mutate(word = ifelse(word %in% proper_noun_list, capitalize(word), word)) %>%
 mutate(word = ifelse(word == "jarvis", "JARVIS", word))

注意前面的简化版人物名字,不要匹配文本数据框中已经处理好格式的人物名字。

unique(word_data$Speaker)
##  [1] "Black Panther"   "Black Widow"     "Bucky"
##  [4] "Captain America" "Falcon"          "Hawkeye"
##  [7] "Hulk"            "Iron Man"        "Loki"
## [10] "Nick Fury"       "Rhodey"          "Scarlet Witch"
## [13] "Spiderman"       "Thor"            "Ultron"
## [16] "Vision"

制作一个查询表,将简写的文件名转换为美观的人物名字

character_labeler <- c(`black_panther` = "Black Panther",
                      `black_widow` = "Black Widow",
                      `bucky` = "Bucky",
                      `captain_america` = "Captain America",
                      `falcon` = "Falcon", `hawkeye` = "Hawkeye",
                      `hulk` = "Hulk", `iron_man` = "Iron Man",
                      `loki` = "Loki", `nick_fury` = "Nick Fury",
                      `rhodey` = "Rhodey",`scarlet_witch` ="Scarlet Witch",
                      `spiderman`="Spiderman", `thor`="Thor",
                      `ultron` ="Ultron", `vision` ="Vision")

获得两个不同版本的人物名字

其中一个版本用来展示(因为美观),另一个版本用于简单的组织和引用图像文件(因为简单)。

convert_pretty_to_simple <- Vectorize(function(pretty_name){
 # pretty_name = "Vision"
 simple_name <- names(character_labeler)[character_labeler==pretty_name]
 # simple_name <- as.vector(simple_name)
 return(simple_name)
})
# convert_pretty_to_simple(c("Vision","Thor"))
# just for fun, the inverse of that function
convert_simple_to_pretty <- function(simple_name){
 # simple_name = "vision"
 pretty_name <- character_labeler[simple_name] %>% as.vector()
 return(pretty_name)
}
# example
convert_simple_to_pretty(c("vision","black_panther"))
## [1] "Vision"        "Black Panther"

为文本数据框添加简化版人物名字。

word_data$character <- convert_pretty_to_simple(word_data$Speaker)

为每个人物分配一个主要颜色。

character_palette <- c(`black_panther` = "#51473E",
                      `black_widow` = "#89B9CD",
                      `bucky` = "#6F7279",
                      `captain_america` = "#475D6A",
                      `falcon` = "#863C43", `hawkeye` = "#84707F",
                      `hulk` = "#5F5F3F", `iron_man` = "#9C2728",
                      `loki` = "#3D5C25", `nick_fury` = "#838E86",
                      `rhodey` = "#38454E",`scarlet_witch` ="#620E1B",
                      `spiderman`="#A23A37", `thor`="#323D41",
                      `ultron` ="#64727D", `vision` ="#81414F" )

制作水平方向的条形图

avengers_bar_plot <- word_data %>%
 group_by(Speaker) %>%
 top_n(5, amount) %>%
 ungroup() %>%
 mutate(word = reorder(word, amount)) %>%
 ggplot(aes(x = word, y = amount, fill = character))+
 geom_bar(stat = "identity", show.legend = FALSE)+
 scale_fill_manual(values = character_palette)+
 scale_y_continuous(name ="Log Odds of Word",
                    breaks = c(0,1,2)) +
 theme(text = element_text(family = "Franklin"),
       # axis.title.x = element_text(size = rel(1.5)),
       panel.grid = element_line(colour = NULL),
       panel.grid.major.y = element_blank(),
       panel.grid.minor = element_blank(),
       panel.background = element_rect(fill = "white",
                                   colour = "white"))+
 # theme(strip.text.x = element_text(size = rel(1.5)))+
 xlab("")+
 coord_flip()+
 facet_wrap(~Speaker, scales = "free_y")
avengers_bar_plot
如何用R语言参破每个复仇者的口头禅?

看起来很不错。

但是我们想画个更酷炫的图:用每个复仇者的照片来填充条形图

也就是说我们只在条形图区域内展示出复仇者的照片,在条形区域以外的地方则不展示(如下图所示)。

如果想做到这点,我们需要显示一个透明的条形,然后在条形的末尾画一个白色的条形,延伸至图像边缘覆盖人物照片的剩余部分。

如何用R语言参破每个复仇者的口头禅?
如何用R语言参破每个复仇者的口头禅?
如何用R语言参破每个复仇者的口头禅?

在数据框部分,我们现在想用所需的值的余数来补充数字值,以实现整体最大化,这样当把值和余数相加时,所有数值都会增加到同一最大数值,以同样的格式将不同行组合到一起。

max_amount <- max(word_data$amount)
word_data$remainder <- (max_amount - word_data$amount) + 0.2

只提取每个复仇者说的最多的5个词

word_data_top5 <- word_data %>%
 group_by(character) %>%
 arrange(desc(amount)) %>%
 slice(1:5) %>%
 ungroup()

将数量&余数转换为长格式

如何用R语言参破每个复仇者的口头禅?

这样能保证每个人物和所说词语的匹配关系有两个 entry,一个用以真实数量(“amount”),一个用以选择在哪里结束,达到常见的最大值(“remainder”)。

这会将“amount”和“remainder”重叠为一个单独的列称为“variable”,表示是什么值,而另一个列“value”包含来自这些值中每一个值的数字。

word_data_top5_m <- melt(word_data_top5, measure.vars = c("amount","remainder"))

Variable 是一个值是真实数量还是补充数量的标记。

现在我们按顺序将它们放在一起,和在melt函数中的确定它们的顺序相反。否则“amount”和“remainder”会以相反的顺序展现在图形中。

word_data_top5_m$variable2 <- factor(word_data_top5_m$variable,
                                    levels = rev(levels(word_data_top5_m$variable)))

为一个人物展示前 5 个词语数据的函数

以简单的形式声明人物名字,比如用 black_panther 而不是 Black Panther。

plot_char <- function(character_name){
 # example: character_name = "black_panther"
 # plot details that we might want to fiddle with
 # thickness of lines between bars
 bar_outline_size <- 0.5
 # transparency of lines between bars
 bar_outline_alpha <- 0.25
 #
 # The function takes the simple character name,
 # but here, we convert it to the pretty name,
 # because we'll want to use that on the plot.
 pretty_character_name <- convert_simple_to_pretty(character_name)

 # Get the image for this character,
 # from the list of all images.
 temp_image <- all_images[character_name]

 # Make a data frame for only this character
 temp_data <- word_data_top5_m %>%
   dplyr::filter(character == character_name) %>%
   mutate(character = character_name)

 # order the words by frequency
 # First, make an ordered vector of the most common words
 # for this character
   ordered_words <- temp_data %>%
     mutate(word = as.character(word)) %>%
     dplyr::filter(variable == "amount") %>%
     arrange(value) %>%
     `[[`(., "word")

   # order the words in a factor,
   # so that they plot in this order,
   # rather than alphabetical order
   temp_data$word = factor(temp_data$word, levels = ordered_words)

 # Get the max value,
 # so that the image scales out to the end of the longest bar
 max_value <- max(temp_data$value)
 fill_colors <- c(`remainder` = "white", `value` = "white")

 # Make a grid object out of the character's image
 character_image <- rasterGrob(all_images[[character_name]],
                               width = unit(1,"npc"),
                               height = unit(1,"npc"))

 # make the plot for this character
 output_plot <- ggplot(temp_data)+
   aes(x = word, y = value, fill = variable2)+
   # add image
   # draw it completely bottom to top (x),
   # and completely from left to the the maximum log-odds value (y)
   # note that x and y are flipped here,
   # in prep for the coord_flip()
   annotation_custom(character_image,
                     xmin = -Inf, xmax = Inf, ymin = 0, ymax = max_value) +
   geom_bar(stat = "identity", color = alpha("white", bar_outline_alpha),
            size = bar_outline_size, width = 1)+
   scale_fill_manual(values = fill_colors)+
   theme_classic()+
   coord_flip(expand = FALSE)+
   # use a facet strip,
   # to serve as a title, but with color
   facet_grid(. ~ character, labeller = labeller(character = character_labeler))+
   # figure out color swatch for the facet strip fill
   # using character name to index the color palette
   # color= NA means there's no outline color.
   theme(strip.background = element_rect(fill = character_palette[character_name],
                                         color = NA))+
   # other theme elements
   theme(strip.text.x = element_text(size = rel(1.15), color = "white"),
         text = element_text(family = "Franklin"),
         legend.position = "none",
         panel.grid = element_blank(),
         axis.text.x = element_text(size = rel(0.8)))+
   # omit the axis title for the individual plot,
   # because we'll have one for the entire ensemble
   theme(axis.title = element_blank())
 return(output_plot)
}

将 X 轴名称用为所有复仇者主图像的名称

plot_x_axis_text <- paste("Tendency to use this word more than other characters do",
                         "(units of log odds ratio)", sep = "n")

下面是函数在这里的工作示例

sample_plot <- plot_char("black_panther")+
 theme(axis.title = element_text())+
 # x lab is still declared as y lab
 # because of coord_flip()
 ylab(plot_x_axis_text)
sample_plot
如何用R语言参破每个复仇者的口头禅?

为何我们这里的水平轴上还带着非常奇怪的“对数差异比”?

因为随着数字增大,差异也会随之增大(具体数学知识这里不再讲述);将它们转换为对数尺度,可以约束变化幅度的大小,方便我们在屏幕上展示。

如果想将这些对数差异转化为简单的概率形式,可以用如下函数:

logit2prob <- function(logit){
 odds <- exp(logit)
 prob <- odds / (1 + odds)
 return(prob)
}

这样处理后水平轴会如下所示:

logit2prob(seq(0, 2.5, 0.5))
## [1] 0.5000000 0.6224593 0.7310586 0.8175745 0.8807971 0.9241418

注意此序列中连续项目之间的差异在慢慢消失:

diff(logit2prob(seq(0, 2.5, 0.5)))
## [1] 0.12245933 0.10859925 0.08651590 0.06322260 0.04334474

Okay,现在我们制作出了一个图···

我们接着将函数应用到列表中所有复仇者身上,将所有绘图放入一个列表对象。

all_plots <- lapply(character_names, plot_char)

从绘图中提取轴名称的函数

不仅仅是文本,还有其它画出的信息。

你可以选择提取 X 轴名称还是 Y 轴名称:

get_axis_grob <- function(plot_to_pick, which_axis){
 # plot_to_pick <- sample_plot
 tmp <- ggplot_gtable(ggplot_build(plot_to_pick))
 # tmp$grobs
 # find the grob that looks like
 # it would be the x axis
 axis_x_index <- which(sapply(tmp$grobs, function(x){
   # for all the grobs,
   # return the index of the one
   # where you can find the text
   # "axis.title.x" or "axis.title.y"
   # based on input argument `which_axis`
   grepl(paste0("axis.title.",which_axis), x)}
 ))
 axis_grob <- tmp$grobs[[axis_x_index]]
 return(axis_grob)
} 

提取轴名称 Grob

px_axis_x <- get_axis_grob(sample_plot, "x")
px_axis_y <- get_axis_grob(sample_plot, "y")

下面是使用这些提取的轴的方法

grid.newpage()
grid.draw(px_axis_x) 

将所有绘图排成一个对象

big_plot <- arrangeGrob(grobs = all_plots)

将 X 轴嵌入绘图的底部,因为每个图并没有 X 轴,而我们想让它们都有 X 轴。

注意这时绘图会看着很不协调,高度差不多是宽度的十倍。

big_plot_w_x_axis_title <- arrangeGrob(big_plot,
                                      px_axis_x,
                                      heights = c(10,1))
grid.newpage()
grid.draw(big_plot_w_x_axis_title)
如何用R语言参破每个复仇者的口头禅?

绘图所占的空间大小不一,因为每个图的词汇长度不同。

这样看起来有些混乱。

通常我们会用 facet_grid() 或 facet_wrap() 来确保绘图整洁有序,但这里却不能使用因为每个图的背景图各不相同,无法像数据框中的其它列一样映射到平面上(因为背景图像实际上并非数据框的一部分)。

使用 cowplot 而非 arrangeGrob

这样绘图的轴会垂直对齐:

big_plot_aligned <- cowplot::plot_grid(plotlist = all_plots, align = 'v', nrow = 4)

和之前一样,将X轴名称添加至绘图对齐后网格的下方。

big_plot_w_x_axis_title_aligned <- arrangeGrob(big_plot_aligned,
                                              px_axis_x,
                                              heights = c(10,1))

下面是将整体效果图绘制在屏幕上的方法:

grid.newpage()
grid.draw(big_plot_w_x_axis_title_aligned)
如何用R语言参破每个复仇者的口头禅?

很好!

保存最终图像:

ggsave(big_plot_w_x_axis_title_aligned,
      file = "Avengers_Word_Usage.png",
      width = 12, height = 6.3)
如何用R语言参破每个复仇者的口头禅?

这样,我们就可视化出了《复联》中各个复仇者都最爱说那些话!

发布者:编程圈,转转请注明出处:https://www.bianchengquan.com/article/63277.html

发表评论

登录后才能评论