Мне нужна помощь в создании динамического пользовательского интерфейса c и использовании одинаковых имен переменных в нескольких пространствах имен для добавления трасс на графике.
Код в следующем разделе: stati c и не Модульная версия того, что я ищу. Он может генерировать две трассы на графике на основе двух комбинаций пар категория-подкатегория, выбранных пользователем. Нерабочий динамический код пользовательского интерфейса c можно найти в следующем разделе.
Stati c Немодульный код
Набор данных:
- Категории : AB C D
- Подкатегории : A1 A2 .. D1 D2
- Метри c (число c)
- Timetick (возрастающая последовательность)
Два раздела c в пользовательском интерфейсе для выберите категорию - пары подкатегорий на раздел
график метри c более Timetick для каждой выбранной категории - пары подкатегорий
library(shiny)
library(dplyr)
library(plotly)
getCategoricalPairs <- function(x) {
allCategories = sort(unique(x$categories))
pairList = list()
for (category in allCategories){
pairList[[category]] = x %>%
filter(categories == category) %>%
pull(subCategories) %>%
unique() %>%
sort()
}
pairList
}
getComparisonPlot <- function(comparisonData, input) {
renderPlotly({
comparisonData = comparisonData()
plt = comparisonData %>%
plot_ly(mode = "lines",
type = "scatter") %>%
config(displayModeBar=FALSE) %>%
layout(
xaxis=list(
title = "X",
tickmode = "linear",
tick0 = 0,
dtick = 1,
tickvals=as.list(union(comparisonData %>%
filter(categories == input$category1 &
subCategories == input$subCategory1) %>%
pull(timeTick),
comparisonData %>%
filter(categories == input$category2 &
subCategories == input$subCategory2) %>%
pull(timeTick))),
gridwidth = 1),
yaxis=list(
title = "Y"
),
legend = list(x = 0.05,
y = 0.95,
font = list(size = 15),
bgcolor = 'rgba(240,240,240,0.5)')
)
selectedCategoryPair = list(c(input$category1, input$subCategory1),
c(input$category2, input$subCategory2))
for(pair in selectedCategoryPair) {
thisPairData = comparisonData %>%
filter(categories == pair[1] &
subCategories == pair[2])
plt = plt %>%
add_trace(
x = thisPairData %>%
pull(timeTick),
y = thisPairData %>%
pull(input$metric),
fill = "tozeroy",
name = paste(pair[1], pair[2], sep = " - ")
)
}
plt
})
}
# Define UI
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
h3(strong("Select Pair 1")),
selectizeInput(inputId = "category1",
label = h5("Category"),
choices = NULL,
width = "100%"),
selectizeInput(inputId = "subCategory1",
label = h5("Sub Category"),
choices = NULL,
width = "100%"),
hr(),
h3(strong("Select Pair 2")),
selectizeInput(inputId = "category2",
label = h5("Category"),
choices = NULL,
width = "100%"),
selectizeInput(inputId = "subCategory2",
label = h5("Sub Category"),
choices = NULL,
width = "100%"),
radioButtons(
inputId = "metric",
label=h5("Selected Metric"),
choices=c("metric"),
selected=c("metric"),
width="100%"
)
),
mainPanel(
plotlyOutput("categoryPairPlot")
)
),
)
server <- function(input, output, session) {
sampleData <- data.frame("categories" = c("A", "A", "A", "A", "B", "B", "B", "B", "C", "C", "C", "C", "D", "D", "D", "D"),
"subCategories" = c("A1", "A1", "A2", "A2", "B1", "B1", "B2", "B2", "C1", "C1", "C2", "C2", "D1", "D1", "D2", "D2"),
"metric" = c(1, 1, 3, 2, 4, 5, 1, 6, 2, 4, 3, 1, 6, 4, 1, 3),
"timeTick" = rep(1:2, 8),
stringsAsFactors = FALSE
)
comparisonData = reactive({
d = sampleData %>%
filter(categories %in% c(input$category1, input$category2))
})
# Map category -> vector<subcategory>
pairList <- getCategoricalPairs(sampleData)
# Initialize input dropdowns categories and related subcategories
updateSelectInput(session,
"category1",
choices = names(pairList),
selected = names(pairList)[1])
updateSelectInput(session,
"subCategory1",
choices = pairList[[1]],
selected = pairList[[1]][1])
updateSelectInput(session,
"category2",
choices = names(pairList),
selected = names(pairList)[2])
updateSelectInput(session,
"subCategory2",
choices = pairList[[2]],
selected = pairList[[2]][1])
# Observe changes in category dropdowns and update subcategories accordingly
observeEvent(input$category1, {
updateSelectInput(session,
"subCategory1",
choices = pairList[[input$category1]],
selected = pairList[[input$category1]][1])
})
observeEvent(input$category2, {
updateSelectInput(session,
"subCategory2",
choices = pairList[[input$category2]],
selected = pairList[[input$category2]][1])
})
# Render Plot
output$categoryPairPlot = getComparisonPlot(comparisonData, input)
}
shinyApp(ui = ui, server = server)
Требуется помощь:
Я очень плохо знаком с shiny и знаю о многочисленных нарушениях DRY. Я хотел бы улучшить этот код следующим образом:
- Использование пространств имен и динамических c UI
- Вместо двух разделов stati c для выбора категории - подкатегории пар, я хотел бы включить кнопку для добавления на столько разделов, сколько необходимо
- Используйте переменные
category и subCategory в каждом пространстве имен, чтобы добавить трассировку к окончательному графику.
Пока что, Мне удалось добавить компонент пользовательского интерфейса, но я не могу:
- Обновить значения в пространстве имен
selectizeInput (в newCategoryPair()) - Получить список переменных во всех пространствах имен, которые будут использоваться для генерации трасс в сюжете.
Вот код, который я мог бы прилагать изо всех сил:
# Define UI
ui2 <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButton("addCategoryPair", "Add Category Pair"),
radioButtons(
inputId = "metric",
label=h5("Selected Metric"),
choices=c("metric"),
selected=c("metric"),
width="100%"
)
),
mainPanel(
plotlyOutput("categoryPairPlot")
)
)
)
# UI Generation
newCategoryPair_UI <- function(id) {
ns = NS(id)
tagList(
h3(strong(paste0("Select Pair ", as.character(id)))),
selectizeInput(ns("category"),
label = h5("Category"),
choices = NULL,
width = "100%"),
selectizeInput(ns("subCategory"),
label = h5("Sub Category"),
choices = NULL,
width = "100%")
)
}
# UI Logic
newCategoryPair <- function(input, output, session, pairList) {
observe({
req(input$category)
updateSelectInput(session,
"category",
choices = names(pairList),
selected = names(pairList)[1])
updateSelectInput(session,
"subCategory",
choices = pairList[[1]],
selected = pairList[[1]][1])
})
}
# Server Logic
server2 <- function(input, output, session) {
sampleData <- data.frame("categories" = c("A", "A", "A", "A", "B", "B", "B", "B", "C", "C", "C", "C", "D", "D", "D", "D"),
"subCategories" = c("A1", "A1", "A2", "A2", "B1", "B1", "B2", "B2", "C1", "C1", "C2", "C2", "D1", "D1", "D2", "D2"),
"metric" = c(1, 1, 3, 2, 4, 5, 1, 6, 2, 4, 3, 1, 6, 4, 1, 3),
"timeTick" = rep(1:2, 8),
stringsAsFactors = FALSE)
pairList <- getCategoricalPairs(sampleData)
# Initialize with two pairs
id <- sprintf('%d', 1)
insertUI(
selector = '#addCategoryPair',
where = "beforeBegin",
ui = newCategoryPair_UI(id)
)
callModule(newCategoryPair, id, pairList)
id <- sprintf('%d', 2)
insertUI(
selector = '#addCategoryPair',
where = "beforeBegin",
ui = newCategoryPair_UI(id)
)
callModule(newCategoryPair, id, pairList)
# Listen for added pairs
idCounter = 2
observeEvent(input$addCategoryPair, {
idCounter = idCounter + 1
id <- sprintf('%d', idCounter)
insertUI(
selector = '#addCategoryPair',
where = "beforeBegin",
ui = newCategoryPair_UI(id)
)
callModule(newCategoryPair, id, pairList)
})
# Get `category` and `subCategory` variables in all the generated namespaces as a list
# Select appropriate data from sampleData
# Plot traces
}
# Run the application
shinyApp(ui = ui2, server = server2)
Ваша помощь очень важна! :)