r - ggplot 的 Shiny 切割顶部

Question

我对 Shiny 很陌生，对 ggplot 也有些陌生。我创建了一个在 RStudio 中看起来不错的图，但是在 renderPlot 中使用它时，图的顶部被截断了。我尝试更改大小(将“height = X”添加到 renderPlot 函数)，这很有效，但 fluidRows 最终渲染在彼此之上。有没有办法不切断情节的顶部？是通过调整渲染大小，还是以某种方式更改 ggplot？

我有这个 UI 和服务器:

shinyUI(fluidPage(

  # Application title
  titlePanel("IGP Risk Analysis"),

  sidebarLayout(
    sidebarPanel(
      uiOutput("portfolio"),  
      uiOutput("portDate"),
      uiOutput("portMetrics"),
      uiOutput("portFields"),
      uiOutput("riskButton"),
      width = 2),

    mainPanel(
      tabsetPanel(type = "tabs", 
                  tabPanel("Summary", 
                           fluidRow(plotOutput("plots")),
                           fluidRow(dataTableOutput("summary"))),
                  tabPanel("Plots"), 
                  tabPanel("Tables", tableOutput("tables"))
      )
    )
  )
))

shinyServer(function(input, output) {

  output$portfolio <- renderUI ({
    temp <- setNames(sendRequest(theURL, myUN, myPW, action = "GetPortfolios"), "Available Portfolios")
    temp <- temp[sapply(temp, function (x) !grepl("AAA|ZZZ|Test|test",x)),]
    selectInput("portfolio", "Underlying Portfolio:", choices = c("Pick One",temp))
  })

  output$portDate <- renderUI ({
    if (is.null(input$portfolio) || input$portfolio == "Pick One") return() else { 
           portfolioDates <- setNames(sendRequest(theURL, myUN, myPW, action = "GetPortfolioDates", 
                                                  portfolioName = input$portfolio, portfolioCurrency = theCurrency), "Available Dates")
           selectInput("portDate", "Portfolio Date",
                             choices = c("Pick One", portfolioDates),
                             selected = "Pick One") }
  })

  output$portMetrics <- renderUI ({
    if (is.null(input$portDate) || input$portDate == "Pick One") return() else { 
      portfolioMetrics <- names(theRiskMetrics)
      selectInput("portMetrics", "Portfolio Metrics",
                  choices = portfolioMetrics,
                  multiple = TRUE) }
  })


  output$portFields <- renderUI ({
    if (is.null(input$portDate) || input$portDate == "Pick One") return() else { 
      portfolioFields <- setNames(sendRequest(theURL, myUN, myPW, action = "GetGroupingFields", 
                                             portfolioName = input$portfolio, portfolioCurrency = theCurrency, portfolioDate = input$portDate), "Available Fields")
      selectInput("portFields", "Portfolio Fields",
                  choices = portfolioFields,
                  multiple = TRUE) }
  })

  output$riskButton <- renderUI ({
    if (is.null(input$portFields)) return() else actionButton("riskButton", "Get the Risk")
  })

  output$summary <- renderDataTable({
    if (is.null(input$portFields)) return(data.frame("Choose Portfolio..." = NA, check.names = FALSE)) else {
    input$riskButton
    dataset <<- sendRequest(theURL, myUN, myPW, action = "GetPortfolioSummary",
                          portfolioName = input$portfolio, portfolioCurrency = theCurrency, portfolioDate = input$portDate)
    dataset <<- dataset[ grepl("Risk Decomp|Contribution", dataset$ID), ]
    dataset$val = paste0(round(dataset$val, 4), "%")
    dataset #} else return()
    }
  })

  output$plots <- renderPlot({
    if (is.null(input$portFields)) return("") else {
      input$riskButton
      riskDecomp <- dataset[grepl("Risk Decomp",dataset$ID),]
      riskDecomp$ID <- gsub(c("Risk Decomp "), "", riskDecomp$ID)
      thePlot <- waterfall(categories = riskDecomp$ID, values = riskDecomp$val, labelType = "percent", igpify = TRUE)
      print(thePlot)
    }
  })

})

我的 waterfall() 函数如下所示:

