r shiny selectInput - selectable classes in only one column - r

I'm new to R and shiny. I have a problem that I could not solve.
I have a histogram where I want to make the classes separately selectable.
The classes are all in one column. To make them separately selectable, I did not succeed.
How do I get it to work?
Thanks a lot
## app.R ##
set.seed(24)
df <- data.frame(Class = sample(LETTERS[1:5], 30, replace = TRUE),
Amount = sample(5:20, 30, replace = TRUE),
stringsAsFactors= FALSE, check.names = FALSE)
server <- function(input, output) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')
})
output$sum = renderPrint({
summary(df)
})
output$str = renderPrint({
str(df)
})
output$data = renderTable({
colm = as.numeric(input$var)
df[colm]
head(df)
})
output$myhist <- renderPlot({
colm = as.numeric(input$var)
hist(df$Amount, col =input$colour, xlim = c(0, max(df$Amount)), main = "Histogram", breaks = seq(0, max(df$Amount),l=input$bin+1),
xlab = names(df$Amount)
)}
)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("var", label = "1. Select Class",
choices = c("A" = 1, "B" = 2, "C" = 3, "D"= 4, "E" = 5),
selected = 2),
sliderInput("bin", "2. Select the number of histogram BINs by using the slider below", min=5, max=25, value=15),
radioButtons("colour", label = "3. Select the color of histogram",
choices = c("Green", "Red",
"Blue"), selected = "Green")
),
mainPanel(
tabsetPanel(type="tab",
tabPanel("Plot", plotOutput("myhist")),
tabPanel("Summary", verbatimTextOutput("sum")),
tabPanel("Structure", verbatimTextOutput("str")),
tabPanel("Data", tableOutput("data"))
)
)
)
)
shinyApp(ui = ui, server = server)
I appreciate your help.

You have a few options:
Allow the selectInput to have multiple selections, by adding multiple = TRUE:
selectInput("var", label = "1. Select Class", choices = c("A" = 1, "B" = 2, "C" = 3, "D"= 4, "E" = 5), multiple = TRUE)
Use a checkbox group:
checkboxGroupInput('var', label = "1. Select Class", choices = c("A" = 1, "B" = 2, "C" = 3, "D"= 4, "E" = 5))
I recommend the 2nd option, using a checkbox group, as I believe they are easy for users to understand.
EDIT
As requested here is the full code, with the checkbox group linked to the chart:
## app.R ##
library(shiny)
set.seed(24)
df <- data.frame(Class = sample(LETTERS[1:5], 30, replace = TRUE),
Amount = sample(5:20, 30, replace = TRUE),
stringsAsFactors= FALSE, check.names = FALSE)
server <- function(input, output) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')
})
output$sum = renderPrint({
summary(df)
})
output$str = renderPrint({
str(df)
})
output$data = renderTable({
colm = as.numeric(input$var)
df[colm]
head(df)
})
output$myhist <- renderPlot({
df_plot <- df[df$Class %in% input$var, ]
hist(df_plot$Amount, col = input$colour, xlim = c(0, max(df_plot$Amount)), main = "Histogram", breaks = seq(0, max(df_plot$Amount),l=input$bin+1),
xlab = names(df_plot$Amount)
)}
)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput('var', label = "1. Select Class", choices = c("A", "B", "C", "D", "E"), selected = "B"),
sliderInput("bin", "2. Select the number of histogram BINs by using the slider below", min=5, max=25, value=15),
radioButtons("colour", label = "3. Select the color of histogram",
choices = c("Green", "Red",
"Blue"), selected = "Green")
),
mainPanel(
tabsetPanel(type="tab",
tabPanel("Plot", plotOutput("myhist")),
tabPanel("Summary", verbatimTextOutput("sum")),
tabPanel("Structure", verbatimTextOutput("str")),
tabPanel("Data", tableOutput("data"))
)
)
)
)
shinyApp(ui = ui, server = server)

Related

shiny click on plot update input

