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))
}
get_order_pairs_monocle2 = function(cds, cell_type){
  df = data.frame(pData(cds),stringsAsFactors = F)
  df = df[df$cell %in% names(cell_type)[!is.na(cell_type)], ]
  df = df[order(df$Pseudotime), ]
  ordered_cell = as.character(df[, 1])
  ordered_celltype = cell_type[ordered_cell]
  index_pair = combn(length(ordered_cell), 2)
  if(min(index_pair[2,] - index_pair[1,]) < 0){
    stop("index_pair error")
  }
  cell_order = sprintf("%s_%s",ordered_celltype[index_pair[1, ]], ordered_celltype[index_pair[2, ]])
  cell_pair = sprintf("%s_%s",ordered_cell[index_pair[1, ]], ordered_cell[index_pair[2, ]])
  names(cell_order) = cell_pair
  return(cell_order)
}
acc_function = function(cell_order, correctorder, wrongorder, compare_pairs = NULL){
  if(is.null(compare_pairs)){
    score = c(sum(cell_order %in% correctorder), sum(cell_order %in% wrongorder))
  }else{
    compare_order = cell_order[names(cell_order) %in% compare_pairs]
    score = c(sum(compare_order %in% correctorder), sum(compare_order %in% wrongorder))
  }
  return(score[1] / sum(score))
}
get_compare_pairs = function(pair_list){
  flag = TRUE
  compare_pairs = NULL
  for(ii in names(pair_list)){
    this_pair = names(pair_list[[ii]])
    cat(ii, " - ", length(this_pair), " pairs\n")
    this_unique_pair = unique(this_pair)
    this_reverse_pair = apply(stri_list2matrix(stri_split_fixed(this_unique_pair, "_"))[c(2, 1), ], 2, stri_join, collapse = "_")
    this_candidate_pair = union(this_unique_pair, this_reverse_pair)
    if(flag){
      compare_pairs = this_candidate_pair
      flag = FALSE
    }else{
      compare_pairs = intersect(compare_pairs, this_candidate_pair)
    }

  }
  cat("Use ", length(compare_pairs), " pairs to compare.\n")
  return(compare_pairs)
}
###
cell_level_df = data.frame(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(cell_level_df) = c("HSC", "MPP", "LMPP", "CMP", "CLP", "GMP", "MEP", "Bcell", "CD4Tcell", "CD8Tcell", "NKcell", "Mono", "Ery")
path_name = c("immunepath", "monopath", "erypath")
order_list = list(correct = list(), wrong = list(), cell_type = list())
for(ii in path_name){
  path_celltype = rownames(cell_level_df)[cell_level_df[, ii] == 1]
  order_list[["cell_type"]][[ii]] = path_celltype
  cell_type_pair = as.matrix(apply(expand.grid(path_celltype, path_celltype), 2, as.character))
  cell_type_pair = cell_type_pair[cell_type_pair[, 1] != cell_type_pair[, 2], ]
  correct_mat = cell_type_pair[cell_level_df[cell_type_pair[, 1], "level"] < cell_level_df[cell_type_pair[, 2], "level"], ]
  wrong_mat = cell_type_pair[cell_level_df[cell_type_pair[, 1], "level"] > cell_level_df[cell_type_pair[, 2], "level"], ]
  order_list[["correct"]][[ii]] = apply(correct_mat, 1, paste, collapse = "_")
  order_list[["wrong"]][[ii]] = apply(wrong_mat, 1, paste, collapse = "_")
}

###
this_method = "raw"
gene_bc_mat = readh5_loom(paste0("./data/BONE_MARROW/", this_method, ".loom"))
gene_bc_filt = gene_bc_mat[used_genes, ]
result_list = list()
this_output_dir = paste0(output_dir, "/split_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
for(ii in path_name){
  used_cells = names(cell_type)[cell_type %in% order_list[["cell_type"]][[ii]]]
  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, order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]])
  result_list[[ii]] = list(cds = cds, cell_order = cell_order, acc = acc)
  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")
}
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_split_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, ]
result_list = list()
this_output_dir = paste0(output_dir, "/split_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
for(ii in path_name){
  used_cells = names(cell_type)[cell_type %in% order_list[["cell_type"]][[ii]]]
  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, order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]])
  result_list[[ii]] = list(cds = cds, cell_order = cell_order, acc = acc)
  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")
}
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_split_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, ]
result_list = list()
this_output_dir = paste0(output_dir, "/split_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
for(ii in path_name){
  used_cells = names(cell_type)[cell_type %in% order_list[["cell_type"]][[ii]]]
  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, order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]])
  result_list[[ii]] = list(cds = cds, cell_order = cell_order, acc = acc)
  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")
}
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_split_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, ]
result_list = list()
this_output_dir = paste0(output_dir, "/split_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
for(ii in path_name){
  used_cells = names(cell_type)[cell_type %in% order_list[["cell_type"]][[ii]]]
  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, order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]])
  result_list[[ii]] = list(cds = cds, cell_order = cell_order, acc = acc)
  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")
}
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_split_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, ]
result_list = list()
this_output_dir = paste0(output_dir, "/split_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
for(ii in path_name){
  used_cells = names(cell_type)[cell_type %in% order_list[["cell_type"]][[ii]]]
  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, order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]])
  result_list[[ii]] = list(cds = cds, cell_order = cell_order, acc = acc)
  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")
}
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_split_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, ]
result_list = list()
this_output_dir = paste0(output_dir, "/split_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
for(ii in path_name){
  used_cells = names(cell_type)[cell_type %in% order_list[["cell_type"]][[ii]]]
  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, order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]])
  result_list[[ii]] = list(cds = cds, cell_order = cell_order, acc = acc)
  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")
}
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_split_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, ]
result_list = list()
this_output_dir = paste0(output_dir, "/split_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
for(ii in path_name){
  used_cells = names(cell_type)[cell_type %in% order_list[["cell_type"]][[ii]]]
  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, order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]])
  result_list[[ii]] = list(cds = cds, cell_order = cell_order, acc = acc)
  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")
}
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_split_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, ]
result_list = list()
this_output_dir = paste0(output_dir, "/split_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
for(ii in path_name){
  used_cells = names(cell_type)[cell_type %in% order_list[["cell_type"]][[ii]]]
  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, order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]])
  result_list[[ii]] = list(cds = cds, cell_order = cell_order, acc = acc)
  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")
}
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_split_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, ]
result_list = list()
this_output_dir = paste0(output_dir, "/split_path/", this_method)
dir.create(this_output_dir, recursive = T, showWarnings = F)
for(ii in path_name){
  used_cells = names(cell_type)[cell_type %in% order_list[["cell_type"]][[ii]]]
  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, order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]])
  result_list[[ii]] = list(cds = cds, cell_order = cell_order, acc = acc)
  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")
}
saveRDS(result_list, paste0(output_dir, "/", this_method, "_monocle2_split_result.rds"))

###
method_names = c("raw", "DISC", "scImpute", "VIPER", "MAGIC", "DCA", "DeepImpute", "scScope", "scVI")
pair_list = list()
for(ii in path_name){
  pair_list[[ii]] = list()
}
for(ii in method_names){
  result_list = readRDS(paste0(output_dir, "/", ii, "_monocle2_split_result.rds"))
  for(jj in path_name){
    pair_list[[jj]][[ii]] = result_list[[jj]][["cell_order"]]
    cat(ii, " - ", jj, " - ", result_list[[jj]][["acc"]], "\n")
  }
}
for(ii in path_name){
  compare_pairs = get_compare_pairs(pair_list[[ii]])
  acc_all = c()
  for(jj in names(pair_list[[ii]])){
    acc_all = c(acc_all, acc_function(pair_list[[ii]][[jj]], order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]], compare_pairs))
  }
  names(acc_all) = names(pair_list[[ii]])
  print(ii)
  print(acc_all)
  pair_list1 = list(DISC = pair_list[[ii]][["DISC"]], raw = pair_list[[ii]][["raw"]])
  compare_pairs1 = get_compare_pairs(pair_list1)
  acc_all1 = c()
  for(jj in names(pair_list1)){
    acc_all1 = c(acc_all1, acc_function(pair_list1[[jj]], order_list[["correct"]][[ii]], order_list[["wrong"]][[ii]], compare_pairs1))
  }
  names(acc_all1) = names(pair_list1)
  print(acc_all1)
}


library(lubridate)
library(ggplot2)
source("Italy/code/utils/read-data-subnational.r")
source("Italy/code/plotting/format-data-plotting.r")
source("Italy/code/plotting/make-three-panel-plots.r")
source("Italy/code/plotting/make-rt-plot.r")

make_plots_all <- function(filename, SIM=FALSE, label = "", last_date_data, ext = ".png"){
  print("In subnational code")
  load(filename)
  countries <- states

  out <- rstan::extract(fit)

  rt_data_long <- NULL
  rt_data_wide <- NULL

  interventions <- read_interventions()

  covariates <- interventions
  covariates$Country  <- as.factor(covariates$Country)
  for (i in 1:length(countries)){
    print(countries[i])

    data_country_plot <- format_data(i = i, dates = dates, countries = countries,
                                     estimated_cases_raw = estimated_cases_raw,
                                     estimated_deaths_raw = estimated_deaths_raw,
                                     reported_cases = reported_cases,
                                     reported_deaths = reported_deaths,
                                     out = out, SIM = SIM)
    # Cuts data on last_data_date
    data_country_plot <- data_country_plot[which(data_country_plot$date <= last_date_data),]

    # Read in covariates

    covariates_long <- gather(covariates[which(covariates$Country == countries[i]),
                                         2:ncol(covariates)],
                              key = "key", value = "value")
    covariates_long$x <- rep(NA, length(covariates_long$key))
    un_dates <- unique(covariates_long$value)

    for (k in 1:length(un_dates)){
      idxs <- which(covariates_long$value == un_dates[k])
      max_val <- ceiling(max(data_country_plot$rt_max) +0.3)
      for (k in idxs){
        covariates_long$x[k] <- max_val
        max_val <- max_val - 0.3
      }
    }

    print(sprintf("Last line of data: %s", data_country_plot$date[length(data_country_plot$rt)]))

    len <- length(data_country_plot$rt)
    rt_data_state_long <- data.frame("state" = c(as.character(countries[i]), as.character(countries[i])),
                                     "x" = c("start", "end"),
                                     "rt" = c(data_country_plot$rt[1],
                                              mean(data_country_plot$rt[(len-6):len])),
                                     "rt_min" = c(data_country_plot$rt_min[1],
                                                  mean(data_country_plot$rt_min[(len-6):len])),
                                     "rt_max" = c(data_country_plot$rt_max[1],
                                                  mean(data_country_plot$rt_max[(len-6):len])))
    rt_data_long <- rbind(rt_data_long, rt_data_state_long)

    # Make the three panel plot
    make_three_panel_plots(data_country_plot, jobid = JOBID, country = countries[i],
                          covariates_long = covariates_long, label = label)
  }

  print("Making rt plot")
  rt_data_long$x <- factor(rt_data_long$x, levels = c("start", "end"))

  region_to_macro=rbind(
                data.frame(country= c("Aosta","Liguria","Lombardy","Piedmont"), macro="NorthWest"),
                data.frame(country=c("Emilia-Romagna","Friuli-Venezia_Giulia","Trento","Bolzano","Veneto"),macro="NorthEast"),
                data.frame(country=c("Lazio","Marche","Tuscany","Umbria"),macro="Centre"),
                data.frame(country=c("Abruzzo","Apulia","Basilicata","Calabria","Campania","Molise"),macro="South"),
                data.frame(country=c("Sardinia","Sicily"),macro="Islands")
  )
  names(region_to_macro) <- c("state", "macro")
  rt_data_long = rt_data_long %>%inner_join(region_to_macro,)

  make_rt_point_plot(rt_data_long, JOBID = JOBID, label = label)

}


#author: Grzegorz Protaziuk, Robert Bembenik
# script EDAMI lab2
#1. Data preprocessing and analysis
#2. Frequent itemsets discovery
#3. Association rules discovery

#set working directory - adjust a path to your directory with datasets
#setwd("path")
#getwd()
#library loading
install.packages("arules")
install.packages("arulesViz")
library(arules) # association rules
library(arulesViz) # visualization of reles

#Dataset AdultUCI is availabe in arules library
data("AdultUCI")
dim(AdultUCI)
?AdultUCI

#information about data - statistics
summary(AdultUCI)
#exemple of records
head(AdultUCI,10)

#discretization of numerical attributes
#using discretize function: n-equal-size ranges,
?discretize

discInterval = discretize(AdultUCI$age, method ='interval', breaks = 4)
summary(discInterval)

# n-equal-frequency ranges
discFreq = discretize(AdultUCI$age, method= 'frequency', breaks = 4)
summary(discFreq);
summary(AdultUCI$age)

summary(AdultUCI$age)
discFreq = discretize(AdultUCI$fnlwgt, method= 'frequency', breaks = 4)
summary(discFreq);

#removing dispensable attributes
AdultUCI["fnlwgt"] <- NULL
AdultUCI["education-num"] <-NULL

AdultUCI[[ "age"]] <- ordered(cut(AdultUCI[[ "age"]], c(15,25,45,65,100)), labels = c("Young", "Middle-aged", "Senior", "Old"))

head(AdultUCI,10)

