R function to see if combinations of multiple vectors match a target vector

The solutions shown in the question consist of non-overlapping vectors so we assume that that is a requirement so that we are looking to partition the target into disjoint vectors that cover it. If the vectors may overlap then instead of using = or == in the constraints involving A below use >=.

The assumed problem is known as a set partitioning problem and the problem with overlaps is known as a set covering problem.

Assuming the list of vectors L and the target shown in the Note at the end form the objective (all one's), incidence matrix A of vectors, animals and the right hand of the constraint equations rhs derived from the target and run the linear program shown.

If a solution is found then we add a constraint that will eliminate it in the next iteration by insisting that at least one of its zeros be one. We iterate 5 times (i.e. up to 5 solutions) or until we can find no more solutions.

We show a solution using the lpSolveAPI package and then in the section after that repeat it using the CVXR package.

lpSolveAPI

library(lpSolveAPI)

animals <- sort(unique(unlist(L)))
A <- +outer(animals, L, Vectorize(`%in%`))
rownames(A) <- animals
nr <- nrow(A)
nc <- ncol(A)

rhs <- rownames(A) %in% target

lp <- make.lp(nr, nc)
set.objfn(lp, rep(1, nc))
for(i in 1:nr) add.constraint(lp, A[i, ], "=", rhs[i])
for(j in 1:nc) set.type(lp, j, type = "binary")

soln <- solns <- NULL
for(s in 1:5) {
  if (!is.null(soln)) add.constraint(lp, 1-soln, ">=", 1)
  if (solve(lp) != 0) break
  soln <- get.variables(lp)
  solns <- c(solns, list(names(L)[soln == 1]))
}
solns   
## [[1]]
## [1] "e" "f"
##
## [[2]]
## [1] "b" "d" "e"

CVXR

An alternative to lpSolve is CVXR. We use nc, A and rhs from above. Below we find up to 5 solutions.

library(CVXR)

x <- Variable(nc, boolean = TRUE)
objective <- Minimize(sum(x))
constraints <- list(A %*% x == matrix(rhs))

solns <- soln <- NULL
for(i in 1:5) {
  if (!is.null(soln)) constraints <- c(constraints, sum((1 - soln) * x) >= 1)
  prob <- Problem(objective, constraints)
  result <- solve(prob)
  if (result$status != "optimal") break
  soln <- result$getValue(x)
  solns <- c(solns, list(names(L)[soln == 1]))
}
solns
## [[1]]
## [1] "e" "f"
##
## [[2]]
## [1] "b" "d" "e"

Note

L <- within(list(), {
  a <- c("giraffe", "dolphin", "pig")
  b <- c("elephant" , "pig")
  c <- c("zebra","cobra","spider","porcupine")
  d <- c("porcupine")
  e <- c("spider","cobra")
  f <- c("elephant","pig","porcupine")
})
L <- L[order(names(L))]
target<- c("elephant" , "pig","cobra","spider","porcupine")

By first converting your vectors into a list l <- list(a = a, b = b, c = c, d = d, e = e, f = f)

In base R you can use lapply:

unlist(lapply(l, FUN = function(x) all(x %in% target)))

    a     b     c     d     e     f 
FALSE  TRUE FALSE  TRUE  TRUE  TRUE 

You could accomplish this with the purrr library function imap_lgl:

library(purrr)

purrr::imap_lgl(l, ~ all( . %in% target))
    a     b     c     d     e     f 
FALSE  TRUE FALSE  TRUE  TRUE  TRUE 

If you add a pipe names you can get a character vector of the names if you prefer:

purrr::imap_lgl(l, ~ all( . %in% target)) %>% 
  names(.)[.]

[1] "b" "d" "e" "f"

Both of these solutions use all and the operator %in%. %in% works by testing if everything in the LHS vector is in the RHS vector:

a %in% target
[1] FALSE FALSE  TRUE

all(a %in% target)
[1] FALSE

Since "giraffe" and "dolphin" are not in target the first two values return FALSE and the last value is TRUE since "pig" is in target. all tests if all values of a vector are TRUE. Since not all values of a are in target it returns FALSE.

Try this:

1. Build a list with your vectors

   vec_list <- list(a, b, c, d, e, f)
   names(vec_list) <- c("a", "b", "c", "d", "e", "f")
   

2. Write a function that identifies matches

   match_elem <- function(i, the_list, target) {
     if (all( the_list[[i]] %in% target)) {
     return(names(the_list)[[i]])
     }
   }
   

3. Apply match_elem to each element of the list

   unlist(lapply(1:6, match_elem, vec_list, target))
   
   > "b" "d" "e" "f"
   

A base R option using combn

lst <- list(a, b, c, d, e, f)
nms <- c("a", "b", "c", "d", "e", "f")
names(
  Filter(
    isTRUE,
    unlist(
      lapply(
        seq_along(lst),
        function(k) {
          setNames(
            combn(lst, k, FUN = function(v) !(length(setdiff(unlist(v), target)) + length(setdiff(target, unlist(v))))),
            combn(nms, k, toString)
          )
        }
      )
    )
  )
)

or

subset(
  unlist(
    lapply(
      seq_along(nms), function(k) combn(nms, k, toString)
    )
  ),
  unlist(
    lapply(
      seq_along(lst),
      function(k) combn(lst, k, FUN = function(v) !(length(setdiff(unlist(v), target)) + length(setdiff(target, unlist(v)))))
    )
  )
)

gives

[1] "e, f"       "b, d, e"    "b, e, f"    "d, e, f"    "b, d, e, f"

Update

If do need to find exclusive combinations, i.e., without overlap, we can try the code below

subset(
  unlist(
    lapply(
      seq_along(nms), function(k) combn(nms, k, toString)
    )
  ),
  unlist(
    lapply(
      seq_along(lst),
      function(k) combn(lst, k, FUN = function(v) length(unlist(v))==length(target) & all(unlist(v)%in% target))
    )
  )
)

or

names(
  Filter(
    isTRUE,
    unlist(
      lapply(
        seq_along(lst),
        function(k) {
          setNames(
            combn(lst, k, FUN = function(v) length(unlist(v))==length(target) & all(unlist(v)%in% target)),
            combn(nms, k, toString)
          )
        }
      )
    )
  )
)

which gives

[1] "b, f"    "e, f"    "b, d, e"