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

feat: работа с несколькими схемами в пределах одного приложения

Browse Source
This commit is contained in:
madeliri
2026-04-13 12:43:47 +03:00
parent dbfe27bbb8
commit 1b7220e647
6 changed files with 177 additions and 116 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@@ -1,4 +1,5 @@
/renv /renv
/temp
.Renviron .Renviron
.DS_Store .DS_Store

211
app.R
View File

@@ -22,9 +22,9 @@ box::use(
) )
# SETTINGS ================================ # SETTINGS ================================
FILE_SCHEME <- fs::path("configs/schemas", "schema.xlsx") FILE_SCHEME <- fs::path("configs/schemas", "schema.xlsx")
AUTH_ENABLED <- Sys.getenv("FORM_AUTH_ENABLED", FALSE) AUTH_ENABLED <- Sys.getenv("FORM_AUTH_ENABLED", FALSE)
HEADER_TEXT <- sprintf("%s (%s)", Sys.getenv("FORM_TITLE", "NA"), Sys.getenv("FORM_VERSION", "NA")) HEADER_TEXT <- sprintf("%s (%s)", Sys.getenv("FORM_TITLE", "NA"), Sys.getenv("FORM_VERSION", "NA"))
global_options$set_global_options( global_options$set_global_options(
shiny.host = "0.0.0.0" shiny.host = "0.0.0.0"
@@ -39,19 +39,7 @@ rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!") if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!")
# SCHEME_MAIN UNPACK ========================== # SCHEME_MAIN UNPACK ==========================
schm <- readRDS("scheme.rds") schms <- readRDS("scheme.rds")
# two_obj <- purrr::map(
# c(one = "configs/schemas/schema.xlsx", two = "configs/schemas/schema_example.xlsx"),
# scheme_R6$new
# )
# two_obj[["a"]]$get_schema("main")
# object.size(two_obj)
# saveRDS(schm, "test.rds")
# readRDS("test.rds")
# check tables
# UI ======================= # UI =======================
ui <- page_sidebar( ui <- page_sidebar(
@@ -78,7 +66,7 @@ ui <- page_sidebar(
# init auth ======================= # init auth =======================
if (AUTH_ENABLED) { if (AUTH_ENABLED) {
# shinymanager::set_labels("en", "Please authenticate" = "aboba") # shinymanager::set_labels("en", "Please authenticate" = "scheme()")
ui <- ui |> ui <- ui |>
shinymanager::secure_app( shinymanager::secure_app(
status = "primary", status = "primary",
@@ -153,6 +141,10 @@ server <- function(input, output, session) {
nested_key = NULL, nested_key = NULL,
nested_form_id = NULL nested_form_id = NULL
) )
scheme <- reactiveVal("schema_example") # наименование выбранной схемы
mhcs <- reactiveVal(schms[["schema_example"]]) # объект для выбранной схемы
observers_started <- reactiveVal(NULL)
main_form_is_empty <- reactiveVal(TRUE) main_form_is_empty <- reactiveVal(TRUE)
validator_main <- reactiveVal(NULL) validator_main <- reactiveVal(NULL)
validator_nested <- reactiveVal(NULL) validator_nested <- reactiveVal(NULL)
@@ -162,16 +154,31 @@ server <- function(input, output, session) {
if (main_form_is_empty()) { if (main_form_is_empty()) {
validator_main(NULL) validator_main(NULL)
"Для начала работы нужно создать новую запись или загрузить существующую!"
div(
"Для начала работы нужно создать новую запись или загрузить существующую!",
paste(getOption("enabled_schemas"), collapse = ", "),
shiny::radioButtons(
"schmes_selector",
label = "Выбрать базу данных для работы",
choices = getOption("enabled_schemas"),
selected = scheme()
)
)
} else { } else {
# list of rendered panels # list of rendered panels
validator_main(data_validation$init_val(schm$get_schema("main"))) validator_main(data_validation$init_val(mhcs()$get_schema("main")))
validator_main()$enable() validator_main()$enable()
schm$get_main_form_ui mhcs()$get_main_form_ui
} }
}) })
observeEvent(input$schmes_selector, {
scheme(input$schmes_selector)
mhcs(schms[[input$schmes_selector]])
})
# ========================================== # ==========================================
# ОБЩИЕ ФУНКЦИИ ============================ # ОБЩИЕ ФУНКЦИИ ============================
# ========================================== # ==========================================
@@ -184,8 +191,8 @@ server <- function(input, output, session) {
ns ns
) { ) {
input_types <- unname(schm$get_id_type_list(table_name)) input_types <- unname(mhcs()$get_id_type_list(table_name))
input_ids <- names(schm$get_id_type_list(table_name)) input_ids <- names(mhcs()$get_id_type_list(table_name))
if (missing(ns)) ns <- NULL if (missing(ns)) ns <- NULL
# transform df to list # transform df to list
@@ -203,7 +210,7 @@ server <- function(input, output, session) {
form_id = x_id, form_id = x_id,
form_type = x_type, form_type = x_type,
value = df[[x_id]], value = df[[x_id]],
scheme = schm$get_schema(table_name), scheme = mhcs()$get_schema(table_name),
ns = ns ns = ns
) )
} }
@@ -218,7 +225,7 @@ server <- function(input, output, session) {
con con
) { ) {
nested_key_id <- schm$get_key_id(table_name) nested_key_id <- mhcs()$get_key_id(table_name)
input_types <- unname(id_and_types_list) input_types <- unname(id_and_types_list)
input_ids <- names(id_and_types_list) input_ids <- names(id_and_types_list)
@@ -255,7 +262,7 @@ server <- function(input, output, session) {
if (table_name == "main") { if (table_name == "main") {
exported_df <- exported_df |> exported_df <- exported_df |>
mutate( mutate(
!!dplyr::sym(schm$get_main_key_id) := values$main_key, !!dplyr::sym(mhcs()$get_main_key_id) := values$main_key,
.before = 1 .before = 1
) )
} }
@@ -264,7 +271,7 @@ server <- function(input, output, session) {
if (table_name != "main") { if (table_name != "main") {
exported_df <- exported_df |> exported_df <- exported_df |>
mutate( mutate(
!!dplyr::sym(schm$get_main_key_id) := values$main_key, !!dplyr::sym(mhcs()$get_main_key_id) := values$main_key,
!!dplyr::sym(nested_key_id) := values$nested_key, !!dplyr::sym(nested_key_id) := values$nested_key,
.before = 1 .before = 1
) )
@@ -276,7 +283,7 @@ server <- function(input, output, session) {
db$write_df_to_db( db$write_df_to_db(
df = exported_df, df = exported_df,
table_name = table_name, table_name = table_name,
schm = schm, schm = mhcs(),
main_key_value = values$main_key, main_key_value = values$main_key,
nested_key_value = values$nested_key, nested_key_value = values$nested_key,
con = con con = con
@@ -287,39 +294,51 @@ server <- function(input, output, session) {
# NESTED FORMS ======================= # NESTED FORMS =======================
# ==================================== # ====================================
## кнопки для каждой вложенной таблицы ------------------------------- ## кнопки для каждой вложенной таблицы -------------------------------
purrr::walk( observe({
.x = schm$nested_tables_names,
.f = \(nested_form_id) {
observeEvent(input[[nested_form_id]], { # проверка инициализированы ли для этой схемы наблюдатели для кнопок вложенных таблиц
req(values$main_key) is_observer_is_started <- (isolate(scheme()) %in% isolate(observers_started()))
con <- db$make_db_connection("nested_tables") if (is_observer_is_started) return()
on.exit(db$close_db_connection(con, "nested_tables"), add = TRUE) purrr::walk(
.x = mhcs()$nested_tables_names,
.f = \(nested_form_id) {
observeEvent(input[[nested_form_id]], {
req(values$main_key)
con <- db$make_db_connection(scheme(),"nested_tables")
on.exit(db$close_db_connection(con, "nested_tables"), add = TRUE)
values$nested_form_id <- nested_form_id
values$nested_key <- NULL # для нормальной работы реактивных значений
show_modal_for_nested_form(con)
})
}
)
values$nested_form_id <- nested_form_id # добавить идентификатор текущей схемы в список иницииализированных валидаторов
values$nested_key <- NULL # для нормальной работы реактивных значений observers_started(c(
show_modal_for_nested_form(con) isolate(observers_started()), isolate(scheme())
))
}) })
}
)
## функция отображения вложенной формы для выбранной таблицы -------- ## функция отображения вложенной формы для выбранной таблицы --------
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) key_id <- mhcs()$get_key_id(values$nested_form_id)
# загрузка схемы для данной вложенной формы # загрузка схемы для данной вложенной формы
this_nested_form_scheme <- schm$get_schema(values$nested_form_id) this_nested_form_scheme <- mhcs()$get_schema(values$nested_form_id)
# мини-схема для ключа # мини-схема для ключа
this_nested_form_key_scheme <- subset(this_nested_form_scheme, form_id == key_id) 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, schm, values$main_key, con) kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, mhcs(), 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))
kyes_for_this_table <- sort(kyes_for_this_table) kyes_for_this_table <- sort(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]]
@@ -394,23 +413,23 @@ 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) key_id <- mhcs()$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,
schm, mhcs(),
main_key_value = values$main_key, main_key_value = values$main_key,
con = con con = con
) )
col_types <- schm$get_schema(values$nested_form_id) |> col_types <- mhcs()$get_schema(values$nested_form_id) |>
dplyr::distinct(form_id, form_type, form_label) dplyr::distinct(form_id, form_type, form_label)
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(-schm$get_main_key_id) |> select(-mhcs()$get_main_key_id) |>
mutate( mutate(
dplyr::across(tidyselect::all_of({{date_cols}}), as.Date) dplyr::across(tidyselect::all_of({{date_cols}}), as.Date)
) |> ) |>
@@ -453,7 +472,7 @@ server <- function(input, output, session) {
### кнопка: отображение DT ----------------------------- ### кнопка: отображение DT -----------------------------
observeEvent(input$nested_form_dt_button, { observeEvent(input$nested_form_dt_button, {
con <- db$make_db_connection("nested_form_save_button") con <- db$make_db_connection(scheme(),"nested_form_save_button")
on.exit(db$close_db_connection(con, "nested_form_save_button"), add = TRUE) on.exit(db$close_db_connection(con, "nested_form_save_button"), add = TRUE)
removeModal() removeModal()
@@ -463,17 +482,17 @@ server <- function(input, output, session) {
### кнопка: сохранить изменения DT -------------------- ### кнопка: сохранить изменения DT --------------------
observeEvent(input$nested_form_dt_save, { observeEvent(input$nested_form_dt_save, {
con <- db$make_db_connection("nested_form_dt_save") con <- db$make_db_connection(scheme(),"nested_form_dt_save")
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 |>
dplyr::distinct() |> dplyr::distinct() |>
dplyr::mutate(!!dplyr::sym(schm$get_main_key_id) := values$main_key, .before = 1) dplyr::mutate(!!dplyr::sym(mhcs()$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, mhcs(),
main_key_value = values$main_key, main_key_value = values$main_key,
nested_key_value = NULL, nested_key_value = NULL,
con = con con = con
@@ -487,20 +506,20 @@ server <- function(input, output, session) {
observeEvent(input$nested_form_save_button, { observeEvent(input$nested_form_save_button, {
req(values$nested_form_id) req(values$nested_form_id)
con <- db$make_db_connection("nested_form_save_button") con <- db$make_db_connection(scheme(),"nested_form_save_button")
on.exit(db$close_db_connection(con, "nested_form_save_button"), add = TRUE) on.exit(db$close_db_connection(con, "nested_form_save_button"), add = TRUE)
# сохраняем данные основной формы!!! # сохраняем данные основной формы!!!
save_inputs_to_db( save_inputs_to_db(
table_name = "main", table_name = "main",
id_and_types_list = schm$get_id_type_list("main"), id_and_types_list = mhcs()$get_id_type_list("main"),
con = con con = con
) )
# сохраняем данные текущей вложенной таблицы # сохраняем данные текущей вложенной таблицы
save_inputs_to_db( save_inputs_to_db(
table_name = values$nested_form_id, table_name = values$nested_form_id,
id_and_types_list = schm$get_id_type_list(values$nested_form_id), id_and_types_list = mhcs()$get_id_type_list(values$nested_form_id),
ns = NS(values$nested_form_id), ns = NS(values$nested_form_id),
con = con con = con
) )
@@ -536,17 +555,17 @@ server <- function(input, output, session) {
observeEvent(values$nested_key, { observeEvent(values$nested_key, {
con <- db$make_db_connection("nested_tables") con <- db$make_db_connection(scheme(),"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, schm, values$main_key, con) kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, mhcs(), 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,
schm, mhcs(),
main_key_value = values$main_key, main_key_value = values$main_key,
nested_key_value = values$nested_key, nested_key_value = values$nested_key,
con = con con = con
@@ -556,7 +575,7 @@ server <- function(input, output, session) {
load_data_to_form( load_data_to_form(
df = df, df = df,
table_name = values$nested_form_id, table_name = values$nested_form_id,
schm, mhcs(),
ns = NS(values$nested_form_id) ns = NS(values$nested_form_id)
) )
} }
@@ -568,8 +587,8 @@ server <- function(input, output, session) {
removeModal() removeModal()
# та самая форма для ключа # та самая форма для ключа
scheme_for_key_input <- schm$get_schema(values$nested_form_id) |> scheme_for_key_input <- mhcs()$get_schema(values$nested_form_id) |>
dplyr::filter(form_id == schm$get_key_id(values$nested_form_id)) dplyr::filter(form_id == mhcs()$get_key_id(values$nested_form_id))
ui1 <- rlang::exec( ui1 <- rlang::exec(
.fn = utils$render_forms, .fn = utils$render_forms,
@@ -590,19 +609,19 @@ server <- function(input, output, session) {
# действие при подтверждении создания новой записи # действие при подтверждении создания новой записи
observeEvent(input$confirm_create_new_nested_key, { observeEvent(input$confirm_create_new_nested_key, {
req(input[[schm$get_key_id(values$nested_form_id)]]) req(input[[mhcs()$get_key_id(values$nested_form_id)]])
con <- db$make_db_connection("confirm_create_new_key") con <- db$make_db_connection(scheme(),"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,
schm, mhcs(),
main_key_value = values$main_key, main_key_value = values$main_key,
con con
) )
if (input[[schm$get_key_id(values$nested_form_id)]] %in% existed_key) { if (input[[mhcs()$get_key_id(values$nested_form_id)]] %in% existed_key) {
showNotification( showNotification(
sprintf("В базе уже запись с данным ключем."), sprintf("В базе уже запись с данным ключем."),
type = "error" type = "error"
@@ -610,8 +629,8 @@ server <- function(input, output, session) {
return() return()
} }
values$nested_key <- input[[schm$get_key_id(values$nested_form_id)]] values$nested_key <- input[[mhcs()$get_key_id(values$nested_form_id)]]
utils$clean_forms(values$nested_form_id, schm, NS(values$nested_form_id)) utils$clean_forms(values$nested_form_id, mhcs(), NS(values$nested_form_id))
removeModal() removeModal()
show_modal_for_nested_form(con) show_modal_for_nested_form(con)
@@ -643,8 +662,8 @@ server <- function(input, output, session) {
observeEvent(input$add_new_main_key_button, { observeEvent(input$add_new_main_key_button, {
# данные для главного ключа # данные для главного ключа
scheme_for_key_input <- schm$get_schema("main") |> scheme_for_key_input <- mhcs()$get_schema("main") |>
dplyr::filter(form_id == schm$get_main_key_id) dplyr::filter(form_id == mhcs()$get_main_key_id)
# создать форму для выбора ключа # создать форму для выбора ключа
ui1 <- rlang::exec( ui1 <- rlang::exec(
@@ -667,14 +686,14 @@ server <- function(input, output, session) {
## действие при подтверждении (проверка нового создаваемого ключа) ------- ## действие при подтверждении (проверка нового создаваемого ключа) -------
observeEvent(input$confirm_create_new_main_key, { observeEvent(input$confirm_create_new_main_key, {
req(input[[schm$get_main_key_id]]) req(input[[mhcs()$get_main_key_id]])
con <- db$make_db_connection("confirm_create_new_main_key") con <- db$make_db_connection(scheme(),"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)
new_main_key <- trimws(input[[schm$get_main_key_id]]) new_main_key <- trimws(input[[mhcs()$get_main_key_id]])
existed_key <- db$get_keys_from_table("main", schm, con) existed_key <- db$get_keys_from_table("main", mhcs(), con)
# если введенный ключ уже есть в базе # если введенный ключ уже есть в базе
if (new_main_key %in% existed_key) { if (new_main_key %in% existed_key) {
@@ -688,7 +707,7 @@ server <- function(input, output, session) {
values$main_key <- new_main_key values$main_key <- new_main_key
main_form_is_empty(FALSE) main_form_is_empty(FALSE)
log_action_to_db("creating new key", values$main_key, con) log_action_to_db("creating new key", values$main_key, con)
utils$clean_forms("main", schm) utils$clean_forms("main", mhcs())
removeModal() removeModal()
}) })
@@ -712,7 +731,7 @@ server <- function(input, output, session) {
# rewrite all inputs with empty data # rewrite all inputs with empty data
values$main_key <- NULL values$main_key <- NULL
utils$clean_forms("main", schm) utils$clean_forms("main", mhcs())
main_form_is_empty(TRUE) main_form_is_empty(TRUE)
removeModal() removeModal()
@@ -723,12 +742,12 @@ server <- function(input, output, session) {
observeEvent(input$save_data_button, { observeEvent(input$save_data_button, {
req(values$main_key) req(values$main_key)
con <- db$make_db_connection("save_data_button") con <- db$make_db_connection(scheme(),"save_data_button")
on.exit(db$close_db_connection(con, "save_data_button"), add = TRUE) on.exit(db$close_db_connection(con, "save_data_button"), add = TRUE)
save_inputs_to_db( save_inputs_to_db(
table_name = "main", table_name = "main",
id_and_types_list = schm$get_id_type_list("main"), id_and_types_list = mhcs()$get_id_type_list("main"),
con = con con = con
) )
@@ -742,13 +761,13 @@ 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(scheme(),"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", schm, con) ids <- db$get_keys_from_table("main", mhcs(), con)
ui_load_menu <- renderUI({ ui_load_menu <- renderUI({
selectizeInput( selectizeInput(
@@ -786,12 +805,12 @@ server <- function(input, output, session) {
observeEvent(input$load_data, { observeEvent(input$load_data, {
req(input$load_data_key_selector) req(input$load_data_key_selector)
con <- db$make_db_connection("load_data") con <- db$make_db_connection(scheme(),"load_data")
on.exit(db$close_db_connection(con, "load_data"), add = TRUE) on.exit(db$close_db_connection(con, "load_data"), add = TRUE)
df <- db$read_df_from_db_by_id( df <- db$read_df_from_db_by_id(
table_name = "main", table_name = "main",
schm = schm, schm = mhcs(),
main_key_value = input$load_data_key_selector, main_key_value = input$load_data_key_selector,
con = con con = con
) )
@@ -799,7 +818,7 @@ server <- function(input, output, session) {
load_data_to_form( load_data_to_form(
df = df, df = df,
table_name = "main", table_name = "main",
schm mhcs()
) )
values$main_key <- input$load_data_key_selector values$main_key <- input$load_data_key_selector
@@ -812,21 +831,21 @@ server <- function(input, output, session) {
## export to .xlsx ==== ## export to .xlsx ====
output$downloadData <- downloadHandler( output$downloadData <- downloadHandler(
filename = paste0("test_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx"), filename = paste0(isolate(scheme()), "_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx"),
content = function(file) { content = function(file) {
con <- db$make_db_connection("downloadData") con <- db$make_db_connection(scheme(),"downloadData")
on.exit(db$close_db_connection(con, "downloadData"), add = TRUE) on.exit(db$close_db_connection(con, "downloadData"), add = TRUE)
# get all data # get all data
list_of_df <- purrr::map( list_of_df <- purrr::map(
.x = purrr::set_names(schm$all_tables_names), .x = purrr::set_names(mhcs()$all_tables_names),
.f = \(x) { .f = \(x) {
df <- read_df_from_db_all(x, con) |> df <- read_df_from_db_all(x, con) |>
tibble::as_tibble() tibble::as_tibble()
# handle with data # handle with data
scheme <- schm$get_schema(x) scheme <- mhcs()$get_schema(x)
date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE) date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE)
number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE) number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE)
@@ -879,7 +898,7 @@ server <- function(input, output, session) {
# iterate by scheme parts # iterate by scheme parts
purrr::walk( purrr::walk(
.x = unique(schm$get_schema("main")$part), .x = unique(mhcs()$get_schema("main")$part),
.f = \(x_iter1) { .f = \(x_iter1) {
# write level 1 header # write level 1 header
HEADER_1 <- paste("#", x_iter1, "\n") HEADER_1 <- paste("#", x_iter1, "\n")
@@ -887,14 +906,14 @@ server <- function(input, output, session) {
# iterate by level2 headers (subgroups) # iterate by level2 headers (subgroups)
purrr::walk( purrr::walk(
.x = dplyr::pull(unique(subset(schm$get_schema("main"), part == x_iter1, "subgroup"))), .x = dplyr::pull(unique(subset(mhcs()$get_schema("main"), part == x_iter1, "subgroup"))),
.f = \(x_iter2) { .f = \(x_iter2) {
# get header 2 name # get header 2 name
HEADER_2 <- paste("##", x_iter2, "\n") HEADER_2 <- paste("##", x_iter2, "\n")
# for some reason set litle scheme... # for some reason set litle scheme...
litle_scheme <- subset( litle_scheme <- subset(
x = schm$get_schema("main"), x = mhcs()$get_schema("main"),
subset = part == x_iter1 & subgroup == x_iter2, subset = part == x_iter1 & subgroup == x_iter2,
select = c("form_id", "form_label", "form_type") select = c("form_id", "form_label", "form_type")
) |> ) |>
@@ -981,25 +1000,25 @@ server <- function(input, output, session) {
observeEvent(input$button_upload_data_from_xlsx_confirm, { observeEvent(input$button_upload_data_from_xlsx_confirm, {
req(input$upload_xlsx) req(input$upload_xlsx)
con <- db$make_db_connection("button_upload_data_from_xlsx_confirm") con <- db$make_db_connection(scheme(),"button_upload_data_from_xlsx_confirm")
on.exit(db$close_db_connection(con, "button_upload_data_from_xlsx_confirm"), add = TRUE) on.exit(db$close_db_connection(con, "button_upload_data_from_xlsx_confirm"), add = TRUE)
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 main_key_id <- mhcs()$get_main_key_id
# проверка на наличие всех листов в файле # проверка на наличие всех листов в файле
if (!all(schm$all_tables_names %in% openxlsx2::wb_get_sheet_names(wb))) { if (!all(mhcs()$all_tables_names %in% openxlsx2::wb_get_sheet_names(wb))) {
cli::cli_alert_warning("данные в файле '{file} не соответствуют схеме'") cli::cli_alert_warning("данные в файле '{file} не соответствуют схеме'")
return() return()
} }
# проверка схемы -------------- # проверка схемы --------------
for (table_name in schm$all_tables_names) { for (table_name in mhcs()$all_tables_names) {
df <- openxlsx2::read_xlsx(wb, table_name) df <- openxlsx2::read_xlsx(wb, table_name)
scheme <- schm$get_schema(table_name) |> scheme <- mhcs()$get_schema(table_name) |>
filter(!form_type %in% c("description", "nested_forms")) filter(!form_type %in% c("description", "nested_forms"))
# столбцы в таблицы и схема # столбцы в таблицы и схема
@@ -1023,10 +1042,10 @@ server <- function(input, output, session) {
} }
# обновление данных # обновление данных
for (table_name in schm$all_tables_names) { for (table_name in mhcs()$all_tables_names) {
df <- openxlsx2::read_xlsx(wb, table_name) df <- openxlsx2::read_xlsx(wb, table_name)
scheme <- schm$get_schema(table_name) |> scheme <- mhcs()$get_schema(table_name) |>
filter(!form_type %in% c("description", "nested_forms")) filter(!form_type %in% c("description", "nested_forms"))
date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE) date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE)
@@ -1139,7 +1158,7 @@ server <- function(input, output, session) {
# output$display_log <- renderUI({ # output$display_log <- renderUI({
# con <- db$make_db_connection("display_log") # con <- db$make_db_connection(scheme(),"display_log")
# on.exit(db$close_db_connection(con, "display_log"), add = TRUE) # on.exit(db$close_db_connection(con, "display_log"), add = TRUE)
# query <- if (!is.null(values$main_key)) { # query <- if (!is.null(values$main_key)) {

4
modules/db.R
View File

@@ -2,9 +2,9 @@
#' @export #' @export
#' @description Function to open connection to db, disigned to easy dubugging. #' @description Function to open connection to db, disigned to easy dubugging.
#' @param where text mark to distingiush calss #' @param where text mark to distingiush calss
make_db_connection = function(where = "") { make_db_connection = function(scheme, where = "") {
if (getOption("APP.DEBUG", FALSE)) message("=== DB CONNECT ", where) if (getOption("APP.DEBUG", FALSE)) message("=== DB CONNECT ", where)
DBI::dbConnect(RSQLite::SQLite(), getOption("APP.FILE_DB", FALSE)) DBI::dbConnect(RSQLite::SQLite(), fs::path("db", scheme, ext = "sqlite"))
} }
#' @export #' @export

57
modules/global_options.R
View File

@@ -3,17 +3,19 @@
set_global_options = function( set_global_options = function(
SYMBOL_DELIM = "; ", SYMBOL_DELIM = "; ",
APP.DEBUG = FALSE, APP.DEBUG = FALSE,
APP.FILE_DB = fs::path("data.sqlite"), # APP.FILE_DB = fs::path("data.sqlite"),
shiny.host = "127.0.0.1", shiny.host = "127.0.0.1",
shiny.port = 1337, shiny.port = 1337,
enabled_schemas = c("schema", "schema_example"),
... ...
) { ) {
options( options(
SYMBOL_DELIM = SYMBOL_DELIM, SYMBOL_DELIM = SYMBOL_DELIM,
APP.DEBUG = APP.DEBUG, APP.DEBUG = APP.DEBUG,
APP.FILE_DB = APP.FILE_DB, # APP.FILE_DB = APP.FILE_DB,
shiny.host = shiny.host, shiny.host = shiny.host,
shiny.port = shiny.port, shiny.port = shiny.port,
enabled_schemas = enabled_schemas,
... ...
) )
} }
@@ -23,21 +25,27 @@ check_and_init_scheme = function() {
cli::cli_inform(c("*" = "проверка схемы...")) cli::cli_inform(c("*" = "проверка схемы..."))
scheme_file <- fs::path("configs/schemas", "schema.xlsx") # scheme_file <- fs::path("configs/schemas", "schema.xlsx")
hash_file <- "schema_hash.rds" scheme_names <- getOption("enabled_schemas")
scheme_file <- paste0("configs/schemas/", scheme_names, ".xlsx")
scheme_file <- stats::setNames(scheme_file, scheme_names)
db_files <- paste0("db/", scheme_names, ".sqlite")
hash_file <- "temp/schema_hash.rds"
# #
exist_hash <- tools::md5sum(scheme_file) exist_hash <- tools::md5sum(scheme_file)
# если первый запуск (нет файла с кешем) инициализация схемы # если первый запуск (нет файла с кешем) инициализация схемы
if (!file.exists("schema_hash.rds") | !file.exists("scheme.rds")) { if (!file.exists(hash_file) | !file.exists("scheme.rds") | !all(file.exists(db_files))) {
init_scheme(scheme_file) init_scheme(scheme_file)
# в ином случае - проверяем кэш # в ином случае - проверяем кэш
} else { } else {
saved_hash <- readRDS("schema_hash.rds") saved_hash <- readRDS(hash_file)
# если данные были изменены проводим реинициализацию таблицы и схемы # если данные были изменены проводим реинициализацию таблицы и схемы
if (!all(exist_hash == saved_hash)) { if (!all(exist_hash == saved_hash)) {
@@ -50,6 +58,7 @@ check_and_init_scheme = function() {
} }
# перезаписываем файл # перезаписываем файл
if (!dir.exists("temp")) dir.create("temp")
saveRDS(exist_hash, hash_file) saveRDS(exist_hash, hash_file)
} }
@@ -62,12 +71,34 @@ init_scheme = function(scheme_file) {
modules/scheme_generator[scheme_R6] modules/scheme_generator[scheme_R6]
) )
con <- db$make_db_connection()
on.exit(db$close_db_connection(con), add = TRUE)
cli::cli_h1("Инициализация схемы") cli::cli_h1("Инициализация схемы")
schm <- scheme_R6$new(scheme_file) schms <- purrr::map2(
db$check_if_table_is_exist_and_init_if_not(schm, con) .x = scheme_file,
.y = names(scheme_file),
\(x, y) {
saveRDS(schm, "scheme.rds") con <- db$make_db_connection(y)
} on.exit(db$close_db_connection(con), add = TRUE)
schm <- scheme_R6$new(x)
db$check_if_table_is_exist_and_init_if_not(schm, con)
schm
}
)
# проверка на наличие дублирующихся названий вложенных таблиц
nested_tables_ids <- purrr::map(
names(schms),
\(x) schms[[x]]$nested_tables_names
)
nested_tables_ids <- unlist(nested_tables_ids)
tab <- table(nested_tables_ids)
# если встречается хоть одно значение несколько раз - начать истошно кричать (могут возникнуть пробемы при вызове всплывающих окон в формах)
if (!all(!tab > 1)) {
cli::cli_abort(c("В одной или нескольких схемах наименования вложенных форм совпадают:", paste("-", names(tab)[tab > 1])))
}
saveRDS(schms, "scheme.rds")
}

14
modules/scheme_generator.R
View File

@@ -125,18 +125,28 @@ scheme_R6 <- R6::R6Class(
c("subgroup", "form_id", "form_label", "form_type") c("subgroup", "form_id", "form_label", "form_type")
) )
readxl::read_xlsx(private$scheme_file_path, sheet = sheet_name) |> table <- readxl::read_xlsx(private$scheme_file_path, sheet = sheet_name) |>
# fill NA down # fill NA down
tidyr::fill(all_of(colnames), .direction = "down") |> tidyr::fill(all_of(colnames), .direction = "down") |>
dplyr::group_by(form_id) |> dplyr::group_by(form_id) |>
tidyr::fill(c(condition, required), .direction = "down") |> tidyr::fill(c(condition, required), .direction = "down") |>
dplyr::ungroup() dplyr::ungroup()
duplicate_ids <- table |>
dplyr::mutate(rleid = dplyr::consecutive_id(form_id)) |>
dplyr::distinct(form_id, rleid) |>
dplyr::count(form_id) |>
dplyr::filter(n > 1) |>
dplyr::pull(form_id)
if (length(duplicate_ids) > 0) {
cli::cli_abort(c("В схеме для формы '{sheet_name}' содержатся повторяющиеся id:", paste("-", duplicate_ids)))
}
table
} }
) )
) )
# schm <- scheme_R6$new(fs::path("configs/schemas", "schema.xlsx"))
# object.size(schm) # object.size(schm)
# schm$get_key_id("main") # schm$get_key_id("main")
# schm$get_forms_ids("main") # schm$get_forms_ids("main")

6
renv.lock
View File

@@ -232,14 +232,14 @@
}, },
"box": { "box": {
"Package": "box", "Package": "box",
"Version": "1.2.0", "Version": "1.2.2",
"Source": "Repository", "Source": "Repository",
"Repository": "RSPM", "Repository": "CRAN",
"Requirements": [ "Requirements": [
"R", "R",
"tools" "tools"
], ],
"Hash": "d94049c1d9446b0abb413fde9e82a505" "Hash": "5fd0a60cdaaea2b97046a82c13e17bfe"
}, },
"bslib": { "bslib": {
"Package": "bslib", "Package": "bslib",