Separating fileInput from radioButtons into shiny code - r

When running the code below, you will notice that I have two options below. If you press the Excel option, a fileInput will appear right below the radioButtons. However, I would like to know if it is possible to separate fileInput from radioButtons. I will insert an image to clarify what I want. See that they are separated.
Executable code below:
library(shiny)
library(dplyr)
library(shinyjs)
library(shinythemes)
library(readxl)
ui <- fluidPage(
shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel("PAGE1",
sidebarLayout(
sidebarPanel(
radioButtons("button",
label = h3("Data source"),
choices = list("Excel" = "Excel",
"Database" = "database"),
selected = "File"),
uiOutput('fileInput'),
),
mainPanel(
)))))
server <- function(input, output) {
observe({
if(is.null(input$button)) {
}else if (input$button =="Excel"){
output$fileInput <- renderUI({
fileInput("file",h4("Import file"), multiple = T, accept = ".xlsx")
})
} else if(input$button=="database"){
output$fileInput <- NULL
} else {
output$fileInput <- NULL
}
})
}
shinyApp(ui = ui, server = server)
Example:
I left it in red to specify the space

A possible workaround could be to use fluidRow with two columns to simulating a sidebarPanel with a mainPanel.
Notice that I wrapped the inputs in a div(class = "well well-lg") for the background.
App
library(shiny)
library(dplyr)
library(shinyjs)
library(shinythemes)
library(readxl)
ui <- navbarPage(
theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel(
"PAGE1",
fluidRow(
column(
width = 6,
fluidRow(div(
class = "well well-lg",
radioButtons("button",
label = h3("Data source"),
choices = list(
"Excel" = "Excel",
"Database" = "database"
),
selected = "File"
)
)),
fluidRow(
uiOutput("fileInput")
)
),
column(
width = 6,
tableOutput("iris")
)
)
)
)
server <- function(input, output) {
output$iris <- renderTable({
iris
})
observe({
if (is.null(input$button)) {
} else if (input$button == "Excel") {
output$fileInput <- renderUI({
div(class = "well well-lg", fileInput("file", h4("Import file"), multiple = T, accept = ".xlsx"))
})
} else if (input$button == "database") {
output$fileInput <- NULL
} else {
output$fileInput <- NULL
}
})
}
shinyApp(ui = ui, server = server)

Related

How to wrap up Image as a floating window in R shiny

I want to develop a feature that when opening the switch the image can show outside of the page and when closing the switch, the image is hidden. Here is my sample code for showing/hiding the image in the page but if we can make the image be a floating window and can be moved around the exiting app page?
library("shinydashboard")
library("shinyWidgets")
ui <- fluidPage(
h4("Embedded image"),
uiOutput("img"),
fluidRow(
tags$h4("Show and Hide Image"),
materialSwitch(
inputId = "get_image",
label = "Show Image",
value = FALSE,
status = "success"
),
),
)
server <- function(input, output, session) {
observeEvent(input$get_image, {
if(input$get_image == TRUE){
output$img <- renderUI({
tags$img(src = "https://www.r-project.org/logo/Rlogo.png")
})
}else{
output$img <- NULL
}
})
}
shinyApp(ui, server)
Something like this?
library(shiny)
library("shinydashboard")
library("shinyWidgets")
ui <- fluidPage(
h4("Embedded image"),
uiOutput("img"),
fluidRow(
tags$h4("Show and Hide Image"),
materialSwitch(
inputId = "get_image",
label = "Show Image",
value = FALSE,
status = "success"
),
),
)
server <- function(input, output, session) {
output$img <- renderUI({
if(input$get_image)
absolutePanel(
tags$img(src = "https://www.r-project.org/logo/Rlogo.png", width = "512"),
draggable = TRUE
)
})
}
shinyApp(ui, server)

How to solve encoding issues in a shiny app

