I want to let the user be able to select "NA" or enter empty values in the sliderInput. Maybe add a "NA" button near the slider input? Is there any way to do that?
example
Thanks
You can add a checkboxInput and pair it with an if condition inside the server. Here's an example using iris dataset.
library(shiny)
library(shinyWidgets)
library(tidyverse)
iris_df <- iris
#populate with some NA's
set.seed(123)
sample(1:nrow(iris), 10) %>%
walk(~ {
iris_df[.x, "Sepal.Width"] <<- NA
})
ui <- fluidPage(
checkboxInput("na", "Select NA Values", value = FALSE),
conditionalPanel(
condition = "input.na == false",
sliderInput("sepalw", "Sepal Width Range",
value = c(median(iris$Sepal.Width), max(iris$Sepal.Width)),
min = min(iris$Sepal.Width),
max = max(iris$Sepal.Width)
)
),
dataTableOutput("table")
)
server <- function(input, output, session) {
df <- reactive({
if (!input$na) {
iris_df %>%
filter(between(Sepal.Width, input$sepalw[[1]], input$sepalw[[2]]))
} else {
iris_df %>% filter(is.na(Sepal.Width))
}
})
output$table <- renderDataTable(
{
df()
},
options = list(pageLength = 10)
)
}
shinyApp(ui, server)
Related
I have a shiny app which is used to sample 10 rows of iris data.
When I start this shiny app for the first time, I need to click the sampling action button to display the sampled iris rows.
Is it possible to pre-assign a value that could allow shiny to display the sampled iris data when I first open the app?
Below is the original code.
library(shiny)
ui = fluidPage(
actionButton(inputId = "sampling", label = "Sample rows"),
tableOutput("DFTable")
)
server = function(input, output, session){
n <- eventReactive(input$sampling, {
getrows <- dim(iris)[1]
return(sample(1:getrows, 10))
})
output$DFTable <- renderTable(iris[n(), ])
}
shinyApp(ui, server)
I tried two ways, both didn't work.
to initiate a default value for n
n <- reactiveVal(value = 1:10)
use if() function
output$DFTable <- renderTable(
if(is.null(n())){n() = 1:10}
iris[n(), ]
)
Thanks a lot for your help.
Would the following work for you?
library(shiny)
ui = fluidPage(
actionButton(inputId = "sampling", label = "Sample rows"),
tableOutput("DFTable")
)
server = function(input, output, session){
values <- reactiveValues()
values$n <- sample(1:nrow(iris), 10)
observeEvent(input$sampling, {
values$n <- sample(1:nrow(iris), 10)
})
output$DFTable <- renderTable(iris[values$n, ])
}
shinyApp(ui, server)
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'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 have found the solution in the first answer to this question (checkboxGroupInput - set minimum and maximum number of selections - ticks) does not work as expected. The reproducible example is as follows:
rm(list = ls())
library(shiny)
my_min <- 1
my_max <- 3
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("SelecetedVars", "MyList:",paste0("a",1:5), selected = "a1")
),
mainPanel(textOutput("Selected"))
)
)
server <- function(input, output,session) {
output$Selected <- renderText({
paste(input$SelecetedVars,collapse=",")
})
observe({
if(length(input$SelecetedVars) > my_max)
{
updateCheckboxGroupInput(session, "SelecetedVars", selected= tail(input$SelecetedVars,my_max))
}
if(length(input$SelecetedVars) < my_min)
{
updateCheckboxGroupInput(session, "SelecetedVars", selected= "a1")
}
})
}
shinyApp(ui = ui, server = server)
When selecting checkboxes as you go down the list new selections are added to the tail of the input$SelectedVars vector and thus the tail(input$SelecetedVars,my_max) returns the last three vars the user selected. However as you go back up the list the vars are added to the head of the input$SelectedVars vector so tail(input$SelecetedVars,my_max) continues to return the vars already selected.
My current patch to this is to add a note on my app that says only three vars can be selected at a time. However this relies on the user to understand they have to un-check variables themselves. So for the sake of simplicity I am wondering if there is a way to have the most recent selected var to be appended to the tail of the vector so you can always display the last vars the user selected.
EDIT 2020/12/17: Including new reprex to illustrate infinite cycling produced from #Ben's 2020/12/16 edit. I removed the min vars as well as this wont be used in my case.*
library(shiny)
library(shinyjs)
library(tsibble)
library(tsibbledata)
library(tidyr)
library(plotly)
df <- aus_production # demo data from tsibbledata package
my_max <- 2
vars_list <- c("Beer", "Tobacco", "Bricks", "Cement", "Electricity", "Gas")
ui <- fluidPage(
useShinyjs(),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("SelectedVars", "MyList:",vars_list, selected = "Beer")
),
mainPanel(
plotlyOutput("plot1", height = "40vh"),
textOutput("Selected"))
)
)
server <- function(input, output,session) {
last_checked <- reactiveVal("Business")
output$Selected <- renderText({
paste(input$SelectedVars,collapse=",")
})
observeEvent(input$SelectedVars, {
shinyjs::disable("SelectedVars")
s <- input$SelectedVars
isolate({
if(length(s) > my_max)
{
removed <- last_checked()[1]
} else {
removed <- c(setdiff(last_checked(), s))
}
Sys.sleep(.5)
complete <- c(last_checked(), c(setdiff(s, last_checked())))
last_checked(complete[!complete %in% removed])
updateCheckboxGroupInput(session, "SelectedVars", selected = last_checked())
shinyjs::enable("SelectedVars")
})
}, ignoreInit = TRUE, ignoreNULL = FALSE)
output$plot1 <- renderPlotly({
req(input$SelectedVars)
vars <- input$SelectedVars
df_plot <- df %>%
select(Quarter:Tobacco)
if(length(input$SelectedVars) == 2){
plot_ly(data = df_plot,
type = "scatter",
mode ="lines"
) %>%
add_trace(x = ~Quarter,
y = ~df_plot[[2]]) %>%
add_trace(x = ~Quarter,
y = ~df_plot[[3]])
} else {
plot_ly(df_plot) %>%
add_lines(x = ~Quarter,
y = ~df_plot[[2]])
}
})
}
shinyApp(ui = ui, server = server)
When using filtering and the verbatimTextOutput function in R Shiny, rows go seemingly go missing when I select more than one of the input choices in my checkboxGroupInput.
Below is my code. Any advice?
Thanks in advance.
infantmort <- read.csv("infantmort.csv", header = TRUE)
ui <- fluidPage(
checkboxGroupInput("regioninputID",
"Select Region(s)",
choices = unique(infantmort$whoregion)
),
mainPanel(
verbatimTextOutput("regionoutputID"), width = "auto", height = "auto"
)
)
server <- function(input, output) {
dataset <- reactive({
as.data.frame(infantmort %>% select(whoregion, year, deathsinthousands) %>%
filter(whoregion == input$regioninputID) )
})
output$regionoutputID <- renderPrint({ dataset()
})
}
shinyApp(ui = ui, server = server)
You need to change your filter from == to %in%
The following should do the trick
server <- function(input, output) {
dataset <- reactive({
as.data.frame(infantmort %>% select(whoregion, year, deathsinthousands) %>%
filter(whoregion %in% input$regioninputID) )
})