Suppose I have the following shiny app that renders a data table from the package DT:
library(shiny)
ui <- fluidPage(uiOutput("abc"))
server <- function(input, output, session) {
output$abc <- renderUI({DT::dataTableOutput("dt_output")}) # line 4
output$dt_output <- DT::renderDataTable({data.table(a = 1:3, b = 4:6)}) # line 5
}
runApp(list(ui = ui, server = server))
How would you combine lines 4 and 5, with the constraint that output$abc must remain a uiOutput?
My attempt at combining (the code below) led to an error, "cannot coerce type closure":
output$abc <- renderUI({DT::dataTableOutput(
DT::renderDataTable({data.table(a = 1:3, b = 4:6)}))})
This should work:
library(shiny)
ui <- fluidPage(
uiOutput("abc")
)
server <- function(input, output, session) {
output$abc <- renderUI({
output$aa <- DT::renderDataTable(head(mtcars))
DT::dataTableOutput("aa")
})
}
runApp(list(ui = ui, server = server))
Related
I have a package built so that I am able to test functions using test that. I have 2 scenarios where I test function. One scenario works fine (Sce. A) and other (Sce. B) does not work
Sce.B
## app.R (location : D:/Windows/Analytics/R Programming/GitHub/App/pacakge1)
library(shiny)
ui <- fluidPage(
numericInput("x", "X", value = 5),
textOutput("txt"),
actionButton("button", "Submit")
)
server <- function(input, output, session) {
server_1(input, output, session , y1)
}
shinyApp(ui, server)
## file. R (Location : D:/Windows/Analytics/R Programming/GitHub/App/pacakge1/R
server_1 <- function(input, output, session , y1){
y1 <- reactiveValues(a = 0)
function1 <- function(){
y1$a = 2 * input$x
}
observeEvent(input$button,{
function1()
})
output$txt <- renderText({
y1$a
})
}
## test server (location : D:/Windows/Analytics/R Programming/GitHub/App/pacakge1/tests/testthat)
library(testthat)
library(shinytest)
library(shiny)
testServer(expr = {
# y1 <- session$getReturned()
session$setInputs(x = 7)
function1()
expect_equal(y1$a, 14)
})
When I test above above scenario (Sce. B). It does not work well. So I need to test if y1$a returns 14 or not
But scenario A below works well since I am not writing server function outside
Sce.A
##app.R (Same location as above)
library(shiny)
ui <- fluidPage(
numericInput("x", "X", value = 5),
textOutput("txt"),
actionButton("button", "Submit")
)
server <- function(input, output, session) {
y1 <- reactiveValues(a = 0)
function1 <- function(){
y1$a = 2 * input$x
}
observeEvent(input$button,{
function1()
})
output$txt <- renderText({
y1$a
})
}
shinyApp(ui, server)
##test server (same location as above)
library(testthat)
library(shinytest)
library(shiny)
testServer(expr = {
# y1 <- session$getReturned()
session$setInputs(x = 7)
function1()
expect_equal(y1$a, 14)
})
Above test passes and allworks well..
But Scenario B is not working.
So the question is here, can we not test functions from other files?
In the following app, I would like to add a global button, to save the tables in the 2 panels at the same time.
Ideally, they should be saved to an xlsx file, in tabs named after the corresponding tabs.
Please note that the tabs were created using a module.
Many thanks!!
library(shiny)
library(DT)
modDtUi <- function(id){ # UI module
ns = NS(id)
DT::dataTableOutput(ns('x1'))
}
modDt <- function(input, output, session, data, globalSession){ # Server module
x <- data
output$x1 <- DT::renderDataTable(x, selection = 'none', editable = TRUE)
proxy <- dataTableProxy('x1', session = globalSession)
}
ui <- fluidPage(
mainPanel(
tabsetPanel(
tabPanel("Table1", modDtUi("editable")),
tabPanel("Table2", modDtUi("editable2"))
)
)
)
server <- function(input, output, session) {
callModule(modDt,"editable", data = head(iris,10), globalSession = session)
callModule(modDt,"editable2", data = tail(iris,5), globalSession = session)
}
shinyApp(ui = ui, server = server)
I believe this demo works.
I used reactiveValues v$data to store the data inside the module. The module will return v$data so it can be retrieved when you want to save the data in the shiny server.
I also added an observeEvent to detect changes in the data, and update the data table with replaceData.
The excel file is created using the writexl library, but you could substitute with others of course.
Let me know if this works for you. I imagine there are some elements of this answer that can be improved upon - and if we can identify them, would like to edit further.
library(shiny)
library(DT)
library(writexl)
modDtUi <- function(id){ # UI module
ns = NS(id)
DT::dataTableOutput(ns(id))
}
modDt <- function(input, output, session, data, id, globalSession){ # Server module
v <- reactiveValues(data = data)
output[[id]] <- DT::renderDataTable(v$data, selection = 'none', editable = TRUE)
proxy <- dataTableProxy(id, session = globalSession)
id_input = paste(id, "cell_edit", sep = "_")
# Could add observeEvent here to detect edit event
observeEvent(input[[id_input]], {
info = input[[id_input]]
if (!is.null(info)) {
v$data[info$row, info$col] <<- DT::coerceValue(info$value, v$data[info$row, info$col])
}
replaceData(proxy, v$data, resetPaging = FALSE)
})
return(data = reactive({v$data}))
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
width = 2,
actionButton("btn", "Save Both")
),
mainPanel(
tabsetPanel(
tabPanel("Table1", modDtUi("editable1")),
tabPanel("Table2", modDtUi("editable2"))
)
)
)
)
server <- function(input, output, session) {
e1 <- callModule(modDt, "editable1", data = head(iris,10), id = "editable1", globalSession = session)
e2 <- callModule(modDt, "editable2", data = tail(iris,5), id = "editable2", globalSession = session)
observeEvent(input$btn, {
print("Saving...")
sheets <- list("e1" = e1(), "e2" = e2())
write_xlsx(sheets, "test.xlsx")
})
}
shinyApp(ui = ui, server = server)
I am having problems rendering any visualizations on Shiny. I tried many different plots, none of them worked. Here is the code:
library(shiny)
ui <- fluidPage("Comex",
selectInput("paises","Selecione o Destino da Exportação",PAISES$NO_PAIS, selected = PAISES$NO_PAIS[55]),
plotlyOutput(outputId = "table"))
server <- function(input, output){
output$table <- renderTable({
p <- RPostgres::dbGetQuery(con, paste0("SELECT CO_ANO, NO_PAIS, SUM(VL_FOB)
FROM comex
INNER JOIN paises ON comex.CO_PAIS = paises.CO_PAIS
WHERE (SG_UF_MUN = 'AL') AND (NO_PAIS = '",input$paises,"')
GROUP BY NO_PAIS, CO_ANO"))
View(p)
})}
shinyApp(ui, server)
The SQL command seems fine, as I successfully extracted data with this very code outside the shinyApp structure.
The return value from View(.) is NULL, so your renderTable will always be blank; just make it p.
If your ui contains plotlyOutput then replace renderTable with plotly::renderPlotly. The ui-component for shiny::renderTable is shiny::tableOutput.
renderTable is intended for a tabular display of data.frame-like data, not a plot.
Choose either:
ui <- fluidPage(
...,
tableOutput("table")
...
)
server <- function(input, output, session) {
output$table <- renderTable({
# code that returns a data.frame
})
}
or
ui <- fluidPage(
...,
plotlyOutput("myplot")
...
)
server <- function(input, output, session) {
output$myplot <- plotly::renderPlotly({
# ...
plot_lt(...)
})
}
I'm trying to dynamically create some content with a for loop using renderUI and uiOutput but every rendered element only contains the information from the last iteration in the for loop. Example:
require(shiny)
ui <- fluidPage(
uiOutput("out1"),
uiOutput("out2")
)
server <- function(input, output, session) {
count <- 1
for(a in c("hello", "world")){
name <- paste0("out", count)
output[[name]] <- renderUI({
strong(a)
})
count <- count + 1
}
}
shinyApp(ui = ui, server = server)
This outputs world twice instead of hello world
It works when using sapply instead of a for loop:
require(shiny)
ui <- fluidPage(
uiOutput("out1"),
uiOutput("out2")
)
server <- function(input, output, session) {
vec <- c("hello", "world")
sapply(seq_along(vec), function(x) {
name <- paste0("out", x)
output[[name]] <- renderUI({
strong(vec[x])
})
})
}
shinyApp(ui = ui, server = server)
As an alternative to Alexandre's answer I figured out using local({}) also works thanks to Zygmunt Zawadzki's comment:
ui <- fluidPage(
uiOutput("out1"),
uiOutput("out2")
)
server <- function(input, output, session) {
count <- 1
for(a in c("hello", "world")){
local({
b <-a #this has to be added as well
name <- paste0("out", count)
output[[name]] <- renderUI({
strong(b)
})
})
count <- count + 1
}
}
shinyApp(ui = ui, server = server)
In figuring out how to use the new shiny modules, I would like to emulate the following app. When the rows of the datatable are clicked and unclicked, it updates the entries in the selectInput box, using updateSelectInput.
library(shiny)
## prepare dataframe -----------------------------------------------------------
df <- mtcars
df$model <- rownames(df)
rownames(df) <- NULL
df <- df[1:10, c(12, 1:5)]
car_names <- data.frame(df$model)
## app -------------------------------------------------------------------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput('car_input', 'Select car:', df$model, multiple = TRUE)
),
mainPanel(
DT::dataTableOutput('table')
)
)
)
server <- function(input, output, session, ...) {
output$table <- DT::renderDataTable(df)
car_rows_selected <- reactive(car_names[input$table_rows_selected, ])
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
shinyApp(ui = ui, server = server)
I have got most of the way there, but am having difficulty with updating the input box. I wonder if it has something to do with the way the namespaces work, and perhaps requires a nested call to the DFTable module within the Car module, but I'm not sure. I am able to add a textOutput element that prints the expected information from the selected table rows. My code for a single file app is below:
library(shiny)
## prepare dataframe -----------------------------------------------------------
df <- mtcars
df$model <- rownames(df)
rownames(df) <- NULL
df <- df[1:10, c(12, 1:5)]
car_names <- data.frame(df$model)
## select module ---------------------------------------------------------------
CarInput <- function(id){
ns <- NS(id)
selectInput(ns('car_input'), 'Select car:', df$model, multiple = TRUE)
}
Car <- function(input, output, session, ...) {
# I was thinking perhaps I needed to call the DFTable module as a nested module within this Car module
car_rows_selected <- callModule(DFTable, 'id_inner')
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
## datatable module ------------------------------------------------------------
DFTableOutput <- function(id){
ns <- NS(id)
DT::dataTableOutput(ns('table'))
}
DFTable <- function(input, output, session, ...){
output$table <- DT::renderDataTable(df)
return(reactive(car_names[input$table_rows_selected, ]))
}
## app -------------------------------------------------------------------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
CarInput('id_car'),
textOutput('selected') # NB. this outputs expected values
),
mainPanel(
DFTableOutput('id_table')
)
)
)
server <- function(input, output, session, ...) {
callModule(Car, 'id_car')
callModule(DFTable, 'id_table')
output$selected <- callModule(DFTable, 'id_table') # NB this works as expected (see textOutput in ui section above)
car_rows_selected <- callModule(DFTable, 'id_table')
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
shinyApp(ui = ui, server = server)
Any help would be greatly appreciated
OK, a little more trial and error got me to the right answer - the car_rows_selected item needed to be given the double arrow <<- operator in the app server function in order for it to be useable in the Car module: look for the car_rows_selected <<- callModule(DFTable, 'id_table') in the server function
library(shiny)
## prepare dataframe -----------------------------------------------------------
df <- mtcars
df$model <- rownames(df)
rownames(df) <- NULL
df <- df[1:10, c(12, 1:5)]
car_names <- data.frame(df$model)
## select module ---------------------------------------------------------------
CarInput <- function(id){
ns <- NS(id)
selectInput(ns('car_input'), 'Select car:', df$model, multiple = TRUE)
}
Car <- function(input, output, session, ...) {
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
## datatable module ------------------------------------------------------------
DFTableOutput <- function(id){
ns <- NS(id)
DT::dataTableOutput(ns('table'))
}
DFTable <- function(input, output, session, ...){
output$table <- DT::renderDataTable(df)
reactive(car_names[input$table_rows_selected, ])
}
## app -------------------------------------------------------------------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
CarInput('id_car')
),
mainPanel(
DFTableOutput('id_table')
)
)
)
server <- function(input, output, session, ...) {
callModule(Car, 'id_car')
car_rows_selected <<- callModule(DFTable, 'id_table')
}
shinyApp(ui = ui, server = server)
I'm still getting my head around the way module namespaces work - perhaps this isn't the most "correct" approach but at least it works - happy to accept a more appropriate answer if someone posts one later