AdultUCI[[ "hours-per-week"]] <- ordered(cut(AdultUCI[[ "hours-per-week"]],c(0,25,40,60,168)),
                                         labels = c("Part-time", "Full-time", "Over-time", "Workaholic"))

head(AdultUCI,10)
AdultUCI[[ "capital-gain"]] <- ordered(cut(AdultUCI[[ "capital-gain"]], c(-Inf,0,median(AdultUCI[[ "capital-gain"]][AdultUCI[[ "capital-gain"]]>0]),Inf)),
                                       labels = c("None", "Low", "High"))

head(AdultUCI,10)
AdultUCI[[ "capital-loss"]] <- ordered(cut(AdultUCI[[ "capital-loss"]],
                                           c(-Inf,0, median(AdultUCI[[ "capital-loss"]][AdultUCI[[ "capital-loss"]]>0]),Inf)),
                                       labels = c("none", "low", "high"))
summary(AdultUCI)

#convertion from "data.frame" datatype to "transactions" datatype
adultTR <- as(AdultUCI, "transactions")
#info about a new structure
str(adultTR)
#class(adultTR)
#statistics
summary(adultTR)
length(which(is.na(AdultUCI)==TRUE))

###############################
#data analyzis
#frequency of items
?itemFrequency
freqTbl  = itemFrequency(adultTR, type = "relative")
str(freqTbl)
#class(freqTbl)
summary(freqTbl)

print(freqTbl)
#?sort
#sorting according  relative support values
freqTbl = sort(freqTbl, decreasing= TRUE)

#printing only items having support > 20%
print(freqTbl[freqTbl > 0.2])

#number of elements with support >= 5%
length(freqTbl[freqTbl>=0.05])

#chart
itemFrequencyPlot(adultTR, type ="relative", support= 0.2)

########################################
#2. Frequent itemsets
#setting parameters of Apriori algorithm
?APparameter
aParam  = new("APparameter", "confidence" = 0.6, "support" =0.5, "minlen"= 1)
print(aParam)
#adjusting values of parameters
aParam@support <- 0.3
aParam@confidence <-0.8
aParam@target ="frequent itemsets"
str(aParam)
print(aParam)
?apriori
#frequent itemsets discovery - Apriori algorithm
asets <-apriori(adultTR,aParam)
#str(asets)
#analysis of discovered frequent itemsets
length(asets)
summary(asets)
inspect(head(sort(asets, by="support"),10))

size(asets)
str(asets)

inspect(asets[size(asets)>5])
#charts
plot(asets[1:10])
plot(asets[size(asets)>5], method = "graph")
plot(asets[size(asets)>4], method = "paracoord", control = list(reorder = TRUE))

#searching for items including a given text

?subset
setsRace <- subset(asets, subset = items %in% "White")
setsRace <- subset(asets, subset = items %in% "race=White")
inspect(setsRace)

setsRace <- subset(asets, subset = items %pin% "White")
inspect(setsRace)

setsRace <- subset(asets, subset = items %ain% c("race=White","sex=Male"))
inspect(setsRace)
?is.closed
#closed itemsets
is.closed(asets)
#maximal itemsets
?is.maximal
maxSets <- asets[is.maximal(asets)==TRUE]
inspect(maxSets)
summary(maxSets)

#frequent itemsets discovery - Eclat algorithm
#parameters
ecParam  = new("ECparameter", "confidence" = 0.8, "support" = 0.3)
print(ecParam)

#discovery of frequent itemsets
fsets <- eclat(adultTR,ecParam)
length(fsets)

#selection of frequent itemset found by means of  Eclat algorithm
# and not found by means of Apriori algorithm

inspect(fsets[which(is.na(fsets %in% asets))])

inspect(fsets[which((fsets %in% asets)==FALSE)])
length(fsets[which((fsets %in% asets)==FALSE)])

#changing values of parameters
ecParam@support = 0.4
print(ecParam)

#frequent itemsets discovery - Eclat algorithm
fsets <- eclat(adultTR,ecParam)
length(fsets)
length(asets)
#selection of frequent itemset found by means of  Apriori algorithm
# and not found by means of Eclat algorithm

inspect(asets[which(is.na(asets %in% fsets))])

#3. Association rules discovery

#setting of parameters
aParam@target ="rules"
aParam@minlen = 2L
aParam@confidence = 0.8

print(aParam)

#Disvoering of assocation rules by means of Apriori algorithm
aRules <-apriori(adultTR,aParam)
#statistics of rules
summary(aRules)

length(aRules)
str(aRules)
#example of rules
inspect(head(aRules))

# discovering rules with a given consequent
rulesWithRHS <- apriori(adultTR, parameter = list(support=0.2, confidence = 0.5, minlen = 2),
                        appearance = list(rhs = c("capital-gain=None", "capital-loss=none"), default="lhs"))
inspect(rulesWithRHS[1:10])
?apriori
# discovering rules not having given items
rulesNotItems <- apriori(adultTR, parameter = list(support=0.2, confidence = 0.5, minlen = 2),
                         appearance = list(none = c("capital-gain=None", "capital-loss=none"), default="both"))
inspect(rulesNotItems[1:10])

?subset
#filtering rules - selection of interesting rules
#rules with lift parameter >1.2
rulesLift1.2 <- subset(aRules, subset = lift > 1.2)
inspect(rulesLift1.2)

#charts presenting association rules
#size(rulesLift1.2)
plot(rulesLift1.2, shading="order", control=list(main = "Two-key plot" ))
plot(rulesLift1.2, method="matrix", measure="lift", interactive = TRUE)

#selection of rules with a given consequent
rulesInGivenConseq <- subset(aRules, subset = rhs %in% "relationship=Husband" & lift >=2.3)
inspect(rulesInGivenConseq)
plot(rulesInGivenConseq, method = "graph", engine = "htmlwidget")
#rules based on maximal frequent itemsets
maxRul <- aRules[is.maximal(aRules) == TRUE]
summary(maxRul)
inspect(maxRul[1:10])
#removing reduntant rules (rules with the same consequent and confidence but with less items in the antecedent
notRedun <- aRules[is.redundant(aRules) == FALSE]
summary(notRedun)
inspect(notRedun[1:10])

#Selecting rules based on the selected indicator of rule interestingness
?interestMeasure
#rules with improvement indicator greater than 0.01

resTbl <- interestMeasure(aRules,"improvement", asets)
intres <- which(sapply(resTbl, function(x) {x > 0.01  && x <= 1 })==TRUE)
intersRule <- aRules[intres]
inspect(intersRule)

################################################3
#generation of association rules based on disvovered frequent itemsets
?ruleInduction

ecParam  = new("ECparameter", "confidence" = 0.8, "support" = 0.3)
#discvoring frequent itemsets
fsets <- eclat(adultTR,ecParam)

iERules = ruleInduction(fsets, adultTR, confidence = 0.8, control=list(method ="ptree"))
summary(iERules)
length(iERules)
inspect(head(iERules))

##################################################################
#datasets for the laboratory task

#marketSet - Tuesday group

download.file('http://staff.ii.pw.edu.pl/~gprotazi/dydaktyka/dane/supermarket.csv','supermarket.csv')
marketSet = read.csv('supermarket.csv',sep=';')
marketSet= as.data.frame(sapply(marketSet, function(x) as.logical(x)))
summary(marketSet)
head(marketSet)

#Mushroom dataset -  Wednesday group
data(Mushroom)
?Mushroom
str(Mushroom)
summary(Mushroom)
inspect(head(Mushroom))


#!/usr/bin/env Rscript
data <- readLines("stdin")
cleaned <- gsub(" $", "", gsub("^[^0-9-]+", "", gsub("[^0-9-]+", " ", data)))

tc <- textConnection(cleaned)

input <- read.csv(tc, header=FALSE, sep=" ")

close(tc)

perm <- order(rowSums(abs(input[,7:9])), rowSums(abs(input[,4:6])))
print(perm[1] - 1)

for (i in 1:100) {
	# Update positions, speeds
	input[,4:6] <- input[,4:6] + input[,7:9]
	input[,1:3] <- input[,1:3] + input[,4:6]

	dups <- !(duplicated(input[,1:3]) | duplicated(input[,1:3], fromLast=TRUE))

	input <- input[dups,]
}

print(nrow(input))


#' Makes community data matrices of given size from simulated community.
#'
#' @param com A list, returned by evolve_com.
#' @param size A number, size of each community data matrix.
#'
#' @return Community data matrices.
#' @export
#'
#' @examples
#' make.cdm(com, size = 8)

make.cdm <- function(com, size)
{
  n <- floor(com$L/size)
  cdm <- as.data.frame(matrix(0, ncol = length(com$niche), nrow = n^2))
  counter <- 1

  for (ii in 1:n) {
    for (jj in 1:n) {
      temp <- com$id[((ii-1)*size+1):(ii*size), ((jj-1)*size+1):(jj*size)]
      tab <- table(temp)
      id <- as.numeric(names(tab))
      cdm[counter, id] <- tab
      counter <- counter + 1
    }
  }

  return(cdm)
}

#' Makes community data array of given size from simulated community.
#'
#' @param com A list, returned by evolve_com.
#' @param size A number, size of each community data matrix.
#'
#' @return Community data array.
#' @export
#'
#' @examples
#' make.cda(com, size = 8)

make.cda <- function(com, size)
{
  n <- floor(com$L/size)
  cda <- array(data = 0, dim = c(n, n, length(com$niche)))

  for (ii in 1:n) {
    for (jj in 1:n) {
      temp <- com$id[((ii-1)*size+1):(ii*size), ((jj-1)*size+1):(jj*size)]
      tab <- table(temp)
      id <- as.numeric(names(tab))
      cda[ii, jj, id] <- tab
    }
  }

  return(cda)
}


# 2. faza: Uvoz podatkov

# Funkcija, ki uvozi podatke iz datoteke druzine.csv
library(ggplot2)

# Zapišimo podatke v razpredelnico
require(csvread)

podatki <- read.csv(file = "uvoz/LaLiga.csv",encoding = "UTF-8")
require(rmarkdown)
names(podatki)[4] <- "Wins"
names(podatki)[5] <- "Draws"
names(podatki)[6] <- "Loses"
names(podatki)[7] <- "Goal_Difference"
names(podatki)[7] <- "Goals_For"
names(podatki)[8] <- "Goals_Against"
names(podatki)[9] <- "Goal_Difference"
names(podatki)[10] <- "Points"
podatki$Qualification.or.relegation <- NULL
names(podatki)[1] <- "Position"
names(podatki)[3] <- "Played"
podatki$'Win/Lose' <- round(podatki$Wins/podatki$Loses,2)
podatki$'Goals_per_match' <- round((podatki$`Goals_For`+podatki$`Goals_Against`)/podatki$Played,2)
podatki$'Draw_percentage' <- round((podatki$Draws/podatki$Played)*100, 2)
summary(podatki)
fillgolrazlika <- c(podatki$`Goal_Difference` + 50)
pozicije <- read.csv(file="podatki/LaLiga_pozicije.csv", encoding = "Windows-1250")
pozicije$povprecna <- round((pozicije$X1 + pozicije$X2 + pozicije$X3 + pozicije$X4 + pozicije$X5 + pozicije$X6 + pozicije$X7 + pozicije$X8 + pozicije$X9 + pozicije$X10 + pozicije$X11 + pozicije$X12 + pozicije$X13 + pozicije$X14 + pozicije$X15 + pozicije$X16 + pozicije$X17 + pozicije$X18 + pozicije$X19 + pozicije$X20 + pozicije$X21 + pozicije$X22 + pozicije$X23 + pozicije$X24 + pozicije$X25 + pozicije$X26 + pozicije$X28 + pozicije$X29 + pozicije$X30 + pozicije$X31 + pozicije$X32 + pozicije$X33 + pozicije$X34 + pozicije$X35 + pozicije$X36 + pozicije$X37 + pozicije$X38)/38,2)

fnk_Barcelona <- pozicije[1,c(0,-1)]
k_bar=0
n_bar=0
for(i in 1:22){k_bar = k_bar+((fnk_Barcelona[1,i + 1] - fnk_Barcelona[1,i]))/22;n_bar = n_bar + (fnk_Barcelona[1,i] +i*(fnk_Barcelona[1,i] - fnk_Barcelona[1,i+1]))/22}

fnk_Real <- pozicije[2,c(0,-1)]
k_real=0
n_real=0
for(i in 1:22){k_real = k_real+((fnk_Real[1,i + 1] - fnk_Real[1,i]))/22;n_real = n_real + (fnk_Real[1,i] + i*(fnk_Real[1,i] - fnk_Real[1,i+1]))/22}

pozi <- data.frame(row.names = c("T1", "T36"))
pozi$Bar <- c(n_bar + k_bar, n_bar + 36*k_bar)
pozi$Real <- c(n_real + k_real, n_real + 36*k_real)

napoved <- ggplot(data=pozi) + geom_smooth(method="lm", aes(x=c(1,36),y=Bar), color="Red") + geom_line(aes(x=c(1,36),y=Real), color="Blue") + ylim(0,7) + xlim(1,37) +xlab("") + ylab("")

