How to subset data based on inputs from renderUI - r

I am trying to subset my data based on inputs from renderUI. This data would then be passed to further work in an observe chunk.
Below is an example, where there is an issue with the server code. I am having difficulties with the code recognising the input to an if clause - or more accurately it starts of NULL and then "Every row" from the input is recognised. If I uncomment carbData() in observe below I get the following error. Also receive a similar error if I move the subset inside the observe environment.
Listening on http://127.0.0.1:7400
NULL ### from check()
Warning: Error in if: argument is of length zero
61: reactive:carbData [#9]
45: carbData
44: [#17]
1: runApp
Is this due to some delayed evaluation from using renderUI? If so, or otherwise how do I fix it please?
My code:
server <- function(input, output) {
amData <- reactive({ mtcars[am %in% input$am, ] })
output$gear <- renderUI({ selectInput("Gear", "GEAR",
choices=unique(amData()[, "gear"]), selected=4 ) })
gearData <- reactive({ amData()[gear %in% input$Gear, ] })
output$carb <- renderUI({ selectInput("Carb", "CARB",
choices=c("Every row", unique(gearData()[, "carb"])), selected="Every row") })
carbData <- reactive({ if(input$Carb %in% "Every row") gearData() else gearData()[ carb %in% input$Carb ] }) #### PROBLEM
# Some text where it can be seen that input$Carb is initially NULL
check <- reactive({ p <- input$Carb; print(p) })
observe({
check();
# problems with if clause in both of these:
# carbData()
# Moving the data subset inside `observe` doesn't help
# df <- if(input$Carb %in% "Every row") gearData() else gearData()[ carb %in% input$Carb ]
})
}
And the rest of the code to allow it to run:
library(shiny)
library(shinydashboard)
data(mtcars); data.table::setDT(mtcars)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
selectInput("am", "AM", unique(mtcars$am), selected = "0"),
uiOutput("gear"),
uiOutput("carb")
)),
dashboardBody())
runApp(shinyApp(ui, server))

I'm a bit uncertain whether this question is closed. However, I took the luxury of editing your codes to locate the problem.
I used tibbles instead of data.table as I am not familiar with the syntax. So far #stefan is absolutely correct, req(input$Carb) will relieve you of your troubles.
The reason that gear %in% input$Gear works, and input$Carb %in% "Every row" does not, is that the reactive-hierachy does not favor input$Carb, and as it is null at startup, you are essentially testing NULL %in% "Every Row". Where as gear exists by construction at app start up.
This is not, as Im certain that you are aware of, the same as input$Carb %in% "NULL", or NULL for that matter.
This is your code that I played around with,
server <- function(input, output) {
amData <- reactive({
mtcars %>% filter(am %in% input$am)
})
gearData <- reactive({
amData() %>% filter(gear %in% input$Gear)
})
output$gear <- renderUI({
selectInput("Gear",
"GEAR",
choices = unique(amData()[, "gear"]),
selected = 4)
})
output$carb <- renderUI({
selectInput(
"Carb",
"CARB",
choices = c("Every row", unique(gearData()[, "carb"])),
selected = "Every row"
)
})
carbData <-
reactive({
req(input$Carb)
if (input$Carb %in% "Every row")
gearData()
else
gearData() %>% filter(carb %in% input$Carb)
}) #### PROBLEM
# Some text where it can be seen that input$Carb is initially NULL
check <- reactive({
p <- input$Carb
print(p)
})
observe({
check()
# problems with if clause in both of these:
carbData()
})
}

Related

Renaming coulmns names of a reactive dataframe in Shiny

I have an R dataframe with several columns and I'd like users to select one column to plot against time. However, when I try to run this code, I get an error message.
country <- reactive({
input$variable
})
date_start <- reactive({
input$dateRange[1]
})
date_end <- reactive({
input$dateRange[2]
})
new_data <- reactive({
data[which(data$location== country() & data$date >= date_start() & data$date<=date_end()),c("date","location",input$info)]
names(new_data()) <- c("date", "location", "col1")
})
The error is:
Error in names(new_data()) <- c("date", "location", "col1") :
invalid (NULL) left side of assignment
Can anyone help me with that, please?
This should do the trick:
new_data <- reactive({
data_selection <- data[which(data$location== country() & data$date >= date_start() & data$date<=date_end()),c("date","location",input$info)]
colnames(data_selection) <- c("date", "location", "col1")
data_selection
})
You were referencing the reactive value inside the reactive call, which is then assigned to the new_data. Because this happens before the assignment, the value of the new_data within the call is null. Fortunately there is no need to do that.
Note: as you didn't post your data, I had no way to actually test your code.
However here is a minimal working example to illustrate the concept:
library(shiny)
ui <- fluidPage(
dataTableOutput("geysers")
)
server <- function(input, output) {
test <- reactive({
a <- faithful[1:3,]
colnames(a) <- c("a", "b")
a
})
output$geysers <- renderDataTable({test()})
}
shinyApp(ui = ui, server = server)

