diff --git a/.Rprofile b/.Rprofile index d6098c7..f1c39cd 100644 --- a/.Rprofile +++ b/.Rprofile @@ -4,7 +4,6 @@ source("renv/activate.R") (function() { paths <- c( - "R_CONFIG_ACTIVE", "AUTH_DB_KEY" ) @@ -18,3 +17,28 @@ source("renv/activate.R") )) } })() + +(function() { + + if (Sys.getenv("R_CONFIG_ACTIVE") == "") { + Sys.setenv(R_CONFIG_ACTIVE = "prod") + cli::cli_inform(c( + "i" = "Не указана конфигурация по умолчанию, автоматически установлен 'prod'. Для изменения конфигурации добавьте в {.file .Renviron}:" + )) + cli::cli_code(paste0("R_CONFIG_ACTIVE", "=")) + + } + Sys.setenv(R_CONFIG_FILE = "config/config.yml") + +})() + + +# при первом запуске скопировать пример конфига +(function() { + + if (!file.exists("config/config.yml")) { + file.copy("config/config_example.yml", "config/config.yml") + } + +})() + diff --git a/.gitignore b/.gitignore index 69fa24b..ab8065f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,8 +1,10 @@ /renv /temp /_devel +/all_bases + +config/config.yml -scheme.rds .Renviron .DS_Store .lintr diff --git a/CHANGELOG.md b/CHANGELOG.md index 34024d5..0e719d4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,27 @@ +### 0.18.2 - 0.18.3 (2026-06-18) +##### features +- возможность отражение лога действий по базам (для администраторов) и отдельно для каждой записи (сгруппированы по уникальным действиям) +- возможность экспорта таблицы со списком значений не прошедшие валидацию согласно схеме (для администраторов) + +##### refactor +- перестройка структуры репозитория + +### 0.18.1 (2026-06-08) +##### fix +- правильный экспорт текстовых данных + +### 0.18.0 (2026-06-06) +##### features +- возможность отрганичить доступ к базам данных для отдельных пользователей + +### 0.17.0 (2026-04-24) +##### features +- модуль с задачами: для каждой записи в базе можно создать задачи, на главном экране отображается общее количество активных задач, по сроку выполнения на сегодня и просроченные задачи; +- проверка на наличие орфанных записей в базе (сверка существующих ключей из главной таблицы `main` с каждой вложенной таблицей) + +##### changes +- определение активных схем - теперь в файле `config.yml` + ### 0.16.0 (2026-04-21) ##### features - возможность импорта данных в базу данных из ранее экспортированных .xlsx таблиц; diff --git a/app/forms.R b/R/app/forms.R similarity index 97% rename from app/forms.R rename to R/app/forms.R index 406efc3..bbca8e2 100644 --- a/app/forms.R +++ b/R/app/forms.R @@ -1,6 +1,6 @@ options(box.path = here::here()) box::use( - modules/utils, + R/modules/utils, ) #' @export diff --git a/R/app/logs.R b/R/app/logs.R new file mode 100644 index 0000000..dc83e32 --- /dev/null +++ b/R/app/logs.R @@ -0,0 +1,129 @@ +box::use( + shiny[...], + bslib[...] +) + +options(box.path = here::here()) +box::use( + R/modules/db, + R/modules/utils, + R/app/forms +) + +#' @export +server <- function(id, values, scheme, mhcs) { + + ns <- NS(id) + + moduleServer(id, function(input, output, session) { + + # отображение DT-таблицы со списком последних действий + observeEvent(input$show_last_actions, { + + con <- db$make_db_connection(scheme(),"show_last_actions") + on.exit(db$close_db_connection(con, "show_last_actions"), add = TRUE) + + log_df <- DBI::dbReadTable(con, "log") + + # новые записи вначале, формат даты с временем + log_df <- log_df |> + dplyr::arrange(dplyr::desc(date)) |> + dplyr::mutate(date = format(as.POSIXct(date), "%d.%m.%Y %H:%M")) + + output$dt_logs <- DT::renderDataTable( + DT::datatable( + log_df, + # caption = 'Table 1: This is a simple caption for the table.', + rownames = FALSE, + colnames = logs_colnames, + extensions = c('KeyTable', "FixedColumns"), + # editable = 'cell', + class = 'cell-border stripe', + selection = "single", + options = list( + # dom = 'tipf', + scrollX = TRUE, + fixedColumns = list(leftColumns = 1), + keys = TRUE, + autoWidth = TRUE, + columnDefs = list( + list(width = "150px", targets = c(0,6)), + list(width = "110px", targets = c(1:4)) + ) + ) + ) + ) + + showModal(modalDialog( + DT::dataTableOutput(ns("dt_logs")), + size = "xl", + # footer = tagList( + # actionButton("nested_form_dt_save", "сохранить изменения") + # ), + easyClose = TRUE + )) + + }) + + # observe({ + # print(input$dt_logs_rows_selected) + # }) + + output$display_log <- renderUI({ + req(values$main_key) + + # получение логов + con <- db$make_db_connection(scheme(),"display_log") + on.exit(db$close_db_connection(con, "display_log"), add = TRUE) + + query <- sprintf("SELECT * FROM \"log\" WHERE key = '%s'", values$main_key) + log_df_for_id <- DBI::dbGetQuery(con, query) + + if (nrow(log_df_for_id) > 0) { + + lines <- log_df_for_id |> + dplyr::mutate( + date = as.POSIXct(date), + date = date + lubridate::hours(3), # fix datetime + date_day = as.Date(date) + ) |> + dplyr::mutate(cons_actions = dplyr::consecutive_id(action, user)) |> + dplyr::mutate(n_actions = dplyr::row_number(), .by = c(cons_actions, user, action, date_day)) |> + dplyr::slice(which.max(n_actions), .by = c(user, action, date_day)) |> + dplyr::arrange(date) |> + dplyr::mutate(string_to_print = sprintf( + "[%s %s] %s: %s (%s)", + format(date, "%d.%m.%y"), + format(date, "%H:%M"), + user, + action, + n_actions + )) |> + dplyr::pull(string_to_print) |> + paste(collapse = "
") + + } else { + lines <- "" + } + + div( + strong("Последние действия:"), + br(), + HTML(lines), + style = "font-size:10px;" + ) + + }) + + }) +} + +logs_colnames <- c( + "время" = "date", + "пользователь" = "user", + "приложение" = "app_id", + "версия" = "app_ver", + "ip" = "remote_addr", + "ID записи" = "key", + "действие" = "action" +) diff --git a/app/tasks.R b/R/app/tasks.R similarity index 97% rename from app/tasks.R rename to R/app/tasks.R index 4493808..1203923 100644 --- a/app/tasks.R +++ b/R/app/tasks.R @@ -1,4 +1,3 @@ - box::use( shiny[...], bslib[...] @@ -6,9 +5,9 @@ box::use( options(box.path = here::here()) box::use( - modules/db, - modules/utils, - app/forms + R/modules/db, + R/modules/utils, + R/app/forms ) #' @export @@ -50,7 +49,7 @@ server <- function(id, values, scheme, mhcs) { if (!is.null(values$tasks_data)) { tasks_selector <- values$tasks_data |> - dplyr::filter(task_status != "completed") |> + dplyr::filter(task_status == "active") |> dplyr::pull(task_id) tasks_selector <- unique(c(values$tasks_id, tasks_selector)) @@ -117,11 +116,15 @@ server <- function(id, values, scheme, mhcs) { on.exit(db$close_db_connection(con, "display_task_modal"), add = TRUE) values$tasks_data <- if ("tasks" %in% DBI::dbListTables(con)) { + DBI::dbGetQuery(con, glue::glue("SELECT * FROM tasks WHERE task_main_key = '{values$main_key}'")) |> dplyr::mutate(dplyr::across(c("task_datetime_created", "task_datetime_last_updated", "task_datetime_completed"), as.POSIXct)) |> dplyr::mutate(dplyr::across(c("task_due_date"), as.Date)) + } else { + NULL + } values$tasks_id <- NULL @@ -159,6 +162,11 @@ server <- function(id, values, scheme, mhcs) { con <- db$make_db_connection(scheme(),"tasks_saving_button") on.exit(db$close_db_connection(con, "tasks_saving_button"), add = TRUE) + if (!values$main_key %in% db$get_keys_from_table("main", mhcs(), con)) { + showNotification("Невозможно создать задачу для данного ID (нет в базе)", type = "error") + return() + } + id_and_types_list <- mhcs()$get_id_type_list("tasks") input_types <- unname(id_and_types_list) input_ids <- names(id_and_types_list) @@ -353,7 +361,8 @@ server <- function(id, values, scheme, mhcs) { display_tasks_dt_review <- function() { values$tasks_data <- values$tasks_data |> - dplyr::select(task_id:task_datetime_last_updated) + dplyr::select(task_id:task_datetime_last_updated) |> + dplyr::arrange(task_due_date) rename_cols <- tasks_colnames[tasks_colnames %in% colnames(values$tasks_data)] @@ -368,6 +377,7 @@ server <- function(id, values, scheme, mhcs) { colnames = rename_cols, extensions = c("FixedColumns"), # editable = 'cell', + class = 'cell-border stripe', selection = "single", options = list( dom = 'tip', @@ -426,13 +436,11 @@ update_task_button_count <- function(con, values, ns) { inputID <- "display_task_modal" if (!missing(ns)) inputID <- ns(inputID) - # если ключ не определен - выход из функции if (is.null(values$main_key)) { updateActionButton(inputId = inputID, label = "Задачи") return() - } # при наличии таблицы - полу diff --git a/modules/data_manipulations.R b/R/modules/data_manipulations.R similarity index 100% rename from modules/data_manipulations.R rename to R/modules/data_manipulations.R diff --git a/R/modules/data_validation.R b/R/modules/data_validation.R new file mode 100644 index 0000000..fc8d703 --- /dev/null +++ b/R/modules/data_validation.R @@ -0,0 +1,249 @@ +options(box.path = here::here()) +box::use( + R/modules/data_manipulations[is_this_empty_value] +) + +#' @export +init_val = function(scheme, ns) { + + 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("nested_forms", "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, val_is_a_number) + + # проверка на соответствие диапазону значений + 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, val_number_within_a_range, ranges = ranges) + } + } + } + + if (form_type %in% c("select_multiple", "select_one", "radio", "checkbox")) { + iv$add_rule(x_input_id, val_choice_within_a_dict, choices = choices) + } + + # 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 +} + +# работа с числовыми значениями ------------------ +## проверка является ли значение числом ---------- +val_is_a_number = function(x) { + + # exit if empty + if (is_this_empty_value(x)) return(NULL) + + # хак для пропуска значений + if (x == "NA") return(NULL) + + # check for numeric + # if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом." + if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом." + +} + +## находится ли число в заданном диапазоне значений ------- +val_number_within_a_range = function(x, ranges) { + + # exit if empty + if (is_this_empty_value(x)) return(NULL) + if (x == "NA") return(NULL) + + # замена разделителя десятичных цифр + x <- stringr::str_replace(x, ",", ".") + + # check for currect value + if (dplyr::between(as.double(x), ranges[1], ranges[2])) { + NULL + } else { + glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.") + } +} + +# списки --------------------------------------------------------- +## являются ли выбранные значения допустимы (согласно файлу схемы) +val_choice_within_a_dict = function(x, choices) { + + if (length(x) == 1) { + if (is_this_empty_value(x)) return(NULL) + } + + # проверка на соответствие вариантов схеме --------- + compare_to_dict <- (x %in% choices) + if (!all(compare_to_dict)) { + + text <- paste0("'",x[!compare_to_dict],"'", collapse = ", ") + glue::glue("варианты, не соответствующие схеме: {text}") + } +} + +# ЭКСПОРТ ДАННЫХ ДЛЯ ВАЛИДАЦИИ +#' @export +validate_value_for_form <- function(data_to_check, form_type, choices, val_required) { + + res <- NULL + # 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") { + + res <- val_is_a_number(data_to_check) + if(!is.null(res)) return(res) + + # проверка на соответствие диапазону значений + if (!is.na(choices)) { + + # разделить на несколько елементов + ranges <- as.integer(stringr::str_split_1(choices, "; ")) + + # проверка на кол-во значений + if (length(ranges) > 3) { + warning("Количество переданных элементов'", x_input_id, "' > 2") + } else { + + res <- val_number_within_a_range(data_to_check, ranges = ranges) + if (!is.null(res)) return(res) + + } + } + } + + if (form_type %in% c("select_multiple", "select_one", "radio", "checkbox")) { + + if (!is_this_empty_value(data_to_check)) { + split_data <- stringr::str_split_1(data_to_check, "; ") + } else { + split_data <- NA + } + + res <- val_choice_within_a_dict(split_data, choices = choices) + if(!is.null(res)) return(res) + } + + # if in `required` column value is `1` apply standart validation + if (!is.na(val_required) && val_required == 1) { + + if (is_this_empty_value(data_to_check)) { + + res <- "Необходимо заполнить." + if(!is.null(res)) return(res) + + } + + } + + if(is.null(res)) return(NA) +} + +#' @export +get_table_with_data_validation_info <- function(schm, con) { + + # итерациям по всем таблицам + purrr::map( + purrr::set_names(schm$all_tables_names), + .f = \(table_name) { + + scheme <- schm$get_scheme(table_name) + data <- DBI::dbReadTable(con, table_name) + + inputs_simple_list <- schm$get_id_type_list(table_name) + + main_key <- schm$get_main_key_id + key <- schm$get_key_id(table_name) + + # итерация по всем form_id в текущей таблице + ff <- purrr::map2( + .x = names(inputs_simple_list), + .y = unname(inputs_simple_list), + .f = \(x_input_id, y_form_type) { + + this_id_scheme <- dplyr::filter(scheme, form_id == {{x_input_id}}) + + choices <- this_id_scheme$choices + val_required <- unique(this_id_scheme$required) + + # extract data + data_to_check <- data[[x_input_id]] + main_keys <- data[[main_key]] + keys <- data[[key]] + iter <- purrr::set_names(data_to_check, keys) + + # cli::cli_inform("~ input_id: {x_input_id} | type: {form_type} | value: {data_to_check}") + validation_info <- purrr::map(iter, validate_value_for_form, y_form_type, choices, val_required) + + df_with_result_and_validation_for_id <- tibble::enframe(validation_info, name = key, value = "value") |> + tidyr::unnest(cols = c(value)) + + # если главный ключ и ключ для таблицы не одно и тоже, добавление главного ключа в таблицу + if (main_key != key) { + df_with_result_and_validation_for_id[main_key] <- main_keys + } + + df_with_result_and_validation_for_id |> + dplyr::mutate(form_id = x_input_id) + + }) |> + purrr::list_rbind() + + ff |> + dplyr::distinct() |> + dplyr::filter(!is.na(value)) |> + # данные схемы для 'читабельности информации' + dplyr::left_join( + y = scheme |> dplyr::distinct(form_id, form_label) |> dplyr::mutate(nr = dplyr::row_number()), + by = dplyr::join_by(form_id), + ) |> + # сортировка (main_key, затем id формы - по порядку в схеме) + dplyr::arrange(!!rlang::sym(main_key), !!rlang::sym(main_key), nr) |> + dplyr::select( + !!rlang::sym(main_key), !!rlang::sym(main_key), + form_id, + form_label, + value + ) + + } + ) + +} + diff --git a/modules/db.R b/R/modules/db.R similarity index 97% rename from modules/db.R rename to R/modules/db.R index ec5ba1d..8c17d90 100644 --- a/modules/db.R +++ b/R/modules/db.R @@ -10,6 +10,7 @@ make_db_connection = function(scheme, where = "") { scheme, ext = "sqlite" )) + } #' @export @@ -102,7 +103,7 @@ get_dummy_data = function(type) { get_dummy_df = function(forms_id_type_list) { options(box.path = here::here()) - box::use(modules/utils) + box::use(R/modules/utils) purrr::map( .x = forms_id_type_list, @@ -135,7 +136,7 @@ compare_existing_table_with_schema = function( } options(box.path = here::here()) - box::use(modules/utils) + box::use(R/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)), all_ids_from_schema)) { @@ -200,7 +201,8 @@ write_df_to_db = function( date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE) number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE) - other_cols <- which(colnames(df) %in% c(date_columns, number_columns)) + # other_cols <- which(colnames(df) %in% c(date_columns, number_columns)) + other_cols <- colnames(df)[!(colnames(df) %in% c(date_columns, number_columns))] df <- df |> dplyr::mutate( @@ -208,7 +210,7 @@ write_df_to_db = function( dplyr::across(tidyselect::all_of({{date_columns}}), \(x) purrr::map_chr(x, excel_to_db_dates_converter)), # числа - к единому формату десятичных значений dplyr::across(tidyselect::all_of({{number_columns}}), ~ gsub("\\.", "," , .x)), - dplyr::across(tidyselect::all_of({{other_cols}}), as.character), + dplyr::across(tidyselect::all_of({{other_cols}}), \(x) dplyr::if_else(x == "", as.character(NA), as.character(x))) ) if (table_name == "main") { @@ -394,8 +396,8 @@ local_db_backup <- function( file.remove(utils::tail(existed_files, length(existed_files) - backups_limit)) } - # если количество существующих бэкапов равно имеющемуся и пора делать бэкап - делаем бэкап, удаляем послендий файл - if (dates[1] + schedule_days == Sys.Date()) { + # если количество существующих бэкапов равно имеющемуся и пора делать бэкап - делаем бэкап + if (dates[1] + schedule_days <= Sys.Date()) { file.copy(db_full_path, todays_backup) cli::cli_alert_success("создан {schedule_name}-бэкап для '{db_name}'") diff --git a/modules/global_options.R b/R/modules/global_options.R similarity index 75% rename from modules/global_options.R rename to R/modules/global_options.R index 2e1c798..8cf2525 100644 --- a/modules/global_options.R +++ b/R/modules/global_options.R @@ -1,72 +1,89 @@ + #' @export #' @description костыли для упрощения работы себе set_global_options = function( SYMBOL_DELIM = "; ", - APP.DEBUG = FALSE, - shiny.host = "127.0.0.1", - shiny.port = 1338, ... ) { - - config_params_to_check <- c( - "form_app_version", - "form_app_configure_path", - "form_auth_enabled", - "form_id", - "form_name" - ) - - expected_params_in_config <- config_params_to_check %in% names(config::get()) - if (!all(expected_params_in_config)) { - cli::cli_abort(c("ну так не пойдет:", paste("-", config_params_to_check[!expected_params_in_config]))) - } options( SYMBOL_DELIM = SYMBOL_DELIM, - # form.db_path = config::get("form_db_path"), - APP.DEBUG = APP.DEBUG, - # APP.FILE_DB = APP.FILE_DB, - shiny.host = shiny.host, - shiny.port = shiny.port, ... ) } +# global vars ------------------------------------ #' @export AUTH_ENABLED <- config::get("form_auth_enabled") +#' @export +#' TODO: нормальный разворот +ENABLED_SCHEMES <- unlist(config::get()$form_schemes) +ENABLED_SCHEMES <- stats::setNames(names(ENABLED_SCHEMES), ENABLED_SCHEMES) + +# ------------------------------------------------- + #' @export check_and_init_scheme = function() { + cli::cli_inform(c("*" = "проверка файла конфигурации...")) + + config_params_to_check <- c( + "form_app_version", + "form_id", + "form_name", + "form_app_configure_path", + "form_auth_enabled", + "form_schemes" + ) + + expected_params_in_config <- config_params_to_check %in% names(config::get()) + + if (!all(expected_params_in_config)) { + cli::cli_abort(c( + "Необходимо добавить в файл конфига {.file config.yml} следующие параметры:", + paste0(config_params_to_check[!expected_params_in_config], ":") + )) + } + # ------------------- + cli::cli_inform(c("*" = "проверка схемы...")) options(box.path = here::here()) - box::use(modules/db[local_db_backup]) + box::use( + R/modules/db[local_db_backup] + ) # список файлов, изменение которых, приведут к переинициализиации схемы files_to_watch <- c( - "config.yml", - "modules/scheme_generator.R", - "modules/utils.R" + "config/config.yml", + "R/modules/scheme_generator.R", + "R/modules/utils.R" ) + # проверка существования отслеживаемых файлов + if (!all(file.exists(files_to_watch))) { + cli::cli_abort("проверка схем: {files_to_watch[!file.exists(files_to_watch)]} is not exists") + } + scheme_names <- names(config::get()$form_schemes) - scheme_file <- paste0(config::get("form_app_configure_path"), "/configs/schemas/", scheme_names, ".xlsx") + scheme_file <- paste0(config::get("form_app_configure_path"), "/schemas/", scheme_names, ".xlsx") scheme_file <- stats::setNames(scheme_file, scheme_names) if (!all(file.exists(scheme_file))) { cli::cli_abort(c("Отсутствуют файлы схем для следующих наименований:", paste("-", names(scheme_file)[!file.exists(scheme_file)]))) } - + db_files <- paste0(config::get("form_app_configure_path"), "/db/", scheme_names, ".sqlite") + if (!dir.exists("temp")) dir.create("temp") hash_file <- "temp/schema_hash.rds" # exist_hash <- tools::md5sum(c(scheme_file, files_to_watch)) # если первый запуск (нет файла с кешем) инициализация схемы - if (!file.exists(hash_file) | !file.exists("scheme.rds") | !all(file.exists(db_files))) { + if (!file.exists(hash_file) | !file.exists("temp/scheme.rds")) { init_scheme(scheme_file) @@ -102,8 +119,8 @@ init_scheme = function(scheme_file) { options(box.path = here::here()) box::use( - modules/db, - modules/scheme_generator[scheme_R6] + R/modules/db, + R/modules/scheme_generator[scheme_R6] ) db_path <- fs::path(config::get("form_app_configure_path"), "db") @@ -146,5 +163,5 @@ init_scheme = function(scheme_file) { cli::cli_abort(c("В одной или нескольких схемах наименования вложенных форм совпадают:", paste("-", names(tab)[tab > 1]))) } - saveRDS(schms, "scheme.rds") + saveRDS(schms, "temp/scheme.rds") } diff --git a/modules/scheme_generator.R b/R/modules/scheme_generator.R similarity index 98% rename from modules/scheme_generator.R rename to R/modules/scheme_generator.R index fd837ac..b8593a3 100644 --- a/modules/scheme_generator.R +++ b/R/modules/scheme_generator.R @@ -49,14 +49,14 @@ scheme_R6 <- R6::R6Class( "task_status", "select_one", "Статус задачи", NA, "deleted", "task_title", "text", "Название задачи", NA, NA, "task_description", "text", "Описание задачи", "краткое описание", "3", - "task_due_date", "date", "Дата выполнения задачи", NA, NA, + "task_due_date", "date", "Срок выполнения задачи", NA, NA, ) |> dplyr::mutate(condition = NA) # extract main key private$main_key_id <- self$get_key_id("main") - box::use(modules/utils) + box::use(R/modules/utils) private$bslib_rendered_ui <- bslib::navset_card_underline( id = "main", !!!utils$make_list_of_pages(private$schemes_list[["main"]], private$main_key_id), diff --git a/modules/utils.R b/R/modules/utils.R similarity index 99% rename from modules/utils.R rename to R/modules/utils.R index 6541065..6e53b1f 100644 --- a/modules/utils.R +++ b/R/modules/utils.R @@ -266,7 +266,7 @@ update_forms_with_data = function( ) { options(box.path = here::here()) - box::use(modules/data_manipulations[is_this_empty_value]) + box::use(R/modules/data_manipulations[is_this_empty_value]) # print("-----------------") # cli::cli_inform("form_id: {form_id} | form_type: {form_type}") diff --git a/utils/init_login_db.r b/R/utils/init_login_db.r similarity index 60% rename from utils/init_login_db.r rename to R/utils/init_login_db.r index b37760c..fbd4018 100644 --- a/utils/init_login_db.r +++ b/R/utils/init_login_db.r @@ -3,17 +3,18 @@ # SETUP AUTH ============================= # Init DB using credentials data credentials <- data.frame( - user = c("admin", "user"), - password = c("admin", "user"), + user = c("admin", "user", "user2"), + password = c("admin", "user", "user2"), # password will automatically be hashed - admin = c(TRUE, FALSE), + admin = c(TRUE, FALSE, FALSE), + scheme_access = c(NA, "all", "example_of_scheme"), # NA - none | all - all | string with seperate stringsAsFactors = FALSE ) # Init the database shinymanager::create_db( credentials_data = credentials, - sqlite_path = "auth.sqlite", # will be created + sqlite_path = "temp/auth.sqlite", # will be created passphrase = Sys.getenv("AUTH_DB_KEY") # passphrase = "passphrase_wihtout_keyring" ) diff --git a/README.md b/README.md index 3d2ccfa..f3bf67e 100644 --- a/README.md +++ b/README.md @@ -23,10 +23,11 @@ git clone https://gitea.madelirihs.ru/madeliri/shiny_form.git Восстановление окружения ```r +renv::activate() renv::init() ``` -# Насторйки +# Настройки ## переменные окружения @@ -46,7 +47,8 @@ FORM_APP_LOCAL_DB_BACKUP_PATH="path_to_backups" Проверка осуществляется при каждом запуске приложения, бэкапы создаются раз в день (при первом запуске). -Количество сохраняемых бэкапов: +Количество послдних сохраненных бэкапов: + ``` FORM_APP_LOCAL_DB_BACKUP_LIMITS=3 ``` diff --git a/app.R b/app.R index d4bc5d7..69eeefb 100644 --- a/app.R +++ b/app.R @@ -1,81 +1,80 @@ -suppressPackageStartupMessages({ - library(DBI) - library(tidyr) - library(dplyr) - library(purrr) - library(magrittr) - library(shiny) - library(bslib) - library(shinymanager) -}) # SOURCE FILES ============================ +# packages box::purge_cache() box::use( - modules/utils, - modules/global_options, - modules/db, - modules/data_validation, - app/forms, - app/tasks + bslib[...], + shiny[...] +) +# modules +box::use( + R/modules/utils, + R/modules/db, + R/modules/data_validation, + R/app/forms, + R/app/tasks, + R/app/logs, + R/modules/data_manipulations[is_this_empty_value] ) -# global settings: -global_options$set_global_options( +# глобальные переменные и проверка/инициация схемы: +box::use( + R/modules/global_options[set_global_options, check_and_init_scheme], + R/modules/global_options[AUTH_ENABLED, ENABLED_SCHEMES], +) + +# set global settings: +set_global_options( shiny.host = "0.0.0.0", + shiny.port = 1338, APP.DEBUG = FALSE ) -# init: -global_options$check_and_init_scheme() +check_and_init_scheme() -# global vars: -box::use( - modules/global_options[AUTH_ENABLED] -) -enabled_schemes <- unlist(config::get()$form_schemes) -enabled_schemes <- setNames(names(enabled_schemes), enabled_schemes) - -# load schemes object: -schms <- readRDS("scheme.rds") +SCHMS <- readRDS("temp/scheme.rds") # CHECK FOR PANDOC ---------- -rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/") +# rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/") # TODO: dynamic button render depend on pandoc installation if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!") +# web resources ------ +shiny::addResourcePath("www", "www") + # UI ======================= ui <- page_sidebar( - # title = config::get("form_name"), - title = tagList( - h4(config::get("form_name"), style = "margin-top: .5rem"), - popover( - span( - config::get("form_app_version"), - fontawesome::fa("circle-info", a11y = "sem", title = "Settings"), - style = "color: #9c9c9c"), - title = "about", - placement = "left", - tagList(span("здесь пока ничего нет"), br(), span("вот")) - ) - ), + title = config::get("form_name"), theme = bs_theme(version = 5, preset = "bootstrap"), + header = tags$head( + tags$link(rel = "icon", href = "www/favicon.ico") + ), sidebar = sidebar( actionButton("add_new_main_key_button", "Добавить новую запись", icon("plus", lib = "font-awesome")), actionButton("save_data_button", "Сохранить данные", icon("floppy-disk", lib = "font-awesome")), actionButton("clean_data_button", "Главная страница", icon("house", lib = "font-awesome")), actionButton("load_data_button", "Загрузить данные", icon("pencil", lib = "font-awesome")), - downloadButton("downloadDocx", "get .docx (test only)"), + # downloadButton("downloadDocx", "get .docx (test only)"), uiOutput("status_message"), textOutput("status_message2"), - uiOutput("display_log"), actionButton("tasks-display_task_modal", "Задачи: нет активных", icon("list-check")), + uiOutput("logs-display_log"), position = "left", - open = list(mobile = "always") + open = list(mobile = "always"), + popover( + span( + config::get("form_app_version"), + fontawesome::fa("circle-info", a11y = "sem", title = "Settings"), + style = "color: #9c9c9c; position: fixed; bottom: 5px; left: 5px;"), + title = "about", + placement = "left", + tagList(span("здесь пока ничего нет"), br(), span("вот")) + ) ), as_fill_carrier(uiOutput("main_ui_navset")), + ) # init auth ======================= @@ -112,8 +111,8 @@ server <- function(input, output, session) { res_auth <- if (AUTH_ENABLED) { # check_credentials directly on sqlite db shinymanager::secure_server( - check_credentials = check_credentials( - db = "auth.sqlite", + check_credentials = shinymanager::check_credentials( + db = "temp/auth.sqlite", passphrase = Sys.getenv("AUTH_DB_KEY") ), keep_token = TRUE @@ -122,6 +121,23 @@ server <- function(input, output, session) { NULL } + user_access <- function(string) { + + if (is_this_empty_value(string)) return(NA) + if (string == "all") return("all") + + forms_access <- stringr::str_split_1(string, ", ") + + # check if exists + exists <- forms_access %in% ENABLED_SCHEMES + if (!all(exists)) { + cli::cli_warn(c("these forms is not exist:", paste("- ", forms_access[!exists]))) + } + + # возращаем схемы для которых есть доступ + forms_access[exists] + } + # важные кнопки управления output$admin_buttons_panel <- renderUI({ @@ -142,12 +158,17 @@ server <- function(input, output, session) { if (showing_buttons) { tagList( - br(), strong("Импорт и экспорт данных для выбранной схемы:"), verticalLayout( - downloadButton("downloadData", "Экспорт в .xlsx", style = "width: 250px; margin-top: 5px"), - actionButton("button_upload_data_from_xlsx", "импорт!", icon("file-import", lib = "font-awesome"), style = "width: 250px; margin-top: 10px"), + downloadButton("downloadData", "Экспорт базы в .xlsx", style = "width: 250px; margin-top: 5px"), + actionButton("button_upload_data_from_xlsx", "Импорт базы из .xlsx", icon("file-import", lib = "font-awesome"), style = "width: 250px; margin-top: 10px"), fluid = FALSE + ), + strong("Дополнительные опции:"), + verticalLayout( + actionButton("logs-show_last_actions", "Все действия", icon("scroll", lib = "font-awesome"), style = "width: 250px; margin-top: 10px"), + downloadButton("download_data_validation_info", "Некорректно заполненные данные (.xlsx)", icon("scroll", lib = "font-awesome"), style = "width: 250px; margin-top: 10px"), + fluid = FALSE ) ) } @@ -159,23 +180,53 @@ server <- function(input, output, session) { # Create a reactive values object to store the input data values <- reactiveValues( - data = NULL, - tasks_data = NULL, - main_key = NULL, - nested_key = NULL, - nested_form_id = NULL, - tasks_id = NULL, - current_user = NULL + data = NULL, + tasks_data = NULL, + main_key = NULL, + nested_key = NULL, + nested_form_id = NULL, + tasks_id = NULL, + current_user = NULL, + user_form_access = ENABLED_SCHEMES ) - scheme <- reactiveVal(enabled_schemes[1]) # наименование выбранной схемы - mhcs <- reactiveVal(schms[[enabled_schemes[1]]]) # объект для выбранной схемы + scheme <- reactiveVal(NULL) # наименование выбранной схемы + mhcs <- reactiveVal(NULL) # объект для выбранной схемы observers_started <- reactiveVal(NULL) - main_form_is_empty <- reactiveVal(TRUE) + main_form_is_empty <- reactiveVal(NULL) validator_main <- reactiveVal(NULL) validator_nested <- reactiveVal(NULL) + # доступ к схемам + observe({ + + # определение доступа в завимости от условий (включена ли авторизация, и есть ли доступы) + res <- if (AUTH_ENABLED) { + # если администратор - полный доступ, если нет - проверка по полю + ifelse(res_auth$admin, "all", user_access(res_auth$scheme_access)) + } else { + # если нет авторизации - полный доступ + "all" + } + if(length(res) == 0) return(NA) + + # списки доступных схем + allowed_schemas <- if (is.na(res)) { + NA # нет доступа + } else if (res == "all") { + ENABLED_SCHEMES # все схемы + } else { + ENABLED_SCHEMES[ENABLED_SCHEMES == res] # только указанные + } + + # переопределяем переменные + main_form_is_empty(ifelse(is.na(res), "empty", "main_menu")) + values$user_form_access <- allowed_schemas + scheme(values$user_form_access[1]) + mhcs(SCHMS[[values$user_form_access[1]]]) + }) + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # reactive ui ------------------------------- # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -183,15 +234,16 @@ server <- function(input, output, session) { ## reactive ui ----------------------------------- ### main screen ------ output$main_ui_navset <- renderUI({ + req(main_form_is_empty()) - if (main_form_is_empty()) { + if (main_form_is_empty() == "main_menu") { validator_main(NULL) div( h5("Выбрать базу данных для работы:"), shiny::radioButtons( "schmes_selector", label = NULL, - choices = enabled_schemes, + choices = values$user_form_access, selected = scheme() ), hr(), @@ -199,17 +251,23 @@ server <- function(input, output, session) { hr(), "Для начала работы нужно создать новую запись или загрузить существующую!", hr(), - # сво # загрузка панели для работы с базой данных uiOutput("admin_buttons_panel") ) - } else { + } else if (main_form_is_empty() == "form") { # list of rendered panels validator_main(data_validation$init_val(mhcs()$get_scheme("main"))) validator_main()$enable() mhcs()$get_main_form_ui + } else if (main_form_is_empty() == "empty") { + + div( + h5("Нет доступных баз данных для работы"), + p("Для данного пользователя нет доступа к формам для работы."), + p("Обратитесь к системному администратору.") + ) } }) @@ -218,7 +276,8 @@ server <- function(input, output, session) { output$base_data <- renderUI({ - if (main_form_is_empty() == TRUE) { + if (main_form_is_empty() == "main_menu") { + con <- db$make_db_connection(scheme(),"base_data") on.exit(db$close_db_connection(con, "base_data"), add = TRUE) @@ -231,13 +290,13 @@ server <- function(input, output, session) { # задачи на сегодня if ("tasks" %in% DBI::dbListTables(con)) { - tasks_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT (task_id) FROM tasks WHERE task_status = 'active'")) |> + tasks_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT (task_id) FROM \"tasks\" WHERE task_status = 'active'")) |> dplyr::pull() - tasks_today_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT (task_id) FROM tasks WHERE task_status = 'active' AND task_due_date = {as.integer(Sys.Date())}")) |> + tasks_today_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT (task_id) FROM \"tasks\" WHERE task_status = 'active' AND task_due_date = {as.integer(Sys.Date())}")) |> dplyr::pull() - tasks_overdue_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT (task_id) FROM tasks WHERE task_status = 'active' AND task_due_date < {as.integer(Sys.Date())}")) |> + tasks_overdue_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT (task_id) FROM \"tasks\" WHERE task_status = 'active' AND task_due_date < {as.integer(Sys.Date())}")) |> dplyr::pull() } else { @@ -265,7 +324,7 @@ server <- function(input, output, session) { observeEvent(input$schmes_selector, { scheme(input$schmes_selector) - mhcs(schms[[input$schmes_selector]]) + mhcs(SCHMS[[input$schmes_selector]]) }) @@ -311,13 +370,13 @@ server <- function(input, output, session) { } ) - exported_df <- setNames(exported_values, input_ids) |> - as_tibble() + exported_df <- stats::setNames(exported_values, input_ids) |> + dplyr::as_tibble() # пайплайн для главной таблицы if (table_name == "main") { exported_df <- exported_df |> - mutate( + dplyr::mutate( !!dplyr::sym(mhcs()$get_main_key_id) := values$main_key, .before = 1 ) @@ -326,7 +385,7 @@ server <- function(input, output, session) { # для всех остальных таблицы (вложенные) if (table_name != "main") { exported_df <- exported_df |> - mutate( + dplyr::mutate( !!dplyr::sym(mhcs()$get_main_key_id) := values$main_key, !!dplyr::sym(nested_key_id) := values$nested_key, .before = 1 @@ -352,6 +411,7 @@ server <- function(input, output, session) { ## кнопки для каждой вложенной таблицы ------------------------------- observe({ + req(scheme()) # проверка инициализированы ли для этой схемы наблюдатели для кнопок вложенных таблиц is_observer_is_started <- (isolate(scheme()) %in% isolate(observers_started())) @@ -411,7 +471,7 @@ server <- function(input, output, session) { # если ключ в формате даты - дать человекочитаемые данные if (this_nested_form_key_scheme_smoll$form_type == "date") { - kyes_for_this_table <- setNames( + kyes_for_this_table <- stats::setNames( kyes_for_this_table, format(as.Date(kyes_for_this_table), "%d.%m.%Y") ) @@ -497,12 +557,12 @@ server <- function(input, output, session) { str_cols <- which(col_types$form_type != "date") values$data <- values$data |> - select(-mhcs()$get_main_key_id) |> - mutate( + dplyr::select(-mhcs()$get_main_key_id) |> + dplyr::mutate( dplyr::across(tidyselect::all_of({{date_cols}}), as.Date), dplyr::across(tidyselect::all_of({{str_cols}}), as.character), ) |> - arrange({{key_id}}) + dplyr::arrange({{key_id}}) output$dt_nested <- DT::renderDataTable( DT::datatable( @@ -646,11 +706,12 @@ server <- function(input, output, session) { # загрузка данных в формы forms$load_data_to_form( - df = df, + df = df, table_name = values$nested_form_id, - mhcs = mhcs, - ns = NS(values$nested_form_id) + mhcs = mhcs, + ns = NS(values$nested_form_id) ) + } else { utils$clean_forms(values$nested_form_id, mhcs(), NS(values$nested_form_id)) } @@ -667,7 +728,7 @@ server <- function(input, output, session) { ui1 <- rlang::exec( .fn = utils$render_forms, - !!!distinct(scheme_for_key_input, form_id, form_label, form_type), + !!!dplyr::distinct(scheme_for_key_input, form_id, form_label, form_type), main_scheme = scheme_for_key_input ) @@ -719,7 +780,7 @@ server <- function(input, output, session) { need(values$main_key, "⚠️ Необходимо указать id пациента!") ) span( - strong("Таблица: "), names(enabled_schemes)[enabled_schemes == scheme()], + strong("Таблица: "), names(ENABLED_SCHEMES)[ENABLED_SCHEMES == scheme()], br(), strong("ID: "), values$main_key ) @@ -742,6 +803,7 @@ server <- function(input, output, session) { ## добавить новый главный ключ ------------------------ ### modal ------- observeEvent(input$add_new_main_key_button, { + req(main_form_is_empty() != "empty") # данные для главного ключа scheme_for_key_input <- mhcs()$get_scheme("main") |> @@ -750,7 +812,7 @@ server <- function(input, output, session) { # создать форму для выбора ключа ui1 <- rlang::exec( .fn = utils$render_forms, - !!!distinct(scheme_for_key_input, form_id, form_label, form_type), + !!!dplyr::distinct(scheme_for_key_input, form_id, form_label, form_type), main_scheme = scheme_for_key_input ) @@ -793,6 +855,8 @@ server <- function(input, output, session) { ## переход на главный акран ----------------------- ### show modal ------- observeEvent(input$clean_data_button, { + req(main_form_is_empty() == "form") + showModal(modalDialog( "Данное действие очистит все заполненные данные. Убедитесь, что нужные данные сохранены.", title = "Очистить форму?", @@ -810,7 +874,7 @@ server <- function(input, output, session) { # rewrite all inputs with empty data values$main_key <- NULL utils$clean_forms("main", mhcs()) - main_form_is_empty(TRUE) + main_form_is_empty("main_menu") removeModal() showNotification("Данные очищены!", type = "warning") @@ -840,11 +904,12 @@ server <- function(input, output, session) { ## загрузка данных ------------------- ### modal with keys ----- observeEvent(input$load_data_button, { + req(main_form_is_empty() != "empty") con <- db$make_db_connection(scheme(),"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(DBI::dbListTables(con)) != 0 && "main" %in% DBI::dbListTables(con)) { # GET DATA files ids <- db$get_keys_from_table("main", mhcs(), con) @@ -856,7 +921,7 @@ server <- function(input, output, session) { choices = ids, selected = NULL, options = list( - placeholder = "id пациента", + placeholder = "id", onInitialize = I('function() { this.setValue(""); }') ) ) @@ -921,7 +986,7 @@ server <- function(input, output, session) { } - main_form_is_empty(FALSE) + main_form_is_empty("form") } @@ -936,6 +1001,7 @@ server <- function(input, output, session) { paste0(isolate(scheme()), "_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx") }, content = function(file) { + req(main_form_is_empty() != "empty") con <- db$make_db_connection(isolate(scheme()),"downloadData") on.exit(db$close_db_connection(con, "downloadData"), add = TRUE) @@ -953,7 +1019,8 @@ server <- function(input, output, session) { date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE) number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE) - other_cols <- which(colnames(df) %in% c(date_columns, number_columns)) + # other_cols <- which(colnames(df) %in% c(date_columns, number_columns)) + other_cols <- colnames(df)[!(colnames(df) %in% c(date_columns, number_columns))] df <- df |> dplyr::mutate( @@ -961,7 +1028,7 @@ server <- function(input, output, session) { dplyr::across(tidyselect::all_of({{date_columns}}), as.Date), # числа - к единому формату десятичных значений dplyr::across(tidyselect::all_of({{number_columns}}), ~ gsub("\\.", "," , .x)), - dplyr::across(tidyselect::all_of({{other_cols}}), as.character) + dplyr::across(tidyselect::all_of({{other_cols}}), \(x) dplyr::if_else(x == "", as.character(NA), as.character(x))) ) |> # очистка от пустых ключей dplyr::filter(!is.na(mhcs()$get_main_key_id)) @@ -974,7 +1041,7 @@ server <- function(input, output, session) { list_of_df[["meta"]] <- dplyr::tribble( ~`Параметр` , ~`Значение`, "Пользователь" , values$current_user, - "Название базы" , names(enabled_schemes)[enabled_schemes == scheme()], + "Название базы" , names(ENABLED_SCHEMES)[ENABLED_SCHEMES == scheme()], "id базы" , scheme(), "id формы" , config::get("form_id"), "ver формы" , config::get("form_app_version"), @@ -1005,6 +1072,8 @@ server <- function(input, output, session) { paste0(values$main_key, "_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".docx") }, content = function(file) { + req(main_form_is_empty() != "empty") + # prepare YAML sections empty_vec <- c( "---", @@ -1014,7 +1083,6 @@ server <- function(input, output, session) { "---", "\n" ) - box::use(modules/data_manipulations[is_this_empty_value]) # iterate by scheme parts purrr::walk( @@ -1081,7 +1149,7 @@ server <- function(input, output, session) { # write vector to temp .Rmd file writeLines(empty_vec, temp_report, sep = "\n") # copy template .docx file - file.copy("references/reference.docx", temp_template, overwrite = TRUE) + file.copy("resources/references/reference.docx", temp_template, overwrite = TRUE) # render file via pandoc rmarkdown::render( @@ -1170,7 +1238,8 @@ server <- function(input, output, session) { date_columns <- subset(scheme, form_type == "date", form_id, drop = TRUE) number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE) - other_cols <- which(colnames(df) %in% c(date_columns, number_columns)) + # other_cols <- which(colnames(df) %in% c(date_columns, number_columns)) + other_cols <- colnames(df)[!(colnames(df) %in% c(date_columns, number_columns))] # функция для преобразование числовых значений и сохранения "NA" num_converter <- function(old_col) { @@ -1188,14 +1257,14 @@ server <- function(input, output, session) { df <- df |> dplyr::mutate( # даты - к единому формату - dplyr::across(tidyselect::all_of({{date_columns}}), \(x) purrr::map_chr(x, db$excel_to_db_dates_converter)), + dplyr::across(tidyselect::all_of({{date_columns}}), \(x) purrr::map_chr(x, db$excel_to_db_dates_converter)), dplyr::across(tidyselect::all_of({{number_columns}}), num_converter), - dplyr::across(tidyselect::all_of({{other_cols}}), as.character) + dplyr::across(tidyselect::all_of({{other_cols}}), \(x) dplyr::if_else(x == "", as.character(NA), as.character(x))) ) |> - select(all_of(unique(c(main_key_id, scheme$form_id)))) + dplyr::select(tidyselect::all_of(unique(c(main_key_id, scheme$form_id)))) df_original <- DBI::dbReadTable(con, table_name) |> - as_tibble() + dplyr::as_tibble() if (input$upload_data_from_xlsx_owerwrite_all_data == TRUE) { @@ -1204,15 +1273,24 @@ server <- function(input, output, session) { } else { # удаление данных в базе данных по ключам - walk( - .x = unique(df[[main_key_id]]), - .f = \(main_key) { + # purrr::walk( + # .x = unique(df[[main_key_id]]), + # .f = \(main_key) { - if (main_key %in% unique(df_original[[main_key_id]])) { - DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key_id} = '{main_key}'")) - } - } - ) + # if (main_key %in% unique(df_original[[main_key_id]])) { + # DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key_id} = '{main_key}'")) + # } + # } + # ) + + # TODO + all_existed_keys <- unique(df_original[[main_key_id]]) + all_new_keys <- unique(df[[main_key_id]]) + + keys_to_delete <- all_existed_keys[all_existed_keys %in% all_new_keys] + keys_to_delete <- paste0("'", keys_to_delete, "'", collapse = ", ") + + DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE \"{main_key_id}\" IN ({keys_to_delete})")) } @@ -1250,7 +1328,7 @@ server <- function(input, output, session) { read_df_from_db_all <- function(table_name, con) { # check if this table exist - if (table_name %in% dbListTables(con)) { + if (table_name %in% DBI::dbListTables(con)) { # prepare query query <- glue::glue(" SELECT * FROM {table_name} @@ -1269,6 +1347,7 @@ server <- function(input, output, session) { "loading data", "creating new key", "exporting data to xlsx", + "export validation dataset", "importing data from xlsx" ), key = NA, @@ -1277,7 +1356,7 @@ server <- function(input, output, session) { action <- match.arg(action) - action_row <- tibble( + action_row <- dplyr::tibble( date = Sys.time(), user = values$current_user, app_id = config::get("form_id"), @@ -1293,9 +1372,57 @@ server <- function(input, output, session) { # TASKS --------------------------------------- tasks$server("tasks", values, scheme, mhcs) + # SHOW LOGS ----------------------------------- + logs$server("logs", values, scheme, mhcs) + + # экспорт таблицы с информации о валидации данных ------------------- + output$download_data_validation_info <- downloadHandler( + filename = function(){ + paste0("dvinfo_", isolate(scheme()), "_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx") + }, + content = function(file) { + req(main_form_is_empty() != "empty") + + box::use( + R/modules/data_validation[get_table_with_data_validation_info] + ) + + con <- db$make_db_connection(isolate(scheme()),"download_data_validation_info") + on.exit(db$close_db_connection(con, "download_data_validation_info"), add = TRUE) + + list_of_df <- get_table_with_data_validation_info(mhcs(), con) + + # добавить мета информацию + list_of_df[["meta"]] <- dplyr::tribble( + ~`Параметр` , ~`Значение`, + "Пользователь" , values$current_user, + "Название базы" , names(ENABLED_SCHEMES)[ENABLED_SCHEMES == scheme()], + "id базы" , scheme(), + "id формы" , config::get("form_id"), + "ver формы" , config::get("form_app_version"), + "Время выгрузки" , format(Sys.time(), "%d.%m.%Y %H:%M:%S"), + ) + + # set date params + options("openxlsx2.dateFormat" = "dd.mm.yyyy") + + cli::cli_alert_success("Данные успешно экспортированы") + showNotification("Данные успешно экспортированы", type = "message") + log_action_to_db("export validation dataset", con = con) + + # pass tables to export + openxlsx2::write_xlsx( + purrr::compact(list_of_df), + file, + na.strings = "", + as_table = TRUE, + col_widths = 20 + ) + } + ) + } +app <- shiny::shinyApp(ui = ui, server = server) -app <- shinyApp(ui = ui, server = server) - -runApp(app, launch.browser = TRUE) \ No newline at end of file +shiny::runApp(app, launch.browser = TRUE) \ No newline at end of file diff --git a/config.yml b/config.yml deleted file mode 100644 index 9acd10a..0000000 --- a/config.yml +++ /dev/null @@ -1,20 +0,0 @@ -default: - form_app_version: 0.16.0 - form_id: new_formy - form_name: NEW FORMY - -prod: - form_app_configure_path: "." - form_auth_enabled: false - form_schemes: - example_of_scheme: Тестовая база данных - main_register: АВЗ и АМИЛОИОДОЗЫ - -devel: - form_app_configure_path: _devel/new_bases - form_auth_enabled: false - form_app_version: 0.16.0 dev - form_schemes: - antifib: антифибротическая - d2tra_t: D2TRA_test - \ No newline at end of file diff --git a/config/config_example.yml b/config/config_example.yml new file mode 100644 index 0000000..5f445c4 --- /dev/null +++ b/config/config_example.yml @@ -0,0 +1,10 @@ +default: + form_app_version: !expr config::get("form_app_version", file = "config/descr.yml") + form_id: !expr config::get("form_id", file = "config/descr.yml") + form_name: !expr config::get("form_name", file = "config/descr.yml") + +prod: + form_app_configure_path: "example_scheme" + form_auth_enabled: false + form_schemes: + example_of_scheme: Тестовая база данных diff --git a/config/descr.yml b/config/descr.yml new file mode 100644 index 0000000..e8b51b6 --- /dev/null +++ b/config/descr.yml @@ -0,0 +1,4 @@ +default: + form_app_version: 0.18.3 + form_id: formy + form_name: FORMY \ No newline at end of file diff --git a/configs/schemas/example_of_scheme.xlsx b/example_scheme/schemas/example_of_scheme.xlsx similarity index 100% rename from configs/schemas/example_of_scheme.xlsx rename to example_scheme/schemas/example_of_scheme.xlsx diff --git a/modules/data_validation.R b/modules/data_validation.R deleted file mode 100644 index 21d15f9..0000000 --- a/modules/data_validation.R +++ /dev/null @@ -1,117 +0,0 @@ -options(box.path = here::here()) -box::use(modules/data_manipulations[is_this_empty_value]) - -#' @export -init_val = function(scheme, ns) { - - 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("nested_forms", "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, val_is_a_number) - - # проверка на соответствие диапазону значений - 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, val_number_within_a_range, ranges = ranges) - } - } - } - - if (form_type %in% c("select_multiple", "select_one", "radio", "checkbox")) { - iv$add_rule(x_input_id, val_choice_within_a_dict, choices = choices) - } - - # 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 -} - -# работа с числовыми значениями ------------------ -## проверка является ли значение числом ---------- -val_is_a_number = function(x) { - - # exit if empty - if (is_this_empty_value(x)) return(NULL) - - # хак для пропуска значений - if (x == "NA") return(NULL) - - # check for numeric - # if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом." - if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом." - -} - -## находится ли число в заданном диапазоне значений ------- -val_number_within_a_range = function(x, ranges) { - - # exit if empty - if (is_this_empty_value(x)) return(NULL) - if (x == "NA") return(NULL) - - # замена разделителя десятичных цифр - x <- stringr::str_replace(x, ",", ".") - - # check for currect value - if (dplyr::between(as.double(x), ranges[1], ranges[2])) { - NULL - } else { - glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.") - } -} - -# списки --------------------------------------------------------- -## являются ли выбранные значения допустимы (согласно файлу схемы) -val_choice_within_a_dict = function(x, choices) { - - if (length(x) == 1) { - if (is_this_empty_value(x)) return(NULL) - } - - # проверка на соответствие вариантов схеме --------- - compare_to_dict <- (x %in% choices) - if (!all(compare_to_dict)) { - - text <- paste0("'",x[!compare_to_dict],"'", collapse = ", ") - glue::glue("варианты, не соответствующие схеме: {text}") - } -} \ No newline at end of file diff --git a/renv.lock b/renv.lock index ca6849e..0c36946 100644 --- a/renv.lock +++ b/renv.lock @@ -1,6 +1,6 @@ { "R": { - "Version": "4.3.1", + "Version": "4.3.2", "Repositories": [ { "Name": "CRAN", @@ -717,6 +717,19 @@ ], "Hash": "b8552d117e1b808b09a832f589b79035" }, + "lubridate": { + "Package": "lubridate", + "Version": "1.9.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "generics", + "methods", + "timechange" + ], + "Hash": "07061b348d057e8ac86771e0eff36b62" + }, "magrittr": { "Package": "magrittr", "Version": "2.0.3", @@ -1203,6 +1216,17 @@ ], "Hash": "79540e5fcd9e0435af547d885f184fd5" }, + "timechange": { + "Package": "timechange", + "Version": "0.4.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cpp11" + ], + "Hash": "39c40cb1ad47a4cc384a34a22a29463f" + }, "tinytex": { "Package": "tinytex", "Version": "0.46", diff --git a/references/reference.docx b/resources/references/reference.docx similarity index 100% rename from references/reference.docx rename to resources/references/reference.docx diff --git a/www/favicon.ico b/www/favicon.ico new file mode 100644 index 0000000..844ac1d Binary files /dev/null and b/www/favicon.ico differ