Issues #64 and #62

DESCRIPTION

@@ -32,7 +32,7 @@ Imports:
     stats,
     crayon,
     Rcpp
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 VignetteBuilder: knitr
 LinkingTo: 
     Rcpp

NEWS.md

@@ -4,6 +4,8 @@
 * Added `read.flist()` and `write.flist()` functions.
 * Fixed note on `fapply()` of flist object.
 * Fixed minor issues with `as.fcat()`.
+* Added "Factor" column to UDF data frame conversion. Will allow user to set
+"as.factor" property from a data frame.
 
 
 # fmtr 1.6.3

R/fcat.R

@@ -297,13 +297,17 @@ as.data.frame.fcat <- function(x, row.names = NULL, optional = FALSE, ...) {
                                 Type = "S",
                                 Expression = x[[nm]],
                                 Label = "", 
-                                Order = NA, stringsAsFactors = FALSE)
+                                Order = NA, 
+                                Factor = NA,
+                                stringsAsFactors = FALSE)
       } else {
         tmp[[nm]] <- data.frame(Name = nm, 
                                 Type = "V",
                                 Expression = paste(deparse(x[[nm]]), collapse = " "),
                                 Label = "", 
-                                Order = NA, stringsAsFactors = FALSE)
+                                Order = NA, 
+                                Factor = NA,
+                                stringsAsFactors = FALSE)
       }
 
     } else if (any(class(x[[nm]]) == "function")) {
@@ -312,7 +316,9 @@ as.data.frame.fcat <- function(x, row.names = NULL, optional = FALSE, ...) {
                                Type = "F",
                                Expression = paste(deparse(x[[nm]]), collapse = " "),
                                Label = "", 
-                               Order = NA, stringsAsFactors = FALSE)
+                               Order = NA, 
+                               Factor = NA,
+                               stringsAsFactors = FALSE)
 
 
     }
