Creating better tooltips/popovers for elements with sub-choices.

R/groupInputTooltipAndPopover.R

@@ -0,0 +1,67 @@
+# Function for UI-sided creation of tooltips and popovers for groupInputs,
+# that is checkboxGroupInput and radioButtons. 
+# Extends the bsTooltip/bsPopover by an additional input "choice", which lets the user
+# define the input choice, which should get a tooltip. 
+# The selection is made a bit finer, filtering by values to get the right element.
+
+
+groupInputTooltip <- function(id, choice, title, placement = "bottom", trigger = "hover", options = NULL){
+
+  options = buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
+  buildGroupInputTooltipOrPopover(options, "tooltip", id, choice)
+}
+
+groupInputPopover <- function(id, choice, title, content, placement = "bottom", trigger = "hover", options = NULL){
+
+  options = buildTooltipOrPopoverOptionsList(title, placement, trigger, options, content)
+  buildGroupInputTooltipOrPopover(options, "popover", id, choice)
+}
+
+addGroupInputTooltip <- function(session, id, choice, title, placement = "bottom", trigger = "hover", options = NULL) {
+
+  options = buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
+  createGroupInputTooltipOrPopoverOnServer(session, id, choice, "tooltip", options)
+}
+
+addGroupInputPopover <- function(session, id, choice, title, content, placement = "bottom", trigger = "hover", options = NULL) {
+
+  options = buildTooltipOrPopoverOptionsList(title, placement, trigger, options, content)
+  createGroupInputTooltipOrPopoverOnServer(session, id, choice, "popover", options)
+}
+
+removeGroupInputTooltip <- function(session, id, choice) {
+
+  session$sendCustomMessage(type="updateGroupInputTooltipOrPopover", list(action = "remove", type = "tooltip", id = id, choice = choice))
+}
+
+removeGroupInputPopover <- function(session, id, choice) {
+
+  session$sendCustomMessage(type="updateGroupInputTooltipOrPopover", list(action = "remove", type = "popover", id = id, choice = choice))
+}
+
+buildGroupInputTooltipOrPopover <- function(options, type, id, choice){
+
+  options = paste0("{'", paste(names(options), options, sep = "': '", collapse = "', '"), "'}")
+
+  bsTag <- shiny::tags$script(shiny::HTML(paste0("
+    $(document).ready(function() {
+      setTimeout(function() {
+        $('input', $('#", id, "')).each(function(){
+          if(this.getAttribute('value') == '", choice, "') {
+            opts = $.extend(", options, ", {html: true});
+            $(this.parentElement).", type, "('destroy');
+            $(this.parentElement).", type, "(opts);
+          }
+        })
+      }, 500)
+    });
+  ")))
+
+  htmltools::attachDependencies(bsTag, shinyBSDep)
+}
+
+createGroupInputTooltipOrPopoverOnServer <- function(session, id, choice, type, options){
+
+  data <- list(action = "add", type = type, id = id, choice = choice, options = options)
+  session$sendCustomMessage(type = "updateGroupInputTooltipOrPopover", data)
+}

R/selectizeTooltipAndPopover.R

@@ -0,0 +1,70 @@
+# Function for UI-sided creation of tooltips and popovers for select-/selectizeInput.
+# Extends the bsTooltip/bsPopover by an additional input "choice", which lets the user
+# define the selectize choice, which should get a tooltip. 
+# The selection is more dynamic, dealing with the many mutations on the selectize,
+# while still maintaining the right popover on the right elements. 
+
+selectizeTooltip <- function(id, choice, title, placement = "bottom", trigger = "hover", options = NULL){
+
+  options = buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
+  buildSelectizeTooltipOrPopover(options, "tooltip", id, choice
+}
+
+selectizePopover <- function(id, choice, title, content, placement = "bottom", trigger = "hover", options = NULL){
+
+  options = buildTooltipOrPopoverOptionsList(title, placement, trigger, options, content)
+  buildSelectizeTooltipOrPopover(options, "popover", id, choice)
+}
+
+addSelectizeTooltip <- function(session, id, choice, title, placement = "bottom", trigger = "hover", options = NULL) {
+
+  options = buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
+  createSelectizeTooltipOrPopoverOnServer(session, id, choice, "tooltip", options)
+}
+
+addSelectizePopover <- function(session, id, choice, title, content, placement = "bottom", trigger = "hover", options = NULL) {
+
+  options = buildTooltipOrPopoverOptionsList(title, placement, trigger, options, content)
+  createSelectizeTooltipOrPopoverOnServer(session, id, choice, "popover", options)
+}
+
+removeSelectizeTooltip <- function(session, id, choice) {
+
+  session$sendCustomMessage(type="updateSelectizeTooltipOrPopover", list(action = "remove", type = "tooltip", id = id, choice = choice))
+}
+
+removeSelectizePopover <- function(session, id, choice) {
+
+  session$sendCustomMessage(type="updateSelectizeTooltipOrPopover", list(action = "remove", type = "popover", id = id, choice = choice))
+}
+
+buildSelectizeTooltipOrPopover <- function(options, type, id, choice){
+
+  options = paste0("{'", paste(names(options), options, sep = "': '", collapse = "', '"), "'}")
+
+  bsTag <- shiny::tags$script(shiny::HTML(paste0("
+    $(document).ready(function() {
+      var opts = $.extend(", options, ", {html: true});
+      var selectizeParent = document.getElementById('", id, "').parentElement;
+      var observer = new MutationObserver(function(mutations) {
+        mutations.forEach(function(mutation){
+          $(mutation.addedNodes).filter('div').filter(function(){return(this.getAttribute('data-value') == '", choice, "');}).each(function() {
+            $(this).", type, "('destroy');
+            $(this).", type, "(opts);
+          });
+        });
+      });
+      observer.observe(selectizeParent, { subtree: true, childList: true });
+
+      selectizeObserverDict['", type, "' + '", id, "' + '", choice, "'] = observer;
+    });
+  ")))
+
+  htmltools::attachDependencies(bsTag, shinyBSDep)
+}
+
+createSelectizeTooltipOrPopoverOnServer <- function(session, id, choice, type, options){
+
+  data <- list(action = "add", type = type, id = id, choice = choice, options = options)
+  session$sendCustomMessage(type = "updateSelectizeTooltipOrPopover", data)
+}

inst/www/shinyBS.js

@@ -243,6 +243,78 @@ Shiny.addCustomMessageHandler("updateTooltipOrPopover", function(data) {
   }
 })
 
+var selectizeObserverDict = {};
+
+Shiny.addCustomMessageHandler("updateSelectizeTooltipOrPopover", function(data) {
+
+  var selectizeParent = document.getElementById(data.id).parentElement;
+
+  if(data.action == "add") {
+    var opts = $.extend(data.options, {html: true});
+
+    var observer = new MutationObserver(function(mutations) {
+      mutations.forEach(function(mutation){
+        $(mutation.addedNodes).filter('div').filter(function(){return(this.getAttribute('data-value') == data.choice);}).each(function() {
+          if(data.type == "tooltip"){
+            $(this).tooltip('destroy');
+            $(this).tooltip(opts);
+          } else if (data.type == "popover") {
+            $(this).popover('destroy');
+            $(this).popover(opts);
+          }
+        });
+      });
+    });
+
+    observer.observe(selectizeParent, { subtree: true, childList: true });
+
+    selectizeObserverDict[data.type + data.id + data.choice] = observer;
+  } else if(data.action == "remove") {
+
+    selectizeObserverDict[data.type + data.id + data.choice].disconnect();
+
+    $(selectizeParent).filter('div').filter(function(){return(this.getAttribute('data-value') == data.choice);}).each(function() {
+      if(data.type == "tooltip"){
+        $(this).tooltip('destroy');
+      } else if (data.type == "popover") {
+        $(this).popover('destroy');
+      }
+    })
+  }
+})
+
+Shiny.addCustomMessageHandler("updateGroupInputTooltipOrPopover", function(data) {
+  if(data.action == "add") {
+
+    $("input", $("#" + data.id)).each(function() {
+      if(this.getAttribute("value") == data.choice) {
+
+		    var opts = $.extend(data.options, {html: true});
+
+		    if(data.type == "tooltip") {
+          $(this.parentElement).tooltip("destroy");
+          $(this.parentElement).tooltip(opts);
+		    } else if(data.type == "popover") {
+		      $(this.parentElement).popover("destroy");
+          $(this.parentElement).popover(opts);
+		    }
+      }
+    })
+  } else if(data.action == "remove") {
+
+    $("input", $("#" + data.id)).each(function() {
+      if(this.getAttribute("value") == data.choice) {
+
+		    if(data.type == "tooltip") {
+		      $(this.parentElement).tooltip("destroy");
+	      } else if(data.type == "popover") {
+		      $(this.parentElement).popover("destroy");
+		    }
+	    }
+    })
+  }
+})
+
 Shiny.addCustomMessageHandler("bsButtonUpdate", function(data) {
 
   var btn = $("button#" + data.id);
@@ -300,4 +372,4 @@ Shiny.addCustomMessageHandler("bsButtonUpdate", function(data) {
     };
   };
 
-})
+})