Skip to content

Instantly share code, notes, and snippets.

@gufodotto

gufodotto/Plot_Bubbles_in_2_Colors.r

Created May 16, 2012 18:12
Show Gist options
  • Save gufodotto/2712729 to your computer and use it in GitHub Desktop.
Save gufodotto/2712729 to your computer and use it in GitHub Desktop.
Download ZIP
Example files for bubble plots
Raw
Plot_Bubbles_in_2_Colors.r
# generic routine to plot bubbles in different colors and sizes - run me using
# source(file.path(Sys.getenv("USERPROFILE"),"Documents/My Dropbox/Proj01_p100PassiveTransport/Data/Models/Plot_Bubbles_in_2_Colors.r"))
# if (exists('debug_flag') & debug_flag) {# cleans up everything but the debug_flag
# rm(list=ls(all=TRUE)[-which(ls()=='debug_flag')])
# } else {debug_flag<-F} # default for debug_flag is obviously FALSE
rm('File_In','Calc'); # initial cleanup - so that we read data from scratch
source(file.path(Sys.getenv("USERPROFILE"),"Documents/My Dropbox/Software/useful.r"))
# set up home directory
sync<-F
homedir <- Sys.getenv("USERPROFILE")
setwd(workdir<-file.path(homedir,"/Documents/MySugarSync/"))
# Source in the plot functions and a bunch of other useful things
source(file.path(homedir,"/Documents/My Dropbox/Proj01_p100PassiveTransport/Data/","./DataPlots/Par'sStuff/surfaceplots.r"))
if (!exists('File_In')) {
File_In<-"./Proj01_p100PassiveTransport/Data/Models/ExamplesSubstrates/Model_A2B_120222_ExampleUptakeSubstrates_OverallOutput.rsave"
}
jittering<-0.6 # this is important - changes the amount of jitter
imagedirpath=gsub(x=file.path(workdir,File_In),pattern=".rsave",replacement="_Bubbles"); fmt1="png"
dir.create(path=imagedirpath, showWarnings=T, recursive=T) # create the directory
if (!exists('ask')) ask<-F# by default we use a semi-automated, interactive variable selection
out2pdf<-F; # by default, we show the output rather than output to pdf
show_plots<-!out2pdf; # if I output to pdf, I can't show the plots at the same time, sorry.
palette_l<-200;
blue2orange <- rev(ramp10(palette_l)); # blue through grey to orange palette, inspired by mathematica
black2red <- rev(rampk2r(palette_l)); # red through grey to green palette, inspired by matlab
black2green <- rev(rampk2g(palette_l)); # red through grey to green palette, inspired by matlab
black2blue <- rev(rampk2b(palette_l)); # red through grey to green palette, inspired by matlab
colorpalette<-blue2orange
colorpalette1<-black2red
colorpalette2<-black2green
if (show_plots) dev.new(width=12,height=8)
# automatic renaming of variable does not work - make sure the variable you read in is called 'Calc'
# old_vars<-c(ls();,'old_vars')
load(file=File_In) # loads an Calc
Calc<-OverallOutput
# new_var_name<-ls()[-which(ls() %in% old_vars)]
# makeActiveBinding('Calc', function() new_var_name, .GlobalEnv)
properties<-colnames(Calc)[-c(1,2)]
if(ask) {
while(T) {
print(sprintf("%3d - %s",(1:length(properties)),properties))
print(sprintf("on the X axys, %s", propX<-properties[as.numeric(readline('pick an x axys:> '))]))
jittered_X <- jitter_logalong(Calc[,propX],expander=jittering);
# jittered_X <- Calc[,propX]
print(sprintf("on the X axys, %s", propY<-properties[as.numeric(readline('pick an y axys:> '))]))
jittered_Y <- jitter_logalong(Calc[,propY],expander=jittering);
# jittered_Y <- Calc[,propY]
if ((answer<-readline('which property for the size? (n for scan) > ')) != 'n') print(sprintf("Size by %s", propSs<-properties[as.numeric(answer)]))
else{ propSs<-properties; print("Scanning through all possible size properties")}
if ((answer<-readline('which property for the 1st color? (n for scan) > ')) != 'n') print(sprintf("coloring by %s", propC1s<-properties[as.numeric(answer)]))
else{ propC1s<-properties; print("Scanning through all possible color properties")}
if ((answer<-readline('which property for the 2nd color? (n for scan) > ')) != 'n') print(sprintf("coloring by %s", propC2s<-properties[as.numeric(answer)]))
else{ propC2s<-properties; print("Scanning through all possible color properties")}
pdffilename<-imgfilename<-sprintf("%s/%s-%s_vs_%s",imagedirpath,action,propX,propY)
if (length(propSs) > 1) {
one_big_file<-T
pdffilename<-sprintf("%s_sby_SSS",pdffilename)
}else{pdffilename<-sprintf("%s_sby_%s",pdffilename,propSs[1])}
if (length(propCs) > 1) {
one_big_file<-T
pdffilename<-sprintf("%s_cby_CCC",pdffilename)
}else{pdffilename<-sprintf("%s_cby_%s",pdffilename,propCs[1])}
if(out2pdf && one_big_file) {
pdf(sprintf("%s.%s",pdffilename,'pdf'), onefile=T, width=12,height=8, useDingbats=F)
}
for (propS in propSs) {
for (propC in propCs) {
if(propX!=propY & propX!=propC & propX!=propS & propY!=propC & propY!=propS & propC!=propS &
(min(Calc[,propS]) != max(Calc[,propS])) & (min(Calc[,propC]) != max(Calc[,propC]))) {
print(sprintf("I am going to plot %s versus %s, sizing by %s and coloring by %s",propX,propY,propS,propC)); flush.console()
titles<-list(
main=sprintf("X is %s, Y is %s, size by %s, color by %s",propX,propY,propS,propC),
color=propC,
size=propS
)
if(!one_big_file) imgfilename<-sprintf("%s/%s-%s_vs_%s_sby_%s_cby_%s",imagedirpath,action,propX,propY,propS,propC)
# useDingbats=F so that if you need to edit the few you generate by hand here they'll not look messed up on inkscape
if(out2pdf & !one_big_file) {pdf(sprintf("%s.%s",imgfilename,'pdf'), onefile=F, width=12,height=8, useDingbats=F)}
bubbles_in_2colors(jittered_X, jittered_Y, propS=Calc[,propS], propC=Calc[,propC], to_jitter=F, dots_names = Calc[,1], titles=titles, xlab=propX, ylab=propY, xaxt='n', pch=21, prop_names=c(propX,propY,propS,propC));
if (out2pdf) {
if (!one_big_file) {
dev.off()
print(sprintf("saving to %s", imgfilename))
}
else{
print(sprintf("keeping it for %s", imgfilename))
}
} else {
print(sprintf("saving to %s", png_filename<-sprintf("%s.%s",imgfilename,'png')))
savePlot(png_filename)
}
# Sys.sleep(0.1);
# stop()
}
else{print(sprintf("It's not OK to plot %s versus %s, sizing by %s and coloring by %s",propX,propY,propS,propC)); flush.console()}
}
}
if (out2pdf) {
if (!one_big_file) {dev.off()}
}
}
}else{
# stop("Sorry, this part of the code may just crash so you can't use it - yet")
for (propX in properties) {
jittered_X <- jitter_logalong(Calc[,propX],expander=jittering);
for (propY in properties) {
jittered_Y <- jitter_logalong(Calc[,propY],expander=jittering);
for (propS in properties) {
for (propC in properties) {
plotprops<-c(propX,propY,propS,propC)
if(length(plotprops)==length(unique(plotprops))) { # if no duplicate props have been selected
if ((length(Calc[!is.na(Calc[,propX]),propX])!=0) & (length(Calc[!is.na(Calc[,propY]),propY])!=0) & (length(Calc[!is.na(Calc[,propS]),propS])!=0) & (length(Calc[!is.na(Calc[,propC]),propC])!=0)) { # if all properties contain at least one non-NA value
# if ((min(Calc[!is.na(Calc[,propX]),propX]) != max(Calc[!is.na(Calc[,propX]),propX])) & (min(Calc[!is.na(Calc[,propY]),propY]) != max(Calc[!is.na(Calc[,propY]),propY])) &
# (min(Calc[!is.na(Calc[,propS]),propS]) != max(Calc[!is.na(Calc[,propS]),propS])) & (min(Calc[!is.na(Calc[,propC]),propC]) != max(Calc[!is.na(Calc[,propC]),propC]))) {
if ((min(Calc[!is.na(Calc[,propX]),propX]) != max(Calc[!is.na(Calc[,propX]),propX])) & (min(Calc[!is.na(Calc[,propY]),propY]) != max(Calc[!is.na(Calc[,propY]),propY])) &
(min(Calc[!is.na(Calc[,propS]),propS]) != max(Calc[!is.na(Calc[,propS]),propS])) & (min(Calc[!is.na(Calc[,propC]),propC]) != max(Calc[!is.na(Calc[,propC]),propC]))) {
print(sprintf("I am going to plot %s versus %s, sizing by %s and coloring by %s",propX,propY,propS,propC)); flush.console()
# useDingbats=T since it' unlikely that you'll edit several thousands of automatically generated graphs by hand...
if(out2pdf) {pdf(imgfilename<-sprintf("%s/%s-%s_vs_%s_sby_%s_cby_%s.%s",imagedirpath,'action',propX,propY,propS,propC,'pdf'), onefile=F, width=12,height=8, useDingbats=T)}
plottitle<-sprintf("X is %s, Y is %s, size by %s, color by %s",propX,propY,propS,propC)
tryCatch(
bubbles_in_2colors(jittered_X, jittered_Y, propS=Calc[,propS], propC=Calc[,propC], to_jitter=F, main=plottitle, xlab=propX, ylab=propY, xaxt='n', pch=21, prop_names=c(propX,propY,propS,propC))
, error = function(x) x # <- what to do if fitting doesn't work (nothing, just keep crunching)
)
if (out2pdf) {dev.off()}
# print(sprintf("saving to %s",imgfilename))
# savePlot(gsub(x=imgfilename,pattern='pdf',replacement=fmt1))
Sys.sleep(1);
# stop()
}
}
}
}
}
}
}
}
Raw
useful.r
# source(file.path(Sys.getenv("USERPROFILE"),"Documents/My Dropbox/Software/useful.r"))
# I may require some libraries here
odds<-c(1,3,5,7,9)
evens<-c(0,2,4,6,8)
library(scatterplot3d) # needed (may be) to plot in 3d the color scale when 3 dimensionare present
require(car); # needed to plot some ellipses
theta <- seq(0, 2 * pi, length=(60)); # angles list for the same ellipses
plot_ellipse <- function (XCenter=0, YCenter=0, XArm=1, YArm=XArm, ...) {
x <- if (grep('x',log_xy) >0) XCenter + 2*XArm * cos(theta) else exp(log(XCenter) + log(2*XArm) * cos(theta));
y <- if (grep('y',log_xy) >0) YCenter + 0.2*YArm * sin(theta) else exp(log(YCenter) + log(2*XArm) * sin(theta));
lines(x, y, type = "l", ...)
}
# creates an empty (NULL) variable of a given name
createVariable <- function(name) {eval(parse(text = paste(name, "<<- NULL"))) }
mins2time <- function(mins) {hourz<-as.integer(mins/60); minz<-as.integer(mins-hourz*60); secz<-((mins-hourz*60)-minz)*60; return(sprintf("%dh:%dm:%2.2fs",hourz,minz,secz)) }
hnt <- function(object, n=3) { # print head and tail of the object given
if (nrow(object) > 3*n) {
print(head(object, n)); print("..."); print(tail(object, n))
}
else{print(object)}
}
last <- function(x) {tail(x=x,n=1)}
first <- function(x) {head(x=x,n=1)}
foldup <- function(object, fold) {object*fold}
foldown <- function(object, fold) {object/fold}
geomean <- function(object) {exp(mean(log(object)))}
geosd <- function(object) {exp(sqrt(sum(log(object/geomean(object))^2)/length(object)))}; # following wikipedia definition
geosd_my <- function(object) {exp(sd(log(object)))}; # following my own nose and intuition
add_slope <- function(slope, from=0, to=1, ...) {curve(slope*x, from=from, to=to, add=T, lty=2, ...)} # adds unity to a plot (by default between 0 and 1)
add_unity <- function(from=0, to=1, ...) {add_slope(1, from=from, to=to, ...)} # adds unity to a plot (by default between 0 and 1)
not.na <- function(x) {return(x[!is.na(x)])}
count <- function(x) {sum(!is.na(x))} # only sums up non NA values
is.within <- function (x, rng) {if (length(which(x < max(rng) & x > min(rng)))) TRUE else FALSE}
is.outside <- function (x, rng) {!is.within(x, rng)}
within <- function (x, rng, strict=T, wantrng=T) {
within <- if (strict) x[which(x < max(rng) & x > min(rng))] else x[which(x <= max(rng) & x >= min(rng))]
return( if(wantrng) sort(unique(c(range(rng),within))) else within)
}
outside <- function (x, rng, strict=T, wantx=T) {
outside <- if (strict) x[which(x > max(rng) & x < min(rng))] else x[which(x >= max(rng) & x <= min(rng))]
return( if(wantrng) sort(unique(c(range(rng),outside))) else outside)
}
log_it <- function(property) {
prp<-property[!is.na(property)]
if ((max(prp)>=100*min(prp)) & min(prp)>0) {T} else {F}
}
log_pretty<- function(x, base_ticks=c(1,2,5)) {
if (min(x) < 0) stop("can't compute log ticks for inptut in negative range, sorry!")
ticks<-{}
for (pwr in floor(log10(min(x))):ceiling(log10(max(x)))) {
ticks<-c(ticks,(10^pwr)*base_ticks)
}
indecex<-which(ticks< max(x) & ticks> min(x))
return(ticks[(min(indecex)-1):(max(indecex)+1)])
}
jitter_along<- function(property, axys, log_it) { # depending on an externally defined log_it variable
if (length(grep(axys,log_it))>0) {
exp(jitter(log(sub_array[,property])))
} else {
jitter(sub_array[,property])
}
}
jitter_logalong<- function(property, expander=0.6) { # not dependent on an externally defined log_it variable
if (log_it(property)) {
runif(length(property),expander,1/expander)*(property)
} else {
jitter(property)
}
}
logprop <- function(x, lo=1, hi=100) {
if (is.na(x)) {NA}
else{
if (hi==0 | lo==0) stop("useful::logprop: can't take log(0), sorry! Check hi or lo")
min(lo,hi)*exp(x*log(max(lo,hi)/min(lo,hi)))
}
}
linprop <- function(x, lo=0, hi=100) {
if (is.na(x)) {NA}
else{
min(lo,hi)+x*(max(lo,hi)-min(lo,hi))
}
}
prop <- function(x, lo, hi, log_it=NULL) {
if(is.null(log_it)) {
if (log_it(c(lo,hi))) logprop(x, lo, hi)
else linprop(x, lo, hi)
}
else if (log_it) logprop(x, lo, hi)
else linprop(x, lo, hi)
}
invlogprop <- function(x, lo=1, hi=100) {
if (is.na(x)) {NA}
else{
if (hi==0 | lo==0) stop("useful::logprop: can't take log(0), sorry! Check hi or lo")
log(x/min(lo,hi))/log(max(lo,hi)/min(lo,hi))
}
}
invlinprop <- function(x, lo=0, hi=100) {
if (is.na(x)) {NA}
else{
(x-min(lo,hi))/(max(lo,hi)-min(lo,hi))
}
}
invprop <- function(x, lo, hi, log_it=NULL) {
if(is.null(log_it)) {
if (log_it(c(lo,hi))) invlogprop(x, lo, hi)
else invlinprop(x, lo, hi)
}
else if (log_it) invlogprop(x, lo, hi)
else invlinprop(x, lo, hi)
}
safe_shapiro.test <- function( set) {
if (count(set) > 5000) {
print("Could not perform Shapiro-Wilk normality test - too many points")
return(data.frame(p.value=2))
}
if (count(set) < 3) {
print("Could not perform Shapiro-Wilk normality test - not enough points")
return(data.frame(p.value=2))
}
# can only run shapiro normality test for this kind of arrays
else {return(shapiro.test(set))} # test for normality the distribution
}
twod_to_oned <- function(dataframe) {
tmp<-{}; rc<-1;
if (is.null(nrow(dataframe)) | is.null(ncol(dataframe))) {return(dataframe)}
for (r in 1:nrow(dataframe)) {
for (c in 1:ncol(dataframe)) {
tmp[rc]<-dataframe[r,c]; rc<-rc+1
}
}
return(tmp)
}
# a function to perform T- or U-test on two sets, based on the normality of the two.
T_or_U_test_on_frame <- function(frame1, frame2) {
tested<- data.frame();
for (property in colnames(frame1)) {
tested[1:2,property] <- sprintf("%5.3f",T_or_U_test(frame1[,property],frame2[,property])['Method','p.value']);
}
return(tested)
}
# a function to perform T- or U-test on two sets, based on the normality of the two.
T_or_U_test <- function(set1, set2) {
stSet1<-safe_shapiro.test(set1); # test for normality the distribution
stSet2<-safe_shapiro.test(set2); # test for normality the distribution
if (stSet1$p.value ==2 | stSet2$p.value == 2) {
print(sprintf("One of the two sets has not enough / too many points to estimate normality Set1(%d), Set2(%d)", count(set1), count(set2)));
Itest<-wilcox.test(set1,set2); Method <- " MWW-U";
}else if (stSet1$p.value < 0.1 & stSet2$p.value < 0.1) { # if both sets are normally distributed
print(sprintf("sets are normally distributed - %f %f", stSet1$p.value, stSet2$p.value));
Itest<-t.test(set1,set2); Method <- "Welch-T";
}else {
print(sprintf("sets are NOT normally distributed - %f %f", stSet1$p.value, stSet2$p.value));
Itest<-wilcox.test(set1,set2); Method <- " MWW-U";
}
return(data.frame(p.value=sprintf("%5.4g",Itest$p.value), Method=Method))
}
plot_pls_loadings <- function(pls.model) { # takes a pls model as input - no default
# first, check if the title for a plot exists and if it doesn't default to a stadanrd value
if (!exists('CpdTitle')) {CpdTitle<-deparse(substitute(pls.model))}
# second, print an invisible plot just to set properly x and y axes
loadingplot(pls.model, pretty.xlabels=F, labels="names", type='h', lwd=9, col="white", main=sprintf("%s : %s", CpdTitle, "PLS loadings"));
grid(nx = NULL, ny = NULL, col = "lightgray", lty = "dotted", lwd = 3, equilogs = TRUE); # add grids
# now plot one after the other the coefficients of the various components, staggered so that they don't overlap
for (c in 1:length(pls.model$coefficients[1,,])) {points(x=c(1:length(pls.model$coefficients[1,,]))+(c-1)/(length(pls.model$coefficients[1,,])+2), y=pls.model$loading.weights[,c], col=(c), type='h', lwd=9)}
}
# stolen from 'calibrate', adapted to my own needs.
textxy <- function (X, Y, labs, cx = 0.5, dcol = "black", m = c(0, 0))
{
posXposY <- ((X >= m[1]) & ((Y >= m[2])))
posXnegY <- ((X >= m[1]) & ((Y < m[2])))
negXposY <- ((X < m[1]) & ((Y >= m[2])))
negXnegY <- ((X < m[1]) & ((Y < m[2])))
if (sum(posXposY) > 0)
text(X[posXposY], Y[posXposY], labs[posXposY], pos=2, cex = cx, col = dcol)
if (sum(posXnegY) > 0)
text(X[posXnegY], Y[posXnegY], labs[posXnegY], pos=2, cex = cx, col = dcol)
if (sum(negXposY) > 0)
text(X[negXposY], Y[negXposY], labs[negXposY], pos=4, cex = cx, col = dcol)
if (sum(negXnegY) > 0)
text(X[negXnegY], Y[negXnegY], labs[negXnegY], pos=4, cex = cx, col = dcol)
}
# define a function to widen x axys so as to fit all labels
widen <- function(dr=NULL, widener=0.6) {
if (length(dr) > 2) {rg<-range(dr)} else{rg<-dr}
if (log_it(dr)) {# do something clever
if (min(rg) <0) {stop("widen(dr, log=T): You can't log scale negative values!")}
meanrg<-geomean(rg); dfrg<- max(rg)/min(rg);
jump<-dfrg^widener;
return( range(c(meanrg/jump,meanrg*jump)))
}
else{
meanrg<-mean(rg); dfrg<- max(rg)-min(rg);
jump<-widener*dfrg;
return( range(pretty(c(meanrg-jump, meanrg+jump))))
}
}
hsv2rgb<-function(x){
x<-as.numeric(sub("#",'0x',x));
c(x%/%256^2,
x%/%256%%256,
x%%256)
}
color.bar <- function(lut, min, max=-min, nticks=11, ticks=seq(min, max, len=nticks), title='') {
scale = (length(lut)-1)/(max-min)
# dev.new(width=1.75, height=5)
# plot(c(0,10), c(min,max), type='n', bty='n', xaxt='n', xlab='', yaxt='n', ylab='', main=title)
axis(2, ticks, las=1)
for (i in 1:(length(lut)-1)) {
y = (i-1)/scale + min
rect(0,y,10,y+1/scale, col=lut[i], border=NA)
}
}
# this is for colors
rampb2o <- colorRampPalette(c(rgb(218/255, 128/255, 65/255), rgb(223/255, 153/255, 71/255), rgb(228/255, 175/255, 75/255), rgb(228/255, 191/255, 84/255), rgb(221/255, 198/255, 103/255), rgb(206/255, 195/255, 136/255), rgb(185/255, 185/255, 183/255), rgb(161/255, 165/255, 189/255), rgb(140/255, 150/255, 195/255), rgb(124/255, 139/255, 199/255), rgb(96/255, 113/255, 171/255), rgb(79/255, 95/255, 153/255), rgb(75/255, 85/255, 144/255)))
rampr2g <- colorRampPalette(c(rgb(218/255, 0/255, 0/255), rgb(218/255, 218/255, 218/255), rgb(0/255, 218/255, 0/255)))
rampk2r <- colorRampPalette(c(rgb( 0/255, 0/255, 0/255), rgb(218/255, 0/255, 0/255)))
rampk2g <- colorRampPalette(c(rgb( 0/255, 0/255, 0/255), rgb( 0/255, 218/255, 0/255)))
rampk2b <- colorRampPalette(c(rgb( 0/255, 0/255, 0/255), rgb( 0/255, 0/255, 218/255)))
# a modified version of grid - for my own personal use
my_grid <- function (nx = NULL, ny = nx, col = "lightgray", lty = "dotted", lwd = par("lwd"), equilogs = TRUE, xlims, ylims)
{
if (is.null(nx) || (!is.na(nx) && nx >= 1)) {
log <- par("xlog")
if (is.null(nx)) {
ax <- par("xaxp")
if (log && equilogs && ax[3L] > 0)
ax[3L] <- 1
at <- axTicks(1, axp = ax, log = log)
}
else {
U <- par("usr")
at <- seq.int(U[1L], U[2L], length.out = nx + 1)
at <- (if (log)
10^at
else at)[-c(1, nx + 1)]
}
print('at'); print (at)
print('ylims'); print (ylims)
# abline(v = at, col = col, lty = lty, lwd = lwd)
arrows(x0 = at, y0=ylims[1], y1=ylims[2], col = col, lty = lty, lwd = lwd, code=0)
}
if (is.null(ny) || (!is.na(ny) && ny >= 1)) {
log <- par("ylog")
if (is.null(ny)) {
ax <- par("yaxp")
if (log && equilogs && ax[3L] > 0)
ax[3L] <- 1
at <- axTicks(2, axp = ax, log = log)
}
else {
U <- par("usr")
at <- seq.int(U[3L], U[4L], length.out = ny + 1)
at <- (if (log)
10^at
else at)[-c(1, ny + 1)]
}
print('at'); print (at)
print('xlims'); print (xlims)
# abline(h = at, col = col, lty = lty, lwd = lwd)
arrows(y0 = at, x0=xlims[1], x1=xlims[2], col = col, lty = lty, lwd = lwd, code=0)
}
}
# bubble plot - takes in four different properties, for X, Y, Size and Color, plus additional parameters to control appearances of the plots produced
bubbles_in_colors<-function( dataset, prop_names=NULL, to_jitter=F, titles=list(main='X vs Y', color='color', size='size'), min_size = 1, max_size = 5, colorpalette, ...) {
if(exists('dataset')) {
propX<-dataset[,1]; propY<-dataset[,2]; propS<-dataset[,3]; propC<-dataset[,4];
print(prop_names<-names(dataset))
}else {stop('did you actually give me a dataset to work with?')}
rangepropX<-range(propX); log_x=log_it(rangepropX); if (!exists('xlab')) {xlab=prop_names[1]}
rangepropY<-range(propY); log_y=log_it(rangepropY); if (!exists('ylab')) {ylab=prop_names[2]}
log_xy=paste(if(log_x){'x'}else{''},if(log_y){'y'}else{''},sep="");
rangepropC<-range(propC); log_c=log_it(rangepropC);
rangepropS<-range(propS); log_s=log_it(rangepropS);
# the line below restricts the sizes in case the span of values isn't too spread out.
Max2min<- rangepropS[2]/rangepropS[1]; if ((!log_s) & (Max2min<5)) {min_size=2; max_size=min_size*Max2min}
# print("defined ranges")
pch <- if (!exists('pch')) {21} else {pch} # 21 for cricles, 22 for squares, 23 for diamonds, 24 for triangles up, 25 for triangles down
# the color palette is obtained by spreading the known palette (log)proportionally across the range of propC
colpaltt<-colorpalette[1+invprop(propC,rangepropC[1],rangepropC[2],log_c)*(palette_l-1)]
if (!length(colpaltt[!is.na(colpaltt)])) colpaltt[is.na(colpaltt)]<-'black'
# the size palette is obtained by (log)proportional representation of the propC range in the min_size-max_size range.
# minimum and maximum for printing symbols 0.5 to 1, or given by the user.
sizepaltt<-(prop(invprop(propS,rangepropS[1],rangepropS[2],log_s),min_size, max_size, log_s))
if (!length(sizepaltt[!is.na(sizepaltt)])) sizepaltt[is.na(sizepaltt)]<-1
# print("defined palettes"); print(colpaltt); print(sizepaltt)
if (to_jitter) {
jittered_X <- jitter_logalong(propX);
jittered_Y <- jitter_logalong(propY);
}else{
jittered_X <- (propX);
jittered_Y <- (propY);
}
# print("jittered X and Y")
# layout(matrix(c(1,1,1,2,1,1,1,3), 2, 4, byrow = TRUE)) # this works but let's try something fancier
layout(matrix(c(2,2,1,3), 2, 2, byrow = TRUE), widths=c(3,1), heights=c(1,3))
# print(sprintf("X from %G to %G, Y from %G to %G",rangepropX[1],rangepropX[2],rangepropY[1],rangepropY[2]))
plot(NULL, xlim=rangepropX, ylim=rangepropY, log=log_xy, bty='n', main=titles$main, ...); # , xaxs="i" to plot exactly within xlim,
# grid(nx = NULL, ny = NULL, col = "darkgray", lty = "dotted", lwd = 1, equilogs = T)
my_grid(nx = NULL, ny = NULL, xlims=rangepropX, ylims=rangepropY, col = "darkgray", lty = "dotted", lwd = 1, equilogs = T)
axXticks<-sort(unique(propX));
if (length(axXticks) > 3) {
if(log_it(axXticks)) {
axXticks<-within(log_pretty(axXticks, 1),axXticks,F, F)
}else{
axXticks<-within(pretty(axXticks),axXticks,F, F)
}
}
axis(1, at=axXticks, labels=sprintf("%5.3g",axXticks))
# Not yet working - attempt to reorder points so that the small ones are plotted above the little ones
# for (n in 1:length(propS)) {indx<-c(indx,which(propS==sort(propS)[n]))}
# indx<-rev(indx)
# jittered_X<-jittered_X[indx]
# jittered_Y<-jittered_Y[indx]
# propS<-propS[indx]
# propC<-propC[indx]
points(jittered_X, jittered_Y, , pch=21, cex=sizepaltt, col="white", bg=colpaltt);
if (length(propX) < 10) {text(x=jittered_X, y=jittered_Y, labels=dots_names, pos=4)}
# print("printed bubbles"); #print(colpaltt); print(sizepaltt)
plot(NULL, xlim=range(propC), ylim=c(0,1), log=if(log_c) 'x' else '', xaxt='n', yaxt='n', xlab='', ylab='', bty='n', main=titles$color);
# the colorbar is a second plot, going at the top.
# must find a x value to center my colorbar - righ side.
ycolorbar<-0
for (n in 1:palette_l) {
rgbcol<-hsv2rgb(colorpalette[n])/255;
rect(xleft= prop(x=(n-1)/(palette_l),rangepropC[1],rangepropC[2],log_c)
,xright= prop(x=(n)/(palette_l),rangepropC[1],rangepropC[2],log_c)
,ytop= 1
,ybottom= 0
, col=rgb(rgbcol[1],rgbcol[2],rgbcol[3], alpha=1)
, border="transparent"
)
}
ycolorbarlegend<- 0.5
colorticks<- if (log_c) within(log_pretty(rangepropC, 1),rangepropC, F, F) else within(pretty(rangepropC),rangepropC, F)
axis(1, at=colorticks, labels=sprintf("%5.3g",colorticks))
# the bubble legend is a third plot, going in the lower right.
plot(NULL, xlim=widen(c(-1,1), 0.9), ylim=widen(rangepropS, 0.9), log=if(log_s) 'y' else '', xaxt='n', yaxt='n', xlab='', ylab='', bty='n', main=titles$size);
circles <- if (log_s) within(log_pretty(rangepropS, 1), rangepropS, strict=F, wantrng=F) else within(pretty(rangepropS), rangepropS, strict=F, wantrng=F) #all of them
# but I only select five at the most:
circles<-circles[ceiling((1:5)*length(circles)/5)] # select 5 circles for the legend.
# I may want to get rid of one of the the last two, in case their values are too close
if (log_s) {if(circles[length(circles)]/circles[length(circles)-1] < 25) {circles<-circles[1:(length(circles)-1)]}}
else {if((circles[length(circles)]-circles[length(circles)-1]) < 0.7(circles[length(circles)-1]-circles[length(circles)-2])) {circles<-circles[1:(length(circles)-1)]}}
xlegend<-2
points(rep(-1,length(circles)),circles, pch=21, cex=prop(invprop(circles, min(circles), max(circles)),min(sizepaltt),max(sizepaltt)))
text(rep(0,length(circles)),circles, labels=sprintf("%5.3g",circles))
}
# bubble plot - takes in a dataframe with five different properties, for X, Y, Size, ColorA, B and C, plus additional parameters to control appearances of the plots produced
bubbles_in_2colors<-function( dataset, to_jitter=F, prop_names=NULL, titles=list(main='X vs Y', color='colors', size='size'), min_size = 1, max_size = 5, max_sat = 200, fav_col='green', alpha_default=0.7, ...) {
# NB: this code can handle a third primary color, but human eyes can't so for the moment I've forbidden that option.
if(exists('dataset')) {
if (is.null(prop_names)) {print(prop_names<-names(dataset))};
if (length(prop_names) ==4) {propX<-dataset[,1]; propY<-dataset[,2]; propS<-dataset[,3]; propCA<-dataset[,4]}
else if (length(prop_names) ==5) {propX<-dataset[,1]; propY<-dataset[,2]; propS<-dataset[,3]; propCA<-dataset[,4]; propCB<-dataset[,5]}
else if (length(prop_names) ==6) {propX<-dataset[,1]; propY<-dataset[,2]; propS<-dataset[,3]; propCA<-dataset[,4]; propCB<-dataset[,5]; propCC<-dataset[,6]; print("Three colors are too many for measly human eyes")}
else {stop(sprintf("I don't know what to do with an array with %d properties",length(prop_names)))}
}else {stop('did you actually give me a dataset to work with?')}
rangepropX<-range(propX); log_x=log_it(rangepropX); if (!exists('xlab')) {xlab=prop_names[1]}
rangepropY<-range(propY); log_y=log_it(rangepropY); if (!exists('ylab')) {ylab=prop_names[2]}
rangepropS<-range(propS); log_s=log_it(rangepropS);
# the line below restricts the sizes in case the span of values isn't too spread out.
Max2min<- rangepropS[2]/rangepropS[1]; if ((!log_s) & (Max2min<5)) {min_size=2; max_size=min_size*Max2min}
log_xy=paste(if(log_x){'x'}else{''},if(log_y){'y'}else{''},sep="");
rangepropCA<-range(propCA); log_cA=log_it(rangepropCA);
if (exists('propCB')) {rangepropCB<-range(propCB); log_cB=log_it(rangepropCB);} else{rangepropCB<-c(0,0); log_cB=F}
if (exists('propCC')) {rangepropCC<-range(propCC); log_cC=log_it(rangepropCC);} else{rangepropCC<-c(0,0); log_cC=F}
pch <- if (!exists('pch')) {21} else {pch} # 21 for circles, 22 for squares, 23 for diamonds, 24 for triangles up, 25 for triangles down
# the color palette is obtained by spreading the known palette (log)proportionally across the range of propC
# how about setting the color directly in rgb space?
if (!exists('palette_l')) {palette_l<-50}
colorpalette<-0:palette_l*(max_sat/255)/palette_l
print(colorpalette)
if(fav_col=='red') {
r_colpaltt<- colorpalette[1+invprop(propCA,rangepropCA[1],rangepropCA[2],log_cA)*(palette_l-1)]
g_colpaltt<- if (exists('propCB')) colorpalette[1+invprop(propCB,rangepropCB[1],rangepropCB[2],log_cB)*(palette_l-1)] else 0
b_colpaltt<- if (exists('propCC')) colorpalette[1+invprop(propCC,rangepropCC[1],rangepropCC[2],log_cC)*(palette_l-1)] else 0
}else if(fav_col=='green') {
g_colpaltt<- colorpalette[1+invprop(propCA,rangepropCA[1],rangepropCA[2],log_cA)*(palette_l-1)]
r_colpaltt<- if (exists('propCB')) colorpalette[1+invprop(propCB,rangepropCB[1],rangepropCB[2],log_cB)*(palette_l-1)] else 0
b_colpaltt<- if (exists('propCC')) colorpalette[1+invprop(propCC,rangepropCC[1],rangepropCC[2],log_cC)*(palette_l-1)] else 0
}else if(fav_col=='blue') {
b_colpaltt<- colorpalette[1+invprop(propCA,rangepropCA[1],rangepropCA[2],log_cA)*(palette_l-1)]
g_colpaltt<- if (exists('propCB')) colorpalette[1+invprop(propCB,rangepropCB[1],rangepropCB[2],log_cB)*(palette_l-1)] else 0
r_colpaltt<- if (exists('propCC')) colorpalette[1+invprop(propCC,rangepropCC[1],rangepropCC[2],log_cC)*(palette_l-1)] else 0
}
colpaltt<- rgb(r_colpaltt, g_colpaltt, b_colpaltt, alpha_default)
# print(colpaltt)
if (!length(colpaltt[!is.na(colpaltt)])) colpaltt[is.na(colpaltt)]<-'black'
# the size palette is obtained by (log)proportional representation of the propC range in the min_size-max_size range.
# minimum and maximum for printing symbols 0.5 to 1, or given by the user.
sizepaltt<-(prop(invprop(propS,rangepropS[1],rangepropS[2],log_s),min_size, max_size, log_s))
if (!length(sizepaltt[!is.na(sizepaltt)])) sizepaltt[is.na(sizepaltt)]<-1
# print("defined palettes"); print(colpaltt); print(sizepaltt)
if (to_jitter) {
jittered_X <- jitter_logalong(propX);
jittered_Y <- jitter_logalong(propY);
}else{
jittered_X <- (propX);
jittered_Y <- (propY);
}
# print("jittered X and Y")
# layout(matrix(c(1,1,1,2,1,1,1,3), 2, 4, byrow = TRUE)) # this works but let's try something fancier
if(!exists('propCB')) {layout(matrix(c(2,2,1,3), 2, 2, byrow = TRUE), widths=c(3,1), heights=c(1,3))}
else if(!exists('propCC')) {layout(matrix(c(1,2,1,3), 2, 2, byrow = TRUE), widths=c(3,1), heights=c(2,2))}
else {layout(matrix(c(1,2,1,3,1,4,1,5), 4, 2, byrow = TRUE), widths=c(4,1), heights=c(1,1,1,1))}
# print(sprintf("X from %G to %G, Y from %G to %G",rangepropX[1],rangepropX[2],rangepropY[1],rangepropY[2]))
plot(NULL, xlim=rangepropX, ylim=rangepropY, log=log_xy, bty='n', xaxt='n', yaxt='n', main=titles$main, xlab=prop_names[1], ylab=prop_names[2]); # , xaxs="i" to plot exactly within xlim,
# grid(nx = NULL, ny = NULL, col = "darkgray", lty = "dotted", lwd = 1, equilogs = T)
my_grid(nx = NULL, ny = NULL, xlims=rangepropX, ylims=rangepropY, col = "darkgray", lty = "dotted", lwd = 1, equilogs = T)
axXticks<-sort(unique(propX));
if (length(axXticks) > 3) {
if(log_it(axXticks)) {
axXticks<-within(log_pretty(axXticks, 1),axXticks,F, T)
}else{
axXticks<-within(pretty(axXticks),axXticks,F, T)
}
}
axis(1, at=axXticks, labels=sprintf("%5.3g",axXticks))
axYticks<-sort(unique(propY));
if (length(axYticks) > 3) {
if(log_it(axYticks)) {
axYticks<-within(log_pretty(axYticks, 1),axYticks,F, T)
}else{
axYticks<-within(pretty(axYticks),axYticks,F, T)
}
}
axis(2, at=axYticks, labels=sprintf("%5.3g",axYticks))
# Not yet working - attempt to reorder points so that the small ones are plotted above the little ones
# for (n in 1:length(propS)) {indx<-c(indx,which(propS==sort(propS)[n]))}
# indx<-rev(indx)
# jittered_X<-jittered_X[indx]
# jittered_Y<-jittered_Y[indx]
# propS<-propS[indx]
# propC<-propC[indx]
points(jittered_X, jittered_Y, , pch=21, cex=sizepaltt, col="white", bg=colpaltt);
if (length(propX) < 10) {text(x=jittered_X, y=jittered_Y, labels=dots_names, pos=4)}
# now it's the time to print a nice colorspace as legend for the bubbles
# the colorbar is a second plot, going at the top right (see layout(matrix()) command, much above)
# I'll have two different colorspaces depending on whether two or three dimensions are being used as colors
if(!exists('propCB')) {
plot(NULL, xlim=range(propCA), ylim=c(0,1), log=if(log_cA) 'x' else '', xaxt='n', yaxt='n', xlab=prop_names[4], ylab=prop_names[5], bty='n', main=titles$color);
for (n in 1:palette_l) {
if (fav_col == 'red') rgbcol<-rgb(colorpalette[n], 0, 0, alpha_default)
else if (fav_col == 'green') rgbcol<-rgb(0, colorpalette[n], 0, alpha_default)
else if (fav_col == 'blue') rgbcol<-rgb(0, 0, colorpalette[n], alpha_default)
rect(xleft= prop(x=(n-1)/(palette_l),rangepropCA[1],rangepropCA[2],log_cA)
,xright= prop(x=(n)/(palette_l),rangepropCA[1],rangepropCA[2],log_cA)
,ytop= 1
,ybottom= 0
, col=rgbcol
, border="transparent"
)
}
ycolorbarlegend<- 0.5
colorticks<- if (log_cA) within(log_pretty(rangepropCA, 1),rangepropCA, F, F) else within(pretty(rangepropCA),rangepropCA, F)
axis(1, at=colorticks, labels=sprintf("%5.3g",colorticks))
}else if(!exists('propCC')) {
plot(NULL, xlim=range(propCA), ylim=range(propCB), log=paste(if(log_cA) 'x' else '',if(log_cB) 'y' else '', sep=''), xaxt='n', yaxt='n', xlab=prop_names[4], ylab=prop_names[5], bty='n', main=titles$color);
for (m in 1:palette_l) {
for (n in 1:palette_l) {
rgbcol<-rgb(colorpalette[n],colorpalette[m],0, alpha_default);
rect(xleft= prop(x=(n-1)/(palette_l),rangepropCA[1],rangepropCA[2],log_cA)
,xright= prop(x=(n)/(palette_l),rangepropCA[1],rangepropCA[2],log_cA)
,ytop= prop(x=(m-1)/(palette_l),rangepropCB[1],rangepropCB[2],log_cB)
,ybottom= prop(x=(m)/(palette_l),rangepropCB[1],rangepropCB[2],log_cB)
,col=rgbcol
,border="transparent"
)
}
}
colorAticks<- if (log_cA) within(log_pretty(rangepropCA, 1),rangepropCA, F, T) else within(pretty(rangepropCA),rangepropCA, F, T)
axis(1, at=colorAticks, labels=sprintf("%5.3g",colorAticks))
colorBticks<- if (log_cB) within(log_pretty(rangepropCB, 1),rangepropCB, F, T) else within(pretty(rangepropCB),rangepropCB, F, T)
axis(2, at=colorBticks, labels=sprintf("%5.3g",colorBticks))
}else{
for (o in c(1,palette_l/2, palette_l)) {
plot(NULL, xlim=range(propCA), ylim=range(propCB), log=paste(if(log_cA) 'x' else '',if(log_cB) 'y' else '', sep=''), xaxt='n', yaxt='n', xlab=prop_names[4], ylab=prop_names[5], bty='n', main=sprintf("ColC=%g percent",100*o/palette_l));
for (m in 1:palette_l) {
for (n in 1:palette_l) {
rgbcol<-rgb(colorpalette[n],colorpalette[m],colorpalette[o], alpha_default)
rect(xleft= prop(x=(n-1)/(palette_l),rangepropCA[1],rangepropCA[2],log_cA)
,xright= prop(x=(n)/(palette_l),rangepropCA[1],rangepropCA[2],log_cA)
,ytop= prop(x=(m-1)/(palette_l),rangepropCB[1],rangepropCB[2],log_cB)
,ybottom= prop(x=(m)/(palette_l),rangepropCB[1],rangepropCB[2],log_cB)
,col=rgbcol
,border="transparent"
)
}
}
# flush.console(); Sys.sleep(0.5)
}
colorAticks<- if (log_cA) within(log_pretty(rangepropCA, 1),rangepropCA, F, T) else within(pretty(rangepropCA),rangepropCA, F, T)
axis(1, at=colorAticks, labels=sprintf("%5.3g",colorAticks))
colorBticks<- if (log_cB) within(log_pretty(rangepropCB, 1),rangepropCB, F, T) else within(pretty(rangepropCB),rangepropCB, F, T)
axis(2, at=colorBticks, labels=sprintf("%5.3g",colorBticks))
}
# the bubble legend is a third plot, going in the lower right.
plot(NULL, xlim=widen(c(-1,1), 0.9), ylim=widen(rangepropS, 0.9), log=if(log_s) 'y' else '', xaxt='n', yaxt='n', xlab='', ylab='', bty='n', main=titles$size);
circles <- if (log_s) within(log_pretty(rangepropS, 1), rangepropS, strict=F, wantrng=F) else within(pretty(rangepropS), rangepropS, strict=F, wantrng=F) #all of them
# but I only select five at the most:
circles<-rev(circles[ceiling((1:5)*length(circles)/5)]) # select 5 circles for the legend.
# I may want to get rid of one of the the last two, in case their values are too close
# if (log_s) {if(circles[length(circles)]/circles[length(circles)-1] < 25) {circles<-circles[1:(length(circles)-1)]}}
# else {if((circles[length(circles)]-circles[length(circles)-1]) < 0.7(circles[length(circles)-1]-circles[length(circles)-2])) {circles<-circles[1:(length(circles)-1)]}}
# xlegend<-2
points(rep(-1,length(circles)), circles, pch=21, bg='grey', col='white', cex=prop(invprop(circles, min(circles), max(circles)),min(sizepaltt),max(sizepaltt)))
text(rep(0,length(circles)),circles, labels=sprintf("%5.3g",circles))
}
# # test to be commented out
# dataset<- data.frame(Perm=runif(n=25,min=0.1, max=10), CSApInit=runif(n=25,min=0, max=100), AAR=runif(n=25,min=10, max=1000), ColA=runif(n=25,min=10, max=1000))
# # dataset<- data.frame(Perm=runif(n=25,min=0.1, max=10), CSApInit=runif(n=25,min=0, max=100), AAR=runif(n=25,min=10, max=1000), ColA=runif(n=25,min=10, max=1000), ColB=runif(n=25,min=10, max=1000))
# # dataset<- data.frame(Perm=runif(n=25,min=0.1, max=10), CSApInit=runif(n=25,min=0, max=100), AAR=runif(n=25,min=10, max=1000), ColA=runif(n=25,min=10, max=1000), ColB=runif(n=25,min=10, max=1000), ColC=runif(n=25,min=10, max=1000))
# dev.new(); bubbles_in_2colors(dataset=dataset, max_sat=255, min_size=3, max_size=10)
# # similar graph in ggplot2
# dev.new(); p<-ggplot(dataset, aes(Perm,CSApInit, size=AAR, color=ColA)) + geom_point()
# dev.new(); p+scale_colour_gradient2(expression(sqrt('ColA')), low='blue', mid='grey', midpoint=mean(dataset$ColA), high='orange')+scale_size(expression(sqrt('Pippo')), limits=range(dataset$AAR))
# dev.new(); p+scale_colour_gradient2(expression(sqrt('ColA')), low='blue', mid='grey', midpoint=mean(dataset$ColA), high='orange')+scale_size(expression(sqrt('Pippo')), limits=range(dataset$AAR))+scale_area()
nst_bbl_lgd<- function(size_prop, x=NULL, y=NULL, pch=21, min_size=5, max_size=25, ...) { # plot beautiful nested bubble chart legends.
# assuming that you already have found a position for it... based on the density of points in the plot space
# you plot circles of given radius, staggering them along the x (optionally y) axys so that they all touch the ground in the same space
print(radii <- if (log_it(size_prop)) within(log_pretty(size_prop, 1), size_prop, F) else within(pretty(size_prop), size_prop, F))
plot(NULL, xlim=widen(range(radii), 0.9), ylim=widen(c(0, max_size), 0.9), xlab='', ylab='', bty='n');
# for (r in radii[c(1, as.integer(length(radii)/4),as.integer(length(radii)/2), length(radii))]) {
rlist<-rev(prop(invprop(radii, min(radii), max(radii), log_it(radii)),min_size, max_size, log_it(size_prop)))
for (r in rlist) {
X<-x
if (!log_it(size_prop)) Y<-y+(r)/2
print(sprintf("R = %g; X = %g; Y = %g",r,X,Y))
points(X,Y, pch=pch, cex=r, bg='grey', col='white')
text(X,Y+r-1, labels=radii[which(rev(rlist)==r)], pos=3, cex=0.5, col='white')
}
# you'll also want to plot numbers on their side.
}
# them below are functions nicked from http://menugget.blogspot.com/
#This is a wrapper function for colorRampPalette. It allows for the
#definition of the number of intermediate colors between the main colors.
#Using this option one can stretch out colors that should predominate
#the palette spectrum. Additional arguments of colorRampPalette can also
#be added regarding the type and bias of the subsequent interpolation.
color.palette <- function(steps, n.steps.between=NULL, ...){
if(is.null(n.steps.between)) n.steps.between <- rep(0, (length(steps)-1))
if(length(n.steps.between) != length(steps)-1) stop("Must have one less n.steps.between value than steps")
fill.steps <- cumsum(rep(1, length(steps))+c(0,n.steps.between))
RGB <- matrix(NA, nrow=3, ncol=fill.steps[length(fill.steps)])
RGB[,fill.steps] <- col2rgb(steps)
for(i in which(n.steps.between>0)){
col.start=RGB[,fill.steps[i]]
col.end=RGB[,fill.steps[i+1]]
for(j in seq(3)){
vals <- seq(col.start[j], col.end[j], length.out=n.steps.between[i]+2)[2:(2+n.steps.between[i]-1)]
RGB[j,(fill.steps[i]+1):(fill.steps[i+1]-1)] <- vals
}
}
new.steps <- rgb(RGB[1,], RGB[2,], RGB[3,], maxColorValue = 255)
pal <- colorRampPalette(new.steps, ...)
return(pal)
}
#This function creates converts the values ina vector to colors from a given palette
val2col<-function(z, zlim, col = heat.colors(12), breaks){
if(!missing(breaks)){
if(length(breaks) != (length(col)+1)){stop("must have one more break than colour")}
}
if(missing(breaks) & !missing(zlim)){
breaks <- seq(zlim[1], zlim[2], length.out=(length(col)+1))
}
if(missing(breaks) & missing(zlim)){
zlim <- range(z, na.rm=TRUE)
zlim[2] <- zlim[2]+c(zlim[2]-zlim[1])*(1E-3)#adds a bit to the range in both directions
zlim[1] <- zlim[1]-c(zlim[2]-zlim[1])*(1E-3)
breaks <- seq(zlim[1], zlim[2], length.out=(length(col)+1))
}
colorlevels <- col[((as.vector(z)-breaks[1])/(range(breaks)[2]-range(breaks)[1]))*(length(breaks)-1)+1] # assign colors to heights for each point
colorlevels
}
#This function creates a color scale for use with the image()
#function. Input parameters should be consistent with those
#used in the corresponding image plot. The "horiz" argument
#defines whether the scale is horizonal(=TRUE) or vertical(=FALSE).
image.scale <- function(z, zlim, col = heat.colors(12),
breaks, horiz=TRUE, ...){
if(!missing(breaks)){
if(length(breaks) != (length(col)+1)){stop("must have one more break than colour")}
}
if(missing(breaks) & !missing(zlim)){
breaks <- seq(zlim[1], zlim[2], length.out=(length(col)+1))
}
if(missing(breaks) & missing(zlim)){
zlim <- range(z, na.rm=TRUE)
zlim[2] <- zlim[2]+c(zlim[2]-zlim[1])*(1E-3)#adds a bit to the range in both directions
zlim[1] <- zlim[1]-c(zlim[2]-zlim[1])*(1E-3)
breaks <- seq(zlim[1], zlim[2], length.out=(length(col)+1))
}
poly <- vector(mode="list", length(col))
for(i in seq(poly)){
poly[[i]] <- c(breaks[i], breaks[i+1], breaks[i+1], breaks[i])
}
xaxt <- ifelse(horiz, "s", "n")
yaxt <- ifelse(horiz, "n", "s")
if(horiz){ylim<-c(0,1); xlim<-range(breaks)}
if(!horiz){ylim<-range(breaks); xlim<-c(0,1)}
plot(1,1,t="n",ylim=ylim, xlim=xlim, xaxt=xaxt, yaxt=yaxt, xaxs="i", yaxs="i", ...)
for(i in seq(poly)){
if(horiz){
polygon(poly[[i]], c(0,0,1,1), col=col[i], border=NA)
}
if(!horiz){
polygon(c(0,0,1,1), poly[[i]], col=col[i], border=NA)
}
}
}
multiplot <- function(..., plotlist=NULL, cols) {
require(grid)
# Make a list from the ... arguments and plotlist
plots <- c(list(...), plotlist)
numPlots = length(plots)
# Make the panel
plotCols = cols # Number of columns of plots
plotRows = ceiling(numPlots/plotCols) # Number of rows needed, calculated from # of cols
# Set up the page
grid.newpage()
pushViewport(viewport(layout = grid.layout(plotRows, plotCols)))
vplayout <- function(x, y)
viewport(layout.pos.row = x, layout.pos.col = y)
# Make each plot, in the correct location
for (i in 1:numPlots) {
curRow = ceiling(i/plotCols)
curCol = (i-1) %% plotCols + 1
print(plots[[i]], vp = vplayout(curRow, curCol ))
}
}
# ggplot2 themes and colors
theme_invisible <- function(base_size = 12) {
structure(list(
axis.line = theme_blank(),
axis.text.x = theme_text(colour = NA,size = base_size * 0.8 , lineheight = 0.9, vjust = 1),
axis.text.y = theme_text(colour = NA,size = base_size * 0.8, lineheight = 0.9, hjust = 1),
axis.ticks = theme_segment(colour = NA, size = 0.2),
axis.title.x = theme_text(colour = NA,size = base_size, vjust = 1),
axis.title.y = theme_text(colour = NA,size = base_size, angle = 90, vjust = 0.5),
axis.ticks.length = unit(0.3, "lines"),
axis.ticks.margin = unit(0.5, "lines"),
legend.background = theme_rect(colour=NA),
legend.key = theme_rect(colour = NA, ),
legend.key.size = unit(1.2, "lines"),
legend.text = theme_text(colour = NA,size = base_size * 0.8),
legend.title = theme_text(colour = NA,size = base_size * 0.8, face = "bold", hjust = 0),
legend.position = "right",
panel.background = theme_rect(fill = NA, colour = NA),
panel.border = theme_rect(fill = NA, colour=NA),
panel.grid.major = theme_line(colour = NA, size = 0.2),
panel.grid.minor = theme_line(colour = NA, size = 0.5),
panel.margin = unit(0.25, "lines"),
strip.background = theme_rect(fill = NA, colour = NA),
strip.text.x = theme_text(colour = NA,size = base_size * 0.8),
strip.text.y = theme_text(colour = NA,size = base_size * 0.8, angle = -90),
plot.background = theme_rect(colour = NA),
plot.title = theme_text(colour = NA,size = base_size * 1.2),
plot.margin = unit(c(1, 1, 0.5, 0.5), "lines")
), class = "options")
}
theme_invisible <- function(base_size = 12) {
structure(list(
axis.line = theme_blank(),
axis.text.x = theme_text(colour = NA,size = base_size * 0.8 , lineheight = 0.9, vjust = 1),
axis.text.y = theme_text(colour = NA,size = base_size * 0.8, lineheight = 0.9, hjust = 1),
axis.ticks = theme_segment(colour = NA, size = 0.2),
axis.title.x = theme_text(colour = NA,size = base_size, vjust = 1),
axis.title.y = theme_text(colour = NA,size = base_size, angle = 90, vjust = 0.5),
axis.ticks.length = unit(0.3, "lines"),
axis.ticks.margin = unit(0.5, "lines"),
legend.background = theme_rect(colour=NA),
legend.key = theme_rect(colour = NA, ),
legend.key.size = unit(1.2, "lines"),
legend.text = theme_text(colour = NA,size = base_size * 0.8),
legend.title = theme_text(colour = NA,size = base_size * 0.8, face = "bold", hjust = 0),
legend.position = "right",
panel.background = theme_rect(fill = NA, colour = NA),
panel.border = theme_rect(fill = NA, colour=NA),
panel.grid.major = theme_line(colour = NA, size = 0.2),
panel.grid.minor = theme_line(colour = NA, size = 0.5),
panel.margin = unit(0.25, "lines"),
strip.background = theme_rect(fill = NA, colour = NA),
strip.text.x = theme_text(colour = NA,size = base_size * 0.8),
strip.text.y = theme_text(colour = NA,size = base_size * 0.8, angle = -90),
plot.background = theme_rect(colour = NA),
plot.title = theme_text(colour = NA,size = base_size * 1.2),
plot.margin = unit(c(1, 1, 0.5, 0.5), "lines")
), class = "options")
}
# The color blind palette with grey:
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
# The color blind palette with black:
cbbPalette <- c("#000000", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
# The color blind palette without black:
cbnbPalette <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
# To use for fills, add
# scale_fill_manual(values=cbPallette)
# To use for line and point colors, add
# scale_colour_manual(values=cbPallette)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment