We Keep Coding

Late timing of `Date().getTime()`?

I'm trying to get the timing of a user's click on a dynamically-generated image using Shiny and some Javascript. The app below reports the client's time as LATER than the time captured within the server, which is not desired. I'd like to capture the time given by the user's browser when they click on the image (this will prevent noise and delays from the trip from the client to the Shiny server). Any ideas?
The ultimate goal for the app is to calculate a "find time" -- the duration it takes for a user to click on a specific coordinate after the image appears in their browser.
library(shiny)
library(shinyjs)
options(digits.secs = 3) # Modify and save default global time options
click.time.image.js <- "
document.getElementById('img').onclick = function(){
var the_time = new Date().getTime();
console.log(the_time);
// set input$client_time to the_time:
Shiny.setInputValue('client_time', the_time)
}
"
shinyApp(
ui = fluidPage(
useShinyjs(),
sidebarLayout(
sidebarPanel(
p("When clicking on the histogram, I'd like to capture the client-side computer's time"),
actionButton(inputId="new_image", label= "New Image")
),
mainPanel(
imageOutput("img", click = "photo_click"),
textOutput("client_time"),
textOutput("server_time")
)
)
),
server = function(input, output) {
output$img <- renderImage({
input$new_image
outfile <- tempfile(fileext='.png')
png(outfile, width=400, height=400)
hist(rnorm(100))
dev.off()
shinyjs::runjs(click.time.image.js)
list(src = outfile,
alt = "This is alternate text")
},
deleteFile = TRUE)
output$server_time <- renderText({
req(input$photo_click)
server.time <- as.character(strptime(Sys.time(), "%Y-%m-%d %H:%M:%OS")) # Time with milliseconds
paste("SERVER TIME:", server.time)
})
output$client_time <- renderText({
req(input$photo_click)
req(input$client_time)
client.time <- input$client_time # Time with milliseconds
client.time <- as.POSIXct(client.time/1000, origin="1970-01-01")
paste("CLIENTs TIME:", client.time)
})
}
)

Override dismiss button in R Shiny modal dialogue

I am using modal-dialogue in R Shiny to get input from the user. In this form, there is a dismiss button by default which closes the form when it is clicked. I want to add a confirmation popup (sweetAlert) when the dismiss button is clicked.
I am ready to use javascript as well but i need sweetAlert instead of the windows alert. I was not able to successfully generate a windows alert as well.
How do i override the functionality of this in-built "dismiss" button? I want to show a warning when someone clicks on dismiss and let them continue only if they are sure. Otherwise i want to let them stay on the modal-dialogue.
Any help is appreciated.

Here's a way. Code is fairly simple. -
library(shiny)
ui <- fluidPage(
actionButton("show", "Show Modal")
)
server <- shinyServer(function(input, output, session) {
observeEvent(input$show, {
showModal(
modalDialog(
"some messsage", title = "modal", footer = actionButton("confirm", "Close")
)
)
})
observeEvent(input$confirm, {
showModal(
modalDialog(
"are you sure?",
footer = tagList(
actionButton("yes", "Yes"),
modalButton("No")
)
)
)
})
observeEvent(input$yes, {
removeModal()
# do something after user confirmation
})
})
shinyApp(ui, server)

You don't need to write your own JS code, instead you might want to use the shinyWidgets package
Specifically, have a look at the Confirmation dialog:
http://shinyapps.dreamrs.fr/shinyWidgets/
Edit: Here you can find some examples, e.g.
library("shiny")
library("shinyWidgets")
ui <- fluidPage(
tags$h1("Confirm sweet alert"),
actionButton(
inputId = "launch",
label = "Launch confirmation dialog"
),
verbatimTextOutput(outputId = "res"),
uiOutput(outputId = "count")
)
server <- function(input, output, session) {
# Launch sweet alert confirmation
observeEvent(input$launch, {
confirmSweetAlert(
session = session,
inputId = "myconfirmation",
type = "warning",
title = "Want to confirm ?",
danger_mode = TRUE
)
})
# raw output
output$res <- renderPrint(input$myconfirmation)
# count click
true <- reactiveVal(0)
false <- reactiveVal(0)
observeEvent(input$myconfirmation, {
if (isTRUE(input$myconfirmation)) {
x <- true() + 1
true(x)
} else {
x <- false() + 1
false(x)
}
}, ignoreNULL = TRUE)
output$count <- renderUI({
tags$span(
"Confirm:", tags$b(true()),
tags$br(),
"Cancel:", tags$b(false())
)
})
}
shinyApp(ui, server)

