Bigrams & word network

1. PREPARE

Continue with the cybersecurtiy professional development. We gathered project plans from 50 participants who completed this professional development. A notable aspect involves the actions that participants plan to take in the future to defend cyber attacks.

Bigarms and the biterm topic modelling (co-occurence of verbs and nouns) will help to explore the most frequent actions.

Research Questions

What are the actions that participants will likely to take to defend cyber attacks after taking this professional development?

1.1 Set Up

library(dplyr)
library(tidytext)
library(tidyverse)
library(tidyr)
library(ggplot2)
library(igraph)
library(ggraph)

1.2 Import Data

project_plan <- read_csv("data/project_plan.csv") %>% 
  mutate_if(is.character, utf8::utf8_encode)

## Rows: 151 Columns: 8
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (7): district, school, current_technology, security_measure, addition_co...
## dbl (1): id
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

2. WRANGLE

2.1 Bigram: Tokenizing & Removing stop words

pplan_action_bigrams <- project_plan %>%
  unnest_tokens(bigram, action, token = "ngrams", n = 2)

pplan_action_bigrams %>%
  count(bigram, sort = TRUE)

## # A tibble: 6,269 × 2
##    bigram         n
##    <chr>      <int>
##  1 n n2          51
##  2 n n3          34
##  3 in the        20
##  4 access to     18
##  5 the school    18
##  6 at the        15
##  7 to the        15
##  8 <NA>          15
##  9 of the        14
## 10 that is       14
## # ℹ 6,259 more rows

bigrams_separated <- pplan_action_bigrams %>%
  separate(bigram, c("word1", "word2"), sep = " ")

bigrams_filtered <- bigrams_separated %>%
  filter(!word1 %in% stop_words$word) %>%
  filter(!word2 %in% stop_words$word)

bigram_counts <- bigrams_filtered %>% 
  count(word1, word2, sort = TRUE)

bigram_counts

## # A tibble: 1,755 × 3
##    word1    word2              n
##    <chr>    <chr>          <int>
##  1 <NA>     <NA>              15
##  2 don      xd5t              10
##  3 factor   authentication     9
##  4 cyber    security           8
##  5 school   level              8
##  6 security measures           8
##  7 1        create             7
##  8 teach    students           7
##  9 action   steps              6
## 10 n3       require            5
## # ℹ 1,745 more rows

bigrams_united <- bigrams_filtered %>%
  unite(bigram, word1, word2, sep = " ")

bigrams_united

## # A tibble: 2,002 × 8
##       id district    school current_technology security_measure addition_concern
##    <dbl> <chr>       <chr>  <chr>              <chr>            <chr>           
##  1     1 St. Pauls … Publi… Vulnerabilities  … "Security measu… What is the cri…
##  2     1 St. Pauls … Publi… Vulnerabilities  … "Security measu… What is the cri…
##  3     1 St. Pauls … Publi… Vulnerabilities  … "Security measu… What is the cri…
##  4     1 St. Pauls … Publi… Vulnerabilities  … "Security measu… What is the cri…
##  5     1 St. Pauls … Publi… Vulnerabilities  … "Security measu… What is the cri…
##  6     1 St. Pauls … Publi… Vulnerabilities  … "Security measu… What is the cri…
##  7     1 St. Pauls … Publi… Vulnerabilities  … "Security measu… What is the cri…
##  8     1 St. Pauls … Publi… Vulnerabilities  … "Security measu… What is the cri…
##  9     1 St. Pauls … Publi… Vulnerabilities  … "Security measu… What is the cri…
## 10     2 Cabarrus C… Jay M… Educator version … "In general, th… <NA>            
## # ℹ 1,992 more rows
## # ℹ 2 more variables: ask <chr>, bigram <chr>

2.2 Biterm: Annotation (co-occurrences of verbs and nouns)

library(data.table)

## 
## Attaching package: 'data.table'

## The following objects are masked from 'package:lubridate':
## 
##     hour, isoweek, mday, minute, month, quarter, second, wday, week,
##     yday, year

## The following object is masked from 'package:purrr':
## 
##     transpose

## The following objects are masked from 'package:dplyr':
## 
##     between, first, last

library(udpipe)
## Annotate text with parts of speech tags
anno <- data.frame(doc_id = project_plan$id, text = project_plan$action,
                   stringsAsFactors = FALSE)
anno <- udpipe(anno, "dutch", trace = 10)

## 2024-03-24 22:47:32.795442 Annotating text fragment 1/151
## 2024-03-24 22:47:33.051897 Annotating text fragment 11/151
## 2024-03-24 22:47:33.362156 Annotating text fragment 21/151
## 2024-03-24 22:47:33.762433 Annotating text fragment 31/151
## 2024-03-24 22:47:33.961605 Annotating text fragment 41/151
## 2024-03-24 22:47:34.223303 Annotating text fragment 51/151
## 2024-03-24 22:47:34.447228 Annotating text fragment 61/151
## 2024-03-24 22:47:34.724189 Annotating text fragment 71/151
## 2024-03-24 22:47:34.960876 Annotating text fragment 81/151
## 2024-03-24 22:47:35.443707 Annotating text fragment 91/151
## 2024-03-24 22:47:35.678249 Annotating text fragment 101/151
## 2024-03-24 22:47:35.982535 Annotating text fragment 111/151
## 2024-03-24 22:47:36.114601 Annotating text fragment 121/151
## 2024-03-24 22:47:36.371706 Annotating text fragment 131/151
## 2024-03-24 22:47:36.52862 Annotating text fragment 141/151
## 2024-03-24 22:47:36.680197 Annotating text fragment 151/151

