how can I select a subset of the data and plot it using shiny & ggvis?
As the ggvis documentation states, it is not possible to swap the dataset using ggvis input_select. Besides this limitation it would be awesome if the data preprocessing & filtering would have to be performed only once.
This is my try using selectInput(). I want to be able to choose parts or the whole dataset for display
library(ggvis)
library(dplyr)
set.seed(1233)
cocaine <- cocaine[sample(1:nrow(cocaine), 500), ]
shinyServer(function(input, output, session) {
output$choose_dataset <- renderUI({
selectInput("dataset", "Select", append("Give me all!", as.list(sort(unique(cocaine$state)))))
})
if(input$dataset != "Give me all!"){
a <- filter(rawData, cocaine$state == input$dataset)
}
if(input$dataset == "Give me all!"){
a <- cocaine
}
a$id <- 1:nrow(a)
return(a)
datFiltered %>%
ggvis(~weight, ~price, key := ~id) %>%
bind_shiny("plot1") # Very important!
})
Here is the UI
library(ggvis)
shinyUI(bootstrapPage(
uiOutput("choose_dataset"),
ggvisOutput("plot1")
))
Your code has a few problems and doesn't run... why are you returning from the main server function? And you're using two variables dataFiltered and rawData that aren't defined anywhere.
Here is the solution of what you're trying to do
runApp(shinyApp(
ui = fluidPage(
uiOutput("choose_dataset"),
ggvisOutput("plot1")
),
server = function(input, output, session) {
output$choose_dataset <- renderUI({
selectInput("dataset", "Select", append("Give me all!", as.list(sort(unique(cocaine$state)))))
})
observeEvent(input$dataset, {
if(input$dataset == "Give me all!"){
data <- cocaine
} else {
data <- filter(cocaine, cocaine$state == input$dataset)
}
data$id <- seq(nrow(data))
data %>%
ggvis(~weight, ~price, key := ~id) %>%
layer_points() %>%
bind_shiny("plot1")
})
}
))
Please try to post code that can be run or at least make in the code saying what doesn't run or what variables need to be defined etc :)
#daattali - I have a suggested improvement to your solution. You use filter in the observeEvent, which introduces NA's to the solution and causes the event to fire incorrectly. Instead, use subset as shown below:
runApp(shinyApp(
ui = fluidPage(
uiOutput("choose_dataset"),
ggvisOutput("plot1")
),
server = function(input, output, session) {
output$choose_dataset <- renderUI({
selectInput("dataset", "Select", append("Give me all!", as.list(sort(unique(cocaine$state)))))
})
observeEvent(input$dataset, {
if(input$dataset == "Give me all!"){
data <- cocaine
} else {
data <- subset(cocaine, cocaine$state == input$dataset)
}
data$id <- seq(nrow(data))
data %>%
ggvis(~weight, ~price, key := ~id) %>%
layer_points() %>%
bind_shiny("plot1")
})
}
))
Related
I show you my shiny application, but I have a problem, I cannot update the selectimput, I have used updateSelectInput but it does not work.
I have two selectInputs inside a tabsetPanel, since I need to update the table with two filters, one is the category and the other the subcategory.
here my code.
library(shiny)
library(tidyverse)
library(DT)
cat1<-rep("LINEA BLANCA", 75)
cat2<- rep("VIDEO", 75)
subcat1<-rep("LAVADORAS", 40)
subcat2<- rep("REFRIS", 35)
subcat3<- rep("TV", 40)
subcat4<- rep("SONIDO", 35)
vent<-sample(100:900, 150, replace=T)
segm1<-rep("AAA", 25)
segm2<-rep("BBB", 25)
segm3<-rep("CCC", 25)
segm4<-rep("ABB", 25)
segm5<-rep("ACC", 25)
segm6<-rep("BAC", 25)
db<- tibble(segment=c(segm1,segm2,segm3,segm4,segm5,
segm1),CATEGORIA=c(cat1,cat2), SUBCAT=c(subcat1,subcat2, subcat3, subcat4), vent=vent)
ui <- fluidPage(
# App title
titlePanel("EXAMPLE"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
),
# Main panel for displaying outputs ----
mainPanel(
# Output: Tabset w/ plot, summary, and table ----
tabsetPanel(type = "tabs",
tabPanel("Ana_inv", uiOutput("selectcat"), uiOutput("selectsubcat"),DT::dataTableOutput("ana_inv")),
#tabPanel("Summary", verbatimTextOutput("summary")),
tabPanel("Table", tableOutput("table"))
)
)
)
)
server <- function(input, output, session) {
output$selectcat <- renderUI({
selectInput("Cat", "Seleccione Categoria", choices = c("ALL",as.vector(db$CATEGORIA)))
})
output$selectsubcat <- renderUI({
#opciones<- db_prueba %>% filter(CATEGORIA==input$CAT)
selectInput("Subcat", "Seleccione Subcategoria", choices = c("ALL",as.vector(db$SUBCAT)))
})
activar<- reactive({
req(input$Cat)
req(input$Subcat)
opciones<- db %>% filter(CATEGORIA==input$Cat)
if(input$Cat == "TODOS") {
filt1 <- quote(CATEGORIA != "#?><")
} else {
filt1 <- quote(CATEGORIA == input$Cat)
}
if (input$Subcat == "TODOS") {
filt2 <- quote(SUBCAT != "#?><")
} else {
filt2 <- quote(SUBCAT == input$Subcat)
}
db %>%
filter_(filt1) %>%
filter_(filt2) %>% group_by(segment)%>%
summarise(SKUs=n(),
vta=sum(vent))
})
# Return the formula text for printing as a caption ----
output$ana_inv <- DT::renderDataTable({
activar()
})
}
shinyApp(ui = ui, server = server)
So I need that if the category "LINEA BLANCA" is selected in the subcategory it only shows "REFRIS" and "LAVADORAS", but also if someone selects "ALL" in the category he can also select each subcategory, that is, it can be filtered by subcategory assuming I only want to see subcategories.
I have tried many ways but none works, any ideas? you can run the application in R to get an idea of what I want.
Try this
server <- function(input, output, session) {
output$selectcat <- renderUI({
selectInput("Cat", "Seleccione Categoria", choices = c("ALL",as.vector(db$CATEGORIA)))
})
output$selectsubcat <- renderUI({
req(input$Cat)
if (input$Cat=="ALL"){ df <- db
}else df <- db %>% filter(CATEGORIA %in% input$Cat)
selectInput("Subcat", "Seleccione Subcategoria", choices = c("ALL",as.vector(df$SUBCAT)))
})
activar<- reactive({
req(input$Cat,input$Subcat)
if (input$Cat=="ALL"){ df <- db
}else df <- db %>% filter(CATEGORIA %in% input$Cat)
if (input$Subcat=="ALL"){ df <- df
}else df <- df %>% filter(SUBCAT == input$Subcat)
df %>%
group_by(segment) %>%
summarise(SKUs=n(),
vta=sum(vent))
})
# Return the formula text for printing as a caption ----
output$ana_inv <- DT::renderDataTable({
activar()
})
}
I am making an app using the diamond dataset that I'd like to show the full table unless inputs are selected. However, if I select, say, cut by itself nothing appears. Also, if I select a lot of things no additional diamonds appear. Here's my code:
library(shiny)
library(DT)
library(tidyverse)
diamonds <- diamonds
#Shiny App
ui = fluidPage(
fluidRow(
column(2, selectizeInput(inputId = 'carat',
label = 'Select carat',
choices = unique(diamonds$carat),
selected = NULL,
multiple=TRUE)),
column(2, selectizeInput(inputId = 'cut',
label = 'Select cut',
choices = unique(diamonds$cut),
selected = NULL,
multiple=TRUE)),
column(2, selectizeInput(inputId = 'color',
label = 'Select color',
choices = unique(diamonds$color),
selected = NULL,
multiple=TRUE))
),
fluidRow (
column(12, dataTableOutput('data', height = '100px') )
)
)
server <- function(input, output, session) {
df_current <- reactive({
df <- diamonds%>%
filter(carat %in% ifelse(is.null(input$carat), carat, input$carat),
cut %in% ifelse(is.null(input$cut), color, input$cut),
color %in% ifelse(is.null(input$color), color, input$color))
df
})
output$data <- renderDataTable({
df_current()
})
}
shinyApp(ui = ui, server = server)
I am not sure why the reactive function df_current doesn't work correctly.
Thanks!
We could change the ifelse to if/else as ifelse requires all the inputs to be same length whereas the is.null returns a single TRUE/FALSE. So, it is better to use if/else. Also, calling unique inside ifelse is also not a correct way because it changes the length of the argument
server <- function(input, output, session) {
df_current <- reactive({
df <- diamonds%>%
filter(carat %in% if(is.null(input$carat)) carat else input$carat,
cut %in% if(is.null(input$cut)) cut else input$cut,
color %in% if(is.null(input$color)) color else input$color)
df
})
output$data <- renderDataTable({
df_current()
})
}
-output
The problem is that ifelse doesn't deal correctly with the factor variables and returns the numbers of the factor levels instead of the factor level. You can circumvent this by using as.character. Also, I've used unique because you don't need the complete column as the return value.
The second issue is that you have a typo in your filtering for cut as you use color instead of cut as the return value.
server <- function(input, output, session) {
df_current <- reactive({
df <- diamonds%>%
filter(carat %in% ifelse(is.null(input$carat), unique(carat), input$carat),
cut %in% ifelse(is.null(input$cut), as.character(unique(cut)), input$cut),
color %in% ifelse(is.null(input$color), as.character(unique(color)), input$color))
df
})
output$data <- renderDataTable({
df_current()
})
}
I'm trying to set codes to recode in shiny web application. However, it doesn't work for me.
Here's my code.
library(shiny)
library(rlang)
library(dplyr)
ui <- fluidPage(
titlePanel("Short Form Web App"),
sidebarPanel(
numericInput("num1","previous vector", value = NULL),
numericInput("num2","post vector", value = NULL),
selectInput("var","select Variable",names(mtcars)),
textInput("new_var","new variable names")
),
mainPanel(
verbatimTextOutput("tab1"),
verbatimTextOutput("tab2"),
actionButton("do","Do")
)
)
server <- function(input, output) {
output$tab1 <- renderPrint({
table(mtcars[["cyl"]])
})
rv <- reactiveValues(data = NULL)
rv$data <- mtcars
observeEvent(input$do,{
new_var <- input$new_var
new <- rv$data %>% transmute(!!new_var := case_when(input$var == input$num1 ~ input$num2))
rv$data <- bind_cols(rv$data,new)
output$tab2 <- renderPrint({
str(rv$data)
})
})
}
shinyApp(ui,server)
What I'm trying to do is recode previous vector to new vector like recode, but the result keeps showing NA..
Could anyone help me fix this problem?
I would very be very appreciated with your helps.
Thank you in advance.
Two issues:
As input$var is character you first have to convert to a symbol, i.e. use !!sym(input$var)
In your case_when you missed to set a default value. Hence, all values not specified to be recoded will be assigned NA.
Try this:
library(shiny)
library(rlang)
library(dplyr)
ui <- fluidPage(
titlePanel("Short Form Web App"),
sidebarPanel(
numericInput("num1","previous vector", value = NULL),
numericInput("num2","post vector", value = NULL),
selectInput("var","select Variable",names(mtcars)),
textInput("new_var","new variable names")
),
mainPanel(
verbatimTextOutput("tab1"),
verbatimTextOutput("tab2"),
actionButton("do","Do")
)
)
server <- function(input, output) {
output$tab1 <- renderPrint({
table(mtcars[["cyl"]])
})
rv <- reactiveValues(data = NULL)
rv$data <- mtcars
observeEvent(input$do,{
new_var <- input$new_var
new <- rv$data %>% transmute(!!sym(new_var) := case_when(
!!sym(input$var) == input$num1 ~ as.double(input$num2),
TRUE ~ !!sym(input$var)))
rv$data <- bind_cols(rv$data,new)
output$tab2 <- renderPrint({
str(rv$data)
})
})
}
I am trying to build a shiny app that gives user the flexibility to choose the variables for group by and summarize. Checkbox will have an option for selecting group by variables. Right now I haven't given measure variables as selections, since I struggling with group by. I want the numbers to be aggregated basis the selection.
library(shiny)
library(ggplot2) # for the diamonds dataset
library(shinydashboard)
library(dplyr)
y1<-diamonds
ui <- fluidPage(
checkboxGroupInput("variable", "Variables to show:",
c("cut","color","clarity"),selected = "cut"),
tableOutput("data"),
textOutput("result")
)
server <- function(input, output, session) {
base <- reactive({
groupby <- enquo(input$variable)
print(groupby)
res <-y1%>% group_by(!!!groupby,x) %>%
tally() %>%
ungroup() %>%
summarise(sum = sum(x)) %>%
pull()
res
})
output$result <- renderText({
input$variable
})
output$data<-renderTable({
base()
}
)
}
shinyApp(ui, server)
Thanks,
Hema
I'm not sure that I understood your question exactly, but maybe something like this:
library(shiny)
library(ggplot2) # for the diamonds dataset
library(shinydashboard)
library(dplyr)
y1<-diamonds
ui <- fluidPage(
checkboxGroupInput("variable", "Variables to show:",
c("cut","color","clarity"),selected = "cut"),
tableOutput("data"),
textOutput("result")
)
server <- function(input, output, session) {
base <- reactive({
res <- y1 %>% group_by(eval(parse(text = input$variable)),x) %>%
tally() %>%
#ungroup() %>%
summarise(sum = sum(x)) %>%
pull()
res
})
output$result <- renderText({
input$variable
})
output$data<-renderTable({
base()
})
}
shinyApp(ui, server)
if it's possible to select multiple from the check boxes such that you'd want something like group_by(x,y) this may help you get what you want:
group_by(across(all_of(input$group)))
I tried to add a filter to my data analysis. The filter (inputF2) is an item in a category (xInput) chosen by the user.
then I want filter out the data to do summarize analysis and plot out the mean. However, once I wrote the if statement, the program won't run.
library(datasets)
library(shiny)
library(dplyr)
library(ggplot2)
library(DT)
library(crosstalk)
data("iris")
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Analyze Iris table"),
# Sidebar with a dropdown menu selection input for key measurecomponent
sidebarLayout(
sidebarPanel(
selectInput("yInput", "Measuring element: ",
colnames(iris), selected = colnames(iris)[2]),
selectInput('xInput', 'Grouper: ',
colnames(iris), selected = colnames(iris)[5])
),
# Show a plot of the generated distribution
mainPanel(
uiOutput('filter'),
plotOutput("barPlot"),
DTOutput('table1')
)))
server <- function(input, output) {
output$filter = renderUI({
selectInput('inputF2', 'Filter Item: ',
c('Null', unique(iris %>% select(input$xInput))))
})
if(input$inputF2 != 'Null') {
iris_sub = reactive({
iris %>% filter_at(input$xInput == input$inputF2)
})
} else{ iris_sub = iris}
by_xInput <- reactive({
iris_sub %>%
group_by_at(input$xInput) %>%
summarize(n = n(), mean_y = mean(!! rlang::sym(input$yInput)))
})
output$barPlot <- renderPlot({
# as the input is a string, use `aes_string`
ggplot(data = by_xInput(), aes_string(x = input$xInput, y = "mean_y")) +
geom_bar(stat = 'identity')
})
output$table1 = renderDT(
datatable(by_xInput())
)
}
shinyApp(ui = ui, server = server)
This is the error message I got:
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.)
The reason you were getting the active reactive content error was because of this chunk
if(input$inputF2 != 'Null') {
iris_sub = reactive({
iris %>% filter_at(input$xInput == input$inputF2)
})
} else{ iris_sub = iris}
Here you are evaluating input$inputF2 but that can change with user selection, so the test needs to be inside a reactive().
Another good practice is to wrap variables like inputF2 in req, to ensure they will have a value before being evaluated. This is because you are rendering the widget for filter on the server side, and initially it will not have a value.
Note also, that the filtering condition filter(input$xInput == input$inputF2) would fail, because filter expects an unquoted variable name in the left hand side of that expression (but input$xInput is a character). You can convert input$xInput to a name with as.name() and then use bang-bang inside filter to evaluate it: filter(!!as.name(input$xInput) == input$inputF2)
After this changes, the filtering chunk becomes:
iris_sub <- reactive({
x_in <- as.name(input$xInput)
if (req(input$inputF2) != 'Null') {
iris_sub <- iris %>% filter(!!x_in == input$inputF2)
} else{
iris_sub <- iris
}
return(iris_sub)
})
Finally, it seems like your app allowed the user to choose the same variable as measuring element and as the grouper. Not sure this is a good idea, as it might throw errors because you can't modify a grouping variable. One way to control this is to use validate inside the reactive that does the summarising and produce a meaningful error message for the user:
validate(
need(expr = input$xInput != input$yInput,
message = "Can't summarise by group when 'grouper' is the same as 'measuring element'"))
Here is the whole app with these modifications.
library(datasets)
library(shiny)
library(dplyr)
library(ggplot2)
library(DT)
library(crosstalk)
data("iris")
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Analyze Iris table"),
# Sidebar with a dropdown menu selection input for key measurecomponent
sidebarLayout(
sidebarPanel(
selectInput("yInput", "Measuring element: ",
colnames(iris), selected = colnames(iris)[2]),
selectInput('xInput', 'Grouper: ',
colnames(iris), selected = colnames(iris)[5])
),
# Show a plot of the generated distribution
mainPanel(
uiOutput('filter'),
plotOutput("barPlot"),
DTOutput('table1')
)))
server <- function(input, output) {
output$filter = renderUI({
selectInput('inputF2',
'Filter Item: ',
c('Null', iris %>% select(input$xInput) %>% unique()))
})
iris_sub <- reactive({
x_in <- as.name(input$xInput)
if (req(input$inputF2) != 'Null') {
iris_sub <- iris %>% filter(!!x_in == input$inputF2)
} else{
iris_sub <- iris
}
return(iris_sub)
})
by_xInput <- reactive({
validate(
need(expr = input$xInput != input$yInput,
message = "Can't summarise by group when 'grouper' is the same as 'measuring element'"))
iris_sub() %>%
group_by_at(input$xInput) %>%
add_tally() %>%
summarize_at(.vars = vars(input$yInput),
.funs = list("mean_y" = mean))
})
output$barPlot <- renderPlot({
# as the input is a string, use `aes_string`
ggplot(data = by_xInput(), aes_string(x = input$xInput, y = "mean_y")) +
geom_bar(stat = 'identity')
})
output$table1 = renderDT(
datatable(by_xInput())
)
}
shinyApp(ui = ui, server = server)