I would like to update a table which is edited in Shiny App. I can't figure out why in below code mean() works fine within observeEvent() but fails to update itself in output$tekst.
library(shiny)
library(DT)
ui <- fluidPage(
textOutput('tekst'),
DTOutput('tabela')
)
server <- function(input, output) {
A <- data.frame("a" = c(1,2,6,5,NA,1), "b" = c(2,2,NA,5,7,NA))
output$tabela = renderDT(A
, selection = 'none'
, editable = 'column')
observeEvent(input$tabela_cell_edit, {
A <<- editData(A, input$tabela_cell_edit, 'tabela')
cat(mean(A$a, na.rm = TRUE), "\n\n")
})
output$tekst <- renderText({mean(A$a, na.rm = TRUE)})
}
shinyApp(ui = ui, server = server)
Help :)
Use a reactive value:
library(shiny)
library(DT)
ui <- fluidPage(
textOutput('tekst'),
DTOutput('tabela')
)
server <- function(input, output) {
A <- data.frame("a" = c(1,2,6,5,NA,1), "b" = c(2,2,NA,5,7,NA))
reactA <- reactiveVal(A)
output$tabela = renderDT(A
, selection = 'none'
, editable = 'column')
observeEvent(input$tabela_cell_edit, {
reactA(editData(reactA(), input$tabela_cell_edit, 'tabela'))
})
output$tekst <- renderText({mean(reactA()$a, na.rm = TRUE)})
}
shinyApp(ui = ui, server = server)
Related
I am trying to create a editable shiny DT table module. It works well when I pass in iris data.
However, when I tried to pass a reactive value, the module does not work. Does anyone had similar experience before ? Could you share your thought?
library(shiny)
library(DT)
editableUI<-function(id){
ns <- NS(id)
DT::dataTableOutput(ns("mod_table"))
}
editableUIServer<-function(id,data,disable_col,change){
moduleServer(id,
function(input,output,session){
print('hi')
v<-reactiveValues(data = data)
print('here we got v')
print(v$data)
output$mod_table <- renderDT(v$data,
editable = list(target = 'cell',
disable = list(columns=c(disable_col))))
proxy = dataTableProxy('mod_table')
observeEvent(input$mod_table_cell_edit, {
info = input$mod_table_cell_edit
v$data <<- editData(v$data, info)
replaceData(proxy, v$data, resetPaging = FALSE)
})
observeEvent(change(),{
v$data<<-data
})
return(v)
}
)}
# Define UI for application that draws a histogram
ui <- fluidPage(
fluidPage(
fluidRow(pickerInput('spec',label = 'Species',choices = unique(as.character(iris$Species)),selected = "versicolor")
),
fluidRow(editableUI("test")))
)
# Define server logic required to draw a histogram
server <- function(input, output) {
data<-reactive({
iris %>% filter(Species %in% c(input$spec))
})
observe({print(data())})
v<-reactive({editableUIServer("test",data(),c(1), change_ppg = reactive(input$spec))})
}
# Run the application
shinyApp(ui = ui, server = server)
I changed a couple of lines and now it works. Not sure why it was wrong in the first place, though
library(shiny)
library(DT)
editableUI<-function(id){
ns <- NS(id)
DT::dataTableOutput(ns("mod_table"))
}
editableUIServer<-function(id,data,disable_col){
moduleServer(id,
function(input,output,session){
print('hi')
v<-reactiveValues(data = data)
print('here we got v')
output$mod_table <- renderDT(v$data,
editable = list(target = 'cell',
disable = list(columns=c(disable_col))))
proxy = dataTableProxy('mod_table')
observeEvent(input$mod_table_cell_edit, {
info = input$mod_table_cell_edit
v$data <<- editData(v$data, info)
replaceData(proxy, v$data, resetPaging = FALSE)
})
return(v)
}
)}
# Define UI for application that draws a histogram
ui <- fluidPage(
fluidPage(
fluidRow(pickerInput('spec',label = 'Species',choices = unique(as.character(iris$Species)),selected = "versicolor")
),
fluidRow(editableUI("test")))
)
# Define server logic required to draw a histogram
server <- function(input, output) {
data<-reactive({
iris %>% filter(Species %in% c(input$spec))
})
# v<-reactive({editableUIServer("test",data =iris,c(1), change_ppg = reactive(input$spec))})
v<- reactive(editableUIServer("test",data(),c(1)))
observe(print(v()$data))
}
# Run the application
shinyApp(ui = ui, server = server)
It would be great someone can help to solve below criteria.
Requirement details:-
How to pass multiple attributes dynamically to group_by/summaries clause to get aggregated data for selected attributes? in my case I am able to achieve the same by using below code, but it was restricted to 1 group by attribute and summary attribute. If I select multiple group by or summary attributes, it's throwing error.
library(dplyr)
library(data.table)
library(shiny)
library(DT)
df1 <- data.frame("name"=c("AAA","BBB","CCC"),"dept"=c("HR","HR","FIN"),"Salary"=c(1000,1345,5678),"Salary2"=c(4567,7896,5678))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
pickerInput("Id0001","group by attributes",choices = unique(names(df1)),multiple = TRUE,options = list(`live-search` = TRUE)),
pickerInput("Id0002","summary attributes",choices = unique(names(df1)),multiple = TRUE,options = list(`live-search` = TRUE)),
actionButton("Id0003", "show data")
),
mainPanel( DT::DTOutput("data_tbl") )
)
)
server <- function(input,output,session){
reactive_string <- eventReactive(input$Id0003, {
if (input$Id0003 > 0) {
dt_agg_ui <<- df1 %>%
group_by(!!rlang::sym(input$Id0001)) %>%
summarise_at(vars(!!rlang::sym(input$Id0002)),funs(sum,n()))
}
dt_agg_ui
})
output$data_tbl <- DT::renderDT( {reactive_string()})
}
shinyApp(ui = ui, server = server)
Using dplyr::across and tidyselect::all_of this could be achieved like so:
library(dplyr)
library(data.table)
library(shiny)
library(shinyWidgets)
library(DT)
df1 <- data.frame("name"=c("AAA","BBB","CCC"),"dept"=c("HR","HR","FIN"),"Salary"=c(1000,1345,5678),"Salary2"=c(4567,7896,5678))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
pickerInput("Id0001","group by attributes",choices = unique(names(df1)),multiple = TRUE,options = list(`live-search` = TRUE)),
pickerInput("Id0002","summary attributes",choices = unique(names(df1)),multiple = TRUE,options = list(`live-search` = TRUE)),
actionButton("Id0003", "show data")
),
mainPanel( DT::DTOutput("data_tbl") )
)
)
server <- function(input,output,session){
reactive_string <- eventReactive(input$Id0003, {
if (input$Id0003 > 0) {
dt_agg_ui <<- df1 %>%
group_by(across(all_of(input$Id0001))) %>%
summarise(across(all_of(input$Id0002), .fns = list(sum = sum, n = ~ n())))
}
dt_agg_ui
})
output$data_tbl <- DT::renderDT( {reactive_string()})
}
shinyApp(ui = ui, server = server)
I have an R shiny app with a DT datatable that is rendered using the datatable function in order to set various options. I would like to use dataTableProxy and replaceData to update the data in the table, but all the examples I can find assume the DT is rendered directly from the data object, not using the datatable function. The reprex below shows what I would like to do, but replaceData doesn't work in this pattern. How do I do this? Thanks.
# based on
# https://community.rstudio.com/t/reorder-data-table-with-seleceted-rows-first/4254
library(shiny)
library(DT)
ui = fluidPage(
actionButton("button1", "Randomize"),
fluidRow(
column(6,
h4("Works"),
DT::dataTableOutput('table1', width="90%")),
column(6,
h4("Doesn't Work"),
DT::dataTableOutput('table2', width="90%"))
)
)
server = function(input, output, session) {
my <- reactiveValues(data = iris)
output$table1 <- DT::renderDataTable(isolate(my$data))
output$table2 <- DT::renderDataTable({
DT::datatable(isolate(my$data),
options = list(lengthChange=FALSE, ordering=FALSE, searching=FALSE,
columnDefs=list(list(className='dt-center', targets="_all")),
stateSave=TRUE, info=FALSE),
class = "nowrap cell-border hover stripe",
rownames = FALSE,
editable = FALSE
) %>%
DT::formatStyle('Sepal.Width', `text-align`="center")
})
observeEvent(input$button1, {
# calculate new row order
row_order <- sample(1:nrow(my$data))
my$data <- my$data[row_order, ]
proxy1 <- DT::dataTableProxy('table1')
DT::replaceData(proxy1, my$data)
proxy2 <- DT::dataTableProxy('table2')
DT::replaceData(proxy2, my$data)
})
}
shinyApp(ui, server)
Update: Very strangely, removing rownames = FALSE made it all possible. I'm not exactly sure why, but probably rownames might be essential for replacing Data.
# based on
# https://community.rstudio.com/t/reorder-data-table-with-seleceted-rows-first/4254
library(shiny)
library(DT)
ui = fluidPage(
actionButton("button1", "Randomize"),
fluidRow(
column(6,
h4("Works"),
DT::dataTableOutput('table1', width="90%")),
column(6,
h4("Doesn't Work"),
DT::dataTableOutput('table2', width="90%"))
)
)
server = function(input, output, session) {
my <- reactiveValues(data = iris)
output$table1 <- DT::renderDataTable(isolate(my$data))
output$table2 <- DT::renderDataTable({
DT::datatable(isolate(my$data),
options = list(lengthChange=FALSE, ordering=FALSE, searching=FALSE,
columnDefs=list(list(className='dt-center', targets="_all")),
stateSave=TRUE, info=FALSE),
class = "nowrap cell-border hover stripe",
# rownames = FALSE,
editable = FALSE
) %>%
DT::formatStyle('Sepal.Width', `text-align`="center")
})
observeEvent(input$button1, {
# calculate new row order
row_order <- sample(1:nrow(my$data))
my$data <- my$data[row_order, ]
proxy1 <- DT::dataTableProxy('table1')
DT::replaceData(proxy1, my$data)
proxy2 <- DT::dataTableProxy('table2')
DT::replaceData(proxy2, my$data)
})
}
shinyApp(ui, server)
I want users of my Shiny app to fill in the values of a 2x2 table with row and column names. Of course, I could do it with 4 input boxes, but I assume that it will be tricky to position everything neatly. Despite that, I would prefer a table layout such as the one provided by the DT package. Thus, my question is: Is it possible to have a datatable (or something similar) filled by the user?
You can use shinysky
devtools::install_github("AnalytixWare/ShinySky") package
or rhandsontable to do what you want:
rm(list = ls())
library(shiny)
library(shinysky)
server <- shinyServer(function(input, output, session) {
# Initiate your table
previous <- reactive({mtcars[1:10,]})
MyChanges <- reactive({
if(is.null(input$hotable1)){return(previous())}
else if(!identical(previous(),input$hotable1)){
# hot.to.df function will convert your updated table into the dataframe
as.data.frame(hot.to.df(input$hotable1))
}
})
output$hotable1 <- renderHotable({MyChanges()}, readOnly = F)
output$tbl = DT::renderDataTable(MyChanges())
})
ui <- basicPage(mainPanel(column(6,hotable("hotable1")),column(6,DT::dataTableOutput('tbl'))))
shinyApp(ui, server)
A solution with DT:
library(DT)
library(shiny)
dat <- data.frame(
V1 = c(as.character(numericInput("x11", "", 0)), as.character(numericInput("x21", "", 0))),
V2 = c(as.character(numericInput("x21", "", 0)), as.character(numericInput("x22", "", 0)))
)
ui <- fluidPage(
fluidRow(
column(5, DT::dataTableOutput('my_table')),
column(2),
column(5, verbatimTextOutput("test"))
)
)
server <- function(input, output, session) {
output$my_table <- DT::renderDataTable(
dat, selection = "none",
options = list(searching = FALSE, paging=FALSE, ordering=FALSE, dom="t"),
server = FALSE, escape = FALSE, rownames= FALSE, colnames=c("", ""),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$test <- renderText({
as.character(input$x11)
})
}
shinyApp(ui, server)
I want to include sparklines in a shiny DT. It works fine in the RStudio viewer but in Shiny the sparklines are not rendered. Here is a minimal example.
# dependencies
require(sparkline)
require(DT)
require(shiny)
# create data with sparklines
spark_data <- data.frame(
id = c('spark1', 'spark2'),
spark = c(
spk_chr(values = 1:3, elementId = 'spark1'),
spk_chr(values = 3:1, elementId = 'spark2')
)
)
# render in RStudio viewer (this works)
tbl <- datatable(spark_data, escape = FALSE)
spk_add_deps(tbl)
# render in Shiny (no sparklines rendered in DT)
ui <- fluidPage(
sparklineOutput("test_spark"),
dataTableOutput("tbl")
)
server <- function(input, output) {
# sparkline outside DT (works fine) - also ensures sparkline dependencies are attached
output$test_spark <- renderSparkline(sparkline(1:3))
# sparkline inside DT (does not render)
output$tbl <- renderDataTable(
expr = spark_data,
escape = FALSE
)
}
shinyApp(ui = ui, server = server)
I have modified your code to generate sparklines. I refered to this link to generate the sparklines.
require(sparkline)
require(DT)
require(shiny)
# create data
spark_data1<- data.frame(id = c('spark1', 'spark2'),
spark = c("1,2,3", "3,2,1"))
ui <- fluidPage(
sparklineOutput("test_spark"),
DT::dataTableOutput("tbl")
)
server <- function(input, output) {
line_string <- "type: 'line', lineColor: 'black', fillColor: '#ccc', highlightLineColor: 'orange', highlightSpotColor: 'orange'"
cd <- list(list(targets = 1, render = JS("function(data, type, full){ return '<span class=sparkSamples>' + data + '</span>' }")))
cb = JS(paste0("function (oSettings, json) {\n $('.sparkSamples:not(:has(canvas))').sparkline('html', { ",
line_string, " });\n}"), collapse = "")
output$tbl <- DT::renderDataTable({
dt <- DT::datatable(as.data.frame(spark_data1), rownames = FALSE, options = list(columnDefs = cd,fnDrawCallback = cb))
})
}
shinyApp(ui = ui, server = server)
Hope it helps!
Old-ish question, I know, but based on info in the question Add label to sparkline plot in datatable I think the solution is what you tried originally plus just a few lines. Here I trimmed out the parts demo-ing it works in the viewer and added just what is needed to make the sparklines work.
# dependencies
require(sparkline)
require(DT)
require(shiny)
# create data with sparklines
spark_data <- data.frame(
id = c('spark1', 'spark2'),
spark = c(
spk_chr(values = 1:3, elementId = 'spark1'),
spk_chr(values = 3:1, elementId = 'spark2')
)
)
### adding this <------------
cb <- htmlwidgets::JS('function(){debugger;HTMLWidgets.staticRender();}')
ui <- fluidPage(
### and this <------------
htmlwidgets::getDependency('sparkline'),
dataTableOutput("tbl")
)
server <- function(input, output) {
output$tbl <- renderDataTable(
expr = spark_data,
escape = FALSE,
### and this <------------
options = list(
drawCallback = cb
)
)
}
shinyApp(ui = ui, server = server)