0.18.3

Reviewed-on: madeliri/shiny_form#1

.Rprofile

@@ -4,9 +4,7 @@ source("renv/activate.R")
 (function() {
 
   paths <- c(
-    "FORM_AUTH_ENABLED",
+    "AUTH_DB_KEY"
-    "FORM_VERSION",
-    "FORM_TITLE"
   )
 
   lines <- paths[Sys.getenv(paths) == ""]
@@ -19,3 +17,28 @@ source("renv/activate.R")
     ))
   }
 })()
+
+(function() {
+
+  if (Sys.getenv("R_CONFIG_ACTIVE") == "") {
+    Sys.setenv(R_CONFIG_ACTIVE = "prod")
+    cli::cli_inform(c(
+      "i" = "Не указана конфигурация по умолчанию, автоматически установлен 'prod'. Для изменения конфигурации добавьте в {.file .Renviron}:"
+    ))
+    cli::cli_code(paste0("R_CONFIG_ACTIVE", "="))
+
+  }
+  Sys.setenv(R_CONFIG_FILE = "config/config.yml")
+
+})()
+
+
+# при первом запуске скопировать пример конфига
+(function() {
+
+  if (!file.exists("config/config.yml")) {
+    file.copy("config/config_example.yml", "config/config.yml")
+  }
+
+})()
+

.gitignore

@@ -1,7 +1,9 @@
 /renv
 /temp
+/_devel
+/all_bases
 
-scheme.rds
+config/config.yml
 
 .Renviron
 .DS_Store

CHANGELOG.md

@@ -1,3 +1,39 @@
+### 0.18.2 - 0.18.3 (2026-06-18)
+##### features
+- возможность отражение лога действий по базам (для администраторов) и отдельно для каждой записи (сгруппированы по уникальным действиям)
+- возможность экспорта таблицы со списком значений не прошедшие валидацию согласно схеме (для администраторов)
+
+##### refactor
+- перестройка структуры репозитория
+
+### 0.18.1 (2026-06-08)
+##### fix
+- правильный экспорт текстовых данных
+
+### 0.18.0 (2026-06-06)
+##### features
+- возможность отрганичить доступ к базам данных для отдельных пользователей
+
+### 0.17.0 (2026-04-24)
+##### features
+- модуль с задачами: для каждой записи в базе можно создать задачи, на главном экране отображается общее количество активных задач, по сроку выполнения на сегодня и просроченные задачи;
+- проверка на наличие орфанных записей в базе (сверка существующих ключей из главной таблицы `main` с каждой вложенной таблицей)
+
+##### changes
+- определение активных схем - теперь в файле `config.yml`
+
+### 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;

R/app/forms.R

@@ -0,0 +1,34 @@
+options(box.path = here::here())
+box::use(
+  R/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
+      )
+    }
+  )
+}

R/app/logs.R

@@ -0,0 +1,129 @@
+box::use(
+  shiny[...],
+  bslib[...]
+)
+
+options(box.path = here::here())
+box::use(
+  R/modules/db,
+  R/modules/utils,
+  R/app/forms
+)
+
+#' @export
+server <- function(id, values, scheme, mhcs) {
+
+  ns <- NS(id)
+
+  moduleServer(id, function(input, output, session) {
+
+    # отображение DT-таблицы со списком последних действий
+    observeEvent(input$show_last_actions, {
+
+      con <- db$make_db_connection(scheme(),"show_last_actions")
+      on.exit(db$close_db_connection(con, "show_last_actions"), add = TRUE)
+
+      log_df <- DBI::dbReadTable(con, "log")
+
+      # новые записи вначале, формат даты с временем
+      log_df <- log_df |>
+        dplyr::arrange(dplyr::desc(date)) |>
+        dplyr::mutate(date = format(as.POSIXct(date), "%d.%m.%Y %H:%M"))
+
+      output$dt_logs <- DT::renderDataTable(
+        DT::datatable(
+          log_df,
+          # caption = 'Table 1: This is a simple caption for the table.',
+          rownames = FALSE,
+          colnames = logs_colnames,
+          extensions = c('KeyTable', "FixedColumns"),
+          # editable = 'cell',
+          class = 'cell-border stripe',
+          selection = "single",
+          options = list(
+            # dom = 'tipf',
+            scrollX = TRUE,
+            fixedColumns = list(leftColumns = 1),
+            keys = TRUE,
+            autoWidth = TRUE,
+            columnDefs = list(
+              list(width = "150px", targets = c(0,6)),
+              list(width = "110px", targets = c(1:4))
+            )
+          )
+        )
+      )
+
+      showModal(modalDialog(
+        DT::dataTableOutput(ns("dt_logs")),
+        size = "xl",
+        # footer = tagList(
+        #   actionButton("nested_form_dt_save", "сохранить изменения")
+        # ),
+        easyClose = TRUE
+      ))
+
+    })
+
+    # observe({
+    #   print(input$dt_logs_rows_selected)
+    # })
+
+    output$display_log <- renderUI({
+      req(values$main_key)
+
+      # получение логов
+      con <- db$make_db_connection(scheme(),"display_log")
+      on.exit(db$close_db_connection(con, "display_log"), add = TRUE)
+
+      query <- sprintf("SELECT * FROM \"log\" WHERE key = '%s'", values$main_key)
+      log_df_for_id <- DBI::dbGetQuery(con, query)
+
+      if (nrow(log_df_for_id) > 0) {
+
+        lines <- log_df_for_id |>
+          dplyr::mutate(
+            date = as.POSIXct(date),
+            date = date + lubridate::hours(3), # fix datetime
+            date_day = as.Date(date)
+          ) |>
+          dplyr::mutate(cons_actions = dplyr::consecutive_id(action, user)) |>
+          dplyr::mutate(n_actions = dplyr::row_number(), .by = c(cons_actions, user, action, date_day)) |>
+          dplyr::slice(which.max(n_actions), .by = c(user, action, date_day)) |>
+          dplyr::arrange(date) |>
+          dplyr::mutate(string_to_print = sprintf(
+            "<b>[%s %s]</b> %s: %s (%s)",
+            format(date, "%d.%m.%y"),
+            format(date, "%H:%M"),
+            user,
+            action,
+            n_actions
+          )) |>
+          dplyr::pull(string_to_print) |>
+          paste(collapse = "</br>")
+
+      } else {
+        lines <- ""
+      }
+
+      div(
+        strong("Последние действия:"),
+        br(),
+        HTML(lines),
+        style = "font-size:10px;"
+      )
+
+    })
+
+  })
+}
+
+logs_colnames <- c(
+  "время"        = "date",
+  "пользователь" = "user",
+  "приложение"   = "app_id",
+  "версия"       = "app_ver",
+  "ip"           = "remote_addr",
+  "ID записи"    = "key",
+  "действие"     = "action"
+)

R/app/tasks.R

@@ -0,0 +1,474 @@
+box::use(
+  shiny[...],
+  bslib[...]
+)
+
+options(box.path = here::here())
+box::use(
+  R/modules/db,
+  R/modules/utils,
+  R/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 == "active") |>
+          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)
+
+      if (!values$main_key %in% db$get_keys_from_table("main", mhcs(), con)) {
+        showNotification("Невозможно создать задачу для данного ID (нет в базе)", type = "error")
+        return()
+      }
+
+      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) |>
+        dplyr::arrange(task_due_date)
+
+      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',
+          class = 'cell-border stripe',
+          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"
+)

R/modules/data_validation.R