How does the pipe (|) in dplyr work in the context of Shiny and datatables?

I have a basic recreation of the component of an app that I am building in Shiny here:
library(dplyr)
library(shiny)
library(DT)
test <- as.data.frame(structure(state.abb, names=state.name))
test <- tibble::rownames_to_column(test, "state_name")
names(test)[2] <- "state_abb"
statedata <- tibble::rownames_to_column(as.data.frame(state.x77), "state_name")
globaldata <- merge(statedata,test, by.x = "state_name", by.y = "state_name")
ui <- fluidPage(
selectInput("states", "States:", sort(c("All states"="", structure(state.abb, names=state.name), "Washington, DC"="DC", "Puerto Rico" = "PR")), multiple=TRUE),
dataTableOutput("table")
)
server <- function(input, output, session) {
filterData <- reactive({
globaldata %>% filter(is.null(input$states) | state_abb %in% input$states) #how does this work???
})
output$table <- renderDataTable({
filterData()
})
}
shinyApp(ui = ui, server = server)
This is exactly the functionality that I am going for with the state filter but I am very confused about how the reactive dataframe works i.e., what condition is being resolved inside the filter statement. Technically, the is.null condition is being met to return the full table when no specific states are selected but there is no value in input$states that is NULL. "All states" = "" which is not equal to NULL so why is that condition being met?

How to prevent output from running twice when inputs are inter-dependent?

