无需重绘传单地图即可进行闪亮的 UI 调整

Question

问题

我正在创建一个闪亮的仪表板来帮助客户探索一些空间数据。我想要实现的 UI 设计允许用户轻松地在两种布局之间切换：

• 仅地图
• 地图+数据表

我在实现这个设计时遇到了麻烦，因为每次用户在布局之间切换时都会出现两个问题：

1. 地图已重新绘制
2. 操作按钮损坏，阻止用户探索数据

我的猜测是这可能是一个命名空间问题，但我没有任何创建模块的经验（看起来很复杂和可怕）。

有人有解决这些问题的好策略吗？

可重现的示例：

library(dplyr)
library(shiny)
library(shinydashboard)
library(leaflet)
library(RColorBrewer)
library(DT)

header <- dashboardHeader(
        title = "Example"
)

sidebar <- dashboardSidebar(
        sidebarMenu(id="tabs",
                    fluidPage(
                            fluidRow(
                                    column(1),
                                    column(11,
                                           checkboxInput(inputId = "show",label = "Show Data Table",value = TRUE),
                                           p(),
                                           actionButton("zoom","Zoom to Oz",icon = icon("search-plus")))
                            )
                    )

                    )

        )
)

body <-   dashboardBody(
        fluidPage(
                fluidRow(
                        uiOutput("content")
                )

        )
)      

ui <- dashboardPage(header, sidebar, body)        

server <- function(input, output) {

        output$map <- renderLeaflet({

                pal <- colorNumeric("Set2", quakes$mag)
                leaflet(quakes) %>% addTiles() %>%
                        fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat)) %>% 
                        addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
                                                              fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
                                                   )
        })

        output$table <- DT::renderDataTable({
                quakes %>% select(lat,long,mag) %>% DT::datatable()
        })


        observeEvent(input$zoom,{
                leafletProxy(mapId = "map",data = quakes$mag) %>% 
                        setView(132.166667, -23.033333,  zoom = 4)
        })




        output$content <- renderUI({

                makeCol_table <- function(){
                        column(4,
                               box(title = "",width = 12,height = "100%",
                                   DT::dataTableOutput("table"))
                               )
                }

                makeCol_map8 <- function(){
                        column(8,
                               box(title = "",width = 12,height = "100%",
                                   leafletOutput("map",height = "600px"))
                               )
                }
                makeCol_map12 <- function(){
                        column(12,
                               box(title = "",width = 12,height = "100%",
                                   leafletOutput("map",height = "600px"))
                               )
                }


                fluidRow(

                        if(input$show == T)({makeCol_table()})else ({NULL}),
                        if(input$show == T)({makeCol_map8()}) else ({makeCol_map12()})

                )





        })
}

shinyApp(ui,server)

会议信息：

> sessionInfo()
R version 3.2.3 (2015-12-10)
Platform: x86_64-apple-darwin13.4.0 (64-bit)
Running under: OS X 10.11.3 (El Capitan)

locale:
[1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8

attached base packages:
[1] stats     graphics  grDevices utils     datasets 
[6] methods   base     

other attached packages:
[1] dplyr_0.4.3          shinydashboard_0.5.1
[3] DT_0.1.39            RColorBrewer_1.1-2  
[5] leaflet_1.0.1.9003   shiny_0.13.1        

loaded via a namespace (and not attached):
 [1] Rcpp_0.12.3        magrittr_1.5       munsell_0.4.3     
 [4] colorspace_1.2-6   xtable_1.8-2       R6_2.1.2          
 [7] plyr_1.8.3         tools_3.2.3        parallel_3.2.3    
[10] DBI_0.3.1          htmltools_0.3      lazyeval_0.1.10   
[13] yaml_2.1.13        digest_0.6.9       assertthat_0.1    
[16] htmlwidgets_0.6    rsconnect_0.4.1.11 mime_0.4          
[19] scales_0.4.0       jsonlite_0.9.19    httpuv_1.3.3 

Answer 1

我重写了你的应用程序，以便它使用 @daattali 的出色

shinyjs

包。我还删除了一些格式以缩短它。

最终我们可以利用

javascript

hide

和

show

方法来隐藏包含表格的盒子。

另请注意，我已将您的地图和表格移至

ui

。

library(dplyr)
library(shiny)
library(shinydashboard)
library(leaflet)
library(RColorBrewer)
library(DT)
library(shinyjs)

header <- dashboardHeader(
  title = "Example"
)

sidebar <- dashboardSidebar(
  sidebarMenu(id="tabs",
              checkboxInput(inputId = "show",label = "Show Data Table",value = TRUE),
              p(),
              actionButton("zoom","Zoom to Oz", icon = icon("search-plus")
                           )
              )
  )

body <- dashboardBody(

  ## Initialise shinyjs
  useShinyjs(),

  div(id = "box_table-outer",
    box(id = "box_table",
      title = "",
      width = 12,
      height = "100%",
      DT::dataTableOutput("table")
      )
    ),
  box(title = "",
      width = 12,
      height = "100%",
      leafletOutput("map",
                    height = "600px")
      )
  )

ui <- dashboardPage(header, sidebar, body)        

server <- function(input, output) {

  output$map <- renderLeaflet({

    pal <- colorNumeric("Set2", quakes$mag)

    leaflet(quakes) %>% 
      addTiles() %>%
      fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat)) %>% 
      addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
                 fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
      )
  })

  output$table <- DT::renderDataTable({
    quakes %>% 
      select(lat,long,mag) %>% 
      DT::datatable()
  })


  observeEvent(input$zoom, {

    leafletProxy(mapId = "map",data = quakes$mag) %>% 
      setView(132.166667, -23.033333,  zoom = 4)

  })

  ## use shinyjs functions to show/hide the table box 
  ## dependant on the check-box
  observeEvent(input$show, {
    if(input$show){
      show(id = "box_table-outer")
    }else{
      hide(id = "box_table-outer")
    }
  })

}

shinyApp(ui,server)