Compare commits

..

20 Commits

Author SHA1 Message Date
e903cd975d Merge pull request '0.18.4' (#3) from devel into main
Reviewed-on: #3
2026-08-12 11:53:24 +03:00
e07d6f70e3 изменение стиля, фикс демонстрации иконки 2026-08-12 11:48:35 +03:00
ab949ee9c2 remake config 2026-08-12 10:03:37 +03:00
fc2e518d7e Merge branch 'devel' of https://gitea.madelirihs.ru/madeliri/shiny_form into devel 2026-08-12 09:59:48 +03:00
14839dee5f update lock 2026-08-12 09:59:46 +03:00
915f3e9810 Удалить config/config.yml 2026-08-12 09:58:51 +03:00
fcd19fb09e Merge branch 'devel' of https://gitea.madelirihs.ru/madeliri/shiny_form into devel 2026-06-23 13:51:35 +03:00
989cc9b219 mm 2026-06-23 13:51:31 +03:00
b428c976d5 Merge pull request 'main > devel' (#2) from main into devel
Reviewed-on: #2
2026-06-23 13:49:22 +03:00
fb4335006d fix. lil code fixing 2026-06-23 13:47:52 +03:00
12c17d3766 refactor: меняем файлы местами в очередной раз 2026-06-23 13:43:25 +03:00
dc51156490 fix: корректная проверка схем 2026-06-18 20:38:06 +03:00
8f3343a103 0.18.3 2026-06-18 14:02:22 +03:00
4baec1003a 0.18.2 2026-06-18 10:27:41 +03:00
7ed3ee0480 fix: path to auth db 2026-06-18 08:07:08 +03:00
a178480912 refactor: moving config files to separate folder 2026-06-17 16:54:58 +03:00
a4d829e3dd fix: more namespacing fixes 2026-06-17 14:38:26 +03:00
89d58c8df5 fix: missing namespaces for functions 2026-06-17 13:45:43 +03:00
4c50473c7e refactor: push all global vars to globla options 2026-06-16 15:40:46 +03:00
df740c4f71 fix; some comments 2026-06-15 16:44:02 +03:00
18 changed files with 319 additions and 116 deletions

View File

@@ -28,6 +28,7 @@ source("renv/activate.R")
cli::cli_code(paste0("R_CONFIG_ACTIVE", "=")) cli::cli_code(paste0("R_CONFIG_ACTIVE", "="))
} }
Sys.setenv(R_CONFIG_FILE = "config/config.yml")
})() })()
@@ -35,8 +36,8 @@ source("renv/activate.R")
# при первом запуске скопировать пример конфига # при первом запуске скопировать пример конфига
(function() { (function() {
if (!file.exists("config.yml")) { if (!file.exists("config/config.yml")) {
file.copy("config_example.yml", "config.yml") file.copy("config/config_example.yml", "config/config.yml")
} }
})() })()

2
.gitignore vendored
View File

@@ -3,7 +3,7 @@
/_devel /_devel
/all_bases /all_bases
config.yml config/config.yml
.Renviron .Renviron
.DS_Store .DS_Store

View File

@@ -1,3 +1,11 @@
### 0.18.2 - 0.18.3 (2026-06-18)
##### features
- возможность отражение лога действий по базам (для администраторов) и отдельно для каждой записи (сгруппированы по уникальным действиям)
- возможность экспорта таблицы со списком значений не прошедшие валидацию согласно схеме (для администраторов)
##### refactor
- перестройка структуры репозитория
### 0.18.1 (2026-06-08) ### 0.18.1 (2026-06-08)
##### fix ##### fix
- правильный экспорт текстовых данных - правильный экспорт текстовых данных

View File

@@ -1,5 +1,7 @@
options(box.path = here::here()) options(box.path = here::here())
box::use(R/modules/data_manipulations[is_this_empty_value]) box::use(
R/modules/data_manipulations[is_this_empty_value]
)
#' @export #' @export
init_val = function(scheme, ns) { init_val = function(scheme, ns) {
@@ -115,3 +117,133 @@ val_choice_within_a_dict = function(x, choices) {
glue::glue("варианты, не соответствующие схеме: {text}") 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
)
}
)
}

View File

