Below is the shiny application. Is there a way to track how the user interacts with the application, for example, from three inputs there,
what all he selects
Can we capture point 1 in a table
To be very specific, the user selects below combinations, so I need to capture this in a table . Is this possible?
if (interactive()) {
# Classic Iris clustering with Shiny
ui <- fluidPage(
headerPanel("Iris k-means clustering"),
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "xcol",
label = "X Variable",
choices = names(iris)
),
selectInput(
inputId = "ycol",
label = "Y Variable",
choices = names(iris),
selected = names(iris)[[2]]
),
numericInput(
inputId = "clusters",
label = "Cluster count",
value = 3,
min = 1,
max = 9
)
),
mainPanel(
plotOutput("plot1")
)
)
)
server <- function(input, output, session) {
# classic server logic
selectedData <- reactive({
iris[, c(input$xcol, input$ycol)]
})
clusters <- reactive({
kmeans(selectedData(), input$clusters)
})
output$plot1 <- renderPlot({
palette(c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3",
"#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999"))
par(mar = c(5.1, 4.1, 0, 1))
plot(selectedData(),
col = clusters()$cluster,
pch = 20, cex = 3)
points(clusters()$centers, pch = 4, cex = 4, lwd = 4)
})
}
shinyApp(ui, server)
}
Related
I am having trouble getting boxes to align in fluidRow column format when using bslib and theme bootstrap 4 and 5 with navbarPage. It works with version 3. I can't figure out how to make the version 5 (or 4) to return the right layout. Only one column is used for the later versions. I need the boxes to be arranged in rows.
library(shiny)
library(bslib)
library(shinydashboard)
ui <- navbarPage(
theme = bs_theme(version = 4), # Wrong Layout
#theme = bs_theme(version = 3), # Right Layout
title="Dynamic Boxes",
#
navbarMenu("Tab1" ,
tabPanel("Item1",
fluidPage(
fluidRow( column(12,
uiOutput("boxes")
)
)
)
)
)
)
server <- function(input, output) {
output$boxes <- renderUI({
lapply(1:10, function(a) {
x = 1:100
box(title = paste0("box ", a), renderPlot(plot(x = x, y = x^a)))
})
# )
})
}
shinyApp(ui = ui, server = server)
fluidRow() needs to be outside of the lapply function and column() inside.
library(shiny)
library(bslib)
library(shinydashboard)
ui <- navbarPage(
theme = bs_theme(version = 4), # Wrong Layout
#theme = bs_theme(version = 3), # Right Layout
title="Dynamic Boxes",
navbarMenu("Tab1" ,
tabPanel("Item1",
uiOutput("boxes")
)
)
)
server <- function(input, output) {
output$boxes <- renderUI({
fluidRow(
lapply(1:10, function(a) {
x = 1:100
column(6,
box(title = paste0("box ", a),
renderPlot(plot(x = x, y = x^a)))
)
})
)
})
}
shinyApp(ui = ui, server = server)
I want the user of my Shiny app to be able to choose between two types of plots by clicking on radiobuttons in the Events panel. The code I have written works, but the page leaves a huge white space when going from "Map" to "Plot". Is there any way to get rid of the white space and position the plot at the very top?
# Load R packages
library(shiny)
library(shinythemes)
library(tidyverse)
library(leaflet)
set.seed(123)
year <- 2001:2020
event <- sample(1:100, size = 20, replace = TRUE)
dat <- as.data.frame(cbind(year, event))
# Define UI
ui <- fluidPage(
shinyjs::useShinyjs(),
theme = shinytheme("journal"),
navbarPage(
"Title",
tabPanel("About",
),
tabPanel("Events",
fluidPage(
titlePanel("Title"),
sliderInput("range", label = "Move slider to select time period", min(2001), max(2020),
value = range(2001:2002), step = 1, sep = "", width = "65%"),
sidebarLayout(
sidebarPanel(
radioButtons("plotType", "Plot type", choices = c("Map" = "m", "Chart" = "l"))),
mainPanel(
leafletOutput("map"),
plotOutput("plot"))
)
)
)
)
)
# Define server function
server <- function(input, output, session) {
observeEvent(input$plotType, {
if(input$plotType == "l"){
shinyjs::disable("range")
}else{
shinyjs::enable("range")
}
})
output$plot <- renderPlot({
if (input$plotType == "l") {
ggplot(dat, aes(year, event)) +
geom_line() +
labs(x = "Year", y = "Events") +
theme_bw()
}
})
output$map <- renderLeaflet({
if ( input$plotType == "m") {
leaflet(dat) %>% addTiles() %>%
fitBounds(~min(11), ~min(54), ~max(67), ~max(24))
}
})
} # server
# Create Shiny object
shinyApp(ui = ui, server = server)
There is a big space because the map html object still exists, but is empty. To avoid this, I created and observeEvent that hides or show the map output depending on input value. I did the same thing with the plot, in cas you need to add others elements below it.
Please note that there are others solutions (conditionalPanel for example), I am just giving you the one I think is the simpliest here.
# Load R packages
library(shiny)
library(shinythemes)
library(tidyverse)
library(leaflet)
set.seed(123)
year <- 2001:2020
event <- sample(1:100, size = 20, replace = TRUE)
dat <- as.data.frame(cbind(year, event))
# Define UI
ui <- fluidPage(
shinyjs::useShinyjs(),
theme = shinytheme("journal"),
navbarPage(
"Title",
tabPanel("About",
),
tabPanel("Events",
fluidPage(
titlePanel("Title"),
sliderInput("range", label = "Move slider to select time period", min(2001), max(2020),
value = range(2001:2002), step = 1, sep = "", width = "65%"),
sidebarLayout(
sidebarPanel(
radioButtons("plotType", "Plot type", choices = c("Map" = "m", "Chart" = "l"))),
mainPanel(
leafletOutput("map"),
plotOutput("plot"))
)
)
)
)
)
# Define server function
server <- function(input, output, session) {
# hide or show map and plot
observeEvent(input$plotType, {
if(input$plotType == "l"){
shinyjs::disable("range")
shinyjs::hide("map")
shinyjs::show("plot")
}
if(input$plotType == "m"){
shinyjs::enable("range")
shinyjs::show("map")
shinyjs::hide("plot")
}
})
output$plot <- renderPlot({
req(input$plotType == "l") # good practice to use req instead of if
ggplot(dat, aes(year, event)) +
geom_line() +
labs(x = "Year", y = "Events") +
theme_bw()
})
output$map <- renderLeaflet({
req(input$plotType == "m")
leaflet(dat) %>% addTiles() %>%
fitBounds(~min(11), ~min(54), ~max(67), ~max(24))
})
} # server
# Create Shiny object
shinyApp(ui = ui, server = server)
I would like that if the checkboxInput Factorial parameters is selected, this would do the app to show a new selectInput with several option.
Here is a minimum working example.
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
checkboxInput("fixed", "Factorial parameters"),
conditionalPanel(condition = "fixed == 'TRUE'",
selectInput("choice",
"Choose your fixed parameter",
c("alpha"= "Alpha", "beta"="Beta"),
selected = "alpha"))
)
,
mainPanel(
plotOutput("distPlot")
)
)
)
server <- function(input, output) {
output$distPlot <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
shinyApp(ui = ui, server = server)
Can anyone tell me what am I doing wrong?
Many thanks!
Update
I figured it out! edit as follows:
conditionalPanel(condition = "input.fixed == 1",
Previous answers
Generally, you would need input.fixed in a conditionalPanel although this doesn't seem to work for checkboxInput for some reason (maybe someone else can explain why?). There are a few alternatives. I would suggest the shinyjs package.
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
checkboxInput("fixed", "Factorial parameters"),
hidden(selectInput("choice",
"Choose your fixed parameter",
c("alpha"= "Alpha", "beta"="Beta"),
selected = "alpha"))
)
,
mainPanel(
plotOutput("distPlot")
)
)
)
server <- function(input, output) {
output$distPlot <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
observeEvent(input$fixed, {
toggle("choice")
}, ignoreInit = TRUE)
})
}
shinyApp(ui = ui, server = server)
Instead of toggle you could be more explicit with an if...else statement using shinysj::show() and shinyjs::hide() although I think this is neater (just note the ignoreInit = TRUE).
As mentioned above using checkboxGroupInput for example seems to work with conditionalPanels:
checkboxGroupInput("fixed", label = "", choices = "Factorial parameters"),
conditionalPanel(condition = "input.fixed == 'Factorial parameters'",
selectInput("choice",
"Choose your fixed parameter",
c("alpha"= "Alpha", "beta"="Beta"),
selected = "alpha"))
slightly hacky but does the job.
I have tried this in different ways and achieved one task, either add or delete., but i couldn't get complete solution in one, i might be missing some small concept somewhere.. I am adding the code , please help me complete my basic app.
library(shiny)
library(DT)
x<- data.frame(v1 = NA,
v2 = NA
),
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
textInput("v1","v1","a"),
numericInput("V2","V2","1"),
# Row selection
numericInput(inputId = "row.selection", label = "Select row to be
deleted", min = 1, max = 100, value = "")
# Add button
actionButton(inputId = "add.button", label = "Add", icon =
icon("plus")),
# Delete button
actionButton(inputId = "delete.button", label = "Delete", icon =
icon("minus")),
),
mainPanel(
dataTableOutput('table')
)
)
)
),
Server side code
server = function(input, output, session) {
values <- reactiveValues()
values$df <- x
newEntry <- observe({
cat("newEntry\n")
if(input$add.button > 0) {
newRow <- data.frame(input$v1, input$v2)
isolate(values$df <- rbind(values$df,newRow))
}
})
deleteEntry <- observe({
cat("deleteEntry\n")
if(input$delete.button > 0) {
if(is.na(isolate(input$row.selection))){
values$df <- isolate(values$df[-nrow(values$df), ])
} else {
values$df <- isolate(values$df[-input$row.selection, ])
}
}
})
output$table = renderDataTable({
values$df
})
}
Try to use observeEvent rather than obser with actionbutton
and also, you have uppercase and lowercase issue with input$v2 (should be input$V2)
Try this modified code:
library(shiny)
library(DT)
x<- data.frame(v1 = NA,
v2 = NA
)
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
textInput("v1","v1","a"),
numericInput("V2","V2","1"),
# Row selection
numericInput(inputId = "row.selection", label = "Select row to be
deleted", min = 1, max = 100, value = ""),
# Add button
actionButton(inputId = "add.button", label = "Add", icon =
icon("plus")),
# Delete button
actionButton(inputId = "delete.button", label = "Delete", icon =
icon("minus"))
),
mainPanel(
dataTableOutput('table')
)
)
)
)
server = function(input, output, session) {
values <- reactiveValues()
values$df <- x
observeEvent(input$add.button,{
cat("addEntry\n")
print(input$v1)
print(input$V2)
newRow <- data.frame(input$v1, input$V2)
colnames(newRow)<-colnames(values$df)
values$df <- rbind(values$df,newRow)
print(nrow(values$df))
})
observeEvent(input$delete.button,{
cat("deleteEntry\n")
if(is.na(input$row.selection)){
values$df <- values$df[-nrow(values$df), ]
} else {
values$df <- values$df[-input$row.selection, ]
}
})
output$table = renderDataTable({
values$df
})
}
shinyApp(ui,server)
Just run all the code above, and it should work properly.
This app is creating a vector of standardised names which I create given some user input (number of channels and replicates). An example of the standard names given the number of channels = 4 and and replicates = 1 is as follows:
c("rep1_C0","rep1_C1","rep1_C2","rep1_C3")
I would like to allow the user to replace the value of the selection with their own custom value. For example to change the input "rep1_C0" to "Control_rep1". And then for it to then update the reactive vector in question. Here is my code:
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
),
uiOutput("selectnames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
standardNames <- reactive({
paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
})
output$selectnames <- renderUI({
selectizeInput("selectnames", "Change Names", choices = standardNames(),
options = list(maxOptions = input$reps * input$chans))
})
## output
output$testcols <- renderTable({
standardNames()
})
})
shinyApp(ui = ui, server = server)
Is there some kind of option I can pass in the options sections that will allow this?
With selectizeInput you can set options = list(create = TRUE) to allow the user to add levels to the selection list, but I don't think that is what you want.
Instead, here is code that generates a text input box for each of the standard names, and allows the user to enter a label for them. It uses lapply and sapply to loop over each value and generate/read the inputs.
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
),
uiOutput("setNames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
standardNames <- reactive({
paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
})
output$setNames <- renderUI({
lapply(standardNames(), function(thisName){
textInput(paste0("stdName_", thisName)
, thisName
, thisName)
})
})
labelNames <- reactive({
sapply(standardNames()
, function(thisName){
input[[paste0("stdName_", thisName)]]
})
})
## output
output$testcols <- renderTable({
data.frame(
stdName = standardNames()
, label = labelNames()
)
})
})
shinyApp(ui = ui, server = server)
If you want to hide the list unless the user wants to add labels, you can use a simple checkbox, like this, which hides the label making list until the use checks the box to show it.
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
)
, checkboxInput("customNames", "Customize names?")
, uiOutput("setNames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
standardNames <- reactive({
paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
})
output$setNames <- renderUI({
if(!input$customNames){
return(NULL)
}
lapply(standardNames(), function(thisName){
textInput(paste0("stdName_", thisName)
, thisName
, thisName)
})
})
labelNames <- reactive({
if(!input$customNames){
return(standardNames())
}
sapply(standardNames()
, function(thisName){
input[[paste0("stdName_", thisName)]]
})
})
## output
output$testcols <- renderTable({
data.frame(
stdName = standardNames()
, label = labelNames()
)
})
})
shinyApp(ui = ui, server = server)
Alternatively, if you think the user may want to only change one or a small number of labels, here is a way to allow them to choose which standard name they are applying a label to:
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
)
, uiOutput("setNames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
vals <- reactiveValues(
labelNames = character()
)
standardNames <- reactive({
out <- paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
vals$labelNames = setNames(out, out)
return(out)
})
output$setNames <- renderUI({
list(
h4("Add labels")
, selectInput("nameToChange", "Standard name to label"
, names(vals$labelNames))
, textInput("labelToAdd", "Label to apply")
, actionButton("makeLabel", "Set label")
)
})
observeEvent(input$makeLabel, {
vals$labelNames[input$nameToChange] <- input$labelToAdd
})
## output
output$testcols <- renderTable({
data.frame(
stdName = standardNames()
, label = vals$labelNames
)
})
})
shinyApp(ui = ui, server = server)