R Shiny: slickR select event - r

The slickR package has a focusOnSelect option - when clicking on an image in the carousel, it is highlighted. How can I access the selection event to use in R Shiny to trigger other actions? Specifically, I want to click on an image and have it update a textbox with the image name.
To use the example below, put 3 images (image1.jpg, image2.jpg, image3.jpg) in the same directory as the app.
library(shiny)
ui <- shiny::basicPage(
slickROutput("my_slick",width='100%',height='200px')
)
server <- function(input, output) {
output$my_slick <- renderSlickR({
my_images <- c("image1.jpg", "image2.jpg", "image3.jpg")
slickR(
my_images,
slideId = 'slick_images',
width='90%'
)
})
}
shinyApp(ui, server)

Is it what you want ?
library(shiny)
library(slickR)
my_images <- c("image1.png", "image2.png", "image3.png")
ui <- shiny::basicPage(
slickROutput("my_slick",width='100%',height='200px'),
tags$p(id="textbox"),
tags$script('var my_images = ["image1.png","image2.png","image3.png"];
$("#my_slick").on("click", function(e){
var slideClicked = $(this).find(".slick-active").attr("data-slick-index");
document.getElementById("textbox").innerHTML = "Selected image: " + my_images[slideClicked];
});')
)
server <- function(input, output) {
output$my_slick <- renderSlickR({
slickR(
my_images,
slideId = 'slick_images',
width='90%'
)
})
}
shinyApp(ui, server)
If you want to get the name of the selected image in Shiny, add a line in the script:
tags$script('var my_images = ["image1.png","image2.png","image3.png"];
$("#my_slick").on("click", function(e){
var slideClicked = $(this).find(".slick-active").attr("data-slick-index");
Shiny.setInputValue("selectedImage", my_images[slideClicked]);
document.getElementById("textbox").innerHTML = "Selected image: " + my_images[slideClicked];
});')
Then the names of the selected image is in input$selectedImage.
EDIT
Here is the script for the improvements asked by the OP in a comment:
tags$script('var my_images = ["image1.png","image2.png","image3.png"];
var binary = true;
$("#my_slick").on("click", function(e){
if(e.target.localName == "img"){
if(binary){
var slideClicked = $(this).find(".slick-active").attr("data-slick-index");
Shiny.setInputValue("selectedImage", my_images[slideClicked]);
document.getElementById("textbox").innerHTML = "Selected image: " + my_images[slideClicked];
}else{
document.getElementById("textbox").innerHTML = "";
}
binary = false;
}else{
document.getElementById("textbox").innerHTML = "";
binary = true;
}
});')

Related

shinyApp - How to copy a value from selectInput and paste to a reactive table

I want to copy values from a selectInput and paste it to a reactive table. Below is an example.
library(shiny)
library(tidyverse)
library(DT)
df<-data.frame("Name" = c("apple","cherry"),
"Value" = c(5,6))
ui <- fluidPage(
uiOutput("fruit"),
fluidRow(DT::DTOutput("table1")))
server <- function(input, output, session) {
df1 <- reactiveValues(data = {df})
output$table1 = DT::renderDT({
DT::datatable(df1$data, editable = T)
})
output$fruit <- renderUI({
selectInput(
inputId = "fruit_name",
label = "Name",
multiple = TRUE,
choices = c("apple","cherry","pear", "peach","banana"),
selected = "apple"
)
})
}
shinyApp(server = server, ui = ui)
I hope to be able to choose a fruit name from selectInput, copy it, and paste it to the table under column "Name". It seems shinyApp doesn't support regular copy and paste. Anyway to do it? Thanks!
It's impossible to select the text inside an item. With the code below, you can select an item and use Ctrl-C and Ctrl-V to copy and paste it.
js <- '
document.addEventListener("copy", (event) => {
const anchorNode = document.getSelection().anchorNode;
if (anchorNode instanceof HTMLElement &&
anchorNode.classList.contains("selectize-input")) {
const items = Array.from(anchorNode.getElementsByClassName("item active"));
const string = items.map(i => i.innerText).join(", ");
event.clipboardData.setData("text/plain", string);
event.preventDefault();
}
})
'
ui <- fluidPage(
tags$head(tags$script(HTML(js))),
uiOutput("fruit"),
fluidRow(DTOutput("table1"))
)

withMathJax inside modalDialog table

I am trying to include LateX formulas inside a table and I am using the MathJack library to do so. Everthing is working smoothly outside a modalDialog, but when the table is produced within the modalDialog, it does not show as expected. I guess it has do to with what is written in the help page "It only needs to be called once in an app unless the content is rendered after the page is loaded, e.g. via renderUI(), in which case we have to call it explicitly every time we write math expressions to the output.". But I can't figure out how to solve the issue.
Here is a repex :
library(shiny)
ui <- shinyUI(
fluidPage(
withMathJax(),
actionButton("open", "Open")))
server <- function(input, output, session){
output$mytable <- renderTable({
df <- data.frame(A = c(HTML("$$\\alpha+\\beta$$"), "$$\\alpha+\\gamma$$", "$$\\alpha+\\lambda$$"),B = c(111111, 3333333, 3123.233))
df
}, sanitize.text.function = function(x) x)
observeEvent(input$open, {
showModal(modalDialog(
withMathJax(),
h2("$$\\mbox{My Math example }\\sqrt{2}$$"),
tableOutput('mytable')))
})
}
shinyApp(ui = ui, server = server)
Oddly, that works like this:
observeEvent(input$open, {
showModal(withMathJax(modalDialog(
h2("$$\\mbox{My Math example }\\sqrt{2}$$"),
withMathJax(tableOutput('mytable')))))
})
EDIT
Since there are some problems with this solution, here is a solution using KaTeX instead of MathJax:
library(shiny)
js <- "
$(document).on('shiny:value', function(event) {
if(event.name === 'mytable'){
// h2 element
var $h2 = $('#title');
var title = $h2.html();
var matches_title = title.match(/(%%+[^%]+%%)/g);
var i, code;
for(i=0; i<matches_title.length; i++){
code = matches_title[i].slice(2,-2);
title = title.replace(matches_title[i], katex.renderToString(code));
}
$h2.html(title);
$h2.css('visibility', 'visible');
// table:
var matches = event.value.match(/(%%+[^%]+%%)/g);
var newvalue = event.value;
for(i=0; i<matches.length; i++){
code = matches[i].slice(2,-2);
newvalue = newvalue.replace(matches[i], katex.renderToString(code));
}
event.value = newvalue;
}
})
"
css <- "#mytable td:nth-child(3) {display: none;}"
ui <- fluidPage(
tags$head(
tags$link(rel="stylesheet", href="https://cdn.jsdelivr.net/npm/katex#0.15.2/dist/katex.min.css", integrity="sha384-MlJdn/WNKDGXveldHDdyRP1R4CTHr3FeuDNfhsLPYrq2t0UBkUdK2jyTnXPEK1NQ", crossorigin="anonymous"),
tags$script(defer="", src="https://cdn.jsdelivr.net/npm/katex#0.15.2/dist/katex.min.js", integrity="sha384-VQ8d8WVFw0yHhCk5E8I86oOhv48xLpnDZx5T9GogA/Y84DcCKWXDmSDfn13bzFZY", crossorigin="anonymous"),
tags$script(HTML(js)),
tags$style(HTML(css))
),
titlePanel("Hello Shiny!"),
br(),
actionButton("open", "Open")
)
server <- function(input, output, session){
output$mytable <- renderTable({
data.frame(
A = c("%%\\alpha+\\beta%%", "%%\\alpha+\\gamma%%", "%%\\alpha+\\lambda%%"),
B = c(111111, 3333333, 3123.233),
` ` = rep(input$open, 3),
check.names = FALSE
)
}, sanitize.text.function = function(x) x)
observeEvent(input$open, {
showModal(modalDialog(
h2(
id = "title",
style = "visibility: hidden;",
"%%\\boxed{Math}\\sqrt{2}%%"
),
tableOutput("mytable")
))
})
}
shinyApp(ui, server)
Note that I include a reactive column in the dataframe:
` ` = rep(input$open, 3)
That's because the KaTeX rendering works only one time if I don't do that. Then I hide this column with some CSS.

R shiny - Change text fileInput after upload

I want to change the placeholder in fileInput after a file has been uploaded, i.e. customize the file name written.
I found how to customize the progress bar label, so I'm guessing the code should be quite similar. This is what I tried so far:
library(shiny)
library(shinyjs)
jscode_upload_msg <- " Shiny.addCustomMessageHandler('upload_msg', function(msg) {
var target = $('#fileUpload_progress').children()[0];
target.innerHTML = msg;
}); "
jscode_upload_txt <- " Shiny.addCustomMessageHandler('upload_txt', function(txt) {
var target = $('#fileUpload_header').children()[1].children()[0];
target.innerHTML = txt;
}); "
ui <- fluidPage(
useShinyjs(),
tags$script(jscode_upload_msg),
tags$script(jscode_upload_txt),
fileInput("fileUpload", "File to upload")
)
server <- function(input, output, session ) {
observe({
req(input$fileUpload)
session$sendCustomMessage("upload_msg", "YOUR TEXT")
session$sendCustomMessage("upload_txt", "SOME OTHER TEXT")
})
}
shinyApp(ui = ui, server = server)
From Shiny customise fileInput, it seems that the input field is in the second position. However, I am not sure how to write the jscode. Any advice?
library(shiny)
jscode_upload_msg <- " Shiny.addCustomMessageHandler('upload_msg', function(msg) {
var target = $('#fileUpload_progress').children()[0];
target.innerHTML = msg;
}); "
jscode_upload_txt <- " Shiny.addCustomMessageHandler('upload_txt', function(txt) {
var target = $('#fileUpload').parent().parent().parent().find('input[type=text]');
target.val(txt);
}); "
ui <- fluidPage(
tags$script(HTML(jscode_upload_msg)),
tags$script(HTML(jscode_upload_txt)),
fileInput("fileUpload", "File to upload")
)
server <- function(input, output, session ) {
observeEvent(input$fileUpload, {
session$sendCustomMessage("upload_msg", "YOUR TEXT")
session$sendCustomMessage("upload_txt", "SOME OTHER TEXT")
})
}
shinyApp(ui = ui, server = server)

