We Keep Coding

How to implement a pop-up bubble when hovering the cursor over the image rendered in the table using R shiny?

The below code is getting close to what I need. I'm trying to modify it so that hovering the cursor over each question mark in the rendered table causes a pop-up bubble to show the help text, instead of rendering the text at the bottom of the screen and requiring the user to click on "close". Moving the cursor off the question mark should cause the pop-up bubble to disappear. As shown in the image.
Any recommendations for how to do this?
I am trying to learn some javascript and CSS through W3 School, but it is slow going.
Code:
library(magrittr)
library(htmlwidgets)
library(rhandsontable)
library(shiny)
DF = data.frame(
Col_1 = c("This is row 1","This is row 2"),
Col_Help = c(
"https://as1.ftcdn.net/v2/jpg/03/35/13/14/1000_F_335131435_DrHIQjlOKlu3GCXtpFkIG1v0cGgM9vJC.jpg",
"https://as1.ftcdn.net/v2/jpg/03/35/13/14/1000_F_335131435_DrHIQjlOKlu3GCXtpFkIG1v0cGgM9vJC.jpg"
),
text = c("Row 1 does xxx","Row 2 does yyy"),
stringsAsFactors = FALSE
)
ui <- fluidPage(br(),rHandsontableOutput('my_table'))
server <- function(input, output, session) {
output$my_table <- renderRHandsontable({
rhandsontable::rhandsontable(
DF,
allowedTags = "<em><b><strong><a><big>"
) %>%
hot_cols(colWidths = c(200, 80)) %>%
hot_col(1, renderer = htmlwidgets::JS("safeHtmlRenderer")) %>%
hot_col(2, renderer = "
function(instance, td, row, col, prop, value, cellProperties) {
var escaped = Handsontable.helper.stringify(value),
img;
if (escaped.indexOf('http') === 0) {
img = document.createElement('IMG');
img.src = value; img.style.width = 'auto'; img.style.height = '20px';
Handsontable.dom.addEvent(img, 'mousedown', function (e){
var exists = document.getElementById('test')
if (exists === null){
var textBlock = instance.params.data[[row]][[2]];
var popup = document.createElement('div');
popup.className = 'popup';
popup.id = 'test';
var cancel = document.createElement('div');
cancel.className = 'cancel';
cancel.innerHTML = '<center><b>close</b></center>';
cancel.onclick = function(e) {
popup.parentNode.removeChild(popup)
}
var message = document.createElement('span');
message.innerHTML = '<center>' + textBlock + '</center>';
popup.appendChild(message);
popup.appendChild(cancel);
document.body.appendChild(popup);
}
});
Handsontable.dom.empty(td);
td.appendChild(img);
}
else {
// render as text
Handsontable.renderers.TextRenderer.apply(this, arguments);
}
return td;
}") %>%
hot_cols(colWidths = ifelse(names(DF) != "text", 100, 0.1))
})
}
shinyApp(ui, server)

Why don't you simply allow displaying img tags and provide them with a title?
library(magrittr)
library(htmlwidgets)
library(rhandsontable)
library(shiny)
DF = data.frame(
Col_1 = c("This is row 1","This is row 2"),
Col_Help = c(
as.character(img(src = "https://images.plot.ly/language-icons/api-home/python-logo.png", title = "My first help text", style = "width: 50px;")),
as.character(img(src = "https://images.plot.ly/language-icons/api-home/r-logo.png", title = "My second help text", style = "width: 50px;"))
),
text = c("Row 1 does xxx","Row 2 does yyy"),
stringsAsFactors = FALSE
)
ui <- fluidPage(br(),rHandsontableOutput('my_table'))
server <- function(input, output, session) {
output$my_table <- renderRHandsontable({
rhandsontable::rhandsontable(
DF,
allowedTags = "<em><b><strong><a><big><img>"
) %>%
hot_cols(colWidths = c(200, 80)) %>%
hot_col(1:2, renderer = htmlwidgets::JS("safeHtmlRenderer")) %>%
hot_cols(colWidths = ifelse(names(DF) != "text", 100, 0.1))
})
}
shinyApp(ui, server)

menuSubItem in sidebar not activated in ShinyDashboard when opened using a direct link from a different tab

In the code below, I am not able to activate the menuSubitem when opening it using the 'Computation completed' link in the first tab. The link opens the correct tab but fails to automatically activate/open the associated submenu in the sidebar.
Code is modified from the example here, Direct link to tabItem with R shiny dashboard.
library(shiny)
library(shinydashboard)
ui <- shinyUI(
dashboardPage(
dashboardHeader(title = "Some Header"),
dashboardSidebar(
sidebarMenu(
menuItem("Computations", tabName = "tabItem1", icon = icon("dashboard")),
menuItem("Results", tabName = "tabItem2", icon = icon("th"),
menuSubItem("Test", tabName = "subitem2"))
)
),
dashboardBody(
tags$script(HTML("
var openTab = function(tabName){
$('a', $('.sidebar')).each(function() {
if(this.getAttribute('data-value') == tabName) {
this.click()
};
});
}
")),
tabItems(
tabItem(tabName = "tabItem1",
fluidRow(
box(plotOutput("plot1", height = 250)),
box(
title = "Controls",
sliderInput("slider", "Number of observations:", 1, 100, 50)
)
),
infoBoxOutput("out1")
),
tabItem(tabName = "subitem2",
h2("Widgets tab content")
)
)
)
)
)
server <- function(input, output){
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata[seq_len(input$slider)]
hist(data)
})
output$out1 <- renderInfoBox({
infoBox("Completed",
a("Computation Completed", onclick = "openTab('subitem2')", href="#"),
icon = icon("thumbs-o-up"), color = "green"
)
})
}
shinyApp(ui, server)

Welcome to stackoverflow!
You could provide your menuItem "Results" with an id and change it's display style dynamically.
Please check my approach using library(shinyjs):
library(shiny)
library(shinydashboard)
library(shinyjs)
jsCode <- 'shinyjs.hidemenuItem = function(targetid) {var x = document.getElementById(targetid); x.style.display = "none"; x.classList.remove("menu-open");};
shinyjs.showmenuItem = function(targetid) {var x = document.getElementById(targetid); x.style.display = "block"; x.classList.add("menu-open");};'
ui <- shinyUI(
dashboardPage(
dashboardHeader(title = "Some Header"),
dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem("Computations", tabName = "tabItem1", icon = icon("dashboard")),
menuItem(text = "Results", id = "resultsID", tabName = "tabItem2", icon = icon("th"),
menuSubItem("Test", tabName = "subitem2"))
)
),
dashboardBody(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("hidemenuItem", "showmenuItem")),
tabItems(
tabItem(tabName = "tabItem1",
fluidRow(
box(plotOutput("plot1", height = 250)),
box(
title = "Controls",
sliderInput("slider", "Number of observations:", 1, 100, 50)
)
),
infoBoxOutput("out1")
),
tabItem(tabName = "subitem2",
h2("Widgets tab content")
)
)
)
)
)
server <- function(input, output, session){
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata[seq_len(input$slider)]
hist(data)
})
output$out1 <- renderInfoBox({
infoBox("Completed",
actionLink(inputId = "completed", label = "Computation Completed"),
icon = icon("thumbs-o-up"), color = "green"
)
})
observeEvent(input$completed, {
js$showmenuItem("resultsID")
updateTabItems(session, inputId="sidebarID", selected = "subitem2")
})
observeEvent(input$sidebarID, {
if(input$sidebarID != "subitem2"){
js$hidemenuItem("resultsID")
}
})
}
shinyApp(ui, server)
Furthermore please see this related article.

