├── data ├── GSE66210_RAW │ └── note └── GSE66210_tec_trait.csv ├── R ├── pca_for450K_pipeline.R ├── 450K_pipeline.R ├── pvca1_for450K_pipeline.R └── pvca2_for450K_pipeline.R └── README.md /data/GSE66210_RAW/note: -------------------------------------------------------------------------------- 1 | Raw data can be do download from https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GSE66210. 2 | -------------------------------------------------------------------------------- /R/pca_for450K_pipeline.R: -------------------------------------------------------------------------------- 1 | batch <- beta_BMIQ_filter 2 | pcbatch <- princomp(batch,cor=T) 3 | pdf("pcv1.pdf") 4 | plot(pcbatch$loadings,pch=18) 5 | text(pcbatch$loadings,substring(row.names(pcbatch$loadings),8),pos=4,cex=.7) 6 | #text(pcbatch$loadings,sub("SAMPLE_"," ",rownames(pcbatch$loadings)),pos=4,cex=.7) 7 | dev.off() 8 | 9 | datat <- t(beta_BMIQ_filter) 10 | alldata <- data.frame(datat,targets$individual,targets$tissue, targets$pregnancy) 11 | library(ggfortify) 12 | a <- autoplot(prcomp(alldata[,c(1:nrow(beta_BMIQ_filter))]),data=alldata,colour="targets.individual") 13 | pdf("pcv2.pdf") 14 | plot(a) 15 | dev.off() -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Illumina 450K methylation analysis 2 | This R code uses [minfi](http://bioconductor.org/packages/release/bioc/html/minfi.html) and [wateRmelon](https://bioconductor.org/packages/release/bioc/html/wateRmelon.html) preprocess the ILLUMINA 450K from idat to filtered and normalized beta-value. 3 | The analysis includes reading 450K idat files, samples and probes filtered by detectionP and Nbead, type II probes normalized using BMIQ, removing cross and snp probes using prepared list, and QC plots which includes PCA, PVCA and so on. Maybe it is not perfect now! More details in Chinese could be found [here](http://www.biotrainee.com/thread-237-1-1.html). Another useful package [ChAMP](https://bioconductor.org/packages/release/bioc/html/ChAMP.html) also could be used for Illumina450K analysis. 4 | The demo data can be download from [NCBI/GSE66210](https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GSE66210). 5 | -------------------------------------------------------------------------------- /data/GSE66210_tec_trait.csv: -------------------------------------------------------------------------------- 1 | description,rep,geo_accession,organism,individual,tissue,pregnancy,Sample_name,supplementary_file_grn,supplementary_file_red,data_row_count,Basename 2 | SAMPLE_3,1,GSM1616988,Homo_sapiens,Female,maternal_whole_blood,normal_pregnancy,8795207029_R01C02,ftp://ftp.ncbi.nlm.nih.gov/pub/geo/DATA/supplementary/samples/GSM1616nnn/GSM1616988/GSM1616988_8795207029_R01C02_Grn.idat.gz,ftp://ftp.ncbi.nlm.nih.gov/pub/geo/DATA/supplementary/samples/GSM1616nnn/GSM1616988/GSM1616988_8795207029_R01C02_Red.idat.gz,485577,GSM1616988_8795207029_R01C02 3 | SAMPLE_6,2,GSM1616991,Homo_sapiens,Female,maternal_whole_blood,normal_pregnancy,7668610068_R04C02,ftp://ftp.ncbi.nlm.nih.gov/pub/geo/DATA/supplementary/samples/GSM1616nnn/GSM1616991/GSM1616991_7668610068_R04C02_Grn.idat.gz,ftp://ftp.ncbi.nlm.nih.gov/pub/geo/DATA/supplementary/samples/GSM1616nnn/GSM1616991/GSM1616991_7668610068_R04C02_Red.idat.gz,485577,GSM1616991_7668610068_R04C02 4 | -------------------------------------------------------------------------------- /R/450K_pipeline.R: -------------------------------------------------------------------------------- 1 | #### 2 | # Describe: use appropriate packages to preprocess 450K idat 3 | # Environment: R 3.2.2 4 | # Author: Wang Kangli (SKLMG) 5 | # Date: 2016-06-28 6 | #### 7 | 8 | ###Reading 450K idat files with the minfi package (idat path and basename needed) 9 | library(minfi) 10 | path <- "GSE66210_RAW" 11 | list.files(path) 12 | targets <- read.csv("GSE66210_tec_trait.csv") 13 | names(targets) 14 | rownames(targets) <- targets[,1] 15 | targets$Basename <- file.path(path, targets$Basename) 16 | targets$Basename 17 | targets$batch <- substring(targets$Sample_name,1,10) 18 | targets$batch 19 | targets$position <- substring(targets$Sample_name,12) 20 | targets$position 21 | 22 | RGsetEx <- read.450k(targets$Basename, extended = TRUE, verbose = TRUE) # extended needed for get NBeads 23 | pData(RGsetEx) <- targets 24 | dim(getRed(RGsetEx)) 25 | dim(getGreen(RGsetEx)) 26 | manifest <- getManifest(RGsetEx) 27 | manifest 28 | head(getProbeInfo(manifest)) 29 | head(getRed(RGsetEx)) 30 | 31 | ###sample filter by detectionP 32 | detP <- detectionP(RGsetEx) 33 | Pfailed <- detP>0.01 34 | colMeans(Pfailed) # Fraction of failed positions per sample 35 | sum(colMeans(Pfailed)>0.01) 36 | cutSample <- colMeans(Pfailed)>0.01 37 | RGsetEx_cutSam <- RGsetEx[,!cutSample] 38 | ###find failed probe by detectionP 39 | detP <- detectionP(RGsetEx_cutSam) 40 | Pfailed <- detP>0.01 41 | sum(rowMeans(Pfailed)>0.1) # How many positions failed in >10% of samples? 42 | failedProbesP <-rownames(Pfailed)[rowMeans(Pfailed)>0.1] 43 | ###find failed probe by Nbeads use wateRmelon packages 44 | library(wateRmelon) 45 | beadcount <- beadcount(RGsetEx_cutSam) 46 | NBfailed <- is.na(beadcount) 47 | sum(rowMeans(NBfailed)>0.05) 48 | failedProbesNB <-rownames(NBfailed)[rowMeans(NBfailed)>0.05] 49 | ###get the list of failed probes 50 | failedProbes <- union(failedProbesP, failedProbesNB) 51 | ###one-step filter: you also can use wateRmelon to filter based on bead count and detection p-values, but the old version is not avaiable for RGsetEx，you can not get MSet after filter. 52 | #RGsetEx.pf <- pfilter(RGsetEx, perCount=5, pnthresh = 0.01, perc = 1, pthresh = 1) 53 | 54 | ###preprocess and get beta value 55 | #MSet <- preprocessRaw(RGsetEx_cutSam) 56 | Mset <-preprocessIllumina(RGsetEx_cutSam, bg.correct=TRUE, normalize = c("controls"), reference =1) 57 | MSet 58 | ###remove failed probes 59 | Mset_cutProbe <- Mset[!rownames(Mset)%in% failedProbes,] 60 | #Mset_cutProbe2 <- Mset[!(rowMeans(Pfailed)>0.1),] 61 | head(getMeth(Mset_cutProbe)) 62 | ###get beta value 63 | RSet <- ratioConvert(Mset_cutProbe, what = "both", keepCN = TRUE) 64 | RSet 65 | beta <- getBeta(RSet) 66 | 67 | ###BMIQ 68 | #typeI <- getProbeInfo(Mset_cutProbe, type = "I") 69 | #typeII <- getProbeInfo(Mset_cutProbe, type = "II") 70 | #typeI$type <- 1 71 | #typeII$type <- 2 72 | #design.typeI <- typeI[,c(1,9)] 73 | #design.typeII <- typeII[,c(1,5)] 74 | #design.type <- rbind(design.typeI,design.typeII) 75 | # #design.v <- subset(design.type,Name==rownames(beta),type) 76 | #lookup <- rownames(beta) 77 | #design.v <- design.type[match(lookup,design.type[,1]),2] 78 | ##another method 79 | design.type <- got(Mset_cutProbe) 80 | design.v <- sub("II",2,design.type) 81 | design.v <- sub("I",1,design.v) 82 | design.v1 <- as.numeric(design.v1) 83 | 84 | BMIQ1 <- apply(beta, 2, function(x) BMIQ(beta.v=x, design.v=design.v, plots=FALSE)) 85 | BMIQ2 <- lapply(BMIQ1, function(y) y$nbeta) 86 | beta_BMIQ <- as.matrix(data.frame(BMIQ2)) 87 | ##BMIQ can be used for a MethyLumiSet or MethylSet, but it got error when I use MethySet 88 | #MethySet_BMIQ <- BMIQ(MethySet) # got error, else it will be more useful 89 | #MethylumiSet_BMIQ <- BMIQ(MethylumiSet) 90 | 91 | ###remove cross and snp probes 92 | filter.probes<- read.csv(file="list167085_for45Kfilter.csv", header=TRUE) 93 | dim(filter.probes) 94 | filter.p <- filter.probes[,1] 95 | length(filter.p) # 167085 96 | beta_BMIQ_filter <- beta_BMIQ[rownames(beta_BMIQ)%in% filter.p,] 97 | beta_BMIQ_nonfilter <- beta_BMIQ[!rownames(beta_BMIQ)%in% filter.p,] 98 | dim(beta_BMIQ_filter) #features.460350 samples.146 99 | 100 | ###PCA and PVCA plot 101 | source("pca_for450K_pipeline.R") 102 | source("pvca1_for450K_pipeline.R") 103 | source("pvca2_for450K_pipeline.R") 104 | 105 | ###QC plot 106 | qc <- getQC(Mset_cutProbe) 107 | head(qc) 108 | pdf("QC.pdf") 109 | plotQC(qc) 110 | densityPlot(Mset_cutProbe, sampGroups = pData(Mset_cutProbe)$rep) 111 | densityBeanPlot(Mset_cutProbe, sampGroups = pData(Mset_cutProbe)$rep) 112 | controlStripPlot(RGsetEx_cutSam, controls="BISULFITE CONVERSION II", sampNames=pData(RGsetEx_cutSam)$description) 113 | #qcReport(RGsetEx_cutSam, sampNames=colnames(RGsetEx_cutSam), sampGroups=pData(RGsetEx_cutSam)$rep, pdf= "qcReport.pdf") 114 | ### Type plot and mds plot 115 | plotBetasByType(Mset_cutProbe[,1], main=colnames(Mset_cutProbe)[1]) 116 | mdsPlot(Mset_cutProbe, numPositions = 1000, sampNames=colnames(Mset_cutProbe), sampGroups=pData(Mset_cutProbe)$rep) 117 | dev.off() 118 | -------------------------------------------------------------------------------- /R/pvca1_for450K_pipeline.R: -------------------------------------------------------------------------------- 1 | #Programmer: Chao Chen 2 | #Location: UCHICAGO 3 | #email chenchaor@gmail.com 4 | #Code: R 5 | #Program name: pvca.R 6 | #Date: May 26, 2010 7 | 8 | ########## load libraries ########## 9 | library(lme4) 10 | ####### Edit these variables according to user defined parameters and the path to your data and data files names ########## 11 | 12 | #myPath <- "C:/Users/WangKangli/Desktop/methylationdata" 13 | #theGene_expression_file <- "RAW_62REPLICATES.TXT" 14 | #theMethylation_file <- "methylation.csv" 15 | #theExperiment_data_file <- "expinfo_tab_delimited.TXT" 16 | #theMethylation_data_file <- "sample.csv" 17 | pct_threshold = .5876 # Amount of variability desired to be explained by the principal components. Set to match the results in book chapter and SAS code. User can adjust this to a higher (>= 0.8) number but < 1.0 18 | 19 | ### In addition, be sure to modify the mixed linear model by adding the appropriate random effects terms in the model 20 | 21 | ################################################ 22 | 23 | #theGEDFilePath = paste(myPath,theMethylation_file, sep="/") 24 | #theExpDataFilePath = paste(myPath,theMethylation_data_file, sep="/") 25 | 26 | ########## Load data ########## 27 | 28 | theDataMatrix <- beta_BMIQ_filter 29 | #theDataMatrix <- read.delim(theGEDFilePath, row.names = 1, header = TRUE, sep = ",") 30 | dataRowN <- nrow(theDataMatrix) 31 | dataColN <- ncol(theDataMatrix) 32 | 33 | ########## Center the data (center rows) ########## 34 | theDataMatrixCentered <- matrix(data = 0, nrow = dataRowN, ncol = dataColN) 35 | theDataMatrixCentered_transposed = apply(theDataMatrix, 1, scale, center = TRUE, scale = FALSE) 36 | theDataMatrixCentered = t(theDataMatrixCentered_transposed) 37 | 38 | #exp_design <- read.delim(theExpDataFilePath, sep = ",", header = TRUE, row.names = 1) 39 | #exp_design <- exp_design[,-c(3,7)] 40 | exp_design <- targets[,c("individual", "tissue", "pregnancy", "batch", "position")] 41 | rownames(exp_design) <- rownames(targets) 42 | expDesignRowN <- nrow(exp_design) 43 | expDesignColN <- ncol(exp_design) 44 | myColNames <- names(exp_design) 45 | 46 | 47 | ########## Compute correlation matrix ########## 48 | 49 | theDataCor <- cor(theDataMatrixCentered) 50 | 51 | ########## Obtain eigenvalues ########## 52 | 53 | eigenData <- eigen(theDataCor) 54 | eigenValues = eigenData$values 55 | ev_n <- length(eigenValues) 56 | eigenVectorsMatrix = eigenData$vectors 57 | eigenValuesSum = sum(eigenValues) 58 | percents_PCs = eigenValues /eigenValuesSum 59 | 60 | ########## Merge experimental file and eigenvectors for n components ########## 61 | 62 | my_counter_2 = 0 63 | my_sum_2 = 1 64 | for (i in ev_n:1){ 65 | my_sum_2 = my_sum_2 - percents_PCs[i] 66 | if ((my_sum_2) <= pct_threshold ){ 67 | my_counter_2 = my_counter_2 + 1 68 | } 69 | 70 | } 71 | if (my_counter_2 < 3){ 72 | pc_n = 3 73 | 74 | }else { 75 | pc_n = my_counter_2 76 | } 77 | 78 | # pc_n is the number of principal components to model 79 | 80 | pc_data_matrix <- matrix(data = 0, nrow = (expDesignRowN*pc_n), ncol = 1) 81 | mycounter = 0 82 | for (i in 1:pc_n){ 83 | for (j in 1:expDesignRowN){ 84 | mycounter <- mycounter + 1 85 | pc_data_matrix[mycounter,1] = eigenVectorsMatrix[j,i] 86 | 87 | } 88 | } 89 | 90 | AAA <- exp_design[rep(1:expDesignRowN,pc_n),] 91 | 92 | Data <- cbind(AAA,pc_data_matrix) 93 | ####### Edit these variables according to your factors ####### 94 | 95 | #Data$sex <- as.factor(Data$sex) 96 | #Data$age <- as.factor(Data$age) 97 | #Data$Index <- as.factor(Data$Index) 98 | 99 | variables <- c(colnames(exp_design)) 100 | for (i in 1:length(variables)) { 101 | Data$variables[i] <- as.factor(Data$variables[i]) 102 | } 103 | 104 | ########## Mixed linear model ########## 105 | op <- options(warn = (-1)) 106 | effects_n = expDesignColN + 1 107 | #effects_n = expDesignColN + choose(expDesignColN, 2) + 1 108 | randomEffectsMatrix <- matrix(data = 0, nrow = pc_n, ncol = effects_n) 109 | 110 | model.func <- c() 111 | index <- 1 112 | for (i in 1:length(variables)) { 113 | mod = paste("(1|", variables[i], ")", sep = "") 114 | model.func[index] = mod 115 | index = index + 1 116 | } 117 | #for (i in 1:(length(variables) - 1)) { 118 | # for (j in (i + 1):length(variables)) { 119 | # mod = paste("(1|", variables[i], ":", variables[j], 120 | # ")", sep = "") 121 | # model.func[index] = mod 122 | # index = index + 1 123 | # } 124 | #} 125 | function.mods <- paste(model.func, collapse = " + ") 126 | 127 | for (i in 1:pc_n) { 128 | y = (((i - 1) * expDesignRowN) + 1) 129 | funct <- paste("pc_data_matrix", function.mods, sep = " ~ ") 130 | Rm1ML <- lmer(funct, Data[y:(((i - 1) * expDesignRowN) + 131 | expDesignRowN), ], REML = TRUE, control=lmerControl(check.nobs.vs.nlev = "ignore",check.nobs.vs.rankZ = "ignore",check.nobs.vs.nRE="ignore"),verbose = FALSE, 132 | na.action = na.omit) 133 | randomEffects <- Rm1ML 134 | randomEffectsMatrix[i, ] <- c(unlist(VarCorr(Rm1ML)), 135 | resid = sigma(Rm1ML)^2) 136 | } 137 | effectsNames <- c(names(getME(Rm1ML, "cnms")), "resid") 138 | ########## Standardize Variance ########## 139 | 140 | randomEffectsMatrixStdze <- matrix(data = 0, nrow = pc_n, ncol = effects_n) 141 | for (i in 1:pc_n){ 142 | mySum = sum(randomEffectsMatrix[i,]) 143 | for (j in 1:effects_n){ 144 | randomEffectsMatrixStdze[i,j] = randomEffectsMatrix[i,j]/mySum 145 | } 146 | } 147 | 148 | ########## Compute Weighted Proportions ########## 149 | 150 | randomEffectsMatrixWtProp <- matrix(data = 0, nrow = pc_n, ncol = effects_n) 151 | for (i in 1:pc_n){ 152 | weight = eigenValues[i]/eigenValuesSum 153 | for (j in 1:effects_n){ 154 | randomEffectsMatrixWtProp[i,j] = randomEffectsMatrixStdze[i,j]*weight 155 | } 156 | } 157 | 158 | ########## Compute Weighted Ave Proportions ########## 159 | 160 | randomEffectsSums <- matrix(data = 0, nrow = 1, ncol = effects_n) 161 | randomEffectsSums <-colSums(randomEffectsMatrixWtProp) 162 | totalSum = sum(randomEffectsSums) 163 | randomEffectsMatrixWtAveProp <- matrix(data = 0, nrow = 1, ncol = effects_n) 164 | 165 | for (j in 1:effects_n){ 166 | randomEffectsMatrixWtAveProp[j] = randomEffectsSums[j]/totalSum 167 | 168 | } 169 | 170 | pdf("pvca1.pdf") 171 | bp <- barplot(randomEffectsMatrixWtAveProp, xlab = "Effects", ylab = "Weighted average proportion variance", ylim= c(0,1.1),col = c("blue"), las=2) 172 | 173 | axis(1, at = bp, labels = effectsNames, xlab = "Effects", cex.axis = 0.5, las=2) 174 | 175 | ## replace the above code of "axis(1, at = bp, labels = effectsNames, xlab = "Effects", cex.axis = 0.5, las=2)" if you want rotate the x axis labels. 176 | ## text(bp, par("usr")[3]-0.02, srt = 45, adj = 1,labels = effectsNames, xpd = TRUE,cex=0.8) 177 | 178 | values = randomEffectsMatrixWtAveProp 179 | new_values = round(values , 3) 180 | text(bp,randomEffectsMatrixWtAveProp,labels = new_values, pos=3, cex = 0.8) # place numbers on top of bars 181 | dev.off() 182 | 183 | 184 | 185 | -------------------------------------------------------------------------------- /R/pvca2_for450K_pipeline.R: -------------------------------------------------------------------------------- 1 | #Programmer: Chao Chen 2 | #Location: UCHICAGO 3 | #email chenchaor@gmail.com 4 | #Code: R 5 | #Program name: pvca.R 6 | #Date: May 26, 2010 7 | 8 | ########## load libraries ########## 9 | library(lme4) 10 | ####### Edit these variables according to user defined parameters and the path to your data and data files names ########## 11 | 12 | #myPath <- "C:/Users/WangKangli/Desktop/methylationdata" 13 | #theGene_expression_file <- "RAW_62REPLICATES.TXT" 14 | #theMethylation_file <- "methylation.csv" 15 | #theExperiment_data_file <- "expinfo_tab_delimited.TXT" 16 | #theMethylation_data_file <- "sample.csv" 17 | pct_threshold = .5876 # Amount of variability desired to be explained by the principal components. Set to match the results in book chapter and SAS code. User can adjust this to a higher (>= 0.8) number but < 1.0 18 | 19 | ### In addition, be sure to modify the mixed linear model by adding the appropriate random effects terms in the model 20 | 21 | ################################################ 22 | 23 | #theGEDFilePath = paste(myPath,theMethylation_file, sep="/") 24 | #theExpDataFilePath = paste(myPath,theMethylation_data_file, sep="/") 25 | 26 | ########## Load data ########## 27 | 28 | theDataMatrix <- beta_BMIQ_filter 29 | #theDataMatrix <- read.delim(theGEDFilePath, row.names = 1, header = TRUE, sep = ",") 30 | dataRowN <- nrow(theDataMatrix) 31 | dataColN <- ncol(theDataMatrix) 32 | 33 | ########## Center the data (center rows) ########## 34 | theDataMatrixCentered <- matrix(data = 0, nrow = dataRowN, ncol = dataColN) 35 | theDataMatrixCentered_transposed = apply(theDataMatrix, 1, scale, center = TRUE, scale = FALSE) 36 | theDataMatrixCentered = t(theDataMatrixCentered_transposed) 37 | 38 | #exp_design <- read.delim(theExpDataFilePath, sep = ",", header = TRUE, row.names = 1) 39 | #exp_design <- exp_design[,-c(3,7)] 40 | exp_design <- targets[,c("individual", "tissue", "pregnancy", "batch", "position")] 41 | rownames(exp_design) <- rownames(targets) 42 | expDesignRowN <- nrow(exp_design) 43 | expDesignColN <- ncol(exp_design) 44 | myColNames <- names(exp_design) 45 | 46 | 47 | ########## Compute correlation matrix ########## 48 | 49 | theDataCor <- cor(theDataMatrixCentered) 50 | 51 | ########## Obtain eigenvalues ########## 52 | 53 | eigenData <- eigen(theDataCor) 54 | eigenValues = eigenData$values 55 | ev_n <- length(eigenValues) 56 | eigenVectorsMatrix = eigenData$vectors 57 | eigenValuesSum = sum(eigenValues) 58 | percents_PCs = eigenValues /eigenValuesSum 59 | 60 | ########## Merge experimental file and eigenvectors for n components ########## 61 | 62 | my_counter_2 = 0 63 | my_sum_2 = 1 64 | for (i in ev_n:1){ 65 | my_sum_2 = my_sum_2 - percents_PCs[i] 66 | if ((my_sum_2) <= pct_threshold ){ 67 | my_counter_2 = my_counter_2 + 1 68 | } 69 | 70 | } 71 | if (my_counter_2 < 3){ 72 | pc_n = 3 73 | 74 | }else { 75 | pc_n = my_counter_2 76 | } 77 | 78 | # pc_n is the number of principal components to model 79 | 80 | pc_data_matrix <- matrix(data = 0, nrow = (expDesignRowN*pc_n), ncol = 1) 81 | mycounter = 0 82 | for (i in 1:pc_n){ 83 | for (j in 1:expDesignRowN){ 84 | mycounter <- mycounter + 1 85 | pc_data_matrix[mycounter,1] = eigenVectorsMatrix[j,i] 86 | 87 | } 88 | } 89 | 90 | AAA <- exp_design[rep(1:expDesignRowN,pc_n),] 91 | 92 | Data <- cbind(AAA,pc_data_matrix) 93 | ####### Edit these variables according to your factors ####### 94 | 95 | #Data$sex <- as.factor(Data$sex) 96 | #Data$age <- as.factor(Data$age) 97 | #Data$Index <- as.factor(Data$Index) 98 | 99 | variables <- c(colnames(exp_design)) 100 | for (i in 1:length(variables)) { 101 | Data$variables[i] <- as.factor(Data$variables[i]) 102 | } 103 | 104 | ########## Mixed linear model ########## 105 | op <- options(warn = (-1)) 106 | #effects_n = expDesignColN + 1 107 | effects_n = expDesignColN + choose(expDesignColN, 2) + 1 108 | randomEffectsMatrix <- matrix(data = 0, nrow = pc_n, ncol = effects_n) 109 | 110 | model.func <- c() 111 | index <- 1 112 | for (i in 1:length(variables)) { 113 | mod = paste("(1|", variables[i], ")", sep = "") 114 | model.func[index] = mod 115 | index = index + 1 116 | } 117 | for (i in 1:(length(variables) - 1)) { 118 | for (j in (i + 1):length(variables)) { 119 | mod = paste("(1|", variables[i], ":", variables[j], 120 | ")", sep = "") 121 | model.func[index] = mod 122 | index = index + 1 123 | } 124 | } 125 | function.mods <- paste(model.func, collapse = " + ") 126 | 127 | for (i in 1:pc_n) { 128 | y = (((i - 1) * expDesignRowN) + 1) 129 | funct <- paste("pc_data_matrix", function.mods, sep = " ~ ") 130 | Rm1ML <- lmer(funct, Data[y:(((i - 1) * expDesignRowN) + 131 | expDesignRowN), ], REML = TRUE, control=lmerControl(check.nobs.vs.nlev = "ignore",check.nobs.vs.rankZ = "ignore",check.nobs.vs.nRE="ignore"),verbose = FALSE, 132 | na.action = na.omit) 133 | randomEffects <- Rm1ML 134 | randomEffectsMatrix[i, ] <- c(unlist(VarCorr(Rm1ML)), 135 | resid = sigma(Rm1ML)^2) 136 | } 137 | effectsNames <- c(names(getME(Rm1ML, "cnms")), "resid") 138 | ########## Standardize Variance ########## 139 | 140 | randomEffectsMatrixStdze <- matrix(data = 0, nrow = pc_n, ncol = effects_n) 141 | for (i in 1:pc_n){ 142 | mySum = sum(randomEffectsMatrix[i,]) 143 | for (j in 1:effects_n){ 144 | randomEffectsMatrixStdze[i,j] = randomEffectsMatrix[i,j]/mySum 145 | } 146 | } 147 | 148 | ########## Compute Weighted Proportions ########## 149 | 150 | randomEffectsMatrixWtProp <- matrix(data = 0, nrow = pc_n, ncol = effects_n) 151 | for (i in 1:pc_n){ 152 | weight = eigenValues[i]/eigenValuesSum 153 | for (j in 1:effects_n){ 154 | randomEffectsMatrixWtProp[i,j] = randomEffectsMatrixStdze[i,j]*weight 155 | } 156 | } 157 | 158 | ########## Compute Weighted Ave Proportions ########## 159 | 160 | randomEffectsSums <- matrix(data = 0, nrow = 1, ncol = effects_n) 161 | randomEffectsSums <-colSums(randomEffectsMatrixWtProp) 162 | totalSum = sum(randomEffectsSums) 163 | randomEffectsMatrixWtAveProp <- matrix(data = 0, nrow = 1, ncol = effects_n) 164 | 165 | for (j in 1:effects_n){ 166 | randomEffectsMatrixWtAveProp[j] = randomEffectsSums[j]/totalSum 167 | 168 | } 169 | 170 | pdf("pvca2.pdf") 171 | bp <- barplot(randomEffectsMatrixWtAveProp, xlab = "Effects", ylab = "Weighted average proportion variance", ylim= c(0,1.1),col = c("blue"), las=2) 172 | 173 | axis(1, at = bp, labels = effectsNames, xlab = "Effects", cex.axis = 0.5, las=2) 174 | 175 | ## replace the above code of "axis(1, at = bp, labels = effectsNames, xlab = "Effects", cex.axis = 0.5, las=2)" if you want rotate the x axis labels. 176 | ## text(bp, par("usr")[3]-0.02, srt = 45, adj = 1,labels = effectsNames, xpd = TRUE,cex=0.8) 177 | 178 | values = randomEffectsMatrixWtAveProp 179 | new_values = round(values , 3) 180 | text(bp,randomEffectsMatrixWtAveProp,labels = new_values, pos=3, cex = 0.8) # place numbers on top of bars 181 | dev.off() 182 | 183 | 184 | 185 | 186 | --------------------------------------------------------------------------------