Any tips to solve encoding problem. I am not able to generate the up (↑) and down (↓) arrows in the code below. When running, the following warning message appears:
Warning messages:
1: unable to translate 'Maximize <U+2191>' to native encoding
2: unable to translate 'Minimize <U+2193>' to native encoding
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
column(
width = 6,
selectInput("maxmin", label = h5("Maximize or Minimize"),
choices = list("Maximize \u2191" = 1, "Minimize \u2193" = 2), selected = "")
)
)),
mainPanel(
))
)
server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)
You can use HTML code for the arrows and proceed like this:
library(shiny)
choicesNames <- list("Minimize", "Maximize")
choicesHTML <- list("Minimize ↓", "Maximize ↑")
choices <- setNames(choicesNames, choicesHTML)
ui <- fluidPage(
selectizeInput("select", label = "Select", choices = NULL),
textOutput("txt")
)
server <- function(input, output, session) {
updateSelectizeInput(
session, "select",
choices = choices,
options = list(render = I("
{
item: function(item, escape) { return '<div>' + item.label + '</div>'; },
option: function(item, escape) { return '<div>' + item.label + '</div>'; }
}
"))
)
output$txt <- renderText({
paste("You chose", input$select)
})
}
shinyApp(ui, server)
Another option is to use my package shinySelect and fontawesome icons for the arrows.
library(shiny)
library(shinySelect)
library(bslib)
library(fontawesome)
choices <- HTMLchoices(
labels = list(
tags$span("Minimize", fa_i("arrow-alt-circle-down")),
tags$span("Maximize", fa_i("arrow-alt-circle-up"))
),
values = list("minimize", "maximize")
)
styles <- list(
borderBottom = "5px solid orange",
color = list(selected = "lime", otherwise = "pink"),
backgroundColor = list(selected = "cyan", otherwise = "seashell")
)
ui <- fluidPage(
theme = bs_theme(version = 4),
titlePanel("shinySelect example"),
selectControlInput(
"inputid",
label = tags$h1("Make a choice", style = "color: red;"),
optionsStyles = styles,
choices = choices,
selected = "minimize",
multiple = FALSE,
animated = TRUE
),
br(),
verbatimTextOutput("textOutput")
)
server <- function(input, output, session) {
output$textOutput <- renderPrint({
sprintf("You selected: %s", input$inputid)
})
}
shinyApp(ui, server)
This is an alternate solution. Solutions provided by #Stephane Laurent are great. To translate unicode points to UTF-8, you can use chr_unserialise_unicode() from rlang package. Try this
library(shiny)
library(rlang)
ll <- chr_unserialise_unicode("<U+2193>")
uu <- chr_unserialise_unicode("<U+2191>")
choicesNames <- list(1,2)
choiceValues <- list(sprintf("Minimize %s",ll),sprintf("Maximize %s",uu))
choices <- setNames(choicesNames, choiceValues)
ui <- fluidPage(
selectInput("maxmin", label = h5("Maximize or Minimize"), choices = NULL),
textOutput("mytxt")
)
server <- function(input, output, session) {
updateSelectInput(session, "maxmin", choices = choices )
output$mytxt <- renderText({
paste("You chose", input$maxmin)
})
}
shinyApp(ui = ui, server = server)

Shiny App: Adding unlimited number of input bars

I want to build an app in which the user can add as many as input slots as he wants. I could only build an app that let the user to add only one more input slot. Here is my code:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput("a", "Something", choices = "blah blah"),
uiOutput("b"),
actionButton(inputId = "rm", label = "-"),
actionButton(inputId = "add", label = "+"),
),
mainPanel(
textOutput("test")
)
)
)
server <- function(input, output) {
observeEvent(input$add ,{
output$b <- renderUI({
selectizeInput("b", "Another thing", choices = "blah blah")
})
})
observeEvent(input$rm ,{
output$b <- renderUI({
NULL
})
})
}
shinyApp(ui = ui, server = server)
I have no idea how I can extend this to let the user add as many as input slots as he wants. Is this even possible?
We can try this approach:
We can access new added inputs with input$a1, input$a2 ... input$ax
Edit: added an observer to see the new inputs generated in the console. The first input created after pressing + button will be called input$a1.
observe({
print(names(input))
print(input$a1)
})
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput("a", "Something", choices = "blah blah"),
actionButton(inputId = "rm", label = "-"),
actionButton(inputId = "add", label = "+"),
),
mainPanel(
textOutput("test")
)
)
)
server <- function(input, output) {
input_counter <- reactiveVal(0)
observeEvent(input$add, {
input_counter(input_counter() + 1)
insertUI(
selector = "#rm", where = "beforeBegin",
ui = div(id = paste0("selectize_div", input_counter()), selectizeInput(paste0("a", input_counter()), label = "Another thing", choices = c("bla", "blabla")))
)
})
observeEvent(input$rm, {
removeUI(
selector = paste0("#selectize_div", input_counter())
)
input_counter(input_counter() - 1)
})
observe({
print(names(input))
print(input$a1)
})
}
shinyApp(ui, server)

Is it possible to clear the displayed output in ShinyApp using actionButton

