Merge pull request '0.18.4' (#3) from devel into main

Reviewed-on: #3

.Rprofile

@@ -28,6 +28,7 @@ source("renv/activate.R")
     cli::cli_code(paste0("R_CONFIG_ACTIVE", "="))
 
   }
+  Sys.setenv(R_CONFIG_FILE = "config/config.yml")
 
 })()
 
@@ -35,8 +36,8 @@ source("renv/activate.R")
 # при первом запуске скопировать пример конфига
 (function() {
 
-  if (!file.exists("config.yml")) {
+  if (!file.exists("config/config.yml")) {
-    file.copy("config_example.yml", "config.yml")
+    file.copy("config/config_example.yml", "config/config.yml")
   }
 
 })()

.gitignore

@@ -3,8 +3,7 @@
 /_devel
 /all_bases
 
-scheme.rds
+config/config.yml
-config.yml
 
 .Renviron
 .DS_Store

CHANGELOG.md

@@ -1,3 +1,11 @@
+### 0.18.2 - 0.18.3 (2026-06-18)
+##### features
+- возможность отражение лога действий по базам (для администраторов) и отдельно для каждой записи (сгруппированы по уникальным действиям)
+- возможность экспорта таблицы со списком значений не прошедшие валидацию согласно схеме (для администраторов)
+
+##### refactor
+- перестройка структуры репозитория
+
 ### 0.18.1 (2026-06-08)
 ##### fix
 - правильный экспорт текстовых данных

R/app/forms.R

@@ -1,6 +1,6 @@
 options(box.path = here::here())
 box::use(
-  modules/utils,
+  R/modules/utils,
 )
 
 #' @export

R/app/logs.R

@@ -5,9 +5,9 @@ box::use(
 
 options(box.path = here::here())
 box::use(
-  modules/db,
+  R/modules/db,
-  modules/utils,
+  R/modules/utils,
-  app/forms
+  R/app/forms
 )
 
 #' @export

R/app/tasks.R

@@ -5,9 +5,9 @@ box::use(
 
 options(box.path = here::here())
 box::use(
-  modules/db,
+  R/modules/db,
-  modules/utils,
+  R/modules/utils,
-  app/forms
+  R/app/forms
 )
 
 #' @export

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

@@ -103,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,
@@ -136,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)) {

R/modules/global_options.R

@@ -1,13 +1,33 @@
+
 #' @export
 #' @description костыли для упрощения работы себе
 set_global_options = function(
   SYMBOL_DELIM = "; ",
-  APP.DEBUG = FALSE,
-  shiny.host = "127.0.0.1",
-  shiny.port = 1338,
   ...
 ) {
 
+  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("*" = "проверка файла конфигурации..."))
+
   config_params_to_check <- c(
     "form_app_version",
     "form_id",
@@ -18,40 +38,27 @@ set_global_options = function(
   )
   
   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,
-    # form.db_path = config::get("form_db_path"),
-    APP.DEBUG = APP.DEBUG,
-    # APP.FILE_DB = APP.FILE_DB,
-    shiny.host = shiny.host,
-    shiny.port = shiny.port,
-    ...
-  )
-}
-
-#' @export
-AUTH_ENABLED <- config::get("form_auth_enabled")
-
-#' @export
-check_and_init_scheme = function() {
 
   cli::cli_inform(c("*" = "проверка схемы..."))
 
   options(box.path = here::here())
-  box::use(modules/db[local_db_backup])
+  box::use(
+    R/modules/db[local_db_backup]
+  )
 
   # список файлов, изменение которых, приведут к переинициализиации схемы
   files_to_watch <- c(
-    "config.yml",
+    "config/config.yml",
-    "modules/scheme_generator.R",
+    "R/modules/scheme_generator.R",
-    "modules/utils.R"
+    "R/modules/utils.R"
   )
 
   # проверка существования отслеживаемых файлов
@@ -69,13 +76,14 @@ check_and_init_scheme = function() {
 
   db_files <- paste0(config::get("form_app_configure_path"), "/db/", scheme_names, ".sqlite")
 
+  if (!dir.exists("temp")) dir.create("temp")
   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))) {
+  if (!file.exists(hash_file) | !file.exists("temp/scheme.rds")) {
 
     init_scheme(scheme_file)
 
@@ -111,8 +119,8 @@ init_scheme = function(scheme_file) {
 
   options(box.path = here::here())
   box::use(
-    modules/db,
+    R/modules/db,
-    modules/scheme_generator[scheme_R6]
+    R/modules/scheme_generator[scheme_R6]
   )
 
   db_path <- fs::path(config::get("form_app_configure_path"), "db")
@@ -155,5 +163,5 @@ init_scheme = function(scheme_file) {
     cli::cli_abort(c("В одной или нескольких схемах наименования вложенных форм совпадают:", paste("-", names(tab)[tab > 1])))
   }
   
-  saveRDS(schms, "scheme.rds")
+  saveRDS(schms, "temp/scheme.rds")
 }

R/modules/scheme_generator.R

@@ -49,14 +49,14 @@ scheme_R6 <- R6::R6Class(
         "task_status",        "select_one",  "Статус задачи",          NA,                 "deleted",
         "task_title",         "text",        "Название задачи",        NA,                 NA,
         "task_description",   "text",        "Описание задачи",        "краткое описание", "3",
-        "task_due_date",      "date",        "Дата выполнения задачи", NA,                 NA,
+        "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),
@@ -168,16 +168,3 @@ scheme_R6 <- R6::R6Class(
     }
   )
 )
-
-# object.size(schm)
-# schm$get_key_id("main")
-# schm$get_forms_ids("main")
-# schm$get_all_ids("main")
-
-# schm$get_scheme("main")
-
-# schm$get_id_type_list("allergo_anamnesis")
-
-# # active
-# schm$get_main_key_id
-# schm$all_tables_names

R/modules/utils.R

@@ -108,7 +108,11 @@ render_forms = function(
   } else {
     shiny::tagList(
       if (!is.na(form_label)) {
+        if (form_type == "description_header") {
+          shiny::span(form_label, class = "description-header", style = "color: #444444; font-weight: 550; line-height: 1.4;")
+        } else {
           shiny::span(form_label, style = "color: #444444; font-weight: 550; line-height: 1.4;")
+        }
         # если в схеме есть поле с описанием - добавляем его следующей строчкой
       },
       if (!is.na(description) && !is.na(form_label)) shiny::br(),
@@ -266,7 +270,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

@@ -14,7 +14,7 @@ credentials <- data.frame(
 # Init the database
 shinymanager::create_db(
   credentials_data = credentials,
-  sqlite_path = "auth.sqlite", # will be created
+  sqlite_path = "temp/auth.sqlite", # will be created
   passphrase = Sys.getenv("AUTH_DB_KEY")
   # passphrase = "passphrase_wihtout_keyring"
 )

app.R

@@ -1,45 +1,38 @@
-suppressPackageStartupMessages({
-  library(DBI)
-  library(tidyr)
-  library(dplyr)
-  library(purrr)
-  library(magrittr)
-  library(shiny)
-  library(bslib)
-  library(shinymanager)
-})
 
 # SOURCE FILES ============================
+# packages
 box::purge_cache()
 box::use(
-  modules/utils,
+  bslib[...],
-  modules/global_options,
+  shiny[...]
-  modules/db,
+)
-  modules/data_validation,
+# modules
-  app/forms,
+box::use(
-  app/tasks,
+  R/modules/utils,
-  app/logs,
+  R/modules/db,
-  modules/data_manipulations[is_this_empty_value]
+  R/modules/data_validation,
+  R/app/forms,
+  R/app/tasks,
+  R/app/logs,
+  R/modules/data_manipulations[is_this_empty_value]
 )
 
-# global settings:
+# глобальные переменные и проверка/инициация схемы:
-global_options$set_global_options(
+box::use(
+  R/modules/global_options[set_global_options, check_and_init_scheme],
+  R/modules/global_options[AUTH_ENABLED, ENABLED_SCHEMES],
+)
+
+# set global settings:
+set_global_options(
   shiny.host = "0.0.0.0",
+  shiny.port = 1338,
   APP.DEBUG = FALSE
 )
 
-# init:
+check_and_init_scheme()
-global_options$check_and_init_scheme()
 
-# global vars:
+SCHMS <- readRDS("temp/scheme.rds")
-box::use(
-  modules/global_options[AUTH_ENABLED]
-)
-enabled_schemes <- unlist(config::get()$form_schemes)
-enabled_schemes <- setNames(names(enabled_schemes), enabled_schemes)
-
-# load schemes object:
-schms <- readRDS("scheme.rds")
 
 # CHECK FOR PANDOC ----------
 # rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
@@ -49,15 +42,18 @@ if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!")
 
 # web resources ------
 shiny::addResourcePath("www", "www")
-
+shiny::resourcePaths()
 
 # UI =======================
 ui <- page_sidebar(
   title = config::get("form_name"),
   theme = bs_theme(version = 5, preset = "bootstrap"),
-  header = tags$head(
+
+  tags$head(
+    tags$link(rel = "stylesheet", type = "text/css", href = "www/styles.css"),
     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")),
@@ -118,8 +114,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 = "temp/auth.sqlite",
         passphrase = Sys.getenv("AUTH_DB_KEY")
       ),
       keep_token = TRUE
@@ -136,7 +132,7 @@ server <- function(input, output, session) {
     forms_access <- stringr::str_split_1(string, ", ")
 
     # check if exists
-    exists <- forms_access %in% enabled_schemes
+    exists <- forms_access %in% ENABLED_SCHEMES
     if (!all(exists)) {
       cli::cli_warn(c("these forms is not exist:", paste("- ", forms_access[!exists])))
     }
@@ -167,13 +163,14 @@ server <- function(input, output, session) {
       tagList(
         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
         )
       )
@@ -193,7 +190,7 @@ server <- function(input, output, session) {
     nested_form_id   = NULL,
     tasks_id         = NULL,
     current_user     = NULL,
-    user_form_access = enabled_schemes
+    user_form_access = ENABLED_SCHEMES
   )
 
   scheme <- reactiveVal(NULL) # наименование выбранной схемы
@@ -221,16 +218,16 @@ server <- function(input, output, session) {
     allowed_schemas <- if (is.na(res)) {
       NA # нет доступа
     } else if (res == "all") {
-      enabled_schemes # все схемы
+      ENABLED_SCHEMES # все схемы
     } else {
-      enabled_schemes[enabled_schemes == res] # только указанные
+      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]]])
+    mhcs(SCHMS[[values$user_form_access[1]]])
   })
 
   # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -330,7 +327,7 @@ server <- function(input, output, session) {
   observeEvent(input$schmes_selector, {
 
     scheme(input$schmes_selector)
-    mhcs(schms[[input$schmes_selector]])
+    mhcs(SCHMS[[input$schmes_selector]])
 
   })
 
@@ -376,13 +373,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
         )
@@ -391,7 +388,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
@@ -477,7 +474,7 @@ server <- function(input, output, session) {
 
     # если ключ в формате даты - дать человекочитаемые данные
     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")
       )
@@ -563,12 +560,12 @@ 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(
@@ -734,7 +731,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
     )
 
@@ -786,7 +783,7 @@ server <- function(input, output, session) {
       need(values$main_key, "⚠️ Необходимо указать id пациента!")
     )
     span(
-      strong("Таблица: "), names(enabled_schemes)[enabled_schemes == scheme()],
+      strong("Таблица: "), names(ENABLED_SCHEMES)[ENABLED_SCHEMES == scheme()],
       br(),
       strong("ID: "), values$main_key
     )
@@ -818,7 +815,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
     )
 
@@ -915,7 +912,7 @@ server <- function(input, output, session) {
     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)
@@ -927,7 +924,7 @@ server <- function(input, output, session) {
           choices = ids,
           selected = NULL,
           options = list(
-            placeholder = "id пациента",
+            placeholder = "id",
             onInitialize = I('function() { this.setValue(""); }')
           )
         )
@@ -1047,7 +1044,7 @@ server <- function(input, output, session) {
       list_of_df[["meta"]] <- dplyr::tribble(
         ~`Параметр`      , ~`Значение`,
         "Пользователь"   , values$current_user,
-        "Название базы"  , names(enabled_schemes)[enabled_schemes == scheme()],
+        "Название базы"  , names(ENABLED_SCHEMES)[ENABLED_SCHEMES == scheme()],
         "id базы"        , scheme(),
         "id формы"       , config::get("form_id"),
         "ver формы"      , config::get("form_app_version"),
@@ -1155,7 +1152,7 @@ server <- function(input, output, session) {
       # write vector to temp .Rmd file
       writeLines(empty_vec, temp_report, sep = "\n")
       # copy template .docx file
-      file.copy("references/reference.docx", temp_template, overwrite = TRUE)
+      file.copy("resources/references/reference.docx", temp_template, overwrite = TRUE)
 
       # render file via pandoc
       rmarkdown::render(
@@ -1267,10 +1264,10 @@ server <- function(input, output, session) {
           dplyr::across(tidyselect::all_of({{number_columns}}), num_converter),
           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) {
 
@@ -1279,15 +1276,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})"))
      
       }
 
@@ -1325,7 +1331,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}
@@ -1344,6 +1350,7 @@ server <- function(input, output, session) {
       "loading data",
       "creating new key",
       "exporting data to xlsx",
+      "export validation dataset",
       "importing data from xlsx"
     ),
     key = NA,
@@ -1352,7 +1359,7 @@ server <- function(input, output, session) {
 
     action <- match.arg(action)
 
-    action_row <- tibble(
+    action_row <- dplyr::tibble(
       date        = Sys.time(),
       user        = values$current_user,
       app_id      = config::get("form_id"),
@@ -1371,9 +1378,54 @@ server <- function(input, output, session) {
   # SHOW LOGS -----------------------------------
   logs$server("logs", values, scheme, mhcs)
 
+  # экспорт таблицы с информации о валидации данных -------------------
+  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")
+
+      box::use(
+        R/modules/data_validation[get_table_with_data_validation_info]
+      )
+
+      con <- db$make_db_connection(isolate(scheme()),"download_data_validation_info")
+      on.exit(db$close_db_connection(con, "download_data_validation_info"), add = TRUE)
+
+      list_of_df <- get_table_with_data_validation_info(mhcs(), con)
+
+      # добавить мета информацию
+      list_of_df[["meta"]] <- dplyr::tribble(
+        ~`Параметр`      , ~`Значение`,
+        "Пользователь"   , values$current_user,
+        "Название базы"  , names(ENABLED_SCHEMES)[ENABLED_SCHEMES == scheme()],
+        "id базы"        , scheme(),
+        "id формы"       , config::get("form_id"),
+        "ver формы"      , config::get("form_app_version"),
+        "Время выгрузки" , format(Sys.time(), "%d.%m.%Y %H:%M:%S"),
+      )
+
+      # set date params
+      options("openxlsx2.dateFormat" = "dd.mm.yyyy")
+
+      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
+      )
+    }
+  )
+
 }
 
+app <- shiny::shinyApp(ui = ui, server = server)
 
-app <- shinyApp(ui = ui, server = server)
+shiny::runApp(app, launch.browser = TRUE)
-
-runApp(app, launch.browser = TRUE)

appinfo.json

@@ -0,0 +1,5 @@
+{
+  "app_id": "formy",
+  "app_title": "FORMY",
+  "formy_version": "0.18.4"
+}

config/config_example.yml

@@ -0,0 +1,10 @@
+default:
+  form_app_version: !expr jsonlite::read_json("appinfo.json")$formy_version
+  form_id:          !expr jsonlite::read_json("appinfo.json")$app_id
+  form_name:        !expr jsonlite::read_json("appinfo.json")$app_title
+
+prod:
+  form_app_configure_path: "example_scheme"
+  form_auth_enabled: false
+  form_schemes:
+    example_of_scheme: Тестовая база данных

config_example.yml

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

descr.yml

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

modules/data_validation.R

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

renv.lock

@@ -1,6 +1,6 @@
 {
   "R": {
-    "Version": "4.3.1",
+    "Version": "4.3.3",
     "Repositories": [
       {
         "Name": "CRAN",
@@ -717,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",
@@ -1203,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",

www/styles.css

@@ -0,0 +1,10 @@
+.description-header {
+  /* 1. Add the border around the whole box */
+  border-bottom: 2px solid #777777;
+
+  /* 2. Forces border inside the total width/height (prevents breaking layouts) */
+  box-sizing: border-box; 
+  
+  /* 3. Ensures the div encloses any internal floated elements */
+  overflow: auto; 
+}