时间戳

首页 > 解决方案 > R中的交互式绘图

sql - R中的交互式绘图

问题描述

使用 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 中巧妙而有效地做到这一点。

在此处输入图像描述

有人可以告诉我如何做到这一点吗？

谢谢

标签： sqlrdplyrshinyplotly

解决方案

我构建了一个闪亮的小应用程序来满足您的大部分要求。根据您预定义的大型数据框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)

输出

推荐阅读