Я работаю над shiny app, который имеет 3 варианта отображения данных для используемых им данных. Для двух из этих опций пользователь должен выбрать один дополнительный вход из списка, но для третьего я бы хотел, чтобы пользователь выбрал два дополнительных входа вместо одного. Я знаю, что эти выборы могут быть реализованы в renderUI в части server. Тем не менее, то, что у меня есть в renderUI, - это единственная опция для выбора в зависимости от выбранной опции отображения фигуры, и я не знаю, как добавить дополнительную для третьей опции дисплея.
Вот мой пример:
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(plotly))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(shiny))
#data.frames to be used in the server
set.seed(1)
coordinate.df <- data.frame(coordinate_id = paste0("c", 1:1000),x = rnorm(1000), y = rnorm(1000), type = sample(LETTERS[1:4], 1000, replace = T), sex = sample(c("F","M"), 1000, replace = T), age = sample(c("Y","O"), 1000, replace = T), stringsAsFactors = F)
feature.df <- data.frame(coordinate_id = rep(paste0("c", 1:1000), 10), feature_id = rep(paste0("f", 1:10), 1000), value = rnorm(10*1000), stringsAsFactors = F)
#options to be used for subsetting point.df not on the fly
types <- c("all",unique(coordinate.df$type))
type.choices <- 1:length(types)
names(type.choices) <- types
sexes <- c("all",unique(coordinate.df$sex))
sex.choices <- 1:length(sexes)
names(sex.choices) <- sexes
ages <- c("all",unique(coordinate.df$age))
age.choices <- 1:length(ages)
names(age.choices) <- ages
color.code.groups <- c("type","sex","age")
feature.color.vec <- c("lightgray","darkred")
plot.type.choices <- c("Group Coordinate Plot","Feature Coordinate Plot","Feature Distribution Plot")
server <- function(input, output)
{
chosen.types <- reactive({
validate(
need(input$types.choice != "",'Please choose at least one of the type checkboxes')
)
types.choice <- input$types.choice
if("all" %in% types.choice) types.choice <- types[-which(types == "all")]
types.choice
})
chosen.sexes <- reactive({
validate(
need(input$sexes.choice != "",'Please choose at least one of the sex checkboxes')
)
sexes.choice <- input$sexes.choice
if("all" %in% sexes.choice) sexes.choice <- sexes[-which(sexes == "all")]
sexes.choice
})
chosen.ages <- reactive({
validate(
need(input$ages.choice != "",'Please choose at least one of the age checkboxes')
)
ages.choice <- input$ages.choice
if("all" %in% ages.choice) ages.choice <- ages[-which(ages == "all")]
ages.choice
})
output$selection <- renderUI({
if(input$plotType == "Group Coordinate Plot"){
selectInput("selection", "Select Group to Color-Code by", choices = color.code.groups)
} else if(input$plotType == "Feature Coordinate Plot"){
selectInput("selection", "Select Feature to Display", choices = unique(feature.df$feature_id))
} else if(input$plotType == "Feature Distribution Plot"){
selectInput("selection", "Select Feature to Display", choices = unique(feature.df$feature_id))
}
})
group.coordinate.plot <- reactive({
if(!is.null(input$selection)){
plot.chosen.types <- chosen.types()
plot.chosen.sexes <- chosen.sexes()
plot.chosen.ages <- chosen.ages()
if(input$plotType == "Group Coordinate Plot"){
plot.df <- suppressWarnings(coordinate.df %>%
dplyr::filter(type %in% plot.chosen.types & sex %in% plot.chosen.sexes & age %in% plot.chosen.ages) %>%
dplyr::mutate(hover.text = paste0("coordinate_id: ",coordinate_id,"\n","type: ",type,"\n","sex: ",sex,"\n","age: ",age)))
plot.df$group <- plot.df[,input$selection]
plot.df$group <- factor(plot.df$group)
group.coordinate.plot <- suppressWarnings(plotly::plot_ly(marker=list(size=3),type='scatter',mode="markers",color=plot.df$group,x=plot.df$x,y=plot.df$y,text=plot.df$hover.text,hoverinfo="text") %>%
plotly::layout(xaxis=list(zeroline=F,showticklabels=F,showgrid=F),yaxis=list(zeroline=F,showticklabels=F,showgrid=F),legend=list(itemsizing='constant')))
}
}
group.coordinate.plot
})
feature.coordinate.plot <- reactive({
if(!is.null(input$selection)){
plot.chosen.types <- chosen.types()
plot.chosen.sexes <- chosen.sexes()
plot.chosen.ages <- chosen.ages()
if(input$plotType == "Feature Coordinate Plot"){
feature.id <- input$selection
plot.title <- feature.id
plot.df <- suppressWarnings(feature.df %>%
dplyr::filter(feature_id == feature.id) %>%
dplyr::left_join(coordinate.df,by = c("coordinate_id"="coordinate_id")) %>%
dplyr::mutate(hover.text = paste0("coordinate_id: ",coordinate_id,"\n","type: ",type,"\n","sex: ",sex,"\n","age: ",age,"\n","value: ",value)))
feature.coordinate.plot <- suppressWarnings(plotly::plot_ly(marker=list(size=3),type='scatter',mode="markers",color=plot.df$value,x=plot.df$x,y=plot.df$y,text=plot.df$hover.text,hoverinfo="text",showlegend=F,colors=colorRamp(feature.color.vec)) %>%
plotly::layout(title=plot.title,xaxis=list(zeroline=F,showticklabels=F,showgrid=F),yaxis=list(zeroline=F,showticklabels=F,showgrid=F)) %>%
plotly::colorbar(limits=c(min(plot.df$value,na.rm=T),max(plot.df$value,na.rm=T)),len=0.4,title="Value"))
}
}
feature.coordinate.plot
})
feature.distribution.plot <- reactive({
if(!is.null(input$selection)){
plot.chosen.types <- chosen.types()
plot.chosen.sexes <- chosen.sexes()
plot.chosen.ages <- chosen.ages()
if(input$plotType == "Feature Distribution Plot"){
feature.id <- input$selection
plot.title <- feature.id
plot.df <- suppressWarnings(feature.df %>%
dplyr::filter(feature_id == feature.id) %>%
dplyr::left_join(coordinate.df,by = c("coordinate_id"="coordinate_id")) %>%
dplyr::mutate(hover.text = paste0("coordinate_id: ",coordinate_id,"\n","type: ",type,"\n","sex: ",sex,"\n","age: ",age,"\n","value: ",value)))
density.df <- do.call(rbind,lapply(sort(unique(plot.df$type)),function(t)
ggplot2::ggplot_build(ggplot2::ggplot(plot.df %>% dplyr::filter(type == t),ggplot2::aes(x=value))+ggplot2::geom_density(adjust=1,colour="#A9A9A9"))$data[[1]] %>%
dplyr::select(x,y) %>% dplyr::mutate(type = t))) %>% dplyr::left_join(dplyr::select(coordinate.df,type) %>% unique())
density.df$type <- factor(density.df$type)
feature.distribution.plot <- suppressWarnings(plotly::plot_ly(x=density.df$x,y=density.df$y,type='scatter',mode='lines',color=density.df$type) %>%
plotly::layout(title=plot.title,xaxis=list(title="Value",zeroline=F),yaxis=list(title="Density",zeroline=F)) %>%
plotly::add_annotations(text="type",xref="paper",yref="paper",x=1.02,xanchor="left",y=1.02,yanchor="top",legendtitle=T,showarrow=F))
}
}
feature.distribution.plot
})
output$outPlot <- plotly::renderPlotly({
if(input$plotType == "Group Coordinate Plot"){
group.coordinate.plot()
} else if(input$plotType == "Feature Coordinate Plot"){
feature.coordinate.plot()
} else if(input$plotType == "Feature Distribution Plot"){
feature.distribution.plot()
}
})
}
ui <- fluidPage(
# App title ----
titlePanel("Results Explorer"),
# Sidebar layout with a input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
## custom CSS for 3 column layout (used below for mechanics filter options)
tags$head(
tags$style(HTML(".multicol {-webkit-column-count: 3; /* Chrome, Safari, Opera */-moz-column-count: 3; /* Firefox */column-count: 3;}"))),
## use the css, assuming your long list of vars comes from global.R
wellPanel(tags$div(class="multicol",checkboxGroupInput("types.choice", "Type",choices = names(type.choices),selected="all"))),
wellPanel(tags$div(class="multicol",checkboxGroupInput("sexes.choice", "Sex",choices = names(sex.choices),selected="all"))),
wellPanel(tags$div(class="multicol",checkboxGroupInput("ages.choice", "Age",choices = names(age.choices),selected="all"))),
# select plot type
selectInput("plotType", "Plot Type", choices = plot.type.choices),
uiOutput("selection")
),
# Main panel for displaying outputs ----
mainPanel(
# The plot is called out.plot and will be created in ShinyServer part
plotly::plotlyOutput("outPlot")
)
)
)
shinyApp(ui = ui, server = server)
"Feature Distribution Plot" input$plotType - это параметр отображения, к которому я хотел бы добавить дополнительный выбор пользовательского ввода (который будет иметь параметр для графика плотности - текущий реализованный параметр или сюжет скрипки).
Есть идеи, как мне это добавить?