refactor: вся основа кода в отдельной папке

R/modules/data_manipulations.R

@@ -0,0 +1,33 @@
+
+#' @description Function check if variable contains some sort of empty data
+#' (NULL, NA, "", other 0-length data) and return `TRUE` (`FALSE` if data is
+#' not 'empty').
+#'
+#' Needed for proper data validation.
+#' @export
+is_this_empty_value = function(value_to_check) {
+
+  # for any 0-length
+  if (length(value_to_check) == 0) return(TRUE)
+
+  # for NA
+  if (is.logical(value_to_check) && is.na(value_to_check)) return(TRUE)
+
+  # for NULL
+  if (is.null(value_to_check)) return(TRUE)
+
+  # for non-empty Date (RETURN FALSE)
+  if (inherits(value_to_check, "Date") && length(value_to_check) != 0) return(FALSE)
+
+  # for empty strings (stands before checking non-empty data for avoid mistakes)
+  if (is.character(value_to_check)) {
+    if (is.na(value_to_check)) return(TRUE)
+    if (value_to_check == "")   return(TRUE)
+  }
+
+  if (is.double(value_to_check)) {
+    if (is.na(value_to_check)) return(TRUE)
+  }
+
+  return(FALSE)
+}

R/modules/data_validation.R

@@ -0,0 +1,117 @@
+options(box.path = here::here())
+box::use(R/modules/data_manipulations[is_this_empty_value])
+
+#' @export
+init_val = function(scheme, ns) {
+
+  iv <- shinyvalidate::InputValidator$new()
+
+  # если передана функция с пространством имен, то происходит модификация id
+  if (!missing(ns)) {
+    scheme <- scheme |>
+      dplyr::mutate(form_id = ns(form_id))
+  }
+
+  # формируем список id - тип
+  inputs_simple_list <- scheme |>
+    dplyr::filter(!form_type %in% c("nested_forms", "description", "description_header")) |>
+    dplyr::distinct(form_id, form_type) |>
+    tibble::deframe()
+
+  # add rules to all inputs
+  purrr::walk(
+    .x = names(inputs_simple_list),
+    .f = \(x_input_id) {
+
+      form_type <- inputs_simple_list[[x_input_id]]
+
+      choices <- dplyr::filter(scheme, form_id == {{x_input_id}}) |>
+        dplyr::pull(choices)
+
+      val_required <- dplyr::filter(scheme, form_id == {{x_input_id}}) |>
+        dplyr::distinct(required) |>
+        dplyr::pull(required)
+
+      # for `number` type: if in `choices` column has values then parsing them to range validation
+      # value `0; 250` -> transform to rule validation value from 0 to 250
+      if (form_type == "number") {
+
+        iv$add_rule(x_input_id, val_is_a_number)
+
+        # проверка на соответствие диапазону значений
+        if (!is.na(choices)) {
+          # разделить на несколько елементов
+          ranges <- as.integer(stringr::str_split_1(choices, "; "))
+
+          # проверка на кол-во значений
+          if (length(ranges) > 3) {
+            warning("Количество переданных элементов'", x_input_id, "' > 2")
+          } else {
+            iv$add_rule(x_input_id, val_number_within_a_range, ranges = ranges)
+          }
+        }
+      }
+
+      if (form_type %in% c("select_multiple", "select_one", "radio", "checkbox")) {
+        iv$add_rule(x_input_id, val_choice_within_a_dict, choices = choices)
+      }
+
+      # if in `required` column value is `1` apply standart validation
+      if (!is.na(val_required) && val_required == 1) {
+        iv$add_rule(x_input_id, shinyvalidate::sv_required(message = "Необходимо заполнить."))
+      }
+    }
+  )
+  iv
+}
+
+# работа с числовыми значениями ------------------
+## проверка является ли значение числом ----------
+val_is_a_number = function(x) {
+
+  # exit if empty
+  if (is_this_empty_value(x)) return(NULL)
+
+  # хак для пропуска значений
+  if (x == "NA") return(NULL)
+
+  # check for numeric
+  # if (grepl("^[-]?(\\d*\\,\\d+|\\d+\\,\\d*|\\d+)$", x)) NULL else "Значение должно быть числом."
+  if (grepl("^[+-]?\\d*[\\.|\\,]?\\d+$", x)) NULL else "Значение должно быть числом."
+
+}
+
+## находится ли число в заданном диапазоне значений -------
+val_number_within_a_range = function(x, ranges) {
+  
+  # exit if empty
+  if (is_this_empty_value(x)) return(NULL)
+  if (x == "NA") return(NULL)
+
+  # замена разделителя десятичных цифр
+  x <- stringr::str_replace(x, ",", ".")
+
+  # check for currect value
+  if (dplyr::between(as.double(x), ranges[1], ranges[2])) {
+    NULL
+  } else {
+    glue::glue("Значение должно быть между {ranges[1]} и {ranges[2]}.")
+  }
+}
+
+# списки ---------------------------------------------------------
+## являются ли выбранные значения допустимы (согласно файлу схемы)
+val_choice_within_a_dict = function(x, choices) {
+
+  if (length(x) == 1) {
+    if (is_this_empty_value(x)) return(NULL)
+  }
+
+  # проверка на соответствие вариантов схеме ---------
+  compare_to_dict <- (x %in% choices)
+  if (!all(compare_to_dict)) {
+
+    text <- paste0("'",x[!compare_to_dict],"'", collapse = ", ")
+    glue::glue("варианты, не соответствующие схеме: {text}")
+  }
+}

R/modules/db.R

@@ -0,0 +1,465 @@
+
+#' @export
+#' @description Function to open connection to db, disigned to easy dubugging.
+#' @param where text mark to distingiush calss
+make_db_connection = function(scheme, where = "") {
+
+  DBI::dbConnect(RSQLite::SQLite(), fs::path(
+    config::get("form_app_configure_path"),
+    "db",
+    scheme, 
+    ext = "sqlite"
+  ))
+
+}
+
+#' @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)
+  )
+
+}
+
+#' @export
+#' @description
+#' Проверить если таблица есть в базе данных и инициировать ее, если от
+check_if_table_is_exist_and_init_if_not = function(
+  schm,
+  con = rlang::env_get(rlang::caller_env(), nm = "con")
+) {
+
+  main_key <- schm$get_main_key_id
+
+  purrr::walk(
+    .x = schm$all_tables_names,
+    .f = \(table_name, con) {
+
+      forms_id_type_list <- schm$get_id_type_list(table_name)
+      key_name           <- schm$get_key_id(table_name)
+
+      if (table_name %in% DBI::dbListTables(con)) {
+
+        # если таблица существует, производим проверку структуры таблицы
+        compare_existing_table_with_schema(
+          table_name = table_name,
+          schm = schm
+        )
+
+      # инициализируем все таблицы
+      } else {
+
+        if (table_name == "main") {
+          dummy_df <- get_dummy_df(forms_id_type_list) |>
+            dplyr::mutate(
+              !!dplyr::sym(main_key) := "dummy",
+              .before = 1
+            )
+        }
+
+        if (table_name != "main") {
+          dummy_df <- get_dummy_df(forms_id_type_list) |>
+            dplyr::mutate(
+              !!dplyr::sym(main_key) := "dummy",
+              !!dplyr::sym(key_name) := "dummy",
+              .before = 1
+            )
+        }
+
+        # write dummy df into base, then delete dummy row
+        DBI::dbWriteTable(con, table_name, dummy_df, append = TRUE)
+        DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key} = 'dummy'"))
+
+        cli::cli_alert_success("таблица '{table_name}' успешно создана")
+      }
+    },
+    con = con
+  )
+  
+}
+
+#' @description
+#' Возращает пустое значение для каждого типа формы
+get_dummy_data = function(type) {
+
+  if (type %in% c("text", "select_one", "select_multiple")) return("dummy")
+  if (type %in% c("radio", "checkbox")) return("dummy")
+  if (type %in% c("date")) return(as.Date("1990-01-01"))
+  if (type %in% c("number")) return(as.double(999))
+  cli::cli_abort("для типа формы '{type}' нет примера пустого значения!")
+
+}
+
+#' @description
+#' Генерация пустого датасета с пустыми значениями соответствующие
+#' типу данных
+get_dummy_df = function(forms_id_type_list) {
+
+  options(box.path = here::here())
+  box::use(R/modules/utils)
+
+  purrr::map(
+    .x = forms_id_type_list,
+    .f = utils$get_empty_data
+  ) |>
+    dplyr::as_tibble()
+
+}
+
+#' @description
+#' Сравнение полей в существующей в базе данных таблице и попытка
+#' коррекции таблицы
+compare_existing_table_with_schema = function(
+  table_name,
+  schm,
+  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)
+  forms_id_type_list <- schm$get_id_type_list(table_name)
+
+  if (table_name == "main") {
+    all_ids_from_schema <- c(main_key, forms_ids)
+  } else {
+    all_ids_from_schema <- c(main_key, key_id, forms_ids)
+  }
+
+  options(box.path = here::here())
+  box::use(R/modules/utils)
+
+  # checking if db structure in form compatible with alrady writed data (in case on changig form)
+  if (identical(colnames(DBI::dbReadTable(con, table_name)), all_ids_from_schema)) {
+    # ...
+  } else {
+
+    df_to_rewrite <- DBI::dbReadTable(con, table_name)
+    form_base_difference <- setdiff(all_ids_from_schema, colnames(df_to_rewrite))
+    base_form_difference <- setdiff(colnames(df_to_rewrite), all_ids_from_schema)
+
+    # if lengths are equal
+    if (length(all_ids_from_schema) == length(colnames(df_to_rewrite)) &&
+          length(form_base_difference) == 0 &&
+          length(base_form_difference) == 0) {
+      cli::cli_warn("changes in scheme file detected: assuming order changed only")
+    }
+
+    if (length(all_ids_from_schema) == length(colnames(df_to_rewrite)) &&
+          length(form_base_difference) != 0 &&
+          length(base_form_difference) != 0) {
+      cli::cli_abort("changes in scheme file detected: structure has been changed")
+    }
+
+    if (length(all_ids_from_schema) > length(colnames(df_to_rewrite)) && length(form_base_difference) != 0) {
+      cli::cli_warn("changes in scheme file detected: new inputs form was added")
+      cli::cli_warn("trying to adapt database")
+
+      # add empty data for each new input form
+      for (i in form_base_difference) {
+        df_to_rewrite <- df_to_rewrite |>
+          dplyr::mutate(!!dplyr::sym(i) := utils$get_empty_data(forms_id_type_list[i]))
+      }
+
+      # reorder due to scheme
+      df_to_rewrite <- df_to_rewrite |>
+        dplyr::select(dplyr::all_of(all_ids_from_schema))
+
+      DBI::dbWriteTable(con, table_name, df_to_rewrite, overwrite = TRUE)
+      DBI::dbExecute(con, glue::glue("DELETE FROM {table_name} WHERE {main_key} = 'dummy'"))
+    }
+
+    if (length(all_ids_from_schema) < length(colnames(df_to_rewrite))) {
+      cli::cli_abort("changes in scheme file detected: some of inputs form was deleted! it may cause data loss!")
+    }
+    
+  }
+}
+
+#' @export
+write_df_to_db = function(
+  df, 
+  table_name, 
+  schm,
+  main_key_value, 
+  nested_key_value, 
+  con
+) {
+
+  scheme         <- schm$get_scheme(table_name)
+  main_key_id    <- schm$get_main_key_id
+  nested_key_id  <- schm$get_key_id(table_name)
+
+  date_columns   <- subset(scheme, form_type == "date", form_id, drop = TRUE)
+  number_columns <- subset(scheme, form_type == "number", form_id, drop = TRUE)
+  # other_cols     <- which(colnames(df) %in% c(date_columns, number_columns))
+  other_cols     <- colnames(df)[!(colnames(df) %in% c(date_columns, number_columns))]
+
+  df <- df |>
+    dplyr::mutate(
+      # даты - к единому формату
+      dplyr::across(tidyselect::all_of({{date_columns}}), \(x) purrr::map_chr(x, excel_to_db_dates_converter)),
+      # числа - к единому формату десятичных значений
+      dplyr::across(tidyselect::all_of({{number_columns}}), ~ gsub("\\.", "," , .x)),
+      dplyr::across(tidyselect::all_of({{other_cols}}), \(x) dplyr::if_else(x == "", as.character(NA), as.character(x)))
+    )
+
+  if (table_name == "main") {
+    del_query <- glue::glue("DELETE FROM main WHERE {main_key_id} = '{main_key_value}'")
+  }
+
+  if (table_name != "main") {
+    if (is.null(nested_key_value)) {
+      del_query <- glue::glue("DELETE FROM '{table_name}' WHERE {main_key_id} = '{main_key_value}'")
+    } else {
+      del_query <- glue::glue("DELETE FROM '{table_name}' WHERE {main_key_id} = '{main_key_value}' AND {nested_key_id} = '{nested_key_value}'")
+    }
+  }
+
+  deleted <- DBI::dbExecute(con, del_query)
+  cli::cli_alert_success("deleted {deleted} rows for '{main_key_value}' in '{table_name}")
+
+  # записать данные
+  DBI::dbWriteTable(con, table_name, df, append = TRUE)
+
+  # report
+  cli::cli_alert_success("данные для '{main_key_value}' в таблице '{table_name}' успешно обновлены")
+
+}
+
+#' @export
+#' reading tables from db by name and id ========
+read_df_from_db_by_id = function(
+  table_name,
+  schm,
+  main_key_value, 
+  nested_key_value, 
+  con
+) {
+
+  main_key_id <- schm$get_main_key_id
+
+  # check if this table exist
+  if (table_name == "main") {
+    query <- glue::glue("
+      SELECT * 
+      FROM main
+      WHERE {main_key_id} = '{main_key_value}'
+    ")
+  }
+
+  if (table_name != "main") {
+    if(!missing(nested_key_value)) {
+      key_id <- schm$get_key_id(table_name)
+      query <- glue::glue("
+        SELECT * 
+        FROM {table_name}
+        WHERE {main_key_id} = '{main_key_value}' AND {key_id} = '{nested_key_value}'
+      ")
+    } else {
+      query <- glue::glue("
+        SELECT * 
+        FROM {table_name}
+        WHERE {main_key_id} = '{main_key_value}'
+      ")
+    }
+  }
+  DBI::dbGetQuery(con, query)
+}
+
+#' @export
+get_keys_from_table = function(table_name, schm, con) {
+
+  main_key_id <- schm$get_main_key_id
+  DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT {main_key_id} FROM {table_name}")) |>
+    dplyr::pull()
+
+}
+
+#' @export
+get_nested_keys_from_table = function(table_name, schm, main_key_value, con) {
+
+  main_key_id <- schm$get_main_key_id
+  key_id <- schm$get_key_id(table_name)
+
+  DBI::dbGetQuery(con, glue::glue("SELECT DISTINCT {key_id} FROM {table_name} WHERE {main_key_id} == '{main_key_value}'")) |>
+    dplyr::pull()
+
+}
+
+
+### HELPERS ---------
+#' @export
+excel_to_db_dates_converter = function(date) {
+
+  if (is.na(date)) return(NA)
+  # cli::cli_inform("date: {date} | nchar: {nchar(date)} | typeof: {typeof(date)}")
+
+  # если текст, количество символов 7, и маска соответствует 'MM.YYYY'
+  if (typeof(date) == "character") {
+    date <- trimws(date)
+
+    if (nchar(date) == 4 & grepl("((?:19|20)\\d\\d)", date)) {
+      date <- sprintf("%s-01-01", date)
+    } else if (nchar(date) == 7 & grepl("(0?[1-9]|1[012])\\.((?:19|20)\\d\\d)", date)) {
+      # если текст, количество символов 7, и маска соответствует 'MM.YYYY'
+      date <- sprintf("01.%s", date)
+    } else if (nchar(date) == 10 & grepl("([12][0-9]|3[01]|0?[1-9])\\.(0?[1-9]|1[012])\\.((?:19|20)\\d\\d)", date)) {
+      # ...
+    } else if (nchar(date) == 10 & grepl("((?:19|20)\\d\\d)-(0?[1-9]|1[012])-([12][0-9]|3[01]|0?[1-9])", date)) {
+      # ...
+    } else {
+      cli::cli_alert_warning("can't compute date from '{date}'")
+      return(date)
+    }
+  }
+
+  parse_date1 <- tryCatch(
+    as.Date(date, tryFormats = c("%d.%m.%Y", "%Y-%m-%d")),
+    error = function(e) NULL
+  )
+  parse_date2 <- suppressWarnings(as.Date(as.numeric(date), origin = "1899-12-30"))
+
+  fin_date <- if (!is.null(parse_date1)) {
+    parse_date1
+  } else if (!is.na(parse_date2)) {
+    parse_date2
+  } else {
+    date
+  }
+  
+  fin_date <- as.character(format(fin_date, "%Y-%m-%d"))
+  fin_date
+}
+
+#' @export
+local_db_backup <- function(
+  db_name,
+  backups_paths = Sys.getenv("FORM_APP_LOCAL_DB_BACKUP_PATH"),
+  backups_limit = as.integer(Sys.getenv("FORM_APP_LOCAL_DB_BACKUP_LIMITS", 5))
+) {
+  
+  db_path <- fs::path(config::get("form_app_configure_path"), "db")
+  db_full_path <- fs::path(db_path, db_name, ext = "sqlite")
+  
+  backup_folder <- fs::path(backups_paths, db_name)
+  
+  if (!dir.exists(backup_folder)) dir.create(backup_folder, recursive = TRUE)
+  
+  date_mark <- format(Sys.time(), "%Y%m%d")
+  
+  schedule <- c(
+    daily = 1,
+    weekly = 7,
+    monthly = 28
+  )
+  
+  purrr::walk2(
+    .x = schedule,
+    .y = names(schedule),
+    .f = \(schedule_days, schedule_name) {
+  
+      daily_folder  <- fs::path(backup_folder, schedule_name)
+      todays_backup <- fs::path(daily_folder, paste0(db_name, "_", format(Sys.time(), "%Y%m%d")), ext = "sqlite")
+  
+      if (!dir.exists(daily_folder)) dir.create(daily_folder)
+  
+      existed_files <- fs::dir_ls(daily_folder, regexp = "((?:19|20)\\d\\d)(0?[1-9]|1[012])([12][0-9]|3[01]|0?[1-9])")
+      existed_files <- sort(existed_files, decreasing = TRUE)
+  
+      # если бэкап для сегодняшнего дня есть - скипаем процедуру
+      if (todays_backup %in% existed_files) {
+        return()
+      }
+  
+      # парсим даты
+      dates <- stringr::str_extract(existed_files, "((?:19|20)\\d\\d)(0?[1-9]|1[012])([12][0-9]|3[01]|0?[1-9])")
+      dates <- as.Date(dates, "%Y%m%d")
+
+      if (length(existed_files) == 0) {
+        file.copy(db_full_path, todays_backup)
+        cli::cli_alert_success("создан {schedule_name}-бэкап для '{db_name}'")
+        return()
+      }
+
+      # если количество существующих бэкапов превышает установленный лимит, удаляем лишнее
+      if (length(existed_files) >= backups_limit) {
+        file.remove(utils::tail(existed_files, length(existed_files) - backups_limit))
+      }
+
+      # если количество существующих бэкапов равно имеющемуся и пора делать бэкап - делаем бэкап
+      if (dates[1] + schedule_days <= Sys.Date()) {
+
+        file.copy(db_full_path, todays_backup)
+        cli::cli_alert_success("создан {schedule_name}-бэкап для '{db_name}'")
+
+      }
+    }
+  )
+}
+
+#' @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} орфанных записей")
+
+  }
+
+}

R/modules/global_options.R

@@ -0,0 +1,159 @@
+#' @export
+#' @description костыли для упрощения работы себе
+set_global_options = function(
+  SYMBOL_DELIM = "; ",
+  APP.DEBUG = FALSE,
+  shiny.host = "127.0.0.1",
+  shiny.port = 1338,
+  ...
+) {
+  
+  config_params_to_check <- c(
+    "form_app_version",
+    "form_id",
+    "form_name",
+    "form_app_configure_path",
+    "form_auth_enabled",
+    "form_schemes"
+  )
+  
+  expected_params_in_config <- config_params_to_check %in% names(config::get())
+  if (!all(expected_params_in_config)) {
+    cli::cli_abort(c(
+      "Необходимо добавить в файл конфига  {.file config.yml} следующие параметры:", 
+      paste0(config_params_to_check[!expected_params_in_config], ":")
+    ))
+  }
+
+  options(
+    SYMBOL_DELIM = SYMBOL_DELIM,
+    # form.db_path = config::get("form_db_path"),
+    APP.DEBUG = APP.DEBUG,
+    # APP.FILE_DB = APP.FILE_DB,
+    shiny.host = shiny.host,
+    shiny.port = shiny.port,
+    ...
+  )
+}
+
+#' @export
+AUTH_ENABLED <- config::get("form_auth_enabled")
+
+#' @export
+check_and_init_scheme = function() {
+
+  cli::cli_inform(c("*" = "проверка схемы..."))
+
+  options(box.path = here::here())
+  box::use(R/modules/db[local_db_backup])
+
+  # список файлов, изменение которых, приведут к переинициализиации схемы
+  files_to_watch <- c(
+    "config.yml",
+    "R/modules/scheme_generator.R",
+    "R/modules/utils.R"
+  )
+
+  # проверка существования отслеживаемых файлов
+  if (!all(file.exists(files_to_watch))) {
+    cli::cli_abort("проверка схем: {files_to_watch[!file.exists(files_to_watch)]} is not exists")
+  }
+
+  scheme_names <- names(config::get()$form_schemes)
+  scheme_file  <- paste0(config::get("form_app_configure_path"), "/schemas/", scheme_names, ".xlsx")
+  scheme_file  <- stats::setNames(scheme_file, scheme_names)
+
+  if (!all(file.exists(scheme_file))) {
+    cli::cli_abort(c("Отсутствуют файлы схем для следующих наименований:", paste("-", names(scheme_file)[!file.exists(scheme_file)])))
+  }
+  
+  db_files <- paste0(config::get("form_app_configure_path"), "/db/", scheme_names, ".sqlite")
+
+  hash_file   <- "temp/schema_hash.rds"
+
+  # 
+  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))) {
+
+    init_scheme(scheme_file)
+
+  # в ином случае - проверяем кэш
+  } else {
+
+    saved_hash <- readRDS(hash_file)
+
+    # если данные были изменены проводим реинициализацию таблицы и схемы
+    if (!all(exist_hash == saved_hash)) {
+
+      cli::cli_inform(c(">" = "Данные схем были изменены..."))
+      init_scheme(scheme_file)
+
+    } else {
+      cli::cli_alert_success("изменений нет")
+    }
+  }
+
+  # MAKING BACKUPS
+  if (Sys.getenv("FORM_APP_LOCAL_DB_BACKUP_PATH") != "") {
+    cli::cli_inform(c("*" = "создание бэкапов баз данных..."))
+    purrr::walk(scheme_names, local_db_backup)
+    
+  }
+
+  # перезаписываем файл
+  if (!dir.exists("temp")) dir.create("temp")
+  saveRDS(exist_hash, hash_file)
+}
+
+init_scheme = function(scheme_file) {
+
+  options(box.path = here::here())
+  box::use(
+    R/modules/db,
+    R/modules/scheme_generator[scheme_R6]
+  )
+
+  db_path <- fs::path(config::get("form_app_configure_path"), "db")
+  if (!dir.exists(db_path)) dir.create(db_path)
+
+  cli::cli_h1("Инициализация схемы")
+
+  schms <- purrr::map2(
+    .x = scheme_file,
+    .y = names(scheme_file),
+    \(x, y) {
+
+      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
+    }
+  )
+
+  # проверка на наличие дублирующихся названий вложенных таблиц
+  nested_tables_ids <- purrr::map(
+    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, "temp/scheme.rds")
+}

