refactoring app

app.R

@@ -22,10 +22,17 @@ config <- config::get(file = "configs/config.yml")
 
 folder_with_schemas <- fs::path("configs/schemas")
 FILE_SCHEME         <- fs::path(folder_with_schemas, "main.xlsx")
-dbfile              <- fs::path("data.sqlite")
+# dbfile              <- fs::path("data.sqlite")
+
+# options(box.path = getwd())
+box::purge_cache()
+box::use(
+  modules/utils,
+  modules/global_options,
+  modules/db
+)
 
 # SETTINGS ================================
-DEBUG <- FALSE
 AUTH_ENABLED <- config$auth_module
 
 # CHECK FOR PANDOC
@@ -35,6 +42,7 @@ rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
 # TODO: dynamic button render depend on pandoc installation
 if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!")
 
+
 # SCHEME_MAIN UNPACK ==========================
 # load scheme
 SCHEME_MAIN <- readxl::read_xlsx(FILE_SCHEME) %>%
@@ -58,25 +66,25 @@ inputs_tables_list <- SCHEME_MAIN %>%
 
 
 # SETUP DB ==========================
-#' @description Function to open connection to db, disigned to easy dubugging.
-make_db_connection <- function(where = "") {
-  if (DEBUG) message("=== DB CONNECT ", where)
-  DBI::dbConnect(RSQLite::SQLite(), dbfile)
-}
+# #' @description Function to open connection to db, disigned to easy dubugging.
+# make_db_connection <- function(where = "") {
+#   if (DEBUG) message("=== DB CONNECT ", where)
+#   DBI::dbConnect(RSQLite::SQLite(), dbfile)
+# }
 
-#' @description Function to close connection to db, disigned to easy dubugging and
-#' hide warnings.
-close_db_connection <- function(con, where = "") {
-  tryCatch(
-    expr = DBI::dbDisconnect(con),
-    error = function(e) print(e),
-    warning = function(w) if (DEBUG) message("=!= ALREADY DISCONNECTED ", where),
-    finally = if (DEBUG) message("=/= DB DISCONNECT ", where)
-  )
-}
+# #' @description Function to close connection to db, disigned to easy dubugging and
+# #' hide warnings.
+# close_db_connection <- function(con, where = "") {
+#   tryCatch(
+#     expr = DBI::dbDisconnect(con),
+#     error = function(e) print(e),
+#     warning = function(w) if (DEBUG) message("=!= ALREADY DISCONNECTED ", where),
+#     finally = if (DEBUG) message("=/= DB DISCONNECT ", where)
+#   )
+# }
 
 # establish connection
