How to insert multiple images into shiny after click of a button? - r

I created a shiny app which has two buttons as you can see in the following screenshot. I want to display 8 images which I have in this folder in the shiny app after I click the "Show Images" button. I tried using renderImages but couldn't get it to work.
Here is the code I have so far:
ui.R
fluidPage(
# Application title
titlePanel("For Fun!!"),
hr(),
sidebarLayout(
# Sidebar with a slider and selection inputs
sidebarPanel(
actionButton("update", "Print Text"),
hr(),
actionButton("test", "Show Images")
),
mainPanel(
verbatimTextOutput("plot"),
uiOutput("images")
)
)
)
server.r
server <- function(input, output) {
randomVals <- eventReactive(input$update, {
myString="Hello!"
myString
})
output$plot <- renderPrint({
myString=randomVals()
print(myString)
})
}
This is what I'm looking for as an output:
Thanks for your time

Try it like this.
library(shiny)
server <- shinyServer(function(input, output) {
output$files <- renderTable(input$files)
files <- reactive({
files <- input$files
files$datapath <- gsub("\\\\", "/", files$datapath)
files
})
output$images <- renderUI({
if(is.null(input$files)) return(NULL)
image_output_list <-
lapply(1:nrow(files()),
function(i)
{
imagename = paste0("image", i)
imageOutput(imagename)
})
do.call(tagList, image_output_list)
})
observe({
if(is.null(input$files)) return(NULL)
for (i in 1:nrow(files()))
{
print(i)
local({
my_i <- i
imagename = paste0("image", my_i)
print(imagename)
output[[imagename]] <-
renderImage({
list(src = files()$datapath[my_i],
alt = "Image failed to render")
}, deleteFile = FALSE)
})
}
})
})
ui <- shinyUI(fluidPage(
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput(inputId = 'files',
label = 'Select an Image',
multiple = TRUE,
accept=c('image/png', 'image/jpeg'))
),
mainPanel(
tableOutput('files'),
uiOutput('images')
)
)
))
shinyApp(ui=ui,server=server)

Related

About shiny branch processing using outputUI

We are currently developing Shiny APP.
When Option A or Option B is selected from pickerinput
If you select Option A, an open file dialog opens. Then select the text file. When I select a text file, I want the title of the text file to be displayed.
When I select OptionB, I want to display nothing and do nothing.
I wrote a sample codee.
library(shiny)
library(shinyWidgets)
library(shinyFiles)
ui <- fluidPage(
pickerInput(
inputId = "Pi1",
label = "SELECT!!",
choices = list(c("OptionA"),
c("OptionB")),
options = list(`actions-box` = TRUE,size = 7),
multiple = FALSE,
),
uiOutput("button"),
uiOutput("Message")
)
server <- function(input, output, session) {
OutputUi_func(input,output)
observeEvent(input$file, {
volumes <- c("Documents"=Sys.getenv("HOME"))
shinyFileChoose(input,'file', session=session,roots=volumes, filetypes=c('', 'txt'))
if(length(input$file) <= 1) return({})
fname <- unlist(input$file)
fname <- c(fname[2][1])
ftitle <- "FileName:"
fname <- paste0(ftitle,fname)
output$filename <- renderText({
paste0(fname)
})
})
}
OutputUi_func <- function(input,output){
output$button <- renderUI({
req(input$Pi1)
if(input$Pi1 %in% c("OptionA")){
shinyFilesButton('file', 'Read File', 'select file', FALSE)
}else return(NULL)})
output$Message <- renderText({
req(input$Pi1)
if(input$Pi1 %in% c("OptionA")){
textOutput("filename")
}else return(NULL)})
}
shinyApp(ui, server)
The code has a problem.
・When I execute the code, I get an error about "cat".
・ Even if you select a text file,The file title is not displayed.
What should I do to avoid the above two errors?
Try :
library(shiny)
library(shinyWidgets)
library(shinyFiles)
ui <- fluidPage(
pickerInput(
inputId = "Pi1",
label = "SELECT!!",
choices = list(c("OptionA"),
c("OptionB")),
options = list(`actions-box` = TRUE,size = 7),
multiple = FALSE,
),
uiOutput("button"),
uiOutput("Message")
)
server <- function(input, output, session) {
OutputUi_func(input,output)
observeEvent(input$file, {
if(input$Pi1 %in% "OptionB") return(NULL)
volumes <- c("Documents"=Sys.getenv("HOME"))
shinyFileChoose(input,'file', session=session,roots=volumes, filetypes=c('', 'txt'))
if(length(input$file) <= 1) return(NULL)
output$Message <- renderText({
if(length(input$file) <= 1 || input$Pi1 %in% "OptionB") return(NULL)
sprintf("FileName:%s", unlist(input$file$files)[[3]])
})
})
}
OutputUi_func <- function(input,output){
output$button <- renderUI({
if(input$Pi1 %in% "OptionA")
shinyFilesButton('file', 'Read File', 'select file', FALSE)
else return(NULL)
})
}
shinyApp(ui, server)

