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)

Why is this Shiny Handler not correctly updating the JS section of the client?

When running the reproducible code at the bottom, I get the strange results in the tree rendered on the left as illustrated in the image below. What am I doing wrong, in my use of the handlers or perhaps in JS script?
"Elements" reads the positions of the tree, "Elements2" does a bit of example transformation, and the Element column in "Elements2" should feed back to the client using Shiny handlers to relabel the tree nodes.
Reproducible code:
library(dplyr)
library(jsTreeR)
library(shiny)
nodes <- list(
list(
text = "Menu",
state = list(opened = TRUE),
children = list(
list(text = "Bog",type = "moveable"),list(text = "Hog",type = "moveable")
)
),
list(text = "Drag here",type = "target",state = list(opened = TRUE))
)
dnd <- list(
always_copy = TRUE,
inside_pos = "last",
is_draggable = JS(
"function(node) {",
" return node[0].type === 'moveable';",
"}"
)
)
mytree <- jstree(nodes,dragAndDrop=TRUE,dnd = dnd,types=list(moveable=list(),target=list()))
script <- '
var LETTERS = ["A", "B", "C", "D", "E"];
var Visited = {};
function updateSubItems(parent){
var tree = $("#mytree").jstree(true);
for (var i = 0; i< parent.children.length; ++i){
sibling = tree.get_node(parent.children[i]);
tree.rename_node(sibling, parent.text + " - " + (i+1))
}
}
// Returns letter of a new copied node
function getSuffix(orgid){
if (Object.keys(Visited).indexOf(orgid) === -1){
Visited[orgid] = 0;
}else{
Visited[orgid]++;
}
return LETTERS[Visited[orgid]];
}
$(document).ready(function(){
$("#mytree").on("copy_node.jstree", function(e, data){
var orgid = data.original.id;
var node = data.node;
var id = node.id;
var basename= node.text;
var text = basename + " " + getSuffix(orgid);
Shiny.setInputValue("Element", text, {priority: "event"});
var instance = data.new_instance;
instance.rename_node(node, text);
node.type = "item";
// the shiny handler below receives newLabel from the server for injecting labels to tree
Shiny.addCustomMessageHandler("injectLabel", function(newLabel) {
instance.rename_node(node, newLabel);
});
node.orgid = orgid;
var tree = $("#mytree").jstree(true);
});
});
'
ui <- fluidPage(
tags$div(class = "header", checked = NA,tags$p(tags$script(HTML(script)))),
fluidRow(
column(width = 4,jstreeOutput("mytree")),
column(width = 8,fluidRow(verbatimTextOutput("Elements"),verbatimTextOutput("Elements2")))
)
)
server <- function(input, output, session){
output[["mytree"]] <- renderJstree(mytree)
Elements <- reactiveVal(data.frame(Element = character(0)))
observeEvent(input[["Element"]], {Elements(rbind(Elements(), data.frame(Element = input[["Element"]])))} )
addLabel <- reactive({if(nrow(Elements()>0)){
addLabel <- Elements()
addLabel <- addLabel %>%
group_by(Element) %>%
mutate(ElementCount = row_number()) %>%
ungroup() %>%
mutate(Element = paste(Element,"-",ElementCount)) %>% select(-ElementCount)
addLabel
}})
output[["Elements"]] <- renderPrint({Elements()})
output[["Elements2"]] <- renderPrint({as.data.frame(addLabel())})
observe({
newLabel <- addLabel()$Element
session$sendCustomMessage("injectLabel", newLabel)
})
}
shinyApp(ui=ui, server=server)

You are sending the entire Element column as a vector. You should only send the last value. Try using:
newLabel <- tail(addLabel()$Element, 1)

How to adjust the width of selected columns in datatable (DT)