waterfall <- function(theTitle = "Risk Decomposition", categories, values, has.total = FALSE, 
                      offset = .475, labelType = c("decimal", "percent"), igpify = FALSE) {
  library(scales)
  library(grid)
  library(ggplot2)
  library(dplyr)

  theData <- data.frame("category" = as.character(categories), "value" = as.numeric(values))
  if (labelType == "percent") theData$value = theData$value/100
  if (!has.total) theData <- theData %>% rbind(.,list("Total", sum(.$val)))
  theData$sign <- ifelse(theData$val >= 0, "pos","neg")
  theData <- data.frame(category = factor(theData$category, levels = unique(theData$category)),
                        value = round(theData$value,4),
                        sign = factor(theData$sign, levels = unique(theData$sign)))
  theData$id <- seq_along(theData$value)
  theData$end <- cumsum(theData$value)
  theData$end <- c(head(theData$end, -1), 0)
  theData$start <- c(0, head(theData$end, -1))
  theData$labels <- paste0(theData$value*100, "%")
  theData$labellocs <- pmax(theData$end,theData$start)

  theGG <- ggplot(theData, aes(category, fill = sign, color = sign)) + 
    geom_rect(aes(x = category, xmin = id - offset, xmax = id + offset, ymin = end, ymax = start)) +
    scale_x_discrete("", breaks = levels(theData$category), labels = gsub("\\s", "\n", trimSpaces(levels(theData$category)))) + 
    geom_text(data = theData, aes(id, labellocs, label = labels), vjust = -.5, size = 5, fontface = 4)
  if(igpify) {
    g <- rasterGrob(blues9, width=unit(1,"npc"), height = unit(1,"npc"), interpolate = TRUE)
    thePP <- theGG + annotation_custom(g) +
      guides(fill = FALSE, color=FALSE) +
      ggtitle(theTitle) + 
      theme(plot.title = element_text(vjust=1.5, face="bold", size = 20),
            axis.title.x = element_blank(), axis.title.y = element_blank()) +
      scale_fill_manual(values=c("red", "forestgreen")) + 
      scale_color_manual(values=c("black", "black")) + 
      scale_y_continuous(labels = percent)
    n1 <- length(thePP$layers)
    thePP$layers <- c(thePP$layers[[n1]],thePP$layers[-n1])
    return(thePP)
  } else return(theGG)
}

这一切都产生了下面的图，它只缺少一点顶部:

请注意，它只是文本的顶部(77% 和 100%)。未截止如下:

Answer 1

所以我认为这是一个 ggplot 截断文本的情况，该文本超出了某些宽高比的 y 限制。以下代码:

library(ggplot2)

g <- rasterGrob(blues9, width=unit(1,"npc"), height = unit(1,"npc"), interpolate = TRUE)

df <- data.frame(x=c(1,2,3,4),y=c(0.7,0.8,0.9,1.0))
df$labels <- sprintf("%.1f %%",100*df$y)
ggplot(df) +annotation_custom(g) + 
   geom_bar(aes(x,y),stat="identity",fill="red",color="black") +
   geom_text(data = df, aes(x, y, label = labels), vjust = -.5, size = 5, fontface = 4) + 
   theme(plot.title = element_text(vjust=1.5, face="bold", size = 20),
         axis.title.x = element_blank(), axis.title.y = element_blank()) +
   labs(title="Risk Decomposition")

生成此图 - 请注意，您可能需要压缩 R-Studio 中的预览以使其中断。

可以通过多种方式解决此问题，例如通过改变 vjust 参数、调整 y 轴限制，或者(也许)通过在正确的地方。在这种情况下，我调整了 y 轴限制，如下所示:

ggplot(df) +annotation_custom(g) + 
  geom_bar(aes(x,y),stat="identity",fill="red",color="black") +
  geom_text(data = df, aes(x, y, label = labels), vjust = -.5, size = 5, fontface = 4) + 
  theme(plot.title = element_text(vjust=1.5, face="bold", size = 20),
        axis.title.x = element_blank(), axis.title.y = element_blank()) +
  scale_y_continuous(limits=c(0,1.2),breaks=c(0,1)) +
  labs(title="Risk Decomposition")

得到这个: