News 2025.01.20-1

lgschuck · Jan 20, 2025 · c228ef2 · c228ef2
1 parent 17439b7
commit c228ef2
Show file tree

Hide file tree

Showing 16 changed files with 249 additions and 70 deletions.
diff --git a/.Rprofile b/.Rprofile
@@ -14,7 +14,10 @@ if(interactive()){
   library(data.table)
   library(dplyr)
   library(conflicted)
+  library(shinyWidgets)
+  library(shinybusy)
 
   conflicted::conflict_prefer('filter', 'dplyr')
+  conflicted::conflict_prefer('between', 'data.table')
 
 }
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -16,6 +16,7 @@ Imports:
   dplyr (>= 1.1.4),
   gt (>= 0.11.1),
   shiny (>= 1.9.1),
+  shinybusy (>= 0.3.3),
   shinyWidgets (>= 0.8.7)
 Encoding: UTF-8
 LazyData: true

diff --git a/NAMESPACE b/NAMESPACE
@@ -72,12 +72,18 @@ importFrom(gt,fmt_number)
 importFrom(gt,fmt_percent)
 importFrom(gt,gt)
 importFrom(gt,gt_output)
+importFrom(gt,gtsave)
 importFrom(gt,opt_interactive)
 importFrom(gt,render_gt)
 importFrom(gt,sub_missing)
 importFrom(gt,tab_options)
 importFrom(shinyWidgets,colorPickr)
+importFrom(shinyWidgets,dropdownButton)
+importFrom(shinyWidgets,radioGroupButtons)
+importFrom(shinyWidgets,show_toast)
 importFrom(shinyWidgets,updateColorPickr)
+importFrom(shinybusy,busy_start_up)
+importFrom(shinybusy,spin_epic)
 importFrom(stats,IQR)
 importFrom(stats,cor)
 importFrom(stats,cor.test)

diff --git a/NEWS.md b/NEWS.md
@@ -22,6 +22,24 @@ editor_options:
 
 7 - Models: linear model, logistic regression, Kmeans, Trees
 
+## 2025.01.20-1
+
+### Improvements
+
+1 - **Startup page**: now with startup page with shinybusy package (new dependencie)
+
+2 - **radioGroupButtons**: change some radioButtons (shiny) for radioGroupButtons (shinyWidgets) in data_overview_module and exploratory_module for better look
+
+3 - **Page config** module: colorPickr now with 'save' mode for better reset of values and other visual changes fo better look
+
+4 - **New Save gt** module: now the gt table can be saved to hmtl, rtf and docx (gt::gt_save function)
+
+5 - **Stats table** module: check for digits if out of range (0, 9) and new save_gt module in this module
+
+6 - **Descriptive Stats** module: insert req to generate stats and new save_gt_module in this module
+
+7 - **show_toast**: change showNotification (shiny) for show_toast (shinyWidgets) for better look
+
 ## 2025.01.17-1
 
 ### Improvements

diff --git a/R/data_overview_module.R b/R/data_overview_module.R
@@ -11,9 +11,10 @@ data_overview_ui <- function(id) {
               "),
     fluidRow(
       column(2, numericInput(ns('size_sample'), 'Number of rows', 100, 100, 1e4, 100)),
-      column(2, radioButtons(
+      column(2, radioGroupButtons(
         ns('radio_sample'), 'Show',
-        c('First rows' = 'first', 'Sample' = 'sample'), inline = T)),
+        c('First rows' = 'first', 'Sample' = 'sample'),
+        size = 'sm', individual = T)),
       style = "margin-top: -16px !important; margin-bottom: -16px !important;"
     ),
   )

diff --git a/R/descriptive_stats_module.R b/R/descriptive_stats_module.R
@@ -29,7 +29,9 @@ descriptive_stats_ui <- function(id) {
           'Stats',
           card(full_screen = T,
             card_body(
-              gt_output(ns('gt_stats')))
+              gt_output(ns('gt_stats')),
+              uiOutput(ns('conditional_save_gt'))
+            )
           )
         )
       )
@@ -53,6 +55,7 @@ descriptive_stats_server <- function(id, df) {
     })
 
     df_stats <- reactive({
+      req(input$sel_var)
       subset(df(), select = input$sel_var)
     })
 
@@ -118,13 +121,26 @@ descriptive_stats_server <- function(id, df) {
       desc_stats
     })
 
