R/utils.R

In spada: A 'shiny' Package for Data Analysis

# ============================================================================.
# ---------------------------- OBJECTS ---------------------------------------
# ============================================================================.

# default conf ----------------------------------------------------------------
default_conf <- list(
  'theme' = 'spada_theme',
  'file_size' = 1000,
  'restore_session' = 'never',
  'save_session' = 'ask',
  'restore_data_status' = 0,
  'restore_output_status' = 0,
  'restore_status' = NULL,
  'plot_fill_color' = plot_fill_color,
  'plot_line_color' = plot_line_color,
  'plot_title_color' = plot_title_color,
  'plot_limit' = 1e5
)

# math functions --------------------------------------------------------------
math_funs <- c(
  'Mean' = 'mean_na',
  'Mean no NA' = 'mean_nona',
  'Geometric Mean' = 'Gmean',
  'Harmonic Mean' = 'Hmean',
  # 'Mode' = 'Mode',
  'Standard Deviation' = 'fsd',
  'Variance' = 'fvar',
  'Min' = 'min_na',
  'Min no NA' = 'min_nona',
  'Max' = 'max_na',
  'Max no NA' = 'max_nona',
  'First' = 'first_na',
  'First no NA' = 'first_nona',
  'Last' = 'last_na',
  'Last no NA' = 'last_nona',
  'Lag' = 'shift',
  # 'Range' = 'range',
  'IQR' = 'IQR',
  'Skewness' = 'Skew',
  'Kurtosis' = 'Kurt',
  'Sum' = 'sum_na',
  'Sum no NA' = 'sum_nona',
  'Cum Sum' = 'cumsum',
  'Prod' = 'prod',
  'Cum Prod' = 'cumprod',
  'Square Root' = 'sqrt',
  'Exponential' = 'exp',
  'Log' = 'log',
  'Log2' = 'log2',
  'Log10' = 'log10',
  'Ceiling' = 'ceiling',
  'Floor' = 'floor',
  'Trunc' = 'trunc',
  'Signif' = 'signif',
  'Round' = 'round',
  'Abs' = 'abs',
  'Sine' = 'sin',
  'Cosine' = 'cos',
  'Tangent' = 'tan',
  'Order' = 'order',
  'As Numeric' = 'as.numeric',
  'Is Numeric' = 'is.numeric',
  'As Double' = 'as.double',
  'Is Double' = 'is.double',
  'As Integer' = 'as.integer',
  'Is Integer' = 'is.integer',
  'Is Integer' = 'is.integer',
  'As Numeric' = 'as.numeric',
  'Is Numeric' = 'is.numeric'
  )

groupby_math_funs <- c(
  'Mean' = 'mean_na',
  'Mean no NA' = 'mean_nona',
  'Geometric Mean' = 'Gmean',
  'Harmonic Mean' = 'Hmean',
  'Standard Deviation' = 'sd',
  'Variance' = 'var',
  'Min' = 'min_na',
  'Min no NA' = 'min_nona',
  'Max' = 'max_na',
  'Max no NA' = 'max_nona',
  'First' = 'fina',
  'Last' = 'lana',
  'Skewness' = 'Skew',
  'Kurtosis' = 'Kurt',
  'Sum' = 'sum_na',
  'Sum no NA' = 'sum_nona',
  'Prod' = 'prod'
)

# char functions --------------------------------------------------------------
char_funs <- c(
  'To Upper' = 'toupper',
  'To Lower' = 'tolower',
  'N Char' = 'nchar',
  'As Char' = 'as.character',
  'Is Char' = 'is.character'
)

groupby_char_funs <- c(
  'First' = 'fina',
  'Last' = 'lana'
)

# date functions --------------------------------------------------------------
date_funs <- c(
  # data.table package
  'Year' = 'year',
  'Month' = 'month',
  'Month Day' = 'mday',
  'Week Day' = 'wday',
  'Year Day' = 'yday',
  'Week' = 'week',
  'Quarter' = 'quarter',
  'Hour' = 'hour',
  'Minute' = 'minute',
  'Second' = 'second',
  # spada package
  'Is Date' = 'is_date'
)

groupby_date_funs <- c(
  'Min' = 'min_na',
  'Min no NA' = 'min_nona',
  'Max' = 'max_na',
  'Max no NA' = 'max_nona',
  'First' = 'fina',
  'Last' = 'lana'
)

# factor functions ------------------------------------------------------------
factor_funs <- c(
  'Number of Levels' = 'nlevels',
  'As factor' = 'as.factor',
  'Is Factor' = 'is.factor',
  'Is Ordered' = 'is.ordered'
)

# logical functions -----------------------------------------------------------
logical_funs <- c(
  'All True' = 'all',
  'Any True' = 'any',
  'As Logical' = 'as.logical',
  'Is Logical' = 'is.logical',
  'Number of True' = 'sum_na',
  'Proportion of True' = 'mean_na'
)

groupby_logical_funs <- c(
  'Min' = 'min_na',
  'Min no NA' = 'min_nona',
  'Max' = 'max_na',
  'Max no NA' = 'max_nona',
  'First' = 'fina',
  'Last' = 'lana',
  'Sum' = 'sum_na',
  'Sum no NA' = 'sum_nona'
)

# complex functions -----------------------------------------------------------
complex_funs <- c(
  'Real Part' = 'Re',
  'Imaginary Part' = 'Im',
  'Is Complex' = 'is.complex'
)

# basic operations ------------------------------------------------------------
basic_operations <- c(
  # base package
  '+', '-', '+', '-', '/', '*', '^',
  '==', '!=', '!', '>', '>=', '<', '<=',
  '&', '|', 'xor',
  '(', '[', '<-', '$',
  '%in%', 'is.na', 'is.null', 'is.nan', 'na.omit',
  '::', ':', 'T', 'F',
  'list', 'try',
  'paste', 'paste0', 'substr',
  'isTRUE', 'isFALSE',
  'c',
  'as.Date', 'as.POSIXct', 'as.POSIXlt',
  'ifelse',
  # base math
  'mean', 'median', 'sd', 'var', 'min', 'max', 'sum',

  # data.table package
  '%notin%', 'between', '%between%', 'fifelse', 'fcase',

  # DescTools package
  'Outlier',

  #stats package
  'quantile',

  #spada utils functions
  'first_na', 'first_nona', 'last_na', 'last_nona', 'max_na', 'max_nona',
  'mean_na', 'mean_nona', 'min_na', 'min_nona', 'sum_na', 'sum_nona'
)

# dangerous operations --------------------------------------------------------
dangerous_operations <- c(
  # R base - code
  'assign', 'attach',
  'do.call',
  'eval', 'eval.parent', 'evalq',
  'get', 'globalenv', 'new.env', 'parent.env', 'parse',
  'remove', 'rm', 'setwd', 'substitute', 'Sys.setenv',

  # R base - files system
  'dir.create', 'dir.exists', 'dir.remove',
  'file.copy', 'file.create', 'file.remove', 'file.rename',
  'load', 'save', 'saveRDS', 'unlink',

  # R base - network
  'curl', 'download.file', 'httr::DELETE', 'httr::GET', 'httr::POST', 'httr::PUT',
  'RCurl::getURL', 'RCurl::postForm', 'socketConnection', 'url',

  # R base - IO
  'read.csv', 'readLines', 'read.table', 'readRDS',
  'write.csv', 'writeLines', 'write.table',

  # R base system
  'shell', 'shell.exec', 'system', 'system2', 'gc',

  # data.table
  ':=',
  'set', 'setattr', 'setcolorder', 'setnames', 'setDT',
  'setDF', 'setkey', 'setorder', 'substitute2'
)

# allowed operations ----------------------------------------------------------
allowed_operations <- c(
  basic_operations,
  math_funs,
  char_funs,
  date_funs,
  factor_funs,
  logical_funs
) |> unique() |> sort()

# list of filters -------------------------------------------------------------
equal_operators <- c('== (Equal)' = '==',
                     '!= (Not Equal)' = '!=')

compare_operators <- c('> (Greater)' = '>',
                       '>= (Greater or Equal)' = '>=',
                       '< (Less)' = '<',
                       '<= (Less or Equal)' = '<=')

na_operators <- c('Is NA (is.na)' = 'is_na',
                  'Not NA (! is.na)' = 'not_na')

in_operators <- c('In (%in%)' = 'in',
                  'Not In (! %in%)' = 'not_in')

between_operators <- c('Between' = 'between',
                       'Not Between' = 'not_between')

outlier_operators <- c('Outlier' = 'outlier',
                       'Not Outlier' = 'not_outlier')

logical_operators <- c('TRUE' = 'is_true',
                       'FALSE' = 'is_false')

filter_operators <- c(
  equal_operators,
  compare_operators,
  na_operators,
  in_operators,
  between_operators,
  outlier_operators,
  logical_operators
)

