We Keep Coding

generate right click and select custom menu R shiny JS automatically

I have created the following App using R Shiny
library(shiny)
library(rhandsontable)
library(shinyjs)
ui <- fluidPage(
sidebarLayout(sidebarPanel = "Inputparameter",
numericInput(inputId = "Noi", label = "Row Count", value = 7, 0, max = 1000)),mainPanel (useShinyjs(),rHandsontableOutput(outputId = 'Adjusttable', width ='100%', height
= '100%'),dataTableOutput(outputId = "Init_Tbl")))
server <- function(input, output, session) {
DF <-reactive({
DF_Out<-data.frame(ID = 1:5,'Column2' = 0, Start = "D",FM="",stringsAsFactors = FALSE)
return(DF_Out)})
output$Adjusttable<-renderRHandsontable({
input_Val<-input$Noi
js_func<-paste("function (key, options) {this.alter('insert_row',[0],",
input_Val,");this.render();}")
###
namestate<-paste("Add",input_Val, "rows at the bottom")
output_Adjusttable<- DF() %>% head(5) %>% rhandsontable(width = 280, height = 677,stretchH =
"all") %>%hot_context_menu(customOpts = list(insert_row = list(name = namestate,callback =
htmlwidgets::JS(js_func))))
return(output_Adjusttable)}, quoted = FALSE )}
shinyApp(ui, server)
the js_func line generates a right click option that adds extra rows. The number of extra rows is determined by the numericinput row count. Is it possible to automatically add the extra rows by the numericinput without the right click.

This example, will add as many empty rows to the output as given by input$Noi. The idea is that you create an empty data.frame which has input$Noi rows and rbind it to your original data.frame:
library(shiny)
library(rhandsontable)
ui <- fluidPage(
sidebarLayout(sidebarPanel = "Inputparameter",
numericInput("Noi", "Row Count", 7, 0, 1000)),
mainPanel(rHandsontableOutput("Adjusttable", "100%", "100%"),
dataTableOutput("Init_Tbl"))
)
server <- function(input, output, session) {
DF <- reactive({
DF_Out <- data.frame(ID = 1:5,
Column2 = 0,
Start = "D",
FM = "")
df_fill <- data.frame(ID = NA_integer_,
Column2 = NA_real_,
Start = NA_character_,
FM = NA_character_)[rep(1L, input$Noi), ]
res <- rbind(DF_Out,
df_fill)
rownames(res) <- NULL
res
})
output$Adjusttable <- renderRHandsontable({
DF() %>%
rhandsontable(width = 280,
height = 677,
stretchH = "all")
})
}
shinyApp(ui, server)

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.

selectInput value not updating in reactable Shiny (Trouble binding-unbiding)

I have a selecInput inside a reactable in Shiny, but the input is not updating. I want to do something like this but in reactable:
Trouble with reactivity when binding/unbinding DataTable
library(shiny)
library(tidyverse)
library(reactable)
runApp(list(
ui = basicPage(
h2("Table Data"),
reactableOutput("tbl_react_mtcars"),
h2("Selected"),
textOutput("tbl_mtcars")
),
server = function(input, output) {
output$tbl_react_mtcars <- renderReactable({
mtcars %>%
slice(1) %>%
as_tibble() %>%
select(1:4) %>%
mutate(list = as.character(selectInput(inputId = "list_1", label = NULL, choices = 1:5))) %>%
reactable(columns = list(
list = colDef(html = T, align = "center")
))
})
output$tbl_mtcars <- renderText({
if(is.null(input$list_1)){
NA
} else{
input$list_1
}
})
}
)
)

Here is a way:
library(shiny)
library(reactable)
js <- "
$(document).on('shiny:value', function(e) {
if(e.name === 'rtbl'){
setTimeout(function(){Shiny.bindAll(document.getElementById('rtbl'))}, 0);
}
});
"
ui <- basicPage(
tags$head(tags$script(js)),
h2("Table Data"),
reactableOutput("rtbl"),
h2("Selected"),
textOutput("selection")
)
dat <- iris[1:5,]
dat$select <- c(
as.character(selectInput(inputId = "list_1", label = NULL, choices = 1:5)),
rep("", 4)
)
server <- function(input, output, session){
output$rtbl <- renderReactable({
reactable(dat, columns = list(
select = colDef(html = TRUE, align = "center")
))
})
output$selection <- renderText({
if(is.null(input$list_1)){
NA
}else{
input$list_1
}
})
}
shinyApp(ui, server)