Get the current image name of a slickR slideshow in shiny

Below is a shiny app which displays a slideshow of images with the slickR package. How to get the name of the current image?
library(shiny)
library(slickR)
ui <- fluidPage(
tags$div(
slickROutput("slickr", width="500px"),
style = "margin-left:100px;"
)
)
server <- function(input, output) {
imgs <- list.files("~/", pattern=".png", full.names = TRUE)
output[["slickr"]] <- renderSlickR({
slickR(imgs)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Here is a solution with a MutationObserver:
library(shiny)
library(slickR)
js <- "
$(document).ready(function(){
var ss = document.getElementById('slickr');
// create an observer instance
var observer = new MutationObserver(function(mutations) {
var index = $(ss).find('.slick-current').data('slick-index');
Shiny.setInputValue('imageIndex', parseInt(index)+1);
});
// configuration of the observer
var config = {subtree: true, attributes: true};
// observe
observer.observe(ss, config);
})
"
ui <- fluidPage(
tags$head(
tags$script(HTML(js))
),
textOutput("imgName"),
tags$hr(),
tags$div(
slickROutput("slickr", width="500px"),
style = "margin-left:100px;"
)
)
server <- function(input, output) {
imgs <- list.files("~/", pattern=".png", full.names = TRUE)
output[["slickr"]] <- renderSlickR({
slickR(imgs)
})
output[["imgName"]] <- renderText({
paste0("CURRENT IMAGE: ", basename(imgs[input[["imageIndex"]]]))
})
}
# Run the application
shinyApp(ui = ui, server = server)
Another solution, simpler: replace js with
js <- "
$(document).ready(function(){
$('#slickr').on('setPosition', function(event, slick) {
var index = slick.currentSlide + 1;
Shiny.setInputValue('imageIndex', index);
});
})"
Maybe something like this workaround?
I am using the index of the image and get the basename of the imagelist.
library(shiny)
library(slickR)
jscode <- HTML("
$(document).on('shiny:connected', function(event) {
var imagindex = 0;
Shiny.onInputChange('slickin', imagindex);
$(document).on('click', '.slick-arrow', function(event) {
var imagindex = $('.slick-active')[0].attributes[1].value;
Shiny.onInputChange('slickin', imagindex);
});
$(document).on('click', '.slick-dots', function(event) {
var imagindex = $('.slick-active')[0].attributes[1].value;
Shiny.onInputChange('slickin', imagindex);
});
});
")
ui <- fluidPage(
tags$head(tags$script(jscode)),
tags$div(
slickROutput("slickr", width="500px"),
style = "margin-left:100px;"
)
)
server <- function(input, output) {
imgs <- list.files(getwd(), pattern=".png", full.names = TRUE);
output[["slickr"]] <- renderSlickR({
slickR(imgs)
})
observe( {
req(input$slickin)
print(basename(imgs[as.numeric(input$slickin) + 1]))
})
}
shinyApp(ui = ui, server = server)
The slickR shiny vignette describes the "official" way without using custom JS:
Observe the active slick
The htmlwidget is observed by shiny and information can be retrieved.
Using the output name you set for the renderSlick object in this example
it is output$slick_output
Using this you can interact server-side "on click" of the active carousel
by accessing elements in input$slick_output_current$
.clicked : The index of the clicked element
.relative_clicked: The relative position of the clicked element
.center : The index of the center element
.total : The total number of elements in the carousel
.active : The ID of the active carousel
library(shiny)
library(slickR)
# create some local images
if(!dir.exists("myimages")){
dir.create("myimages")
}
imgs <- paste0("myimages/myplot", seq_len(3), ".png")
for (myPlot in myPlots) {
png(file = myPlot, bg = "transparent")
plot(runif(10))
dev.off()
}
ui <- fluidPage(
tags$head(
tags$script(HTML(js))
),
textOutput("imgName"),
tags$hr(),
tags$div(
slickROutput("slickr", width="500px"),
style = "margin-left:100px;"
)
)
server <- function(input, output) {
output[["slickr"]] <- renderSlickR({
slickR(imgs)
})
output[["imgName"]] <- renderText({
paste0("CURRENT IMAGE: ", basename(imgs[input$slickr_current$.center]))
})
}
# Run the application
shinyApp(ui = ui, server = server)
Here's a solution from one of the slickR vignettes:
slickR(obj = nba_player_logo$uri[1:2], height = 100, width = "95%") %synch%
( slickR(nba_player_logo$name[1:2], slideType = 'p') + settings(arrows = FALSE) )
Worked great for me.

Determine if DT datatable is clicked in shiny app

Here is a working example of my best attempt to get table click event:
library(shiny)
library(DT)
runApp(shinyApp(
ui = fluidPage(DT::dataTableOutput('table')),
server = function(input, output, session) {
output$table <- DT::renderDataTable({
dt <- data.frame(a = 1)
datatable(dt, rownames = FALSE, selection = 'none')
})
observeEvent(input$table_cell_clicked, {
print(Sys.time())
})}
))
The problem is that observeEvent reacts only if user clicks on the cell which differs from previously clicked. Is there a way to get event on any table click?
I think it s may be helpful
Try add callback with Shiny.onInputChange
and add smth which changed all time ( rnd)
smt like
JS("table.on('click.dt', 'td', function() {
var row_=table.cell(this).index().row;
var col=table.cell(this).index().column;
var rnd= Math.random();
var data = [row_, col, rnd];
Shiny.onInputChange('rows',data );
});")
and then use it like :
library(shiny)
library(DT)
runApp(shinyApp(
ui = fluidPage(DT::dataTableOutput('table')),
server = function(input, output, session) {
output$table <- DT::renderDataTable({
datatable(data.frame(a = c(1,2),b=c(2,3)), rownames = FALSE, selection = 'none', callback = JS("table.on('click.dt', 'td', function() {
var row_=table.cell(this).index().row;
var col=table.cell(this).index().column;
var rnd= Math.random();
var data = [row_, col, rnd];
Shiny.onInputChange('rows',data );
});")
)}
)
observeEvent(input$rows, {
print(input$rows)
print(Sys.time())
})}
))
Then parse all row and col from input$rows
PS. in datatables index start from 0 .

Resources