在 Shiny 中控制多个凹坑图的布局

Question

我一直在根据此处的示例研究交互式人口金字塔 Interactive Population Pyramids。具体来说，我修改了用于 Dimple.js 人口金字塔实现的代码。在 RStudio 中，一切运行良好，但最终产品最好作为 Shiny App 使用。部署到 Shiny 应用程序时，它运行良好，但我无法控制图表的大小及其位置。我打算在同一页上有 4 个图表，理想的布局是 4 个象限（2 行和 2 列），每个象限都有自己的可视化效果。目前我不知道如何通过 R 或 Dimple.js 本身来控制我的图表大小或 Dimple.js 图表的布局。对此的任何帮助将不胜感激我当前的代码如下：

library(shiny)
library(rcdimple)
library(curl)  #devtools::install_github("jeroenooms/curl")
library(plyr)  # for round_any
library(rCharts)

df <- read.csv(curl("https://raw.githubusercontent.com/kilimba/data/master/data2.csv"))
agegroup_mapping <- read.csv(curl("https://raw.githubusercontent.com/kilimba/data/master/agegroup.csv"))
df <- merge(df,agegroup_mapping,by.x="agegrp",by.y="agegroup")
# Max and minimum year to determine range of years to animate by
maxYear <- max(df$year)
minYear <- min(df$year)
# maximum and minimum values for population to determine x-axis
max_x <- round_any(max(df$n), 1000, f = ceiling)
min_x <- round_any(min(-1*df$n), 1000, f = floor)

getData <- function(startyr,endyear) {
  df <- subset(df,(year >= startyr & year <= endyear))
  return(df)
}

# DimpleJS pyramid

dPyramid <- function(startyear, endyear, colors=NULL) {
  #endyear = endyear + 3 #to test storyboard
  dat <- getData(startyear, endyear)
  dat$n <- ifelse(dat$sex == 'MAL', -1 * dat$n, 1 * dat$n)
  dat$gencode <- ifelse(dat$sex == 'MAL', 1, 2)

  d1 <- dimple(
    x = "n", 
    y = "agegrp", 
    groups = "sex", 
    data = dat, 
    type = 'bar')


  d1 <- yAxis(d1, type = "addCategoryAxis", orderRule = "ord")
  d1 <- xAxis(d1,type = "addMeasureAxis")
  d1 <- add_legend( d1,x = 60, y = 10, width = 700, height = 20, horizontalAlign = "right" )
  # Ensure fixed x-axis indepencent of year selected
  d1 <- xAxis(d1, overrideMax = max_x, overrideMin = min_x)

  if (!is.null(colors)){
    d1 <- colorAxis(
      d1,
      type = "addColorAxis", 
      colorSeries = "gencode", 
      palette = colors
    )
  }

  if (endyear - startyear >= 1) {
    d1 <- tack(d1, options = list( storyboard = "year" ) )
#     max_x <- round_any(max(dat$n), 1000, f = ceiling)
#     min_x <- round_any(min(dat$n), 1000, f = floor)
#     d1 <- xAxis(d1, overrideMax = max_x, overrideMin = min_x)
  }

  d1
}


#ui.R

# Define UI for application that draws a outcome pyramid
ui <- shinyUI(fluidPage(

  # Application title
  titlePanel("Options"),

  sidebarLayout(
    sidebarPanel(
      checkboxInput("doAnimate", "Animate Pyramid",value = TRUE),
      tags$p("(Uncheck to select specific year)"),
      conditionalPanel(
        condition = "input.doAnimate == false",
        selectInput(    
                  inputId = "startyr",
                  label = "Select Pyramid Year",
                  c(2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014)),
                  width = 2
      ),
      selectInput(inputId = "agegrp",
                  label = "Choose Age Group",
                  choices = c("0-4",
                              "5-9",
                              "10-14",
                              "15-19",
                              "20-24",
                              "25-29",
                              "30-34",
                              "35-39",
                              "40-44",
                              "45-49",
                              "50-54",
                              "55-59",
                              "60-64",
                              "65-69",
                              "70-74",
                              "75-79",
                              "80-84",
                              "85+"
                  ),
                  selected = "0-4")
    ),

    # Show a plot of the generated pyramid
    mainPanel("Multi-Panel Visualizations",
      fluidRow(style="height:300px;"
               ,column(width = 6,dimpleOutput("distPlot",height="100%", width="100%"))
               ,column(width = 6,showOutput("distPlot2","nvd3"))
      )
      ,fluidRow(style="height:300px;"
                ,column(width = 6,dimpleOutput("distPlot3",height="100%"))
                ,column(width = 6,dimpleOutput("distPlot4",height="100%"))
      )
    )
  )
))


