如何解决从R闪亮的应用程序中美观地显示长数据帧以子集
我有一些要使用design.df R应用程序浏览的数据（以下为shiny）
set.seed(1)
library(dplyr)
samples <- paste0("s",1:5)
clusters <- paste0("c",1:10)
groups <- paste0("g",1:20)
design.df <- expand.grid(samples,clusters,groups) %>%
dplyr::rename(sample=Var1,cluster=Var2,group=Var3) %>%
dplyr::mutate(value=rnorm(nrow(.)))
我想允许用户能够通过任何列（保留design.df列）来对value进行子集设置。在此示例中，它们将是sample，cluster和group，但实际上，这是一个应用程序，不同的用户将使用不同的列加载data.frame（离开所有人都拥有的value列。
我正在尝试根据自己的情况改编10.3.2 Dynamic filtering示例，但还不够。
这是我的代码：
library(shiny)
library(dplyr)
make_ui <- function(x,var) {
if (is.numeric(x)) {
rng <- range(x,na.rm = TRUE)
sliderInput(var,var,min = rng[1],max = rng[2],value = rng)
} else if (is.factor(x)) {
levs <- levels(x)
selectInput(var,choices = levs,selected = levs,multiple = TRUE)
} else {
# Not supported
NULL
}
}
filter_var <- function(x,val) {
if (is.numeric(x)) {
!is.na(x) & x >= val[1] & x <= val[2]
} else if (is.factor(x)) {
x %in% val
} else {
# No control,so don't filter
TRUE
}
}
server <- function(input,output)
{
data <- reactive({
get(input$dataset,data.frame(dplyr::select(design.df,-value)))
})
vars <- reactive(names(data()))
output$filter <- renderUI(
purrr::map(vars,~ make_ui(data()[[.x]],.x))
)
selected <- reactive({
each_var <- purrr::map(vars,~ filter_var(data()[[.x]],input[[.x]]))
purrr::reduce(each_var,`&`)
})
scatter.plot <- reactive({
scatter.plot <- NULL
if(!is.null(data()[selected(),]){
plot.df <- suppressWarnings(data()[selected(),])
scatter.plot <- suppressWarnings(plotly::plot_ly(marker=list(size=3),type='scatter',mode="markers",color=plot.df$sample,x=plot.df$group,y=plot.df$value) %>%
plotly::layout(xaxis=list(title="group",showgrid=F),yaxis=list(title="value",showgrid=F)))
}
return(scatter.plot)
})
output$out.plot <- plotly::renderPlotly({
scatter.plot()
})
}
ui <- fluidPage(
titlePanel("Data Explorer"),sidebarLayout(
sidebarPanel(
tags$head(
tags$style(HTML(".multicol {-webkit-column-count: 3; /* Chrome,Safari,Opera */-moz-column-count: 3; /* Firefox */column-count: 3;}")),tags$style(type="text/css","#loadmessage {position: fixed;top: 0px;left: 0px;width: 100%;padding: 5px 0px 5px 0px;text-align: center;font-weight: bold;font-size: 100%;color: #000000;background-color: #CCFF66;z-index: 105;}"),".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }")),conditionalPanel(condition="$('html').hasClass('shiny-busy')",tags$div("In Progress...",id="loadmessage")),selectInput("dataset",label = "Dataset",choices = colnames(dplyr::select(design.df,-value))),uiOutput("filter"),),mainPanel(
plotly::plotlyOutput("out.plot")
)
)
)
shinyApp(ui = ui,server = server)
哪个提供此界面：
它接近我想要的，但是仍然存在一些问题：
- 它显示design.df的所有列，而不是对选定的列做出反应。
- 它未显示散点图，可能是由于我在
scatter.plotreactive中设置的情况所致。
有什么想法吗？
这些问题解决之后，我还需要更新scatter.plot reactive中的绘图代码，以便它不会从design.df中显式选择列名，而是从中选择列名，但这不是对于这篇文章至关重要。
解决方法
这对我来说是一个足够的解决方案。
数据：
set.seed(1)
library(dplyr)
samples <- paste0("s",1:5)
clusters <- paste0("c",1:10)
groups <- paste0("g",1:20)
design.df <- expand.grid(samples,clusters,groups) %>%
dplyr::rename(sample=Var1,cluster=Var2,group=Var3) %>%
dplyr::mutate(value=rnorm(nrow(.)))
发光的代码：
library(shiny)
library(dplyr)
make_ui <- function(x,var) {
if (is.numeric(x)) {
rng <- range(x,na.rm = TRUE)
sliderInput(var,var,min = rng[1],max = rng[2],value = rng)
} else if (is.factor(x)) {
levs <- levels(x)
selectInput(var,choices = levs,selected = levs,multiple = TRUE)
} else {
# Not supported
NULL
}
}
filter_var <- function(x,val) {
if (is.numeric(x)) {
!is.na(x) & x >= val[1] & x <= val[2]
} else if (is.factor(x)) {
x %in% val
} else {
# No control,so don't filter
TRUE
}
}
server <- function(input,output)
{
output$filter <- renderUI(
purrr::map(colnames(data.frame(dplyr::select(design.df,-value))),~ make_ui(data.frame(dplyr::select(design.df,-value))[[.x]],.x))
)
selected <- reactive({
each_var <- purrr::map(colnames(data.frame(dplyr::select(design.df,~ filter_var(data.frame(dplyr::select(design.df,input[[.x]]))
purrr::reduce(each_var,`&`)
})
scatter.plot <- reactive({
scatter.plot <- NULL
if(!is.null(data.frame(dplyr::select(design.df,-value))[selected(),])){
plot.df <- suppressWarnings(data.frame(dplyr::select(design.df,])
scatter.plot <- suppressWarnings(plotly::plot_ly(marker=list(size=3),type='scatter',mode="markers",color=plot.df$sample,x=plot.df$group,y=plot.df$value) %>%
plotly::layout(xaxis=list(title="group",showgrid=F),yaxis=list(title="value",showgrid=F)))
}
return(scatter.plot)
})
output$out.plot <- plotly::renderPlotly({
scatter.plot()
})
}
ui <- fluidPage(
titlePanel("Data Explorer"),sidebarLayout(
sidebarPanel(
tags$head(
tags$style(HTML(".multicol {-webkit-column-count: 3; /* Chrome,Safari,Opera */-moz-column-count: 3; /* Firefox */column-count: 3;}")),tags$style(type="text/css","#loadmessage {position: fixed;top: 0px;left: 0px;width: 100%;padding: 5px 0px 5px 0px;text-align: center;font-weight: bold;font-size: 100%;color: #000000;background-color: #CCFF66;z-index: 105;}"),".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }")),conditionalPanel(condition="$('html').hasClass('shiny-busy')",tags$div("In Progress...",id="loadmessage")),uiOutput("filter"),),mainPanel(
plotly::plotlyOutput("out.plot")
)
)
)
shinyApp(ui = ui,server = server)
哪个给：
版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。