R中的交互式绘图

Question

使用 plotly 库，我在 R 中制作了以下绘图：

library(dplyr)
library(ggplot2)
library(plotly)

set.seed(123)
df <- data.frame(var1 = rnorm(1000,10,10),
                   var2 = rnorm(1000,5,5))

df <- df %>% mutate(var3 = ifelse(var1 <= 5 & var2 <= 5, "a", ifelse(var1 <= 10 & var2 <= 10, "b", "c"))) 


plot = df %>%
  ggplot() + geom_point(aes(x=var1, y= var2, color= var3))


ggplotly(plot)

这是一个简单的散点图 - 生成两个随机变量，然后点的颜色由某些标准决定（例如，如果 var1 和 var2 在特定范围内）。

从这里，我还可以汇总统计数据：

df$var3 = as.factor(df$var3)
summary = df %>%
    group_by(var3) %>%
    summarize(Mean_var1 = mean(var1), Mean_var2 = mean(var2), count=n())

# A tibble: 3 x 4
  var3  Mean_var1 Mean_var2 count
* <fct>     <dbl>     <dbl> <int>
1 a         -1.70     0.946   158
2 b          4.68     4.94    260
3 c         15.8      6.49    582

我的问题：是否可以在此图中添加一些按钮，以允许用户根据自定义选择为点着色？例如。像这样：

现在，用户可以在他们想要的任何范围内输入 - 点的颜色会发生变化，并且会生成一些摘要统计信息。

谁能告诉我如何在 R 中做到这一点？

我有这个想法 - 首先我会创建一个巨大的表，它会创建“var1”和“var2”的所有可能范围组合：

vec1 <- c(-20:40,1)
vec2 <-  c(-20:40,1)


a <- expand.grid(vec1, vec2)

for (i in seq_along(vec1)) { 
    for (j in seq_along(vec2)) {

df <- df %>% mutate(var3 = ifelse(var1 <= i & var2 <= i, "a", ifelse(var1 <= j & j <= 10, "b", "c"))) 

}

}

然后，根据用户想要的范围 - SQL 风格的语句将这些行从对应于这些范围的海量表中分离出来：

custom_df = df[df$var1 > -20 & df$var1 <10 & df$var1 > -20 & df$var2 <10 , ]    

然后，将对“custom_df”进行单独的抓取，并为“custom_df”记录汇总统计信息：

summary = custom_df %>%
    group_by(var3) %>%
    summarize(Mean_var1 = mean(var1), Mean_var2 = mean(var2), count=n())

但我不确定如何在 R 中巧妙而有效地做到这一点。

有人可以告诉我怎么做吗？

谢谢

Answer 1

我已经构建了一个闪亮的小应用程序来满足您的大部分要求。根据您预定义的大型数据框df，用户可以定义以下内容：

1. 为变量var1 和var2 选择最小值和最大值。
2. 选择标准来定义变量var3，用于显示不同颜色的数据点。现在是一个范围。
3. 将绘图保存为 HTML 文件。
4. 以表格形式显示的汇总统计信息。

您可以定义更多选项，为用户提供选择颜色等的选项。为此，也许你应该在谷歌上搜索如何使用scale_color_manual()。

更新：添加了根据 var1 和 var2 范围值选择红色和绿色的用户选项。

library(shiny)
library(plotly)
library(dplyr)
library(DT)

### define a large df
set.seed(123)
df <- data.frame(var1 = rnorm(1000,10,10),
                 var2 = rnorm(1000,15,15))

ui <- fluidPage(
  titlePanel(p("My First Test App", style = "color:red")),
  sidebarLayout(
    sidebarPanel(
      p("Choose Variable limits"),

      # Horizontal line ----
      tags$hr(),
      uiOutput("var1a"), uiOutput("var1b"),
      uiOutput("var2a"), uiOutput("var2b"),
      uiOutput("criteria")

    ),
    mainPanel(
      DTOutput("summary"), br(),
      plotlyOutput("plot"),
      br(), br(), br(),
      uiOutput("saveplotbtn")
    )
  )
)

