diff --git a/app.R b/app.R index 833f3e9..7cc9f5c 100644 --- a/app.R +++ b/app.R @@ -11,8 +11,6 @@ suppressPackageStartupMessages({ # КАК ЗАПРЯТЯАТЬ ID -source("helpers/functions.R") - # SOURCE FILES ============================ box::purge_cache() box::use( @@ -178,7 +176,7 @@ server <- function(input, output, session) { } else { # list of rendered panels - validator_main(data_validation$init_val(mhcs()$get_schema("main"))) + validator_main(data_validation$init_val(mhcs()$get_scheme("main"))) validator_main()$enable() mhcs()$get_main_form_ui } @@ -206,8 +204,8 @@ server <- function(input, output, session) { if (missing(ns)) ns <- NULL # transform df to list - loaded_df_for_id <- as.list(df) - loaded_df_for_id <- df[input_ids] + # loaded_df_for_id <- as.list(df) + # loaded_df_for_id <- df[input_ids] # rewrite input forms purrr::walk2( @@ -220,7 +218,7 @@ server <- function(input, output, session) { form_id = x_id, form_type = x_type, value = df[[x_id]], - scheme = mhcs()$get_schema(table_name), + scheme = mhcs()$get_scheme(table_name), ns = ns ) } @@ -341,7 +339,7 @@ server <- function(input, output, session) { key_id <- mhcs()$get_key_id(values$nested_form_id) # загрузка схемы для данной вложенной формы - this_nested_form_scheme <- mhcs()$get_schema(values$nested_form_id) + this_nested_form_scheme <- mhcs()$get_scheme(values$nested_form_id) # мини-схема для ключа this_nested_form_key_scheme <- subset(this_nested_form_scheme, form_id == key_id) @@ -431,16 +429,17 @@ server <- function(input, output, session) { con = con ) - col_types <- mhcs()$get_schema_with_values_forms(values$nested_form_id) |> + col_types <- mhcs()$get_scheme_with_values_forms(values$nested_form_id) |> dplyr::distinct(form_id, form_type, form_label) - date_cols <- which(col_types$form_type == "date") + str_cols <- which(col_types$form_type != "date") values$data <- values$data |> select(-mhcs()$get_main_key_id) |> mutate( - dplyr::across(tidyselect::all_of({{date_cols}}), as.Date) + dplyr::across(tidyselect::all_of({{date_cols}}), as.Date), + dplyr::across(tidyselect::all_of({{str_cols}}), as.character), ) |> arrange({{key_id}}) @@ -460,7 +459,8 @@ server <- function(input, output, session) { keys = TRUE ) ) |> - DT::formatDate(date_cols, "toLocaleDateString", params = list('ru-RU')) + DT::formatDate(date_cols, "toLocaleDateString", params = list('ru-RU')) |> + DT::formatString(str_cols) ) showModal(modalDialog( @@ -598,7 +598,7 @@ server <- function(input, output, session) { removeModal() # та самая форма для ключа - scheme_for_key_input <- mhcs()$get_schema(values$nested_form_id) |> + scheme_for_key_input <- mhcs()$get_scheme(values$nested_form_id) |> dplyr::filter(form_id == mhcs()$get_key_id(values$nested_form_id)) ui1 <- rlang::exec( @@ -678,7 +678,7 @@ server <- function(input, output, session) { observeEvent(input$add_new_main_key_button, { # данные для главного ключа - scheme_for_key_input <- mhcs()$get_schema("main") |> + scheme_for_key_input <- mhcs()$get_scheme("main") |> dplyr::filter(form_id == mhcs()$get_main_key_id) # создать форму для выбора ключа @@ -864,7 +864,7 @@ server <- function(input, output, session) { tibble::as_tibble() # handle with data - scheme <- mhcs()$get_schema(x) + scheme <- mhcs()$get_scheme(x) date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE) number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE) @@ -916,10 +916,11 @@ server <- function(input, output, session) { "---", "\n" ) + box::use(modules/data_manipulations[is_this_empty_value]) # iterate by scheme parts purrr::walk( - .x = unique(mhcs()$get_schema("main")$part), + .x = unique(mhcs()$get_scheme("main")$part), .f = \(x_iter1) { # write level 1 header HEADER_1 <- paste("#", x_iter1, "\n") @@ -927,14 +928,14 @@ server <- function(input, output, session) { # iterate by level2 headers (subgroups) purrr::walk( - .x = dplyr::pull(unique(subset(mhcs()$get_schema("main"), part == x_iter1, "subgroup"))), + .x = dplyr::pull(unique(subset(mhcs()$get_scheme("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 = mhcs()$get_schema("main"), + x = mhcs()$get_scheme("main"), subset = part == x_iter1 & subgroup == x_iter2, select = c("form_id", "form_label", "form_type") ) |> @@ -955,7 +956,7 @@ server <- function(input, output, session) { if (length(docx_value) > 1) docx_value <- paste(docx_value, collapse = ", ") # if non empty data - add string - if (!check_for_empty_data(docx_value)) paste0("**", docx_label, "**: ", docx_value, "\n") else NA + if (!is_this_empty_value(docx_value)) paste0("**", docx_label, "**: ", docx_value, "\n") else NA } else if (docx_type == "description") { # treat description label as citation text paste0(">", docx_label, "\n") @@ -1039,7 +1040,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_with_values_forms(table_name) + scheme <- mhcs()$get_scheme_with_values_forms(table_name) # столбцы в таблицы и схема df_to_schema_compare <- setdiff(colnames(df), unique(scheme$form_id)) @@ -1064,7 +1065,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_with_values_forms(table_name) + scheme <- mhcs()$get_scheme_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) @@ -1129,7 +1130,7 @@ server <- function(input, output, session) { type = "message" ) cli::cli_alert_success(message) - } + } log_action_to_db("importing data from xlsx", con = con) removeModal() }) @@ -1239,4 +1240,4 @@ server <- function(input, output, session) { app <- shinyApp(ui = ui, server = server) - runApp(app, launch.browser = TRUE) +runApp(app, launch.browser = TRUE) \ No newline at end of file diff --git a/helpers/functions.R b/helpers/functions.R deleted file mode 100644 index a5a5ca3..0000000 --- a/helpers/functions.R +++ /dev/null @@ -1,27 +0,0 @@ - - -#' @description Function check if variable contains some sort of empty data -#' (NULL, NA, "", other 0-length data) and return `TRUE` (`FALSE` if data is -#' not 'empty'). -#' -#' Needed for proper data validation. -#' (ДУБЛИРУЕТ МОДУЛЬ `data_manipulation`) -check_for_empty_data <- function(value_to_check) { - - # for any 0-length - if (length(value_to_check) == 0) return(TRUE) - - # for NA - if (is.logical(value_to_check) && is.na(value_to_check)) return(TRUE) - - # for NULL - if (is.null(value_to_check)) return(TRUE) - - # for non-empty Date (RETURN FALSE) - if (inherits(value_to_check, "Date") && length(value_to_check) != 0) return(FALSE) - - # for empty strings (stands before checking non-empty data for avoid mistakes) - if (value_to_check == "") return(TRUE) - - FALSE -} diff --git a/modules/data_manipulations.R b/modules/data_manipulations.R index 5919a1e..b9306a1 100644 --- a/modules/data_manipulations.R +++ b/modules/data_manipulations.R @@ -4,7 +4,8 @@ #' not 'empty'). #' #' Needed for proper data validation. -check_for_empty_data = function(value_to_check) { +#' @export +is_this_empty_value = function(value_to_check) { # for any 0-length if (length(value_to_check) == 0) return(TRUE) @@ -19,7 +20,14 @@ check_for_empty_data = function(value_to_check) { if (inherits(value_to_check, "Date") && length(value_to_check) != 0) return(FALSE) # for empty strings (stands before checking non-empty data for avoid mistakes) - if (value_to_check == "") return(TRUE) + if (is.character(value_to_check)) { + if (is.na(value_to_check)) return(TRUE) + if (value_to_check == "") return(TRUE) + } - FALSE + if (is.double(value_to_check)) { + if (is.na(value_to_check)) return(TRUE) + } + + return(FALSE) } diff --git a/modules/data_validation.R b/modules/data_validation.R index 39faa35..d3616ad 100644 --- a/modules/data_validation.R +++ b/modules/data_validation.R @@ -3,7 +3,7 @@ init_val = function(scheme, ns) { options(box.path = here::here()) - box::use(modules/data_manipulations[check_for_empty_data]) + box::use(modules/data_manipulations[is_this_empty_value]) iv <- shinyvalidate::InputValidator$new() @@ -15,7 +15,7 @@ init_val = function(scheme, ns) { # формируем список id - тип inputs_simple_list <- scheme |> - dplyr::filter(!form_type %in% c("nested_forms","description", "description_header")) |> + dplyr::filter(!form_type %in% c("nested_forms", "description", "description_header")) |> dplyr::distinct(form_id, form_type) |> tibble::deframe() @@ -39,7 +39,7 @@ init_val = function(scheme, ns) { iv$add_rule(x_input_id, function(x) { # exit if empty - if (check_for_empty_data(x)) { + if (is_this_empty_value(x)) { return(NULL) } # хак для пропуска значений @@ -64,7 +64,7 @@ init_val = function(scheme, ns) { function(x) { # exit if empty - if (check_for_empty_data(x)) { + if (is_this_empty_value(x)) { return(NULL) } @@ -85,11 +85,11 @@ init_val = function(scheme, ns) { } } - if (form_type %in% c("select_multiple", "select_one")) { + if (form_type %in% c("select_multiple", "select_one", "radio", "checkbox")) { iv$add_rule(x_input_id, function(x) { if (length(x) == 1) { - if (check_for_empty_data(x)) return(NULL) + if (is_this_empty_value(x)) return(NULL) } # проверка на соответствие вариантов схеме --------- diff --git a/modules/db.R b/modules/db.R index 192b133..d9300b3 100644 --- a/modules/db.R +++ b/modules/db.R @@ -185,7 +185,7 @@ write_df_to_db = function( con ) { - scheme <- schm$get_schema(table_name) + scheme <- schm$get_scheme(table_name) main_key_id <- schm$get_main_key_id nested_key_id <- schm$get_key_id(table_name) diff --git a/modules/global_options.R b/modules/global_options.R index 0bed070..d536810 100644 --- a/modules/global_options.R +++ b/modules/global_options.R @@ -30,7 +30,8 @@ check_and_init_scheme = function() { cli::cli_inform(c("*" = "проверка схемы...")) files_to_watch <- c( - "modules/scheme_generator.R" + "modules/scheme_generator.R", + "modules/utils.R" ) scheme_names <- enabled_schemas @@ -59,8 +60,9 @@ check_and_init_scheme = function() { # если данные были изменены проводим реинициализацию таблицы и схемы if (!all(exist_hash == saved_hash)) { - cli::cli_inform(c(">" = "Данные схемы были изменены...")) + cli::cli_inform(c(">" = "Данные схем были изменены...")) init_scheme(scheme_file) + } else { cli::cli_alert_success("изменений нет") } diff --git a/modules/scheme_generator.R b/modules/scheme_generator.R index 299eba7..7b2e261 100644 --- a/modules/scheme_generator.R +++ b/modules/scheme_generator.R @@ -1,14 +1,14 @@ #' @export scheme_R6 <- R6::R6Class( - "schemes_f", + "schemes_generator", public = list( initialize = function(scheme_file_path = NULL) { private$scheme_file_path <- scheme_file_path - # make list of schemas + # make list of schemes private$schemes_list <- list() private$schemes_list[["main"]] <- private$load_scheme_from_xlsx("main") @@ -67,11 +67,11 @@ scheme_R6 <- R6::R6Class( # возврат схемы ------------------------------------ ## полностью ------- - get_schema = function(table_name) { + get_scheme = function(table_name) { private$schemes_list[[table_name]] }, ## с полями имеющие значение ------- - get_schema_with_values_forms = function(table_name) { + get_scheme_with_values_forms = function(table_name) { private$schemes_list[[table_name]] |> dplyr::filter(!form_type %in% private$excluded_types) }, @@ -144,7 +144,7 @@ scheme_R6 <- R6::R6Class( # schm$get_forms_ids("main") # schm$get_all_ids("main") -# schm$get_schema("main") +# schm$get_scheme("main") # schm$get_id_type_list("allergo_anamnesis") diff --git a/modules/utils.R b/modules/utils.R index e89cc12..47503fa 100644 --- a/modules/utils.R +++ b/modules/utils.R @@ -264,6 +264,14 @@ update_forms_with_data = function( ns ) { + box::use(modules/data_manipulations[is_this_empty_value]) + + # print("-----------------") + # cli::cli_inform("form_id: {form_id} | form_type: {form_type}") + # print(value) + # print(typeof(value)) + # print(is_this_empty_value(value)) + filterd_line <- scheme |> dplyr::filter(form_id == {{form_id}}) @@ -294,50 +302,58 @@ update_forms_with_data = function( new_choices <- unique(c(old_choices, value)) new_choices <- new_choices[!is.na(new_choices)] - shiny::updateSelectizeInput(inputId = form_id, selected = value, choices = new_choices) - # shiny::updateSelectizeInput(inputId = form_id, selected = value) } # select_multiple # check if value is not NA and split by delimetr - if (form_type == "select_multiple" && !is.na(value)) { - vars <- stringr::str_split_1(value, local_delimeter) + if (form_type == "select_multiple") { + if (is_this_empty_value(value)) { + shiny::updateSelectizeInput(inputId = form_id, selected = as.character(0)) + } else { + vars <- stringr::str_split_1(value, local_delimeter) - # update choices - old_choices <- filterd_line$choices - new_choices <- unique(c(old_choices, vars)) - new_choices <- new_choices[!is.na(new_choices)] - - shiny::updateSelectizeInput(inputId = form_id, selected = vars, choices = new_choices) - # shiny::updateSelectizeInput(inputId = form_id, selected = vars) - } - - # in other case fill with `character(0)` to proper reseting form - if (form_type == "select_multiple" && is.na(value)) { - shiny::updateSelectizeInput(inputId = form_id, selected = character(0)) + # update choices + old_choices <- filterd_line$choices + new_choices <- unique(c(old_choices, vars)) + new_choices <- new_choices[!is.na(new_choices)] + shiny::updateSelectizeInput(inputId = form_id, selected = vars, choices = new_choices) + } } # radio buttons - if (form_type == "radio" && !is.na(value)) { - shiny::updateRadioButtons(inputId = form_id, selected = value) - } - if (form_type == "radio" && is.na(value)) { - shiny::updateRadioButtons(inputId = form_id, selected = character(0)) + if (form_type == "radio") { + if (is_this_empty_value(value)) { + shiny::updateRadioButtons(inputId = form_id, selected = character(0)) + } else { + # update choices + old_choices <- filterd_line$choices + new_choices <- unique(c(old_choices, value)) + new_choices <- new_choices[!is.na(new_choices)] + + shiny::updateRadioButtons(inputId = form_id, selected = value, choices = new_choices) + } } # checkboxes - if (form_type == "checkbox" && !is.na(value)) { - vars <- stringr::str_split_1(value, local_delimeter) - shiny::updateCheckboxGroupInput(inputId = form_id, selected = vars) - } - if (form_type == "checkbox" && is.na(value)) { - shiny::updateCheckboxGroupInput(inputId = form_id, selected = character(0)) + if (form_type == "checkbox") { + + if (is_this_empty_value(value)) { + shiny::updateCheckboxGroupInput(inputId = form_id, selected = character(0)) + } else { + + vars <- stringr::str_split_1(value, local_delimeter) + + # update choices + old_choices <- filterd_line$choices + new_choices <- unique(c(old_choices, vars)) + new_choices <- new_choices[!is.na(new_choices)] + + shiny::updateCheckboxGroupInput(inputId = form_id, selected = vars, choices = new_choices) + } + } - # if (type == "inline_table") { - # message("EMPTY") - # } } #' @export @@ -361,7 +377,7 @@ clean_forms = function( form_id = x_id, form_type = x_type, value = get_empty_data(x_type), - scheme = schm$get_schema(table_name), + scheme = schm$get_scheme(table_name), ns = ns ) }