Hello!
Let me first describe how my app works then I can describe my main two issues and a few other smaller issues I'm facing. Please let me know how I can reformat to help others find this easily. Also if you see any other optimizations I would greatly appreciate it!
This app is part of a much larger application, so the button placement and module order will seem strange on the first step.
Steps
- Click 'Load UI' on the Load tab - will dynamically load the module ui box() and server for each of the 'IDS' in the 'vis' tab.
- Each IDS box() can be sorted and the order returned
Big issues
- the shinycssloaders::withSpinner() function messes up the spacing for the outputs in each of the boxes.
- the shinycssloaders::withspinner() function does not show the loader.
- When the UI is dynamically loaded the sortable::sortable_js() function does not return the order of the boxes initially. I have to reoder them to get it to work.
Small Issues
- When I dynamically generate the UI I believe it is running over the code too many times.
- I get the following warning message that I would like to figure out. It has to do with the event_data in the plotly plots.
Warning: The 'plotly_click' event tied a source ID of 'src_id2' is not registered. In order to obtain this event data, please add `event_register(p, 'plotly_click')` to the plot (`p`) that you wish to obtain event data from.
- I also get the following warning whenever I create the ggplot instance. I need to pass the 'key' to ggplot or to plotly but I can't figure out how to pass it to plotly.
Warning: Ignoring unknown aesthetics: key
library(shiny)
library(shinydashboard)
library(tidyverse)
library(plotly)
library(DT)
library(shinycssloaders)
library(sortable)
# VARIABLES ---------------------------------------------------------------
IDS <- c("id1", "id2", "id3")
DATA <- mtcars %>% rownames_to_column("car") %>% as_tibble()
# MOD UI ----------------------------------------------------------------------
uiLoad <- function(id){
ns <- NS(id)
fluidRow(
actionButton(ns("loadUi"), label = "Load UI")
)
}
uiBox <- function(id){
tags$div(id = id, class = "col-sm-12",
box(title = id, collapsible = T, width = 12,
tabBox(width = 12,
tabPanel("Vis1",
uiVis(id)
)
)
)
)
}
uiVis <- function(id){
ns <- NS(id)
fluidPage(
fluidRow(
withSpinner(plotlyOutput(ns("gf")), type = 5, color = '#324155'),
# plotlyOutput(ns("gf")),
tags$hr(),
withSpinner(dataTableOutput(ns("tbl")), type = 5, color = '#324155'),
# dataTableOutput(ns("tbl")),
tags$hr(),
withSpinner(verbatimTextOutput(ns("txt")), type = 5, color = '#324155')
# verbatimTextOutput(ns("txt"))
)
)
}
# MOD SERVER ------------------------------------------------------------------
modLoad <- function(input, output, session, load.go){
observeEvent(input$loadUi, {
load.go(TRUE)
},ignoreInit = T)
}
modVis <- function(input, output, session, id2){
src <- paste0("src_",id2)
rv <- reactiveVal()
data <- reactive({
DATA %>%
mutate(out = ifelse(car %in% rv(), T, F))
})
eventClick <- reactive(event_data("plotly_click", source = src)) %>% debounce(500)
observeEvent(eventClick(), {
d <- eventClick()
if(is_empty(d)) return()
if (!is.null(d)) {
x <- c(rv(), d %>% filter(!is.na(key)) %>% pull(key)) %>% unique()
rv(x)
}
}, ignoreInit = T)
eventSelect <- reactive(event_data("plotly_selected", source = src)) %>% debounce(500)
observeEvent(eventSelect(), {
d <- eventSelect()
if(is_empty(d)) return()
if (!is.null(d)) {
x <- c(rv(), d %>% filter(!is.na(key)) %>% pull(key)) %>% unique()
rv(x)
}
}, ignoreInit = T)
output$gf <- renderPlotly({
p <- ggplot() +
geom_point(data = data(),
aes_string(
x = "mpg",
y = "hp",
key = "car",
color = "out",
shape = "out"
)) +
scale_shape_manual(values = c(1, 4)) +
scale_alpha_manual(values = c(1, .4))
p <- p %>% ggplotly(source = src) %>%
layout(dragmode = "lasso") %>%
layout(legend = list(x = 1.1, y = .9))
return(p)
})
output$tbl <- renderDT({
data() %>% filter(!(car %in% rv()))
})
output$txt <- renderText(rv())
}
##UI ----
ui <- dashboardPage(skin = "blue", title = "USMNT Session Planner (v2020.2)",
header = dashboardHeader(
title = "Test App"
),
sidebar = dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("Load", tabName = "load"),
menuItem("Vis", tabName = 'vis')
)
),
body = dashboardBody(
tabItems(
tabItem("load",
fluidPage(
uiLoad("load")
)
),
tabItem('vis',
fluidPage(
column(width = 3, box(title = "Box Order",width = 12, verbatimTextOutput("boxOrder"))),
column(width = 9,
tags$div(id = 'id_placeholder')
),
sortable_js(
css_id = "id_placeholder",
options = sortable_options(
onSort = sortable_js_capture_input(input_id = "boxOrder"),
onLoad = sortable_js_capture_input(input_id = "boxOrder")
)
)
)
)
)
)
)
##SERVER ----
server <- function(input, output, session) {
load.go <- reactiveVal(FALSE)
mod.list <- reactiveValues()
callModule(modLoad, "load", load.go)
observeEvent(load.go(), {
if (!load.go()) return()
updateTabItems(session, "tabs", selected = "vis")
for (i in length(IDS):1){
insertUI(immediate = TRUE, selector = "#id_placeholder",where = "afterBegin", ui = uiBox(id = IDS[i]))
mod.list[[IDS[i]]] <- callModule(module = modVis, id = IDS[i], id2 = IDS[i])
}
}, ignoreInit = T)
output$boxOrder <- renderPrint({
str_split(input$boxOrder, "\n",simplify = T)[,1]
})
}
shinyApp(ui, server)