I am using the DT package to display a data table in my shiny app. Since I provide different data sets, I have radio buttons to select them and the data table updates automatically.
What I would like to do is to preselect the available rows from df1 in df2 when switching the datasets. At the moment, my selection always get erased. When I try to save the selected rows (uncomment the two rows), my table get reset directly.
library(shiny)
library(DT)
df1 <- data.frame(names=letters,
values=1:26)
df2 <- data.frame(names=letters,
values=(1:26)*2)[seq(1,26,2),]
ui <- shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
radioButtons("dataset", label=h5("Select dataset"),
choices=list("df1"='df1',
"df2"='df2'),
selected='df1', inline=TRUE)
),
mainPanel(
DT::dataTableOutput("name_table")
)
)
)
)
Server side...
server <- function(input, output, session) {
getDataset <- reactive({
result <- list()
result[['dataset']] <- switch(input$dataset,
'df1'=df1,
'df2'=df2)
# result[['selection']] <-
# as.numeric(input$name_table_rows_selected)
return(result)
})
output$name_table <- DT::renderDataTable({
DT::datatable(getDataset()[['dataset']],
options=list(pageLength=5))
})
name_proxy = DT::dataTableProxy('name_table')
}
shinyApp(ui, server)
I used the DT table, since I need the proxy and some interaction with the data table.
You can save selected rows only when going to change df like
server <- function(input, output, session) {
dd=reactiveValues(select=NULL)
observeEvent(input$dataset,{
dd$select=as.numeric(isolate(input$name_table_rows_selected))
})
getDataset <- reactive({
result <- list()
result[['dataset']] <- switch(input$dataset,
'df1'=df1,
'df2'=df2)
return(result)
})
output$name_table <- DT::renderDataTable({
DT::datatable(getDataset()[['dataset']],
options=list(pageLength=5),
selection = list(mode = 'multiple', selected =dd$select )
)
})
name_proxy = DT::dataTableProxy('name_table')
}
shinyApp(ui, server)
Or a bit modification of #drmariod variant: use eventReactive instead of reactive
server <- function(input, output, session) {
getDataset <- eventReactive(input$dataset,{
result <- list()
result[['dataset']] <- switch(input$dataset,
'df1'=df1,
'df2'=df2)
result[['selection']] <- testing()
return(result)
})
testing <- function() {
list(selected=as.numeric(input$name_table_rows_selected))
}
output$name_table <- DT::renderDataTable({
DT::datatable(getDataset()[['dataset']],
options=list(pageLength=5),
selection=getDataset()[['selection']])
})
name_proxy = DT::dataTableProxy('name_table')
}
Hm, it looks like I found a solution, but I wonder if there is a better solution.
server <- function(input, output, session) {
getDataset <- reactive({
result <- list()
result[['dataset']] <- switch(input$dataset,
'df1'=df1,
'df2'=df2)
result[['selection']] <- testing()
return(result)
})
testing <- function() {
list(selected=as.numeric(input$name_table_rows_selected))
}
output$name_table <- DT::renderDataTable({
DT::datatable(getDataset()[['dataset']],
options=list(pageLength=5),
selection=getDataset()[['selection']])
})
name_proxy = DT::dataTableProxy('name_table')
}
I wonder, sometimes comes a processing message. and on each click the table shortly "blinks"... Would be great to get a better answer.
Related
I have a list of data frames, ls_df, comprising two dataframes from the datasets package.
I am trying to load these two dataframes into a Shiny app using the code below. However, it does not work, with the error message no item called "ls_df" on the search list being returned. Does anyone know how to fix?
ls_df <- list(datasets::airmiles,
datasets::AirPassengers)
ui <- fluidPage(
selectInput("ls_df", label = "Dataset", choices = ls("ls_df")),
verbatimTextOutput("summary"),
tableOutput("table")
)
server <- function(input, output, session) {
output$summary <- renderPrint({
dataset <- get(input$ls_df, "ls_df")
summary(dataset)
})
output$table <- renderTable({
dataset <- get(input$ls_df, "ls_df")
dataset
})
}
shinyApp(ui, server)
The list needs the names:
library(shiny)
ls_df <- list(airmiles=datasets::airmiles,AirPassengers=datasets::AirPassengers)
ui <- fluidPage(
selectInput("ls_df", label = "Dataset", choices = names(ls_df)),
verbatimTextOutput("summary"),
tableOutput("table")
)
server <- function(input, output, session) {
output$summary <- renderPrint({
dataset <- ls_df[[input$ls_df]]
summary(dataset)
})
output$table <- renderTable({
dataset <- ls_df[[input$ls_df]]
dataset
})
}
shinyApp(ui, server)
Two things wrong:
Your list needs names, as discussed in PorkChop's answer. If this were the only required change, then PorkChop's answer would suffice.
get(input$ls_df, "ls_df") is an error. This should be rather clear, though, since it prevents the shiny interface from starting. This error is because the envir= argument of ls and get require an object, not the character name of an object. (One could go "inception" and use ls(get("ls_df")) and similarly for get, but that hardly seems necessary or useful.)
ls_df <- list(airmiles=datasets::airmiles, # <-- named list
AirPassengers=datasets::AirPassengers)
ui <- fluidPage(
selectInput("ls_df", label = "Dataset", choices = ls(ls_df)), # <-- no quotes
verbatimTextOutput("summary"),
tableOutput("table")
)
server <- function(input, output, session) {
output$summary <- renderPrint({
dataset <- get(input$ls_df, ls_df) # <-- no quotes
summary(dataset)
})
output$table <- renderTable({
dataset <- get(input$ls_df, ls_df) # <-- no quotes
dataset
})
}
I have a cumbersome function inside a server output variable.
The function returns a list of 2 data frames.
I want to extract these tables and plot them side by side.
However I do not want to create two different outputs for them in server, as I don't want the heavy function to run twice.
For the sake of giving a reproducible code :
(my getListOfDataFrames function is much heavier than in this example)
I want df1 and df2 displayed side by side with scrollX = TRUE in options
library(shiny)
library(DT)
ui <- fluidPage(
dataTableOutput("output1")
)
server <- function(input, output){
getListOfDataFrames <- function(df){
return(list(df[1:5,], df[6:10,]))
}
output$output1 <- renderDataTable({
myList <- getListOfDataFrames(mtcars)
df1 <- as.data.frame(myList[1])
df2 <- as.data.frame(myList[2])
})
}
shinyApp(ui, server)
There are plenty of examples how to create dynamic content, like example below:
library(shiny)
library(DT)
ui <- fluidPage(
uiOutput("dt")
)
server <- function(input, output){
getListOfDataFrames <- function(df){
return(list(df[1:5,], df[6:10,]))
}
myList <- getListOfDataFrames(mtcars)
output$dt <- renderUI({
ntables <- seq(myList)
# we want to create the width depending how many tables we have
width <- paste0(99/max(ntables),"%;")
lapply(ntables, function(i) {
id <- paste0("dt", i)
div(style=paste0("display:inline-block;width:",width),DT::dataTableOutput(id))
})
})
observe({
# Dynamically creating 2 tables with separate ids
lapply(seq(myList), function(i){
id <- paste0("dt", i)
output[[id]] <- DT::renderDataTable(as.data.frame(myList[i]))
})
})
}
shinyApp(ui, server)
The following code is a simpler version of my original problem.
The code should do the following steps sequentially:
The table will show entire 'mtcars'
On each click on Half button, it should show half of the previous data
On each click on One3 button, it should show one third of the previous data
** Can someone tell me how to use reactiveValues etc. to solve the problem?
library(shiny)
library(DT)
ui <- fluidPage(tabsetPanel(
tabPanel("Table",
actionButton("Half","Click for Half"),
actionButton("One3","Click for One Third"),
DTOutput("tbl")
)
))
server = function(input, output, session){
data <- reactiveValues(
tbl = mtcars
)
tbl <- eventReactive(T,data$tbl)
observeEvent(input$Half,{
data$tbl <- data$tbl[1:(round(nrow(data$tbl)/2)),]
tbl <- eventReactive(input$Half,data$tbl)
})
observeEvent(input$One3,{
data$tbl <- data$tbl[1:(round(nrow(data$tbl)/3)),]
tbl <- eventReactive(input$One3,data$tbl)
})
output$tbl <- renderDT(tbl())
}
shinyApp(ui = ui, server = server)
No need for eventreactive as reactiveValues(tbl = mtcars) default value i.e. mtcars will be there presented at output$tbl until the user hits Half then it will be updated automatically in the reactive chain.
server = function(input, output, session){
data <- reactiveValues(tbl = mtcars)
observeEvent(input$Half,{
data$tbl <- data$tbl[1:(round(nrow(data$tbl)/2)),]
})
output$tbl <- renderDT(data$tbl)
}
I am creating a shiny module that inputs a dataset, and outputs a DataTable with the data and a numeric input. I know that with inputs in DataTables you need to bind and unbind the elements with javascript each time the table is redrawn or else you will only be able to read the values from the initial table. (https://groups.google.com/forum/#!topic/shiny-discuss/ZUMBGGl1sss) I don't know if the issue is with namespaces, but I can't seem to get the elements of the table to succesfully unbind inside a module. Here is my code:
library(shiny)
library(DT)
# module UI
dtInputUI <- function(id) {
ns <- NS(id)
tbl <- DT::dataTableOutput(ns("tbl"))
btn <- actionButton(ns("btn"),"Submit")
scrpt1 <- tags$script(HTML(
"Shiny.addCustomMessageHandler('display', function(html) {
var w=window.open();
$(w.document.body).html(html);})"
))
# doesn't appear to work properly
scrpt2 <- tags$script(HTML(paste0(
"Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})")))
tagList(
btn,tbl,scrpt1,scrpt2
)
}
# module server
dtInput <- function(input, output, session, data) {
ns <- session$ns
# numeric inputs
form <- reactive({
n <- nrow(data())
inputs <- character(n)
for (i in seq_len(n)) {
inputs[i] <- as.character(numericInput(
ns(paste0("Form",i)),value=0,label=NULL)
)
}
session$sendCustomMessage('unbind-DT',ns("tbl"))
data.frame(data(), RATE=inputs)
})
# datatable
output$tbl <- DT::renderDataTable(form(),
server=FALSE,escape=FALSE,selection='none',
rownames=FALSE,options=list(
paging=FALSE,
bInfo=0,
bSort=0,
bfilter=0,
preDrawCallback=DT::JS(
'function() {Shiny.unbindAll(this.api().table().node());}'),
drawCallback=DT::JS(
'function(settings) {Shiny.bindAll(this.api().table().node());}')
))
vals <- reactive({
unlist(lapply(seq_len(nrow(data())),function(i) {
value <- ifelse(is.null(input[[paste0("Form",i)]]),NA,input[[paste0("Form",i)]])
}))
})
# generate webpage when button clicked
observeEvent(input$btn, {
HTML <- paste0("<p>",paste0(vals(),collapse=" </p> <p>"),"</p>")
session$sendCustomMessage("display",HTML)
})
}
ui <- fluidPage(
mainPanel(
selectInput("choose","Choose data",choices=c("mtcars","iris")),
dtInputUI("example")
)
)
server <- function(input, output, session) {
dat <- reactive({
req(input$choose)
get(input$choose)
})
callModule(dtInput,"example",reactive(dat()))
}
shinyApp(ui, server)
Enter anything in the inputs and press the button and a webpage with the inputs is created. Change the dataset, enter different info in the inputs, and press the button again and you get the same info as before, which tells me that the old inputs didn't successfully unbind.
Any idea what I am doing wrong?
Thanks
I am trying to create a shiny app where I want the user to enter a few (but variable number of) rows of a data frame (with 3 columns). The best way would be to have the user enter a row at a time, and perhaps push a button to create a new row.
What is an intuitive way to implement this in a shiny gui?
You can do something like this:
rm(list = ls())
library(shiny)
# Sample data
my_data <- data.frame(matrix(1,nrow=1,ncol=3))
colnames(my_data) <- c("one","two","three")
emptry_row <- as.data.frame(matrix(1,nrow=1,ncol=3))
colnames(emptry_row) <- colnames(my_data)
ui =fluidPage(
sidebarPanel(actionButton("add_row", "Add a row")),
mainPanel(dataTableOutput("my_table"))
)
server = function(input, output, session){
values <- reactiveValues()
values$df <- my_data
newEntry <- observe({
if(input$add_row > 0) {
isolate(values$df <- rbind(values$df, emptry_row))
}
})
output$my_table <- renderDataTable({
if(input$add_row==0){return(values$df)}
values$df
})
}
runApp(list(ui = ui, server = server))