# Če bi imeli več funkcij za uvoz in nekaterih npr. še ne bi
# potrebovali v 3. fazi, bi bilo smiselno funkcije dati v svojo
# datoteko, tukaj pa bi klicali tiste, ki jih potrebujemo v
# 2. fazi. Seveda bi morali ustrezno datoteko uvoziti v prihodnjih
# fazah.


  transition.matrices = function(p, sex=0, redo=F) {

# Global snow crab parameters
# sex codes
  male = 0
  female = 1
  sex.unknown = 2

    # a wrapper function to obtain transition matrices
    outfilename = file.path( p$annual.results, "transition.matrices.rdata" )
    if (!redo) {
      load( outfilename )
      return ( tmatrix )
    }

    # initialize matrices
    eps = 1e-4  # assume this is min resolution
    xTM =  array(data=NA, dim=c(p$nnodes,p$nnodes,p$nyears,p$nregions), dimnames=list(p$nodes,p$nodes,p$nodeyears,p$regions) )
    xFM =  array(data=NA, dim=c(p$nnodes,p$nyears,p$nregions), dimnames=list(p$nodes,p$nodeyears,p$regions) )

    # create transition matrices
    for (region in p$regions) {
      # observer based landings broken down by size-mat classes
      fm = landings.decomposed ( p, sex=sex, region )
      # kriged numerical abundance estimates
      ts = get.annual.timeseries( p, sex=sex, outtype="yearclass", region=region)
      k = ts$TS
      k[ which(k < eps) ] = 0
      for (y in p$nodeyears) {

        nnodes = length(p$nodes)
        yc0 = as.character(y-1)
        yc1 = as.character(y)

        # the transition matrix estimates the transfer function between
        # the post-fishery numbers [N.post(t-1)] to the prefishery Numbers at time t [N.pre(t)]
        # == N.pre[t] / N.post[t-1]
        # k contains N.post from kriged estimates
        # fm contains N.fishing from observer data
        # N.pre[t] = N.post[t] + N.fishing[t]
        # N.post[t] must be offset to be N.post[t-1] for transition matrix calculations

        # fall surveys from 2003 to present
        # spring surveys from 1998 to 2001
        # spring and fall surveys in 2002
        # correct timing of landings to account for change in survey season (by offsetting landings)
        fm[,,"2002"] = fm[,,"2002"] + fm[,,"2001"]
        for (y in 2001:1999)  fm[,,as.character(y)] = fm[,,as.character(y-1)]
        fm[,,"1998"] = fm[,,"1998"] * NA

        N.pre  = k + fm
        N.post1 = offset.ageclass(k)
        N.post0 = k  # no offsets

        TM = array( data=0, c(nnodes, nnodes), dimnames=list(p$nodes, p$nodes) )
        FM = array( data=0, c(nnodes), dimnames=list(p$nodes) )

        if (sex==male) {

          # imm->imm
          ii = N.pre[,"imm", yc1] / N.post1[,"imm",yc0]
          ii = ifelse( !is.finite(ii) | ii < eps,  mean( ii[ ii > eps &  is.finite(ii) ]) , ii)

          # imm->sm; no offset in size as they do not change in size ("instar")
          sm = N.pre[,"imm.sm",yc1] / N.post0[,"imm",yc0]
          sm = ifelse( sm < eps | !is.finite(sm), mean( sm[ sm > eps & is.finite(sm) ]), sm)

          # fraction of imm -> imm.sm
          fraction.sm.imm = N.post1[,"imm.sm",yc0] / ( N.post1[,"imm",yc0] + N.post1[,"imm.sm",yc0] )
          fraction.sm.imm = ifelse( fraction.sm.imm <= eps |  fraction.sm.imm >= 1 | !is.finite( fraction.sm.imm  ),
            mean( fraction.sm.imm [ which( fraction.sm.imm > eps & fraction.sm.imm < 1 & is.finite( fraction.sm.imm ) ) ]),
            fraction.sm.imm  )

          # imm->cc12  (assuming some fraction came from imm)
          is = (1 - fraction.sm.imm) * N.pre[,"CC1to2",yc1] / N.post1[,"imm",yc0]
          is = ifelse( (is <= eps |  is >= 1 | !is.finite(is) ), mean( is[ is > eps & is < 1 & is.finite(is) ]), is)

          # sm -> CC12 (" ..."  sm)
          m0 = fraction.sm.imm * N.pre[,"CC1to2",yc1] / N.post1 [,"imm.sm",yc0]
          m0 = ifelse( (m0 <= eps | !is.finite(m0) ),  mean( m0[ m0 > eps & is.finite(m0) ]), m0)

          # assume mortality 0.33 = 1/3yr (expected duration of the CC2to4 stage)
          expected.longevity.CC34.yr = 3 # assuming pseudo-steady-state (ie. 1/3 = 33% annual mortality)

          # the mortality percent per year is expressed as passage into the CC5 category
          loss.rate.CC34 = 1 / expected.longevity.CC34.yr
          transfer.rate.CC34 = 1 - loss.rate.CC34
          m2 = rep(transfer.rate.CC34, length(ii))  # cc34 -> cc34 ; assume unit catchability
          names(m2) = names(ii)

          # this is the fraction that is assumed to have come from CC12
          difference = N.pre[,"CC3to4",yc1] - (transfer.rate.CC34 * N.post0[,"CC3to4",yc0])
          phi = difference / N.post0[,"CC1to2",yc0] # cc12 -> cc34
          phi = ifelse( phi <= eps |  !is.finite(phi), mean( phi[ phi > eps & is.finite(phi) ]), phi)

          # cc34 -> cc5
          mt = rep(loss.rate.CC34, length(ii) )
          names(mt) = names(ii)

          TM["imm.6",   "imm.5"] = ifelse( (ii["6"]==0 | !is.finite(ii["6"])), 1, ii["6"] ) # no fishing mort and undersampled .. assume 1 to be safe if est is too low
          TM["imm.7",   "imm.6"] = ifelse( (ii["7"] ==0 | !is.finite(ii["7"])), 1, ii["7"] )
          TM["imm.8",   "imm.7"] = ifelse( (ii["8"] ==0 | !is.finite(ii["8"])), 1, ii["8"] )
          TM["imm.9",   "imm.8"] = ii["9"]
          TM["imm.10",  "imm.9"] = ii["10"]
          TM["imm.11", "imm.10"] = ii["11"]
          TM["imm.12", "imm.11"] = ii["12"]

          TM["CC1to2.9",   "imm.8"] = is["9"]
          TM["CC1to2.10",  "imm.9"] = is["10"]
          TM["CC1to2.11", "imm.10"] = is["11"]
          TM["CC1to2.12", "imm.11"] = is["12"]

          TM["imm.sm.9",   "imm.9"] = sm["9"]
          TM["imm.sm.10",  "imm.10"] = sm["10"]
          TM["imm.sm.11",  "imm.11"] = sm["11"]
          TM["imm.sm.12",  "imm.12"] = sm["12"]

          TM["CC1to2.10", "imm.sm.9"] = m0["10"]
          TM["CC1to2.11","imm.sm.10"] = m0["11"]
          TM["CC1to2.12","imm.sm.11"] = m0["12"]
          TM["CC1to2.13","imm.sm.12"] = m0["13"]

          TM["CC3to4.9", "CC1to2.9"] = phi["9"]
          TM["CC3to4.10", "CC1to2.10"] = phi["10"]
          TM["CC3to4.11", "CC1to2.11"] = phi["11"]
          TM["CC3to4.12", "CC1to2.12"] = phi["12"]
          TM["CC3to4.13", "CC1to2.13"] = phi["13"]

          TM["CC3to4.9", "CC3to4.9"] = m2["9"]
          TM["CC3to4.10", "CC3to4.10"] =  m2["10"]
          TM["CC3to4.11", "CC3to4.11"] =  m2["11"]
          TM["CC3to4.12", "CC3to4.12"] =  m2["12"]
          TM["CC3to4.13", "CC3to4.13"] =  m2["13"]

          TM["CC5.9", "CC3to4.9"] = mt["9"]
          TM["CC5.10", "CC3to4.10"] = mt["10"]
          TM["CC5.11", "CC3to4.11"] = mt["11"]
          TM["CC5.12", "CC3to4.12"] = mt["12"]
          TM["CC5.13", "CC3to4.13"] = mt["13"]

        # Fishing mortality

          f.ii = fm[,"imm", yc1] / N.pre[,"imm",yc1]  # exploitation of imm
          f.ii = ifelse(  f.ii <= eps | f.ii >=1  | !is.finite(f.ii), mean( f.ii[ f.ii > eps & f.ii < 1 & is.finite(f.ii) ]), f.ii)

          f.sm = fm[,"imm.sm", yc1] / N.pre[,"imm.sm",yc1]
          f.sm = ifelse(  f.sm <= eps | f.sm >=1  | !is.finite(f.sm), mean( f.sm[ f.sm > eps & f.sm < 1 & is.finite(f.sm) ]), f.sm)

          f.is = fm[,"CC1to2", yc1] / N.pre[,"CC1to2",yc1]
          f.is = ifelse(  f.is <= eps  | f.is >=1 | !is.finite(f.is), mean( f.is[ f.is > eps & f.is < 1 & is.finite(f.is) ]), f.is)

          f.phi = fm[,"CC3to4", yc1] / N.pre[,"CC3to4",yc1]
          f.phi = ifelse(  f.phi <= eps  | f.phi >=1 | !is.finite(f.phi), mean( f.phi[ f.phi > eps & f.phi < 1 & is.finite(f.phi) ]), f.phi)

          f.mt = fm[,"CC5", yc1] / N.pre[,"CC5",yc1]
          f.mt = ifelse(  f.mt <= eps  | f.mt >=1 | !is.finite(f.mt), mean( f.mt[ f.mt > eps & f.mt < 1 & is.finite(f.mt) ]), f.mt)

          FM["imm.10"] = f.ii["10"]
          FM["imm.11"] = f.ii["11"]
          FM["imm.12"] = f.ii["12"]

          FM["imm.sm.10"] = f.sm["10"]
          FM["imm.sm.11"] = f.sm["11"]
          FM["imm.sm.12"] = f.sm["12"]

          FM["CC1to2.10"] = f.is["10"]
          FM["CC1to2.11"] = f.is["11"]
          FM["CC1to2.12"] = f.is["12"]
          FM["CC1to2.13"] = f.is["13"]

          FM["CC3to4.10"] = f.phi["10"]
          FM["CC3to4.11"] = f.phi["11"]
          FM["CC3to4.12"] = f.phi["12"]
          FM["CC3to4.13"] = f.phi["13"]

          FM["CC5.10"] = f.mt["10"]
          FM["CC5.11"] = f.mt["11"]
          FM["CC5.12"] = f.mt["12"]
          FM["CC5.13"] = f.mt["13"]

        }

        xTM[,,as.character(y),region] = TM
        xFM[,as.character(y),region] = FM
      }
    } #end regions

    tmatrix = list(TM=xTM, FM=xFM)
    save( tmatrix, file=outfilename, compress=T )
    return(tmatrix)
  }


#Functions
###########
#RMSE_row<-function(data0)
#log_new<-function(data_c)
#consist_NMF_markers<-function(ccc,tg_markers_c)
#consist_NMF_markers2<-function(ccc,ccc2,tg_markers_c)
#consist_NMF_markers3<-function(ccc,ccc2,tg_markers_c)
#normalize_data<-function(data0)
#normalize_data2<-function(data0)
#normalize_data3<-function(data0)
#compute_O_Rowspace<-function(data0,k)
#compute_CO_Rowspace<-function(data0,k)
#coexpression_marker_selection<-function(tg_markers,cor_Cut=0.8,cor_C0)
#plot_BCs<-function(tg_selected_BCs,qubic_input_all,qubic_results_all,tg_selected_data_list2)
#compute_plot_BCs<-function(tg_selected_data_list2,c0=1,o0=3000,f0=0.1,BC_nrow_cut0=10)
#Compute_Jaccard_mm<-function(M0,M1)
#coexpression_marker_selection2<-function(cor_C0,marker_stats1,cor_Cut_list=seq(50,90,by=2)/100)
#plot_cor_gene_lists<-function(data0,tg_list)
#analyze_QUBIC_genes_stats<-function(BC_im_depletion_gene_stats)
#compute_Jaccard<-function(data_list)
#compute_Intersect<-function(data_list)
#norm_transform<-function(data0)
#test_cell_list<-function(BC_gene_list,tg_cell_list,all_genes)
#coexpression_marker_selection<-function(tg_markers,cor_Cut=0.8,cor_C0)

##################
#load("IM_markers_02082018.RData")

####################################
RMSE_row<-function(data0)
{
	return(apply(data0^2,1,mean))
}

log_new<-function(data_c)
{
	data_c0<-data_c
	for(i in 1:nrow(data_c0))
	{
		aaa<-log(data_c[i,])
		m<-min(data_c[i,which(data_c[i,]!=0)])
		aaa[which(data_c[i,]==0)]<-log(m*0.5)
		data_c0[i,]<-aaa
	}
	return(data_c0)
}

consist_NMF_markers<-function(ccc,tg_markers_c)
{
ddd<-c()
for(i in 1:nrow(ccc))
{
ddd<-c(ddd,which(ccc[i,]==max(ccc[i,])))
}
names(ddd)<-rownames(ccc)
aaa<-matrix(0,ncol(ccc),length(tg_markers_c))
for(i in 1:ncol(ccc))
{
for(j in 1:length(tg_markers_c))
{
aaa[i,j]<-length(intersect(names(ddd)[which(ddd==i)],tg_markers_c[[j]]))
}
}
rownames(aaa)<-1:ncol(ccc)
colnames(aaa)<-names(tg_markers_c)
fff<-list()
for(i in 1:ncol(ccc))
{
fff[[i]]<-names(ddd)[which(ddd==i)]
}
names(fff)<-1:ncol(ccc)
return(list(aaa,fff))
}

consist_NMF_markers2<-function(ccc,ccc2,tg_markers_c)
{
ccc3<-apply(ccc2,1,mean)
for(i in 1:ncol(ccc))
{
	ccc[,i]<-ccc[,i]*ccc3[i]
}
ddd<-c()
for(i in 1:nrow(ccc))
{
ddd<-c(ddd,which(ccc[i,]==max(ccc[i,])))
}
names(ddd)<-rownames(ccc)
aaa<-matrix(0,ncol(ccc),length(tg_markers_c))
for(i in 1:ncol(ccc))
{
for(j in 1:length(tg_markers_c))
{
aaa[i,j]<-length(intersect(names(ddd)[which(ddd==i)],tg_markers_c[[j]]))
}
}
rownames(aaa)<-1:ncol(ccc)
colnames(aaa)<-names(tg_markers_c)
fff<-list()
for(i in 1:ncol(ccc))
{
fff[[i]]<-names(ddd)[which(ddd==i)]
}
names(fff)<-1:ncol(ccc)
return(list(aaa,fff))
}

consist_NMF_markers3<-function(ccc,ccc2,tg_markers_c)
{
ccc3<-apply(ccc2,1,median)
for(i in 1:ncol(ccc))
{
	ccc[,i]<-ccc[,i]*ccc3[i]
}
ddd<-c()
for(i in 1:nrow(ccc))
{
ddd<-c(ddd,which(ccc[i,]==max(ccc[i,])))
}
names(ddd)<-rownames(ccc)
aaa<-matrix(0,ncol(ccc),length(tg_markers_c))
for(i in 1:ncol(ccc))
{
for(j in 1:length(tg_markers_c))
{
aaa[i,j]<-length(intersect(names(ddd)[which(ddd==i)],tg_markers_c[[j]]))
}
}
rownames(aaa)<-1:ncol(ccc)
colnames(aaa)<-names(tg_markers_c)
fff<-list()
for(i in 1:ncol(ccc))
{
fff[[i]]<-names(ddd)[which(ddd==i)]
}
names(fff)<-1:ncol(ccc)
return(list(aaa,fff))
}

normalize_data<-function(data0)
{
	data1<-data0
	for(i in 1:nrow(data1))
	{
		data1[i,]<-data1[i,]/max(data1[i,])
	}
	return(data1)
}

normalize_data2<-function(data0)
{
	data1<-data0
	for(i in 1:nrow(data1))
	{
		data1[i,]<-(data1[i,]-mean(data1[i,]))/sd(data1[i,])
	}
	return(data1)
}

normalize_data3<-function(data0)
{
	data1<-data0
	for(i in 1:nrow(data1))
	{
		data1[i,]<-(data1[i,]-min(data1[i,]))
		data1[i,]<-data1[i,]/max(data1[i,])
	}
	return(data1)
}

compute_O_Rowspace<-function(data0,k)
{
        SVD_ccc<-svd(normalize_data2(data0))
        ttt_ccc<-t(SVD_ccc$v)[1,]%*%t(t(SVD_ccc$v)[1,])/sum((t(SVD_ccc$v)[1,])^2)
        t_ccc0<-ttt_ccc*0
        for(i in 1:k)
        {
                t_ccc0<-t_ccc0+t(SVD_ccc$v)[i,]%*%t(t(SVD_ccc$v)[i,])/sum((t(SVD_ccc$v)[i,])^2)
        }
        return(t_ccc0)
}

compute_CO_Rowspace<-function(data0,k)
{
	SVD_ccc<-svd(normalize_data2(data0))
	ttt_ccc<-t(SVD_ccc$v)[1,]%*%t(t(SVD_ccc$v)[1,])/sum((t(SVD_ccc$v)[1,])^2)
	t_ccc0<-ttt_ccc*0
	for(i in (k+1):nrow(SVD_ccc$v))
	{
		t_ccc0<-t_ccc0+t(SVD_ccc$v)[i,]%*%t(t(SVD_ccc$v)[i,])/sum((t(SVD_ccc$v)[i,])^2)
	}
	return(t_ccc0)
}

coexpression_marker_selection<-function(tg_markers,cor_Cut=0.8,cor_C0)
{
	tg_B_markers<-tg_markers
	cn<-c()
N<-0
for(i in 1:length(tg_B_markers))
{
	ccc<-names(which(cor_C0[tg_B_markers[[i]],]>0.8))
	if(length(ccc)>4)
	{
		N<-N+1
		cn<-c(cn,tg_B_markers[[i]])
		tg_B_markers_cor_lists[[N]]<-ccc
	}
}
names(tg_B_markers_cor_lists)<-cn

ff_all<-c()
tg_lists<-tg_B_markers_cor_lists
for(i in 1:length(tg_lists))
{
	ccc<-extract_data_symbol(marker_stats1,tg_lists[[i]])
	aaa<-unique(rownames(ccc))
	ddd<-c()
	for(j in 1:length(aaa))
	{
		if(sum(rownames(ccc)==aaa[j])==1)
		{
			bbb<-ccc[aaa[j],]
			bbb[which(bbb==0)]<-100
			bbb<-1/bbb*(bbb<=3)
			ddd<-rbind(ddd,bbb)
		}
		else
		{
			bbb<-ccc[which(rownames(ccc)==aaa[j]),]
			bbb[which(bbb==0)]<-100
			bbb<-1/bbb*(bbb<=3)
			ddd<-rbind(ddd,apply(bbb,2,mean))
		}
	}
	rownames(ddd)<-aaa
	fff<-apply(ddd,2,mean)
	ff_all<-rbind(ff_all,fff)
}
rownames(ff_all)<-names(tg_lists)

#library(gplots)
colors = c(0:100)/100
my_palette <- grDevices::colorRampPalette(c("white", "midnightblue"))(n =100)

heatmap.2(ff_all,Rowv=F,Colv =F,scale="none",main="",
	col=my_palette,breaks=colors,density.info="none",dendrogram="both",
	trace="none",margin=c(10,10),cexRow=0.6,cexCol=1)
	return(list(ff_all,tg_B_markers_cor_lists))
}

##################

plot_BCs<-function(tg_selected_BCs,qubic_input_all,qubic_results_all,tg_selected_data_list2){
for(ii in 1:length(tg_selected_BCs))
{
	print(tg_cancer_keys[ii])
	tg_all_genes<-c()
	for(i in 1:length(tg_selected_BCs[[ii]][[1]]))
	{
		tg_all_genes<-c(tg_all_genes,tg_selected_BCs[[ii]][[1]][[i]])
	}
	tg_all_genes<-unique(tg_all_genes)
	aaa000<-matrix(0,length(tg_selected_BCs[[ii]][[1]]),length(tg_selected_BCs[[ii]][[1]]))
	for(i in 1:length(tg_selected_BCs[[ii]][[1]]))
	{
		for(j in 1:length(tg_selected_BCs[[ii]][[1]]))
		{
			aaa000[i,j]<-1-Compute_Jaccard_mm(qubic_input_all[[ii]][tg_all_genes,tg_selected_BCs[[ii]][[2]][[i]]],qubic_input_all[[ii]][tg_all_genes,tg_selected_BCs[[ii]][[2]][[j]]])
		}
	}
	bbb000<-hclust(as.dist(aaa000))
	plot(bbb000)
	aaa1<-bbb000$order
	hmcols2 <- grDevices::colorRampPalette(rev(c("#D73027", "#FC8D59", "#FEE090", "#FFFFBF", "#E0F3F8", "#91BFDB", "#4575B4")))(length(aaa1))
	tg_genes_all<-c()
	tg_samples_all<-c()
	tg_col_c3<-c()
	tg_row_c3<-c()
	for(i in 1:length(aaa1))
	{
		tg_genes<-tg_selected_BCs[[ii]][[1]][[i]]
		tg_samples<-tg_selected_BCs[[ii]][[2]][[i]]
		tg_samples_c<-setdiff(tg_samples,tg_samples_all)
		tg_genes_c<-setdiff(tg_genes,tg_genes_all)
		tg_genes_all<-c(tg_genes_all,tg_genes_c)
		tg_samples_all<-c(tg_samples_all,tg_samples_c)
		tg_col_c3<-c(tg_col_c3,rep(hmcols2[i],length(tg_samples_c)))
		tg_row_c3<-c(tg_row_c3,rep(hmcols2[i],length(tg_genes_c)))
	}
	#library(gplots)
	colors = c(-100:100)/100
	my_palette <- grDevices::colorRampPalette(c("red","white", "blue"))(n = 200)
	colors2 = c(-100:100)/100
	my_palette2 <- grDevices::colorRampPalette(c("white","white", "midnightblue"))(n = 200)
	tg_bbb0<-qubic_input_all[[ii]][tg_genes_all,tg_samples_all]
	h<-heatmap.2(tg_bbb0,Rowv=F,Colv =F,scale="none",main=tg_cancer_keys[ii],
deColors=as.character(tg_col_c3),RowSideColors=as.character(tg_row_c3),
	col=my_palette,breaks=colors,density.info="none",dendrogram="both",trace="none",margin=c(10,10),cexRow=0.8,cexCol=0.8)
	tg_bbb1<-tg_selected_data_list2[[ii]][tg_genes_all,tg_samples_all]
	h<-heatmap.2(tg_bbb1,Rowv=F,Colv =F,scale="row",main=tg_cancer_keys[ii],ColSideColors=as.character(tg_col_c3),RowSideColors=as.character(tg_row_c3),
	col=my_palette,breaks=colors,density.info="none",dendrogram="both",trace="none",margin=c(10,10),cexRow=0.8,cexCol=0.8)
	tg_r_genes<-setdiff(rownames(qubic_input_all[[ii]]),tg_genes_all)
	tg_r_samples<-setdiff(colnames(qubic_input_all[[ii]]),tg_samples_all)
	cor_r_genes<-c()
	cor_r_samples<-c()
	for(i in 1:length(aaa1))
	{
		tg_genes<-tg_selected_BCs[[ii]][[1]][[i]]
		tg_samples<-tg_selected_BCs[[ii]][[2]][[i]]
		cor_r_genes<-cbind(cor_r_genes,apply(cor(t(tg_selected_data_list2[[ii]][tg_r_genes,tg_samples_all]),t(tg_selected_data_list2[[ii]][tg_genes,tg_samples_all])),1,mean))
		cor_r_samples<-cbind(cor_r_samples,apply(cor(tg_selected_data_list2[[ii]][tg_genes_all,tg_r_samples],tg_selected_data_list2[[ii]][tg_genes_all,tg_samples]),1,mean))
	}
	rownames(cor_r_samples)<-tg_r_samples
	rownames(cor_r_genes)<-tg_r_genes
	cor_r_samples_indi<-c()
	tg_col_c4<-c()
	tg_row_c4<-c()
	for(i in 1:nrow(cor_r_samples))
	{
		cor_r_samples_indi<-c(cor_r_samples_indi,which(cor_r_samples[i,]==max(cor_r_samples[i,]))[1])
	}
	tg_samples_all_total<-c()
	for(i in 1:length(aaa1))
	{
		tg_samples<-tg_selected_BCs[[ii]][[2]][[i]]
		tg_samples_c<-setdiff(tg_samples,tg_samples_all_total)
		tg_samples_all_total<-c(tg_samples_all_total,tg_samples_c)
		tg_col_c4<-c(tg_col_c4,rep(hmcols2[i],length(tg_samples_c)))
		tg_samples_all_total<-c(tg_samples_all_total,names(cor_r_samples[which(cor_r_samples_indi==i),i])[order(-cor_r_samples[which(cor_r_samples_indi==i),i])])
		tg_col_c4<-c(tg_col_c4,rep("white",length(names(cor_r_samples[which(cor_r_samples_indi==i),i])[order(-cor_r_samples[which(cor_r_samples_indi==i),i])])))
	}
	cor_r_genes_indi<-c()
	for(i in 1:nrow(cor_r_genes))
	{
		cor_r_genes_indi<-c(cor_r_genes_indi,which(cor_r_genes[i,]==max(cor_r_genes[i,]))[1])
	}
	tg_genes_all_total<-c()
	for(i in 1:length(aaa1))
	{
		tg_genes<-tg_selected_BCs[[ii]][[1]][[i]]
		tg_genes_c<-setdiff(tg_genes,tg_genes_all_total)
		tg_genes_all_total<-c(tg_genes_all_total,tg_genes_c)
		tg_row_c4<-c(tg_row_c4,rep(hmcols2[i],length(tg_genes_c)))
		tg_genes_all_total<-c(tg_genes_all_total,names(cor_r_genes[which(cor_r_genes_indi==i),i])[order(-cor_r_genes[which(cor_r_genes_indi==i),i])])
		tg_row_c4<-c(tg_row_c4,rep("white",length(names(cor_r_genes[which(cor_r_genes_indi==i),i])[order(-cor_r_genes[which(cor_r_genes_indi==i),i])])))
	}
	tg_bbb0<-qubic_input_all[[ii]][tg_genes_all_total,tg_samples_all_total]
	h<-heatmap.2(tg_bbb0,Rowv=F,Colv =F,scale="none",main=tg_cancer_keys[ii],ColSideColors=as.character(tg_col_c4),RowSideColors=as.character(tg_row_c4),
	col=my_palette,breaks=colors,density.info="none",dendrogram="both",trace="none",margin=c(10,10),cexRow=0.8,cexCol=0.8)
	tg_bbb1<-tg_selected_data_list2[[ii]][tg_genes_all_total,tg_samples_all_total]
	h<-heatmap.2(tg_bbb1,Rowv=F,Colv =F,scale="row",main=tg_cancer_keys[ii],ColSideColors=as.character(tg_col_c4),RowSideColors=as.character(tg_row_c4),
	col=my_palette,breaks=colors,density.info="none",dendrogram="both",trace="none",margin=c(10,10),cexRow=0.8,cexCol=0.8)
}
}