@@ -0,0 +1,249 @@
+options(box.path = here::here())
+box::use(
+  R/modules/data_manipulations[is_this_empty_value]
+)
+
+#' @export
+init_val = function(scheme, ns) {
+
+  iv <- shinyvalidate::InputValidator$new()
+
+  # если передана функция с пространством имен, то происходит модификация id
+  if (!missing(ns)) {
+    scheme <- scheme |>
+      dplyr::mutate(form_id = ns(form_id))
+  }
+
+  # формируем список id - тип
+  inputs_simple_list <- scheme |>
+    dplyr::filter(!form_type %in% c("nested_forms", "description", "description_header")) |>
+    dplyr::distinct(form_id, form_type) |>
+    tibble::deframe()
+
+  # add rules to all inputs
+  purrr::walk(
+    .x = names(inputs_simple_list),
+    .f = \(x_input_id) {
+
+      form_type <- inputs_simple_list[[x_input_id]]
+
+      choices <- dplyr::filter(scheme, form_id == {{x_input_id}}) |>
+        dplyr::pull(choices)
+
+      val_required <- dplyr::filter(scheme, form_id == {{x_input_id}}) |>
+        dplyr::distinct(required) |>
+        dplyr::pull(required)
+
+      # for `number` type: if in `choices` column has values then parsing them to range validation
+      # value `0; 250` -> transform to rule validation value from 0 to 250
+      if (form_type == "number") {
+
+        iv$add_rule(x_input_id, val_is_a_number)
+
+        # проверка на соответствие диапазону значений
+        if (!is.na(choices)) {
+          # разделить на несколько елементов
+          ranges <- as.integer(stringr::str_split_1(choices, "; "))
+
+          # проверка на кол-во значений
+          if (length(ranges) > 3) {
+            warning("Количество переданных элементов'", x_input_id, "' > 2")
+          } else {
+            iv$add_rule(x_input_id, val_number_within_a_range, ranges = ranges)
+          }
+        }
+      }
+
+      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)
+
+  # замена разделителя десятичных цифр
+  x <- stringr::str_replace(x, ",", ".")
+
+  # check for currect value
+  if (dplyr::between(as.double(x), ranges[1], ranges[2])) {
+    NULL
+  } else {
+    glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.")
+  }
+}
+
+# списки ---------------------------------------------------------
+## являются ли выбранные значения допустимы (согласно файлу схемы)
+val_choice_within_a_dict = function(x, choices) {
+
+  if (length(x) == 1) {
+    if (is_this_empty_value(x)) return(NULL)
+  }
+
+  # проверка на соответствие вариантов схеме ---------
+  compare_to_dict <- (x %in% choices)
+  if (!all(compare_to_dict)) {
+
+    text <- paste0("'",x[!compare_to_dict],"'", collapse = ", ")
+    glue::glue("варианты, не соответствующие схеме: {text}")
+  }
+}
+
+# ЭКСПОРТ ДАННЫХ ДЛЯ ВАЛИДАЦИИ
+#' @export
+validate_value_for_form <- function(data_to_check, form_type, choices, val_required) {
+
+  res <- NULL
+  # for `number` type: if in `choices` column has values then parsing them to range validation
+  # value `0; 250` -> transform to rule validation value from 0 to 250
+  if (form_type == "number") {
+
+    res <- val_is_a_number(data_to_check)
+    if(!is.null(res)) return(res)
+
+    # проверка на соответствие диапазону значений
+    if (!is.na(choices)) {
+
+      # разделить на несколько елементов
+      ranges <- as.integer(stringr::str_split_1(choices, "; "))
+
+      # проверка на кол-во значений
+      if (length(ranges) > 3) {
+        warning("Количество переданных элементов'", x_input_id, "' > 2")
+      } else {
+
+        res <- val_number_within_a_range(data_to_check, ranges = ranges)
+        if (!is.null(res)) return(res)
+
+      }
+    }
+  }
+
+  if (form_type %in% c("select_multiple", "select_one", "radio", "checkbox")) {
+
+    if (!is_this_empty_value(data_to_check)) {
+      split_data <- stringr::str_split_1(data_to_check, "; ")
+    } else {
+      split_data <- NA
+    }
+
+    res <- val_choice_within_a_dict(split_data, choices = choices)
+    if(!is.null(res)) return(res)
+  }
+
+  # if in `required` column value is `1` apply standart validation
+  if (!is.na(val_required) && val_required == 1) {
+
+    if (is_this_empty_value(data_to_check)) {
+
+      res <- "Необходимо заполнить."
+      if(!is.null(res)) return(res)
+
+    } 
+
+  }
+
+  if(is.null(res)) return(NA)
+}
+
+#' @export
+get_table_with_data_validation_info <- function(schm, con) {
+
+  # итерациям по всем таблицам
+  purrr::map(
+    purrr::set_names(schm$all_tables_names),
+    .f = \(table_name) {
+
+      scheme <- schm$get_scheme(table_name)
+      data   <- DBI::dbReadTable(con, table_name)
+
+      inputs_simple_list <- schm$get_id_type_list(table_name)
+
+      main_key <- schm$get_main_key_id
+      key      <- schm$get_key_id(table_name)
+
+      # итерация по всем form_id в текущей таблице
+      ff <- purrr::map2(
+        .x = names(inputs_simple_list),
+        .y = unname(inputs_simple_list),
+        .f = \(x_input_id, y_form_type) {
+
+          this_id_scheme <- dplyr::filter(scheme, form_id == {{x_input_id}})
+
+          choices      <- this_id_scheme$choices
+          val_required <- unique(this_id_scheme$required)
+
+          # extract data
+          data_to_check <- data[[x_input_id]]
+          main_keys     <- data[[main_key]]
+          keys          <- data[[key]]
+          iter          <- purrr::set_names(data_to_check, keys)
+
+          # cli::cli_inform("~  input_id: {x_input_id} | type: {form_type} | value: {data_to_check}")
+          validation_info <- purrr::map(iter, validate_value_for_form, y_form_type, choices, val_required)
+
+          df_with_result_and_validation_for_id <- tibble::enframe(validation_info, name = key, value = "value") |>
+            tidyr::unnest(cols = c(value))
+
+          # если главный ключ и ключ для таблицы не одно и тоже, добавление главного ключа в таблицу
+          if (main_key != key) {
+            df_with_result_and_validation_for_id[main_key] <- main_keys
+          }
+
+          df_with_result_and_validation_for_id |>
+            dplyr::mutate(form_id = x_input_id)
+
+        }) |>
+        purrr::list_rbind()
+
+      ff |>
+        dplyr::distinct() |>
+        dplyr::filter(!is.na(value)) |>
+        # данные схемы для 'читабельности информации'
+        dplyr::left_join(
+          y = scheme |> dplyr::distinct(form_id, form_label) |> dplyr::mutate(nr = dplyr::row_number()),
+          by = dplyr::join_by(form_id),
+        ) |>
+        # сортировка (main_key, затем id формы - по порядку в схеме)
+        dplyr::arrange(!!rlang::sym(main_key), !!rlang::sym(main_key), nr) |>
+        dplyr::select(
+          !!rlang::sym(main_key), !!rlang::sym(main_key),
+          form_id, 
+          form_label,
+          value
+        )
+
+      }
+    )
+
+}
+

R/modules/db.R

@@ -3,8 +3,14 @@
 #' @description Function to open connection to db, disigned to easy dubugging.
 #' @param where text mark to distingiush calss
 make_db_connection = function(scheme, where = "") {
-  if (getOption("APP.DEBUG", FALSE)) message("=== DB CONNECT ", where)
+
-  DBI::dbConnect(RSQLite::SQLite(), fs::path("db", scheme, ext = "sqlite"))
+  DBI::dbConnect(RSQLite::SQLite(), fs::path(
+    config::get("form_app_configure_path"),
+    "db",
+    scheme, 
+    ext = "sqlite"
+  ))
+
 }
 
 #' @export
@@ -12,12 +18,14 @@ make_db_connection = function(scheme, 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,14 +47,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 +63,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(
@@ -95,7 +103,7 @@ get_dummy_data = function(type) {
 get_dummy_df = function(forms_id_type_list) {
 
   options(box.path = here::here())
-  box::use(modules/utils)
+  box::use(R/modules/utils)
 
   purrr::map(
     .x = forms_id_type_list,
@@ -114,6 +122,8 @@ compare_existing_table_with_schema = function(
   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)
@@ -126,7 +136,7 @@ compare_existing_table_with_schema = function(
   }
 
   options(box.path = here::here())
-  box::use(modules/utils)
+  box::use(R/modules/utils)
 
   # checking if db structure in form compatible with alrady writed data (in case on changig form)
   if (identical(colnames(DBI::dbReadTable(con, table_name)), all_ids_from_schema)) {
@@ -191,7 +201,8 @@ write_df_to_db = function(
 
   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))
+  # other_cols     <- which(colnames(df) %in% c(date_columns, number_columns))
+  other_cols     <- colnames(df)[!(colnames(df) %in% c(date_columns, number_columns))]
 
   df <- df |>
     dplyr::mutate(
@@ -199,12 +210,9 @@ 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),
+      dplyr::across(tidyselect::all_of({{other_cols}}), \(x) dplyr::if_else(x == "", as.character(NA), as.character(x)))
     )
 
-  df |>
-    dplyr::glimpse()
-
   if (table_name == "main") {
     del_query <- glue::glue("DELETE FROM main WHERE {main_key_id} = '{main_key_value}'")
   }
@@ -332,3 +340,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} орфанных записей")
+
+  }
+
+}

R/modules/global_options.R

@@ -0,0 +1,174 @@
+.on_load = function(ns) {
+
+  check_and_init_scheme()
+  
+  # set global settings:
+  set_global_options(
+    shiny.host = "0.0.0.0",
+    shiny.port = 1338,
+    APP.DEBUG = FALSE
+  )
+
+}
+
+#' @export
+#' @description костыли для упрощения работы себе
+set_global_options = function(
+  SYMBOL_DELIM = "; ",
+  ...
+) {
+  
+  config_params_to_check <- c(
+    "form_app_version",
+    "form_id",
+    "form_name",
+    "form_app_configure_path",
+    "form_auth_enabled",
+    "form_schemes"
+  )
+  
+  expected_params_in_config <- config_params_to_check %in% names(config::get())
+  if (!all(expected_params_in_config)) {
+    cli::cli_abort(c(
+      "Необходимо добавить в файл конфига  {.file config.yml} следующие параметры:", 
+      paste0(config_params_to_check[!expected_params_in_config], ":")
+    ))
+  }
+
+  options(
+    SYMBOL_DELIM = SYMBOL_DELIM,
+    ...
+  )
+}
+
+# global vars ------------------------------------
+#' @export
+AUTH_ENABLED <- config::get("form_auth_enabled")
+
+#' @export
+#' TODO: нормальный разворот
+ENABLED_SCHEMES <- unlist(config::get()$form_schemes)
+ENABLED_SCHEMES <- stats::setNames(names(ENABLED_SCHEMES), ENABLED_SCHEMES)
+
+# -------------------------------------------------
+
+#' @export
+check_and_init_scheme = function() {
+
+  cli::cli_inform(c("*" = "проверка схемы..."))
+
+  options(box.path = here::here())
+  box::use(
+    R/modules/db[local_db_backup]
+  )
+
+  # список файлов, изменение которых, приведут к переинициализиации схемы
+  files_to_watch <- c(
+    "config/config.yml",
+    "R/modules/scheme_generator.R",
+    "R/modules/utils.R"
+  )
+
+  # проверка существования отслеживаемых файлов
+  if (!all(file.exists(files_to_watch))) {
+    cli::cli_abort("проверка схем: {files_to_watch[!file.exists(files_to_watch)]} is not exists")
+  }
+
+  scheme_names <- names(config::get()$form_schemes)
+  scheme_file  <- paste0(config::get("form_app_configure_path"), "/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(c(scheme_file, files_to_watch))
+
+  # если первый запуск (нет файла с кешем) инициализация схемы
+  if (!file.exists(hash_file) | !file.exists("temp/scheme.rds") | !all(file.exists(db_files))) {
+
+    init_scheme(scheme_file)
+
+  # в ином случае - проверяем кэш
+  } else {
+
+    saved_hash <- readRDS(hash_file)
+
+    # если данные были изменены проводим реинициализацию таблицы и схемы
+    if (!all(exist_hash == saved_hash)) {
+
+      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) {
+
+  options(box.path = here::here())
+  box::use(
+    R/modules/db,
+    R/modules/scheme_generator[scheme_R6]
+  )
+
+  db_path <- fs::path(config::get("form_app_configure_path"), "db")
+  if (!dir.exists(db_path)) dir.create(db_path)
+
+  cli::cli_h1("Инициализация схемы")
+
+  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)
+
+      # удаление орфанных записей
+
+      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, "temp/scheme.rds")
+}

R/modules/scheme_generator.R

@@ -40,10 +40,23 @@ 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)
+      box::use(R/modules/utils)
       private$bslib_rendered_ui <- bslib::navset_card_underline(
         id = "main",
         !!!utils$make_list_of_pages(private$schemes_list[["main"]], private$main_key_id),
@@ -78,6 +91,7 @@ scheme_R6 <- R6::R6Class(
     get_scheme = function(table_name) {
       private$schemes_list[[table_name]]
     },
+
     ## с полями имеющие значение -------
     get_scheme_with_values_forms = function(table_name) {
       private$schemes_list[[table_name]] |>
@@ -117,7 +131,7 @@ scheme_R6 <- R6::R6Class(
     nested_forms_names = NA,
     bslib_rendered_ui = NA,
     excluded_types = c("nested_forms", "description", "description_header"),
-    reserved_table_names = c("meta", "log", "main"),
+    reserved_table_names = c("meta", "log", "main", "tasks"),
 
     load_scheme_from_xlsx = function(sheet_name) {
 

R/modules/utils.R

@@ -135,7 +135,8 @@ render_forms = function(
     form <- shiny::textAreaInput(
       inputId = form_id,
       label = label,
-      rows = 1
+      rows = 1,
+      resize = "none"
     )
   }
 
@@ -265,7 +266,7 @@ update_forms_with_data = function(
 ) {
 
   options(box.path = here::here())
-  box::use(modules/data_manipulations[is_this_empty_value])
+  box::use(R/modules/data_manipulations[is_this_empty_value])
 
   # print("-----------------")
   # cli::cli_inform("form_id: {form_id} | form_type: {form_type}")

R/utils/init_login_db.r

@@ -3,17 +3,18 @@
 # SETUP AUTH =============================
 # Init DB using credentials data
 credentials <- data.frame(
-  user     = c("admin", "user"),
+  user     = c("admin", "user", "user2"),
-  password = c("admin", "user"),
+  password = c("admin", "user", "user2"),
   # password will automatically be hashed
-  admin = c(TRUE, FALSE),
+  admin = c(TRUE, FALSE, FALSE),
+  scheme_access = c(NA, "all", "example_of_scheme"), # NA - none | all - all | string with seperate
   stringsAsFactors = FALSE
 )
 
 # Init the database
 shinymanager::create_db(
   credentials_data = credentials,
-  sqlite_path = "auth.sqlite", # will be created
+  sqlite_path = "config/auth.sqlite", # will be created
   passphrase = Sys.getenv("AUTH_DB_KEY")
   # passphrase = "passphrase_wihtout_keyring"
 )

README.md

@@ -12,14 +12,55 @@
 
 ...
 
+# Quick start
+
+## локально:
+
+Копирование содержимого репозитория
+```bash
+git clone https://gitea.madelirihs.ru/madeliri/shiny_form.git
+```
+
+Восстановление окружения
+```r
+renv::activate()
+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 +73,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

@@ -1,78 +1,81 @@
-suppressPackageStartupMessages({
-  library(DBI)
-  library(tidyr)
-  library(dplyr)
-  library(purrr)
-  library(magrittr)
-  library(shiny)
-  library(bslib)
-  library(shinymanager)
-})
-
-# КАК ЗАПРЯТЯАТЬ ID
 
 # SOURCE FILES ============================
+# packages
 box::purge_cache()
 box::use(
-  modules/utils,
+  bslib[...],
-  modules/global_options,
+  shiny[...]
-  modules/global_options[enabled_schemas],
+)
-  modules/db,
+# modules
-  modules/data_validation,
+box::use(
-  modules/scheme_generator[scheme_R6]
+  R/modules/utils,
+  R/modules/db,
+  R/modules/data_validation,
+  R/app/forms,
+  R/app/tasks,
+  R/app/logs,
+  R/modules/data_manipulations[is_this_empty_value]
 )
 
-# SETTINGS ================================
+# глобальные переменные и проверка/инициация схемы:
-FILE_SCHEME  <- fs::path("configs/schemas", "schema.xlsx")
+box::use(
-AUTH_ENABLED <- Sys.getenv("FORM_AUTH_ENABLED", FALSE)
+  R/modules/global_options[AUTH_ENABLED, ENABLED_SCHEMES],
-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"
-  # enabled_schemas = "example_of_scheme"
 )
-global_options$check_and_init_scheme()
 
-# CHECK FOR PANDOC
+SCHMS <- readRDS("temp/scheme.rds")
-# TEMP ! NEED TO HANDLE
+
-rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
+# CHECK FOR PANDOC ----------
+# rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
 
 # TODO: dynamic button render depend on pandoc installation
 if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!")
 
-# SCHEME_MAIN UNPACK ==========================
+# web resources ------
-schms <- readRDS("scheme.rds")
+shiny::addResourcePath("www", "www")
+
 
 # UI =======================
 ui <- page_sidebar(
-  title = HEADER_TEXT,
+  title = config::get("form_name"),
   theme = bs_theme(version = 5, preset = "bootstrap"),
+  header = tags$head(
+    tags$link(rel = "icon", href = "www/favicon.ico")
+  ),
   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("house", lib = "font-awesome")),
     actionButton("load_data_button", "Загрузить данные", icon("pencil", lib = "font-awesome")),
-    downloadButton("downloadDocx", "get .docx (test only)"),
+    # downloadButton("downloadDocx", "get .docx (test only)"),
     uiOutput("status_message"),
     textOutput("status_message2"),
-    uiOutput("display_log"),
+    actionButton("tasks-display_task_modal", "Задачи: нет активных", icon("list-check")),
+    uiOutput("logs-display_log"),
     position = "left",
-    open = list(mobile = "always")
+    open = list(mobile = "always"),
+    popover(
+      span(
+        config::get("form_app_version"), 
+        fontawesome::fa("circle-info", a11y = "sem", title = "Settings"),
+        style = "color: #9c9c9c; position: fixed; bottom: 5px; left: 5px;"),
+      title = "about",
+      placement = "left",
+      tagList(span("здесь пока ничего нет"), br(), span("вот"))
+    )
   ),
-  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" = "scheme()")
   ui <- ui |> 
     shinymanager::secure_app(
       status = "primary",
       tags_top = tags$div(
-        tags$h3(HEADER_TEXT, style = "align:center"),
+        tags$h3(config::get("form_name"), style = "align:center"),
         # tags$img(
         #   src = "https://www.r-project.org/logo/Rlogo.png", width = 100
         # )
@@ -98,8 +101,8 @@ server <- function(input, output, session) {
   res_auth <- if (AUTH_ENABLED) {
     # check_credentials directly on sqlite db
     shinymanager::secure_server(
-      check_credentials = check_credentials(
+      check_credentials = shinymanager::check_credentials(
-        db = "auth.sqlite",
+        db = "config/auth.sqlite",
         passphrase = Sys.getenv("AUTH_DB_KEY")
       ),
       keep_token = TRUE
@@ -108,6 +111,23 @@ server <- function(input, output, session) {
     NULL
   }
 
+  user_access <- function(string) {
+
+    if (is_this_empty_value(string)) return(NA)
+    if (string == "all") return("all")
+
+    forms_access <- stringr::str_split_1(string, ", ")
+
+    # check if exists
+    exists <- forms_access %in% ENABLED_SCHEMES
+    if (!all(exists)) {
+      cli::cli_warn(c("these forms is not exist:", paste("- ", forms_access[!exists])))
+    }
+
+    # возращаем схемы для которых есть доступ
+    forms_access[exists]
+  }
+
   # важные кнопки управления
   output$admin_buttons_panel <- renderUI({
 
@@ -118,113 +138,190 @@ server <- function(input, output, session) {
     if (AUTH_ENABLED) {
       reactiveValuesToList(res_auth)
       if (res_auth$admin) {
-        # print("admin")
       } else {
-        # print("not_admin")
         showing_buttons <- FALSE
       }
     }
 
+    # update user name
+    values$current_user <- ifelse(AUTH_ENABLED, res_auth$user, "anonymous")
+
     if (showing_buttons) {
       tagList(
-        br(),
         strong("Импорт и экспорт данных для выбранной схемы:"),
         verticalLayout(
-          downloadButton("downloadData", "Экспорт в .xlsx", style = "width: 250px; margin-top: 5px"),
+          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"),
+          actionButton("button_upload_data_from_xlsx", "Импорт базы из .xlsx", icon("file-import", lib = "font-awesome"), style = "width: 250px; margin-top: 10px"),
+          fluid = FALSE 
+        ),
+        strong("Дополнительные опции:"),
+        verticalLayout(
+          actionButton("logs-show_last_actions", "Все действия", icon("scroll", lib = "font-awesome"), style = "width: 250px; margin-top: 10px"),
+          downloadButton("download_data_validation_info", "Некорректно заполненные данные (.xlsx)", icon("scroll", lib = "font-awesome"), style = "width: 250px; margin-top: 10px"),
           fluid = FALSE
         )
       )
     }
   })
 
+  # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # REACTIVE VALUES =================================
+  # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
   # Create a reactive values object to store the input data
   values <- reactiveValues(
     data             = NULL,
+    tasks_data       = NULL,
     main_key         = NULL,
     nested_key       = NULL,
-    nested_form_id = NULL
+    nested_form_id   = NULL,
+    tasks_id         = NULL,
+    current_user     = NULL,
+    user_form_access = ENABLED_SCHEMES
   )
 
-  scheme <- reactiveVal(enabled_schemas[1]) # наименование выбранной схемы
+  scheme <- reactiveVal(NULL) # наименование выбранной схемы
-  mhcs   <- reactiveVal(schms[[enabled_schemas[1]]]) # объект для выбранной схемы
+  mhcs   <- reactiveVal(NULL) # объект для выбранной схемы
   observers_started <- reactiveVal(NULL)
 
-  main_form_is_empty <- reactiveVal(TRUE)
+  main_form_is_empty <- reactiveVal(NULL)
   validator_main   <- reactiveVal(NULL)
   validator_nested <- reactiveVal(NULL)
 
-  # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # доступ к схемам
-  # ГЛАВНАЯ СТРАНИЦА ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  observe({
-  # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  output$main_ui_navset <- renderUI({
 
-    if (main_form_is_empty()) {
+    # определение доступа в завимости от условий (включена ли авторизация, и есть ли доступы)
+    res <- if (AUTH_ENABLED) {
+      # если администратор - полный доступ, если нет - проверка по полю
+      ifelse(res_auth$admin, "all", user_access(res_auth$scheme_access))
+    } else {
+      # если нет авторизации - полный доступ
+      "all"
+    }
+    if(length(res) == 0) return(NA)
+
+    # списки доступных схем
+    allowed_schemas <- if (is.na(res)) {
+      NA # нет доступа
+    } else if (res == "all") {
+      ENABLED_SCHEMES # все схемы
+    } else {
+      ENABLED_SCHEMES[ENABLED_SCHEMES == res] # только указанные
+    }
+
+    # переопределяем переменные
+    main_form_is_empty(ifelse(is.na(res), "empty", "main_menu"))
+    values$user_form_access <- allowed_schemas
+    scheme(values$user_form_access[1])
+    mhcs(SCHMS[[values$user_form_access[1]]])
+  })
+
+  # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # reactive ui       -------------------------------
+  # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  ## reactive ui -----------------------------------
+  ### main screen ------
+  output$main_ui_navset <- renderUI({
+    req(main_form_is_empty())
+
+    if (main_form_is_empty() == "main_menu") {
       validator_main(NULL)
       div(
+        h5("Выбрать базу данных для работы:"),
         shiny::radioButtons(
           "schmes_selector",
-          label = strong("Выбрать базу данных для работы:"),
+          label = NULL,
-          choices = enabled_schemas,
+          choices = values$user_form_access,
           selected = scheme()
         ),
+        hr(),
+        uiOutput("base_data"),
+        hr(),
         "Для начала работы нужно создать новую запись или загрузить существующую!",
+        hr(),
         # загрузка панели для работы с базой данных
         uiOutput("admin_buttons_panel")
       )
-    } else {
+    } else if (main_form_is_empty() == "form") {
 
       # list of rendered panels
       validator_main(data_validation$init_val(mhcs()$get_scheme("main")))
       validator_main()$enable()
       mhcs()$get_main_form_ui
+
+    } else if (main_form_is_empty() == "empty") {
+
+      div(
+        h5("Нет доступных баз данных для работы"),
+        p("Для данного пользователя нет доступа к формам для работы."), 
+        p("Обратитесь к системному администратору.") 
+      )
     }
   })
 
+  ### bases info ----------------
+  observeEvent(main_form_is_empty(), {
+
+    output$base_data <- renderUI({
+
+      if (main_form_is_empty() == "main_menu") {
+
+        con <- db$make_db_connection(scheme(),"base_data")
+        on.exit(db$close_db_connection(con, "base_data"), add = TRUE)
+
+        tasks$update_task_button_count(con, values, NS("tasks"))
+
+        # записей в базе всего
+        records_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT ({mhcs()$get_main_key_id}) FROM main")) |>
+          dplyr::pull()
+
+        # задачи на сегодня
+        if ("tasks" %in% DBI::dbListTables(con)) {
+
+          tasks_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT (task_id) FROM \"tasks\" WHERE task_status = 'active'")) |>
+            dplyr::pull()
+
+          tasks_today_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT (task_id) FROM \"tasks\" WHERE task_status = 'active' AND task_due_date = {as.integer(Sys.Date())}")) |>
+            dplyr::pull()
+
+          tasks_overdue_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT (task_id) FROM \"tasks\" WHERE task_status = 'active' AND task_due_date < {as.integer(Sys.Date())}")) |>
+            dplyr::pull()
+
+        } else {
+
+          tasks_count <- 0
+          tasks_today_count <- 0
+          tasks_overdue_count <- 0
+
+        }
+
+        div(
+          h5("Общая информация о базе данных:"),
+          strong("Записей всего:"), records_count, 
+          hr(),
+          h5("Задачи:"),
+          span(strong("Активных всего:"),      if (tasks_count > 0)       actionLink("tasks-show_dt_all", tasks_count) else "0", br()),
+          span(strong("Активных на сегодня:"), if (tasks_today_count > 0) actionLink("tasks-show_dt_today", tasks_today_count) else "0", br()),
+          span(strong("Просроченных:"),        if (tasks_overdue_count > 0) actionLink("tasks-show_dt_overdue", tasks_overdue_count) else "0", br())
+        )
+      }
+    })
+  })
+
+  # обновление данных схем ------
   observeEvent(input$schmes_selector, {
+
     scheme(input$schmes_selector)
-    mhcs(schms[[input$schmes_selector]])
+    mhcs(SCHMS[[input$schmes_selector]])
+
   })
 
   # ==========================================
   # ОБЩИЕ ФУНКЦИИ ============================
   # ==========================================
 
-  ## перенос данных из датафрейма в форму -----------------------
-  load_data_to_form <- function(
-    df,
-    table_name = "main",
-    schm,
-    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
-
-    # transform df to list
-    # loaded_df_for_id <- as.list(df)
-    # loaded_df_for_id <- df[input_ids]
-
-    # 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
-        )
-      }
-    )
-  }
-
   ## сохранение данных из форм в базу данных --------
   save_inputs_to_db <- function(
     table_name, 
@@ -263,13 +360,13 @@ server <- function(input, output, session) {
       }
     )
 
-    exported_df <- setNames(exported_values, input_ids) |>
+    exported_df <- stats::setNames(exported_values, input_ids) |>
-        as_tibble()
+        dplyr::as_tibble()
 
     # пайплайн для главной таблицы
     if (table_name == "main") {
       exported_df <- exported_df |>
-        mutate(
+        dplyr::mutate(
           !!dplyr::sym(mhcs()$get_main_key_id) := values$main_key,
           .before = 1
         )
@@ -278,7 +375,7 @@ server <- function(input, output, session) {
     # для всех остальных таблицы (вложенные)
     if (table_name != "main") {
       exported_df <- exported_df |>
-        mutate(
+        dplyr::mutate(
           !!dplyr::sym(mhcs()$get_main_key_id) := values$main_key,
           !!dplyr::sym(nested_key_id)          := values$nested_key,
           .before = 1
@@ -301,8 +398,10 @@ server <- function(input, output, session) {
   # ====================================
   # NESTED FORMS =======================
   # ====================================
+
   ## кнопки для каждой вложенной таблицы -------------------------------
   observe({
+    req(scheme())
 
     # проверка инициализированы ли для этой схемы наблюдатели для кнопок вложенных таблиц
     is_observer_is_started <- (isolate(scheme()) %in% isolate(observers_started()))
@@ -330,6 +429,7 @@ server <- function(input, output, session) {
     observers_started(c(
       isolate(observers_started()), isolate(scheme())
     ))
+
   })
 
   ## функция отображения вложенной формы для выбранной таблицы --------
@@ -354,11 +454,14 @@ server <- function(input, output, session) {
     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)
+
+    if (length(values$nested_key) == 0) {
       values$nested_key <- if (length(kyes_for_this_table) == 0) NULL else kyes_for_this_table[[1]]
+    }
 
     # если ключ в формате даты - дать человекочитаемые данные
     if (this_nested_form_key_scheme_smoll$form_type == "date") {
-      kyes_for_this_table <- setNames(
+      kyes_for_this_table <- stats::setNames(
         kyes_for_this_table,
         format(as.Date(kyes_for_this_table), "%d.%m.%Y")
       )
@@ -366,6 +469,7 @@ server <- function(input, output, session) {
 
     # nested ui
     nested_form_panels <- if (!is.null(values$nested_key)) {
+
       purrr::map(
         .x = unique(this_nested_form_scheme$subgroup),
         .f = \(subgroup) {
@@ -386,7 +490,9 @@ server <- function(input, output, session) {
         }
       )
     } else {
+
       list(bslib::nav_panel("", div("Нет доступных записей.", br(), "Необходимо создать новую запись.")))
+
     }
 
     # ui для всплывающего окна 
@@ -441,17 +547,17 @@ server <- function(input, output, session) {
     str_cols  <- which(col_types$form_type != "date")
 
     values$data <- values$data |>
-      select(-mhcs()$get_main_key_id) |>
+      dplyr::select(-mhcs()$get_main_key_id) |>
-      mutate(
+      dplyr::mutate(
         dplyr::across(tidyselect::all_of({{date_cols}}), as.Date),
         dplyr::across(tidyselect::all_of({{str_cols}}), as.character),
       ) |>
-      arrange({{key_id}})
+      dplyr::arrange({{key_id}})
 
     output$dt_nested <- DT::renderDataTable(
       DT::datatable(
         values$data,
-        caption = 'Table 1: This is a simple caption for the table.',
+        caption = 'В данной таблице можно изменять данные',
         rownames = FALSE,
         colnames = col_types |> dplyr::pull(form_id, form_label),
         extensions = c('KeyTable', "FixedColumns"),
@@ -472,7 +578,7 @@ server <- function(input, output, session) {
       DT::dataTableOutput("dt_nested"),
       size = "xl",
       footer = tagList(
-        actionButton("nested_form_dt_save", "сохранить изменения")
+        actionButton("nested_form_dt_save", "Сохранить изменения", icon("floppy-disk"))
       ),
       easyClose = TRUE
     ))
@@ -486,8 +592,9 @@ server <- function(input, output, session) {
 
   ### кнопка: отображение DT -----------------------------
   observeEvent(input$nested_form_dt_button, {
-    con <- db$make_db_connection(scheme(),"nested_form_save_button")
+
-    on.exit(db$close_db_connection(con, "nested_form_save_button"), add = TRUE)
+    con <- db$make_db_connection(scheme(),"nested_form_dt_button")
+    on.exit(db$close_db_connection(con, "nested_form_dt_button"), add = TRUE)
 
     removeModal()
     show_modal_for_nested_form_dt(con)
@@ -571,8 +678,8 @@ server <- function(input, output, session) {
 
   observeEvent(values$nested_key, {
 
-    con <- db$make_db_connection(scheme(),"nested_tables")
+    con <- db$make_db_connection(scheme(),"nested_key")
-    on.exit(db$close_db_connection(con, "nested_tables"), add = TRUE)
+    on.exit(db$close_db_connection(con, "nested_key"), add = TRUE)
 
     kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, mhcs(), values$main_key, con)
 
@@ -588,12 +695,13 @@ server <- function(input, output, session) {
       )
 
       # загрузка данных в формы
-      load_data_to_form(
+      forms$load_data_to_form(
         df         = df,
         table_name = values$nested_form_id,
-        mhcs(),
+        mhcs       = mhcs,
         ns         = NS(values$nested_form_id)
       )
+
     } else {
       utils$clean_forms(values$nested_form_id, mhcs(), NS(values$nested_form_id))
     }
@@ -610,7 +718,7 @@ server <- function(input, output, session) {
 
     ui1 <- rlang::exec(
       .fn = utils$render_forms, 
-      !!!distinct(scheme_for_key_input, form_id, form_label, form_type),
+      !!!dplyr::distinct(scheme_for_key_input, form_id, form_label, form_type),
       main_scheme = scheme_for_key_input
     )
 
@@ -629,8 +737,8 @@ server <- function(input, output, session) {
   observeEvent(input$confirm_create_new_nested_key, {
     req(input[[mhcs()$get_key_id(values$nested_form_id)]])
 
-    con <- db$make_db_connection(scheme(),"confirm_create_new_key")
+    con <- db$make_db_connection(scheme(),"confirm_create_new_nested_key")
-    on.exit(db$close_db_connection(con, "confirm_create_new_key"), add = TRUE)
+    on.exit(db$close_db_connection(con, "confirm_create_new_nested_key"), add = TRUE)
 
     existed_key <- db$get_nested_keys_from_table(
       table_name = values$nested_form_id,
@@ -662,7 +770,7 @@ server <- function(input, output, session) {
       need(values$main_key, "⚠️ Необходимо указать id пациента!")
     )
     span(
-      strong("Таблица: "), names(enabled_schemas)[enabled_schemas == scheme()],
+      strong("Таблица: "), names(ENABLED_SCHEMES)[ENABLED_SCHEMES == scheme()],
       br(),
       strong("ID: "), values$main_key
     )
@@ -681,8 +789,11 @@ server <- function(input, output, session) {
   # =========================================
   # MAIN BUTTONS LOGIC ======================
   # =========================================
+
   ## добавить новый главный ключ  ------------------------
+  ### modal -------
   observeEvent(input$add_new_main_key_button, {
+    req(main_form_is_empty() != "empty")
 
     # данные для главного ключа
     scheme_for_key_input <- mhcs()$get_scheme("main") |>
@@ -691,7 +802,7 @@ server <- function(input, output, session) {
     # создать форму для выбора ключа
     ui1 <- rlang::exec(
       .fn = utils$render_forms, 
-      !!!distinct(scheme_for_key_input, form_id, form_label, form_type),
+      !!!dplyr::distinct(scheme_for_key_input, form_id, form_label, form_type),
       main_scheme = scheme_for_key_input
     )
 
@@ -707,7 +818,7 @@ server <- function(input, output, session) {
 
   })
 
-  ## действие при подтверждении (проверка нового создаваемого ключа) -------
+  ### подтверждение(проверка нового создаваемого ключа) -------
   observeEvent(input$confirm_create_new_main_key, {
     req(input[[mhcs()$get_main_key_id]])
 
@@ -715,7 +826,6 @@ server <- function(input, output, session) {
     on.exit(db$close_db_connection(con, "confirm_create_new_key"), add = TRUE)
 
     new_main_key <- trimws(input[[mhcs()$get_main_key_id]])
-
     existed_key <- db$get_keys_from_table("main", mhcs(), con)
 
     # если введенный ключ уже есть в базе
@@ -728,16 +838,15 @@ 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", mhcs())
-
     removeModal()
   })
 
-  ## очистка всех полей -----------------------
+  ## переход на главный акран -----------------------
-  # show modal on click of button
+  ### show modal  -------
   observeEvent(input$clean_data_button, {
+    req(main_form_is_empty() == "form")
+
     showModal(modalDialog(
       "Данное действие очистит все заполненные данные. Убедитесь, что нужные данные сохранены.",
       title = "Очистить форму?",
@@ -749,16 +858,17 @@ server <- function(input, output, session) {
     ))
   })
 
-  # when action confirm - perform action
+  ### when action confirm - perform action ---
   observeEvent(input$clean_all_action, {
     
     # rewrite all inputs with empty data
     values$main_key <- NULL
     utils$clean_forms("main", mhcs())
-    main_form_is_empty(TRUE)
+    main_form_is_empty("main_menu")
 
     removeModal()
     showNotification("Данные очищены!", type = "warning")
+
   })
 
   ## сохранение даннных -------------------------------
@@ -781,13 +891,15 @@ server <- function(input, output, session) {
     )
   })
 
-  ## список ключей для загрузки данных -------------------
+  ## загрузка данных -------------------
+  ### modal with keys -----
   observeEvent(input$load_data_button, {
+    req(main_form_is_empty() != "empty")
 
     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)) {
+    if (length(DBI::dbListTables(con)) != 0 && "main" %in% DBI::dbListTables(con)) {
 
       # GET DATA files
       ids <- db$get_keys_from_table("main", mhcs(), con)
@@ -799,7 +911,7 @@ server <- function(input, output, session) {
           choices = ids,
           selected = NULL,
           options = list(
-            placeholder = "id пациента",
+            placeholder = "id",
             onInitialize = I('function() { this.setValue(""); }')
           )
         )
@@ -824,30 +936,51 @@ server <- function(input, output, session) {
     )
   })
 
-  ## загрузка данных по главному ключу ------------------
+  ### confirm ------------------
   observeEvent(input$load_data, {
     req(input$load_data_key_selector)
 
+    values$main_key <- input$load_data_key_selector
+
+  })
+
+  ## логика: смена ключа -------
+  observeEvent(values$main_key, {
+
     con <- db$make_db_connection(scheme(),"load_data")
     on.exit(db$close_db_connection(con, "load_data"), add = TRUE)
 
+    if (!is.null(values$main_key)) {
+      existed_main_keys <- db$get_keys_from_table("main", mhcs(), con)
+
+      if (values$main_key %in% existed_main_keys) {
+
         df <- db$read_df_from_db_by_id(
           table_name = "main", 
           schm = mhcs(),
-      main_key_value = input$load_data_key_selector,
+          main_key_value = values$main_key,
           con = con
         )
 
-    load_data_to_form(
+        forms$load_data_to_form(
           df = df,
           table_name = "main",
-      mhcs()
+          mhcs
         )
 
-    values$main_key <- input$load_data_key_selector
-    main_form_is_empty(FALSE)
-
         log_action_to_db("loading data", values$main_key, con = con)
+
+      } else {
+
+        utils$clean_forms("main", mhcs())
+
+      }
+
+      main_form_is_empty("form")
+
+    }
+
+    tasks$update_task_button_count(con, values, NS("tasks"))
     removeModal()
 
   })
@@ -858,6 +991,7 @@ server <- function(input, output, session) {
       paste0(isolate(scheme()), "_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx")
     },
     content = function(file) {
+      req(main_form_is_empty() != "empty")
 
       con <- db$make_db_connection(isolate(scheme()),"downloadData")
       on.exit(db$close_db_connection(con, "downloadData"), add = TRUE)
@@ -875,7 +1009,8 @@ server <- function(input, output, session) {
 
           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))
+          # other_cols     <- which(colnames(df) %in% c(date_columns, number_columns))
+          other_cols     <- colnames(df)[!(colnames(df) %in% c(date_columns, number_columns))]
 
           df <- df |>
             dplyr::mutate(
@@ -883,7 +1018,7 @@ 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::across(tidyselect::all_of({{other_cols}}), \(x) dplyr::if_else(x == "", as.character(NA), as.character(x)))
             ) |>
             # очистка от пустых ключей
             dplyr::filter(!is.na(mhcs()$get_main_key_id))
@@ -895,9 +1030,11 @@ server <- function(input, output, session) {
       # добавить мета информацию
       list_of_df[["meta"]] <- dplyr::tribble(
         ~`Параметр`      , ~`Значение`,
-        "Пользователь"   , ifelse(AUTH_ENABLED, res_auth$user, "anonymous"),
+        "Пользователь"   , values$current_user,
-        "Название базы"  , names(enabled_schemas)[enabled_schemas == scheme()],
+        "Название базы"  , 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"),
       )
 
@@ -925,6 +1062,8 @@ server <- function(input, output, session) {
       paste0(values$main_key, "_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".docx")
     },
     content = function(file) {
+      req(main_form_is_empty() != "empty")
+
       # prepare YAML sections
       empty_vec <- c(
         "---",
@@ -934,7 +1073,6 @@ server <- function(input, output, session) {
         "---",
         "\n"
       )
-      box::use(modules/data_manipulations[is_this_empty_value])
 
       # iterate by scheme parts
       purrr::walk(
@@ -1014,6 +1152,7 @@ server <- function(input, output, session) {
   )
 
   ## import data from xlsx ----------------------
+  ### modal -----
   observeEvent(input$button_upload_data_from_xlsx, {
 
     showModal(modalDialog(
@@ -1037,6 +1176,7 @@ server <- function(input, output, session) {
 
   })
 
+  ### confirm --------
   observeEvent(input$button_upload_data_from_xlsx_confirm, {
     req(input$upload_xlsx)
 
@@ -1088,7 +1228,8 @@ server <- function(input, output, session) {
 
       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))
+      # other_cols     <- which(colnames(df) %in% c(date_columns, number_columns))
+      other_cols     <- colnames(df)[!(colnames(df) %in% c(date_columns, number_columns))]
 
       # функция для преобразование числовых значений и сохранения "NA"
       num_converter <- function(old_col) {
@@ -1108,12 +1249,12 @@ 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)
+          dplyr::across(tidyselect::all_of({{other_cols}}), \(x) dplyr::if_else(x == "", as.character(NA), as.character(x)))
         ) |>
-        select(all_of(unique(c(main_key_id, scheme$form_id))))
+        dplyr::select(tidyselect::all_of(unique(c(main_key_id, scheme$form_id))))
 
       df_original <- DBI::dbReadTable(con, table_name) |>
-        as_tibble()
+        dplyr::as_tibble()
 
       if (input$upload_data_from_xlsx_owerwrite_all_data == TRUE) {
 
@@ -1122,15 +1263,24 @@ server <- function(input, output, session) {
       } else {
 
         # удаление данных в базе данных по ключам
-        walk(
+        # purrr::walk(
-          .x = unique(df[[main_key_id]]),
+        #   .x = unique(df[[main_key_id]]),
-          .f = \(main_key) {
+        #   .f = \(main_key) {
 
-            if (main_key %in% unique(df_original[[main_key_id]])) {
+        #     if (main_key %in% unique(df_original[[main_key_id]])) {
-              DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key_id} = '{main_key}'"))
+        #       DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key_id} = '{main_key}'"))
-            }
+        #     }
-          }
+        #   }
-        )
+        # )
+
+        # TODO 
+        all_existed_keys <- unique(df_original[[main_key_id]])
+        all_new_keys     <- unique(df[[main_key_id]])
+        
+        keys_to_delete <- all_existed_keys[all_existed_keys %in% all_new_keys]
+        keys_to_delete <- paste0("'", keys_to_delete, "'", collapse = ", ")
+
+        DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE \"{main_key_id}\" IN ({keys_to_delete})"))
      
       }
 
@@ -1145,13 +1295,15 @@ server <- function(input, output, session) {
         append = TRUE
       )
 
-      message <- glue::glue("Данные таблицы '{table_name}' успешно обновлены (добавлено {nrow(df)} записей)")
+      message <- glue::glue("Данные таблицы '{table_name}' успешно загружены (добавлено {nrow(df)} записей)")
       showNotification(
         message,
         type = "message"
       )
       cli::cli_alert_success(message)
     }
+
+    db$db_clean_orphans(mhcs(), con)
     log_action_to_db("importing data from xlsx", con = con)
     removeModal()
   })
@@ -1166,7 +1318,7 @@ server <- function(input, output, session) {
   read_df_from_db_all <- function(table_name, con) {
 
     # check if this table exist
-    if (table_name %in% dbListTables(con)) {
+    if (table_name %in% DBI::dbListTables(con)) {
       # prepare query
       query <- glue::glue("
         SELECT * FROM {table_name}
@@ -1185,17 +1337,20 @@ server <- function(input, output, session) {
       "loading data",
       "creating new key",
       "exporting data to xlsx",
+      "export validation dataset",
       "importing data from xlsx"
     ),
-    key = NULL,
+    key = NA,
     con
   ) {
 
     action <- match.arg(action)
 
-    action_row <- tibble(
+    action_row <- dplyr::tibble(
       date        = Sys.time(),
-      user        = ifelse(AUTH_ENABLED, res_auth$user, "anonymous"),
+      user        = values$current_user,
+      app_id      = config::get("form_id"),
+      app_ver     = config::get("form_app_version"),
       remote_addr = session$request$REMOTE_ADDR,
       key         = key,
       action      = action,
@@ -1204,61 +1359,60 @@ server <- function(input, output, session) {
     DBI::dbWriteTable(con, "log", action_row, append = TRUE)
   }
 
-  # КРАТКАЯ СВОДКА ПРО ЛОГГИНГ ------------------
+  # TASKS ---------------------------------------
-  # observe({
+  tasks$server("tasks", values, scheme, mhcs)
 
-  #   output$display_log <- renderUI({
+  # SHOW LOGS -----------------------------------
+  logs$server("logs", values, scheme, mhcs)
 
-  #     con <- db$make_db_connection(scheme(),"display_log")
+  # экспорт таблицы с информации о валидации данных -------------------
-  #     on.exit(db$close_db_connection(con, "display_log"), add = TRUE)
+  output$download_data_validation_info <- downloadHandler(
+    filename = function(){
+      paste0("dvinfo_", isolate(scheme()), "_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx")
+    },
+    content = function(file) {
+      req(main_form_is_empty() != "empty")
 
-  #     query <- if (!is.null(values$main_key)) {
+      box::use(
-  #       sprintf("SELECT * FROM log WHERE key = '%s'", values$main_key)
+        R/modules/data_validation[get_table_with_data_validation_info]
-  #     } else {
+      )
-  #       "SELECT * FROM log"
-  #     }
 
-  #     log_rows <- DBI::dbGetQuery(con, query)
+      con <- db$make_db_connection(isolate(scheme()),"download_data_validation_info")
+      on.exit(db$close_db_connection(con, "download_data_validation_info"), add = TRUE)
 
-  #     if (nrow(log_rows) > 0) {
+      list_of_df <- get_table_with_data_validation_info(mhcs(), con)
 
-  #       lines <- log_rows |>
+      # добавить мета информацию
-  #         mutate(date = as.POSIXct(date)) |>
+      list_of_df[["meta"]] <- dplyr::tribble(
-  #         mutate(
+        ~`Параметр`      , ~`Значение`,
-  #           # date = date + lubridate::hours(3), # fix datetime
+        "Пользователь"   , values$current_user,
-  #           date_day = as.Date(date)
+        "Название базы"  , names(ENABLED_SCHEMES)[ENABLED_SCHEMES == scheme()],
-  #         ) |>
+        "id базы"        , scheme(),
-  #         mutate(cons_actions = dplyr::consecutive_id(action, user)) |>
+        "id формы"       , config::get("form_id"),
-  #         mutate(n_actions = row_number(), .by = c(cons_actions, user, action, date_day)) |>
+        "ver формы"      , config::get("form_app_version"),
-  #         slice(which.max(n_actions), .by = c(user, action, date_day)) |>
+        "Время выгрузки" , format(Sys.time(), "%d.%m.%Y %H:%M:%S"),
-  #         mutate(string_to_print = sprintf(
+      )
-  #           "<b>[%s %s]</b>: %s - %s (%s)",
-  #           format(date, "%d.%m.%y"),
-  #           format(date, "%H:%M"),
-  #           user,
-  #           action,
-  #           n_actions
-  #         )) |>
-  #         pull(string_to_print) |>
-  #         paste(collapse = "</br>")
 
-  #     } else {
+      # set date params
-  #       lines <- ""
+      options("openxlsx2.dateFormat" = "dd.mm.yyyy")
-  #     }
+
+      cli::cli_alert_success("Данные успешно экспортированы")
+      showNotification("Данные успешно экспортированы", type = "message")
+      log_action_to_db("export validation dataset", con = con)
+
+      # pass tables to export
+      openxlsx2::write_xlsx(
+        purrr::compact(list_of_df),
+        file,
+        na.strings = "",
+        as_table = TRUE,
+        col_widths = 20
+      )
+    }
+  )
 
-  #     tagList(
-  #       paste0("ID: ", values$main_key),
-  #       br(),
-  #       p(
-  #         HTML(lines),
-  #         style = "font-size:10px;"
-  #       )
-  #     )
-  #   })
-  # })
 }
 
+app <- shiny::shinyApp(ui = ui, server = server)
 
-app <- shinyApp(ui = ui, server = server)
+shiny::runApp(app, launch.browser = TRUE)
-
-runApp(app, launch.browser = TRUE)

config/config_example.yml

@@ -0,0 +1,10 @@
+default:
+  form_app_version: !expr config::get("form_app_version", file = "config/descr.yml")
+  form_id:          !expr config::get("form_id",          file = "config/descr.yml")
+  form_name:        !expr config::get("form_name",        file = "config/descr.yml")
+
+prod:
+  form_app_configure_path: "example_scheme"
+  form_auth_enabled: false
+  form_schemes:
+    example_of_scheme: Тестовая база данных

config/descr.yml

@@ -0,0 +1,4 @@
+default:
+  form_app_version: 0.18.3
+  form_id: formy
+  form_name: FORMY

modules/data_validation.R

@@ -1,114 +0,0 @@
-
-#' @export
-init_val = function(scheme, ns) {
-
-  options(box.path = here::here())
-  box::use(modules/data_manipulations[is_this_empty_value])
-
-  iv <- shinyvalidate::InputValidator$new()
-
-  # если передана функция с пространством имен, то происходит модификация id
-  if(!missing(ns)) {
-    scheme <- scheme |>
-      dplyr::mutate(form_id = ns(form_id))
-  }
-
-  # формируем список id - тип
-  inputs_simple_list <- scheme |>
-    dplyr::filter(!form_type %in% c("nested_forms", "description", "description_header")) |>
-    dplyr::distinct(form_id, form_type) |>
-    tibble::deframe()
-
-  # add rules to all inputs
-  purrr::walk(
-    .x = names(inputs_simple_list),
-    .f = \(x_input_id) {
-
-      form_type <- inputs_simple_list[[x_input_id]]
-
-      choices <- dplyr::filter(scheme, form_id == {{x_input_id}}) |>
-        dplyr::pull(choices)
-
-      val_required <- dplyr::filter(scheme, form_id == {{x_input_id}}) |>
-        dplyr::distinct(required) |>
-        dplyr::pull(required)
-
-      # for `number` type: if in `choices` column has values then parsing them to range validation
-      # value `0; 250` -> transform to rule validation value from 0 to 250
-      if (form_type == "number") {
-
-        iv$add_rule(x_input_id, 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 "Значение должно быть числом."
-        })
-
-        # проверка на соответствие диапазону значений
-        if (!is.na(choices)) {
-          # разделить на несколько елементов
-          ranges <- as.integer(stringr::str_split_1(choices, "; "))
-
-          # проверка на кол-во значений
-          if (length(ranges) > 3) {
-            warning("Количество переданных элементов'", x_input_id, "' > 2")
-          } else {
-            iv$add_rule(
-              x_input_id,
-              function(x) {
-
-                # exit if empty
-                if (is_this_empty_value(x)) {
-                  return(NULL)
-                }
-
-                if (x == "NA") return(NULL)
-
-                # замена разделителя десятичных цифр
-                x <- stringr::str_replace(x, ",", ".")
-
-                # check for currect value
-                if (dplyr::between(as.double(x), ranges[1], ranges[2])) {
-                  NULL
-                } else {
-                  glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.")
-                }
-              }
-            )
-          }
-        }
-      }
-
-      if (form_type %in% c("select_multiple", "select_one", "radio", "checkbox")) {
-        iv$add_rule(x_input_id, function(x) {
-
-          if (length(x) == 1) {
-            if (is_this_empty_value(x)) return(NULL)
-          }
-
-          # проверка на соответствие вариантов схеме ---------
-          compare_to_dict <- (x %in% choices)
-          if (!all(compare_to_dict)) {
-
-            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/global_options.R

@@ -1,117 +0,0 @@
-#' @export
-#' @description костыли для упрощения работы себе
-set_global_options = function(
-  SYMBOL_DELIM = "; ",
-  APP.DEBUG = FALSE,
-  # APP.FILE_DB = fs::path("data.sqlite"),
-  shiny.host = "127.0.0.1",
-  shiny.port = 1338,
-  ...
-) {
-  options(
-    SYMBOL_DELIM = SYMBOL_DELIM,
-    APP.DEBUG = APP.DEBUG,
-    # APP.FILE_DB = APP.FILE_DB,
-    shiny.host = shiny.host,
-    shiny.port = shiny.port,
-    ...
-  )
-}
-
-#' @export
-enabled_schemas <- c(
-  `Тестовая база данных` = "example_of_scheme"
-  # `D2TRA (для отладки)` = "d2tra_t"
-)
-
-#' @export
-check_and_init_scheme = function() {
-
-  cli::cli_inform(c("*" = "проверка схемы..."))
-
-  files_to_watch <- c(
-    "modules/scheme_generator.R",
-    "modules/utils.R"
-  )
-
-  scheme_names <- enabled_schemas
-  scheme_file <- paste0("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("db/", scheme_names, ".sqlite")
-
-  hash_file   <- "temp/schema_hash.rds"
-
-  # 
-  exist_hash <- tools::md5sum(c(scheme_file, files_to_watch))
-
-  # если первый запуск (нет файла с кешем) инициализация схемы
-  if (!file.exists(hash_file) | !file.exists("scheme.rds") | !all(file.exists(db_files))) {
-
-    init_scheme(scheme_file)
-
-  # в ином случае - проверяем кэш
-  } else {
-    
-    saved_hash <- readRDS(hash_file)
-
-    # если данные были изменены проводим реинициализацию таблицы и схемы
-    if (!all(exist_hash == saved_hash)) {
-
-      cli::cli_inform(c(">" = "Данные схем были изменены..."))
-      init_scheme(scheme_file)
-
-    } else {
-      cli::cli_alert_success("изменений нет")
-    }
-  }
-
-  # перезаписываем файл
-  if (!dir.exists("temp")) dir.create("temp")
-  saveRDS(exist_hash, hash_file)
-}
-
-
-init_scheme = function(scheme_file) {
-
-  options(box.path = here::here())
-  box::use(
-    modules/db,
-    modules/scheme_generator[scheme_R6]
-  )
-
-  if (!dir.exists("db")) dir.create("db")
-
-  cli::cli_h1("Инициализация схемы")
-  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)
-      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")
-}

renv.lock

@@ -1,6 +1,6 @@
 {
   "R": {
-    "Version": "4.3.1",
+    "Version": "4.3.2",
     "Repositories": [
       {
         "Name": "CRAN",
@@ -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",
@@ -707,6 +717,19 @@
       ],
       "Hash": "b8552d117e1b808b09a832f589b79035"
     },
+    "lubridate": {
+      "Package": "lubridate",
+      "Version": "1.9.5",
+      "Source": "Repository",
+      "Repository": "CRAN",
+      "Requirements": [
+        "R",
+        "generics",
+        "methods",
+        "timechange"
+      ],
+      "Hash": "07061b348d057e8ac86771e0eff36b62"
+    },
     "magrittr": {
       "Package": "magrittr",
       "Version": "2.0.3",
@@ -1193,6 +1216,17 @@
       ],
       "Hash": "79540e5fcd9e0435af547d885f184fd5"
     },
+    "timechange": {
+      "Package": "timechange",
+      "Version": "0.4.0",
+      "Source": "Repository",
+      "Repository": "CRAN",
+      "Requirements": [
+        "R",
+        "cpp11"
+      ],
+      "Hash": "39c40cb1ad47a4cc384a34a22a29463f"
+    },
     "tinytex": {
       "Package": "tinytex",
       "Version": "0.46",