I'm building a Shiny app and for the last two days I'm being blocked on the following step: I've put a "Submit" button on a typeform and apparently there are no problems, but everytime I run the app I can't click on it because for the very beginning it shows me a "no trespassing" signal disallowing me to do nothing else.
Here's the code I'm using:
# Packages ----
if(require("pacman")=="FALSE"){
install.packages("pacman")
}
library(pacman)
pacman::p_load(dplyr, tidyr, shiny, shinydashboard)
# Global scope ----
dish <- c("Salad", "Spaghetti Carbonara", "Scrambled eggs")
allergens <- c("sesame", "lactose", "eggs")
keywords <- c("veggie", "pasta", "none")
dishes <- data.frame(dish, allergens, keywords)
# Function to label mandatory fields ----
labelMandatory <- function(label) {
tagList(
label,
span("*", class = "mandatory_star")
)
}
appCSS <- ".mandatory_star { color: red; }" #to make the asterisk red
MandatoryFields_dishes <- c(names(dishes[,-3]))
fields_dishes <- c(names(dishes))
ui <- dashboardPage(
dashboardHeader(title = "sample"),
dashboardSidebar(
sidebarMenu(
menuItem("Dishes", tabName = "dishes")
)
),
dashboardBody(
# Dishes
tabItems(
tabItem(tabName = "dishes",
tabsetPanel(
tabPanel("Typeform",
fluidPage(
shinyjs::useShinyjs(),
shinyjs::inlineCSS(appCSS),
titlePanel("Dish introduction"),
div(
id="form",
textInput("dish", labelMandatory("Dishes"), ""),
textInput("allergens", label = "Allergens",""),
textInput("keyword", label = "Keyword", ""),
actionButton("submit", "Submit", class="btn-primary")
)
))
))
))
)
server <- function(input, output) {
observe({
mandatoryFilled_dishes <-
vapply(MandatoryFields_dishes,
function(x) {
!is.null(input[[x]]) && input[[x]] != ""
},
logical(1))
mandatoryFilled_dishes <- all(mandatoryFilled_dishes)
shinyjs::toggleState(id = "submit", condition = mandatoryFilled_dishes)
})
}
shinyApp(ui, server)
I guess I'm missing something on the server. If someone could help me I'll be very grateful, lots of thanks in advance.
Related
I have created an app using ShinyDashboard that has one checkboxInput. If you click on it, you will see two checkboxGroupInput where you can select 1 or 2 choices.
The idea is that if you click 1 option, you will subset your dataframe with your individual choice, or if you click both options, you will subset your dataframe with those two options.
However, I am having problems to verify which option of the checkboxGroupInput the user has selected.
Here is a reproducible example. As you can see, if you select both, you end in the first if statement, subsetting two columns. However, if you select one option (setosa, for example), you are still subsetting by the two, because it doesn't recognise the choice that you have selected. However, if you select "virginica" it is subsetted.
Moreover, it appears this warning all the time.
Warning in if (c("setosa", "virginica") %in% input$species_choice) { :
the condition has length > 1 and only the first element will be used
The code:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
## Sidebar content
dashboardSidebar(
sidebarMenu(
menuItem("App1", tabName = "App1", icon = icon("th"))
)
),
dashboardBody(
fluidRow(
tabItems(
tabItem(tabName = "App1",
sidebarPanel(
checkboxInput(inputId = "species", label = "Select species"),
conditionalPanel(
condition = "input.species",
style = "margin-left: 20px;",
checkboxGroupInput("species_choice", "Choose the species:",
choices = c("setosa", "virginica"), selected = c("setosa", "virginica"))),
),
mainPanel(
dataTableOutput("table")
)
)
)
)
)
)
server <- function(input, output, session) {
mytables <- reactive({
if(input$species){
df_setosa <- iris[iris$Species=="setosa",]
df_virginica <- iris[iris$Species=="virginica",]
df_both <- rbind(df_setosa, df_virginica)
if(c("setosa", "virginica") %in% input$species_choice){
print("both")
return(df_both)
}
if("setosa" %in% input$species_choice){
print("setosa")
return(df_setosa)
}
if("virginica" %in% input$species_choice){
print("virginica")
return(df_virginica)
}
}
})
output$table <- renderDataTable({
mytables()
})
}
shinyApp(ui, server)
I have tried this way too, but it doesn't work:
if(input$species_choice == "setosa"){
print("setosa")
return(df_setosa)
}
if(input$species_choice == "virginica"){
print("virginica")
return(df_virginica)
}
if(input$species_choice == c("setosa, virginica"){
print("both")
return(df_both)
}
Does anyone know how to help me, please?
Thanks in advance
There is no need to subset your dataframe before the if conditions, and you don't need all those if conditions. You can simply check if the first button is clicked (my first if condition), and if it is then you can subset your dataframe with the selected specie(s).
Note that if you select none of the two species, the table is empty (but you can change this behavior).
mytables <- reactive({
if (input$species) {
iris[iris$Species %in% input$species_choice, ]
} else {
iris
}
})
I found another solution:
I just have to include if(all(c(OPTIONS) ....
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
## Sidebar content
dashboardSidebar(
sidebarMenu(
menuItem("App1", tabName = "App1", icon = icon("th"))
)
),
dashboardBody(
fluidRow(
tabItems(
tabItem(tabName = "App1",
sidebarPanel(
checkboxInput(inputId = "species", label = "Select species"),
conditionalPanel(
condition = "input.species",
style = "margin-left: 20px;",
checkboxGroupInput("species_choice", "Choose the species:",
choices = c("setosa", "virginica"), selected = c("setosa", "virginica"))),
),
mainPanel(
dataTableOutput("table")
)
)
)
)
)
)
server <- function(input, output, session) {
mytables <- reactive({
if(input$species){
df_setosa <- iris[iris$Species=="setosa",]
df_virginica <- iris[iris$Species=="virginica",]
df_both <- rbind(df_setosa, df_virginica)
if(all(c("setosa", "virginica") %in% input$species_choice)){
print("both")
return(df_both)
}
if(all(c("setosa") %in% input$species_choice)){
print("setosa")
return(df_setosa)
}
if(all(c("virginica") %in% input$species_choice)){
print("virginica")
return(df_virginica)
}
}
})
output$table <- renderDataTable({
mytables()
})
}
shinyApp(ui, 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 have written a Shiny code that has a dashboard with the following elements
1) Side Bar Layout
2) On clicking Tab 'view', the main panel gets populated with tabset panel
3) On clicking 'table', two selectInput should be displayed where the sheet dropdown is dependent on Table dropdown. The Datasets are read from xlsx files
library(shinydashboard)
library(leaflet)
library(ggplot2)
library(DT)
library(openxlsx)
# -----------------------------------------------------------------------------
# Dashboard UI
# -----------------------------------------------------------------------------
dataset <- c("P1-Long-Term-Unemployment-Statistics","P1-OfficeSupplies")
ui <- dashboardPage(
dashboardHeader(
title = "Validation Tool"
),
dashboardSidebar(
sidebarMenu(
menuItem("View Tables", tabName = "view", icon = icon("database")),
menuItem("Append Data", tabName = "append", icon = icon("database")),
menuItem("Update Table", tabName = "update", icon = icon("crosshairs")),
menuItem("Construct Table", tabName = "construct", icon = icon("fire"))
),
div(style = "padding-left: 15px;padding-right: 5px; padding-top: 40px;",
p(class = "small", "Note : This validation tools automates the mainstream process involved in creating a Master data for detailed analysis ")
)
),
dashboardBody(
tabItems(
# Current location ------------------------------------------------------
tabItem(tabName = "view",
mainPanel(
titlePanel(h2("Explore Datasets")),fluidRow(
column(8,
selectInput("table",
"Table:",
dataset)
),
column(8,
uiOutput("sheets")
),
DT::dataTableOutput("table")
),
tabsetPanel(type="tab",
tabPanel("Data"
),
tabPanel("Summary"),
tabPanel("Plot")
)
)
)
)
)
)
# -----------------------------------------------------------------------------
# Dashboard server code
# -----------------------------------------------------------------------------
server <- function(input, output) {
file <- reactive({paste0("D:/Dataset/",input$table,".xlsx")})
sheetNames <- reactive({getSheetNames(file)})
output$sheets <- renderUI({
selectInput("sheet","Sheet:",choices = sheetNames)
})
output$table <- DT::renderDataTable(DT::datatable({
data <- read.xlsx(file,sheet=as.numeric(input$sheet))
data
}))
}
shinyApp(ui, server)
But while implementing the above, I get the error (screenshot attached)
"Error : Invalid 'description' argument"
"Error : cannot coerce type 'closure' to vector of type 'list'
Please help resolving the issue
You have to call reactive values with parentheses (file reactive value declared in line 62). But there is a file() function in base R, so change this e.g. for my_file and call it with parentheses, e.g.:
my_file <- reactive({paste0("D:/Dataset/",input$table,".xlsx")})
sheetNames <- reactive({getSheetNames(my_file())})
The below code works fine
server <- function(input, output) {
my_file <- function(){
my_file <- paste0("D:/Dataset/",input$table,".xlsx")
}
sheetNames <- function(){
sheetNames <- getSheetNames(my_file())
}
output$sheets <- renderUI({
selectInput("sheet","Sheet:",choices = sheetNames())
})
output$table <- DT::renderDataTable(DT::datatable({
data <- read.xlsx(my_file(),sheet=as.character(input$sheet))
data
}))
}
I need my Shiny module to hide/show a div outside of the namespace. I tried passing the div id to the module server function and using shinyjs to show/hide it but that is not working. I'm not getting an error, it just doesn't show/hide the div.
I know the Shiny module documentation says modules cannot access outputs outside the namespace. The docs do, though, give a way for the module to access inputs outside the namespace using reactives.
Does anyone know if there is a way for a Shiny module to access an output outside the namespace?
Here is what I'm trying to do:
### ui.R ###
header <- dashboardHeader(
title = a(href = 'http://google.com')
)
dashboardPage(
skin = 'black',
header,
dashboardSidebar(
sidebarMenu( id='tabs',
menuItem('Edit Existing Client', tabName = 'client-info')
)),
dashboardBody(
useShinyjs(),
fluidRow(
tabItems(
tabItem(tabName = "client-info",
div(selectClientModuleUI("clientinfons")),
div(id='editclientinfo', uiOutput('editclientstuff'))
)
)
)
)
)
### server.R ###
shinyServer(function(session,input, output) {
output$editclientstuff <- renderUI({
div(
fluidRow(
column(6,
textInput('editname', "Display name", value ='Testing name')
),
column(6,
numericInput('editastart','Start', value ='3')
)
)
)
})
callModule(selectClientModule, 'clientinfons', 'editclientinfo')
shinyjs::hide(id='editclientstuff')
})
### in global.R ###
selectClientModuleUI <- function(id){
ns <- NS(id)
clientlist = c(0, 1, 2)
names(clientlist) = c('Choose client', 'Fred', 'Kim')
div(
selectInput(ns('selectclient'), 'Select client to edit', choices = clientlist, selected = NULL, multiple = FALSE)
)
}
selectClientModule <- function(input, output, session, divtoshow = ''){
observeEvent(input$selectclient, {
if (!is.null(input$selectclient) && input$selectclient > 0){
print(paste0("showing ", divtoshow))
shinyjs::show(divtoshow)
}
})
}
That is possible by giving the value as a reactive (not as the value of the reactive) to the module. You can change the reactive Value in the module and return the reactive from the Module to the app (note, return the reactive itself, not its value). The following app switches the 'divtoshow' in the main app from inside the module. If nothing is selected, it's hidden, otherwise it's shown (note, I adjusted you code a little so it's working as a stand-alone app):
library(shinydashboard)
library(shinyjs)
# Module
selectClientModuleUI <- function(id){
ns <- NS(id)
clientlist = c(0, 1, 2)
names(clientlist) = c('Choose client', 'Fred', 'Kim')
div(
selectInput(ns('selectclient'), 'Select client to edit', choices = clientlist, selected = NULL, multiple = FALSE)
)
}
selectClientModule <- function(input, output, session, divtoshow){
observeEvent(input$selectclient, {
if (input$selectclient > 0){
print(paste0("showing editclientinfo"))
divtoshow("editclientinfo") # set the div to show to "editclientinfo", this will be visible outside the module
}else{
divtoshow("") # set the div to show to "", if nothing was chosen
}
})
# return the div to show as reactive to the main app
return(divtoshow)
}
# Main App
ui <- shinyUI(
dashboardPage(
skin = 'black',
dashboardHeader(
title = a(href = 'http://google.com')
),
dashboardSidebar(
sidebarMenu( id='tabs',
menuItem('Edit Existing Client', tabName = 'client-info')
)),
dashboardBody(
useShinyjs(),
fluidRow(
tabItems(
tabItem(tabName = "client-info",
div(selectClientModuleUI("clientinfons")),
div(id='editclientinfo', uiOutput('editclientstuff'))
)
)
)
)
))
server <- shinyServer(function(session,input, output) {
output$editclientstuff <- renderUI({
div(
fluidRow(
column(6,
textInput('editname', "Display name", value ='Testing name')
),
column(6,
numericInput('editastart','Start', value ='3')
)
)
)
})
# store the div to show in a reactive
divtoshow <- reactiveVal('')
# divtoshow can be changed in side this module, so it's a return value
divtoshow <- callModule(selectClientModule, 'clientinfons', divtoshow)
# observe the value of divtoshow and toggle the corresponding div
observeEvent(divtoshow(), {
if(divtoshow() == "editclientinfo"){
shinyjs::show("editclientinfo")
}else{
shinyjs::hide("editclientinfo")
}
})
})
shinyApp(ui, server)
I'm trying to generate multiple menuItems dynamically, may be simple, but I'm not getting the right idea.
library(shiny)
library(shinydashboard)
port_tables<-c("tab1","tab2","tab3","tab4") # These are from a DB connection in the original code
function(input, output) {
output$smenu1 <- renderMenu({
sidebarMenu( id = "tabs",
h4("Tables",style="color:yellow;margin-left:20px;"),
paste("menuItem(\"",port_tables,"\",tabName=\"",port_tables,"\",icon=icon('th'))",collapse=",")
)
})
)
The menuItems from the paste function doesn't resolve( I get the result of paste function on the sidebar). I tried eval, eval(parse(paste(...))), both didn't work - what am I missing?
I couldn't quite make out what you're asking for, but here's an example of something with a dynamic menu.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic Menu"),
dashboardSidebar(
sidebarMenuOutput(outputId = "dy_menu")
),
dashboardBody(
tabItems(
tabItem(tabName = "main",
textInput(inputId = "new_menu_name",
label = "New Menu Name"),
actionButton(inputId = "add",
label = "Add Menu")
)
)
)
)
server <- function(input, output, session){
output$dy_menu <- renderMenu({
menu_list <- list(
menuItem("Add Menu Items", tabName = "main", selected = TRUE),
menu_vals$menu_list)
sidebarMenu(.list = menu_list)
})
menu_vals = reactiveValues(menu_list = NULL)
observeEvent(eventExpr = input$add,
handlerExpr = {
menu_vals$menu_list[[length(menu_vals$menu_list) + 1]] <- menuItem(input$new_menu_name,
tabName = input$new_menu_name)
})
}
shinyApp(ui, server)
I changed the code as follows and it worked :
library(shiny)
library(shinydashboard)
port_tables<-c("tab1","tab2","tab3","tab4") # These are from a DB connection in the original code
text1<-paste("menuItem(\"",port_tables,"\",tabName=\"",port_tables,"\",icon=icon('th'))")
text2<-paste("sidebarMenu(id = 'tabs',textInput('port', 'Enter port:'),h4('Tables',style='color:yellow;margin-left:20px;'),",paste(text1,collapse=","),paste(")"))
function(input, output) {
output$smenu1 <- renderMenu({
eval(parse(text=text2))
})
)
So, the key is put the whole content of sidebarMenu in a text field and evaluate it