setwd("/home/yuanhao/github_repositories/DISC/reproducibility")
utilities_path = "./source/utilities.r"
source(utilities_path)
#### STEP 1
#Here, we use BONE_MARROW dataset. The detail information of this dataset can be seen at https://raw.githack.com/iyhaoo/DISC/master/reproducibility/data_preparation_and_imputation/data_preprocessing_BONE_MARROW.nb.html.</br>
#  We used the raw data after gene selection for cell identification.
gene_bc_mat = readh5_loom("./data/BONE_MARROW/raw.loom")
gene_bc_filt = gene_bc_mat[gene_selection(gene_bc_mat, 10), ]
dim(gene_bc_filt) #  13813, 6939
used_genes = rownames(gene_bc_filt)
output_dir = "./results/BONE_MARROW"
dir.create(output_dir, showWarnings = F, recursive = T)
#### STEP 2
#Following this script (https://github.com/Winnie09/imputationBenchmark/blob/master/data/code/process/07_hca_assign_celltype.R), we use the bulk-sequence data (https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GSE74246) of 13 normal hematopoietic cell types and 3 acute myeloid leukemia cell types for cell identification, the file is downloaded from https://www.ncbi.nlm.nih.gov/geo/download/?acc=GSE74246&format=file&file=GSE74246%5FRNAseq%5FAll%5FCounts%2Etxt%2Egz.
if(!file.exists("./data/BONE_MARROW/cell_type.rds")){
  library(scran)
  scran_normalization = function(gene_bc_mat){
    #  The source of this function is https://github.com/Winnie09/imputationBenchmark/blob/master/data/code/process/06_make_hca_MantonBM6.R
    dimnames_gene_bc_mat = dimnames(gene_bc_mat)
    dimnames(gene_bc_mat) = list()
    sce = SingleCellExperiment(list(counts = gene_bc_mat))
    no_cores = max(c(detectCores() - 1, 1))
    if(ncol(gene_bc_mat) < 21){
      sce = computeSumFactors(sce, BPPARAM = MulticoreParam(workers = no_cores), sizes = c(5, 10, 15, 20))
    } else {
      sce = computeSumFactors(sce, BPPARAM = MulticoreParam(workers = no_cores))
    }
    sf = sizeFactors(sce)
    dimnames(gene_bc_mat) = dimnames_gene_bc_mat
    return(log2(sweep(gene_bc_mat, 2, sf, "/") + 1))
  }
  scalematrix = function(data){
    cm = rowMeans(data)
    csd = apply(data, 1, sd)
    (data - cm) / csd
  }
  corfunc = function(m1, m2){
    scalematrix(t(m1)) %*% t(scalematrix(t(m2))) / (nrow(m1) - 1)
  }
  gene_bulk_all = as.matrix(read.table("./data/BONE_MARROW/original_data/GSE74246_RNAseq_All_Counts.txt.gz", header = T, row.names = 1))
  gene_bulk_mat = gene_bulk_all[, grep("^X", colnames(gene_bulk_all))]
  #  Use annotation information
  gz_path = "./data/hg19/Homo_sapiens.GRCh37.87.gtf.gz"
  annotation_mat = get_map(gz_path)
  tgngl = tapply(annotation_mat[, "gene_length"] / 1000, annotation_mat[, "gene_name"], max)
  gngl = as.vector(tgngl)
  names(gngl) = names(tgngl)
  gene_bulk_filt = gene_bulk_mat[row.names(gene_bulk_mat) %in% names(gngl),]
  gene_bulk_norm = sweep(gene_bulk_filt / gngl[rownames(gene_bulk_filt)], 2, colSums(gene_bulk_filt) / 1e6, "/")
  bulk_data = log2(gene_bulk_norm[rowSums(gene_bulk_norm) > 0,] + 1)
  bulk_cell_type = sapply(colnames(bulk_data), function(x){
    strsplit(x,"\\.")[[1]][2]
  }, USE.NAMES = F)
  sc_data = scran_normalization(gene_bc_filt)
  rownames(sc_data) = sub(".*:", "", rownames(gene_bc_filt))
  used_genes = intersect(rownames(bulk_data), rownames(sc_data))
  bulk_filt = bulk_data[used_genes, ]
  sc_filt = sc_data[used_genes, ]
  #  The expression level for each cell type in bulk sequencing
  bulk_mean = sapply(unique(bulk_cell_type),function(x) {
    rowMeans(bulk_filt[ , bulk_cell_type == x])
  })
  #  Find 100 top postive differentially expressed genes for each celltype pair.
  DEG_list = list()
  top_number = 100
  unique_celltype_pairs = combn(ncol(bulk_mean), 2)
  for(ii in seq(ncol(unique_celltype_pairs))){
    celltype_1 = colnames(bulk_mean)[unique_celltype_pairs[1, ii]]
    celltype_2 = colnames(bulk_mean)[unique_celltype_pairs[2, ii]]
    sort_result = sort(bulk_mean[ , celltype_1] - bulk_mean[ , celltype_2], decreasing = FALSE)
    DEG_list[[paste(celltype_2, celltype_1, sep = "-")]] = names(sort_result)[seq(top_number)]
    DEG_list[[paste(celltype_1, celltype_2, sep = "-")]] = names(sort_result)[seq(from = length(sort_result), to = length(sort_result) - (top_number - 1))]
  }
  #  Calculate the mean expression of these top-gene combinations across cell types (bulk) or cells (single-cell).
  expression_mean_function = function(gene_bc_norm, DEG_list){
    return(t(sapply(DEG_list, function(x){
      colMeans(gene_bc_norm[x, ])
    })))
  }
  bulk_DEG_expression_mean = expression_mean_function(bulk_mean, DEG_list)
  sc_DEG_expression_mean = expression_mean_function(sc_filt, DEG_list)
  #  Calculate the expression variation of these top-gene combinations across cell types (bulk) or cells (single-cell).
  expression_variation_function = function(x){
    return((x - rowMeans(x)) / apply(x, 1, sd))
  }
  bulk_DEG_expression_variation = expression_variation_function(bulk_DEG_expression_mean)
  sc_DEG_expression_variation = expression_variation_function(sc_DEG_expression_mean)
  #  Each top-gene combination correspond a cell type.
  bulk_DEG_combination_rank = apply(bulk_DEG_expression_variation, 2, rank)
  sc_DEG_combination_rank = apply(sc_DEG_expression_variation, 2, rank)
  #  Cell type identification.
  maxcorcut = 0.6
  difcorcut = 0
  cormat = corfunc(sc_DEG_combination_rank, bulk_DEG_combination_rank)
  maxcor = apply(cormat, 1, max)
  max2cor = apply(cormat, 1, function(x){
    sort(x, decreasing = T)[2]
  })
  cell_type = colnames(cormat)[apply(cormat, 1, which.max)]
  cell_type[maxcor < maxcorcut] = NA
  cell_type[maxcor - max2cor < difcorcut] = NA
  names(cell_type) = colnames(sc_data)
  saveRDS(cell_type, "./data/BONE_MARROW/cell_type.rds")
}else{
  cell_type = readRDS("./data/BONE_MARROW/cell_type.rds")
}
print("Cell Type ... OK!")
### Trajectory evaluation
#After cell identification, we evaluate the trajectory performance using monocle following these scripts(https://github.com/Winnie09/imputationBenchmark/blob/93f27e890a86fdc732257a4036bf38a52faf9f33/trajectory/code/hca/monocle2/01_get_score.R, https://github.com/Winnie09/imputationBenchmark/blob/93f27e890a86fdc732257a4036bf38a52faf9f33/trajectory/code/hca/tscan/01_get_score.R).
###  monocle2
library(monocle)
get_cds_monocle2 = function(gene_bc_mat, cell_type, cell_level_df){
  #  Firstly make a new CDS and use DDRTree for dimension reduction.
  pd = new("AnnotatedDataFrame", data = data.frame(row.names = colnames(gene_bc_mat), cell = colnames(gene_bc_mat)))
  fd = new("AnnotatedDataFrame", data = data.frame(row.names = rownames(gene_bc_mat), gene_short_name = rownames(gene_bc_mat)))
  cds = newCellDataSet(gene_bc_mat, phenoData = pd, featureData = fd, expressionFamily = negbinomial.size())
  cds = estimateSizeFactors(cds)
  cds = estimateDispersions(cds)
  print("Reducing dimension...")
  cds = reduceDimension(cds)
  cds = orderCells(cds)
  print("Looking for the root state...")
  cell_states = as.numeric(as.character(pData(cds)$State))
  names(cell_states) = colnames(gene_bc_mat)
  unique_states = unique(cell_states)
  checkroot = sapply(unique_states, function(x){
    cds = orderCells(cds, root_state = x)
    return(length(cds@auxOrderingData[[cds@dim_reduce_type]]$root_cell))
  })
  unique_states_filt = unique_states[checkroot > 0]
  root_state = unique_states_filt[which.min(sapply(unique_states_filt, function(x){
    return(mean(cell_level_df[cell_type[names(cell_states)[cell_states == x]], "level"], na.rm = T))
  }))]
  #  Reorder the cells.
  return(orderCells(cds, root_state = root_state))
}
ct <- data.frame(cell=names(cell_type),cluster=NA,celltype=cell_type,stringsAsFactors = F)
ctlevel <- data.frame(ct=c('HSC','MPP','LMPP','CMP','CLP','GMP','MEP',"Bcell","CD4Tcell","CD8Tcell",'NKcell','Mono','Ery'),level=c(1,2,3,3,4,4,4,5,5,5,5,5,5),immunepath=c(1,1,1,0,1,0,0,1,1,1,1,0,0),monopath=c(1,1,1,1,0,1,0,0,0,0,0,1,0),erypath=c(1,1,0,1,0,0,1,0,0,0,0,0,1),stringsAsFactors = F)
row.names(ctlevel) <- ctlevel[,1]

