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.
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 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)
I am trying to work on creating the graph using plotly. When the user clicks on any geom_point in the plot using R shiny, it should change the color and keep it unchanged.
Currently, my code is working fine. When the user clicks on any geom_point in the plot, it is changing the color. But when I click on another geom_point, the previous point which was highlighted goes back to its original color.
library(shiny)
library(plotly)
library(htmlwidgets)
ui <- fluidPage(
plotlyOutput("plot")
)
javascript <- "
function(el, x){
el.on('plotly_click', function(data) {
colors = [];
var base_color = document.getElementsByClassName('legendpoints')[data.points[0].curveNumber].getElementsByTagName('path')[0].style['stroke']
for (var i = 0; i < data.points[0].data.x.length; i += 1) {
colors.push(base_color)
};
colors[data.points[0].pointNumber] = '#FF00FF';
Plotly.restyle(el,
{'marker':{color: colors}},
[data.points[0].curveNumber]
);
});
}"
server <- function(input, output, session) {
nms <- row.names(mtcars)
output$plot <- renderPlotly({
p <- ggplot(mtcars, aes(x = mpg, y = wt, col = as.factor(cyl), key = nms)) +
geom_point()
ggplotly(p) %>% onRender(javascript)
})
}
shinyApp(ui, server)
I expect when the user clicks on any geom_point, it should change the color and that color should remain until he closes the shiny app. the color should not return to its original color. Maybe there is a minor change to be made to the Javascript function. Thanks!
The problem is that you always set all point to the base color instead of check which color actual points have. I am no javascript expert but this works for me:
library(shiny)
library(plotly)
library(htmlwidgets)
ui <- fluidPage(
plotlyOutput("plot")
)
javascript <- "
function(el, x){
el.on('plotly_click', function(data) {
var colors = [];
// check if color is a string or array
if(typeof data.points[0].data.marker.color == 'string'){
for (var i = 0; i < data.points[0].data.marker.color.length; i++) {
colors.push(data.points[0].data.marker.color);
}
} else {
colors = data.points[0].data.marker.color;
}
// some debugging
//console.log(data.points[0].data.marker.color)
//console.log(colors)
// set color of selected point
colors[data.points[0].pointNumber] = '#FF00FF';
Plotly.restyle(el,
{'marker':{color: colors}},
[data.points[0].curveNumber]
);
});
}
"
server <- function(input, output, session) {
nms <- row.names(mtcars)
output$plot <- renderPlotly({
p <- ggplot(mtcars, aes(x = mpg, y = wt, col = as.factor(cyl), key = nms)) +
geom_point()
ggplotly(p) %>% onRender(javascript)
})
}
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);
};
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)
})
})
}
))