R/modules/scheme_generator.R

@@ -0,0 +1,183 @@
+
+#' @export
+scheme_R6 <- R6::R6Class(
+  "schemes_generator",
+  public = list(
+
+    initialize = function(scheme_file_path = NULL) {
+
+      private$scheme_file_path <- scheme_file_path
+
+      # make list of schemes
+      private$schemes_list <- list()
+      private$schemes_list[["main"]] <- private$load_scheme_from_xlsx("main")
+
+      # имена вложенных форм
+      private$nested_forms_names <- private$schemes_list[["main"]] |>
+        dplyr::filter(form_type == "nested_forms") |>
+        dplyr::distinct(form_id) |>
+        dplyr::pull(form_id)
+
+      # проверка на не пересечение с зарезервированными именами
+      check <- private$reserved_table_names %in% private$nested_forms_names
+      if (any(check)) cli::cli_abort(c("нельзя использовать данные имена вложенных таблиц:", paste("- ", private$reserved_table_names[check])))
+
+      # проверка на длину строк
+      check <- (nchar(private$nested_forms_names) > 31)
+      if (any(check)) cli::cli_abort(c("нельзя использовать имена длиной более 31 символа:", paste("- ", private$nested_forms_names[check])))
+
+      purrr::walk(
+        .x = purrr::set_names(private$nested_forms_names),
+        .f = \(nested_form_id) {
+
+          nested_form_scheme_sheet_name <- private$schemes_list[["main"]] |>
+            dplyr::filter(form_id == {{nested_form_id}}) |>
+            dplyr::distinct(form_id, .keep_all = TRUE) |>
+            dplyr::pull(choices)
+
+          # загрузка схемы для данной вложенной формы
+          private$schemes_list[[nested_form_id]] <<- private$load_scheme_from_xlsx(nested_form_scheme_sheet_name)
+        }
+      )
+
+      # отдельно для тасков
+      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")
+
+      box::use(R/modules/utils)
+      private$bslib_rendered_ui <- bslib::navset_card_underline(
+        id = "main",
+        !!!utils$make_list_of_pages(private$schemes_list[["main"]], private$main_key_id),
+        header = NULL,
+        height = NULL
+      )
+    },
+
+    get_all_ids = function(table_name) {
+
+      private$schemes_list[[table_name]] |>
+        dplyr::filter(!form_type %in% private$excluded_types) |>
+        dplyr::distinct(form_id) |>
+        dplyr::pull(form_id)
+
+    },
+    get_key_id = function(table_name) {
+
+      ids <- self$get_all_ids(table_name)
+      ids[1]
+
+    },
+    get_forms_ids = function(table_name) {
+
+      ids <- self$get_all_ids(table_name)
+      ids[-1]
+
+    },
+
+    # возврат схемы ------------------------------------
+    ## полностью -------
+    get_scheme = function(table_name) {
+      private$schemes_list[[table_name]]
+    },
+
+    ## с полями имеющие значение -------
+    get_scheme_with_values_forms = function(table_name) {
+      private$schemes_list[[table_name]] |>
+        dplyr::filter(!form_type %in% private$excluded_types)
+    },
+
+    get_id_type_list = function(table_name) {
+
+      # wo main key
+      this_key_id <- self$get_key_id(table_name)
+
+      private$schemes_list[[table_name]] |>
+        dplyr::filter(!form_type %in% private$excluded_types) |>
+        dplyr::filter(form_id != {{this_key_id}}) |>
+        dplyr::distinct(form_id, form_type) |>
+        tibble::deframe()
+    }
+  ),
+  active = list(
+    get_main_key_id = function() {
+      private$main_key_id
+    },
+    all_tables_names = function() {
+      c("main", private$nested_forms_names)
+    },
+    nested_tables_names = function() {
+      private$nested_forms_names
+    },
+    get_main_form_ui = function() {
+      private$bslib_rendered_ui
+    }
+  ),
+  private = list(
+    scheme_file_path = NA,
+    schemes_list = NULL,
+    main_key_id = NA,
+    nested_forms_names = NA,
+    bslib_rendered_ui = NA,
+    excluded_types = c("nested_forms", "description", "description_header"),
+    reserved_table_names = c("meta", "log", "main", "tasks"),
+
+    load_scheme_from_xlsx = function(sheet_name) {
+
+      colnames <- switch(sheet_name,
+        "main" = c("part", "subgroup", "form_id", "form_label", "form_type"),
+        c("subgroup", "form_id", "form_label", "form_type")
+      )
+
+      table <- readxl::read_xlsx(private$scheme_file_path, sheet = sheet_name) |>
+        # fill NA down
+        tidyr::fill(all_of(colnames), .direction = "down") |>
+        dplyr::group_by(form_id) |>
+        tidyr::fill(c(condition, required), .direction = "down") |>
+        dplyr::ungroup()
+
+      duplicate_ids <- table |>
+        dplyr::mutate(rleid = dplyr::consecutive_id(form_id)) |>
+        dplyr::distinct(form_id, rleid) |>
+        dplyr::count(form_id) |>
+        dplyr::filter(n > 1) |>
+        dplyr::pull(form_id)
+      
+      if (length(duplicate_ids) > 0) {
+        cli::cli_abort(c("В схеме '{private$scheme_file_path}' для формы '{sheet_name}' содержатся повторяющиеся id:", paste("-", duplicate_ids)))
+      }
+
+      # проверка на корректные id
+      input_names_with_dash <- unique(table$form_id)[grepl("-", unique(table$form_id))]
+      if (length(input_names_with_dash) > 0) {
+        cli::cli_abort(c("В схеме '{private$scheme_file_path}' в id форм содержатся `-`, может привести к некорректной последующей работой с базой данных", paste("-", input_names_with_dash)))
+      }
+
+      table
+    }
+  )
+)
+
+# 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