# Define server logic required to draw a population pyramid
server <- shinyServer(function(input, output) {

  observe({

    if(input$doAnimate){

    output$distPlot <- renderDimple({
      dPyramid(minYear, maxYear)
    })

  }else{

    output$distPlot <- renderDimple({
      startyear <- as.numeric(input$startyr)
      # Start year and end year are equal we only want cross-sectional pyramid
      # for a single selected year
      dPyramid(startyear, startyear)
    })    
  }
  })
   # Top right quadrant, line-chart
  output$distPlot2 <- renderChart2({

    selection <- subset(df,mapping == input$agegrp)

    plot <- nPlot(n ~ year,
                  data = selection,
                  type = "lineChart",
                  group = "sex")

    # Add axis labels and format the tooltip
    plot$yAxis(axisLabel = "Population", width = 62)

    plot$xAxis(axisLabel = "Year")

    plot$save("ac.html")
    return(plot)    

  })


  output$distPlot3 <- renderDimple({
    startyear <- as.numeric(input$startyr)
    # Both arguments currently for the same thing, startyear, but eventually will want to 
    # process a range of years
    dPyramid(startyear, startyear)
  })
  output$distPlot4 <- renderDimple({
    startyear <- as.numeric(input$startyr)
    # Both arguments currently for the same thing, startyear, but eventually will want to 
    # process a range of years
    dPyramid(startyear, startyear)
  })
})


#shinyApp(ui,server)

它使用的数据可以在这里找到：https://raw.githubusercontent.com/kilimba/data/master/data2.csv

Answer 1

这可以通过 rCharts 完成，但是由于 rcdimple https://github.com/timelyportfolio/rcdimple was released 并且受益于 htmlwidgets 的基础结构，我强烈建议继续使用它。如果您希望看到 rCharts 答案，请告诉我。

library(shiny)
library(rcdimple)
library(curl)  #devtools::install_github("jeroenooms/curl")
library(plyr)  # for round_any

df <- read.csv(curl("https://raw.githubusercontent.com/kilimba/data/master/data2.csv"))
df$year <- df$ExpYear
df$sex <- df$Sex
df$agegrp <- df$AgeGroup

getData <- function(startyr,endyear) {
  df <- subset(df,(year >= startyr & year <= endyear))
  return(df)
}

# DimpleJS pyramid

dPyramid <- function(startyear, endyear, colors=NULL) {
  #endyear = endyear + 3 to test storyboard
  dat <- getData(startyear, endyear)
  dat$n <- ifelse(dat$sex == 'MAL', -1 * dat$n, 1 * dat$n)
  dat$gencode <- ifelse(dat$sex == 'MAL', 1, 2)

  d1 <- dimple(
    x = "n", 
    y = "agegrp", 
    groups = "sex", 
    data = dat, 
    type = 'bar')


  d1 <- yAxis(d1, type = "addCategoryAxis", orderRule = "ord")
  d1 <- xAxis(d1,type = "addMeasureAxis")
  d1 <- add_legend( d1,x = 60, y = 10, width = 700, height = 20, horizontalAlign = "right" )

  if (!is.null(colors)){
    d1 <- colorAxis(
      d1,
      type = "addColorAxis", 
      colorSeries = "gencode", 
      palette = colors
    )
  }

  if (endyear - startyear >= 1) {
    d1 <- tack(d1, options = list( storyboard = "year" ) )
    max_x <- round_any(max(dat$n), 1000, f = ceiling)
    min_x <- round_any(min(dat$n), 1000, f = floor)
    d1 <- xAxis(d1, overrideMax = max_x, overrideMin = min_x)
  }

  d1
}