compute_plot_BCs<-function(tg_selected_data_list2,c0=1,o0=3000,f0=0.1,BC_nrow_cut0=10){
qubic_results_all<-list()
qubic_input_all<-list()
for(i in 1:length(tg_selected_data_list2))
{
	print(i)
	tg_data_cc00<-tg_selected_data_list2[[i]]
	tg_data_cc00<-tg_data_cc00[which(apply(tg_data_cc00==0,1,sum)/ncol(tg_data_cc00)<0.5),]
	tg_data_cc01<-tg_data_cc00*0
	for(j in 1:nrow(tg_data_cc00))
	{
		tg_data_cc01[j,]<-(tg_data_cc00[j,]<quantile(tg_data_cc00[j,],0.3))
	}
	qubic_input_all[[i]]<-tg_data_cc01
	aaa<-biclust(tg_data_cc01, method=BCQUD(),c = c0, o = o0, f = f0)
	qubic_results_all[[i]]<-aaa
}
names(qubic_results_all)<-tg_cancer_keys
names(qubic_input_all)<-tg_cancer_keys
print("BC_done!")
tg_selected_BCs<-list()
for(ii in 1:length(tg_selected_data_list2))
{
	print(names(qubic_results_all)[ii])
	aaa<-qubic_results_all[[ii]]
	tg_data_c<-qubic_input_all[[ii]]
	tg_selected_BCs_r<-list()
	tg_selected_BCs_c<-list()
	N<-0
	for(i in 1:ncol(attributes(aaa)$RowxNumber))
	{
		tg_r_ids<-which(attributes(aaa)$RowxNumber[,i]==1)
		tg_c_ids<-which(attributes(aaa)$NumberxCol[i,]==1)
		if(length(tg_r_ids)>BC_nrow_cut0)
		{
			N<-N+1
			tg_selected_BCs_r[[N]]<-rownames(tg_data_c)[tg_r_ids]
			tg_selected_BCs_c[[N]]<-colnames(tg_data_c)[tg_c_ids]
		}
	}
	tg_selected_BCs[[ii]]<-list(tg_selected_BCs_r,tg_selected_BCs_c)
}
names(tg_selected_BCs)<-tg_cancer_keys
tg_selected_BCs_plot<-list()
tg_selected_BCs_other_sample_genes<-list()
print("BC_Select_done!\nStart_plotting\n")
for(ii in 1:length(tg_selected_BCs))
{
	tg_selected_BCs_plot_c<-list()
	tg_selected_BCs_other_sample_genes_c<-list()
	print(tg_cancer_keys[ii])
	tg_all_genes<-c()
	for(i in 1:length(tg_selected_BCs[[ii]][[1]]))
	{
		tg_all_genes<-c(tg_all_genes,tg_selected_BCs[[ii]][[1]][[i]])
	}
	tg_all_genes<-unique(tg_all_genes)
	aaa000<-matrix(0,length(tg_selected_BCs[[ii]][[1]]),length(tg_selected_BCs[[ii]][[1]]))
	for(i in 1:length(tg_selected_BCs[[ii]][[1]]))
	{
		for(j in 1:length(tg_selected_BCs[[ii]][[1]]))
		{
			aaa000[i,j]<-1-Compute_Jaccard_mm(qubic_input_all[[ii]][tg_all_genes,tg_selected_BCs[[ii]][[2]][[i]]],qubic_input_all[[ii]][tg_all_genes,tg_selected_BCs[[ii]][[2]][[j]]])
		}
	}
	aaa1<-1:length(tg_selected_BCs[[ii]][[1]])
	if(length(tg_selected_BCs[[ii]][[1]])>2)
	{
		bbb000<-hclust(as.dist(aaa000))
		plot(bbb000)
		aaa1<-bbb000$order
	}
	hmcols2 <- grDevices::colorRampPalette(rev(c("#D73027", "#FC8D59", "#FEE090", "#FFFFBF", "#E0F3F8", "#91BFDB", "#4575B4")))(length(aaa1))
	tg_genes_all<-c()
	tg_samples_all<-c()
	tg_col_c3<-c()
	tg_row_c3<-c()
	tg_selected_BCs_plot_gene_c<-list()
	tg_selected_BCs_plot_sample_c<-list()
	for(i in 1:length(aaa1))
	{
		tg_genes<-tg_selected_BCs[[ii]][[1]][[aaa1[i]]]
		tg_samples<-tg_selected_BCs[[ii]][[2]][[aaa1[i]]]
		tg_samples_c<-setdiff(tg_samples,tg_samples_all)
		tg_genes_c<-setdiff(tg_genes,tg_genes_all)
		if(length(tg_genes_c)>0)
		{
			tg_selected_BCs_plot_gene_c[[i]]<-tg_genes_c
		}
		else
		{
			tg_selected_BCs_plot_gene_c[[i]]<-""
		}
		if(length(tg_samples_c)>0)
		{
			tg_selected_BCs_plot_sample_c[[i]]<-tg_samples_c
		}
		else
		{
			tg_selected_BCs_plot_sample_c[[i]]<-""
		}
		tg_genes_all<-c(tg_genes_all,tg_genes_c)
		tg_samples_all<-c(tg_samples_all,tg_samples_c)
		tg_col_c3<-c(tg_col_c3,rep(hmcols2[i],length(tg_samples_c)))
		tg_row_c3<-c(tg_row_c3,rep(hmcols2[i],length(tg_genes_c)))
	}
	#library(gplots)
	colors = c(-100:100)/100
	my_palette <- grDevices::colorRampPalette(c("red","white", "blue"))(n = 200)
	colors2 = c(-100:100)/100
	my_palette2 <- grDevices::colorRampPalette(c("white","white", "midnightblue"))(n = 200)
	tg_bbb0<-qubic_input_all[[ii]][tg_genes_all,tg_samples_all]
	h<-heatmap.2(tg_bbb0,Rowv=F,Colv =F,scale="none",main=tg_cancer_keys[ii],ColSideColors=as.character(tg_col_c3),RowSideColors=as.character(tg_row_c3),
	col=my_palette,breaks=colors,density.info="none",dendrogram="none",trace="none",margin=c(10,10),cexRow=0.8,cexCol=0.8)
	tg_bbb1<-tg_selected_data_list2[[ii]][tg_genes_all,tg_samples_all]
	h<-heatmap.2(tg_bbb1,Rowv=F,Colv =F,scale="row",main=tg_cancer_keys[ii],ColSideColors=as.character(tg_col_c3),RowSideColors=as.character(tg_row_c3),
	col=my_palette,breaks=colors,density.info="none",dendrogram="none",trace="none",margin=c(10,10),cexRow=0.8,cexCol=0.8)
	tg_r_genes<-setdiff(rownames(qubic_input_all[[ii]]),tg_genes_all)
	tg_r_samples<-setdiff(colnames(qubic_input_all[[ii]]),tg_samples_all)
	cor_r_genes<-c()
	cor_r_samples<-c()
	for(i in 1:length(aaa1))
	{
		tg_genes<-tg_selected_BCs[[ii]][[1]][[i]]
		tg_samples<-tg_selected_BCs[[ii]][[2]][[i]]
		cor_r_genes<-cbind(cor_r_genes,apply(cor(t(tg_selected_data_list2[[ii]][tg_r_genes,tg_samples_all]),t(tg_selected_data_list2[[ii]][tg_genes,tg_samples_all])),1,mean))
		cor_r_samples<-cbind(cor_r_samples,apply(cor(tg_selected_data_list2[[ii]][tg_genes_all,tg_r_samples],tg_selected_data_list2[[ii]][tg_genes_all,tg_samples]),1,mean))
	}
	rownames(cor_r_samples)<-tg_r_samples
	rownames(cor_r_genes)<-tg_r_genes
	cor_r_samples_indi<-c()
	for(i in 1:nrow(cor_r_samples))
	{
		cor_r_samples_indi<-c(cor_r_samples_indi,which(cor_r_samples[i,]==max(cor_r_samples[i,]))[1])
	}
	cor_r_genes_indi<-c()
	for(i in 1:nrow(cor_r_genes))
	{
		cor_r_genes_indi<-c(cor_r_genes_indi,which(cor_r_genes[i,]==max(cor_r_genes[i,]))[1])
	}
	tg_selected_BCs_other_sample_c<-list()
	for(i in 1:length(aaa1))
	{
		if(length(names(cor_r_samples[which(cor_r_samples_indi==i),i])[order(-cor_r_samples[which(cor_r_samples_indi==i),i])])>0)
		{
			tg_selected_BCs_other_sample_c[[i]]<-names(cor_r_samples[which(cor_r_samples_indi==i),i])[order(-cor_r_samples[which(cor_r_samples_indi==i),i])]
		}
		else
		{
			tg_selected_BCs_other_sample_c[[i]]<-""
		}
	}
	tg_selected_BCs_other_gene_c<-list()
	for(i in 1:length(aaa1))
	{
		if(length(names(cor_r_genes[which(cor_r_genes_indi==i),i])[order(-cor_r_genes[which(cor_r_genes_indi==i),i])])>0)
		{
			tg_selected_BCs_other_gene_c[[i]]<-names(cor_r_genes[which(cor_r_genes_indi==i),i])[order(-cor_r_genes[which(cor_r_genes_indi==i),i])]
		}
		else
		{
			tg_selected_BCs_other_gene_c[[i]]<-""
		}
	}
	tg_col_c4<-c()
	tg_row_c4<-c()
	tg_samples_all_total<-c()
	tg_genes_all_total<-c()
	for(i in 1:length(aaa1))
	{
		tg_samples<-tg_selected_BCs[[ii]][[2]][[aaa1[i]]]
		tg_samples_c<-setdiff(tg_samples,tg_samples_all_total)
		tg_samples_all_total<-c(tg_samples_all_total,tg_samples_c)
		tg_col_c4<-c(tg_col_c4,rep(hmcols2[i],length(tg_samples_c)))
		tg_samples_all_total<-c(tg_samples_all_total,names(cor_r_samples[which(cor_r_samples_indi==aaa1[i]),aaa1[i]])[order(-cor_r_samples[which(cor_r_samples_indi==aaa1[i]),aaa1[i]])])
		tg_col_c4<-c(tg_col_c4,rep("white",length(names(cor_r_samples[which(cor_r_samples_indi==aaa1[i]),aaa1[i]])[order(-cor_r_samples[which(cor_r_samples_indi==aaa1[i]),aaa1[i]])])))
	}
	for(i in 1:length(aaa1))
	{
		tg_genes<-tg_selected_BCs[[ii]][[1]][[aaa1[i]]]
		tg_genes_c<-setdiff(tg_genes,tg_genes_all_total)
		tg_genes_all_total<-c(tg_genes_all_total,tg_genes_c)
		tg_row_c4<-c(tg_row_c4,rep(hmcols2[i],length(tg_genes_c)))
		tg_genes_all_total<-c(tg_genes_all_total,names(cor_r_genes[which(cor_r_genes_indi==aaa1[i]),aaa1[i]])[order(-cor_r_genes[which(cor_r_genes_indi==aaa1[i]),aaa1[i]])])
		tg_row_c4<-c(tg_row_c4,rep("white",length(names(cor_r_genes[which(cor_r_genes_indi==aaa1[i]),aaa1[i]])[order(-cor_r_genes[which(cor_r_genes_indi==aaa1[i]),aaa1[i]])])))

	}
	tg_bbb0<-qubic_input_all[[ii]][tg_genes_all_total,tg_samples_all_total]
	h<-heatmap.2(tg_bbb0,Rowv=F,Colv =F,scale="none",main=tg_cancer_keys[ii],ColSideColors=as.character(tg_col_c4),RowSideColors=as.character(tg_row_c4),
	col=my_palette,breaks=colors,density.info="none",dendrogram="none",trace="none",margin=c(10,10),cexRow=0.8,cexCol=0.8)
	tg_bbb1<-tg_selected_data_list2[[ii]][tg_genes_all_total,tg_samples_all_total]
	h<-heatmap.2(tg_bbb1,Rowv=F,Colv =F,scale="row",main=tg_cancer_keys[ii],ColSideColors=as.character(tg_col_c4),RowSideColors=as.character(tg_row_c4),
	col=my_palette,breaks=colors,density.info="none",dendrogram="none",trace="none",margin=c(10,10),cexRow=0.8,cexCol=0.8)
	names(tg_selected_BCs_plot_gene_c)<-aaa1
	names(tg_selected_BCs_plot_sample_c)<-aaa1
	names(tg_selected_BCs_other_gene_c)<-1:length(aaa1)
	names(tg_selected_BCs_other_sample_c)<-1:length(aaa1)
	tg_selected_BCs_plot_c<-list(tg_selected_BCs_plot_gene_c,tg_selected_BCs_plot_sample_c)
	tg_selected_BCs_other_sample_genes_c<-list(tg_selected_BCs_other_gene_c,tg_selected_BCs_other_sample_c)
	tg_selected_BCs_plot[[ii]]<-tg_selected_BCs_plot_c
	tg_selected_BCs_other_sample_genes[[ii]]<-tg_selected_BCs_other_sample_genes_c
}
names(tg_selected_BCs_plot)<-tg_cancer_keys
names(tg_selected_BCs_other_sample_genes)<-tg_cancer_keys
return(list(tg_selected_BCs,tg_selected_BCs_plot,tg_selected_BCs_other_sample_genes))
}

Compute_Jaccard_mm<-function(M0,M1)
{
	ccc<-cbind(apply(M0,1,mean),apply(M1,1,mean))
	ddd<-sum((apply(ccc,1,min)+0.01))/sum((apply(ccc,1,max)+0.01))
	return(ddd)
}

coexpression_marker_selection2<-function(cor_C0,marker_stats1,cor_Cut_list=seq(50,90,by=2)/100)
{
	ff_list_all<-list()
	tg_markers_cor_list_all<-list()
	tg_stat_all<-c()
	for(ii in 1:ncol(marker_stats1))
	{
		print(colnames(marker_stats1)[ii])
		tg_stat_c<-rep(0,length(cor_Cut_list))
		tg_cell<-colnames(marker_stats1)[ii]
		tg_markers<-intersect(rownames(cor_C0),names(which((apply(marker_stats1!=0,1,sum)<=4)&(marker_stats1[,tg_cell]==1))))
		tg_B_markers<-tg_markers
		ff_list_c<-list()
		tg_markers_cor_list_c<-list()
		for(jj in 1:length(cor_Cut_list))
		{
			cor_Cut<-cor_Cut_list[jj]
			cn<-c()
			tg_B_markers_cor_lists<-list()
			N<-0
			for(i in 1:length(tg_B_markers))
			{
				ccc<-names(which(cor_C0[tg_B_markers[i],]>cor_Cut))
				if(length(ccc)>4)
				{
					N<-N+1
					cn<-c(cn,tg_B_markers[i])
					tg_B_markers_cor_lists[[N]]<-ccc
				}
			}
			names(tg_B_markers_cor_lists)<-cn
			ff_all<-c()
			tg_lists<-tg_B_markers_cor_lists
			if(length(tg_lists)>0)
			{
				for(i in 1:length(tg_lists))
				{
					ccc<-extract_data_symbol(marker_stats1,tg_lists[[i]])
					aaa<-unique(rownames(ccc))
					ddd<-c()
					for(j in 1:length(aaa))
					{
						if(sum(rownames(ccc)==aaa[j])==1)
						{
							bbb<-ccc[aaa[j],]
							bbb[which(bbb==0)]<-100
							bbb<-1/bbb*(bbb<=3)
							ddd<-rbind(ddd,bbb)
						}
						else
						{
							bbb<-ccc[which(rownames(ccc)==aaa[j]),]
							bbb[which(bbb==0)]<-100
							bbb<-1/bbb*(bbb<=3)
							ddd<-rbind(ddd,apply(bbb,2,mean))
						}
					}
					rownames(ddd)<-aaa
					fff<-apply(ddd,2,mean)
					ff_all<-rbind(ff_all,fff)
				}
				if(length(ff_all)>0)
				{
					rownames(ff_all)<-names(tg_lists)
				}
			}
			tg_stat_c[jj]<-length(tg_lists)
			if(length(ff_all)==0)
			{
				ff_all<-0
				tg_B_markers_cor_lists<-0
			}
			ff_list_c[[jj]]<-ff_all
			tg_markers_cor_list_c[[jj]]<-tg_B_markers_cor_lists
		}
		names(tg_stat_c)<-cor_Cut_list
		names(ff_list_c)<-cor_Cut_list
		tg_stat_all<-cbind(tg_stat_all,tg_stat_c)
		ff_list_all[[ii]]<-ff_list_c
		tg_markers_cor_list_all[[ii]]<-tg_markers_cor_list_c
	}
	names(tg_markers_cor_list_all)<-colnames(marker_stats1)
	names(ff_list_all)<-colnames(marker_stats1)
	colnames(tg_stat_all)<-colnames(marker_stats1)
	return(list(tg_stat_all,ff_list_all,tg_markers_cor_list_all))
}

plot_cor_gene_lists<-function(data0,tg_list)
{
	N<-0
	for(i in 1:length(tg_list))
	{
		if(sum(tg_list[[i]]=="")==0)
		{
			N<-N+1
		}
	}
	hmcols2 <- grDevices::colorRampPalette(rev(c("#D73027", "#FC8D59", "#FEE090", "#FFFFBF", "#E0F3F8", "#91BFDB", "#4575B4")))(N)
	tg_genes_c<-c()
	cols<-c()
	N<-0
	for(i in 1:length(tg_list))
	{
		if(sum(tg_list[[i]]=="")==0)
		{
			N<-N+1
			tg_genes_c<-c(tg_genes_c,tg_list[[i]])
			cols<-c(cols,rep(hmcols2[N],length(tg_list[[i]])))
		}
	}
	heatmap.2(cor(t(data0[tg_genes_c,])),
	Rowv=F,Colv =F,scale="none",main=paste(tg_cancer_keys[j],names(IM_stable_genes)[i]),
	ColSideColors=as.character(cols),RowSideColors=as.character(cols),
	col=my_palette,breaks=colors,density.info="none",dendrogram="both",
	trace="none",margin=c(10,10),cexRow=0.5,cexCol=1)
}

####################
analyze_QUBIC_genes_stats<-function(BC_im_depletion_gene_stats)
{
	aaa<-list()
	for(i in 1:length(BC_im_depletion_gene_stats))
	{
		aaa_c<-list()
		for(j in 1:length(BC_im_depletion_gene_stats[[i]]))
		{
			cc<-c()
			dd<-apply(BC_im_depletion_gene_stats[[i]][[j]],2,sum)[c(1,3)]
			for(k in 1:nrow(BC_im_depletion_gene_stats[[i]][[j]]))
			{
				ff<-rbind(BC_im_depletion_gene_stats[[i]][[j]][k,c(1,3)],dd)
				pp<--1
					if((ff[1,1]/ff[2,1])>(ff[1,2]/ff[2,2]))
					{
						pp<-fisher.test(ff)$p.value
					}
				cc<-c(cc,pp)
			}
			names(cc)<-rownames(BC_im_depletion_gene_stats[[i]][[j]])
			aaa_c[[j]]<-cc
		}
		aaa[[i]]<-aaa_c
	}
	names(aaa)<-names(BC_im_depletion_gene_stats)
	return(aaa)
}

compute_Jaccard<-function(data_list)
{
	aaa<-matrix(0,length(data_list),length(data_list))
	rownames(aaa)<-names(data_list)
	colnames(aaa)<-names(data_list)
	for(i in 1:length(data_list))
	{
		for(j in 1:length(data_list))
		{
			if(i<j)
			{
				aaa[i,j]<-aaa[j,i]<-length(intersect(data_list[[i]],data_list[[j]]))/length(union(data_list[[i]],data_list[[j]]))
			}
		}
	}
	diag(aaa)<-1
	return(aaa)
}

compute_Intersect<-function(data_list)
{
	aaa<-matrix(0,length(data_list),length(data_list))
	rownames(aaa)<-names(data_list)
	colnames(aaa)<-names(data_list)
	for(i in 1:length(data_list))
	{
		for(j in 1:length(data_list))
		{
			if(i<j)
			{
				aaa[i,j]<-aaa[j,i]<-length(intersect(data_list[[i]],data_list[[j]]))
			}
		}
	}
	diag(aaa)<-0
	return(aaa)
}

norm_transform<-function(data0)
{
	data1<-data0
	for(i in 1:nrow(data0))
	{
		data1[i,]<-pnorm(data0[i,],mean(data0[i,]),sd(data0[i,]))
	}
	return(data1)
}

test_cell_list<-function(BC_gene_list,tg_cell_list,all_genes)
{
	cc_all<-list()
	for(i in 1:length(BC_gene_list))
	{
		cc<-c()
		bbb<-BC_gene_list[[i]]
		cc<-c()
		for(j in 1:length(tg_cell_list))
		{
			cc<-rbind(cc,c(length(intersect(bbb,tg_cell_list[[j]])),length(bbb),length(intersect(all_genes,tg_cell_list[[j]]))))
			#print(setdiff(bbb,all_genes))
		}
		rownames(cc)<-names(tg_cell_list)
		cc_all[[i]]<-cc
	}
	return(cc_all)
}

#########################
coexpression_marker_selection<-function(tg_markers,cor_Cut=0.8,cor_C0)
{
	tg_B_markers<-tg_markers
	cn<-c()
tg_B_markers_cor_lists<-list()
N<-0
for(i in 1:length(tg_B_markers))
{
	ccc<-names(which(cor_C0[tg_B_markers[[i]],]>cor_Cut))
	if(length(ccc)>4)
	{
		N<-N+1
		cn<-c(cn,tg_B_markers[[i]])
		tg_B_markers_cor_lists[[N]]<-ccc
	}
}
names(tg_B_markers_cor_lists)<-cn

ff_all<-c()
tg_lists<-tg_B_markers_cor_lists
for(i in 1:length(tg_lists))
{
	ccc<-extract_data_symbol(marker_stats1,tg_lists[[i]])
	aaa<-unique(rownames(ccc))
	ddd<-c()
	for(j in 1:length(aaa))
	{
		if(sum(rownames(ccc)==aaa[j])==1)
		{
			bbb<-ccc[aaa[j],]
			bbb[which(bbb==0)]<-100
			bbb<-1/bbb*(bbb<=3)
			ddd<-rbind(ddd,bbb)
		}
		else
		{
			bbb<-ccc[which(rownames(ccc)==aaa[j]),]
			bbb[which(bbb==0)]<-100
			bbb<-1/bbb*(bbb<=3)
			ddd<-rbind(ddd,apply(bbb,2,mean))
		}
	}
	rownames(ddd)<-aaa
	fff<-apply(ddd,2,mean)
	ff_all<-rbind(ff_all,fff)
}
rownames(ff_all)<-names(tg_lists)
if(nrow(ff_all)==1)
{
	ff_all<-rbind(ff_all,ff_all)
}
if(nrow(ff_all)>1)
{
#library(gplots)
colors = c(0:100)/100
my_palette <- grDevices::colorRampPalette(c("white", "midnightblue"))(n =100)

heatmap.2(ff_all,Rowv=F,Colv =F,scale="none",main="",
	col=my_palette,breaks=colors,density.info="none",dendrogram="both",
	trace="none",margin=c(10,10),cexRow=0.6,cexCol=1)
}
	return(list(ff_all,tg_B_markers_cor_lists))
}


context("subset")

A = matrix(1:10, ncol=2)
b = 1:5
C = matrix(rnorm(20), dimnames=list(letters[1:5],LETTERS[1:4]), nrow=5, ncol=4)
DF = as.data.frame(lapply(as.data.frame(A), as.factor))

test_that("matrix, vector, data.frame", {
    expect_equal(subset(A, c(1,2), along=1), A[1:2,])
    expect_equal(subset(A, c(1,2), along=2), A)

    expect_equal(subset(b, 1:5 %in% c(2,4,5), along=1), subset(A[,1], c(2,4,5)))
    expect_equal(subset(b, 1, along=1), subset(b, 1, along=2))
    expect_error(subset(as.array(b), 1, along=2))

    expect_equal(subset(DF, c(1,2), along=1), DF[1:2,])
    expect_equal(subset(DF, c(1,2), along=2), DF)
})

test_that("index, name, logical subsetting", {
    expect_equal(C[,2:3], subset(C, 2:3, along=2, drop=TRUE))
    expect_equal(C[,2:3], subset(C, 2:3, along=2, drop=FALSE))
    expect_equal(C[,2:3], subset(C, LETTERS[2:3], along=2, drop=TRUE))
    expect_equal(C[,2:3], subset(C, LETTERS[2:3], along=2, drop=FALSE))
    expect_equal(C[,2:3], subset(C, c(FALSE, TRUE, TRUE, FALSE), drop=TRUE))
    expect_equal(C[,2:3], subset(C, c(FALSE, TRUE, TRUE, FALSE), drop=FALSE))

    expect_equal(C[,3,drop=FALSE], subset(C, 3, along=2, drop=FALSE))
    expect_equal(C[,3,drop=FALSE], subset(C, LETTERS[3], along=2, drop=FALSE))
    expect_equal(C[,3,drop=FALSE], subset(C, c(FALSE, FALSE, TRUE, FALSE), along=2, drop=FALSE))
})

test_that("subset with NA", {
    expect_error(subset(1:5, index=c(rep(FALSE, 4), NA)))
})


