feat: возможность полного обновления базы данных из эксель-таблицы

app.R

@@ -55,7 +55,7 @@ ui <- page_sidebar(
     actionButton("clean_data_button", "Главная страница", icon("house", lib = "font-awesome")),
     actionButton("load_data_button", "Загрузить данные", icon("pencil", lib = "font-awesome")),
     downloadButton("downloadDocx", "get .docx (test only)"),
-    textOutput("status_message"),
+    uiOutput("status_message"),
     textOutput("status_message2"),
     uiOutput("display_log"),
     position = "left",
@@ -650,12 +650,16 @@ server <- function(input, output, session) {
 
   # STATUSES ===============================
   # вывести отображение что что-то не так
-  output$status_message <- renderText({
-    scheme()
+  output$status_message <- renderUI({
+
     shiny::validate(
       need(values$main_key, "⚠️ Необходимо указать id пациента!")
     )
-    paste0("ID: ", values$main_key)
+    span(
+      strong("Таблица: "), names(enabled_schemas)[enabled_schemas == scheme()],
+      br(),
+      strong("ID: "), values$main_key
+    )
   })
 
   output$status_message2 <- renderText({
@@ -806,8 +810,8 @@ server <- function(input, output, session) {
         ui_load_menu,
         title = "Загрузить имеющиеся данные",
         footer = tagList(
-          actionButton("close_modal_button", "Отмена", class = "btn btn-danger"),
           actionButton("load_data", "Загрузить данные"),
+          actionButton("close_modal_button", "Отмена", class = "btn-danger"),
         ),
         easyClose = TRUE
       )
@@ -1005,8 +1009,8 @@ server <- function(input, output, session) {
       ),
       checkboxInput("upload_data_from_xlsx_owerwrite_all_data", "перезаписать все данные", width = 450),
       footer = tagList(
-        modalButton("Отмена"),
-        actionButton("button_upload_data_from_xlsx_confirm", "Добавить")
+        actionButton("button_upload_data_from_xlsx_confirm", "Добавить"),
+        actionButton("close_modal_button", "Отмена", class = "btn-danger")
       ),
       easyClose = FALSE
     ))
@@ -1034,19 +1038,17 @@ server <- function(input, output, session) {
     for (table_name in mhcs()$all_tables_names) {
 
       df     <- openxlsx2::read_xlsx(wb, table_name) 
-      scheme <- mhcs()$get_schema(table_name) |>
-        filter(!form_type %in% c("description", "nested_forms"))
+      scheme <- mhcs()$get_schema_with_values_forms(table_name) 
 
       # столбцы в таблицы и схема
       df_to_schema_compare <- setdiff(colnames(df), unique(scheme$form_id))
       schema_to_df_compare <- setdiff(unique(scheme$form_id), colnames(df))
 
-      if (length(schema_to_df_compare) > 0 ) {
+      if (length(df_to_schema_compare) > 0 ) {
         cli::cli_warn(c("в схеме для '{table_name}' нет следующих столбцов:", paste("- ", df_to_schema_compare)))
       }
 
       # схема и столбцы в таблице
-      schema_to_df_compare <- setdiff(unique(scheme$form_id), colnames(df))
       if (length(schema_to_df_compare) > 0 ) {
 
         message <- glue::glue("столбцы в таблице '{table_name}' не соответсвуют схеме")
@@ -1061,8 +1063,7 @@ server <- function(input, output, session) {
     for (table_name in mhcs()$all_tables_names) {
 
       df     <- openxlsx2::read_xlsx(wb, table_name) 
-      scheme <- mhcs()$get_schema(table_name) |>
-        filter(!form_type %in% c("description", "nested_forms"))
+      scheme <- mhcs()$get_schema_with_values_forms(table_name)
 
       date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE)
       number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE)
@@ -1091,8 +1092,13 @@ server <- function(input, output, session) {
       df_original <- DBI::dbReadTable(con, table_name) |>
         as_tibble()
 
-      if (input$upload_data_from_xlsx_owerwrite_all_data == TRUE) cli::cli_abort("not implemented yet")
+      if (input$upload_data_from_xlsx_owerwrite_all_data == TRUE) {
 
+        DBI::dbRemoveTable(con, table_name)
+
+      } else {
+
+        # удаление данных в базе данных по ключам
         walk(
           .x = unique(df[[main_key_id]]),
           .f = \(main_key) {
@@ -1103,6 +1109,8 @@ server <- function(input, output, session) {
           }
         )
      
+      }
+
       DBI::dbWriteTable(
         con,
         name = table_name,

modules/db.R

@@ -39,7 +39,7 @@ check_if_table_is_exist_and_init_if_not = function(
 
       if (table_name %in% DBI::dbListTables(con)) {
 
-        cli::cli_inform(c("*" = "таблица есть такая: '{table_name}'"))
+        cli::cli_inform(c("*" = "проверка таблицы в базе данных: '{table_name}'"))
 
         # если таблица существует, производим проверку структуры таблицы
         compare_existing_table_with_schema(

modules/global_options.R

@@ -29,6 +29,10 @@ check_and_init_scheme = function() {
 
   cli::cli_inform(c("*" = "проверка схемы..."))
 
+  files_to_watch <- c(
+    "modules/scheme_generator.R"
+  )
+
   scheme_names <- enabled_schemas
   scheme_file <- paste0("configs/schemas/", scheme_names, ".xlsx")
   scheme_file <- stats::setNames(scheme_file, scheme_names)
@@ -40,7 +44,7 @@ check_and_init_scheme = function() {
   hash_file   <- "temp/schema_hash.rds"
 
   # 
-  exist_hash <- tools::md5sum(scheme_file)
+  exist_hash <- tools::md5sum(c(scheme_file, files_to_watch))
 
   # если первый запуск (нет файла с кешем) инициализация схемы
   if (!file.exists(hash_file) | !file.exists("scheme.rds") | !all(file.exists(db_files))) {

modules/scheme_generator.R

@@ -36,7 +36,7 @@ scheme_R6 <- R6::R6Class(
       private$main_key_id <- self$get_key_id("main")
 
       box::use(modules/utils)
-      private$testest <- bslib::navset_card_underline(
+      private$bslib_rendered_ui <- bslib::navset_card_underline(
         id = "main",
         !!!utils$make_list_of_pages(private$schemes_list[["main"]], private$main_key_id),
         header = NULL,
@@ -47,7 +47,7 @@ scheme_R6 <- R6::R6Class(
     get_all_ids = function(table_name) {
 
       private$schemes_list[[table_name]] |>
-        dplyr::filter(!form_type %in% private$exluded_types) |>
+        dplyr::filter(!form_type %in% private$excluded_types) |>
         dplyr::distinct(form_id) |>
         dplyr::pull(form_id)
 
@@ -65,32 +65,24 @@ scheme_R6 <- R6::R6Class(
 
     },
 
-    extract_forms_id_and_types_from_scheme2 = function(scheme) {
-
-      form_id_and_types_list <- scheme |>
-        dplyr::filter(!form_type %in% private$exluded_types) |>
-        dplyr::distinct(form_id, form_type) |>
-        tibble::deframe()
-
-      list(
-        key = form_id_and_types_list[1],
-        form = form_id_and_types_list[-1]
-      )
-    },
-
-    # get_key_id = function(table_name) {
-    #   self$extract_forms_id_and_types_from_scheme2(private$schemes_list[[table_name]])
-    # },
+    # возврат схемы ------------------------------------
+    ## полностью -------
     get_schema = function(table_name) {
       private$schemes_list[[table_name]]
     },
+    ## с полями имеющие значение -------
+    get_schema_with_values_forms = function(table_name) {
+      private$schemes_list[[table_name]] |>
+        dplyr::filter(!form_type %in% private$excluded_types)
+    },
+
     get_id_type_list = function(table_name) {
 
       # wo main key
       this_key_id <- self$get_key_id(table_name)
 
       private$schemes_list[[table_name]] |>
-        dplyr::filter(!form_type %in% private$exluded_types) |>
+        dplyr::filter(!form_type %in% private$excluded_types) |>
         dplyr::filter(form_id != {{this_key_id}}) |>
         dplyr::distinct(form_id, form_type) |>
         tibble::deframe()
@@ -107,7 +99,7 @@ scheme_R6 <- R6::R6Class(
       private$nested_forms_names
     },
     get_main_form_ui = function() {
-      private$testest
+      private$bslib_rendered_ui
     }
   ),
   private = list(
@@ -115,8 +107,8 @@ scheme_R6 <- R6::R6Class(
     schemes_list = NULL,
     main_key_id = NA,
     nested_forms_names = NA,
-    testest = NA,
-    exluded_types = c("inline_table", "nested_forms","description", "description_header"),
+    bslib_rendered_ui = NA,
+    excluded_types = c("nested_forms", "description", "description_header"),
 
     load_scheme_from_xlsx = function(sheet_name) {
 

modules/utils.R

@@ -1,6 +1,6 @@
 #' @export
 make_list_of_pages = function(main_schema, main_key_id) {
-  cli::cli_alert_success("AAAA")
+
   purrr::map(
     .x = unique(main_schema$part),
     .f = \(page_name) {