custom-input-control

https://shiny.rstudio.com/gallery/custom-input-control.html
https://shiny.rstudio.com/articles/building-inputs.html
https://shiny.rstudio.com/articles/js-build-widget.html

custom input example

library(shiny)

chooserInput <- function(inputId, leftLabel, rightLabel, leftChoices, rightChoices, size=5, multiple=F){
\tleftChoices  <- lapply(leftChoices,  tags$option)
\trightChoices <- lapply(rightChoices, tags$option)
\tif (multiple){ multiple <- "multiple" }else{ multiple <- NULL }
\t
\ttagList(
\t\tsingleton(tags$head(
\t\t\ttags$script(src="js/chooser-binding.js"),
\t\t\ttags$style(type="text/css", HTML("
\t\t\t\t.chooser{
\t\t\t\t\tdisplay: flex;
\t\t\t\t\tjustify-content: center;
\t\t\t\t\talign-items: center;
\t\t\t\t}
\t\t\t\t.chooser-container { 
\t\t\t\t\tdisplay: inline-block;
\t\t\t\t\tmargin: 0 6px;
\t\t\t\t}"
\t\t\t))
\t\t)),
\t\tdiv(id=inputId, class="chooser",
\t\t\tdiv(class="chooser-container chooser-left-container",
\t\t\t\t\ttags$select(class="left", size=size, multiple=multiple, leftChoices)),
\t\t\tdiv(class="chooser-container chooser-center-container",
\t\t\t\t\ticon("arrow-circle-o-right", "right-arrow fa-2x"),
\t\t\t\t\ttags$br(),
\t\t\t\t\ticon("arrow-circle-o-left",  "left-arrow fa-2x")\t),
\t\t\tdiv(class="chooser-container chooser-right-container",
\t\t\t\t\ttags$select(class="right", size=size, multiple=multiple, rightChoices))
\t\t)
\t)
}

registerInputHandler("customInput.chooser", function(data, ...){
\tif (is.null(data))
\t\tNULL
\telse
\t\tlist(left=as.character(data$left), right=as.character(data$right))
}, force=T)



ui <- fluidPage(
\tactionButton("btn_loadData", "Load Data"),
\t
\tselectInput("slt_mainData", "Data",\tchoices="Not Loaded!"),
\tuiOutput("chooser"), 
\tverbatimTextOutput("rsltChooser"),
\t
\tactionButton("btn_strData", "Show Data"),
\tverbatimTextOutput("rsltData")
)

server <- function(input, output, session){
\tinit_env1 <- function() {
\t\tenv <- new.env()
\t\treturn(env)
\t}
\tenv1 <- init_env1()

\tobserveEvent(input$btn_loadData, {
\t\tdataList <- data.table(value=1:2, name=c("iris", "USArrests"))
\t\tval        <- as.list(dataList$value)
\t\tnames(val) <- str_c(dataList$value, dataList$name, sep=" : ")
\t\t
\t\tupdateSelectInput(session, "slt_mainData",
\t\t\t\t\t\t\t\t\t\t\tchoices = val,
\t\t\t\t\t\t\t\t\t\t\tselected = 1)
\t})
\t
\trct_select_mainData <- reactive(input$slt_mainData)
\tobserve({
\t\tselect_mainData <- rct_select_mainData()
\t\tif (!is.na(select_mainData) && !select_mainData %in% c("Not Loaded!", "")){
\t\t\tif (is.null(select_mainData)){
\t\t\t\treturn()
\t\t\t}else{
\t\t\t\tswitch(select_mainData,
\t\t\t\t\t"1"={env1$dataset <- iris %>% data.table() },
\t\t\t\t\t"2"={env1$dataset <- USArrests %>% data.table()}
\t\t\t\t)
\t\t\t\tchooseList <- env1$dataset %>% colnames()
\t\t\t\toutput$chooser <- renderUI({
\t\t\t\t\tchooserInput("chooserCol", "Available frobs", "Selected frobs", 
\t\t\t\t\t\t\t\t\t\t\t  chooseList, c(), size=10, multiple=T)
\t\t\t\t})
\t\t\t\toutput$rsltChooser <- renderPrint(
\t\t\t\t\tinput$chooserCol
\t\t\t\t)
\t\t\t}
\t\t}
\t})
\t
\tobserveEvent(input$btn_strData, {
\t\tcol <-  input$chooserCol$right
\t\tif(length(col)>0){
\t\t\toutput$rsltData <- renderPrint(
\t\t\t\tenv1$dataset[ , ..col]
\t\t\t)
\t\t}else{\t
\t\t\treturn()
\t\t}
\t})
}

shinyApp(ui, server)","wrapLines":false,"highlightStart":"85","highlightEnd":"88

(function() {
\tfunction updateChooser(chooser) {
\t\tchooser = $(chooser);
\t\tvar left = chooser.find("select.left");
\t\tvar right = chooser.find("select.right");
\t\tvar leftArrow = chooser.find(".left-arrow");
\t\tvar rightArrow = chooser.find(".right-arrow");
\t\t
\t\tvar canMoveTo = (left.val() || []).length > 0;
\t\tvar canMoveFrom = (right.val() || []).length > 0;
\t\t
\t\tleftArrow.toggleClass("muted", !canMoveFrom);
\t\trightArrow.toggleClass("muted", !canMoveTo);
\t}
\t
\tfunction move(chooser, source, dest) {
\t\tchooser = $(chooser);
\t\tvar selected = chooser.find(source).children("option:selected");
\t\tdest = chooser.find(dest);
\t\tdest.children("option:selected").each(function(i, e) {e.selected = false;});
\t\tdest.append(selected);
\t\tupdateChooser(chooser);
\t\tchooser.trigger("change");
\t}
\t
\t$(document).on("change", ".chooser select", function() {
\t\tupdateChooser($(this).parents(".chooser"));
\t});
\t
\t$(document).on("click", ".chooser .right-arrow", function() {
\t\tmove($(this).parents(".chooser"), ".left", ".right");
\t});
\t
\t$(document).on("click", ".chooser .left-arrow", function() {
\t\tmove($(this).parents(".chooser"), ".right", ".left");
\t});
\t
\t$(document).on("dblclick", ".chooser select.left", function() {
\t\tmove($(this).parents(".chooser"), ".left", ".right");
\t});
\t
\t$(document).on("dblclick", ".chooser select.right", function() {
\t\tmove($(this).parents(".chooser"), ".right", ".left");
\t});
\t
\tvar binding = new Shiny.InputBinding();
\t
\tbinding.find = function(scope) {
\t\treturn $(scope).find(".chooser");
\t};
\t
\tbinding.initialize = function(el) {
\t\tupdateChooser(el);
\t};
\t
\tbinding.getValue = function(el) {
\t\treturn {
\t\t\tleft:  $.makeArray($(el).find("select.left option").map(function(i, e) { return e.value; })),
\t\t\tright: $.makeArray($(el).find("select.right option").map(function(i, e){ return e.value; }))
\t\t};
\t};
\t
\tbinding.setValue = function(el, value) {
\t\t// TODO: implement
\t};
\t
\tbinding.subscribe = function(el, callback) {
\t\t$(el).on("change.chooserBinding", function(e) {
\t\t\tcallback();
\t\t});
\t};
\t
\tbinding.unsubscribe = function(el) {
\t\t$(el).off(".chooserBinding");
\t};
\t
\tbinding.getType = function() {
\t\treturn "customInput.chooser";
\t};
\t
\tShiny.inputBindings.register(binding, "customInput.chooser");
\t
})();