# lits of date formats --------------------------------------------------------
date_formats <- c(
  # hifen
  'YYYY-MM-DD' = '%Y-%m-%d',
  'DD-MM-YYY' = '%d-%m-%Y',
  'MM-DD-YY' = '%m-%d-%y',
  'YYYY-MMM-DD' = '%Y-%b-%d',
  'YY-MMM-DD' = '%y-%b-%d',
  'YY-MM-DD' = '%y-%m-%d',
  # bars
  'YYYY/MM/DD' = '%Y/%m/%d',
  'DD/MM/YYYY' = '%d/%m/%Y',
  'MM/DD/YY' = '%m/%d/%y',
  'YYYY/MMM/DD' = '%Y/%b/%d',
  'YY/MMM/DD' = '%y/%b/%d',
  'YY/MM/DD' = '%y/%m/%d',
  # dots
  'YYYY.MM.DD' = '%Y.%m.%d',
  'DD.MM.YYYY' = '%d.%m.%Y',
  'MM.DD.YY' = '%m.%d.%y',
  'YYYY.MMM.DD' = '%Y.%b.%d',
  'YY.MMM.DD' = '%y.%b.%d',
  'YY.MM.DD' = '%y.%m.%d',
  # no separator
  'YYYYMMDD' = '%Y%m%d',
  'DDMMYYYY' = '%d%m%Y',
  'MMDDYY' = '%m%d%y',
  'YYYYMMMDD' = '%Y%b%d',
  'YYMMMDD' = '%y%b%d',
  'YYMMDD' = '%y%m%d'
)

# list of summarise functions -------------------------------------------------
summarise_functions <- c(
  'Distinct' = 'distinct',
  'Count' = 'count'
)

# close browser tab -----------------------------------------------------------
js_exit <- "Shiny.addCustomMessageHandler('closeWindow', function(m) {window.close();});"

tag_js_exit <- tags$head(tags$script(HTML(js_exit)))

# waiter screen ----------------------------------------------------------------
waiter_right_foot <- div('Built with R and Shiny', class = 'screen-footer-right')
waiter_spinner <- div(class = 'screen-spinner')

waiter_screen <- tags$style(
  HTML(
    "
    .waiter-overlay {
      font-family: 'Segoe UI', Ubuntu, system-ui;
      color: white;
      display: flex;
      justify-content: center;
      align-items: center;

      background: linear-gradient(
        55deg,
        #02517D,
	    	#0A101C,
        #001030,
		    #003452,
		    #02517D,
        #003452,
        #001030,
		    #0A101C,
		    #02517D
      );

      background-size: 400% 400%;
      animation: gradientMove 16s ease infinite;
    }

    @keyframes gradientMove {
      0%   { background-position: 0% 50%; }
      50%  { background-position: 100% 50%; }
      100% { background-position: 0% 50%; }
    }

    .waiter-overlay .screen-container {
      text-align: center;
      animation: fadeIn 1.2s ease;
    }

    .waiter-overlay .screen-title-box {
      position: relative;
      width: 100vw;
      padding: 40px 0;
      border-radius: 0;
      background: rgba(10, 16, 28, 0.25);
      backdrop-filter: blur(10px);
      -webkit-backdrop-filter: blur(10px);
      border: none;
      box-shadow: 0 15px 50px rgba(0, 0, 0, 0.4);
      display: flex;
      flex-direction: column;
      align-items: center;
    }

    .waiter-overlay .screen-title {
      font-size: 80px;
      font-weight: 450;
      letter-spacing: 10px;
    }

    .waiter-overlay .screen-subtitle {
      margin-top: 10px;
      font-size: 32px;
      font-weight: 450;
      opacity: 0.9;
      letter-spacing: 4px;
    }

    .waiter-overlay .screen-subtitle2 {
      margin-top: 15px;
      font-size: 20px;
      font-weight: 100;
      opacity: 0.85;
      letter-spacing: 4px;
    }

    .waiter-overlay .screen-subtitle3 {
      margin-top: 15px;
      font-size: 16px;
      font-weight: 100;
      opacity: 0.85;
      letter-spacing: 4px;
    }

    .waiter-overlay .screen-spinner {
      margin: 30px auto 0;
      width: 60px;
      height: 60px;
      border: 5px solid rgba(255,255,255,0.2);
      border-top: 5px solid white;
      border-radius: 50%;
      animation: spin 1.1s linear infinite;
    }

    .screen-footer-right {
      font-family: 'Segoe UI', Ubuntu, system-ui;
      color: white;
      position: fixed;
      bottom: 12px;
      right: 16px;
      font-size: 16px;
      letter-spacing: 1px;
    }

    @keyframes spin {
      to { transform: rotate(360deg); }
    }

    @keyframes fadeIn {
      from { opacity: 0; transform: translateY(8px); }
      to   { opacity: 1; transform: translateY(0); }
    }

    .waiter-overlay .waiter-log {
      position: absolute;
      left: 50%;
      transform: translateX(-50%);
      font-family: 'Segoe UI', Ubuntu, system-ui;
      margin-top: 15px;
      font-size: 16px;
      font-weight: 300;
      letter-spacing: 2px;
      height: 50px;
      width: 400px;
      text-align: center;
      align-items: center;
    }
  "
  )
)

# spada_output_css ------------------------------------------------------------
spada_output_css <- tags$head(tags$style(HTML(
  paste(
    "
      body {
        font-family: 'Segoe UI', Ubuntu sans-serif;
      }

      h2 {
        font-size: 1.5rem !important;
        margin-bottom: 12px ! important;
        color: ", main_color, " !important;
        font-weight: 400 !important;
      }

      .toc-title { color: ", main_color, ";}

      .toc ul{
        list-style:none;
        padding-left:0;
        margin:0;
      }

      .toc li{
        margin-bottom:4px;
      }

      .toc a{
        display:block;
        padding:8px 12px;

        color:#444;
        text-decoration:none;

        border-radius:6px;

        transition:
          background-color .25s ease,
          color .25s ease,
          transform .25s ease,
          box-shadow .25s ease;
      }

      .toc a:hover{
        background:", main_color, ";
        color:white;

        transform:translateX(5px);

        box-shadow:0 2px 8px rgba(13,110,253,.25);
      }
    "
  )
)))

# ============================================================================.
# ---------------------------- FUNCTIONS -------------------------------------
# ============================================================================.
# short name ------------------------------------------------------------------
short_name <- function(name, max_size = 20){
  stopifnot(is.character(name))
  if(nchar(name) <= max_size) name else paste0(substr(name, 1, max_size - 3) , '...')
}
# spada_user_dir --------------------------------------------------------------
spada_user_dir <- function(which){
  dir <- normalizePath(R_user_dir('spada', which), winslash = '/', mustWork = F)

  check_dir(dir)

  return(dir)
}

# set theme -------------------------------------------------------------------
set_spada_theme <- function(session, theme){

  session$setCurrentTheme(spada_bs_theme(theme))
  session$userData$conf$theme <- theme
}

# load conf -------------------------------------------------------------------
load_conf <- function(start_conf,
                      r_user_conf_dir,
                      themes_names) {

  conf_path <- file.path(r_user_conf_dir, 'conf.qs2')

  if (file.exists(conf_path)) {
    conf_saved <- qs_read(conf_path)

    required_fields <- c(
      'theme',
      'file_size',
      'restore_session',
      'save_session',
      'plot_fill_color',
      'plot_line_color',
      'plot_title_color',
      'plot_limit'
    )

    # if all TRUE copy saved conf
    if (
      # test required items
      is.list(conf_saved) &&
        all(required_fields %in% names(conf_saved)) &&

      # test theme
      length(conf_saved$theme) == 1 &&
        isTRUE(conf_saved$theme %in% themes_names) &&

      # file size
      length(conf_saved$file_size) == 1 &&
        is.numeric(conf_saved$file_size) && conf_saved$file_size > 0 &&

      # restore session
      length(conf_saved$restore_session) == 1 &&
        isTRUE(conf_saved$restore_session %in% c('always', 'ask', 'never')) &&

      # save session
      length(conf_saved$save_session) == 1 &&
        isTRUE(conf_saved$save_session %in% c('always', 'ask', 'never')) &&

      # fill color
      length(conf_saved$plot_fill_color) == 1 &&
        isTRUE(is_hex_color(conf_saved$plot_fill_color)) &&

      # line color
      length(conf_saved$plot_line_color) == 1 &&
        isTRUE(is_hex_color(conf_saved$plot_line_color)) &&

      # title color
      length(conf_saved$plot_title_color) == 1 &&
        isTRUE(is_hex_color(conf_saved$plot_title_color)) &&

      # plot limit
      length(conf_saved$plot_limit) == 1 &&
        is.numeric(conf_saved$plot_limit)
      ){
      # copy if test is passed
      start_conf$theme <- conf_saved$theme
      start_conf$file_size <- conf_saved$file_size
      start_conf$restore_session <- conf_saved$restore_session
      start_conf$save_session <- conf_saved$save_session
      start_conf$plot_fill_color <- conf_saved$plot_fill_color
      start_conf$plot_line_color <- conf_saved$plot_line_color
      start_conf$plot_title_color <- conf_saved$plot_title_color
      start_conf$plot_limit <- conf_saved$plot_limit
    }
  }
  if(test_write_access(conf_path)) qs_save(start_conf, conf_path)

  return(start_conf)
}

# generate 2 column table in html ---------------------------------------------
gen_table2 <- function(element1, element2, w1 = '50%', w2 = '50%') {
  div(
    tags$table(
      style = 'width: 95%',
      tags$tr(
        tags$td(style = paste('padding: 10px; width:', w1, ';'), element1),
        tags$td(style = paste('padding: 10px; width:', w2, ';'), element2)
      )
    )
  )
}

# card to insert in output ----------------------------------------------------
report_card <- function(title = 'Spada - Output', annotation = NULL,
                        content = NULL){
  div(
      h2(title,
         style = paste0(
           " font-size: 1.5rem;",
           " margin-bottom: 12px;",
           " color:", main_color ,";",
           " text-align: center;"
           )
        ),
      p(annotation),
      content
  )
}

printable_report_card <- function(btns, card, id = NULL){
  div(
    style = paste0(
      "border: 2px solid", main_color, "; border-radius: 4px; ",
      "padding: 16px; margin-bottom: 8px; "
    ),
    div(style = "display: flex; width: 100%;",
        div(card, style = "width: 98%;"),
        tagList(
          lapply(btns,
               function(x){ div(x, style = 'width: 2%; text-align: right;') }
          )
        )
    ),
    br(),
    p(id)
  )
}

# output header ---------------------------------------------------------------
spada_output_info_card <- function(content){
  div(
    style = '
    padding: 20px 24px;

    background: linear-gradient(
      135deg,
      #003452 0%,
      #02517d 100%
    );

    border-radius: 4px;
    color: #ffffff;
    margin-bottom: 25px;
  ',
    content
  )
}

spada_output_header <- spada_output_info_card(
  div(
    style = 'display: flex; flex-direction: column;',
    tags$div(
      'Spada Output',
      style = ' font-size: 32px; font-weight: 450; letter-spacing: 4px;')
  )
)

spada_output_footer <- spada_output_info_card(
  div(
    style = '
      display: flex;
      justify-content: space-between;
      align-items: center;
      flex-wrap: wrap;
      gap: 15px;
    ',

    # left
    div(
      paste('Spada:', utils::packageVersion('spada')),
      tags$br(),

      tags$a(
        href = 'https://cran.r-project.org/package=spada',
        target = '_blank',
        style = 'color: white;',
        'CRAN'
      ),

      ' | ',

      tags$a(
        href = 'https://github.com/lgschuck/spada',
        target = '_blank',
        style = 'color: white;',
        'GitHub'
      ),

      ' | ',

      tags$a(
        href = 'https://lgschuck.github.io/spada/',
        target = '_blank',
        style = 'color: white;',
        'Documentation'
      ),

      ' | ',

      tags$a(
        href = 'https://lgschuck.github.io/spada_book/',
        target = '_blank',
        style = 'color: white;',
        'Book'
      )
    ),

    # right
    div(
      style = 'text-align: right;',
      format(Sys.time(), '%Y-%m-%d %H:%M:%S %Z')
    )
  )
)

spada_output <- function(output, header = spada_output_header, footer = spada_output_footer){
  toc <- tags$div(
    class = 'toc',
    style = '
    width:15vw;
    min-width:220px;
    height:100vh;
    padding:16px 16px 16px 24px;
    border-left:1px solid #ddd;
    box-sizing:border-box;
    overflow-y:auto;
    position:sticky;
    top:0;
  ',

    tags$h2(class = 'toc-title', 'Table of contents'),

    tags$ul(
      tagList(
        tags$li(tags$a(href = '#home', 'Home')),

        lapply(
          output,
          function(x) { tags$li(tags$a(href = paste0('#', x$id), x$title)) }
        )
      )
    )
  )

  cards <- tags$div(
    style = 'width:85vw; padding:24px; box-sizing:border-box;',

    lapply(
      output,
      function(x) {
        div(
          id = x$id,
          style = 'margin-bottom:32px;',
          printable_report_card(NULL, x$card, NULL)
        )

      }
    )
  )

  body_content <- tags$div(
    style = 'display:flex; align-items:flex-start;',
    cards,
    toc
  )

  tags$html(
    spada_output_css,
    tags$body(div(id = 'home', header), body_content, footer)
  )
}

# add output element ----------------------------------------------------------
add_output_element <- function(id, title, annotation, element, btn_xid, btn_eid){

  btn_x <- actionButton(btn_xid, '', icon('x'), class = 'micro-btn-cancel')
  btn_e <- actionButton(btn_eid, '', icon('pen-to-square'), class = 'micro-btn-cancel')

  list(
    'id' = id,
    'title' = title,
    'annotation' = annotation,
    'element' = element,
    'card' = report_card(title, annotation, element),
    'btn_x' = btn_x,
    'btn_e' = btn_e
  )
}

# register outputs events -----------------------------------------------------
register_output_events <- function(id, session, input, btn_xid, btn_eid) {
  observe({
    session$userData$out$elements[[id]] <- NULL
  }) |> bindEvent(input[[btn_xid]], once = TRUE)

  observe({
    session$userData$out_edit_trigger(id)
  }) |> bindEvent(input[[btn_eid]])
}

# generate output object ------------------------------------------------------
gen_output <- function(element = div(h2('Element'))){

  x <- sample(1e3, 1)
  title <- paste('Test title', x)
  annotation <- paste('Test annotation', x)
  id <- gen_element_id()
  btn_xid <- paste0('btn_xout_', id)
  btn_eid <- paste0('btn_eout_', id)

  element <- if(is.null(element)) data.frame(x = letters) |> gt() else element

  add_output_element(
    id,
    title,
    annotation,
    element,
    btn_xid,
    btn_eid
  )
}

# generate element id for outputs ---------------------------------------------
gen_element_id <- function(id = 'id', time_only = FALSE){
  if(time_only){
    gsub('.', '', format(Sys.time(), '%Y%m%d%H%M%OS8'), fixed = T)
  } else {
    paste0(id, '_', gsub('.', '', format(Sys.time(), '%Y%m%d%H%M%OS8'), fixed = T))
  }
}

# allowed operations function -------------------------------------------------
show_allowed_op <- function(){
  showModal(
    modalDialog(
      title = div(icon('check'), 'Allowed Operations'),
      selectInput(
        inputId = 'allowed_op_selected',
        label   = 'List of operations',
        choices = allowed_operations,
        selected = allowed_operations[1]
      ),
      easyClose = TRUE
    )
  )
}

# safe env function -----------------------------------------------------------
safe_env <- function(operations = NULL){

  e <- new.env(parent = emptyenv())

  lapply(operations, function(x) {
    assign(x, get(x), envir = e)
  })

  return(e)
}

# test dataset ----------------------------------------------------------------
test_dataset <- function(n_row = 1e3, n_col = 11){
  test_data <- data.table(
    integer_var = rep(sample(1:100, n_row, replace = T)),
    numeric_var = rnorm(n_row),
    char_var = rep(sample(letters, n_row, replace = T)),
    char_long_var = rep(paste(letters, collapse = ''), n_row),
    char_colors_var = rep(sample(colors(), n_row, replace = T)),
    date_var = Sys.Date() + rep(sample(-49:50, n_row, replace = T)),
    datetime_var =
      as.POSIXct(Sys.time()) + sample(0:(365 * 24 * 60 * 60), n_row, replace = TRUE),
    factor_var = as.factor(rep(sample(paste0('factor_', 1:10), n_row, replace = T))),
    num_nas_var = c(rep(NA, round(n_row/2)), rnorm(n_row - round(n_row/2))),
    int_nas_var = c(rep(NA, round(n_row/2)), sample(1:100, n_row - round(n_row/2), replace = T)),
    logical_var = rep(sample(c(TRUE, FALSE), n_row, replace = T)),
    all_na = rep(NA, n_row)
  )

  extra_cols <- n_col - ncol(test_data)

  if (extra_cols > 0) {
    for (i in seq_len(extra_cols)) {
      test_data[[paste0("extra_col_", i)]] <- rnorm(n_row)
    }
  }

  test_data
}

# empty plot function ---------------------------------------------------------
empty_plot <- function(msg = 'No plot', c = 2){
  plot(1:10, 1:10, type = 'n', xlab = '', ylab = '')
  text(5, 5, msg, cex = c)
}

# bslib btn task --------------------------------------------------------------
btn_task <- function(ID,
                     LABEL,
                     ICON = NULL,
                     LABEL_BUSY = 'Running...',
                     ...){
  input_task_button(
    id = ID,
    label = LABEL,
    icon = ICON,
    label_busy = LABEL_BUSY,
    class = 'btn-task',
    ...
  )
}

# mini_btn --------------------------------------------------------------------
mini_btn <- function(ID, LABEL, ICON){
  actionButton(
    inputId = ID,
    label = LABEL,
    icon = ICON,
    class = 'mini-btn'
  )
}

# messages - shownotification -------------------------------------------------
msg <- function(TEXT, DURATION = 2.3){
  show_toast(
    title = TEXT,
    type = 'info',
    position = 'center',
    timer = DURATION * 1000,
    timerProgressBar = F,
    width = '650px'
  )
}

msg_error <- function(TEXT, DURATION = 2.3){
  show_toast(
    title = TEXT,
    type = 'error',
    position = 'center',
    timer = DURATION * 1000,
    timerProgressBar = F,
    width = '650px'
  )
}

bmsg <- function(TEXT, DURATION = 2.3){
  bslib::show_toast(

    bslib::toast(
      TEXT,
      header = bslib::toast_header(
        title = TEXT,
        status = "Spada"
      ),
      type = NULL,
      duration_s = DURATION,
      position = c('middle', 'center')
    )
  )
}

# try convert -----------------------------------------------------------------
try_convert <- function(x, fun){
  tryCatch(fun(x),
           error = function(e) rep(NA, x |> length()),
           warning = function(w) rep(NA, x |> length()))
}

# convert function ------------------------------------------------------------
convert <- function(x, type, date_format = '%Y-%m-%d',
                    date_origin = '1970-01-01'){
  if(x |> is.raw()) x <- as.numeric(x)

  if(type == 'as.numeric'){
    suppressWarnings(as.numeric(x))
  } else if(type == 'as.integer'){
    suppressWarnings(as.integer(x))
  } else if(type == 'as.character'){
    as.character(x)
  } else if(type == 'as.Date'){
    if(x |> inherits('Date')) {
      x
    } else if(is.numeric(x)){
      as.Date(x, origin = date_origin)
    } else if(is.raw(x) || is.complex(x)){
      suppressWarnings(
        as.Date(x |> as.numeric(), origin = date_origin)
      )
    } else as.Date(x, format = date_format)
  } else if(type == 'as.factor'){
    as.factor(x)
  } else if(type == 'as.double'){
    suppressWarnings(as.double(x))
  } else if(type == 'as.complex'){
    if(is.complex(x)){
      x
    } else {
      x1 <- suppressWarnings(as.numeric(x))
      as.complex(x1)
    }
  }
}

# filter rows function --------------------------------------------------------
filter_rows <- function(dt, var, operator, filter_value){

  stopifnot(is.data.table(dt))

  if(operator == '=='){
    dt[var1 == filter_value, , env = list(var1 = var)]
  } else if(operator == '!='){
    dt[var1 != filter_value, , env = list(var1 = var)]
  } else if(operator == '>'){
    dt[var1 > filter_value, , env = list(var1 = var) ]
  } else if(operator == '>='){
    dt[var1 >= filter_value, , env = list(var1 = var) ]
  } else if(operator == '<'){
    dt[var1 < filter_value, , env = list(var1 = var) ]
  } else if(operator == '<='){
    dt[var1 <= filter_value, , env = list(var1 = var) ]
  } else if(operator == 'is_na'){
    dt[is.na(var1), , env = list(var1 = var) ]
  } else if(operator == 'not_na'){
    dt[!is.na(var1), , env = list(var1 = var) ]
  } else if(operator == 'in'){
    dt[var1 %in% filter_value,  , env = list(var1 = var)]
  } else if(operator == 'not_in'){
    dt[!var1 %in% filter_value, , env = list(var1 = var) ]
  } else if(operator == 'between'){
    dt[var1 %between% filter_value, , env = list(var1 = var) ]
  } else if(operator == 'not_between'){
    dt[!(var1 %between% filter_value), , env = list(var1 = var) ]
  } else if(operator == 'outlier'){
    dt[Outlier(var1, value = F, na.rm = T), , env = list(var1 = var)]
  } else if(operator == 'not_outlier'){
    dt[!Outlier(var1, value = F, na.rm = T), , env = list(var1 = var)]
  } else if(operator == 'is_true'){
    dt[var1 == TRUE,  , env = list(var1 = var)]
  } else if(operator == 'is_false'){
    dt[var1 == FALSE,  , env = list(var1 = var)]
  }
}

# filter rows 2 vars ----------------------------------------------------------
filter_rows_2vars <- function(dt, var1, var2, operator){

  stopifnot(is.data.table(dt))

  v1 <- dt[[var1]]
  v2 <- dt[[var2]]

  # Convert to char if factor
  if (is.factor(v1) && is.factor(v2)) {
    v1 <- as.character(v1)
    v2 <- as.character(v2)
  }

  if(operator == '=='){
    dt[v1 == v2, ]
  } else if(operator == '!='){
    dt[v1 != v2, ]
  } else if(operator == '>'){
    dt[v1 > v2, ]
  } else if(operator == '>='){
    dt[v1 >= v2, ]
  } else if(operator == '<'){
    dt[v1 < v2, ]
  } else if(operator == '<='){
    dt[v1 <= v2, ]
  } else {
    stop('Invalid Operator')
  }
}

# tip place top by default ----------------------------------------------------
ttip <- function(TRIGGER, ..., ID = NULL, PLACE = 'top'){
  tooltip(trigger = TRIGGER, ... = ..., id = ID, placement = PLACE)
}

# get function help -----------------------------------------------------------
get_help_file <- function(pak, fun){
  paste(
    utils::capture.output(
      tools::Rd2HTML(tools::Rd_db(pak)[[paste0(fun, '.Rd')]])
    ),
    collapse = '\n'
  )
}

# fun help modal --------------------------------------------------------------
fun_help_modal <- function(pak, fun) {
  showModal(modalDialog(
    HTML(get_help_file(pak, fun)),
    title = div(icon('circle-question'), paste('Help:', pak, '-', fun)),
    easyClose = TRUE,
    size = 'xl'
  ))
}

# format decimals -------------------------------------------------------------
f_dec <- function(x, dig = 0){
  if(is.numeric(x) && !is.na(x) |> all()){
    format(round(x, dig), nsmall = dig, scientific = F)
  } else {
    NA
  }
}

# make var names --------------------------------------------------------------
make_var_names <- function(df){
  stopifnot(df |> is.data.frame())
  names(df) <- names(df) |> make.names(unique = T)
  return(df)
}

# test all equal --------------------------------------------------------------
test_all_equal <- function(x){
  all(x == x[1])
}

# obj type --------------------------------------------------------------------
obj_type <- function(x){
  if(x |> is.numeric()) 'numeric'
  else if (x |> is_date()) 'date'
  else if (x |> is.factor()) 'factor'
  else if (x |> is.character()) 'char'
  else if (x |> is.logical()) 'logical'
  else if (x |> is.complex()) 'complex'
  else 'other'
}

# stati_card ------------------------------------------------------------------
stati_card <- function(VALUE, SUBTITLE, ICON = NULL, LEFT = T,
                       COLOR = '#FFFFFF', BACKGROUND = main_color,
                       ANIMATE = T, DURATION = 30, ID = NULL){
  statiCard(value = VALUE,
            subtitle = SUBTITLE,
            icon = ICON,
            left = LEFT,
            color = COLOR,
            background = BACKGROUND,
            animate = ANIMATE,
            duration = DURATION,
            id = ID)
}

# make valid cols -------------------------------------------------------------
make_valid_cols <- function(x){
  if(is.raw(x) || is.complex(x)){
    as.character(x)
  } else {
    x
  }
}

# is spada data frame ---------------------------------------------------------
is_spada_df <- function(df){
  is.data.frame(df) && all(sapply(df, is.atomic)) && ncol(df) > 0 && nrow(df) > 0
}

# is spada data table ---------------------------------------------------------
is_spada_dt <- function(dt){
  is.data.table(dt) && is_spada_df(dt)
}

# test data format-------------------------------------------------------------
test_data_format <- function(data){
  is.list(data) &&
    length(data) > 0 &&
    (sapply(data, is_spada_df) |> all())
}


# running modal ---------------------------------------------------------------
running_modal <- function(text = 'Running...'){
  showModal(
    modalDialog(
      div(
        icon('spinner', class='fa fa-spinner fa-spin fa-1x'),
        span(text, style = 'color:#585c5e;')
      ),
      footer = NULL,
      easyClose = FALSE,
      size = 'm',
      fade = T
    )
  )
}

remove_running_modal <- function(time = 0.7){
  Sys.sleep(time)
  removeModal()
}

# not spada df modal ----------------------------------------------------------
abort_filter_modal <- function(){
  showModal(modalDialog(
    'The resultant dataset must be valid (nrow and ncol > 0)',
    title = div(icon('triangle-exclamation'), 'Operation Aborted')
  ))
}

# abort save session/output ---------------------------------------------------
abort_run_local_modal <- function(msg = 'Spada must run locally'){
  showModal(modalDialog(
    msg,
    title = div(icon('triangle-exclamation'), 'Operation Aborted'),
    easyClose = T
  ))
}

# show startup function -------------------------------------------------------
show_startup_screen <- function() {
  waiterShowOnLoad(html = tagList(
    div(
      class = 'screen-container',
      div(
        class = 'screen-title-box',
        div('Spada', class = 'screen-title'),
        div('a Shiny Package for Data Analysis', class = 'screen-subtitle2')
      ),
      waiter_spinner,
      div(id = 'spada_startup_text', class = 'waiter-log', 'Building UI')
    ),
    waiter_right_foot
  ))
}

# exit screen function --------------------------------------------------------
show_exit_screen <- function(save = TRUE) {
  waiter_show(
    html = {
      if(save){
        tagList(
          div(
            class = 'screen-container',
            div(class = 'screen-title-box',
            div('Spada is saving your work', class = 'screen-subtitle'),
            div('Please do not close this window', class = 'screen-subtitle2')
            ),
            waiter_spinner,
            div(id = 'spada_exit_text', class = 'waiter-log', '')
          ),
          waiter_right_foot
        )
      } else {
        html = tagList(
          div(
            class = 'screen-container',
            div(class = 'screen-title-box',
              div('Closing Spada', class = 'screen-subtitle')
            ),
            waiter_spinner,
            div(id = 'spada_exit_text', class = 'waiter-log', 'Saving conf')
          ),
          waiter_right_foot
        )
      }
    }
  )
}

# update startup text ---------------------------------------------------------
update_waiter_text <- function(session, id, text) {
  session$sendCustomMessage('update-text', list(id = id, text = text))
}

# update start up text-----------------------------------------------------------
waiter_text <- "
  Shiny.addCustomMessageHandler(
    'update-text',
    function(data){

      const el = document.getElementById(data.id);

      if(el){
        const line = document.createElement('div');

        line.innerText = data.text;

        el.appendChild(line);
      }
    }
  )
"

tag_js_waiter_text <- tags$head(tags$script(HTML(waiter_text)))

# spada save function ---------------------------------------------------------
spada_save <- function(dir, object, file_name){
  out_file <- file.path(dir, file_name)

  check_dir(dir)

  try_save <- try(qs_save(object, out_file), silent = T)

  if(inherits(try_save, 'try-error')){
    tmp_file <- temp_file(file_name)
    qs_save(object, tmp_file)
    no_write_msg(out_file, tmp_file)
  }
}

# exit spada with saving session ----------------------------------------------
exit_with_save <- function(session){

  show_exit_screen()
  update_waiter_text(session, 'spada_exit_text', 'Saving data')
  spada_save(session$userData$conf$data_dir,
             session$userData$dt$dt,
             'data.qs2')
  Sys.sleep(0.3)
  update_waiter_text(session, 'spada_exit_text', 'Saving output')
  spada_save(session$userData$conf$data_dir,
             session$userData$out$elements,
             'output.qs2')
  Sys.sleep(0.4)
  update_waiter_text(session, 'spada_exit_text', 'Saving conf')
  spada_save(session$userData$conf$conf_dir,
             reactiveValuesToList(session$userData$conf),
             'conf.qs2')
  Sys.sleep(1)
  session$sendCustomMessage(type = 'closeWindow', message = 'message')
  if(session$userData$run_local) stopApp()
}

# exit spada without saving session -------------------------------------------
exit_without_save <- function(session){

  show_exit_screen(F)

  spada_save(session$userData$conf$conf_dir,
             reactiveValuesToList(session$userData$conf),
             'conf.qs2')

  Sys.sleep(3)
  session$sendCustomMessage(type = 'closeWindow', message = 'message')
  if(session$userData$run_local) stopApp()
}

# test write access -----------------------------------------------------------
test_write_access <- function(file){
  all(!file.exists(file) || isTRUE(file.access(file, 2) == 0))
}

# temp normalized file path ---------------------------------------------------
temp_file <- function(file_name = ''){
  file.path(normalizePath(tempdir(), winslash = '/'), file_name)
}

# no access to write message --------------------------------------------------
no_write_msg <- function(file1, file2){
  message(paste(
    Sys.time(),
    '- Spada could not write on:\n',
    file1,
    '\n Data saved in',
    file2
    )
  )
}

# make names append lists -----------------------------------------------------
make_names_append_list <- function(new_list, actual_names,
                                   suffix = '_previous', index = 1) {

    names(new_list) <- make.names(names(new_list), unique = TRUE)

    while (any(grepl(paste0("^.*", suffix, "$"), actual_names))) {
      suffix <- paste0(suffix, "_", i)
      index <- index + 1
    }

    conflict_names <- names(new_list) %in% actual_names
    names(new_list)[conflict_names] <- paste0(names(new_list)[conflict_names], suffix)

    return(new_list)
}

# plot z test -----------------------------------------------------------------
plot_z_test <- function(confidence = 0.95, test_type = 'two.sided',
                        z_value = qnorm(confidence),
                        color_fill = 'brown3', color_line = 'steelblue') {
  # Define the standardized x-axis (Z-scores)
  x <- seq(-4, 4, length.out = 1000)  # Standardized Z-values
  y <- dnorm(x, mean = 0, sd = 1)  # Standard normal distribution

  alpha <- 1 - confidence

  # Determine critical values in standardized scale
  if (test_type == 'two.sided') {
    z_critical <- qnorm(1 - alpha / 2)
    critical_left <- -z_critical
    critical_right <- z_critical
  } else if (test_type == 'greater') {
    critical_right <- qnorm(1 - alpha)
  } else if (test_type == 'less') {
    critical_left <- qnorm(alpha)
  } else {
    stop("Invalid 'test_type'. Use 'two.sided', 'greater', or 'less'.")
  }

  # Create the plot
  plot(x, y, type = 'l', lwd = 2, col = color_line,
       xlab = 'Standardized Values (Z)', ylab = 'Density',
       main = paste('Z Test\n Type:', test_type, '- Conf.',
                    confidence * 100, '% | Z value:', z_value |> f_num(dig = 3)))

  # Highlight the critical regions
  if (test_type == 'two.sided') {
    polygon(c(x[x <= critical_left], critical_left),
            c(y[x <= critical_left], 0), col = color_fill, border = NA)
    polygon(c(x[x >= critical_right], critical_right),
            c(y[x >= critical_right], 0), col = color_fill, border = NA)

  } else if (test_type == 'less') {
    polygon(c(x[x <= critical_left], critical_left),
            c(y[x <= critical_left], 0), col = color_fill, border = NA)

  } else if (test_type == 'greater') {
    polygon(c(x[x >= critical_right], critical_right),
            c(y[x >= critical_right], 0), col = color_fill, border = NA)
  }

  if(abs(z_value) <= 4){
    abline(v = z_value, col = 'black', lwd = 2, lty = 2)
  }

}

# plot t test -----------------------------------------------------------------
plot_t_test <- function(confidence = 0.95, test_type = 'two.sided',
                        df = 10, t_value = qt(confidence, df = 10),
                        color_fill = 'brown3', color_line = 'steelblue') {
    x <- seq(-4, 4, length.out = 1000)
  y <- dt(x, df = df)

  alpha <- 1 - confidence

  # Determine critical values in standardized scale
  if (test_type == 'two.sided') {
    t_critical <- qt(1 - alpha / 2, df = df)
    critical_left <- -t_critical
    critical_right <- t_critical
  } else if (test_type == 'greater') {
    critical_right <- qt(1 - alpha, df = df)
  } else if (test_type == 'less') {
    critical_left <- qt(alpha, df = df)
  } else {
    stop("Invalid 'test_type'. Use 'two.sided', 'greater', or 'less'.")
  }

  # Create the plot
  plot(x, y, type = 'l', lwd = 2, col = color_line,
       xlab = 't-value', ylab = 'Density',
       main = paste(
         'One-sample t Test\n',
         'Type:', test_type,
         '- Conf.', confidence * 100,
         '% | t value =', t_value |> f_num(dig = 3),
        '(df =', df |> f_int(), ')'
       )
  )

  # Highlight the critical regions
  if (test_type == 'two.sided') {
    polygon(c(x[x <= critical_left], critical_left),
            c(y[x <= critical_left], 0), col = color_fill, border = NA)
    polygon(c(x[x >= critical_right], critical_right),
            c(y[x >= critical_right], 0), col = color_fill, border = NA)

  } else if (test_type == 'less') {
    polygon(c(x[x <= critical_left], critical_left),
            c(y[x <= critical_left], 0), col = color_fill, border = NA)

  } else if (test_type == 'greater') {
    polygon(c(x[x >= critical_right], critical_right),
            c(y[x >= critical_right], 0), col = color_fill, border = NA)
  }

  if(abs(t_value) <= 4){
    abline(v = t_value, col = 'black', lwd = 2, lty = 2)
  }

}

# test if is hex color --------------------------------------------------------
is_hex_color <- function(x) {
  grepl("^#[A-Fa-f0-9]{6}$", x)
}

# test output format-----------------------------------------------------------
test_output_format <- function(output){

  # if list of len 0 is OK
  (is.list(output) && length(output) == 0) ||

    # if len > 0 must pass
    (is.list(output) && length(output) > 0 &&

       # all inside elements must be lists
       all(sapply(output, class) == 'list') &&

       # all names of inside lists must match
       all(
         sapply(output, \(x) {
           all(names(x) %in% c('id', 'title', 'annotation', 'element', 'card', 'btn_x', 'btn_e'))
         })
       ) &&
       # test class of each element in the inside lists
       (
         all(sapply(output, \(x){ 'character' %in% class(x$id)})) &&
           all(sapply(output, \(x){ 'character' %in% class(x$title) })) &&
           all(sapply(output, \(x){ 'character' %in% class(x$annotation) })) &&
           all(sapply(output, \(x){ any(c('gt_tbl', 'html', 'shiny.tag') %in% class(x$element)) })) &&
           all(sapply(output, \(x){ 'shiny.tag' %in% class(x$card) })) &&
           all(sapply(output, \(x){ 'shiny.tag' %in% class(x$btn_x) })) &&
           all(sapply(output, \(x){ 'shiny.tag' %in% class(x$btn_e) }))
       )
    )
}

# check existence of directory ------------------------------------------------
check_dir <- function(dir){
  if(!dir.exists(dir)) dir.create(dir, recursive = T)
}

# linear model df output ------------------------------------------------------
linear_model_df_output <- function(model_summary){
  stopifnot(model_summary |> class() == 'summary.lm')

  table_summary <- as.data.frame(model_summary$coefficients)

  table_summary$Variable <- rownames(table_summary)
  rownames(table_summary) <- NULL

  table_summary <- table_summary[, c("Variable", "Estimate", "Std. Error",
                                     "t value", "Pr(>|t|)")]

  table_summary <- table_summary |> as.data.table()
  table_summary[, `Sig Levels` := fcase(
    `Pr(>|t|)` < 0.001, '***',
    `Pr(>|t|)` < 0.01, '**',
    `Pr(>|t|)` < 0.05, '*',
    `Pr(>|t|)` < 0.1, '.',
    default = ''
  )]
}

# linear model gt metrics -----------------------------------------------------
linear_model_df_metrics <- function(model_summary){
  stopifnot(model_summary |> class() == 'summary.lm')

  f <- model_summary$fstatistic
  f_p_value <- pf(f['value'], f['numdf'], f['dendf'], lower.tail = FALSE)
  data.frame(
    Metric = c('Residual Std Error', 'R-squared', 'Adjusted R-squared',
               'F-statistic', 'F p-value'),
    Value = c(
      model_summary$sigma,
      model_summary$r.squared,
      model_summary$adj.r.squared,
      model_summary$fstatistic[1],
      f_p_value
    )
  )
}

# get active dt ---------------------------------------------------------------
get_act_dt <- function(session){
  session$userData$dt$dt[[ session$userData$dt$act_name ]]
}

# update active dt ------------------------------------------------------------
update_act_dt <- function(session, new_dt, data_changed = TRUE,
                          updated_cols = NULL,
                          change_type = c('new_data',
                                          'convert_cols',
                                          'rename_cols',
                                          'order_cols',
                                          'select_cols')){

  stopifnot(new_dt |> is.data.table())

  change_type <- match.arg(change_type)

  new_dt <- lapply(new_dt, make_valid_cols) |> as.data.table()

  session$userData$dt$dt[[ session$userData$dt$act_name ]] <- new_dt

  if(data_changed) {

    session$userData$dt$updated_cols <- updated_cols
    session$userData$dt$data_changed_type <- change_type
    session$userData$data_changed(session$userData$data_changed() + 1)
  }
}

# append dt -------------------------------------------------------------------
append_dt <- function(session, new_dt, new_dt_name) {

  stopifnot(new_dt |> is.data.frame())
  stopifnot(new_dt_name |> is_valid_name() &&
              new_dt_name %notin% names(session$userData$dt$dt))

  new_dt <- lapply(new_dt, make_valid_cols) |> as.data.table() |> make_var_names()

  new_list <- list(new_dt)
  names(new_list) <- new_dt_name

  session$userData$dt$dt <- c(session$userData$dt$dt, new_list)
}

# append meta data ------------------------------------------------------------
append_meta <- function(session, new_meta, new_dt_name){
  stopifnot(new_meta |> is.data.frame())

  meta_list <- list(new_meta)
  names(meta_list) <- new_dt_name

  session$userData$dt$meta <- c(
    session$userData$dt$meta,
    meta_list
  )
}

# update meta data ------------------------------------------------------------
update_meta <- function(dt = data.table(),
                        previous_meta, col_names, updated_cols, ncols,
                        change_type = c('new_data',
                                        'convert_cols',
                                        'rename_cols',
                                        'order_cols',
                                        'select_cols')){

  stopifnot(dt |> is.data.table())
  stopifnot(previous_meta |> is.data.table())

  change_type <- match.arg(change_type)

  if(change_type %in% c('new_data', 'convert_cols')){
    new_meta <- dt |> df_info()

    # delete updated vars from previous meta
    previous_meta <- previous_meta[var %notin% updated_cols, ]

    new_meta <- rbindlist(list(previous_meta, new_meta), fill = T)

    order_df <- data.table(var = col_names, index = 1:length(col_names))

    new_meta <- merge(new_meta, order_df, by = 'var', all.x = TRUE)

    setorderv(new_meta, c('index'))

    new_meta$index <- NULL
    new_meta$cols <- ncols

    return(new_meta)
  } else if (change_type == 'rename_cols'){
    previous_meta$var <- col_names
    return(previous_meta)
  } else if (change_type == 'order_cols'){

    order_df <- data.table(var = col_names, index = 1:length(col_names))

    meta_reordered <- merge(previous_meta, order_df, by = 'var', all.x = TRUE)

    setorderv(meta_reordered, c('index'))

    meta_reordered$index <- NULL

    return(meta_reordered)

  } else if (change_type == 'select_cols'){
    previous_meta <- previous_meta[var %in% col_names, ]

    previous_meta$cols <- ncols
    return(previous_meta)
  }
}

