Altmetric Top100 2015 data as an R Shiny web app

global.R

library(dplyr)
library(XLConnect)
library(shiny)
library(shinydashboard)
library(d3heatmap)

# See https://ttso.shinyapps.io/altm2015top100

# Read in Altmetric data and merge affiliation data with ID
wb <- loadWorkbook("altmetrictop1002015.xlsx")
top <- readWorksheet(wb, sheet = "Top 100", header = TRUE)
aff <- readWorksheet(wb, sheet = "Institutional affiliations", header = TRUE)
top_aff <- merge(top, aff, by.x = "id", by.y = "altmetric_id")

# Correction: States -> United States
top_aff$country[top_aff$country == "States"] <- "United States"

# Sorted list of country names, for selection
countries <- sort(unique(aff$country))

# Data for heatmap by category
top100 <- top %>%
  group_by(categories) %>%
  summarise(score = round(mean(score), digits=2),
            news = round(mean(count_news), digits=2),
            blogs = round(mean(count_blogs), digits=2),
            twitter = round(mean(count_twitter), digits=2), 
            facebook = round(mean(count_facebook), digits=2),
            peerReview = round(mean(count_peer_review), digits=2),
            weibo = round(mean(count_weibo), digits=2),
            googlePlus = round(mean(count_google_plus), digits=2),
            reddit = round(mean(count_reddit), digits=2),
            researchHi = round(mean(count_research_hi), digits=2),
            video = round(mean(count_video), digits=2),
            wikipedia = round(mean(count_wikipedia), digits=2))

row.names(top100) <- top100$categories
top100 <- top100 %>%
  select(-categories)



# Data for heatmap by country
top100c <- top_aff %>%
  group_by(country) %>%
  summarise(score = round(mean(score), digits=2),
            news = round(mean(count_news), digits=2),
            blogs = round(mean(count_blogs), digits=2),
            twitter = round(mean(count_twitter), digits=2), 
            facebook = round(mean(count_facebook), digits=2),
            peerReview = round(mean(count_peer_review), digits=2),
            weibo = round(mean(count_weibo), digits=2),
            googlePlus = round(mean(count_google_plus), digits=2),
            reddit = round(mean(count_reddit), digits=2),
            researchHi = round(mean(count_research_hi), digits=2),
            video = round(mean(count_video), digits=2),
            wikipedia = round(mean(count_wikipedia), digits=2))

row.names(top100c) <- top100c$country
top100c <- top100c %>%
  select(-country)




# Data for reactive heatmap by country and category
top100cat <- top_aff %>%
  group_by(country, categories) %>%
  summarise(score = round(mean(score), digits=2),
            news = round(mean(count_news), digits=2),
            blogs = round(mean(count_blogs), digits=2),
            twitter = round(mean(count_twitter), digits=2), 
            facebook = round(mean(count_facebook), digits=2),
            peerReview = round(mean(count_peer_review), digits=2),
            weibo = round(mean(count_weibo), digits=2),
            googlePlus = round(mean(count_google_plus), digits=2),
            reddit = round(mean(count_reddit), digits=2),
            researchHi = round(mean(count_research_hi), digits=2),
            video = round(mean(count_video), digits=2),
            wikipedia = round(mean(count_wikipedia), digits=2)) 

server.R

function(input, output, session) {
  
  
  # Heatmap by country
  output$country <- renderD3heatmap({
    
    d3heatmap(top100c,
              scale = "column", 
              dendrogram = "none", 
              colors = "YlOrBr",
              xaxis_font_size = "10px",
              yaxis_font_size = "10px")
    
    })
  
  
  
  # And by category
  output$category <- renderD3heatmap({
    
    d3heatmap(top100, 
              scale = "column", 
              dendrogram = "none", 
              colors = "Greens",
              xaxis_font_size = "10px",
              yaxis_font_size = "10px")
    
  })
  
  
  
  
   # Data for reactive heatmap
   data <- reactive({
     
     thecat <- top100cat[top100cat$country == input$c, "categories"]
     
     validate(
       need(nrow(top100cat[top100cat$country == input$c, ]) >1, 
            message = paste0("Sorry, cannot render only one category (", thecat, "). Select another country."))
     )
     
     top100cat[top100cat$country == input$c, ]
    
  })
  
  
   
   # Reactiv heatmap, by selected country
   output$selcountry <- renderD3heatmap({
     
     countrydata <- data()
     
     row.names(countrydata) <- countrydata$categories
     
     countrydata <- countrydata %>%
       ungroup() %>%
       select(-country,-categories)
     
     d3heatmap(countrydata, 
               scale = "column", 
               dendrogram = "none",
               xaxis_font_size = "10px",
               yaxis_font_size = "10px",
               colors = "Blues")
    
  })
    
    

  

}

ui.R

sidebar <- dashboardSidebar(disable = T)


body <- dashboardBody(
  
  fluidRow(
    column(
      width = 6,
      box(
        height = "1250px",
        width = NULL,
        title = "Average metrics by country",
        status = "success",
        d3heatmapOutput("country", height = "1200px")
      )
    ),
    column(
      width = 6,
      box(
        title = "About",
        width = NULL,
        status = "info",
        tags$div(class="header", checked=NA,
                 tags$a(href="https://figshare.com/s/38e6a778945e11e5aafe06ec4bbcf141", "Data on Figshare by Altmetric (License CC-BY)")
        ),
        tags$div(class="header", checked=NA,
                 tags$p("To select, click row and/or column label. Draw a rectangle to zoom. To reset, click map.", 
                        a(href="https://github.com/rstudio/d3heatmap/issues/43", "Note tooltip issue in FF while zooming")
                        )
        ),
        tags$div(class="header", checked=NA,
                 tags$a(href="https://gist.github.com/tts/c6f8cb8a66f1bb9a21f0", "R source code"))
      ),
      box(
        title = "Average metrics by category",
        width = NULL,
        status = "warning",
        d3heatmapOutput("category")
      ),
      box(
        width = NULL,
        selectInput(inputId = "c",
                    label = "Select country for the map below",
                    choices = countries,
                    selected = "Finland")
      ),
      box(
        width = NULL,
        heigth = "600px",
        status = "primary",
        d3heatmapOutput("selcountry", height = "550px")
      )
    )
  )
)


dashboardPage(
  dashboardHeader(title = "Altmetric Top 100 articles 2015",
                  titleWidth = "500"),
  sidebar,
  body,
  skin = "black"
)