diff --git a/app.R b/app.R index 3789f58..fbeced8 100644 --- a/app.R +++ b/app.R @@ -22,10 +22,17 @@ config <- config::get(file = "configs/config.yml") folder_with_schemas <- fs::path("configs/schemas") FILE_SCHEME <- fs::path(folder_with_schemas, "main.xlsx") -dbfile <- fs::path("data.sqlite") +# dbfile <- fs::path("data.sqlite") + +# options(box.path = getwd()) +box::purge_cache() +box::use( + modules/utils, + modules/global_options, + modules/db +) # SETTINGS ================================ -DEBUG <- FALSE AUTH_ENABLED <- config$auth_module # CHECK FOR PANDOC @@ -35,6 +42,7 @@ 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 ========================== # load scheme SCHEME_MAIN <- readxl::read_xlsx(FILE_SCHEME) %>% @@ -58,25 +66,25 @@ inputs_tables_list <- SCHEME_MAIN %>% # SETUP DB ========================== -#' @description Function to open connection to db, disigned to easy dubugging. -make_db_connection <- function(where = "") { - if (DEBUG) message("=== DB CONNECT ", where) - DBI::dbConnect(RSQLite::SQLite(), dbfile) -} +# #' @description Function to open connection to db, disigned to easy dubugging. +# make_db_connection <- function(where = "") { +# if (DEBUG) message("=== DB CONNECT ", where) +# DBI::dbConnect(RSQLite::SQLite(), dbfile) +# } -#' @description Function to close connection to db, disigned to easy dubugging and -#' hide warnings. -close_db_connection <- function(con, where = "") { - tryCatch( - expr = DBI::dbDisconnect(con), - error = function(e) print(e), - warning = function(w) if (DEBUG) message("=!= ALREADY DISCONNECTED ", where), - finally = if (DEBUG) message("=/= DB DISCONNECT ", where) - ) -} +# #' @description Function to close connection to db, disigned to easy dubugging and +# #' hide warnings. +# close_db_connection <- function(con, where = "") { +# tryCatch( +# expr = DBI::dbDisconnect(con), +# error = function(e) print(e), +# warning = function(w) if (DEBUG) message("=!= ALREADY DISCONNECTED ", where), +# finally = if (DEBUG) message("=/= DB DISCONNECT ", where) +# ) +# } # establish connection -con <- make_db_connection() +con <- db$make_db_connection() # init DB (write dummy data to "main" table) if (!"main" %in% DBI::dbListTables(con)) { @@ -117,7 +125,7 @@ if (identical(colnames(DBI::dbReadTable(con, "main")), names(inputs_simple_list) # add empty data for each new input form for (i in form_base_difference) { df_to_rewrite <- df_to_rewrite %>% - dplyr::mutate(!!dplyr::sym(i) := get_empty_data(inputs_simple_list[i])) + dplyr::mutate(!!dplyr::sym(i) := utils$get_empty_data(inputs_simple_list[i])) } # reorder due to scheme @@ -136,7 +144,7 @@ if (identical(colnames(DBI::dbReadTable(con, "main")), names(inputs_simple_list) } # close connection to prevent data loss -close_db_connection(con) +db$close_db_connection(con) # INLINE TABLES ===================== @@ -144,6 +152,7 @@ close_db_connection(con) inline_tables <- purrr::map( .x = purrr::set_names(inputs_tables_list), .f = \(x_inline_table_name) { + # получить имя файла со схемой file_name <- SCHEME_MAIN %>% dplyr::filter(form_id == x_inline_table_name) %>% @@ -172,166 +181,185 @@ inline_tables <- purrr::map( # создание объектов для ввода # функция -create_forms <- function(form_id, form_label, form_type) { - # check if have condition - condition <- dplyr::filter(SCHEME_MAIN, form_id == {{ form_id }}) %>% - dplyr::distinct(condition) %>% - dplyr::pull() +# create_forms <- function(form_id, form_label, form_type) { +# # check if have condition +# condition <- dplyr::filter(SCHEME_MAIN, form_id == {{ form_id }}) %>% +# dplyr::distinct(condition) %>% +# dplyr::pull() - choices <- dplyr::filter(SCHEME_MAIN, form_id == {{ form_id }}) %>% - dplyr::pull(choices) +# choices <- dplyr::filter(SCHEME_MAIN, form_id == {{ form_id }}) %>% +# dplyr::pull(choices) - # simple text or number input - if (form_type %in% c("text", "number")) { - form <- shiny::textAreaInput( - inputId = form_id, - label = tags$span(style = "color: #444444; font-weight: 550;", form_label), - rows = 1 - ) - } +# # simple text or number input +# if (form_type %in% c("text", "number")) { +# form <- shiny::textAreaInput( +# inputId = form_id, +# label = tags$span(style = "color: #444444; font-weight: 550;", form_label), +# rows = 1 +# ) +# } - # simple date input - if (form_type == "date") { - # supress warning while trying keep data form empty by default - suppressWarnings({ - form <- dateInput( - inputId = form_id, - label = tags$span(style = "color: #444444; font-weight: 550;", form_label), - value = NA, # keep empty - format = "dd.mm.yyyy", - weekstart = 1, - language = "ru" - ) - }) - } +# # simple date input +# if (form_type == "date") { +# # supress warning while trying keep data form empty by default +# suppressWarnings({ +# form <- dateInput( +# inputId = form_id, +# label = tags$span(style = "color: #444444; font-weight: 550;", form_label), +# value = NA, # keep empty +# format = "dd.mm.yyyy", +# weekstart = 1, +# language = "ru" +# ) +# }) +# } - # еденичный выбор - if (form_type == "select_one") { - form <- selectizeInput( - inputId = form_id, - label = tags$span(style = "color: #444444; font-weight: 550;", form_label), - choices = choices, - selected = NULL, - options = list( - create = FALSE, - onInitialize = I('function() { this.setValue(""); }') - ) - ) - } +# # еденичный выбор +# if (form_type == "select_one") { +# form <- selectizeInput( +# inputId = form_id, +# label = tags$span(style = "color: #444444; font-weight: 550;", form_label), +# choices = choices, +# selected = NULL, +# options = list( +# create = FALSE, +# onInitialize = I('function() { this.setValue(""); }') +# ) +# ) +# } - # множественный выбор - if (form_type == "select_multiple") { - form <- selectizeInput( - inputId = form_id, - label = tags$span(style = "color: #444444; font-weight: 550;", form_label), - choices = choices, - selected = NULL, - multiple = TRUE, - options = list( - create = FALSE, - onInitialize = I('function() { this.setValue(""); }') - ) - ) - } +# # множественный выбор +# if (form_type == "select_multiple") { +# form <- selectizeInput( +# inputId = form_id, +# label = tags$span(style = "color: #444444; font-weight: 550;", form_label), +# choices = choices, +# selected = NULL, +# multiple = TRUE, +# options = list( +# create = FALSE, +# onInitialize = I('function() { this.setValue(""); }') +# ) +# ) +# } - # множественный выбор - if (form_type == "radio") { - form <- radioButtons( - inputId = form_id, - label = tags$span(style = "color: #444444; font-weight: 550;", form_label), - choices = choices, - selected = character(0) - ) - } +# # множественный выбор +# if (form_type == "radio") { +# form <- radioButtons( +# inputId = form_id, +# label = tags$span(style = "color: #444444; font-weight: 550;", form_label), +# choices = choices, +# selected = character(0) +# ) +# } - if (form_type == "checkbox") { - form <- checkboxGroupInput( - inputId = form_id, - # label = tags$span(style = "color: #444444; font-weight: 550;", form_label), - label = h6(form_label), - choices = choices, - selected = character(0) - ) - } +# if (form_type == "checkbox") { +# form <- checkboxGroupInput( +# inputId = form_id, +# # label = tags$span(style = "color: #444444; font-weight: 550;", form_label), +# label = h6(form_label), +# choices = choices, +# selected = character(0) +# ) +# } - # вложенная таблица - if (form_type == "inline_table") { - form <- rHandsontableOutput(outputId = form_id) - } +# # вложенная таблица +# if (form_type == "inline_table") { +# form <- rHandsontableOutput(outputId = form_id) +# } - # description part - if (form_type == "description") { - form <- div(HTML(form_label), style = "color:Gray;font-size: 90%;") - } +# # description part +# if (form_type == "description") { +# form <- div(HTML(form_label), style = "color:Gray;font-size: 90%;") +# } - # если есть условие создать кондитионал панель - if (!is.na(condition)) { - form <- conditionalPanel( - condition = condition, - form - ) - } +# # если есть условие создать кондитионал панель +# if (!is.na(condition)) { +# form <- conditionalPanel( +# condition = condition, +# form +# ) +# } - form -} +# form +# } # GENERATE UI ================================== # functions for making cards -make_cards_fn <- function(sub_group) { - subgroups_inputs <- df_forms %>% - dplyr::filter(subgroup == {{ sub_group }}) %>% - dplyr::distinct(form_id, form_label, form_type) +# make_cards_fn <- function(sub_group) { - bslib::card( - bslib::card_header(sub_group, container = htmltools::h5), - full_screen = TRUE, - width = "4000px", - bslib::card_body( - fill = TRUE, - # передаем все аргументы в функцию для создания елементов - purrr::pmap(subgroups_inputs, create_forms) - ) - ) -} +# subgroups_inputs <- df_forms %>% +# dplyr::filter(subgroup == {{sub_group}}) %>% +# dplyr::distinct(form_id, form_label, form_type) + +# subgroups_inputs2 <- SCHEME_MAIN |> +# dplyr::filter(subgroup == {{sub_group}}) %>% +# dplyr::distinct(form_id, form_label, form_type, condition) + +# print(subgroups_inputs2) + +# bslib::card( +# bslib::card_header(sub_group, container = htmltools::h5), +# full_screen = TRUE, +# width = "4000px", +# bslib::card_body( +# fill = TRUE, +# # передаем все аргументы в функцию для создания елементов +# purrr::pmap( +# .l = subgroups_inputs, +# .f = utils$create_forms, +# scheme = SCHEME_MAIN +# ) +# ) +# ) +# } # get pages list pages_list <- unique(SCHEME_MAIN$part) -# get all forms df -df_forms <- SCHEME_MAIN %>% - dplyr::distinct(part, subgroup, form_id, form_label, form_type) +# # get all forms df +# df_forms <- SCHEME_MAIN %>% +# dplyr::distinct(part, subgroup, form_id, form_label, form_type) -# generate nav panels +# generate nav panels for each page nav_panels_list <- purrr::map( .x = pages_list, - .f = \(x_page) { - # get info about inputs for current page - page_forms <- SCHEME_MAIN %>% - dplyr::filter(part == {{ x_page }}) %>% - dplyr::distinct(subgroup, form_id, form_label, form_type) - - # get list of columns - cols_list <- unique(page_forms$subgroup) - - # making cards - cards <- purrr::map( - .x = cols_list, - .f = make_cards_fn - ) - - # make page wrap - page_wrap <- bslib::layout_column_wrap( - # width = "350px", height = NULL, #was 800 - width = 1 / 4, height = NULL, # was 800 - fixed_width = TRUE, - !!!cards # unpack list of cards - ) - - # add panel wrap to nav_panel - bslib::nav_panel(x_page, page_wrap) - } + .f = utils$make_panels, + main_scheme = SCHEME_MAIN ) +# nav_panels_list <- purrr::map( +# .x = pages_list, +# .f = \(x_page) { + +# # get info about inputs for current page +# page_forms <- SCHEME_MAIN %>% +# dplyr::filter(part == {{x_page}}) %>% +# dplyr::distinct(subgroup, form_id, form_label, form_type) + +# # get list of columns +# cols_list <- unique(page_forms$subgroup) + +# # making cards +# cards <- purrr::map( +# .x = cols_list, +# .f = utils$make_cards_fn, +# main_scheme = SCHEME_MAIN +# ) + +# # make page wrap +# page_wrap <- bslib::layout_column_wrap( +# # width = "350px", height = NULL, #was 800 +# width = 1 / 4, height = NULL, # was 800 +# fixed_width = TRUE, +# !!!cards # unpack list of cards +# ) + +# # add panel wrap to nav_panel +# bslib::nav_panel(x_page, page_wrap) +# } +# ) + # UI ======================= ui <- page_sidebar( title = config$header, @@ -413,6 +441,7 @@ server <- function(input, output) { values <- reactiveValues(data = NULL) rhand_tables <- reactiveValues() + # VALIDATIONS ============================ # create new validator iv <- shinyvalidate::InputValidator$new() @@ -422,10 +451,13 @@ server <- function(input, output) { .x = names(inputs_simple_list), .f = \(x_input_id) { form_type <- inputs_simple_list[[x_input_id]] - choices <- filter(SCHEME_MAIN, form_id == {{ x_input_id }}) %>% pull(choices) - val_required <- filter(SCHEME_MAIN, form_id == {{ x_input_id }}) %>% - distinct(required) %>% - pull(required) + + choices <- dplyr::filter(SCHEME_MAIN, form_id == {{x_input_id}}) %>% + dplyr::pull(choices) + + val_required <- dplyr::filter(SCHEME_MAIN, form_id == {{x_input_id}}) %>% + dplyr::distinct(required) %>% + dplyr::pull(required) # for `number` type: if in `choices` column has values then parsing them to range validation # value `0; 250` -> transform to rule validation value from 0 to 250 @@ -518,13 +550,17 @@ server <- function(input, output) { rownames(rhand_tables[[x]]) <- NULL # создать объект рандсонтебл - rh_tabel <- rhandsontable( + rh_tabel <- rhandsontable::rhandsontable( rhand_tables[[x]], colHeaders = headers, rowHeaders = NULL, height = 400, ) %>% - hot_cols(colWidths = 120, manualColumnResize = TRUE, columnSorting = TRUE) + rhandsontable::hot_cols( + colWidths = 120, + manualColumnResize = TRUE, + columnSorting = TRUE + ) # циклом итерируемся по индексу; for (i in seq(1, length(schema_comp$form_id))) { @@ -564,6 +600,7 @@ server <- function(input, output) { ) }) + # BUTTONS LOGIC ====================== ## clear all inputs ================== # show modal on click of button @@ -579,10 +616,10 @@ server <- function(input, output) { .y = names(inputs_simple_list), .f = \(x_type, x_id) { # using function to update forms - update_forms_with_data( + utils$update_forms_with_data( id = x_id, type = x_type, - value = get_empty_data(x_type) + value = utils$get_empty_data(x_type) ) } ) @@ -603,8 +640,8 @@ server <- function(input, output) { # сохранить простые данные; observeEvent(input$save_data_button, { req(input$id) - con <- make_db_connection("save_data_button") - on.exit(close_db_connection(con, "save_data_button"), add = TRUE) + con <- db$make_db_connection("save_data_button") + on.exit(db$close_db_connection(con, "save_data_button"), add = TRUE) ## MAIN # собрать все значения по введенным данным; @@ -615,14 +652,14 @@ server <- function(input, output) { # return empty if 0 element if (length(input_d) == 0) { - return(get_empty_data(inputs_simple_list[[x]])) + return(utils$get_empty_data(inputs_simple_list[[x]])) } # return element if there one if (length(input_d) == 1) { return(input_d) } # если елементов больше одного - объединять через ";" - if (length(input_d) > 1) paste(input_d, collapse = "; ") + if (length(input_d) > 1) paste(input_d, collapse = getOption("SYMBOL_DELIM")) } ) @@ -660,8 +697,8 @@ server <- function(input, output) { ## get list of id's from db ===================== observeEvent(input$load_data_button, { - con <- make_db_connection("load_data_button") - on.exit(close_db_connection(con, "load_data_button")) + con <- db$make_db_connection("load_data_button") + on.exit(db$close_db_connection(con, "load_data_button")) if (length(dbListTables(con)) != 0 && "main" %in% DBI::dbListTables(con)) { # GET DATA files @@ -691,8 +728,8 @@ server <- function(input, output) { ## load data to input forms ================================== observeEvent(input$read_data, { - con <- make_db_connection("read_data") - on.exit(close_db_connection(con, "read_data"), add = TRUE) + con <- db$make_db_connection("read_data") + on.exit(db$close_db_connection(con, "read_data"), add = TRUE) # main df read test_read_df <- read_df_from_db_by_id("main", con) @@ -705,14 +742,14 @@ server <- function(input, output) { .x = inputs_simple_list, .y = names(inputs_simple_list), .f = \(x_type, x_id) { - if (DEBUG) { + if (getOption("APP.DEBUG")) { values_load <- test_read_df[[x_id]] print(paste(x_type, x_id, values_load, sep = " || ")) print(is.na(values_load)) } - # using function to update forms - update_forms_with_data( + # updating forms with loaded data + utils$update_forms_with_data( id = x_id, type = x_type, value = test_read_df[[x_id]] @@ -744,8 +781,8 @@ server <- function(input, output) { output$downloadData <- downloadHandler( filename = paste0("d2tra_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx"), content = function(file) { - con <- make_db_connection("downloadData") - on.exit(close_db_connection(con, "downloadData"), add = TRUE) + con <- db$make_db_connection("downloadData") + on.exit(db$close_db_connection(con, "downloadData"), add = TRUE) # get all data list_of_df <- purrr::map( @@ -875,8 +912,8 @@ server <- function(input, output) { ## trigger saving function ============= observeEvent(input$data_save, { - con <- make_db_connection("saving data (from modal conf)") - on.exit(close_db_connection(con, "saving data (from modal conf)"), add = TRUE) + con <- db$make_db_connection("saving data (from modal conf)") + on.exit(db$close_db_connection(con, "saving data (from modal conf)"), add = TRUE) # убираем плашку removeModal() @@ -895,7 +932,7 @@ server <- function(input, output) { # FUNCTIONS ============================== ## write all inputs to db ================ write_all_to_db <- function() { - con <- make_db_connection("fn call `write_all_to_db()`") + con <- db$make_db_connection("fn call `write_all_to_db()`") # on.exit(close_db_connection("fn call `write_all_to_db()`"), add = TRUE) # write main diff --git a/helpers/db.R b/helpers/db.R deleted file mode 100644 index 955e52a..0000000 --- a/helpers/db.R +++ /dev/null @@ -1,57 +0,0 @@ -# based on https://github.com/datastorm-open/shinymanager/ - - -#' @export -write_db_encrypt <- function(conn, value, name, passphrase = Sys.getenv("AUTH_DB_KEY")) { - if (is.character(conn)) { - conn <- DBI::dbConnect(RSQLite::SQLite(), dbname = conn) - on.exit(DBI::dbDisconnect(conn)) - } - - if (name == "credentials" && "password" %in% colnames(value)) { - if (!"is_hashed_password" %in% colnames(value)) { - value$is_hashed_password <- FALSE - } - to_hash <- which(!as.logical(value$is_hashed_password)) - if (length(to_hash) > 0) { - # store hashed password - value$password[to_hash] <- sapply(value$password[to_hash], function(x) scrypt::hashPassword(x)) - value$is_hashed_password[to_hash] <- TRUE - } - } - - if (!is.null(passphrase)) { - passphrase <- as.character(passphrase) - passphrase <- charToRaw(passphrase) - key <- openssl::sha256(passphrase) - value_serialized <- serialize(value, NULL) - value_encrypted <- openssl::aes_cbc_encrypt(data = value_serialized, key = key) - value <- data.frame(value = I(list(value_encrypted)), iv = I(list(attr(value_encrypted, "iv")))) - } - - DBI::dbWriteTable(conn = conn, name = name, value = value, overwrite = TRUE) -} - - -#' @export -read_db_encrypt <- function(conn, name, passphrase = Sys.getenv("AUTH_DB_KEY")) { - - if (is.character(conn)) { - conn <- DBI::dbConnect(RSQLite::SQLite(), dbname = conn) - on.exit(DBI::dbDisconnect(conn)) - } - - out <- DBI::dbReadTable(conn = conn, name = name) - - if (!is.null(passphrase)) { - passphrase <- as.character(passphrase) - passphrase <- charToRaw(passphrase) - key <- openssl::sha256(passphrase) - value <- out$value[[1]] - attr(value, "iv") <- out$iv[[1]] - out <- openssl::aes_cbc_decrypt(value, key = key) - out <- unserialize(out) - } - - return(out) -} diff --git a/helpers/functions.R b/helpers/functions.R index 617366f..7c5aaf4 100644 --- a/helpers/functions.R +++ b/helpers/functions.R @@ -6,12 +6,12 @@ get_dummy_data <- function(type) { if (type %in% c("number")) return(as.double(999)) } -get_empty_data <- function(type) { - if (type %in% c("text", "select_one", "select_multiple")) return(as.character(NA)) - if (type %in% c("radio", "checkbox")) return(as.character(NA)) - if (type %in% c("date")) return(as.Date(NA)) - if (type %in% c("number")) return(as.character(NA)) -} +# get_empty_data <- function(type) { +# if (type %in% c("text", "select_one", "select_multiple")) return(as.character(NA)) +# if (type %in% c("radio", "checkbox")) return(as.character(NA)) +# if (type %in% c("date")) return(as.Date(NA)) +# if (type %in% c("number")) return(as.character(NA)) +# } get_dummy_df <- function() { purrr::map( @@ -45,62 +45,3 @@ check_for_empty_data <- function(value_to_check) { FALSE } - - -#' @description Function update input forms. -#' @param id - input form id; -#' @param type - type of form; -#' @param value - value to update; -update_forms_with_data <- function(id, type, value) { - if (type == "text") { - shiny::updateTextAreaInput(inputId = id, value = value) - } - - if (type == "number") { - shiny::updateTextAreaInput(inputId = id, value = value) - } - - # supress warnings when applying NA or NULL to date input form - if (type == "date") { - suppressWarnings( - shiny::updateDateInput(inputId = id, value = value) - ) - } - - # select_one - if (type == "select_one") { - shiny::updateSelectizeInput(inputId = id, selected = value) - } - - # select_multiple - # check if value is not NA and split by delimetr - if (type == "select_multiple" && !is.na(value)) { - vars <- stringr::str_split_1(value, "; ") - shiny::updateSelectizeInput(inputId = id, selected = vars) - } - # in other case fill with `character(0)` to proper reseting form - if (type == "select_multiple" && is.na(value)) { - shiny::updateSelectizeInput(inputId = id, selected = character(0)) - } - - # radio buttons - if (type == "radio" && !is.na(value)) { - shiny::updateRadioButtons(inputId = id, selected = value) - } - if (type == "radio" && is.na(value)) { - shiny::updateRadioButtons(inputId = id, selected = character(0)) - } - - # checkboxes - if (type == "checkbox" && !is.na(value)) { - vars <- stringr::str_split_1(value, "; ") - shiny::updateCheckboxGroupInput(inputId = id, selected = vars) - } - if (type == "checkbox" && is.na(value)) { - shiny::updateCheckboxGroupInput(inputId = id, selected = character(0)) - } - - if (type == "inline_table") { - message("EMPTY") - } -} \ No newline at end of file diff --git a/modules/db.R b/modules/db.R new file mode 100644 index 0000000..d75fa5a --- /dev/null +++ b/modules/db.R @@ -0,0 +1,29 @@ +# box ======== +.on_load = function(ns) { + message( + 'Loading module "', box::name(), '"\n', + 'Module path: "', basename(box::file()), '"' + ) +} +# ================ + +# DB RELATED =========================== +#' @export +#' @description Function to open connection to db, disigned to easy dubugging. +#' @param where text mark to distingiush calss +make_db_connection <- function(where = "") { + if (getOption("APP.DEBUG", FALSE)) message("=== DB CONNECT ", where) + DBI::dbConnect(RSQLite::SQLite(), getOption("APP.FILE_DB", FALSE)) +} + +#' @export +#' @description Function to close connection to db, disigned to easy dubugging and +#' hide warnings. +close_db_connection <- function(con, where = "") { + tryCatch( + expr = DBI::dbDisconnect(con), + error = function(e) print(e), + warning = function(w) if (getOption("APP.DEBUG", FALSE)) message("=!= ALREADY DISCONNECTED ", where), + finally = if (getOption("APP.DEBUG", FALSE)) message("=/= DB DISCONNECT ", where) + ) +} \ No newline at end of file diff --git a/modules/global_options.R b/modules/global_options.R new file mode 100644 index 0000000..fa36126 --- /dev/null +++ b/modules/global_options.R @@ -0,0 +1,30 @@ +# box ======== +.on_load = function(ns) { + message( + 'Loading module "', box::name(), '"\n', + 'Module path: "', basename(box::file()), '"' + ) + set_global_options() +} + +# ================ + +#' @export +#' @description костыли для упрощения работы себе +set_global_options <- function( + SYMBOL_DELIM = "; ", + APP.DEBUG = FALSE, + APP.FILE_DB = fs::path("data.sqlite"), + shiny.host = "127.0.0.1", + shiny.port = 1337, + ... +) { + options( + SYMBOL_DELIM = SYMBOL_DELIM, + APP.DEBUG = APP.DEBUG, + APP.FILE_DB = APP.FILE_DB, + shiny.host = shiny.host, + shiny.port = shiny.port, + ... + ) +} \ No newline at end of file diff --git a/modules/utils.R b/modules/utils.R new file mode 100644 index 0000000..b988484 --- /dev/null +++ b/modules/utils.R @@ -0,0 +1,284 @@ +# box ======== +.on_load = function(ns) { + message( + 'Loading module "', box::name(), '"\n', + 'Module path: "', basename(box::file()), '"' + ) +} +# ================ + +# asdasd +#' @export +make_panels <- function(page_name, main_scheme) { + + # get info about inputs for current page + page_forms <- main_scheme |> + dplyr::filter(part == {{page_name}}) |> + dplyr::distinct(subgroup, form_id, form_label, form_type) + + # get list of columns + cols_list <- unique(page_forms$subgroup) + + # making cards + cards <- purrr::map( + .x = cols_list, + .f = make_cards_fn, + main_scheme = main_scheme + ) + + # make page wrap + page_wrap <- bslib::layout_column_wrap( + # width = "350px", height = NULL, #was 800 + width = 1 / 4, height = NULL, # was 800 + fixed_width = TRUE, + # unpack list of cards + !!!cards + ) + + # add panel wrap to nav_panel + bslib::nav_panel( + title = page_name, + page_wrap + ) +} + +# functions for making cards +#' @export +make_cards_fn <- function(sub_group, main_scheme) { + + main_scheme <<- main_scheme + subgroups_inputs <- main_scheme |> + dplyr::filter(subgroup == {{sub_group}}) |> + dplyr::distinct(form_id, form_label, form_type) + + bslib::card( + bslib::card_header(sub_group, container = htmltools::h5), + full_screen = TRUE, + width = "4000px", + bslib::card_body( + fill = TRUE, + # передаем все аргументы в функцию для создания елементов + purrr::pmap( + .l = subgroups_inputs, + .f = create_forms, + main_scheme = main_scheme + ) + ) + ) +} + +# UI RELATED ============================ +#' @export +#' @param TEST s +create_forms <- function( + form_id, + form_label, + form_type, + main_scheme +) { + + # check if have condition + condition <- dplyr::filter(main_scheme, form_id == {{form_id}}) |> + dplyr::distinct(condition) |> + dplyr::pull() + + choices <- dplyr::filter(main_scheme, form_id == {{form_id}}) |> + dplyr::pull(choices) + + # simple text or number input + if (form_type == "text") { + + # get info how much rows to render + rows_to_show <- ifelse(!is.na(choices), as.integer(choices), 1) + + form <- shiny::textAreaInput( + inputId = form_id, + label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), + rows = rows_to_show + ) + } + + if (form_type == "number") { + form <- shiny::textAreaInput( + inputId = form_id, + label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), + rows = 1 + ) + } + + # simple date input + if (form_type == "date") { + # supress warning while trying keep data form empty by default + suppressWarnings({ + form <- shiny::dateInput( + inputId = form_id, + label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), + value = NA, # keep empty + format = "dd.mm.yyyy", + weekstart = 1, + language = "ru" + ) + }) + } + + # еденичный выбор + if (form_type == "select_one") { + form <- shiny::selectizeInput( + inputId = form_id, + label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), + choices = choices, + selected = NULL, + options = list( + create = FALSE, + onInitialize = I('function() { this.setValue(""); }') + ) + ) + } + + # множественный выбор + if (form_type == "select_multiple") { + form <- shiny::selectizeInput( + inputId = form_id, + label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), + choices = choices, + selected = NULL, + multiple = TRUE, + options = list( + create = FALSE, + onInitialize = I('function() { this.setValue(""); }') + ) + ) + } + + # множественный выбор + if (form_type == "radio") { + form <- shiny::radioButtons( + inputId = form_id, + label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), + choices = choices, + selected = character(0) + ) + } + + if (form_type == "checkbox") { + form <- shiny::checkboxGroupInput( + inputId = form_id, + # label = shiny::span(style = "color: #444444; font-weight: 550;", form_label), + label = shiny::h6(form_label), + choices = choices, + selected = character(0) + ) + } + + # вложенная таблица + if (form_type == "inline_table") { + form <- rhandsontable::rHandsontableOutput(outputId = form_id) + } + + # description part + if (form_type == "description") { + form <- shiny::div(shiny::HTML(form_label), style = "color:Gray;font-size: 90%;") + } + + # если есть условие создать кондитионал панель + if (!is.na(condition)) { + form <- shiny::conditionalPanel( + condition = condition, + form + ) + } + form +} + + + + +# SERVER LOGIC ========================== +#' @export +get_empty_data <- function(type) { + if (type %in% c("text", "select_one", "select_multiple")) return(as.character(NA)) + if (type %in% c("radio", "checkbox")) return(as.character(NA)) + if (type %in% c("date")) return(as.Date(NA)) + if (type %in% c("number")) as.character(NA) +} + + +#' @export +#' @description Function to update input forms (default variants only) +#' @param id - input form id; +#' @param type - type of form; +#' @param value - value to update; +#' @param local_delimeter - delimeter to split file +update_forms_with_data <- function( + id, + type, + value, + local_delimeter = getOption("SYMBOL_DELIM") +) { + + if (type == "text") { + shiny::updateTextAreaInput(inputId = id, value = value) + } + + if (type == "number") { + shiny::updateTextAreaInput(inputId = id, value = value) + } + + # supress warnings when applying NA or NULL to date input form + if (type == "date") { + suppressWarnings( + shiny::updateDateInput(inputId = id, value = value) + ) + } + + # select_one + if (type == "select_one") { + # update choices + # old_choices <- subset(scheme, form_id == id, choices) |> dplyr::pull() + # new_choices <- unique(c(old_choices, value)) + # new_choices <- new_choices[!is.na(new_choices)] + + # shiny::updateSelectizeInput(inputId = id, selected = value, choices = new_choices) + shiny::updateSelectizeInput(inputId = id, selected = value) + } + + # select_multiple + # check if value is not NA and split by delimetr + if (type == "select_multiple" && !is.na(value)) { + vars <- stringr::str_split_1(value, local_delimeter) + + # update choices + # old_choices <- subset(scheme, form_id == id, choices) |> dplyr::pull() + # new_choices <- unique(c(old_choices, vars)) + # new_choices <- new_choices[!is.na(new_choices)] + + # shiny::updateSelectizeInput(inputId = id, selected = vars, choices = new_choices) + shiny::updateSelectizeInput(inputId = id, selected = vars) + } + + # in other case fill with `character(0)` to proper reseting form + if (type == "select_multiple" && is.na(value)) { + shiny::updateSelectizeInput(inputId = id, selected = character(0)) + } + + # radio buttons + if (type == "radio" && !is.na(value)) { + shiny::updateRadioButtons(inputId = id, selected = value) + } + if (type == "radio" && is.na(value)) { + shiny::updateRadioButtons(inputId = id, selected = character(0)) + } + + # checkboxes + if (type == "checkbox" && !is.na(value)) { + vars <- stringr::str_split_1(value, local_delimeter) + shiny::updateCheckboxGroupInput(inputId = id, selected = vars) + } + if (type == "checkbox" && is.na(value)) { + shiny::updateCheckboxGroupInput(inputId = id, selected = character(0)) + } + + # if (type == "inline_table") { + # message("EMPTY") + # } +}