diff --git a/app.R b/app.R
index bd3b55e..d4bc5d7 100644
--- a/app.R
+++ b/app.R
@@ -16,42 +16,41 @@ box::use(
modules/global_options,
modules/db,
modules/data_validation,
- modules/scheme_generator[scheme_R6]
+ app/forms,
+ app/tasks
)
+# global settings:
global_options$set_global_options(
- shiny.host = "0.0.0.0"
+ shiny.host = "0.0.0.0",
+ APP.DEBUG = FALSE
)
+# init:
global_options$check_and_init_scheme()
-# global vars
+# global vars:
box::use(
modules/global_options[AUTH_ENABLED]
)
+enabled_schemes <- unlist(config::get()$form_schemes)
+enabled_schemes <- setNames(names(enabled_schemes), enabled_schemes)
-# SETTINGS ================================
-HEADER_TEXT <- config::get("form_name")
+# load schemes object:
+schms <- readRDS("scheme.rds")
-# sadasdasdasdasdas
-options(box.path = config::get("form_app_configure_path"))
-box::use(configs/enabled_schemes[enabled_schemes])
-
-# CHECK FOR PANDOC
-# TEMP ! NEED TO HANDLE
+# CHECK FOR PANDOC ----------
rmarkdown::find_pandoc(dir = "/opt/homebrew/bin/")
# TODO: dynamic button render depend on pandoc installation
if (!rmarkdown::pandoc_available()) warning("Can't find pandoc!")
-# SCHEME_MAIN UNPACK ==========================
-schms <- readRDS("scheme.rds")
# UI =======================
ui <- page_sidebar(
- # title = HEADER_TEXT,
+ # title = config::get("form_name"),
title = tagList(
- h4(HEADER_TEXT, style = "margin-top: .5rem"),
+ h4(config::get("form_name"), style = "margin-top: .5rem"),
popover(
span(
config::get("form_app_version"),
@@ -59,7 +58,7 @@ ui <- page_sidebar(
style = "color: #9c9c9c"),
title = "about",
placement = "left",
- p("a"), p("b")
+ tagList(span("здесь пока ничего нет"), br(), span("вот"))
)
),
theme = bs_theme(version = 5, preset = "bootstrap"),
@@ -72,6 +71,7 @@ ui <- page_sidebar(
uiOutput("status_message"),
textOutput("status_message2"),
uiOutput("display_log"),
+ actionButton("tasks-display_task_modal", "Задачи: нет активных", icon("list-check")),
position = "left",
open = list(mobile = "always")
),
@@ -80,12 +80,13 @@ ui <- page_sidebar(
# init auth =======================
if (AUTH_ENABLED) {
+
# shinymanager::set_labels("en", "Please authenticate" = "scheme()")
ui <- ui |>
shinymanager::secure_app(
status = "primary",
tags_top = tags$div(
- tags$h3(HEADER_TEXT, style = "align:center"),
+ tags$h3(config::get("form_name"), style = "align:center"),
# tags$img(
# src = "https://www.r-project.org/logo/Rlogo.png", width = 100
# )
@@ -131,13 +132,14 @@ server <- function(input, output, session) {
if (AUTH_ENABLED) {
reactiveValuesToList(res_auth)
if (res_auth$admin) {
- # print("admin")
} else {
- # print("not_admin")
showing_buttons <- FALSE
}
}
+ # update user name
+ values$current_user <- ifelse(AUTH_ENABLED, res_auth$user, "anonymous")
+
if (showing_buttons) {
tagList(
br(),
@@ -151,13 +153,19 @@ server <- function(input, output, session) {
}
})
+ # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# REACTIVE VALUES =================================
+ # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
# 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
+ nested_form_id = NULL,
+ tasks_id = NULL,
+ current_user = NULL
)
scheme <- reactiveVal(enabled_schemes[1]) # наименование выбранной схемы
@@ -169,20 +177,29 @@ server <- function(input, output, session) {
validator_nested <- reactiveVal(NULL)
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- # ГЛАВНАЯ СТРАНИЦА ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ # reactive ui -------------------------------
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ ## reactive ui -----------------------------------
+ ### main screen ------
output$main_ui_navset <- renderUI({
if (main_form_is_empty()) {
validator_main(NULL)
div(
+ h5("Выбрать базу данных для работы:"),
shiny::radioButtons(
"schmes_selector",
- label = strong("Выбрать базу данных для работы:"),
+ label = NULL,
choices = enabled_schemes,
selected = scheme()
),
+ hr(),
+ uiOutput("base_data"),
+ hr(),
"Для начала работы нужно создать новую запись или загрузить существующую!",
+ hr(),
+ # сво
# загрузка панели для работы с базой данных
uiOutput("admin_buttons_panel")
)
@@ -192,52 +209,70 @@ server <- function(input, output, session) {
validator_main(data_validation$init_val(mhcs()$get_scheme("main")))
validator_main()$enable()
mhcs()$get_main_form_ui
+
}
})
+ ### bases info ----------------
+ observeEvent(main_form_is_empty(), {
+
+ output$base_data <- renderUI({
+
+ if (main_form_is_empty() == TRUE) {
+ con <- db$make_db_connection(scheme(),"base_data")
+ on.exit(db$close_db_connection(con, "base_data"), add = TRUE)
+
+ tasks$update_task_button_count(con, values, NS("tasks"))
+
+ # записей в базе всего
+ records_count <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT ({mhcs()$get_main_key_id}) FROM main")) |>
+ dplyr::pull()
+
+ # задачи на сегодня
+ if ("tasks" %in% DBI::dbListTables(con)) {
+
+ 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())}")) |>
+ 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())}")) |>
+ dplyr::pull()
+
+ } else {
+
+ tasks_count <- 0
+ tasks_today_count <- 0
+ tasks_overdue_count <- 0
+
+ }
+
+ div(
+ h5("Общая информация о базе данных:"),
+ strong("Записей всего:"), records_count,
+ hr(),
+ h5("Задачи:"),
+ span(strong("Активных всего:"), if (tasks_count > 0) actionLink("tasks-show_dt_all", tasks_count) else "0", br()),
+ span(strong("Активных на сегодня:"), if (tasks_today_count > 0) actionLink("tasks-show_dt_today", tasks_today_count) else "0", br()),
+ span(strong("Просроченных:"), if (tasks_overdue_count > 0) actionLink("tasks-show_dt_overdue", tasks_overdue_count) else "0", br())
+ )
+ }
+ })
+ })
+
+ # обновление данных схем ------
observeEvent(input$schmes_selector, {
+
scheme(input$schmes_selector)
mhcs(schms[[input$schmes_selector]])
+
})
# ==========================================
# ОБЩИЕ ФУНКЦИИ ============================
# ==========================================
- ## перенос данных из датафрейма в форму -----------------------
- load_data_to_form <- function(
- df,
- table_name = "main",
- schm,
- ns
- ) {
-
- input_types <- unname(mhcs()$get_id_type_list(table_name))
- input_ids <- names(mhcs()$get_id_type_list(table_name))
- if (missing(ns)) ns <- NULL
-
- # transform df to list
- # loaded_df_for_id <- as.list(df)
- # loaded_df_for_id <- df[input_ids]
-
- # rewrite input forms
- purrr::walk2(
- .x = input_types,
- .y = input_ids,
- .f = \(x_type, x_id) {
-
- # updating forms with loaded data
- utils$update_forms_with_data(
- form_id = x_id,
- form_type = x_type,
- value = df[[x_id]],
- scheme = mhcs()$get_scheme(table_name),
- ns = ns
- )
- }
- )
- }
-
## сохранение данных из форм в базу данных --------
save_inputs_to_db <- function(
table_name,
@@ -314,6 +349,7 @@ server <- function(input, output, session) {
# ====================================
# NESTED FORMS =======================
# ====================================
+
## кнопки для каждой вложенной таблицы -------------------------------
observe({
@@ -343,6 +379,7 @@ server <- function(input, output, session) {
observers_started(c(
isolate(observers_started()), isolate(scheme())
))
+
})
## функция отображения вложенной формы для выбранной таблицы --------
@@ -382,6 +419,7 @@ server <- function(input, output, session) {
# nested ui
nested_form_panels <- if (!is.null(values$nested_key)) {
+
purrr::map(
.x = unique(this_nested_form_scheme$subgroup),
.f = \(subgroup) {
@@ -402,7 +440,9 @@ server <- function(input, output, session) {
}
)
} else {
+
list(bslib::nav_panel("", div("Нет доступных записей.", br(), "Необходимо создать новую запись.")))
+
}
# ui для всплывающего окна
@@ -467,7 +507,7 @@ server <- function(input, output, session) {
output$dt_nested <- DT::renderDataTable(
DT::datatable(
values$data,
- caption = 'Table 1: This is a simple caption for the table.',
+ caption = 'В данной таблице можно изменять данные',
rownames = FALSE,
colnames = col_types |> dplyr::pull(form_id, form_label),
extensions = c('KeyTable', "FixedColumns"),
@@ -488,7 +528,7 @@ server <- function(input, output, session) {
DT::dataTableOutput("dt_nested"),
size = "xl",
footer = tagList(
- actionButton("nested_form_dt_save", "сохранить изменения")
+ actionButton("nested_form_dt_save", "Сохранить изменения", icon("floppy-disk"))
),
easyClose = TRUE
))
@@ -502,8 +542,9 @@ server <- function(input, output, session) {
### кнопка: отображение DT -----------------------------
observeEvent(input$nested_form_dt_button, {
- con <- db$make_db_connection(scheme(),"nested_form_save_button")
- on.exit(db$close_db_connection(con, "nested_form_save_button"), add = TRUE)
+
+ con <- db$make_db_connection(scheme(),"nested_form_dt_button")
+ on.exit(db$close_db_connection(con, "nested_form_dt_button"), add = TRUE)
removeModal()
show_modal_for_nested_form_dt(con)
@@ -587,8 +628,8 @@ server <- function(input, output, session) {
observeEvent(values$nested_key, {
- con <- db$make_db_connection(scheme(),"nested_tables")
- on.exit(db$close_db_connection(con, "nested_tables"), add = TRUE)
+ con <- db$make_db_connection(scheme(),"nested_key")
+ on.exit(db$close_db_connection(con, "nested_key"), add = TRUE)
kyes_for_this_table <- db$get_nested_keys_from_table(values$nested_form_id, mhcs(), values$main_key, con)
@@ -604,10 +645,10 @@ server <- function(input, output, session) {
)
# загрузка данных в формы
- load_data_to_form(
+ forms$load_data_to_form(
df = df,
table_name = values$nested_form_id,
- mhcs(),
+ mhcs = mhcs,
ns = NS(values$nested_form_id)
)
} else {
@@ -645,8 +686,8 @@ server <- function(input, output, session) {
observeEvent(input$confirm_create_new_nested_key, {
req(input[[mhcs()$get_key_id(values$nested_form_id)]])
- con <- db$make_db_connection(scheme(),"confirm_create_new_key")
- on.exit(db$close_db_connection(con, "confirm_create_new_key"), add = TRUE)
+ con <- db$make_db_connection(scheme(),"confirm_create_new_nested_key")
+ on.exit(db$close_db_connection(con, "confirm_create_new_nested_key"), add = TRUE)
existed_key <- db$get_nested_keys_from_table(
table_name = values$nested_form_id,
@@ -697,7 +738,9 @@ server <- function(input, output, session) {
# =========================================
# MAIN BUTTONS LOGIC ======================
# =========================================
+
## добавить новый главный ключ ------------------------
+ ### modal -------
observeEvent(input$add_new_main_key_button, {
# данные для главного ключа
@@ -723,7 +766,7 @@ server <- function(input, output, session) {
})
- ## действие при подтверждении (проверка нового создаваемого ключа) -------
+ ### подтверждение(проверка нового создаваемого ключа) -------
observeEvent(input$confirm_create_new_main_key, {
req(input[[mhcs()$get_main_key_id]])
@@ -731,7 +774,6 @@ server <- function(input, output, session) {
on.exit(db$close_db_connection(con, "confirm_create_new_key"), add = TRUE)
new_main_key <- trimws(input[[mhcs()$get_main_key_id]])
-
existed_key <- db$get_keys_from_table("main", mhcs(), con)
# если введенный ключ уже есть в базе
@@ -742,17 +784,14 @@ server <- function(input, output, session) {
)
return()
}
-
- values$main_key <- new_main_key
- main_form_is_empty(FALSE)
- log_action_to_db("creating new key", values$main_key, con)
- utils$clean_forms("main", mhcs())
+ values$main_key <- new_main_key
+ log_action_to_db("creating new key", values$main_key, con)
removeModal()
})
- ## очистка всех полей -----------------------
- # show modal on click of button
+ ## переход на главный акран -----------------------
+ ### show modal -------
observeEvent(input$clean_data_button, {
showModal(modalDialog(
"Данное действие очистит все заполненные данные. Убедитесь, что нужные данные сохранены.",
@@ -765,7 +804,7 @@ server <- function(input, output, session) {
))
})
- # when action confirm - perform action
+ ### when action confirm - perform action ---
observeEvent(input$clean_all_action, {
# rewrite all inputs with empty data
@@ -775,6 +814,7 @@ server <- function(input, output, session) {
removeModal()
showNotification("Данные очищены!", type = "warning")
+
})
## сохранение даннных -------------------------------
@@ -797,7 +837,8 @@ server <- function(input, output, session) {
)
})
- ## список ключей для загрузки данных -------------------
+ ## загрузка данных -------------------
+ ### modal with keys -----
observeEvent(input$load_data_button, {
con <- db$make_db_connection(scheme(),"load_data_button")
@@ -840,30 +881,51 @@ server <- function(input, output, session) {
)
})
- ## загрузка данных по главному ключу ------------------
+ ### confirm ------------------
observeEvent(input$load_data, {
req(input$load_data_key_selector)
+ values$main_key <- input$load_data_key_selector
+
+ })
+
+ ## логика: смена ключа -------
+ observeEvent(values$main_key, {
+
con <- db$make_db_connection(scheme(),"load_data")
on.exit(db$close_db_connection(con, "load_data"), add = TRUE)
- df <- db$read_df_from_db_by_id(
- table_name = "main",
- schm = mhcs(),
- main_key_value = input$load_data_key_selector,
- con = con
- )
+ if (!is.null(values$main_key)) {
+ existed_main_keys <- db$get_keys_from_table("main", mhcs(), con)
- load_data_to_form(
- df = df,
- table_name = "main",
- mhcs()
- )
-
- values$main_key <- input$load_data_key_selector
- main_form_is_empty(FALSE)
+ if (values$main_key %in% existed_main_keys) {
- log_action_to_db("loading data", values$main_key, con = con)
+ df <- db$read_df_from_db_by_id(
+ table_name = "main",
+ schm = mhcs(),
+ main_key_value = values$main_key,
+ con = con
+ )
+
+ forms$load_data_to_form(
+ df = df,
+ table_name = "main",
+ mhcs
+ )
+
+ log_action_to_db("loading data", values$main_key, con = con)
+
+ } else {
+
+ utils$clean_forms("main", mhcs())
+
+ }
+
+ main_form_is_empty(FALSE)
+
+ }
+
+ tasks$update_task_button_count(con, values, NS("tasks"))
removeModal()
})
@@ -911,7 +973,7 @@ server <- function(input, output, session) {
# добавить мета информацию
list_of_df[["meta"]] <- dplyr::tribble(
~`Параметр` , ~`Значение`,
- "Пользователь" , ifelse(AUTH_ENABLED, res_auth$user, "anonymous"),
+ "Пользователь" , values$current_user,
"Название базы" , names(enabled_schemes)[enabled_schemes == scheme()],
"id базы" , scheme(),
"id формы" , config::get("form_id"),
@@ -1032,6 +1094,7 @@ server <- function(input, output, session) {
)
## import data from xlsx ----------------------
+ ### modal -----
observeEvent(input$button_upload_data_from_xlsx, {
showModal(modalDialog(
@@ -1055,6 +1118,7 @@ server <- function(input, output, session) {
})
+ ### confirm --------
observeEvent(input$button_upload_data_from_xlsx_confirm, {
req(input$upload_xlsx)
@@ -1163,13 +1227,15 @@ server <- function(input, output, session) {
append = TRUE
)
- message <- glue::glue("Данные таблицы '{table_name}' успешно обновлены (добавлено {nrow(df)} записей)")
+ message <- glue::glue("Данные таблицы '{table_name}' успешно загружены (добавлено {nrow(df)} записей)")
showNotification(
message,
type = "message"
)
cli::cli_alert_success(message)
}
+
+ db$db_clean_orphans(mhcs(), con)
log_action_to_db("importing data from xlsx", con = con)
removeModal()
})
@@ -1213,7 +1279,7 @@ server <- function(input, output, session) {
action_row <- tibble(
date = Sys.time(),
- user = ifelse(AUTH_ENABLED, res_auth$user, "anonymous"),
+ user = values$current_user,
app_id = config::get("form_id"),
app_ver = config::get("form_app_version"),
remote_addr = session$request$REMOTE_ADDR,
@@ -1224,58 +1290,9 @@ server <- function(input, output, session) {
DBI::dbWriteTable(con, "log", action_row, append = TRUE)
}
- # КРАТКАЯ СВОДКА ПРО ЛОГГИНГ ------------------
- # observe({
+ # TASKS ---------------------------------------
+ tasks$server("tasks", values, scheme, mhcs)
- # output$display_log <- renderUI({
-
- # con <- db$make_db_connection(scheme(),"display_log")
- # on.exit(db$close_db_connection(con, "display_log"), add = TRUE)
-
- # query <- if (!is.null(values$main_key)) {
- # sprintf("SELECT * FROM log WHERE key = '%s'", values$main_key)
- # } else {
- # "SELECT * FROM log"
- # }
-
- # log_rows <- DBI::dbGetQuery(con, query)
-
- # if (nrow(log_rows) > 0) {
-
- # lines <- log_rows |>
- # mutate(date = as.POSIXct(date)) |>
- # mutate(
- # # date = date + lubridate::hours(3), # fix datetime
- # date_day = as.Date(date)
- # ) |>
- # mutate(cons_actions = dplyr::consecutive_id(action, user)) |>
- # mutate(n_actions = row_number(), .by = c(cons_actions, user, action, date_day)) |>
- # slice(which.max(n_actions), .by = c(user, action, date_day)) |>
- # mutate(string_to_print = sprintf(
- # "[%s %s]: %s - %s (%s)",
- # format(date, "%d.%m.%y"),
- # format(date, "%H:%M"),
- # user,
- # action,
- # n_actions
- # )) |>
- # pull(string_to_print) |>
- # paste(collapse = "")
-
- # } else {
- # lines <- ""
- # }
-
- # tagList(
- # paste0("ID: ", values$main_key),
- # br(),
- # p(
- # HTML(lines),
- # style = "font-size:10px;"
- # )
- # )
- # })
- # })
}
diff --git a/app/forms.R b/app/forms.R
new file mode 100644
index 0000000..406efc3
--- /dev/null
+++ b/app/forms.R
@@ -0,0 +1,34 @@
+options(box.path = here::here())
+box::use(
+ modules/utils,
+)
+
+#' @export
+load_data_to_form <- function(
+ df,
+ table_name = "main",
+ mhcs,
+ ns
+) {
+
+ input_types <- unname(mhcs()$get_id_type_list(table_name))
+ input_ids <- names(mhcs()$get_id_type_list(table_name))
+ if (missing(ns)) ns <- NULL
+
+ # rewrite input forms
+ purrr::walk2(
+ .x = input_types,
+ .y = input_ids,
+ .f = \(x_type, x_id) {
+
+ # updating forms with loaded data
+ utils$update_forms_with_data(
+ form_id = x_id,
+ form_type = x_type,
+ value = df[[x_id]],
+ scheme = mhcs()$get_scheme(table_name),
+ ns = ns
+ )
+ }
+ )
+}
\ No newline at end of file
diff --git a/app/tasks.R b/app/tasks.R
new file mode 100644
index 0000000..4493808
--- /dev/null
+++ b/app/tasks.R
@@ -0,0 +1,466 @@
+
+box::use(
+ shiny[...],
+ bslib[...]
+)
+
+options(box.path = here::here())
+box::use(
+ modules/db,
+ modules/utils,
+ app/forms
+)
+
+#' @export
+server <- function(id, values, scheme, mhcs) {
+
+ ns <- NS(id)
+
+ moduleServer(id, function(input, output, session) {
+
+ # BOOKMARKS SETUP ========================
+ # observe({
+ # # print(values$current_user)
+ # })
+
+ # functions -------------------
+ ## new tasks ----------------
+ get_default_task <- function() {
+
+ tibble::tibble(
+ task_id = paste0(format(Sys.time(), "%Y%m%d%H%M%S"), "_", values$main_key),
+ task_main_key = values$main_key,
+ task_status = "active",
+ task_title = "НОВАЯ ЗАДАЧА",
+ task_description = "",
+ task_due_date = NA,
+ task_user_created = values$current_user,
+ task_datetime_created = Sys.time(),
+ task_user_last_updated = NA,
+ task_datetime_last_updated = NA,
+ task_user_completed = NA,
+ task_datetime_completed = NA
+ )
+ }
+
+ # logic ---------------------
+ ## modal fun -----
+ show_modal_for_tasks <- function() {
+
+ if (!is.null(values$tasks_data)) {
+
+ tasks_selector <- values$tasks_data |>
+ dplyr::filter(task_status != "completed") |>
+ dplyr::pull(task_id)
+
+ tasks_selector <- unique(c(values$tasks_id, tasks_selector))
+ tasks_selector <- sort(tasks_selector)
+
+ if (length(values$tasks_id) == 0) {
+ values$tasks_id <- if (length(tasks_selector) == 0) NULL else tasks_selector[[1]]
+ }
+
+ } else {
+
+ tasks_selector <- NULL
+
+ }
+
+ # ui --------------------
+ # очень большой костыль
+ subroup_scheme <- mhcs()$get_scheme("tasks") |>
+ dplyr::filter(form_id != "dummy")
+
+ tab <- if (length(tasks_selector) > 0) {
+ bslib::nav_panel(
+ title = "no name provided",
+ purrr::pmap(
+ .l = dplyr::distinct(subroup_scheme, form_id, form_label, form_type),
+ .f = utils$render_forms,
+ main_scheme = subroup_scheme,
+ ns = ns
+ )
+ )
+ } else {
+ bslib::nav_panel("", div("Нет доступных записей.", br(), "Необходимо создать новую запись."))
+ }
+
+ ui <- layout_sidebar(
+ sidebar = tagList(
+ selectizeInput(ns("tasks_id_selector"), label = "ID задачи:", choices = tasks_selector, selected = values$tasks_id),
+ actionButton(ns("tasks_create_new_task"), "Новая задача", icon("plus")),
+ actionButton(ns("tasks_add_autoreview"), "Новая авто-задача (тест)", icon("calendar")),
+ actionButton(ns("tasks_DT_VIEW"), "DT", icon("table"))
+ ),
+ tab
+ )
+
+ showModal(modalDialog(
+ ui,
+ size = "l",
+ footer = tagList(
+ actionButton(ns("tasks_saving_button"), "Сохранить изменения", icon("floppy-disk"))
+ ),
+ easyClose = TRUE
+ ))
+ }
+
+ ## отображение окна -----------------
+ observeEvent(input$display_task_modal, {
+
+ if (is.null(values$main_key)) {
+ showNotification("необходимо выбрать запись", type = "error")
+ return()
+ }
+
+ con <- db$make_db_connection(scheme(),"display_task_modal")
+ 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
+ show_modal_for_tasks()
+
+ })
+
+ ## изменение выбранной задачи -------
+ observeEvent(input$tasks_id_selector, {
+ req(input$tasks_id_selector)
+ req(values$tasks_id)
+
+ # выбранный ключ в форме - перемещаем в RV
+ values$tasks_id <- input$tasks_id_selector
+
+ })
+
+ ## обновление формы при измененнии id ключа ------
+ observeEvent(values$tasks_id, {
+
+ df <- values$tasks_data |>
+ dplyr::filter(task_id == values$tasks_id)
+
+ forms$load_data_to_form(
+ df = df,
+ table_name = "tasks",
+ mhcs
+ # ns = ns
+ )
+ })
+
+ ## saving button ------------------------------
+ observeEvent(input$tasks_saving_button, {
+
+ con <- db$make_db_connection(scheme(),"tasks_saving_button")
+ on.exit(db$close_db_connection(con, "tasks_saving_button"), add = TRUE)
+
+ id_and_types_list <- mhcs()$get_id_type_list("tasks")
+ input_types <- unname(id_and_types_list)
+ input_ids <- names(id_and_types_list)
+
+ exported_values <- purrr::map2(
+ .x = input_ids,
+ .y = input_types,
+ .f = \(x_id, x_type) {
+
+ input_d <- input[[x_id]]
+
+ # return empty if 0 element
+ if (length(input_d) == 0) {
+ return(utils$get_empty_data(x_type))
+ } else {
+ input_d
+ }
+ }
+ )
+
+ exported_df <- stats::setNames(exported_values, input_ids) |>
+ dplyr::as_tibble()
+
+ df <- values$tasks_data
+
+ df[df$task_id == values$tasks_id,]$task_status <- exported_df$task_status
+ df[df$task_id == values$tasks_id,]$task_title <- exported_df$task_title
+ df[df$task_id == values$tasks_id,]$task_description <- exported_df$task_description
+ df[df$task_id == values$tasks_id,]$task_due_date <- exported_df$task_due_date
+ df[df$task_id == values$tasks_id,]$task_user_last_updated <- values$current_user
+ df[df$task_id == values$tasks_id,]$task_datetime_last_updated <- Sys.time()
+
+ if (exported_df$task_status == "completed") {
+ df[df$task_id == values$tasks_id,]$task_user_completed <- values$current_user
+ df[df$task_id == values$tasks_id,]$task_datetime_completed <- Sys.time()
+ }
+
+ values$tasks_data <- df
+
+ if ("tasks" %in% DBI::dbListTables(con)) {
+ query <- glue::glue("
+ DELETE
+ FROM tasks
+ WHERE task_main_key = '{values$main_key}'
+ ")
+ DBI::dbExecute(con, query)
+ }
+
+ DBI::dbWriteTable(con, "tasks", df, append = TRUE)
+
+ update_task_button_count(con, values)
+ showNotification("Задача успешно создана/обновлена", type = "message")
+
+ tasks_selector <- values$tasks_data |>
+ dplyr::filter(task_status != "completed") |>
+ dplyr::pull(task_id)
+
+ selector <- ifelse(!values$tasks_id %in% tasks_selector, tasks_selector[1], values$tasks_id)
+
+ updateSelectInput(inputId = "tasks_id_selector", choices = tasks_selector, selected = selector)
+
+ })
+
+ ## show DT --------------------------
+ observeEvent(input$tasks_DT_VIEW, {
+
+ rename_cols <- tasks_colnames[tasks_colnames %in% colnames(values$tasks_data)]
+
+ date_cols <- c("task_datetime_created", "task_datetime_completed", "task_datetime_last_updated", "task_due_date")
+ date_cols <- which(colnames(values$tasks_data) %in% date_cols)
+
+ output$dt_tasks <- DT::renderDataTable(
+ DT::datatable(
+ values$tasks_data,
+ caption = 'Table 1: This is a simple caption for the table.',
+ rownames = FALSE,
+ colnames = rename_cols,
+ extensions = c('KeyTable', "FixedColumns"),
+ # editable = 'cell',
+ class = 'cell-border stripe',
+ selection = "none",
+ options = list(
+ dom = 'tip',
+ scrollX = TRUE,
+ fixedColumns = list(leftColumns = 1),
+ keys = TRUE,
+ autoWidth = TRUE,
+ columnDefs = list(
+ list(
+ targets = 3:4,
+ width = '200px',
+ render = htmlwidgets::JS(
+ "function(data, type, row, meta) {",
+ "return type === 'display' && data.length > 20 ?",
+ "'' + data.substr(0, 20) + '...' : data;",
+ "}")
+ )
+ )
+ )
+ ) |>
+ DT::formatDate(date_cols, "toLocaleDateString", params = list('ru-RU'))
+ )
+
+ showModal(modalDialog(
+ DT::dataTableOutput(ns("dt_tasks")),
+ size = "xl",
+ # footer = tagList(
+ # actionButton("nested_form_dt_save", "сохранить изменения")
+ # ),
+ easyClose = TRUE
+ ))
+
+ })
+
+ ## создание новой задачи -------------
+ observeEvent(input$tasks_create_new_task, {
+ new_task <- get_default_task()
+
+ values$tasks_data <- rbind(values$tasks_data, new_task)
+ values$tasks_id <- new_task$task_id
+
+ tasks_selector <- values$tasks_data |>
+ dplyr::filter(task_status != "completed") |>
+ dplyr::pull(task_id)
+
+ updateSelectInput(inputId = "tasks_id_selector", choices = tasks_selector, selected = values$tasks_id)
+ removeModal()
+ show_modal_for_tasks()
+ })
+
+ ## создание новой авто-задачи -------------
+ observeEvent(input$tasks_add_autoreview, {
+ new_task <- get_default_task()
+
+ new_task$task_title <- "autoreview"
+ new_task$task_description <- "напоминание об актуализации данных"
+ new_task$task_due_date <- Sys.Date() + 28
+
+ values$tasks_data <- rbind(values$tasks_data, new_task)
+ values$tasks_id <- new_task$task_id
+
+ tasks_selector <- values$tasks_data |>
+ dplyr::filter(task_status != "completed") |>
+ dplyr::pull(task_id)
+
+ updateSelectInput(inputId = "tasks_id_selector", choices = tasks_selector, selected = values$tasks_id)
+ removeModal()
+ show_modal_for_tasks()
+ })
+
+ # review задач ----------------
+ ### все активные задачи ------------
+ observeEvent(input$show_dt_all, {
+
+ con <- db$make_db_connection(scheme(),"display_task_modal")
+ on.exit(db$close_db_connection(con, "display_task_modal"), add = TRUE)
+
+ values$tasks_data <- DBI::dbGetQuery(con, glue::glue("SELECT * FROM tasks WHERE task_status = 'active'")) |>
+ 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))
+
+ display_tasks_dt_review()
+ })
+
+ ### задачи для текущего дня ------------
+ observeEvent(input$show_dt_today, {
+
+ con <- db$make_db_connection(scheme(),"display_task_modal")
+ on.exit(db$close_db_connection(con, "display_task_modal"), add = TRUE)
+
+ values$tasks_data <- DBI::dbGetQuery(con, glue::glue("SELECT * FROM tasks WHERE task_status = 'active' AND task_due_date = {as.integer(Sys.Date())}")) |>
+ 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))
+
+ display_tasks_dt_review()
+ })
+
+ ### просроченные ------------
+ observeEvent(input$show_dt_overdue, {
+
+ con <- db$make_db_connection(scheme(),"display_task_modal")
+ on.exit(db$close_db_connection(con, "display_task_modal"), add = TRUE)
+
+ values$tasks_data <- DBI::dbGetQuery(con, glue::glue("SELECT * FROM tasks WHERE task_status = 'active' AND task_due_date < {as.integer(Sys.Date())}")) |>
+ 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))
+
+ display_tasks_dt_review()
+ })
+
+ ### modal -----
+ display_tasks_dt_review <- function() {
+
+ values$tasks_data <- values$tasks_data |>
+ dplyr::select(task_id:task_datetime_last_updated)
+
+ rename_cols <- tasks_colnames[tasks_colnames %in% colnames(values$tasks_data)]
+
+ date_cols <- c("task_datetime_created", "task_datetime_completed", "task_datetime_last_updated", "task_due_date")
+ date_cols <- which(colnames(values$tasks_data) %in% date_cols)
+
+ output$dt_todays_tasks <- DT::renderDataTable(
+ DT::datatable(
+ values$tasks_data,
+ caption = 'Table 1: This is a simple caption for the table.',
+ rownames = FALSE,
+ colnames = rename_cols,
+ extensions = c("FixedColumns"),
+ # editable = 'cell',
+ selection = "single",
+ options = list(
+ dom = 'tip',
+ scrollX = TRUE,
+ fixedColumns = list(leftColumns = 1),
+ autoWidth = TRUE,
+ columnDefs = list(
+ list(
+ targets = 3:4,
+ width = '200px',
+ render = htmlwidgets::JS(
+ "function(data, type, row, meta) {",
+ "return type === 'display' && data.length > 20 ?",
+ "'' + data.substr(0, 20) + '...' : data;",
+ "}")
+ )
+ )
+ )
+ ) |>
+ DT::formatDate(date_cols, "toLocaleDateString", params = list('ru-RU'))
+ )
+
+ showModal(modalDialog(
+ DT::dataTableOutput(ns("dt_todays_tasks")),
+ size = "xl",
+ footer = tagList(
+ actionButton(ns("jump_to_main_key"), "перейти к id", icon("right-to-bracket"))
+ ),
+ easyClose = TRUE
+ ))
+
+ }
+
+ ### jump to main_key ---------
+ observeEvent(input$jump_to_main_key, {
+
+ if (is.null(input$dt_todays_tasks_rows_selected)) {
+ showNotification("необходимо выбрать задачу", type = "error")
+ } else {
+
+ # get key
+ main_key_to_jump <- values$tasks_data[input$dt_todays_tasks_rows_selected,]$task_main_key
+ values$main_key <- main_key_to_jump
+
+ removeModal()
+
+ }
+ })
+
+ })
+}
+
+#' @export
+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()
+
+ }
+
+ # при наличии таблицы - полу
+ if ("tasks" %in% DBI::dbListTables(con)) {
+
+ tasks_num <- DBI::dbGetQuery(con, glue::glue("SELECT COUNT ('task_id') FROM tasks WHERE task_main_key = '{values$main_key}' AND task_status = 'active'")) |>
+ dplyr::pull()
+
+ if (tasks_num > 0) {
+ updateActionButton(inputId = inputID, label = paste("активных задач:", tasks_num))
+ } else {
+ updateActionButton(inputId = inputID, label = "Задачи: нет активных")
+ }
+ }
+
+}
+
+tasks_colnames <- c(
+ "id задачи" = "task_id",
+ "id записи" = "task_main_key",
+ "статус" = "task_status",
+ "задача" = "task_title",
+ "описание" = "task_description",
+ "срок выполнения" = "task_due_date",
+ "создана" = "task_user_created",
+ "дата создания" = "task_datetime_created",
+ "обновлено" = "task_user_last_updated",
+ "дата обновления" = "task_datetime_last_updated",
+ "завершено" = "task_user_completed",
+ "дата выполнения" = "task_datetime_completed"
+)
diff --git a/config.yml b/config.yml
index 28e3c7d..9acd10a 100644
--- a/config.yml
+++ b/config.yml
@@ -6,8 +6,15 @@ default:
prod:
form_app_configure_path: "."
form_auth_enabled: false
+ form_schemes:
+ example_of_scheme: Тестовая база данных
+ main_register: АВЗ и АМИЛОИОДОЗЫ
devel:
- form_app_configure_path: _devel/antifib
+ form_app_configure_path: _devel/new_bases
form_auth_enabled: false
- form_app_version: 0.16.0 dev
\ No newline at end of file
+ form_app_version: 0.16.0 dev
+ form_schemes:
+ antifib: антифибротическая
+ d2tra_t: D2TRA_test
+
\ No newline at end of file
diff --git a/configs/enabled_schemes.R b/configs/enabled_schemes.R
deleted file mode 100644
index 568ef30..0000000
--- a/configs/enabled_schemes.R
+++ /dev/null
@@ -1,4 +0,0 @@
-#' @export
-enabled_schemes <- c(
- `Тестовая база данных` = "example_of_scheme"
-)
\ No newline at end of file
diff --git a/modules/data_validation.R b/modules/data_validation.R
index 3314c78..21d15f9 100644
--- a/modules/data_validation.R
+++ b/modules/data_validation.R
@@ -71,6 +71,7 @@ val_is_a_number = function(x) {
# exit if empty
if (is_this_empty_value(x)) return(NULL)
+
# хак для пропуска значений
if (x == "NA") return(NULL)
@@ -82,7 +83,7 @@ val_is_a_number = function(x) {
## находится ли число в заданном диапазоне значений -------
val_number_within_a_range = function(x, ranges) {
-
+
# exit if empty
if (is_this_empty_value(x)) return(NULL)
if (x == "NA") return(NULL)
diff --git a/modules/db.R b/modules/db.R
index ffd4db3..ec5ba1d 100644
--- a/modules/db.R
+++ b/modules/db.R
@@ -3,7 +3,7 @@
#' @description Function to open connection to db, disigned to easy dubugging.
#' @param where text mark to distingiush calss
make_db_connection = function(scheme, where = "") {
- if (getOption("APP.DEBUG", FALSE)) message("=== DB CONNECT ", where)
+
DBI::dbConnect(RSQLite::SQLite(), fs::path(
config::get("form_app_configure_path"),
"db",
@@ -46,14 +46,13 @@ check_if_table_is_exist_and_init_if_not = function(
if (table_name %in% DBI::dbListTables(con)) {
- cli::cli_inform(c("*" = "проверка таблицы в базе данных: '{table_name}'"))
-
# если таблица существует, производим проверку структуры таблицы
compare_existing_table_with_schema(
table_name = table_name,
schm = schm
)
+ # инициализируем все таблицы
} else {
if (table_name == "main") {
@@ -63,6 +62,7 @@ check_if_table_is_exist_and_init_if_not = function(
.before = 1
)
}
+
if (table_name != "main") {
dummy_df <- get_dummy_df(forms_id_type_list) |>
dplyr::mutate(
@@ -121,6 +121,8 @@ compare_existing_table_with_schema = function(
con = rlang::env_get(rlang::caller_env(), nm = "con")
) {
+ cli::cli_progress_step("проверка таблицы в базе данных: '{table_name}'")
+
main_key <- schm$get_main_key_id
key_id <- schm$get_key_id(table_name)
forms_ids <- schm$get_forms_ids(table_name)
@@ -403,3 +405,59 @@ local_db_backup <- function(
)
}
+#' @export
+db_clean_orphans = function(schm, con) {
+
+ main_key <- schm$get_main_key_id
+ nested_tables <- schm$nested_tables_names
+
+ all_main_keys <- DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT {main_key} FROM main"))
+ all_main_keys <- dplyr::pull(all_main_keys)
+
+ purrr::walk(
+ .x = nested_tables,
+ .f = \(table_name) clear_orphans(table_name = table_name, main_key = main_key, all_main_keys = all_main_keys, con = con)
+ )
+
+ clear_orphans(table_name = "tasks", main_key = "task_main_key", all_main_keys = all_main_keys, con = con, drop_na_keys = FALSE)
+ clear_orphans(table_name = "log", main_key = "key", all_main_keys = all_main_keys, con = con, drop_na_keys = FALSE)
+
+}
+
+clear_orphans <- function(
+ table_name,
+ main_key,
+ all_main_keys,
+ con,
+ drop_na_keys = TRUE
+) {
+
+ if (!table_name %in% DBI::dbListTables(con)) return(invisible())
+
+ all_main_keys_from_nested <- DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT {main_key} FROM {table_name}"))
+ all_main_keys_from_nested <- dplyr::pull(all_main_keys_from_nested)
+
+ if (!drop_na_keys) {
+ all_main_keys_from_nested <- all_main_keys_from_nested[!is.na(all_main_keys_from_nested)]
+ }
+
+ if (all(all_main_keys_from_nested %in% all_main_keys)) {
+ cli::cli_alert_success("Все ключи в таблице '{table_name}' соответствуют действующим")
+ } else {
+
+ orphaned_keys <- all_main_keys_from_nested[!all_main_keys_from_nested %in% all_main_keys]
+ cli::cli_alert_warning(c("В таблице '{table_name}' найдены орфанные записи для следующих ID: ", paste("\n -", orphaned_keys)))
+
+ orphaned_keys <- paste0("'", orphaned_keys, "'", collapse = ", ")
+ del_query <- glue::glue("DELETE FROM {table_name} WHERE {main_key} IN ({orphaned_keys})")
+ deleted <- DBI::dbExecute(con, del_query)
+
+ if (drop_na_keys) {
+ deleted <- deleted + DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key} IS NULL"))
+ }
+
+ cli::cli_alert_success("Из таблицы '{table_name}' было удалено {deleted} орфанных записей")
+
+ }
+
+}
diff --git a/modules/global_options.R b/modules/global_options.R
index 2f06e4a..2e1c798 100644
--- a/modules/global_options.R
+++ b/modules/global_options.R
@@ -43,19 +43,16 @@ check_and_init_scheme = function() {
options(box.path = here::here())
box::use(modules/db[local_db_backup])
- options(box.path = config::get("form_app_configure_path"))
- box::use(configs/enabled_schemes[enabled_schemes])
-
# список файлов, изменение которых, приведут к переинициализиации схемы
files_to_watch <- c(
- fs::path(config::get("form_app_configure_path"), "configs", "enabled_schemes.R"),
+ "config.yml",
"modules/scheme_generator.R",
"modules/utils.R"
)
- scheme_names <- enabled_schemes
- scheme_file <- paste0(config::get("form_app_configure_path"), "/configs/schemas/", scheme_names, ".xlsx")
- scheme_file <- stats::setNames(scheme_file, scheme_names)
+ scheme_names <- names(config::get()$form_schemes)
+ scheme_file <- paste0(config::get("form_app_configure_path"), "/configs/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)])))
@@ -113,6 +110,7 @@ init_scheme = function(scheme_file) {
if (!dir.exists(db_path)) dir.create(db_path)
cli::cli_h1("Инициализация схемы")
+
schms <- purrr::map2(
.x = scheme_file,
.y = names(scheme_file),
@@ -121,8 +119,15 @@ init_scheme = function(scheme_file) {
con <- db$make_db_connection(y)
on.exit(db$close_db_connection(con), add = TRUE)
+ # новый объект
schm <- scheme_R6$new(x)
+
+ # проверка схемы с существующей базой данных и инициализация таблиц
db$check_if_table_is_exist_and_init_if_not(schm, con)
+
+ # удаление орфанных записей
+
+ db$db_clean_orphans(schm = schm, con = con)
schm
}
)
@@ -132,13 +137,13 @@ init_scheme = function(scheme_file) {
names(schms),
\(x) schms[[x]]$nested_tables_names
)
+
nested_tables_ids <- unlist(nested_tables_ids)
tab <- table(nested_tables_ids)
# если встречается хоть одно значение несколько раз - начать истошно кричать (могут возникнуть пробемы при вызове всплывающих окон в формах)
if (!all(!tab > 1)) {
cli::cli_abort(c("В одной или нескольких схемах наименования вложенных форм совпадают:", paste("-", names(tab)[tab > 1])))
-
}
saveRDS(schms, "scheme.rds")
diff --git a/modules/scheme_generator.R b/modules/scheme_generator.R
index 58a07f9..fd837ac 100644
--- a/modules/scheme_generator.R
+++ b/modules/scheme_generator.R
@@ -40,6 +40,19 @@ scheme_R6 <- R6::R6Class(
}
)
+ # отдельно для тасков
+ private$schemes_list[["tasks"]] <- tibble::tribble(
+ ~ form_id, ~form_type, ~form_label, ~form_description, ~choices,
+ "dummy", "text", "dummy", "dummy", NA,
+ "task_status", "select_one", "Статус задачи", NA, "active",
+ "task_status", "select_one", "Статус задачи", NA, "completed",
+ "task_status", "select_one", "Статус задачи", NA, "deleted",
+ "task_title", "text", "Название задачи", NA, NA,
+ "task_description", "text", "Описание задачи", "краткое описание", "3",
+ "task_due_date", "date", "Дата выполнения задачи", NA, NA,
+ ) |>
+ dplyr::mutate(condition = NA)
+
# extract main key
private$main_key_id <- self$get_key_id("main")
@@ -78,6 +91,7 @@ scheme_R6 <- R6::R6Class(
get_scheme = function(table_name) {
private$schemes_list[[table_name]]
},
+
## с полями имеющие значение -------
get_scheme_with_values_forms = function(table_name) {
private$schemes_list[[table_name]] |>
@@ -117,7 +131,7 @@ scheme_R6 <- R6::R6Class(
nested_forms_names = NA,
bslib_rendered_ui = NA,
excluded_types = c("nested_forms", "description", "description_header"),
- reserved_table_names = c("meta", "log", "main"),
+ reserved_table_names = c("meta", "log", "main", "tasks"),
load_scheme_from_xlsx = function(sheet_name) {
diff --git a/modules/utils.R b/modules/utils.R
index 0efd8fe..6541065 100644
--- a/modules/utils.R
+++ b/modules/utils.R
@@ -135,7 +135,8 @@ render_forms = function(
form <- shiny::textAreaInput(
inputId = form_id,
label = label,
- rows = 1
+ rows = 1,
+ resize = "none"
)
}
@@ -263,7 +264,7 @@ update_forms_with_data = function(
local_delimeter = getOption("SYMBOL_DELIM"),
ns
) {
-
+
options(box.path = here::here())
box::use(modules/data_manipulations[is_this_empty_value])