From 31294f1958cbaffab28c7422e3e941ea8e2a7cf9 Mon Sep 17 00:00:00 2001 From: madeliri Date: Fri, 10 Apr 2026 23:33:50 +0300 Subject: [PATCH] =?UTF-8?q?feat:=20=D0=BC=D0=B0=D0=BD=D0=B8=D0=BF=D1=83?= =?UTF-8?q?=D0=BB=D1=8F=D1=86=D0=B8=D0=B8=20=D1=81=D0=BE=20=D1=81=D1=85?= =?UTF-8?q?=D0=B5=D0=BC=D0=B0=D0=BC=D0=B8=20=D1=87=D0=B5=D1=80=D0=B5=D0=B7?= =?UTF-8?q?=20R6=20=D0=BE=D0=B1=D1=8A=D0=B5=D0=BA=D1=82=20=D0=B0=20=D0=BD?= =?UTF-8?q?=D0=B5=20=D1=82=D0=B0=D0=BD=D1=86=D1=8B=20=D1=81=20=D0=BB=D0=B8?= =?UTF-8?q?=D1=81=D1=82=D0=B0=D0=BC=D0=B8=20=D0=B8=20=D0=B2=D0=BB=D0=BE?= =?UTF-8?q?=D0=B6=D0=B5=D0=BD=D0=BD=D1=8B=D0=BC=D0=B8=20=D1=82=D0=B0=D0=B1?= =?UTF-8?q?=D0=BB=D0=B8=D1=86=D0=B0=D0=BC=D0=B8?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- app.R | 167 +++++++++------------------- configs/config.yml | 2 +- configs/schemas/example_inline.xlsx | Bin 9436 -> 0 bytes helpers/scheme_generator.R | 123 ++++++++++++++++++++ modules/db.R | 121 ++++++++++++-------- 5 files changed, 250 insertions(+), 163 deletions(-) delete mode 100644 configs/schemas/example_inline.xlsx create mode 100644 helpers/scheme_generator.R diff --git a/app.R b/app.R index 3c80747..23ba0c3 100644 --- a/app.R +++ b/app.R @@ -10,6 +10,7 @@ suppressPackageStartupMessages({ }) source("helpers/functions.R") +source("helpers/scheme_generator.R") # box::purge_cache() # box::use(./helpers/db) @@ -40,106 +41,41 @@ rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/") # TODO: dynamic button render depend on pandoc installation if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!") -load_scheme_from_xlsx <- function( - sheet_name -) { - - colnames <- switch(sheet_name, - "main" = c("part", "subgroup", "form_id", "form_label", "form_type"), - c("subgroup", "form_id", "form_label", "form_type") - ) - - readxl::read_xlsx(FILE_SCHEME, sheet = sheet_name) |> - # fill NA down - tidyr::fill(all_of(colnames), .direction = "down") |> - dplyr::group_by(form_id) |> - tidyr::fill(c(condition, required), .direction = "down") |> - dplyr::ungroup() - -} - -extract_forms_id_and_types_from_scheme <- function(scheme, drop_key = c("main_key", "nested_key")) { - - drop_key <- match.arg(drop_key) - - form_id_and_types_list <- scheme |> - dplyr::filter(!form_type %in% c("inline_table", "nested_forms","description", "description_header")) |> - dplyr::distinct(form_id, form_type) |> - tibble::deframe() - - if(!drop_key %in% names(form_id_and_types_list)) cli::cli_abort("в схеме должно быть поле с ключем (key)") - form_id_and_types_list[names(form_id_and_types_list) != drop_key] - -} - # SCHEME_MAIN UNPACK ========================== -# load scheme -SCHEMES_LIST <- list() -SCHEMES_LIST[["main"]] <- load_scheme_from_xlsx("main") +schm <- scheme_R6$new(FILE_SCHEME) +object.size(schm) +schm$get_key_id("main") +schm$get_forms_ids("main") +schm$get_all_ids("main") -# get list of simple inputs -main_id_and_types_list <- extract_forms_id_and_types_from_scheme(SCHEMES_LIST[["main"]]) +schm$get_schema("main") -nested_forms_df <- SCHEMES_LIST[["main"]] |> - dplyr::filter(form_type == "nested_forms") |> - dplyr::distinct(form_id, .keep_all = TRUE) +schm$get_id_type_list("allergo_anamnesis") -# лист со схемами для всех вложенных формы -purrr::walk( +# active +schm$get_main_key_id +schm$all_tables_names - .x = purrr::set_names(unique(nested_forms_df$form_id)), - .f = \(nested_form_id) { - nested_form_scheme_sheet_name <- nested_forms_df |> - dplyr::filter(form_id == {nested_form_id}) |> - dplyr::pull(choices) - # загрузка схемы для данной вложенной формы - SCHEMES_LIST[[nested_form_id]] <<- load_scheme_from_xlsx(nested_form_scheme_sheet_name) - - } -) # establish connection con <- db$make_db_connection() # init DB (write dummy data to "main" table) -db$check_if_table_is_exist_and_init_if_not("main", main_id_and_types_list) - -purrr::walk( - .x = unique(nested_forms_df$form_id), - .f = \(table_name) { - - this_inline_table2_info <- nested_forms_df |> - dplyr::filter(form_id == {table_name}) - - # получение имя файла с таблицой - nested_form_scheme_sheet_name <- this_inline_table2_info$choices - - # загрузка схемы для данной вложенной формы - this_nested_form_scheme <- load_scheme_from_xlsx(nested_form_scheme_sheet_name) - - this_table_id_and_types_list <- extract_forms_id_and_types_from_scheme(this_nested_form_scheme, "nested_key") - - db$check_if_table_is_exist_and_init_if_not( - table_name, - this_table_id_and_types_list, - con = con - ) - - } -) +# db$check_if_table_is_exist_and_init_if_not("main", main_id_and_types_list) +db$check_if_table_is_exist_and_init_if_not(schm, con) # close connection to prevent data loss db$close_db_connection(con) # generate nav panels for each page nav_panels_list <- purrr::map( - .x = unique(SCHEMES_LIST[["main"]]$part), + .x = unique(schm$get_schema("main")$part), .f = \(page_name) { # отделить схему для каждой страницы - this_page_panels_scheme <- SCHEMES_LIST[["main"]] |> + this_page_panels_scheme <- schm$get_schema("main") |> dplyr::filter(!form_id %in% c("main_key", "nested_key")) |> dplyr::filter(part == {{page_name}}) @@ -269,7 +205,8 @@ server <- function(input, output, session) { ns, con ) { - + + nested_key_id <- schm$get_key_id(table_name) input_types <- unname(id_and_types_list) input_ids <- names(id_and_types_list) @@ -306,7 +243,7 @@ server <- function(input, output, session) { if (table_name == "main") { exported_df <- exported_df |> mutate( - main_key = values$main_key, + !!dplyr::sym(schm$get_main_key_id) := values$main_key, .before = 1 ) } @@ -315,8 +252,8 @@ server <- function(input, output, session) { if (table_name != "main") { exported_df <- exported_df |> mutate( - main_key = values$main_key, - nested_key = values$nested_key, + !!dplyr::sym(schm$get_main_key_id) := values$main_key, + !!dplyr::sym(nested_key_id) := values$nested_key, .before = 1 ) } @@ -327,9 +264,9 @@ server <- function(input, output, session) { db$write_df_to_db( df = exported_df, table_name = table_name, - scheme = SCHEMES_LIST[[table_name]], - main_key = values$main_key, - nested_key = values$nested_key, + schm = schm, + main_key_value = values$main_key, + nested_key_value = values$nested_key, con = con ) } @@ -339,7 +276,7 @@ server <- function(input, output, session) { # ==================================== ## кнопки для каждой вложенной таблицы ------------------------------- purrr::walk( - .x = nested_forms_df$form_id, + .x = schm$nested_tables_names, .f = \(nested_form_id) { observeEvent(input[[nested_form_id]], { @@ -350,7 +287,6 @@ server <- function(input, output, session) { values$nested_form_id <- nested_form_id values$nested_key <- NULL # для нормальной работы реактивных значений - show_modal_for_nested_form(con) }) @@ -363,8 +299,8 @@ server <- function(input, output, session) { ns <- NS(values$nested_form_id) # загрузка схемы для данной вложенной формы - this_nested_form_scheme <- SCHEMES_LIST[[values$nested_form_id]] - values$nested_id_and_types <- extract_forms_id_and_types_from_scheme(this_nested_form_scheme, "nested_key") + 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) # мини-схема для ключа this_nested_form_key_scheme <- subset(this_nested_form_scheme, form_id == "nested_key") @@ -451,7 +387,7 @@ server <- function(input, output, session) { con = con ) - col_types <- SCHEMES_LIST[[values$nested_form_id]] |> + col_types <- schm$get_schema(values$nested_form_id) |> dplyr::distinct(form_id, form_type, form_label) date_cols <- subset(col_types, form_type == "date", form_id, drop = TRUE) @@ -518,9 +454,9 @@ server <- function(input, output, session) { db$write_df_to_db( df = export_df, table_name = values$nested_form_id, - scheme = SCHEMES_LIST[[values$nested_form_id]], - main_key = values$main_key, - nested_key = NULL, + schm = schm, + main_key_value = values$main_key, + nested_key_value = NULL, con = con ) @@ -540,7 +476,7 @@ server <- function(input, output, session) { # сохраняем данные основной формы!!! save_inputs_to_db( table_name = "main", - id_and_types_list = main_id_and_types_list, + id_and_types_list = schm$get_id_type_list("main"), con = con ) @@ -600,7 +536,7 @@ server <- function(input, output, session) { removeModal() # та самая форма для ключа - scheme_for_key_input <- SCHEMES_LIST[[values$nested_form_id]] |> + scheme_for_key_input <- schm$get_schema(values$nested_form_id) |> dplyr::filter(form_id %in% c("nested_key")) ui1 <- rlang::exec( @@ -650,7 +586,7 @@ server <- function(input, output, session) { # VALIDATIONS ============================ # create new validator - iv_main <- data_validation$init_val(SCHEMES_LIST[["main"]]) + iv_main <- data_validation$init_val(schm$get_schema("main")) iv_main$enable() # STATUSES =============================== @@ -673,7 +609,7 @@ server <- function(input, output, session) { observeEvent(input$add_new_main_key_button, { # данные для главного ключа - scheme_for_key_input <- SCHEMES_LIST[["main"]] |> + scheme_for_key_input <- schm$get_schema("main") |> dplyr::filter(form_id == "main_key") # создать форму для выбора ключа @@ -714,7 +650,7 @@ server <- function(input, output, session) { } values$main_key <- input$main_key - utils$clean_forms(main_id_and_types_list) + utils$clean_forms(schm$get_id_type_list("main")) removeModal() }) @@ -729,7 +665,7 @@ server <- function(input, output, session) { observeEvent(input$clean_all_action, { # rewrite all inputs with empty data - utils$clean_forms(main_id_and_types_list) + utils$clean_forms(schm$get_id_type_list("main")) removeModal() showNotification("Данные очищены!", type = "warning") @@ -744,7 +680,7 @@ server <- function(input, output, session) { save_inputs_to_db( table_name = "main", - id_and_types_list = main_id_and_types_list, + id_and_types_list = schm$get_id_type_list("main"), con = con ) @@ -811,7 +747,7 @@ server <- function(input, output, session) { load_data_to_form( df = df, - id_and_types_list = main_id_and_types_list + id_and_types_list = schm$get_id_type_list("main") ) values$main_key <- input$load_data_key_selector @@ -829,14 +765,14 @@ server <- function(input, output, session) { # get all data list_of_df <- purrr::map( - .x = purrr::set_names(c("main", unique(nested_forms_df$form_id))), + .x = purrr::set_names(schm$all_tables_names), .f = \(x) { df <- read_df_from_db_all(x, con) |> tibble::as_tibble() # handle with data - scheme <- SCHEMES_LIST[[x]] + scheme <- schm$get_schema(x) date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE) number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE) @@ -890,7 +826,7 @@ server <- function(input, output, session) { # iterate by scheme parts purrr::walk( - .x = unique(SCHEMES_LIST[["main"]]$part), + .x = unique(schm$get_schema("main")$part), .f = \(x_iter1) { # write level 1 header HEADER_1 <- paste("#", x_iter1, "\n") @@ -898,14 +834,14 @@ server <- function(input, output, session) { # iterate by level2 headers (subgroups) purrr::walk( - .x = dplyr::pull(unique(subset(SCHEMES_LIST[["main"]], part == x_iter1, "subgroup"))), + .x = dplyr::pull(unique(subset(schm$get_schema("main"), part == x_iter1, "subgroup"))), .f = \(x_iter2) { # get header 2 name HEADER_2 <- paste("##", x_iter2, "\n") # for some reason set litle scheme... litle_scheme <- subset( - x = SCHEMES_LIST[["main"]], + x = schm$get_schema("main"), subset = part == x_iter1 & subgroup == x_iter2, select = c("form_id", "form_label", "form_type") ) |> @@ -989,30 +925,31 @@ server <- function(input, output, session) { }) 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") 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))) { + if (!all(schm$all_tables_names %in% openxlsx2::wb_get_sheet_names(wb))) { cli::cli_alert_warning("данные в файле '{file} не соответствуют схеме'") return() } # проверка схемы -------------- - for (table_name in names(SCHEMES_LIST)) { + for (table_name in schm$all_tables_names) { df <- openxlsx2::read_xlsx(wb, table_name) - scheme <- SCHEMES_LIST[[table_name]] |> + scheme <- schm$get_schema(table_name) |> filter(!form_type %in% c("description", "nested_forms")) # столбцы в таблицы и схема 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 ) { cli::cli_warn(c("в схеме для '{table_name}' нет следующих столбцов:", paste("- ", df_to_schema_compare))) } @@ -1030,10 +967,10 @@ server <- function(input, output, session) { } # обновление данных - for (table_name in names(SCHEMES_LIST)) { + for (table_name in schm$all_tables_names) { df <- openxlsx2::read_xlsx(wb, table_name) - scheme <- SCHEMES_LIST[[table_name]] |> + scheme <- schm$get_schema(table_name) |> filter(!form_type %in% c("description", "nested_forms")) date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE) diff --git a/configs/config.yml b/configs/config.yml index e309998..d8c7c5b 100644 --- a/configs/config.yml +++ b/configs/config.yml @@ -2,6 +2,6 @@ default: header: "TEST" version: "0.14.1" # shiny serve option - shiny_host: "127.0.0.1" + shiny_host: "0.0.0.0" shiny_port: 1337 auth_module: FALSE # default: FALSE \ No newline at end of file diff --git a/configs/schemas/example_inline.xlsx b/configs/schemas/example_inline.xlsx deleted file mode 100644 index 18ec74183f2b7e58ac71cd9c79815a4038b79625..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 9436 zcmeHN1y>x|*6rXL8V&B&!QI{6gG=z>?(V@QIKd?l+}$-0AV?s%ySwxC~l`-Q;IT>P#6Fh02}}SAORR2eKgm50RY580RZR#I0$VKTN@`6 z8z+5LcRLeDU3xcbE8<)z2^fOUKKjgE~6mLh-Jd9n)N& zPCHZ3pCn*n7NBSuQHxc^Y%}KFD}b3NJABejym(KsijLpAjAz`O853(Pk4Bq$%oLv>*>W8n%;X?JRuwwTwS8$ad9 z3@ww1Po9ca0mtaoapBPm@I$cpQvJ31A+3uu5WDBc`lmXf&S=4C!aB>Ov;LO z!#pN2K#_gvt5wT-I{eYSmjk}%^We!)Km^gJC2)rNJ4xPpx$;>(z?+6u&X+DL8wX?%|fHWL9~w zO$*R(hZI?skvoe^>rECvNoqeX9&Bfga_E#EbLm?G6dP39VyjP4EhYor&*EB37_X(GO+2x{w#uE#uaUJaGQE?p&OBp^_$Qawr9 zK10g>7JZ@gFe{4PA>DPw30p++LvkFp(8A4tVu7RD0Y&481)JR$8#%DnqwFTOl_Qr6 z)+ULcXG~Md)@5Q^awxq4$u}J@oBl!Q^(;I!J`xB?>%f7TH^Z!KzOcbwtR2f$lCkz2-ix#qv`5Da@ZhDTLrF?savNsW z^h@c_bog=jDEy-Y&_7G?S4*iDxy(e;T-LA@}|Z!2h%I69CP{; z?rI0wY?{!RZ8HV}QVq@1yJjX1{F9DyP?G>)P zS5PVl`>KhB>7k`&PP(&U>#$G|?)n_5{Pf@r~IIqE&c@_xNS^Vp#SA}~?^ zPGx`o56S1?GtJ<9hYNsv0jBc5Qr@2l{qOYm0$h!P1HymzR;nx~)5{2KLwpKlbWL}` zME&8!Kzg9Ij{-MT3!0}SVez?G#(UkYtMOfi0n#?a{rKyE%Qf4}HAwW!E}Bo_Xiy&L zR>wThwqMV`Lc$pymJtR>K%=7_?CpO(M0}a%h~C5>KS-O2!MSxqO@R}dS4b*)(KHdl zYB9>_%xvK}PVfaB{)cNf{O*EO4$1;*8ybkyK&G3|O(OGGFj)caMBmPF;H7wx-2vZr zrbuXRy2P&F&RQQ#<=jUtyYlXkHt|2p5SFmiAaDpdhWmqd4-pp zm7T24(OSBAla1O`qB$6*Lv@aN>tx!h*c!RA`V~m3=ajQB{Cx;g&=ha?xEci~M%pnZ ztBoIa?8w`PdaSax2@GGTqLd$p+F6#~bP zMJ7}-6SRG4yRF{fygaTS+3*(2fzCI4V%q#YY*A47VZnV#OqP(9W$0%n$|YxctxUv9 zd~GZdoZyehGia$d7aw+_30?4ckgHGz8FA#^4_tqL=j_}B2MeF{DS5@MRnjz%IJ)2d z#+Sr&0nxq{j;h9&>l=T6$4?jeIebXaei;CMO=%Er2FSSI5Er~3k7BKRuWwE(wAiLX zYG8H~OEj^7pO!EzcK6w_jlE6j%-)kSCJjF6re&8mqa=WWK?z%1cWKUjzq#FXm)=Nv z&My;^r~O4!sFPyxMqvDc&-)NGQc5l94W=BB(g+mnz9!#%HsNeqm*X1&VrOamIBp8& ze124X?pwC694RpD?3j%v;Tf^7DXt`)Nh@DltsL_~VHM|&EtV30s!bxLaL{cs#*tHX zYU<*z>>|X)-d4Ad*-Gngf6)ENp!DOWEg4 zgDEFUjr7<;1im(vw+oNg{H&mq(C3*9Df;x3(F)#<;2@BjXj5Zp7*|}GMnKHxazM{5UF1?*WP_Tin|Em3 zvPc92T<(E<8~UPPGVI#Qw{pjC(e>YJ%|?XPh*bObTQ*nh+`Et=xyBNl+PC(G^2BHhIzc? z(cIWKN&69O`bv3GZ;&qfOY!e~+VG9i+^D;lKD9k8ZtBxN`?&iP$`v`uwtCV$dc%Aq zm);9uLLboL(S(1zn%_=-mAtIe-q?C`#nSi$^YlD2C@&8|N0MAU48`47x+ye+?!!*L z{Y3;x1{y^x)Ap(LtgXeQH65O*POP4ogV8rthmw&CUM|a!UCVXvx<{N%W1j<1$Zr1_ z@>F(-10alfy8%kh9nF4ojrTT$&Tm2{^k_?7vFa51F%fxGsAdWNbCM6F^rbq-0H^tt zCmW)zAgI0G-}e4(k!IBi%!jpoyc>&-HuNjH))!)tlvL?Eck+2kW8;>CA8PohS~V-~ zdD@UN^N4Z3e=BTBITO|8xH5c*jCcWOE);?(7ppZogb_nBKJVB^v8Tjk=C+%|CEpli zDu4t5*H=PR?%NOPmb?;By9Gb8A)c@mx}h=NWZ{k?_*vbr_3myzc}&06>uDxA%lGN* zHfx;!qu6UTlcB>^<2N7fkFEutuPX#Zp6||W+wb>Y*|gHG=|7)F%=q39To;EHC#SDX zGcf3NG`d}WW_Z30t-zm~hlmM3A&Gh~8oGhRx5b1sp3=RgAiidb)&r*^10j(;pVM4H zis;tZI}*GPoDWifHYRv=^0b!Pcgcx{C`Q015NU|$*2%SRx60ZnvZ&tG-6O{A=t_?z zwqO*gpzG~wZ^+fyks@+eK%cl6rokG6Esv2I7et+(b&4*GpLZXmJX{XzMBBKb63n0T zDX@5wT!gzC0`zJwkLku_mlUqN-pcU=!Wn9Rk#j$OtPU)?_~jm!Wi88Cjk=WW@AElY}>9~6ee=+qIr~A=K46{Z|KRR-Xrd) zKh~)h;RYP3%+f@~4hGJkgfa5S%5_d4ZN`A!C_bG-Z(IcmdL6FQ(Yw$k?Zl+r{dTAj zS5G#*yAN+0ja6iIGz;krX+S;lc?%c z3e`xpM9(OYiiXeF9$ac~LB6P>wEg#l51 z_K+nuwe49MQ4K1Fz9*5nG!D-j8S$%v9|-X$X)HK`c|U5H@lyA_yWOFZJ-o(qg45xx zjAK{!s8q!UP&0dclnh+B%$Qa963j;_tjJPLYoKMyci7XFB5wQ?CJq&AmN$wh6E!vu zeURC6CtPNml|jwz32YWVGz7mDV4ErH znaqy2y$;-4JPM|ob=e?-_eiojDYUi?K$P7OJ#v)0`$El`MdEt~nVP_^id>hBu zPH;NJ++xfu$67q*tdv%GHeejSv(dU4T>gcLM`yI;MG|0cs*|zjd%&p07}ivTE@hhh zY@MA}zh1Gr^=e)39<~deRXwh5?ey(lukOrIq1j=j(-b8#o=n$tA?E5iz(2=H9>sHV z0nvR+$0U(mCnq?Y?zqUOO!qLP&SuDV>aM_|U@sZB&ZS_geEPLe2i8rS{0(SaMG1du zB8CFSj=MMM2Nimu_j=8HH)nv0*~mIGhrY;%sOzt0=tAb+>~TJH{vmgHa47ijwcS37 z$n$R-rVgPmmDvuaWuiVxw@e}Lw^brXxOk60O^Fo2;5&J=b!B5E?df)^J-U=l9jP`K zc;qd^!wPlGoxjMS6WBh%%5$_aMQmhkJ$n3EpZr=A9B0f@K7-%p2Eb>L|5Xz>I=Ne! zIQ~|X*Q$Muo@4~JlbyayI{xuc3$jjxQfiKi1&|z)+B>5c)tx99x5yx@jrhB+5O6xI z5V$Od*~iywRt+nlCVwZ45%6VM9wB#MfQv5w#4bC85o-2ATotRt*x}>aOmY)P-=GGm zOm|{FXh|uM$P9&uy#I)^ZC23&RZucvEvoKv;aaXLCm@AIO$DARaUwutcCXIXLQd-4 z0!7y&H5_F-vFzH*xAfrxFHl807QgG|h|1AwGmRdU_jOBRoSRt|vufIB&jlGNXH#bE zz_EEeOIkke5_BPyMV1`ktlX89XbAZh@|>ITgQ6wE7wN>}FN~i|~Qgr(yVT98}(MrOmB7PJ@6XJ=X zs#Ak$BiH)udX!HZaH{M2U3Up+oek7#rN-tdsz>qwbO~aZT@Z9dnYK5U9@xyf{A z_<_H42db3aCd?^zRC|awAG&Ev`t&k+zk(ynmS5Mm zQf{YOnDco#=J5$Gwc13uRZ|-;e&J1{kC03~CeY~kGF%rlFPsnlwP)?%bkR+RLgFk|@D}fWK)e9qN$xXO$$%#3Jt<4IbOr zj?#10P&<>dAe1`Y1NP0cFbjFR7N;p_XsKKucqXubUvy`;onIOM81F>-QY8}hItzR zTV$^#m>#B*XIN=HD-6T*(tDFVL2{wTfb^U+aFxW&!g(MwU|9d7Xe=zjK`#eBV+LMrRIt)yY-^o%2|2esRhtM+O)%ed`6Sm-3Y{Cn%cDFHjL{^k5X-J% z;{#NOEn!wmi4V!VuDzfpDd#3`iW;{kUFyl3l96eWt~~dao_L%V`~4+M;v+wgRf5^u41F@cv1<+6rKOpAPmxLa=-V{Id_fwX^%53xa*`_bnq{&Sstw z7<>)w0qcLC;-Cc;EW|{efu+g%=>^XZh2l6dRZ@5d(%HqjdBU7myG(0%Cgdd13&zun z54^3nocPX7mg%KEDW$H#DPs%|2KN%=&{XjvN{BFV z({tbHPfny~GAvqO`TN)1VGA1}13Q$LHPF4!FikiNO3AYJ4kkwp@-|cpQyinV__gNt zb%x%Re22l+IfK&`N>Ciy4rmtNnQ4H)OL#*-$IZH7lyrcix6(A&F4Rp}3M3FkjK;1^ zjv4}TkSI-|_!2%5`VjgM_|OamRB;BW9J1CQUwQ%U>|P%rivw*kNNs4@Qrh3pgk2z< zdP(y#Mz$73uFrzjPAmwoVjd?NUMytd4eUfXFHc&}-p~+x&F#EXDzgmJIHSVn@S*)= zsb^~Ckzj&s6S0}FWs=ts)N;CT`CypTF??%D#YT~ZqAdUpoBz^cUqH}-)73wJNAm9n z`0xEcd{v?-^H&3Z?Rfti_}e}i%#uI#zkdb(+6DXr+6r#1|I!ou75vw}!yixpAQa&z z`2Xob{A%Y{G5QZn%}D>5#NVXpU#XdpO-{RaKDCi&IEUo-0;cmUuO9{~7Up8Xa6*P!@kxHGtC^dI=|AyQEW8vJwt Q00i*Q5A2iTq`w{gAF!!)h5!Hn diff --git a/helpers/scheme_generator.R b/helpers/scheme_generator.R new file mode 100644 index 0000000..60fd882 --- /dev/null +++ b/helpers/scheme_generator.R @@ -0,0 +1,123 @@ + +#' @export +scheme_R6 <- R6::R6Class( + "schemes_f", + public = list( + + initialize = function(scheme_file_path = NULL) { + private$scheme_file_path <- scheme_file_path + + # make list of schemas + private$schemes_list <- list() + private$schemes_list[["main"]] <- private$load_scheme_from_xlsx("main") + + # имена вложенных форм + private$nested_forms_names <- private$schemes_list[["main"]] |> + dplyr::filter(form_type == "nested_forms") |> + dplyr::distinct(form_id) |> + dplyr::pull(form_id) + + purrr::walk( + .x = purrr::set_names(private$nested_forms_names), + .f = \(nested_form_id) { + + nested_form_scheme_sheet_name <- private$schemes_list[["main"]] |> + dplyr::filter(form_id == {{nested_form_id}}) |> + dplyr::distinct(form_id, .keep_all = TRUE) |> + dplyr::pull(choices) + + # загрузка схемы для данной вложенной формы + private$schemes_list[[nested_form_id]] <<- private$load_scheme_from_xlsx(nested_form_scheme_sheet_name) + } + ) + + # extract main key + private$main_key_id <- self$get_key_id("main") + }, + + get_all_ids = function(table_name) { + + private$schemes_list[[table_name]] |> + dplyr::filter(!form_type %in% private$exluded_types) |> + dplyr::distinct(form_id) |> + dplyr::pull(form_id) + + }, + get_key_id = function(table_name) { + + ids <- self$get_all_ids(table_name) + ids[1] + + }, + get_forms_ids = function(table_name) { + + ids <- self$get_all_ids(table_name) + ids[-1] + + }, + + 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_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_id != {{this_key_id}}) |> + dplyr::distinct(form_id, form_type) |> + tibble::deframe() + } + ), + active = list( + get_main_key_id = function() { + private$main_key_id + }, + all_tables_names = function() { + c("main", private$nested_forms_names) + }, + nested_tables_names = function() { + private$nested_forms_names + } + ), + private = list( + scheme_file_path = NA, + schemes_list = NULL, + main_key_id = NA, + nested_forms_names = NA, + exluded_types = c("inline_table", "nested_forms","description", "description_header"), + + load_scheme_from_xlsx = function(sheet_name) { + + colnames <- switch(sheet_name, + "main" = c("part", "subgroup", "form_id", "form_label", "form_type"), + c("subgroup", "form_id", "form_label", "form_type") + ) + + readxl::read_xlsx(FILE_SCHEME, sheet = sheet_name) |> + # fill NA down + tidyr::fill(all_of(colnames), .direction = "down") |> + dplyr::group_by(form_id) |> + tidyr::fill(c(condition, required), .direction = "down") |> + dplyr::ungroup() + + } + ) +) \ No newline at end of file diff --git a/modules/db.R b/modules/db.R index 8373e42..7cc7b6c 100644 --- a/modules/db.R +++ b/modules/db.R @@ -24,43 +24,57 @@ close_db_connection <- function(con, where = "") { #' @description #' Проверить если таблица есть в базе данных и инициировать ее, если от check_if_table_is_exist_and_init_if_not <- function( - table_name, - forms_id_type_list, + schm, con = rlang::env_get(rlang::caller_env(), nm = "con") ) { - if (table_name %in% DBI::dbListTables(con)) { + main_key <- schm$get_main_key_id - cli::cli_inform(c("*" = "таблица есть такая: '{table_name}'")) + purrr::walk( + .x = schm$all_tables_names, + .f = \(table_name, con) { - # если таблица существует, производим проверку структуры таблицы - compare_existing_table_with_schema(table_name, forms_id_type_list) + forms_id_type_list <- schm$get_id_type_list(table_name) + key_name <- schm$get_key_id(table_name) - } else { + if (table_name %in% DBI::dbListTables(con)) { - if (table_name == "main") { - dummy_df <- dplyr::mutate( - get_dummy_df(forms_id_type_list), - main_key = "dummy", - .before = 1 - ) - } - if (table_name != "main") { - dummy_df <- get_dummy_df(forms_id_type_list) |> - dplyr::mutate( - main_key = "dummy", - nested_key = "dummy", - .before = 1 + cli::cli_inform(c("*" = "таблица есть такая: '{table_name}'")) + + # если таблица существует, производим проверку структуры таблицы + compare_existing_table_with_schema( + table_name = table_name, + schm = schm ) - } - # write dummy df into base, then delete dummy row - DBI::dbWriteTable(con, table_name, dummy_df, append = TRUE) - DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE main_key = 'dummy'")) + } else { - cli::cli_alert_success("таблица '{table_name}' успешно создана") - } + if (table_name == "main") { + dummy_df <- get_dummy_df(forms_id_type_list) |> + dplyr::mutate( + !!dplyr::sym(main_key) := "dummy", + .before = 1 + ) + } + if (table_name != "main") { + dummy_df <- get_dummy_df(forms_id_type_list) |> + dplyr::mutate( + !!dplyr::sym(main_key) := "dummy", + !!dplyr::sym(key_name) := "dummy", + .before = 1 + ) + } + # write dummy df into base, then delete dummy row + DBI::dbWriteTable(con, table_name, dummy_df, append = TRUE) + DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key} = 'dummy'")) + + cli::cli_alert_success("таблица '{table_name}' успешно создана") + } + }, + con = con + ) + } #' @description @@ -96,45 +110,47 @@ get_dummy_df <- function(forms_id_type_list) { #' коррекции таблицы compare_existing_table_with_schema <- function( table_name, - forms_id_type_list, + schm, con = rlang::env_get(rlang::caller_env(), nm = "con") ) { - forms_id_type_list_names <- names(forms_id_type_list) + main_key <- schm$get_main_key_id + key_id <- schm$get_key_id(table_name) + forms_ids <- schm$get_forms_ids(table_name) if (table_name == "main") { - forms_id_type_list_names <- c("main_key", forms_id_type_list_names) + all_ids_from_schema <- c(main_key, forms_ids) } else { - forms_id_type_list_names <- c("main_key", "nested_key", forms_id_type_list_names) + all_ids_from_schema <- c(main_key, key_id, forms_ids) } options(box.path = here::here()) box::use(modules/utils) # checking if db structure in form compatible with alrady writed data (in case on changig form) - if (identical(colnames(DBI::dbReadTable(con, table_name)), forms_id_type_list_names)) { + if (identical(colnames(DBI::dbReadTable(con, table_name)), all_ids_from_schema)) { # ... } else { df_to_rewrite <- DBI::dbReadTable(con, table_name) - form_base_difference <- setdiff(forms_id_type_list_names, colnames(df_to_rewrite)) - base_form_difference <- setdiff(colnames(df_to_rewrite), forms_id_type_list_names) + form_base_difference <- setdiff(all_ids_from_schema, colnames(df_to_rewrite)) + base_form_difference <- setdiff(colnames(df_to_rewrite), all_ids_from_schema) # if lengths are equal - if (length(forms_id_type_list_names) == length(colnames(df_to_rewrite)) && + if (length(all_ids_from_schema) == length(colnames(df_to_rewrite)) && length(form_base_difference) == 0 && length(base_form_difference) == 0) { cli::cli_warn("changes in scheme file detected: assuming order changed only") - print(forms_id_type_list_names) + print(all_ids_from_schema) } - if (length(forms_id_type_list_names) == length(colnames(df_to_rewrite)) && + if (length(all_ids_from_schema) == length(colnames(df_to_rewrite)) && length(form_base_difference) != 0 && length(base_form_difference) != 0) { cli::cli_abort("changes in scheme file detected: structure has been changed") } - if (length(forms_id_type_list_names) > length(colnames(df_to_rewrite)) && length(form_base_difference) != 0) { + if (length(all_ids_from_schema) > length(colnames(df_to_rewrite)) && length(form_base_difference) != 0) { cli::cli_warn("changes in scheme file detected: new inputs form was added") cli::cli_warn("trying to adapt database") @@ -146,13 +162,13 @@ compare_existing_table_with_schema <- function( # reorder due to scheme df_to_rewrite <- df_to_rewrite |> - dplyr::select(dplyr::all_of(forms_id_type_list_names)) + dplyr::select(dplyr::all_of(all_ids_from_schema)) DBI::dbWriteTable(con, table_name, df_to_rewrite, overwrite = TRUE) - DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE main_key = 'dummy'")) + DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key} = 'dummy'")) } - if (length(forms_id_type_list_names) < length(colnames(df_to_rewrite))) { + if (length(all_ids_from_schema) < length(colnames(df_to_rewrite))) { cli::cli_abort("changes in scheme file detected: some of inputs form was deleted! it may cause data loss!") } @@ -160,7 +176,18 @@ compare_existing_table_with_schema <- function( } #' @export -write_df_to_db <- function(df, table_name, scheme, main_key, nested_key, con) { +write_df_to_db <- function( + df, + table_name, + schm, + main_key_value, + nested_key_value, + con +) { + + scheme <- schm$get_schema(table_name) + main_key_id <- schm$get_main_key_id + nested_key_id <- schm$get_key_id(table_name) date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE) number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE) @@ -174,25 +201,25 @@ write_df_to_db <- function(df, table_name, scheme, main_key, nested_key, con) { ) if (table_name == "main") { - del_query <- glue::glue("DELETE FROM main WHERE main_key = '{main_key}'") + del_query <- glue::glue("DELETE FROM main WHERE {main_key_id} = '{main_key_value}'") } if (table_name != "main") { - if (is.null(nested_key)) { - del_query <- glue::glue("DELETE FROM '{table_name}' WHERE main_key = '{main_key}'") + if (is.null(nested_key_value)) { + del_query <- glue::glue("DELETE FROM '{table_name}' WHERE {main_key_id} = '{main_key_value}'") } else { - del_query <- glue::glue("DELETE FROM '{table_name}' WHERE main_key = '{main_key}' AND nested_key = '{nested_key}'") + del_query <- glue::glue("DELETE FROM '{table_name}' WHERE {main_key_id} = '{main_key_value}' AND {nested_key_id} = '{nested_key_value}'") } } deleted <- DBI::dbExecute(con, del_query) - cli::cli_alert_success("deleted {deleted} rows for '{main_key}' in '{table_name}") + cli::cli_alert_success("deleted {deleted} rows for '{main_key_value}' in '{table_name}") # записать данные DBI::dbWriteTable(con, table_name, df, append = TRUE) # report - cli::cli_alert_success("данные для '{main_key}' в таблице '{table_name}' успешно обновлены") + cli::cli_alert_success("данные для '{main_key_value}' в таблице '{table_name}' успешно обновлены") }