Shiny: использование динамических c renderUI с actionLinks и блестящейJS - PullRequest
Новая
       23

Shiny: использование динамических c renderUI с actionLinks и блестящейJS

0 голосов
/ 28 февраля 2020

Я создаю панель мониторинга, в которой мне нужно создать несколько блоков (на основе набора данных), а затем дать возможность каждому блоку щелкать и показывать поля подмножеств.

Я могу сделать это, если я знал данные заранее, но у меня возникли проблемы с созданием link id's и showing and hiding контента при создании вещей динамически .

Ниже приведен код того, как он должен функция (но с использованием stati c content) 

library(shiny)
library(shinydashboard)
library(shinyjs)


#####/UI/####

header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
  useShinyjs(),
  fluidRow(
    uiOutput("box1"),
    uiOutput("box2"),
    uiOutput("box3")
  ),
  fluidRow(
    div(id = "ILRow",
        uiOutput("box1a"),
        uiOutput("box1b"),
        uiOutput("box1c")
        ),
    div(id = "NCRow",
        uiOutput("box2a"),
        uiOutput("box2b")
        ),
    div(id = "INRow",
        uiOutput("box3a")
        )
  )
)

ui <- dashboardPage(header, sidebar, body)



#####/SERVER/####
server <- function(input, output) { 

  CSRbox <- function(description = NULL, linkName = NULL) {

    # the box tags
    withTags(
      # col
      div(
        class = "col-md-2",
        # Widget: user widget style 1
        div(
          class = "box",
          ## Box Header ##
          div(
            actionLink(linkName, NULL, icon = icon("plus-square-o", "fa-2x")),
            h2(description)
          )
        )
      )
    )
  }

  dat <- data.frame(State = c("Illinois","Illinois","Illinois","North Carolina","North Carolina","Indiana"), City = c("Chicago","Niles","Evanston","Charlotte","Raleigh","West Lafayette"))

  output$box1 <- renderUI({
    CSRbox("Illinois", "Ill_Link")
    })

  output$box2 <- renderUI({
    CSRbox("North Carolina", "NC_Link")
  })

  output$box3 <- renderUI({
    CSRbox("Indiana", "IN_Link")
  })

  output$box1a <- renderUI({
    CSRbox("Chicago", "CH_Link")
  })

  output$box1b <- renderUI({
    CSRbox("Niles", "NI_Link")
  })

  output$box1c <- renderUI({
    CSRbox("Evanston", "EV_Link")
  })

  output$box2a <- renderUI({
    CSRbox("Charlotte", "CA_Link")
  })

  output$box2b <- renderUI({
    CSRbox("Raleigh", "RL_Link")
  })

  output$box3a <- renderUI({
    CSRbox("West Lafayette", "WL_Link")
  })

  shinyjs::hide("ILRow")
  shinyjs::hide("NCRow")
  shinyjs::hide("INRow")

  observeEvent(input$Ill_Link, {
    shinyjs::toggle("ILRow")
    shinyjs::hide("NCRow")
    shinyjs::hide("INRow")
  })

  observeEvent(input$NC_Link, {
    shinyjs::toggle("NCRow")
    shinyjs::hide("ILRow")
    shinyjs::hide("INRow")
  })

  observeEvent(input$IN_Link, {
    shinyjs::toggle("INRow")
    shinyjs::hide("ILRow")
    shinyjs::hide("NCRow")
  })



  }

shinyApp(ui, server)

Ниже приведен код динамического создания блоков, но функциональность не работает (вот где мне нужна помощь!): 

library(shiny)
library(shinydashboard)
library(shinyjs)


#####/UI/####

header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
  useShinyjs(),
  fluidRow(
    uiOutput("boxLevel1")
  ),
  fluidRow(
    div(id = "LevelDetail",
        uiOutput("boxLevel2")
        )
  )
)

ui <- dashboardPage(header, sidebar, body)



