Chapter 6 第六章 文本数据分析
6.5 课堂任务
library(tidyverse)
setwd("~/Nutstore Files/310_Tutorial/LanguageDS-e")
# 导入文本数据
require(readtext)
# 文本数据分析
library(quanteda)
library(quanteda.textstats)
library(quanteda.textplots)
library(tidytext)
# 依存句法分析
library(udpipe)
# 表格呈现
library(DT)
library(flextable)
library(DiagrammeR)
library(FactoMineR)
library(factoextra)
# 停止使用科学计数法
options(scipen = 999)
# 可视化
library(GGally)
library(ggdendro)
library(igraph)
library(network)
library(Matrix)
# 可视化
library(scales)
library(tm)
library(sna)任务6.1 高频词分析
# quanteda
detectives.raw <- readtext("data/ch6/detectives/*txt")
corps.detectives = corpus(detectives.raw)
summary(corpus(corps.detectives), 5)
docvars(corps.detectives, "book") <- names(corps.detectives)# make a dfm
dfm_detectives <- corps.detectives %>%
tokens(remove_punct = TRUE) %>%
tokens_remove(stopwords("en")) %>%
dfm()%>%
dfm_group(groups = book)
print(dfm_detectives)
topfeatures(dfm_detectives, 20)dfm_detectives.freq <- textstat_frequency(dfm_detectives,
n = 10,
groups = book)
ggplot(dfm_detectives.freq,
aes(x = frequency, y = reorder(feature, frequency))) +
geom_point() +
labs(x = "Frequency", y = "Feature")+
facet_wrap(~ group, scales = "free") 我们还可以通过 tidytext 包的 tidy() 函数，将语料库转换为整洁数据框格式，以便使用 tidyverse 工具进一步处理和可视化。
tidy.corps.detectives = tidytext::tidy(corps.detectives)%>%
unnest_tokens(word, text) %>%
anti_join(stop_words, by = "word")%>%
group_by(book)%>%
count(word, sort = TRUE) %>%
mutate(proportion = n / sum(n))
tidy.corps.detectives%>%
group_by(book)%>%
arrange(desc(proportion))%>%
mutate(rank = 1:n())%>%
filter(rank < 11) %>%
ggplot(aes(proportion, reorder(word, proportion))) +
geom_col(fill="#006b7b") +
facet_wrap(~book, ncol = 3, scales = "free") +
labs(y = NULL)## 计算两者的词汇频率相关性
df.freq = tidy.corps.detectives%>%
select(-n) %>%
pivot_wider(names_from = book, values_from = proportion) %>%
pivot_longer(`Dee.txt`:`Agatha.txt`,
names_to = "author", values_to = "proportion")%>%
filter(!is.na(Sherlock.txt) & !is.na(proportion))
# expect a warning about rows with missing values being removed
ggplot(df.freq, aes(x = proportion, y = `Sherlock.txt`,
color = abs(`Sherlock.txt` - proportion))) +
geom_abline(color = "gray40", lty = 2) +
geom_jitter(alpha = 0.1, size = 2.5, width = 0.3, height = 0.3) +
geom_text(aes(label = word), check_overlap = TRUE, vjust = 1.5) +
scale_x_log10(labels = percent_format()) +
scale_y_log10(labels = percent_format()) +
scale_color_gradient(limits = c(0, 0.001),
low = "darkslategray4", high = "gray75") +
theme(legend.position="none") +
facet_wrap(~author, ncol = 2) +
labs(y = "Sherlock.txt", x = NULL)
cor.test(data = df.freq[df.freq$author == "Dee.txt",],
~ proportion + `Sherlock.txt`)
cor.test(data = df.freq[df.freq$author == "Agatha.txt",],
~ proportion + `Sherlock.txt`)任务6.2 关键词分析
6.5.0.2 tidytext
# 对比狄仁杰和福尔摩斯
texts_df = detectives.raw%>%
unnest_tokens(word, text)%>%
mutate(doc_id = dplyr::recode(doc_id , "Dee.txt" = "text1",
"Sherlock.txt" = "text2"))%>%
group_by(doc_id,word)%>%
summarise(freq = n())%>%
spread(doc_id, freq, fill = 0)%>%
dplyr::rename(token = "word")%>%
select(-Agatha.txt)%>%
mutate( # remove non-word characters
token = stringr::str_remove_all(token, "[^[:alpha:] ]"),
token = stringr::str_remove_all(token, "[[:punct:][:space:]]+"),
token = na_if(token, "") )%>%
filter(!is.na(token))
# codes borrowed from https://ladal.edu.au/tutorials/key/key.html
stats_tb2 = texts_df %>%
dplyr::mutate(text1 = as.numeric(text1),
text2 = as.numeric(text2)) %>%
dplyr::mutate(C1 = sum(text1),
C2 = sum(text2),
N = C1 + C2) %>%
dplyr::rowwise() %>%
dplyr::mutate(R1 = text1+text2,
R2 = N - R1,
O11 = text1,
O12 = R1-O11,
O21 = C1-O11,
O22 = C2-O12) %>%
dplyr::mutate(E11 = (R1 * C1) / N,
E12 = (R1 * C2) / N,
E21 = (R2 * C1) / N,
E22 = (R2 * C2) / N) %>%
dplyr::select(-text1, -text2)
head(stats_tb2)%>%
datatable(.,
filter = "top",
class = 'cell-border stripe hover compact'
)
assoc_tb3 = stats_tb2 %>%
# determine number of rows
dplyr::mutate(Rws = nrow(.)) %>%
# work row-wise
dplyr::rowwise() %>%
# calculate fishers' exact test
dplyr::mutate(p = as.vector(unlist(fisher.test(matrix(c(O11, O12, O21, O22),
ncol = 2, byrow = T))[1]))) %>%
# extract descriptives
dplyr::mutate(ptw_target = O11/C1*1000,
ptw_ref = O12/C2*1000) %>%
# extract x2 statistics
dplyr::mutate(X2 = (O11-E11)^2/E11 + (O12-E12)^2/E12 + (O21-E21)^2/E21 + (O22-E22)^2/E22) %>%
# extract keyness measures
dplyr::mutate(phi = sqrt((X2 / N)),
MI = log2(O11 / E11),
t.score = (O11 - E11) / sqrt(O11),
PMI = log2( (O11 / N) / ((O11+O12) / N) *
((O11+O21) / N) ),
DeltaP = (O11 / R1) - (O21 / R2),
LogOddsRatio = log(((O11 + 0.5) * (O22 + 0.5)) / ( (O12 + 0.5) * (O21 + 0.5) )),
G2 = 2 * ((O11+ 0.001) * log((O11+ 0.001) / E11) + (O12+ 0.001) * log((O12+ 0.001) / E12) + O21 * log(O21 / E21) + O22 * log(O22 / E22)),
# traditional keyness measures
RateRatio = ((O11+ 0.001)/(C1*1000)) / ((O12+ 0.001)/(C2*1000)),
RateDifference = (O11/(C1*1000)) - (O12/(C2*1000)),
DifferenceCoefficient = RateDifference / sum((O11/(C1*1000)), (O12/(C2*1000))),
OddsRatio = ((O11 + 0.5) * (O22 + 0.5)) / ( (O12 + 0.5) * (O21 + 0.5) ),
LLR = 2 * (O11 * (log((O11 / E11)))),
RDF = abs((O11 / C1) - (O12 / C2)),
PDiff = abs(ptw_target - ptw_ref) / ((ptw_target + ptw_ref) / 2) * 100,
SignedDKL = sum(ifelse(O11 > 0, O11 * log(O11 / ((O11 + O12) / 2)), 0) - ifelse(O12 > 0, O12 * log(O12 / ((O11 + O12) / 2)), 0))) %>%
# determine Bonferroni corrected significance
dplyr::mutate(Sig_corrected = dplyr::case_when(p / Rws > .05 ~ "n.s.",
p / Rws > .01 ~ "p < .05*",
p / Rws > .001 ~ "p < .01**",
p / Rws <= .001 ~ "p < .001***",
T ~ "N.A.")) %>%
# round p-value
dplyr::mutate(p = round(p, 5),
type = ifelse(E11 > O11, "antitype", "type"),
phi = ifelse(E11 > O11, -phi, phi),
G2 = ifelse(E11 > O11, -G2, G2)) %>%
# filter out non significant results
dplyr::filter(Sig_corrected != "n.s.") %>%
# arrange by G2
dplyr::arrange(-G2) %>%
# remove superfluous columns
dplyr::select(-any_of(c("TermCoocFreq", "AllFreq", "NRows",
"R1", "R2", "C1", "C2", "E12", "E21",
"E22", "upp", "low", "op", "t.score", "z.score", "Rws"))) %>%
dplyr::relocate(any_of(c("token", "type", "Sig_corrected", "O11", "O12",
"ptw_target", "ptw_ref", "G2", "RDF", "RateRatio",
"RateDifference", "DifferenceCoefficient", "LLR", "SignedDKL",
"PDiff", "LogOddsRatio", "MI", "PMI", "phi", "X2",
"OddsRatio", "DeltaP", "p", "E11", "O21", "O22")))
head(assoc_tb3)%>%
datatable(.,
filter = "top",
class = 'cell-border stripe hover compact'
)
# sort the assoc_tb3 data frame in descending order based on the 'G2' column
assoc_tb3 %>%
filter(!is.infinite(G2))%>%
dplyr::arrange(-G2) %>%
# select the top 20 rows after sorting
head(20) %>%
# create a ggplot with 'token' on the x-axis (reordered by 'G2') and 'G2' on the y-axis
ggplot(aes(x = reorder(token, G2, mean), y = G2)) +
# add a scatter plot with points representing the 'G2' values
geom_point() +
# flip the coordinates to have horizontal points
coord_flip() +
# set the theme to a basic white and black theme
theme_bw() +
# set the x-axis label to "Token" and y-axis label to "Keyness (G2)"
labs(x = "Token", y = "Keyness (G2)")
# get top 10 keywords for text 1
top <- assoc_tb3 %>%
filter(!is.infinite(G2))%>%
dplyr::ungroup() %>%
dplyr::slice_head(n = 12)
# get top 10 keywords for text 2
bot <- assoc_tb3 %>%
dplyr::ungroup() %>%
dplyr::slice_tail(n = 12)
# combine into table
rbind(top, bot) %>%
# create a ggplot
ggplot(aes(x = reorder(token, G2, mean), y = G2, label = G2, fill = type)) +
# add a bar plot using the 'phi' values
geom_bar(stat = "identity") +
# add text labels above the bars with rounded 'phi' values
geom_text(aes(
y = ifelse(G2 > 0, G2 - 50, G2 + 50),
label = round(G2, 1)
), color = "white", size = 3) +
# flip the coordinates to have horizontal bars
coord_flip() +
# set the theme to a basic white and black theme
theme_bw() +
# remove legend
theme(legend.position = "none") +
# define colors
scale_fill_manual(values = c("orange", "darkgray")) +
# set the x-axis label to "Token" and y-axis label to "Keyness (G2)"
labs(title = "Top 10 keywords for text1 and text 2", x = "Keyword", y = "Keyness (G2)")任务6.3 共现语境分析
双语平行语料库检索
# 导入
law_ce <- read_csv("data/ch6/law.csv", col_names = TRUE)
# 检索中文
law_ce%>%
filter(str_detect(cn, "当事人"))%>%
datatable(.,
filter = "top",
class = 'cell-border stripe hover compact'
) # put it at the top of the table
law_ce%>%
mutate(count = str_count(cn, "当事人"))%>%
filter(count > 0)
##上下排版的文本如何构建平行语料库
trans_corpus <- read_csv("data/ch6/英汉对照文本.csv", col_names = FALSE)
row.no = nrow(trans_corpus)
trans.new = trans_corpus%>%
mutate(key = rep(c("E","C"), (row.no/2)),
id = rep(1:(row.no/2),each=2))%>%
spread(key, X1)
trans.new %>%
datatable(.,
filter = "top",
class = 'cell-border stripe hover compact'
) # put it at the top of the table
#search
trans.new%>%
filter(str_detect(E, "good"))%>%
datatable(.,
filter = "top",
class = 'cell-border stripe hover compact'
) # put it at the top of the table任务6.4 搭配提取
自带算法
toks_corpus_detectives%>%
#提取包含大写字母的专有名词
tokens_select(pattern = "^[A-Z]",
valuetype = "regex",
case_insensitive = FALSE,
padding = TRUE) %>%
textstat_collocations(min_count = 5,
size = 3,
tolower = FALSE)
collocation.3wd <- textstat_collocations(corps.detectives,
size = 3,
tolower = FALSE)
head(collocation.3wd)基于句子提取搭配
# set options
options(stringsAsFactors = F)
options(scipen = 999)
options(max.print=1000)
# codes were borrowed from https://ladal.edu.au/tutorials/coll/coll.html
sentences =corps.detectives%>%
# split text into sentences
tokenizers::tokenize_sentences() %>%
# unlist sentences
unlist() %>%
# remove non-word characters
stringr::str_replace_all("\\W", " ") %>%
stringr::str_replace_all("[^[:alnum:] ]", " ") %>%
# remove superfluous white spaces
stringr::str_squish() %>%
# convert to lower case and save in 'sentences' object
tolower()
head(sentences)
# tokenize the 'sentences' data using quanteda package
coll_basic = sentences %>%
quanteda::tokens() %>%
# create a document-feature matrix (dfm) using quanteda
quanteda::dfm() %>%
# create a feature co-occurrence matrix (fcm) without considering trigrams
quanteda::fcm(tri = FALSE)%>%
# tidy the data using tidytext package
tidytext::tidy() %>%
# rearrange columns for better readability
dplyr::relocate(term, document, count) %>%
# rename columns for better interpretation
dplyr::rename(w1 = 1,
w2 = 2,
O11 = 3)
head(coll_basic)%>%
datatable(.,
filter = "top",
class = 'cell-border stripe hover compact'
)
# calculate the total number of observations (N)
colldf = coll_basic %>%
dplyr::mutate(N = sum(O11)) %>%
# calculate R1, O12, and R2
dplyr::group_by(w1) %>%
dplyr::mutate(R1 = sum(O11),
O12 = R1 - O11,
R2 = N - R1) %>%
dplyr::ungroup(w1) %>%
# calculate C1, O21, C2, and O22
dplyr::group_by(w2) %>%
dplyr::mutate(C1 = sum(O11),
O21 = C1 - O11,
C2 = N - C1,
O22 = R2 - O21)
head(colldf )%>%
datatable(.,
filter = "top",
class = 'cell-border stripe hover compact'
)
# reduce and complement data
colldf_redux = colldf %>%
# determine Term
dplyr::filter(w1 == "crime",
# set minimum number of occurrences of w2
(O11+O21) > 10,
# set minimum number of co-occurrences of w1 and w2
O11 > 5) %>%
dplyr::rowwise() %>%
dplyr::mutate(E11 = R1 * C1 / N,
E12 = R1 * C2 / N,
E21 = R2 * C1 / N,
E22 = R2 * C2 / N)
head(colldf_redux )%>%
datatable(.,
filter = "top",
class = 'cell-border stripe hover compact'
)
# 计算“crime”这个词的搭配
assoc_tb = colldf_redux %>%
# determine number of rows
dplyr::mutate(Rws = nrow(.)) %>%
# work row-wise
dplyr::rowwise() %>%
# calculate fishers' exact test
dplyr::mutate(p = as.vector(unlist(fisher.test(matrix(c(O11, O12, O21, O22),
ncol = 2, byrow = T))[1]))) %>%
# extract AM
# 1. bias towards top left
dplyr::mutate(btl_O12 = ifelse(C1 > R1, 0, R1-C1),
btl_O11 = ifelse(C1 > R1, R1, R1-btl_O12),
btl_O21 = ifelse(C1 > R1, C1-R1, C1-btl_O11),
btl_O22 = ifelse(C1 > R1, C2, C2-btl_O12),
# 2. bias towards top right
btr_O11 = 0,
btr_O21 = R1,
btr_O12 = C1,
btr_O22 = C2-R1) %>%
# 3. calculate AM
dplyr::mutate(upp = btl_O11/R1,
low = btr_O11/R1,
op = O11/R1) %>%
dplyr::mutate(AM = op / upp) %>%
# remove superfluous columns
dplyr::select(-any_of(c("btr_O21", "btr_O12", "btr_O22", "btl_O12",
"btl_O11", "btl_O21", "btl_O22", "btr_O11"))) %>%
# extract x2 statistics
dplyr::mutate(X2 = (O11-E11)^2/E11 + (O12-E12)^2/E12 + (O21-E21)^2/E21 + (O22-E22)^2/E22) %>%
# extract association measures
dplyr::mutate(phi = sqrt((X2 / N)),
Dice = (2 * O11) / (R1 + C1),
LogDice = log((2 * O11) / (R1 + C1)),
MI = log2(O11 / E11),
MS = min((O11/C1), (O11/R1)),
t.score = (O11 - E11) / sqrt(O11),
z.score = (O11 - E11) / sqrt(E11),
PMI = log2( (O11 / N) / ((O11+O12) / N) *
((O11+O21) / N) ),
DeltaP12 = (O11 / (O11 + O12)) - (O21 / (O21 + O22)),
DeltaP21 = (O11 / (O11 + O21)) - (O21 / (O12 + O22)),
DP = (O11 / R1) - (O21 / R2),
LogOddsRatio = log(((O11 + 0.5) * (O22 + 0.5)) / ( (O12 + 0.5) * (O21 + 0.5) )),
# calculate LL aka G2
G2 = 2 * (O11 * log(O11 / E11) + O12 * log(O12 / E12) + O21 * log(O21 / E21) + O22 * log(O22 / E22))) %>%
# determine Bonferroni corrected significance
dplyr::mutate(Sig_corrected = dplyr::case_when(p / Rws > .05 ~ "n.s.",
p / Rws > .01 ~ "p < .05*",
p / Rws > .001 ~ "p < .01**",
p / Rws <= .001 ~ "p < .001***",
T ~ "N.A.")) %>%
# round p-value
dplyr::mutate(p = round(p, 5)) %>%
# filter out non significant results
dplyr::filter(Sig_corrected != "n.s.",
# filter out instances where the w1 and w2 repel each other
E11 < O11) %>%
# arrange by DeltaP12 (association measure)
dplyr::arrange(-DeltaP12) %>%
# remove superfluous columns
dplyr::select(-any_of(c("TermCoocFreq", "AllFreq", "NRows", "O12", "O21",
"O22", "R1", "R2", "C1", "C2", "E11", "E12", "E21",
"E22", "upp", "low", "op", "Rws")))
head(assoc_tb)%>%
datatable(.,
filter = "top",
class = 'cell-border stripe hover compact'
) # data visualisation
# sort the assoc_tb data frame in descending order based on the 'phi' column
assoc_tb %>%
dplyr::arrange(-phi) %>%
# select the top 20 rows after sorting
head(20) %>%
# create a ggplot with 'token' on the x-axis (reordered by 'phi') and 'phi' on the y-axis
ggplot(aes(x = reorder(w2, phi, mean), y = phi)) +
# add a scatter plot with points representing the 'phi' values
geom_point() +
# flip the coordinates to have horizontal points
coord_flip() +
# set the theme to a basic white and black theme
theme_bw() +
# set the x-axis label to "Token" and y-axis label to "Association strength (phi)"
labs(x = "Collocation for crime", y = "Association strength (phi)")# sort the assoc_tb data frame in descending order based on the 'phi' column
assoc_tb %>%
dplyr::arrange(-phi) %>%
# select the top 20 rows after sorting
head(20) %>%
# create a ggplot with 'w2' on the x-axis (reordered by 'phi') and 'phi' on the y-axis
ggplot(aes(x = reorder(w2, phi, mean), y = phi, label = phi)) +
# add a bar plot using the 'phi' values
geom_bar(stat = "identity") +
# add text labels above the bars with rounded 'phi' values
#geom_text(aes(y = phi - 0.005, label = round(phi, 3)), color = "white", size = 3) +
#geom_text(aes(y = phi, label = round(phi, 3)), color = "white", size = 3) +
# flip the coordinates to have horizontal bars
coord_flip() +
# set the theme to a basic white and black theme
theme_bw() +
# set the x-axis label to "Token" and y-axis label to "Association strength (phi)"
labs(x = "Collocation for crime", y = "Association strength (phi)")# sort the assoc_tb2 data frame in descending order based on the 'phi' column
top20colls <- assoc_tb %>%
dplyr::arrange(-phi) %>%
# select the top 20 rows after sorting
head(20) %>%
# extract the 'token' column
dplyr::pull(w2)
# inspect the top 20 tokens with the highest 'phi' values
top20colls
# tokenize the 'sentences' data using quanteda package
keyword_fcm <- sentences %>%
quanteda::tokens() %>%
# create a document-feature matrix (dfm) from the tokens
quanteda::dfm() %>%
# select features based on 'top20colls' and the term "selection" pattern
quanteda::dfm_select(pattern = c(top20colls, "crime")) %>%
# Create a symmetric feature co-occurrence matrix (fcm)
quanteda::fcm(tri = FALSE)
# inspect the first 6 rows and 6 columns of the resulting fcm
keyword_fcm[1:6, 1:6]
# create a hierarchical clustering object using the distance matrix of the fcm as data
hclust(dist(keyword_fcm),
# use ward.D as linkage method
method="ward.D2") %>%
# generate visualization (dendrogram)
ggdendrogram() +
# add title
ggtitle("20 most strongly collocating terms of 'kill'") # create a network plot using the fcm
quanteda.textplots::textplot_network(keyword_fcm,
# set the transparency of edges to 0.8 for visibility
edge_alpha = 0.8,
# set the color of edges to gray
edge_color = "gray",
# set the size of edges to 2 for better visibility
edge_size = 2,
# adjust the size of vertex labels
# based on the logarithm of row sums of the fcm
vertex_labelsize = log(rowSums(keyword_fcm)))任务6.5 依存句法分析
依存句法标注
#Load the model
# First load the model which you have downloaded or which you have stored somewhere on disk.
# udmodel <- udpipe_download_model(language = "chinese")
## Either give a file in the current working directory
udmodel_eng <- udpipe_load_model(file = "data/ch6/english-ewt-ud-2.5-191206.udpipe")
# udmodel_chn <- udpipe_load_model(file = "chinese-gsd-ud-2.5-191206.udpipe")
# dee.raw <- scan(file="judge_dee/01.txt",
# what="character",
# sep="\n")
dee.raw = detectives.raw %>%
filter(doc_id == "Dee.txt")
dee.depd <- udpipe_annotate(udmodel_eng, x = dee.raw$text)
dee.df <- as.data.frame(dee.depd)
table(dee.df$upos)依存句法结构
基于词性的搭配提取
## Using RAKE
stats <- keywords_rake(x = dee.df, term = "lemma", group = "doc_id",
relevant = dee.df$upos %in% c("NOUN", "ADJ"))
stats$key <- factor(stats$keyword, levels = rev(stats$keyword))
barchart(key ~ rake, data = head(subset(stats, freq > 3), 20), col = "cadetblue",
main = "Key NOUN + ADJ phrases identified by RAKE",
xlab = "Rake (Rapid Automatic Keyword Extraction method)")## Using Pointwise Mutual Information Collocations
dee.df$word <- tolower(dee.df$token)
stats <- keywords_collocation(x = dee.df, term = "word", group = "doc_id")
stats$key <- factor(stats$keyword, levels = rev(stats$keyword))
barchart(key ~ pmi, data = head(subset(stats, freq > 3), 20), col = "cadetblue",
main = "Keywords identified by PMI Collocation",
xlab = "PMI (Pointwise Mutual Information method)")## Using a sequence of POS tags (noun phrases / verb phrases)
dee.df$phrase_tag <- as_phrasemachine(dee.df$upos, type = "upos")
stats <- keywords_phrases(x = dee.df$phrase_tag, term = tolower(dee.df$token),
pattern = "(A|N)*N(P+D*(A|N)*N)*",
is_regex = TRUE, detailed = FALSE)
stats <- subset(stats, ngram > 1 & freq > 3)
stats$key <- factor(stats$keyword, levels = rev(stats$keyword))
barchart(key ~ freq, data = head(stats, 20), col = "cadetblue",
main = "Keywords - simple noun phrases", xlab = "Frequency")library(igraph)
library(ggraph)
library(ggplot2)
## Co-occurrences allow to see how words are used either in the same sentence or next to each other.
# This R package make creating co-occurrence graphs using the relevant Parts of Speech tags as easy as possible.
# Nouns / adjectives used in same sentence
cooc <- cooccurrence(x = subset(dee.df, upos %in% c("NOUN", "ADJ")),
term = "lemma",
group = c("doc_id", "paragraph_id", "sentence_id"))
wordnetwork <- head(cooc, 30)
wordnetwork <- graph_from_data_frame(wordnetwork)
ggraph(wordnetwork, layout = "fr") +
geom_edge_link(aes(width = cooc, edge_alpha = cooc), edge_colour = "blue") +
geom_node_text(aes(label = name), col = "darkgreen", size = 4) +
theme_graph(base_family = "Arial Narrow") +
theme(legend.position = "none") +
labs(title = "Cooccurrences within sentence", subtitle = "Nouns & Adjective")## topic modelling
## Define the identifier at which we will build a topic model
dee.df$topic_level_id <- unique_identifier(dee.df, fields = c("doc_id", "paragraph_id", "sentence_id"))
## Get a data.frame with 1 row per id/lemma
dtf <- subset(dee.df, upos %in% c("NOUN"))
dtf <- document_term_frequencies(dtf, document = "topic_level_id", term = "lemma")
head(dtf)
## Create a document/term/matrix for building a topic model
dtm <- document_term_matrix(x = dtf)
## Remove words which do not occur that much
dtm_clean <- dtm_remove_lowfreq(dtm, minfreq = 5)
head(dtm_colsums(dtm_clean))
library(topicmodels)
m <- LDA(dtm_clean, k = 4, method = "Gibbs",
control = list(nstart = 5, burnin = 2000, best = TRUE, seed = 1:5))
scores <- predict(m, newdata = dtm, type = "topics",
labels = c("labela", "labelb", "labelc", "xyz"))
predict(m, type = "terms", min_posterior = 0.05, min_terms = 3)任务6.6 语篇特征分析
词汇丰富度
lexical.diversity <- textstat_lexdiv(dfm_detectives, measure = "all")
lexical.diversity.df = lexical.diversity%>%
as.data.frame()%>%
# mutate(id = 1:n())%>%
# filter(id >1 )%>%
select("document","TTR","C","R","K","D","Vm")%>%
gather("measures", "values", -c("document"))%>%
mutate(measures = as.factor(measures),
measures = fct_relevel(measures, "TTR","C","R","K","D","Vm"))
lexical.diversity.df
## 移动窗口词汇丰富度
lexical.mattr <- textstat_lexdiv(tokens(corps.detectives),
measure = "MATTR", MATTR_window = 500)
lexical.mattr文本可读性
readability <- textstat_readability(corps.detectives, measure = "all")
readability.df = readability %>%
select("document","ARI","Flesch","FOG",
"Coleman.Liau.short","Dale.Chall","Spache")%>%
gather("measures", "values", -c("document"))%>%
mutate(measures = as.factor(measures),
measures = fct_relevel(measures, "ARI","Flesch","FOG",
"Coleman.Liau.short","Dale.Chall","Spache"))
readability.df文本情感分析
library(dplyr)
library(stringr)
library(tidytext)
tidy_books <- detectives.raw %>%
unnest_sentences(sentence, text)%>%
group_by(doc_id) %>%
mutate(linenumber = row_number()) %>%
ungroup() %>%
unnest_tokens(word, sentence)
tidy.sent = tidy_books %>%
inner_join(get_sentiments("bing")) %>%
# 每八十行进行一次平均
count(doc_id, index = linenumber %/% 80, sentiment) %>%
pivot_wider(names_from = sentiment, values_from = n, values_fill = 0) %>%
mutate(sentiment = positive - negative)
library(ggplot2)
ggplot(tidy.sent , aes(index, sentiment, fill = doc_id)) +
geom_col(show.legend = FALSE) +
facet_wrap(~doc_id, ncol = 2, scales = "free_x")
# 进一步看看哪些积极或者消极的词
bing_word_counts <- tidy_books %>%
inner_join(get_sentiments("bing")) %>%
group_by(doc_id) %>%
count(word, sentiment, sort = TRUE) %>%
ungroup()
bing_word_counts %>%
group_by(doc_id, sentiment) %>%
slice_max(n, n = 10) %>%
ungroup() %>%
mutate(word = reorder(word, n))%>%
ggplot(aes(n, word, fill = sentiment)) +
geom_col(show.legend = FALSE) +
facet_wrap(sentiment ~ doc_id, scales = "free_y") +
labs(x = "Contribution to sentiment",
y = NULL)Schweinberger, Martin. 2025. Sentiment Analysis in R. Brisbane: The University of Queensland. url: https://ladal.edu.au/tutorials/sentiment/sentiment.html (Version 2025.04.02).
nrc <- readRDS("data/ch6/nrc.rda")
novels_anno <- tidy_books %>%
dplyr::group_by(doc_id) %>%
dplyr::mutate(words = n()) %>%
dplyr::left_join(nrc) %>%
dplyr::mutate(
novel = factor(doc_id),
sentiment = factor(sentiment)
)
novels <- novels_anno %>%
dplyr::group_by(novel) %>%
dplyr::group_by(novel, sentiment) %>%
dplyr::summarise(
sentiment = unique(sentiment),
sentiment_freq = n(),
words = unique(words)
) %>%
dplyr::filter(is.na(sentiment) == F) %>%
dplyr::mutate(percentage = round(sentiment_freq / words * 100, 1))
novels %>%
dplyr::filter(
sentiment != "positive",
sentiment != "negative"
) %>%
ggplot(aes(sentiment, percentage, fill = novel)) +
geom_bar(
stat = "identity",
position = position_dodge()
) +
scale_fill_manual(name = "", values = c("orange", "gray70", "red")) +
theme_bw() +
theme(legend.position = "top")
novels %>%
dplyr::filter(
sentiment != "positive",
sentiment != "negative"
) %>%
dplyr::mutate(sentiment = factor(sentiment,
levels = c(
"anger", "fear", "disgust", "sadness",
"surprise", "anticipation", "trust", "joy"
)
)) %>%
ggplot(aes(novel, percentage, fill = sentiment)) +
geom_bar(stat = "identity", position = position_dodge()) +
scale_fill_brewer(palette = "RdBu") +
theme_bw() +
theme(legend.position = "right") +
coord_flip()
# Identifying important emotives
novels_impw <- novels_anno %>%
dplyr::filter(
!is.na(sentiment),
sentiment != "anticipation",
sentiment != "surprise",
sentiment != "disgust",
sentiment != "negative",
sentiment != "sadness",
sentiment != "positive"
) %>%
dplyr::mutate(sentiment = factor(sentiment, levels = c("anger", "fear", "trust", "joy"))) %>%
dplyr::group_by(novel) %>%
dplyr::count(word, sentiment, sort = TRUE) %>%
dplyr::group_by(novel, sentiment) %>%
dplyr::top_n(3) %>%
dplyr::mutate(score = n / sum(n))
novels_impw %>%
dplyr::group_by(novel) %>%
slice_max(score, n = 20) %>%
dplyr::arrange(desc(score)) %>%
dplyr::ungroup() %>%
ggplot(aes(x = reorder(word, score), y = score, fill = word)) +
facet_wrap(novel ~ sentiment, ncol = 4, scales = "free_y") +
geom_col(show.legend = FALSE) +
coord_flip() +
labs(x = "Words")# Calculating and dispalying polarity
novels %>%
dplyr::filter(sentiment == "positive" | sentiment == "negative") %>%
dplyr::select(-percentage, -words) %>%
dplyr::mutate(
sentiment_sum = sum(sentiment_freq),
positive = sentiment_sum - sentiment_freq
) %>%
dplyr::filter(sentiment != "positive") %>%
dplyr::rename(negative = sentiment_freq) %>%
dplyr::select(novel, positive, negative) %>%
dplyr::group_by(novel) %>%
dplyr::summarise(polarity = positive / negative) %>%
ggplot(aes(reorder(novel, polarity, mean), polarity, fill = novel)) +
geom_bar(stat = "identity") +
geom_text(aes(y = polarity - 0.1, label = round(polarity, 2)),
color = "white", size = 4
) +
theme_bw() +
labs(
y = "Polarity\n(ration of positive to negative emitives)",
x = ""
) +
coord_cartesian(y = c(0, 2)) +
scale_y_continuous(
breaks = seq(0, 2, 1),
labels = c("more negative", "neutral", "more positive")
) +
theme(legend.position = "none")
# Calculating and dispalying changes in polarity
library(Hmisc)
novels_bin <- novels_anno %>%
dplyr::group_by(novel) %>%
dplyr::filter(is.na(sentiment) | sentiment == "negative" | sentiment == "positive") %>%
dplyr::mutate(
sentiment = as.character(sentiment),
sentiment = case_when(
is.na(sentiment) ~ "0",
TRUE ~ sentiment
),
sentiment = case_when(
sentiment == "0" ~ 0,
sentiment == "positive" ~ 1,
TRUE ~ -1
),
id = 1:n(),
index = as.numeric(cut2(id, m = 80))
) %>%
dplyr::group_by(novel, index) %>%
dplyr::summarize(
index = unique(index),
polarity = mean(sentiment)
)
ggplot(novels_bin, aes(index, polarity)) +
facet_wrap(vars(novel), scales = "free_x") +
geom_smooth(se = F, col = "black") +
theme_bw() +
labs(
y = "polarity ratio (mean by bin)",
x = "index (bin)"
)拓展阅读
Exploring the State of the Union Addresses: A Case Study with cleanNLP