R/correlation_module.R

In spada: A 'shiny' Package for Data Analysis

# ui --------------------------------------------------------------------------
correlation_ui <- function(id) {
  ns <- NS(id)
  card(
    full_screen = T,
    card_header('Correlation Test', class = 'mini-header'),
    layout_sidebar(
      class = 'card-sidebar',
      sidebar = sidebar(uiOutput(ns('parameters'))),
      navset_card_pill(
        nav_panel(
          'Test',
          card(
            layout_sidebar(
              sidebar = sidebar(
                h5('Parameters', style = 'margin-bottom: -18px;'),
                radioButtons(ns('radio_method'), 'Method',
                             c('Pearson' = 'pearson',
                               'Kendall' = 'kendall',
                               'Spearman' = 'spearman')),
                radioButtons(ns('radio_alternative'), 'Alternative',
                             c('Two sided' = 'two.sided',
                               'Less' = 'less',
                               'Greater' = 'greater')),
                numericInput(ns('confidence'), 'Confidence Interval - %',
                             value = 95, 0, 100, 5, width = '180px'),
                layout_columns(
                  col_widths = c(8),
                  btn_task(ns('btn_run_test'), 'Run Test', icon('gear'))
                ),
                layout_columns(
                  col_widths = c(8),
                  btn_task(ns('btn_help_cor'), 'Help', icon('question'))
                ),
              ),
              layout_columns(
                col_widths = c(3, 6, 3),
                uiOutput(ns('conditional_staticard_cor')),
                gt_output(ns('cor_gt')),
                div(
                  uiOutput(ns('cond_add_output')),
                  br(), br(),
                  uiOutput(ns('conditional_save_gt'))
                ),
              )
            )
          )
        ),
        nav_panel(
          'Scatter',
          card(
            full_screen = T,
            card_body(plotOutput(ns('scatter_plot'))),
            card_footer(
              layout_columns(
                col_widths = c(3, 3),
                btn_task(ns('btn_scatter'), 'Show Scatter Plot', icon('chart-simple')),
                insert_output_ui(ns('insert_scatter'))
              )
            )
          )
        )
      )
    )
  )
}

