Я пытаюсь уменьшить количество повторяющихся функций для ввода и вывода renderUI и реактивного, чтобы упростить код с помощью purrr. Я обнаружил, что пытался сделать версию с pmap, но она не работает. Не могли бы вы дать мне некоторое понимание или способ понять, как его отладить?
репо
таблица
library('tidyverse')
library('data.table')
library("shiny")
Attr_scores <- structure(list(scope = c("Sel1", "Sel2", "Sel3", "Sel4", "Sel5",
"Sel6", "Sel7", "Sel8", "Sel9", "Sel10", "Sel11", "Sel12", "Sel13"
), A1 = c(14, 14, 14, 15, 15, 15, 16, 16, 16, 17, 17, 17, 18),
A2 = c(13, 14, 14, 14, 15, 15, 13, 14, 16, 14, 15, 17, 12
), A3 = c(13, 13, 14, 13, 12, 15, 12, 14, 10, 12, 11, 8,
12), A4 = c(13, 13, 13, 12, 12, 11, 12, 10, 10, 10, 11, 8,
10), A5 = c(13, 13, 10, 12, 11, 8, 12, 10, 10, 10, 10, 8,
10), A6 = c(12, 10, 8, 11, 11, 8, 12, 10, 10, 10, 8, 8, 10
)), row.names = c(NA, -13L), class = c("tbl_df", "tbl", "data.frame"
))
Функции
Attr_score_select <- function(y){
Attr_scores %>%
as.data.table() %>%
.[y] %>%
pivot_longer(-scope) %>%
count(value)
}
## change the number of the score you still have
Attr_score_remove <- function(df, score){
df %>%
mutate(n = ifelse(value == score, n-1, n)) %>%
mutate(n = ifelse(n == 0, NA, n)) %>%
drop_na()
}
Пользовательский интерфейс
ui <- fluidPage(
titlePanel("Create your Character:"),
navlistPanel(
"Header B",
tabPanel("Main Attributes",
sidebarPanel(
"Attributes",
# select the values for each attr
c("Strength_ui", "Dexterity_ui",
"Constitution_ui","Intelligence_ui",
"Wisdom_ui","Charisma_ui") %>%
map(~uiOutput(.x))
),
mainPanel(
# table with Attributes score
h4("Select the row with the Attribute scores for your character:"),
DT::dataTableOutput("table"))
),
"-----",
tabPanel("Component 4"),
"-----",
tabPanel("Component 5")
)
)
Сервер работает
server <- function(input, output) {
output$table <- DT::renderDataTable(
DT::datatable(
data = Attr_scores,
style = 'bootstrap',
options = list(pageLength = 10),
selection = "single"))
Scores <- reactive(Attr_score_select(input$table_row_last_clicked))
output$Strength_ui <- renderUI({
#Strength
selectInput('Strength_1',
label = "Choose Strength score for your character:",
c(Choose='',
as.character(Scores()$value))
)
})
Scores1 <- reactive(Scores() %>%
Attr_score_remove(input$Strength_1))
#Dexterity
output$Dexterity_ui = renderUI(
selectInput('Dexterity_1',
label = "Choose Dexterity score for your character:",
c(Choose='', as.character(Scores1()$value))
)
)
Scores2 <- reactive(Scores1() %>%
Attr_score_remove(input$Dexterity_1))
#Constitution
output$Constitution_ui = renderUI(
selectInput('Constitution_1',
label = "Choose Constitution score for your character:",
c(Choose='', as.character(Scores2()$value))
)
)
Scores3 <- reactive(Scores2() %>%
Attr_score_remove(input$Constitution_1))
#Intelligence
output$Intelligence_ui = renderUI(
selectInput('Intelligence_1',
label = "Choose Intelligence score for your character:",
c(Choose='', as.character(Scores3()$value) )
)
)
Scores4 <- reactive(Scores3() %>%
Attr_score_remove(input$Intelligence_1))
#Wisdom
output$Wisdom_ui = renderUI(
selectInput('Wisdom_1',
label = "Choose 'Wisdom score for your character:",
c(Choose='', as.character(Scores4()$value) )
)
)
Scores5 <- reactive(Scores4() %>%
Attr_score_remove(input$Wisdom_1))
#Charisma
output$Charisma_ui = renderUI(
selectInput('Charisma_1',
label = "Choose 'Charisma score for your character:",
c(Choose='',
as.character(Scores5()$value))
)
)
}
попытка уменьшить дублирование при помощи tidyverse
Scores <- list(
"Strength_ui",
"Dexterity_ui",
"Constitution_ui",
"Intelligence_ui",
"Wisdom_ui",
"Charisma_ui"
) %>% set_names(.)
server <- function(input, output) {
output$table <- DT::renderDataTable(
DT::datatable(
data = Attr_scores,
style = 'bootstrap',
options = list(pageLength = 10),
selection = "single"))
Scores[["Strength_ui"]] <- reactive(
Attr_score_select(input$table_row_last_clicked))
pmap(..1 = names(Scores), ..2 = names(Scores) %>% seq_along(),
..3 = c("Strength_1", "Dexterity_1",
"Constitution_1","Intelligence_1",
"Wisdom_1","Charisma_1"),
.f = ~ function(x, y, z){
output[[..1]] <- renderUI({
selectInput(..3,
label = str_c("Choose",str_remove(..1,"_ui") ,
"score for your character:"),
c(Choose='',as.character(Scores[[..1]]()$value))
)
})
Scores[[..2+1]] <- reactive(Scores[[..1]]() %>%
Attr_score_remove(input[[..3]]))
}
)
}
сообщение об ошибке
shinyApp(ui = ui, server = server)
Listening on http://127.0.0.1:3295
Warning: Error in is.data.frame: argument ".l" is missing, with no default
54: is.data.frame
53: pmap
52: server [#13]
Error in is.data.frame(.l) : argument ".l" is missing, with no default