rshinyreactiveflexdashboardgauge
Shiny Flexdashboard Reactive Gauge not Updating
I've added a reactive gauge to my shinyapp. The gauge is to show the most recent Jump Height score compared to the athlete's previous minimum and max value all time.
The selectInput is set for Athlete and the most recent date (max(jumpdata$Date)). My code works perfectly for the reactive gauge max but will not update reactively for the min. When I run the app the min shows for the first Athlete's input and then stays at this same value as I update and select a different input (but the max changes).
I'm not sure where the snag is since the max is updating.
ui.r
library(shiny)
library(shinydashboard)
library(flexdashboard)
library(dplyr)
jumpdata <- read.csv("SO CMJ Dummy.csv")
jumpdata$Date <- as.Date(jumpdata$Date, "%Y-%m-%d")
shinyUI(
fluidPage(
sidebarPanel(width = 3,
selectInput("Athlete", label = "Athlete",
choices = unique(jumpdata$Athlete))),
mainPanel(
fluidRow(
box(title = "Jump Height", gaugeOutput("Gauge_JH"))
))
))
server.r
library(shiny)
library(shinydashboard)
library(flexdashboard)
library(dplyr)
jumpdata <- read.csv("SO CMJ Dummy.csv")
jumpdata$Date <- as.Date(jumpdata$Date, "%Y-%m-%d")
shinyServer(function(input, output){
output$Gauge_JH <- renderGauge({
f <- jumpdata %>%
select(Date, Athlete, JumpHeight_cm) %>%
filter(Athlete == input$Athlete & Date == c(max(jumpdata$Date)))
t <- jumpdata %>%
select(Date, Athlete, JumpHeight_cm) %>%
filter(Athlete == input$Athlete)
g <- gauge(f$JumpHeight_cm, min = min(t$JumpHeight_cm), max = max(t$JumpHeight_cm), symbol = 'cm', gaugeSectors(
success = c((max(t$JumpHeight_cm)*.9), max(t$JumpHeight_cm)), warning = c((max(t$JumpHeight_cm)*.8), max(t$JumpHeight_cm)*.9), danger = c(min(t$JumpHeight_cm), max(t$JumpHeight_cm)*.8)
))
print(g)
})
})
data
jumpdata <- structure(list(Athlete = structure(c(1L, 1L, 1L, 7L, 7L, 7L,
7L, 8L, 8L, 8L, 8L, 9L, 9L, 9L, 9L, 10L, 10L, 10L, 10L, 11L,
11L, 11L, 11L, 12L, 12L, 12L, 12L, 13L, 13L, 13L, 13L, 14L, 14L,
14L, 14L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L, 5L,
5L, 5L, 5L, 6L, 6L, 6L, 6L), .Label = c("Athlete 1", "Athlete 10",
"Athlete 11", "Athlete 12", "Athlete 13", "Athlete 14", "Athlete 2",
"Athlete 3", "Athlete 4", "Athlete 5", "Athlete 6", "Athlete 7",
"Athlete 8", "Athlete 9"), class = "factor"), Date = structure(c(1L,
4L, 5L, 1L, 3L, 5L, 7L, 2L, 3L, 5L, 7L, 1L, 3L, 5L, 7L, 1L, 3L,
5L, 7L, 1L, 3L, 6L, 7L, 2L, 4L, 5L, 8L, 1L, 3L, 5L, 7L, 1L, 3L,
5L, 7L, 1L, 3L, 5L, 7L, 1L, 3L, 5L, 7L, 1L, 3L, 5L, 7L, 1L, 3L,
6L, 7L, 1L, 3L, 5L, 7L), .Label = c("2020-01-06", "2020-01-07",
"2020-01-13", "2020-01-14", "2020-01-21", "2020-01-23", "2020-01-27",
"2020-01-28"), class = "factor"), Position = structure(c(2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 3L,
3L, 3L, 3L, 3L, 3L, 3L), .Label = c("DEF", "FWD", "GOALIE"), class = "factor"),
Program = structure(c(2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 1L, 1L, 1L, 1L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 1L,
1L, 1L, 1L, 2L, 2L, 2L, 2L, 4L, 4L, 4L, 4L, 1L, 1L, 1L, 1L,
4L, 4L, 4L, 4L, 1L, 1L, 1L, 1L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
3L), .Label = c("Navy", "Red", "RTP", "White"), class = "factor"),
mRSI = c(0.36, 0.38, 0.42, 0.46, 0.46, 0.47, 0.48, 0.31,
0.3, 0.24, 0.3, 0.29, 0.26, 0.28, 0.28, 0.36, 0.35, 0.43,
0.43, 0.28, 0.31, 0.28, 0.3, 0.33, 0.36, 0.35, 0.37, 0.37,
0.36, 0.37, 0.36, 0.3, 0.36, 0.34, 0.37, 0.26, 0.28, 0.34,
0.3, 0.39, 0.4, 0.43, 0.43, 0.43, 0.47, 0.46, 0.48, 0.34,
0.36, 0.33, 0.37, 0.28, 0.28, 0.34, 0.33), SystemWeight = c(617.21,
612.4, 620.45, 672.08, 682.23, 670.5, 663.41, 517.33, 515.23,
511.62, 517.85, 697.55, 703.92, 689.43, 691.33, 859.06, 845.9,
850.97, 851.84, 655.79, 665.09, 673.91, 667.92, 626.78, 632.92,
634.52, 624.88, 637.55, 645.6, 648.78, 646.64, 558.03, 563.23,
569.58, 560.95, 693.63, 695.54, 684.37, 684.58, 641.18, 660.8,
663.95, 660, 594.92, 596.97, 591.36, 585.64, 522.35, 518.17,
530.95, 523.5, 780.65, 789.81, 775.84, 775.48), FTCT = c(0.61,
0.62, 0.67, 0.74, 0.75, 0.77, 0.77, 0.54, 0.55, 0.44, 0.53,
0.53, 0.49, 0.53, 0.56, 0.6, 0.58, 0.68, 0.68, 0.53, 0.57,
0.54, 0.55, 0.61, 0.63, 0.64, 0.65, 0.59, 0.58, 0.59, 0.59,
0.51, 0.59, 0.59, 0.59, 0.53, 0.57, 0.63, 0.59, 0.76, 0.76,
0.79, 0.78, 0.67, 0.72, 0.72, 0.74, 0.63, 0.65, 0.61, 0.63,
0.49, 0.5, 0.53, 0.57), JumpHeight_cm = c(28.97, 29.78, 31.43,
35.83, 35.41, 36.59, 36.92, 27.56, 26.11, 26.15, 26.82, 26.15,
25.08, 24.98, 24.62, 29.39, 30.17, 32.42, 32.56, 26.6, 27.25,
25.58, 27.88, 29.17, 31.58, 28.48, 31.24, 33.73, 32.78, 33.09,
33.43, 29.73, 31.91, 30.65, 32.98, 24.15, 24.24, 27.57, 25.44,
26.68, 26.39, 27.43, 28.87, 35.44, 36.29, 35.71, 36.06, 26.79,
27.76, 26.82, 29.71, 28.69, 26.9, 31.12, 29.77), EJH = c(17.6,
18.58, 21.11, 26.66, 26.69, 28.08, 28.38, 14.99, 14.39, 11.41,
14.33, 13.8, 12.34, 13.29, 13.67, 17.58, 17.5, 22.03, 22.19,
14.03, 15.59, 13.92, 15.39, 17.7, 19.75, 18.37, 20.3, 19.99,
18.9, 19.62, 19.61, 15.09, 18.8, 18.18, 19.6, 12.78, 13.87,
17.28, 15.06, 20.44, 20.12, 21.74, 22.52, 23.8, 26.25, 25.68,
26.73, 16.99, 18.13, 16.42, 18.82, 14.09, 13.43, 16.61, 16.9
), Weight = c(62.94, 62.45, 63.27, 68.54, 69.57, 68.38, 67.65,
52.76, 52.54, 52.17, 52.81, 71.13, 71.78, 70.31, 70.5, 87.61,
86.26, 86.78, 86.87, 66.88, 67.82, 68.72, 68.11, 63.92, 64.54,
64.71, 63.72, 65.02, 65.84, 66.16, 65.94, 56.91, 57.44, 58.09,
57.2, 70.74, 70.93, 69.79, 69.81, 65.39, 67.39, 67.71, 67.31,
60.67, 60.88, 60.31, 59.72, 53.27, 52.84, 54.15, 53.39, 79.61,
80.54, 79.12, 79.08)), class = "data.frame", row.names = c(NA,
-55L))
Based on the workaround posted on github, here is my new code but I can't get it to render. I wasn't sure what to include as the input$range based on my original gauge.
ui.r
library(shiny)
library(shinydashboard)
library(flexdashboard)
library(dplyr)
jumpdata <- read.csv("SO CMJ Dummy.csv")
jumpdata$Date <- as.Date(jumpdata$Date, "%Y-%m-%d")
shinyUI(
fluidPage(
sidebarPanel(width = 3,
selectInput("Athlete", label = "Athlete",
choices = unique(jumpdata$Athlete))),
mainPanel(
fluidRow(
box(title = "Jump Height", gaugeOutput("Gauge_JH")),
uiOutput("Gauge_JH_Proxy")
))
))
server.r
library(shiny)
library(shinydashboard)
library(flexdashboard)
library(dplyr)
jumpdata <- read.csv("SO CMJ Dummy.csv")
jumpdata$Date <- as.Date(jumpdata$Date, "%Y-%m-%d")
shinyServer(function(input, output){
output$Gauge_JH <- renderGauge({
f <- jumpdata %>%
select(Date, Athlete, JumpHeight_cm) %>%
filter(Athlete == input$Athlete & Date == c(max(jumpdata$Date)))
t <- jumpdata %>%
select(Date, Athlete, JumpHeight_cm) %>%
filter(Athlete == input$Athlete)
g <- gauge(f$JumpHeight_cm, min = min(t$JumpHeight_cm), max = max(t$JumpHeight_cm), symbol = 'cm', gaugeSectors(
success = c((max(t$JumpHeight_cm)*.9), max(t$JumpHeight_cm)), warning = c((max(t$JumpHeight_cm)*.8), max(t$JumpHeight_cm)*.9), danger = c(min(t$JumpHeight_cm), max(t$JumpHeight_cm)*.8)
))
print(g)
})
output$Gauge_JH_Proxy <- renderUI({
input$Athlete # force re-rendering
gaugeOutput(outputId = "Gauge_JH", width = "30%", height = "200px")
})
})
Solution
It is possible to work around this behaviour by using renderUI and debounce (to delay the rendering, so that the calculations are ready).
Please note, that I've changed the range logic to actually display some colors and see the following:
library(shiny)
library(shinydashboard)
library(flexdashboard)
library(dplyr)
jumpdata <- structure(list(Athlete = structure(c(1L, 1L, 1L, 7L, 7L, 7L,
7L, 8L, 8L, 8L, 8L, 9L, 9L, 9L, 9L, 10L, 10L, 10L, 10L, 11L,
11L, 11L, 11L, 12L, 12L, 12L, 12L, 13L, 13L, 13L, 13L, 14L, 14L,
14L, 14L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L, 5L,
5L, 5L, 5L, 6L, 6L, 6L, 6L), .Label = c("Athlete 1", "Athlete 10",
"Athlete 11", "Athlete 12", "Athlete 13", "Athlete 14", "Athlete 2",
"Athlete 3", "Athlete 4", "Athlete 5", "Athlete 6", "Athlete 7",
"Athlete 8", "Athlete 9"), class = "factor"), Date = structure(c(1L,
4L, 5L, 1L, 3L, 5L, 7L, 2L, 3L, 5L, 7L, 1L, 3L, 5L, 7L, 1L, 3L,
5L, 7L, 1L, 3L, 6L, 7L, 2L, 4L, 5L, 8L, 1L, 3L, 5L, 7L, 1L, 3L,
5L, 7L, 1L, 3L, 5L, 7L, 1L, 3L, 5L, 7L, 1L, 3L, 5L, 7L, 1L, 3L,
6L, 7L, 1L, 3L, 5L, 7L), .Label = c("2020-01-06", "2020-01-07",
"2020-01-13", "2020-01-14", "2020-01-21", "2020-01-23", "2020-01-27",
"2020-01-28"), class = "factor"), Position = structure(c(2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 3L,
3L, 3L, 3L, 3L, 3L, 3L), .Label = c("DEF", "FWD", "GOALIE"), class = "factor"),
Program = structure(c(2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 1L, 1L, 1L, 1L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 1L,
1L, 1L, 1L, 2L, 2L, 2L, 2L, 4L, 4L, 4L, 4L, 1L, 1L, 1L, 1L,
4L, 4L, 4L, 4L, 1L, 1L, 1L, 1L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
3L), .Label = c("Navy", "Red", "RTP", "White"), class = "factor"),
mRSI = c(0.36, 0.38, 0.42, 0.46, 0.46, 0.47, 0.48, 0.31,
0.3, 0.24, 0.3, 0.29, 0.26, 0.28, 0.28, 0.36, 0.35, 0.43,
0.43, 0.28, 0.31, 0.28, 0.3, 0.33, 0.36, 0.35, 0.37, 0.37,
0.36, 0.37, 0.36, 0.3, 0.36, 0.34, 0.37, 0.26, 0.28, 0.34,
0.3, 0.39, 0.4, 0.43, 0.43, 0.43, 0.47, 0.46, 0.48, 0.34,
0.36, 0.33, 0.37, 0.28, 0.28, 0.34, 0.33), SystemWeight = c(617.21,
612.4, 620.45, 672.08, 682.23, 670.5, 663.41, 517.33, 515.23,
511.62, 517.85, 697.55, 703.92, 689.43, 691.33, 859.06, 845.9,
850.97, 851.84, 655.79, 665.09, 673.91, 667.92, 626.78, 632.92,
634.52, 624.88, 637.55, 645.6, 648.78, 646.64, 558.03, 563.23,
569.58, 560.95, 693.63, 695.54, 684.37, 684.58, 641.18, 660.8,
663.95, 660, 594.92, 596.97, 591.36, 585.64, 522.35, 518.17,
530.95, 523.5, 780.65, 789.81, 775.84, 775.48), FTCT = c(0.61,
0.62, 0.67, 0.74, 0.75, 0.77, 0.77, 0.54, 0.55, 0.44, 0.53,
0.53, 0.49, 0.53, 0.56, 0.6, 0.58, 0.68, 0.68, 0.53, 0.57,
0.54, 0.55, 0.61, 0.63, 0.64, 0.65, 0.59, 0.58, 0.59, 0.59,
0.51, 0.59, 0.59, 0.59, 0.53, 0.57, 0.63, 0.59, 0.76, 0.76,
0.79, 0.78, 0.67, 0.72, 0.72, 0.74, 0.63, 0.65, 0.61, 0.63,
0.49, 0.5, 0.53, 0.57), JumpHeight_cm = c(28.97, 29.78, 31.43,
35.83, 35.41, 36.59, 36.92, 27.56, 26.11, 26.15, 26.82, 26.15,
25.08, 24.98, 24.62, 29.39, 30.17, 32.42, 32.56, 26.6, 27.25,
25.58, 27.88, 29.17, 31.58, 28.48, 31.24, 33.73, 32.78, 33.09,
33.43, 29.73, 31.91, 30.65, 32.98, 24.15, 24.24, 27.57, 25.44,
26.68, 26.39, 27.43, 28.87, 35.44, 36.29, 35.71, 36.06, 26.79,
27.76, 26.82, 29.71, 28.69, 26.9, 31.12, 29.77), EJH = c(17.6,
18.58, 21.11, 26.66, 26.69, 28.08, 28.38, 14.99, 14.39, 11.41,
14.33, 13.8, 12.34, 13.29, 13.67, 17.58, 17.5, 22.03, 22.19,
14.03, 15.59, 13.92, 15.39, 17.7, 19.75, 18.37, 20.3, 19.99,
18.9, 19.62, 19.61, 15.09, 18.8, 18.18, 19.6, 12.78, 13.87,
17.28, 15.06, 20.44, 20.12, 21.74, 22.52, 23.8, 26.25, 25.68,
26.73, 16.99, 18.13, 16.42, 18.82, 14.09, 13.43, 16.61, 16.9
), Weight = c(62.94, 62.45, 63.27, 68.54, 69.57, 68.38, 67.65,
52.76, 52.54, 52.17, 52.81, 71.13, 71.78, 70.31, 70.5, 87.61,
86.26, 86.78, 86.87, 66.88, 67.82, 68.72, 68.11, 63.92, 64.54,
64.71, 63.72, 65.02, 65.84, 66.16, 65.94, 56.91, 57.44, 58.09,
57.2, 70.74, 70.93, 69.79, 69.81, 65.39, 67.39, 67.71, 67.31,
60.67, 60.88, 60.31, 59.72, 53.27, 52.84, 54.15, 53.39, 79.61,
80.54, 79.12, 79.08)), class = "data.frame", row.names = c(NA,
-55L))
jumpdata$Date <- as.Date(jumpdata$Date, "%Y-%m-%d")
ui <- fluidPage(
fluidPage(
sidebarPanel(width = 3,
selectInput("Athlete", label = "Athlete",
choices = unique(jumpdata$Athlete))),
mainPanel(
fluidRow(
box(title = "Jump Height", uiOutput("Gauge_JH_Proxy"))
))
))
server <- function(input, output, session) {
output$Gauge_JH <- renderGauge({
g()
})
Athlete <- debounce(reactive({input$Athlete}), 500)
output$Gauge_JH_Proxy <- renderUI({
req(Athlete()) # force rerendering
gaugeOutput("Gauge_JH")
})
g <- reactive({
t <- jumpdata %>%
select(Date, Athlete, JumpHeight_cm) %>%
filter(Athlete == input$Athlete)
f <- t %>% filter(Date == max(Date))
minJump = min(t$JumpHeight_cm)
maxJump = max(t$JumpHeight_cm)
diffJump = maxJump-minJump
gauge(
value = f$JumpHeight_cm,
min = min(t$JumpHeight_cm),
max = max(t$JumpHeight_cm),
sectors = gaugeSectors(
success = c(min(t$JumpHeight_cm) + diffJump * 0.8, max(t$JumpHeight_cm)),
warning = c(min(t$JumpHeight_cm) + diffJump * 0.4, min(t$JumpHeight_cm) + diffJump * 0.8),
danger = c(min(t$JumpHeight_cm), min(t$JumpHeight_cm) + diffJump * 0.4)
),
symbol = 'cm'
)
})
}
shinyApp(ui, server)
However, with all those inconveniences I'd switch the library.
Here is a plotly approach:
library(shiny)
library(shinydashboard)
library(dplyr)
library(plotly)
# jumpdata <- [copy & paste jumpdata here]
jumpdata$Date <- as.Date(jumpdata$Date, "%Y-%m-%d")
ui <- fluidPage(
fluidPage(
sidebarPanel(width = 3,
selectInput("Athlete", label = "Athlete",
choices = unique(jumpdata$Athlete))),
mainPanel(
fluidRow(
plotlyOutput("Gauge_JH_plotly", height = 250, width = "50%")
))
))
server <- function(input, output, session) {
output$Gauge_JH_plotly <- renderPlotly({
t <- jumpdata %>%
select(Date, Athlete, JumpHeight_cm) %>%
filter(Athlete == input$Athlete)
f <- t %>% filter(Date == max(Date))
currentJump = f$JumpHeight_cm
meanJump = mean(t$JumpHeight_cm)
minJump = min(t$JumpHeight_cm)
maxJump = max(t$JumpHeight_cm)
diffJump = maxJump-minJump
success = c(min(t$JumpHeight_cm) + diffJump * 0.8, max(t$JumpHeight_cm))
warning = c(min(t$JumpHeight_cm) + diffJump * 0.4, min(t$JumpHeight_cm) + diffJump * 0.8)
danger = c(min(t$JumpHeight_cm), min(t$JumpHeight_cm) + diffJump * 0.4)
ranges <- unique(c(danger, warning, success))
currentJumpColor <- c("red", "orange", "green")[findInterval(currentJump, ranges, rightmost.closed = TRUE)]
fig <- plot_ly(
domain = list(x = c(0, 1), y = c(0, 1)),
value = currentJump,
title = list(text = "Jump Height [cm]"),
type = "indicator",
mode = "gauge+number+delta",
delta = list(reference = meanJump),
gauge = list(
bar = list(color = currentJumpColor),
axis = list(range = list(minJump, maxJump)),
steps = list(
list(range = danger, color = "lightgray"),
list(range = warning, color = "gray")),
threshold = list(
line = list(color = "green", width = 4),
thickness = 0.75,
value = maxJump)))
fig <- fig %>% layout(margin = list(l=30, r=30, t=80, b=30))
fig
})
}
shinyApp(ui, server)
- How can I download GADM data in R?
- Use dplyr to compute "streaks" in column of data
- Count empty strings?
- How to lookup and sum multiple columns in R
- Is there a way to make the bars' colors conditional to the column?
- How to assign values to a df$column from another df using conditions in R
- Is there a way to read Qlikview data object using R and perform an statistical operation and return results to Qlikview?
- R: Extracting characters from string vectors to data frame rows
- Else if statement to create a new column
- Calculate percentage in a data frame R
- How can I calculate sums of multiple columns without them being summed together into 1 column?
- How to convert a binary file with extension .GRD to .TXT in R?
- How to specify the size of a graph in ggplot2 independent of axis labels
- Using sqldf filter and group by in r dynamically
- Grouping data and reassembling rows as columns
- Coordinates of current mouse position on leaflet map with shiny
- read_csv drops 'f' from end of string
- wes_palettes: How to obtain color hex codes from a wesanderson palette when it set to continuous with more than the predefined colors
- ggplot2 change axis limits for each individual facet panel
- Mixing Rcpp modules and Rcpp::export
- How to create a forest plot that uses estimates obtained from ClubSandwich?
- how to include an abstract in a Rmd file
- Difference between ntile and cut and then quantile() function in R
- Install with devtools::install_github() fails to detect build tools
- How to assign geometry type "polygons" to SpatVector with "null" geometry type using the terra package in R?
- Fitting of nls model in R - manual versus brute force issues
- Likelihood ratio when the difference in the log-likelihood is a large negative number
- How to tally occurrences of same value across columns in R?
- Apply function rowwise() using column names to identify function arguments using mutate()
- writing multiple data frames into the same excel file in R