-con <- make_db_connection()
+con <- db$make_db_connection()
 
 # init DB (write dummy data to "main" table)
 if (!"main" %in% DBI::dbListTables(con)) {
@@ -117,7 +125,7 @@ if (identical(colnames(DBI::dbReadTable(con, "main")), names(inputs_simple_list)
     # add empty data for each new input form
     for (i in form_base_difference) {
       df_to_rewrite <- df_to_rewrite %>%
-        dplyr::mutate(!!dplyr::sym(i) := get_empty_data(inputs_simple_list[i]))
+        dplyr::mutate(!!dplyr::sym(i) := utils$get_empty_data(inputs_simple_list[i]))
     }
 
     # reorder due to scheme
@@ -136,7 +144,7 @@ if (identical(colnames(DBI::dbReadTable(con, "main")), names(inputs_simple_list)
 }
 
 # close connection to prevent data loss
-close_db_connection(con)
+db$close_db_connection(con)
 
 
 # INLINE TABLES =====================
@@ -144,6 +152,7 @@ close_db_connection(con)
 inline_tables <- purrr::map(
   .x = purrr::set_names(inputs_tables_list),
   .f = \(x_inline_table_name) {
+
     # получить имя файла со схемой
     file_name <- SCHEME_MAIN %>%
       dplyr::filter(form_id == x_inline_table_name) %>%
@@ -172,166 +181,185 @@ inline_tables <- purrr::map(
 
 # создание объектов для ввода
 # функция
-create_forms <- function(form_id, form_label, form_type) {
-  # check if have condition
-  condition <- dplyr::filter(SCHEME_MAIN, form_id == {{ form_id }}) %>%
-    dplyr::distinct(condition) %>%
-    dplyr::pull()
+# create_forms <- function(form_id, form_label, form_type) {
+#   # check if have condition
+#   condition <- dplyr::filter(SCHEME_MAIN, form_id == {{ form_id }}) %>%
+#     dplyr::distinct(condition) %>%
+#     dplyr::pull()
 
-  choices <- dplyr::filter(SCHEME_MAIN, form_id == {{ form_id }}) %>% 
-    dplyr::pull(choices)
+#   choices <- dplyr::filter(SCHEME_MAIN, form_id == {{ form_id }}) %>% 
+#     dplyr::pull(choices)
 
-  # simple text or number input
-  if (form_type %in% c("text", "number")) {
-    form <- shiny::textAreaInput(
-      inputId = form_id,
-      label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
-      rows = 1
-    )
-  }
+#   # simple text or number input
+#   if (form_type %in% c("text", "number")) {
+#     form <- shiny::textAreaInput(
+#       inputId = form_id,
+#       label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
+#       rows = 1
+#     )
+#   }
 
-  # simple date input
-  if (form_type == "date") {
-    # supress warning while trying keep data form empty by default
-    suppressWarnings({
-      form <- dateInput(
-        inputId = form_id,
-        label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
-        value = NA, # keep empty
-        format = "dd.mm.yyyy",
-        weekstart = 1,
-        language = "ru"
-      )
-    })
-  }
+#   # simple date input
+#   if (form_type == "date") {
+#     # supress warning while trying keep data form empty by default
+#     suppressWarnings({
+#       form <- dateInput(
+#         inputId = form_id,
+#         label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
+#         value = NA, # keep empty
+#         format = "dd.mm.yyyy",
+#         weekstart = 1,
+#         language = "ru"
+#       )
+#     })
+#   }
 
-  # еденичный выбор
-  if (form_type == "select_one") {
-    form <- selectizeInput(
-      inputId = form_id,
-      label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
-      choices = choices,
-      selected = NULL,
-      options = list(
-        create = FALSE,
-        onInitialize = I('function() { this.setValue(""); }')
-      )
-    )
-  }
+#   # еденичный выбор
+#   if (form_type == "select_one") {
+#     form <- selectizeInput(
+#       inputId = form_id,
+#       label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
+#       choices = choices,
+#       selected = NULL,
+#       options = list(
+#         create = FALSE,
+#         onInitialize = I('function() { this.setValue(""); }')
+#       )
+#     )
+#   }
 
-  # множественный выбор
-  if (form_type == "select_multiple") {
-    form <- selectizeInput(
-      inputId = form_id,
-      label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
-      choices = choices,
-      selected = NULL,
-      multiple = TRUE,
-      options = list(
-        create = FALSE,
-        onInitialize = I('function() { this.setValue(""); }')
-      )
-    )
-  }
+#   # множественный выбор
+#   if (form_type == "select_multiple") {
+#     form <- selectizeInput(
+#       inputId = form_id,
+#       label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
+#       choices = choices,
+#       selected = NULL,
+#       multiple = TRUE,
+#       options = list(
+#         create = FALSE,
+#         onInitialize = I('function() { this.setValue(""); }')
+#       )
+#     )
+#   }
 
-  # множественный выбор
-  if (form_type == "radio") {
-    form <- radioButtons(
-      inputId = form_id,
-      label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
-      choices = choices,
-      selected = character(0)
-    )
-  }
+#   # множественный выбор
+#   if (form_type == "radio") {
+#     form <- radioButtons(
+#       inputId = form_id,
+#       label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
+#       choices = choices,
+#       selected = character(0)
+#     )
+#   }
 
-  if (form_type == "checkbox") {
-    form <- checkboxGroupInput(
-      inputId = form_id,
-      # label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
-      label = h6(form_label),
-      choices = choices,
-      selected = character(0)
-    )
-  }
+#   if (form_type == "checkbox") {
+#     form <- checkboxGroupInput(
+#       inputId = form_id,
+#       # label = tags$span(style = "color: #444444; font-weight: 550;", form_label),
+#       label = h6(form_label),
+#       choices = choices,
+#       selected = character(0)
+#     )
+#   }
 
-  # вложенная таблица
-  if (form_type == "inline_table") {
-    form <- rHandsontableOutput(outputId = form_id)
-  }
+#   # вложенная таблица
+#   if (form_type == "inline_table") {
+#     form <- rHandsontableOutput(outputId = form_id)
+#   }
 
-  # description part
-  if (form_type == "description") {
-    form <- div(HTML(form_label), style = "color:Gray;font-size: 90%;")
-  }
+#   # description part
+#   if (form_type == "description") {
+#     form <- div(HTML(form_label), style = "color:Gray;font-size: 90%;")
+#   }
 
-  # если есть условие создать кондитионал панель
-  if (!is.na(condition)) {
-    form <- conditionalPanel(
-      condition = condition,
-      form
-    )
-  }
+#   # если есть условие создать кондитионал панель
+#   if (!is.na(condition)) {
+#     form <- conditionalPanel(
+#       condition = condition,
+#       form
+#     )
+#   }
 
-  form
-}
+#   form
+# }
 
 # GENERATE UI ==================================
 # functions for making cards
-make_cards_fn <- function(sub_group) {
-  subgroups_inputs <- df_forms %>%
-    dplyr::filter(subgroup == {{ sub_group }}) %>%
-    dplyr::distinct(form_id, form_label, form_type)
+# make_cards_fn <- function(sub_group) {
 
-  bslib::card(
-    bslib::card_header(sub_group, container = htmltools::h5),
-    full_screen = TRUE,
-    width = "4000px",
-    bslib::card_body(
-      fill = TRUE,
-      # передаем все аргументы в функцию для создания елементов
-      purrr::pmap(subgroups_inputs, create_forms)
-    )
-  )
-}
+#   subgroups_inputs <- df_forms %>%
+#     dplyr::filter(subgroup == {{sub_group}}) %>%
+#     dplyr::distinct(form_id, form_label, form_type)
+
+#   subgroups_inputs2 <- SCHEME_MAIN |>
+#     dplyr::filter(subgroup == {{sub_group}}) %>%
+#     dplyr::distinct(form_id, form_label, form_type, condition)
+
+#   print(subgroups_inputs2)
+
+#   bslib::card(
+#     bslib::card_header(sub_group, container = htmltools::h5),
+#     full_screen = TRUE,
+#     width = "4000px",
+#     bslib::card_body(
+#       fill = TRUE,
+#       # передаем все аргументы в функцию для создания елементов
+#       purrr::pmap(
+#         .l = subgroups_inputs,
+#         .f = utils$create_forms,
+#         scheme = SCHEME_MAIN
+#       )
+#     )
+#   )
+# }
 
 # get pages list
 pages_list <- unique(SCHEME_MAIN$part)
 
-# get all forms df
-df_forms <- SCHEME_MAIN %>%
-  dplyr::distinct(part, subgroup, form_id, form_label, form_type)
+# # get all forms df
+# df_forms <- SCHEME_MAIN %>%
+#   dplyr::distinct(part, subgroup, form_id, form_label, form_type)
 
-# generate nav panels
+# generate nav panels for each page
 nav_panels_list <- purrr::map(
   .x = pages_list,
-  .f = \(x_page) {
-    # get info about inputs for current page
-    page_forms <- SCHEME_MAIN %>%
-      dplyr::filter(part == {{ x_page }}) %>%
-      dplyr::distinct(subgroup, form_id, form_label, form_type)
-
-    # get list of columns
-    cols_list <- unique(page_forms$subgroup)
-
-    # making cards
-    cards <- purrr::map(
-      .x = cols_list,
-      .f = make_cards_fn
-    )
-
-    # make page wrap
-    page_wrap <- bslib::layout_column_wrap(
-      # width = "350px", height = NULL, #was 800
-      width = 1 / 4, height = NULL, # was 800
-      fixed_width = TRUE,
-      !!!cards # unpack list of cards
-    )
-
-    # add panel wrap to nav_panel
-    bslib::nav_panel(x_page, page_wrap)
-  }
+  .f = utils$make_panels,
+  main_scheme = SCHEME_MAIN
 )
 
+# nav_panels_list <- purrr::map(
+#   .x = pages_list,
+#   .f = \(x_page) {
+
+#     # get info about inputs for current page
+#     page_forms <- SCHEME_MAIN %>%
+#       dplyr::filter(part == {{x_page}}) %>%
+#       dplyr::distinct(subgroup, form_id, form_label, form_type)
+
+#     # get list of columns
+#     cols_list <- unique(page_forms$subgroup)
+
+#     # making cards
+#     cards <- purrr::map(
+#       .x = cols_list,
+#       .f = utils$make_cards_fn,
+#       main_scheme = SCHEME_MAIN
+#     )
+
+#     # make page wrap
+#     page_wrap <- bslib::layout_column_wrap(
+#       # width = "350px", height = NULL, #was 800
+#       width = 1 / 4, height = NULL, # was 800
+#       fixed_width = TRUE,
+#       !!!cards # unpack list of cards
+#     )
+
+#     # add panel wrap to nav_panel
+#     bslib::nav_panel(x_page, page_wrap)
+#   }
+# )
+
 # UI =======================
 ui <- page_sidebar(
   title = config$header,
@@ -413,6 +441,7 @@ server <- function(input, output) {
   values <- reactiveValues(data = NULL)
   rhand_tables <- reactiveValues()
 
+
   # VALIDATIONS ============================
   # create new validator
   iv <- shinyvalidate::InputValidator$new()
@@ -422,10 +451,13 @@ server <- function(input, output) {
     .x = names(inputs_simple_list),
     .f = \(x_input_id) {
       form_type <- inputs_simple_list[[x_input_id]]
-      choices <- filter(SCHEME_MAIN, form_id == {{ x_input_id }}) %>% pull(choices)
-      val_required <- filter(SCHEME_MAIN, form_id == {{ x_input_id }}) %>%
-        distinct(required) %>%
-        pull(required)
+
+      choices <- dplyr::filter(SCHEME_MAIN, form_id == {{x_input_id}}) %>%
+        dplyr::pull(choices)
+
+      val_required <- dplyr::filter(SCHEME_MAIN, form_id == {{x_input_id}}) %>%
+        dplyr::distinct(required) %>%
+        dplyr::pull(required)
 
       # for `number` type: if in `choices` column has values then parsing them to range validation
       # value `0; 250` -> transform to rule validation value from 0 to 250
@@ -518,13 +550,17 @@ server <- function(input, output) {
         rownames(rhand_tables[[x]]) <- NULL
 
         # создать объект рандсонтебл
-        rh_tabel <- rhandsontable(
+        rh_tabel <- rhandsontable::rhandsontable(
           rhand_tables[[x]],
           colHeaders = headers,
           rowHeaders = NULL,
           height = 400,
         ) %>%
-          hot_cols(colWidths = 120, manualColumnResize = TRUE, columnSorting = TRUE)
+          rhandsontable::hot_cols(
+            colWidths = 120,
+            manualColumnResize = TRUE,
+            columnSorting = TRUE
+          )
 
         # циклом итерируемся по индексу;
         for (i in seq(1, length(schema_comp$form_id))) {
@@ -564,6 +600,7 @@ server <- function(input, output) {
     )
   })
 
+
   # BUTTONS LOGIC ======================
   ## clear all inputs ==================
   # show modal on click of button
@@ -579,10 +616,10 @@ server <- function(input, output) {
       .y = names(inputs_simple_list),
       .f = \(x_type, x_id) {
         # using function to update forms
-        update_forms_with_data(
+        utils$update_forms_with_data(
           id = x_id,
           type = x_type,
-          value = get_empty_data(x_type)
+          value = utils$get_empty_data(x_type)
         )
       }
     )
@@ -603,8 +640,8 @@ server <- function(input, output) {
   # сохранить простые данные;
   observeEvent(input$save_data_button, {
     req(input$id)
-    con <- make_db_connection("save_data_button")
-    on.exit(close_db_connection(con, "save_data_button"), add = TRUE)
+    con <- db$make_db_connection("save_data_button")
+    on.exit(db$close_db_connection(con, "save_data_button"), add = TRUE)
 
     ## MAIN
     # собрать все значения по введенным данным;
@@ -615,14 +652,14 @@ server <- function(input, output) {
 
         # return empty if 0 element
         if (length(input_d) == 0) {
-          return(get_empty_data(inputs_simple_list[[x]]))
+          return(utils$get_empty_data(inputs_simple_list[[x]]))
         }
         # return element if there one
         if (length(input_d) == 1) {
           return(input_d)
         }
         # если елементов больше одного - объединять через ";"
-        if (length(input_d) > 1) paste(input_d, collapse = "; ")
+        if (length(input_d) > 1) paste(input_d, collapse = getOption("SYMBOL_DELIM"))
       }
     )
 
@@ -660,8 +697,8 @@ server <- function(input, output) {
 
   ## get list of id's from db =====================
   observeEvent(input$load_data_button, {
-    con <- make_db_connection("load_data_button")
-    on.exit(close_db_connection(con, "load_data_button"))
+    con <- db$make_db_connection("load_data_button")
+    on.exit(db$close_db_connection(con, "load_data_button"))
 
     if (length(dbListTables(con)) != 0 && "main" %in% DBI::dbListTables(con)) {
       # GET DATA files
@@ -691,8 +728,8 @@ server <- function(input, output) {
 
   ## load data to input forms ==================================
   observeEvent(input$read_data, {
-    con <- make_db_connection("read_data")
-    on.exit(close_db_connection(con, "read_data"), add = TRUE)
+    con <- db$make_db_connection("read_data")
+    on.exit(db$close_db_connection(con, "read_data"), add = TRUE)
 
     # main df read
     test_read_df <- read_df_from_db_by_id("main", con)
@@ -705,14 +742,14 @@ server <- function(input, output) {
       .x = inputs_simple_list,
       .y = names(inputs_simple_list),
       .f = \(x_type, x_id) {
-        if (DEBUG) {
+        if (getOption("APP.DEBUG")) {
           values_load <- test_read_df[[x_id]]
           print(paste(x_type, x_id, values_load, sep = " || "))
           print(is.na(values_load))
         }
 
-        # using function to update forms
-        update_forms_with_data(
+        # updating forms with loaded data
+        utils$update_forms_with_data(
           id = x_id,
           type = x_type,
           value = test_read_df[[x_id]]
@@ -744,8 +781,8 @@ server <- function(input, output) {
   output$downloadData <- downloadHandler(
     filename = paste0("d2tra_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx"),
     content = function(file) {
-      con <- make_db_connection("downloadData")
-      on.exit(close_db_connection(con, "downloadData"), add = TRUE)
+      con <- db$make_db_connection("downloadData")
+      on.exit(db$close_db_connection(con, "downloadData"), add = TRUE)
 
       # get all data
       list_of_df <- purrr::map(
@@ -875,8 +912,8 @@ server <- function(input, output) {
 
   ## trigger saving function =============
   observeEvent(input$data_save, {
-    con <- make_db_connection("saving data (from modal conf)")
-    on.exit(close_db_connection(con, "saving data (from modal conf)"), add = TRUE)
+    con <- db$make_db_connection("saving data (from modal conf)")
+    on.exit(db$close_db_connection(con, "saving data (from modal conf)"), add = TRUE)
 
     # убираем плашку
     removeModal()
@@ -895,7 +932,7 @@ server <- function(input, output) {
   # FUNCTIONS ==============================
   ## write all inputs to db ================
   write_all_to_db <- function() {
-    con <- make_db_connection("fn call `write_all_to_db()`")
+    con <- db$make_db_connection("fn call `write_all_to_db()`")
     # on.exit(close_db_connection("fn call `write_all_to_db()`"), add = TRUE)
 
     # write main

helpers/db.R

@@ -1,57 +0,0 @@
-# based on https://github.com/datastorm-open/shinymanager/
-
-
-#' @export
-write_db_encrypt <- function(conn, value, name, passphrase = Sys.getenv("AUTH_DB_KEY")) {
-  if (is.character(conn)) {
-    conn <- DBI::dbConnect(RSQLite::SQLite(), dbname = conn)
-    on.exit(DBI::dbDisconnect(conn))
-  }
-
-  if (name == "credentials" && "password" %in% colnames(value)) {
-    if (!"is_hashed_password" %in% colnames(value)) {
-      value$is_hashed_password <- FALSE
-    }
-    to_hash <- which(!as.logical(value$is_hashed_password))
-    if (length(to_hash) > 0) {
-      # store hashed password
-      value$password[to_hash] <- sapply(value$password[to_hash], function(x) scrypt::hashPassword(x))
-      value$is_hashed_password[to_hash] <- TRUE
-    }
-  }
-
-  if (!is.null(passphrase)) {
-    passphrase <- as.character(passphrase)
-    passphrase <- charToRaw(passphrase)
-    key <- openssl::sha256(passphrase)
-    value_serialized <- serialize(value, NULL)
-    value_encrypted <- openssl::aes_cbc_encrypt(data = value_serialized, key = key)
-    value <- data.frame(value = I(list(value_encrypted)), iv = I(list(attr(value_encrypted, "iv"))))
-  }
-
-  DBI::dbWriteTable(conn = conn, name = name, value = value, overwrite = TRUE)
-}
-
-
-#' @export
-read_db_encrypt <- function(conn, name, passphrase = Sys.getenv("AUTH_DB_KEY")) {
-
-  if (is.character(conn)) {
-    conn <- DBI::dbConnect(RSQLite::SQLite(), dbname = conn)
-    on.exit(DBI::dbDisconnect(conn))
-  }
-
-  out <- DBI::dbReadTable(conn = conn, name = name)
-
-  if (!is.null(passphrase)) {
-    passphrase <- as.character(passphrase)
-    passphrase <- charToRaw(passphrase)
-    key <- openssl::sha256(passphrase)
-    value <- out$value[[1]]
-    attr(value, "iv") <- out$iv[[1]]
-    out <- openssl::aes_cbc_decrypt(value, key = key)
-    out <- unserialize(out)
-  }
-
-  return(out)
-}

helpers/functions.R

@@ -6,12 +6,12 @@ get_dummy_data <- function(type) {
   if (type %in% c("number")) return(as.double(999))
 }
 
-get_empty_data <- function(type) {
-  if (type %in% c("text", "select_one", "select_multiple")) return(as.character(NA))
-  if (type %in% c("radio", "checkbox")) return(as.character(NA))
-  if (type %in% c("date")) return(as.Date(NA))
-  if (type %in% c("number")) return(as.character(NA))
-}
+# get_empty_data <- function(type) {
+#   if (type %in% c("text", "select_one", "select_multiple")) return(as.character(NA))
+#   if (type %in% c("radio", "checkbox")) return(as.character(NA))
+#   if (type %in% c("date")) return(as.Date(NA))
+#   if (type %in% c("number")) return(as.character(NA))
+# }
 
 get_dummy_df <- function() {
   purrr::map(
@@ -45,62 +45,3 @@ check_for_empty_data <- function(value_to_check) {
 
   FALSE
 }
-
-
-#' @description Function update input forms.
-#' @param id - input form id;
-#' @param type - type of form;
-#' @param value - value to update;
-update_forms_with_data <- function(id, type, value) {
-  if (type == "text") {
-    shiny::updateTextAreaInput(inputId = id, value = value)
-  }
-
-  if (type == "number") {
-    shiny::updateTextAreaInput(inputId = id, value = value)
-  }
-
-  # supress warnings when applying NA or NULL to date input form
-  if (type == "date") {
-    suppressWarnings(
-      shiny::updateDateInput(inputId = id, value = value)
-    )
-  }
-
-  # select_one
-  if (type == "select_one") {
-    shiny::updateSelectizeInput(inputId = id, selected = value)
-  }
-
-  # select_multiple
-  # check if value is not NA and split by delimetr
-  if (type == "select_multiple" && !is.na(value)) {
-    vars <- stringr::str_split_1(value, "; ")
-    shiny::updateSelectizeInput(inputId = id, selected = vars)
-  }
-  # in other case fill with `character(0)` to proper reseting form
-  if (type == "select_multiple" && is.na(value)) {
-    shiny::updateSelectizeInput(inputId = id, selected = character(0))
-  }
-
-  # radio buttons
-  if (type == "radio" && !is.na(value)) {
-    shiny::updateRadioButtons(inputId = id, selected = value)
-  }
-  if (type == "radio" && is.na(value)) {
-    shiny::updateRadioButtons(inputId = id, selected = character(0))
-  }
-
-  # checkboxes
-  if (type == "checkbox" && !is.na(value)) {
-    vars <- stringr::str_split_1(value, "; ")
-    shiny::updateCheckboxGroupInput(inputId = id, selected = vars)
-  }
-  if (type == "checkbox" && is.na(value)) {
-    shiny::updateCheckboxGroupInput(inputId = id, selected = character(0))
-  }
-
-  if (type == "inline_table") {
-    message("EMPTY")
-  }
-}

modules/db.R

@@ -0,0 +1,29 @@
+# box ========
+.on_load = function(ns) {
+  message(
+    'Loading module "', box::name(), '"\n',
+    'Module path: "', basename(box::file()), '"'
+  )
+}
+# ================
+
+# DB RELATED ===========================
+#' @export
+#' @description Function to open connection to db, disigned to easy dubugging.
+#' @param where text mark to distingiush calss
+make_db_connection <- function(where = "") {
+  if (getOption("APP.DEBUG", FALSE)) message("=== DB CONNECT ", where)
+  DBI::dbConnect(RSQLite::SQLite(), getOption("APP.FILE_DB", FALSE))
+}
+
+#' @export
+#' @description Function to close connection to db, disigned to easy dubugging and
+#' hide warnings.
+close_db_connection <- function(con, where = "") {
+  tryCatch(
+    expr = DBI::dbDisconnect(con),
+    error = function(e) print(e),
+    warning = function(w) if (getOption("APP.DEBUG", FALSE)) message("=!= ALREADY DISCONNECTED ", where),
+    finally = if (getOption("APP.DEBUG", FALSE)) message("=/= DB DISCONNECT ", where)
+  )
+}

modules/global_options.R

@@ -0,0 +1,30 @@
+# box ========
+.on_load = function(ns) {
+  message(
+    'Loading module "', box::name(), '"\n',
+    'Module path: "', basename(box::file()), '"'
+  )
+  set_global_options()
+}
+
+# ================
+
+#' @export
+#' @description костыли для упрощения работы себе
+set_global_options <- function(
+  SYMBOL_DELIM = "; ",
+  APP.DEBUG = FALSE,
+  APP.FILE_DB = fs::path("data.sqlite"),
+  shiny.host = "127.0.0.1",
+  shiny.port = 1337,
+  ...
+) {
+  options(
+    SYMBOL_DELIM = SYMBOL_DELIM,
+    APP.DEBUG = APP.DEBUG,
+    APP.FILE_DB = APP.FILE_DB,
+    shiny.host = shiny.host,
+    shiny.port = shiny.port,
+    ...
+  )
+}

modules/utils.R

@@ -0,0 +1,284 @@
+# box ========
+.on_load = function(ns) {
+  message(
+    'Loading module "', box::name(), '"\n',
+    'Module path: "', basename(box::file()), '"'
+  )
+}
+# ================
+
+# asdasd
+#' @export
+make_panels <- function(page_name, main_scheme) {
+
+  # get info about inputs for current page
+  page_forms <- main_scheme |>
+    dplyr::filter(part == {{page_name}}) |>
+    dplyr::distinct(subgroup, form_id, form_label, form_type)
+
+  # get list of columns
+  cols_list <- unique(page_forms$subgroup)
+
+  # making cards
+  cards <- purrr::map(
+    .x = cols_list,
+    .f = make_cards_fn,
+    main_scheme = main_scheme
+  )
+
+  # make page wrap
+  page_wrap <- bslib::layout_column_wrap(
+    # width = "350px", height = NULL, #was 800
+    width = 1 / 4, height = NULL, # was 800
+    fixed_width = TRUE,
+    # unpack list of cards
+    !!!cards
+  )
+
+  # add panel wrap to nav_panel
+  bslib::nav_panel(
+    title = page_name,
+    page_wrap
+  )
+}
+
+# functions for making cards
+#' @export
+make_cards_fn <- function(sub_group, main_scheme) {
+
+  main_scheme <<- main_scheme
+  subgroups_inputs <- main_scheme |>
+    dplyr::filter(subgroup == {{sub_group}}) |>
+    dplyr::distinct(form_id, form_label, form_type)
+
+  bslib::card(
+    bslib::card_header(sub_group, container = htmltools::h5),
+    full_screen = TRUE,
+    width = "4000px",
+    bslib::card_body(
+      fill = TRUE,
+      # передаем все аргументы в функцию для создания елементов
+      purrr::pmap(
+        .l = subgroups_inputs,
+        .f = create_forms,
+        main_scheme = main_scheme
+      )
+    )
+  )
+}
+
+# UI RELATED ============================
+#' @export
+#' @param TEST s
+create_forms <- function(
+  form_id,
+  form_label,
+  form_type,
+  main_scheme
+) {
+
+  # check if have condition
+  condition <- dplyr::filter(main_scheme, form_id == {{form_id}}) |>
+    dplyr::distinct(condition) |>
+    dplyr::pull()
+
+  choices <- dplyr::filter(main_scheme, form_id == {{form_id}}) |>
+    dplyr::pull(choices)
+
+  # simple text or number input
+  if (form_type == "text") {
+
+    # get info how much rows to render
+    rows_to_show <- ifelse(!is.na(choices), as.integer(choices), 1)
+
+    form <- shiny::textAreaInput(
+      inputId = form_id,
+      label = shiny::span(style = "color: #444444; font-weight: 550;", form_label),
+      rows = rows_to_show
+    )
+  }
+
+  if (form_type == "number") {
+    form <- shiny::textAreaInput(
+      inputId = form_id,
+      label = shiny::span(style = "color: #444444; font-weight: 550;", form_label),
+      rows = 1
+    )
+  }
+
+  # simple date input
+  if (form_type == "date") {
+    # supress warning while trying keep data form empty by default
+    suppressWarnings({
+      form <- shiny::dateInput(
+        inputId = form_id,
+        label = shiny::span(style = "color: #444444; font-weight: 550;", form_label),
+        value = NA, # keep empty
+        format = "dd.mm.yyyy",
+        weekstart = 1,
+        language = "ru"
+      )
+    })
+  }
+
+  # еденичный выбор
+  if (form_type == "select_one") {
+    form <- shiny::selectizeInput(
+      inputId = form_id,
+      label = shiny::span(style = "color: #444444; font-weight: 550;", form_label),
+      choices = choices,
+      selected = NULL,
+      options = list(
+        create = FALSE,
+        onInitialize = I('function() { this.setValue(""); }')
+      )
+    )
+  }
+
+  # множественный выбор
+  if (form_type == "select_multiple") {
+    form <- shiny::selectizeInput(
+      inputId = form_id,
+      label = shiny::span(style = "color: #444444; font-weight: 550;", form_label),
+      choices = choices,
+      selected = NULL,
+      multiple = TRUE,
+      options = list(
+        create = FALSE,
+        onInitialize = I('function() { this.setValue(""); }')
+      )
+    )
+  }
+
+  # множественный выбор
+  if (form_type == "radio") {
+    form <- shiny::radioButtons(
+      inputId = form_id,
+      label = shiny::span(style = "color: #444444; font-weight: 550;", form_label),
+      choices = choices,
+      selected = character(0)
+    )
+  }
+
+  if (form_type == "checkbox") {
+    form <- shiny::checkboxGroupInput(
+      inputId = form_id,
+      # label = shiny::span(style = "color: #444444; font-weight: 550;", form_label),
+      label = shiny::h6(form_label),
+      choices = choices,
+      selected = character(0)
+    )
+  }
+
+  # вложенная таблица
+  if (form_type == "inline_table") {
+    form <- rhandsontable::rHandsontableOutput(outputId = form_id)
+  }
+
+  # description part
+  if (form_type == "description") {
+    form <- shiny::div(shiny::HTML(form_label), style = "color:Gray;font-size: 90%;")
+  }
+
+  # если есть условие создать кондитионал панель
+  if (!is.na(condition)) {
+    form <- shiny::conditionalPanel(
+      condition = condition,
+      form
+    )
+  }
+  form
+}
+
+
+
+
+# SERVER LOGIC ==========================
+#' @export
+get_empty_data <- function(type) {
+  if (type %in% c("text", "select_one", "select_multiple")) return(as.character(NA))
+  if (type %in% c("radio", "checkbox")) return(as.character(NA))
+  if (type %in% c("date")) return(as.Date(NA))
+  if (type %in% c("number")) as.character(NA)
+}
+
+
+#' @export
+#' @description Function to update input forms (default variants only)
+#' @param id - input form id;
+#' @param type - type of form;
+#' @param value - value to update;
+#' @param local_delimeter - delimeter to split file
+update_forms_with_data <- function(
+  id,
+  type,
+  value,
+  local_delimeter = getOption("SYMBOL_DELIM")
+) {
+
+  if (type == "text") {
+    shiny::updateTextAreaInput(inputId = id, value = value)
+  }
+
+  if (type == "number") {
+    shiny::updateTextAreaInput(inputId = id, value = value)
+  }
+
+  # supress warnings when applying NA or NULL to date input form
+  if (type == "date") {
+    suppressWarnings(
+      shiny::updateDateInput(inputId = id, value = value)
+    )
+  }
+
+  # select_one
+  if (type == "select_one") {
+    # update choices
+    # old_choices <- subset(scheme, form_id == id, choices) |> dplyr::pull()
+    # new_choices <- unique(c(old_choices, value))
+    # new_choices <- new_choices[!is.na(new_choices)]
+
+    # shiny::updateSelectizeInput(inputId = id, selected = value, choices = new_choices)
+    shiny::updateSelectizeInput(inputId = id, selected = value)
+  }
+
+  # select_multiple
+  # check if value is not NA and split by delimetr
+  if (type == "select_multiple" && !is.na(value)) {
+    vars <- stringr::str_split_1(value, local_delimeter)
+
+    # update choices
+    # old_choices <- subset(scheme, form_id == id, choices) |> dplyr::pull()
+    # new_choices <- unique(c(old_choices, vars))
+    # new_choices <- new_choices[!is.na(new_choices)]
+
+    # shiny::updateSelectizeInput(inputId = id, selected = vars, choices = new_choices)
+    shiny::updateSelectizeInput(inputId = id, selected = vars)
+  }
+
+  # in other case fill with `character(0)` to proper reseting form
+  if (type == "select_multiple" && is.na(value)) {
+    shiny::updateSelectizeInput(inputId = id, selected = character(0))
+  }
+
+  # radio buttons
+  if (type == "radio" && !is.na(value)) {
+    shiny::updateRadioButtons(inputId = id, selected = value)
+  }
+  if (type == "radio" && is.na(value)) {
+    shiny::updateRadioButtons(inputId = id, selected = character(0))
+  }
+
+  # checkboxes
+  if (type == "checkbox" && !is.na(value)) {
+    vars <- stringr::str_split_1(value, local_delimeter)
+    shiny::updateCheckboxGroupInput(inputId = id, selected = vars)
+  }
+  if (type == "checkbox" && is.na(value)) {
+    shiny::updateCheckboxGroupInput(inputId = id, selected = character(0))
+  }
+
+  # if (type == "inline_table") {
+  #   message("EMPTY")
+  # }
+}