correctorder <- wrongorder <- NULL
for(pid in c('immunepath','monopath','erypath')) {
  evct <- ctlevel[ctlevel[,pid]==1,1]
  pair <- expand.grid(evct,evct)
  pair[,1] <- as.character(pair[,1])
  pair[,2] <- as.character(pair[,2])
  pair <- pair[pair[,1]!=pair[,2],]
  corid <- which(ctlevel[pair[,1],'level'] < ctlevel[pair[,2],'level'])
  wroid <- which(ctlevel[pair[,1],'level'] > ctlevel[pair[,2],'level'])
  correctorder <- c(correctorder,sapply(corid,function(si) paste0(pair[si,],collapse = '_')))
  wrongorder <- c(wrongorder,sapply(wroid,function(si) paste0(pair[si,],collapse = '_')))
}
correctorder <- unique(correctorder)
wrongorder <- unique(wrongorder)

scorefunc <- function(cds) {
  if (length(cds@auxOrderingData[[cds@dim_reduce_type]]$branch_points) > 0) {
    sl <- NULL
    for(i in 1:length(cds@auxOrderingData[[cds@dim_reduce_type]]$branch_points)){
      tryCatch({cds_reduced <- buildBranchCellDataSet(cds,branch_point=i)},error=function(e) {})
      df = data.frame(pData(cds_reduced),stringsAsFactors = F)
      df <- df[order(df$Pseudotime),]
      sl <- rbind(sl,rowSums(sapply(unique(df$Branch),function(ub) {
        so <- as.character(df[df[,'Branch']==ub,1])
        soct <- ct[match(so,ct[,1]),3]
        eid <- expand.grid(1:length(soct),1:length(soct))
        eid <- eid[eid[,1]<eid[,2],]
        eid <- sprintf('%s_%s',soct[eid[,1]],soct[eid[,2]])
        c(sum(eid %in% correctorder),sum(eid %in% wrongorder))
      })))
    }
    print(sl)
    outpur_sl = sl[which.max(sl[,1]/rowSums(sl)),]
    pair_number = sum(outpur_sl)
    acc = outpur_sl[1] / pair_number
    return(c(pair_number, acc))
  } else {
    return(NA)
  }
}

