feat: работа с орфанными записями

.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/forms.R

@@ -0,0 +1,34 @@
+options(box.path = here::here())
+box::use(
+  modules/utils,
+)
+
+#' @export
+load_data_to_form <- function(
+  df,
+  table_name = "main",
+  mhcs,
+  ns
+) {
+
+  input_types <- unname(mhcs()$get_id_type_list(table_name))
+  input_ids   <- names(mhcs()$get_id_type_list(table_name))
+  if (missing(ns)) ns <- NULL
+
+  # rewrite input forms
+  purrr::walk2(
+    .x = input_types,
+    .y = input_ids,
+    .f = \(x_type, x_id) {
+
+      # updating forms with loaded data
+      utils$update_forms_with_data(
+        form_id   = x_id,
+        form_type = x_type,
+        value = df[[x_id]],
+        scheme = mhcs()$get_scheme(table_name),
+        ns = ns
+      )
+    }
+  )
+}

app/tasks.R

@@ -0,0 +1,466 @@
+
+box::use(
+  shiny[...],
+  bslib[...]
+)
+
+options(box.path = here::here())
+box::use(
+  modules/db,
+  modules/utils,
+  app/forms
+)
+
+#' @export
+server <- function(id, values, scheme, mhcs) {
+
+  ns <- NS(id)
+
+  moduleServer(id, function(input, output, session) {
+
+    # BOOKMARKS SETUP ========================
+    # observe({
+    #   # print(values$current_user)
+    # })
+
+    # functions -------------------
+    ## new tasks ----------------
+    get_default_task <- function() {
+
+      tibble::tibble(
+        task_id = paste0(format(Sys.time(), "%Y%m%d%H%M%S"), "_", values$main_key),
+        task_main_key = values$main_key,
+        task_status = "active",
+        task_title = "НОВАЯ ЗАДАЧА",
+        task_description = "",
+        task_due_date = NA,
+        task_user_created = values$current_user,
+        task_datetime_created = Sys.time(),
+        task_user_last_updated = NA,
+        task_datetime_last_updated = NA,
+        task_user_completed = NA,
+        task_datetime_completed = NA
+      )
+    }
+
+    # logic ---------------------
+    ## modal fun -----
+    show_modal_for_tasks <- function() {
+
+      if (!is.null(values$tasks_data)) {
+
+        tasks_selector <- values$tasks_data |>
+          dplyr::filter(task_status != "completed") |>
+          dplyr::pull(task_id)
+
+        tasks_selector <- unique(c(values$tasks_id, tasks_selector))
+        tasks_selector <- sort(tasks_selector)
+
+        if (length(values$tasks_id) == 0) {
+          values$tasks_id <- if (length(tasks_selector) == 0) NULL else tasks_selector[[1]]
+        }
+
+      } else {
+
+        tasks_selector <- NULL
+
+      }
+
+      # ui --------------------
+      # очень большой костыль
+      subroup_scheme <- mhcs()$get_scheme("tasks") |>
+        dplyr::filter(form_id != "dummy")
+
+      tab <- if (length(tasks_selector) > 0) {
+        bslib::nav_panel(
+          title = "no name provided",
+          purrr::pmap(
+            .l = dplyr::distinct(subroup_scheme, form_id, form_label, form_type),
+            .f = utils$render_forms,
+            main_scheme = subroup_scheme,
+            ns = ns
+          )
+        )
+      } else {
+        bslib::nav_panel("", div("Нет доступных записей.", br(), "Необходимо создать новую запись."))
+      }
+
+      ui <- layout_sidebar(
+        sidebar = tagList(
+          selectizeInput(ns("tasks_id_selector"), label = "ID задачи:", choices = tasks_selector, selected = values$tasks_id),
+          actionButton(ns("tasks_create_new_task"), "Новая задача", icon("plus")),
+          actionButton(ns("tasks_add_autoreview"), "Новая авто-задача (тест)", icon("calendar")),
+          actionButton(ns("tasks_DT_VIEW"), "DT", icon("table"))
+        ),
+        tab
+      )
+    
+      showModal(modalDialog(
+        ui,
+        size = "l",
+        footer = tagList(
+          actionButton(ns("tasks_saving_button"), "Сохранить изменения", icon("floppy-disk"))
+        ),
+        easyClose = TRUE
+      ))
+    }
+
+    ## отображение окна -----------------
+    observeEvent(input$display_task_modal, {
+      
+      if (is.null(values$main_key)) {
+        showNotification("необходимо выбрать запись", type = "error")
+        return()
+      }
+
+      con <- db$make_db_connection(scheme(),"display_task_modal")
+      on.exit(db$close_db_connection(con, "display_task_modal"), add = TRUE)
+
+      values$tasks_data <- if ("tasks" %in% DBI::dbListTables(con)) {
+        DBI::dbGetQuery(con, glue::glue("SELECT * FROM tasks WHERE task_main_key = '{values$main_key}'")) |>
+          dplyr::mutate(dplyr::across(c("task_datetime_created", "task_datetime_last_updated", "task_datetime_completed"), as.POSIXct)) |>
+          dplyr::mutate(dplyr::across(c("task_due_date"), as.Date))
+      } else {
+        NULL
+      }
+
+      values$tasks_id <- NULL
+      show_modal_for_tasks()
+
+    })
+
+    ## изменение выбранной задачи -------
+    observeEvent(input$tasks_id_selector, {
+      req(input$tasks_id_selector)
+      req(values$tasks_id)
+
+      # выбранный ключ в форме - перемещаем в RV
+      values$tasks_id <- input$tasks_id_selector
+
+    })
+
+    ## обновление формы при измененнии id ключа ------
+    observeEvent(values$tasks_id, {
+
+      df <- values$tasks_data |>
+        dplyr::filter(task_id == values$tasks_id)
+
+      forms$load_data_to_form(
+        df         = df,
+        table_name = "tasks",
+        mhcs
+        # ns = ns
+      )
+    })
+
+    ## saving button ------------------------------
+    observeEvent(input$tasks_saving_button, {
+
+      con <- db$make_db_connection(scheme(),"tasks_saving_button")
+      on.exit(db$close_db_connection(con, "tasks_saving_button"), add = TRUE)
+
+      id_and_types_list <- mhcs()$get_id_type_list("tasks")
+      input_types   <- unname(id_and_types_list)
+      input_ids     <- names(id_and_types_list)
+
+      exported_values <- purrr::map2(
+        .x = input_ids,
+        .y = input_types,
+        .f = \(x_id, x_type) {
+
+          input_d <- input[[x_id]]
+
+          # return empty if 0 element
+          if (length(input_d) == 0) {
+            return(utils$get_empty_data(x_type))
+          } else {
+            input_d
+          }
+        }
+      )
+
+      exported_df <- stats::setNames(exported_values, input_ids) |>
+        dplyr::as_tibble()
+
+      df <- values$tasks_data
+
+      df[df$task_id == values$tasks_id,]$task_status                <- exported_df$task_status
+      df[df$task_id == values$tasks_id,]$task_title                 <- exported_df$task_title
+      df[df$task_id == values$tasks_id,]$task_description           <- exported_df$task_description
+      df[df$task_id == values$tasks_id,]$task_due_date              <- exported_df$task_due_date
+      df[df$task_id == values$tasks_id,]$task_user_last_updated     <- values$current_user
+      df[df$task_id == values$tasks_id,]$task_datetime_last_updated <- Sys.time()
+
+      if (exported_df$task_status == "completed") {
+        df[df$task_id == values$tasks_id,]$task_user_completed     <- values$current_user 
+        df[df$task_id == values$tasks_id,]$task_datetime_completed <- Sys.time() 
+      }
+
+      values$tasks_data <- df
+
+      if ("tasks" %in% DBI::dbListTables(con)) {
+        query <- glue::glue("
+          DELETE 
+          FROM tasks 
+          WHERE task_main_key = '{values$main_key}'
+        ")
+        DBI::dbExecute(con, query)
+      }
+
+      DBI::dbWriteTable(con, "tasks", df, append = TRUE)
+
+      update_task_button_count(con, values)
+      showNotification("Задача успешно создана/обновлена", type = "message")
+
+      tasks_selector <- values$tasks_data |>
+        dplyr::filter(task_status != "completed") |>
+        dplyr::pull(task_id)
+
+      selector <- ifelse(!values$tasks_id %in% tasks_selector, tasks_selector[1], values$tasks_id)
+
+      updateSelectInput(inputId = "tasks_id_selector", choices = tasks_selector, selected = selector)
+
+    })
+
+    ## show DT --------------------------
+    observeEvent(input$tasks_DT_VIEW, {
+
+      rename_cols <- tasks_colnames[tasks_colnames %in% colnames(values$tasks_data)]
+      
+      date_cols <- c("task_datetime_created", "task_datetime_completed", "task_datetime_last_updated", "task_due_date")
+      date_cols <- which(colnames(values$tasks_data) %in% date_cols)
+
+      output$dt_tasks <- DT::renderDataTable(
+        DT::datatable(
+          values$tasks_data,
+          caption = 'Table 1: This is a simple caption for the table.',
+          rownames = FALSE,
+          colnames = rename_cols,
+          extensions = c('KeyTable', "FixedColumns"),
+          # editable = 'cell',
+          class = 'cell-border stripe',
+          selection = "none",
+          options = list(
+            dom = 'tip',
+            scrollX = TRUE,
+            fixedColumns = list(leftColumns = 1),
+            keys = TRUE,
+            autoWidth = TRUE,
+            columnDefs = list(
+              list(
+                targets = 3:4,
+                width = '200px',
+                render = htmlwidgets::JS(
+                  "function(data, type, row, meta) {",
+                  "return type === 'display' && data.length > 20 ?",
+                  "'<span title=\"' + data + '\">' + data.substr(0, 20) + '...</span>' : data;",
+                  "}")
+              )
+            )
+          )
+        ) |>
+          DT::formatDate(date_cols, "toLocaleDateString", params = list('ru-RU'))
+      )
+
+      showModal(modalDialog(
+        DT::dataTableOutput(ns("dt_tasks")),
+        size = "xl",
+        # footer = tagList(
+        #   actionButton("nested_form_dt_save", "сохранить изменения")
+        # ),
+        easyClose = TRUE
+      ))
+
+    })
+
+    ## создание новой задачи -------------
+    observeEvent(input$tasks_create_new_task, {
+      new_task <- get_default_task()
+      
+      values$tasks_data <- rbind(values$tasks_data, new_task)
+      values$tasks_id <- new_task$task_id
+
+      tasks_selector <- values$tasks_data |>
+        dplyr::filter(task_status != "completed") |>
+        dplyr::pull(task_id)
+
+      updateSelectInput(inputId = "tasks_id_selector", choices = tasks_selector, selected = values$tasks_id)
+      removeModal()
+      show_modal_for_tasks()
+    })
+    
+    ## создание новой авто-задачи -------------
+    observeEvent(input$tasks_add_autoreview, {
+      new_task <- get_default_task()
+
+      new_task$task_title       <- "autoreview"
+      new_task$task_description <- "напоминание об актуализации данных"
+      new_task$task_due_date <- Sys.Date() + 28
+      
+      values$tasks_data <- rbind(values$tasks_data, new_task)
+      values$tasks_id <- new_task$task_id
+
+      tasks_selector <- values$tasks_data |>
+        dplyr::filter(task_status != "completed") |>
+        dplyr::pull(task_id)
+
+      updateSelectInput(inputId = "tasks_id_selector", choices = tasks_selector, selected = values$tasks_id)
+      removeModal()
+      show_modal_for_tasks()
+    })
+
+    # review задач ----------------
+    ### все активные задачи ------------
+    observeEvent(input$show_dt_all, {
+
+      con <- db$make_db_connection(scheme(),"display_task_modal")
+      on.exit(db$close_db_connection(con, "display_task_modal"), add = TRUE)
+
+      values$tasks_data <- DBI::dbGetQuery(con, glue::glue("SELECT * FROM tasks WHERE task_status = 'active'")) |>
+        dplyr::mutate(dplyr::across(c("task_datetime_created", "task_datetime_last_updated", "task_datetime_completed"), as.POSIXct)) |>
+        dplyr::mutate(dplyr::across(c("task_due_date"), as.Date))
+
+      display_tasks_dt_review()
+    })
+
+    ### задачи для текущего дня ------------
+    observeEvent(input$show_dt_today, {
+
+      con <- db$make_db_connection(scheme(),"display_task_modal")
+      on.exit(db$close_db_connection(con, "display_task_modal"), add = TRUE)
+
+      values$tasks_data <- DBI::dbGetQuery(con, glue::glue("SELECT * FROM tasks WHERE task_status = 'active' AND task_due_date = {as.integer(Sys.Date())}")) |>
+        dplyr::mutate(dplyr::across(c("task_datetime_created", "task_datetime_last_updated", "task_datetime_completed"), as.POSIXct)) |>
+        dplyr::mutate(dplyr::across(c("task_due_date"), as.Date))
+
+      display_tasks_dt_review()
+    })
+
+    ### просроченные ------------
+    observeEvent(input$show_dt_overdue, {
+
+      con <- db$make_db_connection(scheme(),"display_task_modal")
+      on.exit(db$close_db_connection(con, "display_task_modal"), add = TRUE)
+
+      values$tasks_data <- DBI::dbGetQuery(con, glue::glue("SELECT * FROM tasks WHERE task_status = 'active' AND task_due_date < {as.integer(Sys.Date())}")) |>
+        dplyr::mutate(dplyr::across(c("task_datetime_created", "task_datetime_last_updated", "task_datetime_completed"), as.POSIXct)) |>
+        dplyr::mutate(dplyr::across(c("task_due_date"), as.Date))
+
+      display_tasks_dt_review()
+    })
+
+    ### modal -----
+    display_tasks_dt_review <- function() {
+
+      values$tasks_data <- values$tasks_data |>
+        dplyr::select(task_id:task_datetime_last_updated)
+
+      rename_cols <- tasks_colnames[tasks_colnames %in% colnames(values$tasks_data)]
+      
+      date_cols <- c("task_datetime_created", "task_datetime_completed", "task_datetime_last_updated", "task_due_date")
+      date_cols <- which(colnames(values$tasks_data) %in% date_cols)
+
+      output$dt_todays_tasks <- DT::renderDataTable(
+        DT::datatable(
+          values$tasks_data,
+          caption = 'Table 1: This is a simple caption for the table.',
+          rownames = FALSE,
+          colnames = rename_cols,
+          extensions = c("FixedColumns"),
+          # editable = 'cell',
+          selection = "single",
+          options = list(
+            dom = 'tip',
+            scrollX = TRUE,
+            fixedColumns = list(leftColumns = 1),
+            autoWidth = TRUE,
+            columnDefs = list(
+              list(
+                targets = 3:4,
+                width = '200px',
+                render = htmlwidgets::JS(
+                  "function(data, type, row, meta) {",
+                  "return type === 'display' && data.length > 20 ?",
+                  "'<span title=\"' + data + '\">' + data.substr(0, 20) + '...</span>' : data;",
+                  "}")
+              )
+            )
+          )
+        ) |>
+        DT::formatDate(date_cols, "toLocaleDateString", params = list('ru-RU'))
+      )
+
+      showModal(modalDialog(
+        DT::dataTableOutput(ns("dt_todays_tasks")),
+        size = "xl",
+        footer = tagList(
+          actionButton(ns("jump_to_main_key"), "перейти к id", icon("right-to-bracket"))
+        ),
+        easyClose = TRUE
+      ))
+
+    }
+
+    ### jump to main_key ---------
+    observeEvent(input$jump_to_main_key, {
+
+      if (is.null(input$dt_todays_tasks_rows_selected)) {
+        showNotification("необходимо выбрать задачу", type = "error")
+      } else {
+
+        # get key
+        main_key_to_jump <- values$tasks_data[input$dt_todays_tasks_rows_selected,]$task_main_key
+        values$main_key <- main_key_to_jump
+
+        removeModal()
+
+      }
+    })
+
+  })
+}
+
+#' @export
+update_task_button_count <- function(con, values, ns) {
+
+  inputID <- "display_task_modal"
+  if (!missing(ns)) inputID <- ns(inputID)
+  
+
+  # если ключ не определен - выход из функции
+  if (is.null(values$main_key)) {
+
+    updateActionButton(inputId = inputID, label = "Задачи")
+    return()
+
+  }
+
+  # при наличии таблицы - полу
+  if ("tasks" %in% DBI::dbListTables(con)) {
+
+    tasks_num <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT ('task_id') FROM tasks WHERE task_main_key = '{values$main_key}' AND task_status = 'active'")) |>
+      dplyr::pull()
+
+    if (tasks_num > 0) {
+      updateActionButton(inputId = inputID, label = paste("активных задач:", tasks_num))
+    } else {
+      updateActionButton(inputId = inputID, label = "Задачи: нет активных")
+    }
+  }
+
+}
+
+tasks_colnames <- c(
+  "id задачи"       = "task_id",
+  "id записи"       = "task_main_key",
+  "статус"          = "task_status",
+  "задача"          = "task_title",
+  "описание"        = "task_description",
+  "срок выполнения" = "task_due_date",
+  "создана"         = "task_user_created",
+  "дата создания"   = "task_datetime_created",
+  "обновлено"       = "task_user_last_updated",
+  "дата обновления" = "task_datetime_last_updated",
+  "завершено"       = "task_user_completed",
+  "дата выполнения" = "task_datetime_completed"
+)

config.yml

@@ -0,0 +1,20 @@
+default:
+  form_app_version: 0.16.0
+  form_id: new_formy
+  form_name: NEW FORMY
+
+prod:
+  form_app_configure_path: "."
+  form_auth_enabled: false
+  form_schemes:
+    example_of_scheme: Тестовая база данных
+    main_register: АВЗ и АМИЛОИОДОЗЫ
+
+devel:
+  form_app_configure_path: _devel/new_bases
+  form_auth_enabled: false
+  form_app_version: 0.16.0 dev
+  form_schemes:
+    antifib: антифибротическая
+    d2tra_t: D2TRA_test
+    

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,9 +1,8 @@
+options(box.path = here::here())
+box::use(modules/data_manipulations[is_this_empty_value])
 
 #' @export
-init_val <- function(scheme, ns) {
+init_val = function(scheme, ns) {
-
-  options(box.path = here::here())
-  box::use(modules/data_manipulations[check_for_empty_data])
 
   iv <- shinyvalidate::InputValidator$new()
 
@@ -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,45 @@ 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 +98,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 +114,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,28 +2,35 @@
 #' @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
 #' @description 
 #' Function to close connection to db, disigned to easy dubugging and
 #' hide warnings.
-close_db_connection <- function(con, where = "") {
+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
 #' @description
 #' Проверить если таблица есть в базе данных и инициировать ее, если от
-check_if_table_is_exist_and_init_if_not <- function(
+check_if_table_is_exist_and_init_if_not = function(
   schm,
   con = rlang::env_get(rlang::caller_env(), nm = "con")
 ) {
@@ -39,14 +46,13 @@ check_if_table_is_exist_and_init_if_not <- function(
 
       if (table_name %in% DBI::dbListTables(con)) {
 
-        cli::cli_inform(c("*" = "таблица есть такая: '{table_name}'"))
-
         # если таблица существует, производим проверку структуры таблицы
         compare_existing_table_with_schema(
           table_name = table_name,
           schm = schm
         )
 
+      # инициализируем все таблицы
       } else {
 
         if (table_name == "main") {
@@ -56,6 +62,7 @@ check_if_table_is_exist_and_init_if_not <- function(
               .before = 1
             )
         }
+
         if (table_name != "main") {
           dummy_df <- get_dummy_df(forms_id_type_list) |>
             dplyr::mutate(
@@ -79,7 +86,7 @@ check_if_table_is_exist_and_init_if_not <- function(
 
 #' @description
 #' Возращает пустое значение для каждого типа формы
-get_dummy_data <- function(type) {
+get_dummy_data = function(type) {
 
   if (type %in% c("text", "select_one", "select_multiple")) return("dummy")
   if (type %in% c("radio", "checkbox")) return("dummy")
@@ -92,7 +99,7 @@ get_dummy_data <- function(type) {
 #' @description
 #' Генерация пустого датасета с пустыми значениями соответствующие
 #' типу данных
-get_dummy_df <- function(forms_id_type_list) {
+get_dummy_df = function(forms_id_type_list) {
 
   options(box.path = here::here())
   box::use(modules/utils)
@@ -108,12 +115,14 @@ get_dummy_df <- function(forms_id_type_list) {
 #' @description
 #' Сравнение полей в существующей в базе данных таблице и попытка
 #' коррекции таблицы
-compare_existing_table_with_schema <- function(
+compare_existing_table_with_schema = function(
   table_name,
   schm,
   con = rlang::env_get(rlang::caller_env(), nm = "con")
 ) {
 
+  cli::cli_progress_step("проверка таблицы в базе данных: '{table_name}'")
+
   main_key  <- schm$get_main_key_id
   key_id    <- schm$get_key_id(table_name)
   forms_ids <- schm$get_forms_ids(table_name)
@@ -176,7 +185,7 @@ compare_existing_table_with_schema <- function(
 }
 
 #' @export
-write_df_to_db <- function(
+write_df_to_db = function(
   df, 
   table_name, 
   schm,
@@ -185,12 +194,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 +208,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") {
@@ -225,7 +236,7 @@ write_df_to_db <- function(
 
 #' @export
 #' reading tables from db by name and id ========
-read_df_from_db_by_id <- function(
+read_df_from_db_by_id = function(
   table_name,
   schm,
   main_key_value, 
@@ -264,7 +275,7 @@ read_df_from_db_by_id <- function(
 }
 
 #' @export
-get_keys_from_table <- function(table_name, schm, con) {
+get_keys_from_table = function(table_name, schm, con) {
 
   main_key_id <- schm$get_main_key_id
   DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT {main_key_id} FROM {table_name}")) |>
@@ -273,7 +284,7 @@ get_keys_from_table <- function(table_name, schm, con) {
 }
 
 #' @export
-get_nested_keys_from_table <- function(table_name, schm, main_key_value, con) {
+get_nested_keys_from_table = function(table_name, schm, main_key_value, con) {
 
   main_key_id <- schm$get_main_key_id
   key_id <- schm$get_key_id(table_name)
@@ -286,7 +297,7 @@ get_nested_keys_from_table <- function(table_name, schm, main_key_value, con) {
 
 ### HELPERS ---------
 #' @export
-excel_to_db_dates_converter <- function(date) {
+excel_to_db_dates_converter = function(date) {
 
   if (is.na(date)) return(NA)
   # cli::cli_inform("date: {date} | nchar: {nchar(date)} | typeof: {typeof(date)}")
@@ -327,3 +338,126 @@ 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_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) == 0) {
+        file.copy(db_full_path, todays_backup)
+        cli::cli_alert_success("создан {schedule_name}-бэкап для '{db_name}'")
+        return()
+      }
+
+      # если количество существующих бэкапов превышает установленный лимит, удаляем лишнее
+      if (length(existed_files) >= backups_limit) {
+        file.remove(utils::tail(existed_files, length(existed_files) - backups_limit))
+      }
+
+      # если количество существующих бэкапов равно имеющемуся и пора делать бэкап - делаем бэкап, удаляем послендий файл
+      if (dates[1] + schedule_days == Sys.Date()) {
+
+        file.copy(db_full_path, todays_backup)
+        cli::cli_alert_success("создан {schedule_name}-бэкап для '{db_name}'")
+
+      }
+    }
+  )
+}
+
+#' @export
+db_clean_orphans = function(schm, con) {
+
+  main_key      <- schm$get_main_key_id
+  nested_tables <- schm$nested_tables_names
+
+  all_main_keys <- DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT {main_key} FROM main"))
+  all_main_keys <- dplyr::pull(all_main_keys)
+
+  purrr::walk(
+    .x = nested_tables,
+    .f = \(table_name) clear_orphans(table_name = table_name, main_key = main_key, all_main_keys = all_main_keys, con = con)
+  )
+
+  clear_orphans(table_name = "tasks", main_key = "task_main_key", all_main_keys = all_main_keys, con = con, drop_na_keys = FALSE)
+  clear_orphans(table_name = "log", main_key = "key", all_main_keys = all_main_keys, con = con, drop_na_keys = FALSE)
+
+}
+
+clear_orphans <- function(
+  table_name,
+  main_key,
+  all_main_keys,
+  con,
+  drop_na_keys = TRUE
+) {
+
+  if (!table_name %in% DBI::dbListTables(con)) return(invisible())
+
+  all_main_keys_from_nested <- DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT {main_key} FROM {table_name}"))
+  all_main_keys_from_nested <- dplyr::pull(all_main_keys_from_nested)
+
+  if (!drop_na_keys) {
+    all_main_keys_from_nested <- all_main_keys_from_nested[!is.na(all_main_keys_from_nested)]
+  }
+
+  if (all(all_main_keys_from_nested %in% all_main_keys)) {
+    cli::cli_alert_success("Все ключи в таблице '{table_name}' соответствуют действующим")
+  } else {
+
+    orphaned_keys <- all_main_keys_from_nested[!all_main_keys_from_nested %in% all_main_keys]
+    cli::cli_alert_warning(c("В таблице '{table_name}' найдены орфанные записи для следующих ID: ", paste("\n  -", orphaned_keys)))
+    
+    orphaned_keys <- paste0("'", orphaned_keys, "'", collapse = ", ")
+    del_query <- glue::glue("DELETE FROM {table_name} WHERE {main_key} IN ({orphaned_keys})")
+    deleted <- DBI::dbExecute(con, del_query)
+
+    if (drop_na_keys) {
+      deleted <- deleted + DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key} IS NULL"))
+    }
+
+    cli::cli_alert_success("Из таблицы '{table_name}' было удалено {deleted} орфанных записей")
+
+  }
+
+}

modules/global_options.R

@@ -1,17 +1,31 @@
 #' @export
 #' @description костыли для упрощения работы себе
-set_global_options <- function(
+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,
     ...
@@ -19,42 +33,72 @@ set_global_options <- function(
 }
 
 #' @export
-check_and_init_scheme <- function() {
+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])
+
+  # список файлов, изменение которых, приведут к переинициализиации схемы
+  files_to_watch <- c(
+    "config.yml",
+    "modules/scheme_generator.R",
+    "modules/utils.R"
+  )
+
+  scheme_names <- names(config::get()$form_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
+  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) {
-init_scheme <- function(scheme_file) {
 
   options(box.path = here::here())
   box::use(
@@ -62,12 +106,45 @@ 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(
+    .x = scheme_file,
+    .y = names(scheme_file),
+    \(x, y) {
+
+      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)
 
-  saveRDS(schm, "scheme.rds")
+      # удаление орфанных записей
+
+      db$db_clean_orphans(schm = schm, con = 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) {
@@ -32,17 +40,35 @@ scheme_R6 <- R6::R6Class(
         }
       )
 
+      # отдельно для тасков
+      private$schemes_list[["tasks"]] <- tibble::tribble(
+        ~ form_id,            ~form_type,    ~form_label,              ~form_description,  ~choices, 
+        "dummy",              "text",        "dummy",                  "dummy",            NA,
+        "task_status",        "select_one",  "Статус задачи",          NA,                 "active",
+        "task_status",        "select_one",  "Статус задачи",          NA,                 "completed",
+        "task_status",        "select_one",  "Статус задачи",          NA,                 "deleted",
+        "task_title",         "text",        "Название задачи",        NA,                 NA,
+        "task_description",   "text",        "Описание задачи",        "краткое описание", "3",
+        "task_due_date",      "date",        "Дата выполнения задачи", NA,                 NA,
+      ) |>
+        dplyr::mutate(condition = NA)
+
       # extract main key
       private$main_key_id <- self$get_key_id("main")
 
       box::use(modules/utils)
-      private$testest     <- utils$make_list_of_pages(private$schemes_list[["main"]], private$main_key_id)
+      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,
+        height = NULL
+      )
     },
 
     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)
 
@@ -60,32 +86,25 @@ 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()
@@ -102,7 +121,7 @@ scheme_R6 <- R6::R6Class(
       private$nested_forms_names
     },
     get_main_form_ui = function() {
-      private$testest
+      private$bslib_rendered_ui
     }
   ),
   private = list(
@@ -110,8 +129,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", "tasks"),
 
     load_scheme_from_xlsx = function(sheet_name) {
 
@@ -120,24 +140,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) {
+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) {
@@ -22,7 +22,7 @@ make_list_of_pages <- function(main_schema, main_key_id) {
 }
 
 #' @export
-make_panels <- function(scheme) {
+make_panels = function(scheme) {
 
   cards <- purrr::map(
     .x = unique(scheme$subgroup),
@@ -61,7 +61,7 @@ make_panels <- function(scheme) {
 }
 
 #' @export
-render_forms <- function(
+render_forms = function(
   form_id,
   form_label,
   form_type,
@@ -135,7 +135,8 @@ render_forms <- function(
     form <- shiny::textAreaInput(
       inputId = form_id,
       label = label,
-      rows = 1
+      rows = 1,
+      resize = "none"
     )
   }
 
@@ -162,7 +163,7 @@ render_forms <- function(
       choices = choices,
       selected = NULL,
       options = list(
-        create = FALSE,
+        create = TRUE,
         onInitialize = I('function() { this.setValue(""); }')
       )
     )
@@ -177,7 +178,7 @@ render_forms <- function(
       selected = NULL,
       multiple = TRUE,
       options = list(
-        create = FALSE,
+        create = TRUE,
         onInitialize = I('function() { this.setValue(""); }')
       )
     )
@@ -242,7 +243,7 @@ render_forms <- function(
 #' @export
 #' @description
 #' Функция возращает пустое значение для каждого типа формы
-get_empty_data <- function(type) {
+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))
@@ -255,7 +256,7 @@ get_empty_data <- function(type) {
 #' @param type - type of form;
 #' @param value - value to update;
 #' @param local_delimeter - delimeter to split file
-update_forms_with_data <- function(
+update_forms_with_data = function(
   form_id,
   form_type,
   value,
@@ -264,6 +265,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 +304,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,39 +351,15 @@ 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
-clean_forms <- function(
+clean_forms = function(
   table_name,
   schm, 
   ns
@@ -361,10 +379,9 @@ 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",