0.18.1 (fix - корректный экспорт и импорт текстовых данных)

Reviewed-on: madeliri/shiny_form#1

.Rprofile

@@ -4,7 +4,6 @@ source("renv/activate.R")
 (function() {
 
   paths <- c(
-    "R_CONFIG_ACTIVE",
     "AUTH_DB_KEY"
   )
 
@@ -18,3 +17,27 @@ 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", "="))
+
+  }
+
+})()
+
+
+# при первом запуске скопировать пример конфига
+(function() {
+
+  if (!file.exists("config.yml")) {
+    file.copy("config_example.yml", "config.yml")
+  }
+
+})()
+

.gitignore

@@ -3,6 +3,8 @@
 /_devel
 
 scheme.rds
+config.yml
+
 .Renviron
 .DS_Store
 .lintr

CHANGELOG.md

@@ -1,3 +1,19 @@
+### 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 таблиц;

README.md

@@ -23,10 +23,11 @@ git clone https://gitea.madelirihs.ru/madeliri/shiny_form.git
 
 Восстановление окружения
 ```r
+renv::activate()
 renv::init()
 ```
 
-# Насторйки
+# Настройки
 
 ## переменные окружения
 
@@ -46,7 +47,7 @@ FORM_APP_LOCAL_DB_BACKUP_PATH="path_to_backups"
 
 Проверка осуществляется при каждом запуске приложения, бэкапы создаются раз в день (при первом запуске).
 
-Количество сохраняемых бэкапов:
+Количество послдних сохраненных бэкапов:
 ```
 FORM_APP_LOCAL_DB_BACKUP_LIMITS=3
 ```

app.R

@@ -17,7 +17,8 @@ box::use(
   modules/db,
   modules/data_validation,
   app/forms,
-  app/tasks
+  app/tasks,
+  modules/data_manipulations[is_this_empty_value]
 )
 
 # global settings:
@@ -40,42 +41,46 @@ enabled_schemes <- setNames(names(enabled_schemes), enabled_schemes)
 schms <- readRDS("scheme.rds")
 
 # CHECK FOR PANDOC ----------
-rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
+# rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
 
 # TODO: dynamic button render depend on pandoc installation
 if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!")
 
+# web resources ------
+shiny::addResourcePath("www", "www")
+
 
 # UI =======================
 ui <- page_sidebar(
-  # title = config::get("form_name"),
-  title = tagList(
-    h4(config::get("form_name"), style = "margin-top: .5rem"),
-    popover(
-      span(
-        config::get("form_app_version"), 
-        fontawesome::fa("circle-info", a11y = "sem", title = "Settings"),
-        style = "color: #9c9c9c"),
-      title = "about",
-      placement = "left",
-      tagList(span("здесь пока ничего нет"), br(), span("вот"))
-    )
-  ),
+  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")),
     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")),
+  
 )
 
 # init auth =======================
@@ -122,6 +127,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({
 
@@ -153,29 +175,60 @@ server <- function(input, output, session) {
     }
   })
 
+
   # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # 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,
-    tasks_id = NULL,
-    current_user = NULL
+    data             = NULL,
+    tasks_data       = NULL,
+    main_key         = NULL,
+    nested_key       = NULL,
+    nested_form_id   = NULL,
+    tasks_id         = NULL,
+    current_user     = NULL,
+    user_form_access = enabled_schemes
   )
 
