Related
This is my module file:
library(semantic.dashboard)
example_UI <- function(id) {
ns <- NS(id)
tagList(
# 1:5 %>% map(~ list(menu = list(paste0(.x)),
# content =list(paste0(.x))))
list(menu = list('B'),
content = list('B')),
list(menu = list('C'),
content = list('C')),
list(menu = list('A'),
content = list('A')),
list(menu = list('A'),
content = list('A')),
list(menu = list('A'),
content = list('A'))
)
}
example_Server <- function(id) {
moduleServer(
id,
function(input, output, session) {
}
)
}
When I run the code without using the purrr::map() function the panels labels are created well.
But when I try to create the panel labels with purrr::map() function it is not created
Bellow Is my shiny App
ui <- dashboardPage(
dashboardHeader(color = "blue"),
dashboardSidebar(side = "left", size = "thin", color = "teal",
sidebarMenu(
menuItem(tabName = "tab1", "Tab 1"))),
dashboardBody(tabItems(
tabItem(tabName = "tab1",
tabBox(
collapsible = FALSE,
title = "Pull",
color = "black",
width = 16,
tabs = example_UI('question')
)
)))
)
server <- function(input, output) {
}
shinyApp(ui, server)
What am I doing wrong?
Your map() function returns a list() of length 5. It does not return five separate lists like you are using when calling tagList() without the map. In order to expand that single list into different paraemters, you can use !!!. For example
tagList(
!!!(1:5 %>% map(~ list(menu = list(paste0(.x)),
content =list(paste0(.x))))
))
I'm trying to get input from the User( a bunch of images) and then display them on R shiny using Lightbox gallery. Unfortunately I'm unable to get the images, Please help with this regard,Thank you in advance for your help .
below is my code:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
fileInput(inputId = "file_upload", label = "Upload Images", multiple = TRUE, accept = c('image/*', ".zip"),
width = NULL, buttonLabel = "Browse",
placeholder = "No file selected"),
actionButton("go","Run")
)
),
mainPanel(
fluidRow(
column(12,(uiOutput('lb'))
))
)
)
)
server <- function(input, output) {
vals<-reactiveValues(result=NULL,img_fldr_name=NULL,images=NULL)
observeEvent(input$file_upload, {
c_t <- Sys.time()
dt_str <- format(c_t, "%Y_%m_%d")
hr_str <- format(c_t, "%H_%M_%S")
vals$img_fldr_name <- paste0(dt_str, "_", hr_str)
if (tools::file_ext(input$file_upload$datapath)[[1]] %in% c("jpeg","png","jpg")){
create_folder_name=paste0("trials/www/",vals$img_fldr_name)
dir.create(path = create_folder_name)
for(i in 1:length(input$file_upload$datapath)){
file.copy(input$file_upload$datapath[[i]], paste0(create_folder_name,"/",input$file_upload$name[[i]]), overwrite = TRUE)
}
df <- list.files(paste0("trials/www/",vals$img_fldr_name), full.names = T)
print(df)
images<<-data.frame(src=list.files(paste0("trials/www/",vals$img_fldr_name), full.names = T))
#print(head(vals$images))
vals$result<-images
}
})
observeEvent(input$go,{
output$lb <- renderUI({
images <<- data.frame(src = vals$result$src)
vals$images <- images
lightbox_gallery <- function(df, gallery, display = 'block'){
print(df)
tags$div(style = sprintf('display: %s;', display),
tagList(tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "lightbox-2.10.0/lightbox.min.css"),
tags$link(rel = "stylesheet", type = "text/css", href = "gallerystyle.css")
),
tags$div(class = 'card-deck',
lapply(seq_len(nrow(df)), function(i){
print("Inside Loop")
print(df$src[i])
tags$div(`data-type`="template", class = 'card',
tags$a(#id = df$key[i],
href = df$src[i],
`data-lightbox` = gallery, # this identifies gallery group
`data-title` = paste0("Image"),
tags$span(style="color:black;text-align: center"),
tags$img(class = 'card-img-top',
src = df$src[i],
width = '80px',
height = 'auto')),
)
})
),
includeScript("www/lightbox-2.10.0/lightbox.min.js")
))
}
lightbox_gallery(vals$images, 'gallery', display = TRUE)
#paste0()
})
})
}
shinyApp(ui = ui, server = server)
Print statement inside loop gives proper path to image.
Also the respective folders and scripts are in place.
The code below works. I removed the nesting of how you prepare the output for better readability.
I think the main problem was that you read the image files from a directory outside www in your project folder. I would keep everything in there. This makes it easier. Take a look at the code: when the images are uploaded I explicitely save them to www/.... While preparing the output, I remove the www prefix using gsub, since Shiny is looking for resources in there by default.
Finally, make sure to use reactive values properly. You don't need to define a global images variable. Just use the reactive values. And there again, it is probably sufficient to have one reactive value which holds all the paths as a vector (e.g. paths <- reactiveVal(NULL)).
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
fileInput(inputId = "file_upload", label = "Upload Images", multiple = TRUE, accept = c('image/*', ".zip"),
width = NULL, buttonLabel = "Browse",
placeholder = "No file selected"),
actionButton("go","Run")
)
),
mainPanel(
fluidRow(
column(12,(htmlOutput('lb'))
))
)
)
)
server <- function(input, output) {
vals<-reactiveValues(result=NULL,img_fldr_name=NULL,images=NULL)
observeEvent(input$file_upload, {
c_t <- Sys.time()
dt_str <- format(c_t, "%Y_%m_%d")
hr_str <- format(c_t, "%H_%M_%S")
vals$img_fldr_name <- paste0(dt_str, "_", hr_str)
if (tools::file_ext(input$file_upload$datapath)[[1]] %in% c("jpeg","png","jpg")){
create_folder_name=paste0("www/trials/www/",vals$img_fldr_name)
dir.create(path = create_folder_name)
for(i in 1:length(input$file_upload$datapath)){
file.copy(input$file_upload$datapath[[i]], paste0(create_folder_name,"/",input$file_upload$name[[i]]), overwrite = TRUE)
}
images <- data.frame(src=list.files(paste0("www/trials/www/",vals$img_fldr_name), full.names = T))
vals$result <- images
}
})
get_lb <- eventReactive(input$go,{
images <- data.frame(src = vals$result$src)
vals$images <- images
lightbox_gallery(vals$images, 'gallery', display = TRUE)
})
lightbox_gallery <- function(df, gallery, display = 'block'){
tags$div(style = sprintf('display: %s;', display),
tagList(tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "lightbox.min.css"),
tags$link(rel = "stylesheet", type = "text/css", href = "gallerystyle.css")
),
tags$div(class = 'card-deck',
lapply(seq_len(nrow(df)), function(i){
print("Inside Loop")
print(df$src[i])
tags$div(`data-type`="template", class = 'card',
tags$a(#id = df$key[i],
href = gsub("^www/", "", df$src[i]),
`data-lightbox` = gallery, # this identifies gallery group
`data-title` = paste0("Image"),
tags$span(style="color:black;text-align: center"),
tags$img(class = 'card-img-top',
src = df$src[i],
width = '80px',
height = 'auto')),
)
})
),
includeScript("www/lightbox.min.js")
))
}
output$lb <- renderUI({
get_lb()
})
}
shinyApp(ui = ui, server = server)
I'm trying to scaffold together a basic dashboard using the shinymaterial package (https://ericrayanderson.github.io/shinymaterial/) but having a slight issue where my dropdown menus (usually selectInput in regular shiny apps) don't show up in a nested UI module.
There should be two dropdown menus above the "Settings" button in this screenshot:
Here's the code snippet for my scaffolding so far:
library(shiny)
library(shinymaterial)
# Wrap shinymaterial apps in material_page
ui <- material_page(
title = "App Title",
nav_bar_fixed = FALSE,
nav_bar_color = "black",
background_color = "white",
# font_color = "black",
# Place side-nav in the beginning of the UI
material_side_nav(
fixed = FALSE,
# Place side-nav tabs within side-nav
material_side_nav_tabs(
side_nav_tabs = c(
"Home" = "home",
"About" = "about"
),
icons = c("home", "help")
),
background_color = "white"
),
# Define side-nav tab content
material_side_nav_tab_content(
side_nav_tab_id = "home",
material_row(
material_column(
material_card(title = NULL,
sidebarCharts("main"),
depth = NULL),
width = 2,
offset = 0
),
material_column(
material_card(title = NULL,
"Chart goes here",
depth = NULL),
width = 10,
offset = 0
)
)
),
material_side_nav_tab_content(
side_nav_tab_id = "about",
tags$h1("About")
)
)
server <- function(input, output, session) {
callModule(chartSettings, "main")
}
# Server modules
chartSettings <- function(input, output, session) {
## 'Home' tab -- Sidebar
output$selectRootSymbol <- renderUI({
.choices <- c('a','b','c')
tagList(
helpText("Root Symbol:"), # Note: helpText() looks a little cleaner versus using the 'label' parameter in selectInput() below
# selectInput(session$ns("reactiveRootSymbol"), label = NULL, choices = .choices, selected = NULL, width = '100%')
material_dropdown(session$ns("reactiveRootSymbol"), label = NULL, choices = .choices, selected = NULL, width = '100%')
)
})
output$selectSymbol <- renderUI({
req(input$reactiveRootSymbol)
.choices <- c('d', 'e', 'f')
tagList(
helpText("Symbol:"),
# selectInput(session$ns("reactiveSymbol"), label = NULL, choices = toupper(.choices), selected = NULL, width = '100%')
material_dropdown(session$ns("reactiveSymbol"), label = NULL, choices = toupper(.choices), selected = NULL, width = '100%')
)
})
}
sidebarCharts <- function(id) {
ns <- NS(id)
tagList(
uiOutput(ns("selectRootSymbol")),
uiOutput(ns("selectSymbol")),
# actionButton(ns("settings"), "Settings", icon = icon("cogs"), width = '100%', class = "btn btn-primary"),p()
material_button(ns("settings"), "Settings", icon = "settings")
)
}
shinyApp(ui = ui, server = server)
I think I have a namespace issue, but I'm not sure (since the button does show up in the nested module). What am I doing wrong?
Any help is much appreciated!
There are at least two issues here.
1. material_dropdown does not display (resolved)
This appears to be due to the unused width = 100% option inside material_dropdown(). Removing this results in some of the drop downs displaying and all of the labels displaying.
2. Consecutive material_dropdown does not display (unresolved)
Having two consecutive material_dropdown's results in only the first drop down displaying, even though both labels display. There have been previous bugs with material_dropdown in the shinymaterial package so this could be part of a related issue.
Here is the code following my exploration:
library(shiny)
library(shinymaterial)
# submodule UI
sidebarCharts <- function(id) {
ns <- NS(id)
tagList(
uiOutput(ns("selectRootSymbol")),
uiOutput(ns("selectSymbol")),
# actionButton(ns("settings"), "Settings", icon = icon("cogs"), width = '100%', class = "btn btn-primary"),p()
material_button(ns("settings"), "Settings", icon = "settings")
)
}
# submodule server
chartSettings <- function(input, output, session) {
## 'Home' tab -- Sidebar
output$selectRootSymbol <- renderUI({
.choices <- c('a','b','c')
material_dropdown(session$ns("reactiveRootSymbol"), label = "Root Symbol:", choices = .choices)
})
output$selectSymbol <- renderUI({
# req(input$reactiveRootSymbol)
.choices <- c('d', 'e', 'f')
material_dropdown(session$ns("reactiveSymbol"), label = "Symbol:", choices = .choices)
})
}
## Wrap shinymaterial apps in material_page ----
ui <- material_page(
title = "App Title",
nav_bar_fixed = FALSE,
nav_bar_color = "black",
background_color = "white",
# font_color = "black",
# Place side-nav in the beginning of the UI
material_side_nav(
fixed = FALSE,
# Place side-nav tabs within side-nav
material_side_nav_tabs(
side_nav_tabs = c(
"Home" = "home"
),
icons = c("home")
),
background_color = "white"
),
# Define side-nav tab content
material_side_nav_tab_content(
side_nav_tab_id = "home",
material_row(
material_column(
material_card(title = NULL,
sidebarCharts("main"),
depth = NULL),
width = 2,
offset = 0
),
material_column(
material_card(title = NULL,
"Chart goes here",
depth = NULL),
width = 10,
offset = 0
)
)
)
)
## main server ----
server <- function(input, output, session) {
callModule(chartSettings, "main")
}
## run ----
shinyApp(ui = ui, server = server)
when input$variable change
uiOutput(1) and uiOutput(2) are rendered at the same time?
Is there any way render step by step not synchronistically?
The following is the steps I want.
1) input variable change
2) uiOutput(1) rendering
3) uiOutput(2) rendering
when input variable change shiny page is not working properly.
but after resizing the page window, the screen appears correctly.
Each time I change the input value, i have to recalibrate the page size.
ui.R
library(shiny)
library(shinydashboard)
sidebar <- dashboardSidebar(
radioButtons(inputId = "sidebar_data_sell",
label = "",
choices = c("Sell-in" = "sell_in", "Sell-out" = "sell_out"),
selected = "sell_out",
inline = TRUE),
uiOutput("summary_sidebar_ui")
)
ui <- dashboardPage(
dashboardHeader(title = h5("Hi")),
sidebar,
uiOutput("dashboard_body")
)
server.R
convertMenuItem <- function(mi, tabName) {
mi$children[[1]]$attribs['data-toggle'] = "tab"
mi$children[[1]]$attribs['data-value'] = tabName
mi
}
out_product_main <- function() {
list(
fluidPage(h5("product")))
}
product_items <- function() {
list(
selectInput("product_product_sell",
"product",
choices = list("product1" = "prd1", "product2" = "prd2"),
selected = c("prd1"))
)
}
in_overview_main <- function() {
list(
fluidPage(h5("overview")))
}
overview_items <- function() {
list(
radioButtons("overview_period_sell",
"period",
choices = c("year","month"),
inline = TRUE,
selected = "month")
)
}
shinyServer(function(input, output) {
output$summary_sidebar_ui <- renderUI({
if (input$sidebar_data_sell == "sell_in")
{
sidebarMenu(id = "summary_item",
convertMenuItem(menuItem("Overview",
tabName = "in_overview",
icon = icon("signal", lib = 'font-awesome'),
overview_items()),
tabName = 'in_overview'))
}
else{
sidebarMenu(id = "p_analysis_item",
convertMenuItem(menuItem("Product",
tabName = "out_product",
icon = icon("product-hunt", lib='font-awesome'),
product_items()),
tabName = 'out_product')
)
}
})
output$dashboard_body <- renderUI({
if (input$sidebar_data_sell == "sell_in") {
dashboardBody(tabItems(tabItem("in_overview", in_overview_main())))
}
else {
dashboardBody(tabItems(tabItem("out_product", out_product_main())))
}
})
})
This question might seem to be a duplicate, but let me explain why it's not.
I want to create a shiny navbarPage that has fixed elements and a reactive number of tabPanels, that reacts to other input elements. There are many questions about how to create reactive tabsetPanels/navbarPages but they mostly aim for what it has to look like. The most common answer (and the answer i don't seek) is to render the whole navbarPage with updated set of tabPanels. I am aware of that concept and I used it in the code below.
Here is what I want my app to look like:
library(shiny)
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
uiOutput("navPage")
)
),
server = function(input, output, session){
MemoryValue1 <- 1
MemoryValue2 <- 1
makeReactiveBinding("MemoryValue1")
observeEvent(input$button, {
output[[paste0("plot_", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
observeEvent(input$insidepanels, {
MemoryValue1 <<- input$insidepanels
})
observeEvent(input$number, {
MemoryValue2 <<- input$number
})
output$navPage <- renderUI({
OutsidePanel1 <- tabPanel("Outside1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = isolate(MemoryValue1), step = 1, min = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 1, step = isolate(MemoryValue2), min = 1),
actionButton("button", label = "Add Output-Element")
)
OutsidePanel2 <- tabPanel("Ouside2", "Outside 2")
InsidePanels <- lapply(1:MemoryValue1, function(x){tabPanel(paste0("Inside", x), plotOutput(paste0("plot_", x)))})
do.call(navbarPage, list("Nav", OutsidePanel1, OutsidePanel2, do.call(navbarMenu, c("Menu", InsidePanels))))
})
}
)
)
As you might have seen, it takes a lot of effort to store your input values if they are inside other panels and will be re-rendered = reset all the time. I find this solution to be illegible and slow, because of unnecessary rendering. It also interrupts the user who is clicking through values of input$insidepanels.
What I want the app to be like is that the Outside Panels are fixed and dont re-render. The main problem is that inside shiny, navbarPage on rendering distributes HTML elements to two different locations. Inside the navigation panel and to the body as tab content. That means a-posteori added elements will not be properly embedded.
So far, I have tried to create the navbarPage with custom tags and have dynamic output alter only parts of it. That works pretty well with the navigation panel, but not with tab contents. The reason is that all tabs (their div containers) are listed one after another and as soon as I want to inject multiple at once, I am offthrown by htmlOutput, since it (seemingly) has to have a container and cannot just deliver plain HTML. Thus, all custom tabs are not recongnized properly.
Here my code so far:
library(shiny)
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
tags$nav(class = "navbar navbar-default navbar-static-top", role = "navigation",
tags$div(class = "container",
tags$div(class = "navbar-header",
tags$span(class = "navbar-brand", "Nav")
),
tags$ul(class = "nav navbar-nav",
tags$li(
tags$a(href = "#tab1", "data-toggle" = "tab", "data-value" = "Outside1", "Outside1")
),
tags$li(
tags$a(href = "#tab2", "data-toggle" = "tab", "data-value" = "Outside2", "Outside2")
),
tags$li(class = "dropdown",
tags$a(href = "#", class = "dropdown-toggle", "data-toggle" = "dropdown", "Menu1"),
htmlOutput("dropdownmenu", container = tags$ul, class = "dropdown-menu")
)
)
)
),
tags$div(class = "container-fluid",
tags$div(class = "tab-content", id = "tabContent",
tags$div(class = "tab-pane active", "data-value" = "Outside1", id = "tab1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = 1, step = 1, min = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 1, step = 1, min = 1),
actionButton("button", label = "Add Output-Element")
),
tags$div(class = "tab-pane", "data-value" = "Outside2", id = "tab2", "Content 2"),
htmlOutput("tabcontents")
)
)
)
),
server = function(input, output, session){
observeEvent(input$button, {
output[[paste0("plot_", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
output$dropdownmenu <- renderUI({
lapply(1:input$insidepanels, function(x){tags$li(tags$a(href = paste0("#tab-menu-", x), "data-toggle" = "tab", "data-value" = paste0("Inside", x), paste("Inside", x)))})
})
output$tabcontents <- renderUI({
tagList(
lapply(1:input$insidepanels, function(x){div(class = "tab-pane", "data-value" = paste("Inside", x), id = paste0("tab-menu-", x), plotOutput(paste0("plot_", x)))})
)
})
}
)
)
Note: I also tried to create HTML with JavaScript-Chunks that is triggered from inside server. This works for simple tab content, but I want my tabPanels to still have shiny output elements. I don't see how I can fit that in with JavaScript. That is why I included the plotOutput content in my code.
Thanks to anybody who can help solve this issue!
Finally came up with an own answer. I hope this can be a useful reference to others who try to understand shiny reactiveness. The answer is JavaScript for custom elements (rebuilding standard shiny elements) and using Shiny.unbindAll() / Shiny.bindAll() to achieve the reactivity.
Code:
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
tags$script('
Shiny.addCustomMessageHandler("createTab",
function(nr){
Shiny.unbindAll();
var dropdownContainer = document.getElementById("dropdown-menu");
var liNode = document.createElement("li");
liNode.setAttribute("id", "dropdown-element-" + nr);
var aNode = document.createElement("a");
aNode.setAttribute("href", "#tab-menu-" + nr);
aNode.setAttribute("data-toggle", "tab");
aNode.setAttribute("data-value", "Inside" + nr);
var textNode = document.createTextNode("Inside " + nr);
aNode.appendChild(textNode);
liNode.appendChild(aNode);
dropdownContainer.appendChild(liNode);
var tabContainer = document.getElementById("tabContent");
var tabNode = document.createElement("div");
tabNode.setAttribute("id", "tab-menu-" + nr);
tabNode.setAttribute("class", "tab-pane");
tabNode.setAttribute("data-value", "Inside" + nr);
var plotNode = document.createElement("div");
plotNode.setAttribute("id", "plot-" + nr);
plotNode.setAttribute("class", "shiny-plot-output");
plotNode.setAttribute("style", "width: 100% ; height: 400px");
tabNode.appendChild(document.createTextNode("Content Inside " + nr));
tabNode.appendChild(plotNode);
tabContainer.appendChild(tabNode);
Shiny.bindAll();
}
);
Shiny.addCustomMessageHandler("deleteTab",
function(nr){
var dropmenuElement = document.getElementById("dropdown-element-" + nr);
dropmenuElement.parentNode.removeChild(dropmenuElement);
var tabElement = document.getElementById("tab-menu-" + nr);
tabElement.parentNode.removeChild(tabElement);
}
);
'),
tags$nav(class = "navbar navbar-default navbar-static-top", role = "navigation",
tags$div(class = "container",
tags$div(class = "navbar-header",
tags$span(class = "navbar-brand", "Nav")
),
tags$ul(class = "nav navbar-nav",
tags$li(
tags$a(href = "#tab1", "data-toggle" = "tab", "data-value" = "Outside1", "Outside1")
),
tags$li(
tags$a(href = "#tab2", "data-toggle" = "tab", "data-value" = "Outside2", "Outside2")
),
tags$li(class = "dropdown",
tags$a(href = "#", class = "dropdown-toggle", "data-toggle" = "dropdown", "Menu1"),
tags$ul(id = "dropdown-menu", class = "dropdown-menu")
)
)
)
),
tags$div(class = "container-fluid",
tags$div(class = "tab-content", id = "tabContent",
tags$div(class = "tab-pane active", "data-value" = "Outside1", id = "tab1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = 0, step = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 0, step = 1),
actionButton("button", label = "Add Output-Element")
),
tags$div(class = "tab-pane", "data-value" = "Outside2", id = "tab2", "Content 2")
)
)
)
),
server = function(input, output, session){
allOpenTabs <- NULL
observeEvent(input$insidepanels, {
if(!is.na(input$insidepanels)){
localList <- 0:input$insidepanels
lapply(setdiff(localList, allOpenTabs), function(x){
session$sendCustomMessage(type = "createTab", message = x)
})
lapply(setdiff(allOpenTabs, localList), function(x){
session$sendCustomMessage(type = "deleteTab", message = x)
})
allOpenTabs <<- localList
}
})
observeEvent(input$button, {
output[[paste0("plot-", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
}
), launch.browser = TRUE
)
It is basically adding the HTML Elements "by hand" and linking them to shiny listeners.