We Keep Coding

How to Observe a JavaScript Button in a Shiny App

I am looking for help please to observe when a button in the navbar of a Shiny App with navbarPage is clicked.
I have included a button right in the Shiny navbar with some javascript. I have provided an id to the button tag (‘id = btn_show’) and have introduced an observeevent to listen for ‘input$btn_show’. The button isn’t being observed though… what is required please? Thanks
library(shiny)
library(shinyjs)
ui <- navbarPage(
title = 'Button Up',
tabPanel('Tab 1'),
tabPanel('Tab 1')
, tags$script(HTML(
"var header = $('.navbar> .container-fluid');
header.append('<div style=\"float:right; style=\"valign:middle;\"><button id = \"btn_show\">Show Controls</button></div>');
console.log(header)"))
)
server <- function(input, output, session) {
observeEvent(input$btn_show,{
print('The button was observed')
})
}
shinyApp(ui, server)

Add the onclick attribute to your button:
<button id=\"btn_show\" onclick=\"Shiny.setInputValue(\\\"btn_show\\\", true, {priority: \\\"event\\\"})\">Show Controls</button>
I'm not sure the triple backslashes will work. If not, define a function:
function f(){
Shiny.setInputValue(\"btn_show\", true, {priority: \"event\"})
}
Then onclick = \"f()\".
EDIT
Works like this:
tags$script(HTML(
"var header = $('.navbar> .container-fluid');
var f = function(){Shiny.setInputValue(\"btn_show\", true, {priority: \"event\"})};
header.append('<div style=\"float:right; valign:middle;\"><button id=\"btn_show\" onclick=\"f()\">Show Controls</button></div>');
console.log(header)"))

How to retain scroll position after change of input in Shiny

In Shiny I use a horizontal radioGroupButtons input with huge number of items. If you click on one of the items, the color of the label of the button changes. This works actually fine.
However, if I click on one of the last items so that I have scroll far to the right, the scroll position resets.
So after each click I have to move to the right again if I want to continue with the next item.
Is there a solution so that the scroll position is retained after each click?
This is the code:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(uiOutput("selItem"))
server <- function(input, output, session)
{
global <- reactiveValues(itemNames=NULL, itemValues=NULL)
observe(
{
options <- c("word01", "word02", "word03", "word04", "word05", "word06", "word07", "word08", "word09", "word10", "word11", "word12", "word13", "word14", "word15", "word16", "word17", "word18", "word19", "word20", "word21", "word22", "word23", "word24", "word25", "word26", "word27", "word28", "word29", "word30", "word31", "word32", "word33", "word34", "word35", "word36","word37", "word38", "word38", "word39", "word40", "word41", "word42", "word43", "word44", "word45", "word46", "word47")
global$itemNames = options
global$itemValues = options
})
output$selItem <- renderUI(
{
fluidRow(
style = "overflow-x: scroll;",
radioGroupButtons(inputId = "replyItem", label = NULL, choiceNames = global$itemNames, choiceValues = global$itemValues, selected = character(0), individual = TRUE, width = "10000px")
)
})
observeEvent(input$replyItem,
{
index <- which(global$itemValues==input$replyItem)
global$itemNames[index] <- HTML(paste0("<span style='color: #0000ff'>", global$itemValues[index], "</span>"))
})
}
shinyApp(ui = ui, server = server)

How to adjust width of one column for shiny DataTables created with the JavaScript?

My Shiny App has a paging system, that allows to go back and forth. Below is a miniversion of my entire app. I would like to resize the first column of my datatable that includes checkboxes and make it at least half of the size as it is at this point, to allow for more space for the actual text in the second column.
How do you correctly adjust the first column?
I tried it within the renderdatatable command with:
columnDefs = list(list(targets= 0, width= '30px'). Did not work.
I also added
autoWidth= TRUE within options=list() as suggested here and here, however, that makes the entire table smaller. Below you can see how I included these within the code.
output$table_p2 <- DT::renderDataTable(
checkboxtable2,
server = FALSE, escape = FALSE, selection = 'none',
rownames = FALSE,
options = list(
dom = 't', paging = FALSE, ordering = FALSE,autoWidth = TRUE,
columnDefs = list(list(targets= 0, width= '30%')),
preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } '))
)
I also tried to use the new syntax aoColumnDefs() as suggested here. Which I also could not make to work. How can I explicitly decrease the width of the first column?
ShinyApp
## miniversion of survey
if(!require(shiny))install.packages("shiny");require(shiny)
if(!require(shinyjs)) install.packages("shinyjs"); require(shiny)
if(!require(htmlwidgets)) install.packages("htmlwidgets"); require(htmlwidgets)
if(!require(shinyWidgets)) install.packages("shinyWidgets"); require(shinyWidgets)
if(!require(DT)) install.packages("DT"); require(DT)
answer_options = c("riding", "climbing", "travelling", "binge watching series", "swimming", "reading")
# https://stackoverflow.com/questions/37875078/shiny-checkbox-in-table-in-shiny/37875435#37875435
shinyInput <- function(FUN, ids, ...) {
inputs <- NULL
inputs <- sapply(ids, function(x) {
inputs[x] <- as.character(FUN(inputId = x, label = NULL, ...))
})
inputs
}
#
shinyApp(
ui = fluidPage( ####
useShinyjs(),# For Shinyjs functions
tags$script("
Shiny.addCustomMessageHandler('resetValue', function(variableName) {
Shiny.onInputChange(variableName, null);
});
"),
tags$style('{background-color: #256986;}'),
div(class="content",
# progressbar showing the progress of the survey, currently moves ahead per page in steps of
# 12.5 (excluding intro and thank you page)
progressBar(id= "pbar", value= 0, size= "xs"),
# main utput/ modified userinterface for each page
uiOutput("MainAction")
)
),
server =function(input, output, session) { ####
output$MainAction <- renderUI({
PageLayouts()
})
CurrentPage <- reactiveValues(page= "page1",
selected= 0)
PageLayouts<- reactive({
if(CurrentPage$page == "page1"){
return(
list(
textInput(inputId = "username", label= "Please enter your username"),
# button displayed to continue
div(class= "next button",actionButton(inputId = "p1_next", #input ID refers to following page
label= "Continue"))
))
}
if(CurrentPage$page == "page2"){
checkboxtable2 <- data.frame(
"answer options" = shinyInput(checkboxInput, answer_options),
"What are your hobbies?" = answer_options,
check.names = FALSE
)
output$table_p2 <- DT::renderDataTable(
checkboxtable2,
server = FALSE, escape = FALSE, selection = 'none',
rownames = FALSE,
options = list(
dom = 't', paging = FALSE, ordering = FALSE,
columnDefs = list(list(targets= 0, width= '30px')),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '))
)
return(
list(
# create datatable with checkboxes
p("What are your hobbies?"),
# create datatable with checkboxes
# surpresses header without removing checkboxes
tags$head(tags$style(type = "text/css", "#table_p2 th {display:none;}")),
DT::dataTableOutput('table_p2'),
updateProgressBar(session= session, id= "pbar", value = 12.5),
tags$style(".progress-bar {background-color: #25c484;}")
))
}
})
observeEvent(input$p1_next, {CurrentPage$page <- "page2"})
})
Comment in case you are wondering about the construction of the datatable: The procedure I follow to create these tables is to create dataframes first out of two vectors (one of which includes the checkboxes), transform these into DataTables with renderDataTable, followed by returning the table without the header by overwriting its CSS in a list. I had to follow this procedure, as all other methods to return a checkbox table without a header row, resulted in a data table without checkboxes. Therefore, the code had to be split as I could not create vectors with checkboxes in a list.

DataTables are not very nice, when it comes to column widths. It sais here that widths will never be taken literally from the given definition, but always adapted to the table size and what not. Thats why your efforts were in vain.
But you can still shape things to your need. At first, using checkboxInput creates a container around the checkbox that has a default width of 300 pixels, which are the main reason for the column to be so big. You could in a first step unset this width to see what "natural" size the column would have.
If you want to reduce the size even more, a css rule for the column's width is working fine. For that and the above part, we equip the first column cells with a specific class name.
Weave
columnDefs = list(list(targets = 0, className = "small" ))
into your DataTable definition and then add
td.small .shiny-input-container{width:auto;}
to your css to unset the predefined width in this column.
Further minifications can be achieved by the css rule
td.small{width:30px;}

Shiny - dashboardPage - how can I add a button to box header

Using dashboardPage I made a dashboard made out of boxes.
I would like to be able to click somewhere on the header of a box to trigger some action. The only case I know where the header has a button is the case of expandable boxes. Would it be possible to generalize that so that, upon a click somewhere in the header of a box, some action is triggered?
My design goal is to have the info in the box update when the user clicks on this button, i.e., to have the content of the box change.
Thanks!
body <- dashboardBody(
fluidRow(
box(
title = "Title 1", width = 4, solidHeader = TRUE, status = "primary",
"Box content"
),
box(
title = "Title 1", width = 4, solidHeader = TRUE, status = "warning",
"Box content"
)
)
)
# We'll save it in a variable `ui` so that we can preview it in the console
ui <- dashboardPage(
dashboardHeader(title = "Row layout"),
dashboardSidebar(),
body
)
# Preview the UI in the console
shinyApp(ui = ui, server = function(input, output) { })

If you want a button in the right corner of the box header you could modify the original box function or you could use some JavaScript to add the button after the creation of the box.
An even simpler solution is to create a box title with an actionLink or with an actionButton. Bellow is a example for both cases. The first box has an actionLink as title, when the user clicks on it, the content of the box is updated. On the second box the title is created with plain text and with a small actionButton that will also update the box content. For the second box you could add some custom style to create a header of the same size of a normal box.
library(shiny)
library(shinydashboard)
body <- dashboardBody(
fluidRow(
box(
title = actionLink("titleId", "Update", icon = icon("refresh")),
width = 4, solidHeader = TRUE, status = "primary",
uiOutput("boxContentUI")
),
box(
title = p("Title 1",
actionButton("titleBtId", "", icon = icon("refresh"),
class = "btn-xs", title = "Update")
),
width = 4, solidHeader = TRUE, status = "warning",
uiOutput("boxContentUI2")
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Row layout"),
dashboardSidebar(),
body
)
server = function(input, output, session) {
output$boxContentUI <- renderUI({
input$titleId
pre(paste(sample(letters,10), collapse = ", "))
})
output$boxContentUI2 <- renderUI({
input$titleBtId
pre(paste(sample(LETTERS,10), collapse = ", "))
})
}
shinyApp(ui = ui, server = server)

R: Popovers don't trigger in shiny reactive UI

I'm currently developing a shiny gadget and have ran into the small issue that Bootstrap popovers don't trigger when generated by renderUI(). Can anyone shed light on why this might be?
I'm not very familiar with js so there could be an obvious answer to this question that I'm missing.
The example below reproduces the issue. In short: a gadget is created that renders a sidebar and a plot; within the side bar are two link tags that should trigger a popover, the first being generated within the UI object, and the second generated by the combination of uiOutput() and renderUI(). For me at least, the reactive popover doesn't trigger.
MWE:
library(shiny)
library(miniUI)
# Functions for popovers --------------------------------------------------
popoverInit <- function() {
tags$head(
tags$script(
"$(document).ready(function(){$('[data-toggle=\"popover\"]').popover();});"
)
)
}
popover <- function(content, pos, ...) {
tagList(
singleton(popoverInit()),
tags$a(href = "#pop", `data-toggle` = "popover", `data-placement` = paste("auto", pos),
`data-original-title` = "", title = "", `data-trigger` = "hover",
`data-html` = "true", `data-content` = content, ...)
)
}
# Gadget function ---------------------------------------------------------
reactive_popovers <- function(data, xvar, yvar) {
ui <- miniPage(
gadgetTitleBar("Reactive popovers"),
fillRow( # Sidebar and plot.
flex = c(1, 10),
tagList(
tags$hr(),
## This popover works fine:
popover("No problems", pos = "right", "Working popover"),
tags$hr(),
## This one doesn't.
uiOutput("reactive_popover")
),
## A pointless plot.
miniContentPanel(
plotOutput("plot", height = "100%")
)
)
)
server <- function(input, output, session) {
## Render popover.
output$reactive_popover <- renderUI({
popover("Popover content", "right", "Dead popover")
})
## Render plot.
output$plot <- renderPlot({
plot(mpg ~ hp, data = mtcars)
})
}
runGadget(ui, server, viewer = browserViewer())
}
reactive_popovers()

I think this is happening because the popover from renderUI is created after the js binding so it does not get initialised.
Following the answer from this post, you could do:
popoverInit <- function() {
tags$head(
tags$script(
"$(document).ready(function(){
$('body').popover({
selector: '[data-toggle=\"popover\"]',
trigger: 'hover'
});});"
)
)
}