vctrs class for multiple-response objects

README

Based on the `rimu` package, the start of an implementation of 'mr' objects using Hadley's `vctrs` package, so they can be used in tibbles. 

vec_mr.R

library(vctrs)
library(pillar)
library(rimu)
new_vmr <- function(x,levels=unique(do.call(c,x))) {
  new_list_of(x, ptype = character(), class = "vmr", levs=levels)
}

as.vmr<-function(x,...) UseMethod("as.vmr")
as.vmr.mr<-function(x,...) {
    l<-levels(x)
    y<-lapply(apply(x,1,c, simplify=FALSE), function(i) l[as.logical(i)])
    new_vmr(y,l)
}
as.vmr.default<-function(x,...) as.vmr(as.mr(x,...))

vec_ptype_full.vmr <- function(x, ...) "vmr"
vec_ptype_abbr.vmr <- function(x, ...) "vmr"

format.vmr <- function(x, ...) {
    format(as.mr(unclass(x),...,levels=attr(x,"levs")))
}

obj_print_data.vmr <- function(x, ...) {
  if (length(x) == 0)
    return()
  print(format(x), quote = FALSE)
}


## pillar_shaft.vmr<-function (x, ...) 
## {
##     out <- style_subtle(format(x))
##     new_pillar_shaft_simple(out, align = "right")
## }


pillar_shaft.vmr <- function(x, ...) {
  full <- format(x)
  binary <- apply(as.matrix(as.mr(x)),1, paste0,collapse="")

  pillar::new_pillar_shaft(
    list(full = full, binary =binary),
    width = pillar::get_max_extent(full),
    min_width = pillar::get_max_extent(binary),
    class = "pillar_shaft_vmr"
  )
}


format.pillar_shaft_vmr <- function(x, width, ...) {
  if (get_max_extent(x$full) <= width) {
    ornament <- x$full
  } else {
    ornament <- x$binary
  }

  pillar::new_ornament(ornament, align = "right")
}