#####/SERVER/####
server <- function(input, output) { 

  CSRbox <- function(description = NULL, linkName = NULL) {

    # the box tags
    withTags(
      # col
      div(
        class = "col-md-2",
        # Widget: user widget style 1
        div(
          class = "box",
          ## Box Header ##
          div(
            actionLink(linkName, NULL, icon = icon("plus-square-o", "fa-2x")),
            h2(description)
          )
        )
      )
    )
  }

  dat <- data.frame(State = c("Illinois","Illinois","Illinois","North Carolina","North Carolina","Indiana"), City = c("Chicago","Niles","Evanston","Charlotte","Raleigh","West Lafayette"))



  output$boxLevel1 <- renderUI({

    lapply(sort(unique(dat$State)), function(name) {

      CSRbox(name, paste0(name,"Link"))

    })
  })

  output$boxLevel2 <- renderUI({

    temp <- dat[dat$State == "Illinois",] #Should be based of off the input$Click of the Input Link. Ex: input$Illinois

    lapply(sort(unique(temp$City)), function(name) {

      CSRbox(name, paste0(name,"Link2"))

    })
  })

  shinyjs::hide("LevelDetail")

  observeEvent(input$IllinoisLink, { #Would need to loop through and make an observeEvent for each possible input$click
    shinyjs::toggle("LevelDetail")
  })

  }

shinyApp(ui, server)

ОБНОВЛЕНИЕ

Я выяснил, как отслеживать идентификаторы ввода, что позволяет мне динамически создавать правильное подмножество блоков (ух!). У меня все еще проблемы с show и hide. Я понял, как show подмножество ящиков, но я не могу понять, как hide, так как я использую input ID, который не меняется при двойном нажатии на link, поэтому observeEvent не работает Я попытался получить только ввод ссылки, которая сообщала бы мне count об этом, так что я знаю, изменилась ли она, НО я получаю ошибки, когда использую input[[input$last_btn]] (которая должна быть такой же, как ex: input$Illinois ). Любая помощь приветствуется! Я мог бы добавить другую кнопку отдельно, которая бы скрывала, но это не идеально. 

library(shiny)
library(shinydashboard)
library(shinyjs)


#####/UI/####

header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
  useShinyjs(),
  tags$head(tags$script(HTML("$(document).on('click', '.needed', function () {
                                Shiny.onInputChange('last_btn',this.id);
                             });"))),
  fluidRow(
    uiOutput("boxLevel1"),
    textOutput("lastButtonCliked")
  ),
  fluidRow(
    div(id = "LevelDetail",
        uiOutput("boxLevel2")
        )
  )
)

ui <- dashboardPage(header, sidebar, body)



#####/SERVER/####
server <- function(input, output) { 

  CSRbox <- function(description = NULL, linkName = NULL) {

    # the box tags
    withTags(
      # col
      div(
        class = "col-md-2",
        # Widget: user widget style 1
        div(
          class = "box",
          ## Box Header ##
          div(
            actionLink(linkName, NULL, icon = icon("plus-square-o", "fa-2x"), class="needed"),
            h2(description)
          )
        )
      )
    )
  }

  dat <- data.frame(State = c("Illinois","Illinois","Illinois","North Carolina","North Carolina","Indiana"), City = c("Chicago","Niles","Evanston","Charlotte","Raleigh","West Lafayette"))

  output$boxLevel1 <- renderUI({

    lapply(sort(unique(dat$State)), function(name) {

      CSRbox(name, paste0(name))

    })
  })

  output$boxLevel2 <- renderUI({

    temp <- dat[dat$State == input$last_btn,] #Should be based of off the input$Click of the Input Link. Ex: input$Illinois

    lapply(sort(unique(temp$City)), function(name) {

      CSRbox(name, paste0(name,"Link2"))

    })
  })

  avs <- reactiveValues(
    clickN = NA, #new click
    clickO = NA, #original click
    dataSame = TRUE #data sets are the same
  )

  observe({
    avs$clickN <- input$last_btn
  })

  shinyjs::hide("LevelDetail")

  observeEvent(input$last_btn, {

    avs$dataSame <- identical(avs$clickN, avs$clickO)

    if(!avs$dataSame) {
      shinyjs::show("LevelDetail")
      avs$clickO <- avs$clickN
    } else {
      shinyjs::hide("LevelDetail")
      avs$clickO <- NULL
    }
  })

  }

shinyApp(ui, server)
...