Exploring transport routes, journey characteristics and postcode networks using R Shiny
# 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( " Inputs" ), | |
class = "btn-info" ) | |
), | |
tags$li( class = "dropdown", | |
downloadButton( outputId = "downloadMap", | |
label = HTML( " Map" ), | |
class = "btn-info" ) | |
), | |
tags$li( class = "dropdown", | |
downloadButton( outputId = "downloadTables", | |
label = HTML( " Tables" ), | |
class = "btn-info" ) | |
), | |
tags$li( class = "dropdown", | |
downloadButton( outputId = "downloadNetwork", | |
label = HTML( " 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(" "), "Journey maps" ), | |
leafletOutput( outputId = "leafletMap", width = "100%", height = 800 ) | |
), | |
# 2. | |
tabPanel( tagList( icon = icon( "table" ), HTML(" "), "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(" "), "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