html - ShinyDashboard 仪表板标题与浏览器中的 Logo 不符

Question

我正在构建一个 Shiny 的应用程序，我想要一个静态 dashboardHeader() 标题，其右侧有一个 Logo 。我浏览了 stackoverflow 来弄清楚如何做到这一点，这似乎需要 HTML 标签。我不是计算机程序员 - 只是 R 用户，所以我不太明白它们是如何工作的。但根据其他人的建议，似乎我需要 tag$li() 来设置标题栏和 Logo 的高度。当我运行该应用程序时，标题会按照我想要的方式显示在 RStudio Shiny 查看器中，但是当我在浏览器 (Chrome) 中查看它时，标题会凹陷在 Logo 下方并被切断。下面是一个可重现的示例。您首先需要下载[R标志]https://www.r-project.org/logo/Rlogo.png并将其另存为“Rlogo.png”，位于与以下代码相同的目录中名为“www”的子目录中(而该子目录必须另存为“app.R”):

library(shiny)
library(shinydashboard)
library(plyr)
library(tmap)
library(tmaptools)
library(sp)
library(rgdal)

Projects<-c("Test", "Test", "Example", "Example", "Exhibit B", "Exhibit B")
Units<-c("A1", "A2", "B1", "B2", "C1", "C2")
CHOICE<-data.frame(PROJECTS = Projects, UNITS = Units)

P1<-sample(Projects, 100, replace=TRUE)
U1<-sample(Units, 100, replace=TRUE)
V1<-runif(100, 44.000, 45.900)
V2<-runif(100, -120.5, -118.0)

Data<-data.frame(Project = P1, Unit = U1, Value_1 = V1, Value_2 = V2)

ui<-dashboardPage(title = "Example",# Start Dashboard Page
                  header = dashboardHeader(
                    tags$li(class = "dropdown",
                            tags$style(".main-header {max-height: 100px}"),
                            tags$style(".main-header .logo {height: 100px} .primary-title height {100px}"),
                            tags$style(".sidebar-toggle {height: 20px; padding-top: 1px !important;}"),
                            tags$style(".navbar {min-height:20px !important}")
                    ),
                    titleWidth='100%',
                    title = span(
                      tags$img(src="Rlogo.png", width = '5%', align='right'), 
                      column(12, class="title-box", 
                             tags$h1(class="primary-title", style='margin-top:5px;', 'EXAMPLE SHINY DASHBOARD APP')
                      ))),#End Header,
  dashboardSidebar(
                selectInput(inputId = "Prj", "Select a Project", choices = unique(CHOICE$PROJECTS), selected = unique(CHOICE$PROJECTS)[1]),
                selectInput(inputId = "Unit", "Select a Unit", choices = NULL)
  ),
  dashboardBody(
    tmapOutput(outputId = "map"),
    tableOutput(outputId = "TABLE")
  )
)

server<-function(input, output, session){
  observeEvent(input$Prj,{
    updateSelectInput(session, "Unit", 
                      choices = unique(CHOICE$UNITS[CHOICE$PROJECTS==input$Prj]), 
                      selected = unique(CHOICE$UNITS[CHOICE$PROJECTS==input$Prj])[1])
  })
  output$TABLE<-renderTable({
    Data2<-subset(Data, Project == input$Prj & Unit == input$Unit)
    tbl<-ddply(Data2, c("Project", "Unit"), summarize, VALUE = max(Value_1), OTHER_VALUE=mean(Value_2))
    return(tbl)
  })
  output$map<-renderTmap({
    Data2<-subset(Data, Project == input$Prj & Unit == input$Unit)
    WGS84<-CRS("+init=epsg:4326")
    Pts<-SpatialPointsDataFrame(Data2[,c(4,3)], Data2[,c(1:2)], proj4string = WGS84)
    tmap_mode("view")
    tm_shape(Pts)+
      tm_dots("Project")+
      tm_basemap(server=providers$Esri.WorldImagery)
  })
}