## Get cooccurrences of nouns / adjectives and proper nouns
biterms <- as.data.table(anno)
biterms <- biterms[, cooccurrence(x = lemma, 
                                  relevant = upos %in% c("VERB", "NOUN"),
                                  skipgram = 2), 
                   by = list(doc_id)]

3. MODEL

3.1 BTM

## Build the model
#install.packages("BTM")
library(BTM)

set.seed(123456)
x     <- subset(anno, upos %in% c("VERB", "PROPN", "NOUN"))
x     <- x[, c("doc_id", "lemma")]
model <- BTM(x, k = 7, beta = 0.01, iter = 2000, background = TRUE, 
             biterms = biterms, trace = 100)

## 2024-03-24 22:47:37 Start Gibbs sampling iteration 1/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 101/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 201/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 301/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 401/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 501/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 601/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 701/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 801/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 901/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 1001/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 1101/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 1201/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 1301/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 1401/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 1501/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 1601/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 1701/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 1801/2000
## 2024-03-24 22:47:38 Start Gibbs sampling iteration 1901/2000

topicterms <- terms(model, top_n = 5)

topicterms

## [[1]]
##     token probability
## 1 student  0.05160978
## 2  school  0.02581027
## 3       I  0.02366031
## 4 teacher  0.02043537
## 5       l  0.01828541
## 
## [[2]]
##              token probability
## 1          breache  0.09062147
## 2               my  0.09062147
## 3            avoid  0.06802260
## 4 have\\nsomething  0.06802260
## 5        keep\\nup  0.06802260
## 
## [[3]]
##    token probability
## 1 school  0.26266958
## 2  level  0.15763676
## 3 leader  0.10512035
## 4   eten  0.08761488
## 5  based  0.03509847
## 
## [[4]]
##     token probability
## 1      or  0.13719626
## 2      an  0.08735202
## 3 account  0.07489097
## 4 however  0.07489097
## 5  months  0.04996885
## 
## [[5]]
##    token probability
## 1      l  0.15523546
## 2 should  0.07767313
## 3  perso  0.05551247
## 4  place  0.05551247
## 5 \\nAsk  0.04443213
## 
## [[6]]
##                  token probability
## 1          are\\nbeing  0.13581921
## 2                teken  0.09062147
## 3               copier  0.06802260
## 4 enough\\nprecautions  0.06802260
## 5        team\\nasking  0.06802260
## 
## [[7]]
##      token probability
## 1       at  0.09062147
## 2     show  0.09062147
## 3     test  0.09062147
## 4 finished  0.06802260
## 5 incident  0.06802260

4. VISUALIZE WORD NETWORK

4.1 Bigram Visualization

bigram_graph <- bigram_counts %>%
  graph_from_data_frame()

## Warning in graph_from_data_frame(.): In `d' `NA' elements were replaced with
## string "NA"

bigram_graph

## IGRAPH b9094aa DN-- 1236 1755 -- 
## + attr: name (v/c), n (e/n)
## + edges from b9094aa (vertex names):
##  [1] NA        ->NA             don       ->xd5t          
##  [3] factor    ->authentication cyber     ->security      
##  [5] school    ->level          security  ->measures      
##  [7] 1         ->create         teach     ->students      
##  [9] action    ->steps          n3        ->require       
## [11] student   ->data           1         ->review        
## [13] action    ->step           digital   ->citizenship   
## [15] internet  ->safety         ma        ->gement        
## + ... omitted several edges

bigram_graph_filtered <- bigram_counts %>%
  filter(n > 7) %>%
  graph_from_data_frame()

## Warning in graph_from_data_frame(.): In `d' `NA' elements were replaced with
## string "NA"

bigram_graph_filtered

## IGRAPH fd076a6 DN-- 10 6 -- 
## + attr: name (v/c), n (e/n)
## + edges from fd076a6 (vertex names):
## [1] NA      ->NA             don     ->xd5t           factor  ->authentication
## [4] cyber   ->security       school  ->level          security->measures

set.seed(100)

a <- grid::arrow(type = "closed", length = unit(.2, "inches"))

ggraph(bigram_graph_filtered, layout = "fr") +
  geom_edge_link(aes(edge_alpha = n), show.legend = FALSE,
                 arrow = a, end_cap = circle(.07, 'inches')) +
  geom_node_point(color = "lightblue", size = 3) +
  geom_node_text(aes(label = name), vjust = 1, hjust = 1) +
  theme_void()

4.2 BTM Visualization

# install.packages("textplot")
# install.packages("concaveman")
library(textplot)
library(ggraph)
library(concaveman)
plot(model)

Conclusion

Both bigram visualization and biterm topic modelling highlight the “school level” actions. Other results seems hard to interpret. I am not sure if the data is not appropriate for bigrams/BTM or is not clean enough.