I am trying to adjust the width of datatable DT in shiny which works for the below simple example -
library(magrittr)
library(shiny)
library(DT)
ui <- fluidPage(
DT::dataTableOutput('dt')
)
server <- function(input, output) {
output$dt <- DT::renderDataTable({
dt1 <- head(mtcars)
DT::datatable(dt1, rownames = FALSE) %>%
DT::formatStyle(columns = c(3,6), width='200px')
})
}
shinyApp(ui, server)
However, my actual datatable is bit complicated and has some javascript functions.
ui <- fluidPage(
DT::dataTableOutput('dt', width = '700px')
)
server <- function(input, output) {
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
output$dt<- DT::renderDataTable({
dt1 <- head(mtcars)
df <- cbind(select = shinyInput(shiny::checkboxInput, nrow(dt1), 'check'),dt1)
DT::datatable(df, selection = 'none', escape = FALSE,options = list(
preDrawCallback = htmlwidgets::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = htmlwidgets::JS('function() { Shiny.bindAll(this.api().table().node()); } '))) %>%
DT::formatStyle(columns = c(3,6), width='200px')
})
}
shinyApp(ui, server)
I copied the shinyInput function from this post.
But now formatStyle does not work on this and no width is changed. I want to give different width to every column manually especially reduce the width of the first column with checkbox (select) which takes up lot of space.
Do you have any idea how can I do this?

You can pass width value to shiny::checkboxInput :
df <- cbind(select = shinyInput(shiny::checkboxInput, nrow(dt1), 'check', width = '10px'),dt1)
Complete app code -
ui <- fluidPage(
DT::dataTableOutput('dt', width = '700px')
)
server <- function(input, output) {
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
output$dt<- DT::renderDataTable({
dt1 <- head(mtcars)
df <- cbind(select = shinyInput(shiny::checkboxInput, nrow(dt1), 'check', width = '10px'),dt1)
DT::datatable(df, selection = 'none', escape = FALSE,options = list(
preDrawCallback = htmlwidgets::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = htmlwidgets::JS('function() { Shiny.bindAll(this.api().table().node()); } '))) %>%
DT::formatStyle(columns = c(3,6), width='200px')
})
}
shinyApp(ui, server)

The following is taken from one of my apps, hope it helps
DT::datatable(
data = data,
options = list(
columnDefs = list(
list(width = "10%", class = "dt-right", targets = 4)
)
)
)
The thing is that you can pass options as a list in columnDefs. That particular option is saying that the fifth column (index starts in 0) has class dt-right (to right-align the content) and its width is 10% of the table. You can pass a vector with more than one element in targets.

Radiobuttons in Shiny DataTable for "subselection" of rows/ grouping in one column

What I am trying to accomplish is similar to this thread, but slightly more complicated.
I would like to group the radio buttons into different groups, but in one column so a "subselection" of rows is possible.
Currently only the radio button group with ID "C" works, because the div element is defined for the whole table. I have tried to insert the shiny tags via javascript callback, but I'm only able to insert a radio button for each row or for each column, but not for a subset of multiple rows in one column.
Open to javascript or shiny solutions.
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
tags$div(id="C",class='shiny-input-radiogroup',DT::dataTableOutput('foo')),
verbatimTextOutput("test")
),
server = function(input, output, session) {
m = matrix(
c(round(rnorm(24),1), rep(3,12)), nrow = 12, ncol = 3, byrow = F,
dimnames = list(month.abb, LETTERS[1:3])
)
m[, 2] <- rep(c("A","B","C", "D"), each= 3)
m[, 3] <- paste0('<input type="radio" name="', rep(c("A","B","C", "D"), each= 3),'" value="', month.abb,'"/>')
m[c(1,4,7,10), 3] <- gsub('/>', 'checked="checked"/>', m[c(1,4,7,10), 3], fixed = T)
m
output$foo = DT::renderDataTable(
m, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE)
# callback = JS("table.rows().every(function() {
# var $this = $(this.node());
# $this.attr('id', this.data()[0]);
# $this.addClass('shiny-input-radiogroup');
# });
# Shiny.unbindAll(table.table().node());
# Shiny.bindAll(table.table().node());")
)
output$test <- renderPrint(str(input$C))
}
)
UPDATE:
The rough structure of my final solution with reactive button selection. The inputs and visuals stay preserved with re-rendering the table (just the first time the input renders as NULL which is no particular problem for me).
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
title = "Radio buttons in a table",
sliderInput("slider_num_rows", "Num Rows", min = 2, max = 12, value = 5),
tags$div(id = 'placeholder'),
verbatimTextOutput("test")
),
server = function(input, output, session) {
rea <- reactive({
m = matrix(
c(round(rnorm(24),1), rep(3,12)), nrow = 12, ncol = 3, byrow = F,
dimnames = list(month.abb, LETTERS[1:3])
)
m[, 2] <- rep(c("A","B","C", "D"), each= 3)
m[, 3] <- paste0('<input type="radio" name="', rep(c("A","B","C", "D"), each= 3),'" value="', month.abb,'"/>')
save_sel <- c()
mon_tes <- c("Jan", "Apr", "Jul", "Oct")
ab <- c("A", "B", "C", "D")
for (i in 1:4){
if (is.null(input[[ab[i]]])){
save_sel[i] <- mon_tes[i]
} else {
save_sel[i] <- input[[ab[i]]]
}
}
sel <- rownames(m) %in% save_sel
m[sel, 3] <- gsub('/>', 'checked="checked"/>', m[sel, 3], fixed = T)
m <- m[1:input$slider_num_rows,]
m
})
output$foo = DT::renderDataTable(
rea(), escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE,
columnDefs = list(list(className = 'no_select', targets = 3)))
)
observe({
l <- unique(m[, 2])
for(i in 1:length(l)) {
if (i == 1) {
radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", DT::dataTableOutput("foo"))
} else {
radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", radio_grp)
}
}
insertUI(selector = '#placeholder',
ui = radio_grp)
})
output$test <- renderPrint( {
str(input$A)
str(input$B)
str(input$C)
str(input$D)
})
}
)

You can nest the div elements into each other like this:
ui = fluidPage(
title = "Radio buttons in a table",
div(id = "A", class = "shiny-input-radiogroup",
div(id = "B", class = "shiny-input-radiogroup",
div(id = "C", class = "shiny-input-radiogroup",
div(id = "D", class = "shiny-input-radiogroup", DT::dataTableOutput("foo"))
)
)
),
I also modified renderText in order to print all the values.
output$test <- renderPrint( {
str(input$A)
str(input$B)
str(input$C)
str(input$D)
})
Here is the result after interacting with the dataTableOutput (selected the Feb radio button):
Please note that the elements will still have NULL value until interaction. You can get around this problem though, with an if statement, using the default values of radio buttons when the input elements are NULL.
Edit: You can create the divs with a loop like this:
l <- unique(m[, 2])
for(i in 1:length(l)) {
if (i == 1) {
radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", DT::dataTableOutput("foo"))
} else {
radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", radio_grp)
}
}

Synchronize horizontal scrolling of two handsontables

I'd like to synchronize the scrolling of two handsontables in a shiny app.
I tried some attempts based on proposals given here and here.
I also tried with the jquery.scrollSync library, my code is below.
Nothing works.
library(shiny)
library(rhandsontable)
ui = shinyUI(fluidPage(
tags$head(tags$script(src = "http://trunk.xtf.dk/Project/ScrollSync/jquery.scrollSync.js")),
sidebarLayout(
sidebarPanel(),
mainPanel(
rHandsontableOutput("hot", width = 350),
rHandsontableOutput("hot2", width = 350),
singleton(
tags$script(HTML('$("#hot").addClass("scrollable");'))
),
singleton(
tags$script(HTML('$("#hot2").addClass("scrollable");'))
),
singleton(
tags$script(HTML('$(".scrollable").scrollSync();'))
)
)
)
))
server = shinyServer(function(input, output, session) {
values = reactiveValues()
data = reactive({
if (!is.null(input$hot)) {
DF = hot_to_r(input$hot)
} else {
if (is.null(values[["DF"]]))
DF = mtcars[1:3,]
else
DF = values[["DF"]]
}
values[["DF"]] = DF
DF
})
output$hot <- renderRHandsontable({
DF = data()
if (!is.null(DF))
rhandsontable(DF, stretchH = "all")
})
output$hot2 <- renderRHandsontable({
rhandsontable(mtcars[1:3,], stretchH = "all")
})
})
runApp(list(ui=ui, server=server))
Edit
Below is an unsuccessful attempt to use scrollViewportTo.
library(shiny)
library(rhandsontable)
jscode <- "
$('#scroll').on('click', function () {
$('#hot').scrollViewportTo(1,5);
});
"
ui = shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
actionButton("scroll", "Scroll")
),
mainPanel(
rHandsontableOutput("hot", width = 350),
singleton(
tags$script(HTML(jscode))
)
)
)
))
server = shinyServer(function(input, output, session) {
values = reactiveValues()
data = reactive({
if (!is.null(input$hot)) {
DF = hot_to_r(input$hot)
} else {
if (is.null(values[["DF"]]))
DF = mtcars[1:3,]
else
DF = values[["DF"]]
}
values[["DF"]] = DF
DF
})
output$hot <- renderRHandsontable({
DF = data()
if (!is.null(DF))
rhandsontable(DF, stretchH = "all")
})
})
runApp(list(ui=ui, server=server))

