Skip to content

Instantly share code, notes, and snippets.

@CaterinaC

CaterinaC/exampleTransportShinyApp.R Secret

Last active Sep 20, 2019
Star
Embed
What would you like to do?
Learn more about clone URLs
Download ZIP
Exploring transport routes, journey characteristics and postcode networks using R Shiny
Raw
exampleTransportShinyApp.R
# Title: Exploring transport routes, journey characteristics and postcode networks using R Shiny
# Author: Caterina Constantinescu
# Institution: The Data Lab: https://thedatalab.com/
# Please credit this source if you intend to model your own code on what is shown below.
# Constantinescu, A.C. (2018, June). Exploring transport routes, journey characteristics and postcode networks using R Shiny [R script as GitHub Gist]. Edinburgh, Scotland: The Data Lab Innovation Centre. Retrieved [Month] [Day], [Year], from https://gist.github.com/CaterinaC/4fdfe9bfd753dd47bdec16ca342c401b
# TODOs -------------------------------------------------------------------
# Add any TODOs here
# Packages ----------------------------------------------------------------
library( shiny )
library( shinydashboard )
library( DT )
library( data.table )
library( plyr )
library( dplyr )
library( lubridate )
library( prodlim ) # For row.match()
library( janitor )
library( BBmisc )
library( stringr )
library( sp )
library( maptools )
library( leaflet )
library( visNetwork )
library( xlsx )
library( htmlwidgets )
# UI column on right hand side ----------------------------------------------------------------------
ui <-
dashboardPage(
dashboardHeader( title = "Scottish Council Subsidised Transport Routes",
titleWidth = 625,
tags$li( class = "dropdown",
downloadButton( outputId = "downloadCriteria",
label = HTML( "&nbsp; Inputs" ),
class = "btn-info" )
),
tags$li( class = "dropdown",
downloadButton( outputId = "downloadMap",
label = HTML( "&nbsp; Map" ),
class = "btn-info" )
),
tags$li( class = "dropdown",
downloadButton( outputId = "downloadTables",
label = HTML( "&nbsp; Tables" ),
class = "btn-info" )
),
tags$li( class = "dropdown",
downloadButton( outputId = "downloadNetwork",
label = HTML( "&nbsp; Network" ),
class = "btn-info" )
)
),
dashboardSidebar( disable = TRUE ),
dashboardBody(
fluidPage(
tags$head(
tags$style(
HTML( "#JourneyValueBox {width: 100%;}" ) )
),
sidebarLayout( position = "right",
column( width = 3,
box(
br(),
width = NULL, solidHeader = TRUE,
valueBoxOutput( "JourneyValueBox" )
),
box( width = NULL, status = "warning",
radioButtons( inputId = "isUsingTimeOfDaySubsetting", inline = FALSE,
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Subset by time of day?</li></ul>" ),
choiceNames = list( "No", "Yes" ),
choiceValues = list( "No", "Yes" ),
selected = list( "No" ) ),
conditionalPanel(
condition = "input.isUsingTimeOfDaySubsetting == 'Yes'",
br(),
sliderInput( inputId = "SchTime",
animate = animationOptions( interval = 2500,
loop = FALSE,
playButton = icon( "play-circle", "fa-1.5x" ) ),
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Time of day:</li></ul>" ),
min = as.POSIXct( "1833-01-01 00:00:01", "%H:%M:%S" ),
max = as.POSIXct( "1833-01-01 23:59:59", "%H:%M:%S" ),
value = c( as.POSIXct( "1833-01-01 00:00:01", "%H:%M:%S" ),
as.POSIXct( "1833-01-01 23:59:59", "%H:%M:%S" ) ),
timezone = "GMT",
timeFormat = "%H:%M", ticks = T ),
br()
)
),
box( width = NULL, status = "warning",
checkboxGroupInput( inputId = "Quarter", inline = FALSE,
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Journey quarter:</li></ul>" ),
choiceNames = list( "2015 Q4",
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4",
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ),
choiceValues = list( "2015.4",
"2016.1", "2016.2", "2016.3", "2016.4",
"2017.1", "2017.2", "2017.3", "2017.4" ),
selected = list( "2015.4",
"2016.1", "2016.2", "2016.3", "2016.4",
"2017.1", "2017.2", "2017.3", "2017.4" )
),
HTML( "<ul style='padding-left: 1.25em;'}><li><strong>Batch select quarters:</strong></li></ul>" ),
div( style = "position:relative;left:0%;padding:0px",
actionButton( inputId = 'tick2015', '2015' ),
actionButton( inputId = 'tick2016', '2016' ),
actionButton( inputId = 'tick2017', '2017' ),
actionButton( inputId = 'tick2015_2017', 'Full period' )
)
),
box( width = NULL, status = "warning",
checkboxGroupInput( inputId = "DayOfTheWeek", inline = FALSE,
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Day of the week:</li></ul>" ),
choiceNames = list( "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" ),
choiceValues = list( "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" ),
selected = list( "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" ) ),
HTML( "<ul style='padding-left: 1.25em;'}><li><strong>Batch select days of the week:</strong></li></ul>" ),
div( style = "position:relative;left:0%;padding:0px",
actionButton( inputId = 'tickWeekday', 'Weekdays' ),
actionButton( inputId = 'tickWeekend', 'Weekend' ),
actionButton( inputId = 'tickFullWeek', 'Full week' ) )
),
box(
width = NULL, status = "warning",
radioButtons( inputId = "isUsingPostCodePopups", inline = FALSE,
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Show postcodes on map?</li></ul>" ),
choiceNames = list( "No", "Yes" ),
choiceValues = list( "No", "Yes" ),
selected = list( "No" )
)
)
),
# Output tabs in UI ------------------------------------------------------------------
column( width = 9,
tabBox(
title = tags$a( tags$img( src = 'TheDataLab-Black-Logo-transparent-small.png', height = '33', width = '100' ),
href = 'https://www.thedatalab.com/' ),
id = "outputTabs",
width = NULL,
side = "left",
# 1.
tabPanel( tagList( icon = icon( "map-signs", "fa-1x" ), HTML("&nbsp;"), "Journey maps" ),
leafletOutput( outputId = "leafletMap", width = "100%", height = 800 )
),
# 2.
tabPanel( tagList( icon = icon( "table" ), HTML("&nbsp;"), "Data summaries" ),
fluidRow(
column( width = 4, dataTableOutput( outputId = "summaryPurposeTable" ) ),
column( width = 5, dataTableOutput( outputId = "summaryOperatorTable" ) ),
column( width = 3, dataTableOutput( outputId = "summaryDayOfTheWeekTable" )
)
),
br(),
fluidRow(
column( width = 4, dataTableOutput( outputId = "summaryOccupantsTable" ) ),
column( width = 5, dataTableOutput( outputId = "summaryTimeOfDayTable" ) ),
column( width = 3, dataTableOutput( outputId = "summaryQuarterTable" )
)
)
),
# 3.
tabPanel( tagList( icon = icon( "connectdevelop" ), HTML("&nbsp;"), "Postcode network" ),
visNetworkOutput( outputId = "postcodeNetwork", width = "100%", height = 800 )
)
),
# UI row of menus below --------------------------------------------------------------
fluidRow(
column( width = 4,
box( width = NULL, status = "warning", height = "300px",
selectInput( inputId = "Purpose",
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Journey purpose:</li></ul>" ),
list( `Any purpose` = "Any",
`Recreational activities` = c( "Shopping", "Social", "Retreat", "Sports", "Tourist" ),
`Professional & educational activities` = c( "Employment", "School" ),
`Commitments / appointments` = c( "Meeting", "Doctor" ),
`Transport connection` = c( "Bus connection", "Train connection" ),
`Misc` = c( "Church", "Personal", "Other" ) ) )
)
),
column( width = 4,
box( width = NULL, status = "warning", height = "300px",
selectInput( inputId = "Operator",
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Journey operator:</li></ul>" ),
list( `Any operator` = c( "Any"),
`Cab/Coach companies` = c( "A",
"B",
"C",
"D",
"E",
"F",
"G",
"H" ),
`Transport schemes` = c( "Area 1 scheme",
"Area 2 scheme",
"Area 3 scheme (Mon, Wed, Fri)",
"Area 3 scheme (Tue, Thu, Sat)" ) ) )
)
),
column( width = 4,
box( width = NULL, status = "warning", height = "300px",
selectInput( inputId = "Occupants",
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Number of occupants:</li></ul>" ),
list( `Any number of occupants` = c( "Any"),
`1` = 1,
`2` = 2,
`3` = 3,
`4` = 4,
`5` = 5,
`6` = 6,
`7` = 7,
`8` = 8 )
)
)
)
)
)
)
)
)
)
# SERVER ------------------------------------------------------------------
server <- function( input, output, session ) {
# Custom functions - run ONCE --------------------------------------------------------
getTabularSummary <- function( criterion, recodeQuarters = FALSE, timeOfDay = FALSE ) {
# For table of times of day
if ( timeOfDay == FALSE ) {
smry <- data.frame( tabyl( getDataSubset()[ , get( criterion ) ] ) )
}
else {
smry <- data.frame(
tabyl(
format(
as.POSIXct(
cut( getDataSubset()$JourneyStart,
breaks = "h") ),
"%H:%M:%S" ) ) )
}
# For yearly quarters
if ( recodeQuarters == TRUE ) {
smry[[1]] <- mapvalues( smry[[1]],
c( "2015.4",
"2016.1", "2016.2", "2016.3", "2016.4",
"2017.1", "2017.2", "2017.3", "2017.4" ),
c( "2015 Q4",
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4",
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ) )
}
# For everything, regardless of type:
if ( ncol( smry ) == 4 ) {
# 4 columns = missing values are present, hence another 'Valid percent' column is generated besides the regular 'percent' one.
names( smry ) <- c( criterion, "Journeys", "%", "Valid %" )
smryMissings <- smry[ nrow( smry ), ]
smryMissings[[1]] <- "NA"
smryMissings[[3]] <- round( smryMissings[[3]], digits = 3 )
smry <- smry[ - nrow( smry ), ]
smry <- smry[ order( smry$Journeys, decreasing = TRUE ), ]
smry$`%` <- round( smry$`%`, digits = 3 )
smry$`Valid %` <- round( smry$`Valid %`, digits = 3 )
rbind( smry, smryMissings )
}
else {
# If no missing data is present, there will be 3 columns.
names( smry ) <- c( criterion, "Journeys", "%" )
smry$`%` <- round( smry$`%`, digits = 3 )
return( smry[ order( smry$Journeys, decreasing = TRUE ), ] )
}
}
# Get data and transform some cols - also run ONCE -----------------------------------
# Run once:
tryCatch( load( "my/path/RequiredByShinyApp.RData",
envir = globalenv() ),
error = function(e) {
load( "my/other/path/RequiredByShinyApp.RData",
envir = globalenv() )
} )
# Transform some data once:
data_geocode_from_to_journeys_found[ , JourneyStart := ymd_hms( as.POSIXct( ifelse( RequestType == "PickUp",
Est,
Est - ( VehicleTimeMinutes * 60 ) ),
origin = '1970-01-01', tz = "UTC" ) ) ]
data_geocode_from_to_journeys_found[ , JourneyDecimalStartHour := hour( JourneyStart ) + minute( JourneyStart ) / 60 ]
# Update QUARTER checkbox inputs based on actionButtons ---------------------------
observe({
if ( input$tick2015 > 0 ) {
updateCheckboxGroupInput( session = session,
inputId = "Quarter",
choiceNames = list( "2015 Q4",
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4",
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ),
choiceValues = list( "2015.4",
"2016.1", "2016.2", "2016.3", "2016.4",
"2017.1", "2017.2", "2017.3", "2017.4" ),
selected = list( "2015.4" ) )
}
})
observe({
if ( input$tick2016 > 0 ) {
updateCheckboxGroupInput( session = session,
inputId = "Quarter",
choiceNames = list( "2015 Q4",
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4",
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ),
choiceValues = list( "2015.4",
"2016.1", "2016.2", "2016.3", "2016.4",
"2017.1", "2017.2", "2017.3", "2017.4" ),
selected = list( "2016.1", "2016.2", "2016.3", "2016.4" ) )
}
})
observe({
if ( input$tick2017 > 0 ) {
updateCheckboxGroupInput( session = session,
inputId = "Quarter",
choiceNames = list( "2015 Q4",
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4",
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ),
choiceValues = list( "2015.4",
"2016.1", "2016.2", "2016.3", "2016.4",
"2017.1", "2017.2", "2017.3", "2017.4" ),
selected = list( "2017.1", "2017.2", "2017.3", "2017.4" ) )
}
})
observe({
if ( input$tick2015_2017 > 0 ) {
updateCheckboxGroupInput( session = session,
inputId = "Quarter",
choiceNames = list( "2015 Q4",
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4",
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ),
choiceValues = list( "2015.4",
"2016.1", "2016.2", "2016.3", "2016.4",
"2017.1", "2017.2", "2017.3", "2017.4" ),
selected = list( "2015.4",
"2016.1", "2016.2", "2016.3", "2016.4",
"2017.1", "2017.2", "2017.3", "2017.4" ) )
}
})
# Update DAY OF THE WEEK checkbox input -----------------------------------
observe({
if ( input$tickWeekday > 0 ) {
updateCheckboxGroupInput( session = session,
inputId = "DayOfTheWeek",
choiceNames = list( "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" ),
choiceValues = list( "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" ),
selected = list( "Monday", "Tuesday", "Wednesday", "Thursday", "Friday" ) )
}
})
observe({
if ( input$tickWeekend > 0 ) {
updateCheckboxGroupInput( session = session,
inputId = "DayOfTheWeek",
choiceNames = list( "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" ),
choiceValues = list( "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" ),
selected = list( "Saturday", "Sunday" ) )
}
})
observe({
if ( input$tickFullWeek > 0 ) {
updateCheckboxGroupInput( session = session,
inputId = "DayOfTheWeek",
choiceNames = list( "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" ),
choiceValues = list( "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" ),
selected = list( "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" ) )
}
})
# DATA PREP: Run each time inputs change ----------------------------------
# 1. Tidy up some input values -------------------------------------------------------
getDataSubset <- reactive({
redefinedPurpose <- mapvalues( input$Purpose,
c( "Bus connection", "Train connection" ),
c( "BusConnection", "TrainConnection" ) )
redefinedOperator <- mapvalues( input$Operator,
c( "Area 3 (Mon, Wed, Fri)", "Area 3 (Tue, Thu, Sat)" ),
c( "Area.3 (Monday, Wednesday, Friday)", "Area.3 (Tuesday, Thursday, Saturday)" ) )
# 2. Subset by DAY OF THE WEEK, QUARTER, and TIME OF DAY -----------------------------------------------
selected_interval <- data_geocode_from_to_journeys_found[ DayOfTheWeek %in% c( input$DayOfTheWeek ) &
Quarter %in% c( input$Quarter ), ]
# Optional step with excludes cases with missing time-of-day info:
if ( input$isUsingTimeOfDaySubsetting == "Yes" ) {
# Now compare this to input:
inputStartHour <- hour( input$SchTime[1] ) + minute( input$SchTime[1] ) / 60
inputEndHour <- hour( input$SchTime[2] ) + minute( input$SchTime[2] ) / 60
selected_interval <- selected_interval[ inputStartHour < JourneyDecimalStartHour & JourneyDecimalStartHour <= inputEndHour, ]
}
# 3. Subset routes by PURPOSE, OPERATOR and OCCUPANTS -------------------------------
# 1. ALL PARAMS FREE:
if ( redefinedPurpose == "Any" & redefinedOperator == "Any" & input$Occupants == "Any" ) {
# Simply not subsetting and carrying on:
selected_subset <- selected_interval
} # ALL PARAMS FIXED:
else if ( redefinedPurpose != "Any" & redefinedOperator != "Any" & input$Occupants != "Any" ) {
selected_subset <- selected_interval[ Purpose == redefinedPurpose & Operator == redefinedOperator & Occupants == input$Occupants, ]
} # ONLY PURPOSE FIXED:
else if ( redefinedPurpose != "Any" & redefinedOperator == "Any" & input$Occupants == "Any" ) {
selected_subset <- selected_interval[ Purpose == redefinedPurpose, ]
} # ONLY OPERATOR FIXED:
else if ( redefinedPurpose == "Any" & redefinedOperator != "Any" & input$Occupants == "Any" ) {
selected_subset <- selected_interval[ Operator == redefinedOperator, ]
} # ONLY OCCUPANTS FIXED:
else if ( redefinedPurpose == "Any" & redefinedOperator == "Any" & input$Occupants != "Any" ) {
selected_subset <- selected_interval[ Occupants == input$Occupants, ]
} # ONLY PURPOSE FREE, BUT OPERATOR AND OCCUPANTS FIXED:
else if ( redefinedPurpose == "Any" & redefinedOperator != "Any" & input$Occupants != "Any" ) {
selected_subset <- selected_interval[ Operator == redefinedOperator & Occupants == input$Occupants, ]
} # ONLY OCCUPANTS FREE, BUT OPERATOR AND PURPOSE FIXED:
else if ( redefinedPurpose != "Any" & redefinedOperator != "Any" & input$Occupants == "Any" ) {
selected_subset <- selected_interval[ Purpose == redefinedPurpose & Operator == redefinedOperator, ]
} # ONLY OPERATOR FREE, BUT PURPOSE AND OCCUPANTS FIXED:
else if ( redefinedPurpose != "Any" & redefinedOperator == "Any" & input$Occupants != "Any" ) {
selected_subset <- selected_interval[ Purpose == redefinedPurpose & Occupants == input$Occupants, ]
}
else { # THIS LOGIC DOES NOT INCLUDE AN OPTION FOR WHEN E.G., PURPOSE IS MISSING.
stop( "Unknown combination of trip attributes. Try changing the purpose, operator, or number of occupants." )
}
return( selected_subset )
})
# Recompute volumes post-subset -------------------------------------------
getSubsetVolumes <- reactive({
# Recompute volumes right after subset, otherwise the numbers will be shared with a bunch of other params:
subset_volumes <- na.exclude( ddply( getDataSubset(), .( FromLatitude, FromLongitude, ToLatitude, ToLongitude ), nrow ) )
if ( nrow( subset_volumes ) > 0 ) {
setnames( setDT( subset_volumes ), "V1", "Volume" )
}
return( subset_volumes )
})
getSpatialLinesObj <- reactive({
# Find the index of these social purpose routes within the listing of all unique journeys:
index_selected_routes <- prodlim::row.match( getSubsetVolumes()[ , -5 ], journeys_found, nomatch = NA )
# journeys_found is taken from memory i.e., the .RData loaded at the start.
# Now pull put the spatial lines associated with these particular trips:
lst_lines_social <- lst_lines[ index_selected_routes ]
# Wrap it up and put a bow on it:
spl_lst <- SpatialLines( lst_lines_social )
return( spl_lst )
})
getColorVector <- reactive({
if ( nrow( getSubsetVolumes() ) > 0 ) {
cold_hot_palette <- colorRampPalette( c( "black", "brown1" ) )
color_index <- data.frame( colorName = cold_hot_palette( length( unique( getSubsetVolumes()$Volume ) ) ),
Volume = sort( unique( getSubsetVolumes()$Volume ) ) )
color_vector <- join( getSubsetVolumes(), color_index, by = "Volume" )$colorName
return( color_vector )
}
else {
stop( "No journeys exist for this combination of criteria. Try again!" )
}
})
# Get relevant postcode names to use as popups ----------------------------
getRelevantPopups <- reactive({
if( nrow( getDataSubset() ) > 0 ) {
FromPostcodePopups <- getDataSubset()[ , .SD, .SDcols = c( "FromZipCode", "FromLongitude", "FromLatitude" ) ]
setnames( FromPostcodePopups, c( "ZipCode", "Longitude", "Latitude" ) )
ToPostcodePopups <- getDataSubset()[ , .SD, .SDcols = c( "ToZipCode", "ToLongitude", "ToLatitude") ]
setnames( ToPostcodePopups, c( "ZipCode", "Longitude", "Latitude" ) )
PostCodePopups <- rbind( FromPostcodePopups, ToPostcodePopups )
PostCodePopups <- PostCodePopups[ ! duplicated( PostCodePopups ), ]
return( PostCodePopups )
}
})
# A. Render leaflet map --------------------------------------------------------
drawLeafletMapItself <- reactive({
cityMap <- leaflet( ) %>%
# or CartoDB.DarkMatter
addProviderTiles( "HikeBike.HikeBike" ) %>%
addCircleMarkers( lng = ~ToLongitude,
lat = ~ToLatitude,
data = data.frame( getSubsetVolumes() ),
stroke = FALSE,
fillOpacity = 0.50, radius = 5,
color = "#ff5d00" ) %>%
addCircleMarkers( lng = ~FromLongitude,
lat = ~FromLatitude,
data = data.frame( getSubsetVolumes() ),
stroke = FALSE, fillOpacity = 0.50, radius = 5,
color = "#ff5d00" ) %>%
addPolylines( data = getSpatialLinesObj(),
weight = sqrt( getSubsetVolumes()$Volume ),
# Normalised the data here between a min and max:
opacity = normalize( sqrt( getSubsetVolumes()$Volume ), method = "range", range = c( 0.05, 0.60 ) ),
color = getColorVector(),
# color = "tomato",
label = paste(
"# Journeys = ",
as.character( getSubsetVolumes()$Volume ) ),
stroke = TRUE ) %>%
addMarkers( lng = as.numeric( city_centre_position[ 1 ] ),
lat = as.numeric( city_centre_position[ 2 ] ), # These is just a vector of coords defining the centre of the city
popup = "city centre" ) %>%
# This will fix the zoom level and centre for the map, so that it is more obvious how the flow of journeys changes over time.
setView( lng = -3.5,
lat = 53,
zoom = 10 )
if ( input$isUsingPostCodePopups == "No" ) {
cityMap
}
else {
cityMap %>%
addMarkers( data = getRelevantPopups(),
lng = ~Longitude,
lat = ~Latitude,
label = ~ZipCode,
labelOptions = labelOptions( noHide = F, textsize = "8px", maxHeight = 20 ) )
}
})
output$leafletMap <- renderLeaflet({
drawLeafletMapItself()
})
# B. Render value box --------------------------------------------------------
output$JourneyValueBox <- renderValueBox({
if ( nrow( getDataSubset() ) > 0 ) {
valueBox(
nrow( getDataSubset() ), "Journeys", icon = icon( "taxi", lib = "font-awesome" ),
color = "green"
)
}
else {
valueBox(
0, "Journeys", icon = icon( "taxi", lib = "font-awesome" ),
color = "red"
)
}
})
# C. Render tables in Data summary tab ---------------------------------------
output$summaryPurposeTable <- renderDataTable({
if ( nrow( getDataSubset() ) > 0 ) {
datatable( getTabularSummary( "Purpose" ),
rownames = FALSE,
options = list( dom = 't',
paging = FALSE,
scrollY = "330px" ) )
} else {
stop( "No journeys exist for this combination of criteria. Try again!" )
}
})
output$summaryOperatorTable <- renderDataTable({
if ( nrow( getDataSubset() ) > 0 ) {
datatable( getTabularSummary( "Operator" ),
rownames = FALSE,
options = list( dom = 't',
paging = FALSE,
scrollY = "330px" ) )
}
})
output$summaryOccupantsTable <- renderDataTable({
if ( nrow( getDataSubset() ) > 0 ) {
datatable( getTabularSummary( "Occupants" ),
rownames = FALSE,
options = list( dom = 't' ) )
}
})
output$summaryTimeOfDayTable <- renderDataTable({
if ( nrow( getDataSubset() ) > 0 ) {
datatable( getTabularSummary( "JourneyStart", recodeQuarters = FALSE, timeOfDay = TRUE ),
rownames = FALSE,
options = list( dom = 't',
paging = FALSE,
scrollY = "333px" ) )
}
})
output$summaryQuarterTable <- renderDataTable({
if ( nrow( getDataSubset() ) > 0 ) {
datatable( getTabularSummary( "Quarter", recodeQuarters = TRUE ),
rownames = FALSE,
options = list( dom = 't' ) )
}
})
output$summaryDayOfTheWeekTable <- renderDataTable({
if ( nrow( getDataSubset() ) > 0 ) {
datatable( getTabularSummary( "DayOfTheWeek" ),
rownames = FALSE,
options = list( dom = 't' ) )
}
})
# D. Render postcode network --------------------------------------------------------
drawNetworkItself <- reactive({
edges_or_links <- ddply( getDataSubset(), .( FromZipCode, ToZipCode ), nrow )
names( edges_or_links ) <- c( "from", "to", "value" ) # width = weight
link_data <- edges_or_links
setDT( link_data )
link_data[ , arrows := "to" ]
nodes <- unique( c( edges_or_links$from, edges_or_links$to ) )
node_data <- data.frame( id = nodes,
label = nodes,
color.background = "tomato" )
setDT( node_data )
visNetwork( nodes = node_data,
edges = link_data,
width = "100%",
height = "800px" ) %>%
visOptions( highlightNearest = TRUE ) %>%
visPhysics( solver = "forceAtlas2Based" ) %>%
visLayout( randomSeed = 123 )
})
output$postcodeNetwork <- renderVisNetwork({
if ( nrow( getDataSubset() ) > 0 ) {
drawNetworkItself()
}
else {
stop( "No journeys exist for this combination of criteria. Try again!" )
}
})
# EXPORT --------------------------------------------------------------------------------------
output$downloadCriteria <- downloadHandler(
filename = function() {
paste( 'DRT-Shiny-InputCriteria',
format( input$SchTime[1], "%H:%M:%S" ),
format( input$SchTime[2], "%H:%M:%S" ),
str_replace_all( paste( input$Quarter, collapse = "-" ), "[.]", "Q" ),
paste( input$DayOfTheWeek, collapse = "-" ),
input$Purpose,
input$Operator,
'.txt', sep = '__' )
},
content = function( file ) {
inputCriteria <- data.frame( `SubsettingByTimeOfDay...` = input$isUsingTimeOfDaySubsetting,
`StartTime...` = format( input$SchTime[1], "%H:%M:%S" ),
`EndTime...` = format( input$SchTime[2], "%H:%M:%S" ),
`Quarters...` = paste( input$Quarter, collapse = " - " ),
`DaysOfTheWeek...` = paste( input$DayOfTheWeek, collapse = " - " ),
`ShowingPostcodePopupsOnMap...` = input$isUsingPostCodePopups,
`Purpose...` = input$Purpose,
`Operator...` = input$Operator,
`Occupants...` = input$Occupants,
`Journeys...` = nrow( getDataSubset() ) )
write.table( t( inputCriteria ),
file,
col.names = FALSE,
quote = FALSE )
}
)
output$downloadMap <- downloadHandler(
filename = function() {
paste( 'DRT-Shiny-Map',
format( input$SchTime[1], "%H:%M:%S" ),
format( input$SchTime[2], "%H:%M:%S" ),
str_replace_all( paste( input$Quarter, collapse = "-" ), "[.]", "Q" ),
paste( input$DayOfTheWeek, collapse = "-" ),
input$Purpose,
input$Operator,
'.html', sep = '__' )
},
content = function( file ) {
saveWidget( drawLeafletMapItself(), file )
}
)
output$downloadNetwork <- downloadHandler(
filename = function() {
paste( 'DRT-Shiny-Network',
format( input$SchTime[1], "%H:%M:%S" ),
format( input$SchTime[2], "%H:%M:%S" ),
str_replace_all( paste( input$Quarter, collapse = "-" ), "[.]", "Q" ),
paste( input$DayOfTheWeek, collapse = "-" ),
input$Purpose,
input$Operator,
'.html', sep = '__' )
},
content = function( file ) {
saveWidget( drawNetworkItself(), file )
}
)
output$downloadTables <- downloadHandler(
filename = function() {
paste( 'DRT-Shiny-Tables',
format( input$SchTime[1], "%H:%M:%S" ),
format( input$SchTime[2], "%H:%M:%S" ),
str_replace_all( paste( input$Quarter, collapse = "-" ), "[.]", "Q" ),
paste( input$DayOfTheWeek, collapse = "-" ),
input$Purpose,
input$Operator,
'.xlsx', sep = '__' )
},
content = function( file ) {
write.xlsx( getTabularSummary( "Purpose" ),
file = file, sheetName = "Purpose",
row.names = FALSE )
write.xlsx( getTabularSummary( "Operator" ),
file = file, sheetName = "Operator",
append = TRUE,
row.names = FALSE )
write.xlsx( getTabularSummary( "Occupants" ),
file = file, sheetName = "Occupants",
append = TRUE,
row.names = FALSE )
write.xlsx( getTabularSummary( "JourneyStart", recodeQuarters = FALSE, timeOfDay = TRUE ),
file = file, sheetName = "JourneyStart",
append = TRUE,
row.names = FALSE )
write.xlsx( getTabularSummary( "Quarter", recodeQuarters = TRUE ),
file = file, sheetName = "Quarter",
append = TRUE,
row.names = FALSE )
write.xlsx( getTabularSummary( "DayOfTheWeek" ),
file = file, sheetName = "DayOfTheWeek",
append = TRUE,
row.names = FALSE )
}
)
}
# You should not have any R code after the line below; it needs to be the last line in your file.
shinyApp( ui = ui, server = server )
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment