R/spada_server.R

In spada: A 'shiny' Package for Data Analysis

# Function with the server of spada.R
spada_server <- function(datasets, conf, run_local = TRUE){
  function(input, output, session) {

    previous_shiny.maxRequestSize <- getOption('shiny.maxRequestSize')
    options(shiny.maxRequestSize = conf$file_size * 1024 ^ 2)

    onStop(function(){
      options(shiny.maxRequestSize = previous_shiny.maxRequestSize)
      daemons(0)
    })

    session$onFlushed(function(){
      waiter_hide()
    })

    session$userData$run_local <- run_local
    session$onSessionEnded(function(){
      if(session$userData$run_local) stopApp()
    })

    # conf values -------------------------------------------------------------
    session$userData$conf <- reactiveValues(
      no_input_data = conf$no_input_data,
      conf_dir = conf$conf_dir,
      data_dir = conf$data_dir,
      theme = conf$theme,
      file_size = conf$file_size,
      restore_session = conf$restore_session,
      save_session = conf$save_session,
      restore_data_status = conf$restore_data_status,
      restore_output_status = conf$restore_output_status,
      restore_status = conf$restore_status,
      plot_fill_color = conf$plot_fill_color,
      plot_line_color = conf$plot_line_color,
      plot_title_color = conf$plot_title_color,
      plot_limit = conf$plot_limit,
      run_local = run_local
    )

    # restore session module --------------------------------------------------
    restore_session_server('restore_session')

    # data --------------------------------------------------------------------
    session$userData$dt <- reactiveValues(
      dt = datasets,
      act_name = names(datasets[1]),
      bkp0 = NULL,
      bkp = NULL,
      meta = lapply(datasets, df_info),
      updated_cols = NULL,
      data_changed_type = 'new_data'
    )
    session$userData$out <- reactiveValues(elements = list())

    session$userData$data_changed <- reactiveVal(0)
    session$userData$out_edit_trigger <- reactiveVal(NULL)

    session$userData$dt$bkp0 <- isolate(get_act_dt(session))

    session$userData$dt_names <- reactive({
      req(session$userData$dt$dt)
      names(session$userData$dt$dt)
    })

    output$dt_act_name <- renderText(short_name(session$userData$dt$act_name))

    # datasets metadata -------------------------------------------------------
    observe({
      req(session$userData$dt$dt, session$userData$data_changed() > 0)

      if(is.null(session$userData$dt$updated_cols) &&
         session$userData$dt$data_changed_type == 'new_data'){

        # recalculate meta for all cols
        session$userData$dt$meta[[session$userData$dt$act_name]] <- get_act_dt(session) |>
          df_info()
      } else {

        # update name of vars
        if(session$userData$dt$data_changed_type == 'rename_cols'){

          session$userData$dt$meta[[session$userData$dt$act_name]] <- update_meta(
            previous_meta = session$userData$dt$meta[[session$userData$dt$act_name]],
            col_names = get_act_dt(session) |> names(),
            change_type = session$userData$dt$data_changed_type
          )
          # keep meta of selected vars
        } else if (session$userData$dt$data_changed_type == 'select_cols'){

          session$userData$dt$meta[[session$userData$dt$act_name]] <- update_meta(
            previous_meta = session$userData$dt$meta[[session$userData$dt$act_name]],
            col_names = get_act_dt(session) |> names(),
            ncols = get_act_dt(session) |> fncol(),
            change_type = session$userData$dt$data_changed_type
          )

          # update order of vars in meta df
        } else if (session$userData$dt$data_changed_type == 'order_cols'){

          session$userData$dt$meta[[session$userData$dt$act_name]] <- update_meta(
            previous_meta = session$userData$dt$meta[[session$userData$dt$act_name]],
            col_names = get_act_dt(session) |> names(),
            change_type = session$userData$dt$data_changed_type
          )

        } else if (session$userData$dt$data_changed_type %in% c('convert_cols', 'new_data')){

          # update meta of changed variables
          session$userData$dt$meta[[session$userData$dt$act_name]] <- update_meta(
            dt = get_act_dt(session)[, .SD, .SDcols = session$userData$dt$updated_cols],
            previous_meta = session$userData$dt$meta[[session$userData$dt$act_name]],
            col_names = get_act_dt(session) |> names(),
            updated_cols = session$userData$dt$updated_cols,
            ncols = get_act_dt(session) |> fncol(),
            change_type = session$userData$dt$data_changed_type
          )
        }
        session$userData$dt$updated_cols <- NULL
        session$userData$dt$data_changed_type = 'new_data'
      }

    }) |> bindEvent(session$userData$data_changed())

    session$userData$dt$gt_info <- reactive({
      req(session$userData$dt$meta)

      Map(gt_info, session$userData$dt$meta,
          df_name = names(session$userData$dt$meta))
    })

    # df active metadata ---------------------
    session$userData$dt$act_meta <- reactive({
      req(session$userData$dt$meta)

      session$userData$dt$meta[[session$userData$dt$act_name]]
    })

    # info to use in sidebar and navbar modules --------
    session$userData$dt$act_mini_meta <- reactive({
      req(session$userData$dt$act_meta())

      dt_act_meta <- session$userData$dt$act_meta()

      list(
        'row_col' = paste(
          f_int(dt_act_meta[['rows']][1]),
          '/',
          f_int(dt_act_meta[['cols']][1])
        ),
        'col_nas' = dt_act_meta[n_nas > 0, ] |> fnrow()
      )
    })

    # navbar ------------------------------------------------------------------
    navbar_df_info_server('navbar_df_info', app_session = session)

    # side bar ----------------------------------------------------------------
    sidebar_server('sidebar', app_session = session)

    # metadata ----------------------------------------------------------------
    metadata_server('pD_metadata')

    # overview -------------------------------
    data_overview_server('pD_overview')

    # values for boxes -----------------------
    data_highlights_server('pD_highlights')

    # manage datasets ------------------------
    data_server('pD_data')

    # export file ----------------------------
    export_file_server('pD_export')

    # import file ----------------------------
    import_file_server('pD_import')

    # edit page events --------------------------------------------------------

    # calculate cols events ------------------
    calculate_cols_server('pE_calculate_cols')

    # convert events -------------------------
    convert_cols_server('pE_convert_cols')

    # duplicates events -------------------------
    duplicates_server('pE_duplicates')

    # filter events --------------------------
    filter_rows_server('pE_filter_rows')

    # select cols ----------------------------
    select_cols_server('pE_filter_sel_cols')

    # join datasets --------------------------
    join_server('pE_join')

    # order rows events ----------------------
    order_rows_server('pE_order_rows')

    # order cols events ----------------------
    order_cols_server('pE_order_cols')

    # rename cols events ---------------------
    rename_cols_server('pE_rename_cols')

    # summarise events -----------------------
    groupby_server('pE_groupby')

    summarise_server('pE_summarise')

    # edit backup events ---------------------
    data_bkp_server('pE_bkp')

    # analysis page events ----------------------------------------------------
    exploratory_server('pA_exploratory')

    # descriptive stats ----------------------
    descriptive_stats_server('pA_desc_stats')

    # correlation ----------------------------
    cor_matrix_server('pA_cor_matrix')
    correlation_server('pA_correlation')

    # normality test -------------------------
    normality_test_server('pA_normality_test')

    # stats test -----------------------------
    one_t_test_server('pA_t_test')
    z_test_server('pA_z_test')

    # linear model ---------------------------
    lm_server('pA_lm')

    # output events -----------------------------------------------------------
    output_server('pO_output')

    # config events -----------------------------------------------------------
    config_server('pC', app_session = session)

    # about events ------------------------------------------------------------
    about_spada_server('about_spada')

    # exit app event ----------------------------------------------------------
    observe({
      req(input$navbar)
      if (input$navbar == 'exit') {

        if (!session$userData$run_local ||
            session$userData$conf$save_session == 'never'){
          exit_without_save(session)
        } else if(session$userData$conf$save_session == 'ask'){
          # ask to save data and ouput
          showModal(modalDialog(
            title = div(icon('save'), 'Save Session'),
            'Do you want to save Data and Output objects?',
            easyClose = FALSE,
            size = 'm',
            footer = tagList(
              actionButton('btn_cancel_exit', 'Cancel', icon = icon('xmark'), class = 'btn-task btn-task-neutral'),
              actionButton('btn_cancel_save_session', 'No', icon = icon('xmark'), class = 'btn-task btn-task-cancel'),
              actionButton('btn_confirm_save_session', 'Yes', icon = icon('check'), class = 'btn-task')
            )
          ))
        } else if (session$userData$conf$save_session == 'always'){
          exit_with_save(session)
        }
      }
    })

    # cancel exit ----------------------------
    observe({
      removeModal()
      nav_select('navbar', selected = 'Data', session = session)
      nav_select('navset_card_pill_data', selected = 'Highlights', session = session)
    }) |> bindEvent(input$btn_cancel_exit)

    # cancel save session --------------------
    observe({
      removeModal()
      exit_without_save(session)
    }) |> bindEvent(input$btn_cancel_save_session)

    # confirm save session -------------------
    observe({
      removeModal()
      exit_with_save(session)
    }) |> bindEvent(input$btn_confirm_save_session)

  }
}