I have this very simple shiny app
When input changes, the graph changes accordingly
When a point is selected within the graph the corresponding model is displayed on the right of the input text box
I would like to see the selection to be displayed inside the text box
Can anyone please point me in the right direction
Thanks for any help
require(ggplot2)
require(dplyr)
require(Cairo)
require(dplyr)
mtcars2 <- datasets::mtcars %>% rownames_to_column(var = 'model')
ui <- fluidPage(
fluidRow(
column(width = 3,
selectInput(inputId = '.model', label = 'input model', choices = mtcars2$model, selected = NULL)),
br(),br(),
column(width = 3,
textOutput('click_1A'), label = 'selected model')
),
fluidRow(
column(width = 8,
plotOutput("plot1", height = 350, brush = "plot_brush", click = "plot_click")),
)
)
server <- function(input, output) {
global <- reactiveValues(.model = NULL)
# scatter plot
output$plot1 <- renderPlot({
selected_model <- input$.model
ggplot(mtcars2, aes(x=mpg,y=disp), color = 'red') +
geom_point(size = 3, col = 'red') +
geom_point(data = filter(mtcars2, model == selected_model), col = 'blue', size = 5) +
theme_bw() +
theme(legend.position = 'none')
})
# MODEL name
output$click_1A <- renderText({
near_out <- nearPoints(mtcars2, input$plot_click, addDist = TRUE)
global$.model <- near_out %>%
pull(model)
})
}
shinyApp(ui, server)
Thanks #Ben
Here is the clean version of what was trying to achieve:
require(ggplot2)
require(tidyr)
require(tibble)
require(lubridate)
require(Cairo)
require(dplyr)
mtcars2 <- datasets::mtcars %>% rownames_to_column(var = 'model')
ui <- fluidPage(
fluidRow(
column(width = 3,
selectInput(inputId = '.model', label = 'input model', choices = mtcars2$model, selected = NULL)),
),
fluidRow(
column(width = 8,
plotOutput("plot1", height = 350, brush = "plot_brush", click = "plot_click")),
)
)
server <- function(input, output, session) {
global <- reactiveValues(.model = NULL)
# scatter plot
output$plot1 <- renderPlot({
selected_model <- input$.model
ggplot(mtcars2, aes(x=mpg,y=disp, label = model), color = 'red') +
geom_point(size = 3, col = 'red') +
geom_point(data = filter(mtcars2, model == selected_model), col = 'blue', size = 5) +
#geom_text() +
theme_bw() +
theme(legend.position = 'none')
})
observeEvent(
eventExpr = input$plot_click,
handlerExpr = {
selected_model <- nearPoints(mtcars2, input$plot_click, maxpoints = 1, addDist = F) %>% pull(model)
updateSelectInput(session, inputId = ".model", choices = mtcars2$model, selected = selected_model)}
)
}
shinyApp(ui, server)

How to trigger observeEvent and action with different input types in R Shiny?

