News 2025.02.16-1

lgschuck · Feb 16, 2025 · 83b03f8 · 83b03f8
1 parent 5ed0758
commit 83b03f8
Show file tree

Hide file tree

Showing 19 changed files with 356 additions and 173 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -19,6 +19,7 @@ Imports:
   dplyr (>= 1.1.4),
   gt (>= 0.11.1),
   haven (>= 2.5.4),
+  sass (>= 0.4.9),
   shiny (>= 1.9.1),
   shinybusy (>= 0.3.3),
   shinyWidgets (>= 0.8.7)

diff --git a/NAMESPACE b/NAMESPACE
@@ -30,6 +30,7 @@ importFrom(DescTools,ZTest)
 importFrom(bsicons,bs_icon)
 importFrom(bslib,accordion)
 importFrom(bslib,accordion_panel)
+importFrom(bslib,bs_add_rules)
 importFrom(bslib,bs_theme)
 importFrom(bslib,card)
 importFrom(bslib,card_body)
@@ -101,6 +102,7 @@ importFrom(haven,as_factor)
 importFrom(haven,is.labelled)
 importFrom(haven,read_sav)
 importFrom(haven,write_sav)
+importFrom(sass,as_sass)
 importFrom(shinyWidgets,colorPickr)
 importFrom(shinyWidgets,dropdownButton)
 importFrom(shinyWidgets,radioGroupButtons)

diff --git a/NEWS.md b/NEWS.md
@@ -20,6 +20,22 @@ editor_options:
 
 6 - Models: linear model, logistic regression, Kmeans, Trees
 
+## 2025.02.16-1
+
+Highlights: New **Darkly** theme and new dependencie: **sass** package.
+
+### Improvements
+
+1 - **Correlation, Descriptive Stats, Normality Test, Sidebar, Spada UI, Z Test** modules: changes in visual parameters and elements (e.g. sidebar now has class) for usage of bs_theme
+
+2 - **Export File** module: now downloadButton has class and correct icon
+
+3 - **Filter Rows** module: new Number of Rows filter 
+
+4 - **spada_themes.R**: new objects with themes and usage of sass package
+
+5 - **Spada Server**: now shiny.maxRequestSize = 1000 MB
+
 ## 2025.02.13-1
 
 Highlights: Use of selectizeInput with close and clear button for multiple selections

