adds alert class to status for read_delim

NAMESPACE

@@ -8,12 +8,16 @@ export(dygraph_sidebar_side)
 export(dygraph_ui_input)
 export(dygraph_ui_misc)
 export(dygraph_ui_output)
+export(observe_class_swap)
 export(pre_scroll)
 export(read_delim_server)
 export(read_delim_sidebar_main)
+export(read_delim_sidebar_server)
 export(read_delim_sidebar_side)
 export(read_delim_ui_input)
+export(read_delim_ui_misc)
 export(read_delim_ui_output)
+export(status_content)
 export(update_selected)
 export(write_delim_main)
 export(write_delim_server)

R/dygraph.R

@@ -115,7 +115,7 @@ dygraph_ui_misc <- function(id) {
 #'
 #' Used to define the server within the \code{dygraph} shiny module.
 #'
-#' @family read_delim module functions
+#' @family dygraph module functions
 #
 #' @param input   standard \code{shiny} input
 #' @param output  standard \code{shiny} output

R/read_delim.R

@@ -54,7 +54,6 @@ read_delim_ui_input <- function(id){
       choices = c(Point = ".", Comma = ",")
     )
 
-
   # specify timezones
   tz_choice <- c("UTC", lubridate::olson_time_zones())
 
@@ -84,6 +83,7 @@ read_delim_ui_input <- function(id){
 #' This function returns a \code{shiny::\link[shiny]{tagList}} with members:
 #'
 #' \describe{
+#'  \item{status}{\code{shiny::\link[shiny]{htmlOutput}}, used to display status of the module}
 #'  \item{text}{\code{shiny::\link[shiny]{htmlOutput}}, used to display first few lines of text from file}
 #'  \item{data}{\code{shiny::\link[shiny]{htmlOutput}}, used to display first few lines of the parsed dataframe}
 #' }
@@ -104,6 +104,12 @@ read_delim_ui_output <- function(id){
 
   ui_output <- shiny::tagList()
 
+  ui_output$status <-
+    shiny::htmlOutput(
+      outputId = ns("status"),
+      container = pre_scroll
+    )
+
   # text output
   ui_output$text <-
     shiny::htmlOutput(
@@ -167,17 +173,19 @@ read_delim_ui_misc <- function(id){
 #' @param delim   character, default for parsing delimiter
 #' @param decimal_mark character, default for decimal mark
 #'
-#' @return a \code{shiny::\link[shiny]{reactive}} containing a tbl_df of the parsed text
+#' @return a list with members:
+#' \code{rct_txt} \code{shiny::\link[shiny]{reactive}}, returns raw text
+#' \code{rct_data} \code{shiny::\link[shiny]{reactive}}, returns tbl_df of the parsed text
 #'
 #' @examples
 #' shinyServer(function(input, output, session) {
 #'
-#'   rct_data <- callModule(
+#'   list_rct <- callModule(
 #'     module = read_delim_server,
 #'     id = "foo"
 #'   )
 #'
-#'   observe(print(rct_data()))
+#'   observe(print(list_rct$rct_data()))
 #' })
 #'
 #' @export
@@ -241,23 +249,57 @@ read_delim_server <- function(
     df
   })
 
+  # status
+  rctval_status <-
+    shiny::reactiveValues(
+      input = list(index = 0, is_valid = NULL, message = NULL),
+      result = list(index = 0, is_valid = NULL, message = NULL)
+    )
+
+  rct_status_content <- reactive(status_content(rctval_status))
+
   ## observers ##
   ###############
 
-  # shows and hides controls based on the availabilty and nature of data
-  shiny::observe({
+  # input
+  observeEvent(
+    eventExpr = input$file,
+    handlerExpr = {
 
-    has_data <- !is.null(rct_data())
-    has_numeric <- length(df_names_inherits(rct_data(), "numeric")) > 0
-    has_time_non_8601 <- df_has_time_non_8601(rct_txt(), delim = input$delim)
-    has_time <- length(df_names_inherits(rct_data(), "POSIXct")) > 0
+      rctval_status$input$index <- rctval_status$input$index + 1
 
-    shinyjs::toggle("delim", condition = has_data)
-    shinyjs::toggle("decimal_mark", condition = has_numeric)
-    shinyjs::toggle("tz_parse", condition = has_time_non_8601)
-    shinyjs::toggle("tz_display", condition = has_time)
+      if (is.null(input$file)){
+        rctval_status$input$is_valid <- FALSE
+        rctval_status$input$message <- "Please select a file"
+      } else {
+        rctval_status$input$is_valid <- TRUE
+        rctval_status$input$message <- ""
+      }
 
-  })
+    },
+    ignoreNULL = FALSE, # makes sure we evaluate on initialization
+    priority = 1 # always execute before others
+  )
+
+  # result
+  observeEvent(
+    eventExpr = input$file,
+    handlerExpr = {
+
+      rctval_status$result$index <- rctval_status$input$index
+
+      if (is.null(input$file$datapath)){
+        rctval_status$result$is_valid <- FALSE
+        rctval_status$result$message <- paste("Cannot find file:", input$file$name)
+      } else {
+        rctval_status$result$is_valid <- TRUE
+        rctval_status$result$message <- paste("Uploaded file:", input$file$name)
+      }
+
+    }
+  )
+
+  # observe(print(paste(rctval_status$input$index, rctval_status$result$index)))
 
   # updates the display tz if the parse tz changes
   shiny::observeEvent(
@@ -271,10 +313,14 @@ read_delim_server <- function(
     }
   )
 
+  observe_class_swap(id = "status", rct_status_content()$class)
 
   ## outputs ##
   #############
 
+  output$status <-
+    shiny::renderText(rct_status_content()$message)
+
   # sets the output for the raw text
   output$text <-
     shiny::renderUI({
@@ -298,15 +344,14 @@ read_delim_server <- function(
       h <-
         withr::with_options(
           list(width = 10000, dpylr.width = Inf, dplyr.print_min = 6),
-          capture.output(print(rct_data()))
+          utils::capture.output(print(rct_data()))
         )
       h <- paste(h, collapse = "<br/>")
       h <- shiny::HTML(h)
 
       h
     })
 
-
-  # returns a dataframe
-  rct_data
+  # returns a list
+  list(rct_txt = rct_txt, rct_data = rct_data)
 }

R/read_delim_sidebar.R

@@ -65,7 +65,54 @@ read_delim_sidebar_side <- function(id){
 #
 read_delim_sidebar_main <- function(id){
 
-  read_delim_ui_output(id)
+  main_elems <- read_delim_ui_output(id)
+
+  main_elems$text <- shinyjs::hidden(main_elems$text)
+  main_elems$data <- shinyjs::hidden(main_elems$data)
+
+  main_elems
 }
 
+# note we are initializing the show/hide functions here, but controlling at the definition level
+
+#' @seealso read_delim_sidebar_main
+#' @rdname read_delim_server
+#' @export
+#
+read_delim_sidebar_server <- function(
+  input, output, session,
+  delim = ",",
+  decimal_mark = "."
+){
+
+  ## reactives ##
+  ###############
+
+  list_rct <- read_delim_server(input, output, session, delim, decimal_mark)
 
+  rct_txt <- list_rct$rct_txt
+  rct_data <- list_rct$rct_data
+
+  ## observers ##
+  ###############
+
+  # shows and hides controls based on the availabilty and nature of data
+  shiny::observe({
+
+    has_text <- !is.null(rct_txt())
+    has_data <- !is.null(rct_data())
+    has_numeric <- length(df_names_inherits(rct_data(), "numeric")) > 0
+    has_time_non_8601 <- df_has_time_non_8601(rct_txt(), delim = input$delim)
+    has_time <- length(df_names_inherits(rct_data(), "POSIXct")) > 0
+
+    shinyjs::toggle("text", condition = has_text)
+    shinyjs::toggle("data", condition = has_data)
+    shinyjs::toggle("delim", condition = has_data)
+    shinyjs::toggle("decimal_mark", condition = has_numeric)
+    shinyjs::toggle("tz_parse", condition = has_time_non_8601)
+    shinyjs::toggle("tz_display", condition = has_time)
+
+  })
+
+  list_rct
+}

R/utils.R

@@ -177,4 +177,93 @@ update_selected <- function(value, choices, index = NULL){
   selected
 }
 
+#' swap out classes on an html element
+#'
+#' This function stores the value of the last class to be added (using this function),
+#' then removes that class before addding the new class. For example, this may be useful
+#' if you want to modify a panel to show an alert.
+#'
+#' As this is an observer, there is no return value. It is called for the side-effect of
+#' changing the class of the html element.
+#'
+#' This is based on \code{shiny::renderText()}
+#'
+#' @param id A character vector to identify the html element to operate on.
+#' @param expr An expression that returns a character vector to add to the html element.
+#' @param env The environment in which to evaluate \code{expr}.
+#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
+#'   is useful if you want to save an expression in a variable.
+#' @return nothing
+#' @export
+#
+observe_class_swap <- function(id, expr, env = parent.frame(), quoted = FALSE){
+
+  func <- shiny::exprToFunction(expr, env, quoted)
+
+  # we use a reactive value to persist the value of the class we added previously
+  rctval <- reactiveValues(class_current = NULL)
+
+  shiny::observeEvent(
+    eventExpr = func(),
+    handlerExpr = {
+      # print(paste(rctval$class_current, func(), sep = " -> "))
+      shinyjs::removeClass(id = id, rctval$class_current)
+      shinyjs::addClass(id = id, func())
+      rctval$class_current <- func()
+    }
+  )
+
+}
+
+#' use input and result to generate message and class of status
+#'
+#' The argument \code{status} shall be a list with two members: \code{input} and \code{result}.
+#' Each of those lists shall have components \code{index}, \code{is_valid}, and \code{message}.
+#'
+#' This return value is a list with members \code{class} and \code{message}. The \code{class} can be used by
+#' \link{observe_class_swap} to change the appearance of an output. The \code{message} can be used as the
+#' text displayed by the output.
+#'
+#' @param status  list with components \code{input} and \code{result}
+#'
+#' @return list with components \code{class} and \code{message}
+#' @export
+#
+status_content <- function(status){
+
+  is_danger <-
+    identical(status$result$is_valid, FALSE) &&
+    identical(status$result$index, status$input$index)
+
+  is_warning <- identical(status$input$is_valid, FALSE)
+
+  is_info <-
+    !is.null(status$result$is_valid) &&
+    !identical(status$input$index, status$result$index)
+
+  is_success <- status$result$is_valid
+
+  if (is_danger) {
+    class <- "alert-danger"
+    message <- status$result$message
+  } else if (is_warning) {
+    class <- "alert-warning"
+    message <- status$input$message
+  } else if (is_info) {
+    class <- "alert-info"
+    message <- paste("Inputs have changed since generation of results",
+                     status$input$message,
+                     sep = "\n\n")
+  } else if (is_success){
+    class <- "alert-success"
+    message <- status$result$message
+  } else {
+    class <- NULL
+    message <- status$input$message
+  }
+
+  list(class = class, message = message)
+}
+
+
 

inst/shiny/read_delim/server.R

@@ -5,6 +5,6 @@ library("shinypod")
 
 shinyServer(function(input, output, session) {
 
-  rct_data <- callModule(module = read_delim_server, id = "csv")
+  rct_data <- callModule(module = read_delim_sidebar_server, id = "csv")
 
 })

inst/shiny/read_delim/ui.R

@@ -1,5 +1,4 @@
 library("shiny")
-library("shinyBS")
 library("shinyjs")
 library("shinypod")