@@ -1,19 +1,33 @@
.on_load = function(ns) {
check_and_init_scheme()
}
#' @export #' @export
#' @description костыли для упрощения работы себе #' @description костыли для упрощения работы себе
set_global_options = function( set_global_options = function(
SYMBOL_DELIM = "; ", SYMBOL_DELIM = "; ",
APP.DEBUG = FALSE,
# shiny.host = "127.0.0.1",
# shiny.port = 1338,
... ...
) { ) {
options(
SYMBOL_DELIM = SYMBOL_DELIM,
...
)
}
# 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( config_params_to_check <- c(
"form_app_version", "form_app_version",
"form_id", "form_id",
@@ -24,28 +38,14 @@ set_global_options = function(
) )
expected_params_in_config <- config_params_to_check %in% names(config::get()) expected_params_in_config <- config_params_to_check %in% names(config::get())
if (!all(expected_params_in_config)) { if (!all(expected_params_in_config)) {
cli::cli_abort(c( cli::cli_abort(c(
"Необходимо добавить в файл конфига {.file config.yml} следующие параметры:", "Необходимо добавить в файл конфига {.file config.yml} следующие параметры:",
paste0(config_params_to_check[!expected_params_in_config], ":") paste0(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,
# shiny.host = shiny.host,
# shiny.port = shiny.port,
...
)
}
#' @export
AUTH_ENABLED <- config::get("form_auth_enabled")
#' @export
check_and_init_scheme = function() {
cli::cli_inform(c("*" = "проверка схемы...")) cli::cli_inform(c("*" = "проверка схемы..."))
@@ -56,7 +56,7 @@ check_and_init_scheme = function() {
# список файлов, изменение которых, приведут к переинициализиации схемы # список файлов, изменение которых, приведут к переинициализиации схемы
files_to_watch <- c( files_to_watch <- c(
"config.yml", "config/config.yml",
"R/modules/scheme_generator.R", "R/modules/scheme_generator.R",
"R/modules/utils.R" "R/modules/utils.R"
) )
@@ -76,13 +76,14 @@ check_and_init_scheme = function() {
db_files <- paste0(config::get("form_app_configure_path"), "/db/", scheme_names, ".sqlite") 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" hash_file <- "temp/schema_hash.rds"
# #
exist_hash <- tools::md5sum(c(scheme_file, files_to_watch)) exist_hash <- tools::md5sum(c(scheme_file, files_to_watch))
# если первый запуск (нет файла с кешем) инициализация схемы # если первый запуск (нет файла с кешем) инициализация схемы
if (!file.exists(hash_file) | !file.exists("temp/scheme.rds") | !all(file.exists(db_files))) { if (!file.exists(hash_file) | !file.exists("temp/scheme.rds")) {
init_scheme(scheme_file) init_scheme(scheme_file)

View File

@@ -49,7 +49,7 @@ scheme_R6 <- R6::R6Class(
"task_status", "select_one", "Статус задачи", NA, "deleted", "task_status", "select_one", "Статус задачи", NA, "deleted",
"task_title", "text", "Название задачи", NA, NA, "task_title", "text", "Название задачи", NA, NA,
"task_description", "text", "Описание задачи", "краткое описание", "3", "task_description", "text", "Описание задачи", "краткое описание", "3",
"task_due_date", "date", "Дата выполнения задачи", NA, NA, "task_due_date", "date", "Срок выполнения задачи", NA, NA,
) |> ) |>
dplyr::mutate(condition = NA) dplyr::mutate(condition = NA)
@@ -168,16 +168,3 @@ scheme_R6 <- R6::R6Class(
} }
) )
) )
# object.size(schm)
# schm$get_key_id("main")
# schm$get_forms_ids("main")
# schm$get_all_ids("main")
# schm$get_scheme("main")
# schm$get_id_type_list("allergo_anamnesis")
# # active
# schm$get_main_key_id
# schm$all_tables_names

View File

@@ -108,7 +108,11 @@ render_forms = function(
} else { } else {
shiny::tagList( shiny::tagList(
if (!is.na(form_label)) { if (!is.na(form_label)) {
shiny::span(form_label, style = "color: #444444; font-weight: 550; line-height: 1.4;") if (form_type == "description_header") {
shiny::span(form_label, class = "description-header", style = "color: #444444; font-weight: 550; line-height: 1.4;")
} else {
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) && !is.na(form_label)) shiny::br(),

View File

@@ -14,7 +14,7 @@ credentials <- data.frame(
# Init the database # Init the database
shinymanager::create_db( shinymanager::create_db(
credentials_data = credentials, 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 = Sys.getenv("AUTH_DB_KEY")
# passphrase = "passphrase_wihtout_keyring" # passphrase = "passphrase_wihtout_keyring"
) )

Binary file not shown.

163
app.R
View File

@@ -9,7 +9,6 @@ box::use(
# modules # modules
box::use( box::use(
R/modules/utils, R/modules/utils,
R/modules/global_options,
R/modules/db, R/modules/db,
R/modules/data_validation, R/modules/data_validation,
R/app/forms, R/app/forms,
@@ -18,22 +17,22 @@ box::use(
R/modules/data_manipulations[is_this_empty_value] R/modules/data_manipulations[is_this_empty_value]
) )
# глобальные переменные и проверка/инициация схемы:
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 settings:
global_options$set_global_options( set_global_options(
shiny.host = "0.0.0.0", shiny.host = "0.0.0.0",
shiny.port = 1338, shiny.port = 1338,
APP.DEBUG = FALSE APP.DEBUG = FALSE
) )
# global vars: check_and_init_scheme()
box::use(
R/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("temp/scheme.rds")
schms <- readRDS("temp/scheme.rds")
# CHECK FOR PANDOC ---------- # CHECK FOR PANDOC ----------
# rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/") # rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
@@ -43,15 +42,18 @@ if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!")
# web resources ------ # web resources ------
shiny::addResourcePath("www", "www") shiny::addResourcePath("www", "www")
shiny::resourcePaths()
# UI ======================= # UI =======================
ui <- page_sidebar( ui <- page_sidebar(
title = config::get("form_name"), title = config::get("form_name"),
theme = bs_theme(version = 5, preset = "bootstrap"), theme = bs_theme(version = 5, preset = "bootstrap"),
header = tags$head(
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "www/styles.css"),
tags$link(rel = "icon", href = "www/favicon.ico") tags$link(rel = "icon", href = "www/favicon.ico")
), ),
sidebar = sidebar( sidebar = sidebar(
actionButton("add_new_main_key_button", "Добавить новую запись", icon("plus", lib = "font-awesome")), actionButton("add_new_main_key_button", "Добавить новую запись", icon("plus", lib = "font-awesome")),
actionButton("save_data_button", "Сохранить данные", icon("floppy-disk", lib = "font-awesome")), actionButton("save_data_button", "Сохранить данные", icon("floppy-disk", lib = "font-awesome")),
@@ -113,7 +115,7 @@ server <- function(input, output, session) {
# check_credentials directly on sqlite db # check_credentials directly on sqlite db
shinymanager::secure_server( shinymanager::secure_server(
check_credentials = shinymanager::check_credentials( check_credentials = shinymanager::check_credentials(
db = "auth.sqlite", db = "temp/auth.sqlite",
passphrase = Sys.getenv("AUTH_DB_KEY") passphrase = Sys.getenv("AUTH_DB_KEY")
), ),
keep_token = TRUE keep_token = TRUE
@@ -130,7 +132,7 @@ server <- function(input, output, session) {
forms_access <- stringr::str_split_1(string, ", ") forms_access <- stringr::str_split_1(string, ", ")
# check if exists # check if exists
exists <- forms_access %in% enabled_schemes exists <- forms_access %in% ENABLED_SCHEMES
if (!all(exists)) { if (!all(exists)) {
cli::cli_warn(c("these forms is not exist:", paste("- ", forms_access[!exists]))) cli::cli_warn(c("these forms is not exist:", paste("- ", forms_access[!exists])))
} }
@@ -161,13 +163,14 @@ server <- function(input, output, session) {
tagList( tagList(
strong("Импорт и экспорт данных для выбранной схемы:"), strong("Импорт и экспорт данных для выбранной схемы:"),
verticalLayout( verticalLayout(
downloadButton("downloadData", "Экспорт в .xlsx", style = "width: 250px; margin-top: 5px"), 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"), actionButton("button_upload_data_from_xlsx", "Импорт базы из .xlsx", icon("file-import", lib = "font-awesome"), style = "width: 250px; margin-top: 10px"),
fluid = FALSE fluid = FALSE
), ),
strong("Дополнительные опции:"), strong("Дополнительные опции:"),
verticalLayout( verticalLayout(
actionButton("logs-show_last_actions", "Все действия", icon("scroll", lib = "font-awesome"), style = "width: 250px; margin-top: 10px"), 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 fluid = FALSE
) )
) )
@@ -187,7 +190,7 @@ server <- function(input, output, session) {
nested_form_id = NULL, nested_form_id = NULL,
tasks_id = NULL, tasks_id = NULL,
current_user = NULL, current_user = NULL,
user_form_access = enabled_schemes user_form_access = ENABLED_SCHEMES
) )
scheme <- reactiveVal(NULL) # наименование выбранной схемы scheme <- reactiveVal(NULL) # наименование выбранной схемы
@@ -215,16 +218,16 @@ server <- function(input, output, session) {
allowed_schemas <- if (is.na(res)) { allowed_schemas <- if (is.na(res)) {
NA # нет доступа NA # нет доступа
} else if (res == "all") { } else if (res == "all") {
enabled_schemes # все схемы ENABLED_SCHEMES # все схемы
} else { } else {
enabled_schemes[enabled_schemes == res] # только указанные ENABLED_SCHEMES[ENABLED_SCHEMES == res] # только указанные
} }
# переопределяем переменные # переопределяем переменные
main_form_is_empty(ifelse(is.na(res), "empty", "main_menu")) main_form_is_empty(ifelse(is.na(res), "empty", "main_menu"))
values$user_form_access <- allowed_schemas values$user_form_access <- allowed_schemas
scheme(values$user_form_access[1]) scheme(values$user_form_access[1])
mhcs(schms[[values$user_form_access[1]]]) mhcs(SCHMS[[values$user_form_access[1]]])
}) })
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -324,7 +327,7 @@ server <- function(input, output, session) {
observeEvent(input$schmes_selector, { observeEvent(input$schmes_selector, {
scheme(input$schmes_selector) scheme(input$schmes_selector)
mhcs(schms[[input$schmes_selector]]) mhcs(SCHMS[[input$schmes_selector]])
}) })
@@ -370,13 +373,13 @@ server <- function(input, output, session) {
} }
) )
exported_df <- setNames(exported_values, input_ids) |> exported_df <- stats::setNames(exported_values, input_ids) |>
as_tibble() dplyr::as_tibble()
# пайплайн для главной таблицы # пайплайн для главной таблицы
if (table_name == "main") { if (table_name == "main") {
exported_df <- exported_df |> exported_df <- exported_df |>
mutate( dplyr::mutate(
!!dplyr::sym(mhcs()$get_main_key_id) := values$main_key, !!dplyr::sym(mhcs()$get_main_key_id) := values$main_key,
.before = 1 .before = 1
) )
@@ -385,7 +388,7 @@ server <- function(input, output, session) {
# для всех остальных таблицы (вложенные) # для всех остальных таблицы (вложенные)
if (table_name != "main") { if (table_name != "main") {
exported_df <- exported_df |> exported_df <- exported_df |>
mutate( dplyr::mutate(
!!dplyr::sym(mhcs()$get_main_key_id) := values$main_key, !!dplyr::sym(mhcs()$get_main_key_id) := values$main_key,
!!dplyr::sym(nested_key_id) := values$nested_key, !!dplyr::sym(nested_key_id) := values$nested_key,
.before = 1 .before = 1
@@ -471,7 +474,7 @@ server <- function(input, output, session) {
# если ключ в формате даты - дать человекочитаемые данные # если ключ в формате даты - дать человекочитаемые данные
if (this_nested_form_key_scheme_smoll$form_type == "date") { 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, kyes_for_this_table,
format(as.Date(kyes_for_this_table), "%d.%m.%Y") format(as.Date(kyes_for_this_table), "%d.%m.%Y")
) )
@@ -557,12 +560,12 @@ server <- function(input, output, session) {
str_cols <- which(col_types$form_type != "date") str_cols <- which(col_types$form_type != "date")
values$data <- values$data |> values$data <- values$data |>
select(-mhcs()$get_main_key_id) |> dplyr::select(-mhcs()$get_main_key_id) |>
mutate( dplyr::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), dplyr::across(tidyselect::all_of({{str_cols}}), as.character),
) |> ) |>
arrange({{key_id}}) dplyr::arrange({{key_id}})
output$dt_nested <- DT::renderDataTable( output$dt_nested <- DT::renderDataTable(
DT::datatable( DT::datatable(
@@ -706,10 +709,10 @@ server <- function(input, output, session) {
# загрузка данных в формы # загрузка данных в формы
forms$load_data_to_form( forms$load_data_to_form(
df = df, df = df,
table_name = values$nested_form_id, table_name = values$nested_form_id,
mhcs = mhcs, mhcs = mhcs,
ns = NS(values$nested_form_id) ns = NS(values$nested_form_id)
) )
} else { } else {
@@ -728,7 +731,7 @@ server <- function(input, output, session) {
ui1 <- rlang::exec( ui1 <- rlang::exec(
.fn = utils$render_forms, .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 main_scheme = scheme_for_key_input
) )
@@ -780,7 +783,7 @@ server <- function(input, output, session) {
need(values$main_key, "⚠️ Необходимо указать id пациента!") need(values$main_key, "⚠️ Необходимо указать id пациента!")
) )
span( span(
strong("Таблица: "), names(enabled_schemes)[enabled_schemes == scheme()], strong("Таблица: "), names(ENABLED_SCHEMES)[ENABLED_SCHEMES == scheme()],
br(), br(),
strong("ID: "), values$main_key strong("ID: "), values$main_key
) )
@@ -812,7 +815,7 @@ server <- function(input, output, session) {
# создать форму для выбора ключа # создать форму для выбора ключа
ui1 <- rlang::exec( ui1 <- rlang::exec(
.fn = utils$render_forms, .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 main_scheme = scheme_for_key_input
) )
@@ -909,7 +912,7 @@ server <- function(input, output, session) {
con <- db$make_db_connection(scheme(),"load_data_button") con <- db$make_db_connection(scheme(),"load_data_button")
on.exit(db$close_db_connection(con, "load_data_button")) on.exit(db$close_db_connection(con, "load_data_button"))
if (length(dbListTables(con)) != 0 && "main" %in% DBI::dbListTables(con)) { if (length(DBI::dbListTables(con)) != 0 && "main" %in% DBI::dbListTables(con)) {
# GET DATA files # GET DATA files
ids <- db$get_keys_from_table("main", mhcs(), con) ids <- db$get_keys_from_table("main", mhcs(), con)
@@ -921,7 +924,7 @@ server <- function(input, output, session) {
choices = ids, choices = ids,
selected = NULL, selected = NULL,
options = list( options = list(
placeholder = "id пациента", placeholder = "id",
onInitialize = I('function() { this.setValue(""); }') onInitialize = I('function() { this.setValue(""); }')
) )
) )
@@ -1041,7 +1044,7 @@ server <- function(input, output, session) {
list_of_df[["meta"]] <- dplyr::tribble( list_of_df[["meta"]] <- dplyr::tribble(
~`Параметр` , ~`Значение`, ~`Параметр` , ~`Значение`,
"Пользователь" , values$current_user, "Пользователь" , values$current_user,
"Название базы" , names(enabled_schemes)[enabled_schemes == scheme()], "Название базы" , names(ENABLED_SCHEMES)[ENABLED_SCHEMES == scheme()],
"id базы" , scheme(), "id базы" , scheme(),
"id формы" , config::get("form_id"), "id формы" , config::get("form_id"),
"ver формы" , config::get("form_app_version"), "ver формы" , config::get("form_app_version"),
@@ -1149,7 +1152,7 @@ server <- function(input, output, session) {
# write vector to temp .Rmd file # write vector to temp .Rmd file
writeLines(empty_vec, temp_report, sep = "\n") writeLines(empty_vec, temp_report, sep = "\n")
# copy template .docx file # 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 # render file via pandoc
rmarkdown::render( rmarkdown::render(
@@ -1261,10 +1264,10 @@ server <- function(input, output, session) {
dplyr::across(tidyselect::all_of({{number_columns}}), num_converter), dplyr::across(tidyselect::all_of({{number_columns}}), num_converter),
dplyr::across(tidyselect::all_of({{other_cols}}), \(x) dplyr::if_else(x == "", as.character(NA), as.character(x))) 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) |> df_original <- DBI::dbReadTable(con, table_name) |>
as_tibble() dplyr::as_tibble()
if (input$upload_data_from_xlsx_owerwrite_all_data == TRUE) { if (input$upload_data_from_xlsx_owerwrite_all_data == TRUE) {
@@ -1273,15 +1276,24 @@ server <- function(input, output, session) {
} else { } else {
# удаление данных в базе данных по ключам # удаление данных в базе данных по ключам
walk( # purrr::walk(
.x = unique(df[[main_key_id]]), # .x = unique(df[[main_key_id]]),
.f = \(main_key) { # .f = \(main_key) {
if (main_key %in% unique(df_original[[main_key_id]])) { # 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}'")) # 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})"))
} }
@@ -1319,7 +1331,7 @@ server <- function(input, output, session) {
read_df_from_db_all <- function(table_name, con) { read_df_from_db_all <- function(table_name, con) {
# check if this table exist # check if this table exist
if (table_name %in% dbListTables(con)) { if (table_name %in% DBI::dbListTables(con)) {
# prepare query # prepare query
query <- glue::glue(" query <- glue::glue("
SELECT * FROM {table_name} SELECT * FROM {table_name}
@@ -1338,6 +1350,7 @@ server <- function(input, output, session) {
"loading data", "loading data",
"creating new key", "creating new key",
"exporting data to xlsx", "exporting data to xlsx",
"export validation dataset",
"importing data from xlsx" "importing data from xlsx"
), ),
key = NA, key = NA,
@@ -1346,7 +1359,7 @@ server <- function(input, output, session) {
action <- match.arg(action) action <- match.arg(action)
action_row <- tibble( action_row <- dplyr::tibble(
date = Sys.time(), date = Sys.time(),
user = values$current_user, user = values$current_user,
app_id = config::get("form_id"), app_id = config::get("form_id"),
@@ -1365,6 +1378,52 @@ server <- function(input, output, session) {
# SHOW LOGS ----------------------------------- # SHOW LOGS -----------------------------------
logs$server("logs", values, scheme, mhcs) 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 <- shiny::shinyApp(ui = ui, server = server)

5
appinfo.json Normal file
View File

@@ -0,0 +1,5 @@
{
"app_id": "formy",
"app_title": "FORMY",
"formy_version": "0.18.4"
}

10
config/config_example.yml Normal file
View File

@@ -0,0 +1,10 @@
default:
form_app_version: !expr jsonlite::read_json("appinfo.json")$formy_version
form_id: !expr jsonlite::read_json("appinfo.json")$app_id
form_name: !expr jsonlite::read_json("appinfo.json")$app_title
prod:
form_app_configure_path: "example_scheme"
form_auth_enabled: false
form_schemes:
example_of_scheme: Тестовая база данных

View File

@@ -1,10 +0,0 @@
default:
form_app_version: !expr config::get("form_app_version", file = "descr.yml")
form_id: !expr config::get("form_id", file = "descr.yml")
form_name: !expr config::get("form_name", file = "descr.yml")
prod:
form_app_configure_path: "example_scheme"
form_auth_enabled: false
form_schemes:
example_of_scheme: Тестовая база данных

View File

@@ -1,4 +0,0 @@
default:
form_app_version: 0.18.1
form_id: formy
form_name: FORMY

View File

@@ -1,6 +1,6 @@
{ {
"R": { "R": {
"Version": "4.3.2", "Version": "4.3.3",
"Repositories": [ "Repositories": [
{ {
"Name": "CRAN", "Name": "CRAN",

Binary file not shown.

Before

Width:  |  Height:  |  Size: 295 KiB

After

Width:  |  Height:  |  Size: 2.1 KiB

10
www/styles.css Normal file
View File

@@ -0,0 +1,10 @@
.description-header {
/* 1. Add the border around the whole box */
border-bottom: 2px solid #777777;
/* 2. Forces border inside the total width/height (prevents breaking layouts) */
box-sizing: border-box;
/* 3. Ensures the div encloses any internal floated elements */
overflow: auto;
}