d3 hierarchy as R nested tibble

After Jenny Bryan’s fantastic PlotCon presentation Data Rectangling, I started thinking what would a d3.js hierarchy look like as a nested tibble.

d3r Shows Us

I had forgotten that in d3r::d3_nest I provided an argument to get the tibble instead of the JSON, so getting an example on your machine should be fairly simple (let me know if it isn’t). We will use the helpful random.hierarchical.data function in the treemap package to generate the data.

# install.packages("d3r")
# install.packages("treemap")
library(treemap)
library(d3r)

d3_nest(
  random.hierarchical.data(),
  json = FALSE
)[,c("id","children")]
## # A tibble: 1 × 2
##      id         children
##   <chr>           <list>
## 1  root <tibble [4 × 2]>

Still No Easier to Query

Unfortunately, even though we can get the data in this form, I don’t think R tooling makes it any easier to query or manipulate. Please let me know if you have ideas or a workflow for working with this type data in R. data.tree seems to be our best option.

PlotCon 2016

For those who might not have seen the tweets, I will be speaking at the first ever PlotCon in New York City November 15-18, 2016.  I have the very intimidating spot between Jenny Bryan and Hadley Wickham on Friday at 10:30 AM.

plotcon_logo[1].png

 

 If you are attending the conference or are in New York, I would absolutely love to see you.  Please let me know.

Recursion in R

Working in d3.js often requires recursion with nested data. Recursion in R can be tricky.

Flaw? in rapply

Much of the difficulty of recursion in R stems from a “flaw” in rapply.

# make some simple nested data

(nested <- list(
  id = "A",
  children  = list(
    list(
      id="A.1",
      children=list(
        list(id="A.1.a",size=10),
        list(id="A.1.b",size=5)
      )
    ),
    list(
      id="A.2",
      children=list(id="A.2.a",size=200)
    )
  )
))
## $id
## [1] "A"
## 
## $children
## $children[[1]]
## $children[[1]]$id
## [1] "A.1"
## 
## $children[[1]]$children
## $children[[1]]$children[[1]]
## $children[[1]]$children[[1]]$id
## [1] "A.1.a"
## 
## $children[[1]]$children[[1]]$size
## [1] 10
## 
## 
## $children[[1]]$children[[2]]
## $children[[1]]$children[[2]]$id
## [1] "A.1.b"
## 
## $children[[1]]$children[[2]]$size
## [1] 5
## 
## 
## 
## 
## $children[[2]]
## $children[[2]]$id
## [1] "A.2"
## 
## $children[[2]]$children
## $children[[2]]$children$id
## [1] "A.2.a"
## 
## $children[[2]]$children$size
## [1] 200

When we rapply (recursive lapply), we quickly discover the “flaw”.

rapply(nested, function(x){str(x);NULL})
##  chr "A"
##  chr "A.1"
##  chr "A.1.a"
##  num 10
##  chr "A.1.b"
##  num 5
##  chr "A.2"
##  chr "A.2.a"
##  num 200
## NULL

We lose all attributes, such as names and class. Without attributes, selectively choosing elements is impossible. For instance, what if we wanted to collect and sum size?

Solution?

For fuller featured tree functionality, please check out data.tree and GeneralTree. Often though we might not want to fool with a full-featured tree structure.

As I worked on the d3r package, the best solution I found is to lapply within rapply as shown below in the recurse function.

recurse <- function(l, func, ...) {
  l <- func(l, ...)
  if(is.list(l) && length(l)>0){
    lapply(
      l,
      function(ll){
        recurse(ll, func, ...)
      }
    )
  } else {
    l
  }
}

If we wanted to perform our collect size task, now we can do it like this.

# assumes only leaves contain size
#   or otherwise we would have to change traversal order
sum_size <- function(l){
  if(is.list(l) && length(l)>0 && "children" %in% names(l)){
    # unlist
    ul <- unlist(l$children)
    sum_size <- sum(as.numeric(unlist(
      ul[grep(x=names(ul),pattern="size")],
      use.names=FALSE
    )))
    l$size <- sum_size
    l
  } else {
    l
  }
}

Another Difficult Task

For one more example, what if we wanted to rename an element in a nested list? partykit gives us kids instead of the generally expected-by-d3.js children. These d3r lines use the recurse function to accomplish this renaming.

rename_children <- function(l, old_name="kids", new_name="children") {
  if(length(names(l))>0) {
    names(l)[which(names(l)==old_name)] <- new_name
  }
  l
}

Correct Me

I understand my ignorance is greater than my knowledge. Please correct and improve anything from above.

Custom Styling for htmlwidgets

In this DT Github issue, there was a need to apply custom styling for htmlwidgets. I wrote a quick helper function to apply my solution based on CSS specificity rules. We use htmlwidgets::prependContent to add a style tag using a CSS id selector. Using this method means we don't have to use JavaScript to inject our custom CSS.

helper function

# define function to help apply custom css
#  to htmlwidgets using css specificity with id
style_widget <- function(hw=NULL, style="", addl_selector="") {
  stopifnot(!is.null(hw), inherits(hw, "htmlwidget"))

  # use current id of htmlwidget if already specified
  elementId <- hw$elementId
  if(is.null(elementId)) {
    # borrow htmlwidgets unique id creator
    elementId <- sprintf(
      'htmlwidget-%s',
      htmlwidgets:::createWidgetId()
    )
    hw$elementId <- elementId
  }

  htmlwidgets::prependContent(
    hw,
    htmltools::tags$style(
      sprintf(
        "#%s %s {%s}",
        elementId,
        addl_selector,
        style
      )
    )
  )
}

example

Here is a quick example with rpivotTable.

library(htmltools)
library(htmlwidgets)
library(rpivotTable)

# use rpivotTable to illustrate the effect
rp <- rpivotTable(UCBAdmissions, height=200)

browsable(
  tagList(
    rp,
    style_widget(hw=rp, "font-family:monospace;"),
    style_widget(hw=rp, "font-size:150%; color:purple;", "table td")
  )
)

...and a screenshot of the result.

htmlwidget_custom_style.png

Why d3r?

I released a very alpha package d3r with the intention of helping make using d3.js in R a little easier and more pleasant.  Here is a quick writeup of what it currently does?  I would very much like this to be a complete, full-featured, and well-tested package, so please let me know if you have any ideas.