使用 ggplot 和 Shiny R 中的 geom_histogram 响应式更新 y 轴

Question

所以我正在尝试解决以下问题，但我可能走错了路。

随着这些样本量的增加，我需要更新 y 限制，以便 geom_histogram() 中的最高条不会超出顶部。特别是如果圣。开发者设置在 0 附近。

这实际上是我使用 Shiny 和响应式应用程序的第二天，所以我觉得自己陷入困境。

我想我需要保存 ggplot() 对象，然后使用最后一个直方图中最大条的值反应性地更新它们的 ylimit。只是不确定我是否可以按照现在设置的方式做到这一点。

（我意识到我在 2 年前遇到过类似的问题）

ggplot2 Force y-axis to start at origin and float y-axis upper limit

这是不同的，因为需要告诉y轴增加的是直方图的高度，而不是最大的数据值。另外，因为闪亮。

我的 server.R 函数看起来像

    library(shiny)
library(ggplot2)
library(extrafont)


# Define server logic for random distribution application
function(input, output, session) {


    data <- reactive({
            set.seed(123)

             switch(input$dist, 
                    norm = rnorm(input$n, 
                                 sd = input$stDev),
                    unif = runif(input$n,-4,4),
                    lnorm = rlnorm(input$n)
                    )
                 })

    height="100%"

    plotType <- function(blah, maxVal, stDev, n, type) {

      roundUp <- function(x) 10^ceiling(log10(x)+0.001)
      maxX<- roundUp(maxVal)
      breakVal<-max(floor(maxX/10),1)

      switch(type,
             norm =  ggplot(as.data.frame(blah), aes(x=blah))+
               geom_histogram(binwidth = 0.2,
                              boundary = 0, 
                              colour = "black") +
               scale_y_continuous(limits = c(0, maxX),
                                  breaks = seq(0, maxX, breakVal), 
                                  expand = c(0, 0)) +
               scale_x_continuous(breaks = seq(-4, 4, 1),
                                  expand = c(0, 0)) +
               theme_set(theme_bw(base_size = 40) +
               ylab("Frequency")+
               xlab("")+
               coord_cartesian(xlim=c(-4, 4))+
               ggtitle(paste("n = ",n, "St Dev =", stDev,"  Normal Distribution ", sep = ' ')),

             unif =  ggplot(as.data.frame(blah), aes(x=blah))+
               geom_histogram(binwidth=0.1, boundary =0,colour = "black")+
               scale_y_continuous(limits = c(0,roundUp(maxVal*(3/stDev))),
                                  breaks=seq(0,roundUp(maxVal*(3/stDev)), roundUp(maxVal*(3/stDev))/10),
                                  expand = c(0, 0))+
               scale_x_continuous(breaks=seq(-4,4,1),expand = c(0, 0))+
               theme_set(theme_bw(base_size = 40))+
               ylab("Frequency")+xlab("")+
               coord_cartesian(xlim=c(-4,4))+
               ggtitle(paste("n = ",n, "     Uniform Distribution ", sep = ' ')),


             lnorm = ggplot(as.data.frame(blah), aes(x=blah))+
               geom_histogram(binwidth=0.2, boundary =0,colour = "black")+
               scale_y_continuous(limits = c(0,maxX),
                                  breaks=seq(0,maxX, breakVal),
                                  expand = c(0, 0))+
               scale_x_continuous(breaks=seq(0,8,1),expand = c(0, 0))+
               theme_set(theme_bw(base_size = 40))+
               ylab("Frequency")+xlab("")+
               coord_cartesian(xlim=c(0,8))+
                 ggtitle(paste("n = ",n, "     Log-Normal Distribution ", sep = ' '))
      )

    }

    observe({ 
      updateSliderInput(session, "n", 
                        step = input$stepSize,
                        max=input$maxN)
             })
    plot.dat <- reactiveValues(main=NULL, layer1=NULL)

     #plotType(data, maxVal, stDev, n, type)
    output$plot <- renderPlot({ 
                                plotType(data(),

                                switch(input$dist,
                                       norm = max((input$n)/7,1),
                                       unif = max((input$n)/50,1),
                                       lnorm =max((input$n)/8,1)
                                          ), 

                                input$stDev, 
                                input$n,
                                input$dist) })


  # Generate a summary of the data
  output$summary <- renderTable(
    as.array(round(summary(data())[c(1,4,6)],5)),
    colnames=FALSE
  )

  output$stDev <- renderTable(
    as.array(sd(data())),
    colnames=FALSE
  )

  # Generate an HTML table view of the data
  output$table <- renderTable({
    data.frame(x=data())
  })

}

我的 ui.R 看起来像

  library(shiny)
library(shinythemes)
library(DT)


# Define UI for random distribution application 
shinyUI(fluidPage(theme = shinytheme("slate"),

  # Application title
  headerPanel("Michael's Shiny App"),

  # Sidebar with controls to select the random distribution type
  # and number of observations to generate. Note the use of the
  # br() element to introduce extra vertical spacing
  sidebarLayout(
    sidebarPanel(
      tags$head(tags$style("#plot{height:90vh !important;}")),
      radioButtons("dist", "Distribution:",
                   c("Standard Normal" = "norm",
                     "Uniform" = "unif",
                     "Log-normal" = "lnorm")),
      br(),

      numericInput("stepSize", "Step", 1, min = 1, max = NA, step = NA,
                   width = NULL),
      numericInput("maxN", "Max Sample Size", 50, min = NA, max = NA, step = NA,
                   width = NULL),

      br(),

        sliderInput("n", 
                  "Number of observations:", 
                  value = 0,
                  min = 1, 
                  max = 120000,
                  step = 5000,
                  animate=animationOptions(interval=1200, loop=T)),

      sliderInput("stDev", 
                  "Standard Deviation:", 
                  value = 1,
                  min = 0, 
                  max = 3,
                  step = 0.1,
                  animate=animationOptions(interval=1200, loop=T)),

      p("Summary Statistics"),         
      tabPanel("Summary", tableOutput("summary")),
      p("Sample St. Dev."),
      tabPanel("Standard Dev", tableOutput("stDev")),
      width =2
    ),

    # Show a tabset that includes a plot, summary, and table view
    # of the generated distribution
    mainPanel(
      tabsetPanel(type = "tabs", 
                  tabPanel("Plot", plotOutput("plot")), 
                  tabPanel("Table", tableOutput("table"))
      ))

  )))

整个事情有很多冗余。我想要做的是，一旦直方图上最大的条形图接近 y 上限，我希望 ylimit 跳到 10 的下一个幂。

非常感谢任何建议。

Update 松散地，我最终使用的解决方案如下：在 renderPlot() 函数中，您需要保存ggplot 对象。然后如下所述，访问 ymax 值（仍在 renderPlot() 内），

 ggplot_build(norm)$layout$panel_ranges[[1]]$y.range[[2]]

然后用它来更新 y 轴。我使用以下函数来使轴限制 "nice"。

roundUpNice <- function(x, nice=c(1,2,4,5,6,8,10)) {
        10^floor(log10(x)) * nice[[which(x <= 10^floor(log10(x)) * nice)[[1]]]]
      }

然后更新y轴。（仍在 renderplot() 内）

   ymaxX = roundUpNice(ggplot_build(norm)$layout$panel_ranges[[1]]$y.range[[2]])


  norm+scale_y_continuous(limits = c(0, max(ymaxX, 20)), 
                        expand=c(0,0))

Answer 1

首先，存储直方图（默认轴）。

p1 <- ggplot(...) + geom_histogram()

然后，使用ggplot_build(p1)到access the heights of the histogram bars。例如，

 set.seed(1)
 df <- data.frame(x=rnorm(10000))
 library(ggplot2)
 p1 <- ggplot(df, aes(x=x)) + geom_histogram()
 bar_max <- max(ggplot_build(p1)[['data']][[1]]$ymax) # where 1 is index 1st layer
 bar_max # returns 1042

您将需要一个函数来告诉您 10 的下一个幂是多少，例如：

nextPowerOfTen <- function(x) as.integer(floor(log10(x) + 1))
# example: nextPowerOfTen(999) # returns 3 (10^3=1000)

您需要检查 bar_max 是否在下一个 10 的幂的一定范围内（根据您的偏好）。如果触发调整，您可以简单地执行 p1 + scale_y_continuous(limits=c(0,y_max_new))。

Answer 2

我发现答案隐藏在您代码的 "scale_y_continuous()" 部分。该应用程序非常接近，但在某些情况下，数据超出了 y 轴，这使得它看起来运行比您所说的轴限制更远。

要解决此问题，scale_y_continuous 部分中的扩展参数需要设置为 "c(0.05, 0)"，而不是 "c(0, 0)"。

首先，我通过在您的应用程序中将样本大小设置为 50 并将标准差设置为 0.3，复制了您描述的图表示例运行-off。运行将原始代码与"expand=c(0, 0)"结合后，我们可以看到我们得到了下图：

此问题已通过将参数更改为 "expand=c(0.05, 0)" 解决，如下所示：

有关固定脚本的副本，请参见下文。

第 1 部分 -- server.R

library(shiny)
library(ggplot2)
library(extrafont)


# Define server logic for random distribution application
function(input, output, session) {

  data <- reactive({
    set.seed(123)

    switch(input$dist, 
           norm = rnorm(input$n, 
                        sd = input$stDev),
           unif = runif(input$n,-4,4),
           lnorm = rlnorm(input$n)
    )
  })

  height="100%"

  plotType <- function(blah, maxVal, stDev, n, type){

    roundUp <- function(x){10^ceiling(log10(x)+0.001)}
    maxX<- roundUp(maxVal)
    breakVal<-max(floor(maxX/10),1)

    switch(type,
           norm=ggplot(as.data.frame(blah), aes(x=blah)) +
             geom_histogram(binwidth = 0.2,
                            boundary = 0, 
                            colour = "black") +
             scale_y_continuous(limits = c(0, maxX),
                                breaks = seq(0, maxX, breakVal), 
                                expand = c(0.05, 0)) +
             scale_x_continuous(breaks = seq(-4, 4, 1),
                                expand = c(0, 0)) +
             theme_set(theme_bw(base_size = 40)) +
             ylab("Frequency") +
             xlab("") +
             coord_cartesian(xlim=c(-4, 4))+
             ggtitle(paste("n = ",n, "St Dev =", stDev,
                           "  Normal Distribution ", sep = ' ')),
           unif=ggplot(as.data.frame(blah), aes(x=blah)) +
             geom_histogram(binwidth=0.1, boundary=0, colour="black")+
             scale_y_continuous(
               limits = c(0,roundUp(maxVal*(3/stDev))),
               breaks=seq(0,roundUp(maxVal*(3/stDev)),
                                    roundUp(maxVal*(3/stDev))/10),      
               expand = c(0.05, 0))+
               scale_x_continuous(breaks=seq(-4,4,1),expand=c(0, 0)) +
                     theme_set(theme_bw(base_size = 40))+
                     ylab("Frequency")+xlab("")+
                     coord_cartesian(xlim=c(-4,4))+
                     ggtitle(paste("n = ",n,
                             "     Uniform Distribution ", sep = ' ')),
           lnorm=ggplot(as.data.frame(blah), aes(x=blah))+
              geom_histogram(binwidth=0.2,boundary=0, colour="black") +
                     scale_y_continuous(limits=c(o,maxX),
                                        breaks=seq(0,maxX, breakVal),
                                        expand = c(0.05, 0)) +
                     scale_x_continuous(breaks=seq(0,8,1),
                                        expand = c(0, 0)) +
                     theme_set(theme_bw(base_size = 40)) +
                     ylab("Frequency") +
                     xlab("") +
                     coord_cartesian(xlim=c(0,8)) +
                     ggtitle(paste("n = ",n,
                                   "     Log-Normal Distribution ",
                                   sep = ' '))
    )

}

observe({ 
  updateSliderInput(session, "n", 
                    step = input$stepSize,
                    max=input$maxN)
})
plot.dat <- reactiveValues(main=NULL, layer1=NULL)

#plotType(data, maxVal, stDev, n, type)
output$plot <- renderPlot({ 
  plotType(data(),

           switch(input$dist,
                  norm = max((input$n)/7,1),
                  unif = max((input$n)/50,1),
                  lnorm =max((input$n)/8,1)
           ), 

           input$stDev, 
           input$n,
           input$dist) })


# Generate a summary of the data
output$summary <- renderTable(
  as.array(round(summary(data())[c(1,4,6)],5)),
  colnames=FALSE
)

output$stDev <- renderTable(
  as.array(sd(data())),
  colnames=FALSE
)

# Generate an HTML table view of the data
output$table <- renderTable({
  data.frame(x=data())
})

}

第 2 部分 -- ui.R

library(shiny)
library(shinythemes)
library(DT)

# Define UI for random distribution application 
shinyUI(fluidPage(theme = shinytheme("slate"),

        # Application title
        headerPanel("Michael's Shiny App"),

        # Sidebar with controls to select the random distribution type
        # and number of observations to generate. Note the use of the
        # br() element to introduce extra vertical spacing
        sidebarLayout(
          sidebarPanel(
            tags$head(tags$style("#plot{height:90vh !important;}")),
                      radioButtons("dist", "Distribution:",
                                   c("Standard Normal" = "norm",
                                   "Uniform" = "unif",
                                   "Log-normal" = "lnorm")),
          br(),
          numericInput("stepSize", "Step", 1, 
                       min = 1, max = NA, step = NA, width = NULL),
          numericInput("maxN", "Max Sample Size", 50, 
                       min = NA, max = NA, step = NA,width = NULL),
          br(),

          sliderInput("n", "Number of observations:", value = 0,
                      min = 1, max = 120000, step = 5000,
                      animate=animationOptions(interval=1200, loop=T)),
          sliderInput("stDev","Standard Deviation:",value = 1,
                      min = 0,max = 3,step = 0.1,
                      animate=animationOptions(interval=1200, loop=T)),

          p("Summary Statistics"),         
          tabPanel("Summary", tableOutput("summary")),
          p("Sample St. Dev."),
          tabPanel("Standard Dev", tableOutput("stDev")),
                   width =2),

          # Show a tabset that includes a plot, summary, and table view
          # of the generated distribution
          mainPanel(tabsetPanel(type = "tabs", 
                    tabPanel("Plot", plotOutput("plot")), 
                    tabPanel("Table", tableOutput("table"))
                   ))

)))

Update 松散地，我最终使用的解决方案如下：在 renderPlot() 函数中，您需要保存ggplot 对象。然后如下所述，访问 ymax 值（仍在 renderPlot() 内），

 ggplot_build(p1)$layout$panel_ranges[[1]]$y.range[[2]]

然后用它来更新 y 轴。我使用以下函数来使轴限制 "nice"。

roundUpNice <- function(x, nice=c(1,2,4,5,6,8,10)) {
        if(length(x) != 1) stop("'x' must be of length 1")
        10^floor(log10(x)) * nice[[which(x <= 10^floor(log10(x)) * nice)[[1]]]]
      }

使用 ggplot 和 Shiny R 中的 geom_histogram 响应式更新 y 轴

Updating y-axis Reactively with geom_histogram from ggplot and Shiny R

r

ggplot2

shiny

reactive