diff --git a/R/correlation_module.R b/R/correlation_module.R
@@ -6,15 +6,14 @@ correlation_ui <- function(id) {
     full_screen = T,
     card_header('Correlation Test', class = 'mini-header'),
     layout_sidebar(
-      bg = main_color,
-      sidebar = sidebar(uiOutput(ns('parameters')), bg = sidebar_color),
+      class = 'card-sidebar',
+      sidebar = sidebar(uiOutput(ns('parameters'))),
       navset_card_pill(
         nav_panel(
           'Test',
           card(
             layout_sidebar(
               sidebar = sidebar(
-                bg = sidebar_color,
                 width = 400,
                 h5('Parameters', style = 'margin-bottom: -18px;'),
                 radioButtons(ns('radio_method'), 'Method',

diff --git a/R/descriptive_stats_module.R b/R/descriptive_stats_module.R
@@ -5,9 +5,9 @@ descriptive_stats_ui <- function(id) {
   card(
     full_screen = T,
     card_header('Descriptive Statistics', class = 'mini-header'),
-    layout_sidebar(bg = main_color,
+    layout_sidebar(
+      class = 'card-sidebar',
       sidebar = sidebar(
-        bg = sidebar_color,
         uiOutput(ns('parameters')),
         checkboxGroupInput(
           ns('xg_central_tendency'),

diff --git a/R/exploratory_module.R b/R/exploratory_module.R
@@ -6,8 +6,7 @@ exploratory_ui <- function(id) {
 card(
   full_screen = T,
   card_body(
-    style = 'background-color: #02517d;',
-    height = '800px',
+    class = 'big-card',
     layout_columns(
       col_widths = c(2, 7, 3),
       navset_card_pill(

diff --git a/R/export_file_module.R b/R/export_file_module.R
@@ -49,8 +49,12 @@ export_file_ui <- function(id) {
             ),
           )
         ),
-        card_footer(downloadButton(ns('down_handler'),
-                                   'Export Active dataset', icon('download')))
+        card_footer(downloadButton(
+          ns('down_handler'),
+          'Export Active dataset',
+          class = 'btn-task',
+          icon = icon('download')
+        ))
       )
     )
 }

diff --git a/R/filter_rows_module.R b/R/filter_rows_module.R
@@ -28,9 +28,11 @@ filter_rows_ui <- function(id) {
       # panel for sample filter -----------------------------------------------
       conditionalPanel(
         condition = sprintf("input['%s'] == 'sample'", ns('filter_type')),
-        sliderInput(ns('sample_size'), 'Sample Size (%)', 0, 100, 100),
-        checkboxInput(ns('x_sample_replace'), 'Replace') |>
-          ttip('Allow sample with replacement')
+        radioButtons(
+          ns('sample_type'), NULL,
+          c('Number of Rows' = 'rows', '% of Rows' = 'percent'),
+          inline = T),
+        uiOutput(ns('ui_sample'))
       ),
     ),
     card_footer(
@@ -56,6 +58,8 @@ filter_rows_server <- function(id, input_df) {
       df$df_active <- input_df()
     })
 
+    nrow_df_active <- reactive(nrow(df$df_active))
+
     # variable inputs ---------------------------------------------------------
     output$ui_one_var_sel <- renderUI(
       selectInput(ns('one_var_sel'), 'Variable', c('', df_names()))
@@ -80,6 +84,26 @@ filter_rows_server <- function(id, input_df) {
       df$df_active[[input$two_var_sel1]] |> obj_type()
     })
 
+    # render UI for sample type -----------------------------------------------
+    output$ui_sample <- renderUI({
+      req(input$sample_type)
+      tagList(
+
+        if (input$sample_type == 'rows') {
+          numericInput(
+            ns('n_rows'), 'Number of Rows',
+            value = (nrow_df_active()/2) |> ceiling(),
+            min = 1, max = nrow_df_active()
+          )
+        } else if (input$sample_type == 'percent') {
+          sliderInput(ns('sample_size'), 'Sample Size (%)', 1, 100, 50)
+        }
+        ,
+        checkboxInput(ns('x_sample_replace'), 'Replace') |>
+          ttip('Allow sample with replacement')
+      )
+    })
+
     # render UI for value input dynamically -----------------------------------
     observe({
       req(input$one_var_sel, input$one_var_operator, df$df_active)
@@ -321,12 +345,28 @@ filter_rows_server <- function(id, input_df) {
 
       # filter events for sample ----------------------------------------------
       } else if(input$filter_type == 'sample'){
-        df$df_active <- df$df_active[
-          sample(1:nrow(df$df_active),
-                 input$sample_size/100 * nrow(df$df_active),
-                 replace = input$x_sample_replace), ]
+        if(input$sample_type == 'rows'){
+
+          if(!isTruthy(input$n_rows) ||
+             !between(input$n_rows, 1, nrow_df_active())){
+            msg_error(paste('Number of rows must be between 1 and', nrow_df_active()))
+          } else {
+            df$df_active <- df$df_active[
+              sample(1:nrow_df_active(),
+                     input$n_rows,
+                     replace = input$x_sample_replace), ]
+
+            msg('Filter rows: OK')
+          }
+
+        } else if(input$sample_type == 'percent'){
+          df$df_active <- df$df_active[
+            sample(1:nrow_df_active(),
+                   input$sample_size/100 * nrow_df_active(),
+                   replace = input$x_sample_replace), ]
 
-        msg('Filter rows: OK')
+          msg('Filter rows: OK')
+        }
 
       }
     }) |> bindEvent(input$btn_filter)

diff --git a/R/normality_test_module.R b/R/normality_test_module.R
@@ -5,8 +5,9 @@ normality_test_ui <- function(id) {
   card(
     full_screen = T,
     card_header('Normality Test', class = 'mini-header'),
-    layout_sidebar(bg = main_color,
-      sidebar = sidebar(uiOutput(ns('parameters')), bg = sidebar_color),
+    layout_sidebar(
+      class = 'card-sidebar',
+      sidebar = sidebar(uiOutput(ns('parameters'))),
       navset_card_pill(
         nav_panel(
           'Histogram',

diff --git a/R/page_config_module.R b/R/page_config_module.R
@@ -7,9 +7,9 @@ page_config_ui <- function(id) {
     title = 'Config',
     icon = bs_icon('sliders2'),
     card(
-      style = 'background-color: #02517d;',
+      class = 'big-card',
       layout_columns(
-        col_widths = c(9, 3),
+        col_widths = c(8, 4),
         card(
           card_body(
             h4('Colors'),
@@ -28,25 +28,35 @@ page_config_ui <- function(id) {
                 update = 'save'
               ),
               btn_task(ns('reset'), 'Reset', icon('rotate'),
-                       style = 'margin-top: 20px !important;')
+                       style = 'margin-top: 27px !important;')
             ),
             plotOutput(ns('sample_plot'))
           )
         ),
         card(
           card_body(
-            h4('Size of input files'),
-            layout_columns(
-              col_widths = c(6, 6),
-              numericInput(
-                ns('input_file_size'),
-                'Size in MB',
-                500,
-                min = 0,
-                step = 100
-              ),
-              btn_task(ns('btn_file_size'), 'Apply', icon('check'),
-                       style = 'margin-top: 20px !important;')
+            fluidRow(
+              h4('Theme'),
+              layout_columns(
+                col_widths = c(7, 5),
+                selectInput(ns('theme_choice'), NULL,
+                            choices = c('Spada' = 'spada', 'Darkly Spada' = 'dark')),
+                btn_task(ns('btn_theme'), 'Apply', icon('check'))
+              )
+            ),
+            fluidRow(
+              h4('Size of input files (MB)'),
+              layout_columns(
+                col_widths = c(7, 5),
+                numericInput(
+                  ns('input_file_size'),
+                  NULL,
+                  1000,
+                  min = 0,
+                  step = 500
+                ),
+                btn_task(ns('btn_file_size'), 'Apply', icon('check'))
+              )
             )
           )
         )
@@ -97,6 +107,18 @@ page_config_server <- function(id) {
 
     }) |> bindEvent(input$reset)
 
+    # change theme
+    observe({
+      session$setCurrentTheme(
+
+        if(input$theme_choice == 'spada'){
+          spada_theme
+        } else if(input$theme_choice == 'dark'){
+          spada_dark_theme
+        }
+      )
+    }) |> bindEvent(input$btn_theme)
+
     return(list(palette = palette))
 
   })

diff --git a/R/sidebar_module.R b/R/sidebar_module.R
@@ -4,12 +4,11 @@ sidebar_ui <- function(id) {
   ns <- NS(id)
 
   sidebar(
-    bg = sidebar_color,
     open = F,
     accordion(
       open = T,
       accordion_panel(
-        style = 'background-color: #02517d; color: white;',
+        class = 'accordion-sidebar',
         'Dataset Info',
         icon = bs_icon('file-binary', size = '1.75em'),
         uiOutput(ns('df_info'))

diff --git a/R/spada.R b/R/spada.R
@@ -13,7 +13,7 @@
 #'
 #' @importFrom bsicons bs_icon
 #'
-#' @importFrom bslib accordion accordion_panel bs_theme card card_body
+#' @importFrom bslib accordion accordion_panel bs_add_rules bs_theme card card_body
 #'             card_footer card_header layout_column_wrap layout_columns
 #'             layout_sidebar nav_item nav_menu nav_panel nav_select nav_spacer
 #'             navset_card_pill page_navbar popover sidebar tooltip value_box
@@ -37,6 +37,8 @@
 #'
 #' @importFrom haven as_factor is.labelled read_sav write_sav
 #'
+#' @importFrom sass as_sass
+#'
 #' @importFrom shinyWidgets colorPickr updateColorPickr show_toast dropdownButton
 #'             radioGroupButtons statiCard
 #'

diff --git a/R/spada_server.R b/R/spada_server.R
@@ -3,7 +3,7 @@
 spada_server <- function(datasets){
   function(input, output, session) {
 
-    options(shiny.maxRequestSize = 500 * 1024 ^ 2)
+    options(shiny.maxRequestSize = 1000 * 1024 ^ 2)
 
     # data --------------------------------------------------------------------
     dt_react <- reactiveValues(data = lapply(datasets, setDT))