######
this_method = "raw"
gene_bc_mat = readh5_loom(paste0("./data/BONE_MARROW/", this_method, ".loom"))
gene_bc_filt = gene_bc_mat[used_genes, ]
this_output_dir = paste0(output_dir, "/all_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
used_cells = names(cell_type)[!is.na(cell_type)]
cds = get_cds_monocle2(gene_bc_filt[, used_cells], cell_type, cell_level_df)
cell_order = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(cell_order, unique(unlist(order_list[["correct"]])), unique(unlist(order_list[["wrong"]])))
p = plot_cell_trajectory(cds, color_by = "Pseudotime")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_pseudotime.pdf"), p)
pData(cds)$CellType = cell_type[used_cells]
p = plot_cell_trajectory(cds, color_by = "CellType")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_celltype.pdf"), p)
pData(cds)$level = as.character(cell_level_df[cell_type[used_cells], "level"])
p = plot_cell_trajectory(cds, color_by = "level")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_level.pdf"), p)
cat(ii, " - ", length(cell_order), " pairs\n")
cat(ii, " - ", acc, "\n")
result_list = list(cds = cds, acc = acc)
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_all_result.rds"))

###
this_method = "DISC"
gene_bc_mat = readh5_loom(paste0("./data/BONE_MARROW/", this_method, ".loom"))
gene_bc_filt = gene_bc_mat[used_genes, ]
this_output_dir = paste0(output_dir, "/all_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
used_cells = names(cell_type)[!is.na(cell_type)]
cds = get_cds_monocle2(gene_bc_filt[, used_cells], cell_type, cell_level_df)
cell_order = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(cell_order, unique(unlist(order_list[["correct"]])), unique(unlist(order_list[["wrong"]])))
p = plot_cell_trajectory(cds, color_by = "Pseudotime")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_pseudotime.pdf"), p)
pData(cds)$CellType = cell_type[used_cells]
p = plot_cell_trajectory(cds, color_by = "CellType")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_celltype.pdf"), p)
pData(cds)$level = as.character(cell_level_df[cell_type[used_cells], "level"])
p = plot_cell_trajectory(cds, color_by = "level")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_level.pdf"), p)
cat(ii, " - ", length(cell_order), " pairs\n")
cat(ii, " - ", acc, "\n")
result_list = list(cds = cds, acc = acc)
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_all_result.rds"))

###
this_method = "scVI"
gene_bc_mat = readh5_imputation(paste0("./data/BONE_MARROW/", this_method, ".hdf5"))
gene_bc_filt = gene_bc_mat[used_genes, ]
this_output_dir = paste0(output_dir, "/all_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
used_cells = names(cell_type)[!is.na(cell_type)]
cds = get_cds_monocle2(gene_bc_filt[, used_cells], cell_type, cell_level_df)
cell_order = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(cell_order, unique(unlist(order_list[["correct"]])), unique(unlist(order_list[["wrong"]])))
p = plot_cell_trajectory(cds, color_by = "Pseudotime")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_pseudotime.pdf"), p)
pData(cds)$CellType = cell_type[used_cells]
p = plot_cell_trajectory(cds, color_by = "CellType")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_celltype.pdf"), p)
pData(cds)$level = as.character(cell_level_df[cell_type[used_cells], "level"])
p = plot_cell_trajectory(cds, color_by = "level")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_level.pdf"), p)
cat(ii, " - ", length(cell_order), " pairs\n")
cat(ii, " - ", acc, "\n")
result_list = list(cds = cds, acc = acc)
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_all_result.rds"))

###
this_method = "DCA"
gene_bc_mat = readh5_imputation(paste0("./data/BONE_MARROW/", this_method, ".hdf5"))
gene_bc_filt = gene_bc_mat[used_genes, ]
this_output_dir = paste0(output_dir, "/all_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
used_cells = names(cell_type)[!is.na(cell_type)]
cds = get_cds_monocle2(gene_bc_filt[, used_cells], cell_type, cell_level_df)
cell_order = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(cell_order, unique(unlist(order_list[["correct"]])), unique(unlist(order_list[["wrong"]])))
p = plot_cell_trajectory(cds, color_by = "Pseudotime")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_pseudotime.pdf"), p)
pData(cds)$CellType = cell_type[used_cells]
p = plot_cell_trajectory(cds, color_by = "CellType")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_celltype.pdf"), p)
pData(cds)$level = as.character(cell_level_df[cell_type[used_cells], "level"])
p = plot_cell_trajectory(cds, color_by = "level")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_level.pdf"), p)
cat(ii, " - ", length(cell_order), " pairs\n")
cat(ii, " - ", acc, "\n")
result_list = list(cds = cds, acc = acc)
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_all_result.rds"))

###
this_method = "scScope"
gene_bc_mat = readh5_imputation(paste0("./data/BONE_MARROW/", this_method, ".hdf5"))
gene_bc_filt = gene_bc_mat[used_genes, ]
this_output_dir = paste0(output_dir, "/all_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
used_cells = names(cell_type)[!is.na(cell_type)]
cds = get_cds_monocle2(gene_bc_filt[, used_cells], cell_type, cell_level_df)
cell_order = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(cell_order, unique(unlist(order_list[["correct"]])), unique(unlist(order_list[["wrong"]])))
p = plot_cell_trajectory(cds, color_by = "Pseudotime")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_pseudotime.pdf"), p)
pData(cds)$CellType = cell_type[used_cells]
p = plot_cell_trajectory(cds, color_by = "CellType")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_celltype.pdf"), p)
pData(cds)$level = as.character(cell_level_df[cell_type[used_cells], "level"])
p = plot_cell_trajectory(cds, color_by = "level")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_level.pdf"), p)
cat(ii, " - ", length(cell_order), " pairs\n")
cat(ii, " - ", acc, "\n")
result_list = list(cds = cds, acc = acc)
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_all_result.rds"))

###
this_method = "MAGIC"
gene_bc_mat = readh5_imputation(paste0("./data/BONE_MARROW/", this_method, ".hdf5"))
gene_bc_filt = gene_bc_mat[used_genes, ]
this_output_dir = paste0(output_dir, "/all_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
used_cells = names(cell_type)[!is.na(cell_type)]
cds = get_cds_monocle2(gene_bc_filt[, used_cells], cell_type, cell_level_df)
cell_order = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(cell_order, unique(unlist(order_list[["correct"]])), unique(unlist(order_list[["wrong"]])))
p = plot_cell_trajectory(cds, color_by = "Pseudotime")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_pseudotime.pdf"), p)
pData(cds)$CellType = cell_type[used_cells]
p = plot_cell_trajectory(cds, color_by = "CellType")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_celltype.pdf"), p)
pData(cds)$level = as.character(cell_level_df[cell_type[used_cells], "level"])
p = plot_cell_trajectory(cds, color_by = "level")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_level.pdf"), p)
cat(ii, " - ", length(cell_order), " pairs\n")
cat(ii, " - ", acc, "\n")
result_list = list(cds = cds, acc = acc)
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_all_result.rds"))

###
this_method = "VIPER"
gene_bc_mat = readh5_imputation(paste0("./data/BONE_MARROW/", this_method, ".hdf5"))
gene_bc_filt = gene_bc_mat[used_genes, ]
this_output_dir = paste0(output_dir, "/all_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
used_cells = names(cell_type)[!is.na(cell_type)]
cds = get_cds_monocle2(gene_bc_filt[, used_cells], cell_type, cell_level_df)
cell_order = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(cell_order, unique(unlist(order_list[["correct"]])), unique(unlist(order_list[["wrong"]])))
p = plot_cell_trajectory(cds, color_by = "Pseudotime")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_pseudotime.pdf"), p)
pData(cds)$CellType = cell_type[used_cells]
p = plot_cell_trajectory(cds, color_by = "CellType")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_celltype.pdf"), p)
pData(cds)$level = as.character(cell_level_df[cell_type[used_cells], "level"])
p = plot_cell_trajectory(cds, color_by = "level")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_level.pdf"), p)
cat(ii, " - ", length(cell_order), " pairs\n")
cat(ii, " - ", acc, "\n")
result_list = list(cds = cds, acc = acc)
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_all_result.rds"))

###
this_method = "scImpute"
gene_bc_mat = readh5_imputation(paste0("./data/BONE_MARROW/", this_method, ".hdf5"))
gene_bc_filt = gene_bc_mat[used_genes, ]
this_output_dir = paste0(output_dir, "/all_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
used_cells = names(cell_type)[!is.na(cell_type)]
cds = get_cds_monocle2(gene_bc_filt[, used_cells], cell_type, cell_level_df)
cell_order = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(cell_order, unique(unlist(order_list[["correct"]])), unique(unlist(order_list[["wrong"]])))
p = plot_cell_trajectory(cds, color_by = "Pseudotime")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_pseudotime.pdf"), p)
pData(cds)$CellType = cell_type[used_cells]
p = plot_cell_trajectory(cds, color_by = "CellType")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_celltype.pdf"), p)
pData(cds)$level = as.character(cell_level_df[cell_type[used_cells], "level"])
p = plot_cell_trajectory(cds, color_by = "level")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_level.pdf"), p)
cat(ii, " - ", length(cell_order), " pairs\n")
cat(ii, " - ", acc, "\n")
result_list = list(cds = cds, acc = acc)
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_all_result.rds"))

###
this_method = "DeepImpute"
gene_bc_mat = readh5_imputation(paste0("./data/BONE_MARROW/", this_method, ".hdf5"))
gene_bc_filt = gene_bc_mat[used_genes, ]
this_output_dir = paste0(output_dir, "/all_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
used_cells = names(cell_type)[!is.na(cell_type)]
cds = get_cds_monocle2(gene_bc_filt[, used_cells], cell_type, cell_level_df)
acc = get_score_monocle2(cds, cell_type, unique(unlist(order_list[["correct"]])), unique(unlist(order_list[["wrong"]])))
p = plot_cell_trajectory(cds, color_by = "Pseudotime")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_pseudotime.pdf"), p)
pData(cds)$CellType = cell_type[used_cells]
p = plot_cell_trajectory(cds, color_by = "CellType")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_celltype.pdf"), p)
pData(cds)$level = as.character(cell_level_df[cell_type[used_cells], "level"])
p = plot_cell_trajectory(cds, color_by = "level")
ggsave(paste0(this_output_dir, "/", this_method, "_monocle2_", ii, "_level.pdf"), p)
cat(ii, " - ", length(cell_order), " pairs\n")
cat(ii, " - ", acc, "\n")
result_list = list(cds = cds, acc = acc)
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_all_result.rds"))

###
method_names = c("raw", "DISC", "scImpute", "VIPER", "MAGIC", "DCA", "DeepImpute", "scScope", "scVI")
pair_list = list()
for(ii in method_names){
  result_list = readRDS(paste0(output_dir, "/", ii, "_monocle2_all_result.rds"))
  pair_num_acc = scorefunc(result_list[["cds"]])
  cat(ii, " - ", pair_num_acc[1], " - ", pair_num_acc[2], "\n")
}

result_list = readRDS(paste0(output_dir, "/", "DISC", "_monocle2_all_result.rds"))
p = plot_cell_trajectory(result_list[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/test_monocle2_pseudotime.pdf"), p)
p = plot_cell_trajectory(result_list[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/test_monocle2_celltype.pdf"), p)
p = plot_cell_trajectory(result_list[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/test_monocle2_level.pdf"), p)
all_branch_points = result_list[["cds"]]@auxOrderingData[[result_list[["cds"]]@dim_reduce_type]]$branch_points
for(i in 1:length(all_branch_points)){
  cds_reduced <- buildBranchCellDataSet(result_list[["cds"]], branch_point = i)
  print(all_branch_points[i])
  pData(result_list[["cds"]])$Branch = pData(cds_reduced)[pData(result_list[["cds"]])$cell, "Branch"]
  p = plot_cell_trajectory(result_list[["cds"]], color_by = "Branch")
  ggsave(paste0(output_dir, "/test_", all_branch_points[i], "_monocle2_level.pdf"), p)
}

method_names = c("raw", "DISC", "scImpute", "VIPER", "MAGIC", "DCA", "DeepImpute", "scScope", "scVI")
for(ii in method_names){
  result_list = readRDS(paste0(output_dir, "/", ii, "_monocle2_all_result.rds"))
  p = plot_cell_trajectory(result_list[["cds"]], color_by = "Pseudotime")
  ggsave(paste0(output_dir, "/", ii, "_monocle2_pseudotime.pdf"), p)
  p = plot_cell_trajectory(result_list[["cds"]], color_by = "CellType")
  ggsave(paste0(output_dir, "/", ii, "_monocle2_celltype.pdf"), p)
  p = plot_cell_trajectory(result_list[["cds"]], color_by = "level")
  ggsave(paste0(output_dir, "/", ii, "_monocle2_level.pdf"), p)
  p = plot_cell_trajectory(result_list[["cds"]], color_by = "State")
  ggsave(paste0(output_dir, "/", ii, "_monocle2_state.pdf"), p)
  all_branch_points = result_list[["cds"]]@auxOrderingData[[result_list[["cds"]]@dim_reduce_type]]$branch_points
  for(jj in 1:length(all_branch_points)){
    cds_tmp = result_list[["cds"]]
    cds_reduced = buildBranchCellDataSet(cds_tmp, branch_point = jj)
    df = data.frame(pData(cds_reduced),stringsAsFactors = F)
    cells = as.character(pData(cds_tmp)$cell)
    print(all_branch_points[jj])
    pData(cds_tmp)$Pseudotime = df[cells, "Pseudotime"]
    pData(cds_tmp)$Branch = df[cells, "Branch"]
    pData(cds_tmp)$State = df[cells, "State"]
    p = plot_cell_trajectory(cds_tmp, color_by = "Pseudotime")
    ggsave(paste0(output_dir, "/", ii, "_", all_branch_points[jj], "_monocle2_pseudotime.pdf"), p)
    p = plot_cell_trajectory(cds_tmp, color_by = "Branch")
    ggsave(paste0(output_dir, "/", ii, "_", all_branch_points[jj], "_monocle2_branch.pdf"), p)
    p = plot_cell_trajectory(cds_tmp, color_by = "State")
    ggsave(paste0(output_dir, "/", ii, "_", all_branch_points[jj], "_monocle2_state.pdf"), p)
    cat(ii, " - ", jj, "\n")
  }
}

ii = "raw"
result_list = readRDS(paste0(output_dir, "/", ii, "_monocle2_all_result.rds"))
p = plot_cell_trajectory(result_list[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/", ii, "_monocle2_pseudotime.pdf"), p)
p = plot_cell_trajectory(result_list[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/", ii, "_monocle2_celltype.pdf"), p)
p = plot_cell_trajectory(result_list[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/", ii, "_monocle2_level.pdf"), p)
all_branch_points = result_list[["cds"]]@auxOrderingData[[result_list[["cds"]]@dim_reduce_type]]$branch_points
for(i in 1:length(all_branch_points)){
  cds_reduced <- buildBranchCellDataSet(result_list[["cds"]],branch_point = i)
  print(all_branch_points[i])
  pData(result_list[["cds"]])$Branch = pData(cds_reduced)[pData(result_list[["cds"]])$cell, "Branch"]
  p = plot_cell_trajectory(result_list[["cds"]], color_by = "Branch")
  ggsave(paste0(output_dir, "/", ii, "_", all_branch_points[i], "_monocle2_level.pdf"), p)
}

ii = "DCA"
result_list = readRDS(paste0(output_dir, "/", ii, "_monocle2_all_result.rds"))
p = plot_cell_trajectory(result_list[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/", ii, "_monocle2_pseudotime.pdf"), p)
p = plot_cell_trajectory(result_list[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/", ii, "_monocle2_celltype.pdf"), p)
p = plot_cell_trajectory(result_list[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/", ii, "_monocle2_level.pdf"), p)
all_branch_points = result_list[["cds"]]@auxOrderingData[[result_list[["cds"]]@dim_reduce_type]]$branch_points
for(i in 1:length(all_branch_points)){
  cds_reduced <- buildBranchCellDataSet(result_list[["cds"]],branch_point = i)
  print(all_branch_points[i])
  pData(result_list[["cds"]])$Branch = pData(cds_reduced)[pData(result_list[["cds"]])$cell, "Branch"]
  p = plot_cell_trajectory(result_list[["cds"]], color_by = "Branch")
  ggsave(paste0(output_dir, "/", ii, "_", all_branch_points[i], "_monocle2_level.pdf"), p)
}

get_order_pairs_monocle2 = function(cds, cell_type){
  pair_list = list()
  if(length(cds@auxOrderingData[[cds@dim_reduce_type]]$branch_points) > 0){
    for(ii in seq(length(cds@auxOrderingData[[cds@dim_reduce_type]]$branch_points))){
      cds_reduced = buildBranchCellDataSet(cds, branch_point = ii)
      df = data.frame(pData(cds_reduced),stringsAsFactors = F)[names(cell_type), ]
      df = df[order(df$Pseudotime), ]
      compare_order = c()
      for(jj in unique(df$Branch)){
        branch_cell = as.character(df[df$Branch == jj, 1])
        branch_celltype = cell_type[branch_cell]
        index_pair = combn(length(branch_cell), 2)
        if(min(index_pair[2,] - index_pair[1,]) < 0){
          stop("index_pair error")
        }
        branch_order = sprintf('%s_%s',branch_celltype[index_pair[1, ]], branch_celltype[index_pair[2, ]])
        branch_pair = sprintf('%s_%s',branch_cell[index_pair[1, ]], branch_cell[index_pair[2, ]])
        names(branch_order) = branch_pair
        compare_order = c(compare_order, branch_order)
      }
      pair_list[[ii]] = compare_order
    }
  }else{
    print("Trajectory has only 1 branch.")
    df = data.frame(pData(cds),stringsAsFactors = F)[names(cell_type), ]
    df = df[order(df$Pseudotime), ]
    branch_cell = as.character(df[, 1])
    branch_celltype = cell_type[branch_cell]
    index_pair = combn(length(branch_cell), 2)
    if(min(index_pair[2,] - index_pair[1,]) < 0){
      stop("index_pair error")
    }
    branch_order = sprintf('%s_%s',branch_celltype[index_pair[1, ]], branch_celltype[index_pair[2, ]])
    branch_pair = sprintf('%s_%s',branch_cell[index_pair[1, ]], branch_cell[index_pair[2, ]])
    names(branch_order) = branch_pair
    pair_list[[1]] = branch_order
  }
  return(pair_list)
}
acc_function = function(pair_list, correctorder, wrongorder, compare_pairs = NULL){
  acc = 0
  for(ii in pair_list){
    if(is.null(compare_pairs)){
      score = c(sum(ii %in% correctorder), sum(ii %in% wrongorder))
    }else{
      compare_order = ii[intersect(names(ii), compare_pairs)]
      score = c(sum(compare_order %in% correctorder), sum(compare_order %in% wrongorder))
    }
    acc = max(c(acc, score[1] / sum(score)))
  }
  return(acc)
}

cell_type = readRDS("./data/BONE_MARROW/cell_type.rds")
ctlevel <- data.frame(cell_type=c('HSC','MPP','LMPP','CMP','CLP','GMP','MEP',"Bcell","CD4Tcell","CD8Tcell",'NKcell','Mono','Ery'),level=c(1,2,3,3,4,4,4,5,5,5,5,5,5),immunepath=c(1,1,1,0,1,0,0,1,1,1,1,0,0),monopath=c(1,1,1,1,0,1,0,0,0,0,0,1,0),erypath=c(1,1,0,1,0,0,1,0,0,0,0,0,1),stringsAsFactors = F)
row.names(ctlevel) <- ctlevel[,1]
correctorder <- wrongorder <- NULL
for(pid in c('immunepath','monopath','erypath')) {
  evct <- ctlevel[ctlevel[,pid]==1,1]
  pair <- expand.grid(evct,evct)
  pair[,1] <- as.character(pair[,1])
  pair[,2] <- as.character(pair[,2])
  pair <- pair[pair[,1]!=pair[,2],]
  corid <- which(ctlevel[pair[,1],'level'] < ctlevel[pair[,2],'level'])
  wroid <- which(ctlevel[pair[,1],'level'] > ctlevel[pair[,2],'level'])
  correctorder <- c(correctorder,sapply(corid,function(si) paste0(pair[si,],collapse = '_')))
  wrongorder <- c(wrongorder,sapply(wroid,function(si) paste0(pair[si,],collapse = '_')))
}
correctorder <- unique(correctorder)
wrongorder <- unique(wrongorder)
scVI_res = readRDS("/home/yuanhao/github_repositories/DISC/reproducibility/results/BONE_MARROW/scVI_monocle2_all_result.rds")
pair_list = get_order_pairs_monocle2(scVI_res[["cds"]], cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)

DISC_res = readRDS("/home/yuanhao/github_repositories/DISC/reproducibility/results/BONE_MARROW/DISC_monocle2_all_result.rds")
pair_list = get_order_pairs_monocle2(DISC_res[["cds"]], cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)


library(digest)

input <- "Rosetta code"
cat(digest(input, algo = "sha256", serialize = FALSE), "\n")


# If you use this code or parts of it, please cite the following paper
# Bruhin A., E. Fehr, D. Schunk (2018): "The Many Faces of Human Sociality: Uncovering the Distribution and Stability of Social Preferences",
# Journal of the European Economic Association, forthcoming.
# ===========================================================================================================================================

rm(list=ls()) # Clear the memory

# Function to prepare data sets for out of sample predictions
f.combine <- function(choices, subjects, ipe, finmixobj) {

	d1 <- merge(choices, subjects, by="sid", all.x=T, all.y=F)
	d2 <- merge(d1, ipe, by="sid", all.x=T, all.y=F)

	# ex-post probabilities of type membershipt => classification of subjects into types
	tau       <- finmixobj$tau
	typenam   <- paste("type_", 1:ncol(tau), sep="")
	class     <- matrix(0, nrow(tau), ncol(tau)+1, dimnames=list(c(), c("sid", typenam)))
	class[,1] <- as.numeric(rownames(tau))
	for (i in 1:nrow(tau)) {
		class[i, which.max(tau[i,])+1] <- 1
	}

	d3 <- merge(d2, class, by="sid", all.x=T, all.y=F)

	# add type specific parameter estimates
	d3$alpha_type      <- NA
	d3$beta_type       <- NA
	d3$gamma_type      <- NA
	d3$delta_type      <- NA
	d3$choicesens_type <- NA
	pars <- paste(c("alpha","beta","gamma","delta","choicesens"),"_type", sep="")

	for (i in 1:nrow(d3)) {

		typeind     <- which.max(d3[i, typenam])  # which type?
		d3[i, pars] <- finmixobj$pe[2:6, typeind] # add type-specific estimates

	}

	d3

}

# Function to compute the behavioral predictions for the reward punishment games
f.rppredict <- function(d, betaind, alphaind, gammaind, deltaind, sigmaind) {
	pay.r1 <- d[,"payoff_r"] - d[,"c1"]
	pay.r2 <- d[,"payoff_r"] - d[,"c2"]
	pay.r3 <- d[,"payoff_r"] - d[,"c3"]
	pay.r4 <- d[,"payoff_r"] - d[,"c4"]
	pay.r5 <- d[,"payoff_r"] - d[,"c5"]
	pay.r6 <- d[,"payoff_r"] - d[,"c6"]
	pay.r7 <- d[,"payoff_r"]

	pay.p1 <- d[,"payoff_p"] + d[,"r1"]
	pay.p2 <- d[,"payoff_p"] + d[,"r2"]
	pay.p3 <- d[,"payoff_p"] + d[,"r3"]
	pay.p4 <- d[,"payoff_p"] + d[,"r4"]
	pay.p5 <- d[,"payoff_p"] + d[,"r5"]
	pay.p6 <- d[,"payoff_p"] + d[,"r6"]
	pay.p7 <- d[,"payoff_p"]

	r1 <- as.numeric(pay.r1 > pay.p1)
	r2 <- as.numeric(pay.r2 > pay.p2)
	r3 <- as.numeric(pay.r3 > pay.p3)
	r4 <- as.numeric(pay.r4 > pay.p4)
	r5 <- as.numeric(pay.r5 > pay.p5)
	r6 <- as.numeric(pay.r6 > pay.p6)
	r7 <- as.numeric(pay.r7 > pay.p7)

	s1 <- as.numeric(pay.r1 < pay.p1)
	s2 <- as.numeric(pay.r2 < pay.p2)
	s3 <- as.numeric(pay.r3 < pay.p3)
	s4 <- as.numeric(pay.r4 < pay.p4)
	s5 <- as.numeric(pay.r5 < pay.p5)
	s6 <- as.numeric(pay.r6 < pay.p6)
	s7 <- as.numeric(pay.r7 < pay.p7)

	par1 <- d[,betaind]*r1 + d[,alphaind]*s1 + d[,gammaind]*d[,"pgoesleft_kind"] + d[,deltaind]*(1-d[,"pgoesleft_kind"])
	par2 <- d[,betaind]*r2 + d[,alphaind]*s2 + d[,gammaind]*d[,"pgoesleft_kind"] + d[,deltaind]*(1-d[,"pgoesleft_kind"])
	par3 <- d[,betaind]*r3 + d[,alphaind]*s3 + d[,gammaind]*d[,"pgoesleft_kind"] + d[,deltaind]*(1-d[,"pgoesleft_kind"])
	par4 <- d[,betaind]*r4 + d[,alphaind]*s4 + d[,gammaind]*d[,"pgoesleft_kind"] + d[,deltaind]*(1-d[,"pgoesleft_kind"])
	par5 <- d[,betaind]*r5 + d[,alphaind]*s5 + d[,gammaind]*d[,"pgoesleft_kind"] + d[,deltaind]*(1-d[,"pgoesleft_kind"])
	par6 <- d[,betaind]*r6 + d[,alphaind]*s6 + d[,gammaind]*d[,"pgoesleft_kind"] + d[,deltaind]*(1-d[,"pgoesleft_kind"])
	par7 <- d[,betaind]*r7 + d[,alphaind]*s7 + d[,gammaind]*d[,"pgoesleft_kind"] + d[,deltaind]*(1-d[,"pgoesleft_kind"])

	umat <- matrix(NA, nrow(d), 7)
	umat[,1] <- (1-par1)*pay.r1 + par1*pay.p1
	umat[,2] <- (1-par2)*pay.r2 + par2*pay.p2
	umat[,3] <- (1-par3)*pay.r3 + par3*pay.p3
	umat[,4] <- (1-par4)*pay.r4 + par4*pay.p4
	umat[,5] <- (1-par5)*pay.r5 + par5*pay.p5
	umat[,6] <- (1-par6)*pay.r6 + par6*pay.p6
	umat[,7] <- (1-par7)*pay.r7 + par7*pay.p7

	umaxind   <- max.col(umat)
	pred.hard <- d[,"r1"]*(umaxind == 1) + d[,"r2"]*(umaxind == 2) + d[,"r3"]*(umaxind == 3) + d[,"r4"]*(umaxind == 4) + d[,"r5"]*(umaxind == 5) + d[,"r6"]*(umaxind == 6)

	expu  <- exp(d[,sigmaind]*umat)
	probs <- expu / matrix(rowSums(expu), nrow(expu), ncol(expu))
	pred.prob <- d[,"r1"]*probs[,1] + d[,"r2"]*probs[,2] + d[,"r3"]*probs[,3] + d[,"r4"]*probs[,4] + d[,"r5"]*probs[,5] + d[,"r6"]*probs[,6]
	pred.prob[is.na(pred.prob)] <- pred.hard[is.na(pred.prob)]
	pred.prob
}

# Function to compute the behavioral predictions for the trust games
f.trustpredict <- function(d, betaind, alphaind, gammaind, sigmaind) {
	trustX <- 1200-d[,"cost"]  #trustee's payoff when trustworthy
	trustR <- as.numeric(trustX > 900) #indicator for advantageous inequality
	trustS <- as.numeric(trustX < 900) #indicator for disadvantageous inequality

	umat <- matrix(NA, nrow(d), 2)
	umat[,1] <- (1 - d[,betaind]*trustR - d[,alphaind]*trustS - d[,gammaind])*trustX + (d[,betaind]*trustR + d[,alphaind]*trustS + d[,gammaind])*900
	umat[,2] <- (1 - d[,betaind] - d[,gammaind])*1200

	umaxind   <- max.col(umat)
	pred.hard <- as.numeric(umaxind == 1)

	expu  <- exp(d[,sigmaind]*umat)
	probs <- expu / matrix(rowSums(expu), nrow(expu), ncol(expu))
	pred.prob <- probs[,1]
	pred.prob[is.na(pred.prob)] <- pred.hard[is.na(pred.prob)]
	pred.prob

}

# Load the data that needs to be combined
subjects   <- read.table("subjects.csv",            sep=",", head=T)
trustgames <- read.table("choices_trustgames.csv",  sep=",", head=T)
rpgames    <- read.table("choices_rpgames.csv",     sep=",", head=T)
ipe        <- read.table("individual_est_exp2.csv", sep=",", head=T)

load("finmix_est_3cl.RData") # load the finite mixture estimates

# Prepare the data sets
trg <- f.combine(trustgames, subjects, ipe, pe2)
rpg <- f.combine(rpgames, subjects, ipe, pe2)

# Add the predictions based on the individual- and type-specific estimates (see Section 4.5)
trg$tworthy_indivpred <- f.trustpredict(trg, "beta", "alpha", "gamma", "choicesens")
trg$tworthy_typepred  <- f.trustpredict(trg, "beta_type", "alpha_type", "gamma_type", "choicesens_type")

rpg$reward_punish_indivpred <- f.rppredict(rpg, "beta", "alpha", "gamma", "delta", "choicesens")
rpg$reward_punish_typepred  <- f.rppredict(rpg, "beta_type", "alpha_type", "gamma_type", "delta_type", "choicesens_type")

# Wirte data to files
write.table(trg, "OutOfSample_trustgames.csv", sep=",", col.names=T, row.names=F)
write.table(rpg, "OutOfSample_rpgames.csv",    sep=",", col.names=T, row.names=F)


#  James Rekow

#  Example script for creating a meanOverDOC data frame and using the data frame to create some basic plots

library(ggplot2)
source("meanOverDOCCreatorOrderCheck.r")
source("meanDOCCreatorSubgroupsCheck.r")

#  create data frames containing mean overlap values
#  meanOverDOC = meanOverDOCCreatorOrderCheck()
#  meanDOC = meanDOCCreatorSubgroupsCheck()

#  read in data from file
meanOverDOC = read.csv("meanOverDOCOrderCheck.csv")
meanDOC = read.csv("meanDOC_SubgroupsCheck.csv")

#  make meanOrder and numSubgroups factors for plotting purposes
meanOverDOC$meanOrder = as.factor(meanOverDOC$meanOrder)
meanDOC$numSubgroups = as.factor(meanDOC$numSubgroups)

##  Using varying mean order from meanOverDOC

#  Plot lambda / M vs. meanOver
p1 = ggplot(meanOverDOC, aes(x = lambdaOverM, y = meanOver, col = meanOrder)) +
       geom_point() +
       geom_smooth(method = "loess", se = FALSE) +
       labs(title = "Mean Overlap VS lambda / M",
            subtitle = "meanOrder is the Mean Order of the Vertices in the Random Connectivity Graph Related to Each DOC.
                        meanOrder = 2 * numEdges / numVertices")

##  Plot fitCurve (1 - exp(-lambda / M)) vs. meanOver
p2 = ggplot(meanOverDOC, aes(x = fitCurve, y = meanOver, col = meanOrder)) +
       geom_point() +
       geom_smooth(method = "lm", se = FALSE) +
       labs(title = "Mean Overlap VS fitCurve = 1 - exp(-lambda / M)",
            subtitle = "meanOrder is the Mean Order of the Vertices in the Random Connectivity Graph Related to Each DOC.
                        meanOrder = 2 * numEdges / numVertices")

## Using varying number of subgroups from meanDOC

#  Plot lambda / M vs. meanOver
p3 = ggplot(meanDOC, aes(x = lambdaOverM, y = meanOver, col = numSubgroups)) +
       geom_point() +
       geom_smooth(method = "loess", se = FALSE) +
       labs(title = "Mean Overlap VS lambda / M")

#  Plot lambda / M vs. meanDiss
p4 = ggplot(meanDOC, aes(x = lambdaOverM, y = meanDiss, col = numSubgroups)) +
       geom_point() +
       geom_smooth(method = "loess", se = FALSE) +
       labs(title = "Mean Dissimilarity VS lambda / M")

#  plot the created ggplot objects
dev.new()
plot(p1)

dev.new()
plot(p2)

dev.new()
plot(p3)

dev.new()
plot(p4)


library(dplyr)
library(ggplot2)

if(! exists("inputFile")){
  args <- commandArgs(TRUE)

  if(length(args) == 0){
    setwd("/scratch/cqs/shengq2/jennifer/20190906_lindsay_exomeseq_3772_hg38/bwa_refine_nosoftclip_gatk4_CNV_Germline_08_SizeFactor/result")
    inputFile = "lindsay_exomeseq_3772.txt"
    outputFile = "lindsay_exomeseq_3772.txt.sizefactor"
  }else{
    inputFile = args[1]
    outputFile = args[2]
  }
}

dat<-read.table(inputFile, sep="\t", header=T, stringsAsFactors = F)
dat2<-dat[!(dat$Chromosome %in% c("X", "Y")),]

dmedian<-dat2%>%
  group_by(Chromosome)%>%
  summarise(Median=median(Count))

medCount<-dmedian$Median
names(medCount)<-dmedian$Chromosome

dat2$SizeFactor<-medCount[dat2$Chromosome] / dat2$Count

smedian<-dat2%>%
  group_by(Sample)%>%
  summarise(Median=median(SizeFactor))
medSizeFactor<-smedian$Median
names(medSizeFactor)<-smedian$Sample

datx<-dat[dat$Chromosome == "X",]
datx$SizeFactor<-medSizeFactor[datx$Sample]

daty<-dat[dat$Chromosome == "Y",]
daty$SizeFactor<-medSizeFactor[daty$Sample]

finalDat<-rbind(dat2, datx, daty)

finalDat$LogSizeFactor<-log2(finalDat$SizeFactor)

write.table(finalDat, file=outputFile, sep="\t", row.names=F, quote=F)

nsample=ceiling(sqrt(length(unique(finalDat$Sample))))
swidth=max(1000, nsample * 500)
png(paste0(outputFile, ".png"), width=swidth, height=800, res=300)
g<-ggplot(finalDat, aes(x=Sample,y=LogSizeFactor)) + geom_violin() + theme_bw() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1))
print(g)
dev.off()


REDUCE_TO_ALL = -1L

#' @useDynLib cop cop_allreduce_mat_userop
reducer = function(x, op, commutative, root, comm=0L)
{
  comm_check_is_matrix(x, comm)
  comm_check_is_function(op, comm)
  comm_check_is_flag(commutative, comm)
  comm_check_is_int(root, comm)

  commutative = as.logical(commutative)

  root = as.integer(root)

  comm = as.integer(comm)
  comm_ptr = pbdMPI::get.mpi.comm.ptr(comm)

  env=parent.frame()
  if (is.matrix(x))
  {
    if (!is.double(x))
      storage.mode(x) = "double"

    ret = .Call(cop_allreduce_mat_userop, x, comm_ptr, root, commutative, op, env)
  }

  ret
}

#' Custom Reduction
#'
#' This performs a reduce/allreduce operation on a matrix with a custom binary
#' operation. Currently, only normal dense/numeric matrices are supported.
#'
#' This is a generalization of the \code{qr_allreduce()}/\code{qr_reduce()}
#' methods also offered by this package. Conceptually, \code{qr_reduce()} is the
#' same as doing \code{cop_reduce()} with
#' \code{op = function(a, b) qr.R(qr(rbind(a, b)))} and \code{commutative=TRUE},
#' although the internals of \code{qr_reduce()} are actually quite different.
#' In general, it should be faster and use  less memory.
#'
#' @details
#' The function should take inputs of the same dimension, and the output should
#' be of the same dimension as the inputs. Indeed, for intermediary
#' calculations, the output of the op at one level will be an input for the next
#' evaliation. This criterion is assumed and not validated or tested.
#' Violating it could cause crashes or difficult to understand memory errors.
#'
#' The operation should be associative, meaning that you should be able to put
#' parentheses wherever you want with 2 or more chained calls. Said another
#' way, \code{a op b op c} is the same whether evaluated \code{a op (b op c)} or
#' \code{(a op b) op c}. The operation does not have to be commutative, which
#' would require that \code{a op b} is the same as \code{b op a}. However, if it
#' is, then there may be an improvement to performance by correctly specifying
#' it as such via the \code{commutative} argument.
#'
#' @param x
#' The input data. Should be a numeric matrix. The matrix should be the same
#' dimensions across all processes.
#' @param op
#' A binary operation for numeric matrices. The function should be associative,
#' and inputs/outputs are assumed to have the same dimensions. See the Details
#' section for more information.
#' @param commutative
#' Is the operation commutative? Should be one of \code{TRUE} or \code{FALSE}.
#' @param comm
#' MPI communicator number.
#' @param root
#' MPI rank that should receive the return in the non-all version.
#'
#' @return
#' If the all version is called or if the calling rank is equal to \code{root},
#' then a numeric matrix is returned, and otherwise \code{NULL}.
#'
#' @examples
#' \dontrun{
#' suppressMessages(library(cop))
#'
#' x = matrix(1:4, 2) + 10*comm.rank()
#' add = function(a, b) a+b
#' out = cop_allreduce(x, fun=add, commutative=TRUE)
#' mpi_print(out)
#'
#' finalize()
#' }
#'
#' @seealso \code{\link{qr_allreduce}()}
#'
#' @name cop_allreduce
#' @rdname cop_allreduce
NULL

#' @rdname cop_allreduce
#' @export
cop_allreduce = function(x, op, commutative=FALSE, comm=0L)
{
  reducer(x=x, op=op, commutative=commutative, root=REDUCE_TO_ALL, comm=comm)
}

#' @rdname cop_allreduce
#' @export
cop_reduce = function(x, op, root=0L, commutative=FALSE, comm=0L)
{
  reducer(x=x, op=op, commutative=commutative, root=root, comm=comm)
}


library(ggvis)
library(shiny)

# Basic dynamic example
mtc1 <- reactive({
  invalidateLater(2000, NULL);
  mtcars[sample(nrow(mtcars), 10), ]
})
mtc1 %>% ggvis(x = ~wt, y = ~mpg) %>% layer_points()

# Rapidly changing dynamic example
df <- data.frame(x = runif(20), y = runif(20))
mtc1 <- reactive({
  invalidateLater(200, NULL);

  df$x <<- df$x + runif(20, -0.05, 0.05)
  df$y <<- df$y + runif(20, -0.05, 0.05)
  df
})
mtc1 %>% ggvis(x = ~x, y = ~y) %>%
  layer_points() %>%
  scale_numeric("x", domain = c(0, 1), clamp = TRUE) %>%
  scale_numeric("y", domain = c(0, 1), clamp = TRUE) %>%
  set_options(duration = 0)

# Two separate data sets, equal in the tree
mtc1 <- reactive({
  invalidateLater(2000, NULL);
  mtcars[sample(nrow(mtcars), 10), ]
})
mtc2 <- reactive({
  invalidateLater(1000, NULL);
  mtcars[sample(nrow(mtcars), 10), ]
})
NULL %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points(data = mtc1, stroke := "black", fill := "black") %>%
  layer_points(data = mtc2, fill := "red", size := 40)

# With a transform
mtc1 <- reactive({
  invalidateLater(1000, NULL)
  mtcars[sample(nrow(mtcars), 10), ]
})
mtc1 %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points() %>%
  layer_smooths()

# Data points moving from right to left
set.seed(430)
dat <- data.frame(time = 1:10, value = runif(10))
ddat <- reactive({
  invalidateLater(2000, NULL)
  dat$time  <<- c(dat$time[-1], dat$time[length(dat$time)] + 1)
  dat$value <<- c(dat$value[-1], runif(1))
  dat
})
ddat %>% ggvis(x = ~time, y = ~value, key := ~time) %>%
  layer_points() %>%
  layer_paths()

# Bars moving from right to left
set.seed(430)
dat <- data.frame(time = 1:10, value = runif(10))
ddat <- reactive({
  invalidateLater(2000, NULL);
  dat$time  <<- c(dat$time[-1], dat$time[length(dat$time)] + 1)
  dat$value <<- c(dat$value[-1], runif(1))
  dat
})
ddat %>%
  ggvis(
    x = ~time, x.enter = ~time + 1, x.exit  = ~time - 1,
    y = ~value, y.enter = 0, y.exit = 0,
    y2 = 0, y2.enter = 0, y2.exit = 0,
    fill := "#aaa",
    fillOpacity := 1, fillOpacity.enter := 0, fillOpacity.exit := 0,
    strokeOpacity := 1, strokeOpacity.enter := 0, strokeOpacity.exit := 0,
    width = band(),
    key := ~time
  ) %>%
  scale_numeric("y", domain = 0:1) %>%
  scale_nominal("x", domain = reactive(unique(ddat()$time)), padding = 0,
                points = FALSE) %>%
  layer_rects()

# Dynamic stacked bars
dat <- data.frame(
  g1 = rep(letters[1:4], 3),
  g2 = rep(LETTERS[1:3], each = 4),
  value = runif(12)
)
ddat <- reactive({
  invalidateLater(2000, NULL)
  dat$value <<- runif(12)
  dat
})
ddat %>% ggvis(x = ~g1, y = ~value, fill = ~g2, fillOpacity := 0.5) %>%
  layer_bars()


#data <- read.csv(file="ads_1.csv", header=TRUE, sep=",")
args = commandArgs(trailingOnly=TRUE)
data <- read.csv(file=args[1], header=TRUE, sep=",",check.names=FALSE)
pdf(args[2])
par(mar=c(4, 11, 4, 4)) # Resize the margin to fit the y axis labels
#barplot(as.numeric(data[1,]), main="Precision at K", horiz=TRUE, names.arg=colnames(data), las=1, font.lab=1, font.main=1, family='serif', border=NA)
#xx <- barplot(as.numeric(data[1,]), main="Median", horiz=TRUE, names.arg=colnames(data), las=1, font.lab=1, font.main=1, family='serif', xlim=c(0,100)) #font.lab and font.main defines font size
mm <- max(data)
s <- 1.5
xx <- barplot(as.numeric(data[1,]), main=args[3], xlab="Mean", horiz=TRUE, names.arg=colnames(data), las=1, font.lab=1, font.main=1, family='serif', xlim=c(0, mm*1.1), cex.names=s, cex.axis=s, cex.lab=2.5, cex.main=2.5, cex.sub=s) #font.lab and font.main defines font size

text(y = xx-0.3, x = as.numeric(data[1,]) + 0.09*mm, label = as.numeric(data[1,]), pos = 3, cex = s, family="serif") # show text on top of each bar

dev.off()


# Basic bar graphs
library(ggvis)
library(dplyr, warn.conflicts = FALSE)

pressure %>%
  ggvis(~factor(temperature), ~pressure) %>%
  layer_bars(width = 0.5) %>%
  save_spec("bar/categorical-x.json")

pressure %>%
  ggvis(x = ~temperature, y = ~pressure) %>%
  layer_bars(fill:="red") %>%
  save_spec("bar/continuous-x.json")


#' Cast data.frame to sparse matrix
#'
#' Create a sparse matrix from matching vectors of row indices, column indices and values
#'
#' @param rows a vector of row indices: [i,]
#' @param columns a vector of column indices: [,j]
#' @param values a vector of the values for each (non-zero) cell: [i,j] = value
#' @return a sparse matrix of the dgTMatrix class (\code{\link{Matrix}} package)
#' @export
cast.sparse.matrix <- function(rows, columns, values=rep(1, length(rows))) {
  row_index = unique(rows)
  col_index = unique(columns)
  sm = spMatrix(nrow=length(row_index), ncol=length(col_index),
                match(rows, row_index), match(columns, col_index), values)
  sm = as(sm, 'dgCMatrix')
  rownames(sm) = row_index
  colnames(sm) = col_index
  sm
}

#' Create a document term matrix from a list of tokens
#'
#' Create a \code{\link{DocumentTermMatrix}} from a list of document ids, terms, and frequencies.
#'
#' @param documents a vector of document names/ids
#' @param terms a vector of words of the same length as documents
#' @param freqs a vector of the frequency a a term in a document
#' @param minfreq the minimum frequency of terms for inclusion. Defaults to 5, set to 0 to skip filtering
#' @param minlength the minimum word length (number of characters) for inclusion, set to 0 to skip filtering
#' @param filter.chars filter out any words containing numbers or non-word characters (defaults to True)
#' @param filter an optional boolean vector of the length of documents whether each document should be included. Any additional filtering will be applied on to op this filter
#' @return a document-term matrix  \code{\link{DocumentTermMatrix}}
#' @export
dtm.create <- function (documents, terms, freqs = rep(1, length(documents)),
                        minfreq=5, minlength=3, filter.chars=TRUE, filter=rep(T, length(documents))) {
  if (minfreq>0) {
    message('Ignoring words with frequency lower than ', minfreq)
    t = table(terms)
    filter = filter & terms %in% names(t)[t>=minfreq]
  }
  #TODO: this is not very efficient if terms is a large factor
  if (minlength>0) {
    message('Ignoring words with less than ', minlength, ' characters')
    filter = filter & nchar(as.character(terms)) >= minlength
  }
  if (filter.chars) {
    message('Ignoring words that contain numbers of non-word characters')
    filter = filter & !grepl("\\W|\\d", terms)
  }
  d = data.frame(ids = documents[filter], terms = terms[filter], freqs = freqs[filter])
  if (sum(is.na(d$terms)) > 0) {
    warning("Removing ", sum(is.na(d$terms)), "rows with missing term names")
    d = d[!is.na(d$terms), ]
  }
  sparsemat = cast.sparse.matrix(rows = d$ids, columns = d$terms,  values = d$freqs)
  tm::as.DocumentTermMatrix(sparsemat, weighting = weightTf)
}

#' Filter a dtm by selecting documents or terms
#'
#' Filters the dtm and removes any empty rows or columns
#'
#' @param dtm the dtm to filter
#' @param documents an optional vector of documents to include
#' @param terms an optional  vector of terms to include
#' @return the filtered dtm
#' @export
dtm.filter <- function(dtm, documents=NULL, terms=NULL) {
  if (!is.null(terms)) dtm = dtm[, colnames(dtm) %in% terms]
  if (!is.null(documents)) dtm = dtm[rownames(dtm) %in% documents,]
  dtm[row_sums(dtm) > 0, col_sums(dtm) > 0]
}

#' Split a dtm into a list.
#'
#' Transform a dtm into a list containing the dtm in parts.
#'
#' @param dtm a document-term matrix
#' @param subcorpus a vector that matches the documents (rows) of the dtm. The dtm will be split into separate dtms for each value of subcorpus.
#' @return A list of dtms, named after the split_by values
#' @export
splitDtm <- function(dtm, subcorpus) {
  dtm_list = llply(unique(subcorpus), function(x) dtm[subcorpus == x,])
  names(dtm_list) = unique(subcorpus)
  dtm_list
}

#' Transform a dtm into a sparse matrix.
#'
#' @param dtm a document-term matrix
#' @return a sparse matrix
dtmToSparseMatrix <- function(dtm){
  sm = spMatrix(nrow(dtm), ncol(dtm), dtm$i, dtm$j, dtm$v)
  rownames(sm) = rownames(dtm)
  colnames(sm) = colnames(dtm)
  sm
}

#' Compute some useful corpus statistics for a dtm
#'
#' Compute a number of useful statistics for filtering words: term frequency, idf, etc.
#'
#' @param dtm a document term matrix (e.g. the output of \code{\link{dtm.create}})
#' @return A data frame with rows corresponding to the terms in dtm and the statistics in the columns
#' @export
term.statistics <- function(dtm) {
  dtm = dtm[row_sums(dtm) > 0,col_sums(dtm) > 0]    # get rid of empty rows/columns
  vocabulary = colnames(dtm)
  data.frame(term = as.character(vocabulary),
             characters = nchar(vocabulary),
             number = grepl("[0-9]", vocabulary),
             nonalpha = grepl("\\W", vocabulary),
             termfreq = col_sums(dtm),
             docfreq = col_sums(dtm > 0),
             reldocfreq = col_sums(dtm > 0) / nDocs(dtm),
             tfidf = tapply(dtm$v/row_sums(dtm)[dtm$i], dtm$j, mean) * log2(nDocs(dtm)/col_sums(dtm > 0)),
             stringsAsFactors=F)
}

prepare.time.var <- function(time_var, time_interval){
  if(class(time_var) == 'Date'){
    if(time_interval == 'day') time_var = as.Date(format(time_var, '%Y-%m-%d'))
    if(time_interval == 'week') time_var = as.Date(paste(format(time_var, '%Y-%W'),1), '%Y-%W %u')
    if(time_interval == 'month') time_var = as.Date(paste(format(time_var, '%Y-%m'),'-01',sep=''))
    if(time_interval == 'year') time_var = as.Date(paste(format(time_var, '%Y'),'-01-01',sep=''))
  }
  time_var
}

#' Compute corpus statistics for term use over time
#'
#' Compute corpus statistics for term use over time. Calculates the spearman's rank order correlation of a term's use over time with a vector that gradually increases over time.
#'
#' @param dtm a document term matrix (e.g. the output of \code{\link{dtm.create}})
#' @param document_date a vector with dates that matches the rows in dtm
#' @param time_interval a character string indicating what time interval to use
#' @return A data frame with rows corresponding to the terms in dtm and the statistics in the columns
#' @export
term.time.statistics <- function(dtm, document_date, time_interval='day'){
  document_date = prepare.time.var(meta$date, time_interval)
  dateseq = seq.Date(min(document_date), max(document_date), by=time_interval)
  i = document_date[dtm$i]
  i = match(i, dateseq)
  m = spMatrix(length(dateseq), ncol(dtm), i, dtm$j, dtm$v)
  colnames(m) = colnames(dtm)
  m = as(m, 'dgCMatrix')

  x = 1:nrow(m)
  N = Matrix::colSums(m)
  timecor.total = apply(m, MARGIN = 2, function(y) cor(x, y, method = 'spearman'))
  mean.total = apply(m, MARGIN = 2, mean)
  sd.total = apply(m, MARGIN = 2, sd)

  m = m / Matrix:::rowSums(m)
  timecor.rel = apply(m, MARGIN = 2, function(y) cor(x, y, method = 'spearman'))
  mean.rel = apply(m, MARGIN = 2, mean)
  sd.rel = apply(m, MARGIN = 2, sd)

  data.frame(term=colnames(m), N=N, mean.total, sd.total, mean.rel, sd.rel, timecor.total, timecor.rel)
}

#' Plot a wordcloud with words ordered and coloured according to a dimension (x)
#'
#' Plot a wordcloud with words ordered and coloured according to a dimension (x)
#'
#' @param x The (approximate) x positions of the words
#' @param y The (approximate) y positions of the words
#' @param words A character vector with the words to plot
#' @param wordfreq The frequency of the words, defaulting to 1
#' @return nothing
#' @export
plotWords <- function(x, y=NULL, words, wordfreq=rep(1, length(x)), xlab='', ylab='', yaxt='n', scale=2, random.y=F, xlim=NULL, ylim=NULL, col = color.scale(x, c(1, 2, 0), c(0, 1, 1), 0), ...){
  wordsize = rescale(log(wordfreq), c(0.75, scale))
  if (is.null(y) & random.y) y = sample(seq(-1, 1, by = 0.001), length(x))
  if (is.null(y) & !random.y) y = wordsize
  xmargin = (max(x) - min(x)) * 0.2
  ymargin = (max(y) - min(y)) * 0.2
  if (is.null(xlim)) xlim = c(min(x) - xmargin, max(x) + xmargin)
  if (is.null(ylim)) ylim = c(min(y) - ymargin, max(y) + ymargin)

  plot(x, y, type = "n", xlim = xlim, ylim = ylim, frame.plot = F, yaxt = yaxt, ylab = ylab, xlab = xlab, ...)
  wl <- as.data.frame(wordlayout(x, y, words, cex = wordsize))

  text(wl$x + 0.5 * wl$width, wl$y + 0.5 * wl$ht, words, cex = wordsize, col = col)
}

#' Plot a word cloud from a dtm
#'
#' Compute the term frequencies for the dtm and plot a word cloud with the top n topics
#' You can either supply a document-term matrix or provide terms and freqs directly
#' (in which case this is an alias for wordcloud::wordcloud with sensible defaults)
#'
#' @param dtm the document-term matrix
#' @param nterms the amount of words to plot (default 100)
#' @param freq.fun if given, will be applied to the frequenies (e.g. sqrt)
#' @param terms the terms to plot, ignored if dtm is given
#' @param freqs the frequencies to plot, ignored if dtm is given
#' @param scale the scale to plot (see wordcloud::wordcloud)
#' @param min.freq the minimum frquency to include (see wordcloud::wordcloud)
#' @param rot.per the percentage of vertical words (see wordcloud::wordcloud)
#' @param pal the colour model, see RColorBrewer
#' @export
dtm.wordcloud <- function(dtm=NULL, nterms=100, freq.fun=NULL, terms=NULL, freqs=NULL, scale=c(6, .5), min.freq=1, rot.per=.15, pal=brewer.pal(6,"YlGnBu")) {
  if (!is.null(dtm)) {
    t = term.statistics(dtm)
    t = t[order(t$termfreq, decreasing=T), ]
    terms = t$term
    freqs = t$termfreq
  }
  if (length(terms) < nterms) nterms = length(terms)
  if (!is.null(freq.fun)) freqs = freq.fun(freqs)
  if (!is.null(nterms)) {
    select = order(-freqs)[1:nterms]
    terms = terms[select]
    freqs = freqs[select]
  }
  if (is.null(terms) | is.null(freqs)) stop("Please provide dtm or terms and freqs")
  wordcloud(terms, freqs,
          scale=scale, min.freq=min.freq, max.words=Inf, random.order=FALSE,
          rot.per=rot.per, colors=pal)
}

#### COMPARING CORPORA

#' Compute the chi^2 statistic for a 2x2 crosstab containing the values
#' [[a, b], [c, d]]
chi2 <- function(a,b,c,d, yates_correction=rep(F, length(a)), autocorrect=T){
  n = a+b+c+d
  sums = cbind(c1 = a+c, c2 = b+d, r1 = a+b, r2 = c+d)

  if(autocorrect){
    ## apply Cochrans criteria: no expected values below 1 and less than 20% of cells empty (which means none in a 2x2 design)
    ## if these are violated, use the yates_correction
    ## http://www.ncbi.nlm.nih.gov/pmc/articles/PMC2041889/
    e = cbind(sums[,'c1'] / n, sums[,'c2'] / n)
    e = cbind(e * sums[,'r1'], e * sums[,'r2'])
    c1 = rowSums(e < 1) > 0          # at least one expected value below 1
    c2 = rowSums(sums < 5) > 0       # at least one cell below 5
    yates_correction = ifelse(c1 | c2, T, F)
  }
  x = a*d - b*c
  x = ifelse(yates_correction, abs(x) - n/2, x)
  chi = n*x^2 / (sums[,'c1'] * sums[,'c2'] * sums[,'r1'] * sums[,'r2'])
  ifelse(is.na(chi), 0, chi)
}

#' Compare two corpora
#'
#' Compare the term use in corpus dtm with a refernece corpus dtm.ref, returning relative frequencies
#' and overrepresentation using various measures
#'
#' @param dtm.x the main document-term matrix
#' @param dtm.y the 'reference' document-term matrix
#' @param smooth the smoothing parameter for computing overrepresentation
#' @return A data frame with rows corresponding to the terms in dtm and the statistics in the columns
#' @export
corpora.compare <- function(dtm.x, dtm.y=NULL, smooth=1, min.over=NULL, min.chi=NULL, select.rows=NULL) {
  if (is.null(dtm.y)) {
    dtm.y = dtm.x[!(rownames(dtm.x) %in% select.rows), ]
    dtm.x = dtm.x[rownames(dtm.x) %in% select.rows, ]
  }
  freqs = data.frame(term=colnames(dtm.x), termfreq=col_sums(dtm.x))
  freqs.rel = data.frame(term=colnames(dtm.y), termfreq=col_sums(dtm.y))
  f = merge(freqs, freqs.rel, all=T, by="term")
  f[is.na(f)] = 0
  f = f[f$termfreq.x + f$termfreq.y > 0,]
  f$termfreq = f$termfreq.x + f$termfreq.y
  f$relfreq.x = (f$termfreq.x+smooth) / (sum(freqs$termfreq) + (nrow(freqs)*smooth))
  f$relfreq.y = (f$termfreq.y+smooth) / (sum(freqs.rel$termfreq) + (nrow(freqs.rel)*smooth))
  f$over = (f$relfreq.x) / (f$relfreq.y)
  f$chi = chi2(f$termfreq.x, f$termfreq.y, sum(f$termfreq.x) - f$termfreq.x, sum(f$termfreq.y) - f$termfreq.y)
  if(!is.null(min.over)) f = f[f$over > min.over,]
  if(!is.null(min.chi)) f = f[f$chi > min.chi,]
  f
}

eachToAllComparison <- function(dtm, corpus_ids, .progress="text", ...){
  message('Comparing corpora (N=', length(corpus_ids),')')
  compare_results = llply(names(corpus_ids), function(corpus_name) corpora.compare(dtm[corpus_ids[[corpus_name]],],
                                                                 dtm[unlist(corpus_ids[!names(corpus_ids)==corpus_name]),], ...), .progress=.progress)
  names(compare_results) = names(corpus_ids)
  compare_results
}

#' @export
unlistWindow <- function(list_object, i, window){
  indices = i + window
  indices = indices[indices > 0 & indices <= length(list_object)]
  unlist(list_object[indices], use.names=F)
}

windowComparison <- function(dtm, corpus_ids, window, ...){
  message('Comparing corpora (N=', length(corpus_ids),')')
  corpus_ids = corpus_ids[order(names(corpus_ids))]
  compare_results = llply(1:length(corpus_ids), function(i) corpora.compare(dtm[corpus_ids[[i]],],
                                                          dtm[unlistWindow(corpus_ids,i,window),], ...), .progress='text')
  names(compare_results) = names(corpus_ids)
  compare_results
}

#' The corpora.compare function for a list of dtm's
#'
#' @param x either a named list of document term matrices, or a single dtm (in which cast the subcorpus argument must be given)
#' @param subcorpus if x is a single dtm, subcorpus should be a vector of the length and order of the dtm rows. Each value of subcorpus then represents a separate corpus.
#' @param method different ways to compare corpora. "each_to_all" compares each corpus to a corpos consisting of all other corpora. "window" compares each corpus to a corpus consisting of the previous and/or next corpora (see window.size). The order will be determined by sorting the dtm names (or the subcorpus values) with the order function.
#' @param return.df logical. If True, the results are returned as a data.frame. Otherwise as a list.
#' @param window.size A vector of integers. If method is 'window', this determines which previous and next corpora are used to compare a corpus to. For example: if 3, then each corpus will be compared to a corpus consisting of the 3 previous and 3 next corpora. A corpus itself will not be used to create the comparison corpus. Note that the first and last [window.size] corpora cannot be compared to a full window.
#' @param ... additional arguments to be passed to the corpora.compare function
#' @return a list or data.frame with the corpora.compare results for each dtm.
#' @export
corpora.compare.list <- function(x, subcorpus=NULL, method='each_to_all', return.df=F, window.size=3, .progress="text", ...) {
  if('list' %in% class(x)) {
    subcorpus = rep(names(x), laply(x, nrow))
    x = Reduce(c, x)
  }
  corpus_ids = llply(unique(subcorpus), function(subcorpus_value) which(subcorpus == subcorpus_value))
  names(corpus_ids) = unique(subcorpus)

  if(method == 'each_to_all') results = eachToAllComparison(x, corpus_ids, .progress=.progress, ...)
  if(method == 'window') {
    window = -window.size:window.size
    window = window[!window == 0]
    results = windowComparison(x, corpus_ids, window, ...)
  }
  if(return.df) results = ldply(results, .id='corpus')
  results
}

#' @export
corpcomp.wordcloud <- function(compare_results, nterms=25, ...){
  compare_results = compare_results[compare_results$over > 1,]
  compare_results = compare_results[order(-compare_results$chi),]
  compare_results = head(compare_results, nterms)
  dtm.wordcloud(terms=compare_results$term, freqs=compare_results$over, ...)
}

#' Convert a dtm into a "triples" data frame
#'
#' @param dtm a document-term matrix
#' @return a data frame with columns doc, term, and freq
#' @export
dtm.to.df <- function(dtm) {
  dtm = dtm[row_sums(dtm) > 0, col_sums(dtm) > 0]
  terms = factor(dtm$j, labels = colnames(dtm))
  docs = factor(dtm$i, labels = rownames(dtm))
  data.frame(doc=docs, term=terms, freq=dtm$v)
}

#' Convert a dtm into a quanteda dfm object (requires quanteda to be available)
#'
#' @param dtm a document-term matrix
#' @return a quanteda document-feature matrix
#' @export
dtm.to.dfm <- function(dtm) {
  if (!require("quanteda")) stop("Quanteda needs to be loaded before creating a dtm")
  new("dfmSparse", Matrix(dtm, ncol = ncol(dtm), sparse=T, dimnames=dimnames(dtm)))
}