I am developing a shiny app which steps through time by each hour and shows the precipitation on a mapdeck map. I read in the weather data for the entire day and using reactivity filtering the data for the hour and plotting them as scatterplot using mapdeck_update to update the data. The color scale changes whenever the map updates based on the range of data in that hour. What I want is a static color scale based on the data range for the day. Is it possible?
I have tried using manual colors but for some reason they are not working
library(mapdeck)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
wx_map <- mapdeck(data=NULL,token = Sys.getenv("MAPBOX_API_TOKEN"),style = 'mapbox://styles/mapbox/dark-v9',zoom = 6, location = c(-97,24.5))
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(data=wx_dt,lon = "Center.Longitude",lat = "Center.Latitude",radius = 15000,fill_colour = "vil_int_36",legend = TRUE,layer_id = "wxlyr",update_view = FALSE,focus_layer=FALSE)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
Notice how the range of color scale in the legend changes but the color of the dots stay almost the same. I want the color to represent the min-max of the entire data set (not just the hour) so that I can see change in intensity while stepping through each hour. Thank you.
Good question; you're right you need to create a manual legend so it remains static, otherwise it will update each time the values in the plot update.
The manual legend needs to use the same colours as the map. The map gets coloured by library(colourvalues). So you can use this to make the colours outside of the map, then use the results as the manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
Now this js_legend object is in the correct JSON format for the map to render it as a legend
js_legend
# {"fill_colour":{"colour":["#440154FF","#3B528BFF","#21908CFF","#5DC963FF","#FDE725FF"],"variable":["20.00","23.50","27.00","30.50","34.00"],"colourType":["fill_colour"],"type":["category"],"title":[""],"css":[""]}}
Here it is in your shiny
library(mapdeck)
library(shiny)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
## create a manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
### --------------------------------
wx_map <- mapdeck(
style = 'mapbox://styles/mapbox/dark-v9'
, zoom = 6
, location = c(-97,24.5)
)
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(
data = wx_dt
, lon = "Center.Longitude"
, lat = "Center.Latitude"
, radius = 15000
, fill_colour = "vil_int_36"
, legend = js_legend
, layer_id = "wxlyr"
, update_view = FALSE
, focus_layer = FALSE
)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
Here is my code - creating a dashboard that will filter by date. One tab will show our wellness survey data, the other will show post-practice loading data. I am pulling in the first 3 columns from "post.csv" which are Date, Name, Daily. Then I am looking to create and add the next 3 columns with the math.
Where I am first stuck is that I need my Daily_Load to aggregate data for a specific athlete on the given Date. Then I need to create a rolling 7-day sum for each athlete using the Daily load data from the last 7 days (including Date selected). A 28-Day Rolling Sum/4 and 7-Day/28-Rolling is the last piece.
Thanks again for all of the help!
library(shiny)
library(dplyr)
library(lubridate)
library(ggplot2)
library(DT)
library(zoo)
library(tidyr)
library(tidyverse)
library(data.table)
library(RcppRoll)
AM_Wellness <- read.csv("amwell.csv", stringsAsFactors = FALSE)
Post_Practice <- read.csv("post.csv", stringsAsFactors = FALSE)
Post_Data <- Post_Practice[, 1:3]
Daily_Load <- aggregate(Daily~ ., Post_Data, sum)
Acute_Load <- rollsum(Post_Data$Daily, 7, fill = NA, align = "right")
Chronic_Load <- rollsum(Post_Data$Daily, 28, fill = NA, align = "right")/4
Post_Data['Day Load'] <- aggregate(Daily~ ., Post_Data, sum)
Post_Data['7-Day Sum'] <- Acute_Load
Post_Data['28-Day Rolling'] <- Chronic_Load
Post_Data['Ratio'] <- Acute_Load/Chronic_Load
ui <- fluidPage(
titlePanel("Dashboard"),
sidebarLayout(
sidebarPanel(
dateInput('date',
label = "Date",
value = Sys.Date()
),
selectInput("athleteInput", "Athlete",
choices = c("All"))
),
mainPanel(tabsetPanel(type = "tabs",
tabPanel("AM Wellness", tableOutput("amwell")),
tabPanel("Post Practice", tableOutput("post"))
)
)
)
)
server <- function(input, output) {
output$amwell <- renderTable({
datefilter <- subset(AM_Wellness, AM_Wellness$Date == input$date)
}, hover = TRUE, bordered = TRUE, spacing = "xs", align = "c")
output$post <- renderTable({
datefilter <- subset(Post_Data, Post_Data$Date == input$date)
}, hover = TRUE, bordered = TRUE, spacing = "xs", align = "c")
}
shinyApp(ui = ui, server = server)
I have an r assignment. I am making an interactive plot for a sports team and when I try to calculate the average of the scored goals I keep getting the same error (Error in aggregate.data.frame: arguments must have same length
Stack trace (innermost first)). i tried making the tp variable as data frame and I tried using the tapply function instead of the aggregate but I kept getting the same error.
this is my UI part
library(plotly)
library(ggplot2)
library(plotrix)
ui <- fluidPage(
fluidRow(
column ( width = 3,
h4(span(tagList(icon("filter")), "Select team")),
selectizeInput('team', "", choices = shots$TeamName, selected = TRUE),
br(),
h4(span(tagList(icon("filter")), "Select season")),
selectizeInput('season', "", choices = shots$SeasonNr, selected = TRUE),
br()
)),
plotlyOudataut("pos1")
)
and my server part is:
server <- function(input,oudataut, session){
observeEvent(c(input$team), {
team1 <- input$team
SeasonTx <- input$season
tp <- sqldf(sprintf("select Fullname, Percentage, ShotType, ShotsMade, ShotsNumber, TrainingDate, Position from shots where TeamName is '%s'", team1, "AND SeasonText is '%s'", SeasonTx))
percentageColumn<- aggregate(tp[,4:5], list(tp$TeamName, tp$Position), sum)
percentageColumn$average <- ((percentageColumn$ShotsMade/percentageColumn$ShotsNumber)*100)
colnames(percentageColumn) <- c("Team", "Position", "ShotsMade", "ShotsNumber", "Average")
oudataut$pos1 <-renderPlotly({
plot_ly(x = ~percentageColumn$Position, y = ~percentageColumn$Average, type = 'scatter', mode = 'lines')%>%
layout(title = 'The Average score of the whole team per position',
xaxis = list(title = 'position',dtick=1),
yaxis = list (title = 'Percentage'),xasis=position)
}]
})}
shinyApp(ui, server)
can anyone see the mistake ?
thanks in advance
My data is a matrix with a variable number of columns. Also , the range of values within the matrix is variable, too.
I want to build a variable number of sliderInput, each corresponding to one column in the matrix.
The higher limit of each slider should correspond to the maxRange within the matrix.
Any suggestion how to do it in one shot?
lapply(1:ncol, function(i) {
sliderInput(
paste0('a', i),
paste0('SelectA', i),
min = min(c(1:maxRange)),
max = max(c(1:maxRange)),
value = c(1, maxRange),
step =1
)
}
)
I had broadly similar problem when I wanted to create a set of input elements corresponding to values derived from the data set (min, max list of options, etc.). Broadly speaking, I would source all the required data via global.R and then reference the concepts in the elements, so on the lines of getting min/max in a slider:
global.R
# Get dates for the slider
## Delete pointless month
dta.nom$DATE_NAME <- sub("February ", replacement = "", x = dta.nom$DATE_NAME)
## Convert to number and get min/max
dta.nom$DATE_NAME <- as.numeric(x = dta.nom$DATE_NAME)
yr.min <- min(dta.nom$DATE_NAME)
yr.max <- max(dta.nom$DATE_NAME)
Then in the slider
ui.R
# Select the dates for the data
sliderInput("sliderYears", label = h5("Years"), min = yr.min,
max = yr.max, value = c(2000, 2010), sep = "",
step = 1, animate = FALSE),
Full code is on GitHub. I'm not sure if I understood you correctly but if you are interested in dynamically connecting elements of your interface in Shiny then you can make use of the updateSelectInput. Any other problems with respect to referencing the data should be solvable with use of global code and referencing the values in your interface elements.
In case someone might bump into the same problem, here is my solution:
ui.R
....
sidebarPanel(
selectInput(
inputId = "dataName",
label = "Select your data",
choices = c("data1", "data2", "data3", "data4")
),
uiOutput(outputId = "sliders")
),
.....
server.R
.....
output$sliders <- renderUI({
numSliders <- numCols(input$dataName)
lapply(1:numSliders, function(i) {
sliderInput(
inputId = paste0('column', i),
label = paste0('Select the range for column ', i),
min = min(selectRange(input$dataName)),
max = max(selectRange(input$dataName)),
value = c(min(selectRange(input$dataName)), max(selectRange(input$dataName))),
step =1)
})
})
........
selectRange is a another function in global.R:
global.R
selectRange <- function(x){
if(x == "data1"){choices = c(1:100)}
if(x == "data2"){choices = c(1:50)}
if(x == "data3"){choices = c(1:75)}
if(x == "data4"){choices = c(1:150)}
return(choices)
}
There seems to be some others who are confused by this same issue but after reading and attempting the solutions I found here, I am still stumped. Help!
I have a Shiny App that takes the difference between prices between two dates and returns a list of 4 tables one for each type of Product for each Date, and the same 4 tables for the Price Deltas of the two Dates.
(DATE1, DATE2, DELTA)
On my output screens after Calc, the tables remain empty until the user clicks on the inputSelectors which prompt the table to refresh.
I am still struggling to understand how to get the table to automatically refresh when the Calculation ends.
Here is the logic in my Server.R file concerning the output of one of dataTables:
dataset_HL <- reactive({
switch(input$dataset_HL,
"Deltas" = DELTA$HL,
"Date 1" = DATE1$HL,
"Date 2" = DATE2$HL)
})
termGroup_HL <- reactive({
switch(input$termGroup_HL,
"ALL" = rowIndex$ALL,
"BOM" = rowIndex$BOM,
"QTR" = rowIndex$QTR,
"CAL" = rowIndex$CAL)
})
values_HL <- reactive({
data <- dataset_HL()
colnames(data) <- locations$HL
data <- cbind(Terms = rownames(data), data)
rows <- termGroup_HL()
return(data[rows, ])
})
output$table_HL <- renderDataTable({
datatable(values_HL(),
rownames = FALSE,
options = list(
pageLength = 25,
lengthMenu = c(10, 25, 50, 100)
))
})
Thank you ahead of time.
I found my answer finally and of course it was already answered by Joe Cheng here, Shiny Reactivity.
Simply adding a call to my action button, input$GET_Dates, inside my reactive function triggered the re-calc of the table.
I also simplified my reactive values function.
values_HL <- reactive({
input$GET_Dates
dataset <- switch(input$dataset_HL,
"Deltas" = DELTA$HL,
"Date 1" = DATE1$HL,
"Date 2" = DATE2$HL)
termGroup <- switch(input$termGroup_HL,
"ALL" = rowIndex$ALL,
"BOM" = rowIndex$BOM,
"QTR" = rowIndex$QTR,
"CAL" = rowIndex$CAL)
data <- dataset[termGroup, ]
data <- cbind(Terms = rownames(data), data)
data
})
output$table_HL <- renderDataTable({
datatable(values_HL(),
rownames = FALSE,
options = list(
pageLength = 25,
lengthMenu = c(10, 25, 50, 100)
))
})