Merge pull request #26 from donarus/logical_column_types

Fix for logical column types

Author: trestletech

R/apply-table-changes.R

@@ -42,7 +42,7 @@ applyChange <- function(table, change, trim=TRUE){
   # Extract and shift to 1-based-indexing
   row <- as.integer(change[1]) + 1
   col <- as.integer(change[2]) + 1
-  old <- change[3]
+  old <- setHtableClass(change[3], table[row, col])[1, 1]
   new <- change[4]
 
   if (trim){

R/calc-htable-delta.R

@@ -5,11 +5,10 @@
 #' @param new The new data.frame
 #' @return A matrix in which each row represents a change from the old to the
 #'   new matrix in the form of [row, col, newVal, oldVal].
-#' @author Jeff Allen \email{jeff@@trestletech.com}
+#' @author Jeff Allen \email{jeff@@trestletech.com}, Jonathan Owen \email{jonathanro@@gmail.com}, Tadeas Palusga \email{tadeas@@palusga.cz}
 #' @export
 calcHtableDelta <- function (old, new, zeroIndex = TRUE){
-  changes <- matrix(ncol=4, nrow=0)
-  colnames(changes) <- c("row", "col", "new", "old")
+  changes <- NULL
 
   # Loop through each column, comparing the data
   for(i in 1:(max(ncol(new), ncol(old)))){
@@ -18,36 +17,41 @@ calcHtableDelta <- function (old, new, zeroIndex = TRUE){
 
     if (i > ncol(new)){
       # the new data.frame doesn't have this column 
-      thisColChanges <- matrix(c(1:nrow(old), 
-                                 rep(i, nrow(old)), 
-                                 rep(NA, nrow(old)),
-                                 old[,i])
-                               , ncol=4)
+      thisColChanges <- data.frame(1:nrow(old), 
+                                   rep(i, nrow(old)), 
+                                   rep(NA, nrow(old)),
+                                   old[,i])
     } else if (i > ncol(old)){
       # The old data.frame doesn't have this column
-      thisColChanges <- matrix(c(1:nrow(new), 
-                                 rep(i, nrow(new)), 
-                                 new[,i], 
-                                 rep(NA, nrow(new)))
-                               , ncol=4)
+      thisColChanges <- data.frame(1:nrow(new), 
+                                   rep(i, nrow(new)), 
+                                   new[,i], 
+                                   rep(NA, nrow(new)))
     } else {
       # They both have this column
       deltaInd <- which(suppressWarnings(old[,i] != new[,i]))
       lng <- length(deltaInd)
 
-      thisColChanges <- matrix(c(deltaInd, 
-                                 rep(i, lng), 
-                                 new[deltaInd, i], 
-                                 old[deltaInd, i])
-                               , ncol=4)  
+      thisColChanges <- data.frame(deltaInd, 
+                                   rep(i, lng), 
+                                   new[deltaInd, i], 
+                                   old[deltaInd, i])  
     }
 
+    if (is.logical(thisColChanges[, 3]))
+      thisColChanges[, 3] = ifelse(thisColChanges[, 3], "true", "false")
+    if (is.logical(thisColChanges[, 4]))
+      thisColChanges[, 4] = ifelse(thisColChanges[, 4], "true", "false")
+    
     if (zeroIndex && nrow(thisColChanges) > 0){
       thisColChanges[,1] <- as.integer(thisColChanges[,1]) - 1;
       thisColChanges[,2] <- as.integer(thisColChanges[,2]) - 1;
     }
-    
     changes <- rbind(changes, thisColChanges)
   }
+  
+  if(!is.null(changes)) {
+    colnames(changes) <- c("row", "col", "new", "old")
+  }
   return (changes)
 }

R/get-htable-types.R

@@ -26,4 +26,39 @@ getHtableTypes <- function(data){
   })
 
   as.character(types)
+}
+
+# Convert to specified class
+# 
+# @param x vector
+# @param cls character
+# @return converted vector
+# @seealso https://stackoverflow.com/questions/9214819/supply-a-vector-to-classes-of-dataframe
+# @author Jonathan Owen, jonathanro@@gmail.com
+toCls = function(x, cls) tryCatch(do.call(paste("as", cls, sep = "."), list(x)),
+                                  warning = function(w) do.call(as.character, list(x)))
+
+# Covert htable output matrix to data.frame using classes of model data.frame
+# 
+# @param data htable matrix
+# @param old original data.frame
+# @return data.frame
+# @seealso https://stackoverflow.com/questions/9214819/supply-a-vector-to-classes-of-dataframe
+# @author Jonathan Owen, jonathanro@@gmail.com
+setHtableClass = function(data, old) {
+  if (class(old) == "matrix") {
+    toCls(data, class(old[1, 1]))
+  } else {
+    data = as.data.frame(data, stringsAsFactors = FALSE)
+    
+    cls = sapply(old, class)
+    
+    # assume all cols are numeric, will be down coverted to character in toCls
+    # is there a better way to track which columns were added or removed?
+    if (length(cls) != ncol(data))
+      cls = rep("numeric", ncol(data))
+    
+    data = replace(data, values = Map(toCls, data, cls))
+  }
+  data
 }

R/render-htable.R

@@ -58,11 +58,6 @@ renderHtable <- function(expr, env = parent.frame(),
       }
 
       delta <- calcHtableDelta(.oldTables[[shinysession$token]][[name]], data)
-            
-      # Avoid the awkward serialization of a row-less matrix in RJSONIO
-      if (nrow(delta) == 0){
-        delta <- NULL
-      }
 
       .oldTables[[shinysession$token]][[name]] <- data