NHS Shiny SitRep Viewer

db_tables.csv

global.R

##nhssitrep/global.R
library(zoo)
library(plyr)

#Loading in CSV directly from https seems to cause problems but this workaround seems okay
floader=function(fn){
  temporaryFile <- tempfile()
  download.file(fn,destfile=temporaryFile, method="curl")
  read.csv(temporaryFile)
}

  
#get Tables
u="https://api.scraperwiki.com/api/1.0/datastore/sqlite?format=csv&name=nhs_sit_reps&query=select%20*%20from%20%60swdata%60"
sitrep.tables=floader(u)

sha.pct.lookup=read.csv("~/ShinyApps/nhssitrep/data/sha_pct_lookup.csv", header=T)
sha=unique(subset(sha.pct.lookup,select=c('SHA','SHAname')))
aList=sha$SHA
names(aList)=sha$SHAname

db.tables=read.csv("~/ShinyApps/nhssitrep/data/db_tables.csv", header=T)
bList=db.tables$id
names(bList)=db.tables$name
#names(bList)=db.tables$name

#This is the data source - a scraperwiki API call
#It would make sense to abstract this further, eg allowing the creation of the URL based around a passed in a select statement

getData2=function(Code,tid){
  q=paste("select * from `fulltable` where Code=='",Code,"' and tid=='",tid,"'",sep='')
  #q=paste("select * from `fulltable` where Code=='",Code,"'",sep='')
  #u="https://api.scraperwiki.com/api/1.0/datastore/sqlite?format=csv&name=nhs_sit_reps&query=select%20SHA%2CName%2C%20fromDateStr%2CtoDateStr%2C%20tableName%2CfacetB%2Cvalue%20from%20fulltable%20%20where%20Name%20like%20'%25WIGH%25'"
  u=paste("https://api.scraperwiki.com/api/1.0/datastore/sqlite?format=csv&name=nhs_sit_reps&query=",URLencode(q),sep='')
  print(u)
  tmp=floader(u)
  tmp$fdate=as.Date(tmp$fromDateStr)
  tmp$tdate=as.Date(tmp$toDateStr)
  tmp$val=as.integer(tmp$value)
  
  tmp=tmp[order(as.Date(tmp$toDateStr)) , ]
  
  #http://margintale.blogspot.co.uk/2012/04/ggplot2-time-series-heatmaps.html
  tmp$year<-as.numeric(as.POSIXlt(tmp$fdate)$year+1900)
  # the month too 
  tmp$month<-as.numeric(as.POSIXlt(tmp$fdate)$mon+1)
  # but turn months into ordered facors to control the appearance/ordering in the presentation
  tmp$monthf<-factor(tmp$month,levels=as.character(1:12),labels=c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"),ordered=TRUE)
  # the day of week is again easily found
  tmp$weekday = as.POSIXlt(tmp$fdate)$wday
  # again turn into factors to control appearance/abbreviation and ordering
  # I use the reverse function rev here to order the week top down in the graph
  # you can cut it out to reverse week order
  tmp$weekdayf<-factor(tmp$weekday,levels=rev(0:6),labels=rev(c("Sun","Mon","Tue","Wed","Thu","Fri","Sat")),ordered=TRUE)
  # the monthweek part is a bit trickier 
  # first a factor which cuts the data into month chunks
  tmp$yearmonth<-as.yearmon(tmp$fdate)
  tmp$yearmonthf<-factor(tmp$yearmonth)
  # then find the "week of year" for each day
  tmp$week <- as.numeric(format(tmp$fdate,"%W"))
  # and now for each monthblock we normalize the week to start at 1 
  tmp<-ddply(tmp,.(yearmonthf),transform,monthweek=1+week-min(week))
  
  tmp
}

getData=function(sha,tid){
  q=paste("select * from `",tid,"` where SHA=='",sha,"'",sep='')
  #q=paste("select * from `fulltable` where SHA=='",sha,"' and tid=='",tid,"'",sep='')
  #q=paste("select * from `fulltable` where Code=='",Code,"'",sep='')
  #u="https://api.scraperwiki.com/api/1.0/datastore/sqlite?format=csv&name=nhs_sit_reps&query=select%20SHA%2CName%2C%20fromDateStr%2CtoDateStr%2C%20tableName%2CfacetB%2Cvalue%20from%20fulltable%20%20where%20Name%20like%20'%25WIGH%25'"
  u=paste("https://api.scraperwiki.com/api/1.0/datastore/sqlite?format=csv&name=nhs_sit_reps&query=",URLencode(q),sep='')
  print(u)
  tmp=floader(u)
  tmp$fdate=as.Date(tmp$fromDateStr)
  tmp$tdate=as.Date(tmp$toDateStr)
  tmp$val=as.integer(tmp$value)
  
  tmp=tmp[order(as.Date(tmp$toDateStr)) , ]
  
  #http://margintale.blogspot.co.uk/2012/04/ggplot2-time-series-heatmaps.html
  tmp$year<-as.numeric(as.POSIXlt(tmp$fdate)$year+1900)
  # the month too 
  tmp$month<-as.numeric(as.POSIXlt(tmp$fdate)$mon+1)
  # but turn months into ordered facors to control the appearance/ordering in the presentation
  tmp$monthf<-factor(tmp$month,levels=as.character(1:12),labels=c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"),ordered=TRUE)
  # the day of week is again easily found
  tmp$weekday = as.POSIXlt(tmp$fdate)$wday
  # again turn into factors to control appearance/abbreviation and ordering
  # I use the reverse function rev here to order the week top down in the graph
  # you can cut it out to reverse week order
  tmp$weekdayf<-factor(tmp$weekday,levels=rev(0:6),labels=rev(c("Sun","Mon","Tue","Wed","Thu","Fri","Sat")),ordered=TRUE)
  # the monthweek part is a bit trickier 
  # first a factor which cuts the data into month chunks
  tmp$yearmonth<-as.yearmon(tmp$fdate)
  tmp$yearmonthf<-factor(tmp$yearmonth)
  # then find the "week of year" for each day
  tmp$week <- as.numeric(format(tmp$fdate,"%W"))
  # and now for each monthblock we normalize the week to start at 1 
  tmp<-ddply(tmp,.(yearmonthf),transform,monthweek=1+week-min(week))
  
  tmp
}


#Load the data and do a bit typecasting, just in case...
#d=floader(u)
#d$fdate=as.Date(d$fromDateStr)
#d$val=as.integer(d$value)
#d$tdate=as.Date(d$toDateStr)

server.R

##nhssitrep/server.R

library(shiny)
library(ggplot2)

# Define server logic
shinyServer(function(input, output) {
  
  results.data <- reactive(function(){
    getData(input$sha,input$rep) 
  })
  
  output$tbl <- reactiveUI(function() {
    #cities <- getNearestCities(input$lat, input$long)
    #checkboxGroupInput("cities", "Choose Cities", cities)
    tmp= subset(sha.pct.lookup,SHA==input$sha,select=c('Code','Name'))
    tmp$Code=factor(tmp$Code)
    tmp$Name=factor(tmp$Name)
    tList=tmp$Code
    #tList=tmp$Name
    names(tList)=tmp$Name
    selectInput("tbl", "Trust:",tList)
  })
  
  #Do a simple barchart of data in the selected table.
  #Where there are "subtables", display these using the faceted view
  output$testPlot = reactivePlot(function() {
    d=results.data()
    g=ggplot(subset(d,fdate>as.Date('2012-11-01') & Code==input$tbl))
    g=g+geom_bar(aes(x=fdate,y=val),stat='identity')+facet_wrap(~tableName+facetB,scales = "free_y")
    g=g+theme(axis.text.x=element_text(angle=-90),legend.position="none")#+labs(title="Isle of Wight NHS Trust")
    ##g=g+scale_y_discrete(breaks=0:10)
    g=g+xlab(NULL)+ylab('Number')
    print(g)
  })

  output$testPlot2 = reactivePlot(function() {
    d=results.data()
    g=ggplot(subset(d,fdate>as.Date('2012-11-01') ))
    g=g+geom_bar(aes(x=fdate,y=val,fill=Name),stat='identity')+facet_wrap(~tableName+facetB,scales = "free_y")
    g=g+theme(axis.text.x=element_text(angle=-90),legend.position='bottom')#+labs(title="Isle of Wight NHS Trust")
    ##g=g+scale_y_discrete(breaks=0:10)
    #g=g+guide_legend(title = NULL)
    g=g+scale_fill_discrete(guide = guide_legend(title = NULL,ncol=2))
    g=g+xlab(NULL)+ylab('Number')
    print(g)
  })
  
  output$pctLineChart = reactivePlot(function() {
    d=results.data()
    g=ggplot(subset(d,fdate>as.Date('2012-11-01') & Code==input$tbl))
    g=g+geom_line(aes(x=fdate,y=val))+facet_wrap(~tableName+facetB,scales = "free_y")
    g=g+theme(axis.text.x=element_text(angle=-90),legend.position='bottom')
    #g=g+guides(colour = guide_legend(title = NULL,ncol=2))#scale_y_discrete(guide = guide_legend(title = NULL,ncol=2))
    g=g+xlab(NULL)+ylab('Number')
    g=g+geom_point(aes(x=fdate,y=val),size=1)
    print(g)
  })
  
  output$dayPlot = reactivePlot(function() {
    d=results.data()
    g=ggplot(subset(d,fdate>as.Date('2012-11-01') & Code==input$tbl))
    g=g+geom_boxplot(aes(x=weekdayf,y=val))
    g=g+geom_point(aes(x=weekdayf,y=val),position = position_jitter(w = 0.3, h = 0))+facet_wrap(~tableName+facetB,scales = "free_y")
    g=g+xlab(NULL)+ylab('Number')
    print(g)
  })
  
  output$shaLineChart = reactivePlot(function() {
    d=results.data()
    g=ggplot(subset(d,fdate>as.Date('2012-11-01') ))
    g=g+geom_line(aes(x=fdate,y=val,group=Name,col=Name))+facet_wrap(~tableName+facetB,scales = "free_y")
    g=g+theme(axis.text.x=element_text(angle=-90),legend.position='bottom')
    g=g+guides(colour = guide_legend(title = NULL,ncol=2))#scale_y_discrete(guide = guide_legend(title = NULL,ncol=2))
    g=g+xlab(NULL)+ylab('Number')
    g=g+geom_point(data=subset(d,Code==input$tbl),aes(x=fdate,y=val),size=1)
    print(g)
  })
  
  output$shaBoxPlot = reactivePlot(function() {
    d=results.data()
    
    #Wordwrapper via:
    #http://stackoverflow.com/questions/2351744/insert-line-breaks-in-long-string-word-wrap
    limiter=function(x) gsub('(.{1,15})(\\s|$)', '\\1\n', x)
    d$sName=sapply(d$Name,limiter)
    g=ggplot(subset(d,fdate>as.Date('2012-11-01') ))
    g=g+geom_boxplot(aes(x=sName,y=val))+facet_wrap(~tableName+facetB,scales = "free_y")
    g=g+theme(axis.text.x=element_text(angle=-90,vjust = 0.5,size=5),legend.position='bottom')
    g=g+xlab(NULL)+ylab('Number')
    g=g+geom_boxplot(data=subset(d,Code==input$tbl),aes(x=sName,y=val),col='red')
    print(g)
  })
  
  #It would probable make sense to reshape the data presented in this table
  #For example, define columns based on facetB values, so we have one row per date range
  #I also need to sort the table by date
  output$view = reactiveTable(function() {
    d=results.data()
    if (nrow(d)!=0)
      subset(d,tid==input$rep & Code==input$tbl,select=c('Name','fromDateStr','toDateStr','tableName','facetB','value'))
    else data.frame('Please select a report...')
  }, include.rownames=FALSE)

  downloadData <- reactive(function() {
    ds=results.data()
    if (input$pctdownonly==TRUE) 
      ds=subset(ds,tid==input$rep & Code==input$tbl,select=c('Name','fromDateStr','toDateStr','tableName','facetB','value'))
    ds
  })
  
  output$downloadData <- downloadHandler(
    filename = function() { if (input$pctdownonly==FALSE) paste(input$sha,'_',input$rep, '.csv', sep='') else paste(input$tbl,'_',input$rep, '.csv', sep='') },
    content = function(file) {
      write.csv(downloadData(), file, row.names=FALSE)
    })
  
})

sha+pct_lookup.csv

ui.R

##nhssitrep/ui.R
library(shiny)


#tList=levels(d$tableName)
#names(tList) = tList

# Define UI for application that plots random distributions 
shinyUI(pageWithSidebar(
  
  
  # Application title
  headerPanel("NHS Trust Sit Rep Explorer"),
  
  sidebarPanel(
    selectInput("sha", "SHA:",aList),
    uiOutput("tbl"),
    checkboxInput("pctdownonly", "Only download this Trust's data", FALSE),
    selectInput("rep", "Report:",bList),
    
    downloadButton('downloadData', 'Download Report Data'),
    #selectInput("tbl", "Report:",tList),
    div("This demo provides a crude graphical view over data extracted from",
        a(href='http://transparency.dh.gov.uk/2012/10/26/winter-pressures-daily-situation-reports-2012-13/',
          "NHS Winter pressures daily situation reports") ),
    div("The data is pulled in from a scraped version of the data stored on Scraperwiki",
        a(href="https://scraperwiki.com/scrapers/nhs_sit_reps/","NHS Sit Reps")),
    div(em("Commentary on the data:"),"'On the columns, where we have a weekend, all items apart from beds figures are summed across the weekend (eg number of diverts in place over the weekend, number of cancelled ops). Beds figures (including beds closed to norovirus) are snapshots at the collection time (i.e 8am on the Monday morning).'")
    
  ),
  
  mainPanel(
    tabsetPanel(
      tabPanel("SHA Stacked Barchart", plotOutput("testPlot2")),
      tabPanel("SHA Linechart", plotOutput("shaLineChart")),
      tabPanel("SHA BoxPlot", plotOutput("shaBoxPlot"))
    ),
    tabsetPanel(
      tabPanel("PCT Barchart",plotOutput("testPlot")),
      tabPanel("PCT Linechart",plotOutput("pctLineChart")),
      tabPanel("PCT Daily Boxplot",plotOutput("dayPlot")),
      tabPanel("PCT Datatable",tableOutput("view"))
    )
    
  )
))