Skip to content

Instantly share code, notes, and snippets.

@tts tts/global.R
Last active Jan 16, 2018

Embed
What would you like to do?
Shiny application on visualizing text-mining outputs of REF2014 impact case studies
library(shiny)
library(shinydashboard)
library(dplyr)
library(tidyr)
library(ggvis)
library(DT)
library(d3heatmap)
load("ref2014impact.Rda")
# Thresholds for rendering
relThr <- 0.850
sentThr <- 0.850
# Credits image
alchemyapi.image <- "alchemyAPI.png"
# names(kw.df)
#
#[1] "id" "UnitOfA" "University" "Title" "Keyword" "Relevance" "SentimentScore"
#[8] "SentimentType" "Unique_Keywords"
# Process sentiment data for heatmap
sentStat <- kw.df %>%
group_by(UnitOfA, SentimentType) %>%
summarise(n = n()) %>%
mutate(Procent = round((n / sum(n))*100, digits = 2)) %>%
group_by(SentimentType, Procent) %>%
arrange(SentimentType, desc(Procent)) %>%
select(-n) %>%
spread(key = SentimentType, value = Procent)
rownames(sentStat) <- sentStat$UnitOfA
sentStat <- sentStat %>%
select(-UnitOfA)
function(input, output, session) {
unis <- reactive({
if (!is.null(input$unit) && nrow(kw.df) > 0) {
univWithThisUnit <- kw.df %>%
filter(UnitOfA == input$unit)
}
})
univCount <- reactive({
if (!is.null(unis())) {
length(unique(unis()$University))
}
})
studyCount <- reactive({
if (!is.null(unis())) {
length(unique(unis()$id))
}
})
kwCount <- reactive({
if (!is.null(unis())) {
length(unique(unis()$Keyword))
}
})
kwMean <- reactive({
if (!is.null(unis())) {
round(mean(unis()$Relevance), digits = 3)
}
})
negSentProc <- reactive({
if (!is.null(unis())) {
paste0(round((nrow(unis()[unis()$SentimentType == 'negative',]) / nrow(unis())) * 100, digits=1), "%")
}
})
posSentProc <- reactive({
if (!is.null(unis())) {
paste0(round((nrow(unis()[unis()$SentimentType == 'positive',]) / nrow(unis())) * 100, digits=1), "%")
}
})
neutSentProc <- reactive({
if (!is.null(unis())) {
paste0(round((nrow(unis()[unis()$SentimentType == 'neutral',]) / nrow(unis())) * 100, digits=1), "%")
}
})
output$universitycount <- renderInfoBox({
infoBox(
value = univCount(),
title = "Institutions",
icon = icon("institution"),
color = if (univCount() >= 200) "orange" else "aqua",
fill = TRUE
)
})
output$studycount <- renderInfoBox({
infoBox(
value = studyCount(),
title = "Case studies",
icon = icon("bar-chart"),
fill = TRUE
)
})
output$keywordcount <- renderInfoBox({
infoBox(
value = paste(kwCount(), kwMean(), sep = " / "),
title = "Unique keywords / relevance mean",
icon = icon("language"),
fill = TRUE
)
})
output$keywordSentNeg <- renderInfoBox({
infoBox(
value = negSentProc(),
title = "Negative keywords",
icon = icon("arrow-down"),
color = "blue"
)
})
output$keywordSentPos <- renderInfoBox({
infoBox(
value = posSentProc(),
title = "Positive keywords",
icon = icon("arrow-up"),
color = "green"
)
})
output$keywordSentNeu <- renderInfoBox({
infoBox(
value = neutSentProc(),
title = "Neutral keywords",
icon = icon("arrow-right"),
color = "orange"
)
})
# See http://127.0.0.1:29528/library/xtable/html/xtable.html for digits
output$kwTable <- renderTable({
ut <- data.frame(
Keyword = unis()$Keyword,
Relevance = unis()$Relevance,
stringsAsFactors=FALSE
)
ut$Relevance <- as.double(ut$Relevance)
ut %>%
filter(Relevance >= relThr) %>%
arrange(desc(Relevance), Keyword) %>%
head(20)
}, digits = 3, include.rownames = FALSE)
output$sentTable <- renderTable({
ut <- data.frame(
Keyword = unis()$Keyword,
Score = unis()$SentimentScore,
stringsAsFactors=FALSE
)
ut$Score <- as.double(ut$Score)
ut %>%
filter(Score >= sentThr) %>%
arrange(desc(Score), Keyword) %>%
head(20)
}, digits = 3, include.rownames = FALSE)
output$datatable <- DT::renderDataTable({
baseurl <- "http://impact.ref.ac.uk/CaseStudies/CaseStudy.aspx?Id="
tb <- unis()
tb$id <- lapply(tb$id, function(x) paste0("<a href=\"", baseurl, x, "\">", x, "</a>"))
tb <- tb %>%
group_by(University, Keyword, Relevance)
tb
}, options = list(
pageLength = 10
))
output$heat <- renderD3heatmap({
d3heatmap(sentStat, scale = "column", dendrogram = "none", colors = "YlOrBr",
xaxis_height = 60, yaxis_width = 500,
xaxis_font_size = "8pt")
})
output$alchemyAPI <- renderImage({
list(src = alchemyapi.image,
contentType = 'image/png',
width = 259,
height = 64,
alt = "AlchemyAPI")
}, deleteFile = FALSE)
kw_tooltip <- function(x) {
if (is.null(x)) return(NULL)
if (is.null(x$id)) return(NULL)
# Pick out the keyword with this ID
all_unis <- isolate(unis())
uni <- all_unis[all_unis$id == x$id & all_unis$Relevance == x$Relevance, ]
paste0(uni$Keyword, "<br>",
"<b>", uni$University, "</b><br>",
"ID: ", uni$id, "<br>")
}
vis <- reactive({
visdf <- unis()
visdf$Type <- factor(visdf$SentimentType)
xvar_name <- paste0("Relevance (min ", relThr, ")")
yvar_name <- "Sentiment score"
xvar <- ~Relevance
yvar <- ~SentimentScore
visdf %>%
filter(Relevance >= relThr) %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size := 50,
fill = ~Type,
size.hover := 200,
fillOpacity := 0.7,
fillOpacity.hover := 0.5,
key := ~id) %>%
add_tooltip(kw_tooltip, "hover") %>%
add_axis("x", title = xvar_name) %>%
add_axis("y", title = yvar_name) %>%
set_options(width = "500px")
})
vis %>% bind_shiny("plot")
}
sidebar <- dashboardSidebar(
selectizeInput(
inputId = "unit",
label = "Unit of Assessment",
multiple = F,
choices = sort(unique(kw.df$UnitOfA))
),
sidebarMenu(
menuItem("Overview", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Data by Unit of Assessment", tabName = "dt", icon = icon("th")),
menuItem("Sentiment analysis stats", tabName = "sdt", icon = icon("area-chart"))
),
HTML("<p><a href=\"http://impact.ref.ac.uk/CaseStudies/\">Impact case study data by REF2014</a> <a href=\"https://creativecommons.org/licenses/by/4.0/\">(License)</a></p>"),
HTML("<p><a href=\"http://www.alchemyapi.com/\">Text Analysis by AlchemyAPI</a></p>"),
imageOutput("alchemyAPI", height = "200px"),
HTML("<p><a href=\"https://blogs.aalto.fi/suoritin/2015/06/30/looking-at-keywords-in-ref2014-impact-case-studies\">Fore more info, see this blog posting</a></p>"),
width = "258"
)
body <- dashboardBody(
tabItems(
tabItem("dashboard",
fluidRow(
# Number of case studies
infoBoxOutput("studycount", width = 4),
# Number of universities
infoBoxOutput("universitycount", width = 4),
# Number of unique keywords
infoBoxOutput("keywordcount", width = 4)
),
fluidRow(
# Keyword sentiment
infoBoxOutput("keywordSentPos", width = 4),
infoBoxOutput("keywordSentNeu", width = 4),
infoBoxOutput("keywordSentNeg", width = 4)
),
fluidRow(
box(
width = 6,
status = "info", solidHeader = TRUE,
title = "Keyword relevance and sentiment",
ggvisOutput("plot")
),
box(
width = 3,
status = "success",
title = "Top 20 keywords by relevance",
tableOutput("kwTable")
),
box(
width = 3,
status = "success",
title = "Top 20 positive keywords",
tableOutput("sentTable")
)
)
),
# Data by UnitOfA
tabItem("dt",
DT::dataTableOutput("datatable")
),
# Sentiment analysis statistics as a heatmap (not reactive)
tabItem("sdt",
d3heatmapOutput("heat")
)
)
)
dashboardPage(
skin = "black",
dashboardHeader(title = "Keywords of REF2014 impact case studies",
titleWidth = "500"),
sidebar,
body
)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.