R Shiny - observe () The date input is also triggered when the value of dataInput is not changed

I have shiny code that generates inputs and each of those Inputs trigger the observe when the value is changed, however this does not happen in the dateInput, the dateInput is triggered before the observe.
I want the dateInput to be triggered only when the value of date is changed.
Here is the code
library(shiny)
library(shinydashboard)
js <- "
$(document).on('change', '.dynamicSI .selector select', function(){
Shiny.setInputValue('lastSelectId', this.id, {priority: 'event'});
});
$(document).on('change', '.dynamicSI .radio input', function(){
Shiny.setInputValue('lastSelectId', $(this).attr('name'), {priority: 'event'});
});
$(document).on('change', '.dynamicSI .input input', function(){
Shiny.setInputValue('lastSelectId', this.id, {priority: 'event'});
});
$(document).on('change', '.dynamicSI .date input', function(){
Shiny.setInputValue('lastSelectId', $(this).parent().attr('id'), {priority: 'event'});
});
"
ui <- dashboardPage(
dashboardHeader(title = ""),
dashboardSidebar(),
dashboardBody(
tags$head(tags$script(HTML(js))),
numericInput("graph_tytle_num", "Number of Graph Title elements",
value = 1, min = 1, max = 10),
uiOutput("graph_title"),
plotOutput("plot")
)
)
server <- function(input, output, session) {
#elements of graphic titles
output$graph_title <- renderUI({
buttons <- as.list(1:input$graph_tytle_num)
div(class = "dynamicSI",
lapply(buttons, function(i)
column(
width = 3,
div(class = "selector",
selectInput(inputId = paste0("title1_element",i),
label = paste("Title element",i),
choices = paste0(LETTERS[i],seq(1,i*2)),
selected = 1)
),
div(class = "radio",
radioButtons(inputId = paste0("title2_element",i),
label = paste("Title1 element",i),
choices = c("Yes","No"),
selected = "Yes")
),
div(class = "input",
numericInput(inputId = paste0("title3_element",i),
label = paste("Title element",i),value=1)
),
div(class = "date",
dateInput(inputId = paste0("title4_element",i),
label = paste("Title element",i),
value = "1900-01-01")
)
)
)
)
})
# react to changes in dynamically generated selectInput's
observeEvent(input$lastSelectId, {
cat("lastSelectId:", input$lastSelectId, "\n")
cat("Selection:", input[[input$lastSelectId]], "\n\n")
title <- c()
for(i in 1:input[["graph_tytle_num"]]){
title <- paste(title,input[[paste0("title1_element",i)]],input[[paste0("title2_element",i)]],
input[[paste0("title3_element",i)]],input[[paste0("title4_element",i)]])
}
output$plot <-renderPlot({hist(rnorm(100,4,1),
breaks = 10,
main = title)})
})
}
shinyApp(ui, server)
Thank you for the help. Much Appreciated

