Datatable method for desctable with headers !

DESCRIPTION

@@ -15,7 +15,8 @@ LazyData: true
 Imports:
     dplyr,
     purrr,
-    DT
+    DT,
+    htmltools
 Suggests:
     pander
 RoxygenNote: 6.0.1

R/output.R

@@ -36,16 +36,14 @@ pander.desctable <- function(x = NULL, digits = 2, justify = "left", ...)
   x$Variables$Variables <- gsub("\\+ (.*)", "**\\1**", x$Variables$Variables)
   x$Variables$Variables <- gsub("\\* (.*)", "- *\\1*", x$Variables$Variables)
 
-  header <- x[-1] %>% header("pander")
+  header <- x %>% header("pander")
 
   x[-1] %>%
     flatten_desctable %>%
     lapply(prettyNum, digits = digits, ...) %>%
     lapply(gsub, pattern = "^NA$", replacement = "") %>%
-    data.frame(check.names = F, row.names = x$Variables$Variables, stringsAsFactors = F) -> df
-
-  df %>%
-    setNames(header %>% paste(names(df), sep = "<br/>")) %>%
+    data.frame(check.names = F, row.names = x$Variables$Variables, stringsAsFactors = F) %>%
+    stats::setNames(header) %>%
     pander::pandoc.table(justify = justify, keep.line.breaks = T, split.tables = Inf, emphasize.rownames = F, ...)
 }
 
@@ -73,9 +71,12 @@ datatable.default <- function(data, ...)
 #' @export
 datatable.desctable <- function(data = NULL, ...)
 {
-  flatten_desctable(data) %>%
+  header <- data %>% header("datatable")
+
+  data[-1] %>%
+  flatten_desctable %>%
     lapply(prettyNum, ...) %>%
     lapply(gsub, pattern = "^NA$", replacement = "") %>%
-    data.frame(check.names = F) %>%
-    DT::datatable()
+    data.frame(check.names = F, row.names = data$Variables$Variables, stringsAsFactors = F) %>%
+    DT::datatable(container = header)
 }

R/utils.R

@@ -73,8 +73,18 @@ parse_formula <- function(x, f)
 #' @return A header object in the output format
 header <- function(desctable, output = c("pander", "datatable"))
 {
+  nm <- desctable %>% as.data.frame.desctable %>% names
+  desctable <- desctable[-1]
+
   if (length(desctable) == 1)
-    desctable %>% as.data.frame.desctable %>% names
+  {
+    if (output == "datatable")
+    {
+      c("", nm) %>% lapply(htmltools::tags$th) %>% htmltools::tags$tr() %>% htmltools::tags$thead() %>% htmltools::tags$table(class = "display")
+    }
+    else
+      nm
+  }
   else
   {
     head <- headerList(desctable)
@@ -93,7 +103,27 @@ header <- function(desctable, output = c("pander", "datatable"))
                 sep = "<br/>")
         }
       }
-      head_pander(head)
+      head_pander(head) %>% paste(nm, sep = "<br/>")
+    } else if (output == "datatable")
+    {
+      head_datatable <- function(head)
+      {
+        TRs <- list()
+        while(head[[1]] %>% is.list)
+        {
+          TR <- purrr::map2(head %>% names, head %>% lapply(attr, "colspan"), ~htmltools::tags$th(.x, colspan = .y))
+
+          TRs <- c(TRs, list(TR))
+          head <- purrr::flatten(head)
+        }
+        c(TRs, list(purrr::map2(head %>% names, head, ~htmltools::tags$th(.x, colspan = .y))))
+      }
+      c(head_datatable(head), list(nm %>% lapply(htmltools::tags$th))) -> head
+      head[[1]] <- c(list(htmltools::tags$th(rowspan = length(head))), head[[1]])
+      head %>%
+        lapply(htmltools::tags$tr) %>%
+        htmltools::tags$thead() %>%
+        htmltools::tags$table(class = "display")
     }
   }
 }

man/header.Rd

@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils.R
+\name{header}
+\alias{header}
+\title{Build header}
+\usage{
+header(desctable, output = c("pander", "datatable"))
+}
+\arguments{
+\item{desctable}{A desctable object}
+
+\item{output}{An output format for the header}
+}
+\value{
+A header object in the output format
+}
+\description{
+Take a desctable object and create a suitable header for the mentionned output.
+Output can be one of "pander" or "datatable".
+}