################################################################################
# Replication material for Swiatczak (2021)                                    #
# Different algorithms, different models, Quality & Quantity                   #
# Simulation 1: QMC, Figure 1
# July 2021                                                                    #
# Packages: cna 3.0.1; QCA 3.10.                                               #
################################################################################

library(QCA)
library(cna)
library(dplyr)
library(stringr)
library(stringi)
library(reshape2)
library(tikzDevice)
library(ggplot2)

#you have to source the aux_functions.R via function source("your path to/aux_functions.R")

# Crisp-Set Data
# --------------
# Number of datasets

for(t in 1){

n <- 1000


# Sample sizes 
samplesize <- c(20,60,120)

outcome <- "D"

# Noise levels
noise <- c(0,0.10,0.2)

# Inclusion cuts
incl <- c(1,0.8,0.75)
setlist <- list(samplesize, noise,incl)

settings <- expand.grid(setlist) #combinations of sample size, noise ratio and threshold
colnames(settings) <- c("ssize", "noise", "incl") 

# Prepare storage of results
storage <- vector("list", nrow(settings))

# Prepare score sheet
resultsCrisp <- matrix( nrow = nrow(settings),ncol=7, dimnames = list(1:nrow(settings), 
                                   c("n","ssize", "noise", "incl","standard_QMC","imitate","CCubes") ))
resultsCrisp[,1] <- rep(n,nrow(resultsCrisp))
resultsCrisp[,2] <- settings[,1]
resultsCrisp[,3] <- settings[,2]
resultsCrisp[,4] <- settings[,3]

# Draw replication seeds
set.seed(4) #seed for selecting seeds
seeds <- sample(.Machine$integer.max, nrow(settings))

# Create the ground truth DGSs that are the search targets
datFull <- ct2df(full.ct(6))
target <- replicate(n, randomAsf(datFull, outcome = outcome, compl = 2:3))
ideal.data <- lapply(lapply(target, function(x) selectCases(x, datFull)), ct2df) #ideale daten für jedes target
incomp.data <- lapply(lapply(ideal.data, function(x) dplyr::setdiff(datFull,x)), ct2df) #noise daten für jedes target

# score <-  vector("list", nrow(settings))

# Test Loop
# ---------
for(s in 1:nrow(settings)){
    cat(s, " \n")
   set.seed(seeds[s])

   score.inter.standard_QMC <- score.inter.imitate <- score.inter.ccubes <-  vector("list", n) 

   # Generate Data
   #--------------
  # ensure fragmentation
    testdata <-  lapply(ideal.data,function(x) x[-sample(1:nrow(x),nrow(x)*0.3,replace=F),]) #limited diversity randomly, im durchschnitt 30%, replace = F!
   # set sample size
   testdata <-  lapply(testdata,function(x) x[sample(1:nrow(x),settings[s,1],replace=T),]) 
   # set noise ratio
   nratio <- settings[s,2] #aus dem loop index
   # set incl.cut
   incl.cut <- settings[s,3]
   # introduce noise
   Noisedata <- vector("list", length(testdata))
   for (i in 1:length(testdata)){
   Noisedata[[i]] <- bring_theNoise(testdata[[i]], incomp.data[[i]],
                                         no.replace = round(nrow(testdata[[i]])*nratio), 
                                         add = FALSE)
   }
  
  # standard_QMC
  cat(s,"standard_QMC \n")
  # QCA analysis
  # ------------
  tt <- lapply(Noisedata, function(x) truthTable(x, outcome = outcome, incl.cut = incl.cut)) 
  anaPS <- lapply(tt, function(x) tryCatch(minimize(x, all.sol = T, include = "?",method="QMC"), error=function(e){NULL}))
  # transform syntax
  anaPSlow <- lapply(anaPS, function(x) lapply(x$solution, function(y)negTOlow(y) ))
  anaPSlow <- lapply(anaPSlow,function(t) lapply(t,function(s)paste(s,collapse = "+")))
  anaPSlow <- lapply(anaPSlow,function(t) lapply(t,function(s)paste0(s,"<->",outcome)))
  anaPSlow <- lapply(anaPSlow,function(t) unlist(t))
  
  # CNA analysis 
  # -------------
   # mapply(function(x,y) condTbl(x,y), x=anaPSlow, y=Noisedata,SIMPLIFY = F)
  anaCNA <- lapply(Noisedata,function(r) suppressMessages(cna(r, ordering=list(outcome), strict=T, con=incl.cut,cov=incl.cut, rm.const.factors=F, rm.dup.factors=F, maxstep = c(5,7,25))))
 anaCNA <- lapply(anaCNA, function(r) suppressMessages(asf(r)$condition))
 anaCNA <- lapply(anaCNA, function(r) if(length(r)==0){NULL}else{r})
  # Comparison
  # ----------
  # standard_QMC 
  for(i in 1:n){
    score.inter.standard_QMC[[i]] <- identical.output(anaPSlow[[i]],anaCNA[[i]])
  }
  x <- unlist(score.inter.standard_QMC) 
  
  resultsCrisp[s,5] <- length(x[which(x)])/n
  
 
  
  # IMITATE
  cat(s,"imitate \n")
  # QCA analysis
  # ------------
  # as above
  
  # CNA analysis 
  # -------------
  
  
  QCAscores <- mapply(function(x,y) if(!is.null(x)){suppressMessages(condTbl(x,y))}else{NULL}, x=anaPSlow, y=Noisedata,SIMPLIFY = F)
  QCA.cons <- lapply(QCAscores,function(t) if(!is.null(t)){min(t$consistency)}else{NULL}) 
  QCA.cov <- lapply(QCAscores,function(t) if(!is.null(t)){min(t$coverage)}else{NULL})
  anaCNA.imitate <- vector("list",n)
  for(i in 1:n){
    if(!is.null(QCA.cons[[i]])){
   anaCNA.imitate[[i]]  <-  suppressMessages(cna(Noisedata[[i]], ordering=list(outcome), strict=T, con=QCA.cons[[i]],cov=QCA.cov[[i]], 
                                             rm.const.factors=F, rm.dup.factors=F,maxstep = c(5,7,25)))
    } else {NULL} 
   
  }
  anaCNA.imitate <- lapply(anaCNA.imitate, function(r) if(!is.null(r)){suppressMessages(asf(r)$condition)}else{NULL})
  anaCNA.imitate <- lapply(anaCNA.imitate, function(r) if(length(r)==0){NULL}else{r})

  
  # Comparison
  # ----------
  # standard_QMC 
  for(i in 1:n){
    score.inter.imitate[[i]] <- identical.output(anaPSlow[[i]],anaCNA.imitate[[i]])
  }
  x <- unlist(score.inter.imitate) 
  
  resultsCrisp[s,6] <- length(x[which(x)])/n
  

  
  # CCUBES
  cat(s,"ccubes \n")
  # QCA analysis
  # ------------
   anaCCubes <- lapply(tt, function(x) tryCatch(minimize(x, all.sol = T, include = "?", sol.cons=incl.cut,
                                                         sol.cov = incl.cut,method = "CCubes"), error=function(e){NULL}))
  # transform syntax
  anaCCubeslow <- lapply(anaCCubes, function(x) lapply(x$solution, function(y)negTOlow(y) ))
  anaCCubeslow <- lapply(anaCCubeslow,function(t) lapply(t,function(s)paste(s,collapse = "+")))
  anaCCubeslow <- lapply(anaCCubeslow,function(t) lapply(t,function(s)paste0(s,"<->",outcome)))
  anaCCubeslow <- lapply(anaCCubeslow,function(t) unlist(t))
   

  # CNA analysis 
  # -------------
  # same as standard_QMC
  
  
  # Comparison
  # ----------
  # standard_QMC 
  for(i in 1:n){
    score.inter.ccubes[[i]] <- identical.output(anaCCubeslow[[i]],anaCNA[[i]])
  }
  x <- unlist(score.inter.ccubes) 
  
  resultsCrisp[s,7] <- length(x[which(x)])/n
  
  
  
  
  
 storage[[s]] <- list(Noisedata, anaPSlow, anaCNA, anaCNA.imitate,anaCCubeslow) 
  
}



#storage[[14]][[4]][[3]]
#storage[[14]][[2]][[3]]
selection1_QMC <- as.data.frame(resultsCrisp[,c(2:7)])
saveRDS(resultsCrisp, file="resultsCrisp_QMC.RDS")
saveRDS(storage, file = "storage_QMC.RDS")
saveRDS(selection1_QMC, file = "selection1_QMC.RDS")
}