R shiny observeEvent() cannot isolate the reactivity when input$files parameters changes

I met a problem abount R shiny observeEvent(). I have to upload three csv table files to separately show at different tabpanels. And I set a selectInput to set if to show header of table. At last I give a actionButton(ui)-observeEvent(server) to decide whether to run the showing process. But I find the selectInput just skip the observeEvent(), dynamicly change the show.That is observeEvent is invalidted.I dont'know why.I want selectInput can be under control of actionButton(). I doubt if observeEvent() is a good option to execute the job. Hope somebody can help me! Thanks in advance. Here is my demo code
# get 3 test uploaded files
data(mtcars)
test1 <- mtcars[,c(1:3)]
test2 <- mtcars[,c(5:8)]
test3 <- mtcars[c(1:3),]
write.csv(test1,file = "test1.csv")
write.csv(test2,file = "test2.csv")
write.csv(test3,file = "test3.csv")
# shiny part
library(shiny)
ui <- fluidPage(
# useShinyjs(),
sidebarLayout(
sidebarPanel(
fileInput(
inputId = "files",
label = "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
tags$hr(),
selectInput("type", "Choose Data:", choices = c('Noheader'=TRUE,'Header'=FALSE)),
tags$hr(),
actionButton("update", "show",class = "btn btn-primary btn-lg",icon = icon("refresh"), width = "120px"),
),
mainPanel(
uiOutput("mytabs"),
textOutput("text_null", container = h4)
)
)
)
server <- function(input, output, session){
values <- reactiveValues(file_data=NULL)
filedata <- reactive({
req(input$files)
upload = list()
for(nr in 1:length(input$files[, 1])){
raw_name <- sub(".csv$", "",input$files[[nr, 'name']])
upload[[raw_name]] <- read.csv(file = input$files[[nr, 'datapath']],header = as.logical(input$type))
}
return((upload))
})
observe({
output$mytabs = renderUI({
values$file_data <- filedata()
nTabs <- length(filedata())
tabNames <- names(values$file_data)
myTabs = lapply(1: nTabs, function(i) {
tabPanel( tabNames[i],
tags$div(class = "group-output",
tags$br(),
tableOutput(paste0("Group",i))#))
)
)
})
do.call(tabsetPanel, myTabs)
})
})
observeEvent(input$update, {
values$file_data <- filedata()
nn_Tabs <- length(filedata())
progress <<- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Begin to process data", value = 0)
for (i in 1: nn_Tabs){
local({
my_n <- i
TableName <- paste0("Group",my_n)
output[[TableName]] <- renderTable({ values$file_data[[my_n]] })
print(values$file_data[[my_n]])
progress$inc(1/nn_Tabs, detail = ", Please wait...")
})
}
progress$set(message = "Finished!", value = 1)
})
}
shinyApp(ui, server)
The problem is that you wrap output$mytabs in an observe. I'm not sure why this influences also the content of the output$Group1 etc. you generate in the renderUI call and overrules the observeEvent. Anyway, you don't need the observe, outputs are automatically updated when a dependency changes:
# get 3 test uploaded files
data(mtcars)
test1 <- mtcars[,c(1:3)]
test2 <- mtcars[,c(5:8)]
test3 <- mtcars[c(1:3),]
write.csv(test1,file = "test1.csv")
write.csv(test2,file = "test2.csv")
write.csv(test3,file = "test3.csv")
# shiny part
library(shiny)
ui <- fluidPage(
# useShinyjs(),
sidebarLayout(
sidebarPanel(
fileInput(
inputId = "files",
label = "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
tags$hr(),
selectInput("type", "Choose Data:", choices = c('Noheader'=TRUE,'Header'=FALSE)),
tags$hr(),
actionButton("update", "show",class = "btn btn-primary btn-lg",icon = icon("refresh"), width = "120px"),
),
mainPanel(
uiOutput("mytabs"),
textOutput("text_null", container = h4)
)
)
)
server <- function(input, output, session){
values <- reactiveValues(file_data=NULL)
filedata <- reactive({
req(input$files)
upload = list()
for(nr in 1:length(input$files[, 1])){
raw_name <- sub(".csv$", "",input$files[[nr, 'name']])
upload[[raw_name]] <- read.csv(file = input$files[[nr, 'datapath']],header = as.logical(input$type))
}
return((upload))
})
output$mytabs = renderUI({
values$file_data <- filedata()
nTabs <- length(filedata())
tabNames <- names(values$file_data)
myTabs = lapply(1: nTabs, function(i) {
tabPanel( tabNames[i],
tags$div(class = "group-output",
tags$br(),
tableOutput(paste0("Group",i))#))
)
)
})
do.call(tabsetPanel, myTabs)
})
observeEvent(input$update, {
values$file_data <- filedata()
nn_Tabs <- length(filedata())
progress <<- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Begin to process data", value = 0)
for (i in 1: nn_Tabs){
local({
my_n <- i
TableName <- paste0("Group",my_n)
output[[TableName]] <- renderTable({ values$file_data[[my_n]] })
print(values$file_data[[my_n]])
progress$inc(1/nn_Tabs, detail = ", Please wait...")
})
}
progress$set(message = "Finished!", value = 1)
})
}
shinyApp(ui, server)
Edit
I think this solution is more what you want. Maybe one can optimise the last observe statement to a better coding pattern:
# get 3 test uploaded files
data(mtcars)
test1 <- mtcars[,c(1:3)]
test2 <- mtcars[,c(5:8)]
test3 <- mtcars[c(1:3),]
write.csv(test1,file = "test1.csv")
write.csv(test2,file = "test2.csv")
write.csv(test3,file = "test3.csv")
# shiny part
library(shiny)
ui <- fluidPage(
# useShinyjs(),
sidebarLayout(
sidebarPanel(
fileInput(
inputId = "files",
label = "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
tags$hr(),
selectInput("type", "Choose Data:", choices = c('Noheader'=TRUE,'Header'=FALSE)),
tags$hr(),
actionButton("update", "show",class = "btn btn-primary btn-lg",icon = icon("refresh"), width = "120px"),
),
mainPanel(
uiOutput("mytabs"),
textOutput("text_null", container = h4)
)
)
)
server <- function(input, output, session){
values <- reactiveValues(file_data=NULL)
filedata <- eventReactive(input$update, {
req(input$files)
upload = list()
for(nr in 1:length(input$files[, 1])){
raw_name <- sub(".csv$", "",input$files[[nr, 'name']])
upload[[raw_name]] <- read.csv(file = input$files[[nr, 'datapath']],header = as.logical(input$type))
}
return((upload))
})
output$mytabs = renderUI({
values$file_data <- filedata()
nTabs <- length(filedata())
tabNames <- names(values$file_data)
myTabs = lapply(1: nTabs, function(i) {
tabPanel( tabNames[i],
tags$div(class = "group-output",
tags$br(),
tableOutput(paste0("Group",i))#))
)
)
})
do.call(tabsetPanel, myTabs)
})
observe({
values$file_data <- filedata()
nn_Tabs <- length(filedata())
progress <<- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Begin to process data", value = 0)
for (i in 1: nn_Tabs){
local({
my_n <- i
TableName <- paste0("Group",my_n)
output[[TableName]] <- renderTable({ values$file_data[[my_n]] })
print(values$file_data[[my_n]])
progress$inc(1/nn_Tabs, detail = ", Please wait...")
})
}
progress$set(message = "Finished!", value = 1)
})
}
shinyApp(ui, server)

Show a tabPanel in popup window or modalDialog

I need some help I want to show my reactive tabPanel in a popup with the shinyBS package.
Everything seems to work well except the creation of popup.
I am inspired by :
1) R Shiny - add tabPanel to tabsetPanel dynamically (with the use of renderUI)
2)Show dataTableOutput in modal in shiny app
My code :
library(shiny)
library(DT) # need datatables package
library(shinyBS)
ui <- shinyUI(fluidPage(
titlePanel("Example"),
sidebarLayout(
sidebarPanel(
selectInput("decision", label = "Choose your specie",
choices = iris$Species,
selected = "mtcars", multiple = TRUE)
),
mainPanel(
uiOutput('mytabs')
)
)
))
server <- shinyServer(function(input, output, session) {
output$mytabs <- renderUI({
nTabs = length(input$decision)
# create tabPanel with datatable in it
myTabs = lapply(seq_len(nTabs), function(i) {
tabPanel(paste0("dataset_", input$decision[i]),
tableOutput(paste0("datatable_",i))
)
})
do.call(tabsetPanel, myTabs)
})
# create datatables in popup ?
bsModal(
id = "modalExample",
"yb",
observe(
lapply(seq_len(length(input$decision)), function(i) {
output[[paste0("datatable_",i)]] <- renderTable({
as.data.frame(iris[iris$Species == input$decision[i], ])
})
})
)
)
})
shinyApp(ui, server)
Thanks in advance for any help !
bsModal is an UI element, so you need to put it into you UI. Within this modal you want to show the tabPanels (rendered via uiOutput), so all you need to do is to place your bsModal into the UI, and within this bsModal you have your uiOutput. All what is left is to add an actionButton which shows the modal.
library(shiny)
library(shinyBS)
ui <- shinyUI(fluidPage(
titlePanel("Example"),
sidebarLayout(
sidebarPanel(
selectInput("decision", label = "Choose your species",
choices = unique(iris$Species),
selected = unique(iris$Species), multiple = TRUE),
actionButton("show", "Show")
),
mainPanel(
bsModal("modalExample",
"myTitle",
"show",
uiOutput('mytabs')
)
)
)
))
server <- shinyServer(function(input, output, session) {
output$mytabs <- renderUI({
nTabs <- length(input$decision)
# create tabPanel with datatable in it
myTabs <- lapply(seq_len(nTabs), function(i) {
tabPanel(paste0("dataset_", input$decision[i]),
tableOutput(paste0("datatable_",i))
)
})
do.call(tabsetPanel, myTabs)
})
# create datatables in popup ?
observe(
lapply(seq_len(length(input$decision)), function(i) {
output[[paste0("datatable_",i)]] <- renderTable({
as.data.frame(iris[iris$Species == input$decision[i], ])
})
})
)
})
shinyApp(ui, server)
It's not clear to me what you want to do (maybe #thothal has the right answer). What about this app ?
library(shiny)
library(DT) # need datatables package
library(shinyBS)
ui <- shinyUI(fluidPage(
titlePanel("Example"),
sidebarLayout(
sidebarPanel(
selectInput("decision", label = "Choose your specie",
choices = iris$Species,
selected = "mtcars", multiple = TRUE),
actionButton("trigger_modal", "View modal")
),
mainPanel(
uiOutput("modal")
# uiOutput('mytabs')
)
)
))
server <- shinyServer(function(input, output, session) {
# output$mytabs <- renderUI({
# nTabs = length(input$decision)
# # create tabPanel with datatable in it
# myTabs = lapply(seq_len(nTabs), function(i) {
# tabPanel(paste0("dataset_", input$decision[i]),
# tableOutput(paste0("datatable_",i))
# )
# })
#
# do.call(tabsetPanel, myTabs)
# })
# create datatables in popup ?
observe(
lapply(seq_len(length(input$decision)), function(i) {
output[[paste0("datatable_",i)]] <- renderTable({
as.data.frame(iris[iris$Species == input$decision[i], ])
})
})
)
output$modal <- renderUI({
bsModal(
id = "modalExample",
"yb",
trigger = "trigger_modal",
do.call(tagList, lapply(seq_along(input$decision), function(i){
tableOutput(paste0("datatable_",i))
}))
)
})
})
shinyApp(ui, server)

Shiny/shinydashboard: Dynamic Number of Output Elements/valueBoxes

I'm currently trying to set up a UI that is creating valueBoxes dynamically.
I' picked up the code shown here which does exactly what I want, but using plots.
Actually the following works, but the boxes aren't rendered as expected:
library(shiny)
library(shinydashboard)
ui <- pageWithSidebar(
headerPanel("Dynamic number of valueBoxes"),
sidebarPanel(
selectInput(inputId = "choosevar",
label = "Choose Cut Variable:",
choices = c("Nr. of Gears"="gear", "Nr. of Carburators"="carb"))
),
mainPanel(
# This is the dynamic UI for the plots
uiOutput("plots")
)
)
server <- function(input, output) {
#dynamically create the right number of htmlOutput
# renderUI
output$plots <- renderUI({
plot_output_list <- lapply(unique(mtcars[,input$choosevar]), function(i) {
plotname <- paste0("plot", i)
# valueBoxOutput(plotname)
htmlOutput(plotname)
})
tagList(plot_output_list)
})
# Call renderPlot for each one. Plots are only actually generated when they
# are visible on the web page.
for (i in 1:max(unique(mtcars[,"gear"]),unique(mtcars[,"carb"]))) {
local({
my_i <- i
plotname <- paste0("plot", my_i)
output[[plotname]] <- renderUI({
valueBox(
input$choosevar,
my_i,
icon = icon("credit-card")
)
})
})
}
}
# Run the application
shinyApp(ui = ui, server = server)
Thanks for any hints!
You are mixing shinydashboard elements with normal shiny-uis. You have to create a dashboard-ui, as the valueboxes are for dashboards.
The following should work:
library(shiny)
library(shinydashboard)
ui = dashboardPage(
dashboardHeader(title = "Dynamic number of valueBoxes"),
dashboardSidebar(
selectInput(inputId = "choosevar",
label = "Choose Cut Variable:",
choices = c("Nr. of Gears"="gear", "Nr. of Carburators"="carb"))
),
dashboardBody(
uiOutput("plots")
)
)
server <- function(input, output) {
#dynamically create the right number of htmlOutput
# renderUI
output$plots <- renderUI({
plot_output_list <- lapply(unique(mtcars[,input$choosevar]), function(i) {
plotname <- paste0("plot", i)
valueBoxOutput(plotname)
# htmlOutput(plotname)
})
tagList(plot_output_list)
})
# Call renderPlot for each one. Plots are only actually generated when they
# are visible on the web page.
for (i in 1:max(unique(mtcars[,"gear"]),unique(mtcars[,"carb"]))) {
local({
my_i <- i
plotname <- paste0("plot", my_i)
output[[plotname]] <- renderUI({
valueBox(
input$choosevar,
my_i,
icon = icon("credit-card")
)
})
})
}
}
# Run the application
shinyApp(ui = ui, server = server)

Dynamically display images from upload in Shiny UI

This is pretty much the same question as presented here:
dynamically add plots to web page using shiny
But instead of producing a variable number of plots (which I've successfully done), I am trying to upload a selection of images into the application and display them on the user interface. Using the same approach as described in the question above, I've produced my application with the code below. But only the first image is rendering in the UI.
What obvious thing have I missed today?
R 3.2.2 (Windows 7)
shiny 0.12.2
server.R
library(shiny)
shinyServer(function(input, output) {
output$files <- renderTable(input$files)
files <- reactive({
files <- input$files
files$datapath <- gsub("\\\\", "/", files$datapath)
files
})
output$images <- renderUI({
image_output_list <-
lapply(seq_along(nrow(files())),
function(i)
{
imagename = paste0("image", i)
imageOutput(imagename)
})
do.call(tagList, image_output_list)
})
observe({
for (i in seq_along(nrow(files())))
{
local({
my_i <- i
imagename = paste0("image", my_i)
output[[imagename]] <-
renderImage({
list(src = files()$datapath[my_i],
alt = "Image failed to render")
}, deleteFile = FALSE)
})
}
})
})
ui.R
library(shiny)
shinyUI(fluidPage(
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput(inputId = 'files',
label = 'Select an Image',
multiple = TRUE,
accept=c('image/png', 'image/jpeg'))
),
mainPanel(
tableOutput('files'),
uiOutput('images')
)
)
))
Your so close! Try this:
library(shiny)
server <- shinyServer(function(input, output) {
output$files <- renderTable(input$files)
files <- reactive({
files <- input$files
files$datapath <- gsub("\\\\", "/", files$datapath)
files
})
output$images <- renderUI({
if(is.null(input$files)) return(NULL)
image_output_list <-
lapply(1:nrow(files()),
function(i)
{
imagename = paste0("image", i)
imageOutput(imagename)
})
do.call(tagList, image_output_list)
})
observe({
if(is.null(input$files)) return(NULL)
for (i in 1:nrow(files()))
{
print(i)
local({
my_i <- i
imagename = paste0("image", my_i)
print(imagename)
output[[imagename]] <-
renderImage({
list(src = files()$datapath[my_i],
alt = "Image failed to render")
}, deleteFile = FALSE)
})
}
})
})
ui <- shinyUI(fluidPage(
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput(inputId = 'files',
label = 'Select an Image',
multiple = TRUE,
accept=c('image/png', 'image/jpeg'))
),
mainPanel(
tableOutput('files'),
uiOutput('images')
)
)
))
shinyApp(ui=ui,server=server)
I changed seq_along to just 1:nrow(files()) but seq_len(nrow(files())) or seq_along(t(files())) would work to.

Resources