What I have
I made a Shiny app that shows a plot with some points.
You can manually change the y axis. There is a button that allows to automatically adjust the y axis so it fits the data. There is a drop-down box that allows you to select data.
I have this code:
library(shiny)
# user interface ----------------------------------------------------------
ui <- fluidPage(
fluidRow(plotOutput("myplot")),
tabsetPanel(
tabPanel(
"Input",
fluidRow(
column(
2,
numericInput(inputId = "ymax", label = "y-axis maximum", value = 30),
numericInput(inputId = "ymin", label = "y-axis minimum", value = 9),
actionButton("fity", label = "zoom to fit")
),
column(
2,
selectInput(inputId = "yaxis", label = "y-axis",
choices = list("1 to 5" = 1,
"3 to 7" = 2)
),
checkboxInput("mybx", label = "checkbox", value = TRUE)
)
)
),
fluidRow()
)
)
# server function ---------------------------------------------------------
server <- function(input, output, session) {
ydata <- reactive({
switch(input$yaxis,
"1" = {
updateCheckboxInput(session, "mybx", value = TRUE)
1:5},
"2" = {
updateCheckboxInput(session, "mybx", value = FALSE)
3:7}
)
})
observeEvent(input$fity, {
newymax <- trunc(max(ydata())) + 1
newymin <- trunc(min(ydata()))
updateNumericInput(session, "ymax", value = newymax)
updateNumericInput(session, "ymin", value = newymin)}
)
output$myplot <- renderPlot({
par(mar = c(4, 4, 0.1, 0.1))
plot(x = 1:5, y = ydata(), ylim = c(input$ymin, input$ymax))
})
}
shinyApp(ui = ui, server = server)
What I want to do
I want that the fit-y-axis code triggered by the action button will also be triggered when I'm changing the data with the dropdown box.
Things I've tried:
This. But I think it doesn't like getting a selectInput together with the button.
Putting the fit-y-axis code into a separate function, calling the function from both ydata <- reactive and observeEvent. Did not work. Cries about recursion (obviously - it's calling ydata again from inside ydata!).
Any help would be appreciated.
Why not just have another observeEvent that monitors the change in the yaxis input?
library(shiny)
# user interface ----------------------------------------------------------
ui <- fluidPage(
fluidRow(plotOutput("myplot")),
tabsetPanel(
tabPanel(
"Input",
fluidRow(
column(
2,
numericInput(inputId = "ymax", label = "y-axis maximum", value = 30),
numericInput(inputId = "ymin", label = "y-axis minimum", value = 9),
actionButton("fity", label = "zoom to fit")
),
column(
2,
selectInput(inputId = "yaxis", label = "y-axis",
choices = list("1 to 5" = 1,
"3 to 7" = 2)
),
checkboxInput("mybx", label = "checkbox", value = TRUE)
)
)
),
fluidRow()
)
)
server <- function(input, output, session) {
ydata <- reactive({
switch(input$yaxis,
"1" = {
updateCheckboxInput(session, "mybx", value = TRUE)
1:5},
"2" = {
updateCheckboxInput(session, "mybx", value = FALSE)
3:7}
)
})
observeEvent(input$fity, {
newymax <- trunc(max(ydata())) + 1
newymin <- trunc(min(ydata()))
updateNumericInput(session, "ymax", value = newymax)
updateNumericInput(session, "ymin", value = newymin)}
)
observeEvent(input$yaxis, {
newymax <- trunc(max(ydata())) + 1
newymin <- trunc(min(ydata()))
updateNumericInput(session, "ymax", value = newymax)
updateNumericInput(session, "ymin", value = newymin)}
)
output$myplot <- renderPlot({
par(mar = c(4, 4, 0.1, 0.1))
plot(x = 1:5, y = ydata(), ylim = c(input$ymin, input$ymax))
})
}
shinyApp(ui = ui, server = server)
But this makes your 'zoom to fit' button redundant.

how can I get more than one plot from several selected items in a checkbox?

Good morning,
in my dashboard I inserted a checkbox to select one or more output to display. In the ui I entered the checkbox and in the server all the conditions (if ... else if ...). When I launch the app it only shows me a plot, even when I select more than one choice in the checkbox. In addition it gives me this error in console:
"Warning in if (input$checkGroup == 1) { :the condition has length > 1 and only the first element will be used"
I suppose it's telling me that I can't handle more than one choice, how do I view all the plots I choose?
ui <- fluidPage(titlePanel("IULM Dashboard"), sidebarLayout(sidebarPanel(
selectInput("selection", "Choose a Dataset:",
choices = datasets),
("Barplot","Network",'Wordcloud', "LDA-Latent topic"),
#selected = "Barplot", inline = TRUE),
checkboxGroupInput("checkGroup", label = ("Checkbox group"),
choices = list("Barplot" = 1, "Network" = 2), selected = 1, inline = TRUE),
actionButton("update", "Change"))
, mainPanel(
uiOutput("plot")))
server <- function(input, output){
datasetInput <- reactive({
input$update
isolate({
withProgress({
setProgress(message = "Processing corpus...")
getTermMatrix(input$selection)
})
})
})
output$plot <- renderUI({
if(input$checkGroup== 1 ){
output$barplot <- renderPlot({
v=datasetInput()
dtm1 = removeSparseTerms(v, 0.992)
freq <- colSums(as.matrix(dtm1))
wf = data.frame(term = names(freq), occurrences = freq)
wf <- wf[order(wf$occurrences, decreasing = TRUE),]
wf2 = subset(wf[1:input$maxB,])
ggplot(wf2, aes(term, occurrences)) +
geom_bar(stat="identity", fill="darkred", colour="black", width=0.5)+
theme(axis.text.x=element_text(angle=45, hjust=1))+
ggtitle("Word barplot")})
plotOutput(outputId = "barplot", width = 600, height = 400)
}
else if(input$checkGroup== 2 ){
output$network <- renderPlot({
v=datasetInput()
dtm1 = removeSparseTerms(v, 0.992)
rowTotals <- apply(dtm1 , 1, sum)
dtm2 <- dtm1[rowTotals> 0, ]
wdtm <- weightTf(dtm2)
dtm1 <- removeSparseTerms(wdtm, 0.96)
dfm <- as.dfm(dtm1)
textplot_network(dfm, min_freq = 0.5, omit_isolated = TRUE,
edge_color = "#1F78B4", edge_alpha = 0.5, edge_size = 2,
vertex_color = "#4D4D4D", vertex_size = 2,
vertex_labelsize = 5, offset = NULL)})
plotOutput(outputId = "network", width = 600, height = 600)}
})
}
shinyApp(ui = ui, server = server)
You can try
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("variable", "Variables to show:",
c("Cylinders" = "cyl",
"Transmission" = "am",
"Gears" = "gear"))
),
mainPanel(
uiOutput("plots")
)))
server <- function(input, output) {
output$plots <- renderUI({
req(input$variable)
output = tagList()
if(any(input$variable %in% "cyl")){
tmp <- mtcars$cyl
output[[1]] <- renderPlot({plot(mtcars$mpg, tmp)})
}
if(any(input$variable %in% "am")){
tmp <- mtcars$am
output[[2]] <- renderPlot({boxplot(mtcars$mpg, tmp)})
}
output
})
}
shinyApp(ui = ui, server = server)