####produce plot####
selection1_QMC <- selection1_QMC %>% group_by(noise, incl, ssize, standard_QMC ,imitate, CCubes) 
colnames(selection1_QMC)
colnames(selection1_QMC) <- c("ssize", "noise","incl","standard", "imitate", "CCubes")
k1 <- melt(selection1_QMC, id.vars = c("noise",  "ssize", "incl")) 
k1$noise <- k1$noise*100
k1$noise<- as.character(k1$noise)
k1$noise <- paste0(k1$noise,"%")
k1$noise <- factor(k1$noise,levels = c("0%","10%","20%"))
k1$incl <- paste0("threshold=",k1$incl)
k1$variable <- factor(k1$variable,levels = c("standard","imitate","CCubes"))
k1$incl <- factor(k1$incl,levels = c("threshold=1","threshold=0.8","threshold=0.75"))
k1 <- k1 %>% tidyr:::unite("BothLabels", incl, ssize, sep = ", n=", remove = FALSE)
k1$BothLabels <- factor(k1$BothLabels,levels = unique(k1$BothLabels))

plot1_QMC <- ggplot(k1, aes(x = noise, y = value,fill = variable)) +
  geom_bar(stat="identity", position = position_dodge(width = .7), width=.6) +
  scale_fill_grey(start = 0, end = 0.85) +
  theme_bw() +facet_wrap(vars(BothLabels)) +
 theme(plot.title = element_text(size = 3), axis.text.x = element_text( size = 8 ), 
        axis.text.y = element_text( size = 8 ),axis.title = element_text( size = 8), legend.spacing.x = unit(0.5, 'cm'),
        legend.title = element_blank(),strip.text = element_text(size = 8),legend.text=element_text(size=8,margin = margin(l = -8, r=10,unit = "pt")))+
   scale_x_discrete(name ="noise ratios")+ylim(0, 1.1) +theme(legend.position="top") +
   ylab("identical output") + 
  geom_text(aes(label=value),size=1.7, position=position_dodge(width=0.7), check_overlap = TRUE, vjust=-0.3)