R/modules/utils.R

@@ -0,0 +1,387 @@
+#' @export
+make_list_of_pages = function(main_schema, main_key_id) {
+
+  purrr::map(
+    .x = unique(main_schema$part),
+    .f = \(page_name) {
+
+      # отделить схему для каждой страницы
+      this_page_panels_scheme <- main_schema |>
+        dplyr::filter(!form_id %in% main_key_id) |>
+        dplyr::filter(part == {{page_name}})
+
+      this_page_panels <- make_panels(this_page_panels_scheme)
+
+      # add panel wrap to nav_panel
+      bslib::nav_panel(
+        title = page_name,
+        this_page_panels
+      )
+    }
+  )
+}
+
+#' @export
+make_panels = function(scheme) {
+
+  cards <- purrr::map(
+    .x = unique(scheme$subgroup),
+    .f = \(sub_group) {
+
+      this_column_cards_scheme <- scheme |>
+        dplyr::filter(subgroup == {{sub_group}})
+
+      bslib::card(
+        bslib::card_header(sub_group, container = htmltools::h5),
+        full_screen = TRUE,
+        fill = TRUE,
+        width = "4000px",
+        bslib::card_body(
+          fill = TRUE,
+          # передаем все аргументы в функцию для создания елементов
+          purrr::pmap(
+            .l = dplyr::distinct(this_column_cards_scheme, form_id, form_label, form_type),
+            .f = render_forms,
+            main_scheme = scheme
+          )
+        )
+      )
+    }
+  )
+
+  # make page wrap
+  bslib::layout_column_wrap(
+    # width = "350px", height = NULL, #was 800
+    width = 1 / 4, height = NULL, # was 800
+    fixed_width = TRUE,
+    heights_equal = "row",
+    # unpack list of cards
+    !!!cards
+  )
+}
+
+#' @export
+render_forms = function(
+  form_id,
+  form_label,
+  form_type,
+  main_scheme,
+  ns
+) {
+
+  # заготовку для формы (проверка на выходе функции)
+  form <- NULL
+
+  # параметры только для этой формы
+  filterd_line <- main_scheme |>
+    dplyr::filter(form_id == {{form_id}})
+
+  # если передана ns() функция то подмеяем id для каждой формы в соответствии с пространством имен
+  if (!missing(ns)) {
+    form_id <- ns(form_id)
+  }
+
+  # отдельно извлечение параметров условного отображения
+  condition <- unique(filterd_line$condition)
+
+  # элементы выбора 
+  choices <- filterd_line$choices
+
+  # описание 
+  description <- unique(filterd_line) |>
+    dplyr::filter(!is.na(form_description)) |>
+    dplyr::distinct(form_description) |>
+    dplyr::pull()
+
+  # описание
+  if (length(description) > 1) {
+    rlang::abort(sprintf(
+      "%s - более чем 1 уникальный вариант описания:\n%s", form_id, paste0(description, collapse = "\n")
+    ))
+  } else if (length(description) == 0) {
+    description <- NA
+  }
+
+  # отдельно создаем заголовки
+  label <- if (is.na(description) && is.na(form_label)) {
+    NULL
+  } else {
+    shiny::tagList(
+      if (!is.na(form_label)) {
+        shiny::span(form_label, style = "color: #444444; font-weight: 550; line-height: 1.4;")
+        # если в схеме есть поле с описанием - добавляем его следующей строчкой
+      },
+      if (!is.na(description) && !is.na(form_label)) shiny::br(),
+      if (!is.na(description)) {
+        shiny::span(shiny::markdown(description)) |> htmltools::tagAppendAttributes(style = "color:gray; font-size:small; line-height: 1.4;")
+      }
+    )
+  }
+
+  # 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 = label,
+      rows = rows_to_show
+    )
+  }
+
+  if (form_type == "number") {
+    form <- shiny::textAreaInput(
+      inputId = form_id,
+      label = label,
+      rows = 1,
+      resize = "none"
+    )
+  }
+
+  # 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 = 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 = label,
+      choices = choices,
+      selected = NULL,
+      options = list(
+        create = TRUE,
+        onInitialize = I('function() { this.setValue(""); }')
+      )
+    )
+  }
+
+  # множественный выбор
+  if (form_type == "select_multiple") {
+    form <- shiny::selectizeInput(
+      inputId = form_id,
+      label = label,
+      choices = choices,
+      selected = NULL,
+      multiple = TRUE,
+      options = list(
+        create = TRUE,
+        onInitialize = I('function() { this.setValue(""); }')
+      )
+    )
+  }
+
+  # множественный выбор
+  if (form_type == "radio") {
+    form <- shiny::radioButtons(
+      inputId = form_id,
+      label = label,
+      choices = choices,
+      selected = character(0)
+    )
+  }
+
+  if (form_type == "checkbox") {
+    form <- shiny::checkboxGroupInput(
+      inputId = form_id,
+      # label = label,
+      label = shiny::h6(form_label),
+      choices = choices,
+      selected = character(0)
+    )
+  }
+
+  # вложенная форма
+  if (form_type == "nested_forms") {
+    form <- shiny::actionButton(inputId = form_id, label = label)
+  }
+
+  # description part
+  if (form_type == "description") {
+    if (is.na(form_label)) {
+      form <- shiny::hr(style = "margin-bottom: -3px;")
+    } else {
+      form <- shiny::div(shiny::HTML(form_label), style = "color: Gray; font-size: 90%;")
+    }
+  }
+
+  if (form_type == "description_header") {
+    form <- shiny::h5(
+      label,
+      style = "margin-bottom: -8px; margin-top: 10px;"
+    )
+  }
+
+  # если есть условие создать кондитионал панель
+  if (!is.na(condition)) {
+    form <- shiny::conditionalPanel(
+      condition = condition,
+      form,
+      ns = ifelse(missing(ns), shiny::NS(NULL), ns)
+    )
+  }
+
+  if (is.null(form)) cli::cli_abort("невозможно создать форму типа '{form_type}' (id: '{form_id}') !")
+  form
+}
+
+
+# SERVER LOGIC ==========================
+#' @export
+#' @description
+#' Функция возращает пустое значение для каждого типа формы
+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(
+  form_id,
+  form_type,
+  value,
+  scheme,
+  local_delimeter = getOption("SYMBOL_DELIM"),
+  ns
+) {
+
+  options(box.path = here::here())
+  box::use(R/modules/data_manipulations[is_this_empty_value])
+
+  # print("-----------------")
+  # cli::cli_inform("form_id: {form_id} | form_type: {form_type}")
+  # print(value)
+  # print(typeof(value))
+  # print(is_this_empty_value(value))
+
+  filterd_line <- scheme |>
+    dplyr::filter(form_id == {{form_id}})
+
+  # если передана ns() функция то подмеяем id для каждой формы в соответствии с пространством имен
+  if (!missing(ns) & !is.null(ns)) {
+    form_id <- ns(form_id)
+  }
+
+  if (form_type == "text") {
+    shiny::updateTextAreaInput(inputId = form_id, value = value)
+  }
+
+  if (form_type == "number") {
+    shiny::updateTextAreaInput(inputId = form_id, value = value)
+  }
+
+  # supress warnings when applying NA or NULL to date input form
+  if (form_type == "date") {
+    suppressWarnings(
+      shiny::updateDateInput(inputId = form_id, value = value)
+    )
+  }
+
+  # select_one
+  if (form_type == "select_one") {
+    # update choices
+    old_choices <- filterd_line$choices
+    new_choices <- unique(c(old_choices, value))
+    new_choices <- new_choices[!is.na(new_choices)]
+
+    shiny::updateSelectizeInput(inputId = form_id, selected = value, choices = new_choices)
+  }
+
+  # select_multiple
+  # check if value is not NA and split by delimetr
+  if (form_type == "select_multiple") {
+    if (is_this_empty_value(value)) {
+      shiny::updateSelectizeInput(inputId = form_id, selected = as.character(0))
+    } else {
+      vars <- stringr::str_split_1(value, local_delimeter)
+
+      # update choices
+      old_choices <- filterd_line$choices
+      new_choices <- unique(c(old_choices, vars))
+      new_choices <- new_choices[!is.na(new_choices)]
+      shiny::updateSelectizeInput(inputId = form_id, selected = vars, choices = new_choices)
+    }
+  }
+
+  # radio buttons
+  if (form_type == "radio") {
+    if (is_this_empty_value(value)) {
+      shiny::updateRadioButtons(inputId = form_id, selected = character(0))
+    } else {
+      # update choices
+      old_choices <- filterd_line$choices
+      new_choices <- unique(c(old_choices, value))
+      new_choices <- new_choices[!is.na(new_choices)]
+
+      shiny::updateRadioButtons(inputId = form_id, selected = value, choices = new_choices)
+    }
+  }
+
+  # checkboxes
+  if (form_type == "checkbox") {
+
+    if (is_this_empty_value(value)) {
+      shiny::updateCheckboxGroupInput(inputId = form_id, selected = character(0))
+    } else {
+
+      vars <- stringr::str_split_1(value, local_delimeter)
+  
+      # update choices
+      old_choices <- filterd_line$choices
+      new_choices <- unique(c(old_choices, vars))
+      new_choices <- new_choices[!is.na(new_choices)]
+  
+      shiny::updateCheckboxGroupInput(inputId = form_id, selected = vars, choices = new_choices)
+    }
+
+  }
+
+}
+
+#' @export
+clean_forms = function(
+  table_name,
+  schm, 
+  ns
+) {
+
+ # если передана ns() функция то подмеяем id для каждой формы в соответствии с пространством имен
+  if (missing(ns)) ns <- NULL
+  id_and_types_list <- schm$get_id_type_list(table_name)
+
+  purrr::walk2(
+    .x = id_and_types_list,
+    .y = names(id_and_types_list),
+    .f = \(x_type, x_id) {
+      
+      # using function to update forms
+      update_forms_with_data(
+        form_id   = x_id,
+        form_type = x_type,
+        value     = get_empty_data(x_type),
+        scheme = schm$get_scheme(table_name),
+        ns = ns
+      )
+    }
+  )
+}