simplify the javascript code for sanitizing and validating the dose table, and apply similar rules to other handsontables (the ability to convert 5:80 -> 06:20, disallowing typing illegal characters, removing extra colons or periods, accepting either clock or relative times depending on the mode)

R/app_server.R

@@ -1016,6 +1016,7 @@ app_server <- function(input, output, session) {
         ) %>%
         hot_col(
           col = "Dose",
+          type = "numeric",
           halign = "htRight"
         ) %>%
         hot_col(
@@ -1029,7 +1030,8 @@ app_server <- function(input, output, session) {
         ) %>%
         hot_context_menu(allowRowEdit = TRUE, allowColEdit = FALSE) %>%
         hot_rows(rowHeights = 10) %>%
-        hot_cols(colWidths = c(50,55,55,90))
+        hot_cols(colWidths = c(50,55,55,90)) %>%
+        addHotHooks(filterKeys = TRUE, sanitize = TRUE)
 
       editPriorDosesTableHOT
     }, name = "output$editPriorDosesTable")
@@ -1191,8 +1193,7 @@ app_server <- function(input, output, session) {
           ) %>%
           hot_col(
             col = "Time",
-            halign = "htRight",
-            format = "0"
+            halign = "htRight"
           ) %>%
           hot_col(
             col = "Event",
@@ -1201,11 +1202,12 @@ app_server <- function(input, output, session) {
             strict = TRUE,
             halign = "htLeft",
             valign = "vtMiddle",
-            allowInvalid=FALSE
+            allowInvalid = FALSE
           ) %>%
           hot_context_menu(allowRowEdit = TRUE, allowColEdit = FALSE) %>%
           hot_rows(rowHeights = 10) %>%
           hot_cols(colWidths = c(50,55,90))
+
         output$editEventsTableHTML <- renderRHandsontable(tempTableHOT)
         showModal(
           modalDialog(
@@ -1388,6 +1390,7 @@ app_server <- function(input, output, session) {
           ) %>%
           hot_col(
             col = "Target",
+            type = "numeric",
             halign = "htRight"
           ) %>%
           hot_context_menu(
@@ -1399,7 +1402,9 @@ app_server <- function(input, output, session) {
           ) %>%
           hot_cols(
             colWidths = c(70,70)
-          )
+          ) %>%
+          addHotHooks(filterKeys = TRUE, sanitize = TRUE)
+
         output$targetTableHTML <- renderRHandsontable(targetHOT)
         showModal(
           modalDialog(

R/createHOT.R

@@ -24,8 +24,7 @@ createHOT <- function(doseTable,drugDefaults)
     rhandsontable::hot_col(
       col = "Dose",
       type = "numeric",
-      halign = "htRight",
-      validator = "function(value, callback) {callback(true)}"
+      halign = "htRight"
     ) %>%
     rhandsontable::hot_col(
       col = "Units",
@@ -52,20 +51,7 @@ createHOT <- function(doseTable,drugDefaults)
     HOT$x$cell <- c(HOT$x$cell, list(cell))
   }
 
-  HOT <- htmlwidgets::onRender(HOT,
-                               "
-function(el, x) {
+  HOT <- addHotHooks(HOT, filterKeys = TRUE, sanitize = TRUE, afterChange = "hookDoseTableUpdate")
 
-  var hot = this.hot;
-  // do this to avoid adding duplicate callbacks on re-render
-  hot.removeHook('beforeKeyDown', beforeKeyDownHot);
-  hot.removeHook('beforeChange', beforeChangeHot);
-  hot.removeHook('afterChange', changeHot);
-  hot.addHook('beforeKeyDown', beforeKeyDownHot);
-  hot.addHook('beforeChange', beforeChangeHot);
-  hot.addHook('afterChange', changeHot);
-}
-"
-  )
   return(HOT)
 }

R/shiny-utils.R

@@ -5,3 +5,24 @@ attachClass <- function(tag, class) {
 inlineUI <- function(tag) {
   attachClass(tag, "inline_ui")
 }
+
+addHotHooks <- function(hot, filterKeys = TRUE, sanitize = TRUE, ...) {
+  hooks <- list(...)
+
+  if (filterKeys) hooks$beforeKeyDown <- c("hookFilterKeys", hooks$beforeKeyDown)
+  if (sanitize)   hooks$beforeChange <- c("hookSanitize", hooks$beforeChange)
+
+  js <- c("function(el, x) {", "  var hot = this.hot;")
+
+  for (hookType in names(hooks)) {
+    for (fxn in hooks[[hookType]]) {
+      js <- c(js,
+              sprintf("  hot.removeHook('%s', %s);", hookType, fxn),
+              sprintf("  hot.addHook('%s', %s);", hookType, fxn)
+      )
+    }
+  }
+
+  js <- c(js, "}")
+  htmlwidgets::onRender(hot, paste(js, collapse = "\n"))
+}