I'm developping an R Shiny-based application.
I want to keep my input consistent with available data, thus I update the selected values in selectInput.
When I change selected value in input 1, then the value of input 2 is updated, then the data is updated (just once). OK
BUT if I change selected value in input 2, then the data is updated, then the value of input 1 is updated, then the data is updated AGAIN.
Check out the "check latest_value" that is printed twice.
Initially I used renderUI rather than updateSelectInput, but at initialisation, the data is computed twice.
library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
# Running a Shiny app object
app <- shinyApp(
ui = bootstrapPage(
selectInput('type','Choix du type',choices = unique(my_data$Type)),
uiOutput('plant_ui'),
DTOutput('plot')
),
server = function(input, output) {
data=reactive({
# req(input$type)
my_data_temp=my_data
if(length(input$type)>0){
my_data_temp=my_data_temp%>%filter(Type%in%input$type)
}
if(length(input$plant)>0){
my_data_temp=my_data_temp%>%filter(Plant%in%input$plant)
}
my_data_temp
})
latest_plant_value=reactive({
if(is.null(input$plant))data()$Plant[1]
else input$plant
})
output$plant_ui=renderUI({
sub_data=data()
selectInput(inputId = 'plant',"filtre par plant",choices = unique(sub_data$Plant),
selected=latest_plant_value())
})
output$plot <- renderDT({
print("check latest_value")
datatable(data()) })
}
)
runApp(app)
That's why I decided to use updateSelectInput based on this Alternate control of a sliderInput between a derived value and user selected value but the sequential structure of the code makes the data to be computed twice when I change input 2 value.
library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
# Running a Shiny app object
app <- shinyApp(
ui = bootstrapPage(
selectInput('type','Choix du type',choices = unique(my_data$Type),selected=my_data$Type[1]),
selectInput('plant','Choix du type',choices = unique(my_data$Plant),selected=my_data$Plant[1]),
DTOutput('plot')
),
server = function(input, output,session) {
data=reactive({
# req(input$type)
my_data_temp=my_data
if(length(input$type)>0){
my_data_temp=my_data_temp%>%filter(Type%in%input$type)
}
if(length(input$plant)>0){
my_data_temp=my_data_temp%>%filter(Plant%in%input$plant)
}
my_data_temp
})
observeEvent(input$type,{
print("update type changed")
updateSelectInput(session, "plant",
selected = unique(my_data%>%filter(Type%in%input$type)%>%.$Plant)[1])
})
observeEvent(input$plant,{
print("update plant changed")
updateSelectInput(session, "type",
selected = unique(my_data%>%filter(Plant%in%input$plant)%>%.$Type)[1])
})
output$plot <- renderDT({
print("check latest_value")
datatable(data()) })
}
)
runApp(app)
Fixes like this one don't work in that case because I'm not trying to achieve the same thing three interdependent selectInput in R/Shiny application
I want the default selected value of each input to be consistent so that the filter returns at least 1 value. This of any input I change.
One way to get around this is to create a reactiveVal that tells the app that an updating operation is in progress, and require data to wait until that flag returns to False before running.
I've added 5 lines to your second shiny app:
To server():
# Create update in progress flag
updating_type_inprogress <- reactiveVal(FALSE)
To observeEvent(input$type ...:
# When type is changed, set flag to TRUE
updating_type_inprogress(TRUE)
To observeEvent(input$plant ...:
# Once this function has run, the updating operation is done
updating_type_inprogress(FALSE)
To data():
# Stops updating data() if the in-progress flag is TRUE
req(!updating_type_inprogress())
To renderDT():
# Stops updating renderDT() if the in-progress flag is TRUE
# this is probably optional unless there's resource-intensive code
# that doesn't depend on changes in data()
req(!updating_type_inprogress())
Here's the whole code:
library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
# Running a Shiny app object
app <- shinyApp(
ui = bootstrapPage(
selectInput('type','Choix du type',choices = unique(my_data$Type),selected=my_data$Type[1]),
selectInput('plant','Choix du type',choices = unique(my_data$Plant),selected=my_data$Plant[1]),
DTOutput('plot')
),
server = function(input, output,session) {
data=reactive({
req(!updating_type_inprogress())
print(input$type)
print(input$plant)
my_data_temp=my_data
if(length(input$type)>0){
my_data_temp=my_data_temp%>%filter(Type%in%input$type)
}
if(length(input$plant)>0){
my_data_temp=my_data_temp%>%filter(Plant%in%input$plant)
}
my_data_temp
})
observeEvent(input$type,{
updating_type_inprogress(TRUE)
updateSelectInput(session, "plant",
selected = unique(my_data%>%filter(Type%in%input$type)%>%.$Plant)[1])
})
observeEvent(input$plant,{
updating_type_inprogress(FALSE)
updateSelectInput(session, "type",
selected = unique(my_data%>%filter(Plant%in%input$plant)%>%.$Type)[1])
})
updating_type_inprogress <- reactiveVal(FALSE)
output$plot <- renderDT({
req(!updating_type_inprogress())
print("check latest_value")
datatable(data()) })
}
)
runApp(app)
As you can see, when you change input$type, the data() and renderDT() functions only run once with the correctly updated values:
[1] "check latest_value"
[1] "Quebec"
[1] "Qn1"
[1] "check latest_value"
[1] "Mississippi"
[1] "Mn1"
[1] "check latest_value"
[1] "Quebec"
[1] "Qn1"
Interesting problem and not easy to solve! Interestingly, what you are asking for is not what you need. Observation:
If the user selects Qn2 while Input1 is "Mississippi", you first set Input1 on Quebec and then hard set Input2 on Qn1, changing the choise of the user. This is bad.
Datatable is always updated once any of the two inputs changes, hence the many re-calculations of the table.
The solution therefore is twofold:
Don't overwrite the user's choice of e.g. Qc2 to Qc1. I used an if condition for that.
Install a watchguard to only update
the datatable when its contents actually changed. I do this with a reactiveVal() that I only update when the choice of the two inputs was valid (i.e. when the result set is greater than 0).
See the result below. Watch the console output to observe the decisions.
library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
shinyApp(
ui = bootstrapPage(
selectInput('type','Choix du type',choices = unique(my_data$Type),selected=my_data$Type[1]),
selectInput('plant','Choix du plant',choices = unique(my_data$Plant),selected=my_data$Plant[1]),
DTOutput('plot')
),
server = function(input, output,session) {
latest_data <- reactiveVal(my_data)
observe({
result <- my_data %>% filter(Type %in% input$type, Plant %in% input$plant)
if(nrow(result) > 0){
latest_data(result)
}else{
cat(format(Sys.time(), "%H:%M:%S"), "Didn't update the dataframe because the choice was not valid.\n")
}
})
observeEvent(input$type,{
if(! input$plant %in% my_data$Plant[my_data$Type == input$type]){
old <- input$plant
new <- my_data %>% filter(Type %in% input$type) %>% slice(1) %>% pull(Plant) %>% as.character()
updateSelectInput(session, "plant", selected = new)
cat(format(Sys.time(), "%H:%M:%S"), "Updated input$plant from", old, "to", new, "so that it represents a valid choice for", input$type, "\n")
}else{
cat(format(Sys.time(), "%H:%M:%S"), "Didn't update input$plant", input$plant, "because it is a valid choice for", input$type, "already\n")
}
})
observeEvent(input$plant,{
updateSelectInput(session, "type",
selected = my_data %>% filter(Plant %in% input$plant) %>% slice(1) %>% pull(Type))
})
output$plot <- renderDT({
cat(format(Sys.time(), "%H:%M:%S"), "updating datatable to only include", isolate(input$plant), "and", isolate(input$type), "\n\n")
latest_data()
datatable(latest_data())
})
}
)

Using observer to hold the resulted data subset in a vector

I am new to Shiny R.Can anyone help me solve the issue below.
I am trying to plot the data using a dataset, and with a user defined option "All" added to the "selectlist" of "region" provided in UI.
When "All" option is selected from "selectlist", how can I use the below observer to store information about all the regions into vector "l", so that the same can be used to query based on other user inputs
observe({
if("All" %in% input$region) {
selected <- setdiff(allchoice, "All")
updateSelectInput(session, "region", selected = selected)
}
})
Ref: How to add a user defined value to the select list of values from dataset
UI.R
library(shiny)
library("RMySQL")
library(ggplot2)
library(plotly)
library(DT)
library(dplyr)
dataset <- read.csv("dataset.csv", header=TRUE)
dataset$X <- NULL
allchoice <- c("All", levels(dataset$region))
fluidPage(
title = "ABC XYZ",
hr(),
fluidRow(
titlePanel("ABC XYZ"),
sidebarPanel(
dateRangeInput('dateRange',
label = 'Date Input',
start = as.Date("1967-01-01"), end = Sys.Date()),
selectInput("region", label = "Region",
choices = allchoice,
selected = 1),
selectInput("gender", label = "Gender",
choices = unique(dataset$gender), multiple = TRUE,
selected = unique(dataset$gender)),
selectInput('x', 'X', names(dataset), names(dataset)[[2]]),
selectInput('y', 'Y', names(dataset), names(dataset)[[8]]),
hr()
),
mainPanel(
column(12, plotlyOutput("plot1")),
hr(),
column(12, plotlyOutput("plot2"))
)
)
)
Server.r
library(ggplot2)
library("RMySQL")
library("mgcv")
library(plotly)
function(input, output, session) {
dataset <- read.csv("dataset.csv", header=TRUE)
dataset$X <- NULL
dataset$date <- as.Date(dataset$date)
if(input$region == "All"){
l <- observe({
if("All" %in% input$region) {
selected <- setdiff(allchoice, "All")
updateSelectInput(session, "region", selected = selected)
}
})
}
else{
l <- reactive(subset(dataset, region %in% input$region))
}
k <- reactive({subset(l(), date >= as.Date(input$dateRange[1]) & date <= as.Date(input$dateRange[2]))})
n <- reactive(subset(k(), gender %in% input$gender))
#output plots
output$plot1 <- renderPlotly({
p <- ggplot(n(), aes_string(x=input$x, y=input$y)) + geom_point(alpha=0.4)
ggplotly(p)
})
output$plot2 <- renderPlotly({
q <- ggplot(n(), aes_string(x=input$x, y=input$y)) + geom_smooth()
ggplotly(q)
})
}
Error I am facing -
Warning: 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.)
Stack trace (innermost first):
46: .getReactiveEnvironment()$currentContext
45: .subset2(x, "impl")$get
44: $.reactivevalues
43: $ [D:\Demo\server.R#36]
42: server $ [D:\Demo\server.R#36]
1: runApp
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.)
Note: My vocabulary above may be off, so please correct me if I'm wrong, I am totally new to the world of R.
Thanks in advance.
EDIT 1:
Listening on http://127.0.0.1:5128
We recommend that you use the dev version of ggplot2 with `ggplotly()`
Install it with: `devtools::install_github('hadley/ggplot2')`
Warning in origRenderFunc() :
Ignoring explicitly provided widget ID "2988253b22c1"; Shiny doesn't use them
We recommend that you use the dev version of ggplot2 with `ggplotly()`
Install it with: `devtools::install_github('hadley/ggplot2')`
`geom_smooth()` using method = 'gam'
Warning in origRenderFunc() : Ignoring explicitly provided widget ID "29885be33e8"; Shiny doesn't use them
and even when i do that, I am getting many exceptions and sometimes the same exceptions as above again. Just worried if the same will affect the application in the long run, can you suggest anything about that?
Thanks again.
You have not provided an example data so i can only guess and via looking at your error which says clearly whats the problem: no active reactive context, i assume that it is exactly in this part:
if(input$region == "All"){
l <- observe({
if("All" %in% input$region) {
selected <- setdiff(allchoice, "All")
updateSelectInput(session, "region", selected = selected)
}
})
}
else{
l <- reactive(subset(dataset, region %in% input$region))
}
[!] but actually i do not understand what for you need the observer...i think it should work totally fine if you just use if...else... statement.
[!] And additionally i have no idea why at first you say you wanna get the vector of choices (except "All") and you use it as selected choice in selectInput, may i ask what for?
and else statement should give you subset of the data based on input$region.
So shortly saying: if gives you updatedSelectInput and else gives you dataset --> It actually does not make sense at all..
and should be as simple as that, if "All" is selected then there is no need to subset the dataset, if any other choice then "All" is selected then the subset of the dataset should happen:
l <- reactive({
if(input$region == "All"){
dataset
}else{
dataset <- subset(dataset, region %in% input$region)
}})

Error in [: incorrect number of dimensions (while executing Shiny R code)

I am getting errors as "Warning: Error in grepl: invalid 'pattern' argument" and "Error in [: incorrect number of dimensions" (in UI) while executing shiny code. please help. below is the snippet of the code. I am getting error when I am un-commenting last line
library(MASS)
library(shinythemes)
library(shiny)
library(ggplot2)
mass.tmp <- data(package = "MASS")[3]
mass.datasets <- as.vector(mass.tmp$results[,3])
ui <- fluidPage(
theme = shinytheme("superhero"),
titlePanel("Linear Regression Modelling"),
sidebarLayout(
sidebarPanel(
selectInput("dsname", "Dataset:",choices = c(mass.datasets)),
uiOutput("y_axis"),
uiOutput("x_axis")
) ,
mainPanel(
tags$br(),
tags$br(),
"R-squared:",
tags$span(tags$b(textOutput("rsquared")),style="color:blue")
)
)
)
server <- function(input, output) {
output$x_axis <- renderUI({
col_opts <- get(input$dsname)
selectInput("x_axis2", "Independent Variable:", choices = c(names(col_opts)))
})
cols2 <- reactive({
col_opts2 <- get(input$dsname)
#names(col_opts2)[!grepl(input$x_axis2, names(col_opts2))]
})
output$y_axis <- renderUI({
selectInput("y_axis2", "Dependent Variable:", choices = c(names(cols2())))
})
model <- reactive({
#lm(input$dsname[,names(input$dsname) %in% input$y_axis2] ~ input$dsname[,names(input$dsname) %in% input$x_axis2])
#tmp <- paste(input$y_axis2,"~",input$x_axis2,sep = " ")
lm( input$y_axis2 ~ input$x_axis2 , data = input$dsname )
})
model_summary <- reactive({summary(model())})
output$rsquared <- renderText({ model_summary()$r.squared })
}
shinyApp(ui = ui, server = server)
Yes thats better.
There a multiple errors:
We shouldnt debug it all for you, but here are quite some pointers.
That should help you to find them all.
1)
You are using: input$x_axis and input$y_axis but defined it with a "2" at the end. So adapt that.
2)
You should define:
cols2 <- reactive({
col_opts2 <- get(input$dsname)
names(col_opts2)[!grepl(input$x_axis2, names(col_opts2))]
})
outside the renderUI function.
3) Moreover, there seems to be something wrong with this snippet:
names(col_opts2)[!grepl(input$x_axis2, names(col_opts2))]
Finally, I would check if you produce NULLS and prohibit that by !is.null().
Edit: Question update:
You tried to build the lm()formula by strings, which you can test outside of shiny: Will not work.
You should use the formula() function and come up with somethin like:
lm(formula(paste(input$y_axis2, input$x_axis2, sep =" ~ ")), data = get(input$dsname))

Resources