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)
Related
I am trying to build a Shiny App and get the onClick function to output the cell row/column the user clicked on.
How can I fix the code to display the cell row/column?
Shiny App
library(reactable)
library(shiny)
library(htmlwidgets)
iris = iris
ui <- fluidPage(
reactable::reactableOutput("irisTABLE"),
textOutput("'cellDATA")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$irisTABLE = renderReactable({
reactable(iris,
onClick = JS("
function(rowInfo, colInfo) {
Shiny.setInputValue('cell_data', colInfo.id + '-' + rowInfo.row.CapRate, { priority: 'event' })
}
")
)
})
output$cellDATA = renderText({
paste0("The cell selected is: ", input$cell_data)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Change theoutput$cellDATA to
if (!is.null(input$cell_data)) { row_col <- strsplit(input$cell_data, "-") paste0("The cell selected is in row ", row_col[[1]][2], " and column ", row_col[[1]][1]) }
library(reactable)
library(shiny)
iris = iris
ui <- fluidPage(
reactable::reactableOutput("irisTABLE"),
textOutput("cellDATA")
)
server <- function(input, output) {
output$irisTABLE = renderReactable({
reactable(iris,
onClick = JS("
function(rowInfo, colInfo, e) {
Shiny.setInputValue('cell_data', colInfo.id + '-' + rowInfo.index)
}
")
)
})
output$cellDATA = renderText({
if (!is.null(input$cell_data)) {
row_col <- strsplit(input$cell_data, "-")
paste0("The cell selected is in row ", row_col[[1]][2], " and column ", row_col[[1]][1])
}
})
}
shinyApp(ui = ui, server = server)
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.
I am trying to start a reactivePoll only after selecting a parent directory using shinyFiles. I want the function to check based on the selection. I keep getting checkFunc errors about argument is of length 0. I looked this up and typically happens when the vector is logical(0). I got this example from reactivePoll example. Please provide some help, thanks.
Warning: Error in if: argument is of length zero
reactivePoll
observeEventHandler
shiny::runApp
library(shiny)
library(shinyFiles)
home_dir <- "/top/directory"
server <- function(input, output, session) {
pdf_file <- 'full_report.pdf'
status <- reactiveValues(text = 'Idle')
shinyDirChoose(
input,
"dir",
roots = c(home = home_dir)
)
dir <- reactive(
basename(parseDirPath(c(home=home_dir), input$dir))
)
output$dirpath_dply <- renderText({
dir()
})
observeEvent(input$dir, {
session$sendCustomMessage('disableButton', 'dir')
status$text <- 'Running...'
# mimic httr post
Sys.sleep(5)
message(dir())
req(dir()) # seems to prevent error but just hangs?
omiqPDF_file <- reactivePoll(2000, session,
checkFunc = function() {
if (file.exists(file.path(home_dir, dir(), pdf_file)))
file.info(file.path(home_dir, dir(), pdf_file))$mtime
else
''
},
valueFunc = function() {
if ( length(list.files(path = paste0(home_dir, '/', input$dir),
pattern = pdf_file,
recursive=TRUE) ) > 0 )
file.info(file.path(home_dir, dir(), pdf_file))$size > 5000
else
''
}
)
observe({
if (omiqPDF_file() == TRUE) {
session$sendCustomMessage('enableButton', 'dir')
status$text <- paste0('Completed for ', dir())
}
})
})
output$uiStatus <- renderUI(
h4(paste0('STATUS: ', status$text), style="color:red;")
)
}
ui <- fluidPage(
singleton(tags$head(HTML('
<script type="text/javascript">
$(document).ready(function() {
// Enable button
Shiny.addCustomMessageHandler("enableButton", function(id) {
$("#" + id).removeAttr("disabled");
});
// Disable button
Shiny.addCustomMessageHandler("disableButton", function(id) {
$("#" + id).attr("disabled", "true");
});
})
</script>
')
)),
navbarPage(
"main",
tabPanel("navbar 1",
sidebarPanel(
tags$h2("HEADER"),
shinyDirButton("dir", "Input Directory", ""),
br()
),
mainPanel(
h1("HEADER MAIN"),
h4("DIRPATH OUTPUT"),
verbatimTextOutput("dirpath_dply"),
uiOutput('uiStatus')
)
),
tabPanel("navbar 2", "blank"),
tabPanel("navbar 3", "blank")
)
)
shinyApp(ui = ui, server = server)
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.
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;
}
});')