R Shiny Dashboard valueBox: Animation from one number to another

I am trying to show animation / transition from 0 to a number in valuebox. let's say 92.6 in valuebox. For example, if a value 90.6 needs to be shown, it will be transitioning from 0 to 90.6.
Example
library(shinydashboard)
library(dplyr)
# UI
ui <- dashboardPage(skin = "black",
dashboardHeader(title = "Test"),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidRow(
valueBoxOutput("test_box")
)
)
)
# Server response
server <- function(input, output, session) {
output$test_box <- renderValueBox({
iris %>%
summarise(Petal.Length = mean(Petal.Length)) %>%
.$Petal.Length %>%
scales::dollar() %>%
valueBox(subtitle = "Unit Sales",
icon = icon("server"),
color = "purple"
)
})
}
shinyApp(ui, server)
In javascript solution is shown here - http://jsfiddle.net/947Bf/1/ In the script below, I tried to communicate using shiny.addCustomMessageHandler but couldn't get success.
tags$script("
Shiny.addCustomMessageHandler('testmessage',
function(){
var o = {value : 0};
$.Animation( o, {
value: $('#IRR .inner h3').val()
}, {
duration: 1500,
easing : 'easeOutCubic'
}).progress(function(e) {
$('#IRR .inner h3').text((e.tweens[0].now).toFixed(1));
});
});"),

Here is an example. The parameter easing: 'easeOutCubic' causes some errors, so I removed this line.
library(shiny)
library(shinydashboard)
js <- "
Shiny.addCustomMessageHandler('anim',
function(x){
var $s = $('div.small-box div.inner h3');
var o = {value: 0};
$.Animation( o, {
value: x
}, {
duration: 1500
//easing: 'easeOutCubic'
}).progress(function(e) {
$s.text('$' + (e.tweens[0].now).toFixed(1));
});
}
);"
# UI
ui <- dashboardPage(skin = "black",
dashboardHeader(title = "Test"),
dashboardSidebar(disable = TRUE),
dashboardBody(
tags$head(tags$script(js)),
fluidRow(
valueBox("", subtitle = "Unit Sales",
icon = icon("server"),
color = "purple"
)
),
br(),
actionButton("btn", "Change value")
)
)
# Server response
server <- function(input, output, session) {
rv <- reactiveVal(10)
observeEvent(input[["btn"]], {
rv(rpois(1,20))
})
observeEvent(rv(), {
session$sendCustomMessage("anim", rv())
})
}
shinyApp(ui, server)
EDIT
Here is a way to change the icon according to value < 10 or value > 10.
library(shiny)
library(shinydashboard)
js <- "
Shiny.addCustomMessageHandler('anim',
function(x){
var $icon = $('div.small-box i.fa');
if(x <= 10 && $icon.hasClass('fa-arrow-up')){
$icon.removeClass('fa-arrow-up').addClass('fa-arrow-down');
}
if(x > 10 && $icon.hasClass('fa-arrow-down')){
$icon.removeClass('fa-arrow-down').addClass('fa-arrow-up');
}
var $s = $('div.small-box div.inner h3');
var o = {value: 0};
$.Animation( o, {
value: x
}, {
duration: 1500
//easing: 'easeOutCubic'
}).progress(function(e) {
$s.text('$' + (e.tweens[0].now).toFixed(1));
});
}
);"
# UI
ui <- dashboardPage(skin = "black",
dashboardHeader(title = "Test"),
dashboardSidebar(disable = TRUE),
dashboardBody(
tags$head(tags$script(HTML(js))),
fluidRow(
valueBox("", subtitle = "Unit Sales",
icon = icon("arrow-up"),
color = "purple"
)
),
br(),
actionButton("btn", "Change value")
)
)
# Server response
server <- function(input, output, session) {
rv <- reactiveVal(10)
observeEvent(input[["btn"]], {
rv(rpois(1,10))
})
observeEvent(rv(), {
session$sendCustomMessage("anim", rv())
})
}
shinyApp(ui, server)
EDIT
Here is a way to do such an animated box with an id set to the box. This allows to do multiple animated boxes with the same JS code:
library(shiny)
library(shinydashboard)
js <- "
Shiny.addCustomMessageHandler('anim',
function(x){
var $box = $('#' + x.id + ' div.small-box');
var value = x.value;
var $icon = $box.find('i.fa');
if(value <= 10 && $icon.hasClass('fa-arrow-up')){
$icon.removeClass('fa-arrow-up').addClass('fa-arrow-down');
}
if(value > 10 && $icon.hasClass('fa-arrow-down')){
$icon.removeClass('fa-arrow-down').addClass('fa-arrow-up');
}
var $s = $box.find('div.inner h3');
var o = {value: 0};
$.Animation( o, {
value: value
}, {
duration: 1500
}).progress(function(e) {
$s.text('$' + (e.tweens[0].now).toFixed(1));
});
}
);"
# UI
ui <- dashboardPage(
skin = "black",
dashboardHeader(title = "Test"),
dashboardSidebar(disable = TRUE),
dashboardBody(
tags$head(tags$script(HTML(js))),
fluidRow(
tagAppendAttributes(
valueBox("", subtitle = "Unit Sales",
icon = icon("server"),
color = "purple"
),
id = "mybox"
)
),
br(),
actionButton("btn", "Change value")
)
)
# Server response
server <- function(input, output, session) {
rv <- reactiveVal(10)
observeEvent(input[["btn"]], {
rv(rpois(1,20))
})
observeEvent(rv(), {
session$sendCustomMessage("anim", list(id = "mybox", value = rv()))
})
}
shinyApp(ui, server)

R shiny: update select input values in data.table

I have renderDataTable with select Inputs and buttons inside. I want to update selectInput inside datatable after click on 'Save' button in appropriate row. How can I do that? During searching for a solution I found that "if you rerender the table, the inputs won't work unless you add some extra code to unbind". However I am new in shiny and using js options, so I would be grateful for any hints/solutions.
library(shiny)
library(DT)
runApp(list(
ui = basicPage(
h2('The mtcars data'),
DT::dataTableOutput('mytable'),
h2("Selected"),
tableOutput("checked")
),
server = function(input, output) {
# helper function for making checkbox
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), ...))
}
inputs
}
# datatable with checkbox
output$mytable = DT::renderDataTable({
data.frame(mtcars,Rating=shinyInput(selectInput,nrow(mtcars),"selecter_",label=NULL,
choices=1:5, width="60px"),
Save = shinyInput(actionButton, nrow(mtcars),'button_',
label = 'Save',onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ))
}, selection='none',server = FALSE, escape = FALSE, options = list(
paging=TRUE,
preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
) )
# helper function for reading checkbox
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
# output read checkboxes
output$checked <- renderTable({
data.frame(selected=shinyValue("selecter_",nrow(mtcars)))
})
}
))

