Проблема с пространством имен модулей: кнопки действий в таблице данных - PullRequest
Новая
       16

Проблема с пространством имен модулей: кнопки действий в таблице данных

0 голосов
/ 27 мая 2019

Я добавляю кнопку «Удалить» в таблицу для удаления строки. Он работает в блестящем приложении, но не в блестящем модуле. Я почти уверен, что это проблема с пространством имен, где-то в функции блестящей передачи или функции getRemoveButton, но я не знаю, как ее исправить. 

library(DT)
library(dplyr)
library(purrr)
library(shiny)

getRemoveButton <- function(name, idS = "", lab = "Pit") {
  if (stringr::str_length(idS) > 0) idS <- paste0(idS, "-")
  ret <- shinyInput(actionButton, name,
                    'button_', label = "Remove",
                    onclick = sprintf('Shiny.onInputChange(\"%sremove_button_%s\",  this.id)' ,idS, lab))
  return(ret)
}


shinyInput <- function(FUN, name, id, ses, ...) {
  n <- length(name)
  inputs <- character(n)
  for (i in seq_len(n)) {
    inputs[i] <- as.character(FUN(paste0(id, i), ...))
  }
  inputs
}



uploadFigUI <- function(id) {

  ns <- NS(id)

  tagList(
    fluidPage(
      titlePanel("Uploading Files"),
      sidebarLayout(
        sidebarPanel(
          fileInput(inputId = ns('files'), 
                    label = 'Select an Image',
                    multiple = TRUE,
                    accept=c('image/png', 'image/jpeg')), 
          DT::dataTableOutput(ns("myTable"))
        ),
        mainPanel(
          uiOutput(ns('images'))
        )
      )
    )
  )
}

uploadFig <- function(input, output, session) {

  ns <- session$ns

  files <- eventReactive(input$files, {
    req(input$files)
    files <- input$files
    files$datapath <- gsub("\\\\", "/", files$datapath)
    files
  })


  values <- reactiveValues()

  observeEvent(files(), {

    if(is.null(values$tab)){
      values$tab <- files() %>%
        mutate(Remove = getRemoveButton(files()$name, idS = "", lab = "Tab1"))

    }else{
      tab <- files() %>%
        mutate(Remove = getRemoveButton(files()$name, idS = "", lab = "Tab1"))
      myTable <- bind_rows(values$tab,tab)
      replaceData(proxyTable, myTable, resetPaging = FALSE)
      values$tab <- myTable
    }

  })



  output$images <- renderUI({
    req(values$tab$datapath)
    image_output_list <- 
      lapply(1:nrow(values$tab),
             function(i)
             {
               imagename = ns(paste0("image", i))
               uiOutput(imagename)
             })

    do.call(tagList, image_output_list)
  })

  observe({

    req(values$tab$datapath)
    for (i in 1:nrow(values$tab))
    {
      print(i)
      local({
        my_i <- i
        imagename = paste0("image", my_i)
        img <- knitr::image_uri(values$tab$datapath[my_i])
        values$img[[i]] <- img
        output[[imagename]] <- renderUI({
          req(values$img[[i]])

          tags$img(src = img, width = "100%", height= "auto")


        })
      })
    }
  })

  proxyTable <- DT::dataTableProxy("tab")

  output$myTable <- DT::renderDataTable({
    req(values$tab)
    DT::datatable(values$tab %>%
                    select(-datapath),
                  options = list(pageLength = 25,
                                 dom        = "rt"),
                  rownames = FALSE,
                  escape   = FALSE,
                  editable = FALSE)
  })



  observeEvent(input$remove_button_Tab1, {
    myTable <- values$tab
    values$what <- str_replace(input$remove_button_Tab1, "button_", "")
    s <-  str_replace(input$remove_button_Tab1, "button_", "") %>% as.numeric()
    myTable <- myTable[-s, ]
    replaceData(proxyTable, myTable, resetPaging = FALSE)
    values$tab <- myTable
  })


}

shinyApp(
  ui = fluidPage(
    uploadFigUI("test")
  ),

  server = function(input, output) {

    suppfigure <- callModule(uploadFig, "test")

  }
)

Если эта кнопка «Удалить» работает, она должна удалить строку и изображение на главной панели.

1 Ответ

0 голосов
/ 09 июня 2019

Первая проблема: прокси должен быть proxyTable <- DT::dataTableProxy("myTable").

Вторая проблема: необходимо добавить префикс идентификатора кнопки удаления к пространству имен: 

getRemoveButton(files()$name, idS = "test", lab = "Tab1")

Это работает так.

...