ShinyDashboard 仪表板标题与浏览器中的徽标不符

Question

我正在构建一个闪亮的应用程序，我想要一个静态的 dashboardHeader() 标题，其右侧有一个徽标。我查看了 stackoverflow 以弄清楚如何做到这一点，似乎这需要 HTML 标签。我不是计算机程序员——只是一个 R 用户，所以我不太了解这些是如何工作的。但是按照其他人的建议，我似乎需要tag$li() 来设置标题栏和徽标的高度。当我运行该应用程序时，标题会在 RStudio 闪亮查看器中按我想要的方式显示，但是当我在浏览器 (Chrome) 中查看它时，标题会低于徽标并被切断。下面是一个可重现的例子。您首先需要下载 [R logo] 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 的工作原理。我发现要同时获得徽标和标题以显示 tags$li(class = "dropdown") 的使用会创建一个下拉列表，并且由于标题是列表的第二个元素，它必须位于徽标下方。所以我“破解”了那个“破解！”在对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)