-    output$gt_stats <- render_gt(
+    gt_stats <- reactive({
       data.frame(
         Measures = names(desc_stats()),
         do.call(rbind, desc_stats())
       ) |>
-        gt() |>
+        gt()
+    }) |> bindEvent(input$btn_stats)
+
+    output$gt_stats <- render_gt({
+      req(gt_stats)
+      gt_stats() |>
         opt_interactive()
-    ) |> bindEvent(input$btn_stats)
+    })
+
+    save_gt_server('pA_desciptive_stats_save_gt', gt_stats)
+
+    output$conditional_save_gt <- renderUI({
+      req(gt_stats())
+      save_gt_ui(ns('pA_desciptive_stats_save_gt'))
+    })
+
   })
 }
diff --git a/R/exploratory_module.R b/R/exploratory_module.R
@@ -30,14 +30,14 @@ card(
           card_footer(
             fluidRow(
               column(8,
-                     radioButtons(
+                     radioGroupButtons(
                        ns('radio_dist_plot'),
                        'Plot type:',
                        c('Histogram' = 'hist',
                          'Boxplot' = 'boxplot',
                          'Boxplot by Groups' = 'boxplot_group',
                          'Dots' = 'dots',
-                         'Barplot' = 'barplot'),inline = T)),
+                         'Barplot' = 'barplot'), size = 'sm', individual = T)),
               column(2, numericInput(ns('var_percentile'), 'Percentile', 50, 0, 100, 5)),
               column(2, conditionalPanel(
                 condition = sprintf("input['%s'] == 'hist'", ns('radio_dist_plot')),
@@ -66,9 +66,9 @@ card(
           'Table',
           full_screen = T,
           card_body(
-            radioButtons(ns('table_type'), 'Table type:',
+            radioGroupButtons(ns('table_type'), 'Table type:',
                          c('1 Variable' = '1d',
-                           '2 Variables' = '2d'), inline = T),
+                           '2 Variables' = '2d'), size = 'sm', individual = T),
             verbatimTextOutput(ns('table'), placeholder = T),
           )
         ),
@@ -91,10 +91,12 @@ card(
               plotOutput(ns('g_lm_resid')),
               card_footer(
                 layout_column_wrap(
-                  radioButtons(ns('radio_lm_resid'), 'Plot type:',
+                  radioGroupButtons(ns('radio_lm_resid'), 'Plot type:',
                                c('Histogram' = 'hist', 'Boxplot' = 'boxplot',
-                                 'Dots' = 'dots'), inline = T),
-                  btn_task(ns('btn_lm_resid'), 'Plot residuals', icon('chart-simple')))
+                                 'Dots' = 'dots'), size = 'sm', individual = T),
+                  btn_task(ns('btn_lm_resid'), 'Plot residuals', icon('chart-simple'))
+                ),
+                div(style = "margin-bottom: -24px !important;"),
               )
             ),
           )),

diff --git a/R/page_config_module.R b/R/page_config_module.R
@@ -6,24 +6,52 @@ page_config_ui <- function(id) {
     value = 'config',
     title = 'Config',
     icon = bs_icon('sliders2'),
-    card(style = 'background-color: #02517d;', layout_columns(
-      col_widths = c(9, 3), card(card_body(
-        h4('Colors'),
-        layout_columns(
-          col_widths = c(3, 3, 3),
-          colorPickr(inputId = ns('sel_fill'), label = 'Fill color:',
-                     selected = '#5cacee', update = 'changestop'),
-          colorPickr(inputId = ns('sel_line'),label = 'Line color',
-                     selected = '#EE7942', update = 'changestop'),
-          btn_task(ns('reset'), 'Reset', style = 'margin-top: 20px !important;')
+    card(
+      style = 'background-color: #02517d;',
+      layout_columns(
+        col_widths = c(9, 3),
+        card(
+          card_body(
+            h4('Colors'),
+            layout_columns(
+              col_widths = c(3, 3, 3),
+              colorPickr(
+                inputId = ns('sel_fill'),
+                label = 'Fill color:',
+                selected = '#5cacee',
+                update = 'save'
+              ),
+              colorPickr(
+                inputId = ns('sel_line'),
+                label = 'Line color',
+                selected = '#EE7942',
+                update = 'save'
+              ),
+              btn_task(ns('reset'), 'Reset', icon('rotate'),
+                       style = 'margin-top: 20px !important;')
+            ),
+            plotOutput(ns('sample_plot'))
+          )
         ),
-        plotOutput(ns('sample_plot'))
-      )), card(card_body(
-        h4('Size of input files'),
-        numericInput(ns('input_file_size'), 'Size in MB', 500, min = 0, step = 100),
-        btn_task(ns('btn_file_size'), 'Apply', icon('check'))
-      ))
-    ))
+        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;')
+            )
+          )
+        )
+      )
+    )
   )
 }
 
@@ -60,16 +88,14 @@ page_config_server <- function(id) {
     }) |> bindEvent(input$btn_file_size)
 
     observe({
-      updateColorPickr(
-      session = session,
-      inputId = 'sel_fill', action = 'show', value = '#5cacee')
-
-      updateColorPickr(
-        session = session,
-        inputId = 'sel_line', action = 'show', value = '#EE7942')
+      updateColorPickr(session = session,
+                       inputId = 'sel_fill',
+                       value = '#5cacee')
+      updateColorPickr(session = session,
+                       inputId = 'sel_line',
+                       value = '#EE7942')
 
-      }) |>
-        bindEvent(input$reset)
+    }) |> bindEvent(input$reset)
 
     return(list(palette = palette))
 

diff --git a/R/save_gt_module.R b/R/save_gt_module.R
@@ -0,0 +1,39 @@
+
+# ui --------------------------------------------------------------------------
+save_gt_ui <- function(id) {
+  ns <- NS(id)
+
+  dropdownButton(
+    inputId = ns('drop_btn'),
+    label = 'Save',
+    tagList(
+      h3('Save table'),
+      textInput(ns('file_name'), 'File name', value = 'table'),
+      radioGroupButtons(ns('radio_format'), 'Format',
+                        c('html', 'rtf', 'docx'), size = 'sm', individual = T),
+      downloadButton(ns('down_handler'),
+                     'Save table', icon('download')),
+      br()),
+    circle = F, size = 'sm', icon = icon('download')
+  )
+}
+
+# server ----------------------------------------------------------------------
+save_gt_server <- function(id, input_table) {
+  moduleServer(id, function(input, output, session) {
+
+    output$down_handler <- downloadHandler(
+
+      filename = function() {
+        req(input_table())
+        paste(input$file_name,
+              switch(input$radio_format,
+                    html = '.html', rtf = '.rtf', docx = '.docx'))
+      },
+      content = function(file) {
+        req(input_table())
+        gtsave(input_table(), file)
+      }
+    )
+  })
+}
diff --git a/R/spada.R b/R/spada.R
@@ -14,21 +14,23 @@
 #' @importFrom bsicons bs_icon
 #' @importFrom gt cols_align cols_hide cols_label cols_merge cols_move
 #'             cols_width data_color fmt_bytes fmt_icon fmt_integer
-#'             fmt_number fmt_percent gt gt_output opt_interactive render_gt
-#'             sub_missing tab_options
+#'             fmt_number fmt_percent gt gt_output gtsave opt_interactive
+#'             render_gt sub_missing tab_options
 #'
 #' @importFrom bslib accordion accordion_panel 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
-#' @importFrom shinyWidgets colorPickr updateColorPickr
+#' @importFrom shinyWidgets colorPickr updateColorPickr show_toast dropdownButton
+#'             radioGroupButtons
 #' @importFrom dplyr arrange filter mutate pull select
 #' @importFrom graphics abline hist
 #' @importFrom utils object.size head
 #' @importFrom graphics barplot boxplot curve lines mtext text
 #' @importFrom stats cor lm sd var median rnorm IQR cor.test dnorm ks.test
 #'             qqline qqnorm shapiro.test
 #' @importFrom grDevices colors
+#' @importFrom shinybusy busy_start_up spin_epic
 
 spada <- function(...) {
   datasets <- list(...)

diff --git a/R/spada_server.R b/R/spada_server.R
@@ -103,7 +103,7 @@ spada_server <- function(datasets){
     observe({
       if(!is_valid_name(input$pD_data_txt_new_name) ||
          (input$pD_data_txt_new_name %in% dt_names_react())){
-        msg_error('Name invalid or already in use')
+        msg_error('New name is not valid or already in use')
       } else {
         dt_react$data[[ input$pD_data_txt_new_name ]] <- df$df_active
         msg(paste('Dataset', input$pD_data_txt_new_name, 'created'))

diff --git a/R/spada_ui.R b/R/spada_ui.R
@@ -4,6 +4,21 @@ spada_ui <- function(){
   tagList(
     useBusyIndicators(),
 
+    busy_start_up(
+      loader = spin_epic('orbit', color = '#FFFFFF'),
+      text = tagList(
+        h1(
+        'Spada',
+        style = "font-family: 'Times'; font-size: 120px;"),
+        p('Loading...',
+          style = "font-family: 'Times'; font-size: 20px;")
+      ),
+      mode = 'auto',
+      timeout = 1200,
+      color = '#FFFFFF',
+      background = '#02517d'
+    ),
+
     # close the app
     tag_js_exit,