# server ----------------------------------------------------------------------
correlation_server <- function(id) {
  moduleServer(id, function(input, output, session) {
	  ns <- session$ns

	  df <- reactive(get_act_dt(session))

    # outupt objects ----------------------------------------------------------
    cor_test <- reactiveValues(results = NULL)

    df_active <- reactive({
      req(df())
      df()[, lapply(df(), is.numeric) == T, with = F]
    })

    var_analysis <- reactive({
      df_names <- df_active() |> names()

      var_analysis <- session$userData$dt$act_meta()[perc_nas != 1, var]

      df_names[df_names %in% var_analysis]
    })

    output$parameters <- renderUI({
      tagList(
        selectInput(ns('sel_var1'), 'Variable 1', var_analysis()),
        selectInput(ns('sel_var2'), 'Variable 2', var_analysis(),
                    var_analysis()[2]),
        p('* Showing only numeric variables')
      )
    })

    # run test events ---------------------------------------------------------
    observe({
      req(input$sel_var1)
      req(input$sel_var2)
      req(input$radio_alternative)
      req(input$radio_method)

      if(!isTruthy(input$confidence) ||
         !between(input$confidence, 0, 100)) {
        msg_error('Confidence interval must be between 0 and 100%', 2)
      } else if (sum(!is.na(df_active()[[input$sel_var1]])) < 3 ||
                 sum(!is.na(df_active()[[input$sel_var2]])) < 3) {
        msg_error('Inform at least 3 valid values for each variable')
      } else if (sd(df_active()[[input$sel_var1]], na.rm = T) == 0 ||
                 sd(df_active()[[input$sel_var2]], na.rm = T) == 0) {
        msg_error('The Standard deviation of any of the variables can not be zero', 3)
      } else {
        df <- cor.test(df_active()[[input$sel_var1]],
                       df_active()[[input$sel_var2]],
                       alternative = input$radio_alternative,
                       method = input$radio_method,
                       conf.level = input$confidence/100,
                       exact = F)

        df <- df |>
          unlist() |> as.data.frame()

        df$results <- rownames(df)
        names(df) <- c('values', 'results')

        df[df$results == 'data.name', ]$values <-
          paste(input$sel_var1, '/', input$sel_var2)

        cor_test$results <- df
      }
    }) |> bindEvent(input$btn_run_test)

    # results -----------------------------------------------------------------
    cor_results_gt <- reactive({
      req(cor_test$results)
      cor_test$results |>
        gt() |>
        cols_move(columns = 'values', after = 'results') |>
        cols_label('values' = 'Values', 'results' = 'Results') |>
        tab_header('Correlation Test')
    })

    output$cor_gt <- render_gt({
      req(cor_results_gt())
      cor_results_gt()
    })

    # save gt -----------------------------------------------------------------
    save_gt_server('cor_save_gt', cor_results_gt)

    output$conditional_save_gt <- renderUI({
      req(cor_results_gt())
      save_gt_ui(ns('cor_save_gt'))
    })

    # insert to output --------------------------------------------------------
    insert_output_server('insert_gt', cor_results_gt, 'Correlation Test')

    output$cond_add_output <- renderUI({
      req(cor_results_gt())
      insert_output_ui(ns('insert_gt'))
    })

    # staticards --------------------------------------------------------------
    cor_staticards <- reactive({
      req(cor_results_gt())

      idx_cor <- cor_test$results$results %in% c(
        'estimate.cor', 'estimate.tau', 'estimate.rho'
      )
      est_cor <- cor_test$results$values[idx_cor]

      indx_p <- cor_test$results$results %in% c('p.value')
      p_value <-  cor_test$results$values[indx_p]

      tagList(
        stati_card(f_num(as.numeric(est_cor), dig = 3), 'Correlation'),
        stati_card(f_num(as.numeric(p_value), dig = 3), 'p value')
      )
    })

    output$conditional_staticard_cor <- renderUI({
      req(cor_staticards())
      cor_staticards()
    })

    # scatter plot ------------------------------------------------------------
    task_scatter <- ExtendedTask$new(function(spada_plot_fun,
                                              df,
                                              sel_var1,
                                              sel_var2,
                                              plot_fill_color,
                                              sample_limit) {
      mirai({
        spada_plot_fun(
          type = 'scatter',
          df = df,
          xvar = sel_var1,
          yvar = sel_var2,
          xlab = sel_var1,
          ylab = sel_var2,
          fill_color = plot_fill_color,
          point_shape = if(sample_limit > 1e4 && nrow(df) > 1e4) '.' else 20,
          sample_limit = sample_limit
        )
      },
      spada_plot_fun = spada_plot_fun,
      df = df,
      sel_var1 = sel_var1,
      sel_var2 = sel_var2,
      plot_fill_color = plot_fill_color,
      sample_limit = sample_limit)
    }) |> bind_task_button('btn_scatter')

    observe({
      req(input$sel_var1, input$sel_var2, df_active())
      task_scatter$invoke(
        spada_plot_fun = spada_plot,
        df = df_active(),
        sel_var1 = input$sel_var1,
        sel_var2 = input$sel_var2,
        plot_fill_color = session$userData$conf$plot_fill_color,
        sample_limit = session$userData$conf$plot_limit
      )
    }) |> bindEvent(input$btn_scatter)

    scatter_plot <- reactive({ task_scatter$result() })

    output$scatter_plot <- renderPlot({
      req(scatter_plot())
      scatter_plot()
    }, res = 96)

    # insert scatter to output ------------------------------------------------
    insert_output_server(
      'insert_scatter',
      reactive(plot_tag(scatter_plot())),
      'Scatter Plot'
    )

    # help events -------------------------------------------------------------
    observe({
      fun_help_modal('stats', 'cor.test')
    }) |> bindEvent(input$btn_help_cor)

  })
}