Develop Reference

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)

shiny doesn't work after, containing javascript

I have a problem with this application, containing a javascript file for the user-interface part, which enables more tabs. However, the server part doesn't work when we have included the javascript file. I have a simple reactivity regarding the mtcars dataset here to showcase the problem. when I disable the "includeScript("script.js")", by merely put the # in front of it, the app works, so the problem is connected to this part. So my question would be, How can I fix this issue and also keep the javascript part in the shiny app.
Grateful for all your help.
Edit:
Now I have replaced includeScript("script.js") with tags$head(tags$script(src="./script.js")), and it appears to work, but with an extremely slow reactivity, I have to wait almost 1-2 min before seeing something. Any suggestion, or do you also experience this ?
library(shiny)
library(shinythemes)
library(shinymanager)
library(dplyr)
script.js
$(document).ready(function(){
$('.dropdown').on('click', function(e){
$(this).toggleClass('open');
e.stopPropagation();
e.preventDefault();
});
$('[data-toggle=tab]').on('click', function(e){
let dv = ($(this).attr('data-value'));
//Set active element in tabcontents
$('.tab-pane').removeClass('active');
$('.tab-pane[data-value="' + dv + '"]').addClass('active');
//Set active element in navbar
$('a[data-toggle=tab]').parent().removeClass('active');
$('a[data-value="' + dv + '"]').parent().addClass("active");
//Close the dropdowns
$('.dropdown').removeClass('open');
e.stopPropagation();
e.preventDefault();
});
});
Credentials
credentials <- data.frame(
user = c("Jhon", "Erik"), # mandatory
password = c("1", "1"), # mandatory
start = c("2022-02-14"), # optinal (all others)
expire = c(NA, "2022-12-31"),
admin = c(TRUE, TRUE),
comment = "Model Performance application",
stringsAsFactors = FALSE
)
Ui
ui <- fluidPage(
includeScript("script.js"),
navbarPage("Shiny",
collapsible = TRUE,
theme = shinytheme('yeti'),
tabPanel("Information" ,icon = icon("info"),
tags$h2("Information about the current user"),
verbatimTextOutput("auth_output")
),
tabPanel("Simulation 1",
tags$h2("Simulation"),
tags$hr(),
selectInput("vars", "Variables", names(mtcars), multiple = T),
tableOutput("data")
),
tabPanel("Upload",icon = icon("upload"),
tags$h2("Upload datasets"),
tags$hr(),
),
tabPanel("Simulation 2",
tags$h2("Simulation"),
tags$hr()
),
navbarMenu("Statistical outputs",
tabPanel("One"
),
tabPanel("Two"
),
tabPanel("Three"
),
tabPanel("Four"
),
tabPanel("Report"
),
navbarMenu("More",
tabPanel("Statistical", icon = icon("info")
),
tabPanel("Info",
icon = icon("info-circle")
),
tabPanel("Subpart 4", "Subpart 4"),
tabPanel("Subpart 5", "Subpart 5")
)
)
)
)
Wrap your UI with secure_app
ui <- secure_app(ui)
Server
server <- function(input, output, session) {
# call the server part
# check_credentials returns a function to authenticate users
res_auth <- secure_server(
check_credentials = check_credentials(credentials)
)
output$auth_output <- renderPrint({
reactiveValuesToList(res_auth)
})
output$data <-renderTable({
req(input$vars)
mtcars %>% select(all_of(input$vars))
})
}
shiny::shinyApp(ui, server)

Update:
Most important in addition to 1. and 2. from the first answer. The app works as desired only if split in ui and server part!
It seems that the server part is not working but after clicking on Statistical outputs the table appears!
First answer:
Put your script.js into a www folder. This should be in the same folder where your app is.
Change includeScript("script.js"), in ui part with tags$head(tags$script(src="script.js")),

How to add space on the left and right of a table exported to a PDF with datatable in shiny?

I want to export a table displayed in a shiny app using datatable to a PDF. For this purpose, I am using the export button provided by datatable, see the code below.
However, I want to make a little modification to the table shown in the PDF. I want to add some space to the left of the first column and to the right of the last column.
I couldn't find a datatable option to control this. It seems, I have to use the pdfmake library to specify this via the customize argument. You can see something I tried in the code below, however commented out, as it does not work. I tried a lot of other stuff but nothing worked. Unfortunately, I have almost no experience with JavaScript, that's why I hope someone can help me here.
library(shiny)
library(DT)
words <- c("water", "apple", "house", "family", "basket")
set.seed(42)
data <- data.frame(column1 = sample(words, 10, TRUE),
column2 = sample(words, 10, TRUE),
column3 = sample(words, 10, TRUE))
ui <- fluidPage(
DTOutput("dtable")
)
server <- function(input, output, session) {
output$dtable <- renderDT({
datatable(data,
rownames = FALSE,
extensions = "Buttons",
options = list(
dom = "Bfrtip",
buttons = list(
list(
extend = "pdf",
exportOptions = list(orthogonal = "export"),
filename = "Filename",
title = "Title",
# customize = JS("function(doc) { doc.content.table.margin = [50, 0, 50, 0]; }")
orientation = "landscape")
)
)
)
})
}
shinyApp(ui, server)

