We Keep Coding

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

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)

Find caret position in TextAreaInput, within Shiny R

I am struggling with this problem. I have a textAreaInput field within Shiny, and I would like the user to be able to position their cursor within text in that field, click a button, which will then paste additional text at that position. I am struggling with figuring out how to find the caret position within that text field a the time the button is clicked. I think this might require a java solution - but I am having no luck getting this to work. Any hints are greatly appreciated.
here's my code
server.R
library(shiny)
library(shinydashboard)
library(shinyjs)
shinyServer(function(input, output, session){
output$narrOut <- renderText({
if (input$updtext == 0)
return("")
isolate({
tmpchunk<-gsub("\n","<br/>",input$uplchunk)
gsub(" "," ",tmpchunk)
})
})
observeEvent(input$symMicr,{
bthing<-js$cursPos(input$uplchunk) #just returns NULL
updateTextAreaInput(session, inputId = "uplchunk", value = paste(input$uplchunk , "µ",sep="")) #just appends symbol at the end of the text... I would like to insert at the cursor position
})
})
ui.R
library(shiny)
library(shinydashboard)
library(shinyjs)
jsCode <- "
shinyjs.cursPos = function(el) {
var pos = 0;
if (document.selection)
{
el.focus ();
var Sel = document.selection.createRange();
var SelLength = document.selection.createRange().text.length;
Sel.moveStart ('character', -el.value.length);
pos = Sel.text.length - SelLength;
}
else if (el.selectionStart || el.selectionStart == '0')
pos = el.selectionStart;
return pos;
}"
header <- dashboardHeader(title = "LNGnote", titleWidth = 300)# how , src="DivTITLE2.png")
textareaInput <- function(inputId, label, value="", placeholder="", rows=2){
tagList(
div(strong(label), style="margin-top: 5px;"),
tags$style(type="text/css", "textarea {width:100%; margin-top: 5px;}"),
tags$textarea(id = inputId, placeholder = placeholder, rows = rows, value))
}
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Start Again", href="/", newtab=F, icon=icon("refresh")),
menuItem("Say Hello :-", href="#", newtab=F),
menuSubItem("#IPDGC", href="https://twitter.com/pdgenetics", icon = icon("twitter")),
menuSubItem("IPDGC Page", href="http://pdgenetics.org", icon = icon("eye"))
)
)
body <- dashboardBody(
useShinyjs(),
extendShinyjs(text = jsCode),
fluidRow(
# tabBox(width = 12,
tabsetPanel(id = "panels",
####
###
tabPanel("Notebook",
fluidRow(
box(title="Notebook Output", status = "info", width=12, solidHeader = T,
fluidRow(
column(width = 3,
htmlOutput(paste("narrOut")),
HTML("something here<br/>something there")
)
)
)
),
fluidRow(
column(width=3,
box(title="Recipes", status = "info", solidHeader = T, width=12)
),
column(width=6,
box(title="Export Chunk", status = "info", solidHeader = T, width=12,
h6("insert symbol: "),
actionLink(inputId = "symTab", label = "TAB"),
actionLink(inputId = "symBeta", label = HTML("β")),
actionLink(inputId = "symAlph", label = HTML("α")),
actionLink(inputId = "symMicr", label = HTML("µ")),
textareaInput(inputId = "uplchunk", label = NULL, value = "", rows = 20)
),
actionButton("updtext", "Upload", class = "buttfind")
)
)
),
tabPanel("Ongoing Notebooks",
fluidRow(
box(title="Variant Selection", status = "info", width=12, solidHeader = T,
fluidRow(
column(width = 3,
h2('loggedinas')
)
)
)
)
)
)
)
)
ui<-dashboardPage(header, sidebar, body, skin = "black")

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);
};