cut var / up factor: color ui in primary

DESCRIPTION

@@ -30,6 +30,7 @@ Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.1
 Imports: 
+    bslib,
     classInt,
     data.table,
     htmltools,
@@ -46,7 +47,6 @@ Imports:
     shinybusy,
     writexl
 Suggests: 
-    bslib,
     ggplot2,
     jsonlite,
     knitr,

NAMESPACE

@@ -44,6 +44,9 @@ export(validation_ui)
 export(winbox_create_column)
 export(winbox_cut_variable)
 export(winbox_update_factor)
+importFrom(bslib,bs_current_theme)
+importFrom(bslib,bs_get_variables)
+importFrom(bslib,is_bs_theme)
 importFrom(classInt,classIntervals)
 importFrom(data.table,":=")
 importFrom(data.table,.N)

R/cut-variable.R

@@ -130,8 +130,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
       output$plot <- renderPlot({
         data <- req(data_r())
         variable <- req(input$variable)
-        # ggplot_histogram(data, variable, breaks = breaks_r()$brks)
-        plot_histogram(data, variable, breaks = breaks_r()$brks)
+        plot_histogram(data, variable, breaks = breaks_r()$brks, color = get_primary_color())
       })
 
 
@@ -189,7 +188,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
           column = "count",
           label_outside = TRUE,
           label_width = "40px",
-          bar_bg = "#112466",
+          bar_bg = get_primary_color(),
           from = c(0, max(count_data$count) + 1)
         )
       })
@@ -262,14 +261,14 @@ winbox_cut_variable <- function(id,
 
 
 #' @importFrom graphics abline axis hist par plot.new plot.window
-plot_histogram <- function(data, column, bins = 30, breaks = NULL) {
+plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112466") {
   x <- data[[column]]
   op <- par(mar = rep(1.5, 4)); on.exit(par(op))
   plot.new()
   plot.window(xlim = range(pretty(x)), ylim =  range(pretty(hist(x, breaks = bins, plot = FALSE)$counts)))
   abline(v = pretty(x), col = "#D8D8D8")
   abline(h = pretty(hist(x, breaks = bins, plot = FALSE)$counts), col = "#D8D8D8")
-  hist(x, breaks = bins, xlim = range(pretty(x)), xaxs = "i", yaxs = "i", col = "#112466", add = TRUE)
+  hist(x, breaks = bins, xlim = range(pretty(x)), xaxs = "i", yaxs = "i", col = color, add = TRUE)
   axis(side = 1, at = pretty(x), pos = 0)
   axis(side = 2, at = pretty(hist(x, breaks = bins, plot = FALSE)$counts), pos = min(pretty(x)))
   abline(v = breaks, col = "#FFFFFF", lty = 1, lwd = 1.5)

R/update-factor.R

@@ -180,6 +180,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
           label_outside = TRUE,
           label_width = "30px",
           background = "#D8DEE9",
+          bar_bg = get_primary_color(),
           from = c(0, max(rv$data_grid$Freq) + 1)
         )
         grid

R/utils-shiny.R

@@ -211,3 +211,13 @@ button_close_modal <- function() {
 }
 
 
+#' @importFrom bslib bs_current_theme is_bs_theme bs_get_variables
+get_primary_color <- function() {
+  theme <- bslib::bs_current_theme()
+  if (!bslib::is_bs_theme(theme)) {
+    return("#112466")
+  }
+  primary <- bslib::bs_get_variables(theme, "primary")
+  unname(primary)
+}
+