feat: функционал импорта базы данных из xlsx таблицы

app.R

@@ -166,6 +166,7 @@ ui <- page_sidebar(
     actionButton("load_data_button", "Загрузить данные", icon("pencil", lib = "font-awesome")),
     downloadButton("downloadData", "Экспорт в .xlsx"),
     downloadButton("downloadDocx", "get .docx (test only)"),
+    actionButton("button_upload_data_from_xlsx", "импорт!"),
     position = "left",
     open = list(mobile = "always")
   ),
@@ -797,6 +798,7 @@ server <- function(input, output, session) {
 
   ## загрузка данных по главному ключу ------------------
   observeEvent(input$load_data, {
+    req(input$load_data_key_selector)
 
     con <- db$make_db_connection("load_data")
     on.exit(db$close_db_connection(con, "load_data"), add = TRUE)
@@ -963,6 +965,118 @@ server <- function(input, output, session) {
     }
   )
 
+  ## upload xlsx to df ----------------------
+  observeEvent(input$button_upload_data_from_xlsx, {
+
+    showModal(modalDialog(
+      title = "Добавить пациентов к текущему списку...",
+      fileInput(
+        "upload_xlsx",
+        NULL,
+        buttonLabel = "Выбрать файлы...",
+        placeholder = "No file selected",
+        multiple = TRUE,
+        accept = ".xlsx",
+        width = 450
+      ),
+      checkboxInput("upload_data_from_xlsx_owerwrite_all_data", "перезаписать все данные", width = 450),
+      footer = tagList(
+        actionButton("button_upload_data_from_xlsx_confirm", "Добавить")
+      ),
+      easyClose = TRUE
+    ))
+
+  })
+
+  observeEvent(input$button_upload_data_from_xlsx_confirm, {
+    req(input$upload_xlsx
+    )
+    con <- db$make_db_connection("button_upload_data_from_xlsx_confirm")
+    on.exit(db$close_db_connection(con, "button_upload_data_from_xlsx_confirm"), add = TRUE)
+
+    file <- input$upload_xlsx$datapath
+    # print(file)
+    wb <- openxlsx2::wb_load(file)
+
+    # проверка на наличие всех листов в файле
+    if (!all(names(SCHEMES_LIST) %in% openxlsx2::wb_get_sheet_names(wb))) {
+      cli::cli_alert_warning("данные в файле '{file} не соответствуют схеме'")
+      return()
+    }
+
+    # проверка схемы --------------
+    for (table_name in names(SCHEMES_LIST)) {
+
+      df     <- openxlsx2::read_xlsx(wb, table_name) 
+      scheme <- SCHEMES_LIST[[table_name]] |>
+        filter(!form_type %in% c("description", "nested_forms"))
+
+      # столбцы в таблицы и схема
+      df_to_schema_compare <- setdiff(colnames(df), unique(scheme$form_id))
+      if (length(schema_to_df_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}' не соответсвуют схеме")
+        cli::cli_warn(c(message, paste("- ", schema_to_df_compare)))
+        showNotification(message, type = "error")
+
+        return()
+      }
+    }
+
+    # обновление данных
+    for (table_name in names(SCHEMES_LIST)) {
+
+      df     <- openxlsx2::read_xlsx(wb, table_name) 
+      scheme <- SCHEMES_LIST[[table_name]] |>
+        filter(!form_type %in% c("description", "nested_forms"))
+
+      date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE)
+
+      df <- df |>
+        dplyr::mutate(
+          # даты - к единому формату
+          dplyr::across(tidyselect::all_of({{date_columns}}), \(x) purrr::map_chr(x, db$excel_to_db_dates_converter)),
+        ) |>
+        select(all_of(unique(c("main_key", scheme$form_id))))
+
+      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")
+
+      walk(
+        .x = unique(df$main_key),
+        .f = \(main_key) {
+
+          if (main_key %in% unique(df_original$main_key)) {
+            DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE main_key = '{main_key}'"))
+          }
+        }
+      )
+
+      DBI::dbWriteTable(
+        con,
+        name = table_name,
+        value = df,
+        append = TRUE
+      )
+
+      message <- glue::glue("Данные таблицы '{table_name}' успешно обновлены")
+      showNotification(
+        message,
+        type = "message"
+      )
+      cli::cli_alert_success(message)
+    }
+    removeModal()
+  })
+
   ## cancel ==========================
   observeEvent(input$cancel_button, {
     removeModal()

modules/db.R

@@ -165,25 +165,6 @@ write_df_to_db <- function(df, table_name, scheme, main_key, nested_key, con) {
   date_columns   <- subset(scheme, form_type == "date", form_id, drop = TRUE)
   number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE)
 
-  excel_to_db_dates_converter <- function(date) {
-
-    parse_date1 <- tryCatch(
-      as.Date(date, tryFormats = c("%Y-%m-%d")),
-      error = function(e) NULL
-    )
-    parse_date2 <- suppressWarnings(as.Date(as.numeric(date), origin = "1899-12-30"))
-
-    date <- if (!is.null(parse_date1)) {
-      parse_date1
-    } else if (!is.na(parse_date2)) {
-      parse_date2
-    } else {
-      date
-    }
-    
-    date <- as.character(format(date, "%Y-%m-%d"))
-  }
-
   df <- df |>
     dplyr::mutate(
       # даты - к единому формату
@@ -260,4 +241,38 @@ get_nested_keys_from_table <- function(table_name, main_key, con) {
   DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT nested_key FROM {table_name} WHERE main_key == '{main_key}'")) |>
     dplyr::pull()
 
-}
+}
+
+
+### HELPERS ---------
+#' @export
+excel_to_db_dates_converter <- function(date) {
+
+  if(is.na(date)) return(NA)
+  # cli::cli_inform("date: {date} | nchar: {nchar(date)} | typeof: {typeof(date)}")
+
+  # если текст, количество символов 7, и маска соответствует 'MM.YYYY'
+  if (typeof(date) == "character" & nchar(date) == 4 & grepl("((?:19|20)\\d\\d)", date)) {
+    date <- sprintf("%s-01-01", date)
+  } else if (typeof(date) == "character" & nchar(date) == 7 & grepl("(0?[1-9]|1[012])\\.((?:19|20)\\d\\d)", date)) {
+    # если текст, количество символов 7, и маска соответствует 'MM.YYYY'
+    date <- sprintf("01.%s", date)
+  }
+
+  parse_date1 <- tryCatch(
+    as.Date(date, tryFormats = c("%d.%m.%Y", "%Y-%m-%d")),
+    error = function(e) NULL
+  )
+  parse_date2 <- suppressWarnings(as.Date(as.numeric(date), origin = "1899-12-30"))
+
+  date <- if (!is.null(parse_date1)) {
+    parse_date1
+  } else if (!is.na(parse_date2)) {
+    parse_date2
+  } else {
+    date
+  }
+  
+  date <- as.character(format(date, "%Y-%m-%d"))
+  date
+}