From f41da7c400bd71d35c413e85d660bfdc35e1a9d0 Mon Sep 17 00:00:00 2001
From: Steven Nydick <steven.nydick@kornferry.com>
Date: Fri, 14 Jan 2022 09:45:02 -0600
Subject: [PATCH] fixes speed of selectOptions (addresses Issue #184)

---
 R/input-selectpicker.R | 53 +++++++++++++++++++++++++++---------------
 1 file changed, 34 insertions(+), 19 deletions(-)

diff --git a/R/input-selectpicker.R b/R/input-selectpicker.R
index 9d3b6f26..e821fd05 100644
--- a/R/input-selectpicker.R
+++ b/R/input-selectpicker.R
@@ -300,25 +300,40 @@ pickerSelectOptions <- function(choices, selected = NULL, choicesOpt = NULL, max
 }
 
 # From shiny/input-select.R, faster alternative if no choice options specific to picker
-selectOptions <- function(choices, selected = NULL) {
-  html <- mapply(choices, names(choices), FUN = function(choice, label) {
-    if (is.list(choice)) {
-      sprintf(
-        '<optgroup label="%s">\n%s\n</optgroup>',
-        htmlEscape(label, TRUE),
-        selectOptions(choice, selected)
-      )
+selectOptions <- function(choices,
+                          selected = NULL){
 
-    } else {
-      sprintf(
-        '<option value="%s"%s>%s</option>',
-        htmlEscape(choice, TRUE),
-        if (choice %in% selected) ' selected' else '',
-        htmlEscape(label)
-      )
-    }
-  })
-  HTML(paste(html, collapse = '\n'))
-}
+  # initial vector to store output character strings
+  html           <- vector("character", length(choices))
+
+  # indicating where to update list elements
+  is_list_choice <- vapply(choices, is.list, logical(1L))
+
+  # apply function ON list choices and add back to html
+  if(any(is_list_choice)){
+    list_choices   <- choices[is_list_choice]
+    list_html      <- sprintf(
+      fmt = '<optgroup label="%s">\n%s\n</optgroup>',
+      htmltools::htmlEscape(text      = names(list_choices),
+                            attribute = TRUE),
+      vapply(list_choices, selectOptions, character(1L), selected = selected)
+    )
+    html[is_list_choice] <- list_html
+  }
 
+  # run on just vector choices and put back into html
+  if(any(!is_list_choice)){
+    vec_choices <- choices[!is_list_choice]
+    vec_html    <- sprintf(
+      fmt = '<option value="%s"%s>%s</option>',
+      htmltools::htmlEscape(text      = vec_choices,
+                            attribute = TRUE),
+      c("", " selected")[(vec_choices %in% selected) + 1],
+      htmltools::htmlEscape(names(vec_choices))
+    )
+    html[!is_list_choice] <- vec_html
+  }
 
+  # paste everything together
+  htmltools::HTML(paste(html, collapse = "\n"))
+}