Trim data frame using input select in ggvis & shiny - r

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:

Related

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

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)

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.

R shiny cannot coerce type 'closure' to vector of type 'double'

I' trying to modify pch parameter of plot by inserting an input from selectInput:
selectInput("points", "Points:",
list("Job lost" = "joblost",
"Sex" = "sex",
))
into
output$Plot <- renderPlot({
plot(as.formula(formula()),data=Benefits,
main = caption(), pch = as.numeric(input$points),
col=as.numeric(input$points))
})
Unfortunately, I get an error: cannot coerce type 'closure' to vector of type 'double'. What steps should I take to fix this ? Of course, both joblost and sex are factors.
Full code:
library(shiny)
library(Ecdat)
attach(Benefits)
u <- shinyUI(pageWithSidebar(
headerPanel("Social benefits"),
sidebarPanel(
selectInput("variable1", "Zmienna X:",
list("Bezrobocie" = "stateur",
"Max zasilek" = "statemb",
"Wiek" = "age",
"Staz w bezrobociu" = "tenure",
"Replacement rate" = "rr"
)),
selectInput("variable2", "Zmienna Y:",
list("Bezrobocie" = "stateur",
"Max zasilek" = "statemb",
"Wiek" = "age",
"Staz w bezrobociu" = "tenure",
"Replacement rate" = "rr"
)),
selectInput("points", "Punkty:",
list("Powod utraty pracy" = "joblost",
"Plec" = "sex",
"Nie-bialy" = "nwhite",
">12 lat szkoly" = "school12",
"Robotnik fizyczny" = "bluecol",
"Mieszka w miescie" = "smsa",
"Zonaty" = "married",
"Ma dzieci" = "dkids",
"Male dzieci" = "dykids",
"Glowa rodziny" = "head",
"Otrzymuje zasilki" = "ui"
)),
checkboxInput("reg", "Pokaz krzywa regresji", FALSE)
),
mainPanel(
plotOutput("Plot")
)
))
s <- shinyServer(function(input, output)
{
formula <- reactive({paste(input$variable2,"~",input$variable1)})
caption <- renderText({formula()})
pkt <- reactive({input$points})
#pkt <- renderText({paste(input$points)})
output$Plot <- renderPlot({
plot(as.formula(formula()),data=Benefits,
main = caption(), pch = as.numeric(input$points),
col=as.numeric(input$points))
if(input$reg == TRUE){
abline(lm(as.formula(formula())),col ="red", lwd = 2)
legend("topleft",inset = 0.02, legend = "Krzywa regresji",
col="red",lty = 1, lwd = 2)
}
})
})
shinyApp(u,s)
The issue was resolved by using a switch in selectInput:
pkt <- reactive({
switch(input$points,
"Powod utraty pracy" = joblost,
"Plec" = sex,
"Nie-bialy" = nwhite,
">12 lat szkoly" = school12,
"Robotnik fizyczny" = bluecol,
"Mieszka w miescie" = smsa,
"Zonaty" = married,
"Ma dzieci" = dkids,
"Male dzieci" = dykids,
"Glowa rodziny" = head,
"Otrzymuje zasilki" = ui)
})
txt <- renderText({paste(input$points)})
output$Plot <- renderPlot({
plot(as.formula(formula()),data=Benefits,
main = caption(), pch = as.numeric(pkt()),
col=as.numeric(pkt()))

Calculating eucledian distance inside reactive dataframe in shiny

I am trying to do some transformation to the reactive dataframe in shiny. I want to use the function euc.dist to the reactive dataframe bathy_new() in the code below.
Here is the reproducible example:
library(shiny)
ui <- fluidRow(
numericInput(inputId = "n", "Group ", value = 1),
plotOutput(outputId = "plot")
)
server <- function(input, output){
bathy <- structure(list(`Corrected Time` = structure(c(
1512040500, 1512040500,
1512040501, 1512040502, 1512040502, 1512040503
), class = c(
"POSIXct",
"POSIXt"
), tzone = "UTC"), Longitude = c(
-87.169858, -87.169858,
-87.1698618, -87.1698652, -87.1698652, -87.16986785
), Latitude = c(
33.7578743,
33.7578743, 33.75788237, 33.75789018, 33.75789018, 33.75789717
), `Depth (m)` = c(
3.95096, 3.82296, 3.63096, 3.57096, 3.48096,
3.32096
), easting = c(
484269.60819222, 484269.60819222, 484269.257751374,
484268.944306767, 484268.944306767, 484268.700169299
), northing = c(
3735323.04565401,
3735323.04565401, 3735323.94098565, 3735324.80742908, 3735324.80742908,
3735325.58284154
), diff = c(0, 0, 0, 0, 0, 0), group = c(
1, 1,
1, 2, 2, 2
)), .Names = c(
"Corrected Time", "Longitude", "Latitude",
"Depth (m)", "easting", "northing", "diff", "group"
), row.names = c(
NA,
-6L
), class = c("tbl_df", "tbl", "data.frame"))
euc.dist <- function(x1, y1, x2, y2){
distance <- sqrt((x2-x1)^2 + (y2-y1)^2)
return(distance)
}
#
bathy_new <- reactive({
bathy %>% dplyr::filter(group == input$n)
})
test <- bathy_new()
dist <- NULL
for (i in 1:nrow(test)){
dist <- euc.dist(x1 = test[i, "easting"] %>% .$easting,
y1 = test[i, "northing"] %>% .$northing,
x2 = test[i+1, 'easting'] %>% .$easting,
y2 = test[i+1, 'northing'] %>% .$northing)
}
test$dist <- dist
output$plot <- renderPlot(
qplot(cumsum(test$dist), bathy_new()$`Depth (m)`)
)
}
shinyApp(ui, server)
The data here is very small data compared to my original set. But the goal is to find eucledian distance between points in each group. In this small dataset, I have 2 groups ; 1 and 2.
I keep getting the following error
Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
I can run this code outside of shiny just fine but not sure how to deal with reactive data.
This is the chunk of code where there is error:
test <- bathy_new()
dist <- NULL
for (i in 1:nrow(test)){
dist <- euc.dist(x1 = test[i, "easting"] %>% .$easting,
y1 = test[i, "northing"] %>% .$northing,
x2 = test[i+1, 'easting'] %>% .$easting,
y2 = test[i+1, 'northing'] %>% .$northing)
}
test$dist <- dist
Eventually, I want to plot cumulative distance cum(dist) and depth Depth (m).
The reason you're getting that error is because you actually tried to assign a reactive to the variable test. This can only be done from inside a reactive expression or observer.
So what you need to do is to place that code inside of a reactive expression, such as renderPlot.
output$plot <- renderPlot({
test <- bathy_new()
dist <- NULL
for (i in 1:(nrow(test) - 1)){
dist <- euc.dist(x1 = test[i, "easting"] %>% .$easting,
y1 = test[i, "northing"] %>% .$northing,
x2 = test[i+1, 'easting'] %>% .$easting,
y2 = test[i+1, 'northing'] %>% .$northing)
}
test$dist <- dist
qplot(cumsum(test$dist), bathy_new()$`Depth (m)`)
})
This should get rid of the error, however I think you may have some trouble with your for loop as well. You iterate through 1:nrow(test) but you calculate with i+1 inside the loop. Because of this dist is going to be NA and thus your plot will not show anything.
I modified your loop to iterate through 1:(nrow(test) - 1) in order to get valid results.
I would also like to point out the way Shiny works. Shiny runs code outside of the server function once per R process, then runs code inside the server function once per connection. And then there are reactives which run every time their dependency changes.
See this topic for more help
So it is better to define data and functions outside of the server function, since they only need to run once. If they are inside the server function they are ran every single time a new user is connected to the app which works but it is not efficient.
Full code:
library(shiny)
library(magrittr)
library(ggplot2)
bathy <- structure(list(`Corrected Time` = structure(c(
1512040500, 1512040500,
1512040501, 1512040502, 1512040502, 1512040503
), class = c(
"POSIXct",
"POSIXt"
), tzone = "UTC"), Longitude = c(
-87.169858, -87.169858,
-87.1698618, -87.1698652, -87.1698652, -87.16986785
), Latitude = c(
33.7578743,
33.7578743, 33.75788237, 33.75789018, 33.75789018, 33.75789717
), `Depth (m)` = c(
3.95096, 3.82296, 3.63096, 3.57096, 3.48096,
3.32096
), easting = c(
484269.60819222, 484269.60819222, 484269.257751374,
484268.944306767, 484268.944306767, 484268.700169299
), northing = c(
3735323.04565401,
3735323.04565401, 3735323.94098565, 3735324.80742908, 3735324.80742908,
3735325.58284154
), diff = c(0, 0, 0, 0, 0, 0), group = c(
1, 1,
1, 2, 2, 2
)), .Names = c(
"Corrected Time", "Longitude", "Latitude",
"Depth (m)", "easting", "northing", "diff", "group"
), row.names = c(
NA,
-6L
), class = c("tbl_df", "tbl", "data.frame"))
euc.dist <- function(x1, y1, x2, y2){
distance <- sqrt((x2-x1)^2 + (y2-y1)^2)
return(distance)
}
ui <- fluidRow(
numericInput(inputId = "n", "Group ", value = 1),
plotOutput(outputId = "plot")
)
server <- function(input, output){
bathy_new <- reactive({
bathy %>% dplyr::filter(group == input$n)
})
output$plot <- renderPlot({
test <- bathy_new()
dist <- NULL
for (i in 1:(nrow(test) - 1)){
dist <- euc.dist(x1 = test[i, "easting"] %>% .$easting,
y1 = test[i, "northing"] %>% .$northing,
x2 = test[i+1, 'easting'] %>% .$easting,
y2 = test[i+1, 'northing'] %>% .$northing)
}
test$dist <- dist
qplot(cumsum(test$dist), bathy_new()$`Depth (m)`)
})
}
shinyApp(ui, server)

Resources