server <- function(input, output, session){
  
  output$var1a <- renderUI({
    tagList(
      numericInput("var11", "Variable 1 min",
                  min = min(df$var1), max = max(df$var1), value = min(df$var1))
    )
  })
  output$var1b <- renderUI({
    if (is.null(input$var11)){
      low1 <- min(df$var1)
    }else low1 <- max(min(df$var1),input$var11)  ## cannot be lower than var 1 minimum
    tagList(
      numericInput("var12", "Variable 1 max", min = low1, max = max(df$var1), value = max(df$var1))
    )
  })
  
  output$var2a <- renderUI({
    tagList(
      numericInput("var21", "Variable 2 min",
                   min = min(df$var2), max = max(df$var2), value = min(df$var2))
    )
  })
  output$var2b <- renderUI({
    if (is.null(input$var21)){
      low2 <- min(df$var2)
    }else low2 <- max(min(df$var2),input$var21)  ## cannot be lower than var 2 minimum
    tagList(
      numericInput("var22", "Variable 2 max", min = low2, max = max(df$var2), value = max(df$var2))
    )
  })
  
  output$criteria <- renderUI({
    req(input$var11,input$var12,input$var21,input$var22)
        
    tagList(
      sliderInput("crit11", "Variable 1 red color range:",
                  min = -10, max = 0, value = c(-10,0)),
      sliderInput("crit12", "Variable 2 red color range:",
                  min = -25, max = 0, value = c(-25,0)),
      sliderInput("crit21", "Variable 1 green color range:",
                  min = 0.1, max = 10, value = c(0.1,10)),
      sliderInput("crit22", "Variable 2 green color range:",
                  min = 0.1, max = 20, value = c(0.1,20))
    )

  })
  
  dat <- reactive({
    req(input$crit11,input$crit12,input$crit21,input$crit22)
    
    df <- df %>% filter(between(var1, input$var11, input$var12)) %>% 
                 filter(between(var2, input$var21, input$var22))
    
    # df1 <- df %>% mutate(var3 = ifelse(var1 <= i & var2 <= i, "a", ifelse(var1 <= j & var2 <= j , "b", "c")))
    
    df1 <- df %>% mutate(var3 = ifelse(between(var1, input$crit11[1], input$crit11[2]) & between(var2, input$crit12[1], input$crit12[2]), "a",
                                       ifelse(between(var1, input$crit21[1], input$crit21[2]) & between(var2, input$crit22[1], input$crit22[2]), "b", "c")))
    
  })
  
  summari <- reactive({
    req(dat())
    df1 <- dat()
    df1$var3 = as.factor(df1$var3)
    summary = df1 %>%
      group_by(var3) %>%
      dplyr::summarize(Mean_var1 = mean(var1), Mean_var2 = mean(var2), count=n())
  })
  
  output$summary <- renderDT(summari())
  
  rv <- reactiveValues()
  
  observe({
    req(dat())
    p <- ggplot(data=dat()) + geom_point(aes(x=var1, y= var2, color= var3))
    pp <- ggplotly(p)
    rv$plot <- pp
  })
  
  output$plot <- renderPlotly({
    rv$plot
  })
  
  output$saveplotbtn <-  renderUI({
    div(style="display: block; padding: 5px 350px 5px 50px;",
        downloadBttn("saveHTML",
                     HTML("HTML"),
                     style = "fill",
                     color = "default",
                     size = "lg",
                     block = TRUE,
                     no_outline = TRUE
        ) )
  })
  
  output$saveHTML <- downloadHandler(
    filename = function() {
      paste("myplot", Sys.Date(), ".html", sep = "")
    },
    content = function(file) {
      htmlwidgets::saveWidget(as_widget(rv$plot), file, selfcontained = TRUE)  ## self-contained
    }
  )

}

shinyApp(ui, server)