#ui.R

# Define UI for application that draws a outcome pyramid
ui <- shinyUI(fluidPage(

  # Application title
  titlePanel("Outcome Pyramid"),

  sidebarLayout(
    sidebarPanel(
      selectInput(inputId = "startyr",
                  label = "Select Start Year",
                  c(2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014))
    ),

    # Show a plot of the generated pyramid
    mainPanel(
      fluidRow(style="height:300px;"
        ,column(width = 6,dimpleOutput("distPlot",height="100%"))
        ,column(width = 6,dimpleOutput("distPlot2",height="100%"))
      )
      ,fluidRow(style="height:300px;"
        ,column(width = 6,dimpleOutput("distPlot3",height="100%"))
        ,column(width = 6,dimpleOutput("distPlot4",height="100%"))
      )
    )
  )
))


# Define server logic required to draw a population pyramid
server <- shinyServer(function(input, output) {

  output$distPlot <- renderDimple({
    startyear <- as.numeric(input$startyr)
    # Both arguments currently for the same thing, startyear, but eventually will want to 
    # process a range of years
    dPyramid(startyear, startyear)
  })
  output$distPlot2 <- renderDimple({
    startyear <- as.numeric(input$startyr)
    # Both arguments currently for the same thing, startyear, but eventually will want to 
    # process a range of years
    dPyramid(startyear, startyear)
  })
  output$distPlot3 <- renderDimple({
    startyear <- as.numeric(input$startyr)
    # Both arguments currently for the same thing, startyear, but eventually will want to 
    # process a range of years
    dPyramid(startyear, startyear)
  })
  output$distPlot4 <- renderDimple({
    startyear <- as.numeric(input$startyr)
    # Both arguments currently for the same thing, startyear, but eventually will want to 
    # process a range of years
    dPyramid(startyear, startyear)
  })
})


shinyApp(ui,server)

Answer 2

要使 nvd3 正常工作，我们需要手动添加依赖项，因为 rCharts 和 htmlwidgets 都会通过 d3.js 发送，从而导致冲突。由于这是一个与最初提出的问题不同的问题，因此我将添加一个新答案而不是修改我的第一个答案。主要区别是将 add_lib=F 添加到 showOutput，然后在 UI.

中手动添加资产

library(shiny)
library(rcdimple)
library(curl)  #devtools::install_github("jeroenooms/curl")
library(plyr)  # for round_any
library(rCharts)

df <- read.csv(curl("https://raw.githubusercontent.com/kilimba/data/master/data2.csv"))
agegroup_mapping <- read.csv(curl("https://raw.githubusercontent.com/kilimba/data/master/agegroup.csv"))
df <- merge(df,agegroup_mapping,by.x="agegrp",by.y="agegroup")
# Max and minimum year to determine range of years to animate by
maxYear <- max(df$year)
minYear <- min(df$year)
# maximum and minimum values for population to determine x-axis
max_x <- round_any(max(df$n), 1000, f = ceiling)
min_x <- round_any(min(-1*df$n), 1000, f = floor)

getData <- function(startyr,endyear) {
  df <- subset(df,(year >= startyr & year <= endyear))
  return(df)
}

# DimpleJS pyramid

dPyramid <- function(startyear, endyear, colors=NULL) {
  #endyear = endyear + 3 #to test storyboard
  dat <- getData(startyear, endyear)
  dat$n <- ifelse(dat$sex == 'MAL', -1 * dat$n, 1 * dat$n)
  dat$gencode <- ifelse(dat$sex == 'MAL', 1, 2)

  d1 <- dimple(
    x = "n", 
    y = "agegrp", 
    groups = "sex", 
    data = dat, 
    type = 'bar')


  d1 <- yAxis(d1, type = "addCategoryAxis", orderRule = "ord")
  d1 <- xAxis(d1,type = "addMeasureAxis")
  d1 <- add_legend( d1,x = 60, y = 10, width = 700, height = 20, horizontalAlign = "right" )
  # Ensure fixed x-axis indepencent of year selected
  d1 <- xAxis(d1, overrideMax = max_x, overrideMin = min_x)

  if (!is.null(colors)){
    d1 <- colorAxis(
      d1,
      type = "addColorAxis", 
      colorSeries = "gencode", 
      palette = colors
    )
  }

  if (endyear - startyear >= 1) {
    d1 <- tack(d1, options = list( storyboard = "year" ) )
    #     max_x <- round_any(max(dat$n), 1000, f = ceiling)
    #     min_x <- round_any(min(dat$n), 1000, f = floor)
    #     d1 <- xAxis(d1, overrideMax = max_x, overrideMin = min_x)
  }

  d1
}