# descriptive stats -----------------------------------------------------------
desc_stats <- function(df = NULL,
                       fmt_digits = 9,
                       central_tendency = c('mean', 'gmean', 'hmean', 'median', 'mode'),
                       dispersion = c('min', 'max', 'IQR', 'range', 'var', 'sd'),
                       shape = c('skew', 'kurt')) {

  desc_stats <- list()

  # central tendency
  if('mean' %in% central_tendency){
    desc_stats$Mean <- sapply(
      df,
      \(x) {if(x |> is.numeric()) mean_nona(x) |> f_num(dig = fmt_digits) else NA })
  }

  if('gmean' %in% central_tendency){
    desc_stats$Gmean <- sapply(
      df,
      \(x) {if(x |> is.numeric()) suppressWarnings(Gmean(x, na.rm = T)) |> f_num(dig = fmt_digits) else NA })
  }

  if('hmean' %in% central_tendency){
    desc_stats$Hmean <- sapply(
      df,
      \(x) {if(x |> is.numeric()) Hmean(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
  }

  if('median' %in% central_tendency){
    desc_stats$Median <- sapply(
      df,
      \(x) {if(x |> is.numeric()) fmedian(x, na.rm = T) |> f_num(dig = fmt_digits)  else NA })
  }

  if('mode' %in% central_tendency){
    desc_stats$Mode <- sapply(
      df,
      \(x) {if(x |> is.numeric() ||
               x |> is.character() ||
               x |> is.factor()){
        x_mode <- fmode(x, na.rm = T) |> f_num(dig = fmt_digits)
        if(is.na(x_mode) |> all()) NA else paste(x_mode, collapse = ' | ')
      } else { NA }
      })
  }

  # dispersion
  if('min' %in% dispersion){
    desc_stats$Min <- sapply(
      df,
      \(x) {if(x |> is.numeric()) min_nona(x) |> f_num(dig = fmt_digits) else NA })
  }

  if('max' %in% dispersion){
    desc_stats$Max <- sapply(
      df,
      \(x) {if(x |> is.numeric()) max_nona(x) |> f_num(dig = fmt_digits) else NA })
  }

  if('IQR' %in% dispersion){
    desc_stats$IQR <- sapply(
      df,
      \(x) {if(x |> is.numeric()) IQR(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
  }

  if('range' %in% dispersion){
    desc_stats$Range <- sapply(
      df,
      \(x) {
        if(x |> is.numeric()){
          paste('[', frange(x, na.rm = T) |> f_num(dig = fmt_digits) , ']', collapse = '--->')
        } else { NA }
      }
    )
  }

  if('var' %in% dispersion){
    desc_stats$Variance <- sapply(
      df,
      \(x) {if(x |> is.numeric()) fvar(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
  }

  if('sd' %in% dispersion){
    desc_stats[['Standard Deviation']] <- sapply(
      df,
      \(x) {if(x |> is.numeric()) fsd(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
  }

  if('skew' %in% shape){
    desc_stats[['Skewness']] <- sapply(
      df,
      \(x) {if(x |> is.numeric()) Skew(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
  }

  if('kurt' %in% shape){
    desc_stats[['Kurtosis']] <- sapply(
      df,
      \(x) {if(x |> is.numeric()) Kurt(x, na.rm = T) |> f_num(dig = fmt_digits) else NA })
  }

  desc_stats
}

# plots -----------------------------------------------------------------------
spada_plot <- function(
    type = 'hist',
    df = NULL,
    xvar = NULL,
    yvar = NULL,
    zvar = NULL,
    xlab = '',
    ylab = '',
    fill_color = '#0099F8',
    line_color = '#000000',
    title_color = '#02517d',
    title = NULL,
    bins = 25,
    vertical_line = NULL,
    point_shape = '.',
    line_type = 1,
    mean_value = NULL,
    sd_value = NULL,
    sample_limit = 1e5,
    na_rm = TRUE
  ){

  if(nrow(df) > sample_limit){
    df <- df[sample.int(nrow(df), sample_limit), , drop = FALSE]
  }

  stopifnot(is.data.frame(df))

  if(type == 'hist'){

    ggplot(data = df, aes(x = .data[[xvar]])) +
      geom_histogram(
        bins = bins,
        fill = fill_color,
        color = '#000000',
        na.rm = na_rm
      ) +
      geom_vline(xintercept = vertical_line, color = line_color, linetype = line_type) +
      labs(title = title, x = xlab, y = ylab) +
      theme_classic() +
      theme(axis.text.x = element_text(size = 14),
            axis.text.y = element_text(size = 14),
            axis.title.y = element_text(size = 16),
            plot.title = element_text(color = title_color, size = 16, face = 'bold')
      )
  } else if (type == 'hist_density'){

    ggplot(data = df, aes(x = .data[[xvar]])) +
      geom_histogram(aes(y = after_stat(density)),
                     bins = bins,
                     fill = fill_color,
                     color = 'black',
                     na.rm = na_rm) +
      stat_function(fun = dnorm,
                    args = list(mean = mean_value,
                                sd = sd_value),
                    color = line_color,
                    linewidth = 1) +
      labs(title = title, x = xlab, y = ylab) +
      theme_classic() +
      theme(axis.text.x = element_text(size = 14),
            axis.text.y = element_text(size = 14),
            axis.title.x = element_text(size = 16),
            axis.title.y = element_text(size = 16),
            plot.title = element_text(color = title_color, size = 16, face = 'bold')
      )

  } else if (type == 'boxplot'){

    ggplot(data = df, aes(x = .data[[xvar]])) +
      stat_boxplot(geom = 'errorbar', width = 0.3, na.rm = na_rm) +
      geom_boxplot(fill = fill_color, na.rm = na_rm) +
      ylim(-1.2, 1.2) +
      geom_vline(xintercept = vertical_line, color = line_color, linetype = line_type) +
      labs(title = title, x = xlab, y = ylab) +
      theme_classic() +
      theme(
        axis.ticks.y = element_blank(),
        axis.text.y  = element_blank(),
        axis.line.y  = element_blank(),
        panel.border = element_rect(color = '#000000', fill = NA),
        axis.text.x = element_text(size = 14),
        plot.title = element_text(color = title_color, size = 16, face = 'bold')
      )
  } else if(type == 'dots'){

    ggplot(data = df, aes(x = .data[[xvar]], y = .data[[yvar]])) +
      geom_point(shape = point_shape, color = fill_color, na.rm = na_rm) +
      geom_hline(yintercept = vertical_line, color = line_color, linetype = line_type) +
      labs(title = title, x = xlab, y = ylab) +
      theme_classic() +
      theme(axis.text.x = element_text(size = 14),
            axis.text.y = element_text(size = 14),
            axis.title.x = element_text(size = 16),
            axis.title.y = element_text(size = 16),
            plot.title = element_text(color = title_color, size = 16, face = 'bold')
      )
  } else if (type == 'barplot'){

    ggplot(data = df, aes(x = factor(.data[[xvar]]))) +
      geom_bar(fill = fill_color, na.rm = na_rm) +
      labs(title = title, x = xlab, y = ylab) +
      theme_classic() +
      theme(axis.text.x = element_text(size = 14),
            axis.text.y = element_text(size = 14),
            axis.title.y = element_text(size = 16),
            plot.title = element_text(color = title_color, size = 16, face = 'bold')
      )

  } else if (type == 'boxplot_group'){

    ggplot(data = df, aes(x = .data[[xvar]], y = .data[[yvar]], fill = .data[[xvar]])) +
      stat_boxplot(geom = 'errorbar', width = 0.3, na.rm = na_rm) +
      geom_boxplot(orientation = 'x', na.rm = na_rm) +
      geom_hline(yintercept = vertical_line,
                 color = line_color) +
      coord_flip() +
      labs(title = title, x = xlab, y = ylab) +
      theme_classic() +
      theme(
        legend.position = 'none',
        axis.ticks.y = element_blank(),
        axis.line.y  = element_blank(),
        panel.border = element_rect(color = 'black', fill = NA),
        axis.text.x = element_text(size = 14),
        axis.text.y = element_text(size = 14),
        plot.title = element_text(color = title_color, size = 16, face = 'bold')
      )
  } else if (type == 'scatter'){

    ggplot(data = df, aes(x = .data[[xvar]], y = .data[[yvar]])) +
      geom_point(color = fill_color, shape = point_shape, na.rm = na_rm) +
      labs(title = title, x = xlab, y = ylab) +
      theme_classic() +
      theme(axis.text.x = element_text(size = 14),
            axis.text.y = element_text(size = 14),
            axis.title.x = element_text(size = 16),
            axis.title.y = element_text(size = 16),
            plot.title = element_text(color = title_color, size = 16, face = 'bold')
      )
  } else if (type == 'qq_plot'){
    ggplot(data = df, aes(sample = .data[[xvar]])) +
      stat_qq(color = fill_color, na.rm = na_rm) +
      stat_qq_line(color = line_color, na.rm = na_rm) +
      labs(title = title, x = xlab, y = ylab) +
      theme_classic() +
      theme(axis.text.x = element_text(size = 14),
            axis.text.y = element_text(size = 14),
            axis.title.x = element_text(size = 16),
            axis.title.y = element_text(size = 16),
            plot.title = element_text(color = title_color, size = 16, face = 'bold')
      )
  }
}

# plotTag with attributes -----------------------------------------------------
plot_tag <- function(plot, w = 900, h = 300){
  plotTag(
    plot,
    '',
    width = w,
    height = h,
    suppressSize = 'xy',
    attribs = list(style = 'max-width:90%; height:auto;')
  )
}

# status row for restore session ----------------------------------------------
status_row <- function(icon_name, color, text) {
  div(
    style = paste0(
      'display:flex; align-items:center; gap:12px;
       padding:12px 16px;
       border-radius:2px;
       background-color:', color, '15;'
    ),
    icon(icon_name, style = paste0('font-size:20px; color:', color)),
    tags$span(text, style = 'font-size:20px; font-weight:400;')
  )
}

# display restore status ------------------------------------------------------

display_restore_status <- function(session_restore_status, btn_ok){
  list_check_restore <- div(
    style = 'display:flex; flex-direction:column; gap:12px;',

    switch(
      substr(session_restore_status, 1, 1),
      '1' = status_row('check', '#2e7d32', 'Data restored successfully'),
      '2' = status_row('times', '#c62828', 'Data not found'),
      '3' = status_row('circle-question', '#ed6c02', 'Data in invalid format')
    ),

    switch(
      substr(session_restore_status, 3, 3),
      '1' = status_row('check', '#2e7d32', 'Output restored successfully'),
      '2' = status_row('times', '#c62828', 'Output not found'),
      '3' = status_row('circle-question', '#ed6c02', 'Output in invalid format')
    )
  )

  # show modal
  showModal(modalDialog(
    title = div(h2(
      bs_icon('database-up', size = '40px',
              style = 'margin-right: 8px; color:#FFFFFF'),
      'Session Status'
    )),
    div(style = 'padding:12px; border-radius:0px;', list_check_restore),
    size = 'l',
    easyClose = T,
    footer = div(style = 'text-align:right;', btn_ok)

  ))
}

# summarise dataset -----------------------------------------------------------
summarise_dt <- function(dt, fun = c('count', 'distinct'), vars){

  stopifnot(is.data.table(dt))
  stopifnot(all(vars %in% (dt |> names())))

  fun <- match.arg(fun)
  if(fun == 'distinct'){
    dt[, .SD, .SDcols = vars] |> unique()
  } else if(fun == 'count'){
    dt[, .N, by = vars]
  }
}

# build calls -----------------------------------------------------------------
build_calls <- function(new, funs, vars){

  vars_as_symbols <- lapply(vars, as.name)

  calls <- Map(
    \(v, f) call(f, v),
    vars_as_symbols,
    funs
  )

  as.call(c(as.name('.'), setNames(calls, new)))
}

# dt join ---------------------------------------------------------------------
dt_join <- function(dt1, dt2, vars1, vars2,
                     join_type = c('left', 'right', 'full', 'inner')){

  stopifnot(is_spada_dt(dt1))
  stopifnot(is_spada_dt(dt2))
  stopifnot(length(vars1) > 0)
  stopifnot(length(vars2) > 0)

  join_type <- match.arg(join_type)

  types_x <- sapply(dt1[, .SD, .SDcols = vars1], obj_type)
  types_y <- sapply(dt2[, .SD, .SDcols = vars2], obj_type)

  stopifnot('The variables types must match' = all(types_x == types_y))

  temp <- merge(
    dt1,
    dt2,
    by.x = vars1,
    by.y = vars2,
    all = join_type == 'full',
    all.x = any(c('left', 'full') %in% join_type),
    all.y = any(c('right', 'full') %in% join_type),
    allow.cartesian = T,
    suffixes = c('_x', '_y')
  )
  return(temp)
}


# math and other functions ----------------------------------------------------

df_info <- function(df, type = c('basic', 'complete')){
  stopifnot(is.data.frame(df))

  type = match.arg(type)

  if (fncol(df) == 0) {
    dt <- data.table(
      var = 'v1',
      type = NA,
      class = NA,
      min = NA,
      max = NA,
      n_valid = NA,
      perc_valid = NA,
      n_zero = NA,
      perc_zero = NA,
      n_nas = NA,
      perc_nas = NA,
      rows = NA,
      cols = NA
    )
    if(type == 'complete'){
      dt[, `:=`(n_unique = NA, perc_unique = NA, size = 0)]
    }

  } else {
    rows <- fnrow(df)
    cols <- fncol(df)

    res <- lapply(seq_len(cols), function(j) {
      x <- df[[j]]

      nas <- whichNA(x) |> NROW()
      valid <- rows - nas

      if(type == 'complete'){ uniq <- fnunique(x) }

      if (is.numeric(x)){
        zeros <- NROW(x %==% 0)

        rangev <- frange(x, na.rm = T)
        minv <- rangev[1]
        maxv <- rangev[2]
      } else {
        zeros <- 0
        minv <- NA
        maxv <- NA
      }

      if(type == 'basic'){
        list(
          type = typeof(x),
          class = paste(class(x), collapse = '/'),
          min = minv,
          max = maxv,
          n_valid = valid,
          perc_valid = valid / rows,
          n_zero = zeros,
          perc_zero = zeros / rows,
          n_nas = nas,
          perc_nas = nas / rows
        )
      } else if (type == 'complete'){
        list(
          type = typeof(x),
          class = paste(class(x), collapse = '/'),
          size = as.numeric(object.size(x)),
          min = minv,
          max = maxv,
          n_valid = valid,
          perc_valid = valid / rows,
          n_unique = uniq,
          perc_unique = uniq / rows,
          n_zero = zeros,
          perc_zero = zeros / rows,
          n_nas = nas,
          perc_nas = nas / rows
        )
      }
    })

    dt <- data.table::rbindlist(res)
    dt$var <- names(df)
    dt[, `:=`(rows = rows, cols = cols)]

  }

  if(type == 'basic'){
    setcolorder(
      dt,
      neworder = c(
        'var',
        'type',
        'class',
        'min',
        'max',
        'n_valid',
        'perc_valid',
        'n_zero',
        'perc_zero',
        'n_nas',
        'perc_nas',
        'rows',
        'cols')
    )
  } else if(type =='complete'){
    setcolorder(
      dt,
      neworder = c(
        'var',
        'type',
        'class',
        'size',
        'min',
        'max',
        'n_valid',
        'perc_valid',
        'n_unique',
        'perc_unique',
        'n_zero',
        'perc_zero',
        'n_nas',
        'perc_nas',
        'rows',
        'cols')
    )
  }
  return(dt)
}

f_num <- function(x, big = ',', dec = '.', thousand = 'K',
                  million = 'M', billion = 'B', dig = 0){

  if(x |> is.numeric()){
    fcase(
      is.infinite(x), paste(x),
      x > 1e9,
      paste(format(round(x/1e9, digits = dig), nsmall = dig,
                   decimal.mark = dec, big.mark = big, scientific = F), billion),
      x > 1e6,
      paste(format(round(x/1e6, digits = dig), nsmall = dig,
                   decimal.mark = dec, big.mark = big, scientific = F), million),
      x > 1e3,
      paste(format(round(x/1e3, digits = dig), nsmall = dig,
                   decimal.mark = dec, big.mark = big, scientific = F), thousand),
      default = format(round(x, dig), nsmall = dig, scientific = F)
    )
  } else {
    x
  }
}

f_int <- function(int){
  formatC(int, format = 'd', big.mark = ',', digits = 0)
}

gt_info <- function(df, df_name){
  stopifnot(is.data.frame(df))

  dt <- df |> as.data.table()

  dt[, f_icon := fcase(
    class == 'integer', '1',
    class == 'character', 'a',
    class == 'numeric', 'calculator',
    class %in% c('Date', 'IDate/Date', 'POSIXt', 'POSIXct', 'POSIXlt',
                 'POSIXct/POSIXt', 'POSIXlt/POSIXt'), 'calendar',
    class == 'factor', 'sitemap',
    class == 'raw', 'sd-card',
    class == 'complex', 'info',
    class == 'logical', 'puzzle-piece')]

  dt_gt <- dt[, `:=` (n_valid = f_num(n_valid, dig = 3),
                      n_zero = f_num(n_zero, dig = 3),
                      n_nas = f_num(n_nas, dig = 3))] |>
    gt()

  # if all NA do nothing
  if(!allNA(dt$min)){
    dt_gt <- dt_gt |>
      data_color(columns = 'min', palette = yl_palette)
  }

  # if all NA do nothing
  if(!allNA(dt$max)){
    dt_gt <- dt_gt |>
      data_color(columns = 'max', palette = pk_palette)
  }

  dt_gt |>
    tab_header(
      title = df_name,
      subtitle = paste(f_int(dt$rows[1]), 'rows -', f_int(dt$cols[1]), 'variables')
    ) |>
    cols_hide(columns = c('rows', 'cols')) |>
    fmt_percent(columns = c('perc_valid', 'perc_zero', 'perc_nas')) |>
    data_color(columns = 'n_valid', palette = lg_palette) |>
    data_color(columns = 'n_zero', palette = gray_palette) |>
    data_color(columns = 'n_nas', palette = red_palette) |>
    fmt_integer(columns = c('n_valid', 'n_nas')) |>
    fmt_number(columns = c('min', 'max', 'n_valid', 'n_zero', 'n_nas')) |>
    sub_missing() |>
    cols_move(columns = 'f_icon', after = 'var') |>
    fmt_icon(columns = 'f_icon') |>
    cols_label(
      var = 'Variable',
      type = 'Type',
      class = 'Class',
      min = 'Min',
      max = 'Max',
      n_valid = 'Valid',
      n_zero = 'Zeros',
      n_nas = "NA's",
      f_icon = ''
    ) |>
    cols_width(f_icon ~ px(30)) |>
    cols_merge(columns = c('class', 'f_icon'), pattern = "{2} {1}") |>
    cols_merge(columns = c('n_valid', 'perc_valid'), pattern = "{1} / {2}") |>
    cols_merge(columns = c('n_zero', 'perc_zero'), pattern = "{1} / {2}") |>
    cols_merge(columns = c('n_nas', 'perc_nas'), pattern = "{1} / {2}") |>
    tab_options(table.background.color = '#ffffff', heading.title.font.size = 20)
}

is_date <- function(x){
  inherits(x, c('Date', 'POSIXt', 'POSIXct', 'POSIXlt'))
}

is_categorical <- function(x) {
  is.character(x) || is.factor(x) || is.logical(x)
}

is_valid_name <- function(x){
  x == make.names(x)
}

is_name_available <- function(n, names){
  is_valid_name(n) && n %notin% names
}

is_var_available <- function(var_name, df){
  is_valid_name(var_name) && var_name %notin% names(df)
}

# wrapper functions from collapse package for speed ---------------------------
first_na <- function(x){
  ffirst(x, na.rm = F)
}

first_nona <- function(x){
  ffirst(x, na.rm = T)
}

last_na <- function(x){
  flast(x, na.rm = F)
}

last_nona <- function(x){
  flast(x, na.rm = T)
}

max_na <- function(x){
  fmax(x, na.rm = F)
}

max_nona <- function(x){
  fmax(x, na.rm = T)
}

mean_na <- function(x){
  fmean(x, na.rm = F)
}

mean_nona <- function(x){
  fmean(x, na.rm = T)
}

min_na <- function(x){
  fmin(x, na.rm = F)
}

min_nona <- function(x){
  fmin(x, na.rm = T)
}

sum_na <- function(x){
  fsum(x, na.rm = F)
}

sum_nona <- function(x){
  fsum(x, na.rm = T)
}