I'm trying to render some UI elements in Shiny on the client side using Javascript. I want the user to click a button which reveals a hidden panel. Once the panel is revealed, it should show a plot. When the button is clicked the panel becomes visible but the plot doesn't render.
I know this behaviour is achievable using server-side functions like observeEvent but the goal here is to leverage the client directly via JS.
Below is a reprex. For ease, I've inlined the JS and CSS.
library(shiny)
# Inline js to toggle display of element when button is clicked
js <- '
$(document).ready(function() {
document.getElementById("reveal").addEventListener("click", event => {
var panel = document.getElementById("init-hidden-panel");
panel.style.display = "block";
});
})
'
ui <- fluidPage(
tags$script(HTML(js)),
actionButton("reveal", "Reveal"),
div(
id = "init-hidden-panel",
plotOutput("plot"),
style = "display: none; background-color: darkgray" # initialize element as hidden
)
)
server <- function(input, output) {
output$plot <- renderPlot({
hist(iris$Sepal.Length)
})
}
# Run the application
shinyApp(ui = ui, server = server)
We can tell that the JS is in fact toggling the display because the gray background appears.
Perhaps you can use this method:
ui <- fluidPage(
actionButton("reveal", "Reveal"),
plotOutput("plot")
)
server <- function(input, output) {
plot_data <- reactiveValues(trigger = 0)
observe({
req(input$reveal)
isolate(plot_data$trigger <- plot_data$trigger + 1)
})
output$plot <- renderPlot({
input$reveal
if (plot_data$trigger %% 2 == 0) {
return(NULL)
} else {
hist(iris$Sepal.Length)
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
Related
Summary: When I put a shinyTree (from the R package of the same name) in a dropdownButton (from the shinyWidgets package), it seems that the tree in question is not accessible from the input variable until the user has interacted with the tree in some way. Is there a way I can force the tree to load when the app is loaded at the start?
Here is a minimal (almost) example:
library(shiny)
library(shinyWidgets)
library(shinyTree)
library(magrittr)
render.as.text <- function(t) {
if (is.null(t)) {
'argument is NULL'
} else {
q <- get_selected(t)
if (length(q) == 0) {
'none selected'
} else {
paste(q, sep=', ', collapse=', ')
}
}
}
ui <- fluidPage(
dropdownButton(shinyTree('tree', checkbox=TRUE), circle=FALSE, inputId='dd')
)
server <- function(input, output, session) {
output$tree <- renderTree({ list(OptionA = structure(list(OptionAA='', OptionAB=''), stopened=TRUE), OptionB='') })
updateActionButton(session, 'dd', label='initial label')
observe({
updateActionButton(session, 'dd', label=render.as.text(input$tree))
}) %>% bindEvent(input$dd_state)
}
shinyApp(ui = ui, server = server)
When I run this app, the button begins with the text 'initial label' (as expected), then when I click on it the first time the text changes to 'argument is NULL' (showing that the variable input$tree has a NULL value), but the tree displays correctly in the dropdown. If I then click the button again to close the dropdown, the text 'argument is NULL' remains - it remains until I actually select one or more of the tree's checkboxes after which (and after clicking the button again) it will display either a comma-separated list of selected options or 'none selected' as expected.
I would very much like to be able to refer to input$tree beginning with the first time the user takes any action in the app - ideally I am looking for some command to insert in either the server or ui code (or both) which will mean that the first time the user clicks the button its text will change directly to 'none selected' because input$tree is no longer NULL. Is this possible?
Would just changing the default of your render.as.text function work for your purpose?
library(shiny)
library(shinyWidgets)
library(shinyTree)
library(magrittr)
render.as.text <- function(t) {
if (is.null(t)) {
'none selected'
} else {
q <- get_selected(t)
if (length(q) == 0) {
'none selected'
} else {
paste(q, sep=', ', collapse=', ')
}
}
}
ui <- fluidPage(
dropdownButton(shinyTree('tree', checkbox=TRUE), circle=FALSE, inputId='dd')
)
server <- function(input, output, session) {
output$tree <- renderTree({ list(OptionA = structure(list(OptionAA='', OptionAB=''), stopened=TRUE), OptionB='') })
updateActionButton(session, 'dd', label='initial label')
observe({
updateActionButton(session, 'dd', label=render.as.text(input$tree))
}) %>% bindEvent(input$dd_state)
}
shinyApp(ui = ui, server = server)
I am builing a RShiny app where I need to create vanilla/plain html buttons and give basic functionality to them using JavaScript. In my original app I have a htmlOutput (or uiOutput) element containing these buttons (they are generated dynamically based on user input). Unfortunately JavaScript is not working properly inside this htmlOutput element and I cant figure out why. Please see my minimal reproducible example (app.R):
library(shiny)
library(shinyjs)
# define ui
ui <- fluidPage(
useShinyjs(),
tags$head(
tags$script(
HTML(
"window.onload = function(){
var coll = document.getElementsByClassName('testclass');
var i;
console.log(coll);
for (i = 0; i < coll.length; i++) {
coll[i].addEventListener('click', function() {
alert('clicked');
});
};
};
")
)
),
mainPanel(
# normal button (working)
tags$button(
type="button",
class="testclass",
"Click to alert (button inside main panel)"
),
# html output button (not working)
htmlOutput("html_out")
)
)
# define server
server <- function(input, output) {
# generate html output button (problematic with JS)
output$html_out <- renderUI({
tags$button(
type="button",
class="testclass",
"Click to alert (button inside htmlOutput)"
)
})
}
# run app
shinyApp(ui = ui, server = server)
The tags$button() element is working without problem if it is added statically into the main panel. But if the same tags$button() element is added via the htmlOutput it is not working with the JavaScript code. Is there any explanation or workaround for that?
The only difference in the html output code is that the htmlOutput element is wrapped inside a div with class = "shiny-html-output shiny-bound-output". And I know that I usually shouls use actionButton() but in my case this is not possible.
Thanks for your help!
The problem is that the initial JS in head is run when the app starts but the second button isn't available immediately. you can add the JS code directly to the HTML code
library(shiny)
library(shinyjs)
# define ui
ui <- fluidPage(
useShinyjs(),
tags$head(
tags$script(
HTML(
"window.onload = function(){
var coll = document.getElementsByClassName('testclass');
var i;
console.log(coll);
for (i = 0; i < coll.length; i++) {
coll[i].addEventListener('click', function() {
alert('clicked');
});
};
};
")
)
),
mainPanel(
# normal button (working)
tags$button(
type="button",
class="testclass",
"Click to alert (button inside main panel)"
),
# html output button (not working)
htmlOutput("html_out")
)
)
# define server
server <- function(input, output) {
# generate html output button (problematic with JS)
output$html_out <- renderUI({
tags$button(
type="button",
class="testclass",
# ADD JS HERE
onclick = "alert('clicked');",
"Click to alert (button inside htmlOutput)"
)
})
}
# run app
shinyApp(ui = ui, server = server)
I am trying to use JohnCoene/marker package to highlight sections of text in a shiny app. My intend is to first generate the text using some server logic and display it with textOutput. However, I am struggeling with how to trigger the marker after the text appeared on the website. Putting it in the same observeEvent() does not work.
Here is my reprex
# remotes::install_github("johncoene/marker")
library(shiny)
library(marker)
ui <- fluidPage(
use_marker(),
actionButton("click", "click"),
textOutput("text_to_mark")
)
server <- function(input, output) {
observeEvent(input$click,
{
output$text <- renderText("My house is yellow")
})
# observeEvent() below does not work. This is just for illustration
observeEvent(input$text_to_mark,
{
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Created on 2019-10-10 by the reprex package (v0.3.0)
For illustration: I can get the marker to work, by adding a second button as in the code below, but I am look for a solution where it gets triggered when the text appears.
# remotes::install_github("johncoene/marker")
library(shiny)
library(marker)
ui <- fluidPage(
use_marker(),
actionButton("click", "click"),
textOutput("text_to_mark"),
actionButton("mark", "Mark!")
)
server <- function(input, output) {
observeEvent(input$click,
{
output$text_to_mark <- renderText("My house is yellow")
})
observeEvent(input$mark,
{
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Created on 2019-10-10 by the reprex package (v0.3.0)
You could listen on DOM changes with javascript: Is there a JavaScript / jQuery DOM change listener?.
When a change happens you can check if your target element has text:
hasText = document.getElementById("text_to_mark").innerHTML != ""
Note that i assume that your element has the id "text_to_mark".
The result you can "send to R" with
Shiny.onInputChange("hasText", hasText);
On the R side you will know if the element has text via listening on input$hasText.
So you can add:
observeEvent(input$hasText,{
...
})
The javascript you can add to your app with tags$script(jsCode) or use shinyjs.
A reproducible example:
library(shiny)
library(marker)
jsCode <- '
MutationObserver = window.MutationObserver || window.WebKitMutationObserver;
var observer = new MutationObserver(function(mutations, observer) {
console.log(mutations, observer);
hasText = document.getElementById("text_to_mark").innerHTML != ""
Shiny.onInputChange("hasText", hasText);
});
observer.observe(document, {
subtree: true,
attributes: true
});
'
ui <- fluidPage(
use_marker(),
tags$script(jsCode),
actionButton("click", "click"),
textOutput("text_to_mark"),
actionButton("mark", "Mark!")
)
server <- function(input, output) {
observeEvent(input$click, {
output$text_to_mark <- renderText("My house is yellow")
})
observeEvent(input$hasText,{
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Note that this only works on the first appearance of the text. If you also want to listen for changes of the text, one could send the text to R instead and check on the R side if the text was updated. Not sure if it is needed here.
Listening on DOM changes is one option, but your approach already shows that there is a pure shiny (non-custom-JS) solution, it only takes one click more, so the question is how to do it with only one click. I suggest using invalidateLater and wrap it in an if statement to prevent it from running over and over again like seen here.
The trick is to run your marker calls in an observe statement. Include the invalidateLater here and wrap it in an if condition with a counter which counts how many times the statement has been executed. Play around with the number of milliseconds and counts, in my case it works fine with if(isolate(val$cnt) < 1) and invalidateLater(1000). Don't forget to wrap your counter in an isolate otherwise it will get stuck in a loop.
Note also that input$click not only writes the text into a reactiveValue but also resets the counter val$cnt to 0 so that you can use the invalidateLater again on a new text. The same procedure will help you if you want to update your text using an observeEvent or the like. Just make sure to also reset the counter to 0 and the highlighting works on your new text part.
# remotes::install_github("johncoene/marker")
library(shiny)
library(marker)
ui <- fluidPage(
use_marker(),
actionButton("click", "click"),
textOutput("text_to_mark")
)
server <- function(input, output) {
val <- reactiveValues(cnt = 0,
text = NULL)
observeEvent(input$click, {
val$text <- "My house is yellow"
val$cnt <- 0
})
observe({
if(isolate(val$cnt) < 1) {
invalidateLater(1000)
}
marker <- marker$new("#text_to_mark.shiny-text-output.shiny-bound-output")
marker$
unmark()$ # unmark all before we mark
mark("My house")
val$cnt = isolate(val$cnt) + 1
})
output$text_to_mark <-renderText({
val$text
})
}
# Run the application
shinyApp(ui = ui, server = server)
I've been trying to add a row (basically a row of check boxes) on my data table, so that users will be able to decide which column they like to keep/delete. And here is what my Shiny App looks like so far. Anyone who knows any hints please help!
Any help would be appreciated!
ui <- dashboardPage(dashboardHeader(disable = T),
dashboardSidebar(disable = T),
dashboardBody(uiOutput("MainBody")))
server <- shinyServer(function(input, output){
vals <- reactiveValues()
vals$data <- data.table(vals$Data<-data.table(
Brands=paste0("Brand",1:10),
Forecasted_Growth=sample(1:20,10),
Last_Year_Purchase=round(rnorm(10,1000,1000)^2),
Contact=paste0("Brand",1:10,"#email.com")
))
output$MainBody <- renderUI({
fluidPage(
box(width = 12,
h3(strong("Template"), align = "center"),
hr(),
column(6, offset = 6,
actionButton(inputId = "Del_Col", label = "Delete Select Column"))),
column(12, dataTableOutput("MainTable")),
tags$script()
)
})
I agree with Pork Chop that you should rethink your layout. I couldn't get my head around it so I reworked it into a minimal fluidpage.
The code below should get you close. It renders buttons (you could make these checkboxes though) directly into the table using a helper function described here. The code below uses these buttons to subset and update the dataframe which I term reactiveTable. Here's the functionality:
Good luck!
library(data.table)
library(DT)
## Nice helper function to make the buttons from:
## https://github.com/rstudio/DT/issues/178
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
## Basic UI with a reset button
ui <- fluidPage(
mainPanel(
h1('Table Subsetter'),
actionButton('reset', 'Reset!'),
DT::dataTableOutput('mytable')
)
)
server <- function(input, output){
#This is the table you provided in your question
tableA <- data.table(
Brands=paste0("Brand",1:10),
Forecasted_Growth=sample(1:20,10),
Last_Year_Purchase=round(rnorm(10,1000,1000)^2),
Contact=paste0("Brand",1:10,"#email.com")
)
#make a reactive value for the table and columns to delete
reactiveTable <- reactiveValues(tab=tableA)
columnToDelete <- reactiveValues(col=NULL)
#Logic to make the buttons, reruns everytime the table is updated
tableOut <- reactive({
buttons <- shinyInput(actionButton, length(reactiveTable$tab[1,]), 'button_', label = "Delete!", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' )
buttons <- t(as.data.frame(buttons, stringsAsFactors = FALSE))
colnames(buttons) = colnames(reactiveTable$tab)
rbind(buttons, reactiveTable$tab)
})
#reset button replaces the table
observeEvent(input$reset, {
reactiveTable$tab <- tableA
})
#listener to for the delete button
observeEvent(input$select_button, {
columnToDelete$col <-as.numeric(strsplit(input$select_button, "_")[[1]][2])
reactiveTable$tab <- subset( reactiveTable$tab, select = -columnToDelete$col )
})
#output the table with DT. use escape=F so it renders the html
output$mytable <- DT::renderDataTable({
tableOut()
},server = FALSE, escape = FALSE, selection = 'none')
}
shinyApp(ui = ui, server = server)
I have a tabbed shiny app that generates quite a bit of content based on user inputs and I'm trying to figure out how to scroll to the bottom of the active tab each time new content is generated. I tried implementing the answer given in this question but it doesn't seem to work. I'm have minimal experience with javaScript so it may just be something needs to be changed for my specific example. Here is a very silly toy example with my attempt at implementing the answer from the linked question:
library(shiny)
ui <- fluidPage(
tags$script(
'
Shiny.addCustomMessageHandler("scrollCallback",
function(color) {
var objDiv = document.getElementById("outDiv");
objDiv.scrollTop = objDiv.scrollHeight;
}
);'
),
tabsetPanel(id = "mainPanels",
tabPanel("FirstPanel",
actionButton("outGen", "GenerateOutput"))),
uiOutput("randomOutput")
)
server <- function(input, output, session) {
output$randomOutput <- renderUI({
req(input$outGen)
lapply(1:50, function(x)p("FooBar"))
})
observeEvent(input$outGen,{
session$sendCustomMessage(type = "scrollCallback", 1)
})
}
runApp(shinyApp(ui,server))
I'm trying to find a way to scroll to the bottom of the tab once the generate output button is pressed.
Here is a fixup that works. The following changes were made:
Changed the initialization so that there is some text rendered to that div before we start. This is necessary otherwise some of the variables will not be initialized properly in the div object.
Modified the text output so it changes every time (for better testing)
Added the necessary CSS overflow:auto style to the randomOutput div so that you would have a scroll bar to scroll.
Fixed up some minor typos (getElementById was querying the wrong div)
added some debugging output to scrollCallback
Here is the code:
library(shiny)
ui <- fluidPage(
tags$style('#randomOutput { height: 450px; overflow: auto;}'),
tags$script(
'
Shiny.addCustomMessageHandler("scrollCallback",
function(msg) {
console.log("aCMH" + msg)
var objDiv = document.getElementById("randomOutput");
objDiv.scrollTop = objDiv.scrollHeight - objDiv.clientHeight;
console.dir(objDiv)
console.log("sT:"+objDiv.scrollTop+" = sH:"+objDiv.scrollHeight+" cH:"+objDiv.clientHeight)
}
);'
),
tabsetPanel(id = "mainPanels",
tabPanel("FirstPanel",
actionButton("outGen", "GenerateOutput"))),
uiOutput("randomOutput")
)
server <- function(input, output, session) {
n <- 0
output$randomOutput <- renderUI({
input$outGen
n <<- n + 50
lapply(1:50, function(x)p(paste0("FooBar-",x+n-50)))
})
observeEvent(input$outGen,{
session$sendCustomMessage(type = "scrollCallback", 1)
})
}
runApp(shinyApp(ui,server))
and here is what it looks like on testing: