# load packages, data
# load Rdata
# load("C:/Users/newsomevw/OneDrive - National Institutes of Health/NHGRI-NHGRI SNMS (O365) - Caregiving - Lori/variables_model_draft_data.Rdata")
# or pickup
load("C:/Users/newsomevw/OneDrive - National Institutes of Health/NHGRI-NHGRI SNMS (O365) - Caregiving - Lori/stm_rd_data.Rdata")
model 1: token, names, term freq > 1, doc freq > 1
# Structural Topic Models- token
set.seed(20000)
processed <- convert(token_dfm, to = "stm")
processed <- prepDocuments(documents = processed$documents,
vocab = processed$vocab,
meta = processed$meta,
lower.thresh = 1)
## Removing 1078 of 7069 terms (1078 of 65285 tokens) due to frequency
## Your corpus now has 83 documents, 5991 terms and 64207 tokens.
docs <- processed$documents
vocab <- processed$vocab
meta <- processed$meta
# adjust to see thresholds affecting words removed.
plotRemoved(processed$documents, lower.thresh = seq(1, 100, by = 10))
## Initial Model
# create the processed object in the prior chunk
model <- stm(documents = processed$documents,
vocab = processed$vocab,
K = 7,
data = processed$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model, type = "summary", labeltype = "score")
plot(model, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(model, type = "perspectives", topics = c(1, 2))
topicCorr(model, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.0000000 -0.1854685 -0.1970298 -0.2136266 -0.1543761 -0.14596646
## [2,] -0.1854685 1.0000000 -0.2040545 -0.1580331 -0.1323805 -0.11066041
## [3,] -0.1970298 -0.2040545 1.0000000 -0.1682213 -0.1315957 -0.14762838
## [4,] -0.2136266 -0.1580331 -0.1682213 1.0000000 -0.1266858 -0.26229169
## [5,] -0.1543761 -0.1323805 -0.1315957 -0.1266858 1.0000000 -0.36307982
## [6,] -0.1459665 -0.1106604 -0.1476284 -0.2622917 -0.3630798 1.00000000
## [7,] -0.1574752 -0.1110856 -0.1510391 -0.1652236 -0.1075009 -0.06472106
## [,7]
## [1,] -0.15747524
## [2,] -0.11108560
## [3,] -0.15103907
## [4,] -0.16522355
## [5,] -0.10750095
## [6,] -0.06472106
## [7,] 1.00000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model, processed$documents)
## [1] -0.2922194 -0.1951115 -0.6414596 -0.3046403 -2.3484688 -1.1622788 -0.2922194
## [1] 8.054371 7.096897 7.436145 7.758859 7.658368 7.245996 7.561825
labelTopics(model)
## Topic 1 Top Words:
## Highest Prob: like, i, not, you, just, know, he
## FREX: like, pediatrician, super, appointment, preschool, walker, feel
## Lift: 6th, confusing, congenital, contractions, ct, drama, leukodystrophy
## Score: like, drama, _101301__care_recipient__, leukodystrophy, i, trach, contractions
## Topic 2 Top Words:
## Highest Prob: i, not, you, we, my, like, just
## FREX: aides, grief, church, died, lord, upon, christian
## Lift: 04, 07, banner, bridge, broadly, choked, cleveland
## Score: listing, i, jar, aides, his, encouragement, lord
## Topic 3 Top Words:
## Highest Prob: you, know, i, not, we, she, just
## FREX: trees, mother, ride, said, door, gm1, tree
## Lift: battens, bite, brown, ccs, closet, club, fat
## Score: you, know, measure, gm1, tree, trees, bicycle
## Topic 4 Top Words:
## Highest Prob: i, we, you, know, just, not, like
## FREX: _103901__care_recipient__, caregivers, trip, role, sadness, diagnosis, medicaid
## Lift: _103901__care_recipient__s, 250, advancing, bachelors, believers, burdensome, contribute
## Score: _103901__care_recipient__, tanzania, norway, climbing, batten, norwegian, skiing
## Topic 5 Top Words:
## Highest Prob: i, he, we, not, like, him, you
## FREX: _102301__care_recipient__, autism, son, him, mma, olaf, he
## Lift: hiding, hugs, _102301__care_recipient__, _102301__care_recipient__s, 16-year-old, 180, 800
## Score: _102301__care_recipient__, he, him, his, olaf, cochlear, deaf
## Topic 6 Top Words:
## Highest Prob: i, she, her, we, not, like, you
## FREX: her, she, volunteer, herself, condition, speech, iep
## Lift: cancelled, donate, eager, federation, homeschool, homocysteine, selected
## Score: her, she, braille, jokingly, doula, cblc, charity
## Topic 7 Top Words:
## Highest Prob: you, know, we, like, not, i, they
## FREX: 107301_care_recipient, 107321_ps_son_rs_brother, pa, docs, ramp, stuff, memorable
## Lift: 10-hour, 65, 90s, adequate, amputee, breath, classrooms
## Score: 107301_care_recipient, 107321_ps_son_rs_brother, downs, you, vegas, know, hometown
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage <- searchK(processed$documents, processed$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage)
plot_data <- storage$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic Model Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# heatmap
plot_theta <- melt(as.matrix(model$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 2: same but stem
# Structural Topic Models- stem
set.seed(20001)
processeds <- convert(stem_dfm, to = "stm")
processeds <- prepDocuments(documents = processeds$documents,
vocab = processeds$vocab,
meta = processeds$meta,
lower.thresh = 1)
## Removing 802 of 4948 terms (802 of 55283 tokens) due to frequency
## Your corpus now has 83 documents, 4146 terms and 54481 tokens.
docs <- processeds$documents
vocab <- processeds$vocab
meta <- processeds$meta
plotRemoved(processeds$documents, lower.thresh = seq(1, 100, by = 10))
## Initial Model
# create the processeds object in the prior chunk
models <- stm(documents = processeds$documents,
vocab = processeds$vocab,
K = 7,
data = processeds$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(models, type = "summary", labeltype = "score")
plot(models, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(models, type = "perspectives", topics = c(1, 2))
topicCorr(models, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.0000000 -0.14852424 -0.22452623 -0.2078849 -0.12768879 -0.12433965
## [2,] -0.1485242 1.00000000 -0.18016971 -0.1780077 -0.13846546 -0.08433099
## [3,] -0.2245262 -0.18016971 1.00000000 -0.1663361 -0.09657363 -0.16806759
## [4,] -0.2078849 -0.17800774 -0.16633607 1.0000000 -0.13924090 -0.21427549
## [5,] -0.1276888 -0.13846546 -0.09657363 -0.1392409 1.00000000 -0.29748987
## [6,] -0.1243397 -0.08433099 -0.16806759 -0.2142755 -0.29748987 1.00000000
## [7,] -0.1519599 -0.17287510 -0.06805635 -0.1709640 -0.20673939 -0.21668392
## [,7]
## [1,] -0.15195993
## [2,] -0.17287510
## [3,] -0.06805635
## [4,] -0.17096402
## [5,] -0.20673939
## [6,] -0.21668392
## [7,] 1.00000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(models, processeds$documents)
## [1] -0.2922194 -1.0513100 -0.1951115 -0.1334675 -2.3119604 -1.0513100 -0.1951115
## [1] 8.140827 7.662427 7.625102 7.828905 7.721237 6.935284 7.343670
labelTopics(models)
## Topic 1 Top Words:
## Highest Prob: like, i, not, you, just, know, he
## FREX: like, pediatrician, condit, super, appoint, preschool, neurologist
## Lift: aac, assert, outrag, harmless, twilight, suburban, talker
## Score: like, aac, i, walker, leukodystrophi, trach, _101301__care_recipient__
## Topic 2 Top Words:
## Highest Prob: i, you, not, she, know, just, her
## FREX: tree, music, sing, aid, fever, mother, car
## Lift: clingi, wire, 04, 07, bridg, coat, cush
## Score: she, her, remarri, i, tree, sin, transplant
## Topic 3 Top Words:
## Highest Prob: you, know, we, like, i, not, he
## FREX: 107301_care_recipi, 107321_ps_son_rs_broth, 104201_care_recipi, stuff, doc, drink, know
## Lift: 104201_care_recipi, examin, hygien, violent, 10-hour, 90s, gbmc
## Score: 107301_care_recipi, 107321_ps_son_rs_broth, you, know, 104201_care_recipi, soup, he
## Topic 4 Top Words:
## Highest Prob: i, we, you, just, not, know, yeah
## FREX: diagnosi, yeah, communiti, caregiv, kind, _103901__care_recipient__, stress
## Lift: _103901__care_recipient__, 250, burdensom, indoor, instal, norwegian, obtain
## Score: tanzania, _103901__care_recipient__, norway, yeah, kind, ski, think
## Topic 5 Top Words:
## Highest Prob: he, i, we, not, him, his, go
## FREX: _102301__care_recipient__, son, his, mma, wife, him, olaf
## Lift: 16-year-old, firstborn, hematologist, hummus, indirect, jargon, mexican
## Score: _102301__care_recipient__, he, olaf, his, him, unpredict, pakistani
## Topic 6 Top Words:
## Highest Prob: she, i, we, her, not, you, they
## FREX: her, she, volunt, adopt, pa, speech, outcom
## Lift: defici, mal, paycheck, three-person, tuition, 2000s, absurd
## Score: she, her, paycheck, adopt, doula, braill, gm1
## Topic 7 Top Words:
## Highest Prob: i, you, not, he, like, know, we
## FREX: dad, toy, autism, mom, messag, behavior, bike
## Lift: cream, dentist, fri, lawn, self-car, aquarium, buri
## Score: cream, he, i, him, his, hurrican, 106801_care_recipi
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storages <- searchK(processeds$documents, processeds$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storages)
# append with s for different var name, will get large later on
plot_data <- storages$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic models Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# heatmap
plot_theta <- melt(as.matrix(models$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 3: same but lemma
# Structural Topic Models- lemma
set.seed(20002)
processedl <- convert(lemma_dfm, to = "stm")
processedl <- prepDocuments(documents = processedl$documents,
vocab = processedl$vocab,
meta = processedl$meta,
lower.thresh = 1)
## Removing 903 of 5342 terms (903 of 54247 tokens) due to frequency
## Your corpus now has 83 documents, 4439 terms and 53344 tokens.
docs <- processedl$documents
vocab <- processedl$vocab
meta <- processedl$meta
plotRemoved(processedl$documents, lower.thresh = seq(1, 100, by = 10))
## Initial Model
# create the processedl object in the prior chunk
modell <- stm(documents = processedl$documents,
vocab = processedl$vocab,
K = 5,
data = processedl$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(modell, type = "summary", labeltype = "score")
plot(modell, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(modell, type = "perspectives", topics = c(1, 2))
topicCorr(modell, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 0 0 0 0
## [2,] 0 1 0 0 0
## [3,] 0 0 1 0 0
## [4,] 0 0 0 1 0
## [5,] 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 0 0 0 0
## [2,] 0 1 0 0 0
## [3,] 0 0 1 0 0
## [4,] 0 0 0 1 0
## [5,] 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1.0000000 -0.2498213 -0.2874200 -0.2464402 -0.2712175
## [2,] -0.2498213 1.0000000 -0.1205902 -0.1736422 -0.2224177
## [3,] -0.2874200 -0.1205902 1.0000000 -0.2076219 -0.2554740
## [4,] -0.2464402 -0.1736422 -0.2076219 1.0000000 -0.4221318
## [5,] -0.2712175 -0.2224177 -0.2554740 -0.4221318 1.0000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(modell, processedl$documents)
## [1] -0.13406598 -0.13406598 -0.07316544 -0.18254554 -1.13857214
## [1] 7.806221 6.908791 7.529484 7.124991 6.754310
labelTopics(modell)
## Topic 1 Top Words:
## Highest Prob: like, i, not, he, you, just, we
## FREX: like, pediatrician, _102301__care_recipient__, toy, birthday, fine, olaf
## Lift: 16th, 6th, borderline, chattanooga, contraction, reimbursement, steroid
## Score: like, _102301__care_recipient__, he, olaf, i, aac, him
## Topic 2 Top Words:
## Highest Prob: i, not, you, know, we, just, my
## FREX: grief, grieve, church, divorce, important, autism, myself
## Lift: 04, banner, beep, behalf, broadly, darkness, drill
## Score: i, remarry, his, my, grief, sin, him
## Topic 3 Top Words:
## Highest Prob: you, know, i, we, like, not, he
## FREX: 107301_care_recipient, 107321_ps_son_rs_brother, drink, maryland, doc, know, stuff
## Lift: 2010, celebrity, hydrate, hygiene, oaa, whiteboard, 10-hour
## Score: 107301_care_recipient, 107321_ps_son_rs_brother, you, know, he, soup, his
## Topic 4 Top Words:
## Highest Prob: i, we, he, not, just, yes, you
## FREX: _103901__care_recipient__, vision, trip, mma, affirmative, wife, climb
## Lift: acronym, alexa, believer, competition, dysfunction, frontline, newspaper
## Score: tanzania, _103901__care_recipient__, he, his, him, norway, ski
## Topic 5 Top Words:
## Highest Prob: i, she, we, not, her, you, know
## FREX: her, she, volunteer, pa, tree, herself, transplant
## Lift: 2000s, announce, brick, chatter, deficiency, dfw, discriminate
## Score: she, her, jokingly, adopt, transplant, gm1, doula
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storagel <- searchK(processedl$documents, processedl$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storagel)
plot_data <- storagel$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic modell Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# heatmap
plot_theta <- melt(as.matrix(modell$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 4: token, no names, removed more fill words, term freq > 1,
doc freq > 1
I, you, he, she, they, we, not, know, like, just, go, going, ok,
yeah, really
# Structural Topic Models- token, no fill
set.seed(20003)
processed_tnf <- convert(token_nf_dfm, to = "stm")
processed_tnf <- prepDocuments(documents = processed_tnf$documents,
vocab = processed_tnf$vocab,
meta = processed_tnf$meta,
lower.thresh = 1)
## Removing 800 of 6611 terms (800 of 62575 tokens) due to frequency
## Your corpus now has 83 documents, 5811 terms and 61775 tokens.
docs <- processed_tnf$documents
vocab <- processed_tnf$vocab
meta <- processed_tnf$meta
# adjust to see thresholds affecting words removed.
plotRemoved(processed_tnf$documents, lower.thresh = seq(1, 100, by = 10))
## Initial Model
# create the processed object in the prior chunk
model_tnf <- stm(documents = processed_tnf$documents,
vocab = processed_tnf$vocab,
K = 8,
data = processed_tnf$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_tnf, type = "summary", labeltype = "score")
plot(model_tnf, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(model_tnf, type = "perspectives", topics = c(1, 2))
topicCorr(model_tnf, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,] 1 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0
## [6,] 0 0 0 0 0 1 0 0
## [7,] 0 0 0 0 0 0 1 0
## [8,] 0 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,] 1 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0
## [6,] 0 0 0 0 0 1 0 0
## [7,] 0 0 0 0 0 0 1 0
## [8,] 0 0 0 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.0000000 -0.12229534 -0.1682715 -0.10479856 -0.10905299 -0.11573749
## [2,] -0.1222953 1.00000000 -0.1740352 -0.16519027 -0.05152583 -0.13726451
## [3,] -0.1682715 -0.17403519 1.0000000 -0.17137949 -0.15802802 -0.13658119
## [4,] -0.1047986 -0.16519027 -0.1713795 1.00000000 -0.11127859 -0.11456837
## [5,] -0.1090530 -0.05152583 -0.1580280 -0.11127859 1.00000000 -0.08052802
## [6,] -0.1157375 -0.13726451 -0.1365812 -0.11456837 -0.08052802 1.00000000
## [7,] -0.1812228 -0.23163662 -0.2224492 -0.09682652 -0.18525736 -0.12560506
## [8,] -0.1173357 -0.12293009 -0.1413487 -0.15199851 -0.08865703 -0.12465526
## [,7] [,8]
## [1,] -0.18122283 -0.11733575
## [2,] -0.23163662 -0.12293009
## [3,] -0.22244923 -0.14134865
## [4,] -0.09682652 -0.15199851
## [5,] -0.18525736 -0.08865703
## [6,] -0.12560506 -0.12465526
## [7,] 1.00000000 -0.21103400
## [8,] -0.21103400 1.00000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_tnf, processed_tnf$documents)
## [1] -0.7776383 -1.8886904 -1.9448774 -0.7092417 -2.3461325 -1.4341563 -0.3360967
## [8] -2.0864115
## [1] 8.404252 7.977385 8.111738 8.041612 7.614843 7.624898 7.344701 6.599440
labelTopics(model_tnf)
## Topic 1 Top Words:
## Highest Prob: her, my, think, no, laughs, can, us
## FREX: aides, nurses, nurse, plane, nursing, trach, everyone
## Lift: katie, listing, postictal, trach, beckett, careers, vents
## Score: listing, trach, aides, katie, beckett, tennessee, nashville
## Topic 2 Top Words:
## Highest Prob: kind, think, my, can, him, his, one
## FREX: kind, norway, wife, feelings, role, course, sad
## Lift: competing, indoor, norwegian, bachelors, contribution, formulated, internship
## Score: competing, tanzania, norway, antonio, spanish, norwegian, climbing
## Topic 3 Top Words:
## Highest Prob: him, his, my, me, can, think, time
## FREX: crying, affirmative, olaf, him, blind, his, angry
## Lift: bleed, branch, copying, cream, decorations, elder, forbid
## Score: cream, olaf, toy, vision, cochlear, blind, pakistani
## Topic 4 Top Words:
## Highest Prob: her, my, said, me, can, one, get
## FREX: trees, said, transplant, mother, s, her, behavior
## Lift: adventures, bears, bow, brand-new, bucket, dire, dollar
## Score: gaze, trees, motorcycle, bicycle, song, her, sits
## Topic 5 Top Words:
## Highest Prob: my, him, me, his, things, think, can
## FREX: grief, autism, son, extreme, died, lord, line
## Lift: anonymous, audio, banner, broadly, categorize, embrace, evidence
## Score: jarring, grieve, grief, jar, antibiotics, lord, autism
## Topic 6 Top Words:
## Highest Prob: kind, get, can, mean, stuff, got, think
## FREX: stuff, s, docs, memorable, level, houston, lots
## Lift: adequate, allotted, amputee, bethesda, cardio, chemistry, contagious
## Score: delegate, docs, vegas, s, flipping, memorable, las
## Topic 7 Top Words:
## Highest Prob: her, think, my, kind, me, time, no
## FREX: condition, pa, speech, newborn, her, it’s, therapy
## Lift: analyze, approvals, arrived, awkward, bits, consent, continuous
## Score: pitch, it’s, pa, cblc, her, epilepsy, jewish
## Topic 8 Top Words:
## Highest Prob: think, our, him, my, her, can, us
## FREX: volunteer, sort, disney, rehab, program, braille, walker
## Lift: assignment, audiology, barrier, certified, congenital, convenient, cracks
## Score: doula, placement, uniquely, rehab, braille, leukodystrophy, injury
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage_tnf <- searchK(processed_tnf$documents, processed_tnf$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage_tnf)
plot_data <- storage_tnf$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic Model Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# heatmap
plot_theta <- melt(as.matrix(model_tnf$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 5: same but stem
# Structural Topic Models- stem, no fill
set.seed(20004)
processed_snf <- convert(stem_nf_dfm, to = "stm")
processed_snf <- prepDocuments(documents = processed_snf$documents,
vocab = processed_snf$vocab,
meta = processed_snf$meta,
lower.thresh = 1)
## Removing 583 of 3511 terms (583 of 49676 tokens) due to frequency
## Your corpus now has 83 documents, 2928 terms and 49093 tokens.
docs <- processed_snf$documents
vocab <- processed_snf$vocab
meta <- processed_snf$meta
plotRemoved(processed_snf$documents, lower.thresh = seq(1, 100, by = 10))
## Initial Model
# create the processeds object in the prior chunk
model_snf <- stm(documents = processed_snf$documents,
vocab = processed_snf$vocab,
K = 7,
data = processed_snf$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_snf, type = "summary", labeltype = "score")
plot(model_snf, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(model_snf, type = "perspectives", topics = c(1, 2))
topicCorr(model_snf, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.00000000 -0.35695022 -0.2064909 -0.08557761 -0.20755020 -0.16931384
## [2,] -0.35695022 1.00000000 -0.2625338 -0.23926879 -0.07595629 -0.07912585
## [3,] -0.20649094 -0.26253383 1.0000000 -0.13722711 -0.17237649 -0.09467920
## [4,] -0.08557761 -0.23926879 -0.1372271 1.00000000 -0.14616044 -0.14740059
## [5,] -0.20755020 -0.07595629 -0.1723765 -0.14616044 1.00000000 -0.11363207
## [6,] -0.16931384 -0.07912585 -0.0946792 -0.14740059 -0.11363207 1.00000000
## [7,] -0.10351723 -0.12647566 -0.2871831 -0.03353990 -0.21643781 -0.15335233
## [,7]
## [1,] -0.1035172
## [2,] -0.1264757
## [3,] -0.2871831
## [4,] -0.0335399
## [5,] -0.2164378
## [6,] -0.1533523
## [7,] 1.0000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_snf, processed_snf$documents)
## [1] -0.1854665 -1.2134191 -1.9082166 -0.6585537 -2.0147370 -1.3221217 -1.1002295
## [1] 7.971362 7.953286 8.325615 8.177371 7.161261 7.819784 7.422996
labelTopics(model_snf)
## Topic 1 Top Words:
## Highest Prob: her, my, think, realli, time, one, get
## FREX: nurs, seizur, everyon, trip, aid, pretti, wish
## Lift: administ, jinx, stubborn, beckett, kati, trach, tennesse
## Score: administ, trach, her, it’, beckett, kati, smoke
## Topic 2 Top Words:
## Highest Prob: think, kind, realli, thing, my, lot, can
## FREX: kind, diagnosi, sad, role, futur, realiz, dynam
## Lift: hematologist, inund, newspap, norwegian, re-evalu, sank, spanish
## Score: norway, sank, tanzania, kind, grief, norwegian, ski
## Topic 3 Top Words:
## Highest Prob: him, his, my, me, can, thing, time
## FREX: him, his, wife, happi, mma, cri, toy
## Lift: cream, limp, mash, olaf, pakistan, pakistani, portion
## Score: cream, olaf, blind, cochlear, pakistani, pakistan, hurrican
## Topic 4 Top Words:
## Highest Prob: her, my, said, get, can, one, me
## FREX: tree, said, swing, motorcycl, transplant, mother, sing
## Lift: brand-new, pier, pink, pit, preacher, re, retard
## Score: gaze, motorcycl, tree, bucket, bicycl, preacher, song
## Topic 5 Top Words:
## Highest Prob: my, him, his, thing, me, our, can
## FREX: grief, autism, son, accept, line, die, rehab
## Lift: anonym, audio, banner, capitol, curv, endeavor, flood
## Score: grief, funer, lord, humbl, sin, injuri, jar
## Topic 6 Top Words:
## Highest Prob: get, kind, think, thing, stuff, got, mean
## FREX: sort, doc, stuff, walker, transfer, ramp, pediatr
## Lift: adequ, allot, bilater, compens, congenit, encephalopathi, fda
## Score: oaa, leukodystrophi, walker, vega, hydrat, violent, las
## Topic 7 Top Words:
## Highest Prob: her, kid, time, my, me, get, famili
## FREX: volunt, speech, iep, condit, pa, adopt, braill
## Lift: eager, instructor, jersey, jewish, tee, three-person, zombi
## Score: adopt, tee, braill, doula, blind, her, pa
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage_snf <- searchK(processed_snf$documents, processed_snf$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage_snf)
# append with s for different var name, will get large later on
plot_data <- storage_snf$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic models Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# heatmap
plot_theta <- melt(as.matrix(model_snf$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 6: same but lemma
# Structural Topic Models- lemma, no fill
set.seed(20005)
processed_lnf <- convert(lemma_nf_dfm, to = "stm")
processed_lnf <- prepDocuments(documents = processed_lnf$documents,
vocab = processed_lnf$vocab,
meta = processed_lnf$meta,
lower.thresh = 1)
## Removing 625 of 3681 terms (625 of 48054 tokens) due to frequency
## Your corpus now has 83 documents, 3056 terms and 47429 tokens.
docs <- processed_lnf$documents
vocab <- processed_lnf$vocab
meta <- processed_lnf$meta
plotRemoved(processed_lnf$documents, lower.thresh = seq(1, 100, by = 10))
## Initial Model
# create the processed_lnf object in the prior chunk
model_lnf <- stm(documents = processed_lnf$documents,
vocab = processed_lnf$vocab,
K = 7,
data = processed_lnf$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_lnf, type = "summary", labeltype = "score")
plot(model_lnf, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(model_lnf, type = "perspectives", topics = c(1, 2))
topicCorr(model_lnf, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.00000000 -0.34604728 -0.2506603 -0.21768484 -0.11604622 -0.09136982
## [2,] -0.34604728 1.00000000 -0.2632928 -0.07109133 -0.25028526 -0.06249321
## [3,] -0.25066029 -0.26329282 1.0000000 -0.14110782 -0.11764368 -0.19267206
## [4,] -0.21768484 -0.07109133 -0.1411078 1.00000000 -0.13724675 -0.05381590
## [5,] -0.11604622 -0.25028526 -0.1176437 -0.13724675 1.00000000 -0.11232366
## [6,] -0.09136982 -0.06249321 -0.1926721 -0.05381590 -0.11232366 1.00000000
## [7,] -0.08499841 -0.25293451 -0.2002212 -0.18593403 -0.03041844 -0.18786033
## [,7]
## [1,] -0.08499841
## [2,] -0.25293451
## [3,] -0.20022117
## [4,] -0.18593403
## [5,] -0.03041844
## [6,] -0.18786033
## [7,] 1.00000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_lnf, processed_lnf$documents)
## [1] -0.1336162 -0.5398358 -2.2129189 -0.5297006 -1.9048794 -1.2127142 -1.7438358
## [1] 8.071993 8.026245 8.131083 7.928378 7.585583 7.427470 7.263141
labelTopics(model_lnf)
## Topic 1 Top Words:
## Highest Prob: think, yes, kind, thing, my, feel, get
## FREX: diagnosis, guess, kind, disease, community, yes, definitely
## Lift: norwegian, norway, airway, competition, da, obtain, tanzania
## Score: tanzania, norway, batten, yes, kind, ski, vision
## Topic 2 Top Words:
## Highest Prob: her, my, yes, think, get, good, me
## FREX: condition, nurse, her, seizure, aide, birthday, frustrate
## Lift: administer, default, epilepsy, cblc, trach, stewardess, ranch
## Score: administer, her, trach, cblc, herself, epilepsy, behavior
## Topic 3 Top Words:
## Highest Prob: him, his, my, get, me, thing, can
## FREX: him, his, mma, wife, cry, affirmative, toy
## Lift: cream, limp, mash, pakistan, pakistani, portion, psych
## Score: cream, olaf, him, pakistani, blind, his, cochlear
## Topic 4 Top Words:
## Highest Prob: her, say, get, my, can, one, me
## FREX: tree, swing, sing, buy, motorcycle, s, ride
## Lift: brand-new, pier, pink, pit, plastic, speaker, florida
## Score: gaze, tree, motorcycle, bucket, bicycle, her, song
## Topic 5 Top Words:
## Highest Prob: get, kind, thing, think, mean, good, one
## FREX: doc, pediatric, level, stuff, walker, ramp, houston
## Lift: anomaly, aspirin, bilateral, encephalopathy, generate, george, gillette
## Score: oaa, concert, doc, tpn, leukodystrophy, vega, las
## Topic 6 Top Words:
## Highest Prob: her, get, say, kid, time, us, think
## FREX: volunteer, pa, iep, braille, worker, college, doula
## Lift: federation, instructor, pku, tee, three-person, zombie, doorbell
## Score: tee, braille, adopt, her, pa, doula, blind
## Topic 7 Top Words:
## Highest Prob: my, him, his, get, thing, say, think
## FREX: son, autism, grief, die, line, brain, joy
## Lift: affection, anonymous, audio, convenient, curve, encouragement, evidence
## Score: funeral, grief, injury, metabolics, lord, humble, absolute
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage_lnf <- searchK(processed_lnf$documents, processed_lnf$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage_lnf)
plot_data <- storage_lnf$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic model_lnf Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# heatmap
plot_theta <- melt(as.matrix(model_lnf$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 7: lemma, no names, no prons, removed more words, word freq
any, doc freq any
“not”, “like”, “just”, “go”, “ok”, “okay”, “yeah”, “really”, “no”,
“yes”, “get”, “laugh”, “think”, “mean”, “know”, “kind”
# Structural Topic Models- lemma, no pron, min 1 doc
set.seed(20006)
processed_lnp <- convert(lemma_np_dfm, to = "stm")
processed_lnp <- prepDocuments(documents = processed_lnp$documents,
vocab = processed_lnp$vocab,
meta = processed_lnp$meta,
lower.thresh = 0)
docs <- processed_lnp$documents
vocab <- processed_lnp$vocab
meta <- processed_lnp$meta
plotRemoved(processed_lnp$documents, lower.thresh = seq(1, 20, by = 2))
## Initial Model
# create the processed_lnp object in the prior chunk
model_lnp <- stm(documents = processed_lnp$documents,
vocab = processed_lnp$vocab,
K = 7,
data = processed_lnp$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_lnp, type = "summary", labeltype = "score")
plot(model_lnp, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(model_lnp, type = "perspectives", topics = c(1, 2))
topicCorr(model_lnp, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.0000000 -0.1826388 -0.2249467 -0.12260802 -0.1944868 -0.16205465
## [2,] -0.1826388 1.0000000 -0.2587129 -0.06840460 -0.2670593 -0.18147484
## [3,] -0.2249467 -0.2587129 1.0000000 -0.13236671 -0.2454572 -0.16020120
## [4,] -0.1226080 -0.0684046 -0.1323667 1.00000000 -0.1312391 -0.09873811
## [5,] -0.1944868 -0.2670593 -0.2454572 -0.13123912 1.0000000 -0.17259258
## [6,] -0.1620547 -0.1814748 -0.1602012 -0.09873811 -0.1725926 1.00000000
## [7,] -0.1339255 -0.1382725 -0.1708394 -0.09966352 -0.1513365 -0.08282112
## [,7]
## [1,] -0.13392545
## [2,] -0.13827249
## [3,] -0.17083937
## [4,] -0.09966352
## [5,] -0.15133650
## [6,] -0.08282112
## [7,] 1.00000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_lnp, processed_lnp$documents)
## [1] -0.6080874 -0.1460372 -0.2545177 -1.0486106 -0.5011161 -1.2026535 -1.4169179
## [1] 8.017869 7.883026 7.538678 7.806906 7.468080 7.942775 7.060894
labelTopics(model_lnp)
## Topic 1 Top Words:
## Highest Prob: good, can, mean, time, laugh, say, one
## FREX: toy, nurse, protein, everyone, dad, formula, medicine
## Lift: anoint, bipap, carpool, cord, ham, psychology, puerto
## Score: puerto, rico, remarry, cruise, mare, shrimp, horseback
## Topic 2 Top Words:
## Highest Prob: time, good, say, one, thing, okay, can
## FREX: transplant, it’s, super, italy, condition, wife, nih
## Lift: activate, activation, apraxia, aps, ashamed, asia, ass
## Score: cream, it’s, usher, italy, i’m, we’re, trach
## Topic 3 Top Words:
## Highest Prob: kind, thing, good, can, say, time, one
## FREX: pa, kind, metabolic, course, climb, norway, yoga
## Lift: amicus, antifreeze, athlete, competition, founder, getaway, hlh
## Score: norway, yoga, kilometer, tanzania, galactosemia, arc, reinforce
## Topic 4 Top Words:
## Highest Prob: stuff, kind, one, thing, can, good, time
## FREX: s, stuff, walker, doc, t, ramp, sort
## Lift: adequate, affair, benign, bilateral, captain, encephalopathy, fals
## Score: norovirus, radiator, soda, opener, leukodystrophy, doc, walker
## Topic 5 Top Words:
## Highest Prob: feel, thing, good, time, can, lot, say
## FREX: grief, covid, autism, behavior, grieve, disability, therapy
## Lift: agendum, akron, algorithm, anticipatory, asthma, ataxia, basin
## Score: grief, dysautonomia, bereavement, shriver, philadelphia, grieve, placement
## Topic 6 Top Words:
## Highest Prob: thing, can, good, one, mean, say, kind
## FREX: olaf, son, party, nicu, memory, chief, port
## Lift: aunty, waterpark, glennon, accumulation, all-girls, anti, catheter
## Score: olaf, dialogue, delegate, tpn, intentional, aunty, waterpark
## Topic 7 Top Words:
## Highest Prob: say, can, thing, good, time, one, kid
## FREX: tree, volunteer, adoption, swing, heres, braille, doula
## Lift: adoption, aha, ail, aloud, americas, andersen, announcement
## Score: adoption, pony, karaoke, motorcycle, doula, tree, dune
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage_lnp <- searchK(processed_lnp$documents, processed_lnp$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage_lnp)
plot_data <- storage_lnp$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic model_lnp Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# ran with low threshold 4 to promote more overlap
# heatmap
plot_theta <- melt(as.matrix(model_lnp$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 8: lemma, same but min term freq 2
# Structural Topic Models- lemma, no pron, min term freq 2
set.seed(20007)
processed_lnp2 <- convert(lemma_np2_dfm, to = "stm")
processed_lnp2 <- prepDocuments(documents = processed_lnp2$documents,
vocab = processed_lnp2$vocab,
meta = processed_lnp2$meta,
lower.thresh = 1)
## Removing 237 of 3786 terms (237 of 48185 tokens) due to frequency
## Your corpus now has 83 documents, 3549 terms and 47948 tokens.
docs <- processed_lnp2$documents
vocab <- processed_lnp2$vocab
meta <- processed_lnp2$meta
plotRemoved(processed_lnp2$documents, lower.thresh = seq(1, 20, by = 2))
## Initial Model
# create the processed_lnp2 object in the prior chunk
model_lnp2 <- stm(documents = processed_lnp2$documents,
vocab = processed_lnp2$vocab,
K = 7,
data = processed_lnp2$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_lnp2, type = "summary", labeltype = "score")
plot(model_lnp2, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(model_lnp2, type = "perspectives", topics = c(2, 6))
topicCorr(model_lnp2, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,] 1 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0
## [4,] 0 0 0 1 0 0 0
## [5,] 0 0 0 0 1 0 0
## [6,] 0 0 0 0 0 1 0
## [7,] 0 0 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.0000000 -0.2122914 -0.21891775 -0.16433702 -0.27270388 -0.1744827
## [2,] -0.2122914 1.0000000 -0.24171154 -0.13186177 -0.24604358 -0.1247582
## [3,] -0.2189178 -0.2417115 1.00000000 -0.06386706 -0.21813147 -0.1037340
## [4,] -0.1643370 -0.1318618 -0.06386706 1.00000000 -0.08851981 -0.1129635
## [5,] -0.2727039 -0.2460436 -0.21813147 -0.08851981 1.00000000 -0.1029128
## [6,] -0.1744827 -0.1247582 -0.10373397 -0.11296350 -0.10291280 1.0000000
## [7,] -0.1760855 -0.2265404 -0.13379614 -0.10247200 -0.12366051 -0.1414866
## [,7]
## [1,] -0.1760855
## [2,] -0.2265404
## [3,] -0.1337961
## [4,] -0.1024720
## [5,] -0.1236605
## [6,] -0.1414866
## [7,] 1.0000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_lnp2, processed_lnp2$documents)
## [1] -0.2669350 -0.2913235 -1.1154434 -1.1196937 -1.0358930 -1.0234903 -1.0650939
## [1] 7.371847 7.955854 7.292455 7.630310 7.264653 7.376305 7.033115
summary(model_lnp2)
## A topic model with 7 topics, 83 documents and a 3549 word dictionary.
## Topic 1 Top Words:
## Highest Prob: good, time, thing, can, one, day, lot
## FREX: trip, disney, nurse, everyone, aide, fear, covid
## Lift: appeal, bipap, fda, frontline, hh, hopeless, mature
## Score: trach, mature, beckett, fusion, cruise, cobalamin, katie
## Topic 2 Top Words:
## Highest Prob: time, can, thing, one, good, say, now
## FREX: wife, behavior, affirmative, toy, thank, vision, happy
## Lift: branch, cream, gradually, haven’t, jinx, mash, norwegian
## Score: cream, it’s, norway, tanzania, hurricane, transplant, portion
## Topic 3 Top Words:
## Highest Prob: thing, feel, can, time, say, one, good
## FREX: grief, olaf, community, trial, grieve, network, joy
## Lift: acknowledgement, bankrupt, four-year, inundate, oaa, ad, confusion
## Score: olaf, oaa, tpn, intentional, four-year, ad, federal
## Topic 4 Top Words:
## Highest Prob: stuff, thing, one, can, good, time, say
## FREX: doc, stuff, s, ramp, walker, folk, mitochondrial
## Lift: adequate, bilateral, critically, encephalopathy, generate, hall, hydrate
## Score: gaze, walker, concert, charity, leukodystrophy, doc, self-sufficient
## Topic 5 Top Words:
## Highest Prob: good, feel, kid, thing, say, time, one
## FREX: condition, speech, newborn, geneticist, obviously, pediatrician, pa
## Lift: arrangement, bloodwork, cardinal, cerebral, console, copay, deficit
## Score: epilepsy, condition, cblc, bunny, jewish, chop, pa
## Topic 6 Top Words:
## Highest Prob: say, can, good, thing, one, kid, time
## FREX: tree, volunteer, bike, braille, minnesota, swing, ride
## Lift: cpr, dj, extensive, former, glare, gown, minivan
## Score: adopt, tree, doula, motorcycle, glare, braille, bucket
## Topic 7 Top Words:
## Highest Prob: thing, say, good, can, time, need, one
## FREX: son, autism, extreme, stroke, antibiotic, line, lord
## Lift: anonymous, audio, deplete, distraction, drill, entail, entitle
## Score: funeral, spanish, metabolics, antonio, lord, humble, antibiotic
labelTopics(model_lnp2)
## Topic 1 Top Words:
## Highest Prob: good, time, thing, can, one, day, lot
## FREX: trip, disney, nurse, everyone, aide, fear, covid
## Lift: appeal, bipap, fda, frontline, hh, hopeless, mature
## Score: trach, mature, beckett, fusion, cruise, cobalamin, katie
## Topic 2 Top Words:
## Highest Prob: time, can, thing, one, good, say, now
## FREX: wife, behavior, affirmative, toy, thank, vision, happy
## Lift: branch, cream, gradually, haven’t, jinx, mash, norwegian
## Score: cream, it’s, norway, tanzania, hurricane, transplant, portion
## Topic 3 Top Words:
## Highest Prob: thing, feel, can, time, say, one, good
## FREX: grief, olaf, community, trial, grieve, network, joy
## Lift: acknowledgement, bankrupt, four-year, inundate, oaa, ad, confusion
## Score: olaf, oaa, tpn, intentional, four-year, ad, federal
## Topic 4 Top Words:
## Highest Prob: stuff, thing, one, can, good, time, say
## FREX: doc, stuff, s, ramp, walker, folk, mitochondrial
## Lift: adequate, bilateral, critically, encephalopathy, generate, hall, hydrate
## Score: gaze, walker, concert, charity, leukodystrophy, doc, self-sufficient
## Topic 5 Top Words:
## Highest Prob: good, feel, kid, thing, say, time, one
## FREX: condition, speech, newborn, geneticist, obviously, pediatrician, pa
## Lift: arrangement, bloodwork, cardinal, cerebral, console, copay, deficit
## Score: epilepsy, condition, cblc, bunny, jewish, chop, pa
## Topic 6 Top Words:
## Highest Prob: say, can, good, thing, one, kid, time
## FREX: tree, volunteer, bike, braille, minnesota, swing, ride
## Lift: cpr, dj, extensive, former, glare, gown, minivan
## Score: adopt, tree, doula, motorcycle, glare, braille, bucket
## Topic 7 Top Words:
## Highest Prob: thing, say, good, can, time, need, one
## FREX: son, autism, extreme, stroke, antibiotic, line, lord
## Lift: anonymous, audio, deplete, distraction, drill, entail, entitle
## Score: funeral, spanish, metabolics, antonio, lord, humble, antibiotic
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage_lnp2 <- searchK(processed_lnp2$documents, processed_lnp2$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage_lnp2)
plot_data <- storage_lnp2$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic model_lnp2 Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# ran with low threshold 4 to promote more overlap
# heatmap
plot_theta <- melt(as.matrix(model_lnp2$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 9: lemma, same but min term freq 5
# Structural Topic Models- lemma, no pron, min 5
set.seed(20008)
processed_lnp5 <- convert(lemma_np5_dfm, to = "stm")
processed_lnp5 <- prepDocuments(documents = processed_lnp5$documents,
vocab = processed_lnp5$vocab,
meta = processed_lnp5$meta,
lower.thresh = 1)
## Removing 73 of 2762 terms (73 of 45664 tokens) due to frequency
## Your corpus now has 83 documents, 2689 terms and 45591 tokens.
docs <- processed_lnp5$documents
vocab <- processed_lnp5$vocab
meta <- processed_lnp5$meta
plotRemoved(processed_lnp5$documents, lower.thresh = seq(1, 20, by = 2))
## Initial Model
# create the processed_lnp5 object in the prior chunk
model_lnp5 <- stm(documents = processed_lnp5$documents,
vocab = processed_lnp5$vocab,
K = 8,
data = processed_lnp5$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_lnp5, type = "summary", labeltype = "score")
plot(model_lnp5, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(model_lnp5, type = "perspectives", topics = c(1, 2))
topicCorr(model_lnp5, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,] 1 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0
## [3,] 0 0 1 1 0 0 0 0
## [4,] 0 0 1 1 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0
## [6,] 0 0 0 0 0 1 0 0
## [7,] 0 0 0 0 0 0 1 0
## [8,] 0 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,] 1 0 0.00000000 0.00000000 0 0 0 0
## [2,] 0 1 0.00000000 0.00000000 0 0 0 0
## [3,] 0 0 1.00000000 0.01478336 0 0 0 0
## [4,] 0 0 0.01478336 1.00000000 0 0 0 0
## [5,] 0 0 0.00000000 0.00000000 1 0 0 0
## [6,] 0 0 0.00000000 0.00000000 0 1 0 0
## [7,] 0 0 0.00000000 0.00000000 0 0 1 0
## [8,] 0 0 0.00000000 0.00000000 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.0000000 -0.18689260 -0.17763665 -0.13377366 -0.27545104 -0.16319319
## [2,] -0.1868926 1.00000000 -0.17889887 -0.10977739 -0.21532097 -0.16083326
## [3,] -0.1776366 -0.17889887 1.00000000 0.01478336 -0.14943189 -0.07015878
## [4,] -0.1337737 -0.10977739 0.01478336 1.00000000 -0.08311182 -0.04108611
## [5,] -0.2754510 -0.21532097 -0.14943189 -0.08311182 1.00000000 -0.28197057
## [6,] -0.1631932 -0.16083326 -0.07015878 -0.04108611 -0.28197057 1.00000000
## [7,] -0.1468407 -0.14201750 -0.13842426 -0.14247184 -0.07846016 -0.08873297
## [8,] -0.1339548 -0.08449094 -0.08367587 -0.08998969 -0.17911797 -0.14510425
## [,7] [,8]
## [1,] -0.14684070 -0.13395479
## [2,] -0.14201750 -0.08449094
## [3,] -0.13842426 -0.08367587
## [4,] -0.14247184 -0.08998969
## [5,] -0.07846016 -0.17911797
## [6,] -0.08873297 -0.14510425
## [7,] 1.00000000 -0.16929016
## [8,] -0.16929016 1.00000000
##
## attr(,"class")
## [1] "topicCorr"
plot.topicCorr(topicCorr(model_lnp5, method = c("simple", "huge")))
# heatmap
plot_theta <- melt(as.matrix(model_lnp5$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
topicQuality(model_lnp5, processed_lnp5$documents)
## [1] -0.2913235 -0.3888774 -0.8781035 -1.0425938 -0.9364683 -0.7379533 -0.5382417
## [8] -1.4666651
## [1] 7.488363 8.118369 6.979249 7.640994 7.106336 7.982573 8.069129 6.859122
labelTopics(model_lnp5)
## Topic 1 Top Words:
## Highest Prob: good, time, can, one, day, thing, say
## FREX: nurse, trip, everyone, disney, fear, aide, wish
## Lift: administer, trach, crib, hh, tennessee, vanderbilt, katie
## Score: administer, trach, cruise, beckett, crib, aide, cobalamin
## Topic 2 Top Words:
## Highest Prob: time, thing, one, feel, can, now, good
## FREX: behavior, wife, autism, vision, blind, batten, genetic
## Lift: cream, stargardt, terror, diarrhea, autism, mourn, retina
## Score: cream, batten, cochlear, autism, behavior, implant, vision
## Topic 3 Top Words:
## Highest Prob: thing, say, can, one, time, need, good
## FREX: line, resident, lord, literally, infection, true, upon
## Lift: encouragement, fundraiser, lord, oaa, tpn, homecare, pharmacist
## Score: oaa, tpn, lord, intentional, humble, worthy, sin
## Topic 4 Top Words:
## Highest Prob: stuff, thing, can, good, one, lot, need
## FREX: s, stuff, doc, ramp, walker, sort, folk
## Lift: hydrate, wichita, gaze, las, vega, regain, self-sufficient
## Score: gaze, concert, doc, walker, charity, strategy, vega
## Topic 5 Top Words:
## Highest Prob: good, thing, kid, time, say, one, lot
## FREX: metabolic, newborn, baby, condition, seem, crisis, geneticist
## Lift: epilepsy, glennon, jewish, louis, remote, urine, cardinal
## Score: epilepsy, it’s, cblc, acidemia, geneticist, antonio, ammonia
## Topic 6 Top Words:
## Highest Prob: can, thing, good, say, lot, make, time
## FREX: course, climb, son, maybe, sad, norway, mention
## Lift: norwegian, tanzania, ski, fry, norway, rope, hurricane
## Score: tanzania, norway, ski, norwegian, hurricane, orlando, strategy
## Topic 7 Top Words:
## Highest Prob: say, can, thing, good, one, want, tell
## FREX: tree, transplant, sing, sit, dad, ride, olaf
## Lift: preacher, bread, motorcycle, pit, brown, fat, dentist
## Score: motorcycle, tree, transplant, bicycle, olaf, preacher, band
## Topic 8 Top Words:
## Highest Prob: say, time, good, can, family, feel, thing
## FREX: volunteer, disability, grief, program, system, grieve, placement
## Lift: appreciative, convenient, homeschool, immunocompromise, memorial, reflection, unable
## Score: memorial, doula, braille, adopt, placement, grief, el
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage_lnp5 <- searchK(processed_lnp5$documents, processed_lnp5$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage_lnp5)
plot_data <- storage_lnp5$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic model_lnp5 Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# ran with low threshold 4 to promote more overlap
# heatmap
plot_theta <- melt(as.matrix(model_lnp5$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 10: stem, same but min term freq 2
# Structural Topic Models- stem, no pron, min 2
set.seed(20009)
# also change lower thresh to 1 and see if fix
processed_snp2 <- convert(stem_np2_dfm, to = "stm")
processed_snp2 <- prepDocuments(documents = processed_snp2$documents,
vocab = processed_snp2$vocab,
meta = processed_snp2$meta,
lower.thresh = 1)
## Removing 226 of 3604 terms (226 of 49725 tokens) due to frequency
## Your corpus now has 83 documents, 3378 terms and 49499 tokens.
docs <- processed_snp2$documents
vocab <- processed_snp2$vocab
meta <- processed_snp2$meta
plotRemoved(processed_snp2$documents, lower.thresh = seq(1, 20, by = 2))
## Initial Model
# create the processed_snp2 object in the prior chunk
model_snp2 <- stm(documents = processed_snp2$documents,
vocab = processed_snp2$vocab,
K = 8,
data = processed_snp2$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_snp2, type = "summary", labeltype = "score")
plot(model_snp2, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(model_snp2, type = "perspectives", topics = c(1, 2))
topicCorr(model_snp2, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,] 1 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0
## [6,] 0 0 0 0 0 1 0 0
## [7,] 0 0 0 0 0 0 1 0
## [8,] 0 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,] 1 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0
## [6,] 0 0 0 0 0 1 0 0
## [7,] 0 0 0 0 0 0 1 0
## [8,] 0 0 0 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.0000000 -0.22937607 -0.18366105 -0.13780682 -0.10994211 -0.21355789
## [2,] -0.2293761 1.00000000 -0.18979656 -0.09874817 -0.19969523 -0.19894112
## [3,] -0.1836610 -0.18979656 1.00000000 -0.05455511 -0.08409998 -0.20590263
## [4,] -0.1378068 -0.09874817 -0.05455511 1.00000000 -0.07210058 -0.05503653
## [5,] -0.1099421 -0.19969523 -0.08409998 -0.07210058 1.00000000 -0.04241832
## [6,] -0.2135579 -0.19894112 -0.20590263 -0.05503653 -0.04241832 1.00000000
## [7,] -0.1177498 -0.08598245 -0.09810657 -0.07315516 -0.07711782 -0.16075836
## [8,] -0.2000778 -0.18310830 -0.15807447 -0.07123886 -0.11912894 -0.24930151
## [,7] [,8]
## [1,] -0.11774981 -0.20007780
## [2,] -0.08598245 -0.18310830
## [3,] -0.09810657 -0.15807447
## [4,] -0.07315516 -0.07123886
## [5,] -0.07711782 -0.11912894
## [6,] -0.16075836 -0.24930151
## [7,] 1.00000000 -0.11953947
## [8,] -0.11953947 1.00000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_snp2, processed_snp2$documents)
## [1] -0.5133884 -1.6523589 -0.7730405 -2.1715226 -1.6202032 -1.2147704 -1.7377103
## [8] -0.6245868
## [1] 7.745367 7.798886 7.782159 8.042842 7.418795 7.799937 7.697059 7.330364
labelTopics(model_snp2)
## Topic 1 Top Words:
## Highest Prob: realli, time, can, thing, day, need, one
## FREX: trip, disney, nurs, everyon, aid, fear, covid
## Lift: appeal, compens, defect, fda, hhs, matur, semest
## Score: matur, trach, beckett, kati, fusion, defect, cobalamin
## Topic 2 Top Words:
## Highest Prob: time, one, can, thing, realli, want, day
## FREX: affirm, told, super, toy, seizur, babi, eye
## Lift: cream, haven’t, limp, mash, pacifi, portion, sleepov
## Score: cream, it’, hurrican, orlando, cane, muslim, cart
## Topic 3 Top Words:
## Highest Prob: can, one, thing, say, realli, time, even
## FREX: minnesota, geneticist, decis, condit, outcom, norway, newborn
## Lift: bypass, eager, favor, newspap, norwegian, onset, redo
## Score: norway, sank, tanzania, tpn, reduc, itali, norwegian
## Topic 4 Top Words:
## Highest Prob: stuff, thing, got, can, one, realli, time
## FREX: s, stuff, doc, folk, walker, ramp, mitochondri
## Lift: self-suffici, vega, violent, welfar, adequ, bilater, encephalopathi
## Score: gaze, walker, chariti, concert, leukodystrophi, doc, violent
## Topic 5 Top Words:
## Highest Prob: thing, can, time, realli, want, say, need
## FREX: autism, olaf, deaf, line, god, christian, lord
## Lift: audio, entail, oaa, sicker, strive, testament, frozen
## Score: oaa, olaf, deaf, frozen, lord, autism, humbl
## Topic 6 Top Words:
## Highest Prob: realli, feel, thing, lot, time, can, help
## FREX: definit, feel, communiti, therapi, diagnosi, behavior, batten
## Lift: anticipatori, bedrest, epilepsi, heighten, hemorrhag, jewish, urgenc
## Score: epilepsi, grief, batten, chop, griev, behavior, arc
## Topic 7 Top Words:
## Highest Prob: said, can, thing, kid, time, one, want
## FREX: tree, volunt, adopt, said, bike, braill, doula
## Lift: coolest, cpr, dj, glare, gown, hostess, midwiv
## Score: adopt, doula, motorcycl, tree, braill, glare, niec
## Topic 8 Top Words:
## Highest Prob: thing, one, realli, can, time, well, got
## FREX: metabol, pa, son, stroke, crisi, acidemia, wife
## Lift: spanish, antonio, assur, funer, hip, hummus, inborn
## Score: spanish, antonio, funer, pa, ammonia, puddl, distract
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage_snp2 <- searchK(processed_snp2$documents, processed_snp2$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage_snp2)
plot_data <- storage_snp2$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic model_snp2 Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity") +
theme_minimal()
# then repeat "model"
# heatmap
plot_theta <- melt(as.matrix(model_snp2$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 11: stem, same but min term freq 5
# Structural Topic Models- stem, no pron, min 5
set.seed(20010)
processed_snp5 <- convert(stem_np5_dfm, to = "stm")
processed_snp5 <- prepDocuments(documents = processed_snp5$documents,
vocab = processed_snp5$vocab,
meta = processed_snp5$meta,
lower.thresh = 1)
## Removing 73 of 2678 terms (73 of 47440 tokens) due to frequency
## Your corpus now has 83 documents, 2605 terms and 47367 tokens.
docs <- processed_snp5$documents
vocab <- processed_snp5$vocab
meta <- processed_snp5$meta
plotRemoved(processed_snp5$documents, lower.thresh = seq(1, 20, by = 2))
## Initial Model
# create the processed_snp5 object in the prior chunk
model_snp5 <- stm(documents = processed_snp5$documents,
vocab = processed_snp5$vocab,
K = 8,
data = processed_snp5$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_snp5, type = "summary", labeltype = "score")
plot(model_snp5, type = "hist", labeltype = "score")
# compare within topic, if covariate
plot(model_snp5, type = "perspectives", topics = c(1, 2))
topicCorr(model_snp5, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,] 1 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0
## [6,] 0 0 0 0 0 1 0 0
## [7,] 0 0 0 0 0 0 1 0
## [8,] 0 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,] 1 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0
## [6,] 0 0 0 0 0 1 0 0
## [7,] 0 0 0 0 0 0 1 0
## [8,] 0 0 0 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.00000000 -0.23707733 -0.02113424 -0.12248215 -0.21174754 -0.10238508
## [2,] -0.23707733 1.00000000 -0.15357466 -0.12513924 -0.20219726 -0.27022508
## [3,] -0.02113424 -0.15357466 1.00000000 -0.04682161 -0.10888125 -0.10347731
## [4,] -0.12248215 -0.12513924 -0.04682161 1.00000000 -0.02319692 -0.08119311
## [5,] -0.21174754 -0.20219726 -0.10888125 -0.02319692 1.00000000 -0.22866510
## [6,] -0.10238508 -0.27022508 -0.10347731 -0.08119311 -0.22866510 1.00000000
## [7,] -0.15276930 -0.01631384 -0.10035490 -0.11871612 -0.18145362 -0.16270034
## [8,] -0.14105556 -0.14412598 -0.13101155 -0.11616498 -0.23286817 -0.14921385
## [,7] [,8]
## [1,] -0.15276930 -0.1410556
## [2,] -0.01631384 -0.1441260
## [3,] -0.10035490 -0.1310116
## [4,] -0.11871612 -0.1161650
## [5,] -0.18145362 -0.2328682
## [6,] -0.16270034 -0.1492139
## [7,] 1.00000000 -0.1570434
## [8,] -0.15704343 1.0000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_snp5, processed_snp5$documents)
## [1] -1.1292019 -0.4899070 -1.5701990 -1.3935960 -0.9583818 -1.0917615 -1.8218182
## [8] -1.2750957
## [1] 7.621272 7.951119 7.267166 7.723637 7.465200 8.059150 7.442607 7.270591
labelTopics(model_snp5)
## Topic 1 Top Words:
## Highest Prob: realli, can, time, thing, need, caregiv, one
## FREX: mother, aid, caregiv, divorc, fear, affect, best
## Lift: defect, matur, montana, hhs, hands-on, tick, horizon
## Score: matur, defect, cobalamin, montana, tick, horizon, ongo
## Topic 2 Top Words:
## Highest Prob: time, one, can, thing, realli, now, day
## FREX: wife, told, behavior, liver, transplant, affirm, mma
## Lift: cream, portion, it’, don’t, overreact, autist, dietitian
## Score: cream, it’, liver, muslim, cane, stargardt, smoke
## Topic 3 Top Words:
## Highest Prob: thing, can, peopl, say, time, one, need
## FREX: line, infect, resid, liter, lord, christian, sound
## Lift: oaa, sin, tpn, platelet, drill, septic, christ
## Score: oaa, tpn, lord, sin, humbl, worthi, upon
## Topic 4 Top Words:
## Highest Prob: stuff, thing, got, can, one, realli, time
## FREX: s, stuff, doc, walker, sort, ramp, folk
## Lift: self-suffici, vega, violent, wichita, gaze, las, leukodystrophi
## Score: gaze, concert, walker, doc, chariti, leukodystrophi, violent
## Topic 5 Top Words:
## Highest Prob: realli, thing, kid, time, one, lot, can
## FREX: condit, pretti, metabol, obvious, newborn, acidemia, speech
## Lift: cardin, epilepsi, glennon, incub, jewish, loui, perhap
## Score: epilepsi, acidemia, spanish, kindergarten, cblc, pa, antonio
## Topic 6 Top Words:
## Highest Prob: realli, thing, can, feel, famili, time, lot
## FREX: grief, disabl, communiti, son, feel, realiz, griev
## Lift: alexa, cue, norwegian, ski, tanzania, immunocompromis, embrac
## Score: tanzania, norway, griev, grief, ski, norwegian, placement
## Topic 7 Top Words:
## Highest Prob: said, can, thing, want, kid, time, one
## FREX: tree, said, adopt, volunt, blind, sing, braill
## Lift: hostess, motorcycl, pit, adopt, cart, fri, panda
## Score: motorcycl, adopt, doula, tree, braill, olaf, bicycl
## Topic 8 Top Words:
## Highest Prob: realli, can, time, thing, one, need, got
## FREX: nurs, insur, trip, gosh, everyon, minnesota, rehab
## Lift: pleasur, beckett, diarrhea, kati, leigh, tennesse, trach
## Score: trach, beckett, kati, paint, bucket, tennesse, homebound
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage_snp5 <- searchK(processed_snp5$documents, processed_snp5$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage_snp5)
plot_data <- storage_snp5$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic model_snp/5 Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# ran with low threshold 4 to promote more overlap
# heatmap
plot_theta <- melt(as.matrix(model_snp5$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model 12 and 13: stem, term freq > 5, only minimal list of
stopwords. k = 5 and k = 9
# Structural Topic Models- stem, keep more words, min 5
set.seed(20011)
processed_s5 <- convert(stem5_dfm, to = "stm")
processed_s5 <- prepDocuments(documents = processed_s5$documents,
vocab = processed_s5$vocab,
meta = processed_s5$meta,
lower.thresh = 1)
## Removing 73 of 2713 terms (73 of 50007 tokens) due to frequency
## Your corpus now has 83 documents, 2640 terms and 49934 tokens.
docs <- processed_s5$documents
vocab <- processed_s5$vocab
meta <- processed_s5$meta
plotRemoved(processed_s5$documents, lower.thresh = seq(1, 20, by = 2))
## Initial Model
# create the processed_s5 object in the prior chunk
model_s5 <- stm(documents = processed_s5$documents,
vocab = processed_s5$vocab,
K = 5,
data = processed_s5$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_s5, type = "summary", labeltype = "lift")
plot(model_s5, type = "hist", labeltype = "lift")
# compare within topic, if covariate
plot(model_s5, type = "perspectives", topics = c(1, 2))
topicCorr(model_s5, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 0 0 0 0
## [2,] 0 1 0 0 0
## [3,] 0 0 1 0 0
## [4,] 0 0 0 1 0
## [5,] 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 0 0 0 0
## [2,] 0 1 0 0 0
## [3,] 0 0 1 0 0
## [4,] 0 0 0 1 0
## [5,] 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1.0000000 -0.1203433 -0.1496071 -0.2110443 -0.2910178
## [2,] -0.1203433 1.0000000 -0.1725740 -0.3025262 -0.1988738
## [3,] -0.1496071 -0.1725740 1.0000000 -0.2574095 -0.4691875
## [4,] -0.2110443 -0.3025262 -0.2574095 1.0000000 -0.2664084
## [5,] -0.2910178 -0.1988738 -0.4691875 -0.2664084 1.0000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_s5, processed_s5$documents)
## [1] -0.1583058 -0.1461859 -0.2311738 -0.1461859 -1.1887928
## [1] 6.771902 7.257152 6.849069 7.827048 6.494026
labelTopics(model_s5)
## Topic 1 Top Words:
## Highest Prob: i, not, you, he, my, we, know
## FREX: mom, dad, church, god, listen, die, me
## Lift: administ, sin, fri, parad, drill, christ, attitud
## Score: administ, i, his, him, he, my, me
## Topic 2 Top Words:
## Highest Prob: you, know, we, i, like, not, he
## FREX: know, s, you, stuff, drink, wheelchair, somebodi
## Lift: brutal, spoon, oaa, violent, neuro, kennedi, tick
## Score: you, know, spoon, he, his, him, kennedi
## Topic 3 Top Words:
## Highest Prob: i, we, he, not, just, yeah, you
## FREX: trip, medicaid, yeah, caregiv, diagnosi, realiz, kind
## Lift: alexa, dysfunct, norwegian, ski, tanzania, tpn, translat
## Score: tanzania, he, his, him, ski, norway, yeah
## Topic 4 Top Words:
## Highest Prob: like, i, not, he, you, just, we
## FREX: like, pediatrician, birthday, fine, super, rememb, oh
## Lift: glennon, presid, steroid, valentin, olaf, score, frozen
## Score: like, glennon, he, olaf, his, him, i
## Topic 5 Top Words:
## Highest Prob: i, she, her, we, not, you, like
## FREX: her, she, volunt, pa, transplant, herself, daughter
## Lift: tee, epilepsi, jewish, sold, wichita, chicago, hormon
## Score: she, her, tee, adopt, doula, herself, braill
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage_s5 <- searchK(processed_s5$documents, processed_s5$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage_s5)
plot_data <- storage_s5$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic model_snp5 Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# heatmap
plot_theta <- melt(as.matrix(model_s5$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model_s5 <- stm(documents = processed_s5$documents,
vocab = processed_s5$vocab,
K = 9,
data = processed_s5$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_s5, type = "summary", labeltype = "lift")
plot(model_s5, type = "hist", labeltype = "lift")
# compare within topic, if covariate
plot(model_s5, type = "perspectives", topics = c(1, 2))
topicCorr(model_s5, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]
## [1,] 1 0 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0 1
## [6,] 0 0 0 0 0 1 0 0 0
## [7,] 0 0 0 0 0 0 1 0 0
## [8,] 0 0 0 0 0 0 0 1 0
## [9,] 0 0 0 0 1 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]
## [1,] 1 0 0 0 0.0000000 0 0 0 0.0000000
## [2,] 0 1 0 0 0.0000000 0 0 0 0.0000000
## [3,] 0 0 1 0 0.0000000 0 0 0 0.0000000
## [4,] 0 0 0 1 0.0000000 0 0 0 0.0000000
## [5,] 0 0 0 0 1.0000000 0 0 0 0.0696833
## [6,] 0 0 0 0 0.0000000 1 0 0 0.0000000
## [7,] 0 0 0 0 0.0000000 0 1 0 0.0000000
## [8,] 0 0 0 0 0.0000000 0 0 1 0.0000000
## [9,] 0 0 0 0 0.0696833 0 0 0 1.0000000
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.00000000 -0.03716479 -0.07645551 -0.13256744 -0.15415856 -0.03663978
## [2,] -0.03716479 1.00000000 -0.11264096 -0.11975779 -0.16011470 -0.02653894
## [3,] -0.07645551 -0.11264096 1.00000000 -0.10499044 -0.09896085 -0.12199371
## [4,] -0.13256744 -0.11975779 -0.10499044 1.00000000 -0.15478299 -0.10905903
## [5,] -0.15415856 -0.16011470 -0.09896085 -0.15478299 1.00000000 -0.14631130
## [6,] -0.03663978 -0.02653894 -0.12199371 -0.10905903 -0.14631130 1.00000000
## [7,] -0.12211494 -0.05527318 -0.18321775 -0.07716835 -0.12092205 -0.18429342
## [8,] -0.12847903 -0.19058972 -0.09359011 -0.14406477 0.00000000 -0.17724435
## [9,] -0.14288334 -0.20562932 -0.19927095 -0.17408100 0.06968330 -0.29568340
## [,7] [,8] [,9]
## [1,] -0.12211494 -0.12847903 -0.14288334
## [2,] -0.05527318 -0.19058972 -0.20562932
## [3,] -0.18321775 -0.09359011 -0.19927095
## [4,] -0.07716835 -0.14406477 -0.17408100
## [5,] -0.12092205 0.00000000 0.06968330
## [6,] -0.18429342 -0.17724435 -0.29568340
## [7,] 1.00000000 -0.12790533 -0.20750171
## [8,] -0.12790533 1.00000000 -0.05428776
## [9,] -0.20750171 -0.05428776 1.00000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_s5, processed_s5$documents)
## [1] -0.2560084 -0.2195000 -0.1577073 -0.3166078 -1.1887928 -2.3728572 -1.1547902
## [8] -1.1887928 -1.1887928
## [1] 6.701066 7.526219 7.796582 7.840010 7.118333 7.164542 8.226012 7.564773
## [9] 7.573452
labelTopics(model_s5)
## Topic 1 Top Words:
## Highest Prob: i, not, you, we, my, just, know
## FREX: grief, church, divorc, import, liter, griev, christian
## Lift: administ, christ, hopeless, parad, sin, precious, conflict
## Score: administ, grief, i, his, lord, humbl, him
## Topic 2 Top Words:
## Highest Prob: you, know, we, like, i, not, he
## FREX: know, you, stuff, drink, somebodi, level, doc
## Lift: spoon, brutal, oaa, violent, bitter, defect, concert
## Score: spoon, you, know, he, his, hydrat, concert
## Topic 3 Top Words:
## Highest Prob: i, we, yeah, you, not, like, just
## FREX: diagnosi, yeah, kind, diseas, communiti, batten, caregiv
## Lift: norwegian, norway, tanzania, da, radar, villag, cabin
## Score: tanzania, norway, yeah, batten, norwegian, kind, villag
## Topic 4 Top Words:
## Highest Prob: like, i, not, you, just, know, he
## FREX: like, sort, pediatrician, appoint, preschool, super, walker
## Lift: glennon, welfar, ct, leukodystrophi, presid, trach, score
## Score: like, glennon, walker, trach, leukodystrophi, he, paint
## Topic 5 Top Words:
## Highest Prob: we, i, she, not, her, you, like
## FREX: volunt, adopt, braill, colleg, blind, iep, train
## Lift: tee, braill, adopt, bias, el, homeschool, motorcycl
## Score: tee, adopt, her, she, doula, motorcycl, braill
## Topic 6 Top Words:
## Highest Prob: i, he, we, not, just, you, know
## FREX: son, him, wife, his, disney, food, trip
## Lift: antonio, spanish, tpn, ski, conveni, alabama, altern
## Score: ski, he, his, him, spanish, tpn, antonio
## Topic 7 Top Words:
## Highest Prob: i, he, like, not, we, you, him
## FREX: cri, he, him, happi, toy, told, his
## Lift: cochlear, cream, dentist, pakistan, pakistani, olaf, chattanooga
## Score: cream, he, olaf, him, his, cochlear, pakistani
## Topic 8 Top Words:
## Highest Prob: you, i, know, she, not, we, her
## FREX: tree, pa, mother, she, transplant, minnesota, buy
## Lift: club, gaze, wichita, bucket, sold, pit, brown
## Score: gaze, she, her, tree, pa, you, bucket
## Topic 9 Top Words:
## Highest Prob: i, like, she, not, her, you, just
## FREX: her, condit, speech, she, therapi, behavior, babi
## Lift: cblc, epilepsi, aba, bunni, psychiatri, nonprofit, it’
## Score: epilepsi, her, she, i, cblc, bunni, it’
model 14 and 15: stem, term freq > 5, removed a lot more stop
words from tidytext dicts. k = 8 and k = 9
# Structural Topic Models- stem, remove more stopwords, min 5
set.seed(20012)
processed_s5 <- convert(stem5_dfm, to = "stm")
processed_s5 <- prepDocuments(documents = processed_s5$documents,
vocab = processed_s5$vocab,
meta = processed_s5$meta,
lower.thresh = 1)
## Removing 73 of 2713 terms (73 of 50007 tokens) due to frequency
## Your corpus now has 83 documents, 2640 terms and 49934 tokens.
docs <- processed_s5$documents
vocab <- processed_s5$vocab
meta <- processed_s5$meta
plotRemoved(processed_s5$documents, lower.thresh = seq(1, 20, by = 2))
## Initial Model
# create the processed_s5 object in the prior chunk
model_s5 <- stm(documents = processed_s5$documents,
vocab = processed_s5$vocab,
K = 8,
data = processed_s5$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_s5, type = "summary", labeltype = "lift")
plot(model_s5, type = "hist", labeltype = "lift")
# compare within topic, if covariate
plot(model_s5, type = "perspectives", topics = c(2, 3))
topicCorr(model_s5, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,] 1 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0
## [6,] 0 0 0 0 0 1 0 0
## [7,] 0 0 0 0 0 0 1 0
## [8,] 0 0 0 0 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,] 1 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0
## [6,] 0 0 0 0 0 1 0 0
## [7,] 0 0 0 0 0 0 1 0
## [8,] 0 0 0 0 0 0 0 1
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.00000000 -0.06685168 -0.08865897 -0.20094470 -0.07967095 -0.03037841
## [2,] -0.06685168 1.00000000 -0.13962770 -0.18293940 -0.22671642 -0.04138845
## [3,] -0.08865897 -0.13962770 1.00000000 -0.17788991 -0.13290036 -0.13243724
## [4,] -0.20094470 -0.18293940 -0.17788991 1.00000000 -0.09336152 -0.13680322
## [5,] -0.07967095 -0.22671642 -0.13290036 -0.09336152 1.00000000 -0.29495557
## [6,] -0.03037841 -0.04138845 -0.13243724 -0.13680322 -0.29495557 1.00000000
## [7,] -0.14363131 -0.07080231 -0.17742148 -0.14662164 -0.24155736 -0.19719960
## [8,] -0.15531556 -0.19463056 -0.14329927 -0.10820591 -0.03575634 -0.21281278
## [,7] [,8]
## [1,] -0.14363131 -0.15531556
## [2,] -0.07080231 -0.19463056
## [3,] -0.17742148 -0.14329927
## [4,] -0.14662164 -0.10820591
## [5,] -0.24155736 -0.03575634
## [6,] -0.19719960 -0.21281278
## [7,] 1.00000000 -0.10569063
## [8,] -0.10569063 1.00000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_s5, processed_s5$documents)
## [1] -0.04847957 -0.23176859 -0.13346750 -0.32887642 -1.17667290 -2.38512584
## [7] -1.17917864 -1.17667290
## [1] 6.860167 7.401914 7.780817 7.788525 6.696214 7.090431 8.217694 7.698960
labelTopics(model_s5)
## Topic 1 Top Words:
## Highest Prob: i, not, you, my, just, know, like
## FREX: divorc, grief, church, import, griev, listen, myself
## Lift: administ, hopeless, sin, salin, christ, choke, divorc
## Score: administ, i, grief, humbl, lord, my, sin
## Topic 2 Top Words:
## Highest Prob: you, know, we, like, i, not, he
## FREX: know, you, stuff, somebodi, level, drink, doc
## Lift: spoon, brutal, oaa, violent, bitter, defect, cyst
## Score: spoon, you, know, he, his, hydrat, him
## Topic 3 Top Words:
## Highest Prob: i, we, yeah, you, just, not, like
## FREX: diagnosi, yeah, kind, stress, diseas, guess, communiti
## Lift: norwegian, tanzania, norway, da, radar, reinforc, upbring
## Score: tanzania, yeah, norway, kind, batten, norwegian, think
## Topic 4 Top Words:
## Highest Prob: like, i, not, you, just, know, they
## FREX: like, pediatrician, appoint, sort, super, preschool, felt
## Lift: glennon, steroid, welfar, presid, ct, leukodystrophi, score
## Score: like, glennon, walker, i, leukodystrophi, trach, paint
## Topic 5 Top Words:
## Highest Prob: i, she, her, we, not, like, you
## FREX: her, she, volunt, speech, condit, adopt, babi
## Lift: epilepsi, tee, jewish, cblc, braill, aba, adopt
## Score: her, she, tee, adopt, doula, braill, cblc
## Topic 6 Top Words:
## Highest Prob: we, he, i, not, just, you, him
## FREX: son, wife, him, his, decis, attend, disney
## Lift: spanish, antonio, ski, tpn, conveni, altern, dysfunct
## Score: ski, he, him, his, spanish, we, tpn
## Topic 7 Top Words:
## Highest Prob: i, he, like, not, we, you, him
## FREX: he, cri, him, told, toy, happi, his
## Lift: cream, dentist, pakistan, chattanooga, olaf, pakistani, cochlear
## Score: cream, he, him, olaf, his, like, cochlear
## Topic 8 Top Words:
## Highest Prob: i, you, she, know, not, we, her
## FREX: tree, pa, said, she, formula, mother, her
## Lift: bucket, gaze, wichita, yall, fuss, club, pit
## Score: gaze, she, her, motorcycl, tree, you, bucket
# plotQuote or findThoughts require a shorter (200 char ea) ver of docs
invisible(capture.output(storage_s5 <- searchK(processed_s5$documents, processed_s5$vocab, K = 3:12,
data = meta)))
# t <- storage$results[[1]]
# t <- storage$results[[2]]
plot(storage_s5)
plot_data <- storage_s5$results %>%
mutate(
semcoh = as.numeric(unlist(semcoh)),
exclus = as.numeric(unlist(exclus)),
K = as.factor(unlist(K))
)
ggplot(plot_data, aes(x = semcoh, y = exclus, group = 1)) +
geom_line() +
geom_point() +
geom_text(aes(label = K), vjust = -1) +
labs(title = "Topic model_snp5 Diagnostics",
x = "Semantic Coherence",
y = "Exclusivity")
# then repeat "model"
# heatmap
plot_theta <- melt(as.matrix(model_s5$theta)) %>%
rename(doc = Var1, topic_prop = Var2, value = value)
ggplot(plot_theta, aes(x = topic_prop, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap",
x = "topic",
y = "document",
fill = "proportion")
# visualize topic proportions, draft
plot_theta <- plot_theta %>%
group_by(doc) %>%
arrange(doc, desc(value)) %>%
mutate(rank = row_number()) %>%
ungroup()
ggplot(plot_theta, aes(x = rank, y = doc, fill = value)) +
geom_tile() +
scale_fill_viridis_c(option = "plasma") +
theme_minimal() +
labs(title = "Topic Heatmap by Rank",
x = "topic rank (NOT topic #)",
y = "document",
fill = "proportion")
model_s5 <- stm(documents = processed_s5$documents,
vocab = processed_s5$vocab,
K = 9,
data = processed_s5$meta,
max.em.its = 75,
init.type = "Spectral",
verbose = FALSE)
plot(model_s5, type = "summary", labeltype = "lift")
plot(model_s5, type = "hist", labeltype = "lift")
# compare within topic, if covariate
plot(model_s5, type = "perspectives", topics = c(1, 2))
topicCorr(model_s5, method = c("simple", "huge"), cutoff = 0.01, verbose = TRUE)
## $posadj
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]
## [1,] 1 0 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0 1
## [6,] 0 0 0 0 0 1 0 0 0
## [7,] 0 0 0 0 0 0 1 0 0
## [8,] 0 0 0 0 0 0 0 1 0
## [9,] 0 0 0 0 1 0 0 0 1
##
## $poscor
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]
## [1,] 1 0 0 0 0.0000000 0 0 0 0.0000000
## [2,] 0 1 0 0 0.0000000 0 0 0 0.0000000
## [3,] 0 0 1 0 0.0000000 0 0 0 0.0000000
## [4,] 0 0 0 1 0.0000000 0 0 0 0.0000000
## [5,] 0 0 0 0 1.0000000 0 0 0 0.0696833
## [6,] 0 0 0 0 0.0000000 1 0 0 0.0000000
## [7,] 0 0 0 0 0.0000000 0 1 0 0.0000000
## [8,] 0 0 0 0 0.0000000 0 0 1 0.0000000
## [9,] 0 0 0 0 0.0696833 0 0 0 1.0000000
##
## $cor
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1.00000000 -0.03716479 -0.07645551 -0.13256744 -0.15415856 -0.03663978
## [2,] -0.03716479 1.00000000 -0.11264096 -0.11975779 -0.16011470 -0.02653894
## [3,] -0.07645551 -0.11264096 1.00000000 -0.10499044 -0.09896085 -0.12199371
## [4,] -0.13256744 -0.11975779 -0.10499044 1.00000000 -0.15478299 -0.10905903
## [5,] -0.15415856 -0.16011470 -0.09896085 -0.15478299 1.00000000 -0.14631130
## [6,] -0.03663978 -0.02653894 -0.12199371 -0.10905903 -0.14631130 1.00000000
## [7,] -0.12211494 -0.05527318 -0.18321775 -0.07716835 -0.12092205 -0.18429342
## [8,] -0.12847903 -0.19058972 -0.09359011 -0.14406477 0.00000000 -0.17724435
## [9,] -0.14288334 -0.20562932 -0.19927095 -0.17408100 0.06968330 -0.29568340
## [,7] [,8] [,9]
## [1,] -0.12211494 -0.12847903 -0.14288334
## [2,] -0.05527318 -0.19058972 -0.20562932
## [3,] -0.18321775 -0.09359011 -0.19927095
## [4,] -0.07716835 -0.14406477 -0.17408100
## [5,] -0.12092205 0.00000000 0.06968330
## [6,] -0.18429342 -0.17724435 -0.29568340
## [7,] 1.00000000 -0.12790533 -0.20750171
## [8,] -0.12790533 1.00000000 -0.05428776
## [9,] -0.20750171 -0.05428776 1.00000000
##
## attr(,"class")
## [1] "topicCorr"
topicQuality(model_s5, processed_s5$documents)
## [1] -0.2560084 -0.2195000 -0.1577073 -0.3166078 -1.1887928 -2.3728572 -1.1547902
## [8] -1.1887928 -1.1887928
## [1] 6.701066 7.526219 7.796582 7.840010 7.118333 7.164542 8.226012 7.564773
## [9] 7.573452
labelTopics(model_s5)
## Topic 1 Top Words:
## Highest Prob: i, not, you, we, my, just, know
## FREX: grief, church, divorc, import, liter, griev, christian
## Lift: administ, christ, hopeless, parad, sin, precious, conflict
## Score: administ, grief, i, his, lord, humbl, him
## Topic 2 Top Words:
## Highest Prob: you, know, we, like, i, not, he
## FREX: know, you, stuff, drink, somebodi, level, doc
## Lift: spoon, brutal, oaa, violent, bitter, defect, concert
## Score: spoon, you, know, he, his, hydrat, concert
## Topic 3 Top Words:
## Highest Prob: i, we, yeah, you, not, like, just
## FREX: diagnosi, yeah, kind, diseas, communiti, batten, caregiv
## Lift: norwegian, norway, tanzania, da, radar, villag, cabin
## Score: tanzania, norway, yeah, batten, norwegian, kind, villag
## Topic 4 Top Words:
## Highest Prob: like, i, not, you, just, know, he
## FREX: like, sort, pediatrician, appoint, preschool, super, walker
## Lift: glennon, welfar, ct, leukodystrophi, presid, trach, score
## Score: like, glennon, walker, trach, leukodystrophi, he, paint
## Topic 5 Top Words:
## Highest Prob: we, i, she, not, her, you, like
## FREX: volunt, adopt, braill, colleg, blind, iep, train
## Lift: tee, braill, adopt, bias, el, homeschool, motorcycl
## Score: tee, adopt, her, she, doula, motorcycl, braill
## Topic 6 Top Words:
## Highest Prob: i, he, we, not, just, you, know
## FREX: son, him, wife, his, disney, food, trip
## Lift: antonio, spanish, tpn, ski, conveni, alabama, altern
## Score: ski, he, his, him, spanish, tpn, antonio
## Topic 7 Top Words:
## Highest Prob: i, he, like, not, we, you, him
## FREX: cri, he, him, happi, toy, told, his
## Lift: cochlear, cream, dentist, pakistan, pakistani, olaf, chattanooga
## Score: cream, he, olaf, him, his, cochlear, pakistani
## Topic 8 Top Words:
## Highest Prob: you, i, know, she, not, we, her
## FREX: tree, pa, mother, she, transplant, minnesota, buy
## Lift: club, gaze, wichita, bucket, sold, pit, brown
## Score: gaze, she, her, tree, pa, you, bucket
## Topic 9 Top Words:
## Highest Prob: i, like, she, not, her, you, just
## FREX: her, condit, speech, she, therapi, behavior, babi
## Lift: cblc, epilepsi, aba, bunni, psychiatri, nonprofit, it’
## Score: epilepsi, her, she, i, cblc, bunni, it’