I would like to have a custom URL generated in shinyapps.IO (or willing to upgrade to appropriate Enterprise tools) based on value selected by selectInput(). In the example below, if I publish to shinyapps.IO, the URL will be https://myDomain.shinyapps.io/myAppName/.
I would like 5 unique URLs, based on the user-selected option from selectInput().
https://myDomain.shinyapps.io/myAppName/Option1
https://myDomain.shinyapps.io/myAppName/Option2
https://myDomain.shinyapps.io/myAppName/Option3
https://myDomain.shinyapps.io/myAppName/Option4
https://myDomain.shinyapps.io/myAppName/Option5
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(tidyverse)
#################### UI ###################
ui <- dashboardPagePlus(
###### Header ####
header = dashboardHeaderPlus(
title = NULL,
titleWidth = '250',
disable = FALSE,
enable_rightsidebar = FALSE,
.list = NULL,
left_menu = tagList(
selectInput(
inputId = "options",
label = "Select an option",
choices = c('Option1', 'Option2', 'Option3', 'Option4', 'Option5'))
) #end left_menu
), #close Header
###### Sidebar ####
sidebar = dashboardSidebar(disable = TRUE),
footer = dashboardFooter(NULL),
###### Body ####
body = dashboardBody(
uiOutput('optionSelected')
) #close dashboardBody
) # closes Dashboard Page Plus
#################### SERVER ####################
server = function(input, output, session) {
output$optionSelected <- renderUI({
input$options
}
)
}
shinyApp(ui = ui, server = server)
I have read about 'Vanity URLs' at https://community.rstudio.com/t/vanity-urls-with-connect-via-deployapp/18927/4, but this does not quite seem like the solution that I am seeking.
Thank for any advice.
Like i mentioned in the comment, i think you are looking for bookmarking, see ?shiny::enableBookmarking().
For bookmarking you have to make three modifications to your code. Make
the ui code a function
ui <- function(request){...}
include a bookmark trigger/button in your ui
bookmarkButton()
Enable bookmarking before you launch the app.
enableBookmarking("url")
Minimal reproducible example would be:
ui <- function(request) {
fluidPage(
selectInput("options", "opt", choices = c('Option1', 'Option2')),
bookmarkButton()
)
}
server <- function(input, output, session) { }
enableBookmarking("url")
shinyApp(ui, server)
Automating the generation of urls
port_nr <- 3033
input_id <- "select_opt"
choices <- c('Option1', 'Option2')
paste0("http://127.0.0.1:", port_nr, "/?_inputs_&", input_id, "=",
URLencode(choices, reserved = TRUE))
Your example would read:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
ui <- function(request) {
dashboardPagePlus(
###### Header ####
header = dashboardHeaderPlus(
title = NULL,
titleWidth = '250',
disable = FALSE,
enable_rightsidebar = FALSE,
.list = NULL,
left_menu = tagList(
selectInput(
inputId = "options",
label = "Select an option",
choices = c('Option1', 'Option2', 'Option3', 'Option4', 'Option5'))
) #end left_menu
), #close Header
###### Sidebar ####
sidebar = dashboardSidebar(disable = TRUE),
footer = dashboardFooter(NULL),
###### Body ####
body = dashboardBody(
uiOutput('optionSelected'),
bookmarkButton()
) #close dashboardBody
) # closes Dashboard Page Plus
}
#################### SERVER ####################
server = function(input, output, session) {
output$optionSelected <- renderUI({
input$options
}
)
}
enableBookmarking("url")
shinyApp(ui = ui, server = server)
Related
I'd like to use shinyWidgets::materialSwitch instead of a checkbox in my app for an improved UI.
However, I can't seem to get materialSwitch to work when used with renderUI/uiOutput. The input displays properly but doesn't seem to register a click to "switch".
For the purposes of my app - I need this to be inside a renderUI.
Pkg Versions:
shinyWidgets_0.7.2
shiny_1.7.2
library(shiny)
library(shinyWidgets)
# library(shinyjs)
ui <- fluidPage(
div(class="row",
column(width = 3,
uiOutput("switch")
)
)
)
server <- function(input, output, session) {
output$switch = renderUI({
materialSwitch(
inputId = "switch",
label = "Show Count",
right = TRUE,
status = "primary",
value = FALSE
)
})
}
shinyApp(ui = ui, server = server)
Why is this happening, and how can the problem be fixed?
The issue is that you give same name "switch" to both uiOutput.outputId and materiaSwitch.inputId.
It works OK when they get different ids:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
div(class="row",
column(width = 3,
uiOutput("switch"),
textOutput("result")
)
)
)
server <- function(input, output, session) {
output$switch = renderUI({
materialSwitch(
inputId = "switchButton",
label = "Show Count",
right = TRUE,
status = "primary",
value = FALSE
)
})
output$result = renderText(input$switchButton)
}
shinyApp(ui = ui, server = server)
Here is how it should work:
library(shiny)
library(shinyWidgets)
# library(shinyjs)
ui <- fluidPage(
div(style = 'position: absolute;left: 50px; top:100px; width:950px;margin:auto',
materialSwitch(inputId = "switch",
label = "Show Count",
right = TRUE,
status = "primary",
value = FALSE)
)
)
server <- function(input, output, session) {
output$value1 <- renderText({ input$switch })
}
shinyApp(ui = ui, server = server)
Im trying to limit the max number of choices made by pickerInput() to two in shiny app but I cannot make it work.
library(shiny)
library(shinydashboard)
library(plotly)
library(shinyWidgets)
header <- dashboardHeader()
sidebar <- dashboardSidebar(
fluidRow(column(12,
pickerInput(
inputId = "iss",
label = "Issue",
choices = colnames(mtcars),
multiple = T,
options = list("max-options-group" = 2)
)
))
)
body <- dashboardBody(fluidPage(
)
)
ui <- dashboardPage(title = 'Search', header, sidebar, body)
server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)
The problem is that you are using "max-options-group" but you are not using any groups in your choices. You must use "max-options" = 2 in the options argument of pickerInput().
For completeness, this is the modified version of your code. We cannot pick more than 2 options with it:
library(shiny)
library(shinydashboard)
library(plotly)
library(shinyWidgets)
header <- dashboardHeader()
sidebar <- dashboardSidebar(
fluidRow(column(12,
pickerInput(
inputId = "iss",
label = "Issue",
choices = colnames(mtcars),
multiple = T,
options = list("max-options" = 2)
)
))
)
body <- dashboardBody(fluidPage(
)
)
ui <- dashboardPage(title = 'Search', header, sidebar, body)
server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)
Try this
columns <- as.list(names(mtcars))
type <- as.list(1:ncol(mtcars))
header <- dashboardHeader()
sidebar <- dashboardSidebar(
fluidRow(column(12,
pickerInput(
inputId = "iss",
label = "Issue",
choices = list(Columns = columns,
Type = type),
selected = list(columns[[1]],type[[1]]),
multiple = T,
inline=TRUE,
options = list("max-options-group" = 1, `style` = "btn-info")
)
))
)
body <- dashboardBody(fluidPage())
ui <- dashboardPage(title = 'Search', header, sidebar, body)
server <- function(input, output, session) {}
shinyApp(ui = ui, server = server)
I am creating ShinyDashboard which reads the csv file inputted by user and displays 2 plots at the top and datatable at the bottom of dashboards. For this I used box to built my Dashboard. Next, I would like create popup for each boxes so the box output displays bigger in size to the enduser. For this I am following the post mentioned here. However, whenever I use ModalDialog under ui code as suggested by Pork Chop. The table output doesn't return anything. Not sure if I am using ModalDialog correctly ? Below is my ui and server code.
Thank in advance for help and effort!
ui
library(shiny)
library(shinydashboard)
library(dplyr)
library(ggplot2)
library(shinyBS)
library(DT)
ui<-dashboardPage(
dashboardHeader(title="Missing",titleWidth = 230),
dashboardSidebar(
fileInput("file1", "Upload CSV File below",
accept = c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv")
)),
dashboardBody(
fluidRow(
box(plotOutput("Plot1"),collapsible = TRUE,title="Columns ",solidHeader = TRUE,status = "primary"),
box(plotOutput("Plot2"),collapsible=TRUE,title="Columns data Type",solidHeader = TRUE,status = "primary"),
fluidRow(column(width=12,box( bsModal("modalExample", "Data Table", "My_datatable", size = "large",dataTableOutput("My_datatable")),width = NULL,collapsible = TRUE))
)
)
)
)
Server:
server<- function(input, output,session) {
output$Plot1 <- renderPlot({
plot(cars)
})
output$Plot2 <- renderPlot({ plot(pressure)})
output$My_datatable <- renderDT({iris[1:7,]})
}
# Run the application
shinyApp(ui = ui, server = server)
As shown in the answer you need to wrap each item you want to popout in a div() and give an id. Then use that id to popout and display what you wish. Try this
library(shiny)
library(shinydashboard)
library(dplyr)
library(ggplot2)
library(shinyBS)
library(DT)
#library(visdat)
ui<-dashboardPage(
dashboardHeader(title="Missing",titleWidth = 230),
dashboardSidebar(
fileInput("file1", "Upload CSV File below",
accept = c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv")
)),
dashboardBody(
fluidRow(
div(id="popme1", box(plotOutput("Plot1"),collapsible = TRUE,title="Columns with null",solidHeader = TRUE,status = "primary")),
bsModal("modalExample1", "Plot1", "popme1", size = "large", plotOutput("Plot11")),
div(id="popme2", box(plotOutput("Plot2"),collapsible=TRUE,title="Data Types of columns",solidHeader = TRUE,status = "primary")),
bsModal("modalExample2", "Plot2", "popme2", size = "large", plotOutput("Plot22")),
div(id="popme3", fluidRow(column(width=8,box(DTOutput("Missing_datatable"), width = NULL,collapsible = TRUE)) )),
bsModal("modalExample3", "Data Table", "popme3", size = "large", DTOutput("Missing_datatable2"))
)
)
)
server<- function(input, output,session) {
output$Plot1 <- renderPlot({
plot(cars)
})
output$Plot11 <- renderPlot({
plot(cars)
})
output$Plot22 <- renderPlot({ plot(pressure)})
output$Plot2 <- renderPlot({ plot(pressure) })
output$Missing_datatable <- renderDT({iris[1:7,]})
output$Missing_datatable2 <- renderDT({iris[1:7,]})
}
# Run the application
shinyApp(ui = ui, server = server)
I have the shiny app below in which I create tab panels based on a column of a dataframe. Then based on the radiobutton selected I display either a plot ot a table of either iris or mtcars datasets.
The issue is that if for example Im in Table mode of mtcars dataset and press the Plot mode I want to remain to the mtcars panel and see the mtcars plot instead of moving back to the iris panel. How could I achieve that?
Uni<-data.frame(NAME=c("Iris","Mtcars"))
# app.R ##
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(DT)
dbHeader <- dashboardHeaderPlus(
title = "Tabs"
)
ui <- dashboardPagePlus(
dbHeader,
dashboardSidebar(
uiOutput("r")
),
dashboardBody(
useShinyjs(),
tags$hr(),
tabsetPanel(
id ="tabA",
type = "tabs",
tabPanel("Front",icon = icon("accusoft")),
tabPanel("Data", icon = icon("table"),
uiOutput("dyntab")
)
)
)
)
server <- function(input, output) {
output$dyntab<-renderUI({
do.call(tabsetPanel,
c(id='tabB',
type="tabs",
lapply(1:nrow(Uni), function(i) {
tabPanel(Uni[i,],icon = icon("table"),
if(input$radioV2=="Table"){
renderDataTable({
if(input$tabB=="Iris"){
datatable(iris)
}
else{
datatable(mtcars)
}
})
}
else{
renderPlot({
if(input$tabB=="Iris"){
plot(iris)
}
else{
plot(mtcars)
}
})
}
)
}))
)
})
output$r<-renderUI({
if(input$tabA=="Front"){
return(NULL)
}
else{
radioButtons("radioV2", label = "Choose Mode",
choices = c("Table","Plot"),
selected = "Table")
}
})
}
shinyApp(ui = ui, server = server)
You had a few things going on, one is that the creation of dyntab was happening every time you change a tab, which is now been fixed to render only once on start
We shall take advantage of the shinyjs with its show and hide functions to show the radioButtons instead of creating it all the time with renderUI
Im still not 100% on the using the above approach in the dyntab as you can see I had to create the id for the div in order to show and hide it, this happens because it assigns random idto the tables and the charts you're rendering
I've also took advantage of hidden function to hide the div upon start
Uni <- data.frame(NAME=c("Iris","Mtcars"))
options(stringsAsFactors = F)
# app.R ##
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(DT)
dbHeader <- dashboardHeaderPlus(
title = "Tabs"
)
ui <- dashboardPagePlus(
dbHeader,
dashboardSidebar(
hidden(
radioButtons("radioV2", label = "Choose Mode",choices = c("Table","Plot"), selected = "Table")
)
),
dashboardBody(
useShinyjs(),
tags$hr(),
tabsetPanel(
id ="tabA",
type = "tabs",
tabPanel("Front",icon = icon("accusoft")),
tabPanel("Data", icon = icon("table"), uiOutput("dyntab")
)
)
)
)
server <- function(input, output, session) {
observeEvent(input$tabA,{
if(input$tabA == "Front"){
hide("radioV2")
}
else{
show("radioV2")
}
})
output$dyntab <- renderUI({
do.call(tabsetPanel,
c(id='tabB',
type="tabs",
lapply(1:nrow(Uni), function(i) {
tabPanel(Uni[i,],icon = icon("table"),
div(id = paste0("Table",Uni$NAME[i]),DT::renderDataTable({
if(Uni$NAME[i] == "Iris"){
datatable(iris)
}else{
datatable(mtcars)
}
})),
hidden(div(id = paste0("Plot",Uni$NAME[i]),renderPlot({
if(Uni$NAME[i] == "Iris"){
plot(iris)
}else{
plot(mtcars)
}
})
))
)
})
)
)
})
observeEvent(input$radioV2,{
print(paste0(input$radioV2,input$tabB))
if(input$radioV2 == 'Table'){
show(paste0("Table",input$tabB))
hide(paste0("Plot",input$tabB))
}else{
hide(paste0("Table",input$tabB))
show(paste0("Plot",input$tabB))
}
})
}
shinyApp(ui = ui, server = server)
I am trying to use a package that allows users to graph their data in shiny (esquiss). It works fine. However the user interface for the shiny module in the package requires a fixed height container. I have therefore placed the call to the module in tag$div (inside a modal) called by a button.
The problem is that this call to this module seems to get rid of all the scrollbars for the main page of the app (so I can't scroll to the bottom of the main page (it is a one page app).
How can I limit the html of the module to prevent it from overriding the rest of the app? The code for the module being called is here.
My reproducible example follows:
ui.R
library(shiny)
library(esquisse)
library(shinyBS)
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = ''),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard")
)),
dashboardBody(
actionButton(inputId = "esquissGraphs",label = "esquissGraphs"),
DT::dataTableOutput("mytable"),
bsModal("modalExample", "Data Table", "esquissGraphs", size = "large",
tags$h1("Use esquisse as a Shiny module"),
radioButtons(
inputId = "data",
label = "Data to use:",
choices = c("Mydftbbinnit", "mtcars"),
inline = TRUE
),
tags$div(
style = "height: 700px;", # needs to be in fixed height container
esquisserUI(
id = "esquisse",
header = FALSE, # dont display gadget title
choose_data = FALSE # dont display button to change data
)
)
)
)
)
)
server.R
RV <- reactiveValues(data = data.frame())
RV2 <- reactiveValues(data = data.frame())
server <- function(input, output, session) {
n<-c("1","434","101")
t<-c("Bugs","Mugs","Thugs")
RV$data<-data.frame(n,t,stringsAsFactors = FALSE)
o<-c("1","434","101")
p<-c("Bugs","Mugs","Thugs")
RV2$data<-data.frame(o,p,stringsAsFactors = FALSE)
output$mytable = DT::renderDataTable({
mtcars
})
data_r <-reactiveValues(data = data.frame())
observeEvent(input$data, {
if (input$data == "Mydftbbinnit") {
data_r$data <- RV$data
data_r$name <- "Mydftbbinnit"
} else {
data_r$data <- RV2$data
data_r$name <- "The rest"
}
})
callModule(module = esquisserServer, id = "esquisse", data = data_r)
}
shinyApp(ui, server)
You need to add
tags$style("html, body {overflow: visible !important;")
in your UI to force scrollbar to appear.
Source : https://github.com/dreamRs/esquisse/blob/master/R/esquisserUI.R
Full example gives :
library(shiny)
library(shinydashboard)
library(esquisse)
library(shinyBS)
library(shiny)
library(esquisse)
library(shinyBS)
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = ""),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard")
)
),
dashboardBody(
tags$style("html, body {overflow: visible !important;"),
actionButton(inputId = "esquissGraphs", label = "esquissGraphs"),
DT::dataTableOutput("mytable"),
bsModal("modalExample", "Data Table", "esquissGraphs",
size = "large",
tags$h1("Use esquisse as a Shiny module"),
radioButtons(
inputId = "data",
label = "Data to use:",
choices = c("Mydftbbinnit", "mtcars"),
inline = TRUE
),
tags$div(
style = "height: 700px;", # needs to be in fixed height container
esquisserUI(
id = "esquisse",
header = FALSE, # dont display gadget title
choose_data = FALSE # dont display button to change data
)
)
)
)
)
)
RV <- reactiveValues(data = data.frame())
RV2 <- reactiveValues(data = data.frame())
server <- function(input, output, session) {
n <- c("1", "434", "101")
t <- c("Bugs", "Mugs", "Thugs")
RV$data <- data.frame(n, t, stringsAsFactors = FALSE)
o <- c("1", "434", "101")
p <- c("Bugs", "Mugs", "Thugs")
RV2$data <- data.frame(o, p, stringsAsFactors = FALSE)
output$mytable <- DT::renderDataTable({
mtcars
})
data_r <- reactiveValues(data = data.frame())
observeEvent(input$data, {
if (input$data == "Mydftbbinnit") {
data_r$data <- RV$data
data_r$name <- "Mydftbbinnit"
} else {
data_r$data <- RV2$data
data_r$name <- "The rest"
}
})
callModule(module = esquisserServer, id = "esquisse", data = data_r)
}
shinyApp(ui, server)