R/limitedDiversity.R

In QCApro: Advanced Functionality for Performing and Evaluating Qualitative Comparative Analysis

limitedDiversity <- function (truth.tab, outcome = "", exo.facs = c(""), 
                              sol.type = "ps", dir.exp = c(), n.drop = 1,
                              c.minterms = FALSE) {
  # unique models
  usols <- list()
  
  # solution space
  sol.space <- list()
  
  # if truth.tab is an object of class "tt" generated by truthTable function,...
  if (is.tt(truth.tab)) {
      
      # extract the bare truth table, also eliminating remainders if truth table
      # was built with complete = TRUE
      truth.tab <- truth.tab$tt[truth.tab$tt$OUT != "?" , -(which(
        colnames(truth.tab$tt) %in% c("n", "incl", "PRI", "pval1", "pval0")
        ))]
      
      # if present, replace "C" by c.minterms and turn OUT into numeric vector
      truth.tab$OUT[truth.tab$OUT == "C"] <- c.minterms
      truth.tab$OUT <- as.numeric(truth.tab$OUT)
      
      # if the name of the outcome is not 'OUT' and 'outcome' is not ""
      if (outcome != "OUT" & nchar(gsub(" ", "", outcome)) != 0) {
       
          errmsg <- paste0("You are using an object of class 'tt'. In this case, 
                            the outcome must be set to 'OUT'. It is currently 
                            specified as '", outcome, "'.")
          cat("\n")
          stop(paste(strwrap(errmsg, exdent = 7), collapse = "\n"), 
               call. = FALSE)
      }
      
      else {
         
          outcome <- "OUT"
          exo.facs <- colnames(truth.tab)[-length(colnames(truth.tab))]
      }
  }
  
  rows.truth.tab <- nrow(truth.tab)
  
  # if the number of truth table rows is smaller than n.drop
  if (rows.truth.tab < n.drop) {
      
      errmsg <- paste0("The number of minterms to be dropped (", n.drop, 
                       ") cannot be larger than the number of observed minterms 
                       in the truth table (", rows.truth.tab,").")
      cat("\n")
      stop(paste(strwrap(errmsg, exdent = 7), collapse = "\n"), call. = FALSE)
  }
  
  # if any other value/s apart from only 0 or only 1 are assigned to c.minterms
  if (length(c.minterms) > 1 & !c.minterms %in% c(0,1)) {
   
      errmsg <- paste0("The number of minterms to be dropped (", n.drop, 
                       ") cannot be larger than the number of observed minterms 
                       in the truth table (", rows.truth.tab,").")
      cat("\n")
      stop(paste(strwrap(errmsg, exdent = 7), collapse = "\n"), call. = FALSE)
  }
  
  # combinations of minterms to be dropped
  cbs <- combn(rows.truth.tab, n.drop)
  
  solist <- lapply(seq(ncol(cbs)), function (x) {
  
    # for intermediate solutions
    if (length(dir.exp) > 0) {
    
        try({sol.space <- unname(
               sapply(eQMC(truth.tab[-cbs[, x], ], outcome = outcome, 
                           exo.facs = exo.facs, sol.type = sol.type,
                           dir.exp = dir.exp)$i.sol, "[[", "solution")
             )},
             silent = TRUE)
    } 
   
    # conservative and parsimonious solutions
    else {
     
        try({sol.space <- eQMC(truth.tab[-cbs[, x], ], outcome = outcome,
                               exo.facs = exo.facs, 
                               sol.type = sol.type)$solution}, 
            silent = TRUE)
    }
    
    if (length(sol.space) > 0) {
        
        if (is.list(unlist(sol.space, recursive = FALSE)) == FALSE) {
            
            for (sol in seq(length(sol.space))) {
                 sol.space[[sol]] <- paste(sort(sol.space[[sol]]),
                 collapse = "+")
            }
        } 
        
        else {
            
            sol.space <- unlist(sol.space, recursive = FALSE)
              
              for (sol in seq(length(sol.space))) {
                   sol.space[[sol]] <- paste(sort(sol.space[[sol]]),
                   collapse = "+")
              }
        }
        
        sol.space <- unlist(sol.space)
    } 
    
    else {
        
        sol.space <- ""
    }
    
    return(sol.space)
  })
    
  solsfull <- solist
  
  solist <- unlist(solist)
    
  for (sol in seq(length(solist))) {
    
       poslist <- which(unlist(lapply(usols, all.equal, solist[[sol]])) == TRUE)
    
          if (length(poslist) == 0) {
              usols[[length(usols) + 1]] <- solist[sol]
              solist[sol] <- names(usols)[length(usols)] <- length(usols)
          } 
             
          else {
                
              solist[sol] <- names(usols)[poslist]
          }
  }
    
  soltable <- table(unlist(solist))
  
  soldf <- data.frame(N = as.vector(soltable),
                      ID = as.integer(names(soltable)),
                      SHARE = round(prop.table(as.vector(soltable)), 4)*100)
    
  rownames(soldf) <- unlist(usols)
  
  return(list(model.shares = soldf[order(-soldf$SHARE, soldf$ID), ], 
              solutions = solsfull, tt = truth.tab))
}