Last active
September 30, 2019 19:08
-
-
Save trafficonese/04747d599f12a58052bb66bedc2f7eba to your computer and use it in GitHub Desktop.
pickerSelectOptions optimizations / benchmarks
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ## functions ############## | |
| pickerSelectOptions <- function(choices, selected = NULL, choicesOpt = NULL, maxOptGroup = NULL) { | |
| if (is.null(choicesOpt)) | |
| choicesOpt <- list() | |
| l <- sapply(choices, length) | |
| if (!is.null(maxOptGroup)) | |
| maxOptGroup <- rep_len(x = maxOptGroup, length.out = sum(l)) | |
| m <- matrix(data = c(c(1, cumsum(l)[-length(l)] + 1), cumsum(l)), ncol = 2) | |
| html <- lapply(seq_along(choices), FUN = function(i) { | |
| label <- names(choices)[i] | |
| choice <- choices[[i]] | |
| if (is.list(choice)) { | |
| optionTag <- list( | |
| label = htmltools::htmlEscape(label, TRUE), | |
| pickerSelectOptions( | |
| choice, selected, | |
| choicesOpt = lapply( | |
| X = choicesOpt, | |
| FUN = function(j) { | |
| j[m[i, 1]:m[i, 2]] | |
| } | |
| ) | |
| ) | |
| ) | |
| if (!is.null(maxOptGroup)) | |
| optionTag[["data-max-options"]] <- maxOptGroup[i] | |
| optionTag <- dropNulls(optionTag) | |
| do.call(htmltools::tags$optgroup, optionTag) | |
| } else { | |
| optionTag <- list( | |
| value = choice, htmltools::HTML(htmltools::htmlEscape(label)), | |
| style = choicesOpt$style[i], | |
| `data-icon` = choicesOpt$icon[i], | |
| `data-subtext` = choicesOpt$subtext[i], | |
| `data-content` = choicesOpt$content[i], | |
| disabled = if (!is.null(choicesOpt$disabled[i]) && choicesOpt$disabled[i]) "disabled", | |
| selected = if (choice %in% selected) "selected" else NULL | |
| ) | |
| # optionTag$attribs <- c(optionTag$attribs, list(if (choice %in% selected) " selected" else "")) | |
| optionTag <- dropNulls(optionTag) | |
| do.call(htmltools::tags$option, optionTag) | |
| } | |
| }) | |
| return(htmltools::tagList(html)) | |
| } | |
| pickerSelectOptions1 <- function(choices, selected = NULL, choicesOpt = NULL, maxOptGroup = NULL) { | |
| if (is.null(choicesOpt)) | |
| choicesOpt <- list() | |
| l <- sapply(choices, length) | |
| if (!is.null(maxOptGroup)) | |
| maxOptGroup <- rep_len(x = maxOptGroup, length.out = sum(l)) | |
| m <- matrix(data = c(c(1, cumsum(l)[-length(l)] + 1), cumsum(l)), ncol = 2) | |
| namechoice <- names(choices) | |
| html <- lapply(1:length(choices), FUN = function(i) { | |
| label <- namechoice[i] | |
| choice <- choices[[i]] | |
| if (is.list(choice)) { | |
| optionTag <- list( | |
| label = htmlEscape(label, TRUE), | |
| pickerSelectOptions1( | |
| choice, selected, | |
| choicesOpt = lapply( | |
| X = choicesOpt, | |
| FUN = function(j) { | |
| j[m[i, 1]:m[i, 2]] | |
| } | |
| ) | |
| ) | |
| ) | |
| if (!is.null(maxOptGroup)) | |
| optionTag[["data-max-options"]] <- maxOptGroup[i] | |
| optionTag <- dropNulls(optionTag) | |
| do.call(tags$optgroup, optionTag) | |
| } else { | |
| optionTag <- list( | |
| value = choice, HTML(htmlEscape(label)), | |
| style = choicesOpt$style[i], | |
| `data-icon` = choicesOpt$icon[i], | |
| `data-subtext` = choicesOpt$subtext[i], | |
| `data-content` = choicesOpt$content[i], | |
| disabled = if (!is.null(choicesOpt$disabled[i]) && choicesOpt$disabled[i]) "disabled", | |
| selected = if (choice %in% selected) "selected" else NULL | |
| ) | |
| # optionTag$attribs <- c(optionTag$attribs, list(if (choice %in% selected) " selected" else "")) | |
| optionTag <- dropNulls(optionTag) | |
| do.call(tags$option, optionTag) | |
| } | |
| }) | |
| return(tagList(html)) | |
| } | |
| pickerSelectOptions2 <- function(choices, selected = NULL, choicesOpt = NULL, maxOptGroup = NULL) { | |
| if (is.null(choicesOpt)) | |
| choicesOpt <- list() | |
| l <- sapply(choices, length) | |
| if (!is.null(maxOptGroup)) | |
| maxOptGroup <- rep_len(x = maxOptGroup, length.out = sum(l)) | |
| cs <- cumsum(l) | |
| m <- matrix(data = c(c(1, cs[-length(l)] + 1), cs), ncol = 2) | |
| namechoice <- names(choices) | |
| html <- lapply(1:length(choices), FUN = function(i) { | |
| label <- namechoice[i] | |
| choice <- choices[[i]] | |
| if (is.list(choice)) { | |
| optionTag <- list( | |
| label = htmlEscape(label, TRUE), | |
| pickerSelectOptions2( | |
| choice, selected, | |
| choicesOpt = lapply( | |
| X = choicesOpt, | |
| FUN = function(j) { | |
| j[m[i, 1]:m[i, 2]] | |
| } | |
| ) | |
| ) | |
| ) | |
| if (!is.null(maxOptGroup)) | |
| optionTag[["data-max-options"]] <- maxOptGroup[i] | |
| optionTag <- dropNulls(optionTag) | |
| do.call(tags$optgroup, optionTag) | |
| } else { | |
| optionTag <- list( | |
| value = choice, HTML(htmlEscape(label)), | |
| style = choicesOpt$style[i], | |
| `data-icon` = choicesOpt$icon[i], | |
| `data-subtext` = choicesOpt$subtext[i], | |
| `data-content` = choicesOpt$content[i], | |
| disabled = if (!is.null(choicesOpt$disabled[i]) && choicesOpt$disabled[i]) "disabled", | |
| selected = if (choice %in% selected) "selected" else NULL | |
| ) | |
| # optionTag$attribs <- c(optionTag$attribs, list(if (choice %in% selected) " selected" else "")) | |
| optionTag <- dropNulls(optionTag) | |
| do.call(tags$option, optionTag) | |
| } | |
| }) | |
| return(tagList(html)) | |
| } | |
| pickerSelectOptions3 <- function(choices, selected = NULL, choicesOpt = NULL, maxOptGroup = NULL) { | |
| if (is.null(choicesOpt)) choicesOpt <- list() | |
| l <- sapply(choices, length) | |
| if (!is.null(maxOptGroup)) maxOptGroup <- rep_len(x = maxOptGroup, length.out = sum(l)) | |
| cs <- cumsum(l) | |
| m <- matrix(data = c(c(1, cs[-length(l)] + 1), cs), ncol = 2) | |
| namechoice <- names(choices) | |
| tagList(lapply(1:length(choices), function(i) { | |
| label <- namechoice[i] | |
| choice <- choices[[i]] | |
| if (is.list(choice)) { | |
| optionTag <- list( | |
| label = htmlEscape(label, TRUE), | |
| pickerSelectOptions3( | |
| choice, selected, | |
| choicesOpt = lapply( | |
| X = choicesOpt, | |
| FUN = function(j) { | |
| j[m[i, 1]:m[i, 2]] | |
| } | |
| ) | |
| ) | |
| ) | |
| if (!is.null(maxOptGroup)) | |
| optionTag[["data-max-options"]] <- maxOptGroup[i] | |
| optionTag <- dropNulls(optionTag) | |
| do.call(tags$optgroup, optionTag) | |
| } else { | |
| if (length(choicesOpt) == 0) { | |
| optionTag <- list( | |
| value = choice, HTML(htmlEscape(label)), | |
| selected = if (any(choice == selected)) "selected" else NULL | |
| ) | |
| } else { | |
| optionTag <- list( | |
| value = choice, HTML(htmlEscape(label)), | |
| style = choicesOpt$style[i], | |
| `data-icon` = choicesOpt$icon[i], | |
| `data-subtext` = choicesOpt$subtext[i], | |
| `data-content` = choicesOpt$content[i], | |
| disabled = if (!is.null(choicesOpt$disabled[i]) && choicesOpt$disabled[i]) "disabled", | |
| selected = if (any(choice == selected)) "selected" else NULL | |
| ) | |
| } | |
| # optionTag$attribs <- c(optionTag$attribs, list(if (choice %in% selected) " selected" else "")) | |
| optionTag <- dropNulls(optionTag) | |
| do.call(tags$option, optionTag) | |
| } | |
| })) | |
| } | |
| dropNulls1 <- function(x) { | |
| x[lengths(x) != 0] | |
| } | |
| pickerSelectOptions4 <- function(choices, selected = NULL, choicesOpt = NULL, maxOptGroup = NULL) { | |
| if (is.null(choicesOpt)) choicesOpt <- list() | |
| l <- sapply(choices, length) | |
| if (!is.null(maxOptGroup)) maxOptGroup <- rep_len(x = maxOptGroup, length.out = sum(l)) | |
| cs <- cumsum(l) | |
| m <- matrix(data = c(1, cs[-length(l)] + 1, cs), ncol = 2) | |
| namechoice <- names(choices) | |
| tagList(lapply(1:length(choices), function(i) { | |
| label <- namechoice[i] | |
| choice <- choices[[i]] | |
| if (is.list(choice)) { | |
| optionTag <- list( | |
| label = htmlEscape(label, TRUE), | |
| pickerSelectOptions4( | |
| choice, selected, | |
| choicesOpt = lapply( | |
| X = choicesOpt, | |
| FUN = function(j) { | |
| j[m[i, 1]:m[i, 2]] | |
| } | |
| ) | |
| ) | |
| ) | |
| if (!is.null(maxOptGroup)) | |
| optionTag[["data-max-options"]] <- maxOptGroup[i] | |
| optionTag <- dropNulls1(optionTag) | |
| do.call(tags$optgroup, optionTag) | |
| } else { | |
| if (length(choicesOpt) == 0) { | |
| optionTag <- list( | |
| value = choice, if (is.null(label)) HTML(NULL) else HTML(htmlEscape(label)), | |
| selected = if (any(choice == selected)) "selected" else NULL | |
| ) | |
| } else { | |
| optionTag <- list( | |
| value = choice, if (is.null(label)) HTML(NULL) else HTML(htmlEscape(label)), | |
| style = choicesOpt$style[i], | |
| `data-icon` = choicesOpt$icon[i], | |
| `data-subtext` = choicesOpt$subtext[i], | |
| `data-content` = choicesOpt$content[i], | |
| disabled = if (!is.null(choicesOpt$disabled[i]) && choicesOpt$disabled[i]) "disabled", | |
| selected = if (any(choice == selected)) "selected" else NULL | |
| ) | |
| } | |
| # optionTag$attribs <- c(optionTag$attribs, list(if (choice %in% selected) " selected" else "")) | |
| optionTag <- dropNulls1(optionTag) | |
| do.call(tags$option, optionTag) | |
| } | |
| })) | |
| } | |
| ## benchmarks ################ | |
| choices <- sample.int(1e6, 1e4) | |
| mc <- microbenchmark::microbenchmark(times = 20, | |
| res0 = shinyWidgets:::pickerSelectOptions(choices, choices[100] , NULL, NULL), | |
| res1 = shinyWidgets:::pickerSelectOptions1(choices, choices[100] , NULL, NULL), | |
| res2 = shinyWidgets:::pickerSelectOptions2(choices, choices[100] , NULL, NULL), | |
| res3 = shinyWidgets:::pickerSelectOptions3(choices, choices[100] , NULL, NULL), | |
| res4 = shinyWidgets:::pickerSelectOptions4(choices, choices[100] , NULL, NULL) | |
| ); mc | |
| ## identical #################### | |
| res0 = shinyWidgets:::pickerSelectOptions(choices, choices[100], NULL, NULL) | |
| res1 = shinyWidgets:::pickerSelectOptions1(choices, choices[100], NULL, NULL) | |
| res2 = shinyWidgets:::pickerSelectOptions2(choices, choices[100], NULL, NULL) | |
| res3 = shinyWidgets:::pickerSelectOptions3(choices, choices[100], NULL, NULL) | |
| res4 = shinyWidgets:::pickerSelectOptions4(choices, choices[100], NULL, NULL) | |
| identical(res0, res1); identical(res0, res2); identical(res0, res3); identical(res0, res4) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment