server.R
In moj-analytical-services/PQTool: Parliamentary Questions Tool
source(file = "global.R")
############### Server
function(input, output, session) {
### Similarity Pane
returnNearestMatches <- reactive({
space <- search.space
foundWords <- which(space$i %in% queryVec(input$question, vocab))
if(length(foundWords)==0){
return("Unable to determine similarity to query")
}
Document <- space$j[foundWords]
vees <- space$v[foundWords]
JayVees <- data.table(Document = Document, vees = vees)
outGroup <- JayVees[,
.("Similarity_score" = sum(vees)),
by = Document ][order(-Similarity_score)]
table_output <- outGroup #[1:30]
data <- merge.data.frame(table_output,
data,
by.x = "Document",
by.y = "Document_Number")
data["Similarity_score"] <- round(data["Similarity_score"], digits = 2)
data <- data[with(data, order(-data["Similarity_score"])), ]
rownames(data) <- 1:nrow(data)
data["Rank"] <- as.numeric(rownames(data))
return(data)
})
df <- reactive({
subset(returnNearestMatches(),
returnNearestMatches()$Date >= input$q_date_range[1] &
returnNearestMatches()$Date <= input$q_date_range[2])
})
plot_points <- reactive({
cols <- c(
'Question_Text',
'Answer_Text',
'Similarity_score',
'Rank',
'Question_MP',
'MP_Party',
'Date',
'Answer_Date',
'Topic',
'Topic_Keywords'
)
tryCatch({
df()[1:100, cols]
}, warning = function(war){
print("warning")
}, error = function(err){
print("Unable to complete query. Try resolving typos or including more search terms.")
}, finally = {
})
})
#using LOESS smoothing we plot a non-parametric curve of best fit for the plotted scatter points, which should
#give an indication of how interest has risen and fallen over time.
line_points <- reactive({
tryCatch({
test <- plot_points()$Similarity_score
}, warning = function(war){
print("warning")
}, error = function(err){
print("error")
}, finally = {
loessThing <- loess(plot_points()$Similarity_score ~ as.numeric(plot_points()$Date), span = 1/exp(1), degree = 2)
Dates <- as.Date(loessThing$x[order(loessThing$x)][-length(loessThing$x)][-1], format="%Y-%m-%d", origin = "1970-01-01")
Scores <- loessThing$fitted[order(loessThing$x)][-length(loessThing$x)][-1]
Scores[Scores < 0] <- 0
return(data.frame(Dates = Dates,
Scores = Scores))
})
})
output$similarity_table <- renderDataTable({
datatable(
cbind(' ' = '⊕', plot_points()), escape = -2,
options = list(
columnDefs = list(
list(visible = FALSE, targets = c(0, 2, 3, 4, 9, 10)),
list(orderable = FALSE, className = 'details-control', targets = 1)
),
deferRender = TRUE,
#scrollY = 400,
scroller = TRUE,
searching = FALSE,
paging = TRUE,
lengthChange = FALSE,
pageLength = 10,
server = FALSE
),
callback = JS("
search_table = table;
table.column(1).nodes().to$().css({cursor: 'pointer'});
table.on('click', 'tr', rowActivate);"
),
caption = "Questions ranked by similarity to search text. Select a row to see the corresponding question text:"
)
})
addPopover(session, "similarity_table", "What does this table show?",
content = paste0("<p> This table shows the past written PQs that are most similar to your search (the most",
" similar questions are at the top). </p><p> You can click any row to see the question text,",
" or reorder the results by clicking on the column headings. </br> </br> All the questions in",
" our database have been grouped into topics by an algorithm and given Topic numbers. Try",
" clicking on the 'View Topic' button to see all the questions . ",
"Analysis\' page.</p>"), trigger = 'hover', placement = 'right', options = list(container = "body"))
y_axis <- list(
title = "Similarity",
autotick = TRUE,
ticks = "",
showticklabels = FALSE,
rangemode = "tozero"
)
output$similarity_plot <- renderPlotly({
gg=plot_ly(x = plot_points()$Date) %>%
#add trend line first so it's the bottom layer
add_trace(x = line_points()$Dates,
y = line_points()$Scores,
name = "Avg. parliamentary interest in search phrase",
type = 'scatter',
mode = 'lines',
line = list( # line is a named list, valid keys: /r/reference/#scatter-line
color = "gray"),
text = NULL,
hoverinfo = "text"
) %>%
add_markers(y = plot_points()$Similarity_score,
name = "Top 100 Qs",
text = ~paste("Rank:", plot_points()$Rank,
"<br> Member HoC/HoL:", plot_points()$Question_MP,
"<br> Date:", plot_points()$Date ),
hoverinfo = "text", marker = list(color = "#67a9cf")
)%>%
layout(yaxis = y_axis,
title = "Top 100 questions most similar to your search",
titlefont=list(
family='Arial',
size=14,
color='#696969')
) %>%
add_trace(x = plot_points()$Date[input$similarity_table_rows_current],
y = plot_points()$Similarity_score[input$similarity_table_rows_current],
name = "Current Table Page",
type = "scatter", mode = 'markers', marker = list(color = "#ef8a62"),
text = ~paste("Rank:", plot_points()$Rank[input$similarity_table_rows_current],
"<br> Member HoC/HoL:", plot_points()$Question_MP[input$similarity_table_rows_current],
"<br> Date:", plot_points()$Date[input$similarity_table_rows_current] ),
hoverinfo = "text"
) %>%
add_trace(x = plot_points()$Date[input$similarity_table_rows_selected],
y = plot_points()$Similarity_score[input$similarity_table_rows_selected],
name = 'Qs selected',
type = "scatter", mode = 'markers', marker = list(size = 12, color = "red"),
text = NULL,
hoverinfo = "text"
) %>%
config(displayModeBar = F) %>%
layout(legend = list(orientation = 'h'))
})
addPopover(session, "similarity_plot", "What does this plot show?",
content = paste0("<p>This graph plots Similarity on the y axis against Time on the x axis.</p><p>",
"Each point represents a past PQ from our database with the height showing ",
"how similar the PQ is to the search terms (higher = more similar). ",
" </p>"), trigger = 'hover', placement = 'left')
observeEvent(
input$tutorial_button, {
introjs(session,
events = list(
"onchange" = I("$('.introjs-nextbutton').css('visibility', 'visible');
step = this._currentStep
prev_selection = $('.selected')
buttonIndices = {6 : 0, 10 : 2, 11 : 1}
if ([6, 10, 11].includes(step)) {
next_button_disabled = true;
$('.introjs-nextbutton').css('visibility', 'hidden');
$('.btn-info')[buttonIndices[step]].addEventListener('mouseup', function(){
setTimeout(function(){
next_button_disabled = false;
$('.introjs-nextbutton').click()
}, 1000)
})
}"),
"onbeforechange" = I("new_selection = $('.selected');
if (this._currentStep == 1) {
question = $('#question');
if(question.val() == '') {
question.val('Prison officers');
Shiny.onInputChange('question', 'Prison officers');
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text(\"We've added some search terms for you, but you can change them if you like.\");
introJs().previousStep();
}
} else if ([3, 10, 15].includes(this._currentStep)) {
if(noChange(new_selection, prev_selection)) {
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text('Please select a row before continuing.');
introJs().previousStep();
}
} else if (this._currentStep == 5) {
if(noChange(new_selection, prev_selection)) {
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text('Please select another point on the graph before continuing.');
introJs().previousStep();
}
} else if (this._currentStep == 7) {
if (next_button_disabled == true) {
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text(\"Please click 'See all questions asked by...' to continue.\");
introJs().previousStep();
}
} else if (this._currentStep == 11) {
if (next_button_disabled == true) {
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text(\"Please click 'Back to search' to continue.\");
introJs().previousStep();
}
} else if (this._currentStep == 12) {
if (next_button_disabled == true) {
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text(\"Please click 'View topic...' to continue.\");
introJs().previousStep();
}
}"),
"onexit" = I("question.val('Prison officers');
Shiny.onInputChange('question', 'Prison officers');
location.reload(true);"
)
),
options = list("nextLabel" = "Next",
"scrollToElement" = FALSE,
"showProgress" = TRUE,
"showBullets" = FALSE,
"keyboardNavigation" = TRUE))
})
### Cluster Pane
dfClus <- function(){
cols <- c(
'Question_Text',
'Answer_Text',
'Question_MP',
'MP_Constituency',
'MP_Party',
'Date',
'Answer_MP',
'Answer_Date'
)
df <- subset(tables_data, (tables_data$Topic == input$topic_choice))
df <- df[order(-as.numeric(df$Date)),]
df[cols]
}
keyword <- reactive({
subset(tables_data, (tables_data$Topic == input$topic_choice))$Topic_Keywords[1]
})
minDate <- min(tables_data$Date)
maxDate <- max(tables_data$Date + 14)
wordcloud_df <- function(){
df <- subset(topic_data,
(topic_data$topic == input$topic_choice))
}
observeEvent(input$explanation_button, {
showModal(modalDialog(
title = "What do the topics mean?",
HTML("We have taken all of the questions in our database and fed them into an algorithm which has
split them into different groups, or 'topics', with each group containing questions related to
similar issues. For each topic there is a set of three 'Topic Keywords' to give an idea of what
the topic is about. <br><br>
Each of these topics have also been assigned a number as a unique identifier. To find
out about your chosen topic, go to the 'Search' tab and, once you have entered your search
terms, just click the question you are focusing on followed by the 'View Topic' button."),
easyClose = TRUE,
footer = NULL
))
})
output$wordcloud <- renderPlot(
wordcloud(words = wordcloud_df()$word, freq = wordcloud_df()$freq,
scale = c(4, 1), random.order = FALSE, rot.per = 0,,
min.freq = 0.1),
width = "auto"
)
addPopover(session, "wordcloud", "Wordcloud",
content = paste0("This wordcloud shows the words that are most important to the topic.<br><br> The bigger the word, the more important it is."),
trigger = 'hover', placement = 'top', options = list(container = "body"))
output$topic_plot <- renderPlot({
# Plot is generated first so that it can be used to grab values for other layers
plot <- ggplot(data = NULL, aes(x = dfClus()$Date)) +
geom_histogram(binwidth = 14, fill = "#67a9cf")
# Now add the other layers
plot +
xlim(min(data$Date) - 1, max(data$Date) + 1) +
scale_x_date(
limits = c(minDate, maxDate),
labels = date_format("%b %y"),
date_breaks = "6 months",
date_minor_breaks = "1 month"
) +
scale_y_continuous(
breaks = seq(0, yMax(plot), yBreaks(plot)),
expand = c(0,0),
limits = c(0, yMax(plot))
) +
labs(
title = paste0("Topic ", input$topic_choice, ": ", keyword()),
subtitle = paste0("Each bar shows the number of questions for topic ", input$topic_choice, " in a particular fortnight"),
x = "Question Date",
y = "Count"
) +
theme(
panel.background = element_rect(fill = "white", colour = "grey"),
panel.grid.minor = element_line(colour = "#efefef"),
panel.grid.major = element_line(colour = "#efefef"),
axis.title = element_text(family = "Arial", size = 14, colour = "#4f4f4f"),
axis.text = element_text(family = "Arial", size = 14),
axis.line = element_line(colour = "grey"),
plot.title = element_text(size = 17, face = "bold", family = "Arial", colour = "#4f4f4f"),
plot.subtitle = element_text(size = 12, family = "Arial", colour = "#4f4f4f")
#axis.ticks.x = element_line(size = 0)
)
})
addPopover(session, "topic_plot", "Questions plotted over time",
content = paste0("This plot shows when questions in the topic were asked. <br><br> Each bar shows the number of questions asked in a particular fortnight - the higher the bar, the more questions from that topic."),
trigger = 'hover', placement = 'left', options = list(container = "body"))
output$topic_documents <- renderDataTable({
datatable(
cbind(' ' = '⊕', dfClus()), escape = -2,
options = list(
columnDefs = list(
list(visible = FALSE, targets = c(0, 2, 3)),
list(orderable = FALSE, className = 'details-control', targets = 1)
),
caption = "Documents contained within the topic:",
deferRender = TRUE,
scroller = TRUE,
searching = FALSE,
paging = TRUE,
lengthChange = FALSE,
pageLength = 10,
server = FALSE
),
callback = JS("
topic_table = table;
table.column(1).nodes().to$().css({cursor: 'pointer'});
table.on('click', 'tr', rowActivate);"
)
)
# datatable(data = dfClus(), #[, c("Question_Text", "Answer_Text")],
# #colnames = c("Question Text", "Answer Text"),
# caption = "Documents contained within the topic:",
# extensions = 'Buttons',
# rownames = FALSE,
# options = list(dom = 'Bfrtip',
# buttons = I('colvis'),
# scroller = TRUE,
# searching = FALSE,
# paging = TRUE,
# lengthChange = FALSE,
# pageLength = 5))
})
addPopover(session, "topic_documents", "Questions in the topic",
content = paste0("This table contains all of the information on the questions asked on this topic.<br><br>",
"Click on a row to see the corresponding question and answer text."),
trigger = 'hover', placement = 'top', options = list(container = "body"))
### Q&A Analysis Pane
# Each item in hoc_members must be a list to achieve the desired effect in the hoc members dropdown
list_if_one <- function(members) {
if(length(members) == 1) {
return(list(members))
} else {
return(members)
}
}
# Merge labur and labour (co-op) members for the sake of the drop down list (only)
merge_labour_and_co_op <- function(members) {
members$Labour <- append(members$Labour, members$'Labour (Co-op)') %>% sort()
members$'Labour (Co-op)' <- NULL
members
}
hoc_members <- function(data) {
parties <- data$MP_Party[ data$MP_Party != 'Not found' ] %>%
unique() %>%
sort()
members <- lapply(parties, function(party) {
data$Question_MP[ data$MP_Party == party ] %>%
unique() %>%
sort() %>%
list_if_one()
})
names(members) <- parties
merge_labour_and_co_op(members)
}
output$member_ui <- renderUI({
switch(input$member_analysis,
"Lords" = selectInput(inputId = "person_choice",
label = "Choose a Peer:",
choices = sort(unique(data$Question_MP[ grepl("HL", data$Question_ID) ]))
),
"Commons" = selectInput(inputId = "person_choice",
label = "Choose an MP:",
choices = hoc_members(data)
)
)
})
grouped_hoc_members <- function(hoc_data) {
}
dfMP <- function(){
df <- subset(tables_data, (tables_data$Question_MP == input$person_choice))
df <- df[order(-as.numeric(df$Date)),]
cols <- c(
'Question_Text',
'Answer_Text',
'Question_MP',
'MP_Constituency',
'MP_Party',
'Date',
'Answer_MP',
'Answer_Date',
'Topic',
'Topic_Keywords'
)
df[cols]
}
minDate <- min(tables_data$Date)
maxDate <- max(tables_data$Date + 14)
member_wordcloud_df <- function(){
df <- subset(member_data,
(member_data$member == input$person_choice))
}
output$member_wordcloud <- renderPlot(
wordcloud(words = member_wordcloud_df()$word, freq = member_wordcloud_df()$freq,
scale = c(4, 1), random.order = FALSE, rot.per = 0,
min.freq = 0.1),
width = "auto"
)
linkText <- reactive({
paste0("TheyWorkForYouPage for ",
input$person_choice)
})
linkURL <- reactive({
paste0("https://www.theyworkforyou.com/",
if(input$member_analysis=="Commons"){
"mp/"
} else {
"peer/"
},
urlName(input$person_choice)
)
})
output$memberlink <- renderUI({
tags$a(href = linkURL(), target="_blank", linkText())
})
addPopover(session, "member_wordcloud", "Wordcloud",
content = paste0("This wordcloud shows the words that are most important in the questions asked by this
member.<br><br> The bigger the word, the more important it is."),
trigger = 'hover', placement = 'top', options = list(container = "body"))
output$member_plot <- renderPlot({
p <- ggplot(data = NULL, aes(x = dfMP()$Date, y = )) + geom_histogram(binwidth = 14, fill = "#67a9cf")
maxCount <- ggplot_build(p)$data[[1]]$count %>% max() #max value of the histogram
yBreaks <- if(maxCount < 11) {
1
} else if(maxCount < 21){
2
} else {
5
}
yMax <- (floor(maxCount / yBreaks) + 1) * yBreaks
p +
xlim(min(data$Date) - 1, max(data$Date) + 1) +
scale_x_date(limits = c(minDate, maxDate),
labels = date_format("%b %y"),
date_breaks = "6 months",
date_minor_breaks = "1 month") +
scale_y_continuous(
breaks = seq(0, yMax, yBreaks),
expand = c(0,0),
limits = c(0, yMax)) +
labs(title = member_plot_title(input$person_choice, data),
subtitle = paste0("Each bar shows the number of questions from ", input$person_choice, " in a particular fortnight"),
x = "Question Date",
y = "Count"
) +
theme(panel.background = element_rect(fill = "white", colour = "grey"),
panel.grid.minor = element_line(colour = "#efefef"),
panel.grid.major = element_line(colour = "#efefef"),
axis.title = element_text(family = "Arial", size = 14, colour = "#4f4f4f"),
axis.text = element_text(family = "Arial", size = 14),
axis.line = element_line(colour = "grey"),
plot.title = element_text(size = 17, face = "bold", family = "Arial", colour = "#4f4f4f"),
plot.subtitle = element_text(size = 12, family = "Arial", colour = "#4f4f4f")
#axis.ticks.x = element_line(size = 0)
)
})
member_plot_title <- function(selected_member, data) {
party = data$MP_Party[ data$Question_MP == selected_member ]
constituency = data$MP_Constituency[ data$Question_MP == selected_member ]
if(party == 'Not found') {
selected_member
} else {
paste0(selected_member, ' - ', party, ' - ', constituency)
}
}
addPopover(session, "member_plot", "Questions plotted over time",
content = paste0("This plot shows when the selected MP/peer tabled written questions <br><br> Each bar shows the number of questions tabled by the MP/peer in a particular fortnight - the higher the bar, the more questions."),
trigger = 'hover', placement = 'left', options = list(container = "body"))
output$member_table <- renderDataTable({
datatable(
cbind(' ' = '⊕', dfMP()), escape = -2,
options = list(
columnDefs = list(
list(visible = FALSE, targets = c(0, 2, 3, 4, 5, 6)),
list(orderable = FALSE, className = 'details-control', targets = 1)
),
caption = "Documents contained within the topic:",
deferRender = TRUE,
scroller = TRUE,
searching = FALSE,
paging = TRUE,
lengthChange = FALSE,
pageLength = 10,
server = FALSE
),
callback = JS("
member_table = table;
table.column(1).nodes().to$().css({cursor: 'pointer'});
table.on('click', 'tr', rowActivate);"
)
)
})
addPopover(session, "member_table", "Questions asked by the member",
content = paste0("This table contains all of the information on the questions asked by this member.<br><br>",
"Click on a row to see the corresponding question and answer text."),
trigger = 'hover', placement = 'top', options = list(container = "body"))
}
moj-analytical-services/PQTool documentation built on June 12, 2021, 5:31 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
source(file = "global.R")
############### Server
function(input, output, session) {
### Similarity Pane
returnNearestMatches <- reactive({
space <- search.space
foundWords <- which(space$i %in% queryVec(input$question, vocab))
if(length(foundWords)==0){
return("Unable to determine similarity to query")
}
Document <- space$j[foundWords]
vees <- space$v[foundWords]
JayVees <- data.table(Document = Document, vees = vees)
outGroup <- JayVees[,
.("Similarity_score" = sum(vees)),
by = Document ][order(-Similarity_score)]
table_output <- outGroup #[1:30]
data <- merge.data.frame(table_output,
data,
by.x = "Document",
by.y = "Document_Number")
data["Similarity_score"] <- round(data["Similarity_score"], digits = 2)
data <- data[with(data, order(-data["Similarity_score"])), ]
rownames(data) <- 1:nrow(data)
data["Rank"] <- as.numeric(rownames(data))
return(data)
})
df <- reactive({
subset(returnNearestMatches(),
returnNearestMatches()$Date >= input$q_date_range[1] &
returnNearestMatches()$Date <= input$q_date_range[2])
})
plot_points <- reactive({
cols <- c(
'Question_Text',
'Answer_Text',
'Similarity_score',
'Rank',
'Question_MP',
'MP_Party',
'Date',
'Answer_Date',
'Topic',
'Topic_Keywords'
)
tryCatch({
df()[1:100, cols]
}, warning = function(war){
print("warning")
}, error = function(err){
print("Unable to complete query. Try resolving typos or including more search terms.")
}, finally = {
})
})
#using LOESS smoothing we plot a non-parametric curve of best fit for the plotted scatter points, which should
#give an indication of how interest has risen and fallen over time.
line_points <- reactive({
tryCatch({
test <- plot_points()$Similarity_score
}, warning = function(war){
print("warning")
}, error = function(err){
print("error")
}, finally = {
loessThing <- loess(plot_points()$Similarity_score ~ as.numeric(plot_points()$Date), span = 1/exp(1), degree = 2)
Dates <- as.Date(loessThing$x[order(loessThing$x)][-length(loessThing$x)][-1], format="%Y-%m-%d", origin = "1970-01-01")
Scores <- loessThing$fitted[order(loessThing$x)][-length(loessThing$x)][-1]
Scores[Scores < 0] <- 0
return(data.frame(Dates = Dates,
Scores = Scores))
})
})
output$similarity_table <- renderDataTable({
datatable(
cbind(' ' = '⊕', plot_points()), escape = -2,
options = list(
columnDefs = list(
list(visible = FALSE, targets = c(0, 2, 3, 4, 9, 10)),
list(orderable = FALSE, className = 'details-control', targets = 1)
),
deferRender = TRUE,
#scrollY = 400,
scroller = TRUE,
searching = FALSE,
paging = TRUE,
lengthChange = FALSE,
pageLength = 10,
server = FALSE
),
callback = JS("
search_table = table;
table.column(1).nodes().to$().css({cursor: 'pointer'});
table.on('click', 'tr', rowActivate);"
),
caption = "Questions ranked by similarity to search text. Select a row to see the corresponding question text:"
)
})
addPopover(session, "similarity_table", "What does this table show?",
content = paste0("<p> This table shows the past written PQs that are most similar to your search (the most",
" similar questions are at the top). </p><p> You can click any row to see the question text,",
" or reorder the results by clicking on the column headings. </br> </br> All the questions in",
" our database have been grouped into topics by an algorithm and given Topic numbers. Try",
" clicking on the 'View Topic' button to see all the questions . ",
"Analysis\' page.</p>"), trigger = 'hover', placement = 'right', options = list(container = "body"))
y_axis <- list(
title = "Similarity",
autotick = TRUE,
ticks = "",
showticklabels = FALSE,
rangemode = "tozero"
)
output$similarity_plot <- renderPlotly({
gg=plot_ly(x = plot_points()$Date) %>%
#add trend line first so it's the bottom layer
add_trace(x = line_points()$Dates,
y = line_points()$Scores,
name = "Avg. parliamentary interest in search phrase",
type = 'scatter',
mode = 'lines',
line = list( # line is a named list, valid keys: /r/reference/#scatter-line
color = "gray"),
text = NULL,
hoverinfo = "text"
) %>%
add_markers(y = plot_points()$Similarity_score,
name = "Top 100 Qs",
text = ~paste("Rank:", plot_points()$Rank,
"<br> Member HoC/HoL:", plot_points()$Question_MP,
"<br> Date:", plot_points()$Date ),
hoverinfo = "text", marker = list(color = "#67a9cf")
)%>%
layout(yaxis = y_axis,
title = "Top 100 questions most similar to your search",
titlefont=list(
family='Arial',
size=14,
color='#696969')
) %>%
add_trace(x = plot_points()$Date[input$similarity_table_rows_current],
y = plot_points()$Similarity_score[input$similarity_table_rows_current],
name = "Current Table Page",
type = "scatter", mode = 'markers', marker = list(color = "#ef8a62"),
text = ~paste("Rank:", plot_points()$Rank[input$similarity_table_rows_current],
"<br> Member HoC/HoL:", plot_points()$Question_MP[input$similarity_table_rows_current],
"<br> Date:", plot_points()$Date[input$similarity_table_rows_current] ),
hoverinfo = "text"
) %>%
add_trace(x = plot_points()$Date[input$similarity_table_rows_selected],
y = plot_points()$Similarity_score[input$similarity_table_rows_selected],
name = 'Qs selected',
type = "scatter", mode = 'markers', marker = list(size = 12, color = "red"),
text = NULL,
hoverinfo = "text"
) %>%
config(displayModeBar = F) %>%
layout(legend = list(orientation = 'h'))
})
addPopover(session, "similarity_plot", "What does this plot show?",
content = paste0("<p>This graph plots Similarity on the y axis against Time on the x axis.</p><p>",
"Each point represents a past PQ from our database with the height showing ",
"how similar the PQ is to the search terms (higher = more similar). ",
" </p>"), trigger = 'hover', placement = 'left')
observeEvent(
input$tutorial_button, {
introjs(session,
events = list(
"onchange" = I("$('.introjs-nextbutton').css('visibility', 'visible');
step = this._currentStep
prev_selection = $('.selected')
buttonIndices = {6 : 0, 10 : 2, 11 : 1}
if ([6, 10, 11].includes(step)) {
next_button_disabled = true;
$('.introjs-nextbutton').css('visibility', 'hidden');
$('.btn-info')[buttonIndices[step]].addEventListener('mouseup', function(){
setTimeout(function(){
next_button_disabled = false;
$('.introjs-nextbutton').click()
}, 1000)
})
}"),
"onbeforechange" = I("new_selection = $('.selected');
if (this._currentStep == 1) {
question = $('#question');
if(question.val() == '') {
question.val('Prison officers');
Shiny.onInputChange('question', 'Prison officers');
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text(\"We've added some search terms for you, but you can change them if you like.\");
introJs().previousStep();
}
} else if ([3, 10, 15].includes(this._currentStep)) {
if(noChange(new_selection, prev_selection)) {
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text('Please select a row before continuing.');
introJs().previousStep();
}
} else if (this._currentStep == 5) {
if(noChange(new_selection, prev_selection)) {
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text('Please select another point on the graph before continuing.');
introJs().previousStep();
}
} else if (this._currentStep == 7) {
if (next_button_disabled == true) {
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text(\"Please click 'See all questions asked by...' to continue.\");
introJs().previousStep();
}
} else if (this._currentStep == 11) {
if (next_button_disabled == true) {
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text(\"Please click 'Back to search' to continue.\");
introJs().previousStep();
}
} else if (this._currentStep == 12) {
if (next_button_disabled == true) {
this._currentStep = this._currentStep - 1;
$('.introjs-tooltiptext').text(\"Please click 'View topic...' to continue.\");
introJs().previousStep();
}
}"),
"onexit" = I("question.val('Prison officers');
Shiny.onInputChange('question', 'Prison officers');
location.reload(true);"
)
),
options = list("nextLabel" = "Next",
"scrollToElement" = FALSE,
"showProgress" = TRUE,
"showBullets" = FALSE,
"keyboardNavigation" = TRUE))
})
### Cluster Pane
dfClus <- function(){
cols <- c(
'Question_Text',
'Answer_Text',
'Question_MP',
'MP_Constituency',
'MP_Party',
'Date',
'Answer_MP',
'Answer_Date'
)
df <- subset(tables_data, (tables_data$Topic == input$topic_choice))
df <- df[order(-as.numeric(df$Date)),]
df[cols]
}
keyword <- reactive({
subset(tables_data, (tables_data$Topic == input$topic_choice))$Topic_Keywords[1]
})
minDate <- min(tables_data$Date)
maxDate <- max(tables_data$Date + 14)
wordcloud_df <- function(){
df <- subset(topic_data,
(topic_data$topic == input$topic_choice))
}
observeEvent(input$explanation_button, {
showModal(modalDialog(
title = "What do the topics mean?",
HTML("We have taken all of the questions in our database and fed them into an algorithm which has
split them into different groups, or 'topics', with each group containing questions related to
similar issues. For each topic there is a set of three 'Topic Keywords' to give an idea of what
the topic is about. <br><br>
Each of these topics have also been assigned a number as a unique identifier. To find
out about your chosen topic, go to the 'Search' tab and, once you have entered your search
terms, just click the question you are focusing on followed by the 'View Topic' button."),
easyClose = TRUE,
footer = NULL
))
})
output$wordcloud <- renderPlot(
wordcloud(words = wordcloud_df()$word, freq = wordcloud_df()$freq,
scale = c(4, 1), random.order = FALSE, rot.per = 0,,
min.freq = 0.1),
width = "auto"
)
addPopover(session, "wordcloud", "Wordcloud",
content = paste0("This wordcloud shows the words that are most important to the topic.<br><br> The bigger the word, the more important it is."),
trigger = 'hover', placement = 'top', options = list(container = "body"))
output$topic_plot <- renderPlot({
# Plot is generated first so that it can be used to grab values for other layers
plot <- ggplot(data = NULL, aes(x = dfClus()$Date)) +
geom_histogram(binwidth = 14, fill = "#67a9cf")
# Now add the other layers
plot +
xlim(min(data$Date) - 1, max(data$Date) + 1) +
scale_x_date(
limits = c(minDate, maxDate),
labels = date_format("%b %y"),
date_breaks = "6 months",
date_minor_breaks = "1 month"
) +
scale_y_continuous(
breaks = seq(0, yMax(plot), yBreaks(plot)),
expand = c(0,0),
limits = c(0, yMax(plot))
) +
labs(
title = paste0("Topic ", input$topic_choice, ": ", keyword()),
subtitle = paste0("Each bar shows the number of questions for topic ", input$topic_choice, " in a particular fortnight"),
x = "Question Date",
y = "Count"
) +
theme(
panel.background = element_rect(fill = "white", colour = "grey"),
panel.grid.minor = element_line(colour = "#efefef"),
panel.grid.major = element_line(colour = "#efefef"),
axis.title = element_text(family = "Arial", size = 14, colour = "#4f4f4f"),
axis.text = element_text(family = "Arial", size = 14),
axis.line = element_line(colour = "grey"),
plot.title = element_text(size = 17, face = "bold", family = "Arial", colour = "#4f4f4f"),
plot.subtitle = element_text(size = 12, family = "Arial", colour = "#4f4f4f")
#axis.ticks.x = element_line(size = 0)
)
})
addPopover(session, "topic_plot", "Questions plotted over time",
content = paste0("This plot shows when questions in the topic were asked. <br><br> Each bar shows the number of questions asked in a particular fortnight - the higher the bar, the more questions from that topic."),
trigger = 'hover', placement = 'left', options = list(container = "body"))
output$topic_documents <- renderDataTable({
datatable(
cbind(' ' = '⊕', dfClus()), escape = -2,
options = list(
columnDefs = list(
list(visible = FALSE, targets = c(0, 2, 3)),
list(orderable = FALSE, className = 'details-control', targets = 1)
),
caption = "Documents contained within the topic:",
deferRender = TRUE,
scroller = TRUE,
searching = FALSE,
paging = TRUE,
lengthChange = FALSE,
pageLength = 10,
server = FALSE
),
callback = JS("
topic_table = table;
table.column(1).nodes().to$().css({cursor: 'pointer'});
table.on('click', 'tr', rowActivate);"
)
)
# datatable(data = dfClus(), #[, c("Question_Text", "Answer_Text")],
# #colnames = c("Question Text", "Answer Text"),
# caption = "Documents contained within the topic:",
# extensions = 'Buttons',
# rownames = FALSE,
# options = list(dom = 'Bfrtip',
# buttons = I('colvis'),
# scroller = TRUE,
# searching = FALSE,
# paging = TRUE,
# lengthChange = FALSE,
# pageLength = 5))
})
addPopover(session, "topic_documents", "Questions in the topic",
content = paste0("This table contains all of the information on the questions asked on this topic.<br><br>",
"Click on a row to see the corresponding question and answer text."),
trigger = 'hover', placement = 'top', options = list(container = "body"))
### Q&A Analysis Pane
# Each item in hoc_members must be a list to achieve the desired effect in the hoc members dropdown
list_if_one <- function(members) {
if(length(members) == 1) {
return(list(members))
} else {
return(members)
}
}
# Merge labur and labour (co-op) members for the sake of the drop down list (only)
merge_labour_and_co_op <- function(members) {
members$Labour <- append(members$Labour, members$'Labour (Co-op)') %>% sort()
members$'Labour (Co-op)' <- NULL
members
}
hoc_members <- function(data) {
parties <- data$MP_Party[ data$MP_Party != 'Not found' ] %>%
unique() %>%
sort()
members <- lapply(parties, function(party) {
data$Question_MP[ data$MP_Party == party ] %>%
unique() %>%
sort() %>%
list_if_one()
})
names(members) <- parties
merge_labour_and_co_op(members)
}
output$member_ui <- renderUI({
switch(input$member_analysis,
"Lords" = selectInput(inputId = "person_choice",
label = "Choose a Peer:",
choices = sort(unique(data$Question_MP[ grepl("HL", data$Question_ID) ]))
),
"Commons" = selectInput(inputId = "person_choice",
label = "Choose an MP:",
choices = hoc_members(data)
)
)
})
grouped_hoc_members <- function(hoc_data) {
}
dfMP <- function(){
df <- subset(tables_data, (tables_data$Question_MP == input$person_choice))
df <- df[order(-as.numeric(df$Date)),]
cols <- c(
'Question_Text',
'Answer_Text',
'Question_MP',
'MP_Constituency',
'MP_Party',
'Date',
'Answer_MP',
'Answer_Date',
'Topic',
'Topic_Keywords'
)
df[cols]
}
minDate <- min(tables_data$Date)
maxDate <- max(tables_data$Date + 14)
member_wordcloud_df <- function(){
df <- subset(member_data,
(member_data$member == input$person_choice))
}
output$member_wordcloud <- renderPlot(
wordcloud(words = member_wordcloud_df()$word, freq = member_wordcloud_df()$freq,
scale = c(4, 1), random.order = FALSE, rot.per = 0,
min.freq = 0.1),
width = "auto"
)
linkText <- reactive({
paste0("TheyWorkForYouPage for ",
input$person_choice)
})
linkURL <- reactive({
paste0("https://www.theyworkforyou.com/",
if(input$member_analysis=="Commons"){
"mp/"
} else {
"peer/"
},
urlName(input$person_choice)
)
})
output$memberlink <- renderUI({
tags$a(href = linkURL(), target="_blank", linkText())
})
addPopover(session, "member_wordcloud", "Wordcloud",
content = paste0("This wordcloud shows the words that are most important in the questions asked by this
member.<br><br> The bigger the word, the more important it is."),
trigger = 'hover', placement = 'top', options = list(container = "body"))
output$member_plot <- renderPlot({
p <- ggplot(data = NULL, aes(x = dfMP()$Date, y = )) + geom_histogram(binwidth = 14, fill = "#67a9cf")
maxCount <- ggplot_build(p)$data[[1]]$count %>% max() #max value of the histogram
yBreaks <- if(maxCount < 11) {
1
} else if(maxCount < 21){
2
} else {
5
}
yMax <- (floor(maxCount / yBreaks) + 1) * yBreaks
p +
xlim(min(data$Date) - 1, max(data$Date) + 1) +
scale_x_date(limits = c(minDate, maxDate),
labels = date_format("%b %y"),
date_breaks = "6 months",
date_minor_breaks = "1 month") +
scale_y_continuous(
breaks = seq(0, yMax, yBreaks),
expand = c(0,0),
limits = c(0, yMax)) +
labs(title = member_plot_title(input$person_choice, data),
subtitle = paste0("Each bar shows the number of questions from ", input$person_choice, " in a particular fortnight"),
x = "Question Date",
y = "Count"
) +
theme(panel.background = element_rect(fill = "white", colour = "grey"),
panel.grid.minor = element_line(colour = "#efefef"),
panel.grid.major = element_line(colour = "#efefef"),
axis.title = element_text(family = "Arial", size = 14, colour = "#4f4f4f"),
axis.text = element_text(family = "Arial", size = 14),
axis.line = element_line(colour = "grey"),
plot.title = element_text(size = 17, face = "bold", family = "Arial", colour = "#4f4f4f"),
plot.subtitle = element_text(size = 12, family = "Arial", colour = "#4f4f4f")
#axis.ticks.x = element_line(size = 0)
)
})
member_plot_title <- function(selected_member, data) {
party = data$MP_Party[ data$Question_MP == selected_member ]
constituency = data$MP_Constituency[ data$Question_MP == selected_member ]
if(party == 'Not found') {
selected_member
} else {
paste0(selected_member, ' - ', party, ' - ', constituency)
}
}
addPopover(session, "member_plot", "Questions plotted over time",
content = paste0("This plot shows when the selected MP/peer tabled written questions <br><br> Each bar shows the number of questions tabled by the MP/peer in a particular fortnight - the higher the bar, the more questions."),
trigger = 'hover', placement = 'left', options = list(container = "body"))
output$member_table <- renderDataTable({
datatable(
cbind(' ' = '⊕', dfMP()), escape = -2,
options = list(
columnDefs = list(
list(visible = FALSE, targets = c(0, 2, 3, 4, 5, 6)),
list(orderable = FALSE, className = 'details-control', targets = 1)
),
caption = "Documents contained within the topic:",
deferRender = TRUE,
scroller = TRUE,
searching = FALSE,
paging = TRUE,
lengthChange = FALSE,
pageLength = 10,
server = FALSE
),
callback = JS("
member_table = table;
table.column(1).nodes().to$().css({cursor: 'pointer'});
table.on('click', 'tr', rowActivate);"
)
)
})
addPopover(session, "member_table", "Questions asked by the member",
content = paste0("This table contains all of the information on the questions asked by this member.<br><br>",
"Click on a row to see the corresponding question and answer text."),
trigger = 'hover', placement = 'top', options = list(container = "body"))
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.