madeliri/shiny_form
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat: переработана работа с ключами (нет прямой привязки к использованию form_id "main_key" и "nested_key"

Browse Source
This commit is contained in:
madeliri
2026-04-11 01:57:47 +03:00
parent 31294f1958
commit e4231a023c
2 changed files with 84 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files

74
app.R
View File

@@ -76,7 +76,7 @@ nav_panels_list <- purrr::map(
# отделить схему для каждой страницы # отделить схему для каждой страницы
this_page_panels_scheme <- schm$get_schema("main") |> this_page_panels_scheme <- schm$get_schema("main") |>
dplyr::filter(!form_id %in% c("main_key", "nested_key")) |> dplyr::filter(!form_id %in% schm$get_main_key_id) |>
dplyr::filter(part == {{page_name}}) dplyr::filter(part == {{page_name}})
this_page_panels <- utils$make_panels(this_page_panels_scheme) this_page_panels <- utils$make_panels(this_page_panels_scheme)
@@ -297,17 +297,18 @@ server <- function(input, output, session) {
show_modal_for_nested_form <- function(con) { show_modal_for_nested_form <- function(con) {
ns <- NS(values$nested_form_id) ns <- NS(values$nested_form_id)
key_id <- schm$get_key_id(values$nested_form_id)
# загрузка схемы для данной вложенной формы # загрузка схемы для данной вложенной формы
this_nested_form_scheme <- schm$get_schema(values$nested_form_id) this_nested_form_scheme <- schm$get_schema(values$nested_form_id)
values$nested_id_and_types <- schm$get_id_type_list(values$nested_form_id) values$nested_id_and_types <- schm$get_id_type_list(values$nested_form_id)
# мини-схема для ключа # мини-схема для ключа
this_nested_form_key_scheme <- subset(this_nested_form_scheme, form_id == "nested_key") this_nested_form_key_scheme <- subset(this_nested_form_scheme, form_id == key_id)
if (nrow(this_nested_form_key_scheme) > 1) cli::cli_abort("количество строк не может быть больше одного для ключа") if (nrow(this_nested_form_key_scheme) > 1) cli::cli_abort("количество строк не может быть больше одного для ключа")
# выбираем все ключи из баз данных # выбираем все ключи из баз данных
kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, values$main_key, con) kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, schm, values$main_key, con)
kyes_for_this_table <- unique(c(values$nested_key, kyes_for_this_table)) kyes_for_this_table <- unique(c(values$nested_key, kyes_for_this_table))
values$nested_key <- if (length(kyes_for_this_table) == 0) NULL else kyes_for_this_table[[1]] values$nested_key <- if (length(kyes_for_this_table) == 0) NULL else kyes_for_this_table[[1]]
@@ -327,7 +328,7 @@ server <- function(input, output, session) {
subroup_scheme <- this_nested_form_scheme |> subroup_scheme <- this_nested_form_scheme |>
dplyr::filter(subgroup == {{subgroup}}) |> dplyr::filter(subgroup == {{subgroup}}) |>
dplyr::filter(!form_id %in% c("main_key", "nested_key")) dplyr::filter(form_id != key_id)
bslib::nav_panel( bslib::nav_panel(
title = subgroup, title = subgroup,
@@ -379,11 +380,13 @@ server <- function(input, output, session) {
### функция для отображения DT-таблицы для выбранной вложенной формы -------- ### функция для отображения DT-таблицы для выбранной вложенной формы --------
show_modal_for_nested_form_dt <- function(con) { show_modal_for_nested_form_dt <- function(con) {
key_id <- schm$get_key_id(values$nested_form_id)
# получение дата-фрейма # получение дата-фрейма
values$data <- db$read_df_from_db_by_id( values$data <- db$read_df_from_db_by_id(
table_name = values$nested_form_id, table_name = values$nested_form_id,
main_key = values$main_key, schm,
# nested_key = values$nested_key, main_key_value = values$main_key,
con = con con = con
) )
@@ -393,11 +396,11 @@ server <- function(input, output, session) {
date_cols <- subset(col_types, form_type == "date", form_id, drop = TRUE) date_cols <- subset(col_types, form_type == "date", form_id, drop = TRUE)
values$data <- values$data |> values$data <- values$data |>
select(-main_key) |> select(-schm$get_main_key_id) |>
mutate( mutate(
dplyr::across(tidyselect::all_of({{date_cols}}), as.Date) dplyr::across(tidyselect::all_of({{date_cols}}), as.Date)
) |> ) |>
arrange(nested_key) arrange({{key_id}})
output$dt_nested <- DT::renderDataTable( output$dt_nested <- DT::renderDataTable(
DT::datatable( DT::datatable(
@@ -448,13 +451,13 @@ server <- function(input, output, session) {
on.exit(db$close_db_connection(con, "nested_form_dt_save"), add = TRUE) on.exit(db$close_db_connection(con, "nested_form_dt_save"), add = TRUE)
export_df <- values$data |> export_df <- values$data |>
distinct() |> dplyr::distinct() |>
mutate(main_key = values$main_key, .before = 1) dplyr::mutate(!!dplyr::sym(schm$get_main_key_id) := values$main_key, .before = 1)
db$write_df_to_db( db$write_df_to_db(
df = export_df, df = export_df,
table_name = values$nested_form_id, table_name = values$nested_form_id,
schm = schm, schm,
main_key_value = values$main_key, main_key_value = values$main_key,
nested_key_value = NULL, nested_key_value = NULL,
con = con con = con
@@ -509,15 +512,16 @@ server <- function(input, output, session) {
con <- db$make_db_connection("nested_tables") con <- db$make_db_connection("nested_tables")
on.exit(db$close_db_connection(con, "nested_tables"), add = TRUE) on.exit(db$close_db_connection(con, "nested_tables"), add = TRUE)
kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, values$main_key, con) kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, schm, values$main_key, con)
if (values$nested_key %in% kyes_for_this_table) { if (values$nested_key %in% kyes_for_this_table) {
# выгрузка датафрейма по общим и вложенным ключам # выгрузка датафрейма по общим и вложенным ключам
df <- db$read_df_from_db_by_id( df <- db$read_df_from_db_by_id(
table_name = values$nested_form_id, table_name = values$nested_form_id,
main_key = values$main_key, schm,
nested_key = values$nested_key, main_key_value = values$main_key,
nested_key_value = values$nested_key,
con = con con = con
) )
@@ -537,7 +541,7 @@ server <- function(input, output, session) {
# та самая форма для ключа # та самая форма для ключа
scheme_for_key_input <- schm$get_schema(values$nested_form_id) |> scheme_for_key_input <- schm$get_schema(values$nested_form_id) |>
dplyr::filter(form_id %in% c("nested_key")) dplyr::filter(form_id == schm$get_key_id(values$nested_form_id))
ui1 <- rlang::exec( ui1 <- rlang::exec(
.fn = utils$render_forms, .fn = utils$render_forms,
@@ -558,18 +562,19 @@ server <- function(input, output, session) {
# действие при подтверждении создания новой записи # действие при подтверждении создания новой записи
observeEvent(input$confirm_create_new_nested_key, { observeEvent(input$confirm_create_new_nested_key, {
req(input$nested_key) req(input[[schm$get_key_id(values$nested_form_id)]])
con <- db$make_db_connection("confirm_create_new_key") con <- db$make_db_connection("confirm_create_new_key")
on.exit(db$close_db_connection(con, "confirm_create_new_key"), add = TRUE) on.exit(db$close_db_connection(con, "confirm_create_new_key"), add = TRUE)
existed_key <- db$get_nested_keys_from_table( existed_key <- db$get_nested_keys_from_table(
table_name = values$nested_form_id, table_name = values$nested_form_id,
main_key = values$main_key, schm,
main_key_value = values$main_key,
con con
) )
if (input$nested_key %in% existed_key) { if (input[[schm$get_key_id(values$nested_form_id)]] %in% existed_key) {
showNotification( showNotification(
sprintf("В базе уже запись с данным ключем."), sprintf("В базе уже запись с данным ключем."),
type = "error" type = "error"
@@ -577,7 +582,7 @@ server <- function(input, output, session) {
return() return()
} }
values$nested_key <- input$nested_key values$nested_key <- input[[schm$get_key_id(values$nested_form_id)]]
utils$clean_forms(values$nested_id_and_types, NS(values$nested_form_id)) utils$clean_forms(values$nested_id_and_types, NS(values$nested_form_id))
removeModal() removeModal()
show_modal_for_nested_form(con) show_modal_for_nested_form(con)
@@ -610,7 +615,7 @@ server <- function(input, output, session) {
# данные для главного ключа # данные для главного ключа
scheme_for_key_input <- schm$get_schema("main") |> scheme_for_key_input <- schm$get_schema("main") |>
dplyr::filter(form_id == "main_key") dplyr::filter(form_id == schm$get_main_key_id)
# создать форму для выбора ключа # создать форму для выбора ключа
ui1 <- rlang::exec( ui1 <- rlang::exec(
@@ -633,15 +638,16 @@ server <- function(input, output, session) {
## действие при подтверждении (проверка нового создаваемого ключа) ------- ## действие при подтверждении (проверка нового создаваемого ключа) -------
observeEvent(input$confirm_create_new_main_key, { observeEvent(input$confirm_create_new_main_key, {
req(input$main_key) req(input[[schm$get_main_key_id]])
con <- db$make_db_connection("confirm_create_new_main_key") con <- db$make_db_connection("confirm_create_new_main_key")
on.exit(db$close_db_connection(con, "confirm_create_new_key"), add = TRUE) on.exit(db$close_db_connection(con, "confirm_create_new_key"), add = TRUE)
existed_key <- db$get_keys_from_table("main", con) existed_key <- db$get_keys_from_table("main", schm, con)
print(existed_key)
# если введенный ключ уже есть в базе # если введенный ключ уже есть в базе
if (input$main_key %in% existed_key) { if (input[[schm$get_main_key_id]] %in% existed_key) {
showNotification( showNotification(
sprintf("В базе уже запись с данным ключем."), sprintf("В базе уже запись с данным ключем."),
type = "error" type = "error"
@@ -649,7 +655,7 @@ server <- function(input, output, session) {
return() return()
} }
values$main_key <- input$main_key values$main_key <- input[[schm$get_main_key_id]]
utils$clean_forms(schm$get_id_type_list("main")) utils$clean_forms(schm$get_id_type_list("main"))
removeModal() removeModal()
@@ -692,13 +698,14 @@ server <- function(input, output, session) {
## список ключей для загрузки данных ------------------- ## список ключей для загрузки данных -------------------
observeEvent(input$load_data_button, { observeEvent(input$load_data_button, {
con <- db$make_db_connection("load_data_button") con <- db$make_db_connection("load_data_button")
on.exit(db$close_db_connection(con, "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(dbListTables(con)) != 0 && "main" %in% DBI::dbListTables(con)) {
# GET DATA files # GET DATA files
ids <- db$get_keys_from_table("main", con) ids <- db$get_keys_from_table("main", schm, con)
ui_load_menu <- renderUI({ ui_load_menu <- renderUI({
selectizeInput( selectizeInput(
@@ -741,7 +748,8 @@ server <- function(input, output, session) {
df <- db$read_df_from_db_by_id( df <- db$read_df_from_db_by_id(
table_name = "main", table_name = "main",
main_key = input$load_data_key_selector, schm = schm,
main_key_value = input$load_data_key_selector,
con = con con = con
) )
@@ -933,6 +941,8 @@ server <- function(input, output, session) {
file <- input$upload_xlsx$datapath file <- input$upload_xlsx$datapath
wb <- openxlsx2::wb_load(file) wb <- openxlsx2::wb_load(file)
main_key_id <- schm$get_main_key_id
# проверка на наличие всех листов в файле # проверка на наличие всех листов в файле
if (!all(schm$all_tables_names %in% openxlsx2::wb_get_sheet_names(wb))) { if (!all(schm$all_tables_names %in% openxlsx2::wb_get_sheet_names(wb))) {
cli::cli_alert_warning("данные в файле '{file} не соответствуют схеме'") cli::cli_alert_warning("данные в файле '{file} не соответствуют схеме'")
@@ -980,7 +990,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({{date_columns}}), \(x) purrr::map_chr(x, db$excel_to_db_dates_converter)),
) |> ) |>
select(all_of(unique(c("main_key", scheme$form_id)))) select(all_of(unique(c(main_key_id, scheme$form_id))))
df_original <- DBI::dbReadTable(con, table_name) |> df_original <- DBI::dbReadTable(con, table_name) |>
as_tibble() as_tibble()
@@ -988,11 +998,11 @@ server <- function(input, output, session) {
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) cli::cli_abort("not implemented yet")
walk( walk(
.x = unique(df$main_key), .x = unique(df[[main_key_id]]),
.f = \(main_key) { .f = \(main_key) {
if (main_key %in% unique(df_original$main_key)) { if (main_key %in% unique(df_original[[main_key_id]])) {
DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE main_key = '{main_key}'")) DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key_id} = '{main_key}'"))
} }
} }
) )

60
modules/db.R
View File

@@ -225,29 +225,38 @@ write_df_to_db <- function(
#' @export #' @export
#' reading tables from db by name and id ======== #' reading tables from db by name and id ========
read_df_from_db_by_id <- function(table_name, main_key, nested_key, con) { read_df_from_db_by_id <- function(
table_name,
schm,
main_key_value,
nested_key_value,
con
) {
main_key_id <- schm$get_main_key_id
# check if this table exist # check if this table exist
if (table_name == "main") { if (table_name == "main") {
query <- glue::glue(" query <- glue::glue("
SELECT * SELECT *
FROM main FROM main
WHERE main_key = '{main_key}' WHERE {main_key_id} = '{main_key_value}'
") ")
} }
if (table_name != "main") { if (table_name != "main") {
if(!missing(nested_key)) { if(!missing(nested_key_value)) {
key_id <- schm$get_key_id(table_name)
query <- glue::glue(" query <- glue::glue("
SELECT * SELECT *
FROM {table_name} FROM {table_name}
WHERE main_key = '{main_key}' AND nested_key = '{nested_key}' WHERE {main_key_id} = '{main_key_value}' AND {key_id} = '{nested_key_value}'
") ")
} else { } else {
query <- glue::glue(" query <- glue::glue("
SELECT * SELECT *
FROM {table_name} FROM {table_name}
WHERE main_key = '{main_key}' WHERE {main_key_id} = '{main_key_value}'
") ")
} }
} }
@@ -255,17 +264,21 @@ read_df_from_db_by_id <- function(table_name, main_key, nested_key, con) {
} }
#' @export #' @export
get_keys_from_table <- function(table_name, con) { get_keys_from_table <- function(table_name, schm, con) {
DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT main_key FROM {table_name}")) |> main_key_id <- schm$get_main_key_id
DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT {main_key_id} FROM {table_name}")) |>
dplyr::pull() dplyr::pull()
} }
#' @export #' @export
get_nested_keys_from_table <- function(table_name, main_key, con) { get_nested_keys_from_table <- function(table_name, schm, main_key_value, con) {
DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT nested_key FROM {table_name} WHERE main_key == '{main_key}'")) |> main_key_id <- schm$get_main_key_id
key_id <- schm$get_key_id(table_name)
DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT {key_id} FROM {table_name} WHERE {main_key_id} == '{main_key_value}'")) |>
dplyr::pull() dplyr::pull()
} }
@@ -275,15 +288,26 @@ get_nested_keys_from_table <- function(table_name, main_key, con) {
#' @export #' @export
excel_to_db_dates_converter <- function(date) { excel_to_db_dates_converter <- function(date) {
if(is.na(date)) return(NA) if (is.na(date)) return(NA)
# cli::cli_inform("date: {date} | nchar: {nchar(date)} | typeof: {typeof(date)}") # cli::cli_inform("date: {date} | nchar: {nchar(date)} | typeof: {typeof(date)}")
# если текст, количество символов 7, и маска соответствует 'MM.YYYY' # если текст, количество символов 7, и маска соответствует 'MM.YYYY'
if (typeof(date) == "character" & nchar(date) == 4 & grepl("((?:19|20)\\d\\d)", date)) { if (typeof(date) == "character") {
date <- sprintf("%s-01-01", date) date <- trimws(date)
} else if (typeof(date) == "character" & nchar(date) == 7 & grepl("(0?[1-9]|1[012])\\.((?:19|20)\\d\\d)", date)) {
# если текст, количество символов 7, и маска соответствует 'MM.YYYY' if (nchar(date) == 4 & grepl("((?:19|20)\\d\\d)", date)) {
date <- sprintf("01.%s", date) date <- sprintf("%s-01-01", date)
} else if (nchar(date) == 7 & grepl("(0?[1-9]|1[012])\\.((?:19|20)\\d\\d)", date)) {
# если текст, количество символов 7, и маска соответствует 'MM.YYYY'
date <- sprintf("01.%s", date)
} else if (nchar(date) == 10 & grepl("([12][0-9]|3[01]|0?[1-9])\\.(0?[1-9]|1[012])\\.((?:19|20)\\d\\d)", date)) {
# ...
} else if (nchar(date) == 10 & grepl("((?:19|20)\\d\\d)-(0?[1-9]|1[012])-([12][0-9]|3[01]|0?[1-9])", date)) {
# ...
} else {
cli::cli_alert_warning("can't compute date from '{date}'")
return(date)
}
} }
parse_date1 <- tryCatch( parse_date1 <- tryCatch(
@@ -292,7 +316,7 @@ excel_to_db_dates_converter <- function(date) {
) )
parse_date2 <- suppressWarnings(as.Date(as.numeric(date), origin = "1899-12-30")) parse_date2 <- suppressWarnings(as.Date(as.numeric(date), origin = "1899-12-30"))
date <- if (!is.null(parse_date1)) { fin_date <- if (!is.null(parse_date1)) {
parse_date1 parse_date1
} else if (!is.na(parse_date2)) { } else if (!is.na(parse_date2)) {
parse_date2 parse_date2
@@ -300,6 +324,6 @@ excel_to_db_dates_converter <- function(date) {
date date
} }
date <- as.character(format(date, "%Y-%m-%d")) fin_date <- as.character(format(fin_date, "%Y-%m-%d"))
date fin_date
} }