#' Nucleotide at the third position of the codon
#'
#' Calculates the nucleotide frequency at the third position of the codon
#' @param x a list of KZsqns objects.
#' @return a matrix of nucleotide composition at the third position
#' @export

n3_freq <- function(x){
  if(!is.list(x)){
    cat("Just one perhap very long sequence?\n")
    x = list(x)
  }

  ans = matrix(0, length(x), 4)
  for(i in 1:length(x)){
    if(class(x[[i]])!='KZsqns') warning("KZsqns objects are expected")
    freq_table = table(c('A', 'C', 'G', 'T', strsplit(paste0(x[[i]], collapse = ''),'')[[1]][c(F, F, T)]))
    ans[i,] = (freq_table-rep(1,4))/length(x[[i]])
  }

  colnames(ans) <- c('A3', 'C3', 'G3', 'T3')
  rownames(ans) <- paste0('s_', 1:length(x), sep='')
  return(ans)
}


# Read in World Ocean Atlas data
nms <- c('lat', 'lon', 'm0', 'm5', 'm10', 'm15', 'm20', 'm25', 'm30', 'm35', 'm40', 'm45', 'm50', 'm55', 'm60', 'm65', 'm70', 'm75', 'm80', 'm85', 'm90', 'm95', 'm100', 'm125', 'm150', 'm175', 'm200', 'm225', 'm250', 'm275', 'm300', 'm325', 'm350', 'm375', 'm400', 'm425', 'm450', 'm475', 'm500', 'm550', 'm600', 'm650', 'm700', 'm750', 'm800', 'm850', 'm900', 'm950', 'm1000', 'm1050', 'm1100', 'm1150', 'm1200', 'm1250', 'm1300', 'm1350', 'm1400', 'm1450', 'm1500', 'm1550', 'm1600', 'm1650', 'm1700', 'm1750', 'm1800', 'm1850', 'm1900', 'm1950', 'm2000', 'm2100', 'm2200', 'm2300', 'm2400', 'm2500', 'm2600', 'm2700', 'm2800', 'm2900', 'm3000', 'm3100', 'm3200', 'm3300', 'm3400', 'm3500', 'm3600', 'm3700', 'm3800', 'm3900', 'm4000', 'm4100', 'm4200', 'm4300', 'm4400', 'm4500', 'm4600', 'm4700', 'm4800', 'm4900', 'm5000', 'm5100', 'm5200', 'm5300', 'm5400', 'm5500')
dps <- c(0, 5, 10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 85, 90, 95, 100, 125, 150, 175, 200, 225, 250, 275, 300, 325, 350, 375, 400, 425, 450, 475, 500, 550, 600, 650, 700, 750, 800, 850, 900, 950, 1000, 1050, 1100, 1150, 1200, 1250, 1300, 1350, 1400, 1450, 1500, 1550, 1600, 1650, 1700, 1750, 1800, 1850, 1900, 1950, 2000, 2100, 2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 3000, 3100, 3200, 3300, 3400, 3500, 3600, 3700, 3800, 3900, 4000, 4100, 4200, 4300, 4400, 4500, 4600, 4700, 4800, 4900, 5000, 5100, 5200, 5300, 5400, 5500) # the depths associated with each column (after lat/lon)

woa <- read.csv('data_dl/woa/woa13_decav_t00an01v2.csv', skip=2, row.names=NULL, header=FALSE, col.names=nms) # use col.names to force all columns to be read (file doesn't have trailing ,s for blank columns)

# Initial plot (slow)

col = rgb(0,0,0,0.01)
plot(dps, woa[1,3:ncol(woa)], type='l', ylab='temperature', xlab='depth (m)', ylim=c(-2,30), col=col, xlim=c(0,1000))
for(i in 2:nrow(woa)){
	lines(dps, woa[i,3:ncol(woa)], col=col)
}

###########################################
# average temperature within lat bands
###########################################
woalat <- aggregate(list(m0=woa$m0, m5=woa$m5, m10=woa$m10, m15=woa$m15, m20=woa$m20, m25=woa$m25, m30=woa$m30, m35=woa$m35, m40=woa$m40, m45=woa$m45, m50=woa$m50, m55=woa$m55, m60=woa$m60, m65=woa$m65, m70=woa$m70, m75=woa$m75, m80=woa$m80, m85=woa$m85, m90=woa$m90, m95=woa$m95, m100=woa$m100, m125=woa$m125, m150=woa$m150, m175=woa$m175, m200=woa$m200, m225=woa$m225, m250=woa$m250, m275=woa$m275, m300=woa$m300, m325=woa$m325, m350=woa$m350, m375=woa$m375, m400=woa$m400, m425=woa$m425, m450=woa$m450, m475=woa$m475, m500=woa$m500, m550=woa$m550, m600=woa$m600, m650=woa$m650, m700=woa$m700, m750=woa$m750, m800=woa$m800, m850=woa$m850, m900=woa$m900, m950=woa$m950, m1000=woa$m1000, m1050=woa$m1050, m1100=woa$m1100, m1150=woa$m1150, m1200=woa$m1200, m1250=woa$m1250, m1300=woa$m1300, m1350=woa$m1350, m1400=woa$m1400, m1450=woa$m1450, m1500=woa$m1500, m1550=woa$m1550, m1600=woa$m1600, m1650=woa$m1650, m1700=woa$m1700, m1750=woa$m1750, m1800=woa$m1800, m1850=woa$m1850, m1900=woa$m1900, m1950=woa$m1950, m2000=woa$m2000, m2100=woa$m2100, m2200=woa$m2200, m2300=woa$m2300, m2400=woa$m2400, m2500=woa$m2500, m2600=woa$m2600, m2700=woa$m2700, m2800=woa$m2800, m2900=woa$m2900, m3000=woa$m3000, m3100=woa$m3100, m3200=woa$m3200, m3300=woa$m3300, m3400=woa$m3400, m3500=woa$m3500, m3600=woa$m3600, m3700=woa$m3700, m3800=woa$m3800, m3900=woa$m3900, m4000=woa$m4000, m4100=woa$m4100, m4200=woa$m4200, m4300=woa$m4300, m4400=woa$m4400, m4500=woa$m4500, m4600=woa$m4600, m4700=woa$m4700, m4800=woa$m4800, m4900=woa$m4900, m5000=woa$m5000, m5100=woa$m5100, m5200=woa$m5200, m5300=woa$m5300, m5400=woa$m5400, m5500=woa$m5500), by=list(lat=woa$lat), FUN=mean, na.rm=TRUE)

# plot lat averages, color by lat
#col = rgb(0,0,0,0.1)
cols <- rainbow(nrow(woalat))
plot(dps, woalat[1,2:ncol(woalat)], type='l', ylab='temperature', xlab='depth (m)', ylim=c(-2,30), col=cols[1], xlim=c(0,1000))
for(i in 2:nrow(woalat)){
	lines(dps, woalat[i,2:ncol(woalat)], col=cols[i])
}

abline(v=100, lty=2)

# plot SST vs. lat
plot(woalat$lat, woalat$m0, type='l')
abline(v=5)

# plot all profiles at 0.5°
inds <- which(woa$lat==0.5)
cols <- rainbow(length(inds))
plot(dps, woa[inds[1],3:ncol(woa)], type='l', ylab='temperature', xlab='depth (m)', ylim=c(-2,30), col=cols[1], xlim=c(0,1000))
for(i in 2:length(inds)){
	lines(dps, woa[inds[i],3:ncol(woa)], col=cols[i])
}

# plot all profiles where depth < 1000
inds <- which(is.na(woa$m1050))
col = rgb(0,0,0,0.1)
plot(dps, woa[inds[1],3:ncol(woa)], type='l', ylab='temperature', xlab='depth (m)', ylim=c(-2,30), col=col, xlim=c(0,1000))
for(i in 2:length(inds)){
	lines(dps, woa[inds[i],3:ncol(woa)], col=col)
}

##################
# Average all
##################

woaave <- apply(woa[,3:ncol(woa)], MARGIN=2, FUN=mean, na.rm=TRUE)

plot(dps, woaave, type='l')

plot(dps, woaave, type='l', xlim=c(0,300))

woaave['m50'] - woaave['m0']
woaave['m300'] - woaave['m0']

#######################
# Average change in temperature
#######################

mean(woa$m50 - woa$m0, na.rm=TRUE)
mean(woa$m300 - woa$m0, na.rm=TRUE)
mean(woa$m1000 - woa$m0, na.rm=TRUE)


# John Alan McDonald 2015-12-11
#-------------------------------------------------------------------------------
setwd('e:/workplace/tu-projects/taiga')
source('src/scripts/r/functions.r')
#-------------------------------------------------------------------------------
for (n in (1024*c(32,64,128,256,512,1024))) {
 for (nt in c(128,256,512)) {
  for (pkg in c('spikes','pyramid')) {
  for (mc in c(15,31,63,127)) {
  for (ns in c(
    #'bias-weight-majority-vote-probability',
    #'bias-weight-positive-fraction-probability',
    #'bias-majority-vote-probability',
    #'bias-positive-fraction-probability'
    #,
    #'majority-vote-probability'
    # ,
    'positive-fraction-probability'
    , 'weight-majority-vote-probability'
    , 'weight-positive-fraction-probability'
      )) {
   predictions <- synthetic.prediction.data(
     package=pkg,namespace=ns,mincount=mc,ndata=n,nterms=nt)
   if (! is.null(predictions)) {
    synthetic.prediction.plots(package=pkg, namespace=ns, mincount=mc, ndata=n,
       nterms=nt, prefix='all', data=predictions)
# synthetic.prediction.plots(package=pkg, namespace=ns,mincount=mc,
#   prefix='train', data=predictions[predictions$trainTest=='train',])
# synthetic.prediction.plots(package=pkg,namespace=ns,mincount=mc,
#   prefix='test', data=predictions[predictions$trainTest=='test',])
   } } } } } }
#-------------------------------------------------------------------------------


# Best ARIMA model for drift detection
# Rest is taken over from analysis v23

source('./../../gwloggeR/R/fourier.R')

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Meta data
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]

  data.table::setkey(df, TIMESTAMP_UTC)
  data.table::setattr(df, 'logger.name', logger.name)

  df
}

# from analysis 04
compare <- function(df1, df2) {
  if (nrow(df1) == 0L || nrow(df2) == 0L) return(data.table::data.table())

  diff.df <- df1[J(df2), .('PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE, TIMESTAMP_UTC)][!is.na(PRESSURE_DIFF), ]

  data.table::setkey(diff.df, TIMESTAMP_UTC)

  diff.df
}

ref.compare <- function(logger.name) {
  compare(read.baro(logger.name), read.baro('KNMI_20200312_hourly'))
}

coef.pvals <- function(M) {
  (1-pnorm(abs(M$coef)/sqrt(diag(M$var.coef))))*2
}

plt.comp <- function(TIMESTAMP_UTC, Y, M = NULL, significant = NULL, front_layer = NULL,
                     xlim = range(TIMESTAMP_UTC), ylim = quantile(Y, c(0.005, 0.995))) {

  force(TIMESTAMP_UTC); force(Y); force(M)
  force(ylim); force(xlim)

  p <- ggplot2::ggplot(mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = Y)) +
    front_layer +
    ggplot2::geom_line(col = 'red', alpha = 0.9)

  if (!is.null(M))
    p <- p + ggplot2::geom_line(mapping = ggplot2::aes(y = fitted(M)), col = 'black', size = 1.5)

  if (!is.null(significant)) {
    p <- p + ggplot2::annotate(
      "label", x = as.POSIXct(-Inf, origin = '1970-01-01'), y = Inf,
      size = 4, col = if (significant) 'green' else 'red',
      hjust = 0, vjust = 1, fill = 'grey', label.size = NA,
      label = if (significant) 'SIGNIFINCANT' else 'NOT SIGNIFICANT'
    )
  }

  if (!is.null(M[['btrend']]) && coef.pvals(M)['btrend'] < 0.0001)
    p <- p + ggplot2::geom_vline(xintercept = TIMESTAMP_UTC[which.max(M$btrend > 0)],
                                 col = 'blue', linetype = 'dotted', size = 1.2)

  p <- p +
    ggplot2::coord_cartesian(ylim = ylim, xlim = xlim) +
    ggplot2::ylab('PRESSURE_DIFF') +
    ggplot2::theme_light() +
    ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5),
                   axis.title.y = ggplot2::element_blank(),
                   axis.title.x = ggplot2::element_blank())

  p
}