@@ -341,10 +347,6 @@ as.data.frame.fcat <- function(x, row.names = NULL, optional = FALSE, ...) {
 #' current working directory, using the variable name as the file name.  These
 #' defaults can be overridden using the appropriate parameters.  The catalog
 #' will be saved with a file extension of ".fcat". 
-#' 
-#' Note that the format catalog is saved as an RDS file.  The ".fcat" file 
-#' extension only serves to distinguish the format catalog from other RDS
-#' files.
 #' @param x The format catalog to write.
 #' @param dir_path The directory path to write the catalog to. Default is the 
 #' current working directory.
@@ -404,10 +406,6 @@ write.fcat <- function(x, dir_path = getwd(), file_name = NULL) {
 #' @description The \code{read.fcat} function reads a format catalog
 #' from the file system.  The function accepts a path to the format catalog,
 #' reads the catalog, and returns it.
-#' 
-#' Note that the format catalog is saved as an RDS file.  The ".fcat" file 
-#' extension only serves to distinguish the format catalog from other RDS
-#' files.
 #' @param file_path The path to the format catalog.
 #' @return The format catalog as an R object.
 #' @family fcat

R/flist.R

@@ -70,24 +70,50 @@
 #' 
 #' 
 #' ## Example 3: Formatting List - Row Type with lookup ##
+#' 
+#' #' # Create formatting list
+#' fl3 <- flist(type = "row", 
+#'              DEC1 = "%.1f",
+#'              DEC2 = "%.2f", 
+#'              PCT1 = "%.1f%%")
+#'              
 #' # Set up data
-#' # Notice each row has a different data type
-#' l2 <- list(2841.258, "H", as.Date("2020-06-19"),
-#'            "L", as.Date("2020-04-24"), 1382.8865)
-#' v3 <- c("num", "char", "date", "char", "date", "num")
+#' df <- data.frame(CODE = c("DEC1", "DEC2", "PCT1", "DEC2", "PCT1"),
+#'                  VAL = c(41.258, 62.948, 12.125, 65.294, 15.825))
 #' 
-#' # Create formatting list
-#' fl3 <- flist(type = "row", lookup = v3,
-#'              num = function(x) format(x, digits = 2, nsmall = 1, 
-#'                                   big.mark=","),
-#'              char = value(condition(x == "H", "High"),
-#'                      condition(x == "L", "Low"),
-#'                      condition(TRUE, "NA")),
-#'              date = "%d%b%Y")
+#' # Assign lookup
+#' fl3$lookup <- df$CODE
+#' 
+#' # Apply Formatting List
+#' fapply(df$VAL, fl3)
+#' # [1] "41.3"  "62.95" "12.1%" "65.29" "15.8%"
+#' 
+#' ## Example 4: Formatting List - Values with Units ##
 #' 
-#' # Apply formatting list to vector, using lookup
-#' fapply(l2, fl3)
-#' # [1] "2,841.3"   "High"      "19Jun2020" "Low"       "24Apr2020" "1,382.9"
+#' #' # Create formatting list
+#' fl4 <- flist(type = "row", 
+#'              BASO = "%.2f x10(9)/L",
+#'              EOS  = "%.2f x10(9)/L",
+#'              HCT = "%.1f%%", 
+#'              HGB = "%.1f g/dL")
+#'              
+#' # Set up data
+#' df <- data.frame(CODE = c("BASO", "EOS", "HCT", "HGB"),
+#'                  VAL = c(0.02384, 0.14683, 40.68374, 15.6345))
+#' 
+#' # Assign lookup
+#' fl4$lookup <- df$CODE
+#' 
+#' # Apply Formatting List
+#' df$VALC <- fapply(df$VAL, fl4)
+#'
+#' # View results
+#' df
+#' #   CODE      VAL          VALC
+#' # 1 BASO  0.02384 0.02 x10(9)/L
+#' # 2  EOS  0.14683 0.15 x10(9)/L
+#' # 3  HCT 40.68374         40.7%
+#' # 4  HGB 15.63450     15.6 g/dL
 flist <- function(..., type = "column", lookup = NULL, simplify = TRUE) {
 
   if (!type %in% c("column", "row"))
@@ -338,14 +364,18 @@ as.data.frame.fmt_lst <- function(x, row.names = NULL, optional = FALSE, ...) {
                                 Type = "S",
                                 Expression = fmts[[i]],
                                 Label = "", 
-                                Order = NA, stringsAsFactors = FALSE)
+                                Order = NA, 
+                                Factor = NA, 
+                                stringsAsFactors = FALSE)
       } else {
         tmp[[nm]] <- data.frame(Name = nm, 
                                 Type = "V",
                                 Expression = paste(deparse(fmts[[i]]), 
                                                    collapse = " "),
                                 Label = "", 
-                                Order = NA, stringsAsFactors = FALSE)
+                                Order = NA, 
+                                Factor = NA, 
+                                stringsAsFactors = FALSE)
       }
 
     } else if (any(class(fmts[[i]]) == "function")) {
@@ -355,7 +385,9 @@ as.data.frame.fmt_lst <- function(x, row.names = NULL, optional = FALSE, ...) {
                                Expression = paste(deparse(fmts[[i]]), 
                                                   collapse = " "),
                                Label = "", 
-                               Order = NA, stringsAsFactors = FALSE)
+                               Order = NA, 
+                               Factor = NA, 
+                               stringsAsFactors = FALSE)
 
 
     }
