custom-input-control

Published by onesixx on 19-04-0819-04-08

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){
	leftChoices  <- lapply(leftChoices,  tags$option)
	rightChoices <- lapply(rightChoices, tags$option)
	if (multiple){ multiple <- "multiple" }else{ multiple <- NULL }
	
	tagList(
		singleton(tags$head(
			tags$script(src="js/chooser-binding.js"),
			tags$style(type="text/css", HTML("
				.chooser{
					display: flex;
					justify-content: center;
					align-items: center;
				}
				.chooser-container { 
					display: inline-block;
					margin: 0 6px;
				}"
			))
		)),
		div(id=inputId, class="chooser",
			div(class="chooser-container chooser-left-container",
					tags$select(class="left", size=size, multiple=multiple, leftChoices)),
			div(class="chooser-container chooser-center-container",
					icon("arrow-circle-o-right", "right-arrow fa-2x"),
					tags$br(),
					icon("arrow-circle-o-left",  "left-arrow fa-2x")	),
			div(class="chooser-container chooser-right-container",
					tags$select(class="right", size=size, multiple=multiple, rightChoices))
		)
	)
}

registerInputHandler("customInput.chooser", function(data, ...){
	if (is.null(data))
		NULL
	else
		list(left=as.character(data$left), right=as.character(data$right))
}, force=T)



ui <- fluidPage(
	actionButton("btn_loadData", "Load Data"),
	
	selectInput("slt_mainData", "Data",	choices="Not Loaded!"),
	uiOutput("chooser"), 
	verbatimTextOutput("rsltChooser"),
	
	actionButton("btn_strData", "Show Data"),
	verbatimTextOutput("rsltData")
)

server <- function(input, output, session){
	init_env1 <- function() {
		env <- new.env()
		return(env)
	}
	env1 <- init_env1()

	observeEvent(input$btn_loadData, {
		dataList <- data.table(value=1:2, name=c("iris", "USArrests"))
		val        <- as.list(dataList$value)
		names(val) <- str_c(dataList$value, dataList$name, sep=" : ")
		
		updateSelectInput(session, "slt_mainData",
											choices = val,
											selected = 1)
	})
	
	rct_select_mainData <- reactive(input$slt_mainData)
	observe({
		select_mainData <- rct_select_mainData()
		if (!is.na(select_mainData) && !select_mainData %in% c("Not Loaded!", "")){
			if (is.null(select_mainData)){
				return()
			}else{
				switch(select_mainData,
					"1"={env1$dataset <- iris %>% data.table() },
					"2"={env1$dataset <- USArrests %>% data.table()}
				)
				chooseList <- env1$dataset %>% colnames()
				output$chooser <- renderUI({
					chooserInput("chooserCol", "Available frobs", "Selected frobs", 
											  chooseList, c(), size=10, multiple=T)
				})
				output$rsltChooser <- renderPrint(
					input$chooserCol
				)
			}
		}
	})
	
	observeEvent(input$btn_strData, {
		col <-  input$chooserCol$right
		if(length(col)>0){
			output$rsltData <- renderPrint(
				env1$dataset[ , ..col]
			)
		}else{	
			return()
		}
	})
}

shinyApp(ui, server)

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

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

onesixx

Shiny

the condition has length > 1 and only the first element will be used

Shiny

Reset renderPlot

Shiny

Promise

custom-input-control

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

onesixx

Related Posts

Shiny

the condition has length > 1 and only the first element will be used

Shiny

Reset renderPlot

Shiny

Promise

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