R Shiny selectizeInput: set minimum for amount of inputs

I have a selectizeInput with multiple = TRUE in a shiny application and I would like to prevent the user from selecting NULL (i.e., from leaving it blank). My goal is to ensure that at least one item is selected (no matter which one).
I found this question on the opposite problem (i.e., limiting maximum number of selections) and I checked selectize documentation. Unfortunately, there seem to be no minItems option. Is there a way to achieve my desired functionality?
Minimum example:
library(shiny)
shinyApp(
ui = fluidPage(
selectizeInput(
inputId = "testSelect",
label = "Test",
choices = LETTERS[1:4],
selected = LETTERS[1],
multiple = TRUE,
# Problem: how to specify 'minItems' here
options = list(maxItems = 2)
),
verbatimTextOutput("selected")
),
server = function(input, output) {
output$selected <- renderPrint({
input$testSelect
})
}
)

Seems to be an open issue: #https://github.com/selectize/selectize.js/issues/1228.
Concerning your R/Shiny implementation you could use a workaround with renderUI().
You would build the input on the server side and control the selected choices.
Before you build the input on the server side you can check the current value and if it does not fulfill your requirement you can overwrite it:
selected <- input$testSelect
if(is.null(selected)) selected <- choices[1]
Reproducible example:
library(shiny)
choices <- LETTERS[1:4]
shinyApp(
ui = fluidPage(
uiOutput("select"),
verbatimTextOutput("selected")
),
server = function(input, output) {
output$selected <- renderPrint({
input$testSelect
})
output$select <- renderUI({
selected <- input$testSelect
if(is.null(selected)) selected <- choices[1]
selectizeInput(
inputId = "testSelect",
label = "Test",
choices = choices,
selected = selected,
multiple = TRUE,
options = list(maxItems = 2)
)
})
}
)

download rpivotTable output in shiny Dasboard

I'm trying to save data from rpivotTable in my dashboardUI.
I already read
https://github.com/smartinsightsfromdata/rpivotTable/issues/62
and in works with ui.r and server.r
But when I try to use this with dashboard - it's nothing .
dashboard.r
# install.packages("devtools")
#devtools::install_github("smartinsightsfromdata/rpivotTable",ref="master")
options(java.parameters = "-Xmx8000m")
library(shiny)
library(shinyjs)
library(shinydashboard)
library(highcharter)
library(xts)
library(htmlwidgets)
library(rpivotTable)
library(xml2)
library(rvest)
sotrud <- c("1","2")
dashboardUI <- function(id) {
ns <- NS(id)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("log", tabName = "login", icon = icon("user")),
menuItem("test", tabName = "ost", icon = icon("desktop"))
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "login",
tabPanel("log",
useShinyjs(), # Set up shinyjs
br(),
selectInput(inputId=ns("sel_log"), label = h5("log"),
choices= c(unique(as.character(sotrud)))
, selected = NULL),
tags$form( passwordInput(inputId=ns("pass"), label =
h3("int psw"), value = "000")),
fluidRow(
br(),
column(8,actionButton(ns("psw"), "in")
)
)
)
),
tabItem(tabName = "ost",
tabPanel("test",
fluidRow(
column(3,
h4(" "),
conditionalPanel(
condition = paste0("input['", ns("psw"), "'] > '0' "),
actionButton(ns("save"), "download") )
)
,br()
,br()
)
)
,DT::dataTableOutput(ns('aSummaryTable'))
,rpivotTableOutput(ns('RESULTS'))
,column(6,
tableOutput(ns('myData')))
)
))
# Put them together into a dashboardPage
dashboardPage(
dashboardHeader(title = "1"),
sidebar,
body
)
}
dashboard <- function(input, output, session) {
observe({ ## will 'observe' the button press
if(input$save){
print("here") ## for debugging
print(class(input$myData))
}
})
# Make some sample data
qbdata <- reactive({
expand.grid(LETTERS,1:3)
})
# # Clean the html and store as reactive
# summarydf <- eventReactive(input$myData,{
# print("here")
#
# input$myData %>%
# read_html %>%
# html_table(fill = TRUE) %>%
# # Turns out there are two tables in an rpivotTable, we want the
second
# .[[2]]
#
# })
# # show df as DT::datatable
# output$aSummaryTable <- DT::renderDataTable({
# datatable(summarydf(), rownames = FALSE)
# })
# Whenever the config is refreshed, call back with the content of the table
output$RESULTS <- renderRpivotTable({
rpivotTable(
qbdata(),
onRefresh =
htmlwidgets::JS("function(config) {Shiny.onInputChange('myData', document.getElementById('RESULTS').innerHTML);}")
)
})
}
app.r
source("dashboard.R")
ui <-
dashboardUI("dash")
server <- function(input, output, session) {
df2 <- callModule(dashboard, "dash")
}
shinyApp(ui, server)
I fell problem with this:
htmlwidgets::JS("function(config) {Shiny.onInputChange('myData', document.getElementById('RESULTS').innerHTML);}")
I tried to change 'myData' to ns('myData') , but nothing
print(class(input$myData)) - always shows [1] "NULL" in console, that's mean I didn't pass data to 'myData'
Maybe someone know how to resolve this?
p.s. button "download" appears after pushing "in"

