News 2025.02.08-1

lgschuck · Feb 9, 2025 · 69fcd02 · 69fcd02
1 parent 5e7929e
commit 69fcd02
Show file tree

Hide file tree

Showing 8 changed files with 220 additions and 48 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -20,8 +20,13 @@ export(spada)
 export(suna)
 import(data.table)
 import(shiny)
+importFrom(DescTools,Gmean)
+importFrom(DescTools,Hmean)
+importFrom(DescTools,Kurt)
 importFrom(DescTools,Mode)
 importFrom(DescTools,Outlier)
+importFrom(DescTools,ShapiroFranciaTest)
+importFrom(DescTools,Skew)
 importFrom(DescTools,ZTest)
 importFrom(bsicons,bs_icon)
 importFrom(bslib,accordion)
@@ -60,6 +65,7 @@ importFrom(graphics,curve)
 importFrom(graphics,hist)
 importFrom(graphics,lines)
 importFrom(graphics,mtext)
+importFrom(graphics,polygon)
 importFrom(graphics,text)
 importFrom(gt,cols_align)
 importFrom(gt,cols_hide)
@@ -81,6 +87,9 @@ importFrom(gt,render_gt)
 importFrom(gt,sub_missing)
 importFrom(gt,sub_values)
 importFrom(gt,tab_options)
+importFrom(haven,as_factor)
+importFrom(haven,is.labelled)
+importFrom(haven,read_sav)
 importFrom(haven,write_sav)
 importFrom(shinyWidgets,colorPickr)
 importFrom(shinyWidgets,dropdownButton)
@@ -97,6 +106,7 @@ importFrom(stats,dnorm)
 importFrom(stats,ks.test)
 importFrom(stats,lm)
 importFrom(stats,median)
+importFrom(stats,qnorm)
 importFrom(stats,qqline)
 importFrom(stats,qqnorm)
 importFrom(stats,quantile)

diff --git a/NEWS.md b/NEWS.md
@@ -22,6 +22,23 @@ editor_options:
 
 7 - Models: linear model, logistic regression, Kmeans, Trees
 
+## 2025.02.08-1
+
+Highlights: New stats in Descriptive Stats, Shapiro Francia test and bug fix
+
+### Bug Fixes
+
+1 - **Analysis > Scatter: warning if two Factors variables**: fixed, now requires numeric variables 
+([#18](https://github.com/lgschuck/spada/issues/18))
+
+### Improvements
+
+1 - **Descriptive Stats** module: added geometric mean, harmonic mean, skewness and kurtosis from DescTools package.
+
+2 - **Normality test** module: new test, Shapiro-Francia from DescTools package.
+
+3 - **Exploratory** module: bug fix in scatter. ([#18](https://github.com/lgschuck/spada/issues/18))
+
 ## 2025.02.06-1
 
 Highlights: import sav (SPSS) files and Plot in Z test

diff --git a/R/descriptive_stats_module.R b/R/descriptive_stats_module.R
@@ -12,8 +12,9 @@ descriptive_stats_ui <- function(id) {
         checkboxGroupInput(
           ns('xg_central_tendency'),
           h6('Central Tendency'), inline = T,
-          c('Mean' = 'mean', 'Median' = 'median', 'Mode' = 'mode'),
-          c('mean', 'median', 'mode')
+          c('Mean' = 'mean', 'Geometric Mean' = 'gmean', 'Harmonic Mean' = 'hmean',
+            'Median' = 'median', 'Mode' = 'mode'),
+          c('mean', 'gmean', 'hmean', 'median', 'mode')
         ),
         checkboxGroupInput(
           ns('xg_dispersion'), h6('Dispersion'), inline = T,
@@ -22,6 +23,10 @@ descriptive_stats_ui <- function(id) {
             'Standard Deviation' = 'sd'),
           c('min', 'max', 'IQR', 'range', 'var', 'sd')
         ),
+        checkboxGroupInput(
+          ns('xg_shape'), h6('Shape'), inline = T,
+          c('Skewness' = 'skew', 'Kurtosis' = 'kurt'), c('skew', 'kurt')
+        ),
         numericInput(ns('table_digits'), 'Digits', 2, 0, 9, 1),
         btn_task(ns('btn_stats'), 'Generate Table', icon('gear'))
       ),
@@ -61,6 +66,8 @@ descriptive_stats_server <- function(id, df) {
       subset(df(), select = input$sel_var)
     })
 
+
+    # calculate stats ---------------------------------------------------------
     desc_stats <- reactive({
       req(input$sel_var)
       desc_stats <- list()
@@ -74,6 +81,18 @@ descriptive_stats_server <- function(id, df) {
           \(x) {if(x |> is.numeric()) mean(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
       }
 
+      if('gmean' %in% input$xg_central_tendency){
+        desc_stats$Gmean <- sapply(
+          df_stats(),
+          \(x) {if(x |> is.numeric()) Gmean(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
+      }
+
+      if('hmean' %in% input$xg_central_tendency){
+        desc_stats$Hmean <- sapply(
+          df_stats(),
+          \(x) {if(x |> is.numeric()) Hmean(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
+      }
+
       if('median' %in% input$xg_central_tendency){
         desc_stats$Median <- sapply(
           df_stats(),
@@ -134,9 +153,22 @@ descriptive_stats_server <- function(id, df) {
           \(x) {if(x |> is.numeric()) sd(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
       }
 
+      if('skew' %in% input$xg_shape){
+        desc_stats[['Skewness']] <- sapply(
+          df_stats(),
+          \(x) {if(x |> is.numeric()) Skew(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
+      }
+
+      if('kurt' %in% input$xg_shape){
+        desc_stats[['Kurtosis']] <- sapply(
+          df_stats(),
+          \(x) {if(x |> is.numeric()) Kurt(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
+      }
+
       desc_stats
     })
 
+    # gt table ----------------------------------------------------------------
     gt_stats <- reactive({
       data.frame(
         Measures = names(desc_stats()),
@@ -150,9 +182,12 @@ descriptive_stats_server <- function(id, df) {
       gt_stats() |>
         sub_missing(missing_text = '-') |>
         sub_values(values = 'NA', replacement = '-') |>
-        opt_interactive()
+        sub_values(values = 'Gmean', replacement = 'Geometric Mean') |>
+        sub_values(values = 'Hmean', replacement = 'Harmonic Mean') |>
+        opt_interactive(page_size_default = 25)
     })
 
+    # save table module -------------------------------------------------------
     save_gt_server('pA_desciptive_stats_save_gt', gt_stats)
 
     output$conditional_save_gt <- renderUI({

diff --git a/R/exploratory_module.R b/R/exploratory_module.R
@@ -221,8 +221,12 @@ exploratory_server <- function(id, input_df, df_metadata,
                     input$var_percentile, color_fill(), color_line())
     # render scatter plot -----------------------------------------------------
     output$g_scatter <- renderPlot({
-      if (input$scatter_lm &
-          linear_model$y_name == input$sel_vars &
+      validate(
+        need(is.numeric(var()) && is.numeric(var2()), 'Variables must be numeric')
+      )
+
+      if (input$scatter_lm &&
+          linear_model$y_name == input$sel_vars &&
           linear_model$x_name == input$sel_vars2) {
         plot(
           var2(),

diff --git a/R/normality_test_module.R b/R/normality_test_module.R
@@ -68,6 +68,23 @@ normality_test_ui <- function(id) {
               btn_task(ns('btn_help_sw'), 'Help', icon('question'))
             )
           )
+        ),
+        nav_panel(
+          'Shapiro-Francia Test',
+          card(
+            full_screen = T,
+            card_body(
+              layout_columns(
+                col_widths = c(3, 7, 2),
+                uiOutput(ns('conditional_staticard_sf')),
+                gt_output(ns('sf_test')),
+                uiOutput(ns('conditional_save_sf_gt')))
+            ),
+            card_footer(
+              btn_task(ns('btn_sf'), 'Run Test', icon('gear')),
+              btn_task(ns('btn_help_sf'), 'Help', icon('question'))
+            )
+          )
         )
       )
     )
@@ -317,5 +334,79 @@ normality_test_server <- function(id, df, df_metadata, color_fill, color_line) {
       ))
     }) |> bindEvent(input$btn_help_sw)
 
+    # sf test -----------------------------------------------------------------
+    sf_results <- reactive({
+      req(input$sel_var)
+      req(var())
+      req(var_len())
+
+      if (var_len() < 5 || var_len() > 5000) {
+        msg(paste0('Sample size must be between 5 and 5000 (actual: ', var_len(), ')'), 3)
+
+        return()
+      }
+
+      if (test_all_equal(var())) {
+        msg('Shapiro-Francia test: the values can not be all equal')
+        return()
+      }
+
+      df <- ShapiroFranciaTest(var()) |> unlist() |> as.data.frame()
+
+      df$results <- rownames(df)
+      names(df) <- c('values', 'results')
+
+      df[df$results == 'data.name', ]$values <- paste(input$sel_var)
+
+      df
+    }) |> bindEvent(input$btn_sf)
+
+    sf_results_gt <- reactive({
+      req(sf_results())
+
+      sf_results() |>
+        gt() |>
+        cols_move(columns = 'values', after = 'results') |>
+        gt::cols_label('values' = 'Values', 'results' = 'Results')
+    })
+
+    output$conditional_staticard_sf <- renderUI({
+      req(sf_results())
+      tagList(
+        stati_card(sf_results() |>
+                     filter(results %in% c('statistic.W')) |>
+                     pull(values) |>
+                     as.numeric() |>
+                     f_num(dig = 5),
+                   'Statistic W (test value)'),
+        stati_card(sf_results() |>
+                     filter(results %in% c('p.value')) |>
+                     pull(values) |>
+                     as.numeric() |>
+                     f_num(dig = 5),
+                   'p value')
+      )
+    })
+
+    output$sf_test <- render_gt({
+      req(sf_results_gt())
+      sf_results_gt()
+    })
+
+    save_gt_server('sf_save_gt', sf_results_gt)
+
+    output$conditional_save_sf_gt <- renderUI({
+      req(sf_results_gt())
+      save_gt_ui(ns('sf_save_gt'))
+    })
+
+    # help file of ShapiroFranciaTest
+    observe({
+      showModal(modalDialog(
+        HTML(get_help_file('DescTools', 'ShapiroFranciaTest')),
+        easyClose = TRUE, size = 'xl'
+      ))
+    }) |> bindEvent(input$btn_help_sf)
+
   })
 }
diff --git a/R/spada.R b/R/spada.R
@@ -19,11 +19,12 @@
 #'             layout_sidebar nav_item nav_menu nav_panel nav_select nav_spacer
 #'             navset_card_pill page_navbar popover sidebar tooltip value_box
 #'
-#' @importFrom DescTools Mode Outlier ZTest
+#' @importFrom DescTools Gmean Hmean Kurt Mode Outlier ShapiroFranciaTest
+#'             Skew ZTest
 #'
 #' @importFrom dplyr arrange filter mutate pull select
 #'
-#' @importFrom graphics abline barplot boxplot curve hist lines mtext text
+#' @importFrom graphics abline barplot boxplot curve hist lines mtext polygon text
 #'
 #' @importFrom grDevices colors
 #'
@@ -32,15 +33,15 @@
 #'             fmt_number fmt_percent gt gt_output gtsave opt_interactive
 #'             render_gt sub_missing sub_values tab_options
 #'
-#' @importFrom haven write_sav
+#' @importFrom haven as_factor is.labelled read_sav write_sav
 #'
 #' @importFrom shinyWidgets colorPickr updateColorPickr show_toast dropdownButton
 #'             radioGroupButtons statiCard
 #'
 #' @importFrom shinybusy busy_start_up spin_epic
 #'
 #' @importFrom stats cor lm sd var median rnorm IQR cor.test dnorm ks.test
-#'             qqline qqnorm shapiro.test
+#'             qnorm qqline qqnorm shapiro.test
 #'
 #' @importFrom utils object.size head