r shiny code - selectInput with factor variables

I am building a shiny app. In the drop down menu I have the categories of a factor variable. I think the problem is in the server but I dont know how to fix it.
Also, I would like that to add a vertical in the histograms at 15 when the colour chosen is yellow, and a vertical line at 20 when the colour chose in the histogram is Red. Can you please help me with my code?
Thanks
library(shiny)
# Creating a fake data frame
categories <- c("A", "B", "c")
values <- c(12, 15, 20)
data <- merge(categories, values)
# Define UI for application
ui <- shinyUI(fluidPage(
# Title panel
titlePanel(title = h1("Title", align = "center")),
sidebarLayout(
# Sidebar panel
sidebarPanel(
# Options
selectInput(inputId = "xcol", label = "Select", choices = levels(data$x)),
br(),
#Colours histogram
radioButtons(inputId = "colour", label = strong("Select the colour of
histogram"), choices = c("Yellow", "Red"), selected = "Yellow"),
br(),
#Bins for histogram
sliderInput(inputId = "bins", label = "Select the number of Bins for the
histogram", min=5, max = 25, value = 15),
br(),
#Density curve
checkboxInput(inputId = "density", label = strong("Show Density Curve"),
value = FALSE),
# Display this only if the density is shown
conditionalPanel(condition = "input.density ==true",
sliderInput(inputId = "bw_adjust",
label = "Bandwidth adjustment:",
min = 0.2, max = 3, value = 1, step = 0.2))
),
# Main Panel
mainPanel(
#plot histogram
plotOutput("plot"),
# Output: Verbatim text for data summary
verbatimTextOutput("summary"))
)))
# Define server logic
server <- shinyServer(function(input, output) {
output$plot <-renderPlot({
hist(data[input$xcol, data$x], breaks = seq(0, max(data[input$xcol,
data$x]), l= input$bins+1), col = "lightblue",
probability = TRUE, xlab = "Values", main = "")
abline(v = mean(data[input$xcol, data$x]), col = "red", lty = 2)
title(main = levels(data$x[input$xcol]))
if (input$density) {
dens <- density(data[input$xcol, data$x], adjust = input$bw_adjust)
lines(dens, col = "blue", lwd = 1)
}
# Generate the summary
output$summary <- renderPrint({
xcol <- xcolInput()
summary(xcol)
})
})
})
# Run the application
shinyApp(ui = ui, server = server)
It looks like you were subsetting data incorrectly. I created a reactive expression for the data subset: data2(), and used that to make the plot outputs. I also added the vertical lines you mention with an if(){...}else{...} statement.
library(shiny)
# Creating a fake data frame
categories <- c("A", "B", "c")
values <- c(12, 15, 20)
data <- merge(categories, values)
# Define UI for application
ui <- shinyUI(fluidPage(
# Title panel
titlePanel(title = h1("Title", align = "center")),
sidebarLayout(
# Sidebar panel
sidebarPanel(
# Options
selectInput(inputId = "xcol", label = "Select", choices = levels(data$x)),
br(),
#Colours histogram
radioButtons(inputId = "colour", label = strong("Select the colour of
histogram"), choices = c("Yellow", "Red"), selected = "Yellow"),
br(),
#Bins for histogram
sliderInput(inputId = "bins", label = "Select the number of Bins for the
histogram", min=5, max = 25, value = 15),
br(),
#Density curve
checkboxInput(inputId = "density", label = strong("Show Density Curve"),
value = FALSE),
# Display this only if the density is shown
conditionalPanel(condition = "input.density ==true",
sliderInput(inputId = "bw_adjust",
label = "Bandwidth adjustment:",
min = 0.2, max = 3, value = 1, step = 0.2))
),
# Main Panel
mainPanel(
#plot histogram
plotOutput("plot"),
# Output: Verbatim text for data summary
verbatimTextOutput("summary"))
)))
# Define server logic
server <- shinyServer(function(input, output) {
data2 <- reactive({data[as.character(data$x)==input$xcol, "y"]})
output$plot <-renderPlot({
hist(data2(), breaks = seq(0, max(c(1, data2()), na.rm=TRUE), l= input$bins+1), col = input$colour,
probability = TRUE, xlab = "Values", main = "")
abline(v = mean(data2()), col = "red", lty = 2)
title(main = input$xcol)
if (input$density) {
dens <- density(data2(), adjust = input$bw_adjust)
lines(dens, col = "blue", lwd = 1)
}
if(input$colour=="Red"){
abline(v=20)}else{abline(v=15)}
# Generate the summary
output$summary <- renderPrint({
#xcol <- xcolInput()
summary(data2())
})
})
})
# Run the application
shinyApp(ui = ui, server = server)

Vector as a choice in shiny::selectInput()

Here is a working template:
require(data.table)
require(shiny)
require(ggplot2)
x <- data.table(v1 = sample(letters[1:5], 100, replace = T),
v2 = sample(letters[1:2], 100, replace = T),
v3 = runif(100, 0, 1))
ui <- fluidPage(
sidebarPanel(
selectInput("in1", "Choice v1", selected = "All", choices = c("All" = list(letters[1:5]))),
selectInput("in2", "Choice v2", selected = "a", choices = letters[1:2])
),
mainPanel(
plotOutput("out1")
)
)
server <- function(input, output){
output$out1 <- renderPlot({
ggplot(x[v1 %in% input$in1 & v2 %in% input$in2], aes(x = v3)) +
geom_density(fill = "dodgerblue4", alpha = .7) +
theme_light()
})
}
runApp(shinyApp(ui, server))
Issue here is that I'd like to allow for selection of subset of values within variable. Line selectInput("in1", "Choice v1", selected = "All", choices = c("All" = list(letters[1:5]))) was intended to pass letters[1:5] to input$in1 effectively selecting all values and performing no subsetting of data on v1.
Same applies to any other subset of values e.g. choice "a_b_c" = c("a", "b", "c"), or "All" = x[,unique(v1)] and so on. What shiny does, is break up list to all values included in it, basically achieving opposite of desired result.
I know there is selectizeInput() to select multiple values. However, this is not viable if I want selected = "All" for all variables as initial state.
Would something like this work?
#rm(list=ls())
require(data.table)
require(shiny)
require(ggplot2)
x <- data.table(v1 = sample(letters[1:5], 100, replace = T),
v2 = sample(letters[1:2], 100, replace = T),
v3 = runif(100, 0, 1))
ui <- fluidPage(
sidebarPanel(
selectInput("in1", "Choice v1", selected = "All", choices = c("All",letters[1:5])),
selectInput("in2", "Choice v2", selected = "a", choices = letters[1:2])
),
mainPanel(
plotOutput("out1")
)
)
server <- function(input, output){
output$out1 <- renderPlot({
value <- input$in1
if(value == "All"){
value <- letters[1:5]
}
ggplot(x[v1 %in% value & v2 %in% input$in2], aes(x = v3)) +
geom_density(fill = "dodgerblue4", alpha = .7) +
theme_light()
})
}
runApp(shinyApp(ui, server))
shiny supports selection of multiple values in selectInput. You need to set multiple = TRUE and selectize = FALSE. I think this will provide you the functionality you desire.
You then make the choices and selected variables the same to preselect all of the variables. If you need to use an "all" feature, you'll need to add an action button to run updateSelectInput. Combining those two features could be done by writing a module.
require(data.table)
require(shiny)
require(ggplot2)
x <- data.table(v1 = sample(letters[1:5], 100, replace = T),
v2 = sample(letters[1:2], 100, replace = T),
v3 = runif(100, 0, 1))
ui <- fluidPage(
sidebarPanel(
selectInput("in1", "Choice v1",
selected = letters[1:5],
choices = letters[1:5],
multiple = TRUE,
selectize = FALSE),
selectInput("in2", "Choice v2",
selected = letters[1:2],
choices = letters[1:2],
multiple = TRUE,
selectize = FALSE)
),
mainPanel(
plotOutput("out1")
)
)
server <- function(input, output){
output$out1 <- renderPlot({
ggplot(x[v1 %in% input$in1 & v2 %in% input$in2], aes(x = v3)) +
geom_density(fill = "dodgerblue4", alpha = .7) +
theme_light()
})
}
runApp(shinyApp(ui, server))
While reading other answers and wondering about possible clean and compact workaround, here's what I came up with. It was crucial to have clean approach to adding new variables.
require(data.table)
require(shiny)
require(ggplot2)
x <- data.table(v1 = sample(letters[1:5], 100, replace = T),
v2 = sample(letters[1:2], 100, replace = T),
v3 = runif(100, 0, 1))
map.dt <- function(x, variables){
map.out <- data.table(name = character(), variable = character(), value = character())
for(i in variables){
map.out <- rbind(map.out,
data.table(name = x[,sort(as.character(na.omit(unique(get(i)))))],
variable = i,
value = x[,sort(as.character(na.omit(unique(get(i)))))]),
data.table(name = "All",
variable = i,
value = x[,sort(as.character(na.omit(unique(get(i)))))]))
}
return(map.out)
}
y <- map.dt(x, c("v1", "v2"))
ui <- fluidPage(
sidebarPanel(
selectInput("in1", "Choice v1", selected = "All", choices = c("All", letters[1:5])),
selectInput("in2", "Choice v2", selected = "All", choices = c("All", letters[1:2]))
),
mainPanel(
plotOutput("out1")
)
)
server <- function(input, output){
output$out1 <- renderPlot({
ggplot(x[v1 %in% y[variable == "v1" & name == input$in1, value] &
v2 %in% y[variable == "v2" & name == input$in2, value]],
aes(x = v3)) +
geom_density(fill = "dodgerblue4", alpha = .7) +
theme_light()
})
}
runApp(shinyApp(ui, server))
Basically, it's adding an intermediate mapping table which is generated via function.

Resources