Nothing
R/plotPCAw.R
In wrGraph: Graphics in the Context of Analyzing High-Throughput Data
Defines functions
.addTextToPoints
plotPCAw
Documented in
.addTextToPoints
plotPCAw
#' PCA Plot With Bag-plot To Highlight Centers Of Groups
#'
#' @description
#' This function allows to plot \href{https://en.wikipedia.org/wiki/Principal_component_analysis}{principal components analysis (PCA)},
#' with options to show center and potential outliers for each of the groups (columns of data).
#' The main points of this implementation consist in offering bagplots to highlight groups of columns/samples and support to (object-oriented)
#' output from \href{https://bioconductor.org/packages/release/bioc/html/limma.html}{limma} and \href{https://CRAN.R-project.org/package=wrProteo}{wrProteo}.
#'
#' @details
#' One motivation for this implementation of plotting PCA was to provide a convenient way for doing so with of MArrayLM-objects or lists
#' as created by \href{https://bioconductor.org/packages/release/bioc/html/limma.html}{limma} and \href{https://CRAN.R-project.org/package=wrProteo}{wrProteo}.
#'
#' Another motivation for this implementation comes from integrating the idea of bag-plots to better visualize different groups of points
#' (if external knowledge allows organizing them as distinct groups) :
#' The main body of data is shown as 'bag-plots' (a bivariate boxplot, see \href{https://en.wikipedia.org/wiki/Bagplot}{Bagplot})
#' with different transparent colors to highlight the core part of different groups (if they contain more than 2 values per group).
#' Furthermore, group centers are shown as average or median (see 'nGrpForMedian') with stars & index-number (if <25 groups).
#'
#' If the data allow for at least 3 principal components, by default the plotting region will be devided in 3 parts:
#' The 1st part for 1st and 2nd principal components, the 2nd part for 2nd and 3rd principal components and the 3rd part to display the variability captured in each principal component.
#' Otherwise one may use \code{suplFig=FALSE} to restrict on only plotting the 1st and 2nd principal components.
#'
#' Note : This function uses \code{\link[stats]{prcomp}} for calculating Eigenvectors and principal components, with default \code{center=TRUE} and \code{scale.=FALSE} (different to \code{princomp()}. which standardizes by default).
#' This way the user has to option to intervene on arguments \code{center} and \code{scale.}. However, this should be done with care.
#'
#' Note: \code{NA}-values cannot (by definition) be processed by (any) PCA - all lines with any non-finite values/content (eg \code{NA}) will be omitted !
#'
#' Note : Package RColorBrewer may be used if available.
#'
#' For more options with PCA (and related methods) you may also see also the package \href{https://CRAN.R-project.org/package=FactoMineR}{FactoMineR}
#' which provides a very wide spectrum of possibiities, in particular for combined numeric and categorical data.
#'
#' @param dat (matrix, data.frame, MArrayLM-object or list) data to plot. Note: \code{NA}-values cannot be processed - all lines with non-finite data (eg \code{NA}) will be omitted !
#' In case of MArrayLM-object or list \code{dat} must conatain list-element named 'datImp','dat' or 'data'.
#' @param sampleGrp (character or factor) should be factor describing groups of replicates, NAs are not supported
#' @param tit (character) custom title
#' @param useSymb (integer) symbols to use (see also \code{\link[graphics]{par}})
#' @param center (logical or numeric) decide if variables should be shifted to be zero centered, argument passed to \code{\link[stats]{prcomp}}
#' @param scale. (logical or numeric) decide if scaling to obtain unit variance, argument passed to \code{\link[stats]{prcomp}}
#' Alternatively, a vector of length equal the number of columns of x can be supplied. The value is passed to scale.
#' @param colBase (character or integer) define custom colors (must be of length corresponding to number of columns from argument \code{dat})
#' @param useSymb2 (integer) symbol to mark group-center (no mark of group-center if default NULL) (equivalent to \code{pch}, see also \code{\link[graphics]{par}})
#' @param cexTxt (numeric) expansion factor for text (see also \code{\link[graphics]{par}})
#' @param cexSub (integer) expansion factor for subtitle line text (see also \code{\link[graphics]{par}})
#' @param cexAxis (numeric) size of numeric y-axis labels as cex-expansion factor (see also \code{\link[graphics]{par}})
#' @param cexNames (numeric) size of labels/values on axis as cex-expansion factor (see also \code{\link[graphics]{par}})
#' @param cexMain (numeric) size of title as cex-expansion factor (see also \code{\link[graphics]{par}})x
#' @param displBagPl (logical) if \code{TRUE}, show bagPlot (group-center) if >3 points per group otherwise the average-confidence-interval
#' @param outCoef (numeric) parameter for defining outliers, see \code{\link{addBagPlot}} (equivalent to \code{range} in \code{\link[graphics]{boxplot}})
#' @param getOutL (logical) return outlyer samples/values
#' @param showLegend (logical or character) toggle to display legend, if character it designes the location within the plot to display the legend ('bottomleft','topright', etc..)
#' @param nGrpForMedian (integer) decide if group center should be displayed via its average or median value: If group has less than 'nGrpForMedian' values, the average will be used, otherwise the median; if \code{NULL} no group centers will be displayed
#' @param pointLabelPar (character) define formatting for optional labels next to points in main figure (ie PC1 vs PC2); may be \code{TRUE} or list containing elments '$textLabel', '$textCol', '$textCex',
#' '$textOffSet', '$textAdj' for fine-tuning
#' may aslo be '$pointCex' and '$pointCol' for custom size of points
#' @param rowTyName (character) for subtitle : specify nature of rows (genes, proteins, probesets,...)
#' @param rotatePC (integer) optional rotation (by -1) for figure of the principal components specified by index
#' @param suplFig (logical) to include plots vs 3rd principal component (PC) and Screeplot
#' @param silent (logical) suppress messages
#' @param debug (logical) display additional messages for debugging
#' @param callFrom (character) allow easier tracking of messages produced
#' @return This function make a plot and may retiurn an optional matrix of outlyer-data (depending on argument \code{getOutL})
#' @seealso \code{\link[stats]{prcomp}} (used here for the PCA underneith) , \code{\link[stats]{princomp}}, see the package \href{https://CRAN.R-project.org/package=FactoMineR}{FactoMineR} for multiple plotting options or ways of combining categorical and numeric data
#' @examples
#' set.seed(2019); dat1 <- matrix(round(c(rnorm(1000), runif(1000,-0.9,0.9)),2),
#' ncol=20, byrow=TRUE) + matrix(rep(rep(1:5,6:2), each=100), ncol=20)
#' biplot(prcomp(dat1)) # traditional plot
#' (grp = factor(rep(LETTERS[5:1], 6:2)))
#' plotPCAw(dat1, grp)
#' ## with some custom settings
#' plotPCAw(dat1, grp, pointLabelPar=list(textCex=0.7, textCol=2, pointCex=2), suplFig=FALSE)
#' @export
plotPCAw <- function(dat, sampleGrp, tit=NULL, useSymb=c(21:25,9:12,3:4), center=TRUE, scale.=TRUE, useSymb2=NULL, colBase=NULL,
cexTxt=1, cexSub=0.6, cexAxis=NULL, cexNames=NULL, cexMain=NULL, displBagPl=TRUE, outCoef=2, getOutL=FALSE, showLegend=TRUE,
nGrpForMedian=6, pointLabelPar=NULL, rowTyName="genes", rotatePC=NULL, suplFig=TRUE, callFrom=NULL, silent=TRUE, debug=FALSE) {
## note : so far not well adopted for plotting all points in transparent grey with same symb for interactive mouse-over
fxNa <- wrMisc::.composeCallName(callFrom, newNa="plotPCAw")
msg <- " 'dat' must be matrix, data.frame (with at least 1 line and 2 columns) or list/MArrayLM-object (with element 'datImp','dat' or 'data' as matrix or data.frame)"
if(!isTRUE(silent)) silent <- FALSE
if(isTRUE(debug)) silent <- FALSE else debug <- FALSE
#colBase <- NULL
if("MArrayLM" %in% class(dat) || is.list(dat)) {
## check which list-element may contain abundance data (prefer $datImp is avail)
chDat <- c("datImp","dat","data","quant","datRaw") %in% names(dat)
chGr <- c("groups","grp","sampleGroups") %in% names(dat)
if(any(chGr, na.rm=TRUE) && length(sampleGrp) <1) {
chGrpNa <- c("groups","grp","sampleGroups")
sampleGrp <- dat[[which(names(dat) %in% chGrpNa)[1]]]
} else if("sampleSetup" %in% names(dat)) if(any(chGrpNa %in% names(dat$sampleSetup), na.rm=TRUE)) {
sampleGrp <- dat$sampleSetup[[ which(chGrpNa %in% names(dat$sampleSetup))[1]]] }
if(any(chDat, na.rm=TRUE)) dat <- dat[[which(names(dat) %in% c("datImp","dat","data","datRaw"))[1]]] else stop(msg) }
if(any(length(dim(dat)) !=2, dim(dat) < 1:2, na.rm=TRUE)) stop(msg)
if(length(sampleGrp) <1 || sum(is.na(sampleGrp))==length(sampleGrp)) stop("Argument 'sampleGrp' seems to be empty (or all NA)")
if(length(sampleGrp) != ncol(dat)) stop(fxNa,"Length of argument 'sampleGrp' must match number of columns of 'dat'")
if(!is.factor(sampleGrp)) sampleGrp <- as.factor(sampleGrp)
if(!isFALSE(center)) center <- TRUE
if(!isFALSE(scale.)) scale. <- TRUE
if(!isFALSE(suplFig)) suplFig <- TRUE
nGrpLim <- 25 # decide/limit if group-centers are shown as stars
## reduce to columns defined by 'sampleGrp' (groups declared as NA will be removed) and to columns with finite data
if(length(dat) >0) {
dat <- dat[,!is.na(sampleGrp)]
chFin <- is.finite(dat)
chCol <- colSums(chFin) <2
if(sum(chCol) >0) {
dimIni <- dim(dat)
if(!silent) message(fxNa,"Removing ",sum(chCol)," (out of ",ncol(dat),") columns with less than 2 finite values")
dat <- dat[,which(!chCol)]
chFin <- chFin[,which(!chCol)]
if(ncol(dat) <2) stop("After removing bad (non-finite) columns less than 2 columns remain !")
sampleGrp <- sampleGrp[which(!chCol)]
if(length(useSymb) == dimIni[2]) useSymb <- useSymb[which(!chCol)] }
opar <- graphics::par(no.readonly=TRUE)
if(suplFig && ncol(dat) > 3) on.exit(opar) else {
opar2 <- opar[which(names(opar) %in% c("mar","mfrow"))]
on.exit(opar2)
}
if(debug) {message(fxNa,"plotPCAw_1") }
## remove rows with NAs
chRow <- rowSums(!chFin) # check for lines with non-finite values (avoid error during svd/pca ..)
if(any(chRow >0, na.rm=TRUE)) if(sum(chRow >0) ==nrow(dat)) stop("All lines have some non-finite values !?!") else {
if(!silent) message(fxNa,"Eliminating ",sum(chRow >0)," (out of ",nrow(dat),") lines with non-finite values")
dat <- dat[which(chRow <1),] }
## remove 0 variance rows
isZeroVar <- function(x) length(unique(wrMisc::naOmit(x)))==1
ch1 <- apply(dat, 1, isZeroVar)
if(any(ch1, na.rm=TRUE)) {
if(!silent) message(fxNa,"Eliminating ",sum(ch1)," (out of ",nrow(dat),") lines with 0 variance values (ie all values identical)")
dat <- dat[which(ch1),] }
averNa3 <- wrMisc::naOmit(sampleGrp)
if(suplFig && ncol(dat) > 3) graphics::layout(matrix(c(1,1:3,4,4),3,2,byrow=TRUE), heights=c(10,5,4))
if(!identical(ncol(dat),length(wrMisc::naOmit(sampleGrp))) && !silent) warning("'plotPCA': number of columns and number of (QC-filtered) arrays in 'AverNa2' don't match !")
nGrp <- length(levels(sampleGrp))
if(debug) {message(fxNa,"pPCAw2"); pCAw2 <- list(dat=dat,sampleGrp=sampleGrp,tit=tit,useSymb=useSymb,colBase=colBase,nGrp=nGrp,averNa3=averNa3,displBagPl=displBagPl,pointLabelPar=pointLabelPar,center=center, scale.=scale. )}
## custom colors : A) single color, B) all points specified, C) col of levels
if((length(pointLabelPar$pointCol) %in% c(1, length(averNa3))) && length(pointLabelPar$pointCol) !=0) {
useCol <- pointLabelPar$pointCol # use pointLabelPar$pointCol as length=1 (single color) OR fitting to number of samples
colBase <- unique(useCol)
if(debug) message(fxNa,"use pointLabelPar$pointCol as fitting to number of samples")
} else { if(length(pointLabelPar$pointCol) ==nGrp && length(pointLabelPar$pointCol) !=0) {
useCol <- pointLabelPar$pointCol[as.numeric(averNa3)] # use pointLabelPar$pointCol as fitting to number of groups
colBase <- unique(useCol)
if(debug) message(fxNa,"use pointLabelPar$pointCol as fitting to number of groups")
} else { if((length(colBase) %in% c(1, length(averNa3))) && length(colBase) !=0) {
useCol <- colBase # use colBase as length=1 OR fitting to number of samples
colBase <- unique(useCol)
if(debug) message(fxNa,"use colBase as fitting to number of samples")
} else { if(length(colBase) ==nGrp && length(colBase) !=0) {
useCol <- colBase[as.numeric(averNa3)] # use colBase as fitting to number of groups
if(debug) message(fxNa,"use colBase as fitting to number of groups")
} else {
## create default colors
chPa <- requireNamespace("RColorBrewer", quietly=TRUE)
if(debug) message(fxNa,"create default colors")
if(!silent && !chPa) message(fxNa,"Please consider installing package 'RColorBrewer' for improved color-palettes")
colBase <- if(chPa && nGrp <10) { RColorBrewer::brewer.pal(max(3, nGrp),"Set1")[1:nGrp]
} else {
grDevices::rainbow(1.5 +nGrp*1.08)[1:(nGrp+1)][-ceiling(length(levels(sampleGrp))/2)]
}
useCol <- colBase[as.numeric(averNa3)] # adjust to groups
} } } }
## useCol should be defined now !
chGr <- duplicated(sampleGrp)
if(!any(chGr, na.rm=TRUE)) { displBagPl <- FALSE; if(debug) message(fxNa,"All samples belong to different groups, bagplots won't make any sense ...")}
if(debug) {message(fxNa,"pPCAw3"); pCAw3 <- list(dat=dat,sampleGrp=sampleGrp,tit=tit,useSymb=useSymb,useCol=useCol,colBase=colBase,chGr=chGr,nGrp=nGrp,averNa3=averNa3,displBagPl=displBagPl,center=center, scale.=scale. )}
} #
## MAIN
if(length(dat >0)) { pca <- try(stats::prcomp(t(dat), center=center, scale.=scale.), silent=TRUE)
if(inherits(pca, "try-error")) {dat <- NULL; pca <- NULL}}
if(length(dat) >0) {
percVar <- 100*round(pca$sdev^2/sum(pca$sdev^2),3)
pca.grpMed <- pca.grpAv <- matrix(nrow=nGrp, ncol=min(4,ncol(pca$x)))
tabAverNa3 <- table(averNa3)
if(length(nGrpForMedian) >0) { for(i in 1:min(4,ncol(pca$x))) {
pca.grpMed[,i] <- unlist(tapply(pca$x[,i], averNa3, stats::median, na.rm=TRUE))
pca.grpAv[,i] <- unlist(tapply(pca$x[,i], averNa3, mean, na.rm=TRUE)) }
rownames(pca.grpMed) <- rownames(pca.grpAv) <- unique(averNa3)
pca.grpMed[names(tabAverNa3)[which(tabAverNa3 <nGrpForMedian)],] <- pca.grpAv[names(tabAverNa3)[which(tabAverNa3 < nGrpForMedian)],]}
if(debug) {message(fxNa,"pPCAw4 .. : ");
pPCAw4 <- list(dat=dat,sampleGrp=sampleGrp,averNa3=averNa3,pca=pca,pca.grpMed=pca.grpMed,displBagPl=displBagPl,center=center,scale.=scale.,tit=tit,cexTxt=cexTxt,useSymb=useSymb ) }
if(length(cexTxt) != 1 || !is.finite(cexTxt)) cexTxt <- graphics::par("cex.axis")
if(length(cexAxis) !=1 || !is.finite(cexAxis)) cexAxis <- cexTxt *0.65 # graphics::par("cex.axis")
if(length(cexMain) !=1 || !is.finite(cexMain)) cexMain <- if(ncol(dat) > 3) 1.4 else 0.85 # graphics::par("cex.main")
if(length(cexNames) !=1 || !is.finite(cexNames)) cexNames <- cexTxt *0.75 # graphics::par("cex.lab")
if(length(cexSub) != 1 || !is.finite(cexTxt)) cexSub <- graphics::par("cex.sub")
useCex <- round( (1/nGrp +0.65)*cexTxt, 2)
useSymb.ori <- rep(useSymb, 1 +length(levels(sampleGrp)) %/% length(useSymb)) [1:length(levels(sampleGrp))] #
useSymb <- (useSymb.ori[order(unique(as.numeric(averNa3)))] )[as.numeric(wrMisc::naOmit(sampleGrp))]
useTxtCol <- 1
figNumOffs <- function(pca, cols=c(1,2), fact=100) signif(c(abs(diff(range(pca$x[,cols[1]])))/fact, abs(diff(range(pca$x[,cols[2]])))/fact), digits=3)
outL <- list()
length(outL) <- length(unique(averNa3)); names(outL) <- unique(averNa3)
lab123 <- paste0("PC",1:3," (",percVar[1:3],"%)")
useTit <- if(is.null(tit)) "Principal Components of Samples" else tit
if(suplFig) useTit <- paste(useTit, if(nchar(useTit) < 35) ": 1st and 2nd Component" else ", PC1 & PC2")
## optional rotate axis
if(length(rotatePC) >0 && is.numeric(rotatePC)) {
chRo <- rotatePC >0 && rotatePC <= ncol(dat)
if(any(!rotatePC, na.rm=TRUE)) rotatePC <- rotatePC[which(rotatePC)]
if(length(rotatePC) >0) pca$x[,rotatePC] <- -1*pca$x[,rotatePC] }
if(debug) {message(fxNa,"pPCAw5 .. lab123: ",wrMisc::pasteC(lab123)); pPCAw5 <- list(dat=dat,sampleGrp=sampleGrp,averNa3=averNa3,pca=pca,useTit=useTit,cexTxt=cexTxt,showLegend=showLegend ) }
## start plot (1st & 2nd PC)
ch1 <- try(graphics::plot(pca$x[,c(1,2)], main=useTit, cex.axis=cexAxis, cex.lab=cexNames, cex.main=cexMain, xlab=lab123[1], ylab=lab123[2], las=1, type="n")) # empty plot
if(inherits(ch1, "try-error")) {dat <- NULL; message(fxNa,"UNABLE TO DRAW PLOT !! check current plotting device...")} }
if(length(dat) >0) {
## check for legend-location (if legend should be drawn)
if(is.character(showLegend) && length(showLegend)==1) {
chL <- showLegend %in% c("bottomleft","bottomright","topright","topleft")
if(!chL) showLegend <- TRUE
}
displLeg <- if(is.logical(showLegend)) {if(showLegend) checkForLegLoc(matr=pca$x, sampleGrp=sampleGrp, showLegend=showLegend, suplSpace=5.5, silent=silent,callFrom=callFrom) else list(FALSE)
} else { if(is.character(showLegend)) list(TRUE, showLegend) else list(FALSE)}
if(debug) {message(fxNa,"pCAw5b .. displLeg: ",displLeg); pCAw5b <- list(dat=dat,sampleGrp=sampleGrp,averNa3=averNa3,pca=pca,useTit=useTit,cexTxt=cexTxt,lab123=lab123,displLeg=displLeg,displBagPl=displBagPl,useCol=useCol ) }
if(displLeg[[1]] && showLegend) graphics::legend(displLeg[[2]], pch=useSymb.ori, col=colBase,
paste(1:length(levels(sampleGrp)),"..",substr(unique(averNa3),1,25)), text.col=colBase,
cex=cexTxt*max(0.4, round(0.75 -((length(unique(sampleGrp)) %/% 5)/31),3)), xjust=0.5, yjust=0.5)
graphics::points(pca$x[,c(1,2)], pch=useSymb, col=useCol, cex=if(length(pointLabelPar$pointCex) ==0) 0.8 else pointLabelPar$pointCex) # main plotting of points
if(debug) { message(fxNa,"pCAw6 .. displLeg: ",unlist(displLeg[1:2])); pCAw6 <- list(silent=silent, debug=debug, pca=pca,dat=dat, displLeg=displLeg) }
## prepare for labels on points
if(length(pointLabelPar) >0) {
chLe <- sapply(pointLabelPar, length) %in% c(1,ncol(dat))
if(any(!chLe, na.rm=TRUE) && !silent) message(fxNa,"Some elements of argument 'pointLabelPar' may have odd lengths, they might be discarded")
if(isTRUE(pointLabelPar)) .addTextToPoints(x=pca$x, cex=0.6*cexTxt, adj="auto", callFrom=fxNa, silent=silent,debug=debug) else {
if(!isFALSE(pointLabelPar) && length(pointLabelPar) >0) .addTextToPoints(x=pca$x[,1:2], paramLst=pointLabelPar, cex=0.6*cexTxt, adj="auto", callFrom=fxNa, silent=silent,debug=debug) }}
if(debug) {message(fxNa,"pCAw7 .. displBagPl=",displBagPl); pCAw7 <- list(dat=dat,sampleGrp=sampleGrp,pca=pca,colBase=colBase, useTit=useTit,cexTxt=cexTxt,lab123=lab123,showLegend=showLegend,displLeg=displLeg,
nGrp=nGrp,averNa3=averNa3,pointLabelPar=pointLabelPar,colBase=colBase,
outCoef=outCoef,useSymb2=useSymb2,nGrpForMedian=nGrpForMedian,nGrpLim=nGrpLim,displBagPl=displBagPl,pca.grpMed=pca.grpMed,figNumOffs=figNumOffs, callFrom=callFrom,fxNa=fxNa, silent=silent, debug=debug)}
## prepare for bagplot
for(i in 1:length(levels(sampleGrp))) {
## need to check if all labels are printed (or set to NULL)
if(debug) message(fxNa,"Setting alpha of useCol2 to ",if(max(table(sampleGrp)) > 2) signif(0.25 +0.95/nGrp, digits=3) else 0.1," ( since max(table(sampleGrp)) = ",max(table(sampleGrp)),")")
useCol2 <- grDevices::rgb(t(grDevices::col2rgb(colBase[order(as.numeric(unique(averNa3)))][i])/256),
alpha=if(max(table(sampleGrp)) > 2) signif(0.15 +0.25/nGrp, digits=3) else 0.18) # so far too light with signif(0.04 +0.25/nGrp, digits=3)
useCol3 <- grDevices::rgb(t(grDevices::col2rgb(colBase[order(as.numeric(unique(averNa3)))][i])/256),
alpha=if(max(table(sampleGrp)) > 2) min(0.9, signif(0.25 +0.95/nGrp, digits=3)) else 0.4) # for outlyer-labels
dispOut <- !(length(unlist(pointLabelPar)) ==0 && any(c("col","color","cex","ce") %in% names(pointLabelPar)) ) # if TRUE : it is OK to add (outlyer-) names via addBagPlot()
if(debug) {message(fxNa,"pCAw7b .. dispOut ",dispOut); pCAw7b <- list(dat=dat,sampleGrp=sampleGrp,pca=pca,colBase=colBase,useCol2=useCol2, useTit=useTit,cexTxt=cexTxt,lab123=lab123,showLegend=showLegend,displLeg=displLeg,
nGrp=nGrp,averNa3=averNa3,pointLabelPar=pointLabelPar,colBase=colBase,
outCoef=outCoef,useSymb2=useSymb2,nGrpForMedian=nGrpForMedian,nGrpLim=nGrpLim,displBagPl=displBagPl,dispOut=dispOut,pca.grpMed=pca.grpMed,figNumOffs=figNumOffs, callFrom=callFrom,fxNa=fxNa, silent=silent, debug=debug)}
## addSubTi
if(dispOut) { outlCex <- 0.6 } else { outlCex <- NULL} # set 'default' values in case addBagPlot gets to add names of outlyer-points
outli <- if(displBagPl) try(addBagPlot(pca$x[which(as.numeric(wrMisc::naOmit(sampleGrp)) %in% i), 1:2], bagCol=if(length(useCol2)==1) rep(useCol2,length(levels(useCol2))) else useCol2, bagCont=useCol2, outlCol=useCol3, outCoef=outCoef,
#ctrPch=useSymb2, returnOutL= isTRUE(pointLabelPar) && length(pointLabelPar) ==0, addSubTi=dispOut, callFrom=fxNa, silent=!debug, debug=debug), silent=TRUE) else NULL
ctrPch=useSymb2, returnOutL= TRUE, addSubTi=dispOut && length(pointLabelPar) <1, callFrom=fxNa, silent=!debug, debug=debug), silent=TRUE) else NULL
if(length(outli) >0) outL[[i]] <- outli }
if(debug) {message(fxNa,"pCAw7c ..",i," .. displBagPl=",displBagPl); pCAw7c <- list(dat=dat,sampleGrp=sampleGrp,pca=pca,nGrpLim=nGrpLim,nGrpForMedian=nGrpForMedian,pca.grpMed=pca.grpMed,displBagPl=displBagPl,cexTxt=cexTxt,useCex=useCex,useSymb2=useSymb2,useSymb=useSymb,useCol=useCol )}
if(length(nGrpForMedian) >0 && length(levels(sampleGrp)) < nGrpLim && !is.null(useSymb2)) { # display of group-center (number & )
cexCtr <- if(cexTxt <=1) useCex +0.2 else useCex
if(!displBagPl && any(duplicated(sampleGrp), na.rm=TRUE)) { # add group-centers for those where multiple replicates/points were drawn (if not drawn by addBagPot)
## which points have replicates ? set point not needed to draw as pch as NA
pch1 <- useSymb; col1 <- useCol # indiv points
if(debug) {message(fxNa,"plotPCAw_7d"); plotPCAw_7d <- list(dat=dat,sampleGrp=sampleGrp,pca=pca,nGrpLim=nGrpLim,pca.grpMed=pca.grpMed,pch1=pch1,displBagPl=displBagPl,useSymb2=useSymb2,useSymb=useSymb,useCol=useCol )}
if(!all(duplicated(sampleGrp))) pch1 <- rep(NA, length(pch1))
if(any(duplicated(sampleGrp), na.rm=TRUE)) pch1[ which(!duplicated(sampleGrp, fromLast=TRUE) & !duplicated(sampleGrp, fromLast=FALSE)) ] <- NA
graphics::points(pca.grpMed[,c(1,2)], col=useCol, pch=pch1, cex=1.7) # draw group-means as same color, but bigger symbol
}
if(!displBagPl) graphics::text(pca.grpMed[,c(1,2)] + 1.1*figNumOffs(pca, cols=c(1,2)), # group-center names
as.character(1:nGrp)[order(as.numeric(unique(averNa3)))], cex=cexCtr, font=2,col=1) }
if(debug) {message(fxNa,"plotPCAw_8") }
## subtitle
graphics::mtext(paste0("n=",nrow(dat)," ",rowTyName, " ; Samples shown as open symbols",
if(isTRUE(pointLabelPar)) ", color stars and black numbers for group-centers",
if(displBagPl) ", groups highlighted as bagplot"), cex=cexSub, line=0.25)
## add more plots to include 3rd PC
if(suplFig && ncol(dat) > 3) {
graphics::plot(pca$x[,c(2,3)], pch=useSymb, main="PCA : 2nd and 3rd Component", col=useCol, cex=0.6, cex.axis=0.6*cexTxt, cex.lab=cexNames*0.9, xlab=lab123[2], ylab=lab123[3], las=1 )
for(i in 1:length(unique(sampleGrp))) {
useCol2 <- grDevices::rgb(t(grDevices::col2rgb(colBase[order(as.numeric(unique(averNa3)))][i])/256), alpha=if(max(table(sampleGrp)) > 2) signif(0.04 +0.25/nGrp,digits=3) else 0.1)
if(displBagPl) try(addBagPlot(pca$x[as.numeric(averNa3) %in% i,c(2,3)], outCoef=outCoef, bagCol=useCol2, outlCol=useCol3, ctrPch=useSymb2, outlCex=outlCex,
addSubTi=dispOut || !isFALSE(pointLabelPar), returnOutL=FALSE, callFrom=fxNa, silent=!debug, debug=debug), silent=TRUE) }
if(length(nGrpForMedian) >0 && length(levels(sampleGrp)) < nGrpLim & !is.null(useSymb2)) {
graphics::points(pca.grpMed[,c(2,3)], col=colBase[order(as.numeric(unique(averNa3)))], pch=useSymb2, cex=1.1)
cexCtr2 <- if(cexTxt <=1) useCex -0.1 else useCex
if(!displBagPl) graphics::text(pca.grpMed[,c(2,3)]+ 1.7*figNumOffs(pca, cols=c(2,3)), as.character(1:nGrp)[order(as.numeric(unique(averNa3)))], cex=cexCtr2, col=1) }
graphics::plot(pca$x[,c(1,3)], pch=useSymb, main="PCA : 1st and 3rd Component", col=useCol, cex=0.6, cex.axis=0.6*cexTxt, cex.lab=cexNames*0.9, xlab=lab123[1], ylab=lab123[3],las=1 )
for(i in 1:length(unique(sampleGrp))) {
useCol2 <- grDevices::rgb(t(grDevices::col2rgb(colBase[order(as.numeric(unique(averNa3)))][i])/256), alpha=if(max(table(sampleGrp)) > 2) signif(0.04+0.25/nGrp,digits=3) else 0.1)
if(displBagPl) try(addBagPlot(pca$x[as.numeric(averNa3) %in% i,c(1,3)], outCoef=outCoef, bagCol=useCol2, outlCol=useCol3, ctrPch=useSymb2, outlCex=outlCex,
addSubTi=dispOut || !isFALSE(pointLabelPar), returnOutL=FALSE, callFrom=fxNa, silent=!debug, debug=debug), silent=TRUE) }
if(length(nGrpForMedian) >0 && length(levels(sampleGrp)) < nGrpLim & !is.null(useSymb2)) {
graphics::points(pca.grpMed[,c(1,3)],col=colBase[order(as.numeric(unique(averNa3)))], pch=useSymb2, cex=1.1)
if(!displBagPl) graphics::text(pca.grpMed[,c(1,3)] +1.7*figNumOffs(pca, cols=c(1,3)), as.character(1:nGrp)[order(as.numeric(unique(averNa3)))], cex=useCex-0.1, col=1) }
}
if(suplFig) { graphics::plot(pca, main="Screeplot on Variance Captured by the Principal Components", cex.main=cexMain, cex.axis=0.6*cexTxt )
graphics::mtext(at=(1.2*(1:length(pca$sdev)) -0.5)[1:min(10,ncol(dat))], as.character(1:length(pca$sdev))[1:min(10,ncol(dat))], cex=0.7, side=1) }
if(getOutL && !is.null(rownames(pca$x))) return(outL)
} else warning(fxNa,"OMIT plot ! Unable to calculate principal components !")
}
#' Add text to points on plot
#'
#' @description
#' This function allows to add custom text as lables to points on standard xy-plot.
#'
#' @param x (matrix, data.frame) coordinated of ponts on plot
#' @param paramLst (list) additional parameters for plotting (priority over separate cex or col), otherwise names displayed will be taken from 'labels' or rownames of coordinates 'x'
#' @param labels (character) the text to be displayed (has not priority over 'paramLst'), if nothing valid found numbers will be displayed
#' @param cex (character) (numeric) size of text, as expansion factor (see also \code{cex} in \code{\link[graphics]{par}})
#' @param col (character or integer) use custom colors
#' @param adj (character) values other than 0,0.5 or 1 will lead to 'auto' where text is displayed only to left of sufficient space available
#' @param silent (logical) suppress messages
#' @param debug (logical) display additional messages for debugging
#' @param callFrom (character) allow easier tracking of messages produced
#' @return This function make a plot and may retiurn an optional matrix of outlyer-data (depending on argument \code{getOutL})
#' @seealso \code{\link[stats]{prcomp}} (used here for the PCA underneith) , \code{\link[stats]{princomp}}, see the package \href{https://CRAN.R-project.org/package=FactoMineR}{FactoMineR} for multiple plotting options or ways of combining categorical and numeric data
#' @examples
#' set.seed(2019); dat1 <- matrix(round(runif(30),2), ncol=2)
#' plot(dat1) # traditional plot
#' .addTextToPoints(dat1, labels=letters[1:nrow(dat1)])
#' @export
.addTextToPoints <- function(x, paramLst=NULL, labels=NULL, cex=NULL, col=NULL, adj="auto", callFrom=NULL, silent=TRUE, debug=FALSE){
## add text at given position(s) to (scatter) plot (left top display), eg names describing points
## 'x' should be matrix or data.frame with numeric coordinates for plotting labels,
## paramLst may be list with additional parameters (priority over separate cex or col), otherwise names displayed will be taken from 'labels' or rownames of coordinates 'x'
## 'labels' .. for text to be displayed (has not priority over 'paramLst'), if nothing valid found numbers will be displayed
## 'adj' .. values other than 0,0.5 or 1 will lead to 'auto' where text is displayed only to left of sufficient space available
fxNa <- wrMisc::.composeCallName(callFrom, newNa=".addTextToPoints")
textCex <- textLabel <- textAdj <- textCol <- textOffSet <- NULL
if(length(dim(x)) !=2) message(fxNa," Trouble ahead, 'x' shound be matrix or data.frame of min 2 columns")
if(length(adj) >0) { if(is.list(paramLst) && "textAdj" %in% names(paramLst)) {textAdj <- paramLst$textAdj <- adj} else {textAdj <- list(textAdj=adj)} }
if(length(cex) >0) textCex <- cex
if(length(col) ==nrow(x) || length(col)==1) textCol <- col
textLabel <- if(length(labels) != length(x) ) names(x) else labels
if(debug) message(fxNa,"aTTP0")
if(length(paramLst) >0 && !is.list(paramLst)) paramLst <- as.list(paramLst)
if(is.list(paramLst) && length(paramLst) >0) {
textLabel <- if("labels" %in% names(paramLst)) paramLst$labels else {if(is.null(rownames(x))) 1:nrow(x) else rownames(x)}
if("textLabel" %in% names(paramLst)) textLabel <- paramLst$textLabel
if("col" %in% names(paramLst)) textCol <- paramLst$col
if("textCol" %in% names(paramLst)) textCol <- paramLst$textCol
if("cex" %in% names(paramLst)) textCex <- paramLst$cex
if("textCex" %in% names(paramLst)) textCex <- paramLst$textCex
if("offSet" %in% names(paramLst)) textOffSet <- paramLst$offSet
if("textOffSet" %in% names(paramLst)) textOffSet <- paramLst$textOffSet
if("adj" %in% names(paramLst)) textAdj <- paramLst$adj
if(is.null(names(paramLst)) & is.character(paramLst[[1]])) textLabel <- paramLst[[1]]
if("textAdj" %in% names(paramLst)) {
if(!any(c(0,0.5,1) %in% paramLst$textAdj, na.rm=TRUE)) {
strW <- graphics::strwidth(textLabel, cex=if("cex" %in% names(paramLst)) paramLst$cex else 1) + 0.2
chLe <- graphics::par("usr")[1] < x[,1] -strW
paramLst$textAdj <- 0 + chLe }
textAdj <- paramLst$textAdj }
} else {if(is.character(paramLst) && length(paramLst)==nrow(x)) textLabel <- paramLst}
if(debug) { message(fxNa,"aTTP1"); aTTP1 <- list(x=x,paramLst=paramLst,labels=labels,adj=adj,textAdj=textAdj,textOffSet=textOffSet,textLabel=textLabel,textCol=textCol,textCex=textCex)}
if(length(textLabel) != nrow(x)) textLabel <- rownames(x)
if(is.null(textLabel)) textLabel <- 1:nrow(x)
if(length(textCol) <1) textCol <- rep(grDevices::grey(0.8), nrow(x)) else if(length(textCol) ==1) textCol <- rep(textCol, nrow(x))
if(length(textAdj) <1) textAdj <- 1:nrow(x)
if(length(textOffSet) <1) {ra <- graphics::par("usr"); textOffSet <- c(2,-4)*signif((ra[c(2,4)] - ra[c(1,3)])/300,3) }
textOffSet <- matrix(rep(textOffSet, each=nrow(x)), ncol=2)
if(0 %in% textAdj) textOffSet[,1] <- textOffSet[,1]*(2*textAdj -1)
if(debug) { message(fxNa,"aTTP2"); aTTP2 <- list(x=x,paramLst=paramLst,labels=labels,adj=adj,textAdj=textAdj,textOffSet=textOffSet,textLabel=textLabel,textCol=textCol,textCex=textCex)}
if(length(unique(textAdj)) >1) {
for(i in unique(unlist(textAdj))) { j <- which(textAdj==i)
graphics::text(x[j, c(1,2)] -textOffSet[j,], labels=textLabel[j], col=textCol[j], cex=textCex, adj=i) }
} else { if(!silent) message(fxNa,"absent/short textAdj")
graphics::text(x[,c(1,2)] -textOffSet, labels=textLabel, col=textCol, cex=textCex, adj=if(grepl("^[[:digit:]]+(\\.[[:digit:]]+)$", textAdj)) textAdj else 1) }
}
Try the wrGraph package in your browser
Any scripts or data that you put into this service are public.
wrGraph documentation built on Sept. 3, 2026, 5:06 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .addTextToPoints plotPCAw
Documented in .addTextToPoints plotPCAw
#' PCA Plot With Bag-plot To Highlight Centers Of Groups
#'
#' @description
#' This function allows to plot \href{https://en.wikipedia.org/wiki/Principal_component_analysis}{principal components analysis (PCA)},
#' with options to show center and potential outliers for each of the groups (columns of data).
#' The main points of this implementation consist in offering bagplots to highlight groups of columns/samples and support to (object-oriented)
#' output from \href{https://bioconductor.org/packages/release/bioc/html/limma.html}{limma} and \href{https://CRAN.R-project.org/package=wrProteo}{wrProteo}.
#'
#' @details
#' One motivation for this implementation of plotting PCA was to provide a convenient way for doing so with of MArrayLM-objects or lists
#' as created by \href{https://bioconductor.org/packages/release/bioc/html/limma.html}{limma} and \href{https://CRAN.R-project.org/package=wrProteo}{wrProteo}.
#'
#' Another motivation for this implementation comes from integrating the idea of bag-plots to better visualize different groups of points
#' (if external knowledge allows organizing them as distinct groups) :
#' The main body of data is shown as 'bag-plots' (a bivariate boxplot, see \href{https://en.wikipedia.org/wiki/Bagplot}{Bagplot})
#' with different transparent colors to highlight the core part of different groups (if they contain more than 2 values per group).
#' Furthermore, group centers are shown as average or median (see 'nGrpForMedian') with stars & index-number (if <25 groups).
#'
#' If the data allow for at least 3 principal components, by default the plotting region will be devided in 3 parts:
#' The 1st part for 1st and 2nd principal components, the 2nd part for 2nd and 3rd principal components and the 3rd part to display the variability captured in each principal component.
#' Otherwise one may use \code{suplFig=FALSE} to restrict on only plotting the 1st and 2nd principal components.
#'
#' Note : This function uses \code{\link[stats]{prcomp}} for calculating Eigenvectors and principal components, with default \code{center=TRUE} and \code{scale.=FALSE} (different to \code{princomp()}. which standardizes by default).
#' This way the user has to option to intervene on arguments \code{center} and \code{scale.}. However, this should be done with care.
#'
#' Note: \code{NA}-values cannot (by definition) be processed by (any) PCA - all lines with any non-finite values/content (eg \code{NA}) will be omitted !
#'
#' Note : Package RColorBrewer may be used if available.
#'
#' For more options with PCA (and related methods) you may also see also the package \href{https://CRAN.R-project.org/package=FactoMineR}{FactoMineR}
#' which provides a very wide spectrum of possibiities, in particular for combined numeric and categorical data.
#'
#' @param dat (matrix, data.frame, MArrayLM-object or list) data to plot. Note: \code{NA}-values cannot be processed - all lines with non-finite data (eg \code{NA}) will be omitted !
#' In case of MArrayLM-object or list \code{dat} must conatain list-element named 'datImp','dat' or 'data'.
#' @param sampleGrp (character or factor) should be factor describing groups of replicates, NAs are not supported
#' @param tit (character) custom title
#' @param useSymb (integer) symbols to use (see also \code{\link[graphics]{par}})
#' @param center (logical or numeric) decide if variables should be shifted to be zero centered, argument passed to \code{\link[stats]{prcomp}}
#' @param scale. (logical or numeric) decide if scaling to obtain unit variance, argument passed to \code{\link[stats]{prcomp}}
#' Alternatively, a vector of length equal the number of columns of x can be supplied. The value is passed to scale.
#' @param colBase (character or integer) define custom colors (must be of length corresponding to number of columns from argument \code{dat})
#' @param useSymb2 (integer) symbol to mark group-center (no mark of group-center if default NULL) (equivalent to \code{pch}, see also \code{\link[graphics]{par}})
#' @param cexTxt (numeric) expansion factor for text (see also \code{\link[graphics]{par}})
#' @param cexSub (integer) expansion factor for subtitle line text (see also \code{\link[graphics]{par}})
#' @param cexAxis (numeric) size of numeric y-axis labels as cex-expansion factor (see also \code{\link[graphics]{par}})
#' @param cexNames (numeric) size of labels/values on axis as cex-expansion factor (see also \code{\link[graphics]{par}})
#' @param cexMain (numeric) size of title as cex-expansion factor (see also \code{\link[graphics]{par}})x
#' @param displBagPl (logical) if \code{TRUE}, show bagPlot (group-center) if >3 points per group otherwise the average-confidence-interval
#' @param outCoef (numeric) parameter for defining outliers, see \code{\link{addBagPlot}} (equivalent to \code{range} in \code{\link[graphics]{boxplot}})
#' @param getOutL (logical) return outlyer samples/values
#' @param showLegend (logical or character) toggle to display legend, if character it designes the location within the plot to display the legend ('bottomleft','topright', etc..)
#' @param nGrpForMedian (integer) decide if group center should be displayed via its average or median value: If group has less than 'nGrpForMedian' values, the average will be used, otherwise the median; if \code{NULL} no group centers will be displayed
#' @param pointLabelPar (character) define formatting for optional labels next to points in main figure (ie PC1 vs PC2); may be \code{TRUE} or list containing elments '$textLabel', '$textCol', '$textCex',
#' '$textOffSet', '$textAdj' for fine-tuning
#' may aslo be '$pointCex' and '$pointCol' for custom size of points
#' @param rowTyName (character) for subtitle : specify nature of rows (genes, proteins, probesets,...)
#' @param rotatePC (integer) optional rotation (by -1) for figure of the principal components specified by index
#' @param suplFig (logical) to include plots vs 3rd principal component (PC) and Screeplot
#' @param silent (logical) suppress messages
#' @param debug (logical) display additional messages for debugging
#' @param callFrom (character) allow easier tracking of messages produced
#' @return This function make a plot and may retiurn an optional matrix of outlyer-data (depending on argument \code{getOutL})
#' @seealso \code{\link[stats]{prcomp}} (used here for the PCA underneith) , \code{\link[stats]{princomp}}, see the package \href{https://CRAN.R-project.org/package=FactoMineR}{FactoMineR} for multiple plotting options or ways of combining categorical and numeric data
#' @examples
#' set.seed(2019); dat1 <- matrix(round(c(rnorm(1000), runif(1000,-0.9,0.9)),2),
#' ncol=20, byrow=TRUE) + matrix(rep(rep(1:5,6:2), each=100), ncol=20)
#' biplot(prcomp(dat1)) # traditional plot
#' (grp = factor(rep(LETTERS[5:1], 6:2)))
#' plotPCAw(dat1, grp)
#' ## with some custom settings
#' plotPCAw(dat1, grp, pointLabelPar=list(textCex=0.7, textCol=2, pointCex=2), suplFig=FALSE)
#' @export
plotPCAw <- function(dat, sampleGrp, tit=NULL, useSymb=c(21:25,9:12,3:4), center=TRUE, scale.=TRUE, useSymb2=NULL, colBase=NULL,
cexTxt=1, cexSub=0.6, cexAxis=NULL, cexNames=NULL, cexMain=NULL, displBagPl=TRUE, outCoef=2, getOutL=FALSE, showLegend=TRUE,
nGrpForMedian=6, pointLabelPar=NULL, rowTyName="genes", rotatePC=NULL, suplFig=TRUE, callFrom=NULL, silent=TRUE, debug=FALSE) {
## note : so far not well adopted for plotting all points in transparent grey with same symb for interactive mouse-over
fxNa <- wrMisc::.composeCallName(callFrom, newNa="plotPCAw")
msg <- " 'dat' must be matrix, data.frame (with at least 1 line and 2 columns) or list/MArrayLM-object (with element 'datImp','dat' or 'data' as matrix or data.frame)"
if(!isTRUE(silent)) silent <- FALSE
if(isTRUE(debug)) silent <- FALSE else debug <- FALSE
#colBase <- NULL
if("MArrayLM" %in% class(dat) || is.list(dat)) {
## check which list-element may contain abundance data (prefer $datImp is avail)
chDat <- c("datImp","dat","data","quant","datRaw") %in% names(dat)
chGr <- c("groups","grp","sampleGroups") %in% names(dat)
if(any(chGr, na.rm=TRUE) && length(sampleGrp) <1) {
chGrpNa <- c("groups","grp","sampleGroups")
sampleGrp <- dat[[which(names(dat) %in% chGrpNa)[1]]]
} else if("sampleSetup" %in% names(dat)) if(any(chGrpNa %in% names(dat$sampleSetup), na.rm=TRUE)) {
sampleGrp <- dat$sampleSetup[[ which(chGrpNa %in% names(dat$sampleSetup))[1]]] }
if(any(chDat, na.rm=TRUE)) dat <- dat[[which(names(dat) %in% c("datImp","dat","data","datRaw"))[1]]] else stop(msg) }
if(any(length(dim(dat)) !=2, dim(dat) < 1:2, na.rm=TRUE)) stop(msg)
if(length(sampleGrp) <1 || sum(is.na(sampleGrp))==length(sampleGrp)) stop("Argument 'sampleGrp' seems to be empty (or all NA)")
if(length(sampleGrp) != ncol(dat)) stop(fxNa,"Length of argument 'sampleGrp' must match number of columns of 'dat'")
if(!is.factor(sampleGrp)) sampleGrp <- as.factor(sampleGrp)
if(!isFALSE(center)) center <- TRUE
if(!isFALSE(scale.)) scale. <- TRUE
if(!isFALSE(suplFig)) suplFig <- TRUE
nGrpLim <- 25 # decide/limit if group-centers are shown as stars
## reduce to columns defined by 'sampleGrp' (groups declared as NA will be removed) and to columns with finite data
if(length(dat) >0) {
dat <- dat[,!is.na(sampleGrp)]
chFin <- is.finite(dat)
chCol <- colSums(chFin) <2
if(sum(chCol) >0) {
dimIni <- dim(dat)
if(!silent) message(fxNa,"Removing ",sum(chCol)," (out of ",ncol(dat),") columns with less than 2 finite values")
dat <- dat[,which(!chCol)]
chFin <- chFin[,which(!chCol)]
if(ncol(dat) <2) stop("After removing bad (non-finite) columns less than 2 columns remain !")
sampleGrp <- sampleGrp[which(!chCol)]
if(length(useSymb) == dimIni[2]) useSymb <- useSymb[which(!chCol)] }
opar <- graphics::par(no.readonly=TRUE)
if(suplFig && ncol(dat) > 3) on.exit(opar) else {
opar2 <- opar[which(names(opar) %in% c("mar","mfrow"))]
on.exit(opar2)
}
if(debug) {message(fxNa,"plotPCAw_1") }
## remove rows with NAs
chRow <- rowSums(!chFin) # check for lines with non-finite values (avoid error during svd/pca ..)
if(any(chRow >0, na.rm=TRUE)) if(sum(chRow >0) ==nrow(dat)) stop("All lines have some non-finite values !?!") else {
if(!silent) message(fxNa,"Eliminating ",sum(chRow >0)," (out of ",nrow(dat),") lines with non-finite values")
dat <- dat[which(chRow <1),] }
## remove 0 variance rows
isZeroVar <- function(x) length(unique(wrMisc::naOmit(x)))==1
ch1 <- apply(dat, 1, isZeroVar)
if(any(ch1, na.rm=TRUE)) {
if(!silent) message(fxNa,"Eliminating ",sum(ch1)," (out of ",nrow(dat),") lines with 0 variance values (ie all values identical)")
dat <- dat[which(ch1),] }
averNa3 <- wrMisc::naOmit(sampleGrp)
if(suplFig && ncol(dat) > 3) graphics::layout(matrix(c(1,1:3,4,4),3,2,byrow=TRUE), heights=c(10,5,4))
if(!identical(ncol(dat),length(wrMisc::naOmit(sampleGrp))) && !silent) warning("'plotPCA': number of columns and number of (QC-filtered) arrays in 'AverNa2' don't match !")
nGrp <- length(levels(sampleGrp))
if(debug) {message(fxNa,"pPCAw2"); pCAw2 <- list(dat=dat,sampleGrp=sampleGrp,tit=tit,useSymb=useSymb,colBase=colBase,nGrp=nGrp,averNa3=averNa3,displBagPl=displBagPl,pointLabelPar=pointLabelPar,center=center, scale.=scale. )}
## custom colors : A) single color, B) all points specified, C) col of levels
if((length(pointLabelPar$pointCol) %in% c(1, length(averNa3))) && length(pointLabelPar$pointCol) !=0) {
useCol <- pointLabelPar$pointCol # use pointLabelPar$pointCol as length=1 (single color) OR fitting to number of samples
colBase <- unique(useCol)
if(debug) message(fxNa,"use pointLabelPar$pointCol as fitting to number of samples")
} else { if(length(pointLabelPar$pointCol) ==nGrp && length(pointLabelPar$pointCol) !=0) {
useCol <- pointLabelPar$pointCol[as.numeric(averNa3)] # use pointLabelPar$pointCol as fitting to number of groups
colBase <- unique(useCol)
if(debug) message(fxNa,"use pointLabelPar$pointCol as fitting to number of groups")
} else { if((length(colBase) %in% c(1, length(averNa3))) && length(colBase) !=0) {
useCol <- colBase # use colBase as length=1 OR fitting to number of samples
colBase <- unique(useCol)
if(debug) message(fxNa,"use colBase as fitting to number of samples")
} else { if(length(colBase) ==nGrp && length(colBase) !=0) {
useCol <- colBase[as.numeric(averNa3)] # use colBase as fitting to number of groups
if(debug) message(fxNa,"use colBase as fitting to number of groups")
} else {
## create default colors
chPa <- requireNamespace("RColorBrewer", quietly=TRUE)
if(debug) message(fxNa,"create default colors")
if(!silent && !chPa) message(fxNa,"Please consider installing package 'RColorBrewer' for improved color-palettes")
colBase <- if(chPa && nGrp <10) { RColorBrewer::brewer.pal(max(3, nGrp),"Set1")[1:nGrp]
} else {
grDevices::rainbow(1.5 +nGrp*1.08)[1:(nGrp+1)][-ceiling(length(levels(sampleGrp))/2)]
}
useCol <- colBase[as.numeric(averNa3)] # adjust to groups
} } } }
## useCol should be defined now !
chGr <- duplicated(sampleGrp)
if(!any(chGr, na.rm=TRUE)) { displBagPl <- FALSE; if(debug) message(fxNa,"All samples belong to different groups, bagplots won't make any sense ...")}
if(debug) {message(fxNa,"pPCAw3"); pCAw3 <- list(dat=dat,sampleGrp=sampleGrp,tit=tit,useSymb=useSymb,useCol=useCol,colBase=colBase,chGr=chGr,nGrp=nGrp,averNa3=averNa3,displBagPl=displBagPl,center=center, scale.=scale. )}
} #
## MAIN
if(length(dat >0)) { pca <- try(stats::prcomp(t(dat), center=center, scale.=scale.), silent=TRUE)
if(inherits(pca, "try-error")) {dat <- NULL; pca <- NULL}}
if(length(dat) >0) {
percVar <- 100*round(pca$sdev^2/sum(pca$sdev^2),3)
pca.grpMed <- pca.grpAv <- matrix(nrow=nGrp, ncol=min(4,ncol(pca$x)))
tabAverNa3 <- table(averNa3)
if(length(nGrpForMedian) >0) { for(i in 1:min(4,ncol(pca$x))) {
pca.grpMed[,i] <- unlist(tapply(pca$x[,i], averNa3, stats::median, na.rm=TRUE))
pca.grpAv[,i] <- unlist(tapply(pca$x[,i], averNa3, mean, na.rm=TRUE)) }
rownames(pca.grpMed) <- rownames(pca.grpAv) <- unique(averNa3)
pca.grpMed[names(tabAverNa3)[which(tabAverNa3 <nGrpForMedian)],] <- pca.grpAv[names(tabAverNa3)[which(tabAverNa3 < nGrpForMedian)],]}
if(debug) {message(fxNa,"pPCAw4 .. : ");
pPCAw4 <- list(dat=dat,sampleGrp=sampleGrp,averNa3=averNa3,pca=pca,pca.grpMed=pca.grpMed,displBagPl=displBagPl,center=center,scale.=scale.,tit=tit,cexTxt=cexTxt,useSymb=useSymb ) }
if(length(cexTxt) != 1 || !is.finite(cexTxt)) cexTxt <- graphics::par("cex.axis")
if(length(cexAxis) !=1 || !is.finite(cexAxis)) cexAxis <- cexTxt *0.65 # graphics::par("cex.axis")
if(length(cexMain) !=1 || !is.finite(cexMain)) cexMain <- if(ncol(dat) > 3) 1.4 else 0.85 # graphics::par("cex.main")
if(length(cexNames) !=1 || !is.finite(cexNames)) cexNames <- cexTxt *0.75 # graphics::par("cex.lab")
if(length(cexSub) != 1 || !is.finite(cexTxt)) cexSub <- graphics::par("cex.sub")
useCex <- round( (1/nGrp +0.65)*cexTxt, 2)
useSymb.ori <- rep(useSymb, 1 +length(levels(sampleGrp)) %/% length(useSymb)) [1:length(levels(sampleGrp))] #
useSymb <- (useSymb.ori[order(unique(as.numeric(averNa3)))] )[as.numeric(wrMisc::naOmit(sampleGrp))]
useTxtCol <- 1
figNumOffs <- function(pca, cols=c(1,2), fact=100) signif(c(abs(diff(range(pca$x[,cols[1]])))/fact, abs(diff(range(pca$x[,cols[2]])))/fact), digits=3)
outL <- list()
length(outL) <- length(unique(averNa3)); names(outL) <- unique(averNa3)
lab123 <- paste0("PC",1:3," (",percVar[1:3],"%)")
useTit <- if(is.null(tit)) "Principal Components of Samples" else tit
if(suplFig) useTit <- paste(useTit, if(nchar(useTit) < 35) ": 1st and 2nd Component" else ", PC1 & PC2")
## optional rotate axis
if(length(rotatePC) >0 && is.numeric(rotatePC)) {
chRo <- rotatePC >0 && rotatePC <= ncol(dat)
if(any(!rotatePC, na.rm=TRUE)) rotatePC <- rotatePC[which(rotatePC)]
if(length(rotatePC) >0) pca$x[,rotatePC] <- -1*pca$x[,rotatePC] }
if(debug) {message(fxNa,"pPCAw5 .. lab123: ",wrMisc::pasteC(lab123)); pPCAw5 <- list(dat=dat,sampleGrp=sampleGrp,averNa3=averNa3,pca=pca,useTit=useTit,cexTxt=cexTxt,showLegend=showLegend ) }
## start plot (1st & 2nd PC)
ch1 <- try(graphics::plot(pca$x[,c(1,2)], main=useTit, cex.axis=cexAxis, cex.lab=cexNames, cex.main=cexMain, xlab=lab123[1], ylab=lab123[2], las=1, type="n")) # empty plot
if(inherits(ch1, "try-error")) {dat <- NULL; message(fxNa,"UNABLE TO DRAW PLOT !! check current plotting device...")} }
if(length(dat) >0) {
## check for legend-location (if legend should be drawn)
if(is.character(showLegend) && length(showLegend)==1) {
chL <- showLegend %in% c("bottomleft","bottomright","topright","topleft")
if(!chL) showLegend <- TRUE
}
displLeg <- if(is.logical(showLegend)) {if(showLegend) checkForLegLoc(matr=pca$x, sampleGrp=sampleGrp, showLegend=showLegend, suplSpace=5.5, silent=silent,callFrom=callFrom) else list(FALSE)
} else { if(is.character(showLegend)) list(TRUE, showLegend) else list(FALSE)}
if(debug) {message(fxNa,"pCAw5b .. displLeg: ",displLeg); pCAw5b <- list(dat=dat,sampleGrp=sampleGrp,averNa3=averNa3,pca=pca,useTit=useTit,cexTxt=cexTxt,lab123=lab123,displLeg=displLeg,displBagPl=displBagPl,useCol=useCol ) }
if(displLeg[[1]] && showLegend) graphics::legend(displLeg[[2]], pch=useSymb.ori, col=colBase,
paste(1:length(levels(sampleGrp)),"..",substr(unique(averNa3),1,25)), text.col=colBase,
cex=cexTxt*max(0.4, round(0.75 -((length(unique(sampleGrp)) %/% 5)/31),3)), xjust=0.5, yjust=0.5)
graphics::points(pca$x[,c(1,2)], pch=useSymb, col=useCol, cex=if(length(pointLabelPar$pointCex) ==0) 0.8 else pointLabelPar$pointCex) # main plotting of points
if(debug) { message(fxNa,"pCAw6 .. displLeg: ",unlist(displLeg[1:2])); pCAw6 <- list(silent=silent, debug=debug, pca=pca,dat=dat, displLeg=displLeg) }
## prepare for labels on points
if(length(pointLabelPar) >0) {
chLe <- sapply(pointLabelPar, length) %in% c(1,ncol(dat))
if(any(!chLe, na.rm=TRUE) && !silent) message(fxNa,"Some elements of argument 'pointLabelPar' may have odd lengths, they might be discarded")
if(isTRUE(pointLabelPar)) .addTextToPoints(x=pca$x, cex=0.6*cexTxt, adj="auto", callFrom=fxNa, silent=silent,debug=debug) else {
if(!isFALSE(pointLabelPar) && length(pointLabelPar) >0) .addTextToPoints(x=pca$x[,1:2], paramLst=pointLabelPar, cex=0.6*cexTxt, adj="auto", callFrom=fxNa, silent=silent,debug=debug) }}
if(debug) {message(fxNa,"pCAw7 .. displBagPl=",displBagPl); pCAw7 <- list(dat=dat,sampleGrp=sampleGrp,pca=pca,colBase=colBase, useTit=useTit,cexTxt=cexTxt,lab123=lab123,showLegend=showLegend,displLeg=displLeg,
nGrp=nGrp,averNa3=averNa3,pointLabelPar=pointLabelPar,colBase=colBase,
outCoef=outCoef,useSymb2=useSymb2,nGrpForMedian=nGrpForMedian,nGrpLim=nGrpLim,displBagPl=displBagPl,pca.grpMed=pca.grpMed,figNumOffs=figNumOffs, callFrom=callFrom,fxNa=fxNa, silent=silent, debug=debug)}
## prepare for bagplot
for(i in 1:length(levels(sampleGrp))) {
## need to check if all labels are printed (or set to NULL)
if(debug) message(fxNa,"Setting alpha of useCol2 to ",if(max(table(sampleGrp)) > 2) signif(0.25 +0.95/nGrp, digits=3) else 0.1," ( since max(table(sampleGrp)) = ",max(table(sampleGrp)),")")
useCol2 <- grDevices::rgb(t(grDevices::col2rgb(colBase[order(as.numeric(unique(averNa3)))][i])/256),
alpha=if(max(table(sampleGrp)) > 2) signif(0.15 +0.25/nGrp, digits=3) else 0.18) # so far too light with signif(0.04 +0.25/nGrp, digits=3)
useCol3 <- grDevices::rgb(t(grDevices::col2rgb(colBase[order(as.numeric(unique(averNa3)))][i])/256),
alpha=if(max(table(sampleGrp)) > 2) min(0.9, signif(0.25 +0.95/nGrp, digits=3)) else 0.4) # for outlyer-labels
dispOut <- !(length(unlist(pointLabelPar)) ==0 && any(c("col","color","cex","ce") %in% names(pointLabelPar)) ) # if TRUE : it is OK to add (outlyer-) names via addBagPlot()
if(debug) {message(fxNa,"pCAw7b .. dispOut ",dispOut); pCAw7b <- list(dat=dat,sampleGrp=sampleGrp,pca=pca,colBase=colBase,useCol2=useCol2, useTit=useTit,cexTxt=cexTxt,lab123=lab123,showLegend=showLegend,displLeg=displLeg,
nGrp=nGrp,averNa3=averNa3,pointLabelPar=pointLabelPar,colBase=colBase,
outCoef=outCoef,useSymb2=useSymb2,nGrpForMedian=nGrpForMedian,nGrpLim=nGrpLim,displBagPl=displBagPl,dispOut=dispOut,pca.grpMed=pca.grpMed,figNumOffs=figNumOffs, callFrom=callFrom,fxNa=fxNa, silent=silent, debug=debug)}
## addSubTi
if(dispOut) { outlCex <- 0.6 } else { outlCex <- NULL} # set 'default' values in case addBagPlot gets to add names of outlyer-points
outli <- if(displBagPl) try(addBagPlot(pca$x[which(as.numeric(wrMisc::naOmit(sampleGrp)) %in% i), 1:2], bagCol=if(length(useCol2)==1) rep(useCol2,length(levels(useCol2))) else useCol2, bagCont=useCol2, outlCol=useCol3, outCoef=outCoef,
#ctrPch=useSymb2, returnOutL= isTRUE(pointLabelPar) && length(pointLabelPar) ==0, addSubTi=dispOut, callFrom=fxNa, silent=!debug, debug=debug), silent=TRUE) else NULL
ctrPch=useSymb2, returnOutL= TRUE, addSubTi=dispOut && length(pointLabelPar) <1, callFrom=fxNa, silent=!debug, debug=debug), silent=TRUE) else NULL
if(length(outli) >0) outL[[i]] <- outli }
if(debug) {message(fxNa,"pCAw7c ..",i," .. displBagPl=",displBagPl); pCAw7c <- list(dat=dat,sampleGrp=sampleGrp,pca=pca,nGrpLim=nGrpLim,nGrpForMedian=nGrpForMedian,pca.grpMed=pca.grpMed,displBagPl=displBagPl,cexTxt=cexTxt,useCex=useCex,useSymb2=useSymb2,useSymb=useSymb,useCol=useCol )}
if(length(nGrpForMedian) >0 && length(levels(sampleGrp)) < nGrpLim && !is.null(useSymb2)) { # display of group-center (number & )
cexCtr <- if(cexTxt <=1) useCex +0.2 else useCex
if(!displBagPl && any(duplicated(sampleGrp), na.rm=TRUE)) { # add group-centers for those where multiple replicates/points were drawn (if not drawn by addBagPot)
## which points have replicates ? set point not needed to draw as pch as NA
pch1 <- useSymb; col1 <- useCol # indiv points
if(debug) {message(fxNa,"plotPCAw_7d"); plotPCAw_7d <- list(dat=dat,sampleGrp=sampleGrp,pca=pca,nGrpLim=nGrpLim,pca.grpMed=pca.grpMed,pch1=pch1,displBagPl=displBagPl,useSymb2=useSymb2,useSymb=useSymb,useCol=useCol )}
if(!all(duplicated(sampleGrp))) pch1 <- rep(NA, length(pch1))
if(any(duplicated(sampleGrp), na.rm=TRUE)) pch1[ which(!duplicated(sampleGrp, fromLast=TRUE) & !duplicated(sampleGrp, fromLast=FALSE)) ] <- NA
graphics::points(pca.grpMed[,c(1,2)], col=useCol, pch=pch1, cex=1.7) # draw group-means as same color, but bigger symbol
}
if(!displBagPl) graphics::text(pca.grpMed[,c(1,2)] + 1.1*figNumOffs(pca, cols=c(1,2)), # group-center names
as.character(1:nGrp)[order(as.numeric(unique(averNa3)))], cex=cexCtr, font=2,col=1) }
if(debug) {message(fxNa,"plotPCAw_8") }
## subtitle
graphics::mtext(paste0("n=",nrow(dat)," ",rowTyName, " ; Samples shown as open symbols",
if(isTRUE(pointLabelPar)) ", color stars and black numbers for group-centers",
if(displBagPl) ", groups highlighted as bagplot"), cex=cexSub, line=0.25)
## add more plots to include 3rd PC
if(suplFig && ncol(dat) > 3) {
graphics::plot(pca$x[,c(2,3)], pch=useSymb, main="PCA : 2nd and 3rd Component", col=useCol, cex=0.6, cex.axis=0.6*cexTxt, cex.lab=cexNames*0.9, xlab=lab123[2], ylab=lab123[3], las=1 )
for(i in 1:length(unique(sampleGrp))) {
useCol2 <- grDevices::rgb(t(grDevices::col2rgb(colBase[order(as.numeric(unique(averNa3)))][i])/256), alpha=if(max(table(sampleGrp)) > 2) signif(0.04 +0.25/nGrp,digits=3) else 0.1)
if(displBagPl) try(addBagPlot(pca$x[as.numeric(averNa3) %in% i,c(2,3)], outCoef=outCoef, bagCol=useCol2, outlCol=useCol3, ctrPch=useSymb2, outlCex=outlCex,
addSubTi=dispOut || !isFALSE(pointLabelPar), returnOutL=FALSE, callFrom=fxNa, silent=!debug, debug=debug), silent=TRUE) }
if(length(nGrpForMedian) >0 && length(levels(sampleGrp)) < nGrpLim & !is.null(useSymb2)) {
graphics::points(pca.grpMed[,c(2,3)], col=colBase[order(as.numeric(unique(averNa3)))], pch=useSymb2, cex=1.1)
cexCtr2 <- if(cexTxt <=1) useCex -0.1 else useCex
if(!displBagPl) graphics::text(pca.grpMed[,c(2,3)]+ 1.7*figNumOffs(pca, cols=c(2,3)), as.character(1:nGrp)[order(as.numeric(unique(averNa3)))], cex=cexCtr2, col=1) }
graphics::plot(pca$x[,c(1,3)], pch=useSymb, main="PCA : 1st and 3rd Component", col=useCol, cex=0.6, cex.axis=0.6*cexTxt, cex.lab=cexNames*0.9, xlab=lab123[1], ylab=lab123[3],las=1 )
for(i in 1:length(unique(sampleGrp))) {
useCol2 <- grDevices::rgb(t(grDevices::col2rgb(colBase[order(as.numeric(unique(averNa3)))][i])/256), alpha=if(max(table(sampleGrp)) > 2) signif(0.04+0.25/nGrp,digits=3) else 0.1)
if(displBagPl) try(addBagPlot(pca$x[as.numeric(averNa3) %in% i,c(1,3)], outCoef=outCoef, bagCol=useCol2, outlCol=useCol3, ctrPch=useSymb2, outlCex=outlCex,
addSubTi=dispOut || !isFALSE(pointLabelPar), returnOutL=FALSE, callFrom=fxNa, silent=!debug, debug=debug), silent=TRUE) }
if(length(nGrpForMedian) >0 && length(levels(sampleGrp)) < nGrpLim & !is.null(useSymb2)) {
graphics::points(pca.grpMed[,c(1,3)],col=colBase[order(as.numeric(unique(averNa3)))], pch=useSymb2, cex=1.1)
if(!displBagPl) graphics::text(pca.grpMed[,c(1,3)] +1.7*figNumOffs(pca, cols=c(1,3)), as.character(1:nGrp)[order(as.numeric(unique(averNa3)))], cex=useCex-0.1, col=1) }
}
if(suplFig) { graphics::plot(pca, main="Screeplot on Variance Captured by the Principal Components", cex.main=cexMain, cex.axis=0.6*cexTxt )
graphics::mtext(at=(1.2*(1:length(pca$sdev)) -0.5)[1:min(10,ncol(dat))], as.character(1:length(pca$sdev))[1:min(10,ncol(dat))], cex=0.7, side=1) }
if(getOutL && !is.null(rownames(pca$x))) return(outL)
} else warning(fxNa,"OMIT plot ! Unable to calculate principal components !")
}
#' Add text to points on plot
#'
#' @description
#' This function allows to add custom text as lables to points on standard xy-plot.
#'
#' @param x (matrix, data.frame) coordinated of ponts on plot
#' @param paramLst (list) additional parameters for plotting (priority over separate cex or col), otherwise names displayed will be taken from 'labels' or rownames of coordinates 'x'
#' @param labels (character) the text to be displayed (has not priority over 'paramLst'), if nothing valid found numbers will be displayed
#' @param cex (character) (numeric) size of text, as expansion factor (see also \code{cex} in \code{\link[graphics]{par}})
#' @param col (character or integer) use custom colors
#' @param adj (character) values other than 0,0.5 or 1 will lead to 'auto' where text is displayed only to left of sufficient space available
#' @param silent (logical) suppress messages
#' @param debug (logical) display additional messages for debugging
#' @param callFrom (character) allow easier tracking of messages produced
#' @return This function make a plot and may retiurn an optional matrix of outlyer-data (depending on argument \code{getOutL})
#' @seealso \code{\link[stats]{prcomp}} (used here for the PCA underneith) , \code{\link[stats]{princomp}}, see the package \href{https://CRAN.R-project.org/package=FactoMineR}{FactoMineR} for multiple plotting options or ways of combining categorical and numeric data
#' @examples
#' set.seed(2019); dat1 <- matrix(round(runif(30),2), ncol=2)
#' plot(dat1) # traditional plot
#' .addTextToPoints(dat1, labels=letters[1:nrow(dat1)])
#' @export
.addTextToPoints <- function(x, paramLst=NULL, labels=NULL, cex=NULL, col=NULL, adj="auto", callFrom=NULL, silent=TRUE, debug=FALSE){
## add text at given position(s) to (scatter) plot (left top display), eg names describing points
## 'x' should be matrix or data.frame with numeric coordinates for plotting labels,
## paramLst may be list with additional parameters (priority over separate cex or col), otherwise names displayed will be taken from 'labels' or rownames of coordinates 'x'
## 'labels' .. for text to be displayed (has not priority over 'paramLst'), if nothing valid found numbers will be displayed
## 'adj' .. values other than 0,0.5 or 1 will lead to 'auto' where text is displayed only to left of sufficient space available
fxNa <- wrMisc::.composeCallName(callFrom, newNa=".addTextToPoints")
textCex <- textLabel <- textAdj <- textCol <- textOffSet <- NULL
if(length(dim(x)) !=2) message(fxNa," Trouble ahead, 'x' shound be matrix or data.frame of min 2 columns")
if(length(adj) >0) { if(is.list(paramLst) && "textAdj" %in% names(paramLst)) {textAdj <- paramLst$textAdj <- adj} else {textAdj <- list(textAdj=adj)} }
if(length(cex) >0) textCex <- cex
if(length(col) ==nrow(x) || length(col)==1) textCol <- col
textLabel <- if(length(labels) != length(x) ) names(x) else labels
if(debug) message(fxNa,"aTTP0")
if(length(paramLst) >0 && !is.list(paramLst)) paramLst <- as.list(paramLst)
if(is.list(paramLst) && length(paramLst) >0) {
textLabel <- if("labels" %in% names(paramLst)) paramLst$labels else {if(is.null(rownames(x))) 1:nrow(x) else rownames(x)}
if("textLabel" %in% names(paramLst)) textLabel <- paramLst$textLabel
if("col" %in% names(paramLst)) textCol <- paramLst$col
if("textCol" %in% names(paramLst)) textCol <- paramLst$textCol
if("cex" %in% names(paramLst)) textCex <- paramLst$cex
if("textCex" %in% names(paramLst)) textCex <- paramLst$textCex
if("offSet" %in% names(paramLst)) textOffSet <- paramLst$offSet
if("textOffSet" %in% names(paramLst)) textOffSet <- paramLst$textOffSet
if("adj" %in% names(paramLst)) textAdj <- paramLst$adj
if(is.null(names(paramLst)) & is.character(paramLst[[1]])) textLabel <- paramLst[[1]]
if("textAdj" %in% names(paramLst)) {
if(!any(c(0,0.5,1) %in% paramLst$textAdj, na.rm=TRUE)) {
strW <- graphics::strwidth(textLabel, cex=if("cex" %in% names(paramLst)) paramLst$cex else 1) + 0.2
chLe <- graphics::par("usr")[1] < x[,1] -strW
paramLst$textAdj <- 0 + chLe }
textAdj <- paramLst$textAdj }
} else {if(is.character(paramLst) && length(paramLst)==nrow(x)) textLabel <- paramLst}
if(debug) { message(fxNa,"aTTP1"); aTTP1 <- list(x=x,paramLst=paramLst,labels=labels,adj=adj,textAdj=textAdj,textOffSet=textOffSet,textLabel=textLabel,textCol=textCol,textCex=textCex)}
if(length(textLabel) != nrow(x)) textLabel <- rownames(x)
if(is.null(textLabel)) textLabel <- 1:nrow(x)
if(length(textCol) <1) textCol <- rep(grDevices::grey(0.8), nrow(x)) else if(length(textCol) ==1) textCol <- rep(textCol, nrow(x))
if(length(textAdj) <1) textAdj <- 1:nrow(x)
if(length(textOffSet) <1) {ra <- graphics::par("usr"); textOffSet <- c(2,-4)*signif((ra[c(2,4)] - ra[c(1,3)])/300,3) }
textOffSet <- matrix(rep(textOffSet, each=nrow(x)), ncol=2)
if(0 %in% textAdj) textOffSet[,1] <- textOffSet[,1]*(2*textAdj -1)
if(debug) { message(fxNa,"aTTP2"); aTTP2 <- list(x=x,paramLst=paramLst,labels=labels,adj=adj,textAdj=textAdj,textOffSet=textOffSet,textLabel=textLabel,textCol=textCol,textCex=textCex)}
if(length(unique(textAdj)) >1) {
for(i in unique(unlist(textAdj))) { j <- which(textAdj==i)
graphics::text(x[j, c(1,2)] -textOffSet[j,], labels=textLabel[j], col=textCol[j], cex=textCex, adj=i) }
} else { if(!silent) message(fxNa,"absent/short textAdj")
graphics::text(x[,c(1,2)] -textOffSet, labels=textLabel, col=textCol, cex=textCex, adj=if(grepl("^[[:digit:]]+(\\.[[:digit:]]+)$", textAdj)) textAdj else 1) }
}
Try the wrGraph package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.