A solution. My case is specific: the second table has only one row, with the same number of columns as the first table, and the user only scrolls the first table.
It is also possible to have the same column widths for the two tables, but this is not done in the code below.
It would be better if the scrolling were not continuous, if it jumped row by row. Solved: see the edit at the end.
library(shiny)
library(rhandsontable)
js_getViewport <- "
$(document).ready(setTimeout(function() {
var hot_instance = HTMLWidgets.getInstance(hot).hot
hot_instance.updateSettings({width: hot_instance.getSettings('width').width + Handsontable.Dom.getScrollbarWidth(hot)})
var colPlugin = hot_instance.getPlugin('autoColumnSize');
hot_instance.addHook('afterScrollHorizontally', function(){changeViewport2(colPlugin)});
}, 2000)
)
"
js_setViewport <- "
function changeViewport2 (colPlugin) {
var colStart = colPlugin.getFirstVisibleColumn();
var hot2_instance = HTMLWidgets.getInstance(hot2).hot;
hot2_instance.scrollViewportTo(0, colStart, false, false);
};
"
ui = shinyUI(fluidPage(
tags$head(tags$script(HTML(js_getViewport)),
tags$script(HTML(js_setViewport))),
sidebarLayout(
sidebarPanel(
),
mainPanel(
rHandsontableOutput("hot", height=200),
br(),
rHandsontableOutput("hot2", height=100)
)
)
))
server = shinyServer(function(input, output, session) {
values = reactiveValues()
data = reactive({
if (!is.null(input$hot)) {
DF = hot_to_r(input$hot)
} else {
if (is.null(values[["DF"]]))
DF = mtcars[,]
else
DF = values[["DF"]]
}
values[["DF"]] = DF
DF
})
rowHeaderWidth <- reactive({
max(100,floor(max(nchar(rownames(values[["DF"]])))*8))
})
output$hot <- renderRHandsontable({
DF = data()
if (!is.null(DF))
rhandsontable(DF, stretchH = "none", useTypes=TRUE,
width = 500,
rowHeaderWidth = rowHeaderWidth())
})
output$hot2 <- renderRHandsontable({
rhandsontable(mtcars[1,], stretchH = "none", useTypes=TRUE,
width = 500,
rowHeaderWidth = rowHeaderWidth())
})
})
runApp(list(ui=ui, server=server))
EDIT:
For a better alignment, use:
js_setViewport <- "
function changeViewport2 (colPlugin) {
var colStart = colPlugin.getFirstVisibleColumn();
var hot2_instance = HTMLWidgets.getInstance(hot2).hot;
hot2_instance.scrollViewportTo(0, colStart, false, false);
//
var hot_instance = HTMLWidgets.getInstance(hot).hot;
var rowStart = hot_instance.getPlugin('autoRowSize').getFirstVisibleRow();
hot_instance.scrollViewportTo(rowStart, colStart, false, false);
};