diff --git a/app.R b/app.R index c19950a..0dcacd7 100644 --- a/app.R +++ b/app.R @@ -28,7 +28,8 @@ box::purge_cache() box::use( modules/utils, modules/global_options, - modules/db + modules/db, + modules/data_validation ) # SETTINGS ================================ @@ -41,7 +42,6 @@ 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( filename, colnames = c("part", "subgroup", "form_id", "form_label", "form_type") @@ -56,15 +56,19 @@ load_scheme_from_xlsx <- function( } +extract_forms_id_and_types_from_scheme <- function(scheme) { + scheme |> + dplyr::filter(!form_type %in% c("inline_table", "inline_table2","description", "description_header")) |> + dplyr::distinct(form_id, form_type) |> + tibble::deframe() +} + # SCHEME_MAIN UNPACK ========================== # load scheme SCHEME_MAIN <- load_scheme_from_xlsx(FILE_SCHEME) # get list of simple inputs -inputs_simple_list <- SCHEME_MAIN |> - dplyr::filter(!form_type %in% c("inline_table", "inline_table2","description", "description_header")) |> - dplyr::distinct(form_id, form_type) |> - tibble::deframe() +inputs_simple_list <- extract_forms_id_and_types_from_scheme(SCHEME_MAIN) # get list of inputs with inline tables inputs_tables_list <- SCHEME_MAIN |> @@ -80,61 +84,32 @@ inputs_table_df <- SCHEME_MAIN |> con <- db$make_db_connection() # init DB (write dummy data to "main" table) -if (!"main" %in% DBI::dbListTables(con)) { - dummy_df <- dplyr::mutate(get_dummy_df(), id = "dummy") +db$check_if_table_is_exist_and_init_if_not("main", inputs_simple_list) - # write dummy df into base, then delete dummy row - DBI::dbWriteTable(con, "main", dummy_df, append = TRUE) - DBI::dbExecute(con, "DELETE FROM main WHERE id = 'dummy'") +purrr::walk( + .x = unique(inputs_table_df$form_id), + .f = \(table_name) { - rm(dummy_df) -} + this_inline_table2_info <- inputs_table_df |> + dplyr::filter(form_id == {table_name}) -# checking if db structure in form compatible with alrady writed data (in case on changig form) -if (identical(colnames(DBI::dbReadTable(con, "main")), names(inputs_simple_list))) { - print("identical") -} else { - df_to_rewrite <- DBI::dbReadTable(con, "main") - form_base_difference <- setdiff(names(inputs_simple_list), colnames(df_to_rewrite)) - base_form_difference <- setdiff(colnames(df_to_rewrite), names(inputs_simple_list)) + # получение имя файла с таблицой + inline_table2_file_name <- this_inline_table2_info$choices + + # загрузка схемы для данной вложенной формы + this_inline_table2_scheme <- fs::path(folder_with_schemas, inline_table2_file_name) |> + load_scheme_from_xlsx(colnames = c("subgroup","form_id", "form_label", "form_type")) + + this_table_id_and_types_list <- extract_forms_id_and_types_from_scheme(this_inline_table2_scheme) + + db$check_if_table_is_exist_and_init_if_not( + table_name, + this_table_id_and_types_list, + con = con + ) - # if lengths are equal - if (length(names(inputs_simple_list)) == length(colnames(df_to_rewrite)) && - length(form_base_difference) == 0 && - length(base_form_difference) == 0) { - warning("changes in scheme file detected: assuming order changed only") } - - if (length(names(inputs_simple_list)) == length(colnames(df_to_rewrite)) && - length(form_base_difference) != 0 && - length(base_form_difference) != 0) { - stop("changes in scheme file detected: structure has been changed") - } - - if (length(names(inputs_simple_list)) > length(colnames(df_to_rewrite)) && length(form_base_difference) != 0) { - warning("changes in scheme file detected: new inputs form was added") - warning("trying to adapt database") - - # add empty data for each new input form - for (i in form_base_difference) { - df_to_rewrite <- df_to_rewrite |> - dplyr::mutate(!!dplyr::sym(i) := utils$get_empty_data(inputs_simple_list[i])) - } - - # reorder due to scheme - df_to_rewrite <- df_to_rewrite |> - dplyr::select(dplyr::all_of(names(inputs_simple_list))) - - DBI::dbWriteTable(con, "main", df_to_rewrite, overwrite = TRUE) - DBI::dbExecute(con, "DELETE FROM main WHERE id = 'dummy'") - } - - if (length(names(inputs_simple_list)) < length(colnames(df_to_rewrite))) { - stop("changes in scheme file detected: some of inputs form was deleted! it may cause data loss!") - } - # cleaning - rm(df_to_rewrite, form_base_difference) -} +) # close connection to prevent data loss db$close_db_connection(con) @@ -281,35 +256,66 @@ server <- function(input, output) { observeEvent(input[[table_name]], { + ns <- NS(table_name) + + # данные для данной вложенной формы this_inline_table2_info <- inputs_table_df |> dplyr::filter(form_id == {table_name}) + # получение имя файла с таблицой inline_table2_file_name <- this_inline_table2_info$choices + # загрузка схемы для данной вложенной формы this_inline_table2_scheme <- fs::path(folder_with_schemas, inline_table2_file_name) |> - load_scheme_from_xlsx(colnames = c("form_id", "form_label", "form_type")) + load_scheme_from_xlsx(colnames = c("subgroup","form_id", "form_label", "form_type")) - yay_its_fun <- purrr::pmap( - .l = dplyr::distinct(this_inline_table2_scheme, form_id, form_label, form_type), - .f = utils$render_forms, - main_scheme = this_inline_table2_scheme - ) + # # формирование карточек для данной формы + # yay_its_fun <- purrr::pmap( + # .l = dplyr::distinct(this_inline_table2_scheme, form_id, form_label, form_type), + # .f = utils$render_forms, + # main_scheme = this_inline_table2_scheme, + # ns = ns + # ) + yay_its_fun <- purrr::map( + .x = unique(this_inline_table2_scheme$subgroup), + .f = \(subgroup) { + subroup_scheme <- this_inline_table2_scheme |> + filter(subgroup == {{subgroup}}) + + bslib::nav_panel( + title = subgroup, + purrr::pmap( + .l = dplyr::distinct(subroup_scheme, form_id, form_label, form_type), + .f = utils$render_forms, + main_scheme = subroup_scheme, + ns = ns + ) + ) + } + ) + + # ui для всплывающего окна ui_for_inline_table <- card( - height = "800px", - layout_sidebar( - sidebar = selectizeInput( - inputId = "aboba", - label = "key", - choices = c("a", "b") + navset_card_underline( + sidebar = sidebar( + width = 300, + selectizeInput( + inputId = "aboba", + label = "key", + choices = c("a", "b") + ) ), - yay_its_fun + !!!yay_its_fun ) ) + # проверка данных для внутренних таблиц + iv_inner <- data_validation$init_val(this_inline_table2_scheme, ns) + iv_inner$enable() + showModal(modalDialog( ui_for_inline_table, - # title = modalButton("Dismiss"),, footer = modalButton("Dismiss"), size = "l" )) @@ -320,76 +326,8 @@ server <- function(input, output) { # VALIDATIONS ============================ # create new validator - iv <- shinyvalidate::InputValidator$new() - - # add rules to all inputs - purrr::walk( - .x = names(inputs_simple_list), - .f = \(x_input_id) { - form_type <- inputs_simple_list[[x_input_id]] - - choices <- dplyr::filter(SCHEME_MAIN, form_id == {{x_input_id}}) |> - dplyr::pull(choices) - - val_required <- dplyr::filter(SCHEME_MAIN, form_id == {{x_input_id}}) |> - dplyr::distinct(required) |> - dplyr::pull(required) - - # for `number` type: if in `choices` column has values then parsing them to range validation - # value `0; 250` -> transform to rule validation value from 0 to 250 - if (form_type == "number") { - - iv$add_rule(x_input_id, function(x) { - # exit if empty - if (check_for_empty_data(x)) { - return(NULL) - } - # check for numeric - # if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом." - if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом." - }) - - # проверка на соответствие диапазону значений - if (!is.na(choices)) { - # разделить на несколько елементов - ranges <- as.integer(stringr::str_split_1(choices, "; ")) - - # проверка на кол-во значений - if (length(ranges) > 3) { - warning("Количество переданных элементов'", x_input_id, "' > 2") - } else { - iv$add_rule( - x_input_id, - function(x) { - - # замена разделителя десятичных цифр - x <- stringr::str_replace(x, ",", ".") - - # exit if empty - if (check_for_empty_data(x)) { - return(NULL) - } - - # check for currect value - if (between(as.double(x), ranges[1], ranges[2])) { - NULL - } else { - glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.") - } - } - ) - } - } - } - - # if in `required` column value is `1` apply standart validation - if (!is.na(val_required) && val_required == 1) { - iv$add_rule(x_input_id, shinyvalidate::sv_required(message = "Необходимо заполнить.")) - } - } - ) - # enable validator - iv$enable() + iv_main <- data_validation$init_val(SCHEME_MAIN) + iv_main$enable() # STATUSES =============================== # вывести отображение что что-то не так @@ -401,8 +339,7 @@ server <- function(input, output) { }) output$status_message2 <- renderText({ - iv$is_valid() - # res_auth$admin + iv_main$is_valid() }) # CREATE RHANDSOME TABLES ===================== diff --git a/configs/schemas/main.xlsx b/configs/schemas/main.xlsx index 3aa4c49..6110899 100644 Binary files a/configs/schemas/main.xlsx and b/configs/schemas/main.xlsx differ diff --git a/configs/schemas/test_inline2.xlsx b/configs/schemas/test_inline2.xlsx deleted file mode 100644 index df19e63..0000000 Binary files a/configs/schemas/test_inline2.xlsx and /dev/null differ diff --git a/configs/schemas/test_inline3.xlsx b/configs/schemas/test_inline3.xlsx new file mode 100644 index 0000000..0ccd690 Binary files /dev/null and b/configs/schemas/test_inline3.xlsx differ diff --git a/helpers/functions.R b/helpers/functions.R index bd1c908..a5a5ca3 100644 --- a/helpers/functions.R +++ b/helpers/functions.R @@ -1,32 +1,11 @@ -get_dummy_data <- function(type) { - if (type %in% c("text", "select_one", "select_multiple")) return("dummy") - if (type %in% c("radio", "checkbox")) return("dummy") - if (type %in% c("date")) return(as.Date("1990-01-01")) - if (type %in% c("number")) return(as.double(999)) -} - -# get_empty_data <- function(type) { -# if (type %in% c("text", "select_one", "select_multiple")) return(as.character(NA)) -# if (type %in% c("radio", "checkbox")) return(as.character(NA)) -# if (type %in% c("date")) return(as.Date(NA)) -# if (type %in% c("number")) return(as.character(NA)) -# } - -get_dummy_df <- function() { - purrr::map( - .x = inputs_simple_list, - .f = get_empty_data - ) %>% - as_tibble() -} - #' @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 diff --git a/modules/data_manipulations.R b/modules/data_manipulations.R new file mode 100644 index 0000000..f668aaa --- /dev/null +++ b/modules/data_manipulations.R @@ -0,0 +1,25 @@ + +#' @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. +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_validation.R b/modules/data_validation.R new file mode 100644 index 0000000..27edb02 --- /dev/null +++ b/modules/data_validation.R @@ -0,0 +1,90 @@ + + +init_val <- function(scheme, ns) { + + options(box.path = here::here()) + box::use(modules/data_manipulations[check_for_empty_data]) + + iv <- shinyvalidate::InputValidator$new() + + # если передана функция с пространством имен, то происходит модификация id + if(!missing(ns)) { + scheme <- scheme |> + dplyr::mutate(form_id = ns(form_id)) + } + + # формируем список id - тип + inputs_simple_list <- scheme |> + dplyr::filter(!form_type %in% c("inline_table", "inline_table2","description", "description_header")) |> + dplyr::distinct(form_id, form_type) |> + tibble::deframe() + + # add rules to all inputs + purrr::walk( + .x = names(inputs_simple_list), + .f = \(x_input_id) { + + form_type <- inputs_simple_list[[x_input_id]] + + choices <- dplyr::filter(scheme, form_id == {{x_input_id}}) |> + dplyr::pull(choices) + + val_required <- dplyr::filter(scheme, form_id == {{x_input_id}}) |> + dplyr::distinct(required) |> + dplyr::pull(required) + + # for `number` type: if in `choices` column has values then parsing them to range validation + # value `0; 250` -> transform to rule validation value from 0 to 250 + if (form_type == "number") { + + iv$add_rule(x_input_id, function(x) { + # exit if empty + if (check_for_empty_data(x)) { + return(NULL) + } + # check for numeric + # if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом." + if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом." + }) + + # проверка на соответствие диапазону значений + if (!is.na(choices)) { + # разделить на несколько елементов + ranges <- as.integer(stringr::str_split_1(choices, "; ")) + + # проверка на кол-во значений + if (length(ranges) > 3) { + warning("Количество переданных элементов'", x_input_id, "' > 2") + } else { + iv$add_rule( + x_input_id, + function(x) { + + # замена разделителя десятичных цифр + x <- stringr::str_replace(x, ",", ".") + + # exit if empty + if (check_for_empty_data(x)) { + return(NULL) + } + + # check for currect value + if (dplyr::between(as.double(x), ranges[1], ranges[2])) { + NULL + } else { + glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.") + } + } + ) + } + } + } + + # if in `required` column value is `1` apply standart validation + if (!is.na(val_required) && val_required == 1) { + iv$add_rule(x_input_id, shinyvalidate::sv_required(message = "Необходимо заполнить.")) + } + } + ) + iv +} \ No newline at end of file diff --git a/modules/db.R b/modules/db.R index ff458da..9c9dd9d 100644 --- a/modules/db.R +++ b/modules/db.R @@ -24,4 +24,110 @@ close_db_connection <- function(con, where = "") { warning = function(w) if (getOption("APP.DEBUG", FALSE)) message("=!= ALREADY DISCONNECTED ", where), finally = if (getOption("APP.DEBUG", FALSE)) message("=/= DB DISCONNECT ", where) ) +} + +#' @export +#' проверить если таблица есть в базе данных и инициировать ее, если от +check_if_table_is_exist_and_init_if_not <- function( + table_name, + forms_id_type_list, + con = rlang::env_get(rlang::caller_env(), nm = "con") +) { + + if (table_name %in% DBI::dbListTables(con)) { + + cli::cli_inform("таблица есть такая: 'table_name'") + + # если таблица существует, производим проверку структуры таблицы + compare_existing_table_with_schema(table_name, forms_id_type_list) + + } else { + + dummy_df <- dplyr::mutate(get_dummy_df(forms_id_type_list), id = "dummy") + + # write dummy df into base, then delete dummy row + DBI::dbWriteTable(con, table_name, dummy_df, append = TRUE) + DBI::dbExecute(con, "DELETE FROM main WHERE id = 'dummy'") + + cli::cli_alert_success("таблица '{table_name}' успешно создана") + } + +} + +get_dummy_data <- function(type) { + + if (type %in% c("text", "select_one", "select_multiple")) return("dummy") + if (type %in% c("radio", "checkbox")) return("dummy") + if (type %in% c("date")) return(as.Date("1990-01-01")) + if (type %in% c("number")) return(as.double(999)) + +} + +get_dummy_df <- function(forms_id_type_list) { + + options(box.path = here::here()) + box::use(modules/utils) + + purrr::map( + .x = forms_id_type_list, + .f = utils$get_empty_data + ) |> + dplyr::as_tibble() + +} + +compare_existing_table_with_schema <- function( + table_name, + forms_id_type_list, + con = rlang::env_get(rlang::caller_env(), nm = "con") +) { + + 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)), names(forms_id_type_list))) { + print("identical") + } else { + df_to_rewrite <- DBI::dbReadTable(con, table_name) + form_base_difference <- setdiff(names(forms_id_type_list), colnames(df_to_rewrite)) + base_form_difference <- setdiff(colnames(df_to_rewrite), names(forms_id_type_list)) + + # if lengths are equal + if (length(names(forms_id_type_list)) == length(colnames(df_to_rewrite)) && + length(form_base_difference) == 0 && + length(base_form_difference) == 0) { + warning("changes in scheme file detected: assuming order changed only") + } + + if (length(names(forms_id_type_list)) == length(colnames(df_to_rewrite)) && + length(form_base_difference) != 0 && + length(base_form_difference) != 0) { + stop("changes in scheme file detected: structure has been changed") + } + + if (length(names(forms_id_type_list)) > length(colnames(df_to_rewrite)) && length(form_base_difference) != 0) { + warning("changes in scheme file detected: new inputs form was added") + warning("trying to adapt database") + + # add empty data for each new input form + for (i in form_base_difference) { + df_to_rewrite <- df_to_rewrite |> + dplyr::mutate(!!dplyr::sym(i) := utils$get_empty_data(forms_id_type_list[i])) + } + + # reorder due to scheme + df_to_rewrite <- df_to_rewrite |> + dplyr::select(dplyr::all_of(names(forms_id_type_list))) + + DBI::dbWriteTable(con, table_name, df_to_rewrite, overwrite = TRUE) + DBI::dbExecute(con, "DELETE FROM main WHERE id = 'dummy'") + } + + if (length(names(forms_id_type_list)) < length(colnames(df_to_rewrite))) { + stop("changes in scheme file detected: some of inputs form was deleted! it may cause data loss!") + } + # cleaning + rm(df_to_rewrite, form_base_difference) + } } \ No newline at end of file diff --git a/modules/utils.R b/modules/utils.R index 28b3912..bd3d314 100644 --- a/modules/utils.R +++ b/modules/utils.R @@ -50,19 +50,28 @@ render_forms <- function( form_id, form_label, form_type, - main_scheme + main_scheme, + ns ) { + # заготовку для формы (проверка на выходе функции) form <- NULL + + # параметры только для этой формы filterd_line <- dplyr::filter(main_scheme, form_id == {{form_id}}) - # check if have condition + # если передана ns() функция то подмеяем id для каждой формы в соответствии с пространством имен + if (!missing(ns)) { + form_id <- ns(form_id) + } + + # отдельно извлечение параметров условного отображения condition <- unique(filterd_line$condition) - # get choices from schema + # элементы выбора choices <- filterd_line$choices - # get choices from schema + # описание description <- unique(filterd_line) |> dplyr::filter(!is.na(form_description)) |> dplyr::distinct(form_description) |> @@ -84,12 +93,11 @@ render_forms <- function( shiny::tagList( if (!is.na(form_label)) { shiny::span(form_label, style = "color: #444444; font-weight: 550; line-height: 1.4;") - # если в схеме есть поле с описанием - добавлеяем его следующей строчкой + # если в схеме есть поле с описанием - добавляем его следующей строчкой }, if (!is.na(description) && !is.na(form_label)) shiny::br(), if (!is.na(description)) { shiny::span(shiny::markdown(description)) |> htmltools::tagAppendAttributes(style = "color:gray; font-size:small; line-height: 1.4;") - # span(description, style = "color:gray; font-size:small;") } ) } @@ -130,7 +138,7 @@ render_forms <- function( }) } - # еденичный выбор + # единичный выбор if (form_type == "select_one") { form <- shiny::selectizeInput( inputId = form_id, @@ -208,7 +216,8 @@ render_forms <- function( if (!is.na(condition)) { form <- shiny::conditionalPanel( condition = condition, - form + form, + ns = ifelse(missing(ns), shiny::NS(NULL), ns) ) } @@ -228,7 +237,6 @@ get_empty_data <- function(type) { if (type %in% c("number")) as.character(NA) } - #' @export #' @description Function to update input forms (default variants only) #' @param id - input form id;