Develop Reference

update menuanchor of fullPage.js in R Shiny App from server side

I am using the fullPage package to create a Shiny App and I am facing the following issue : I would like to update from the server side the labels of the menu that are first defined in the pagePiling function of the ui part.
I have seen in the HTML code that the field that I should update is the one here below, but I don't know how to change it/access it in the server part of my app.
<ul id="tocMenu">
<li data-menuanchor="test_page">
temp_title
</li>
</ul>
I have the impression that this sould be achievable with javascript, but I don't know a lot about js ; among others, I have tried so far the following stuff :
library(fullPage)
library(shiny)
library(shinyjs)
library(shinyWidgets)
shinyApp(
ui = pagePiling(
shinyjs::useShinyjs(),
center = TRUE,
sections.color = c(
"#CFE2F3"
),
menu = c(
"temp_title" = "test_page"
),
pageSection(
menu="test_page",
pickerInput("title", multiple = F, selected=NULL,
choices = c("Title 1", "Title 2")),
)
),
server = function(input, output) {
observeEvent(input$title, {
# runjs("$('#fullpage').fullpage({
# anchors: ['test'],
# menu: '#tocMenu'});")
runjs(paste0('document.getElementById("test_page").innerHTML = "', input$title, '";'))
} )
}
)
If anyone could help, I would be very grateful !
Thanks

