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