Merge pull request #274 from thekangaroofactory/v0.5.0-beta

v0.5.0Beta - Milestone delivery

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,

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)

R/dynamic_sidebar.R

@@ -2,29 +2,26 @@
 
 #' 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){
     menuSubItem(text = name, tabName = name,
                 icon = shiny::icon("angle-double-right"))}
 
   # -- Apply helper
-  subitems <- lapply(dm_list, FUN = helper)
+  subitems <- lapply(names, FUN = helper)
 
   # -- Return sidebar
   sidebarMenu(

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){
 

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")
 
 }

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")
 
 }

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
 

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)
 
   # ----------------------------------------------------------------------------
 

R/item_update.R

@@ -2,30 +2,35 @@
 
 #' 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
 #' The item$id value will be used to replace the corresponding item in the items data.frame
 #'
 #' @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")
 
 }

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"))))
 
 }