I use the library shinythemes pretty extensively in apps that I build. I was trying to leverage a bsModal from the shinyBS package and noticed that the 'fade in' div never went away leaving me with an unusable web app since nothing was clickable.
The examples from shinyBS::bsModal all work fine (they are sans-shinythemes). How can I continue to use themes while also using modals?
Example App:
library(shiny)
library(shinyBS)
library(shinythemes)
app = shinyApp(
ui =
navbarPage(title=NULL,
id="navbar",
theme = shinytheme("journal"),
tabPanel("test",
column(1),
column(3,
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
actionButton("tabBut", "View Table")
),
column(7,
plotOutput("distPlot"),
bsModal("modalExample", "Data Table", "tabBut", size = "large",
dataTableOutput("distTable"))
)
)
),
server =
function(input, output, session) {
output$distPlot <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$distTable <- renderDataTable({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
tab <- hist(x, breaks = bins, plot = FALSE)
tab$breaks <- sapply(seq(length(tab$breaks) - 1), function(i) {
paste0(signif(tab$breaks[i], 3), "-", signif(tab$breaks[i+1], 3))
})
tab <- as.data.frame(do.call(cbind, tab))
colnames(tab) <- c("Bins", "Counts", "Density")
return(tab[, 1:3])
}, options = list(pageLength=10))
}
)
runApp(app)
I don't know what causes the conflict, but the solution is to specify the link to the theme directly. Replace theme = shinytheme("journal") with theme = "http://bootswatch.com/journal/bootstrap.css" adjusting the name for the theme you're using.
Related
I am trying to create a dynamic UI that has variable number of user inputs based on a user input and charts that uses that second level of user input.
A working example below:
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
numericInput(inputId = "Chartcount",
label = "Enter number of charts",
value = 5,
min = 2,
max = 8),
uiOutput("distui")
)
server <- function(input, output) {
c_count = reactive({input$Chartcount})
output$distui <- renderUI({
lapply(seq(1:c_count()), function(x){
chartId = (paste("Chart",x, sep = "="))
sinput <- sliderInput(inputId = paste(x,"_bins"),
"Number of bins:",
min = 1,
max = 50,
value = 30)
selectedbins = input[[paste(x,"_bins")]] # input$inputId does not work here as expression after $ can not be evaluated
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = 25 ) #I want to use selectedbins here for length.out
distplot <- renderPlot(hist(x, breaks = bins, col = 'darkgray', border = 'white'))
list(chartId, sinput,selectedbins, distplot)
})
})
}
shinyApp(ui = ui, server = server)
I think there are at least a couple of problems with this.
Selected number of bins resets as soon as they are selected
I get an error when I try to use selectedbins in the chart for
length.out
bins <- seq(min(x), max(x), length.out = selectedbins ) # This throws an error Error: argument 'length.out' must be of length 1
The selected number of bins is resetting because it is inside of the same reactive expression, you should put it in a different reactive expression, otherwise the full expression is going to be executed every time you change the input and it is going to recreate all the inputs and plots.
The second problem is caused because you are trying to use the selectedbins input value before the slider is created, therefore the value is NULL (length 0), you can only get the value after the slider is created.
Below is your code modified to create the plots in a separated reactive expression as a nested expression, maybe not the best solution but it is in the same style that your program. Also, reusing the x variable is confusing, so I changed the first one by k.
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
numericInput(inputId = "Chartcount",
label = "Enter number of charts",
value = 5,
min = 2,
max = 8),
uiOutput("distui")
)
server <- function(input, output) {
output$distui <- renderUI({
lapply(seq(1:input$Chartcount), function(k){
chartId = (paste("Chart", k, sep = "="))
sinput <- sliderInput(inputId = paste(k, "bins_"),
"Number of bins:",
min = 1,
max = 50,
value = 30)
x <- faithful[, 2]
distplot <- tagList(
renderUI({
selectedbins = input[[paste(k, "bins_")]]
bins <- seq(min(x), max(x), length.out = selectedbins )
tagList(
selectedbins,
renderPlot(hist(x, breaks = bins, col = 'darkgray', border = 'white'))
)
})
)
list(chartId, sinput, distplot)
})
})
}
shinyApp(ui = ui, server = server)
I am using bsModal() window from the ShinyBS package in one of my Shiny Apps. Whenever the user opens the modal window for the second time, the contents of the window from the first opening remain on the screen until the new content loads. Which is not ideal. Is there a way to delete the contents of the bsModal() window once it is closed? I do not want the older content to appear in the window once it is reopened. Subsequently, maybe there is a way to clean up the bsModal() window before opening?
I wasn't able to find any solution for this
Here is some example (not my) code of an app that can be also accessed through:
library(shinyBS)
bsExample("Modals")
ui.R
library(shiny)
library(shinyBS)
fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
actionButton("tabBut", "View Table")
),
mainPanel(
plotOutput("distPlot"),
bsModal("modalExample", "Data Table", "tabBut", size = "large",
dataTableOutput("distTable"))
)
)
)
server.R
library(shiny)
library(shinyBS)
shinyServer(
function(input, output, session) {
output$distPlot <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$distTable <- renderDataTable({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
tab <- hist(x, breaks = bins, plot = FALSE)
tab$breaks <- sapply(seq(length(tab$breaks) - 1), function(i) {
paste0(signif(tab$breaks[i], 3), "-", signif(tab$breaks[i+1], 3))
})
tab <- as.data.frame(do.call(cbind, tab))
colnames(tab) <- c("Bins", "Counts", "Density")
return(tab[, 1:3])
}, options = list(pageLength=10))
}
)
I have been asked to create something I'm not sure is possible in Shiny: a context menu that appears when a user right-clicks on a numeric input. I know how to show a context popup on a chart (see code below), but this doesn't help me answer the following:
Can an input widget catch a click / hover / right click event?
Can I generate a Shiny menu in this kind of popup window?
I'm happy to receive answers along the lines of 'not possible' or 'not possible unless you learn all of Javascript today'. If so I will think of another way to incorporate this kind of context-sensitive response in the interface.
Example code that produces a hovering window on click on a chart:
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
numericInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30
)
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot", click = "plotclick"),
uiOutput("plotClickInfo")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$plotClickInfo <- renderUI({
click <- input$plotclick
## Find the KPI
if (!is.null(click)){
aText <- "More text"
aLabel <- 'my label'
# calculate point position INSIDE the image as percent of total dimensions
# from left (horizontal) and from top (vertical)
left_pct <- (click$x - click$domain$left) / (click$domain$right - click$domain$left)
top_pct <- (click$domain$top - click$y) / (click$domain$top - click$domain$bottom)
# calculate distance from left and bottom side of the picture in pixels
left_px <- click$range$left + left_pct * (click$range$right - click$range$left)
top_px <- click$range$top + top_pct * (click$range$bottom - click$range$top)
# create style property fot tooltip
# background color is set so tooltip is a bit transparent
# z-index is set so we are sure are tooltip will be on top
style <- paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); max-width: 200px;",
"left:", left_px + 2, "px; top:", top_px + 2, "px;")
# actual tooltip created as wellPanel
wellPanel(
style = style,
p(HTML(paste0("<b> KPI: </b>", aLabel, "<br/>",
"<b> Information: </b>", aText)))
)
}
else return(NULL)
})
}
# Run the application
shinyApp(ui = ui, server = server)
You can use wonderful shinyjs package which has a lot of event listeners built. Have a look at his docs https://cran.r-project.org/web/packages/shinyjs/shinyjs.pdf. If you want to reconcile some jquery events look here http://api.jquery.com/category/events/mouse-events/
Here is an example of some of them you might find useful, I think the right click is the mousedown event, but you can check
#onclick("bins", v$click <- rnorm(1))
#onevent("hover", "bins", v$click <- rnorm(1))
#onevent("dblclick", "bins", v$click <- rnorm(1))
onevent("mousedown", "bins", v$click <- rnorm(1))
Code:
library(shiny)
library(shinyjs)
# Define UI for application that draws a histogram
ui <- fluidPage(
useShinyjs(),
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
numericInput("bins","Number of bins:",min = 1,max = 50,value = 30),
uiOutput("plotClickInfo")
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot", click = "plotclick")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
v <- reactiveValues()
#onclick("bins", v$click <- rnorm(1))
#onevent("hover", "bins", v$click <- rnorm(1))
#onevent("dblclick", "bins", v$click <- rnorm(1))
onevent("mousedown", "bins", v$click <- rnorm(1))
output$plotClickInfo <- renderUI({
if (!is.null(v$click)){
aText <- "More text"
aLabel <- paste0('my label - ',v$click)
wellPanel(
p(HTML(paste0("<b> KPI: </b>", aLabel, "<br/>","<b> Information: </b>", aText)))
)
}
else return(NULL)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Following the excellent pointers by #Pork Chop and some previous code that I had, I have finished with the following code (note in the end I have gone with clicking on an icon / image next to the widget label rather than inside the widget; this purely to avoid confusing the user, and because the right click (for which the event is contextmenu) brings up a browser-specific context menu already. The code remembers the numbers that the user has entered and gives feedback where the totals go over or under 100% (relevant in my case). It also only accepts the entries if they add up to exactly 100%, otherwise the context menu will not disappear.
I know this answer goes beyond my initial question but I hope it may be helpful for someone trying to do the same or similar.
library(shiny)
library(shinyjs)
initialValues <- c(25, 25, 25, 25)
# Define UI for application that draws a histogram
ui <- fluidPage(
useShinyjs(),
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
p(id = "coords", "Click me to see the mouse coordinates"), ## Example of the mouse click feedback
div(style='display: inline-block;',
"Click here for info",
img(id = "image", src='https://www.zorro.com/wp-content/uploads/cc_resize/005-1200x542.jpg',height='30px',style='display: inline-block;', click = "image_click")
),
uiOutput("plotClickInfo"),
numericInput("bins",NULL,min = 1,max = 50,value = 30)
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot", click = "plotclick")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
v <- reactiveValues()
onclick("coords", function(event) { alert(event) })
## Examples of other events we might use
#onclick("bins", v$click <- rnorm(1))
#onevent("hover", "bins", v$click <- rnorm(1))
#onevent("dblclick", "bins", v$click <- rnorm(1))
#onevent("mousedown", "bins", v$click <- rnorm(1))
## The actual event we have used.
onclick("image", function(event) {v$clickX <- event$pageX
v$clickY <- event$pageY
## Store the initial values of the controls.
if (!is.null(input$perc1)) {
initialValues[1] <- input$perc1
}
else {
v$perc1Value <- initialValues[1]
}
if (!is.null(input$perc2)) {
initialValues[2] <- input$perc2
}
else {
v$perc2Value <- initialValues[2]
}
if (!is.null(input$perc3)) {
initialValues[3] <- input$perc3
}
else {
v$perc3Value <- initialValues[3]
}
if (!is.null(input$perc4)) {
initialValues[4] <- input$perc4
}
else {
v$perc4Value <- initialValues[4]
}
})
output$plotClickInfo <- renderUI({
if (!is.null(v$clickX)){
style <- paste0("position:absolute; z-index:100; background-color: rgba(100, 245, 245, 0.85); max-width: 250px; width: 250px;",
"left:", v$clickX + 2, "px; top:", v$clickY - 50, "px;")
# actual tooltip created as wellPanel
wellPanel(
style = style,
p(HTML(paste0("<b> KPI: </b>", "bla", "<br/>",
"<b> Information: </b>", "aText"))),
numericInput("perc1", "Percentage1", v$perc1Value, 0, 100, width="100%"),
numericInput("perc2", "Percentage2", v$perc2Value, 0, 100, width="100%"),
numericInput("perc3", "Percentage3", v$perc3Value, 0, 100, width="100%"),
numericInput("perc4", "Percentage4", v$perc4Value, 0, 100, width="100%"),
conditionalPanel(style = "color: red;", condition = "(input.perc1 + input.perc2 + input.perc3 +
input.perc4 > 100)",
"Total of percentages cannot exceed 100%"),
conditionalPanel(style = "color: red;", condition = "(input.perc1 + input.perc2 + input.perc3 +
input.perc4 < 100)",
"Total of percentages must add up to 100%"),
actionButton("myAction", "Go"), actionButton("myCancel", "Cancel")
)
}
else return(NULL)
})
observeEvent(input$myAction, {
## Only disappear this popup
if (input$perc1 + input$perc2 + input$perc3 + input$perc4 == 100) {
v$perc1Value <- input$perc1
v$perc2Value <- input$perc2
v$perc3Value <- input$perc3
v$perc4Value <- input$perc4
v$clickX = NULL
}
})
observeEvent(input$myCancel, {
## Revert to original values.
updateNumericInput(session, "perc1", initialValues[1])
updateNumericInput(session, "perc2", initialValues[2])
updateNumericInput(session, "perc3", initialValues[3])
updateNumericInput(session, "perc4", initialValues[4])
v$clickX = NULL
})
}
# Run the application
shinyApp(ui = ui, server = server)
I want the app to load a single time with default values, but become reactive only when the user types the correct password. To keep things simple let's work from the Rstudio template (minutely edited):
ui.R:
library(shiny)
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
passwordInput("pw", "Password:"),
sliderInput("nbins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
plotOutput("histo")
)
)))
server.R:
PASSWORD <- "test"
library(shiny)
shinyServer(function(input, output) {
output$histo <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$nbins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
})
There are two reactive inputs pw and nbins. My question is: How could the code be extended to make nbins (behavior) switch between reactive and non-reactive depending on the input pw being equal to PASSWORD?
Building on Valter's answer, you can use shinyjs to enable/disable interactivity with the input widget.
ui.R
library(shiny)
library(shinyjs) # install shinyjs
shinyUI(fluidPage(
useShinyjs(), # activate
sidebarLayout(
sidebarPanel(
passwordInput("pw", "Password:"),
sliderInput("nbins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
plotOutput("histo")
)
)))
server.R
library(shiny)
library(shinyjs)
shinyServer(function(input, output) {
observe({
if(input$pw != "PASSWORD") shinyjs::hide("nbins") else shinyjs::show("nbins")
})
output$histo <- renderPlot({
x <- faithful[, 2]
# will 'reset' bins to original value if incorrect pw
if(input$pw != "PASSWORD") {
bins <- seq(min(x), max(x), length.out = 30 + 1)
} else {
bins <- seq(min(x), max(x), length.out = input$nbins + 1)
}
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
})
What about this solution:
PASSWORD <- "test"
library(shiny)
shinyServer(function(input, output) {
bins <- eventReactive(input$nbins, {
if (input$pw == PASSWORD) {
bins <- seq(min(faithful[, 2]), max(faithful[, 2]), length.out = input$nbins + 1)
} else {
bins <- seq(min(faithful[, 2]), max(faithful[, 2]), length.out = 30 + 1)
}
})
output$histo <- renderPlot({
x <- faithful[, 2]
hist(x, breaks = bins(), col = 'darkgray', border = 'white')
})
})
I am building my first app in shiny. The problem to solve is like this.
I've ui
shinyUI(fluidPage(
# Application title
titlePanel("My"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel("Variables",
sliderInput("bins",
"Number of circles:",
min = 1,
max = 50,
value = 30),
sliderInput("bins",
"Number of triangels:",
min = 1,
max = 50,
value = 1)
),
# Show a plot of the generated distribution
mainPanel(tabsetPanel(
tabPanel("Data", plotOutput("distPlot")),
tabPanel("Data1", textOutput("text1")),
tabPanel("Data2", plotOutput("distPlot1")))
)
)
))
and server
shinyServer(function(input, output) {
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$distPlot1 <- renderPlot({
x <- faithful[, 2]
plot(density(x))
})
output$text1 <- renderText({
"Hello mother"
})
})
The question concern ui part. I'd like to fave 2 panels in the sidebarPanel - triangles and circles, similar to that what is in the mainPanel i.e. Data, Data1, Data2.
Thanks for the comments!