Hey so I don't completely understand your question, but hopefully this helps. This app isn't perfect, but should do what you want:
library(shiny)
library(DT)
runApp(list(
ui = basicPage(
tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})"
)
),
h2('The data'),
selectInput("myData", "Choose dataset", c("mtcars", "iris"), "mtcars"),
DT::dataTableOutput('mytable'),
h2("Selected"),
tableOutput("checked")
),
server = function(input, output, session) {
dataset <- reactive({
session$sendCustomMessage("unbind-DT", "mytable")
get(input$myData)
})
# helper function for making checkbox
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), ...))
}
inputs
}
# datatable with checkbox
output$mytable = DT::renderDataTable({
data.frame(
dataset(),
Rating = shinyInput(
selectInput,
nrow(dataset()),
"selecter_",
choices = 1:5,
width = "60px",
label = NULL
),
Save = shinyInput(actionButton, nrow(dataset()), 'button_',
label = 'Save')
)
}, selection = 'none', server = FALSE, escape = FALSE, options = list(
dom = "ti",
paging = TRUE,
preDrawCallback = JS(
'function() {
Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
))
# helper function for reading checkbox
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value))
NA
else
value
}))
}
# output read checkboxes
output$checked <- renderTable({
data.frame(selected = shinyValue("selecter_", nrow(mtcars)))
})
lapply(1:150, function(i) {
observeEvent(input[[paste0("button_", i)]], {
updateSelectInput(session,
paste0("selecter_", i),
selected = 5,
label = NULL)
})
})
}
))