#----------------------------------------------------------------------------- #README #----------------------------------------------------------------------------- #The purpose of this script is to conduct a marker association analysis with #the Weaver data set which includes VSH. #input: #Allele_freq_consensus.rds #pop_factor.rds #output: # # #----------------------------------------------------------------------------- #Libraries and options #----------------------------------------------------------------------------- #libraries pkgs <- c("tidyverse", "magrittr", "data.table", "adegenet", "RColorBrewer", "GenomicRanges", "SNPRelate", "ape", "Rtsne", "plotly", "dbscan", "adegenet", "MASS", "igraph", "gplots", "ggtree") invisible(lapply(pkgs, library, character.only = T, lib.loc = "/Users/arian.avalos/Library/R/3.6/library")) rm(pkgs); gc() #options options(stringsAsFactors = F, scipen = 999) set.seed(12345) #----------------------------------------------------------------------------- #Analyze the data #----------------------------------------------------------------------------- #read in the data gahb.seq <- snpgdsOpen("../../2017_gahb_aggression_gwas/out/gwas_individual/worker_mvcall.phasedimputed.snp_subset.gds") stock.seq <- snpgdsOpen("../data/hilo.gds") stock.geno <- readRDS("../data/stock.geno_wHilo.rds") stock.pop <- readRDS("../data/stock.pop_factor_wHilo.rds") #create a color vector stock.col <- setNames(c("orange", "black", "purple", "red", "green", "brown", "blue", "darkturquoise"), levels(stock.pop)) #filter by allele frequency #create the filter stock.idx <- stock.geno %>% colMeans %>% {. >= 0.95 | . <= 0.05} %>% `!` (.) #apply the filter stock.sub <- stock.geno[, stock.idx] #create the PCA stock.pca <- prcomp(stock.sub, center = T, scale. = F) #visualize the PCA #2D #quartz(width = 11, height = 11) #X11(width = 11, height = 11) plot(stock.pca$x[, 1], stock.pca$x[, 2], pch = 1, lwd = 3, col = stock.col[stock.pop], bty = "n", tck = 0.01, xlab = "PC1", ylab = "PC2", xlim = quantile(stock.pca$x[, 1], c(0, 1)) + c(- 10, 10), ylim = quantile(stock.pca$x[, 2], c(0, 1)) + c(- 10, 10)) abline(h = 0, v = 0, col = "grey80", lty = 3, lwd = 2) legend(x = "topright", legend = names(stock.col), bty = "n", col = stock.col, pch = 1, pt.lwd = 2, cex = 0.5) #3D stock.pca.df <- data.frame(stock = stock.pop, stock.pca$x[, 1:3]) p <- plot_ly(stock.pca.df, x = ~PC1, y = ~PC2, z = ~PC3, color = ~stock, colors = col2hex(stock.col), text = ~stock) %>% add_markers() %>% layout(scene = list(xaxis = list(title = 'PC1'), yaxis = list(title = 'PC2'), zaxis = list(title = 'PC3'))) p #----------------------------------------------------------------------------- #Conduct the cluster analysis #----------------------------------------------------------------------------- #optimal k via BIC stock.k <- lapply(1:10, function(i) { tmp = kmeans(stock.pca$x, iter.max = 5000, centers = i, nstart = 1000) out = (length(tmp$cluster) * log(tmp$tot.withinss / length(tmp$cluster))) + (nrow(tmp$centers) * log(length(tmp$cluster))) return(out) }) %>% unlist #NOTE: optimal k = 3 #clusterfing vector stock.clus <- kmeans(x = stock.pca$x, centers = 3, iter.max = 5000, nstart = 1000) #visualize #create a color vector stock.clus.col <- setNames(brewer.pal(nrow(stock.clus$centers), "Dark2"), 1:nrow(stock.clus$centers)) #table plot #create the table vector stock.clus.tab <- table(stock.pop, stock.clus$cluster) #create the symbol size vector stock.clus.tab.sq <- stock.clus.tab %>% {sqrt(.) * (diff(range(colSums(.))) / 200) / max(sqrt(.))} %>% #stupid R non-conversion as.list %>% unlist #quartz(width = 11, height = 11) #X11(width = 11, height = 11) par(mar = c(0.5, 0.5, 3, 6)) plot(0, 0, type = "n", axes = F, xaxs = "i", yaxs = "i", xlim = c(1, 5), ylim = c(1, nrow(stock.clus.tab) + 2), xlab = "\n", ylab = "\n") abline(h = 1:(nrow(stock.clus.tab) + 2), v = 1:5, col = "grey40", lty = 3) box() symbols(rep(2:4, each = nrow(stock.clus.tab)), rep(1:nrow(stock.clus.tab), 3) + 1, squares = stock.clus.tab.sq, bg = rep(stock.clus.col, each = nrow(stock.clus.tab)), fg = 0, add = T, inches = F) axis(side = 3, at = c(2:4), labels = paste0("Cluster ", 1:3), col = 0, col.ticks = 1) axis(side = 4, at = 1:nrow(stock.clus.tab) + 1, labels = row.names(stock.clus.tab), las = 1) #2D #quartz(width = 11, height = 11) #X11(width = 11, height = 11) plot(stock.pca$x[, 1], stock.pca$x[, 2], pch = 1, lwd = 3, col = stock.clus.col[stock.clus$cluster], bty = "n", tck = 0.01, xlab = "PC1", ylab = "PC2", xlim = quantile(stock.pca$x[, 1], c(0, 1)) + c(- 10, 10), ylim = quantile(stock.pca$x[, 2], c(0, 1)) + c(- 10, 10)) abline(h = 0, v = 0, col = "grey80", lty = 3, lwd = 2) legend(x = "topright", legend = paste0("Cluster ", names(stock.clus.col)), bty = "n", col = stock.clus.col, pch = 1, pt.lwd = 2, cex = 0.5) #3D stock.pca.df$clus <- factor(stock.clus$cluster) g <- plot_ly(stock.pca.df, x = ~PC1, y = ~PC2, z = ~PC3, color = ~clus, colors = stock.clus.col, text = ~stock) %>% add_markers() %>% layout(scene = list(xaxis = list(title = 'PC1'), yaxis = list(title = 'PC2'), zaxis = list(title = 'PC3'))) g #----------------------------------------------------------------------------- #Examine the relationship network #----------------------------------------------------------------------------- #build the tree stock.nj <- bionj(stock.sub %>% dist(upper = T) %>% as.matrix) #adjust the labels to show only relevant information stock.nj$tip.label <- stock.nj$tip.label %>% {gsub("\\d+.vars.vcf.gz_AF", "", .)} #normalize the branch lengths to 1 stock.nj$edge.length <- rep(1, length(stock.nj$edge.length)) #visualize #plot (note ggtree takes some time) cairo_ps("../out/stock_nj_tree.eps", width = 8, height = 8, family = "sans") #quartz(width = 8, height = 8) #X11(width = 8, height = 8) ggtree(tr = stock.nj, layout = "daylight") + geom_tippoint(color = stock.clus.col[stock.clus$cluster], shape = 16, size = 3) + geom_tiplab(size = 3, color = "black") dev.off() #----------------------------------------------------------------------------- #Conduct DAPC #----------------------------------------------------------------------------- #execute the LDA with the candidate clusters stock.lda <- lda(stock.clus$cluster ~ stock.pca$x[, 1:37]) #reduce the dimensions stock.dapc <- stock.pca$x[, 1:37] %*% stock.lda$scaling #visualize plot(0, 0, type = "n", xlab = "DA1", ylab = "DA2", xlim = quantile(stock.dapc[, 1], c(0, 1)) + c(- 0.5, 0.5), ylim = quantile(stock.dapc[, 2], c(0, 1)) + c(- 0.5, 0.5)) text(x = stock.dapc, labels = stock.pop, cex = 0.75, col = stock.clus.col[stock.clus$cluster]) abline(h = 0, v = 0, col = "grey80", lty = 3, lwd = 2) legend(x = "topright", legend = paste0("Cluster ", names(stock.clus.col)), bty = "n", col = stock.clus.col, pch = 1, pt.lwd = 2, cex = 0.5) #CONCLUSION: largely unnecessary, the genetic differences are simple enough #that this visualiztion just exagerates it. Better to go with the simplified #or 3D plot. #----------------------------------------------------------------------------- #DEPRECATED - Unnecessary plus filled with uncertainty #----------------------------------------------------------------------------- #create the tSNE stock.tsne <- Rtsne(stock.geno, dims = 3, perplexity = 27, max_iter = 10000, check_duplicates = F) #cluster the tSNE kNNdistplot(stock.tsne$Y, k = sqrt(length(stock.pop))) stock.clus <- kNN(stock.tsne$Y, k = sqrt(length(stock.pop))) stock.clus <- dbscan(stock.tsne$Y, eps = 1.25, minPts = 3) #visualize the tSNE plot(stock.tsne$Y[, 1], stock.tsne$Y[, 2], pch = 1, lwd = 3, col = stock.col[stock.pop], bty = "n", tck = 0.01, xlab = "tSNE 1", ylab = "tSNE 2", xlim = c(min(stock.tsne$Y[, 1]), max(stock.tsne$Y[, 1])) + c(- 1, 1), ylim = c(min(stock.tsne$Y[, 2]), max(stock.tsne$Y[, 2])) + c(- 1, 1) ) abline(h = 0, v = 0, col = "grey80", lty = 3, lwd = 2) legend(x = "topright", legend = names(stock.col), bty = "n", col = stock.col, pch = 1, pt.lwd = 2, cex = 0.5) plot_ly(x = stock.tsne$Y[, 1], y = stock.tsne$Y[, 2], z = stock.tsne$Y[, 3], color = stock.pop, colors = stock.col, text = stock.pop) #### Loop to keep all SNPs #Using a dataframe we first remove non-standard chromosome SNPdata<-SNPdata[!grepl("NW", SNPdata$Chr),] SNPdata<-SNPdata[!grepl("NC_001566.1", SNPdata$Chr),] #Create a column with a standard format to match against SNPdata$site<- paste(SNPdata$Chr,SNPdata$Pos, sep = "__") #Remove Duplicates SNPdata <- SNPdata[!duplicated(SNPdata$site), c(4,3)] count = 3 #merge all Allele frequency files in a directory for(i in list.files(pattern ="_AF$")){ temp <- fread(list.files(pattern=i)) temp<-temp[!grepl("NW", temp$Chr),] temp<-temp[!grepl("NC_001566.1", temp$Chr),] temp$site<- paste(temp$Chr,temp$Pos, sep = "__") temp <- temp[!duplicated(temp$site), c(4,3)] SNPdata <- merge(SNPdata, temp, by = c("site"), all=TRUE) colnames(SNPdata)[count] = i count= count +1 print(i) } ### extract unique SNPS library(data.table) setwd("/Volumes/ProDisk/Stockseq2/FST_estimation/") files <- c(list.files(pattern ="*woo*")) infile <- lapply(files, fread) alldataaf <- lapply(rapply(infile, function(x) gsub("1:2=", "",x) , how = "list"), as.data.frame) for(i in 1:length(files)){ alldataaf[[i]]$V6 <- as.numeric(as.character(alldataaf[[i]]$V6)) } names(alldataaf) <- c(list.files(pattern ="*woo*")) fst <- c() for(i in 1:length(files)){ fst <- c(fst,mean(alldataaf[[i]]$V6, na.rm = TRUE)) } for(i in 1:length(files)){ alldataaf[[i]]$V6 <- as.numeric(as.character(alldataaf[[i]]$V6)) alldataaf[[i]]<-alldataaf[[i]][!grepl("NW", alldataaf[[i]]$V1),] alldataaf[[i]]<-alldataaf[[i]][!grepl("NC_001566.1", alldataaf[[i]]$V1),] alldataaf[[i]]$site<- paste(alldataaf[[i]]$V1,alldataaf[[i]]$V2, sep = "__") alldataaf[[files[i]]]<-subset(alldataaf[[i]], V6 >= quantile(V6, 0.99)) ### alldataaf[[i]] <- alldataaf[[i]][!duplicated(alldataaf[[i]]$site), c(4,3)] } uniquesnp <- Reduce(function(...) merge(...,by = "site") , list(alldataaf[[files[1]]],alldataaf[[files[2]]],alldataaf[[files[3]]],alldataaf[[files[4]]],alldataaf[[files[5]]],alldataaf[[files[6]]],alldataaf[[files[7]]])) nrow(uniquesnp) rus <-uniquesnp[,c(2,3,1,7,13,19,25,31,37,43)] ### Calculating CSS library(dplyr) #this one if don doesn twork not reduce library(tidyr) library(tidyverse) #this is for the reduce function library(data.table) library(plyr) fst<- fread("/Volumes/ProDisk/Stockseq2/FST_estimation/AdditionalFiles_Italians/true_ital_hilo_pol_russ_mnh.mpileup_sync.fst") from <-c("NC_037638.1","NC_037639.1","NC_037640.1","NC_037641.1","NC_037642.1","NC_037643.1","NC_037644.1","NC_037645.1","NC_037646.1","NC_037647.1","NC_037648.1","NC_037649.1","NC_037650.1","NC_037651.1","NC_037652.1", "NC_037653.1") to <- c(1:16) ital_pol_rus<- fst ital_pol_rus$V7 <- sub("1:3=", "",ital_pol_rus$V7) ital_pol_rus$V7 <- as.numeric(as.character(ital_pol_rus$V7)) ital_pol_rus$V8 <- sub("1:4=", "",ital_pol_rus$V8) ital_pol_rus$V8 <- as.numeric(as.character(ital_pol_rus$V8)) ital_pol_rus$V9 <- sub("1:5=", "",ital_pol_rus$V9) ital_pol_rus$V9 <- as.numeric(as.character(ital_pol_rus$V9)) ital_pol_rus$V10 <- sub("1:6=", "",ital_pol_rus$V10) ital_pol_rus$V10 <- as.numeric(as.character(ital_pol_rus$V10)) ital_pol_rus <- ital_pol_rus[!grepl("NW",ital_pol_rus$V1),] ital_pol_rus<-ital_pol_rus[!grepl("NC_001566.1", ital_pol_rus$V1),] ital_pol_rus$V1 <- mapvalues(ital_pol_rus$V1, from, to) ital_pol_rus$V1 <- as.numeric(ital_pol_rus$V1) hilo <- ital_pol_rus[,c(1,2,7)] pol <- ital_pol_rus[,c(1,2,8)] russ <- ital_pol_rus[,c(1,2,9)] mnh <- ital_pol_rus[,c(1,2,10)] fst<- list(pol = ital_pol_rus[,c(1,2,8)], russ = ital_pol_rus[,c(1,2,9)], mnh = ital_pol_rus[,c(1,2,10)], hilo = ital_pol_rus[,c(1,2,7)]) ##fst<- list(pol = ital_pol_rus[,c(1,2,8)]) fst$mnh$rank <- rank(-fst$mnh$V10)/length(fst$mnh$V10) fst$pol$rank <- rank(-fst$pol$V8)/length(fst$pol$V8) fst$russ$rank <- rank(-fst$russ$V9)/length(fst$russ$V9) fst$hilo$rank <- rank(-fst$hilo$V7)/length(fst$hilo$V7) fst$pol$z <- qnorm(fst$pol$rank) fst$mnh$z <- qnorm(fst$mnh$rank) fst$russ$z <- qnorm(fst$russ$rank) fst$hilo$z <- qnorm(fst$hilo$rank) fst$russ$Pos <- paste(fst$russ$V1, fst$russ$V2, sep = "_") fst$mnh$Pos <- paste(fst$mnh$V1, fst$mnh$V2, sep ="_") fst$pol$Pos <- paste(fst$pol$V1, fst$pol$V2, sep = "_") fst$hilo$Pos <- paste(fst$hilo$V1, fst$hilo$V2, sep = "_") fst <- fst %>% reduce(inner_join, by = "Pos") head(fst) #fst$zbar <- rowMeans(fst[,c(5,11)]) fst$zbar <- rowMeans(fst[,c(5,11,16,21)]) fst$CSS <- (2*pnorm(-fst$zbar)) fst$CSS <- as.numeric(fst$CSS) fst2<-fst[is.finite(fst$zbar), ] fst$CSS <- (2*pnorm(-fst$pol.z)) fst$CSS <- as.numeric(fst$CSS) fst2<-fst[is.finite(fst$zbar), ] fst2$logp <- -log10(fst2$CSS) ###NC_037638.1 1976 1 1.000 72.0 1:2=0.01063948 1:3=0.02002521 ### ### ###1:4=0.00417343 2:3=0.00481609 2:4=0.00532433 3:4=0.01209045 ital_pol_rus<- fst ital_pol_rus$V6 <- sub("1:2=", "",ital_pol_rus$V6) ital_pol_rus$V6 <- as.numeric(as.character(ital_pol_rus$V6)) ital_pol_rus$V7 <- sub("1:3=", "",ital_pol_rus$V7) ital_pol_rus$V7 <- as.numeric(as.character(ital_pol_rus$V7)) ital_pol_rus$V8 <- sub("1:4=", "",ital_pol_rus$V8) ital_pol_rus$V8 <- as.numeric(as.character(ital_pol_rus$V8)) ital_pol_rus$V9 <- sub("2:3=", "",ital_pol_rus$V9) ital_pol_rus$V9 <- as.numeric(as.character(ital_pol_rus$V9)) ital_pol_rus$V10 <- sub("2:4=", "",ital_pol_rus$V10) ital_pol_rus$V10 <- as.numeric(as.character(ital_pol_rus$V10)) ital_pol_rus$V11 <- sub("3:4=", "",ital_pol_rus$V11) ital_pol_rus$V11 <- as.numeric(as.character(ital_pol_rus$V11)) #pop_sd <- sd(mnh$rank)*sqrt((length(mnh$rank)-1)/(length(mnh$rank))) #pop_mean <- mean(mnh$rank) #z <- (13 - pop_mean)/ pop_sd #scale() # does the same thing pol <- ital_pol_rus[,c(1,2,6)] russ <- ital_pol_rus[,c(1,2,7)] mnh <- ital_pol_rus[,c(1,2,8)] pr<- ital_pol_rus[,c(1,2,9)] pm<- ital_pol_rus[,c(1,2,10)] rm<- ital_pol_rus[,c(1,2,11)] fst<- list(pol = ital_pol_rus[,c(1,2,6)], russ = ital_pol_rus[,c(1,2,7)], mnh = ital_pol_rus[,c(1,2,8)], pr= ital_pol_rus[,c(1,2,9)], pm= ital_pol_rus[,c(1,2,10)], rm= ital_pol_rus[,c(1,2,11)]) fst$mnh$rank <- rank(-fst$mnh$V8)/length(fst$mnh$V8) fst$pol$rank <- rank(-fst$pol$V6)/length(fst$pol$V6) fst$russ$rank <- rank(-fst$russ$V7)/length(fst$russ$V7) fst$pr$rank <- rank(fst$pr$V9)/length(fst$pr$V9) fst$pm$rank<- rank(fst$pm$V10)/length(fst$pm$V10) fst$rm$rank<- rank(fst$rm$V11)/length(fst$rm$V11) ### Allele frequency analysis library(SNPRelate) vcf.fn <- "./allsamplesmerged.vcf" snpgdsVCF2GDS(vcf.fn, "test.gds", method="biallelic.only") snpgdsSummary("test.gds") genofile <- snpgdsOpen("test.gds") pca <- snpgdsPCA(genofile, num.thread=4, autosome.only=FALSE) sample.id <- read.gdsn(index.gdsn(genofile, "sample.id")) pop_code <- c(rep("Carniolan", 12), rep("KItalian", 12), rep("Kona",12), rep("MNHyg", 12), rep("Pol",12), rep("Russian",12), rep("Wooten",12)) tab <- data.frame(sample.id = pca$sample.id, pop = factor(pop_code)[match(pca$sample.id, sample.id)], EV1 = pca$eigenvect[,1], # the first eigenvector EV2 = pca$eigenvect[,2], # the second eigenvector stringsAsFactors = FALSE) head(tab) plot(tab$EV2, tab$EV1, col=as.integer(tab$pop), xlab="eigenvect or 2", ylab="eigenvector 1") text(tab$EV2, tab$EV1, labels=tab$sample.id, cex= 0.7) legend("topleft", legend=levels(tab$pop), pch="o", col=1:nlevels(tab$pop)) pc.percent <- pca$varprop*100 head(round(pc.percent, 2)) lbls <- paste("PC", 1:4, "\n", format(pc.percent[1:4], digits=2), "%", sep="") pairs(pca$eigenvect[,1:4], col=tab$pop, labels=lbls) ibs <- snpgdsIBS(genofile, num.thread=4, autosome.only=FALSE) pop.idx <- order(pop_code) image(ibs$ibs[pop.idx, pop.idx], col=terrain.colors(16)) loc <- cmdscale(1 - ibs$ibs, k = 2) x <- loc[, 1]; y <- loc[, 2] race <- as.factor(pop_code) plot(x, y, col=race, xlab = "", ylab = "", main = "Multidimensional Scaling Analysis (IBS)") legend("bottomleft", legend=levels(race), pch="o", text.col=1:nlevels(race)) set.seed(100) ibs.hc <- snpgdsHCluster(snpgdsIBS(genofile, num.thread=4, autosome.only = FALSE)) rv <- snpgdsCutTree(ibs.hc) plot(rv$dendrogram, leaflab="none", main="HapMap Phase II") rv2 <- snpgdsCutTree(ibs.hc, samp.group=as.factor(pop_code)) plot(rv2$dendrogram, leaflab="none", main="HapMap Phase II") legend("topright", legend=levels(race), col=1:nlevels(race), pch=19, ncol=4) plot(rv2$dendrogram, main="HapMap Phase II") legend("topright", legend=levels(race), col=1:nlevels(race), pch=19, ncol=4) chr <- read.gdsn(index.gdsn(genofile, "snp.chromosome")) CORR <- snpgdsPCACorr(pca, genofile, eig.which=1:4) savepar <- par(mfrow=c(2,1), mai=c(0.45, 0.55, 0.1, 0.25)) for (i in 1:2) { plot(abs(CORR$snpcorr[i,]), ylim=c(0,1), xlab="", ylab=paste("PC", i), col=chr, pch="+") } library(pcadapt) vcf.fn <- "./allsamplesmerged.vcf" bed.fn <- "~/Desktop/testfile.bed.bed" filename <- read.pcadapt(bed.fn, type = "pool") x <- pcadapt(input = filename, K = 20) plot(x, option = "screeplot") plot(x, option = "scores", pop = pop_code) padj <- p.adjust(x$pvalues,method="bonferroni") alpha <- 0.1 outliers <- which(padj < alpha) length(outliers) padj <- p.adjust(x$pvalues, method = "BH") alpha <- 0.1 outliers <- which(padj < alpha) length(outliers)