# Shiny dashboard for the Center for Writing and
# The Northeast Writing Across the Curriculum Consortium.
# Plots school locations with an information box containing school information.
# Richard A. Lent, Jan 10 16:23:07 2018.
library(shiny)
library(shinydashboard)
#>
#> Attaching package: 'shinydashboard'
#> The following object is masked from 'package:graphics':
#>
#> box
library(leaflet)
library(leaflet.extras)
library(maps)
library(googlesheets)
library(stringr)
library(htmltools)
fields <- c("instname", "lat", "lon", "url", "logoURL", "info")
# This performs authentication using a stored Google Sheets OAuth token obtained with gs_auth().
gs_auth(token = "googlesheets_token.rds")
#> Auto-refreshing stale OAuth token.
table <- "Schools for NEWACC project" # The name of the Google Sheet.
sheet <- gs_title(table) # Register the Google Sheet.
#> Sheet successfully identified: "Schools for NEWACC project"
bounds <- map('state',
c('Massachusetts', 'Vermont', 'New Hampshire', 'Maine', 'Rhode Island', 'Connecticut',
'New Jersey', 'New York', 'Pennsylvania'),
fill=TRUE, plot=FALSE)
theTitle <- HTML("Institutions of <a href='http://newacc.wac.colostate.edu' target='_blank'>The Northeast Writing Across the Curriculum Consortium</a>")
header <- dashboardHeader(title = theTitle, titleWidth = 650, disable = FALSE)
sidebar <- dashboardSidebar(disable = TRUE)
body <- dashboardBody(
# Custom CSS to make the title background area the same color as the rest of the header.
tags$head(tags$style(HTML('
.skin-blue .main-header .logo {
background-color: #3c8dbc;
}
.skin-blue .main-header .logo:hover {
background-color: #3c8dbc;
}
'))),
fluidRow(
box(leafletOutput("theMap", height = 700), title = "Click a site for more information.", solidHeader = TRUE, status = "info"),
box(htmlOutput("markerData"), title = "Site Data", solidHeader = TRUE, status = "info", width = 4)
),
fluidRow(
box("Row 2, Box 1", title = "Placeholder 1", solidHeader = TRUE, status = "info"),
box("Row 2, Box 2.", title = "Placeholder 2", solidHeader = TRUE, status = "info")
)
)
ui <- dashboardPage(header, sidebar, body, skin = "black")
server <- function(input, output, session) {
sheetData <- gs_read(sheet)
# Build an HTML content string.
sheetData$content <- paste0(
"<center><img src='", sheetData$logoURL, "'", " alt='logo'", " height='200' width='300'", "></center>",
"<br><h3>", sheetData$info, "</h3><br><br>",
"<a href='", sheetData$url, "' target='_blank'>", "website", "</a>"
)
output$theMap <- renderLeaflet({
leaflet(data = sheetData) %>%
# Center map on the vicinity of Williamstown, Massachusetts.
setView(-73.262695, 42.740128, zoom = 6) %>%
# The following line will restrict the map view to the given coordinates.
# setMaxBounds( -76.14405, 47.64953, -64.432627, 36.207562) %>%
addProviderTiles("CartoDB.Positron", group = "Map") %>%
addProviderTiles("Esri.WorldImagery", group = "Satellite") %>%
addProviderTiles("Esri.WorldShadedRelief", group = "Relief") %>%
addMarkers(lng = ~lon, lat = ~lat, label = ~instname, group = "Sites",
layerId = ~instname, popup = ~content) %>%
addPolygons(data=bounds, group="States", weight=2, fillOpacity = 0) %>%
addScaleBar(position = "bottomleft") %>%
addLayersControl(
position = "bottomleft",
baseGroups = c("Map", "Satellite", "Relief"),
overlayGroups = c("States", "Sites"),
options = layersControlOptions(collapsed = FALSE)
) %>%
addSearchFeatures(targetGroup = "Sites",
options = searchFeaturesOptions(position = "topleft",
textPlaceholder = "Search for a school...", textErr = "Location not found.")) %>%
addEasyButton(easyButton(
icon='fa-globe', title='Zoom to Full Extent',
onClick=JS("function(btn, map){map.setView([42.740128, -73.262695], 6);}")))
}) # renderLeaflet
# THIS DOES NOT WORK WHEN SEARCHING FOR A SCHOOL USING addSearchFeatures.
observeEvent(input$theMap_marker_click, {
mdata <- input$theMap_marker_click$id
print(mdata) # This is NOT printed following use of addSearchFeatures.
siteInfo <- sheetData[which(sheetData$instname == mdata),]
output$markerData <- renderText(siteInfo$content)
})
} # server
shinyApp(ui, server)
#> Error in appshot.shiny.appobj(structure(list(httpHandler = function (req) : appshot of Shiny app objects is not yet supported.