I'm building a shinyApp on mtcars data. I got 2 actionButtons (Go & Clear).
The Go button is for displaying the output on mainPanel whereas the Clear button is for clearing that output.
My Clear button isn't working due to some unforeseen reason. Can somebody please have a look at my codes. I shall be extremely grateful.
library(shiny)
library(DT)
library(dplyr)
library(shinythemes)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear")),
mainPanel(
DT::dataTableOutput('mytable') )))
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- eventReactive(input$go,{
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
data_table
})
# thedata <- eventReactive(input$reset,{
# data_table<-NULL
# })
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server)
insertUI() and removeUI() is what you might be looking for.
Removing the element is easier with removeUI():
observeEvent(input$reset, {
removeUI("#mytable")
})
To avoid that you dont delete it permanently you could use insertUI():
observeEvent(input$go, {
insertUI("#placeholder", "afterEnd", ui = DT::dataTableOutput('mytable'))
})
In order to place the element correctly you can use a placeholder in the mainPanel():
mainPanel(
tags$div(id = "placeholder")
)
Then you could remove the dependency of thedata() from the input button, since you use the insertUI() now. (You should swith to insertUI(), because otherwise you cant re-insert the table once its deleted without it,...)
thedata <- reactive({
...
})
Full example would read:
library(shiny)
library(DT)
library(dplyr)
library(shinythemes)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear")),
mainPanel(
tags$div(id = "placeholder")
)
)
)
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- reactive({
input$go
isolate({
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
return(data_table)
})
})
observeEvent(input$reset, {
removeUI("#mytable")
})
observeEvent(input$go, {
insertUI("#placeholder", "afterEnd", ui = DT::dataTableOutput('mytable'))
})
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server)
)
Why not inject some javascript? This way, your code is kept virtually unchanged.
Create a js file in your shiny folder with the following code (rmDt.js in this example):
$("#reset").click(function() {
$(".display.dataTable.no-footer").DataTable().destroy();
$(".display.dataTable.no-footer").DataTable().clear().draw();
$(".display.no-footer").DataTable().destroy();
$(".display.no-footer").DataTable().clear().draw();
});
Save this file and then inject it in your shiny R script:
library(shiny)
library(DT)
library(dplyr)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear"),
includeScript(path ="rmDt.js") # inject javascript
),
mainPanel(
DT::dataTableOutput('mytable') ))
)
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- eventReactive(input$go,{
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
data_table
})
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server, options = list(launch.browser = T))

updateTabsetPanel not working

Does anyone know why this simple code is not working?
What I am trying to do: make the structure tab active whenever users click on the run button (input$runButton). When I click the run button, the value of input$runButton gets updated, but the tab is not changed to structure.
Here is a simple reproducible example:
server.R
function(input, output, session) {
#RUN button
observeEvent(input$runButton, {
updateTabsetPanel(session, "allResults", 'structure')
})
#VAR SELECTION
output$inputVars <- renderText({
if (input$runButton == 0)
return()
print("Vars Selected")
})
#STRUCTURE RESULT
output$structure <- renderText({
if (input$runButton == 0)
return()
print("Structure Results")
})
}
ui.R
fluidPage(
titlePanel("Periscope Structure"),
br(),
sidebarPanel(
fileInput(inputId="inFile", "Choose CSV File",
accept = c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
checkboxInput("header", "Header", TRUE),
numericInput("level", "Structure Level", 3, min = 2, max = 10),
br(),
actionButton("runButton", strong("Run!"))
),
mainPanel(
tabsetPanel(id = "allResults",
tabPanel('Variable Selection', textOutput('inputVars')),
tabPanel('Structure Result', textOutput('structure')))
)
)
Thank you!
Note that you need to assign a value to TabPanel so you can make them active using the updateTabsetPanel call, so try this:
require(shiny)
ui <- fluidPage(
titlePanel("Periscope Structure"),
br(),
sidebarPanel(
fileInput(inputId="inFile", "Choose CSV File",
accept = c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
checkboxInput("header", "Header", TRUE),
numericInput("level", "Structure Level", 3, min = 2, max = 10),
br(),
actionButton("runButton", strong("Run!"))
),
mainPanel(
tabsetPanel(id = "allResults",
tabPanel(value = "inputVars",'Variable Selection', textOutput('inputVars')),
tabPanel(value = "structure",'Structure Result', textOutput('structure')))
)
)
server <- function(input, output, session) {
#RUN button
observeEvent(input$runButton, {
updateTabsetPanel(session, "allResults", 'structure')
})
#VAR SELECTION
output$inputVars <- renderText({
if (input$runButton == 0)
return()
print("Vars Selected")
})
#STRUCTURE RESULT
output$structure <- renderText({
if (input$runButton == 0)
return()
print("Structure Results")
})
}
runApp(shinyApp(ui, server), launch.browser = TRUE)
Note that if you are using shiny modules, that you have to refer to the correct session. For example, if a single tab is a module, the session of that tab won't be able to switch to another tab
To fix this, you can actually pass the session of the "parent" (container) of all your tabs into the constructor of the tab module, and then use that
Rough sketch of an example
shinyUI(function(request) {
source('page/search.R', local = T)
source('page/app.R', local = T)
fluidPage(
tabsetPanel(id = 'inTabset',
tabPanel(id = 'search', 'Search', searchUI('search'), value = 'search'),
tabPanel(id = 'app', 'App', appUI('app'), value = 'app')
)
)
})
shinyServer(function(input, output, session) {
source('page/search.R', local = T)
source('page/app.R', local = T)
searchSession = callModule(searchServer, 'search')
callModule(appServer, 'app', session, searchSession)
})
The shiny module
appUI = function(id) {
ns = NS(id)
tagList(
actionButton(ns('sendToHeatmap'), 'Send ortholog groups to heatmap')
)
}
appServer = function(input, output, session, parentSession, searchSession) {
# listen to a button press and switch to tab
observeEvent(input$sendToSearch, {
updateTextInput(searchSession, 'searchBox', 'funsearchterm')
updateTabsetPanel(parentSession, 'inTabset', selected = 'search')
})
}

Resources