R shiny plot colour conditionally based on values on separate data frame - r

I'm fairly new to r and shiny, so bear with me - I have created a plot which shows the accumulated weekly distance covered by players in a sports team, where the user can select the player and the week range. Each player has an individual target distance they should meet and I want the data points in the plot to be green if they have met the target and red if they have not.
The data for weekly distance and target distance are located in different data frames (and they need to be) so I need that when a player is selected in selectInput(), the weekly distance is pulled from the first data frame and the target for the same player is pulled from the second data frame and used for conditional formatting.
EDIT - This is the gps2 data frame (though the PlayerName column lists the actual name which I've changed to initials here):
structure(list(Week = c(14, 14, 14, 14, 14, 15), PlayerName = c("CF",
"DR", "GB", "KB", "RA",
"AM"), Distance = c(3.8088, 2.1279, 2.4239, 1.3565,
4.5082, 4.4097), SprintDistance = c(291.473, 146.97, 11.071,
67.596, 252.787, 0), TopSpeed = c(22.6402, 21.3442, 20.5762,
21.6002, 20.5602, 18.6401)), row.names = c(NA, -6L), groups = structure(list(
Week = c(14, 15), .rows = structure(list(1:5, 6L), ptype = integer(0), class = c("vctrs_list_of",
"vctrs_vctr", "list"))), row.names = 1:2, class = c("tbl_df",
"tbl", "data.frame"), .drop = TRUE), class = c("grouped_df",
"tbl_df", "tbl", "data.frame"))
And the targets data frame:
structure(list(PlayerName = c("AM", "AB", "AMc",
"BC", "CD", "CM"), Distance = c(28.2753333333333,
34.867, NA, 31.633, 34.6122, 32.1405), SprintDistance = c(1355.2,
1074.85, NA, 2426.55, 2430.54, 2447.9), TopSpeed = c(32.61, 30.3,
NA, 36.82, 42, 33.44)), row.names = c(NA, -6L), class = c("tbl_df",
"tbl", "data.frame"))
I have been working on this for a few days now and can't wrap my head around how to do it or find a post which describes what I want to do. So far this is what I have:
# DEFINE UI ####
ui <- fluidPage(
titlePanel("GPS Monitoring Dashboard"),
sidebarLayout(
sidebarPanel(
#select player
selectInput(inputId = "name",
label = strong("Choose player"),
choices = unique(gps2$PlayerName),
selected = "AB"),
#select weeks
numericRangeInput(inputId = "week",
label = strong("Choose weeks"),
value = c(36, 37))),
# graphs and tables
mainPanel(
plotOutput(outputId = "TD"),
tableOutput(outputId = "TDsum"))
)
)
# DEFINE SERVER ####
server <- function(input, output) {
# Total Distance ----
# Data for distance plot
TD_plot <- reactive({
gps2 %>%
filter(PlayerName == input$name,
Week >= input$week [1] &
Week <= input$week [2],
) %>%
select(Distance)
})
# Build distance plot
output$TD <- renderPlot({
ggplot(TD_plot()) +
geom_point(aes(Week, Distance,
color = Distance > 5),
stat = "identity", size = 3) +
scale_color_manual(name = "Target met", values = set_names(c("green", "red"), c(TRUE, FALSE))) +
geom_line(aes(Week, Distance), size = 1) +
labs(title = "Weekly Total Distance", x = "Week", y = "Distance (km)")
})
# Data for distance table
TD_sum <- reactive({
gps2 %>%
filter(PlayerName == input$name,
Week >= input$week [1] &
Week <= input$week [2])%>%
select(Distance) %>%
pivot_wider(.,
names_from = Week,
values_from = Distance)
})
# Build distance table
output$TDsum <- renderTable(TD_sum())
}
shinyApp(ui = ui, server = server)
Right now the data points changes based on an arbitrary value (5) as I was trying to expand on that. I hope this explains in enough detail what I'm trying to do, thanks in advance for your help!

Here's a working example that may be helpful.
First, would left_join your actual distances by players, and their target distances. This will rename columns with "Actual" or "Target" as suffixes to keep them apart.
In geom_point you can use color = DistanceActual > DistanceTarget to have differential color based on whether a distance is greater or less than the target.
I simplified the other functions for demonstration.
library(shiny)
library(tidyverse)
full_data <- left_join(gps2, df_targets, by = "PlayerName", suffix = c("Actual", "Target"))
# DEFINE UI ####
ui <- fluidPage(
titlePanel("GPS Monitoring Dashboard"),
sidebarLayout(
sidebarPanel(
#select player
selectInput(inputId = "name",
label = strong("Choose player"),
choices = unique(full_data$PlayerName),
selected = "player1"),
#select weeks
numericRangeInput(inputId = "week",
label = strong("Choose weeks"),
value = c(36, 37))),
# graphs and tables
mainPanel(
plotOutput(outputId = "TD"),
tableOutput(outputId = "TDsum"))
)
)
# DEFINE SERVER ####
server <- function(input, output) {
# Filter by week and player name
TD_data <- reactive({
full_data %>%
filter(PlayerName == input$name,
Week >= input$week [1],
Week <= input$week [2])
})
# Build distance plot
output$TD <- renderPlot({
ggplot(TD_data()) +
geom_point(aes(Week, DistanceActual, color = DistanceActual > DistanceTarget), stat = "identity", size = 3) +
scale_color_manual(name = "Target met", values = set_names(c("green", "red"), c(TRUE, FALSE))) +
geom_line(aes(Week, DistanceActual), size = 1) +
labs(title = "Weekly Total Distance", x = "Week", y = "Distance (km)")
})
# Build distance table
output$TDsum <- renderTable(
TD_data() %>%
select(Week, DistanceActual)
)
}
shinyApp(ui = ui, server = server)

Related

How do you specify variables when rending a formattable table in shiny?

I'm trying to create and render an interactive formattable table in a shiny app.
Here is a sample dataframe:
tcharts <- data.frame(pgm = c(1,2,3,4,5,6,7,8),
horse = c("Cigar", "Funny Cide", "Animal Kingdom", "Blame", "Zenyatta", "New Years Day", "Northern Dancer", "Beautiful Pleasure"),
groundloss = c(55,70,85,42,90,45,53,50),
distanceRun = c(5050,5070,5085,5045,5090,5045,5053,5050),
ttl = c(50,70,85,42,90,45,53,50),
fps = c(52.3,51.8,51.9,52.0,53.6,52.9,53.7,53.1),
finishTime = c(52.3,51.8,51.9,52.0,53.6,52.9,53.7,53.1),
finish = c(4,7,1,2,5,6,3,8),
BL = c(0,1,2,6,2,9,6,8),
rnum = c(1,1,1,1,1,1,1,1),
sixteenth = c(330,330,330,330,330,330,330)
)
Working version
This version of the code, when list() is empty (use all variables in dataframe) produces a table as expected.
library(shiny)
library(formattable)
inputPanel(
selectInput("rnum", label = "Race Number:",
choices = c(1,2,3,4,5,6,7,8,9), selected = 1),
sliderInput("poc", label = "Point of Call:",
min = 330, max = 5280, value = 330, step = 330)
)
cdat <- reactive({
tcharts %>% filter(rnum %in% input$rnum) %>%
filter(Sixteenth %in% input$poc)
})
renderFormattable({
formattable(cdat(),list(
))
})
Error Version:
With this version, I get an ERROR: object pgm not found
library(shiny)
library(formattable)
inputPanel(
selectInput("rnum", label = "Race Number:",
choices = c(1,2,3,4,5,6,7,8,9), selected = 1),
sliderInput("poc", label = "Point of Call:",
min = 330, max = 5280, value = 330, step = 330)
)
cdat <- reactive({
tcharts %>% filter(rnum %in% input$rnum) %>%
filter(Sixteenth %in% input$poc)
})
renderFormattable({
formattable(cdat(),list(
pgm,
Horse
))
})
The error message leads me to believe I'm not specifying the variable correctly, but I'm not sure how to do it. I'v looked at several formattable / shiny SO questions and responses, but have not come up with the correct sytax.

R and Shiny: object not found

EDITED to include full UI and sample data
I did read the other StackOverflow qs on this issue, but none seemed to address the cause of my error.
When the app loads, I get "error object [name of district I've selected] not found" for the District (inputID = "d"). I know it must be an issue with the subsetting reactive in the server, but I've tried everything (loading the data in the server, removing the vector from the filter function, changing the data type of the variables).
I also took this code from another Shiny App I built, which works. I can't see any differences between the two, besides that one is geom_point() and this is geom_col() so again, not sure what is going on.
Thanks!
Sample data:
sample <- sample_n(pop, 10)
dput(sample)
structure(list(GazID = c(NA, NA, "13872", NA, "13610", "13985",
"13984", "13434", "13428", "13631"), Province = c("Niolandskaia",
"Kaluzhskaia", "Iaroslavskaia", "Vyborgskaia", "Moskovskaia",
"Volynskaia", "Volynskaia", "Orenburgskaia", "Orenburgskaia",
"Arkhangel'skaia"), District = c(NA, "Suhinichinbezuezdniigorod",
"Romanov", NA, "Zvenigorod", "Kovel", "Lutsk", "Ufa", "Orenburg",
"Mezen"), TotalPop = c(NA, NA, 104104, NA, 71746, 103381, 102779,
93145, 62740, 26796), Male = c(NA, NA, 48604, NA, 36948, 52266,
50393, 46403, 32617, 13078), Female = c(NA, NA, 55500, NA, 34798,
51115, 52386, 46742, 30123, 13718), City = c(NA, 5552, NA, NA,
1253, 4254, 5552, 6682, 9533, NA), Rural = c(NA, NA, NA, NA,
70493, 99127, 97228, 86483, 53207, NA)), row.names = c(NA, -10L
), class = c("tbl_df", "tbl", "data.frame"))
Above the UI:
library(tidyverse)
library(readr)
library(shiny)
library(stringr)
library(rebus)
pop <- read_csv("pop.csv")
pop$TotalPop <- str_replace_all(pop$TotalPop, pattern = fixed(","), replacement = "")
pop$Male <- str_replace_all(pop$Male, pattern = fixed(","), replacement = "")
pop$Female <- str_replace_all(pop$Female, pattern = fixed(","), replacement = "")
pop$City <- str_replace_all(pop$City, pattern = fixed(","), replacement = "")
pop$Rural <- str_replace_all(pop$Rural, pattern = fixed(","), replacement = "")
pop$District <- str_remove_all(pop$District, pattern = "[^[:alnum:]]")
pop$TotalPop <- as.numeric(pop$TotalPop)
pop$Male <- as.numeric(pop$Male)
pop$Female <- as.numeric(pop$Female)
pop$City <- as.numeric(pop$City)
pop$Rural <- as.numeric(pop$Rural)
pop$GazID <- as.character(pop$GazID)
pop$District <- str_trim(pop$District)
The UI:
ui <- fluidPage(
titlePanel("Population Data from VSO"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "y", #internal label
label = "Population to map", #label that user sees
choices = c("Total population" = "TotalPop",
"Male population" = "Male",
"Female population" = "Female",
"Urban population" = "City",
"Rural population" = "Rural"),
selected = "TotalPop"),
selectizeInput(inputId = "d",
label = "Select district",
choices = c(pop$District),
multiple = TRUE, # can choose multiple
options = list(maxItems = 5))),
mainPanel(
plotOutput("plot")
)
)
)
The server:
server <- function(input, output) {
pop_subset <- reactive({
req(input$d)
filter(pop, District %in% c(input$d)
)})
output$plot <- renderPlot({
ggplot(data = pop_subset(), aes_string(x = pop_subset()$District, y = input$y)) +
geom_col(aes(fill = pop_subset()$District)) +
labs(x = "District", y = "Population") +
scale_fill_discrete(name = "Districts")
})}
shinyApp(ui = ui, server = server)
The problem is that you are using aes_string in your ggplot, but trying to pass District without quotes. I realize you need aes_string because you are using input$y, so just change your plot call to
output$plot <- renderPlot({
req(pop_subset())
ggplot(data = pop_subset(), aes_string(x = "District", y = input$y)) +
geom_col(aes(fill = District)) +
labs(x = "District", y = "Population") +
scale_fill_discrete(name = "Districts")
})
For reproducibility, packages and some sample data (no idea of its true representative nature, doesn't really matter I think).
library(dplyr)
library(shiny)
library(ggplot2)
set.seed(42)
n <- 50
pop <- data_frame(
TotalPop = sample(1e4, size=n, replace=TRUE)
) %>%
mutate(
Male = pmax(0, TotalPop - sample(1e4, size=n, replace=TRUE)),
Female = TotalPop - Male,
City = sample(LETTERS, size=n, replace=TRUE),
District = sample(letters, size=n, replace=TRUE)
)

How to use RShiny reactiveFileReader with reactiveUI and non-existent files?

How would I build a reactive UI that responds to a reactiveFileReader with varying data inputs?
I'm interested in integrating a reactiveFileReader into an app that graphs groups within the data and shows selected points group by group.
Challenges:
Not every file I can identify from the prefix and suffix exists.
There are varying number of groups per file.
CRASHES/FAILS WHEN I
Attempt to open a non-existent file.
Update a file (so it does detect that there was a change)
POTENTIAL SOLUTIONS:
Slow down/delay the next steps after reading the data so it can re-load the data. Fixed via a reactive() and req()
isolate() the dependent UI so it only changes the # of groups the first time a file is loaded.
I included mock data (and its generation), a UI, the broken server, and a working server that doesn't have the reactive file reader.
UPDATES
The only thing left is to have the renderUI 'group' not reset the moment the file is reread. Normally it's a good thing, but here I don't want that.
Packages
library(tidyr); library(dplyr); library(ggplot2); library(readr); library(stringr)
library(shiny)
#library(DT)
Mock Data
a1 <- structure(list(Group = c("alpha_1", "alpha_1", "alpha_2", "alpha_2", "alpha_3", "alpha_3"), Sample = c("ps_1", "ps_2", "ps_1", "ps_2", "ps_1", "ps_2"), x = c(1, 1.1, 4, 4.1, 6.8, 7), y = c(2.1, 2, 7.3, 7, 10, 9.7)), .Names = c("Group", "Sample", "x", "y"), row.names = c(NA,-6L), class = c("tbl_df", "tbl", "data.frame"), spec = structure(list(cols = structure(list(Group = structure(list(), class = c("collector_character", "collector")),Sample = structure(list(), class = c("collector_character","collector")), x = structure(list(), class = c("collector_double", "collector")), y = structure(list(), class = c("collector_double", "collector"))), .Names = c("Group", "Sample", "x", "y")), default = structure(list(), class = c("collector_guess", "collector"))), .Names = c("cols", "default"), class = "col_spec"))
a2 <- structure(list(Group = c("alpha_6", "alpha_6", "alpha_7", "alpha_7", "alpha_9", "alpha_9", "alpha_10", "alpha_10"), Sample = c("ps_1", "ps_2", "ps_1", "ps_2", "ps_1", "ps_2", "ps_1", "ps_2"), x = c(3,3.2, 5, 5.1, 1, 1.1, 5, 5.1), y = c(8.1, 7, 3, 4, 14, 15, 4,3)), .Names = c("Group", "Sample", "x", "y"), row.names = c(NA, -8L), class = c("tbl_df", "tbl", "data.frame"), spec = structure(list(cols = structure(list(Group = structure(list(), class = c("collector_character", "collector")), Sample = structure(list(), class = c("collector_character","collector")), x = structure(list(), class = c("collector_double", "collector")), y = structure(list(), class = c("collector_double", "collector"))), .Names = c("Group", "Sample", "x", "y")), default = structure(list(), class = c("collector_guess", "collector"))), .Names = c("cols", "default"), class = "col_spec"))
b2 <- structure(list(Group = c("beta_3", "beta_3", "beta_4", "beta_4", "beta_6", "beta_6"), Sample = c("ps_1", "ps_2", "ps_1", "ps_2", "ps_1", "ps_2"), x = c(3, 3.2, 5, 5.1, 1, 1.1), y = c(8.1, 7, 3, 4, 14, 15)),.Names = c("Group", "Sample", "x", "y"), row.names = c(NA, -8L), class = c("tbl_df", "tbl", "data.frame"), spec = structure(list(cols = structure(list(Group = structure(list(), class = c("collector_character", "collector")), Sample = structure(list(), class = c("collector_character","collector")), x = structure(list(), class = c("collector_double", "collector")), y = structure(list(), class = c("collector_double", "collector"))), .Names = c("Group", "Sample", "x", "y")), default = structure(list(), class = c("collector_guess", "collector"))), .Names = c("cols", "default"), class = "col_spec"))
b3 <- structure(list(Group = c("beta_3", "beta_3", "beta_4", "beta_4", "beta_6", "beta_6"), Sample = c("ps_1", "ps_2", "ps_1", "ps_2", "ps_1", "ps_2"), x = c(3, 3.2, 5, 5.1, 1, 1.1), y = c(8.1, 7, 3, 4, 14, 15)), .Names = c("Group", "Sample", "x", "y"), row.names = c(NA, -8L), class = c("tbl_df", "tbl", "data.frame"), spec = structure(list(cols = structure(list(Group = structure(list(), class = c("collector_character", "collector")), Sample = structure(list(), class = c("collector_character","collector")), x = structure(list(), class = c("collector_double", "collector")), y = structure(list(), class = c("collector_double", "collector"))), .Names = c("Group", "Sample", "x", "y")), default = structure(list(), class = c("collector_guess", "collector"))), .Names = c("cols", "default"), class = "col_spec"))
# Data export to simulate the problem
lz_write <- function(input) {
write_csv(input, paste0(substitute(input), ".csv"))
}
lz_write(a1); lz_write(a2); lz_write(b2); lz_write(b3) # Messed up function for lapply...
# rm(list = ls()) # Clean the environment
UI
ui <- fluidPage(
titlePanel("Minimal Example"),
fluidRow(
column(width = 2, class = "well",
# File selection
HTML(paste("Which file?")),
# Prefix:
selectInput(inputId = "p",
label = "Prefix:",
choices = c("a", "b", "c"),
selected = "a"),
# Suffix:
numericInput(inputId = "s",
label = "Suffix:",
min = 1,
max = 3,
value = 1,
step = 1)),
column(width = 10,
plotOutput(outputId = "scatterplot",
dblclick = "plot_dblclick", # Might not be necessary, but it's not more work to include but more work to exclude
brush = brushOpts(id = "plot_brush", resetOnNew = TRUE)))
),
fluidRow(
column(width = 3,
br(),
uiOutput(outputId = "group_n")),
column(width = 9,
fixedRow(
column(width = 3,
HTML(paste0("Arg 1"))),
column(width = 3,
HTML(paste0("Arg 2"))),
column(width = 3,
uiOutput(outputId = "num_2"))
)
)
),
fluidRow(
br(), br(), br(), #Lets add some gaps or spacing
DT::dataTableOutput(outputId = "Table")) # Summary table
) # Not sure if actually necessary for this example
Broken Server
It's only problem right now is that the UI resets the moment the file is re-read...
server_broken <- function(input, output, session) { # Broken version
#Larger subset: A Reactive Expression # May be used later...
args <- reactive({
list(input$p, input$s) #which file do we wish to input. This was our tag
})
# Reactive File-reader Subset
path <- reactive({
paste0(input$p, input$s, ".csv")
}) # Reactive Filename, kinda like our args...
filereader <- function(input) { # The function we pass into a reactive filereader.
suppressWarnings(read_csv(input, col_types = cols(
Group = col_character(),
Sample = col_character(),
x = col_double(),
y = col_double())
))
}
##BROKEN REACTIVE FILE READER HERE##
data_1 <- reactiveValues() # The function we use for livestream data
observe({
if(file.exists(path()) == TRUE) {
fileReaderData <- reactiveFileReader(500, session, path(), filereader)
} else {
message("This file does not exist")
## OR DO I DO SOMETHING ELSE HERE??##
}
data_1$df <- reactive({
## STOPS APP CRASHING, BUT NO LONGER REFRESHES CONSTANTLY ##
req(fileReaderData())
fileReaderData()
})
}) # Honestly don't understand still
data <- reactive(data_1$df()) # Pulling things out just so the rest of our code can stay the same.
## END OF BROKEN FILE READER##
## Reactive UI HERE##
data_m <- reactive({
req(data())
args()
tmp <- isolate(select(data(), Group))
tmp %>% distinct()
}) # number of groups
output$num_2 <- renderUI({
req(data())
numericInput(inputId = "n",
label = "Group:",
min = 1,
max = length(data_m()$Group),
value = 1
)
}) #This is our 'reactive' numeric input for groups. This caps the max of our function based on the number of groups there are per file
n <- reactive(input$n) #which marker number we are dealing with.
## End of reactive UI##
data_n <- reactive({
req(data()); req(data_m())
dt <- filter(data(), Group == data_m()[[1]][input$n])
})
# Create scatterplot object the plotOutput function is expecting ----
ranges <- reactiveValues(x = NULL, y = NULL)
output$scatterplot <- renderPlot({
validate(need(data(), "The specified file does not exist. Please try another"))
p <- as.numeric(input$p)
plot <- ggplot(data_n(), aes(x, y)) +
labs(title = paste0("Group ", data_n()$Group[1])) +
labs(x = "X vals", y = "Y vals") +
geom_point() + theme_bw() # I already have customized aesthetics. Removed for minimalism
plot + coord_cartesian(xlim = ranges$x, ylim = ranges$y, expand = TRUE) # So we see all points more readily. messes up the zoom but oh well
})
# When a double-click happens, check if there's a brush on the plot.
# If so, zoom to the brush bounds; if not, reset the zoom.
observeEvent(input$plot_dblclick, {
brush <- input$plot_brush
if (!is.null(brush)) {
ranges$x <- c(brush$xmin, brush$xmax)
ranges$y <- c(brush$ymin, brush$ymax)
} else {
ranges$x <- NULL
ranges$y <- NULL
}
})
#Creating text ----
output$group_n <- renderText({
req(data())
paste0("There are ", length(data_m()$Group), " groups in this file.",
tags$br("This is Group: ", data_m()$Group[n()])
)
})
#Building a table for you to visibly see points. You may need to update the DT to the github version ----
output$Table <- DT::renderDataTable({
req(data())
brushedPoints(data_n(), brush = input$plot_brush) %>%
select(Sample)
})
}
Functional Server
It has been removed since the broken one at least doesn't crash, and the problem is apparent. See previous edits for the original.
Sources consulted
Interactive file input and reactive reading in shinyapp
https://github.com/rstudio/shiny/issues/167
Looking for inspiration on isolate and observers
https://groups.google.com/forum/#!topic/shiny-discuss/QgdUfWGsuVU
Session Info
R version 3.4.2 (2017-09-28)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 7 x64 (build 7601) Service Pack 1
UPDATES
Placing a reactive within an Observe() stopped the app from crashing, AND it does update the files (forgot to delete some stuff). All that's left is saving the dependent UI somewhere...
In short, problems were due to not properly understanding the logic of observers, missing a () after a reactive, and not calling req to stop certain parts from re-executing (see HERE).
Specific line-by-line updates can be found by looking for ##CHANGE: below... The most important changes (in no significant order) are:
Using isolate() for the renderUI
Using req() in the renderUI to slow it down and not run until there is an update in the # of groups, but calling args() to make it dependent upon the file selection
pre-calculating the # of groups outside the renderUI
Updated Server
server_fixed <- function(input, output, session) {
#Larger subset: A Reactive Expression # May be used later...
args <- reactive({
list(input$p, input$s) #which file do we wish to input. This was our tag
})
# Reactive File-reader Subset
path <- reactive({
paste0(input$p, input$s, ".csv")
}) # Reactive Filename, kinda like our args...
filereader <- function(input) { # The function we pass into a reactive filereader.
suppressWarnings(read_csv(input, col_types = cols(
Group = col_character(),
Sample = col_character(),
x = col_double(),
y = col_double())
))
}
data_1 <- reactiveValues() # The function we use for livestream data
observe({
if(file.exists(path()) == TRUE) {
fileReaderData <- reactiveFileReader(500, session, path(), filereader)
} else {
message("This file does not exist")
}
data_1$df <- reactive({
# if(exists(fileReaderData())) {
# fileReaderData()
# } # Crashed from the beginning
req(fileReaderData())
fileReaderData()
})
})
data <- reactive(data_1$df()) ##CHANGE: FORGOT THE ()##
# Group setting...
data_m <- reactive({
req(data())
args()
tmp <- isolate(select(data(), Group))
tmp %>% distinct()
}) #number of markers, keeping only the marker name
data_m_length <- reactive({ ##CHANGE: TOOK OUT OF output$num_2##
##CHANGE: ADDED AN ISOLATE to fix the # of groups per file ##
isolate(length(data_m()$Group))
})
output$num_2 <- renderUI({
req(data_m_length()) ## CHANGE: ONLY EXECUTE ONCE WE HAVE OUR isolated data_m_length##
args() ## CHANGE: DEPENDENT UPON changing files##
isolate(
numericInput(inputId = "n",
label = "Group:",
min = 1,
max = data_m_length(),
value = 1 # THIS SHOULD BE CACHED!
)) ##CHANGE: ADDED IT IN ISOLATE when testing. NOT SURE IF STILL NEEDED##
}) #This is our 'reactive' numeric input for groups. This caps the max of our function based on the number of groups there are per file
n <- reactive(input$n) #which marker number we are dealing with.
data_n <- reactive({
req(data()); req(data_m())
dt <- filter(data(), Group == data_m()[[1]][n()])
})
# Create scatterplot object the plotOutput function is expecting ----
ranges <- reactiveValues(x = NULL, y = NULL)
output$scatterplot <- renderPlot({
validate(need(data(), "The specified file does not exist. Please try another"))
p <- as.numeric(input$p)
plot <- ggplot(data_n(), aes(x, y)) +
labs(title = paste0("Group ", data_n()$Group[1])) +
labs(x = "X vals", y = "Y vals") +
geom_point() + theme_bw() # I already have customized aesthetics. Removed for minimalism
plot + coord_cartesian(xlim = ranges$x, ylim = ranges$y, expand = TRUE) # So we see all points more readily. messes up the zoom but oh well
})
# When a double-click happens, check if there's a brush on the plot.
# If so, zoom to the brush bounds; if not, reset the zoom.
observeEvent(input$plot_dblclick, {
brush <- input$plot_brush
if (!is.null(brush)) {
ranges$x <- c(brush$xmin, brush$xmax)
ranges$y <- c(brush$ymin, brush$ymax)
} else {
ranges$x <- NULL
ranges$y <- NULL
}
})
#Creating text ----
output$group_n <- renderText({
req(data())
paste0("There are ", length(data_m()$Group), " groups in this file.",
tags$br("This is Group: ", data_m()$Group[n()])
)
})
#Building a table for you to visibly see points. You may need to update the DT to the github version ----
output$Table <- DT::renderDataTable({
req(data())
brushedPoints(data_n(), brush = input$plot_brush) %>%
select(Sample)
})
}
All that's left is to use suppressError and validate appropriately.

multiple selection in checkboxGroupInput and plotting in shiny

In my shiny app I have a checkboxGroupInput
How should I do the plot command in server function, in a way that I plot the TurbInt_mean against MeanWindSpeed_mean and add lines (curves) to the plot by user selection ?
I have tried to summaries my shiny app as reproduce-able code as follow (you have to first load the sample data that I have provided)
library(shiny)
ui <- fluidPage(
checkboxGroupInput("variable", "Select IEC Classes for TI",c("A Plus" = "ap","A" = "a","B" = "b","C"="c")),
plotOutput("plotmeanTI",width = "100%") )
server <- function(input, output, session){
output$plotmeanTI <- renderPlot({
plot(as.matrix(TI_plot[,1]),as.matrix(TI_plot[,2]),t='o',ylim=c(0,1),xaxs="i",
xlab="Mean Wind Speed", ylab="<TI>")
if(input$variable=="ap"){lines(as.matrix(TI_plot[,1]),TI_plot$NTM_A_Plus_mean,col=6)}
if(input$variable=="a"){lines(as.matrix(TI_plot[,1]),TI_plot$NTM_A_mean,col=2)}
if(input$variable=="b"){lines(as.matrix(TI_plot[,1]),TI_plot$NTM_B_mean,col=3)}
if(input$variable=="c"){lines(as.matrix(TI_plot[,1]),TI_plot$NTM_C_mean,col=4)}
})
}
shinyApp(ui=ui,server=server)
If user select 1, one curve should be added, if select more than one, I want to have multiple curves added to my plot.I can do it for single selection like I have explained in my code, but when I have multi selection it does not work.
My data set looks like :
dput(TI_plot)
structure(list(MeanWindSpeed_mean = c(0.292023070097604, 1.12011882699226,
2.0283906614786, 3.00947886508396, 4.01428066037736, 5.01250749719984,
6.0080377166157, 7.00777409860191, 8.0049941822883, 9.00201938353988,
9.99646762244478, 10.9883558855227, 11.9798700705476, 12.976996101646,
13.9653724394786, 14.9495068163593, 15.9628459343795, 16.9708685581934,
17.9623943661972, 18.992621231979, 19.9643220338983, 20.9834693877551,
22.0170278637771, 22.9658904109589, 24.0025266903915, 24.9935025380711
), TurbInt_mean = c(3.02705430346051, 0.420402191213343, 0.264195029831388,
0.215109260166585, 0.18794121258946, 0.16699392997796, 0.148261539245668,
0.134479958525654, 0.122038442146089, 0.110595865904036, 0.097103704211826,
0.0836329541372291, 0.0708397249149876, 0.0622491842333237, 0.0591184473929236,
0.0611678829190056, 0.0652080242510699, 0.0690131441806601, 0.073762588028169,
0.0756961992136304, 0.0805696610169492, 0.0817446428571429, 0.0830263157894737,
0.0827277397260274, 0.0749537366548043, 0.0765532994923858),
NTM_A_Plus_mean = c(Inf, 1.10260388189292, 0.642329939163608,
0.473065816856713, 0.387417559923049, 0.336769624752903,
0.303163441845455, 0.27908457313955, 0.261084722917897, 0.247090026094941,
0.235918715179959, 0.226796351934008, 0.219190019655214,
0.212713243118379, 0.20720881268079, 0.202452008587075, 0.19816685602934,
0.19441329542209, 0.191131377464549, 0.188086340606011, 0.185500707351721,
0.18304730715887, 0.180790073836667, 0.178898058874634, 0.177002145398197,
0.175335040729601), NTM_A_mean = c(Inf, 0.98009233946037,
0.570959945923208, 0.420502948317078, 0.344371164376044,
0.299350777558136, 0.269478614973738, 0.248075176124045,
0.232075309260353, 0.219635578751059, 0.209705524604408,
0.201596757274674, 0.194835573026857, 0.189078438327448,
0.184185611271814, 0.179957340966289, 0.176148316470525,
0.172811818152969, 0.169894557746266, 0.167187858316455,
0.164889517645975, 0.162708717474551, 0.160702287854815,
0.159020496777452, 0.157335240353953, 0.155853369537423),
NTM_B_mean = c(Inf, 0.857580797027824, 0.499589952682807,
0.367940079777444, 0.301324768829038, 0.261931930363369,
0.23579378810202, 0.217065779108539, 0.203065895602809, 0.192181131407176,
0.183492334028857, 0.176397162615339, 0.1704811263985, 0.165443633536517,
0.161162409862837, 0.157462673345503, 0.154129776911709,
0.151210340883848, 0.148657738027983, 0.146289376026898,
0.144278327940228, 0.142370127790232, 0.140614501872963,
0.139142934680271, 0.137668335309708, 0.136371698345246),
NTM_C_mean = c(Inf, 0.735069254595278, 0.428219959442406,
0.315377211237809, 0.258278373282033, 0.224513083168602,
0.202108961230303, 0.186056382093034, 0.174056481945265,
0.164726684063294, 0.157279143453306, 0.151197567956005,
0.146126679770143, 0.141808828745586, 0.13813920845386, 0.134968005724717,
0.132111237352894, 0.129608863614727, 0.127420918309699,
0.125390893737341, 0.123667138234481, 0.122031538105913,
0.120526715891111, 0.119265372583089, 0.118001430265464,
0.116890027153068)), class = c("tbl_df", "tbl", "data.frame"
), row.names = c(NA, -26L), .Names = c("MeanWindSpeed_mean",
"TurbInt_mean", "NTM_A_Plus_mean", "NTM_A_mean", "NTM_B_mean",
"NTM_C_mean"))
the head of TI_plot is like :
head(TI_plot)
# A tibble: 6 x 6
MeanWindSpeed_mean TurbInt_mean NTM_A_Plus_mean NTM_A_mean NTM_B_mean NTM_C_mean
<dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 0.2920231 3.0270543 Inf Inf Inf Inf
2 1.1201188 0.4204022 1.1026039 0.9800923 0.8575808 0.7350693
3 2.0283907 0.2641950 0.6423299 0.5709599 0.4995900 0.4282200
4 3.0094789 0.2151093 0.4730658 0.4205029 0.3679401 0.3153772
5 4.0142807 0.1879412 0.3874176 0.3443712 0.3013248 0.2582784
6 5.0125075 0.1669939 0.3367696 0.2993508 0.2619319 0.2245131
We could use switch
library(shiny)
ui <- fluidPage(
checkboxGroupInput("variable", "Select IEC Classes for TI",c("A Plus" = "ap","A" = "a","B" = "b","C"="c"),
selected = c("A Plus" = "ap")),
plotOutput("plotmeanTI",width = "100%")
)
server <- function(input, output, session){
output$plotmeanTI <- renderPlot({
f1 <- function(nm1){
switch(nm1,
ap = lines(TI_plot[[1]],TI_plot$NTM_A_Plus_mean,col=6),
a = lines(TI_plot[[1]],TI_plot$NTM_A_mean,col=2),
b = lines(TI_plot[[1]],TI_plot$NTM_B_mean,col=3),
c = lines(TI_plot[[1]],TI_plot$NTM_C_mean,col=4)
)
}
if(is.null(input$variable)) {
plot(TI_plot[[1]], TI_plot[[2]],t='o',ylim=c(0,1),xaxs="i",
xlab="Mean Wind Speed", ylab="<TI>")
} else {
plot(TI_plot[[1]], TI_plot[[2]],t='o',ylim=c(0,1),xaxs="i",
xlab="Mean Wind Speed", ylab="<TI>")
f1(input$variable)
}
})
}
shinyApp(ui=ui,server=server)
-output
Using ggplot2
library(shiny)
library(ggplot2)
library(tidyr)
library(dplyr)
ui <- fluidPage(
checkboxGroupInput("variable", "Select IEC Classes for TI",c("A Plus" = "ap","A" = "a","B" = "b","C"="c"),
selected = c("A Plus" = "ap")),
plotOutput("plotmeanTI",width = "100%") )
server <- function(input, output, session){
output$plotmeanTI <- renderPlot({
keyvaldata <- data.frame(key = c('NTM_A_Plus_mean', 'NTM_A_mean', 'NTM_B_mean', 'NTM_C_mean' ),
Var = c('ap', 'a', 'b', 'c'), stringsAsFactors = FALSE)
p1 <- gather(TI_plot, key, val, -MeanWindSpeed_mean, -TurbInt_mean) %>%
left_join(., keyvaldata) %>%
filter(Var %in% input$variable) %>%
ggplot(., aes(MeanWindSpeed_mean, TurbInt_mean, colour = Var)) +
geom_line() +
geom_line(aes(y =val)) +
labs(x = "Mean Wind Speed", y = "<TI>") +
theme_bw()
if(is.null(input$variable)) {
ggplot(TI_plot, aes(MeanWindSpeed_mean, TurbInt_mean)) +
geom_line() +
labs(x = "Mean Wind Speed", y = "<TI>") +
theme_bw()
} else {
p1
}
})
}
shinyApp(ui=ui,server=server)
-output

Trim data frame using input select in ggvis & shiny

I'm trying to add an input slider that will trim the data frame which is being used to create a ggvis object as following:
runApp(list(
ui = bootstrapPage(
ggvisOutput("p"),
uiOutput("p_ui")
),
server = function(..., session) {
for_plot[age>input_slider(0, 300, value = 0, step = .1, label = "Trim first values") ] %>% ggvis(x = ~age, y = ~sum) %>%
layer_points() %>%
bind_shiny("p", "p_ui")
}
))
I'm getting the following error:
Listening on http://127.0.0.1:4088
Error in age > input_slider(0, 300, value = 0, step = 0.1, label = "Trim first values") :
comparison (6) is possible only for atomic and list types
The Data:
> dput(for_plot)
structure(list(age = -1:137, sum = c(2.9127625202, 1136.15788767452,
273.533113629, 182.577023, 259.43127, 252.508971, 275.684614,
215.032984, 175.90742, 148.352428, 113.003169, 161.357073209,
115.466020271, 156.797340424, 175.038016749, 176.488390764, 91.7729895453,
91.7239276033, 98.9969827211, 102.388825709, 163.942421421, 118.938171624,
134.030560948, 145.528713073, 84.0943510378, 115.900420968, 160.417479634,
141.631984678, 168.467217905, 181.655436653, 148.207568964, 124.859941782,
183.997252898, 156.513051044, 188.82588873, 137.168202013, 123.305076295,
218.081338481, 141.886229086, 93.1080326721, 135.859208991, 227.694944957,
144.246245253, 97.2852532409, 63.379350963, 100.227810825, 127.057637341,
138.673543227, 122.797269725, 127.785499103, 78.9781895255, 94.6973510316,
81.2852298166, 77.0061306202, 101.976840318, 83.4868494245, 68.6421595439,
119.399666, 61.027956, 90.133668, 88.624048, 58.100079, 46.529205,
70.834879, 57.513635, 65.62522, 59.748113, 51.254763, 60.01,
60.041919, 105.772536, 85.564368969, 89.6614592424, 42.607413704,
52.3980349542, 62.0695635701, 85.9011843079, 64.7162277064, 56.1468546477,
46.9516467187, 56.0426098096, 130.354148072, 165.365221108, 69.6146107006,
40.1394275162, 77.6468523819, 60.8783613406, 62.6635625966, 105.87122289,
55.6055641606, 61.8159765316, 72.1644279856, 74.4649577482, 80.1998824221,
45.9350257767, 103.843842017, 98.9039021267, 59.1849148128, 67.5026269702,
52.0332749562, 216.69104441, 85.9505852324, 104.008136809, 200.005094773,
102.962733793, 56.2068235785, 41.0352422907, 51.7020950197, 33.2931629372,
65.704230091, 79.6758468335, 79.4543446244, 103.260073438, 76.7873225476,
37.6227208976, 40.6325385694, 70.9006911716, 51.4076995898, 38.1693658093,
109.9354882, 95.8973745099, 19.0864056748, 69.3897454729, 61.7374836761,
66.5707198551, 63.8689019338, 42.7001939824, 14.5081003557, 40.127732022,
65.8789453554, 95.1309843037, 8.6965147506, 34.625986323, 44.5887916163,
14.4472523862, 35.7203407751, 10.0911065622, 30.1301061724, 12.9129026453
)), .Names = c("age", "sum"), row.names = c(NA, -139L), class = c("data.table",
"data.frame"), .internal.selfref = <pointer: 0x0000000001390788>)
Thanks For any help on that!
There were some syntax errors in your for_plot filtering above. Also used a shiny slider instead.
library(shiny)
library(ggvis)
for_plot <- structure(
list(age = -1:137,
sum = c(2.9127625202, 1136.15788767452,
273.533113629, 182.577023, 259.43127, 252.508971, 275.684614,
215.032984, 175.90742, 148.352428, 113.003169, 161.357073209,
115.466020271, 156.797340424, 175.038016749, 176.488390764, 91.7729895453,
91.7239276033, 98.9969827211, 102.388825709, 163.942421421, 118.938171624,
134.030560948, 145.528713073, 84.0943510378, 115.900420968, 160.417479634,
141.631984678, 168.467217905, 181.655436653, 148.207568964, 124.859941782,
183.997252898, 156.513051044, 188.82588873, 137.168202013, 123.305076295,
218.081338481, 141.886229086, 93.1080326721, 135.859208991, 227.694944957,
144.246245253, 97.2852532409, 63.379350963, 100.227810825, 127.057637341,
138.673543227, 122.797269725, 127.785499103, 78.9781895255, 94.6973510316,
81.2852298166, 77.0061306202, 101.976840318, 83.4868494245, 68.6421595439,
119.399666, 61.027956, 90.133668, 88.624048, 58.100079, 46.529205,
70.834879, 57.513635, 65.62522, 59.748113, 51.254763, 60.01,
60.041919, 105.772536, 85.564368969, 89.6614592424, 42.607413704,
52.3980349542, 62.0695635701, 85.9011843079, 64.7162277064, 56.1468546477,
46.9516467187, 56.0426098096, 130.354148072, 165.365221108, 69.6146107006,
40.1394275162, 77.6468523819, 60.8783613406, 62.6635625966, 105.87122289,
55.6055641606, 61.8159765316, 72.1644279856, 74.4649577482, 80.1998824221,
45.9350257767, 103.843842017, 98.9039021267, 59.1849148128, 67.5026269702,
52.0332749562, 216.69104441, 85.9505852324, 104.008136809, 200.005094773,
102.962733793, 56.2068235785, 41.0352422907, 51.7020950197, 33.2931629372,
65.704230091, 79.6758468335, 79.4543446244, 103.260073438, 76.7873225476,
37.6227208976, 40.6325385694, 70.9006911716, 51.4076995898, 38.1693658093,
109.9354882, 95.8973745099, 19.0864056748, 69.3897454729, 61.7374836761,
66.5707198551, 63.8689019338, 42.7001939824, 14.5081003557, 40.127732022,
65.8789453554, 95.1309843037, 8.6965147506, 34.625986323, 44.5887916163,
14.4472523862, 35.7203407751, 10.0911065622, 30.1301061724, 12.9129026453
)), .Names = c("age", "sum"), row.names = c(NA, -139L),
class = c("data.table", "data.frame")
)
runApp(list(
ui = bootstrapPage(
ggvisOutput("p"),
sliderInput("agetrimlim", "Trim first values:", min = 0, max = 300, value = 0, step= 1)
),
server = function(input,output, session) {
output$p <- renderGvis({
input$agetrimlim
for_plot[for_plot$age>input$agetrimlim,] %>% ggvis(x = ~age, y = ~sum) %>% bind_shiny('p')
})
}
))
Yielding:

Resources