report <- function(logger.name) {
  require(forecast)

  environment(plt.comp) <- environment() # fitted(Arima) then can find the source data.

  print(logger.name)

  df.diff <- ref.compare(logger.name)

  if (nrow(df.diff) < 10L) return(invisible(FALSE))

  M <- arima(x = df.diff$PRESSURE_DIFF, order = c(0, 0, 0))
  df.diff[, M_pred := fitted(M)]

  M.AR <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0))
  df.diff[, M.AR.pred := fitted(M.AR)]

  trend <- c(0, cumsum(diff(as.numeric(df.diff$TIMESTAMP_UTC))/3600/24))
  breakpoints <- seq(from = 1, to = nrow(df.diff) - 1, by = 10)

  M.ARD <- M.AR
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .M <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = btrend)
    .M[['btrend']] <- btrend
    if (logLik(.M) > logLik(M.ARD)) M.ARD <- .M
  }
  df.diff[, M.ARD.pred := fitted(M.ARD)]

  sbasis <- fbasis(timestamps = df.diff$TIMESTAMP_UTC, frequencies = 1/(365.25*3600*24))

  M.ARS <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = sbasis)

  M.ARDS <- M.ARS
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .M <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = cbind(sbasis, btrend))
    .M[['btrend']] <- btrend
    if (logLik(.M) > logLik(M.ARDS)) M.ARDS <- .M
  }

  M.AUTO <- forecast::auto.arima(df.diff$PRESSURE_DIFF, trace = TRUE,
                                 stationary = TRUE, ic = 'aicc',
                                 xreg = data.matrix(cbind(sbasis, 'btrend' = M.ARDS[['btrend']])))
  M.AUTO[['btrend']] <- M.ARDS[['btrend']]

  M.AUTOF <- forecast::auto.arima(df.diff$PRESSURE_DIFF, trace = TRUE,
                                  stationary = FALSE, ic = 'aicc',
                                  xreg = data.matrix(cbind(sbasis, 'btrend' = M.ARDS[['btrend']])))
  M.AUTOF[['btrend']] <- M.ARDS[['btrend']]

  p.comp <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF)

  p.M <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M)

  p.M.AR <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.AR)

  p.M.ARS <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARS)

  p.M.ARD <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARD)

  p.M.ARDS <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARDS)

  p.M.AUTO <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.AUTO)

  p.M.AUTOF <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.AUTOF)

  # File export ----------------------------------------------------------------

  filename <- sprintf('./drifts/analysis_26/%s.png', tools::file_path_sans_ext(basename(logger.name)))
  dir.create(dirname(filename), showWarnings = FALSE, recursive = TRUE)

  layout_matrix <- rbind(c(1, 2),
                         c(3, 4),
                         c(5, 6))

  grob.title <- grid::textGrob(sprintf('%s (#%s differences with KNMI data from %s to %s) -> %s | %s',
                                       basename(logger.name), nrow(df.diff),
                                       min(df.diff$TIMESTAMP_UTC), max(df.diff$TIMESTAMP_UTC),
                                       forecast:::arima.string(M.AUTO), forecast:::arima.string(M.AUTOF)),
                               x = 0.05, hjust = 0)

  p.empty <- ggplot2::ggplot() + ggplot2::theme_void()

  local({
    png(filename, width = 1280, height = 720)
    on.exit(dev.off())
    gridExtra::grid.arrange(p.M.AUTO, p.M.AUTOF,
                            p.M.AR, p.M.ARS,
                            p.M.ARD, p.M.ARDS,
                            layout_matrix = layout_matrix,
                            top = grob.title)
  })

  invisible(TRUE)

}

# report('BAOL009X_78680')
invisible(lapply(logger.names, report))


#' tidyfun
#'
#' `tidyfun` makes data wrangling and exploratory analysis for functional data
#' in `R` easier.\cr\cr
#' `tidyfun` provides:
#'
#'   - new data types for representing functional data: [tfd()] & [tfb()]
#'   - arithmetic operators ([Ops.tf()]),
#'   - descriptive statistics: e.g. [mean.tf()], [median.tf()]
#'   - and graphics functions for such data: [plot.tf()], [geom_spaghetti()], [gglasagna()]
#'   - functions to do smoothing ([tf_smooth.tfd()]), differentiation and integration ([tf_derive.tfd()])
#' - `tidyverse`-verbs for handling functional data inside data frames: [tf_gather()] etc.
#' \cr\cr
#' \cr
#' Also see `vignette("Introducing tidyfun", "tidyfun")` for a brief introduction.
#'
#' @name tidyfun
#' @docType package
NULL


library(arules)
setwd("/root/Desktop/mercy520/arules")
SocMed <- read.transactions(file="2016_Racial_Profiling_Dataset_Arrests.csv", sep=",")
#list.files()
dim(SocMed)


fn.cd38 = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_lowDA_cd38_ge_sig_score_subjects.txt")
fn.pb = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_PB.DC_SLEDAI_corr_score.txt")

df.cd38 = fread(fn.cd38)
df.pb = fread(fn.pb)

PG.group.names = c("SLE patients with plasmablast\nsignature during flare", "Other SLE patients")

df = inner_join(df.cd38, df.pb, by="SUBJECT") %>%
  dplyr::filter(!is.na(PG)) %>%
  mutate(PG.group = ifelse(PG %in% 2:4, PG.group.names[1], PG.group.names[2])) %>%
  mutate(PG2 = ifelse(PG %in% 2:3, "2/3", ifelse(PG %in% 4, "4", "other"))) %>%
  mutate(PG = factor(PG), PG2 = factor(PG2), PG.group = factor(PG.group, levels=PG.group.names))

df.cc = df %>% split(.$PG.group) %>%
  map(~cor.test(.$CD38_score_mean, .$PB_SLEDAI_corr_score, method="pearson")) %>%
  map_df(~data.frame(label=sprintf("r = %.3f\np = %.2g",.$estimate,.$p.value),
                     x=-Inf, y=Inf)) %>%
  mutate(PG.group = levels(df$PG.group) %>% factor())

df.cc2 = df %>% split(.$PG2) %>%
  map(~cor.test(.$CD38_score_mean, .$PB_SLEDAI_corr_score, method="pearson")) %>%
  map_df(~data.frame(label=sprintf("r = %.3f\np = %.2g",.$estimate,.$p.value),
                     x=-Inf, y=Inf)) %>%
  mutate(PG2 = levels(df$PG2) %>% factor())

PG2.clr = c("steelblue", "grey80", "black")

p = ggplot(df, aes(CD38_score_mean, PB_SLEDAI_corr_score)) +
  geom_point(aes(fill=PG2), size=3, shape=21, col="white") +
  scale_fill_manual(values = PG2.clr, guide="none") +
  facet_wrap(~PG.group, nrow=1) +
  geom_text(data=df.cc, aes(label=label), x=-Inf, y=Inf, vjust=1.5, hjust=-0.1, col="black") +
  geom_hline(yintercept=0) + geom_vline(xintercept=0) + theme_bw() + theme(legend.key = element_blank()) +
  xlab("Mean Baseline score at low DA") +
  ylab("DA-associated\nchange in plasmablasts") +
  theme_bw() +
  theme(strip.background = element_blank(),
        strip.text.x = element_text(size=12),
        panel.spacing = unit(10,"mm") )
p

fn.fig = file.path(PROJECT_DIR, "figure_generation", "SLE_PB.DC.corr_vs_CD38.mean.score_2groups")
ggsave(paste0(fn.fig,".png"), w=6,h=3)
ggsave(paste0(fn.fig,'.pdf'), w=5,h=3)


#' @export
#'
#' @title plot.eoar - Plot rate estimates from an \code{eoar} model
#'
#' @description Plot method for \code{eoar} objects.
#'
#' @param obj An object of class "eoar".  Usually output by the
#' routine \code{eoar}.
#'
#' @param xvar The x-axis variable to plot.  Points in the plot
#' are carcasses/g/numTurbines ~ xvar and line in plot is lambda ~ xvar.
#' xvar must be in the model you want and in the data frame contained
#' in the model object. All other covariates in the model are held
#' constant at their mean value.
#'
#' @param main  The main title of the plot
#'
#' @author Trent McDonald
#'
#' @seealso \code{\link{plot.Mest}}
#'
#'
plot.eoar <- function(obj, xvar=NULL, main=NULL){

  if(is.null(xvar)){
    # xaxis is first variable after intercept in design mat
    xvar <- attr(obj$terms, "term.labels")[1]
  }

  df <- obj$data
  df$g <- df$gFac.a / (df$gFac.a+df$gFac.b)

  xmat <- model.matrix(obj)[,-1, drop=FALSE]
  xmeans <- colMeans(xmat)
  xmeans <- xmeans[names(xmeans)!=xvar]
  nms <- names(xmeans)

  xvar.seq <- seq(min(df[,xvar]), max(df[,xvar]), length=70)
  xmeans <- data.frame(matrix(xmeans, length(xvar.seq),
                              length(xmeans),byrow=T),
                       xvar.seq )
  names(xmeans) <- c(nms, xvar)

  preds <- predict(obj, newdata=xmeans)

  plot(df[,xvar],df$carcasses/df$g/exp(df$logOffset),
       pch=16, col="black", xlab=xvar, ylab="Lambda/turbine/year",
       main=main)
  lines(xvar.seq, preds, col="red",lwd=2)

  data.frame(xmeans, predicted=preds)

}


a=c(1,2,3,5,6,19)
b=c("a","b","c","d","e")
c=c(TRUE,FALSE)
mat=matrix(c(2,3,5,1),2,2)
mat
list1=list(a,b,c,mat)
list1
list1[c(1,2)]
list1[[3]]
list1[[2]][3]="aditi"
list1[2]
list1

elist=list(eno=c(1,2,3,4,5),ename=c("aditi","ankita","prerna","roshni","darshika"))
elist["eno"]
elist["ename"]
elist[c("eno","ename")]
elist$eno
str(elist)

mon1=c("jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec")
mon1
mat2=matrix(c(3,4,6,3,6,7,3,12,13,9,5,64),3,3)
mat2
list2=list(mon1,mat2)
list2
list3=list(char=c("a","b","c","d"),num=c(1,2,3,4))
list3
list2=list(mon1,mat2,list3)
list2

names(list2)=c("months","matrix","another_list")
list2
list2[4]="v"
list2
list2[4]=NULL
list2
list2[3]="a"
list2
list4=c(list2,list3)
list4


library(dplyr)
library(ggplot2)

## read.table('results_unnormalized.txt', col.names = c('network', 'phase', 'p', 'value')) %>%
pdf('results.pdf', 10, 7)
read.table('results1.txt', col.names = c('sample', 'variant', 'phase', 'p', 'value', 'value_smooth')) %>%
    filter(variant != 'i') %>%
    ggplot(aes(p, value_smooth, color = phase)) +
    facet_grid(variant~sample) +
    geom_line() +
    labs(x = 'Expected remaining nodes', y = 'Relative size of largest cluster') +
    theme(legend.position = 'bottom')
dev.off()

read.table('results2.txt', col.names = c('sample', 'variant', 'phase', 'p', 'value', 'value_smooth')) %>%
    ## filter(phase == 'optimized') %>%
    ggplot(aes(p, value, color = phase)) +
    facet_grid(variant~sample) +
    geom_line() +
    labs(x = 'Expected remaining nodes', y = 'Relative size of largest cluster')

pdf('training.pdf', 10, 7)
read.table('training1.txt', col.names = c('sample', 'variant', 'phase', 'p', 'value', 'value_smooth')) %>%
    filter(variant != 'i') %>%
    ggplot(aes(p, value_smooth, color = phase)) +
    facet_grid(variant~sample) +
    geom_line() +
    labs(x = 'Expected remaining nodes', y = 'Relative size of largest cluster') +
    theme(legend.position = 'bottom')
dev.off()


#' @title get_day
#' @description This function provides the number of days in each month, given a year and month. This script was originally part of the date.picker() function, but was separated since it might be useful on its own
#' @note It accounts for leapyears from 1904-2096.  Leapyears are not simply every 4 years - please look it up should this script live long enough to need modification
#' @param \code{the.year} YYYY
#' @param \code{the.month} MM
#' @author Mike McMahon, \email{Mike.McMahon@@dfo-mpo.gc.ca}
#' @family date functions
#' @export
get_day<-function(the.year,the.month){
  leapyears = seq(1904, 2096, 4 )
  if (the.month %in% c(1,3,5,7,8,10,12)){
    the.days = c(1:31)
  }  else if (the.month %in% c(4,6,9,11)){
    the.days = c(1:30)
  } else if (the.year %in% leapyears){
    the.days = c(1:29)
  }else{
    the.days = c(1:28)
  }
  return(the.days)
}


## unit tests - colprods

context("Checking colprods functions")

test_that("check all functions give identical results", {

    x = matrix(1:9,3,3)

    colprods_loop_result   = colprods_for_loop(x)
    colprods_apply_result  = colprods_apply(x)
    colprods_sapply_result = colprods_sapply(x)
    colprods_rcpp_result   = colprods_rcpp(x)
    colprods_rcpp2_result  = colprods_rcpp_rowwise(x)
    colprods_arma_result   = as.numeric(colprods_arma(x))

    ans = c(6, 120, 504)
    expect_equal( colprods_loop_result, ans )
    expect_equal( colprods_apply_result, ans )
    expect_equal( colprods_sapply_result, ans )
    expect_equal( colprods_rcpp_result, ans )
    expect_equal( colprods_rcpp_result, ans )
    expect_equal( colprods_arma_result, ans )

})


install.packages('rmarkdown', dependencies = TRUE);
install.packages('ggplot2', dependencies = TRUE);
install.packages('Hmisc', dependencies = TRUE);
install.packages('icd', dependencies = TRUE);
install.packages('xts', dependencies = TRUE);
install.packages('tscount', dependencies = TRUE);
install.packages('Hmisc', dependencies = TRUE);
install.packages('devtools', dependencies = TRUE);
library(devtools)
install_github('sinhrks/ggfortify')
install.packages('forecast', dependencies = TRUE);
cat("\014")