Adding dynamic mouseover to all entries in a column in a DataTable with Shiny (R)

I was pretty sure that there is an answer already out there to my question,
but no matter how hard I searched I couldn't find any solution that could work in this case. So if this is considered to be trivial, please don't shoot.
Now here's the problem:
Assuming we are rendering a dataTable with Shiny, I would like to grab the id of every cell (rowID+columnID) when I hover over over the cell and present dynamically output from the underlying datasets.
I know that there are already solutions for mouseovers, such as shinyBS or this example here:
#server.R:
shinyServer(function(input, output) {
dat <- list(iris,cars)
output$tabset <- renderUI({
tabs <- list()
for(i in c(1,2)){
id <- paste("id",i, sep="")
tabs[[i]] <- tabPanel(title=id,DT::dataTableOutput(outputId=id)) #dynamic panels
}
do.call(tabsetPanel,c(tabs, id='Panel'))
})
lapply(1:2,function(i){
id <- paste("id",i, sep="")
output[[id]] <- DT::renderDataTable({
dat[[i]]},
extensions = c('Scroller'),
options=list(deferRender=TRUE, dom='T<"clear">fitrS', scrollY=540, searchHighlight = TRUE,
scrollCollapse=TRUE, autoWidth = TRUE,
columnDefs = list(list(width = '60%', targets = '_all',
render = JS("function(data, type, row, meta) {",
"return type === 'display' && data.length > 5 ?",
"'<span title=\"' + data + '\">' + data.substr(0, 5) + '...</span>' : data;",
"}"
)))),
callback = JS('table.page(3).draw(false);'),
escape=FALSE, rownames=TRUE,class = 'table-condensed', server=TRUE)
})
})
And the ui.R
#ui.R:
library(shiny)
library(DT)
ui <- fluidPage(
uiOutput('tabset')
)
There is a mouseover that trims a cell if its length is 5 or more. What I would like to do now is to see if it the highlighted cell comes from panel with 'id1', is from column Sepal.Length and the mouseover should show data from panel 'id2', that had the same rowId as in Sepal.Length and should show the data from column dist.
Basically I want don't want to present static content or just modify the string that is already in that cell, but rather dynamically present additional content depending on what cell has been hovered over.
Is that possible with Shiny and JavaScript?
Thanks for any input.

Shiny r: clear selected rows from data table by click on plot

Using a ShinyR and data table we can create an interactive plot. When a user select a row in the data table it displayed with specific color and shape in the graph. When we un-select the row, point gain normal conditions.
Example modified from (Shiny apps).
Additionally, we can identify particular points (we are interested in) on the graph (Using nearPoints)
I would like a user to be able un-select the row by clicking on particular point on the graph. Once user clicked the point on the graph it will gain normal appearance.
However, I can’t find function to make it work.
There is a proxy and selectRows function in new DT library (the DT-package)(but for Mac it is unavailable). Example
Another option would be to write and option javascript code in callback, however my knowledge is limited in that area.
Will be thankful for any comments and suggestions.
UI
library(shiny)
library(DT)
fluidPage(
title = 'Select Table Rows',
fluidRow(
column(6, DT::dataTableOutput('x1')),
column(6, plotOutput('x2', height = 500,click = "plot_click"),
verbatimTextOutput("info"))
)
)
Server
shinyServer(function(input, output, session) {
output$x1 = DT::renderDataTable(cars, server = FALSE)
# highlight selected rows in the scatterplot
output$x2 = renderPlot({
s = input$x1_rows_selected
par(mar = c(4, 4, 1, .1))
plot(cars)
if (length(s)) points(cars[s, , drop = FALSE], pch = 19, cex = 2)
})
output$info <- renderPrint({
paste("Selected point row.name - ", row.names(nearPoints(cars, input$plot_click, xvar = "speed", yvar = "dist")), sep="")
})
})

With a new version of DT it works perfect with proxy
proxy = dataTableProxy('x1')
observeEvent(input$plot_click, {
removeRow <- as.numeric(row.names(nearPoints(cars, input$plot_click, xvar = "speed", yvar = "dist")))
selectRows(proxy, input$x1_rows_selected[!input$x1_rows_selected %in% removeRow])
})