plot1_QMC
saveRDS(plot1_QMC, file = "plot1_QMC.RDS")


#produce plot only for standard_QMC
selection2_QMC <- as.data.frame(resultsCrisp[,c(2:5)])
selection2_QMC <- selection2_QMC %>% group_by(noise, incl, ssize, standard_QMC) 
k2 <- melt(selection2_QMC, id.vars = c("noise",  "ssize", "incl")) 
k2$noise <- k2$noise*100
k2$noise<- as.character(k2$noise)
k2$noise <- paste0(k2$noise,"%")
k2$noise <- factor(k2$noise,levels = c("0%","10%","20%"))
k2$incl <- paste0("threshold=",k2$incl)
k2$variable <- factor(k2$variable,levels = c("standard"))
k2$incl <- factor(k2$incl,levels = c("threshold=1","threshold=0.8","threshold=0.75"))
k2 <- k2 %>% tidyr:::unite("BothLabels", incl, ssize, sep = ", n=", remove = FALSE)
k2$BothLabels <- factor(k2$BothLabels,levels = unique(k2$BothLabels))
plot2_QMC <- ggplot(k2, aes(x = noise, y = value,fill = variable)) +
  geom_bar(stat="identity", position = position_dodge(width = .7), width=.6, fill="black") +
  scale_fill_grey(start = 0, end = 0.85) +  theme_bw() +
  facet_wrap(vars(BothLabels)) +
  theme(plot.title = element_text(size = 3), axis.text.x = element_text( size = 8 ), 
        axis.text.y = element_text( size = 8 ),axis.title = element_text( size = 8), legend.spacing.x = unit(0.5, 'cm'),
        legend.title = element_blank(),strip.text = element_text(size = 8),legend.text=element_text(size=8,margin = margin(l = -8, r=10,unit = "pt")))+
  scale_x_discrete(name ="noise ratios")+ylim(0, 1.1) +theme(legend.position="top") +
  ylab("identical output") + 
  geom_text(aes(label=value),size=3, vjust=-0.5) 

plot2_QMC
saveRDS(plot2_QMC, file = "plot2_QMC.RDS")