##---------------------------------------------------------------------------------------------------------------------
## Title: PLM CC Tools -- Functions for data wrangling with CC and CC-RIX related data, and other miscellanea.
## Author: Paul L. Maurizio
## Contact: paul.maurizio@gmail.com
## Institution (past): University of North Carolina at Chapel Hill
## Institution (present): University of Chicago
## Date Created: 2016-08-08
## Date Updated: 2018-08-04
##---------------------------------------------------------------------------------------------------------------------
#' PLMcctools: A package for wrangling CC and CC-RIX related data.
#'
#' @docType package
#' @name PLMcctools
#' @import stringr
NULL
#' @import devtools
NULL
#' @import miqtl
NULL
#' @import gridGraphics
NULL
#' @section require namespaces:
requireNamespace("stringr", quietly=TRUE)
requireNamespace("devtools", quietly=TRUE)
requireNamespace("miqtl", quietly=TRUE)
requireNamespace("gridGraphcs", quietly=TRUE)
#' @section cc-tools functions:
#' @title colSwitch
#' @description Provide standard colors for CC founders.
#' @param arg the argument, in the form of "AA", "BB", etc.
#' @param ... additional arguments
#' @return Returns standard CC founder colors in hex-code
#' @examples
#' colSwitch(c("A", "B", "C", "DD", "EE", "FF"))
#' @export
colSwitch <- function(arg, ...){
founder.colors <- c("#F0F000", "#808080", "#F08080", "#1010F0", "#00A0F0", "#00A000", "#F00000", "#9000E0")
ret <- NULL
for(i in 1:length(arg)){
ret[i] <- switch(as.character(arg[i]),
AA=founder.colors[1],
BB=founder.colors[2],
CC=founder.colors[3],
DD=founder.colors[4],
EE=founder.colors[5],
FF=founder.colors[6],
GG=founder.colors[7],
HH=founder.colors[8],
A=founder.colors[1],
B=founder.colors[2],
C=founder.colors[3],
D=founder.colors[4],
E=founder.colors[5],
F=founder.colors[6],
G=founder.colors[7],
H=founder.colors[8],
"AJxAJ"=founder.colors[1],
"B6xB6"=founder.colors[2],
"129x129"=founder.colors[3],
"NODxNOD"=founder.colors[4],
"NZOxNZO"=founder.colors[5],
"CASTxCAST"=founder.colors[6],
"PWKxPWK"=founder.colors[7],
"WSBxWSB"=founder.colors[8],
"AJ"=founder.colors[1],
"B6"=founder.colors[2],
"129"=founder.colors[3],
"NOD"=founder.colors[4],
"NZO"=founder.colors[5],
"CAST"=founder.colors[6],
"PWK"=founder.colors[7],
"WSB"=founder.colors[8],
"black")
}
return(ret)
}
#' @title lettersToStrains
#' @description Convert CC letter names to short strain names.
#' @param arg the argument, in the form of "AJ", "B6", etc.
#' @param ... additional arguments
#' @return Returns standard CC short strain names from letter codes.
#' @examples
#' lettersToStrains(c("AJ", "B6"))
#' @export
lettersToStrains <- function(arg, ...){
founder.names <- c("AJ", "B6", "129", "NOD", "NZO", "CAST", "PWK", "WSB")
ret <- NULL
for(i in 1:length(arg)){
ret[i] <- switch(as.character(arg[i]),
AA=founder.names[1],
BB=founder.names[2],
CC=founder.names[3],
DD=founder.names[4],
EE=founder.names[5],
FF=founder.names[6],
GG=founder.names[7],
HH=founder.names[8],
A=founder.names[1],
B=founder.names[2],
C=founder.names[3],
D=founder.names[4],
E=founder.names[5],
F=founder.names[6],
G=founder.names[7],
H=founder.names[8],
"unknown")
}
return(ret)
}
#' @title strainsToLetters
#' @description This converts strain names to strain letters.
#' @param arg the argument, in the form of "AJ", "C57BL6J", etc., or a vector of these.
#' @param ... additional arguments
#' @return Returns standard CC founder letters from strain names.
#' @examples
#' strains <- c("A_J", "C57BL6J", "129S1_SvImJ", "NOD_ShiLtJ", "NZO_HlLtJ", "CAST_EiJ", "PWK_PhJ", "WSB_EiJ")
#' strainsToLetters(strains)
#' @export
strainsToLetters <- function(arg, ...){
ret <- NULL
for(i in 1:length(arg)){
ret[i] <- switch(as.character(arg[i]),
"A_J"="A",
"C57BL6J"="B",
"129S1_SvImJ"="C",
"NOD_ShiLtJ"="D",
"NZO_HlLtJ"="E",
"CAST_EiJ"="F",
"PWK_PhJ"="G",
"WSB_EiJ"="H",
"AJ"="A",
"B6"="B",
"129"="C",
"129S1"="C",
"NOD"="D",
"NZO"="E",
"CAST"="F",
"PWK"="G",
"WSB"="H",
"unknown")
}
return(ret)
}
#' @title strainsShortToFull
#' @description This converts short strainnames to full strain names.
#' @param arg the argument, in the form of "AJ", "B6", etc., or a vector of these.
#' @param ... additional arguments
#' @return Returns standard CC founder letters from strain names.
#' @examples
#' strains <- c("AJ", "B6", "129", "NOD", "NZO", "CAST", "PWK", "WSB")
#' strainsShortToFull(strains)
#' @export
strainsShortToFull <- function(arg, ...){
ret <- NULL
for(i in 1:length(arg)){
ret[i] <- switch(as.character(arg[i]),
"AJ"="A/J",
"B6"="C57BL/6J",
"129"="129S1/SvImJ",
"NOD"="NOD/ShiLtJ",
"NZO"="NZO/HlLtJ",
"CAST"="CAST/EiJ",
"PWK"="PWK/PhJ",
"WSB"="WSB/EiJ",
"unknown")
}
return(ret)
}
#' @title lettersToNumbers
#' @description This converts strain name letters to numbers.
#' @param arg the argument, in the form of "A", "B", ... "H", or vector of these.
#' @param ... additional arguments
#' @return Returns standard CC founder numbers from single letters.
#' @examples
#' lettersToNumbers(c("A", "B", "C", "D", "E", "F"))
#' @export
lettersToNumbers <- function(arg, ...){
ret <- NULL
for(i in 1:length(arg)){
ret[i] <- switch(as.character(arg[i]),
A=1, B=2, C=3, D=4,
E=5, F=6, G=7, H=8)
}
return(ret)
}
#' @title convertCrossNames
#' @description This converts CC cross names.
#' @param arg the argument, in the form of "8042", "8002", etc., or vector of these.
#' @param ... additional arguments
#' @return Returns the CCXXX version of the numeric strain names in the vector.
#' @examples
#' convertCrossNames(c("8042", "8002"))
#' @export
convertCrossNames <- function(crossnames, ...){
ret <- rep(NA, length(crossnames))
for(i in 1:length(crossnames)){
ret[i] <- switch(as.character(crossnames[i]),
"18042"="CC042",
"8042"="CC042",
"8002"="CC032",
"8004"="CC024",
"8005"="CC012",
"8008"="CC025",
"8010"="CC013",
"8016"="CC028",
"8018"="CC010",
"18018"="CC010",
"8021"="CC043",
"8024"="CC016",
"8026"="CC026",
"8027"="CC027",
"8031"="CC031",
"8033"="CC033",
"8034"="CC030",
"8036"="CC008",
"8043"="CC023",
"18045"="CC045",
"8045"="CC045",
"8046"="CC022",
"8048"="CC061",
"8049"="CC038",
"8050"="CC054",
"8052"="CC052",
"8054"="CC020",
"8056"="CC056",
"16012"="CC059",
"16034"="CC070",
"16072"="CC037",
"16188"="CC004",
"16211"="CC005",
"16296"="CC049",
"16441"="CC041",
"16513"="CC019",
"16521"="CC072",
"16557"="CC040",
"16680"="CC055",
"16750"="CC006",
"16768"="CC068",
"16785"="CC071",
"16912"="CC051",
"13067"="CC003",
"13140"="CC001",
"13421"="CC007",
"1515"="CC073",
"15155"="CC039",
"15156"="CC002",
"1566"="CC021",
"3015"="CC074",
"3032"="CC017",
"3154"="CC015",
"3252"="CC011",
"3260"="CC075",
"3393"="CC057",
"3415"="CC014",
"3460"="CC060",
"3564"="CC029",
"3609"="CC018",
"4410"="CC044",
"477"="CC036",
"5035"="CC035",
"5080"="CC034",
"15119"="CC065",
"5119"="CC065",
"5248"="CC048",
"5306"="CC062",
"5343"="CC076",
"5346"="CC046",
"5358"="CC058",
"5391"="CC063",
"5489"="CC009",
"15489"="CC009",
"559"="OR559",
"5612"="CC047",
"773"="CC053",
"867"="CC050",
NA)
}
return(ret)
}
#' @title backConvertCrossNames
#' @description This converts CC cross names.
#' @param arg the argument, in the form of "CC001", "CC002", etc., or vector of these.
#' @param ... additional arguments
#' @return Returns the number version of the CCXXX strain names in the vector.
#' @examples
#' backConvertCrossNames(c("CC002", "CC001"))
#' @export
backConvertCrossNames <- function(crossnames, ...){
ret <- rep(NA, length(crossnames))
for(i in 1:length(crossnames)){
ret[i] <- switch(as.character(crossnames[i]),
# "CC042"="18042",
"CC042"="8042",
"CC032"="8002",
"CC024"="8004",
"CC012"="8005",
"CC025"="8008",
"CC013"="8010",
"CC028"="8016",
"CC010"="8018",
# "CC010"="18018",
"CC043"="8021",
"CC016"="8024",
"CC026"="8026",
"CC027"="8027",
"CC031"="8031",
"CC033"="8033",
"CC030"="8034",
"CC008"="8036",
"CC023"="8043",
"CC045"="8045",
"CC022"="8046",
"CC061"="8048",
"CC038"="8049",
"CC054"="8050",
"CC052"="8052",
"CC020"="8054",
"CC056"="8056",
"CC059"="16012",
"CC070"="16034",
"CC037"="16072",
"CC004"="16188",
"CC005"="16211",
"CC049"="16296",
"CC041"="16441",
"CC019"="16513",
"CC072"="16521",
"CC040"="16557",
"CC055"="16680",
"CC006"="16750",
"CC068"="16768",
"CC071"="16785",
"CC051"="16912",
"CC003"="13067",
"CC001"="13140",
"CC007"="13421",
"CC073"="1515",
"CC039"="15155",
"CC002"="15156",
"CC021"="1566",
"CC074"="3015",
"CC017"="3032",
"CC015"="3154",
"CC011"="3252",
"CC075"="3260",
"CC057"="3393",
"CC014"="3415",
"CC060"="3460",
"CC029"="3564",
"CC018"="3609",
"CC044"="4410",
"CC036"="477",
"CC035"="5035",
"CC034"="5080",
"CC065"="15119",
"CC065"="5119",
"CC048"="5248",
"CC062"="5306",
"CC076"="5343",
"CC046"="5346",
"CC058"="5358",
"CC063"="5391",
"CC009"="5489",
"CC009"="15489",
"OR559"="559",
"CC047"="5612",
"CC053"="773",
"CC050"="867",
NA)
}
return(ret)
}
#' @title underNumAlpha
#' @description This adds underscores between alphabet and numeric characters
#' @param arg the argument which has numeric and character strings next to each ther
#' or a vector of character strings
#' @param ... additional arguments
#' @return Returns elements with underscores between letters and numbers
#' @examples
#' underNumAlpha(c("135RL","136R"))
#' @export
underNumAlpha <- function(ids, ...){
ret <- rep(NA, length(ids))
for(i in 1:length(ids)){
num <- str_extract(ids[i], "^[0-9]+")
alpha <- str_extract(ids[i], "[A-Z]+$")
ret[i] <- paste(num, alpha, sep="_")
}
return(ret)
}
#' @title removeDots
#' @description This removes dots (and underscores) from a string, replacing with a space.
#'
#' @param x the dot-containing string
#' or a vector of character strings
#' @param ... additional arguments
#' @return Returns string without dot/underscore.
#' @examples
#' removeDots("This_is_a.test.string.")
#' @export
removeDots <- function(x, ...){
if(!(is.character(x))){
cat("ERROR:", as.character(x), "is not a string! \n")
return(cat(NULL))
}
new.x <- gsub(".", " ", x, fixed=TRUE)
new.x <- gsub("_", " ", new.x, fixed=TRUE)
return(new.x)
}
#' @title docBuildInstall
#' @description This documents, builds, and installs an R package based on its directory.
#' @param dir the directory of the R package to be documented, built, installed
#' @param ... additional arguments
#' @return Returns string without dot/underscore.
#' @examples
#' # Not Run
#' @export
docBuildInstall <- function(dir, ...){
document(dir, roclets=c('rd', 'namespace'))
build(dir)
install(dir, quick=TRUE, upgrade_dependencies=FALSE)
}
#' @title parseDamSire
#' @description This separates damxsire into dam and sire.
#' @param data.frame the data frame with dam x sire names
#' @param cross.colname the column name with dam x sire
#' @param ... additional arguments
#' @return Returns string without dot/underscore.
#' @examples
#' # Not Run
#' @export
parseDamSire <- function(data.frame, cross.colname, ...){
data.frame$dam <- sapply(data.frame[, as.character(cross.colname)],
FUN=function(x){gsub("x.*", "", x)})
data.frame$sire <- sapply(data.frame[, as.character(cross.colname)],
FUN=function(x){gsub(".*x", "", x)})
return(data.frame)
}
#' @title plotCheckerboard
#' @description This plots checkerboard-style heatmaps of mean phenotype values in the diallel.
#' @param summary.dat summary data frame, summarized by strain-pair
#' @param phen phenotype column name
#' @param aggregate.col data frame column to aggregate by
#' @param fun usually supplied as "mean", but could also be "sd" or some similar function of interest
#' @param founder.ids usually letters A through ...
#' @param founder.names descriptive names of founders, for axis labels
#' @param founder.colors colors for founder lines, for axis plotting
#' @param match.by choose founder.letters or founder.names, based on what is in input data frame
#' @param scale.palette specify the palette to be used for color scale in the heatmap
#' @param scale.range define the range of the data
#' @param plot.palette specify the palette for the scale to be plotted, which may differ from the range of the palette of the plot
#' @param scale.tick specify whether to highlight a mark on the axis with an additional tick
#' @param which.tick specify which axis tick to highlight
#' @param noscale boolean specifying whether to hide the scale
#' @param scale.las specify the side of the scale axis using las
#' @param axis.srt specify the angle to tilt the scale axis labels
#' @param axis.y.adj specify a vertical adjustment for the scale axis labels
#' @param scale.cex specify how big the scale text is using standard cex adjustments
#' @param ... additional arguments
#' @return Returns checkerboard plot
#' @examples
#' # Not Run
#' @export
plotCheckerboard <- function(summary.dat=NULL, phen=NULL, aggregate.col="Strain", fun="mean",
founder.ids=LETTERS[1:8], main="", xlab="",
founder.names=c("AJ", "B6", "129", "NOD", "NZO", "CAST", "PWK", "WSB"),
founder.letters=LETTERS[1:8],
founder.colors=c("#F0F000", "#808080", "#F08080", "#1010F0",
"#00A0F0", "#00A000", "#F00000", "#9000E0"),
match.by=c("founder.letters","founder.names")[1],
scale.palette=colorRampPalette(c("white", "black"))(n = 1000),
scale.range=range(summary.dat, na.rm=TRUE),
plot.palette=scale.palette, scale.tick=FALSE, which.tick=5,
noscale=c(FALSE, TRUE)[1], scale.las=1, axis.srt=45, axis.y.adj=0.1,
scale.cex=1, scale.gradient.cex=1,
...){
fdim <- length(founder.ids)
if(match.by=="founder.letters"){
matchvec <- expand.grid(founder.letters, founder.letters)
matchvec$paste <- paste0(matchvec$Var1, matchvec$Var2)
}
if(match.by=="founder.names"){
matchvec <- expand.grid(founder.names, founder.names)
matchvec$paste <- paste(matchvec$Var1, matchvec$Var2, sep="x")
}
matchmat <- matrix(as.character(matchvec$paste), nrow=fdim, ncol=fdim)
data.mat <- matrix(NA, nrow=fdim, ncol=fdim)
colnames(data.mat) <- rownames(data.mat) <- founder.names
for(j in 1:fdim){
for(k in 1:fdim){
thiscross <- as.character(matchmat[j,k])
try(data.mat[j,k] <- as.numeric(summary.dat[summary.dat[,aggregate.col]==thiscross,phen]),
silent=TRUE)
}
}
heatfun <- function(){
heatmap(t(data.mat), scale="none", Colv=NA, Rowv=NA,
revC=TRUE, symm=TRUE, ColSideColors = founder.colors, margins=c(6,6),
RowSideColors = founder.colors, xlab=expression(bold("sire")),
ylab=expression(bold("dam")), col=plot.palette, main=main)
}
grid.newpage()
pushViewport(viewport(y=1.1, x=0.5, width=0.8, just="top"))
grid.echo(heatfun, newpage=FALSE)
upViewport()
scalefun <- function(){
plot(c(1:length(scale.palette)), rep(0.92,length(scale.palette)),
pch="|", col=scale.palette, cex=scale.gradient.cex, ylab="", xlab=xlab,
yaxt="n", frame.plot=FALSE, ylim=c(0.85,1.4), xaxt="n",
adj=0, yaxs='i')
labs <- signif(as.numeric(pretty(scale.range)), digits=3)
if(TRUE==scale.tick){
axis(side=3, at=seq(from=1, to=length(scale.palette),
length.out=length(labs))[which.tick],
labels="", pos=0.9)
}
axis(side=1, at=seq(from=1, to=length(scale.palette), length.out=length(labs)),
labels=FALSE, pos=0.9, las=scale.las)
text(x=seq(from=1, to=length(scale.palette), length.out=length(labs)), labels=labs,
y=par()$usr[3]-axis.y.adj*(par()$usr[4]-par()$usr[3]),
srt=axis.srt, adj=1, xpd=TRUE, cex=scale.cex)
}
if(noscale==FALSE){
pushViewport(viewport(y=0, height=0.4, width=0.85, x=0.44, just="bottom"))
grid.echo(scalefun, newpage=FALSE)
upViewport()
}
}
#' @title rescale.palette
#' @description This rescales the palette based on where the plot range falls within the data range.
#' @param plot.range the range of values for plotting (i.e., range of strain means)
#' @param data.range the range of values for the color ramp scale (i.e., range of strain means across all plots)
#' @param start.pal the starting palette
#' @param ... additional arguments
#' @return Returns rescaled palette, with same length of colors as original scale
#' @examples
#' # Not Run
#' @export
rescale.palette <- function(plot.range, data.range, color.len=1000,
start.pal=colorRampPalette(c("white", "black"))(n = color.len),
...){
center <- -data.range[1]
scale <- (length(start.pal)-1)/(data.range[2]-data.range[1])
len <- length(start.pal)-1
rescaled.startcol <- round((plot.range[1]+center)*scale + 1)
rescaled.endcol <- round((plot.range[2]+center)*scale + 1)
rescaled <- colorRampPalette(c(start.pal[rescaled.startcol], start.pal[rescaled.endcol]))(n = color.len)
return(rescaled)
}
#' @title prob.heatmap.sdp
#' @description This is an SDP-collapsed version of the miqtl::prob.heatmap function.
#' @param ... additional arguments
#' @return Returns rescaled palette, with same length of colors as original scale
#' @examples
#' # Not Run
#' @export
prob.heatmap.sdp <- function (marker, p.value = NULL, genomecache, model = "additive",
phenotype, phenotype.data, merge.by = "SUBJECT.NAME", founder.labels = NULL,
founder.cex = 1, founder.line = 1,
founder.col = rep("black", length(levels(as.factor(sdp)))),
phenotype.lab.cex = 1, phenotype.num.cex = 1, phenotype.num.padj = NA,
phenotype.line = NA, phenotype.num.line = NA, include.ramp = TRUE,
ramp.label.cex = 0.7, ramp.label.line = 0.5, prob.axis.cex = 1,
include.marker = TRUE, marker.line = 1, alternative.phenotype.label = NULL,
alternative.marker.label = NULL, sdp = NULL)
{
h <- DiploprobReader$new(genomecache)
Xtemp <- h$getLocusMatrix(locus = marker, model = model)
levs <- levels(as.factor(sdp))
X <- NULL
for(s in 1:length(levs)){
X <- cbind(X, rowSums(Xtemp[,colnames(Xtemp)[sdp==as.integer(levs[s])], drop=FALSE]))
}
colnames(X) <- as.character(levs)
subjects <- h$getSubjects()
rownames(X) <- subjects
if (!include.marker) {
marker <- NULL
}
if (!is.null(alternative.marker.label)) {
marker <- alternative.marker.label
}
prob.heatmap.from.matrix(geno.matrix = X, marker = marker,
p.value = p.value, model = model, phenotype = phenotype,
phenotype.data, merge.by = merge.by, founder.labels = founder.labels,
founder.cex = founder.cex, phenotype.lab.cex = phenotype.lab.cex,
phenotype.num.cex = phenotype.num.cex, phenotype.num.padj = phenotype.num.padj,
phenotype.line = phenotype.line, phenotype.num.line = phenotype.num.line,
include.ramp = include.ramp, ramp.label.cex = ramp.label.cex,
ramp.label.line = ramp.label.line, prob.axis.cex = prob.axis.cex,
marker.line = marker.line, alternative.phenotype.label = alternative.phenotype.label)
}
#' @title docBuildInstall
#' @description Document, build, and install an R package from its decompressed directory.
#' @param dir the directory path
#' @param ... additional arguments
#' @return Installs the R package.
#' @examples
#' # Not Run
#' @export
docBuildInstall <- function(dir, ...){
document(as.character(dir), roclets=c('rd', 'namespace'))
build(as.character(dir))
install(as.character(dir), quick=TRUE, upgrade_dependencies=FALSE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.