-  scheme <- reactiveVal(enabled_schemes[1]) # наименование выбранной схемы
-  mhcs   <- reactiveVal(schms[[enabled_schemes[1]]]) # объект для выбранной схемы
+  scheme <- reactiveVal(NULL) # наименование выбранной схемы
+  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({
+
+    # определение доступа в завимости от условий (включена ли авторизация, и есть ли доступы)
+    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       -------------------------------
   # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -183,15 +236,16 @@ server <- function(input, output, session) {
   ## reactive ui -----------------------------------
   ### main screen ------
   output$main_ui_navset <- renderUI({
+    req(main_form_is_empty())
 
-    if (main_form_is_empty()) {
+    if (main_form_is_empty() == "main_menu") {
       validator_main(NULL)
       div(
         h5("Выбрать базу данных для работы:"),
         shiny::radioButtons(
           "schmes_selector",
           label = NULL,
-          choices = enabled_schemes,
+          choices = values$user_form_access,
           selected = scheme()
         ),
         hr(),
@@ -203,13 +257,20 @@ server <- function(input, output, session) {
         # загрузка панели для работы с базой данных
         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("Обратитесь к системному администратору.") 
+      )
     }
   })
 
@@ -218,7 +279,7 @@ server <- function(input, output, session) {
 
     output$base_data <- renderUI({
 
-      if (main_form_is_empty() == TRUE) {
+      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)
 
@@ -352,6 +413,7 @@ server <- function(input, output, session) {
 
   ## кнопки для каждой вложенной таблицы -------------------------------
   observe({
+    req(scheme())
 
     # проверка инициализированы ли для этой схемы наблюдатели для кнопок вложенных таблиц
     is_observer_is_started <- (isolate(scheme()) %in% isolate(observers_started()))
@@ -742,6 +804,7 @@ server <- function(input, output, session) {
   ## добавить новый главный ключ  ------------------------
   ### modal -------
   observeEvent(input$add_new_main_key_button, {
+    req(main_form_is_empty() != "empty")
 
     # данные для главного ключа
     scheme_for_key_input <- mhcs()$get_scheme("main") |>
@@ -793,6 +856,8 @@ server <- function(input, output, session) {
   ## переход на главный акран -----------------------
   ### show modal  -------
   observeEvent(input$clean_data_button, {
+    req(main_form_is_empty() == "form")
+
     showModal(modalDialog(
       "Данное действие очистит все заполненные данные. Убедитесь, что нужные данные сохранены.",
       title = "Очистить форму?",
@@ -810,7 +875,7 @@ server <- function(input, output, session) {
     # 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")
@@ -840,6 +905,7 @@ 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"))
@@ -921,7 +987,7 @@ server <- function(input, output, session) {
 
       }
 
-      main_form_is_empty(FALSE)
+      main_form_is_empty("form")
 
     }
 
@@ -936,6 +1002,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)
@@ -953,7 +1020,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(
@@ -961,7 +1029,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))
@@ -1005,6 +1073,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(
         "---",
@@ -1014,7 +1084,6 @@ server <- function(input, output, session) {
         "---",
         "\n"
       )
-      box::use(modules/data_manipulations[is_this_empty_value])
 
       # iterate by scheme parts
       purrr::walk(
@@ -1170,7 +1239,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) {
@@ -1190,7 +1260,7 @@ 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))))
 

app/tasks.R

@@ -50,7 +50,7 @@ server <- function(id, values, scheme, mhcs) {
       if (!is.null(values$tasks_data)) {
 
         tasks_selector <- values$tasks_data |>
-          dplyr::filter(task_status != "completed") |>
+          dplyr::filter(task_status == "active") |>
           dplyr::pull(task_id)
 
         tasks_selector <- unique(c(values$tasks_id, tasks_selector))
@@ -117,11 +117,15 @@ server <- function(id, values, scheme, mhcs) {
       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
@@ -159,6 +163,11 @@ server <- function(id, values, scheme, mhcs) {
       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)
@@ -230,6 +239,7 @@ server <- function(id, values, scheme, mhcs) {
       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,
@@ -353,7 +363,8 @@ server <- function(id, values, scheme, mhcs) {
     display_tasks_dt_review <- function() {
 
       values$tasks_data <- values$tasks_data |>
-        dplyr::select(task_id:task_datetime_last_updated)
+        dplyr::select(task_id:task_datetime_last_updated) |>
+        dplyr::arrange(task_due_date)
 
       rename_cols <- tasks_colnames[tasks_colnames %in% colnames(values$tasks_data)]
       
@@ -368,6 +379,7 @@ server <- function(id, values, scheme, mhcs) {
           colnames = rename_cols,
           extensions = c("FixedColumns"),
           # editable = 'cell',
+          class = 'cell-border stripe',
           selection = "single",
           options = list(
             dom = 'tip',

config.yml

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

config_example.yml

@@ -0,0 +1,10 @@
+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

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

modules/db.R

@@ -200,7 +200,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(
@@ -208,7 +209,7 @@ write_df_to_db = function(
       dplyr::across(tidyselect::all_of({{date_columns}}), \(x) purrr::map_chr(x, excel_to_db_dates_converter)),
       # числа - к единому формату десятичных значений
       dplyr::across(tidyselect::all_of({{number_columns}}), ~ gsub("\\.", "," , .x)),
-      dplyr::across(tidyselect::all_of({{other_cols}}), as.character),
+      dplyr::across(tidyselect::all_of({{other_cols}}), \(x) dplyr::if_else(x == "", as.character(NA), as.character(x)))
     )
 
   if (table_name == "main") {
@@ -394,8 +395,8 @@ local_db_backup <- function(
         file.remove(utils::tail(existed_files, length(existed_files) - backups_limit))
       }
 
-      # если количество существующих бэкапов равно имеющемуся и пора делать бэкап - делаем бэкап, удаляем послендий файл
-      if (dates[1] + schedule_days == Sys.Date()) {
+      # если количество существующих бэкапов равно имеющемуся и пора делать бэкап - делаем бэкап
+      if (dates[1] + schedule_days <= Sys.Date()) {
 
         file.copy(db_full_path, todays_backup)
         cli::cli_alert_success("создан {schedule_name}-бэкап для '{db_name}'")

modules/global_options.R

@@ -10,15 +10,19 @@ set_global_options = function(
   
   config_params_to_check <- c(
     "form_app_version",
+    "form_id",
+    "form_name",
     "form_app_configure_path",
     "form_auth_enabled",
-    "form_id",
-    "form_name"
+    "form_schemes"
   )
   
   expected_params_in_config <- config_params_to_check %in% names(config::get())
   if (!all(expected_params_in_config)) {
-    cli::cli_abort(c("ну так не пойдет:", paste("-", config_params_to_check[!expected_params_in_config])))
+    cli::cli_abort(c(
+      "Необходимо добавить в файл конфига  {.file config.yml} следующие параметры:", 
+      paste0(config_params_to_check[!expected_params_in_config], ":")
+    ))
   }
 
   options(
@@ -51,7 +55,7 @@ check_and_init_scheme = function() {
   )
 
   scheme_names <- names(config::get()$form_schemes)
-  scheme_file  <- paste0(config::get("form_app_configure_path"), "/configs/schemas/", scheme_names, ".xlsx")
+  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))) {

utils/init_login_db.r

@@ -3,10 +3,11 @@
 # SETUP AUTH =============================
 # Init DB using credentials data
 credentials <- data.frame(
-  user     = c("admin", "user"),
-  password = c("admin", "user"),
+  user     = c("admin", "user", "user2"),
+  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
 )