0.16.0

.Rprofile

@@ -1 +1,20 @@
 source("renv/activate.R")
+
+
+(function() {
+
+  paths <- c(
+    "R_CONFIG_ACTIVE",
+    "AUTH_DB_KEY"
+  )
+
+  lines <- paths[Sys.getenv(paths) == ""]
+
+  if (length(lines) > 0) {
+    cli::cli_h3("Настройка путей окружения")
+    cli::cli_code(paste0(lines, "="))
+    cli::cli_inform(c(
+      "i" = "Для нормальной работы скриптов добавьте в {.file .Renviron}:"
+    ))
+  }
+})()

.gitignore

@@ -1,5 +1,8 @@
 /renv
+/temp
+/_devel
 
+scheme.rds
 .Renviron
 .DS_Store
 .lintr

CHANGELOG.md

@@ -1,3 +1,15 @@
+### 0.16.0 (2026-04-21)
+##### features
+- возможность импорта данных в базу данных из ранее экспортированных .xlsx таблиц;
+- пререндеринг схемы формы (сокращение количества времени на загрузку приложения);
+- главная форма для заполнения не отображается если не выбрана/создана запись;
+- валидация правильности заполненных данных в формах 'select_one', 'select_multiple', 'radio' и 'checkboxes';
+- возможность работы с несколькими формами в пределах одного приложения;
+
+##### changes
+- в каждой схеме первый элемент с формой (по id) теперь является ключевым (ранее необходимо было явно указывать id 'main_key' и 'nested_key');
+- при экспорте из базы в .xlsx числовые значения всегда экспортируются как текст (чтобы сохранить 'NA' значения);
+
 ### 0.15.0 (2026-04-07)
 ##### features
 - added `description_header` form type;

README.md

@@ -12,14 +12,53 @@
 
 ...
 
+# Quick start
+
+## локально:
+
+Копирование содержимого репозитория
+```bash
+git clone https://gitea.madelirihs.ru/madeliri/shiny_form.git
+```
+
+Восстановление окружения
+```r
+renv::init()
+```
+
+# Насторйки
+
+## переменные окружения
+
+### работа с авторизацией
+
+Пароль базы данных с авторизацией необходимо указать в `.Renviron`:
+```
+AUTH_DB_KEY = "this_is_your_password"
+```
+
+### бэкапы локальных баз
+
+Для создания бэкапов локальных баз данных, необходимо указать путь куда будут сохранятся бэкапы в переменной окружения:
+```
+FORM_APP_LOCAL_DB_BACKUP_PATH="path_to_backups"
+```
+
+Проверка осуществляется при каждом запуске приложения, бэкапы создаются раз в день (при первом запуске).
+
+Количество сохраняемых бэкапов:
+```
+FORM_APP_LOCAL_DB_BACKUP_LIMITS=3
+```
+
 
 # Cтруктура `schema.xlsx`
 
 Файл, формирующий структуру всей формы, представляет собой таблицу в формате `.xlsx`, состоящий из следующих столбцов:
 
-- `part` - группировка первого уровня (страницы);
+- `part` - группировка первого уровня (страницы), используется только в главной схеме ('main');
 - `subgroup` - группировка второго уровня (колонки);
-- `form_id` - id;
+- `form_id` - id формы;
 - `form_label` - Название формы;
 - `form_description` - Описание формы;
 - `form_type` - тип формы, в настоящее время доступные следующие варианты:
@@ -32,20 +71,17 @@
   - `checkboxes` - выбор нескольких вариантов (checkboxes); 
   - `description` - описание (отображение текста, без формы выбора/ввода);
   - `description_header` - для отображение заголовка;
-  - `nested_form` - вложенная форма;
+  - `nested_forms` - вложенная форма;
 - `choices` - варианты выбора (если предполагаются типом формы ввода);
 - `condition` - условие, при котором форма ввода будет отображаться;
 - `required` - проверка заполненности поля: пустое значение - нет проверки, 1 - есть проверка
 
+Первый по порядку id – для каждой схемы является ключевой (!)
+
 # Как пользоваться
 
 ## Авторизация
 
-Пароль базы данных с авторизацией необходимо указать в `.Renviron`:
-
-```
-AUTH_DB_KEY = "this_is_your_password"
-```
 
 # trade-ofs
 

app.R

@@ -9,8 +9,6 @@ suppressPackageStartupMessages({
   library(shinymanager)
 })
 
-source("helpers/functions.R")
-
 # SOURCE FILES ============================
 box::purge_cache()
 box::use(
@@ -21,16 +19,24 @@ box::use(
   modules/scheme_generator[scheme_R6]
 )
 
-# SETTINGS ================================
-FILE_SCHEME <- fs::path("configs/schemas", "schema.xlsx")
-AUTH_ENABLED <- Sys.getenv("FORM_AUTH_ENABLED", FALSE)
-HEADER_TEXT <- sprintf("%s (%s)", Sys.getenv("FORM_TITLE", "NA"), Sys.getenv("FORM_VERSION", "NA"))
-
 global_options$set_global_options(
   shiny.host = "0.0.0.0"
 )
+
 global_options$check_and_init_scheme()
 
+# global vars
+box::use(
+  modules/global_options[AUTH_ENABLED]
+)
+
+# SETTINGS ================================
+HEADER_TEXT  <- sprintf("%s (%s)", config::get("form_name"), config::get("form_app_version"))
+
+# sadasdasdasdasdas
+options(box.path = config::get("form_app_configure_path"))
+box::use(configs/enabled_schemes[enabled_schemes])
+
 # CHECK FOR PANDOC
 # TEMP ! NEED TO HANDLE
 rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
@@ -39,46 +45,37 @@ rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
 if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!")
 
 # SCHEME_MAIN UNPACK ==========================
-schm            <- readRDS("scheme.rds")
+schms <- readRDS("scheme.rds")
-
-# two_obj <- purrr::map(
-#   c(one = "configs/schemas/schema.xlsx", two = "configs/schemas/schema_example.xlsx"),
-#   scheme_R6$new
-# )
-# two_obj[["a"]]$get_schema("main")
-# object.size(two_obj)
-# saveRDS(schm, "test.rds")
-# readRDS("test.rds")
-
-# check tables
-
 
 # UI =======================
 ui <- page_sidebar(
-  title = HEADER_TEXT,
+  # title = HEADER_TEXT,
+  title = tagList(
+    h4(HEADER_TEXT, style = "margin-top: .5rem"),
+    tooltip(
+      span("about", icon("circle-info", lib = "font-awesome")),
+      "Данный функционал позволяет обрабатывать информацию о пациентах на комиссию, используя Excel (обновление данных возможно через окно формирования списка пациентов)"
+    )
+  ),
   theme = bs_theme(version = 5, preset = "bootstrap"),
   sidebar = sidebar(
     actionButton("add_new_main_key_button", "Добавить новую запись", icon("plus", lib = "font-awesome")),
     actionButton("save_data_button", "Сохранить данные", icon("floppy-disk", lib = "font-awesome")),
-    actionButton("clean_data_button", "Очистить данные", icon("user-plus", lib = "font-awesome")),
+    actionButton("clean_data_button", "Главная страница", icon("house", lib = "font-awesome")),
     actionButton("load_data_button", "Загрузить данные", icon("pencil", lib = "font-awesome")),
     downloadButton("downloadDocx", "get .docx (test only)"),
-    textOutput("status_message"),
+    uiOutput("status_message"),
     textOutput("status_message2"),
-    uiOutput("admin_buttons_panel"),
     uiOutput("display_log"),
     position = "left",
     open = list(mobile = "always")
   ),
-  as_fill_carrier(uiOutput("main_ui_navset"))
+  as_fill_carrier(uiOutput("main_ui_navset")),
 )
 
-# MODALS ========================
-# окно для подвтерждения очищения данных
-
 # init auth =======================
 if (AUTH_ENABLED) {
-  # shinymanager::set_labels("en", "Please authenticate" = "aboba")
+  # shinymanager::set_labels("en", "Please authenticate" = "scheme()")
   ui <- ui |> 
     shinymanager::secure_app(
       status = "primary",
@@ -105,7 +102,7 @@ if (AUTH_ENABLED) {
 # SERVER LOGIC =============================
 server <- function(input, output, session) {
   
-  # AUTH SETUP ========================================
+  # AUTH SETUP =============================================
   res_auth <- if (AUTH_ENABLED) {
     # check_credentials directly on sqlite db
     shinymanager::secure_server(
@@ -129,18 +126,22 @@ server <- function(input, output, session) {
     if (AUTH_ENABLED) {
       reactiveValuesToList(res_auth)
       if (res_auth$admin) {
-        print("admin")
+        # print("admin")
       } else {
-        print("not_admin")
+        # print("not_admin")
         showing_buttons <- FALSE
       }
     }
 
     if (showing_buttons) {
-      fluidRow(
+      tagList(
-        downloadButton("downloadData", "Экспорт в .xlsx"),
+        br(),
-        p(""), # separate buttons
+        strong("Импорт и экспорт данных для выбранной схемы:"),
-        actionButton("button_upload_data_from_xlsx", "импорт!", icon("file-import", lib = "font-awesome"))
+        verticalLayout(
+          downloadButton("downloadData", "Экспорт в .xlsx", style = "width: 250px; margin-top: 5px"),
+          actionButton("button_upload_data_from_xlsx", "импорт!", icon("file-import", lib = "font-awesome"), style = "width: 250px; margin-top: 10px"),
+          fluid = FALSE 
+        )
       )
     }
   })
@@ -153,25 +154,47 @@ server <- function(input, output, session) {
     nested_key = NULL,
     nested_form_id = NULL
   )
+
+  scheme <- reactiveVal(enabled_schemes[1]) # наименование выбранной схемы
+  mhcs   <- reactiveVal(schms[[enabled_schemes[1]]]) # объект для выбранной схемы
+  observers_started <- reactiveVal(NULL)
+
   main_form_is_empty <- reactiveVal(TRUE)
   validator_main   <- reactiveVal(NULL)
   validator_nested <- reactiveVal(NULL)
 
-  # динамический рендеринг --------------------------
+  # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # ГЛАВНАЯ СТРАНИЦА ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   output$main_ui_navset <- renderUI({
 
     if (main_form_is_empty()) {
       validator_main(NULL)
-      "Для начала работы нужно создать новую запись или загрузить существующую!"
+      div(
+        shiny::radioButtons(
+          "schmes_selector",
+          label = strong("Выбрать базу данных для работы:"),
+          choices = enabled_schemes,
+          selected = scheme()
+        ),
+        "Для начала работы нужно создать новую запись или загрузить существующую!",
+        # загрузка панели для работы с базой данных
+        uiOutput("admin_buttons_panel")
+      )
     } else {
 
       # list of rendered panels
-      validator_main(data_validation$init_val(schm$get_schema("main")))
+      validator_main(data_validation$init_val(mhcs()$get_scheme("main")))
       validator_main()$enable()
-      schm$get_main_form_ui
+      mhcs()$get_main_form_ui
     }
   })
 
+  observeEvent(input$schmes_selector, {
+    scheme(input$schmes_selector)
+    mhcs(schms[[input$schmes_selector]])
+  })
+
   # ==========================================
   # ОБЩИЕ ФУНКЦИИ ============================
   # ==========================================
@@ -184,13 +207,13 @@ server <- function(input, output, session) {
     ns
   ) {
 
-    input_types <- unname(schm$get_id_type_list(table_name))
+    input_types <- unname(mhcs()$get_id_type_list(table_name))
-    input_ids   <- names(schm$get_id_type_list(table_name))
+    input_ids   <- names(mhcs()$get_id_type_list(table_name))
     if (missing(ns)) ns <- NULL
 
     # transform df to list
-    loaded_df_for_id <- as.list(df)
+    # loaded_df_for_id <- as.list(df)
-    loaded_df_for_id <- df[input_ids]
+    # loaded_df_for_id <- df[input_ids]
 
     # rewrite input forms
     purrr::walk2(
@@ -203,7 +226,7 @@ server <- function(input, output, session) {
           form_id = x_id,
           form_type = x_type,
           value = df[[x_id]],
-          scheme = schm$get_schema(table_name),
+          scheme = mhcs()$get_scheme(table_name),
           ns = ns
         )
       }
@@ -218,7 +241,7 @@ server <- function(input, output, session) {
     con
   ) {
 
-    nested_key_id <- schm$get_key_id(table_name)
+    nested_key_id <- mhcs()$get_key_id(table_name)
     input_types   <- unname(id_and_types_list)
     input_ids     <- names(id_and_types_list)
 
@@ -255,7 +278,7 @@ server <- function(input, output, session) {
     if (table_name == "main") {
       exported_df <- exported_df |>
         mutate(
-          !!dplyr::sym(schm$get_main_key_id) := values$main_key,
+          !!dplyr::sym(mhcs()$get_main_key_id) := values$main_key,
           .before = 1
         )
     }
@@ -264,7 +287,7 @@ server <- function(input, output, session) {
     if (table_name != "main") {
       exported_df <- exported_df |>
         mutate(
-          !!dplyr::sym(schm$get_main_key_id) := values$main_key,
+          !!dplyr::sym(mhcs()$get_main_key_id) := values$main_key,
           !!dplyr::sym(nested_key_id)          := values$nested_key,
           .before = 1
         )
@@ -276,7 +299,7 @@ server <- function(input, output, session) {
     db$write_df_to_db(
       df = exported_df,
       table_name = table_name,
-      schm = schm,
+      schm = mhcs(),
       main_key_value   = values$main_key,
       nested_key_value = values$nested_key,
       con = con
@@ -287,14 +310,20 @@ server <- function(input, output, session) {
   # NESTED FORMS =======================
   # ====================================
   ## кнопки для каждой вложенной таблицы -------------------------------
+  observe({
+
+    # проверка инициализированы ли для этой схемы наблюдатели для кнопок вложенных таблиц
+    is_observer_is_started <- (isolate(scheme()) %in% isolate(observers_started()))
+
+    if (is_observer_is_started) return()
     purrr::walk(
-    .x = schm$nested_tables_names,
+      .x = mhcs()$nested_tables_names,
       .f = \(nested_form_id) {
         
         observeEvent(input[[nested_form_id]], {
           req(values$main_key)
   
-        con <- db$make_db_connection("nested_tables")
+          con <- db$make_db_connection(scheme(),"nested_tables")
           on.exit(db$close_db_connection(con, "nested_tables"), add = TRUE)
   
           values$nested_form_id <- nested_form_id
@@ -305,27 +334,38 @@ server <- function(input, output, session) {
       }
     )
 
+    # добавить идентификатор текущей схемы в список иницииализированных валидаторов
+    observers_started(c(
+      isolate(observers_started()), isolate(scheme())
+    ))
+  })
+
   ## функция отображения вложенной формы для выбранной таблицы --------
   show_modal_for_nested_form <- function(con) {
 
     ns     <- NS(values$nested_form_id)
-    key_id <- schm$get_key_id(values$nested_form_id)
+    key_id <- mhcs()$get_key_id(values$nested_form_id)
 
     # загрузка схемы для данной вложенной формы
-    this_nested_form_scheme <-  schm$get_schema(values$nested_form_id)
+    this_nested_form_scheme <- mhcs()$get_scheme(values$nested_form_id)
 
     # мини-схема для ключа
-    this_nested_form_key_scheme <- subset(this_nested_form_scheme, form_id == key_id)
+    this_nested_form_key_scheme <- this_nested_form_scheme |>
-    if (nrow(this_nested_form_key_scheme) > 1) cli::cli_abort("количество строк не может быть больше одного для ключа")
+      dplyr::filter(form_id == {{key_id}})
+
+    this_nested_form_key_scheme_smoll <- this_nested_form_key_scheme |>
+      dplyr::distinct(form_id, form_label, form_type)
+
+    if (nrow(this_nested_form_key_scheme_smoll) > 1) cli::cli_abort("количество строк не может быть больше одного для ключа")
 
     # выбираем все ключи из баз данных
-    kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, schm, values$main_key, con)
+    kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, mhcs(), values$main_key, con)
     kyes_for_this_table <- unique(c(values$nested_key, kyes_for_this_table))
     kyes_for_this_table <- sort(kyes_for_this_table)
     values$nested_key <- if (length(kyes_for_this_table) == 0) NULL else kyes_for_this_table[[1]]
 
     # если ключ в формате даты - дать человекочитаемые данные
-    if (this_nested_form_key_scheme$form_type == "date") {
+    if (this_nested_form_key_scheme_smoll$form_type == "date") {
       kyes_for_this_table <- setNames(
         kyes_for_this_table,
         format(as.Date(kyes_for_this_table), "%d.%m.%Y")
@@ -333,8 +373,8 @@ server <- function(input, output, session) {
     }
 
     # nested ui
-    if (!is.null(values$nested_key)) {
+    nested_form_panels <- if (!is.null(values$nested_key)) {
-      yay_its_fun <- purrr::map(
+      purrr::map(
         .x = unique(this_nested_form_scheme$subgroup),
         .f = \(subgroup) {
 
@@ -354,9 +394,8 @@ server <- function(input, output, session) {
         }
       )
     } else {
-      yay_its_fun <- list(bslib::nav_panel("", "empty"))
+      list(bslib::nav_panel("", div("Нет доступных записей.", br(), "Необходимо создать новую запись.")))
     }
-    # yay_its_fun <- !!!yay_its_fun
 
     # ui для всплывающего окна 
     ui_for_inline_table <- navset_card_underline(
@@ -364,19 +403,18 @@ server <- function(input, output, session) {
         width = 300,
         selectizeInput(
           inputId = "nested_key_selector",
-          label = this_nested_form_key_scheme$form_label, 
+          label = strong(this_nested_form_key_scheme_smoll$form_label),
           choices = kyes_for_this_table,
           selected = values$nested_key,
           # options = list(placeholder = "действие комиссии", create = FALSE, onInitialize = I('function() { this.setValue(""); }'))
         ),
-        actionButton("add_new_nested_key_button", "add"),
+        actionButton("add_new_nested_key_button", "Добавить новую запись", icon("plus", lib = "font-awesome")),
-        actionButton("nested_form_save_button", "save"),
+        actionButton("nested_form_save_button", "Сохранить данные", icon("floppy-disk", lib = "font-awesome")),
-        actionButton("nested_form_dt_button", "dt"),
+        actionButton("nested_form_dt_button", "DT", icon("table", lib = "font-awesome")),
         uiOutput("validation_nested"),
         open = list(mobile = "always-above")
       ),
-      # if (!is.null(values$nested_key)) {rlang::syms(!!!yay_its_fun)} else bslib::nav_panel("empty")
+      !!!nested_form_panels
-      !!!yay_its_fun
     )
 
     # проверка данных для внутренних таблиц
@@ -394,25 +432,27 @@ server <- function(input, output, session) {
   ### функция для отображения DT-таблицы для выбранной вложенной формы --------
   show_modal_for_nested_form_dt <- function(con) {
 
-    key_id <- schm$get_key_id(values$nested_form_id)
+    key_id <- mhcs()$get_key_id(values$nested_form_id)
 
     # получение дата-фрейма
     values$data <- db$read_df_from_db_by_id(
       table_name = values$nested_form_id, 
-      schm,
+      mhcs(),
       main_key_value = values$main_key,
       con = con
     )
 
-    col_types <- schm$get_schema(values$nested_form_id) |>
+    col_types <- mhcs()$get_scheme_with_values_forms(values$nested_form_id) |>
       dplyr::distinct(form_id, form_type, form_label)
 
-    date_cols <- subset(col_types, form_type == "date", form_id, drop = TRUE)
+    date_cols <- which(col_types$form_type == "date")
+    str_cols  <- which(col_types$form_type != "date")
 
     values$data <- values$data |>
-      select(-schm$get_main_key_id) |>
+      select(-mhcs()$get_main_key_id) |>
       mutate(
-        dplyr::across(tidyselect::all_of({{date_cols}}), as.Date)
+        dplyr::across(tidyselect::all_of({{date_cols}}), as.Date),
+        dplyr::across(tidyselect::all_of({{str_cols}}), as.character),
       ) |>
       arrange({{key_id}})
 
@@ -421,7 +461,7 @@ server <- function(input, output, session) {
         values$data,
         caption = 'Table 1: This is a simple caption for the table.',
         rownames = FALSE,
-        # colnames = dplyr::pull(col_types, form_id, form_label),
+        colnames = col_types |> dplyr::pull(form_id, form_label),
         extensions = c('KeyTable', "FixedColumns"),
         editable = 'cell',
         selection = "none",
@@ -432,7 +472,8 @@ server <- function(input, output, session) {
           keys = TRUE
         )
       ) |>
-        DT::formatDate(date_cols, "toLocaleDateString", params = list('ru-RU'))
+        DT::formatDate(date_cols, "toLocaleDateString", params = list('ru-RU')) |>
+        DT::formatString(str_cols)
     )
 
     showModal(modalDialog(
@@ -453,7 +494,7 @@ server <- function(input, output, session) {
 
   ### кнопка: отображение DT -----------------------------
   observeEvent(input$nested_form_dt_button, {
-    con <- db$make_db_connection("nested_form_save_button")
+    con <- db$make_db_connection(scheme(),"nested_form_save_button")
     on.exit(db$close_db_connection(con, "nested_form_save_button"), add = TRUE)
 
     removeModal()
@@ -463,50 +504,52 @@ server <- function(input, output, session) {
   ### кнопка: сохранить изменения DT --------------------
   observeEvent(input$nested_form_dt_save, {
   
-    con <- db$make_db_connection("nested_form_dt_save")
+    con <- db$make_db_connection(scheme(),"nested_form_dt_save")
     on.exit(db$close_db_connection(con, "nested_form_dt_save"), add = TRUE)
 
     export_df <- values$data |>
       dplyr::distinct() |>
-      dplyr::mutate(!!dplyr::sym(schm$get_main_key_id) := values$main_key, .before = 1)
+      dplyr::mutate(!!dplyr::sym(mhcs()$get_main_key_id) := values$main_key, .before = 1)
 
     db$write_df_to_db(
       df = export_df,
       table_name = values$nested_form_id,
-      schm,
+      mhcs(),
       main_key_value = values$main_key,
       nested_key_value = NULL,
       con = con
     )
 
     log_action_to_db("saving data (gt)", values$main_key, con)
-
+    showNotification(
+      "Данные успешно сохранены",
+      type = "message"
+    )
   })
 
   ## сохранение данных из вложенной формы ---------------
   observeEvent(input$nested_form_save_button, {
     req(values$nested_form_id)
 
-    con <- db$make_db_connection("nested_form_save_button")
+    con <- db$make_db_connection(scheme(),"nested_form_save_button")
     on.exit(db$close_db_connection(con, "nested_form_save_button"), add = TRUE)
     
     # сохраняем данные основной формы!!!
     save_inputs_to_db(
       table_name        = "main",
-      id_and_types_list = schm$get_id_type_list("main"),
+      id_and_types_list = mhcs()$get_id_type_list("main"),
       con               = con
     )
 
     # сохраняем данные текущей вложенной таблицы
     save_inputs_to_db(
       table_name        = values$nested_form_id,
-      id_and_types_list = schm$get_id_type_list(values$nested_form_id),
+      id_and_types_list = mhcs()$get_id_type_list(values$nested_form_id),
       ns                = NS(values$nested_form_id),
       con = con
     )
 
     log_action_to_db("saving data", values$main_key, con)
-
     showNotification(
       "Данные успешно сохранены",
       type = "message"
@@ -536,17 +579,17 @@ server <- function(input, output, session) {
 
   observeEvent(values$nested_key, {
 
-    con <- db$make_db_connection("nested_tables")
+    con <- db$make_db_connection(scheme(),"nested_tables")
     on.exit(db$close_db_connection(con, "nested_tables"), add = TRUE)
 
-    kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, schm, values$main_key, con)
+    kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, mhcs(), values$main_key, con)
 
     if (values$nested_key %in% kyes_for_this_table) {
 
       # выгрузка датафрейма по общим и вложенным ключам
       df <- db$read_df_from_db_by_id(
         table_name = values$nested_form_id,
-        schm,
+        mhcs(),
         main_key_value   = values$main_key,
         nested_key_value = values$nested_key,
         con = con
@@ -556,9 +599,11 @@ server <- function(input, output, session) {
       load_data_to_form(
         df                = df,
         table_name = values$nested_form_id,
-        schm,
+        mhcs(),
         ns                = NS(values$nested_form_id)
       )
+    } else {
+      utils$clean_forms(values$nested_form_id, mhcs(), NS(values$nested_form_id))
     }
   })
 
@@ -568,8 +613,8 @@ server <- function(input, output, session) {
     removeModal()
 
     # та самая форма для ключа
-    scheme_for_key_input <- schm$get_schema(values$nested_form_id) |>
+    scheme_for_key_input <- mhcs()$get_scheme(values$nested_form_id) |>
-      dplyr::filter(form_id == schm$get_key_id(values$nested_form_id))
+      dplyr::filter(form_id == mhcs()$get_key_id(values$nested_form_id))
 
     ui1 <- rlang::exec(
       .fn = utils$render_forms, 
@@ -590,19 +635,19 @@ server <- function(input, output, session) {
 
   # действие при подтверждении создания новой записи
   observeEvent(input$confirm_create_new_nested_key, {
-    req(input[[schm$get_key_id(values$nested_form_id)]])
+    req(input[[mhcs()$get_key_id(values$nested_form_id)]])
 
-    con <- db$make_db_connection("confirm_create_new_key")
+    con <- db$make_db_connection(scheme(),"confirm_create_new_key")
     on.exit(db$close_db_connection(con, "confirm_create_new_key"), add = TRUE)
 
     existed_key <- db$get_nested_keys_from_table(
       table_name = values$nested_form_id,
-      schm,
+      mhcs(),
       main_key_value = values$main_key,
       con
     )
 
-    if (input[[schm$get_key_id(values$nested_form_id)]] %in% existed_key) {
+    if (input[[mhcs()$get_key_id(values$nested_form_id)]] %in% existed_key) {
       showNotification(
         sprintf("В базе уже запись с данным ключем."),
         type = "error"
@@ -610,8 +655,8 @@ server <- function(input, output, session) {
       return()
     }
     
-    values$nested_key <- input[[schm$get_key_id(values$nested_form_id)]]
+    values$nested_key <- input[[mhcs()$get_key_id(values$nested_form_id)]]
-    utils$clean_forms(values$nested_form_id, schm, NS(values$nested_form_id))
+    utils$clean_forms(values$nested_form_id, mhcs(), NS(values$nested_form_id))
     removeModal()
     show_modal_for_nested_form(con)
 
@@ -619,11 +664,16 @@ server <- function(input, output, session) {
 
   # STATUSES ===============================
   # вывести отображение что что-то не так
-  output$status_message <- renderText({
+  output$status_message <- renderUI({
+
     shiny::validate(
       need(values$main_key, "⚠️ Необходимо указать id пациента!")
     )
-    paste0("ID: ", values$main_key)
+    span(
+      strong("Таблица: "), names(enabled_schemes)[enabled_schemes == scheme()],
+      br(),
+      strong("ID: "), values$main_key
+    )
   })
 
   output$status_message2 <- renderText({
@@ -643,8 +693,8 @@ server <- function(input, output, session) {
   observeEvent(input$add_new_main_key_button, {
 
     # данные для главного ключа
-    scheme_for_key_input <- schm$get_schema("main") |>
+    scheme_for_key_input <- mhcs()$get_scheme("main") |>
-      dplyr::filter(form_id == schm$get_main_key_id)
+      dplyr::filter(form_id == mhcs()$get_main_key_id)
 
     # создать форму для выбора ключа
     ui1 <- rlang::exec(
@@ -667,14 +717,14 @@ server <- function(input, output, session) {
 
   ## действие при подтверждении (проверка нового создаваемого ключа) -------
   observeEvent(input$confirm_create_new_main_key, {
-    req(input[[schm$get_main_key_id]])
+    req(input[[mhcs()$get_main_key_id]])
 
-    con <- db$make_db_connection("confirm_create_new_main_key")
+    con <- db$make_db_connection(scheme(),"confirm_create_new_main_key")
     on.exit(db$close_db_connection(con, "confirm_create_new_key"), add = TRUE)
 
-    new_main_key <- trimws(input[[schm$get_main_key_id]])
+    new_main_key <- trimws(input[[mhcs()$get_main_key_id]])
 
-    existed_key <- db$get_keys_from_table("main", schm, con)
+    existed_key <- db$get_keys_from_table("main", mhcs(), con)
 
     # если введенный ключ уже есть в базе
     if (new_main_key %in% existed_key) {
@@ -688,7 +738,7 @@ server <- function(input, output, session) {
     values$main_key <- new_main_key
     main_form_is_empty(FALSE)
     log_action_to_db("creating new key", values$main_key, con)
-    utils$clean_forms("main", schm)
+    utils$clean_forms("main", mhcs())
 
     removeModal()
   })
@@ -712,7 +762,7 @@ server <- function(input, output, session) {
     
     # rewrite all inputs with empty data
     values$main_key <- NULL
-    utils$clean_forms("main", schm)
+    utils$clean_forms("main", mhcs())
     main_form_is_empty(TRUE)
 
     removeModal()
@@ -723,12 +773,12 @@ server <- function(input, output, session) {
   observeEvent(input$save_data_button, {
     req(values$main_key)
 
-    con <- db$make_db_connection("save_data_button")
+    con <- db$make_db_connection(scheme(),"save_data_button")
     on.exit(db$close_db_connection(con, "save_data_button"), add = TRUE)
 
     save_inputs_to_db(
       table_name = "main",
-      id_and_types_list = schm$get_id_type_list("main"),
+      id_and_types_list = mhcs()$get_id_type_list("main"),
       con = con
     )
 
@@ -742,13 +792,13 @@ server <- function(input, output, session) {
   ## список ключей для загрузки данных -------------------
   observeEvent(input$load_data_button, {
 
-    con <- db$make_db_connection("load_data_button")
+    con <- db$make_db_connection(scheme(),"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
-      ids <- db$get_keys_from_table("main", schm, con)
+      ids <- db$get_keys_from_table("main", mhcs(), con)
 
       ui_load_menu <- renderUI({
         selectizeInput(
@@ -774,8 +824,8 @@ server <- function(input, output, session) {
         ui_load_menu,
         title = "Загрузить имеющиеся данные",
         footer = tagList(
-          actionButton("close_modal_button", "Отмена", class = "btn btn-danger"),
           actionButton("load_data", "Загрузить данные"),
+          actionButton("close_modal_button", "Отмена", class = "btn-danger"),
         ),
         easyClose = TRUE
       )
@@ -786,12 +836,12 @@ server <- function(input, output, session) {
   observeEvent(input$load_data, {
     req(input$load_data_key_selector)
 
-    con <- db$make_db_connection("load_data")
+    con <- db$make_db_connection(scheme(),"load_data")
     on.exit(db$close_db_connection(con, "load_data"), add = TRUE)
 
     df <- db$read_df_from_db_by_id(
       table_name = "main", 
-      schm = schm,
+      schm = mhcs(),
       main_key_value = input$load_data_key_selector,
       con = con
     )
@@ -799,7 +849,7 @@ server <- function(input, output, session) {
     load_data_to_form(
       df = df,
       table_name = "main",
-      schm
+      mhcs()
     )
     
     values$main_key <- input$load_data_key_selector
@@ -810,26 +860,30 @@ server <- function(input, output, session) {
 
   })
 
-  ## export to .xlsx ====
+  ## export to .xlsx ======================
   output$downloadData <- downloadHandler(
-    filename = paste0("test_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx"),
+    filename = function(){
+      paste0(isolate(scheme()), "_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx")
+    },
     content = function(file) {
-      con <- db$make_db_connection("downloadData")
+
+      con <- db$make_db_connection(isolate(scheme()),"downloadData")
       on.exit(db$close_db_connection(con, "downloadData"), add = TRUE)
 
       # get all data
       list_of_df <- purrr::map(
-        .x = purrr::set_names(schm$all_tables_names),
+        .x = purrr::set_names(mhcs()$all_tables_names),
         .f = \(x) {
 
           df <- read_df_from_db_all(x, con) |>
             tibble::as_tibble()
 
           # handle with data
-          scheme <- schm$get_schema(x)
+          scheme <- mhcs()$get_scheme(x)
 
           date_columns   <- subset(scheme, form_type == "date", form_id, drop = TRUE)
           number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE)
+          other_cols     <- which(colnames(df) %in% c(date_columns, number_columns))
 
           df <- df |>
             dplyr::mutate(
@@ -837,12 +891,26 @@ server <- function(input, output, session) {
               dplyr::across(tidyselect::all_of({{date_columns}}), as.Date),
               # числа - к единому формату десятичных значений
               dplyr::across(tidyselect::all_of({{number_columns}}), ~ gsub("\\.", "," , .x)),
-            )
+              dplyr::across(tidyselect::all_of({{other_cols}}), as.character)
+            ) |>
+            # очистка от пустых ключей
+            dplyr::filter(!is.na(mhcs()$get_main_key_id))
 
           df
         }
       )
 
+      # добавить мета информацию
+      list_of_df[["meta"]] <- dplyr::tribble(
+        ~`Параметр`      , ~`Значение`,
+        "Пользователь"   , ifelse(AUTH_ENABLED, res_auth$user, "anonymous"),
+        "Название базы"  , names(enabled_schemes)[enabled_schemes == scheme()],
+        "id базы"        , scheme(),
+        "id формы"       , config::get("form_id"),
+        "ver формы"      , config::get("form_app_version"),
+        "Время выгрузки" , format(Sys.time(), "%d.%m.%Y %H:%M:%S"),
+      )
+
       # set date params
       options("openxlsx2.dateFormat" = "dd.mm.yyyy")
 
@@ -876,10 +944,11 @@ server <- function(input, output, session) {
         "---",
         "\n"
       )
+      box::use(modules/data_manipulations[is_this_empty_value])
 
       # iterate by scheme parts
       purrr::walk(
-        .x = unique(schm$get_schema("main")$part),
+        .x = unique(mhcs()$get_scheme("main")$part),
         .f = \(x_iter1) {
           # write level 1 header
           HEADER_1 <- paste("#", x_iter1, "\n")
@@ -887,14 +956,14 @@ server <- function(input, output, session) {
 
           # iterate by level2 headers (subgroups)
           purrr::walk(
-            .x = dplyr::pull(unique(subset(schm$get_schema("main"), part == x_iter1, "subgroup"))),
+            .x = dplyr::pull(unique(subset(mhcs()$get_scheme("main"), part == x_iter1, "subgroup"))),
             .f = \(x_iter2) {
               # get header 2 name
               HEADER_2 <- paste("##", x_iter2, "\n")
 
               # for some reason set litle scheme...
               litle_scheme <- subset(
-                x = schm$get_schema("main"),
+                x = mhcs()$get_scheme("main"),
                 subset = part == x_iter1 & subgroup == x_iter2,
                 select = c("form_id", "form_label", "form_type")
               ) |>
@@ -915,7 +984,7 @@ server <- function(input, output, session) {
                     if (length(docx_value) > 1) docx_value <- paste(docx_value, collapse = ", ")
 
                     # if non empty data - add string
-                    if (!check_for_empty_data(docx_value)) paste0("**", docx_label, "**: ", docx_value, "\n") else NA
+                    if (!is_this_empty_value(docx_value)) paste0("**", docx_label, "**: ", docx_value, "\n") else NA
                   } else if (docx_type == "description") {
                     # treat description label as citation text
                     paste0(">", docx_label, "\n")
@@ -970,8 +1039,8 @@ server <- function(input, output, session) {
       ),
       checkboxInput("upload_data_from_xlsx_owerwrite_all_data", "перезаписать все данные", width = 450),
       footer = tagList(
-        modalButton("Отмена"),
+        actionButton("button_upload_data_from_xlsx_confirm", "Добавить"),
-        actionButton("button_upload_data_from_xlsx_confirm", "Добавить")
+        actionButton("close_modal_button", "Отмена", class = "btn-danger")
       ),
       easyClose = FALSE
     ))
@@ -981,56 +1050,55 @@ server <- function(input, output, session) {
   observeEvent(input$button_upload_data_from_xlsx_confirm, {
     req(input$upload_xlsx)
 
-    con <- db$make_db_connection("button_upload_data_from_xlsx_confirm")
+    con <- db$make_db_connection(scheme(),"button_upload_data_from_xlsx_confirm")
     on.exit(db$close_db_connection(con, "button_upload_data_from_xlsx_confirm"), add = TRUE)
 
     file <- input$upload_xlsx$datapath
     wb <- openxlsx2::wb_load(file)
 
-    main_key_id <- schm$get_main_key_id
+    main_key_id <- mhcs()$get_main_key_id
 
     # проверка на наличие всех листов в файле
-    if (!all(schm$all_tables_names %in% openxlsx2::wb_get_sheet_names(wb))) {
+    if (!all(mhcs()$all_tables_names %in% openxlsx2::wb_get_sheet_names(wb))) {
       cli::cli_alert_warning("данные в файле '{file} не соответствуют схеме'")
       return()
     }
 
     # проверка схемы --------------
-    for (table_name in schm$all_tables_names) {
+    for (table_name in mhcs()$all_tables_names) {
 
       df     <- openxlsx2::read_xlsx(wb, table_name) 
-      scheme <- schm$get_schema(table_name) |>
+      scheme <- mhcs()$get_scheme_with_values_forms(table_name) 
-        filter(!form_type %in% c("description", "nested_forms"))
 
       # столбцы в таблицы и схема
       df_to_schema_compare <- setdiff(colnames(df), unique(scheme$form_id))
+      df_to_schema_compare <- df_to_schema_compare[df_to_schema_compare != main_key_id]
       schema_to_df_compare <- setdiff(unique(scheme$form_id), colnames(df))
 
-      if (length(schema_to_df_compare) > 0 ) {
+      if (length(df_to_schema_compare) > 0 ) {
         cli::cli_warn(c("в схеме для '{table_name}' нет следующих столбцов:", paste("- ", df_to_schema_compare)))
       }
 
       # схема и столбцы в таблице
-      schema_to_df_compare <- setdiff(unique(scheme$form_id), colnames(df))
       if (length(schema_to_df_compare) > 0 ) {
 
         message <- glue::glue("столбцы в таблице '{table_name}' не соответсвуют схеме")
-        cli::cli_warn(c(message, paste("- ", schema_to_df_compare)))
         showNotification(message, type = "error")
+        cli::cli_warn(c(message, paste("- ", schema_to_df_compare)))
 
         return()
       }
     }
 
     # обновление данных
-    for (table_name in schm$all_tables_names) {
+    for (table_name in mhcs()$all_tables_names) {
 
       df     <- openxlsx2::read_xlsx(wb, table_name) 
-      scheme <- schm$get_schema(table_name) |>
+      scheme <- mhcs()$get_scheme_with_values_forms(table_name)
-        filter(!form_type %in% c("description", "nested_forms"))
 
       date_columns   <- subset(scheme, form_type == "date", form_id, drop = TRUE)
       number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE)
+      other_cols     <- which(colnames(df) %in% c(date_columns, number_columns))
 
       # функция для преобразование числовых значений и сохранения "NA"
       num_converter <- function(old_col) {
@@ -1050,14 +1118,20 @@ server <- function(input, output, session) {
           # даты - к единому формату
           dplyr::across(tidyselect::all_of({{date_columns}}),   \(x) purrr::map_chr(x, db$excel_to_db_dates_converter)),
           dplyr::across(tidyselect::all_of({{number_columns}}), num_converter),
+          dplyr::across(tidyselect::all_of({{other_cols}}),     as.character)
         ) |>
         select(all_of(unique(c(main_key_id, scheme$form_id))))
 
       df_original <- DBI::dbReadTable(con, table_name) |>
         as_tibble()
 
-      if (input$upload_data_from_xlsx_owerwrite_all_data == TRUE) cli::cli_abort("not implemented yet")
+      if (input$upload_data_from_xlsx_owerwrite_all_data == TRUE) {
 
+        DBI::dbRemoveTable(con, table_name)
+
+      } else {
+
+        # удаление данных в базе данных по ключам
         walk(
           .x = unique(df[[main_key_id]]),
           .f = \(main_key) {
@@ -1068,6 +1142,12 @@ server <- function(input, output, session) {
           }
         )
      
+      }
+
+      # очистка от пустых ключей
+      df <- df |>
+        dplyr::filter(!is.na({{main_key_id}}))
+
       DBI::dbWriteTable(
         con,
         name = table_name,
@@ -1075,7 +1155,7 @@ server <- function(input, output, session) {
         append = TRUE
       )
 
-      message <- glue::glue("Данные таблицы '{table_name}' успешно обновлены")
+      message <- glue::glue("Данные таблицы '{table_name}' успешно обновлены (добавлено {nrow(df)} записей)")
       showNotification(
         message,
         type = "message"
@@ -1117,7 +1197,7 @@ server <- function(input, output, session) {
       "exporting data to xlsx",
       "importing data from xlsx"
     ),
-    key = NULL,
+    key = NA,
     con
   ) {
 
@@ -1126,6 +1206,8 @@ server <- function(input, output, session) {
     action_row <- tibble(
       date        = Sys.time(),
       user        = ifelse(AUTH_ENABLED, res_auth$user, "anonymous"),
+      app_id      = config::get("form_id"),
+      app_ver     = config::get("form_app_version"),
       remote_addr = session$request$REMOTE_ADDR,
       key         = key,
       action      = action,
@@ -1139,7 +1221,7 @@ server <- function(input, output, session) {
 
   #   output$display_log <- renderUI({
 
-  #     con <- db$make_db_connection("display_log")
+  #     con <- db$make_db_connection(scheme(),"display_log")
   #     on.exit(db$close_db_connection(con, "display_log"), add = TRUE)
 
   #     query <- if (!is.null(values$main_key)) {

config.yml

@@ -0,0 +1,13 @@
+default:
+  form_app_version: 0.16.0
+  form_id: new_formy
+  form_name: NEW FORMY
+
+prod:
+  form_app_configure_path: "."
+  form_auth_enabled: true
+
+devel:
+  form_app_configure_path: _devel/d2tra
+  form_auth_enabled: false
+  form_app_version: 0.16.0 dev

configs/enabled_schemes.R

@@ -0,0 +1,4 @@
+#' @export
+enabled_schemes <- c(
+  `Тестовая база данных` = "example_of_scheme"
+)

helpers/functions.R

@@ -1,27 +0,0 @@
-
-
-#' @description Function check if variable contains some sort of empty data
-#' (NULL, NA, "", other 0-length data) and return `TRUE` (`FALSE` if data is
-#' not 'empty').
-#'
-#' Needed for proper data validation.
-#' (ДУБЛИРУЕТ МОДУЛЬ `data_manipulation`)
-check_for_empty_data <- function(value_to_check) {
-
-  # for any 0-length
-  if (length(value_to_check) == 0) return(TRUE)
-
-  # for NA
-  if (is.logical(value_to_check) && is.na(value_to_check)) return(TRUE)
-
-  # for NULL
-  if (is.null(value_to_check)) return(TRUE)
-
-  # for non-empty Date (RETURN FALSE)
-  if (inherits(value_to_check, "Date") && length(value_to_check) != 0) return(FALSE)
-
-  # for empty strings (stands before checking non-empty data for avoid mistakes)
-  if (value_to_check == "") return(TRUE)
-
-  FALSE
-}

modules/data_manipulations.R

@@ -4,7 +4,8 @@
 #' not 'empty').
 #'
 #' Needed for proper data validation.
-check_for_empty_data = function(value_to_check) {
+#' @export
+is_this_empty_value = function(value_to_check) {
 
   # for any 0-length
   if (length(value_to_check) == 0) return(TRUE)
@@ -19,7 +20,14 @@ check_for_empty_data = function(value_to_check) {
   if (inherits(value_to_check, "Date") && length(value_to_check) != 0) return(FALSE)
 
   # for empty strings (stands before checking non-empty data for avoid mistakes)
+  if (is.character(value_to_check)) {
+    if (is.na(value_to_check)) return(TRUE)
     if (value_to_check == "")   return(TRUE)
-
+  }
-  FALSE
+
+  if (is.double(value_to_check)) {
+    if (is.na(value_to_check)) return(TRUE)
+  }
+
+  return(FALSE)
 }

modules/data_validation.R

@@ -1,10 +1,9 @@
+options(box.path = here::here())
+box::use(modules/data_manipulations[is_this_empty_value])
 
 #' @export
 init_val = function(scheme, ns) {
 
-  options(box.path = here::here())
-  box::use(modules/data_manipulations[check_for_empty_data])
-
   iv <- shinyvalidate::InputValidator$new()
 
   # если передана функция с пространством имен, то происходит модификация id
@@ -37,18 +36,7 @@ init_val = function(scheme, ns) {
       # value `0; 250` -> transform to rule validation value from 0 to 250
       if (form_type == "number") {
 
-        iv$add_rule(x_input_id, function(x) {
+        iv$add_rule(x_input_id, val_is_a_number)
-          # exit if empty
-          if (check_for_empty_data(x)) {
-            return(NULL)
-          }
-          # хак для пропуска значений
-          if (x == "NA") return(NULL)
-
-          # check for numeric
-          # if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом."
-          if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом."
-        })
 
         # проверка на соответствие диапазону значений
         if (!is.na(choices)) {
@@ -59,15 +47,44 @@ init_val = function(scheme, ns) {
           if (length(ranges) > 3) {
             warning("Количество переданных элементов'", x_input_id, "' > 2")
           } else {
-            iv$add_rule(
+            iv$add_rule(x_input_id, val_number_within_a_range, ranges = ranges)
-              x_input_id,
+          }
-              function(x) {
+        }
-
-                # exit if empty
-                if (check_for_empty_data(x)) {
-                  return(NULL)
       }
 
+      if (form_type %in% c("select_multiple", "select_one", "radio", "checkbox")) {
+        iv$add_rule(x_input_id, val_choice_within_a_dict, choices = choices)
+      }
+
+      # if in `required` column value is `1` apply standart validation
+      if (!is.na(val_required) && val_required == 1) {
+        iv$add_rule(x_input_id, shinyvalidate::sv_required(message = "Необходимо заполнить."))
+      }
+    }
+  )
+  iv
+}
+
+# работа с числовыми значениями ------------------
+## проверка является ли значение числом ----------
+val_is_a_number = function(x) {
+
+  # exit if empty
+  if (is_this_empty_value(x)) return(NULL)
+  # хак для пропуска значений
+  if (x == "NA") return(NULL)
+
+  # check for numeric
+  # if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом."
+  if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом."
+
+}
+
+## находится ли число в заданном диапазоне значений -------
+val_number_within_a_range = function(x, ranges) {
+
+  # exit if empty
+  if (is_this_empty_value(x)) return(NULL)
   if (x == "NA") return(NULL)
 
   # замена разделителя десятичных цифр
@@ -80,16 +97,13 @@ init_val = function(scheme, ns) {
     glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.")
   }
 }
-            )
-          }
-        }
-      }
 
-      if (form_type %in% c("select_multiple", "select_one")) {
+# списки ---------------------------------------------------------
-        iv$add_rule(x_input_id, function(x) {
+## являются ли выбранные значения допустимы (согласно файлу схемы)
+val_choice_within_a_dict = function(x, choices) {
 
   if (length(x) == 1) {
-            if (check_for_empty_data(x)) return(NULL)
+    if (is_this_empty_value(x)) return(NULL)
   }
 
   # проверка на соответствие вариантов схеме ---------
@@ -99,16 +113,4 @@ init_val = function(scheme, ns) {
     text <- paste0("'",x[!compare_to_dict],"'", collapse = ", ")
     glue::glue("варианты, не соответствующие схеме: {text}")
   }
-        })
-
-      }
-
-
-      # if in `required` column value is `1` apply standart validation
-      if (!is.na(val_required) && val_required == 1) {
-        iv$add_rule(x_input_id, shinyvalidate::sv_required(message = "Необходимо заполнить."))
-      }
-    }
-  )
-  iv
 }

modules/db.R

@@ -2,9 +2,14 @@
 #' @export
 #' @description Function to open connection to db, disigned to easy dubugging.
 #' @param where text mark to distingiush calss
-make_db_connection = function(where = "") {
+make_db_connection = function(scheme, where = "") {
   if (getOption("APP.DEBUG", FALSE)) message("=== DB CONNECT ", where)
-  DBI::dbConnect(RSQLite::SQLite(), getOption("APP.FILE_DB", FALSE))
+  DBI::dbConnect(RSQLite::SQLite(), fs::path(
+    config::get("form_app_configure_path"),
+    "db",
+    scheme, 
+    ext = "sqlite"
+  ))
 }
 
 #' @export
@@ -12,12 +17,14 @@ make_db_connection = function(where = "") {
 #' 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)
   )
+
 }
 
 #' @export
@@ -39,7 +46,7 @@ check_if_table_is_exist_and_init_if_not = function(
 
       if (table_name %in% DBI::dbListTables(con)) {
 
-        cli::cli_inform(c("*" = "таблица есть такая: '{table_name}'"))
+        cli::cli_inform(c("*" = "проверка таблицы в базе данных: '{table_name}'"))
 
         # если таблица существует, производим проверку структуры таблицы
         compare_existing_table_with_schema(
@@ -185,12 +192,13 @@ write_df_to_db = function(
   con
 ) {
 
-  scheme         <- schm$get_schema(table_name)
+  scheme         <- schm$get_scheme(table_name)
   main_key_id    <- schm$get_main_key_id
   nested_key_id  <- schm$get_key_id(table_name)
 
   date_columns   <- subset(scheme, form_type == "date", form_id, drop = TRUE)
   number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE)
+  other_cols     <- which(colnames(df) %in% c(date_columns, number_columns))
 
   df <- df |>
     dplyr::mutate(
@@ -198,6 +206,7 @@ write_df_to_db = function(
       dplyr::across(tidyselect::all_of({{date_columns}}), \(x) purrr::map_chr(x, excel_to_db_dates_converter)),
       # числа - к единому формату десятичных значений
       dplyr::across(tidyselect::all_of({{number_columns}}), ~ gsub("\\.", "," , .x)),
+      dplyr::across(tidyselect::all_of({{other_cols}}), as.character),
     )
 
   if (table_name == "main") {
@@ -327,3 +336,71 @@ excel_to_db_dates_converter = function(date) {
   fin_date <- as.character(format(fin_date, "%Y-%m-%d"))
   fin_date
 }
+
+#' @export
+local_db_backup <- function(
+  db_name,
+  backups_paths = Sys.getenv("FORM_APP_LOCAL_DB_BACKUP_PATH"),
+  backups_limit = as.integer(Sys.getenv("FORM_APP_LOCAL_DB_BACKUP_LIMITS", 5))
+) {
+  
+  db_path <- fs::path(config::get("form_app_configure_path"), "db")
+  db_full_path <- fs::path(db_path, db_name, ext = "sqlite")
+  
+  backup_folder <- fs::path(backups_paths, db_name)
+  
+  if (!dir.exists(backup_folder)) dir.create(backup_folder, recursive = TRUE)
+  
+  date_mark <- format(Sys.time(), "%Y%m%d")
+  
+  schedule <- c(
+    daily = 1,
+    weekly = 7,
+    monthly = 28
+  )
+  
+  purrr::walk2(
+    .x = schedule,
+    .y = names(schedule),
+    .f = \(schedule_days, schedule_name) {
+  
+      # daily
+      daily_folder  <- fs::path(backup_folder, schedule_name)
+      todays_backup <- fs::path(daily_folder, paste0(db_name, "_", format(Sys.time(), "%Y%m%d")), ext = "sqlite")
+  
+      if (!dir.exists(daily_folder)) dir.create(daily_folder)
+  
+      existed_files <- fs::dir_ls(daily_folder, regexp = "((?:19|20)\\d\\d)(0?[1-9]|1[012])([12][0-9]|3[01]|0?[1-9])")
+      existed_files <- sort(existed_files, decreasing = TRUE)
+  
+      # если бэкап для сегодняшнего дня есть - скипаем процедуру
+      if (todays_backup %in% existed_files) {
+        return()
+      }
+  
+      # парсим даты
+      dates <- stringr::str_extract(existed_files, "((?:19|20)\\d\\d)(0?[1-9]|1[012])([12][0-9]|3[01]|0?[1-9])")
+      dates <- as.Date(dates, "%Y%m%d")
+
+      # если количество существующих бэкапов значимо превышает установленный лимит, удаляем лишнее
+      if (length(existed_files) > backups_limit) {
+        file.remove(utils::tail(existed_files, length(existed_files) - backups_limit))
+      }
+
+      # если количество существующих бэкапов равно имеющемуся и пора делать бэкап - делаем бэкап, удаляем послендий файл
+      if (length(existed_files) >= backups_limit & dates[1] + schedule_days == Sys.Date()) {
+  
+        file.remove(utils::tail(existed_files, 1))
+        file.copy(db_full_path, todays_backup)
+  
+      } else if(length(existed_files) == 0) {
+  
+        file.copy(db_full_path, todays_backup)
+
+      }
+  
+    }
+  )
+
+}
+

modules/global_options.R

@@ -3,56 +3,103 @@
 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,
+  shiny.port = 1338,
   ...
 ) {
+  
+  config_params_to_check <- c(
+    "form_app_version",
+    "form_app_configure_path",
+    "form_auth_enabled",
+    "form_id",
+    "form_name"
+  )
+  
+  expected_params_in_config <- config_params_to_check %in% names(config::get())
+  if (!all(expected_params_in_config)) {
+    cli::cli_abort(c("ну так не пойдет:", paste("-", config_params_to_check[!expected_params_in_config])))
+  }
+
   options(
     SYMBOL_DELIM = SYMBOL_DELIM,
+    # form.db_path = config::get("form_db_path"),
     APP.DEBUG = APP.DEBUG,
-    APP.FILE_DB = APP.FILE_DB,
+    # APP.FILE_DB = APP.FILE_DB,
     shiny.host = shiny.host,
     shiny.port = shiny.port,
     ...
   )
 }
 
+#' @export
+AUTH_ENABLED <- config::get("form_auth_enabled")
+
 #' @export
 check_and_init_scheme = function() {
 
   cli::cli_inform(c("*" = "проверка схемы..."))
 
-  scheme_file <- fs::path("configs/schemas", "schema.xlsx")
+  options(box.path = here::here())
-  hash_file   <- "schema_hash.rds"
+  box::use(modules/db[local_db_backup])
+
+  options(box.path = config::get("form_app_configure_path"))
+  box::use(configs/enabled_schemes[enabled_schemes])
+
+  # список файлов, изменение которых, приведут к переинициализиации схемы
+  files_to_watch <- c(
+    fs::path(config::get("form_app_configure_path"), "configs", "enabled_schemes.R"),
+    "modules/scheme_generator.R",
+    "modules/utils.R"
+  )
+
+  scheme_names <- enabled_schemes
+  scheme_file <- paste0(config::get("form_app_configure_path"), "/configs/schemas/", scheme_names, ".xlsx")
+  scheme_file <- stats::setNames(scheme_file, scheme_names)
+
+  if (!all(file.exists(scheme_file))) {
+    cli::cli_abort(c("Отсутствуют файлы схем для следующих наименований:", paste("-", names(scheme_file)[!file.exists(scheme_file)])))
+  }
+  
+  db_files <- paste0(config::get("form_app_configure_path"), "/db/", scheme_names, ".sqlite")
+
+  hash_file   <- "temp/schema_hash.rds"
 
   # 
-  exist_hash <- tools::md5sum(scheme_file)
+  exist_hash <- tools::md5sum(c(scheme_file, files_to_watch))
 
   # если первый запуск (нет файла с кешем) инициализация схемы
-  if (!file.exists("schema_hash.rds") | !file.exists("scheme.rds")) {
+  if (!file.exists(hash_file) | !file.exists("scheme.rds") | !all(file.exists(db_files))) {
 
     init_scheme(scheme_file)
 
   # в ином случае - проверяем кэш
   } else {
 
-    saved_hash <- readRDS("schema_hash.rds")
+    saved_hash <- readRDS(hash_file)
 
     # если данные были изменены проводим реинициализацию таблицы и схемы
     if (!all(exist_hash == saved_hash)) {
 
-      cli::cli_inform(c(">" = "Данные схемы были изменены..."))
+      cli::cli_inform(c(">" = "Данные схем были изменены..."))
       init_scheme(scheme_file)
+
     } else {
       cli::cli_alert_success("изменений нет")
     }
   }
 
-  # перезаписываем файл
+  # MAKING BACKUPS
-  saveRDS(exist_hash, hash_file)
+  if (Sys.getenv("FORM_APP_LOCAL_DB_BACKUP_PATH") != "") {
+    cli::cli_inform(c("*" = "создание бэкапов баз данных..."))
+    purrr::walk(scheme_names, local_db_backup)
+    
   }
 
+  # перезаписываем файл
+  if (!dir.exists("temp")) dir.create("temp")
+  saveRDS(exist_hash, hash_file)
+}
 
 init_scheme = function(scheme_file) {
 
@@ -62,12 +109,37 @@ init_scheme = function(scheme_file) {
     modules/scheme_generator[scheme_R6]
   )
 
-  con <- db$make_db_connection()
+  db_path <- fs::path(config::get("form_app_configure_path"), "db")
-  on.exit(db$close_db_connection(con), add = TRUE)
+  if (!dir.exists(db_path)) dir.create(db_path)
 
   cli::cli_h1("Инициализация схемы")
-  schm <- scheme_R6$new(scheme_file)
+  schms <- purrr::map2(
-  db$check_if_table_is_exist_and_init_if_not(schm, con)
+    .x = scheme_file,
+    .y = names(scheme_file),
+    \(x, y) {
 
-  saveRDS(schm, "scheme.rds")
+      con <- db$make_db_connection(y)
+      on.exit(db$close_db_connection(con), add = TRUE)
+
+      schm <- scheme_R6$new(x)
+      db$check_if_table_is_exist_and_init_if_not(schm, con)
+      schm
+    }
+  )
+
+  # проверка на наличие дублирующихся названий вложенных таблиц
+  nested_tables_ids <- purrr::map(
+    names(schms),
+    \(x) schms[[x]]$nested_tables_names
+  )
+  nested_tables_ids <- unlist(nested_tables_ids)
+  tab <- table(nested_tables_ids)
+
+  # если встречается хоть одно значение несколько раз - начать истошно кричать (могут возникнуть пробемы при вызове всплывающих окон в формах)
+  if (!all(!tab > 1)) {
+    cli::cli_abort(c("В одной или нескольких схемах наименования вложенных форм совпадают:", paste("-", names(tab)[tab > 1])))
+    
+  }
+  
+  saveRDS(schms, "scheme.rds")
 }

modules/scheme_generator.R

@@ -1,14 +1,14 @@
 
 #' @export
 scheme_R6 <- R6::R6Class(
-  "schemes_f",
+  "schemes_generator",
   public = list(
 
     initialize = function(scheme_file_path = NULL) {
 
       private$scheme_file_path <- scheme_file_path
 
-      # make list of schemas
+      # make list of schemes
       private$schemes_list <- list()
       private$schemes_list[["main"]] <- private$load_scheme_from_xlsx("main")
 
@@ -18,6 +18,14 @@ scheme_R6 <- R6::R6Class(
         dplyr::distinct(form_id) |>
         dplyr::pull(form_id)
 
+      # проверка на не пересечение с зарезервированными именами
+      check <- private$reserved_table_names %in% private$nested_forms_names
+      if (any(check)) cli::cli_abort(c("нельзя использовать данные имена вложенных таблиц:", paste("- ", private$reserved_table_names[check])))
+
+      # проверка на длину строк
+      check <- (nchar(private$nested_forms_names) > 31)
+      if (any(check)) cli::cli_abort(c("нельзя использовать имена длиной более 31 символа:", paste("- ", private$nested_forms_names[check])))
+
       purrr::walk(
         .x = purrr::set_names(private$nested_forms_names),
         .f = \(nested_form_id) {
@@ -36,7 +44,7 @@ scheme_R6 <- R6::R6Class(
       private$main_key_id <- self$get_key_id("main")
 
       box::use(modules/utils)
-      private$testest <- bslib::navset_card_underline(
+      private$bslib_rendered_ui <- bslib::navset_card_underline(
         id = "main",
         !!!utils$make_list_of_pages(private$schemes_list[["main"]], private$main_key_id),
         header = NULL,
@@ -47,7 +55,7 @@ scheme_R6 <- R6::R6Class(
     get_all_ids = function(table_name) {
 
       private$schemes_list[[table_name]] |>
-        dplyr::filter(!form_type %in% private$exluded_types) |>
+        dplyr::filter(!form_type %in% private$excluded_types) |>
         dplyr::distinct(form_id) |>
         dplyr::pull(form_id)
 
@@ -65,32 +73,24 @@ scheme_R6 <- R6::R6Class(
 
     },
 
-    extract_forms_id_and_types_from_scheme2 = function(scheme) {
+    # возврат схемы ------------------------------------
-
+    ## полностью -------
-      form_id_and_types_list <- scheme |>
+    get_scheme = function(table_name) {
-        dplyr::filter(!form_type %in% private$exluded_types) |>
-        dplyr::distinct(form_id, form_type) |>
-        tibble::deframe()
-
-      list(
-        key = form_id_and_types_list[1],
-        form = form_id_and_types_list[-1]
-      )
-    },
-
-    # get_key_id = function(table_name) {
-    #   self$extract_forms_id_and_types_from_scheme2(private$schemes_list[[table_name]])
-    # },
-    get_schema = function(table_name) {
       private$schemes_list[[table_name]]
     },
+    ## с полями имеющие значение -------
+    get_scheme_with_values_forms = function(table_name) {
+      private$schemes_list[[table_name]] |>
+        dplyr::filter(!form_type %in% private$excluded_types)
+    },
+
     get_id_type_list = function(table_name) {
 
       # wo main key
       this_key_id <- self$get_key_id(table_name)
 
       private$schemes_list[[table_name]] |>
-        dplyr::filter(!form_type %in% private$exluded_types) |>
+        dplyr::filter(!form_type %in% private$excluded_types) |>
         dplyr::filter(form_id != {{this_key_id}}) |>
         dplyr::distinct(form_id, form_type) |>
         tibble::deframe()
@@ -107,7 +107,7 @@ scheme_R6 <- R6::R6Class(
       private$nested_forms_names
     },
     get_main_form_ui = function() {
-      private$testest
+      private$bslib_rendered_ui
     }
   ),
   private = list(
@@ -115,8 +115,9 @@ scheme_R6 <- R6::R6Class(
     schemes_list = NULL,
     main_key_id = NA,
     nested_forms_names = NA,
-    testest = NA,
+    bslib_rendered_ui = NA,
-    exluded_types = c("inline_table", "nested_forms","description", "description_header"),
+    excluded_types = c("nested_forms", "description", "description_header"),
+    reserved_table_names = c("meta", "log", "main"),
 
     load_scheme_from_xlsx = function(sheet_name) {
 
@@ -125,24 +126,41 @@ scheme_R6 <- R6::R6Class(
         c("subgroup", "form_id", "form_label", "form_type")
       )
 
-      readxl::read_xlsx(private$scheme_file_path, sheet = sheet_name) |>
+      table <- readxl::read_xlsx(private$scheme_file_path, sheet = sheet_name) |>
         # fill NA down
         tidyr::fill(all_of(colnames), .direction = "down") |>
         dplyr::group_by(form_id) |>
         tidyr::fill(c(condition, required), .direction = "down") |>
         dplyr::ungroup()
 
+      duplicate_ids <- table |>
+        dplyr::mutate(rleid = dplyr::consecutive_id(form_id)) |>
+        dplyr::distinct(form_id, rleid) |>
+        dplyr::count(form_id) |>
+        dplyr::filter(n > 1) |>
+        dplyr::pull(form_id)
+      
+      if (length(duplicate_ids) > 0) {
+        cli::cli_abort(c("В схеме '{private$scheme_file_path}' для формы '{sheet_name}' содержатся повторяющиеся id:", paste("-", duplicate_ids)))
+      }
+
+      # проверка на корректные id
+      input_names_with_dash <- unique(table$form_id)[grepl("-", unique(table$form_id))]
+      if (length(input_names_with_dash) > 0) {
+        cli::cli_abort(c("В схеме '{private$scheme_file_path}' в id форм содержатся `-`, может привести к некорректной последующей работой с базой данных", paste("-", input_names_with_dash)))
+      }
+
+      table
     }
   )
 )
 
-# schm <- scheme_R6$new(fs::path("configs/schemas", "schema.xlsx"))
 # object.size(schm)
 # schm$get_key_id("main")
 # schm$get_forms_ids("main")
 # schm$get_all_ids("main")
 
-# schm$get_schema("main")
+# schm$get_scheme("main")
 
 # schm$get_id_type_list("allergo_anamnesis")
 

modules/utils.R

@@ -1,6 +1,6 @@
 #' @export
 make_list_of_pages = function(main_schema, main_key_id) {
-  cli::cli_alert_success("AAAA")
+
   purrr::map(
     .x = unique(main_schema$part),
     .f = \(page_name) {
@@ -162,7 +162,7 @@ render_forms = function(
       choices = choices,
       selected = NULL,
       options = list(
-        create = FALSE,
+        create = TRUE,
         onInitialize = I('function() { this.setValue(""); }')
       )
     )
@@ -177,7 +177,7 @@ render_forms = function(
       selected = NULL,
       multiple = TRUE,
       options = list(
-        create = FALSE,
+        create = TRUE,
         onInitialize = I('function() { this.setValue(""); }')
       )
     )
@@ -264,6 +264,15 @@ update_forms_with_data = function(
   ns
 ) {
   
+  options(box.path = here::here())
+  box::use(modules/data_manipulations[is_this_empty_value])
+
+  # print("-----------------")
+  # cli::cli_inform("form_id: {form_id} | form_type: {form_type}")
+  # print(value)
+  # print(typeof(value))
+  # print(is_this_empty_value(value))
+
   filterd_line <- scheme |>
     dplyr::filter(form_id == {{form_id}})
 
@@ -294,14 +303,46 @@ update_forms_with_data = function(
     new_choices <- unique(c(old_choices, value))
     new_choices <- new_choices[!is.na(new_choices)]
 
-
     shiny::updateSelectizeInput(inputId = form_id, selected = value, choices = new_choices)
-    # shiny::updateSelectizeInput(inputId = form_id, selected = value)
   }
 
   # select_multiple
   # check if value is not NA and split by delimetr
-  if (form_type == "select_multiple" && !is.na(value)) {
+  if (form_type == "select_multiple") {
+    if (is_this_empty_value(value)) {
+      shiny::updateSelectizeInput(inputId = form_id, selected = as.character(0))
+    } else {
+      vars <- stringr::str_split_1(value, local_delimeter)
+
+      # update choices
+      old_choices <- filterd_line$choices
+      new_choices <- unique(c(old_choices, vars))
+      new_choices <- new_choices[!is.na(new_choices)]
+      shiny::updateSelectizeInput(inputId = form_id, selected = vars, choices = new_choices)
+    }
+  }
+
+  # radio buttons
+  if (form_type == "radio") {
+    if (is_this_empty_value(value)) {
+      shiny::updateRadioButtons(inputId = form_id, selected = character(0))
+    } else {
+      # update choices
+      old_choices <- filterd_line$choices
+      new_choices <- unique(c(old_choices, value))
+      new_choices <- new_choices[!is.na(new_choices)]
+
+      shiny::updateRadioButtons(inputId = form_id, selected = value, choices = new_choices)
+    }
+  }
+
+  # checkboxes
+  if (form_type == "checkbox") {
+
+    if (is_this_empty_value(value)) {
+      shiny::updateCheckboxGroupInput(inputId = form_id, selected = character(0))
+    } else {
+
       vars <- stringr::str_split_1(value, local_delimeter)
   
       # update choices
@@ -309,35 +350,11 @@ update_forms_with_data = function(
       new_choices <- unique(c(old_choices, vars))
       new_choices <- new_choices[!is.na(new_choices)]
   
-    shiny::updateSelectizeInput(inputId = form_id, selected = vars, choices = new_choices)
+      shiny::updateCheckboxGroupInput(inputId = form_id, selected = vars, choices = new_choices)
-    # shiny::updateSelectizeInput(inputId = form_id, selected = vars)
     }
 
-  # in other case fill with `character(0)` to proper reseting form
-  if (form_type == "select_multiple" && is.na(value)) {
-    shiny::updateSelectizeInput(inputId = form_id, selected = character(0))
   }
 
-  # radio buttons
-  if (form_type == "radio" && !is.na(value)) {
-    shiny::updateRadioButtons(inputId = form_id, selected = value)
-  }
-  if (form_type == "radio" && is.na(value)) {
-    shiny::updateRadioButtons(inputId = form_id, selected = character(0))
-  }
-
-  # checkboxes
-  if (form_type == "checkbox" && !is.na(value)) {
-    vars <- stringr::str_split_1(value, local_delimeter)
-    shiny::updateCheckboxGroupInput(inputId = form_id, selected = vars)
-  }
-  if (form_type == "checkbox" && is.na(value)) {
-    shiny::updateCheckboxGroupInput(inputId = form_id, selected = character(0))
-  }
-
-  # if (type == "inline_table") {
-  #   message("EMPTY")
-  # }
 }
 
 #' @export
@@ -361,7 +378,7 @@ clean_forms = function(
         form_id   = x_id,
         form_type = x_type,
         value     = get_empty_data(x_type),
-        scheme = schm$get_schema(table_name),
+        scheme = schm$get_scheme(table_name),
         ns = ns
       )
     }

renv.lock

@@ -232,14 +232,14 @@
     },
     "box": {
       "Package": "box",
-      "Version": "1.2.0",
+      "Version": "1.2.2",
       "Source": "Repository",
-      "Repository": "RSPM",
+      "Repository": "CRAN",
       "Requirements": [
         "R",
         "tools"
       ],
-      "Hash": "d94049c1d9446b0abb413fde9e82a505"
+      "Hash": "5fd0a60cdaaea2b97046a82c13e17bfe"
     },
     "bslib": {
       "Package": "bslib",
@@ -318,6 +318,16 @@
       "Repository": "CRAN",
       "Hash": "14eb0596f987c71535d07c3aff814742"
     },
+    "config": {
+      "Package": "config",
+      "Version": "0.3.2",
+      "Source": "Repository",
+      "Repository": "RSPM",
+      "Requirements": [
+        "yaml"
+      ],
+      "Hash": "8b7222e9d9eb5178eea545c0c4d33fc2"
+    },
     "cpp11": {
       "Package": "cpp11",
       "Version": "0.5.1",