diff --git a/DESCRIPTION b/DESCRIPTION index c60c97c..b55c1a2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: kitems -Title: Framework to manage data.frame items -Version: 0.4.0.0000 +Title: Framework To Manage Data.frame Items +Version: 0.4.2 Authors@R: person(given = "philippe", family = "peret", @@ -11,8 +11,9 @@ License: GPL (>=3) Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.2 +RoxygenNote: 7.3.1 Depends: + R (>= 3.5.0), shiny, shinydashboard, shinyWidgets, diff --git a/NAMESPACE b/NAMESPACE index 1058bc3..01690d3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand export(admin_ui) +export(clicked_column_name) export(create_BTN) export(data_model) export(date_slider_INPUT) @@ -38,6 +39,7 @@ export(kitemsManager_Server) export(runExample) export(selected_items_name) export(trigger_add_name) +export(trigger_create_name) export(trigger_delete_name) export(trigger_save_name) export(trigger_update_name) diff --git a/R/dm_get_list.R b/R/dm_get_list.R deleted file mode 100644 index f54abfa..0000000 --- a/R/dm_get_list.R +++ /dev/null @@ -1,26 +0,0 @@ - - -#' Available data models -#' -#' @param r the shared reactive communication object -#' -#' @return a list with the names (ids) of the data models available in session -#' -#' @examples -#' \dontrun{ -#' dm_get_list(r) -#' } - - -dm_get_list <- function(r){ - - # -- Get data models from r - values <- isolate(reactiveValuesToList(r)) - values <- names(values) - values <- values[grep("_data_model", values)] - values <- strsplit(values, "_data_model") - - # -- Return - values - -} diff --git a/R/dynamic_sidebar.R b/R/dynamic_sidebar.R index b9e1bec..88d9478 100644 --- a/R/dynamic_sidebar.R +++ b/R/dynamic_sidebar.R @@ -2,21 +2,18 @@ #' Generate dynamic menuItem #' -#' @param r the reactive shared communication object +#' @param names a list of the data model names #' #' @return a sidebarMenu menuItem object with one menuSubItem per data model #' @export #' #' @examples #' \dontrun{ -#' dynamic_sidebar(r) +#' dynamic_sidebar(names = list("data", "data2")) #' } -dynamic_sidebar <- function(r){ - - # -- Get data model list - dm_list <- dm_get_list(r = r) +dynamic_sidebar <- function(names){ # -- Helper: return sub item helper <- function(name){ @@ -24,7 +21,7 @@ dynamic_sidebar <- function(r){ icon = shiny::icon("angle-double-right"))} # -- Apply helper - subitems <- lapply(dm_list, FUN = helper) + subitems <- lapply(names, FUN = helper) # -- Return sidebar sidebarMenu( diff --git a/R/inputList.R b/R/inputList.R index 97a4b95..97699f4 100644 --- a/R/inputList.R +++ b/R/inputList.R @@ -78,9 +78,13 @@ inputList <- function(ns, item = NULL, update = FALSE, data.model){ if(is.character(value)) value <- as.logical(value) + # -- check NA (in case no default has been set) #246 + if(is.na(value)) + value <- FALSE + # -- input input <- checkboxInput(inputId = ns(names(colClasses)), - label = "logical", + label = names(colClasses), value = value, width = NULL) } @@ -95,6 +99,11 @@ inputList <- function(ns, item = NULL, update = FALSE, data.model){ cat(" - Filter out attributes to skip:", skip, "\n") colClasses <- colClasses[!names(colClasses) %in% skip] + # -- check + # when id is the only attribute, colClasses will be empty #243 + if(length(colClasses) == 0) + return("Warning: there is no attribute that requires an input value (all attributes are skipped!).") + # -- Define default input values if(update){ diff --git a/R/item_add.R b/R/item_add.R index b6fca0e..f8cd777 100644 --- a/R/item_add.R +++ b/R/item_add.R @@ -3,19 +3,26 @@ #' Add item #' #' @param item an item data.frame to be added -#' @param items the items data.frame +#' @param items the reference! of the reactive value carrying the items +#' @param name an optional character string to display along with the notification (basically the name of the item) #' -#' @return the updated items data.frame #' @export #' #' @examples #' \dontrun{ -#' item_add(items = myitems, item = mynewitem) +#' item_add(items = myitems, item = mynewitem, name = "myitem") #' } -item_add <- function(items, item){ +item_add <- function(items, item, name = NULL){ - # -- rbind - items <- rbind(items, item) + # -- check items + stopifnot("reactiveVal" %in% class(items)) + + # -- rbind & store + items(rbind(items(), item)) + + # -- notify + if(shiny::isRunning()) + showNotification(paste(name, "Item created."), type = "message") } diff --git a/R/item_delete.R b/R/item_delete.R index 3360037..9dfbff9 100644 --- a/R/item_delete.R +++ b/R/item_delete.R @@ -2,21 +2,35 @@ #' Delete item #' -#' @param items a data.frame of the items +#' @param items the reference! of the reactive value carrying the items #' @param id the id of the item to delete +#' @param name a character string used inside the notification (typically the name of the items) #' #' @return an updated data.frame of the items #' @export #' #' @examples #' \dontrun{ -#' item_delete(items = myitems, id = 123456789) +#' item_delete(items = myitems, id = 123456789, name = "myitems") #' } -item_delete <- function(items, id){ +item_delete <- function(items, id, name = NULL){ - # -- drop item - items[!items$id %in% id, ] + # -- check items + stopifnot("reactiveVal" %in% class(items)) + + # -- trace + MODULE <- paste0("[", ifelse(is.null(name), "kitems", name), "]") + cat(MODULE, "Delete item(s) \n") + cat("-- Item(s) to be deleted =", as.character(id), "\n") + + # -- drop item & store + x <- items()[!items()$id %in% id, ] + items(x) + + # -- notify + if(shiny::isRunning()) + showNotification(paste(MODULE, "Item(s) deleted."), type = "message") } diff --git a/R/item_load.R b/R/item_load.R index 63183a7..e0d8cc1 100644 --- a/R/item_load.R +++ b/R/item_load.R @@ -29,6 +29,20 @@ item_load <- function(data.model, file = NULL, path = NULL, create = TRUE){ col.classes <- dm_colClasses(data.model) + # ---------------------------------------------------------------------------- + # Ensure timezone continuity #269 + # ---------------------------------------------------------------------------- + # datetime will be read as character (and converted later) + + # -- get datetime index + idx_ct <- which(col.classes %in% "POSIXct") + idx_lt <- which(col.classes %in% c("POSIXlt")) + + # -- convert classes + if(length(c(idx_ct, idx_lt)) > 0) + col.classes[c(idx_ct, idx_lt)] <- "character" + + # ---------------------------------------------------------------------------- # Connector: file (.csv) # ---------------------------------------------------------------------------- @@ -47,6 +61,28 @@ item_load <- function(data.model, file = NULL, path = NULL, create = TRUE){ if(all(dim(items) == c(0,0))) items <- NULL + else { + + # -------------------------------------------------------------------------- + # Ensure timezone continuity #269 + # -------------------------------------------------------------------------- + # convert ISO 8601 character vector to POSIXct, POSIXlt + # output will get an extra tzone attribute compared to original object, + # but values are the same + + # -- POSIXct + if(length(idx_ct) > 0){ + cat("[item_load] Converting attribute(s) to POSIXct =", names(col.classes[idx_ct]), "\n") + items[idx_ct] <- lapply(items[idx_ct], function(x) as.POSIXct(x, format = "%Y-%m-%dT%H:%M:%S%z", tz = ""))} + + # -- POSIXlt + if(length(idx_lt) > 0){ + cat("[item_load] Converting attribute(s) to POSIXlt =", names(col.classes[idx_lt]), "\n") + items[idx_lt] <- lapply(items[idx_lt], function(x) as.POSIXct(x, format = "%Y-%m-%dT%H:%M:%S%z", tz = ""))} + + } + + # -- return items diff --git a/R/item_save.R b/R/item_save.R index 1b3ebb7..c211d0f 100644 --- a/R/item_save.R +++ b/R/item_save.R @@ -3,8 +3,7 @@ #' Save data #' #' @param data a data.frame containing the data to be saved -#' @param file an optional file name (including .csv extension) -#' @param path an optional path to the file +#' @param file the url of the file (including path & .csv extension) #' #' @export #' @@ -14,22 +13,33 @@ #' @examples #' \dontrun{ #' # -- File connector: -#' item_save(data = mydata, file = "mydata.csv", path = "path/to/my/data") +#' item_save(data = mydata, file = "path/to/my/data/mydata.csv") #' } -item_save <- function(data, file = NULL, path = NULL){ +item_save <- function(data, file = NULL){ + + # -------------------------------------------------------------------------- + # Ensure timezone continuity #269 + # -------------------------------------------------------------------------- + + # -- get datetime index + # To avoid adding data.model to the function signature, get classes from data + classes <- lapply(data, function(x) class(x)[1]) + idx <- which(classes %in% c("POSIXct", "POSIXlt")) + + # -- convert to ISO 8601 character format + if(length(idx) > 0){ + cat("[item_save] Convert datetime attribute(s) to ISO-8601 =", names(data[idx]), "\n") + data[idx] <- format(data[idx], "%FT%H:%M:%S%z")} + # ---------------------------------------------------------------------------- # Connector: file (.csv) # ---------------------------------------------------------------------------- - if(!is.null(file)) - - # -- Write - kfiles::write_data(data = data, - file = file, - path = path) + if(!is.null(file)) + kfiles::write_data(data, file) # ---------------------------------------------------------------------------- diff --git a/R/item_update.R b/R/item_update.R index 7766992..52c4e6c 100644 --- a/R/item_update.R +++ b/R/item_update.R @@ -2,10 +2,10 @@ #' Update item #' -#' @param items a data.frame of the items -#' @param item the items to be updated +#' @param items the reference! of the reactiveVal carrying the data.frame of the items +#' @param item the item to be updated +#' @param name a character string used inside the notification (typically the name of the items) #' -#' @return an updated data.frame of the items #' @export #' #' @details @@ -13,19 +13,24 @@ #' #' @examples #' \dontrun{ -#' item_update(items = myitems, item = myupdateditem) +#' item_update(items = myitems, item = myupdateditem, name = "myitem") #' } -item_update <- function(items, item){ +item_update <- function(items, item, name = NULL){ - # -- get target item id - id <- item$id + # -- check items + stopifnot("reactiveVal" %in% class(items)) - # -- update row - items[items$id == id, ] <- item + # -- get value & update + x <- items() + x[x$id == item$id, ] <- item - # -- return - items + # -- store + items(x) + + # -- notify + if(shiny::isRunning()) + showNotification(paste(name, "Item updated."), type = "message") } diff --git a/R/kitems_inputs_ui.R b/R/kitems_inputs_ui.R index 975bb31..13bf30f 100644 --- a/R/kitems_inputs_ui.R +++ b/R/kitems_inputs_ui.R @@ -18,6 +18,8 @@ date_slider_INPUT <- function(id){ ns <- NS(id) # UI - uiOutput(ns("date_slider")) + fluidRow( + column(width = 6, uiOutput(ns("date_slider"))), + column(width = 6, uiOutput(ns("date_slider_strategy")))) } diff --git a/R/kitems_module_server.R b/R/kitems_module_server.R index a05e70c..6aa9555 100644 --- a/R/kitems_module_server.R +++ b/R/kitems_module_server.R @@ -31,6 +31,9 @@ kitemsManager_Server <- function(id, r, path, create = TRUE, autosave = TRUE) { moduleServer(id, function(input, output, session) { + # -- check reactive #240 + stopifnot(class(r) == "reactivevalues") + # -- Check path (to avoid connection problems if missing folder) if(!dir.exists(path)) dir.create(path) @@ -64,34 +67,17 @@ kitemsManager_Server <- function(id, r, path, items_url <- file.path(path, paste0(items_name(id), ".csv")) # -- Build object names from module id (to access outside module) - r_data_model <- dm_name(id) - r_items <- items_name(id) r_filtered_items <- filtered_items_name(id) r_selected_items <- selected_items_name(id) + r_clicked_column <- clicked_column_name(id) r_filter_date <- filter_date_name(id) # -- Declare reactive objects (for external use) - r[[r_items]] <- reactiveVal(NULL) r[[r_filtered_items]] <- reactiveVal(NULL) r[[r_selected_items]] <- reactiveVal(NULL) + r[[r_clicked_column]] <- reactiveVal(NULL) r[[r_filter_date]] <- reactiveVal(NULL) - # -- Build triggers names from module id - trigger_add <- trigger_add_name(id) - trigger_update <- trigger_update_name(id) - trigger_delete <- trigger_delete_name(id) - trigger_save <- trigger_save_name(id) - - # -- Declare reactive objects (for external use) - r[[trigger_add]] <- reactiveVal(NULL) - r[[trigger_update]] <- reactiveVal(NULL) - r[[trigger_delete]] <- reactiveVal(NULL) - r[[trigger_save]] <- reactiveVal(0) - cat(MODULE, "trigger_add available @", trigger_add, "\n") - cat(MODULE, "trigger_update available @", trigger_update, "\n") - cat(MODULE, "trigger_delete available @", trigger_delete, "\n") - cat(MODULE, "trigger_save available @", trigger_save, "\n") - # -------------------------------------------------------------------------- # Initialize data model and items: @@ -177,10 +163,10 @@ kitemsManager_Server <- function(id, r, path, # ------------------------------------------------------------------------ # -- Store data model (either content of the RDS or the server function input) - r[[r_data_model]] <- reactiveVal(data.model) + k_data_model <- reactiveVal(data.model) # -- Store items - r[[r_items]]<- reactiveVal(items) + k_items <- reactiveVal(items) # Increment the progress bar, and update the detail text. incProgress(4/4, detail = "done") @@ -194,10 +180,10 @@ kitemsManager_Server <- function(id, r, path, # -- Check parameter & observe data model if(autosave) - observeEvent(r[[r_data_model]](), { + observeEvent(k_data_model(), { # -- Write & notify - saveRDS(r[[r_data_model]](), file = dm_url) + saveRDS(k_data_model(), file = dm_url) cat(MODULE, "[EVENT] Data model has been (auto) saved \n") }, ignoreInit = TRUE) @@ -209,12 +195,10 @@ kitemsManager_Server <- function(id, r, path, # -- Check parameter & observe items if(autosave) - observeEvent(r[[r_items]](), { + observeEvent(k_items(), { # -- Write - item_save(data = r[[r_items]](), - file = items_url, - path = path) + item_save(data = k_items(), file = items_url) # -- Notify cat(MODULE, "[EVENT] Item list has been (auto) saved \n") @@ -222,72 +206,6 @@ kitemsManager_Server <- function(id, r, path, }, ignoreInit = TRUE) - # -------------------------------------------------------------------------- - # Triggers: - # -------------------------------------------------------------------------- - - # -- Observe: trigger_add - observeEvent(r[[trigger_add]](), { - - # -- add item to list & store - cat(MODULE, "[TRIGGER] Add item \n") - item_list <- item_add(r[[r_items]](), r[[trigger_add]]()) - r[[r_items]](item_list) - - # -- notify - if(is_running) - showNotification(paste(MODULE, "Item created."), type = "message") - - }, ignoreInit = TRUE) - - - # -- Observe: trigger_update - observeEvent(r[[trigger_update]](), { - - # -- add item to list & store - cat(MODULE, "[TRIGGER] Update item \n") - item_list <- item_update(r[[r_items]](), r[[trigger_update]]()) - r[[r_items]](item_list) - - # -- notify - if(is_running) - showNotification(paste(MODULE, "Item updated."), type = "message") - - }, ignoreInit = TRUE) - - - # -- Observe: trigger_delete - observeEvent(r[[trigger_delete]](), { - - # -- add item to list & store - cat(MODULE, "[TRIGGER] Delete item(s) \n") - cat("-- Item(s) to be deleted =", as.character(r[[trigger_delete]]()), "\n") - item_list <- item_delete(r[[r_items]](), r[[trigger_delete]]()) - r[[r_items]](item_list) - - # -- notify - if(is_running) - showNotification(paste(MODULE, "Item(s) deleted."), type = "message") - - }, ignoreInit = TRUE) - - - # -- Observe: trigger_save (items) - observeEvent(r[[trigger_save]](), { - - # -- Write - item_save(data = r[[r_items]](), - file = items_url, - path = path) - - # -- Notify - cat(MODULE, "[TRIGGER] Item list has been saved \n") - if(is_running) - showNotification(paste(MODULE, "Items saved."), type = "message") - - }, ignoreInit = TRUE) - - # -------------------------------------------------------------------------- # Declare filtered items: # -------------------------------------------------------------------------- @@ -298,13 +216,17 @@ kitemsManager_Server <- function(id, r, path, cat(MODULE, "Updating filtered item view \n") # -- Get items - items <- r[[r_items]]() + items <- k_items() # -- Apply date filter filter_date <- r[[r_filter_date]]() if(!is.null(filter_date)) items <- items[items$date >= filter_date[1] & items$date <= filter_date[2], ] + # -- Apply ordering + if(!is.null(filter_date)) + items <- items[order(items$date, decreasing = TRUE), ] + cat(MODULE, "ouput dim =", dim(items), "\n") # -- Return @@ -346,21 +268,24 @@ kitemsManager_Server <- function(id, r, path, # -------------------------------------------------------------------------- # -- Raw view for admin - output$raw_item_table <- DT::renderDT(r[[r_items]](), + output$raw_item_table <- DT::renderDT(k_items(), rownames = FALSE, options = list(lengthMenu = c(5, 10, 15), pageLength = 5, dom = "t", scrollX = TRUE), selection = list(mode = 'single', target = "row", selected = NULL)) # -- Masked view for admin (reuse of r_view_items) - output$view_item_table <- DT::renderDT(view_apply_masks(r[[r_data_model]](), r[[r_items]]()), + output$view_item_table <- DT::renderDT(view_apply_masks(k_data_model(), k_items()), rownames = FALSE, selection = list(mode = 'single', target = "row", selected = NULL)) # -- colClasses for admin # setting rownames = FALSE #209 - output$data_model <- DT::renderDT(dm_table_mask(r[[r_data_model]]()), + # setting dom = "tpl" instead of "t" #245 + # allowing display all #244 + output$data_model <- DT::renderDT(dm_table_mask(k_data_model()), rownames = FALSE, - options = list(lengthMenu = c(5, 10, 15), pageLength = 10, dom = "t", scrollX = TRUE), + options = list(lengthMenu = list(c(20, 50, -1), c('20', '50', 'All')), + pageLength = 20, dom = "tpl", scrollX = TRUE), selection = list(mode = 'single', target = "row", selected = isolate(input$data_model_rows_selected))) @@ -369,12 +294,12 @@ kitemsManager_Server <- function(id, r, path, # -------------------------------------------------------------------------- # -- Default view (reuse of r_view_items, includes dm masks) - output$default_view <- DT::renderDT(view_apply_masks(r[[r_data_model]](), r[[r_items]]()), + output$default_view <- DT::renderDT(view_apply_masks(k_data_model(), k_items()), rownames = FALSE, selection = list(mode = 'multiple', target = "row", selected = NULL)) # -- Filtered view - output$filtered_view <- DT::renderDT(view_apply_masks(r[[r_data_model]](), r[[r_filtered_items]]()), + output$filtered_view <- DT::renderDT(view_apply_masks(k_data_model(), r[[r_filtered_items]]()), rownames = FALSE, selection = list(mode = 'multiple', target = "row", selected = NULL)) @@ -395,7 +320,7 @@ kitemsManager_Server <- function(id, r, path, cat(MODULE, "Selected rows (default view) =", input$default_view_rows_selected, "\n") # -- Get item ids from the default view - ids <- r[[r_items]]()[input$default_view_rows_selected, ]$id + ids <- k_items()[input$default_view_rows_selected, ]$id cat("-- ids =", as.character(ids), "\n") } @@ -429,21 +354,45 @@ kitemsManager_Server <- function(id, r, path, }, ignoreNULL = FALSE) + # -- Filtered view + observeEvent(input$filtered_view_cell_clicked$col, { + + # -- Get table col names (need to apply masks to get correct columns, hence sending only first row) + cols <- colnames(view_apply_masks(k_data_model(), head(r[[r_filtered_items]](), n = 1))) + + # -- Get name of the clicked column + col_clicked <- cols[input$filtered_view_cell_clicked$col + 1] + cat(MODULE, "Clicked column (filtered view) =", col_clicked, "\n") + + # -- Store + r[[r_clicked_column]](col_clicked) + + }, ignoreNULL = TRUE) + + # -------------------------------------------------------------------------- # Declare outputs: Inputs # -------------------------------------------------------------------------- + # -- date slider options + output$date_slider_strategy <- renderUI(radioButtons(inputId = ns("date_slider_strategy"), + label = "Strategy", + choices = c("this-year", "keep-range"), + selected = "this-year", + inline = TRUE)) + + # -- Declare output: output$date_slider <- renderUI({ # -- check data model - if(hasDate(r[[r_data_model]]())){ + if(hasDate(k_data_model())){ # -- Get min/max - if(dim(r[[r_items]]())[1] > 0){ + if(dim(k_items())[1] > 0){ - min <- min(r[[r_items]]()$date) - max <- max(r[[r_items]]()$date) + min <- min(k_items()$date) + max <- max(k_items()$date) } else { @@ -457,7 +406,8 @@ kitemsManager_Server <- function(id, r, path, # -- Set value # implement this_year strategy by default #211 - value <- if(is.null(range)) + # keep this year after item is added #223 & #242 + value <- if(is.null(input$date_slider_strategy) || input$date_slider_strategy == "this-year") ktools::date_range(min, max, type = "this_year") else value <- range @@ -474,12 +424,14 @@ kitemsManager_Server <- function(id, r, path, }) + # -- Observe: date_slider observeEvent(input$date_slider, { cat(MODULE, "Date sliderInput has been updated: \n") cat("-- values =", input$date_slider, "\n") + # -- store r[[r_filter_date]](input$date_slider) }) @@ -495,7 +447,7 @@ kitemsManager_Server <- function(id, r, path, output$admin_dm_tab <- renderUI({ # -- check NULL data model - if(is.null(r[[r_data_model]]())){ + if(is.null(k_data_model())){ # -- display create / import btns fluidRow(column(width = 12, @@ -533,7 +485,7 @@ kitemsManager_Server <- function(id, r, path, output$admin_raw_tab <- renderUI({ # -- check NULL data model - if(!is.null(r[[r_data_model]]())){ + if(!is.null(k_data_model())){ # -- display raw table fluidRow(column(width = 2, @@ -553,7 +505,7 @@ kitemsManager_Server <- function(id, r, path, output$admin_view_tab <- renderUI({ # -- check NULL data model - if(!is.null(r[[r_data_model]]())){ + if(!is.null(k_data_model())){ # -- display view table fluidRow(column(width = 2, @@ -687,8 +639,8 @@ kitemsManager_Server <- function(id, r, path, items <- item_check_integrity(items = items, data.model = data.model) # -- Store items & data model - r[[r_items]](items) - r[[r_data_model]](data.model) + k_items(items) + k_data_model(data.model) # -- notify if(is_running) @@ -709,7 +661,7 @@ kitemsManager_Server <- function(id, r, path, output$dm_danger_btn <- renderUI( # -- Check for NULL data model - if(!is.null(r[[r_data_model]]())) + if(!is.null(k_data_model())) shinyWidgets::materialSwitch(inputId = ns("adm_dz_toggle"), label = "Danger zone", value = FALSE, @@ -730,7 +682,7 @@ kitemsManager_Server <- function(id, r, path, # -- select attribute name selectizeInput(inputId = ns("dm_dz_att_name"), label = "Name", - choices = r[[r_data_model]]()$name, + choices = k_data_model()$name, selected = NULL, options = list(create = FALSE, placeholder = 'Type or select an option below', @@ -763,14 +715,16 @@ kitemsManager_Server <- function(id, r, path, removeModal() # -- drop column! & store - items <- r[[r_items]]() + cat(MODULE, "Drop attribute from all items \n") + items <- k_items() items[input$dm_dz_att_name] <- NULL - r[[r_items]](items) + k_items(items) # -- update data model & store - dm <- r[[r_data_model]]() + cat(MODULE, "Drop attribute from data model \n") + dm <- k_data_model() dm <- dm[dm$name != input$dm_dz_att_name, ] - r[[r_data_model]](dm) + k_data_model(dm) }) @@ -824,29 +778,32 @@ kitemsManager_Server <- function(id, r, path, # Implement template #220 template <- TEMPLATE_DATA_MODEL[TEMPLATE_DATA_MODEL$name == "id", ] colClasses <- c("id" = template$type) + default_val <- c("id" = template$default.val) + default_fun <- c("id" = template$default.fun) filter <- if(template$filter) c("id") else NULL skip <- if(template$skip) c("id") else NULL # -- init data model & store cat(MODULE, "-- Building data model \n") dm <- data_model(colClasses = colClasses, - default.val = template$default.val, - default.fun = template$default.fun, + default.val = default_val, + default.fun = default_fun, filter = filter, skip = skip) # -- store - r[[r_data_model]](dm) + k_data_model(dm) # -- init items + # create = autosave : so that file won't be created if autosave is FALSE #271 cat(MODULE, "-- Init data \n") items <- kfiles::read_data(file = items_url, path = path, colClasses = colClasses, - create = TRUE) + create = autosave) # -- store items - r[[r_items]](items) + k_items(items) }) @@ -880,7 +837,7 @@ kitemsManager_Server <- function(id, r, path, # Add attribute to the data model & store - dm <- r[[r_data_model]]() + dm <- k_data_model() dm <- dm_add_attribute(data.model = dm, name = input$dm_att_name, type = input$dm_att_type, @@ -890,18 +847,18 @@ kitemsManager_Server <- function(id, r, path, filter = FALSE) # -- store - r[[r_data_model]](dm) + k_data_model(dm) # -- get default value value <- dm_get_default(data.model = dm, name = input$dm_att_name) # -- Add column to items & store - items <- item_add_attribute(r[[r_items]](), name = input$dm_att_name, type = input$dm_att_type, fill = value) - r[[r_items]](items) + items <- item_add_attribute(k_items(), name = input$dm_att_name, type = input$dm_att_type, fill = value) + k_items(items) # -- update form # in case an attribute from template was added, it's necessary to drop it from available choices - output$dm_att_form <- dm_inputs_ui(names = TEMPLATE_DATA_MODEL$name[!TEMPLATE_DATA_MODEL$name %in% colnames(r[[r_items]]())], + output$dm_att_form <- dm_inputs_ui(names = TEMPLATE_DATA_MODEL$name[!TEMPLATE_DATA_MODEL$name %in% colnames(k_items())], types = OBJECT_CLASS, ns = ns) @@ -914,28 +871,34 @@ kitemsManager_Server <- function(id, r, path, # -- get selected row row <- input$data_model_rows_selected + # -- check out of limit value #272 + # If last row is selected and attribute is deleted, a crash would occur + if(!is.null(row)) + if(row > nrow(k_data_model())) + row <- NULL + # -- check NULL (no row selected) if(is.null(row)){ # -- update form (creation mode, only if r_items not NULL) - if(is.null(r[[r_items]]())) + if(is.null(k_items())) output$dm_att_form <- NULL else - output$dm_att_form <- dm_inputs_ui(names = TEMPLATE_DATA_MODEL$name[!TEMPLATE_DATA_MODEL$name %in% colnames(r[[r_items]]())], + output$dm_att_form <- dm_inputs_ui(names = TEMPLATE_DATA_MODEL$name[!TEMPLATE_DATA_MODEL$name %in% colnames(k_items())], types = OBJECT_CLASS, ns = ns) } else { # -- get attribute to update - attribute <- r[[r_data_model]]()[row, ] + attribute <- k_data_model()[row, ] # -- update form (update mode) output$dm_att_form <- dm_inputs_ui(update = TRUE, attribute = attribute, ns = ns) } - }, ignoreNULL = FALSE) + }, ignoreNULL = FALSE, ignoreInit = TRUE) # -- observe upd_att button @@ -950,21 +913,34 @@ kitemsManager_Server <- function(id, r, path, row <- input$data_model_rows_selected # -- get data model - dm <- r[[r_data_model]]() + dm <- k_data_model() # -- default val & fun - if(input$dm_default_choice == "none"){ - default_val <- NA - default_fun <- NA + # check: in case of id, attribute has no default choice + # hence input$dm_default_choice is not reliable in this case #248 + if(dm[row, ]$name != "id"){ - } else { - if(input$dm_default_choice == "val"){ - default_val <- input$dm_att_default_detail - default_fun <- NULL + if(input$dm_default_choice == "none"){ + default_val <- NA + default_fun <- NA } else { - default_val <- NULL - default_fun <- input$dm_att_default_detail}} + + if(input$dm_default_choice == "val"){ + default_val <- input$dm_att_default_detail + default_fun <- NULL + + } else { + default_val <- NULL + default_fun <- input$dm_att_default_detail}} + + } else { + + # -- when attribute is id + default_val <- NULL + default_fun <- input$dm_att_default_detail + + } # -- skip (force for id) skip <- if(dm[row, ]$name != "id") @@ -980,7 +956,7 @@ kitemsManager_Server <- function(id, r, path, skip = skip) # -- store - r[[r_data_model]](dm) + k_data_model(dm) }) @@ -993,7 +969,7 @@ kitemsManager_Server <- function(id, r, path, output$dm_sort_buttons <- renderUI( # -- check NULL data model - if(is.null(r[[r_data_model]]())) + if(is.null(k_data_model())) NULL else { @@ -1003,8 +979,8 @@ kitemsManager_Server <- function(id, r, path, # order attribute name selectizeInput(inputId = ns("dm_order_cols"), label = "Select cols order", - choices = r[[r_data_model]]()$name, - selected = r[[r_data_model]]()$name, + choices = k_data_model()$name, + selected = k_data_model()$name, multiple = TRUE))}) @@ -1012,17 +988,17 @@ kitemsManager_Server <- function(id, r, path, observeEvent(input$dm_order_cols, { # -- Check - req(length(input$dm_order_cols) == dim(r[[r_items]]())[2]) + req(length(input$dm_order_cols) == dim(k_items())[2]) cat("[BTN] Reorder column \n") # -- Reorder items & store - r[[r_items]](r[[r_items]]()[input$dm_order_cols]) + k_items(k_items()[input$dm_order_cols]) # -- Reorder data model & store - dm <- r[[r_data_model]]() + dm <- k_data_model() dm <- dm[match(input$dm_order_cols, dm$name), ] - r[[r_data_model]](dm) + k_data_model(dm) }) @@ -1035,13 +1011,13 @@ kitemsManager_Server <- function(id, r, path, output$adm_filter_buttons <- renderUI( # -- check NULL data model - if(is.null(r[[r_data_model]]())) + if(is.null(k_data_model())) NULL else { # -- init params - filter_cols <- dm_filter(r[[r_data_model]]()) + filter_cols <- dm_filter(k_data_model()) onInitialize <- if(is.null(filter_cols)) I('function() { this.setValue(""); }') @@ -1051,7 +1027,7 @@ kitemsManager_Server <- function(id, r, path, # -- define input selectizeInput(inputId = ns("adm_filter_col"), label = "Filter columns", - choices = r[[r_data_model]]()$name, + choices = k_data_model()$name, selected = filter_cols, multiple = TRUE, options = list(create = FALSE, @@ -1063,12 +1039,12 @@ kitemsManager_Server <- function(id, r, path, observeEvent(input$adm_filter_col, { cat("[BTN] Filter columns:", input$adm_filter_col, "\n") - dm <- r[[r_data_model]]() + dm <- k_data_model() # -- Check NULL data model if(!is.null(dm)){ dm <- dm_filter_set(data.model = dm, filter = input$adm_filter_col) - r[[r_data_model]](dm)} + k_data_model(dm)} }, ignoreInit = TRUE, ignoreNULL = FALSE) @@ -1082,15 +1058,14 @@ kitemsManager_Server <- function(id, r, path, label = "Create")) # -- Observe: create_btn - observeEvent(input$create_btn, { + observeEvent(input$create_btn, - showModal(modalDialog(inputList(ns, item = NULL, update = FALSE, data.model = r[[r_data_model]]()), - title = "Create", - footer = tagList( - modalButton("Cancel"), - actionButton(ns("confirm_create_btn"), "Create")))) + showModal(modalDialog(inputList(ns, item = NULL, update = FALSE, data.model = k_data_model()), + title = "Create", + footer = tagList( + modalButton("Cancel"), + actionButton(ns("confirm_create_btn"), "Create"))))) - }) # -- Observe: confirm_create_btn observeEvent(input$confirm_create_btn, { @@ -1102,14 +1077,14 @@ kitemsManager_Server <- function(id, r, path, # -- get list of input values & name it cat("-- Get list of input values \n") - input_values <- get_input_values(input, dm_colClasses(r[[r_data_model]]())) + input_values <- get_input_values(input, dm_colClasses(k_data_model())) # -- create item based on input list cat("-- Create item \n") - item <- item_create(values = input_values, data.model = r[[r_data_model]]()) + item <- item_create(values = input_values, data.model = k_data_model()) - # -- call trigger - r[[trigger_add]](item) + # -- update reactive + item_add(k_items, item, name = id) }) @@ -1135,10 +1110,10 @@ kitemsManager_Server <- function(id, r, path, cat(MODULE, "[EVENT] Update item \n") # -- Get selected item - item <- r[[r_items]]()[r[[r_items]]()$id == r[[r_selected_items]](), ] + item <- k_items()[k_items()$id == r[[r_selected_items]](), ] # -- Dialog - showModal(modalDialog(inputList(ns, item = item, update = TRUE, data.model = r[[r_data_model]]()), + showModal(modalDialog(inputList(ns, item = item, update = TRUE, data.model = k_data_model()), title = "Update", footer = tagList( modalButton("Cancel"), @@ -1156,18 +1131,18 @@ kitemsManager_Server <- function(id, r, path, # -- get list of input values & name it cat("-- Get list of input values \n") - input_values <- get_input_values(input, dm_colClasses(r[[r_data_model]]())) + input_values <- get_input_values(input, dm_colClasses(k_data_model())) # -- update id (to replace selected item) input_values$id <- r[[r_selected_items]]() # -- create item based on input list cat("-- Create item \n") - item <- item_create(values = input_values, data.model = r[[r_data_model]]()) + item <- item_create(values = input_values, data.model = k_data_model()) # -- update item & store - cat("-- Call update trigger \n") - r[[trigger_update]](item) + cat("-- Update item \n") + item_update(k_items, item, name = id) }) @@ -1209,19 +1184,22 @@ kitemsManager_Server <- function(id, r, path, # -- close modal removeModal() - # -- get selected items (ids) & call trigger + # -- get selected items (ids) & delete ids <- r[[r_selected_items]]() - r[[trigger_delete]](ids) + item_delete(k_items, ids, name = id) }) # -------------------------------------------------------------------------- - # Sandbox: + # Module server return value: # -------------------------------------------------------------------------- - - + # -- the reference (not the value!) + list(id = id, + url = items_url, + items = k_items, + data_model = k_data_model) }) } diff --git a/R/kitems_names.R b/R/kitems_names.R index 35fd117..b8fd847 100644 --- a/R/kitems_names.R +++ b/R/kitems_names.R @@ -52,6 +52,19 @@ filtered_items_name <- function(id){paste0(id, "_filtered_items")} selected_items_name <- function(id){paste0(id, "_selected_items")} +#' Clicked column name +#' +#' @param id the id of the module server instance +#' +#' @return the name of the corresponding reactive value +#' @export +#' +#' @examples +#' clicked_column_name(id = "mydata") + +clicked_column_name <- function(id){paste0(id, "_clicked_column")} + + #' Filter date name #' #' @param id the id of the module server instance @@ -115,3 +128,16 @@ trigger_save_name <- function(id){paste0(id, "_trigger_save")} #' trigger_update_name(id = "mydata") trigger_update_name <- function(id){paste0(id, "_trigger_update")} + + +#' Trigger create name +#' +#' @param id the id of the module server instance +#' +#' @return the name of the corresponding reactive value +#' @export +#' +#' @examples +#' trigger_create_name(id = "mydata") + +trigger_create_name <- function(id){paste0(id, "_trigger_create")} diff --git a/README.Rmd b/README.Rmd index b9d40a0..7224e8e 100644 --- a/README.Rmd +++ b/README.Rmd @@ -98,6 +98,7 @@ from the r object passed as an argument of the module server): - r[[items]] - r[[filtered_items]] - r[[selected_items]] +- r[[clicked_column]] - r[[filter_date]] - r[[trigger_add]] - r[[trigger_update]] @@ -375,6 +376,27 @@ tabItem(tabName = "my_data", kitems::admin_ui("my_data")))) ``` +### Nested module considerations + +In case the kitemsManager_Server module server function is called from +inside a module (i.e. as a nested module), then it is not possible to +call the UI functions from the main app with the nested module id. + +From there, two options are available: + +- wrap the package UI functions into functions from the calling module + (encapsulation)\ + For example, you could create an action_BTN function that would + implement create_BTN, update_BTN and delete_BTN into a single UI + +- call the package UI functions directly from the main app using + multiple namespaces:\ + (as specified in the shiny::NS function) + +```{r nested_module, eval=FALSE} + kitems::admin_ui(c("module_id", "nested_module_id")) +``` + ## Import & migration When the module server is initialized with data.model = NULL, an import diff --git a/README.md b/README.md index d4594f4..bb0cecf 100644 --- a/README.md +++ b/README.md @@ -73,6 +73,7 @@ from the r object passed as an argument of the module server): - r\[[items](#items)\] - r\[\[filtered_items\]\] - r\[\[selected_items\]\] +- r\[\[clicked_column\]\] - r\[\[filter_date\]\] - r\[\[trigger_add\]\] - r\[\[trigger_update\]\] @@ -345,6 +346,27 @@ tabItem(tabName = "my_data", kitems::admin_ui("my_data")))) ``` +### Nested module considerations + +In case the kitemsManager_Server module server function is called from +inside a module (i.e. as a nested module), then it is not possible to +call the UI functions from the main app with the nested module id. + +From there, two options are available: + +- wrap the package UI functions into functions from the calling module + (encapsulation) + For example, you could create an action_BTN function that would + implement create_BTN, update_BTN and delete_BTN into a single UI + +- call the package UI functions directly from the main app using + multiple namespaces: + (as specified in the shiny::NS function) + +``` r + kitems::admin_ui(c("module_id", "nested_module_id")) +``` + ## Import & migration When the module server is initialized with data.model = NULL, an import diff --git a/inst/shiny-examples/demo/server.R b/inst/shiny-examples/demo/server.R index b35966c..1185847 100644 --- a/inst/shiny-examples/demo/server.R +++ b/inst/shiny-examples/demo/server.R @@ -25,13 +25,13 @@ shinyServer( # ------------------------------------- # -- start module server: data - kitems::kitemsManager_Server(id = "data", r = r, path = demo_dir, - create = TRUE, autosave = FALSE) + data <- kitems::kitemsManager_Server(id = "data", r = r, path = demo_dir, + create = TRUE, autosave = FALSE) # -- start module server: data_2 - kitems::kitemsManager_Server(id = "data_2", r = r, path = demo_dir, - create = TRUE, autosave = FALSE) + data_2 <- kitems::kitemsManager_Server(id = "data_2", r = r, path = demo_dir, + create = TRUE, autosave = FALSE) # ------------------------------------- @@ -39,16 +39,16 @@ shinyServer( # ------------------------------------- # -- data - observeEvent(r$data_items(), { + observeEvent(data$items(), { - cat("Main application server observeEvent: data_items() has just been updated \n") + cat("Main application server observeEvent: data_1() has just been updated \n") }) # -- data_2 - observeEvent(r$data_2_items(), { + observeEvent(data_2$items(), { - cat("Main application server observeEvent: data2_items() has just been updated \n") + cat("Main application server observeEvent: data_2() has just been updated \n") }) @@ -58,7 +58,7 @@ shinyServer( # ------------------------------------- # -- adding pkg::fun() call #205 - output$menu <- renderMenu(kitems::dynamic_sidebar(r)) + output$menu <- renderMenu(kitems::dynamic_sidebar(names = list("data", "data_2"))) } diff --git a/man/clicked_column_name.Rd b/man/clicked_column_name.Rd new file mode 100644 index 0000000..d2d28ea --- /dev/null +++ b/man/clicked_column_name.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/kitems_names.R +\name{clicked_column_name} +\alias{clicked_column_name} +\title{Clicked column name} +\usage{ +clicked_column_name(id) +} +\arguments{ +\item{id}{the id of the module server instance} +} +\value{ +the name of the corresponding reactive value +} +\description{ +Clicked column name +} +\examples{ +clicked_column_name(id = "mydata") +} diff --git a/man/dm_get_list.Rd b/man/dm_get_list.Rd deleted file mode 100644 index 5ad6091..0000000 --- a/man/dm_get_list.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/dm_get_list.R -\name{dm_get_list} -\alias{dm_get_list} -\title{Available data models} -\usage{ -dm_get_list(r) -} -\arguments{ -\item{r}{the shared reactive communication object} -} -\value{ -a list with the names (ids) of the data models available in session -} -\description{ -Available data models -} -\examples{ -\dontrun{ -dm_get_list(r) -} -} diff --git a/man/dynamic_sidebar.Rd b/man/dynamic_sidebar.Rd index 3a78d31..9e7abcc 100644 --- a/man/dynamic_sidebar.Rd +++ b/man/dynamic_sidebar.Rd @@ -4,10 +4,10 @@ \alias{dynamic_sidebar} \title{Generate dynamic menuItem} \usage{ -dynamic_sidebar(r) +dynamic_sidebar(names) } \arguments{ -\item{r}{the reactive shared communication object} +\item{names}{a list of the data model names} } \value{ a sidebarMenu menuItem object with one menuSubItem per data model @@ -17,6 +17,6 @@ Generate dynamic menuItem } \examples{ \dontrun{ -dynamic_sidebar(r) +dynamic_sidebar(names = list("data", "data2")) } } diff --git a/man/item_add.Rd b/man/item_add.Rd index 85e6bf3..bb40ba0 100644 --- a/man/item_add.Rd +++ b/man/item_add.Rd @@ -4,21 +4,20 @@ \alias{item_add} \title{Add item} \usage{ -item_add(items, item) +item_add(items, item, name = NULL) } \arguments{ -\item{items}{the items data.frame} +\item{items}{the reference! of the reactive value carrying the items} \item{item}{an item data.frame to be added} -} -\value{ -the updated items data.frame + +\item{name}{an optional character string to display along with the notification (basically the name of the item)} } \description{ Add item } \examples{ \dontrun{ -item_add(items = myitems, item = mynewitem) +item_add(items = myitems, item = mynewitem, name = "myitem") } } diff --git a/man/item_delete.Rd b/man/item_delete.Rd index 9526984..6be5592 100644 --- a/man/item_delete.Rd +++ b/man/item_delete.Rd @@ -4,12 +4,14 @@ \alias{item_delete} \title{Delete item} \usage{ -item_delete(items, id) +item_delete(items, id, name = NULL) } \arguments{ -\item{items}{a data.frame of the items} +\item{items}{the reference! of the reactive value carrying the items} \item{id}{the id of the item to delete} + +\item{name}{a character string used inside the notification (typically the name of the items)} } \value{ an updated data.frame of the items @@ -19,6 +21,6 @@ Delete item } \examples{ \dontrun{ -item_delete(items = myitems, id = 123456789) +item_delete(items = myitems, id = 123456789, name = "myitems") } } diff --git a/man/item_save.Rd b/man/item_save.Rd index 74b9b70..8ded6fa 100644 --- a/man/item_save.Rd +++ b/man/item_save.Rd @@ -4,14 +4,12 @@ \alias{item_save} \title{Save data} \usage{ -item_save(data, file = NULL, path = NULL) +item_save(data, file = NULL) } \arguments{ \item{data}{a data.frame containing the data to be saved} -\item{file}{an optional file name (including .csv extension)} - -\item{path}{an optional path to the file} +\item{file}{the url of the file (including path & .csv extension)} } \description{ Save data @@ -22,6 +20,6 @@ File connector: if file is not NULL, then data is saved to .csv \examples{ \dontrun{ # -- File connector: -item_save(data = mydata, file = "mydata.csv", path = "path/to/my/data") +item_save(data = mydata, file = "path/to/my/data/mydata.csv") } } diff --git a/man/item_update.Rd b/man/item_update.Rd index 41aab47..b72af00 100644 --- a/man/item_update.Rd +++ b/man/item_update.Rd @@ -4,15 +4,14 @@ \alias{item_update} \title{Update item} \usage{ -item_update(items, item) +item_update(items, item, name = NULL) } \arguments{ -\item{items}{a data.frame of the items} +\item{items}{the reference! of the reactiveVal carrying the data.frame of the items} -\item{item}{the items to be updated} -} -\value{ -an updated data.frame of the items +\item{item}{the item to be updated} + +\item{name}{a character string used inside the notification (typically the name of the items)} } \description{ Update item @@ -22,6 +21,6 @@ The item$id value will be used to replace the corresponding item in the items da } \examples{ \dontrun{ -item_update(items = myitems, item = myupdateditem) +item_update(items = myitems, item = myupdateditem, name = "myitem") } } diff --git a/man/trigger_create_name.Rd b/man/trigger_create_name.Rd new file mode 100644 index 0000000..8dd37c3 --- /dev/null +++ b/man/trigger_create_name.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/kitems_names.R +\name{trigger_create_name} +\alias{trigger_create_name} +\title{Trigger create name} +\usage{ +trigger_create_name(id) +} +\arguments{ +\item{id}{the id of the module server instance} +} +\value{ +the name of the corresponding reactive value +} +\description{ +Trigger create name +} +\examples{ +trigger_create_name(id = "mydata") +} diff --git a/tests/testthat/test-kitemsManager_Server.R b/tests/testthat/test-kitemsManager_Server.R index 482048a..8d10f3d 100644 --- a/tests/testthat/test-kitemsManager_Server.R +++ b/tests/testthat/test-kitemsManager_Server.R @@ -1250,3 +1250,21 @@ test_that("Import data without id works", { # -------------------------------------------------------------------------- clean_all(testdata_path) + + +test_that("r not reactive fails", { + + # -- dummy + dummy <- 1 + + # -- declare arguments + params <- list(id = module_id, + r = dummy, + path = testdata_path, + create = FALSE, + autosave = FALSE) + + # -- module server call + expect_error(testServer(kitemsManager_Server, args = params)) + +})