R发亮框中可移动的多个项目--类似于附加屏幕截图的东西

Question

我试图构建一个闪亮的应用程序，在那里我试图构建一个类似于下面的屏幕截图的功能：-

​

​

我已经构建了一些类似的使用Shinyjqui/sortable，但我希望允许多选择之前，移动项目。如果有人做过类似的事情，请告诉我。

下面是我使用"shinyjqui“包创建的一个示例：

library(shiny)
library(shinyjqui)
attach(mtcars)


ui <- fluidPage(
  fluidRow(
    column(
      width = 12,
      uiOutput("OrderInputRender")
      )
    )
  )

server<- function(input,output){
  output$OrderInputRender <- renderUI({
    fluidRow(
      column(width = 6,
             orderInput(
               "All_Columns",
               width = "100%",
               label = "Available columns",
               items = colnames(mtcars),
               style="margin:5px 0 0 0%; overflow: auto; background-color:#DCDCDC; border: 0px solid; padding: 10px; padding: 10px; height:360px;",
               connect = c("Segment_Column","Channel_Column")##which dropboxes can interact
             )## close of order input
      ),
      column(width = 6,
             orderInput(
               "Channel_Column",
               width = "100%",
               label = "Selected Columns",
               items = NULL,
               style="margin:5px 0 0 0%; overflow: auto; background-color:#DCDCDC; border: 0px solid; padding: 10px; padding: 10px; height:360px;",
               connect = c("All_Columns","Segment_Column")##which dropboxes can interact
             )## close of order input
      )
    )
  })
}

shinyApp(ui, server)

Answer 1

这只是一个使用DT包的概念的证明。可以从任何一方选择多个项，并将其移到另一侧。

我不打算花时间在这方面做得很漂亮，但是使用DT选项和css应该是可能的。最后，它可以很容易地通过封装在一个模块中重用。

ui -

library(shiny)
library(DT)

ui <- fluidPage(
  br(),
  splitLayout(cellWidths = c("45%", "10%", "45%"),
    DTOutput("pool"),
    list(
      br(),br(),br(),br(),br(),br(),br(),
      actionButton("add", label = NULL, icon("arrow-right")),
      br(),br(),
      actionButton("remove", label = NULL, icon("arrow-left"))
    ),
    DTOutput("selected")
  )
)

服务器-

server <- function(input, output, session) {
  mem <- reactiveValues(
    pool = data.frame(LETTERS[1:10]), selected = data.frame()
  )

  observeEvent(input$add, {
    req(input$pool_rows_selected)
    mem$selected <- rbind(isolate(mem$selected), mem$pool[input$pool_rows_selected, , drop = F])
    mem$pool <- isolate(mem$pool[-input$pool_rows_selected, , drop = F])
  })

  observeEvent(input$remove, {
    req(input$selected_rows_selected)
    mem$pool <- rbind(isolate(mem$pool), mem$selected[input$selected_rows_selected, , drop = F])
    mem$selected <- isolate(mem$selected[-input$selected_rows_selected, , drop = F])
  })

  output$pool <- renderDT({
    mem$pool
  })

  output$selected <- renderDT({
    mem$selected
  })
}

shinyApp(ui, server)

应用快照-

​

​

Answer 2

为我糟糕的英语感到抱歉。我找到了jQuery双面选择框，我制作了一个漂亮的演示，包括这个脚本。https://www.jqueryscript.net/form/Two-side-Multi-Select-Plugin-with-jQuery-multiselect-js.html

闪亮的双侧选择框jQuery

这看起来不错，但有一个问题是，服务器只能在右框中选择输入值。

# function for make UI HTML
MultiselectHTML <- function(mylist,myname){
  paste_sum <- ""
  for(i in 1:length(mylist)){
    paste_sum <- paste0(paste_sum,"<option value=",i,">",mylist[i],"</option>")
  }

  # make tag list
  tagList(
    div(
      class = "item_search"
      ,div(class = "row",
           div(class = "col-xs-5",
               tags$select(name="from[]",id=myname,class = "form-control",multiple = "multiple",size = "8"
                           ,HTML(paste_sum)
               )
           )
           ,div(class = "col-xs-2"
                ,tags$button(type = "button",class = "btn btn-primary btn-block",id=paste0(myname,"_undo"),"undo")
                ,tags$button(type = "button",class = "btn btn-block",id=paste0(myname,"_rightAll"),tags$i(class = "glyphicon glyphicon-forward"))
                ,tags$button(type = "button",class = "btn btn-block",id=paste0(myname,"_rightSelected"),tags$i(class = "glyphicon glyphicon-chevron-right"))
                ,tags$button(type = "button",class = "btn btn-block",id=paste0(myname,"_leftSelected"),tags$i(class = "glyphicon glyphicon-chevron-left"))
                ,tags$button(type = "button",class = "btn btn-block",id=paste0(myname,"_leftAll"),tags$i(class = "glyphicon glyphicon-backward"))
                ,tags$button(type = "button",class = "btn btn-warning btn-block",id=paste0(myname,"_redo"),"redo")
           )
           ,div(class = "col-xs-5"
                ,tags$select(name="to[]",id=paste0(myname,"_to"), class="form-control" ,size="8", multiple="multiple")
           )
      )
    )
    ,br()
  )
}

ui <- fluidPage(
  tags$head(includeScript("www/multiselect.js"))
  ,tags$script(HTML(
    'jQuery(document).ready(function($) {
      $("#multiselect1").multiselect({
       search: {
       left: \'<input type="text" name="q" class="form-control" placeholder="Search..." />\',
       right: \'<input type="text" name="q" class="form-control" placeholder="Search..." />\',
       },
       fireSearch: function(value) {
       return value.length >= 1;
       }
       });
       });
     ')
  )
  ,MultiselectHTML(c("a","b","c","d","e"),"multiselect1")
  ,h5("Selected List :")
  ,textOutput("mselect")
)

server <- function(input, output, session) {
  output$mselect <- renderText({input$multiselect1_to})
}

shinyApp(ui = ui,server = server)