You have a lot of extra, unnecessary stuff in your code (not ideal for a minimal reproducible example). However, I've found that as long as you always use ns() when appropriate, everything works as expected, even with modules. The largest deviation from the non-modular code I've made is using a downloadHandler() because that answer doesn't follow best practices for that.
So extending the original solution (from here) to modules gives you something like this (notice that in the jsCallback function, you need to use ns() for both myData and the pivot, as they both belong to that module):
library(shiny)
library(shinyjs)
library(shinydashboard)
library(highcharter)
library(xts)
library(htmlwidgets)
library(rpivotTable)
library(xml2)
library(rvest)
options(shiny.launch.browser=F, shiny.minified=F, shiny.port = 6245)
sotrud <- c("1","2")
dashboardUI <- function(id) {
ns <- NS(id)
dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
tableOutput(ns('tbl')),
downloadButton(ns('save')),
rpivotTableOutput(ns('pivot'))
)
)
}
dashboard <- function(input, output, session) {
output$pivot <- renderRpivotTable({
jsCallback <- paste0("function(config) {",
"Shiny.onInputChange('",
session$ns("myData"), "',",
"document.getElementById('", session$ns("pivot"), "').innerHTML);}")
rpivotTable(
expand.grid(LETTERS, 1:3),
onRefresh = htmlwidgets::JS(jsCallback)
)
})
summarydf <- eventReactive(input$myData, {
input$myData %>%
read_html %>%
html_table(fill = TRUE) %>%
.[[2]]
}, ignoreInit = TRUE)
output$tbl <- renderTable({ summarydf() })
output$save <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".csv", sep="")
},
content = function(file) {
req(summarydf())
write.csv(summarydf(), file)
}
)
}
ui <- dashboardUI("dash")
server <- function(input, output, session) { callModule(dashboard, "dash") }
shinyApp(ui, server)

Need to replace default "No data available in table" message in Shiny R renderDataTable

I don't know much of JavaScript, and I'm having a problem to override the default message in the Shiny R App, when I'm outputting table.
When table is empty, it's giving message "No data available in table" in the first row. I wanted to put some app-specific instructions instead.
I found that there's something like:
options = list(searching = FALSE,paging = FALSE) but don't know what option it would be to switch that text.
Also, I found JS code to reset the message (https://datatables.net/reference/option/language.zeroRecords),
but I wasn't able to attach this correctly to renderDataTable in Shiny.
I just don't know the correct syntax of incorporating JS into shiny, I tried
options = list(searching = FALSE,paging = FALSE, callback=DT:JS(
'
{
"language": {
"zeroRecords": "No records to display- custom text"
}
'
but it didn't work. I would appreciate some guidance on this.
Here's the whole code. Right now my attempts to replace the mesage are ignored:
library(ggplot2)
library(DT)
ui <- fluidPage(
titlePanel("Basic DataTable"),
# Create a new Row in the UI for selectInputs
fluidRow(
column(12,
selectInput("man",
"Manufacturer:",
c("All",
unique(as.character(mpg$manufacturer))))
)
),
# Create a new row for the table.
fluidRow(
DT::dataTableOutput("table")
)
)
server <-function(input, output) {
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data <- mpg
if (input$man != "All") {
data <- data[data$manufacturer == "dddddd",]
}
data
},options = list(searching = FALSE,paging = FALSE,callback=DT::JS(
'
{
"language": {
"zeroRecords": "No records to display- custom text"
}}
') )
))
}
shinyApp(ui = ui, server = server)

Do not use the callback, you can directly set the language -> zeroRecords attribute using the options parameter:
server <- function(input, output) {
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data <- mpg
if (input$man != "All") {
data <- data[data$manufacturer == "dddddd",]
}
data
}, options =
list(searching = FALSE,paging = FALSE,
language = list(
zeroRecords = "No records to display - custom text")
)))
}
This works for me.