# function to launch a shiny app for topic model visualisation & article/word (de)selection
screen_topics <- function(
x = NULL,
remove_words = NULL,
max_file_size
){
# set file size if requested, ensuring to reset on exit
if(!missing(max_file_size)){
initial_file_size <- options("shiny.maxRequestSize")
options(shiny.maxRequestSize = max_file_size * 1024^2)
on.exit(options(initial_file_size))
}
data_in <- load_topic_data(
data = x,
stopwords = remove_words
)
# create ui
ui_data <- screen_topics_ui()
ui <- shinydashboard::dashboardPage(
title = "revtools | screen_topics",
header = ui_data$header,
sidebar = ui_data$sidebar,
body = ui_data$body,
skin = "black"
)
# start server
server <- function(input, output, session){
options(warn = -1) # hide incompatibility between shiny and plotly
# https://github.com/hrbrmstr/metricsgraphics/issues/49
# establish a reactiveValue object to store data
data <- reactiveValues(
raw = data_in$raw,
stopwords = data_in$stopwords,
columns = data_in$columns,
grouped = data_in$grouped,
dtm = data_in$dtm,
model = data_in$model,
plot_ready = data_in$plot_ready
)
# need to run some extra code here if class screen_topics_progress is used
if(!is.null(data_in$model)){
palette_initial <- viridis(
n = data_in$model@k,
alpha = 0.9,
begin = 0.1,
end = 0.9,
option = "A"
)
appearance_initial <- build_appearance(
plot_data = data_in$plot_ready,
palette = palette_initial
)
}else{
palette_initial <- NULL
appearance_initial <- NULL
}
# add remaining reactiveValue objects
plot_features <- reactiveValues(
palette = palette_initial,
appearance = appearance_initial,
notes = FALSE,
common_words = FALSE
)
click_data <- reactiveValues(
main = c(),
topic = c(),
topic_2 = c(1),
word = c()
)
words <- reactiveValues(
current = NULL,
rows = NULL,
search_results = NULL,
search_clicks = NULL,
selected = NULL
)
# create header image
output$header <- renderPlot({
revtools_logo(text = "screen_topics")
})
# DATA INPUT
## when specified, ensure input data is processed correctly
observeEvent(input$data_in, {
data_loaded <- import_shiny_topic_data(
source = input$data_in,
current_data = data
)
data$raw <- data_loaded$raw
data$columns <- data_loaded$columns
data$grouped <- data_loaded$grouped
data$dtm <- data_loaded$dtm
data$model <- data_loaded$model
data$plot_ready <- data_loaded$plot_ready
# need to run some extra code here if class screen_topics_progress is used
if(!is.null(data$model)){
# create color palette
plot_features$palette <- viridis(
n = data$model@k,
alpha = 0.9,
begin = 0.1,
end = 0.9,
option = "A"
)
# add appearance info
plot_features$appearance <- build_appearance(
plot_data = data$plot_ready,
palette = plot_features$palette
)
}
})
# show number of articles in current dataset
output$progress_text <- renderText({
if(!is.null(data$raw)){
HTML(
paste0(
length(which(!is.na(data$raw$screened_topics))),
" of ",
nrow(data$raw),
" entries screened"
)
)
}
})
# duplicate of above for 'words' screen
output$selector_n2 <- renderPrint({
if(!is.null(data$raw)){
cat(paste0(
"Dataset containing ",
nrow(data$raw),
" entries | ",
length(which(!is.na(data$raw$screened_topics))),
" screened<br><br>"
))
}
})
# add option to remove data
observeEvent(input$clear_data, {
shiny::showModal(
shiny::modalDialog(
HTML("If you proceed, all data will be removed from this window,
including any progress you have made screening your data.
If you have not saved your data,
you might want to consider doing that first.<br><br>
Are you sure you want to continue?<br><br>"
),
shiny::actionButton(
inputId = "clear_data_confirmed",
label = "Confirm"),
shiny::modalButton("Cancel"),
title = "Clear all data",
footer = NULL,
easyClose = FALSE
)
)
})
observeEvent(input$clear_data_confirmed, {
data$raw <- NULL
data$columns <- NULL
data$grouped <- NULL
data$dtm <- NULL
data$model <- NULL
data$plot_ready <- NULL
removeModal()
})
# data selection
# select a grouping variable
output$response_selector <- renderUI({
if(!is.null(data$columns)){
if(any(data$columns == "label")){
response_column <- "label"
}else{
response_column <- data$columns[1]
}
selectInput(
"response_variable",
label = "Show one point per:",
choices = data$columns,
selected = response_column
)
}
})
# select text to be included in the DTM/topic model
output$variable_selector <- renderUI({
if(!is.null(data$columns)){
checkboxGroupInput("variable_selector",
"Select included variables:",
choices = data$columns
)
}
})
# calculate topic models
observeEvent(input$calc_model, {
# if no variables are selected, do not run a topic model
if(length(input$variable_selector) < 1){
showModal(
modalDialog(
HTML("Please select 1 or more variables to include in the topic model<br><br>
<em>Click anywhere to exit</em>"),
title = "Error: insufficient data",
footer = NULL,
easyClose = TRUE
)
)
}else{
showModal(
modalDialog(
HTML("Depending on the size of your dataset, this may take some time"),
title = "Calculating Topic Model",
footer = NULL,
easyClose = FALSE
)
)
# wipe earlier models/data
data$grouped <- NULL
data$dtm <- NULL
data$model <- NULL
data$plot_ready <- NULL
plot_features$appearance <- NULL
# choose which rows to use for later calculation
if(!all(is.na(data$raw$screened_topics))){
data$raw$display[which(is.na(data$raw$screened_topics) == FALSE)] <- FALSE
}
# create data.frame with only relevant information for topic modelling
data$grouped <- create_grouped_dataframe(
data = data$raw[which(data$raw$display), ],
response_variable = input$response_variable,
text_variables = input$variable_selector
)
data$dtm <- make_dtm(
x = data$grouped$text,
stop_words = data$stopwords,
min_freq = input$min_freq * 0.01,
max_freq = input$max_freq * 0.01,
bigram_quantile = input$bigram_quantile * 0.01
)
if(input$response_variable != data$columns[1]){
plot_features$common_words <- TRUE
}else{
plot_features$common_words <- FALSE
}
# restrict to only entries that are present in data$dtm
if(data$dtm$nrow < nrow(data$grouped)){
data$grouped <- data$grouped[as.numeric(data$dtm$dimnames$Docs), ]
}
# calculate topic model
data$model <- run_topic_model(
dtm = data$dtm,
type = tolower(input$model_type),
n_topics = input$n_topics,
iterations = input$n_iterations
)
# create plottable information
data$plot_ready <- build_plot_data(
info = data$grouped,
dtm = data$dtm,
model = data$model,
hide_names = input$hide_names
)
# create color palette
plot_features$palette <- viridis(
n = data$model@k,
alpha = 0.9,
begin = 0.1,
end = 0.9,
option = "A"
)
# add topic to data$raw
data$grouped$topic <- topicmodels::topics(data$model)
data$raw$topic <- unlist(lapply(
data$raw[, input$response_variable],
function(a, lookup){
if(is.na(a)){
NA
}else{
if(any(lookup[, 1] == a)){
lookup$topic[which(lookup[, 1] == a)]
}else{
NA
}
}
},
lookup = data$grouped
))
# add appearance info
plot_features$appearance <- build_appearance(
plot_data = data$plot_ready,
palette = plot_features$palette
)
# exit modal
removeModal()
} # end if
}) # end topic model calculation
# update color palette when inputs change
observeEvent({
input$palette
input$color_alpha
input$color_hue
input$point_size
}, {
if(is.null(data$model)){
k <- 5
}else{
k <- data$model@k
}
plot_features$palette <- viridis(
n = k,
alpha = input$color_alpha,
begin = input$color_hue[1],
end = input$color_hue[2],
option = input$palette
)
plot_features$appearance <- update_appearance(
plot_data = plot_features$appearance,
palette = plot_features$palette
)
})
# update caption if required
observeEvent(input$hide_names, {
if(!is.null(data$plot_ready)){
data$plot_ready$x$caption <- paste0(
format_citation(
data = data$plot_ready$x,
details = !as.logical(input$hide_names),
add_html = TRUE,
line_breaks = TRUE
),
"<br>[Topic #",
data$plot_ready$x$topic,
"]"
)
}
})
# ENTRIES TAB
# PLOTS
output$plot_main <- renderPlotly({
validate(
need(data$plot_ready, "Choose data & model parameters to continue")
)
do.call(
paste0("plot_", input$plot_dims),
list(
input_info = data$plot_ready$x,
color = isolate(plot_features$appearance$x$color),
pointsize = 12
)
)
})
# update (not redraw) when colours change
observe({
plotlyProxy("plot_main", session) %>%
plotlyProxyInvoke("restyle", list(
marker = list(
size = input$point_size,
color = plot_features$appearance$x$color
)
))
})
# topic barplot (article tab)
output$plot_topics <- renderPlotly({
validate(
need(data$plot_ready, "")
)
plot_topics(
x = data$plot_ready$topic,
n = data$plot_ready$topic$n,
color = plot_features$appearance$topic$color,
source = "topic_plot"
)
})
# CLICK DATA
observe({
click_main <- event_data(
event = "plotly_click",
source = "main_plot"
)$pointNumber + 1 # Note: plotly uses Python-style indexing, hence +1
current_data <- plot_features$appearance$x
click_data$main <- which(data$plot_ready$x[, 1] ==
plot_features$appearance$x$id[click_main])
click_data$topic <- c()
})
observe({
click_topic <- event_data(
event = "plotly_click",
source = "topic_plot"
)$pointNumber + 1
click_data$topic <- which(data$plot_ready$topic$topic ==
plot_features$appearance$topic$topic[click_topic])
click_data$main <- c()
})
# if a topic is selected, highlight points with that topic in the main plot
observeEvent(click_data$topic, {
if(length(click_data$topic) > 0){
current_topic_colors <- rep("#d1d1d180", nrow(data$plot_ready$x))
current_topic_colors[
which(data$plot_ready$x$topic == click_data$topic)
] <- plot_features$palette[click_data$topic]
current_topic_colors[plot_features$appearance$x$color == "#000000"] <- "#000000"
current_topic_colors[plot_features$appearance$x$color == "#CCCCCC"] <- "#CCCCCC"
plot_features$appearance$x$color <- current_topic_colors
}else{
plot_features$appearance <- update_appearance(
plot_data = plot_features$appearance,
palette = plot_features$palette
)
}
})
# SHOW INFO ON CLICKED POINTS
# show selected entry
output$selector_text <- renderPrint({
if(length(click_data$main) > 0){ # i.e. display data for one entry
citation_tr <- format_citation(
data$plot_ready$x[click_data$main, ],
abstract = FALSE,
details = (input$hide_names == FALSE),
add_html = TRUE
)
if(plot_features$common_words){
display_text <- paste0(
"<b>",
citation_tr,
"</b><br><em>Most common words:</em> ",
data$plot_ready$x$common_words[click_data$main]
)
}else{
display_text <- citation_tr
}
cat(paste0(
"<br><font color =",
plot_features$appearance$x$text_color[click_data$main],
">",
display_text,
"</font><br><br>"
))
}else{ # display data for one topic
if(length(click_data$topic) > 0){
cat(
paste0(
"<br><font color =",
plot_features$appearance$x$text_color[click_data$main],
"><b>Topic: ",
click_data$topic,
"</b><br>",
data$plot_ready$topic$caption_full[click_data$topic],
"</font><br><br>"
)
)
}
}
})
# render abstracts
output$abstract_text <- renderPrint({
if(length(click_data$main) == 0){
cat("")
}else{
if(any(colnames(data$plot_ready$x) == "abstract")){
abstract_info <- paste0(
"<br><b>Abstract:</b> ",
data$plot_ready$x$abstract[click_data$main]
)
if(is.na(abstract_info)){
cat("No abstract available")
}else{
cat(abstract_info)
}
}else{
cat("No abstracts available")
}
}
})
# SELECTION/DESELECTION
# show selection options for selected point
output$select_choice <- renderUI({
if((length(click_data$main) > 0 | length(click_data$topic) > 0)){
div(
list(
div(
style = "
display: inline-block;
vertical-align: top;
width: 80px",
actionButton(
inputId = "select_yes",
label = "Select",
style = "
background-color: #7c93c1;
color: #fff;
width: 80px"
)
),
div(
style = "
display: inline-block;
vertical-align: top;
width: 80px",
actionButton(
inputId = "select_no",
label = "Exclude",
style = "
background-color: #c17c7c;
color: #fff;
width: 80px"
)
),
div(
style = "
display: inline-block;
vertical-align: top;
width: 150px",
actionButton(
inputId = "notes_toggle",
label = "Show/Hide Notes",
style = "
background-color: #adadad;
color: #fff;
width: 150px"
)
)
)
)
}
})
# when toggle is triggered, invert display status of notes
observeEvent(input$notes_toggle, {
plot_features$notes <- !plot_features$notes
})
# when requested, show notes
output$render_notes <- renderUI({
if(
plot_features$notes &
(sum(c(click_data$main, click_data$topic)) > 0)
){
if(length(click_data$main) > 0){
selected_response <- data$plot_ready$x[click_data$main, 1]
row <- which(data$raw[which(data$raw$display), input$response_variable] == selected_response)
start_text <- data$raw$notes[row]
}else{
topic_selected <- plot_features$appearance$topic$topic[click_data$topic]
rows <- which(data$raw$topic[which(data$raw$display)] == topic_selected)
unique_text <- unique(data$raw$notes[rows])
start_text <- unique_text[which(is.na(unique_text) == FALSE)]
if(length(start_text) == 0){
start_text <- ""
}else{
start_text <- paste(start_text, collapse = "; ")
}
}
if(is.na(start_text)){
initial_text <- ""
}else{
initial_text <- start_text
}
# add content to screen
div(
list(
br(),
div(
textAreaInput("notes_text",
label = NULL,
value = initial_text,
resize = "vertical",
width = "100%"
)
),
div(
actionButton(
inputId = "notes_save",
label = "Save Notes",
width = "80%"
)
)
)
)
}
})
# SAVE STATUS OF EACH ARTICLE/TOPIC
# when button is clicked, update plot and data as requested
observeEvent(input$select_yes, {
if(length(click_data$main) > 0){ # i.e. point selected on main plot
plot_features$appearance$x$color[click_data$main] <- "#000000"
plot_features$appearance$x$text_color[click_data$main] <- "#405d99" # NEW
selected_response <- data$plot_ready$x[click_data$main, 1]
display_rows <- which(data$raw$display)
selected_rows <- display_rows[
which(data$raw[display_rows, input$response_variable] == selected_response)
]
data$raw$screened_topics[selected_rows] <- "selected"
}else{ # i.e. topic selected on barplot
# color topic plot
topic_selected <- plot_features$appearance$topic$topic[click_data$topic]
plot_features$appearance$topic$color[click_data$topic] <- "#000000"
plot_features$appearance$topic$text_color[click_data$main] <- "#405d99"
# color main plot
rows <- which(data$plot_ready$x$topic == topic_selected)
plot_features$appearance$x$color[rows] <- "#000000"
plot_features$appearance$x$text_color[rows] <- "#405d99"
# map to data$raw
display_rows <- which(data$raw$display)
rows <- display_rows[which(data$raw$topic[display_rows] == topic_selected)]
data$raw$screened_topics[rows] <- "selected"
}
})
observeEvent(input$select_no, {
if(length(click_data$main) > 0){ # i.e. point selected on main plot
plot_features$appearance$x$color[click_data$main] <- "#CCCCCC"
plot_features$appearance$x$text_color[click_data$main] <- "#993f3f"
selected_response <- data$plot_ready$x[click_data$main, 1]
display_rows <- which(data$raw$display)
selected_rows <- display_rows[
which(data$raw[display_rows, input$response_variable] == selected_response)
]
data$raw$screened_topics[selected_rows] <- "excluded"
}else{ # i.e. topic selected on barplot
# color topic plot
topic_selected <- plot_features$appearance$topic$topic[click_data$topic]
plot_features$appearance$topic$color[click_data$topic] <- "#CCCCCC"
plot_features$appearance$topic$text_color[click_data$main] <- "#993f3f"
# color main plot
rows <- which(data$plot_ready$x$topic == topic_selected)
plot_features$appearance$x$color[rows] <- "#CCCCCC"
plot_features$appearance$x$text_color[rows] <- "#993f3f"
# map to data$raw
display_rows <- which(data$raw$display)
rows <- display_rows[which(data$raw$topic[display_rows] == topic_selected)]
data$raw$screened_topics[rows] <- "excluded"
}
})
observeEvent(input$notes_save, {
if(length(click_data$main) > 0){
selected_response <- data$plot_ready$x[click_data$main, 1]
display_rows <- which(data$raw$display)
selected_rows <- display_rows[
which(data$raw[display_rows, input$response_variable] == selected_response)
]
data$raw$notes[selected_rows] <- input$notes_text
}else{ # i.e. topic selected on barplot
topic_selected <- plot_features$appearance$topic$topic[click_data$topic]
display_rows <- which(data$raw$display)
rows <- display_rows[which(data$raw$topic[display_rows] == topic_selected)]
data$raw$notes[rows] <- input$notes_text
}
})
# WORD TAB
# PLOTS
# topic barplot (word tab)
output$plot_topics_2 <- renderPlotly({
validate(
need(data$plot_ready, "")
)
plot_topics(
x = data$plot_ready$topic,
n = data$plot_ready$topic$n,
color = plot_features$appearance$topic$color,
source = "topic_plot_2"
)
})
# word barplot
output$plot_words <- renderPlotly({
validate(
need(data$plot_ready, "Choose data & model parameters to continue"),
need(words$current, "Select a topic to continue")
)
plot_words(
input_info = words$current,
color = plot_features$appearance$y$color[words$rows]
)
})
# get clicks from topic plot
observe({
click_topic_2 <- event_data(
event = "plotly_click",
source = "topic_plot_2"
)$pointNumber + 1
click_data$topic_2 <- which(data$plot_ready$topic$topic ==
plot_features$appearance$topic$topic[click_topic_2])
click_data$word <- c() # should clear currently selected word, but doesn't
if(length(click_topic_2) > 0){
word_rows <- which(data$plot_ready$y$topic == click_data$topic_2)[1:30]
word_data <- data$plot_ready$y[word_rows, ]
word_data$term <- factor(
x = rev(seq_len(30)),
levels = seq_len(30),
labels = rev(word_data$term)
)
words$current <- word_data
words$rows <- word_rows
}else{
words$current <- NULL
words$rows <- NULL
}
})
# click data from word plot
observe({
click_word <- event_data(
event = "plotly_click",
source = "word_plot"
)$pointNumber + 1
click_data$word <- which(
(data$plot_ready$y$topic == click_data$topic_2) &
(data$plot_ready$y$term == words$current$term[click_word])
)
if(length(click_data$word) > 0){
words$selected <- data$plot_ready$y$term[click_data$word]
}else{
words$selected <- NULL
}
})
# WORD SEARCH
observeEvent(input$search_text, {
removeUI(selector = "#search_buttons")
if(nchar(input$search_text) < 1){
words$search_results <- NULL
words$search_clicks <- NULL
}else{
result <- grep(
pattern = input$search_text,
x = colnames(data$dtm)
)
if(length(result) > 0){
result_rows <- result[seq_len(min(c(9, length(result))))]
words$search_results <- colnames(data$dtm)[result_rows]
words$search_clicks <- rep(0, length(result_rows))
insertUI(
selector = "#search_placeholder",
ui = shiny::div(
lapply(
seq_len(length(words$search_results)),
function(a, term){
actionButton(
inputId = paste0("search_", a),
label = term[a]
)
},
term = words$search_results
),
id = "search_buttons"
)
)
}else{
words$search_results <- FALSE
words$search_clicks <- NULL
}
}
})
# write some text that explains current search results
output$search_results <- renderPrint({
if(is.null(words$search_results)){
cat("<em>Enter a word to begin searching</em>")
}else{
if(is.logical(words$search_results)){
cat("<em>No results found</em>")
}else{
cat("Results:<br>")
}
}
})
# search for hits to search result buttons, and select any that are hit
observe({
if(!is.null(words$search_results)){
if(!is.logical(words$search_results)){
lookup_check <- grepl(
"^search_[0-9]",
names(input),
perl = TRUE
)
lookup_names <- names(input)[which(lookup_check)]
lookup_values <- unlist(lapply(
lookup_names,
function(a){input[[a]]}
))
if(any(words$search_clicks != lookup_values)){
words$selected <- words$search_results[
which(words$search_clicks != lookup_values)
]
words$search_clicks <- lookup_values
}
}
}
})
# SELECTION/DESELECTION
# give option to exclude selected word
output$word_selector <- renderUI({
if(!is.null(words$selected)){
actionButton("remove_word",
label = paste0(
"Remove '",
words$selected,
"' from dataset"
),
style = "width: 300px"
)
}
})
observeEvent(input$remove_word, {
if(any(data$stopwords == words$selected) == FALSE){
data$stopwords <- c(data$stopwords, words$selected)
}
if(any(plot_features$appearance$y$id == words$selected)){
row_color <- which(plot_features$appearance$y$id == words$selected)
plot_features$appearance$y$color[row_color] <- "#CCCCCC"
}
})
# SAVE OPTIONS
observeEvent(input$save_data, {
if(is.null(data$raw)){
showModal(
modalDialog(
HTML(
"Import some data to begin<br><br>
<em>Click anywhere to exit</em>"
),
title = "Error: no data to save",
footer = NULL,
easyClose = TRUE
)
)
}else{
showModal(
modalDialog(
selectInput(
inputId = "save_what",
label = "Choose an item to save",
choices = list(
"Save Progress (.rds)" = "progress",
"Save Choices (.csv)" = "choices"
),
multiple = FALSE
),
textInput(
inputId = "save_filename",
label = "File Name"
),
actionButton(
inputId = "save_data_execute",
label = "Save"
),
modalButton("Cancel"),
title = "Save As",
footer = NULL,
easyClose = FALSE
)
)
}
})
observeEvent(input$save_data_execute, {
if(nchar(input$save_filename) == 0){
filename <- "revtools_data"
}else{
if(grepl("\\.[[:lower:]]{3}$", input$save_filename)){
filename <- substr(
input$save_filename, 1,
nchar(input$save_filename) - 4
)
}else{
filename <- input$save_filename
}
}
if(input$save_what == "progress"){
file_extension <- "rds"
}else{
file_extension <- "csv"
}
filename <- paste(filename, file_extension, sep = ".")
switch(input$save_what,
"choices" = {
write.csv(data$raw,
file = filename,
row.names = FALSE
)
},
"progress" = {
output <- list(
raw = data$raw,
stopwords = data$stopwords,
columns = data$columns,
grouped = data$grouped,
dtm = data$dtm,
model = data$model,
plot_ready = data$plot_ready
)
class(output) <- "screen_topics_progress"
saveRDS(
output,
file = filename
)
}
)
removeModal()
})
observeEvent(input$exit_app, {
exit_modal()
})
observeEvent(input$exit_app_confirmed, {
output <- list(
raw = data$raw,
stopwords = data$stopwords,
columns = data$columns,
grouped = data$grouped,
dtm = data$dtm,
model = data$model,
plot_ready = data$plot_ready
)
class(output) <- "screen_topics_progress"
stopApp(returnValue = invisible(output))
})
} # end server
print(shinyApp(ui, server))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.