suppressMessages(
  singleton(
    addResourcePath(
      get_lib("nvd3")$name
      ,get_lib("nvd3")$url
    )
  )
)

#ui.R

# Define UI for application that draws a outcome pyramid
ui <- shinyUI(fluidPage(

  tags$head(get_assets_shiny(get_lib("nvd3"))[-3]),

  # Application title
  titlePanel("Options"),

  sidebarLayout(
    sidebarPanel(
      checkboxInput("doAnimate", "Animate Pyramid",value = TRUE),
      tags$p("(Uncheck to select specific year)"),
      conditionalPanel(
        condition = "input.doAnimate == false",
        selectInput(    
          inputId = "startyr",
          label = "Select Pyramid Year",
          c(2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014)),
        width = 2
      ),
      selectInput(inputId = "agegrp",
                  label = "Choose Age Group",
                  choices = c("0-4",
                              "5-9",
                              "10-14",
                              "15-19",
                              "20-24",
                              "25-29",
                              "30-34",
                              "35-39",
                              "40-44",
                              "45-49",
                              "50-54",
                              "55-59",
                              "60-64",
                              "65-69",
                              "70-74",
                              "75-79",
                              "80-84",
                              "85+"
                  ),
                  selected = "0-4")
    ),

    # Show a plot of the generated pyramid
    mainPanel("Multi-Panel Visualizations",
              fluidRow(style="height:300px;"
                       ,column(width = 6,dimpleOutput("distPlot",height="100%", width="100%"))
                       ,column(width = 6,showOutput("distPlot2","nvd3",add_lib=F))
              )
              ,fluidRow(style="height:300px;"
                        ,column(width = 6,dimpleOutput("distPlot3",height="100%"))
                        ,column(width = 6,dimpleOutput("distPlot4",height="100%"))
              )
    )
  )
))


# Define server logic required to draw a population pyramid
server <- shinyServer(function(input, output) {

  observe({

    if(input$doAnimate){

      output$distPlot <- renderDimple({
        dPyramid(minYear, maxYear)
      })

    }else{

      output$distPlot <- renderDimple({
        startyear <- as.numeric(input$startyr)
        # Start year and end year are equal we only want cross-sectional pyramid
        # for a single selected year
        dPyramid(startyear, startyear)
      })    
    }
  })
  # Top right quadrant, line-chart
  output$distPlot2 <- renderChart2({

    selection <- subset(df,mapping == input$agegrp)

    plot <- nPlot(n ~ year,
                  data = selection,
                  type = "lineChart",
                  group = "sex",
                  height = 300,
                  width = 300 )

    # Add axis labels and format the tooltip
    plot$yAxis(axisLabel = "Population", width = 62)

    plot$xAxis(axisLabel = "Year")

    plot$save("ac.html")
    return(plot)    

  })


  output$distPlot3 <- renderDimple({
    startyear <- as.numeric(input$startyr)
    # Both arguments currently for the same thing, startyear, but eventually will want to 
    # process a range of years
    dPyramid(startyear, startyear)
  })
  output$distPlot4 <- renderDimple({
    startyear <- as.numeric(input$startyr)
    # Both arguments currently for the same thing, startyear, but eventually will want to 
    # process a range of years
    dPyramid(startyear, startyear)
  })
})


shinyApp(ui,server)

在 Shiny 中控制多个凹坑图的布局

Controlling Layout of Multiple Dimple Charts in Shiny

shiny

rstudio

rcharts

dimple.js