shinyApp(ui = ui, server = server)

Answer 1

经过一番尝试和错误以及大量的谷歌搜索后，我认为这个问题基本上是一个“黑客”(用程序员的说法)来绕过 shinydashboard 的工作原理。我发现要显示 Logo 和标题，请使用 tags$li(class = "dropdown") 创建一个下拉列表，因为标题是列表的第二个元素它必须位于 Logo 下方。所以我“破解”了那个“破解!”在对 tags$h1() 的调用中，我发现可以为边距指定负值。通过将其设置为 -50px，我得到了所需的输出。我确信真正理解 HTML 和 CSS 的真正计算机程序员可以给出更优雅的解决方案。对于不是程序员的 R 用户，这里是我的“hacking-the-hack”解决方案的可重现代码。关于下载图像、将其保存到 www 子目录并将脚本保存为 app.R 的相同注意事项(如我的问题中所述)适用于此:

library(shiny)
library(shinydashboard)
library(plyr)
library(tmap)
library(tmaptools)
library(sp)
library(rgdal)

Projects<-c("Test", "Test", "Example", "Example", "Exhibit B", "Exhibit B")
Units<-c("A1", "A2", "B1", "B2", "C1", "C2")
CHOICE<-data.frame(PROJECTS = Projects, UNITS = Units)

P1<-sample(Projects, 100, replace=TRUE)
U1<-sample(Units, 100, replace=TRUE)
V1<-runif(100, 44.000, 45.900)
V2<-runif(100, -120.5, -118.0)

Data<-data.frame(Project = P1, Unit = U1, Value_1 = V1, Value_2 = V2)

ui<-dashboardPage(title = "Example",# Start Dashboard Page
                  header = dashboardHeader(
                    tags$li(class = "dropdown",
                            tags$style(".main-header {max-height: 100px}"),
                            tags$style(".main-header .logo {height: 100px} .primary-title height {100px}"),
                            tags$style(".sidebar-toggle {height: 20px; padding-top: 1px !important;}"),
                            tags$style(".navbar {min-height:20px !important}")
                    ),
                    titleWidth='100%',
                    title = span(
                      tags$img(src="Rlogo.png", width = '5%', align='right'), 
                      column(12, class="title-box", 
                             tags$h1(class="primary-title", style='margin-top:-50px;', 'EXAMPLE SHINY DASHBOARD APP')
                      ))),#End Header,
  dashboardSidebar(
                selectInput(inputId = "Prj", "Select a Project", choices = unique(CHOICE$PROJECTS), selected = unique(CHOICE$PROJECTS)[1]),
                selectInput(inputId = "Unit", "Select a Unit", choices = NULL)
  ),
  dashboardBody(
    tmapOutput(outputId = "map"),
    tableOutput(outputId = "TABLE")
  )
)

server<-function(input, output, session){
  observeEvent(input$Prj,{
    updateSelectInput(session, "Unit", 
                      choices = unique(CHOICE$UNITS[CHOICE$PROJECTS==input$Prj]), 
                      selected = unique(CHOICE$UNITS[CHOICE$PROJECTS==input$Prj])[1])
  })
  output$TABLE<-renderTable({
    Data2<-subset(Data, Project == input$Prj & Unit == input$Unit)
    tbl<-ddply(Data2, c("Project", "Unit"), summarize, VALUE = max(Value_1), OTHER_VALUE=mean(Value_2))
    return(tbl)
  })
  output$map<-renderTmap({
    Data2<-subset(Data, Project == input$Prj & Unit == input$Unit)
    WGS84<-CRS("+init=epsg:4326")
    Pts<-SpatialPointsDataFrame(Data2[,c(4,3)], Data2[,c(1:2)], proj4string = WGS84)
    tmap_mode("view")
    tm_shape(Pts)+
      tm_dots("Project")+
      tm_basemap(server=providers$Esri.WorldImagery)
  })
}

shinyApp(ui = ui, server = server)