R/parse_input.R

In eulerr: Area-Proportional Euler and Venn Diagrams with Ellipses

parse_list <- function(combinations)
{
  if (is.null(attr(combinations, "names")))
    stop("when `combinations` is a list, all vectors in that list must be named")

  if (any(names(combinations) == ""))
    stop("all elements of `combinations` must be named")

  if (!all(sapply(combinations, anyDuplicated) == 0))
    stop("vectors in `combinations` cannot contain duplicates")

  if (any(duplicated(names(combinations))))
    stop("names of elements in `combinations` must be unique")

  sets <- names(combinations)
  n <- length(sets)

  id <- bit_indexr(n)

  out <- integer(nrow(id))
  rownames(id) <- apply(id, 1L, function(x) paste(sets[x], collapse = "&"))

  intersect_sets <- as.list(rep(-1, nrow(id)))
  names(intersect_sets) <- rownames(id)
  compute_intersect <- function(bool) {
    ind <- which(bool)
    nm <- paste(sets[ind], collapse = "&")
    if (identical(intersect_sets[[nm]], -1)) { # not computed yet
      if (length(ind) == 1) {
        intersect_sets[[nm]] <<- combinations[[ind]]
      } else {
        bool[] <- FALSE
        bool[ind[1]] <- TRUE
        part1 <- compute_intersect(bool)
        bool[ind] <- TRUE
        bool[ind[1]] <- FALSE
        part2 <- compute_intersect(bool)
        intersect_sets[[nm]] <<- intersect(part1, part2)
      }
    }
    intersect_sets[[nm]]
  }

  apply(id, 1, function(x) length(compute_intersect(x)))
}

parse_dataframe <- function(combinations,
                            weights = NULL,
                            by = NULL,
                            facs,
                            sep = "_",
                            factor_names = TRUE,
                            ...)
{
  if (any(grepl("&", colnames(combinations), fixed = TRUE)))
    stop("names of columns in `combinations` must not contain '$'")

  if (!is.null(facs)) {
    if (is.list(facs)) {
      if (!is.null(names(facs)))
        nms <- names(facs)
      else {
        nms <- sapply(by[-1L], deparse)
      }
    } else
      nms <- deparse(by)

    if (is.list(facs))
      stopifnot(length(facs) < 3)
    else
      facs <- list(facs)

    dd <- as.data.frame(facs, col.names = nms, stringsAsFactors = TRUE)
    groups <- unique(dd)
    rownames(groups) <- NULL

    out <- g <- vector("list", NROW(groups))

    by_ind <- match(nms, colnames(combinations))

    for (i in seq_len(NROW(groups))) {
      ind <- apply(dd, 1, function(x) all(x == groups[i, ]))
      out[[i]] <- combinations[ind, -by_ind, drop = FALSE]
      names(out)[[i]] <- paste(unlist(groups[i, , drop = TRUE]),
                               collapse = ".")
    }

    attr(out, "groups") <- groups
  } else {
    is_factor <- vapply(combinations,
                        function(x) is.factor(x) || is.character(x),
                        logical(1))

    reals <- vapply(combinations,
                    is_real,
                    FUN.VALUE = logical(1))

    if (any(reals))
      stop("you cannot use non-integer numeric variables.")

    if (any(is_factor))
      combinations <- dummy_code(combinations,
                                 sep = sep,
                                 factor_names = factor_names)

    if (is.null(weights))
      weights <- rep.int(1L, NROW(combinations))

    out <- tally_combinations(combinations, weights)
  }
  out
}