library(shiny)
library(shinyjs)
library(leaflet)
library(rgdal)
library(dplyr)
library(leaflet.extras)
library(shinyWidgets)
source("leafletfunctions.R")
source("extras.R")
# work_travel <- read_csv("../travel-work.csv")
load(file="datasets.RData")
shpf <- readOGR(dsn="sa20025WGSfil")
sa.in.dest <- shpf@data$SA22018_V1 %in% work_to$work_code
sa.in.home <- shpf@data$SA22018_V1 %in% work_from$res_code
transport.t <- c("Private car", "Passenger in car",
"Walk", "Bicycle", "Company car", "Bus", "Train",
"Ferry", "Other", "(Work at home)", "None/Unknown")
edu.t <- c("Drive self", "Passenger in car", "Walk", "Bicycle",
"School bus", "Public bus", "Train", "Ferry",
"Other", "(Study at home)", "None/Unknown")
cols.labs <- c(transport.t[1:10], "Total")
cols.edu.labs <- c(edu.t[1:10], "Total")
codelist <- shpf@data %>%
mutate(sa2_code = as.numeric(as.character(SA22018_V1))) %>%
select(sa2_code)
startcols.res <- codelist %>% left_join(work_from, by = c("sa2_code" = "res_code"))
startcols.res <- tencols[startcols.res$MAX]
startcols.res <- ifelse(is.na(startcols.res), "#808080", startcols.res)
startcols.work <- codelist %>% left_join(work_to, by = c("sa2_code" = "work_code"))
startcols.work <- tencols[startcols.work$MAX]
startcols.work <- ifelse(is.na(startcols.work), "#808080", startcols.work)
startcols.edures <- codelist %>% left_join(edu_from,
by = c("sa2_code" = "res_code"))
startcols.edures <- tencols[startcols.edures$MAX]
startcols.edures <- ifelse(is.na(startcols.edures), "#808080", startcols.edures)
startcols.edu <- codelist %>% left_join(edu_to, by = c("sa2_code" = "edu_code"))
startcols.edu <- tencols[startcols.edu$MAX]
startcols.edu <- ifelse(is.na(startcols.edu), "#808080", startcols.edu)
hrstr <- "
"
# Define UI
ui <- fillPage(
useShinyjs(),
leafletjs,
keyboardjs,
shiny::tags$title("How did Kiwis commute in 2018?"),
tags$style(type = "text/css", extracss),
leafletOutput("map"),
absolutePanel(top = 10, right = 10, id="mapcontrol",
div(
radioGroupButtons("radioeduemp",
label = "Commuters (age 15+) travelling to",
status = "default",
choiceNames = list(
HTML("Employment"),
HTML("Education")
),
choiceValues = list(
"Employment", "Education"
)
),
radioGroupButtons("radioinout", label="Show commuters who",
choiceNames = list(
HTML("Commute from selected area"),
HTML("Commute to selected area")),
choiceValues = list(
"res",
"work"
),
direction="vertical",
justified = TRUE,
status = "default",
checkIcon = list(yes = icon("check"),
no = icon("check"))
),
radioGroupButtons("radiocolour",
label = "Colour by",
choiceNames = list(
HTML("Most common commute method"),
HTML("Number of commuters")
),
choiceValues = list(
"type",
"number"
),
direction = "vertical",
checkIcon = list(yes = icon("check"),
no = icon("check")),
status = "default",
justified = TRUE),
div(class="locinfo",
htmlOutput("lochtml")),
div(id="loc2"),
htmlOutput("secondarylochtml"))
),
absolutePanel(top=10, right=9, id="infobuttoncontainer",
title="Toggle (I)nformation",
prettyToggle("mapinfobutton",
label_on = NULL,
label_off = NULL,
icon_on=icon("times"),
icon_off = icon("info"),
animation = "pulse",
inline = TRUE,
status_on = "danger",
status_off = "primary",
value = TRUE)
),
absolutePanel(top = 40, right = 6, id="control2", title="Toggle pane(L)",
prettySwitch("controlswitch", value=TRUE, label = NULL,
slim = FALSE,
inline=TRUE, status="info",
fill=FALSE, bigger=FALSE)),
absolutePanel(bottom = 26, right = 10, id="loading",
p("Loading...")),
absolutePanel(bottom=26, right=10, left=10, top=10, id="infopanel",
infotext)
)
# Define server logic
server <- function(input, output) {
sel.SA2.code <- reactiveVal(0)
attribupdate <- FALSE
mouseover <- reactive({
lastover <- input$map_shape_mouseover$id
lastover <- ifelse(is.null(lastover), 0, lastover)
lastout <- input$map_shape_mouseout$id
lastout <- ifelse(is.null(lastout), 0, lastout)
ifelse(lastout == lastover, 0, lastover)
})
output$map <- renderLeaflet({
leaf <- leaflet(shpf, options = leafletOptions(minZoom = 3, maxZoom = 13,
crs = NULL)) %>%
addPolygons(color="#000", opacity = 1, weight=1,
fillColor = startcols.res,
layerId = ~SA22018_V1,
label = shpf@data$SA22018__1,
fillOpacity = 1, group = "polys") %>%
setView(174, -41, 6) %>%
addResetMapButton() %>%
addSearchFeatures("polys",
options = searchFeaturesOptions(
hideMarkerOnCollapse = TRUE,
autoCollapse = FALSE,
openPopup = FALSE,
zoom=11,
position="topleft")) %>%
addLegend(position = "topleft",
colors = c(tencols, "#808080"),
labels = transport.t, opacity = 1,
title = HTML("Most Common
Commute Method"))
shinyjs::hideElement(selector="#loading p", asis = TRUE,
anim=TRUE, animType = "slide", time=10)
leaf
})
updateMap <- function() {
shinyjs::showElement(selector="#loading p", asis = TRUE,
anim=TRUE, animType = "slide")
selcode <- sel.SA2.code()
selcode <- ifelse(is.na(selcode), 0, selcode)
psel <- selcode %in% shpf@data$SA22018_V1
if (input$radioeduemp == "Employment") {
if (input$radiocolour == "type") {
if (input$radioinout == "work") {
fcols <- startcols.work
if (psel) {
codvs <- work_simp %>% filter(work_code == selcode)
codvs <- codelist %>% left_join(codvs, by=c("sa2_code" = "res_code"))
codvs <- tencols[codvs$MAX]
fcols <- ifelse(is.na(codvs), "#808080", codvs)
}
} else {
fcols <- startcols.res
if (psel) {
codvs <- work_simp %>% filter(res_code == selcode)
codvs <- codelist %>% left_join(codvs, by=c("sa2_code" = "work_code"))
codvs <- tencols[codvs$MAX]
fcols <- ifelse(is.na(codvs), "#808080", codvs)
}
}
lp <- leafletProxy("map", data = shpf) %>%
setShapeStyle(layerId = ~SA22018_V1, fillColor = fcols) %>%
clearControls() %>%
addLegend(position = "topleft",
colors = c(tencols, "#808080"),
labels = transport.t, opacity = 1,
title = HTML("Most Common
Commute Method")
) %>%
clearGroup("hpoly")
} else {
if (input$radioinout == "work") {
if (psel) {
codvs <- work_simp %>% filter(work_code == selcode)
codvs <- codelist %>% left_join(codvs, by=c("sa2_code" = "res_code"))
cvals <- ifelse(codvs$total == 0, NA, codvs$total)
} else {
codvs <- codelist %>%
left_join(work_to, by = c("sa2_code" = "work_code"))
cvals <- ifelse(codvs$total == 0, NA, codvs$total)
}
} else {
if (psel) {
codvs <- work_simp %>% filter(res_code == selcode)
codvs <- codelist %>% left_join(codvs, by=c("sa2_code" = "work_code"))
cvals <- ifelse(codvs$total == 0, NA, codvs$total)
} else {
codvs <- codelist %>%
left_join(work_from, by = c("sa2_code" = "res_code"))
cvals <- ifelse(codvs$total == 0, NA, codvs$total)
}
}
cvr <- range(cvals, na.rm = TRUE)
binner <- colorBin(c("white", "red"), cvr, bins = 7, pretty = TRUE)
lp <- leafletProxy("map", data = shpf) %>%
setShapeStyle(layerId = ~SA22018_V1, fillColor = binner(cvals)) %>%
clearControls() %>%
addLegend(position = "topleft",
pal = binner,
values = cvals, opacity = 1,
na.label = "None",
title = "Number of commuters") %>%
clearGroup("hpoly")
}
} else {
# Education code
if (input$radiocolour == "type") {
if (input$radioinout == "work") {
fcols <- startcols.edu
if (psel) {
codvs <- edu_simp %>% filter(edu_code == selcode)
codvs <- codelist %>% left_join(codvs, by=c("sa2_code" = "res_code"))
codvs <- tencols[codvs$MAX]
fcols <- ifelse(is.na(codvs), "#808080", codvs)
}
} else {
fcols <- startcols.edures
if (psel) {
codvs <- edu_simp %>% filter(res_code == selcode)
codvs <- codelist %>% left_join(codvs, by=c("sa2_code" = "edu_code"))
codvs <- tencols[codvs$MAX]
fcols <- ifelse(is.na(codvs), "#808080", codvs)
}
}
lp <- leafletProxy("map", data = shpf) %>%
setShapeStyle(layerId = ~SA22018_V1, fillColor = fcols) %>%
clearControls() %>%
addLegend(position = "topleft",
colors = c(tencols, "#808080"),
labels = edu.t, opacity = 1,
title = HTML("Most Common
Commute Method")
) %>%
clearGroup("hpoly")
} else {
if (input$radioinout == "work") {
if (psel) {
codvs <- edu_simp %>% filter(edu_code == selcode)
codvs <- codelist %>% left_join(codvs, by=c("sa2_code" = "res_code"))
cvals <- ifelse(codvs$total == 0, NA, codvs$total)
} else {
codvs <- codelist %>%
left_join(edu_to, by = c("sa2_code" = "edu_code"))
cvals <- ifelse(codvs$total == 0, NA, codvs$total)
}
} else {
if (psel) {
codvs <- edu_simp %>% filter(res_code == selcode)
codvs <- codelist %>% left_join(codvs, by=c("sa2_code" = "edu_code"))
cvals <- ifelse(codvs$total == 0, NA, codvs$total)
} else {
codvs <- codelist %>%
left_join(edu_from, by = c("sa2_code" = "res_code"))
cvals <- ifelse(codvs$total == 0, NA, codvs$total)
}
}
cvr <- range(cvals, na.rm = TRUE)
binner <- colorBin(c("white", "red"), cvr, bins = 7, pretty = TRUE)
lp <- leafletProxy("map", data = shpf) %>%
setShapeStyle(layerId = ~SA22018_V1, fillColor = binner(cvals)) %>%
clearControls() %>%
addLegend(position = "topleft",
pal = binner,
values = cvals, opacity = 1,
na.label = "None",
title = "Number of commuters") %>%
clearGroup("hpoly")
}
}
if (psel) {
lp %>% addPolygons(group = "hpoly",
weight = 4,
data = shpf[which(shpf@data$SA22018_V1 == selcode),],
color = "#000000",
fill = FALSE, opacity = 1)
}
shinyjs::hideElement(selector="#loading p", asis=TRUE,
anim=TRUE, animType = "slide",
time = 1)
}
observeEvent(input$map_click, ignoreInit = TRUE, {
cursel <- sel.SA2.code()
p <- input$map_click
pdat <- data.frame(Longitude = p$lng,
Latitude =p$lat)
coordinates(pdat) <- ~ Longitude + Latitude
proj4string(pdat) <- proj4string(shpf)
ppoly <- over(pdat, shpf)
codetmp <- as.numeric(as.character(ppoly[1,"SA22018_V1"]))
codetmp <- ifelse(is.na(codetmp), 0, codetmp)
newsl <- ifelse(sel.SA2.code() == codetmp, 0, codetmp)
if (newsl != cursel) {
sel.SA2.code(newsl)
updateMap()
}
})
observeEvent(input$map_zoom, once=TRUE, {
if (!attribupdate) {
shinyjs::html(selector=".leaflet-control-attribution.leaflet-control",
html = attribhtml)
attribupdate <<- TRUE
}
})
observeEvent(input$map_shape_mouseover, once=TRUE,{
# Backup
if (!attribupdate) {
shinyjs::html(selector=".leaflet-control-attribution.leaflet-control",
html = attribhtml)
attribupdate <<- TRUE
}
})
observeEvent(input$radioeduemp, ignoreInit = TRUE, {
updateMap()
})
observeEvent(input$radioinout, ignoreInit = TRUE, {
updateMap()
})
observeEvent(input$radiocolour, ignoreInit = TRUE, {
updateMap()
})
observeEvent(input$controlswitch, ignoreInit = TRUE, {
if (input$controlswitch) {
shinyjs::showElement("mapcontrol", anim=TRUE,
time = 0.5)
} else {
shinyjs::hideElement("mapcontrol", anim=TRUE,
time = 0.5)
}
})
observeEvent(input$mapinfobutton, ignoreInit = TRUE, {
if (input$mapinfobutton) {
shinyjs::showElement("infopanel", anim=TRUE,
time = 0.5)
} else {
shinyjs::hideElement("infopanel", anim=TRUE,
time = 0.5)
shinyjs::runjs("document.getElementById('map').focus()")
}
})
output$lochtml <- renderUI({
seled <- sel.SA2.code()
seled <- ifelse(is.na(seled), 0, seled)
if (!(seled %in% shpf@data$SA22018_V1)) {
HTML("")
} else {
namesel <- shpf@data$SA22018__1[shpf@data$SA22018_V1 == seled]
if (input$radioeduemp == "Employment") {
if (input$radiocolour == "type") {
str <- sprintf("%s", namesel)
if (input$radioinout == "work") {
str <- sprintf("Commuting method of people who work in
%s
", str)
vals <- as.numeric(work_to[work_to$work_code == seled, 5:15])
vals <- ifelse(is.na(vals), 0, vals)
vals <- ifelse(vals < 0, "~0", as.character(vals))
listi <- paste0(sprintf("%s: %s", cols.labs,
vals),
collapse="")
str <- paste0(hrstr, str, "")
} else {
str <- sprintf("Commuting method of people who live in
%s
", str)
vals <- as.numeric(work_from[work_from$res_code == seled, 5:15])
vals <- ifelse(is.na(vals), 0, vals)
vals <- ifelse(vals < 0, "~0", as.character(vals))
listi <- paste0(sprintf("%s: %s", cols.labs,
vals),
collapse="")
str <- paste0(hrstr, str, "")
}
HTML(str)
} else {
str <- hrstr
if (input$radioinout == "work") {
val <- as.numeric(work_to[work_to$work_code == seled, 15])
val <- ifelse(is.na(val), 0, ifelse(val < 0, 0, val))
str <- sprintf("%s%d people commute to employment in
%s
", str, val, namesel)
if (val > 0) {
subs <- work_simp %>% filter(work_code == seled) %>%
arrange(desc(total)) %>% head(10)
listi <- paste0(sprintf("%s: %s", subs$res_name,
subs$total),
collapse="")
str <- sprintf("%sTop areas to commute from:
", str, listi)
}
} else {
val <- as.numeric(work_from[work_from$res_code == seled, 15])
val <- ifelse(is.na(val), 0, ifelse(val < 0, 0, val))
str <- sprintf("%s%d people commute to employment from
%s
", str, val, namesel)
if (val > 0) {
subs <- work_simp %>% filter(res_code == seled) %>%
arrange(desc(total)) %>% head(10)
listi <- paste0(sprintf("%s: %s", subs$work_name,
subs$total),
collapse="")
str <- sprintf("%sTop areas to commute to:
", str, listi)
}
}
HTML(str)
}
} else {
if (input$radiocolour == "type") {
str <- sprintf("%s", namesel)
if (input$radioinout == "work") {
str <- sprintf("Commuting method of people who commute to
education in
%s
", str)
vals <- as.numeric(edu_to[edu_to$edu_code == seled, 5:15])
vals <- ifelse(is.na(vals), 0, vals)
vals <- ifelse(vals < 0, "~0", as.character(vals))
listi <- paste0(sprintf("%s: %s", cols.edu.labs,
vals),
collapse="")
str <- paste0(hrstr, str, "")
} else {
str <- sprintf("Commuting method to education
of people who live in
%s
", str)
vals <- as.numeric(edu_from[edu_from$res_code == seled, 5:15])
vals <- ifelse(is.na(vals), 0, vals)
vals <- ifelse(vals < 0, "~0", as.character(vals))
listi <- paste0(sprintf("%s: %s", cols.edu.labs,
vals),
collapse="")
str <- paste0(hrstr, str, "")
}
} else {
str <- hrstr
if (input$radioinout == "work") {
val <- as.numeric(edu_to[edu_to$edu_code == seled, 15])
val <- ifelse(is.na(val), 0, ifelse(val < 0, 0, val))
str <- sprintf("%s%d people commute to education in
%s
", str, val, namesel)
if (val > 0) {
subs <- edu_simp %>% filter(edu_code == seled) %>%
arrange(desc(total)) %>% head(10)
listi <- paste0(sprintf("%s: %s", subs$res_name,
subs$total),
collapse="")
str <- sprintf("%sTop areas to commute from:
", str, listi)
}
} else {
val <- as.numeric(edu_from[edu_from$res_code == seled, 15])
val <- ifelse(is.na(val), 0, ifelse(val < 0, 0, val))
str <- sprintf("%s%d people commute to education from
%s
", str, val, namesel)
if (val > 0) {
subs <- edu_simp %>% filter(res_code == seled) %>%
arrange(desc(total)) %>% head(10)
listi <- paste0(sprintf("%s: %s", subs$edu_name,
subs$total),
collapse="")
str <- sprintf("%sTop areas to commute to:
", str, listi)
}
}
}
HTML(str)
}
}
})
output$secondarylochtml <- renderUI({
curshp <- mouseover()
cursel <- sel.SA2.code()
if (curshp == 0) {
if (cursel == 0) {
HTML(paste0(hrstr,
"No area selected. Click on
an area for more information.
"))
} else {
HTML("")
}
} else {
shpname <- shpf@data$SA22018__1[curshp == shpf@data$SA22018_V1]
if (cursel == 0) {
if (input$radioeduemp == "Employment") {
if (input$radioinout == "res") {
fdf <- work_from %>% filter(res_code == curshp)
tot <- ifelse(nrow(fdf) == 0, 0, fdf$total)
ttype <- ifelse(is.na(fdf$MAX) || nrow(fdf) == 0, 0, fdf$MAX)
pmp <- ""
if (ttype != 0) {
pmp <- sprintf("Most common mode of transport: %s",
transport.t[ttype])
}
HTML(sprintf("%s%d people commute to employment from
%s. %s
", hrstr, tot, shpname,
pmp))
} else {
fdf <- work_to %>% filter(work_code == curshp)
tot <- ifelse(nrow(fdf) == 0, 0, fdf$total)
ttype <- ifelse(is.na(fdf$MAX) || nrow(fdf) == 0, 0, fdf$MAX)
pmp <- ""
if (ttype != 0) {
pmp <- sprintf("Most common mode of transport: %s",
transport.t[ttype])
}
HTML(sprintf("%s%d people commute to employment in
%s. %s
", hrstr, tot, shpname,
pmp))
}
} else {
if (input$radioinout == "res") {
fdf <- edu_from %>% filter(res_code == curshp)
tot <- ifelse(nrow(fdf) == 0, 0, fdf$total)
ttype <- ifelse(is.na(fdf$MAX) || nrow(fdf) == 0, 0, fdf$MAX)
pmp <- ""
if (ttype != 0) {
pmp <- sprintf("Most common mode of transport: %s",
edu.t[ttype])
}
HTML(sprintf("%s%d people commute to education from
%s. %s
", hrstr, tot, shpname,
pmp))
} else {
fdf <- edu_to %>% filter(edu_code == curshp)
tot <- ifelse(nrow(fdf) == 0, 0, fdf$total)
ttype <- ifelse(is.na(fdf$MAX) || nrow(fdf) == 0, 0, fdf$MAX)
pmp <- ""
if (ttype != 0) {
pmp <- sprintf("Most common mode of transport: %s",
edu.t[ttype])
}
HTML(sprintf("%s%d people commute to education in
%s. %s
", hrstr, tot, shpname,
pmp))
}
}
} else {
shpname.0 <- shpf@data$SA22018__1[cursel == shpf@data$SA22018_V1]
if (input$radioeduemp == "Employment") {
if (input$radioinout == "res") {
fdf <- work_simp %>% filter(res_code == cursel,
work_code == curshp)
tot <- ifelse(nrow(fdf) == 0, 0, fdf$total)
ttype <- ifelse(is.na(fdf$MAX) || nrow(fdf) == 0, 0, fdf$MAX)
pmp <- ""
if (ttype != 0) {
pmp <- sprintf("Most common mode of transport: %s",
transport.t[ttype])
}
HTML(sprintf("%s%d people commute to employment
in %s from %s. %s
", hrstr, tot, shpname,
shpname.0, pmp))
} else {
fdf <- work_simp %>% filter(work_code == cursel,
res_code == curshp)
tot <- ifelse(nrow(fdf) == 0, 0, fdf$total)
ttype <- ifelse(is.na(fdf$MAX) || nrow(fdf) == 0, 0, fdf$MAX)
pmp <- ""
if (ttype != 0) {
pmp <- sprintf("Most common mode of transport: %s",
transport.t[ttype])
}
HTML(sprintf("%s%d people commute to employment
in %s from %s. %s
", hrstr, tot, shpname.0,
shpname, pmp))
}
} else {
if (input$radioinout == "res") {
fdf <- edu_simp %>% filter(res_code == cursel,
edu_code == curshp)
tot <- ifelse(nrow(fdf) == 0, 0, fdf$total)
ttype <- ifelse(is.na(fdf$MAX) || nrow(fdf) == 0, 0, fdf$MAX)
pmp <- ""
if (ttype != 0) {
pmp <- sprintf("Most common mode of transport: %s",
edu.t[ttype])
}
HTML(sprintf("%s%d people commute to education
in %s from %s. %s
", hrstr, tot, shpname,
shpname.0, pmp))
} else {
fdf <- edu_simp %>% filter(edu_code == cursel,
res_code == curshp)
tot <- ifelse(nrow(fdf) == 0, 0, fdf$total)
ttype <- ifelse(is.na(fdf$MAX) || nrow(fdf) == 0, 0, fdf$MAX)
pmp <- ""
if (ttype != 0) {
pmp <- sprintf("Most common mode of transport: %s",
edu.t[ttype])
}
HTML(sprintf("%s%d people commute to education
in %s from %s. %s
", hrstr, tot, shpname.0,
shpname, pmp))
}
}
}
}
})
}
# Run the application
shinyApp(ui = ui, server = server)