From a5249a36e13460535b7ab5b03c7fcaf34fb6477b Mon Sep 17 00:00:00 2001 From: mtennekes Date: Fri, 13 Sep 2024 22:55:44 +0200 Subject: [PATCH] ! table faster ! --- R/c4a_gui.R | 144 +++++++++++++++++++---------------------- R/c4a_table.R | 66 ++++++++++++++----- build/build_palettes.R | 25 ++++++- 3 files changed, 139 insertions(+), 96 deletions(-) diff --git a/R/c4a_gui.R b/R/c4a_gui.R index bddb515..cfc921f 100644 --- a/R/c4a_gui.R +++ b/R/c4a_gui.R @@ -529,9 +529,9 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { palBW = unique(c(pal_init, "#FFFFFF", "#000000")), pal_name = palette, n = n_init, - colA1 = pal_init[1], colA2 = pal_init[2], - colB1 = pal_init[1], colB2 = pal_init[2], - colC1 = pal_init[1], colC2 = pal_init[2], + idA1 = 1L, idA2 = 2L, + idB1 = 1L, idB2 = 2L, + idC1 = 1L, idC2 = 2L, CR = colorspace::contrast_ratio(pal_init[1], pal_init[2]), type = type12, cvd = "none", @@ -831,15 +831,15 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { tab_vals$pal = cols tab_vals$palBW = unique(c(cols, "#FFFFFF", "#000000")) tab_vals$type = values$type - tab_vals$colA1 = cols[1] - tab_vals$colA2 = cols[2] - tab_vals$colB1 = cols[1] - tab_vals$colB2 = cols[2] + tab_vals$idA1 = 1L + tab_vals$idA2 = 2L + tab_vals$idB1 = 1L + tab_vals$idB2 = 2L tab_vals$CR = colorspace::contrast_ratio(cols[1], cols[2]) tab_vals$b = approx_blues(cols) tab_vals$r = approx_reds(cols) - tab_vals$colC1 = cols[which.max(tab_vals$b)] - tab_vals$colC2 = cols[which.max(tab_vals$r)] + tab_vals$idC1 = cols[which.max(tab_vals$b)] + tab_vals$idC2 = cols[which.max(tab_vals$r)] } else { tab_vals$pal = character(0) @@ -848,13 +848,13 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { tab_vals$pal_name = character(0) tab_vals$n = integer(0) tab_vals$palBW = character(0) - tab_vals$colA1 = character(0) - tab_vals$colA2 = character(0) - tab_vals$colB1 = character(0) - tab_vals$colB2 = character(0) + tab_vals$idA1 = integer(0) + tab_vals$idA2 = integer(0) + tab_vals$idB1 = integer(0) + tab_vals$idB2 = integer(0) tab_vals$CR = numeric(0) - tab_vals$colC1 = character(0) - tab_vals$colC2 = character(0) + tab_vals$idC1 = integer(0) + tab_vals$idC2 = integer(0) tab_vals$b = integer(0) tab_vals$r = integer(0) tab_vals$type = character(0) @@ -907,13 +907,13 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { tab_vals$pal_name = character(0) tab_vals$n = integer(0) tab_vals$palBW = character(0) - tab_vals$colA1 = character(0) - tab_vals$colA2 = character(0) - tab_vals$colB1 = character(0) - tab_vals$colB2 = character(0) + tab_vals$idA1 = integer(0) + tab_vals$idA2 = integer(0) + tab_vals$idB1 = integer(0) + tab_vals$idB2 = integer(0) tab_vals$CR = numeric(0) - tab_vals$colC1 = character(0) - tab_vals$colC2 = character(0) + tab_vals$idC1 = integer(0) + tab_vals$idC2 = integer(0) tab_vals$b = integer(0) tab_vals$b = integer(0) tab_vals$type = character(0) @@ -938,14 +938,14 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { if (pal_nr == 4) { # select maximum floating colors - tab_vals$colC1 = cols[which.max(tab_vals$b)] - tab_vals$colC2 = cols[which.max(tab_vals$r)] + tab_vals$idC1 = which.max(tab_vals$b) + tab_vals$idC2 = which.max(tab_vals$r) } else if (pal_nr == 1) { - tab_vals$colA1 = cols[1] - tab_vals$colA2 = cols[2] + tab_vals$idA1 = 1L + tab_vals$idA2 = 2L } else { - tab_vals$colB1 = cols[1] - tab_vals$colB2 = cols[2] + tab_vals$idB1 = 1L + tab_vals$idB2 = 2L tab_vals$CR = colorspace::contrast_ratio(cols[1], cols[2]) } @@ -1044,10 +1044,8 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { if (!length(tab_vals$pal)) return(NULL) pal = tab_vals$pal - col1 = tab_vals$colA1 - col2 = tab_vals$colA2 - id1 = which(col1 == pal) - id2 = which(col2 == pal) + id1 = tab_vals$idA1 + id2 = tab_vals$idA2 c4a_plot_dist_matrix(pal, cvd = "none", id1 = id1, id2 = id2, dark = input$dark, advanced = (input$cbfScore == "Gradient"), bc_adj = input$cbfBcAdj) }) @@ -1056,10 +1054,8 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { if (!length(tab_vals$pal)) return(NULL) pal = tab_vals$pal - col1 = tab_vals$colA1 - col2 = tab_vals$colA2 - id1 = which(col1 == pal) - id2 = which(col2 == pal) + id1 = tab_vals$idA1 + id2 = tab_vals$idA2 c4a_plot_dist_matrix(pal, cvd = "deutan", id1 = id1, id2 = id2, dark = input$dark, advanced = (input$cbfScore == "Gradient"), bc_adj = input$cbfBcAdj) }) @@ -1068,10 +1064,8 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { if (!length(tab_vals$pal)) return(NULL) pal = tab_vals$pal - col1 = tab_vals$colA1 - col2 = tab_vals$colA2 - id1 = which(col1 == pal) - id2 = which(col2 == pal) + id1 = tab_vals$idA1 + id2 = tab_vals$idA2 c4a_plot_dist_matrix(pal, cvd = "protan", id1 = id1, id2 = id2, dark = input$dark, advanced = (input$cbfScore == "Gradient"), bc_adj = input$cbfBcAdj) }) @@ -1080,10 +1074,8 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { if (!length(tab_vals$pal)) return(NULL) pal = tab_vals$pal - col1 = tab_vals$colA1 - col2 = tab_vals$colA2 - id1 = which(col1 == pal) - id2 = which(col2 == pal) + id1 = tab_vals$idA1 + id2 = tab_vals$idA2 c4a_plot_dist_matrix(pal, cvd = "tritan", id1 = id1, id2 = id2, dark = input$dark, advanced = (input$cbfScore == "Gradient"), bc_adj = input$cbfBcAdj) }) @@ -1112,24 +1104,24 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { output$cbf_ex1 = shiny::renderPlot({ - if (!length(tab_vals$colA1)) return(NULL) + if (!length(tab_vals$idA1)) return(NULL) fun = paste0("cbf_", tolower(input$cbfType)) - do.call(fun, list(cols = c(tab_vals$colA1, tab_vals$colA2), cvd = "none")) + do.call(fun, list(cols = tab_vals$pal[c(tab_vals$idA1, tab_vals$idA2)], cvd = "none")) }) output$cbf_ex2 = shiny::renderPlot({ - if (!length(tab_vals$colA1)) return(NULL) + if (!length(tab_vals$idA1)) return(NULL) fun = paste0("cbf_", tolower(input$cbfType)) - do.call(fun, list(cols = c(tab_vals$colA1, tab_vals$colA2), cvd = "deutan")) + do.call(fun, list(cols = tab_vals$pal[c(tab_vals$idA1, tab_vals$idA2)], cvd = "deutan")) }) output$cbf_ex3 = shiny::renderPlot({ - if (!length(tab_vals$colA1)) return(NULL) + if (!length(tab_vals$idA1)) return(NULL) fun = paste0("cbf_", tolower(input$cbfType)) - do.call(fun, list(cols = c(tab_vals$colA1, tab_vals$colA2), cvd = "protan")) + do.call(fun, list(cols = tab_vals$pal[c(tab_vals$idA1, tab_vals$idA2)], cvd = "protan")) }) output$cbf_ex4 = shiny::renderPlot({ - if (!length(tab_vals$colA1)) return(NULL) + if (!length(tab_vals$idA1)) return(NULL) fun = paste0("cbf_", tolower(input$cbfType)) - do.call(fun, list(cols = c(tab_vals$colA1, tab_vals$colA2), cvd = "tritan")) + do.call(fun, list(cols = tab_vals$pal[c(tab_vals$idA1, tab_vals$idA2)], cvd = "tritan")) }) @@ -1193,9 +1185,9 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { if (input$plus_rev_original) { c4a_plot_Plus_Reversed(orientation = "landscape", borders = borders, lwd = lwd) } else { - col1 = tab_vals$colB1 + col1 = tab_vals$idB1 if (!length(col1)) return(NULL) - col2 = tab_vals$colB2 + col2 = tab_vals$idB2 c4a_plot_Plus_Reversed(col1, col2, orientation = "landscape", borders = borders, lwd = lwd) @@ -1205,9 +1197,9 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { output$ex = shiny::renderPlot({ - col1 = tab_vals$colB1 + col1 = tab_vals$idB1 if (!length(col1)) return(NULL) - col2 = tab_vals$colB2 + col2 = tab_vals$idB2 borders = input$borders lwd = input$lwd @@ -1220,14 +1212,10 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { output$table = shiny::renderPlot({ - col1 = tab_vals$colB1 - if (!length(col1)) return(NULL) - col2 = tab_vals$colB2 + id1 = tab_vals$idB1 + id2 = tab_vals$idB2 pal = tab_vals$palBW - - id1 = which(col1 == pal) - id2 = which(col2 == pal) c4a_plot_CR_matrix(pal, id1 = id1, id2 = id2, dark = input$dark) }) @@ -1302,9 +1290,9 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { }) output$textPlot = shiny::renderPlot({ - col1 = tab_vals$colB1 + col1 = tab_vals$idB1 if (!length(col1)) return(NULL) - col2 = tab_vals$colB2 + col2 = tab_vals$idB2 c4a_plot_text2(c(col1, col2), dark = input$dark) }) @@ -1330,8 +1318,8 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { ids = get_click_id(pal, input$cbfSimi_click$x, input$cbfSimi_click$y) - if (!is.na(ids$x)) tab_vals$colA2 = pal[ids$x] - if (!is.na(ids$y)) tab_vals$colA1 = pal[ids$y] + if (!is.na(ids$x)) tab_vals$idA2 = ids$x + if (!is.na(ids$y)) tab_vals$idA1 = ids$y }) shiny::observeEvent(input$cbfPSimi1_click, { @@ -1340,8 +1328,8 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { ids = get_click_id(pal, input$cbfPSimi1_click$x, input$cbfPSimi1_click$y) - if (!is.na(ids$x)) tab_vals$colA2 = pal[ids$x] - if (!is.na(ids$y)) tab_vals$colA1 = pal[ids$y] + if (!is.na(ids$x)) tab_vals$idA2 = ids$x + if (!is.na(ids$y)) tab_vals$idA1 = ids$y }) @@ -1351,8 +1339,8 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { ids = get_click_id(pal, input$cbfPSimi2_click$x, input$cbfPSimi2_click$y) - if (!is.na(ids$x)) tab_vals$colA2 = pal[ids$x] - if (!is.na(ids$y)) tab_vals$colA1 = pal[ids$y] + if (!is.na(ids$x)) tab_vals$idA2 = ids$x + if (!is.na(ids$y)) tab_vals$idA1 = ids$y }) shiny::observeEvent(input$cbfPSimi3_click, { @@ -1361,8 +1349,8 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { ids = get_click_id(pal, input$cbfPSimi3_click$x, input$cbfPSimi3_click$y) - if (!is.na(ids$x)) tab_vals$colA2 = pal[ids$x] - if (!is.na(ids$y)) tab_vals$colA1 = pal[ids$y] + if (!is.na(ids$x)) tab_vals$idA2 = ids$x + if (!is.na(ids$y)) tab_vals$idA1 = ids$y }) @@ -1372,10 +1360,10 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { ids = get_click_id(pal, input$table_click$x, input$table_click$y) - if (!is.na(ids$x)) tab_vals$colB2 = pal[ids$x] - if (!is.na(ids$y)) tab_vals$colB1 = pal[ids$y] + if (!is.na(ids$x)) tab_vals$idB2 = ids$x + if (!is.na(ids$y)) tab_vals$idB1 = ids$y - if (!is.na(ids$x) || !is.na(ids$y)) tab_vals$CR = colorspace::contrast_ratio(tab_vals$colB1, tab_vals$colB2) + if (!is.na(ids$x) || !is.na(ids$y)) tab_vals$CR = colorspace::contrast_ratio(tab_vals$idB1, tab_vals$idB2) }) @@ -1423,18 +1411,18 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { }) shiny::observeEvent(input$float_col1, { - tab_vals$colC1 = tab_vals$pal[which(c(LETTERS, letters) == input$float_col1)] + tab_vals$idC1 = tab_vals$pal[which(c(LETTERS, letters) == input$float_col1)] }) shiny::observeEvent(input$float_col2, { - tab_vals$colC2 = tab_vals$pal[which(c(LETTERS, letters) == input$float_col2)] + tab_vals$idC2 = tab_vals$pal[which(c(LETTERS, letters) == input$float_col2)] }) output$float_letters_AB = shiny::renderPlot({ pal = tab_vals$pal if (!length(pal)) return(NULL) - cols = c(tab_vals$colC1, tab_vals$colC2) + cols = c(tab_vals$idC1, tab_vals$idC2) lL = c(LETTERS,letters)[c(which(pal == cols[1]), @@ -1450,7 +1438,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { pal = tab_vals$pal - cols = c(tab_vals$colC1, tab_vals$colC2) + cols = c(tab_vals$idC1, tab_vals$idC2) if (input$float_rev) cols = rev(cols) c4a_plot_floating_rings(col1 = cols[2], col2 = cols[1], dark = input$dark) diff --git a/R/c4a_table.R b/R/c4a_table.R index 381d8a3..9f20a98 100644 --- a/R/c4a_table.R +++ b/R/c4a_table.R @@ -346,35 +346,67 @@ plot_table = function(p, text.format, text.col, include.na, cvd.sim, verbose) { k = kableExtra::kbl(e2[, e2cols], col.names = e2th, escape = F) - for (cN in colNames) { - if (cN == " ") { - # column between colors and NA-color - k = kableExtra::column_spec(k, which(cN == e2nms), width_min = "1em", width_max = "1em") - } else { - k = kableExtra::column_spec(k, which(cN == e2nms), width_min = "6em", width_max = "6em") - } - } - for (i in which(substr(e2cols, 1, 4) == "Copy")) { - k = kableExtra::column_spec(k, i, width = "1em", extra_css = "padding-left: 10px; padding-right: 0px; text-align: right") #width_min = "1em", width_max = "1em") + # ORIGINAL + # for (cN in colNames) { + # if (cN == " ") { + # # column between colors and NA-color + # k = kableExtra::column_spec(k, which(cN == e2nms), width_min = "1em", width_max = "1em") + # } else { + # k = kableExtra::column_spec(k, which(cN == e2nms), width_min = "6em", width_max = "6em") + # } + # } + + # for (i in which(substr(e2cols, 1, 4) == "Copy")) { + # k = kableExtra::column_spec(k, i, width = "1em", extra_css = "padding-left: 10px; padding-right: 0px; text-align: right") #width_min = "1em", width_max = "1em") + # } + + + # FASTER + ks = strsplit(k[1], "", fixed = TRUE)[[1]] + ins = rep("", length(ks) - 1L) + + col_repl = function(ins, cids, str) { + id = cids + rep(0:(nrow(e2)-1L) * length(e2cols), each = length(cids)) + ins[id] = str + ins } - k = kableExtra::column_spec(k, 1, width = "5em", extra_css = "padding-left: 10px; padding-right: 10px; text-align: right") - k = kableExtra::column_spec(k, 2, width = "5em", extra_css = "padding-left: 0px; padding-right: 10px; text-align: right") - k = kableExtra::column_spec(k, which(substr(e2cols, 1, 4) == "Copy"), width = "1em", extra_css = "padding-left: 5px; padding-right: 0px; text-align: right") - k = kableExtra::row_spec(k, 0, align = "c", extra_css = "padding-left: 3px; padding-right: 3px; vertical-align: bottom; max-width: 0em;") #max-width: 5em; + ins2 = ins |> + col_repl(match(colNames[colNames == " "], e2cols), "") |> + col_repl(match(colNames[colNames != " "], e2cols), "") |> + #col_repl(which(substr(e2cols, 1, 4) == "Copy"), "") |> + col_repl(1, "") |> + col_repl(2, "") |> + col_repl(which(substr(e2cols, 1, 4) == "Copy"), "") + for (q in qn_other) { if (q %in% dupl) { - k = kableExtra::column_spec(k, which(q == e2cols), width = "2.2em", extra_css = "text-align: center; vertical-align: center; overflow: hidden; text-overflow: ellipsis; max-width: 2.2em; min-width: 2.2em;") + ins2 = col_repl(ins2, which(q == e2cols), "") } else { - k = kableExtra::column_spec(k, which(q == e2cols), width = "4em", extra_css = "text-align: center; vertical-align: center; overflow: hidden; text-overflow: ellipsis; max-width: 4em; min-width: 4em;") + ins2 = col_repl(ins2, which(q == e2cols), "") } } for (q in qn_icons) { - k = kableExtra::column_spec(k, which(q == e2cols), extra_css = "font-size: 200%; line-height: 40%; vertical-align: center; text-align: center; white-space: nowrap; max-width: 2.2em; min-width: 2.2em;", width = "2.2em") + ins2 = col_repl(ins2, which(q == e2cols), "") } + # colIds1 = match(colNames[colNames != " "], e2cols) + rep(0:(nrow(e2)-1L) * length(e2cols), each = length(colNames[colNames != " "])) + # ins[colIds1] = "" + # colIds2 = match(colNames[colNames == " "], e2cols) + rep(0:(nrow(e2)-1L) * length(e2cols), each = length(colNames[colNames == " "])) + # ins[colIds2] = "" + + k[1] = paste(c(ks[1], unlist(mapply(c, ins2, ks[-1], SIMPLIFY = FALSE, USE.NAMES = FALSE))), collapse = "") + + + # k = kableExtra::column_spec(k, 1, width = "5em", extra_css = "padding-left: 10px; padding-right: 10px; text-align: right") + # k = kableExtra::column_spec(k, 2, width = "5em", extra_css = "padding-left: 0px; padding-right: 10px; text-align: right") + # k = kableExtra::column_spec(k, which(substr(e2cols, 1, 4) == "Copy"), width = "1em", extra_css = "padding-left: 5px; padding-right: 0px; text-align: right") + k = kableExtra::row_spec(k, 0, align = "c", extra_css = "padding-left: 3px; padding-right: 3px; vertical-align: bottom; max-width: 0em;") #max-width: 5em; + + + kc = k[1] kl = strsplit(kc, "\n")[[1]] diff --git a/build/build_palettes.R b/build/build_palettes.R index 9962745..afafb40 100644 --- a/build/build_palettes.R +++ b/build/build_palettes.R @@ -16,7 +16,7 @@ library(MetBrewer) sessioninfo::session_info(pkgs = "attached") # colorblindcheck * 1.0.2 2023-05-13 [1] CRAN (R 4.4.0) # colorspace * 2.1-1 2024-07-26 [1] CRAN (R 4.4.0) -# P cols4all * 0.7-2 2024-08-23 [?] load_all() +# VP cols4all * 0.7-2 2024-03-12 [?] CRAN (R 4.4.0) (on disk 0.7.1) # ggthemes * 5.1.0 2024-02-10 [1] CRAN (R 4.4.0) # khroma * 1.14.0 2024-08-26 [1] CRAN (R 4.4.1) # MetBrewer * 0.2.0 2022-03-21 [1] CRAN (R 4.4.0) @@ -26,6 +26,7 @@ sessioninfo::session_info(pkgs = "attached") # RColorBrewer * 1.1-3 2022-04-03 [1] CRAN (R 4.4.0) # reticulate * 1.38.0 2024-06-19 [1] CRAN (R 4.4.0) # shiny * 1.8.1.1 2024-04-02 [1] CRAN (R 4.4.0) +# treemap * 2.4-4 2023-05-25 [1] CRAN (R 4.4.0) # viridisLite * 0.4.2 2023-05-02 [1] CRAN (R 4.4.0) @@ -575,6 +576,13 @@ local({ }), names = hclnames) c4a_load(c4a_data(pals, types = "cat", series = "hcl")) + + hcl_cyc = c("pastel1", "dark2", "dark3", "set2", "set3", "dynamic") + pals_cyc = structure(lapply(hcl_cyc, function(h){ + pal = c4a(paste0("hcl.", h)) + pal = c(pal, pal[1]) + }), names = paste0(hcl_cyc, "_cyc")) + c4a_load(c4a_data(pals_cyc, types = "cyc", series = "hcl")) }) ################################### @@ -905,6 +913,21 @@ local({ }) +if (FALSE) { + ### tree colors + library(treemap) + for (child in 2:4) { + dseq = if (child == 2) 3:4 else 2 + for (depth in dseq) { + res = rep(list(1:child),depth) + names(res) = paste0("index", 1:depth) + df = as.data.frame(do.call(expand.grid, rev(res))[,depth:1]) + tp = treepalette(df, palette.HCL.options = list(hue_fraction = .8)) + c4a_plot(tp$HCL.color) + } + } +} + .z = get("z", .C4A) .s = get("s", .C4A)