The problem is that you use getElementById() but the menu title doesn't have an id, it has an href tag:
Therefore, you should use querySelectorAll() instead and specify the characteristics of the element you want to select (here, it's an element a that has href="#test_page"). Finally, this function returns a list of elements (this list only contains 1 element here), so you need to use [0] to select it.
Here's your example fixed:
library(fullPage)
library(shiny)
library(shinyjs)
library(shinyWidgets)
shinyApp(
ui = pagePiling(
shinyjs::useShinyjs(),
center = TRUE,
sections.color = c(
"#CFE2F3"
),
menu = c(
"temp_title" = "test_page"
),
pageSection(
menu="test_page",
pickerInput("title", multiple = F, selected=NULL,
choices = c("Title 1", "Title 2")),
)
),
server = function(input, output) {
observeEvent(input$title, {
# runjs("$('#fullpage').fullpage({
# anchors: ['test'],
# menu: '#tocMenu'});")
runjs(paste0('document.querySelectorAll("a[href=\'#test_page\']")[0].innerHTML = "', input$title, '";'))
} )
}
)

How to use JS to count the number of clicks of a selectInput function?

In running the below code, each click of the actionButton() is correctly counted and output to the UI (using reactive value y). I'm trying to do the same with selectInput() (counting each time a selection is made)(using reactive value x), but it doesn't completely correctly count because when first invoking the App, selecting the default choice of "Cyl" is not included in the count (I'd like it to), and clicking the same choice more than once isn't included in the count (I'd like all clicks counted). One workaround is to include "multiple = TRUE" in the selectInput(), but I'd like to see if there's a JS solution instead so I don't have to change the UI the way including "multiple = TRUE" does.
As an aside, using "multiple = TRUE" also corrects the weird subtraction of 1 from (x) in output$clickSelInput...; hopefully a JS solution does the same.
Code:
library(shiny)
ui = fluidPage(hr(),
selectInput("selInput",label=NULL,c("Cyl"="cyl","Trans"="am","Gears"="gear"),selected=NULL),
actionButton("addBtn","Add"), hr(),
textOutput("clickSelInput"),
textOutput("clickAddBtn"),
tableOutput("data")
)
server = function(input, output) {
x = reactiveVal(0)
y = reactiveVal(0)
output$data <- renderTable({mtcars[1:10, c("mpg", input$selInput), drop = FALSE]})
observeEvent(input$selInput,{x(x()+1)})
observeEvent(input$addBtn,{y(y()+1)})
output$clickSelInput <- renderText({paste('Select Input clicks =',x()-1)})
output$clickAddBtn <- renderText({paste('Add Button clicks =',y())})
}
shinyApp(ui, server)

Here is a working solution, taking SamR's suggestion into account and using that example by analogy. I had to make other changes to make it work. I commented changes below from OP.
library(shiny)
library(shinyjs) # added
ui = fluidPage(hr(),
useShinyjs(), # added, this line is easy to forget to add
uiOutput("selInput"), # added, pulls renderUI output from server into UI
actionButton("addBtn","Add"), hr(),
textOutput("clickSelInput"),
textOutput("clickAddBtn"),
tableOutput("data")
)
server = function(input, output) {
x = reactiveVal(0)
y = reactiveVal(0)
output$data <- renderTable({mtcars[1:10, c("mpg", input$selInput), drop = FALSE]})
observeEvent(input$addBtn,{y(y()+1)})
# moved select input into renderUI so it can interact with JS in the observe further down:
output$selInput <- renderUI(
selectInput("selInput",label=NULL,c("Cyl"="cyl","Trans"="am","Gears"="gear"),selected=NULL)
)
output$clickSelInput <- renderText({paste('Select Input clicks =',input$rnd)}) # changed
output$clickAddBtn <- renderText({paste('Add Button clicks =',y())})
# added js:
observe({
if(is.null(input$rnd)){
runjs("
var click = 0;
Shiny.onInputChange('rnd', click)
var selInput = document.getElementById('selInput')
selInput.onclick = function() {click += 1; Shiny.onInputChange('rnd', click)};
")
}
})
}
shinyApp(ui, server)

How the change attributes of UI elements with JavaScript in Shiny?

I know there is this server side method called renderUI, but it makes updating the UI extremely slow in some cases, so I am now relying on the JavaScript.
My problem is a follows. I would like to update the title attribute of material_card from shinymaterial package. I would like to see the title to change, every time I select an alternative from a separate dropdown menu.
So far my list of UI components contain tags$script() object, which is supposed to observe the changes in the selectInput (goes with id "dropdown").
My code looks as follows:
library(shinymaterial)
library(shiny)
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
c('Hat','Shoes','Jacket')),
tags$script('
$(document).on("shiny:inputchanged", function(event) {
if (event.name === "dropdown") {
if(input.dropdown === "Jacket") {
//Even this alert is not working, possibly because input.name is not recognized. :(
alert("You chose Jacket, now the material card title will be changed to: Jacket selected");
//What am I supposed to put here to update the material_card title?
} else {
//...and here as well...
}
});'
),
material_card(
depth=5,
title = 'This value needs to be changed according what was chosen in the dropdown menu!')
),
mainPanel(
h5('Nothing here!')
)
)
)
server <- function(input, output) {
#The server is empty, as it should. :)
}
shinyApp(ui = ui, server = server)
I managed to get the alert working without the if(input.dropdown === "Jacket") validation, but this validation is not working: Most likely input.dropdown is not even recognized, although it works nicely with conditional panel.
Furthermore, I am even more lost with the logic: How should I actually use JavaScript to update the material_card title, after the change in selectInput (dropdown) value has been observed?

library(shinymaterial)
library(shiny)
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
c('Hat','Shoes','Jacket')),
tags$script(HTML('
$(document).on("shiny:inputchanged", function(event) {
if (event.name === "dropdown") {
if(event.value === "Jacket") {
alert("You chose Jacket, now the material card title will be changed to: Jacket selected");
$("#mycard>span.card-title").html("Here is the new card title");
} else {
//...and here as well...
}
}
});')
),
material_card(
depth=5,
title = 'This value needs to be changed according what was chosen in the dropdown menu!',
id = "mycard"
)
),
mainPanel(
h5('Nothing here!')
)
)
)
shinyApp(ui, server = function(input,output){})

A shiny UI-only solution:
library(shinymaterial)
library(shiny)
dropdownChoices <- c('Hat','Shoes','Jacket')
ui <- material_page(
titlePanel("Soon to be working JavaScript example!"),
sidebarLayout(
sidebarPanel(
selectInput(
"dropdown",
"Dropdown menu",
dropdownChoices),
material_card(
depth = 5,
title = lapply(dropdownChoices, function(i){
conditionalPanel(sprintf('input.dropdown == "%s"', i), i)
})
)),
mainPanel(
h5('Nothing here!')
)
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)

Trigger a reaction after change of textOutput() in shiny

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)

Autoclose date range input shiny

I want the date picker to autoclose after a date is selected. I know how to do it when the daterangeinput is rendered directly in the ui but not when it is created in the server.
Here is my code.
library('shiny')
js_string <- "$('#dates input').bsDatepicker({autoclose: true});"
shinyApp(
ui = fluidPage(
tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode", function(message) { eval(message.value); });'))),
includeScript("code.js"),
fluidRow(
column(4,
uiOutput(outputId = 'dateui'),
verbatimTextOutput("datesOut")
)
)
),
server = function(input, output, session) {
output$dateui <- renderUI({
dateRangeInput("dates", label = h3("Date range"))
})
session$onFlushed(function() {
session$sendCustomMessage(type = 'jsCode', list(value = js_string))
})
output$datesOut <- renderPrint({ names(session) })
}
)
$('#dates input').bsDatepicker({autoclose: true}); works well if the daterange is created in the ui directly as shown in following code. Besides this code also works well if I want to disable keyboard input with $('#dates').attr('onkeydown', 'return false');.
library('shiny')
shinyApp(
ui = fluidPage(
includeScript("code.js"),
fluidRow(
column(4,
dateRangeInput("dates", label = h3("Date range")),
verbatimTextOutput("datesOut")
)
)
),
server = function(input, output, session) {
output$datesOut <- renderPrint({ input$dates })
}
)
With the js code
$(document).ready(function(){
$('#dates input').bsDatepicker({autoclose: true});
});
My question is related to another question I posted.
I also tried $('#dates input').datepicker({autoclose: true}); but it does not work. I know that $(document).ready(function() ... cannot work as the code will be launched once the document is ready hence before the daterange is rendered.
Edit:
I also tried using shinyjs but it does not work either.
library('shiny')
library('shinyjs')
jsCode <- "shinyjs.changeDate = function(){
$('#dates input').bsDatepicker({autoclose: true});
$('#dates').attr('onkeydown', 'return false');
}"
shinyApp(
ui = fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode),
fluidRow(
column(4,
uiOutput(outputId = 'dateui'),
verbatimTextOutput("datesOut")
)
)
),
server = function(input, output, session) {
output$dateui <- renderUI({
dateRangeInput("dates", label = h3("Date range"))
})
session$onFlushed(function() {
js$changeDate()
})
}
)
I am stuck here, any help is greatly appreciated.
Cheers
Edit2: Adding my session info
R version 3.4.4 (2018-03-15)
Platform: x86_64-apple-darwin15.6.0 (64-bit)
Running under: macOS High Sierra 10.13.3
Matrix products: default
BLAS: /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libBLAS.dylib
LAPACK: /Library/Frameworks/R.framework/Versions/3.4/Resources/lib/libRlapack.dylib
locale:
[1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] shinyjs_1.0 shiny_1.0.5 V8_1.5
loaded via a namespace (and not attached):
[1] compiler_3.4.4 R6_2.2.2 htmltools_0.3.6 tools_3.4.4 curl_3.1
[6] yaml_2.1.18 Rcpp_0.12.16 digest_0.6.15 jsonlite_1.5 xtable_1.8-2
[11] httpuv_1.3.6.2 mime_0.5

This is a bit hacky but it works using JQuery:
tags$head(
tags$script(HTML("setInterval(
function checkContainer () {
if($('.datepicker-days').is(':visible')){ //if the container is visible on the page
$(function () {
$('td.day').click(function () {
$('.dropdown-menu').hide()
});
});
} else {
setTimeout(checkContainer, 50); //wait 50 ms, then try again
}
},
50 /* 10000 ms = 10 sec */
);"))
)
All you need to do is add this to the tags$head function within fluidpage of your ui.
This works if the last user input is selecting the day.
If your dateRangeInput is limited to choosing the month, then all you have to do is edit '.datepicker-days' to '.datepicker-months' and change '.td.day' to '.td.month'. If you're limiting to a year; change days to years and change day to year.
The reason as to why it's hacky is because the JQuery script is being redeployed every 50ms so as to check if the datepicker-days class is visible...but it works.