@@ -386,10 +418,6 @@ as.data.frame.fmt_lst <- function(x, row.names = NULL, optional = FALSE, ...) {
 #' current working directory, using the variable name as the file name.  These
 #' defaults can be overridden using the appropriate parameters.  The catalog
 #' will be saved with a file extension of ".flist". 
-#' 
-#' Note that the formatting list is saved as an RDS file.  The ".flist" file 
-#' extension only serves to distinguish the format catalog from other RDS
-#' files.
 #' @param x The formatting list to write.
 #' @param dir_path The directory path to write the catalog to. Default is the 
 #' current working directory.
@@ -445,10 +473,6 @@ write.flist <- function(x, dir_path = getwd(), file_name = NULL) {
 #' @description The \code{read.flist} function reads a formatting list
 #' from the file system.  The function accepts a path to the formatting list,
 #' reads the list, and returns it.
-#' 
-#' Note that the formatting list is saved as an RDS file.  The ".flist" file 
-#' extension only serves to distinguish the formatting list from other RDS
-#' files.
 #' @param file_path The path to the formatting list.
 #' @return The formatting list as an R object.
 #' @family flist

R/fmt.R

@@ -230,6 +230,12 @@ as.data.frame.fmt <- function(x, row.names = NULL, optional = FALSE, ...,
   l <- c()
   o <- c()
 
+  f <- FALSE
+  isFactor <- attr(x, "as.factor")
+  if (!is.null(isFactor)) {
+    f <- isFactor
+  }
+
   for (cond in x) {
     e[[length(e) + 1]] <- paste(deparse(cond$expression), collapse = " ")
     l[[length(l) + 1]] <- cond$label
@@ -242,6 +248,7 @@ as.data.frame.fmt <- function(x, row.names = NULL, optional = FALSE, ...,
 
   dat <- data.frame(Name = name, Type = "U", 
                     Expression = e, Label = l, Order = o, 
+                    Factor = f,
                     stringsAsFactors = FALSE)
 
   if (!is.null(row.names))
@@ -274,6 +281,8 @@ as.data.frame.fmt <- function(x, row.names = NULL, optional = FALSE, ...,
 #' data frame, this expression is stored as a character string.
 #' \item \strong{Label}: The label for user-defined, "U" type formats.
 #' \item \strong{Order}: The order for user-defined, "U" type formats. 
+#' \item \strong{Factor}: An optional column for "U" type formats that sets
+#' the "as.factor" parameter. Valid values are TRUE, FALSE, or NA. 
 #' }
 #' Any additional columns will be ignored.  Column names are case-insensitive.
 #' 
@@ -286,7 +295,7 @@ as.data.frame.fmt <- function(x, row.names = NULL, optional = FALSE, ...,
 #' \item \strong{F}: A vectorized function.
 #' \item \strong{V}: A named vector lookup.}
 #' 
-#' The "Label" and "Order" columns are used only for a type "U", user-defined
+#' The "Label", "Order", and "Factor" columns are used only for a type "U", user-defined
 #' format created with the \code{\link{value}} function.
 #' @param x The data frame to convert.
 #' @return A format catalog based on the information contained in the 
@@ -301,10 +310,10 @@ as.data.frame.fmt <- function(x, row.names = NULL, optional = FALSE, ...,
 #' df <- as.data.frame(f1)
 #' print(df)
 #' 
-#' # Name Type Expression   Label Order
-#' # 1 f1    U   x == "A" Label A    NA
-#' # 2 f1    U   x == "B" Label B    NA
-#' # 3 f1    U       TRUE   Other    NA
+#' # Name Type Expression   Label Order Factor
+#' # 1 f1    U   x == "A" Label A    NA  FALSE
+#' # 2 f1    U   x == "B" Label B    NA  FALSE
+#' # 3 f1    U       TRUE   Other    NA  FALSE
 #' 
 #' # Convert data frame back to a user-defined format 
 #' f2 <- as.fmt(df)
@@ -324,11 +333,23 @@ as.fmt.data.frame <- function(x) {
 
   names(x) <- titleCase(names(x))
 
+  hasFactor <- ifelse("Factor" %in% names(x), TRUE, FALSE) 
+
+  isFactor <- FALSE
+  if (hasFactor) {
+    if ("logical" %in% class(x[["Factor"]])) {
+      isFactor <- all(x[["Factor"]] == TRUE)
+    }
+  }
+
+  if (is.na(isFactor)) {
+    isFactor <- FALSE 
+  }
+
   ret <- list()
 
   for (i in seq_len(nrow(x))) {
 
-
     y <- structure(list(), class = c("fmt_cnd"))    
 
     y$expression <- str2lang(as.character(x[i, "Expression"]))
@@ -345,14 +366,12 @@ as.fmt.data.frame <- function(x) {
       y$order <- as.character(x[i, "Order"]) 
     }
 
-
     ret[[length(ret) + 1]] <- y
-
-
   }
 
   class(ret) <- "fmt"
   attr(ret, "levels") <- labels(ret)
+  attr(ret, "as.factor") <- isFactor
 
   return(ret)
 
@@ -501,6 +520,8 @@ print.fmt <- function(x, ..., name = deparse(substitute(x, env = environment()))
 
     dat <- as.data.frame(x, name = name, stringsAsFactors = FALSE)
 
+    dat$Factor <- NULL
+
     print(dat)
   }
 

_pkgdown.yml

@@ -41,6 +41,8 @@ reference:
   desc: Functions to create a manage a formatting list.
   contents:
   - flist
+  - read.flist
+  - write.flist
   - as.flist
   - as.flist.data.frame
   - as.flist.tbl_df