-
Notifications
You must be signed in to change notification settings - Fork 0
/
gwscaR_plot.R
566 lines (518 loc) · 21.5 KB
/
gwscaR_plot.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
#Author: Sarah P. Flanagan
#Purpose: Plot genome-wide statistics and perform other population genomics visualizations
#Package: gwscaR
#' Plot genome-wide statistics from a data frame.
#' @param fst.dat The data.frame containing at least three columns: the statistic to be plotted, the chromosome ID, and the BP ID for each locus. Each row is a locus.
#' @param pt.cols The color of the points. The default is c("darkgrey","lightgrey").
#' @param fst.name The name of the column containing the statistic to be plotted. Default is "Fst".
#' @param chrom.name The name of the column containing the chromosome information for each locus. Default is "Chrom".
#' @param bp.name The name of the column containing the basepair information for each locus. Default is "BP".
#' @param axis.size The value of cex.axis passed to the plotting of the y-axis. Default is 0.5. Set axis.size = 0 to suppress plotting of the y-axis.
#' @param scaffs.to.plot A vector or list containing the names of the chromosomes/scaffolds you want to include in the order in which you would like them to be plotted.
#' @param y.lim The limits for the y-axis.
#' @param pt.cex The size of the points
#' @param xlabels Either a boolean (TRUE) or a vector of labels for the x-axis
#' @param xlab.indices If the xlabels are not the same as the names of the chromosomes in fst.dat, then provide xlab.indices, which is a vector of integers that are the indices in scaffs.to.plot for which chromosome sets you would like to label.
#' @param scaffold.widths A data.frame with first column naming the chromosomes/linkage groups, second column having the last number of loci on the chromosome for indexing purposes.
#' e.g.:
#' Chrom End
#' LG1 3945850
#' LG2 435215
#' This parameter is used to make multiple plots from the same overall dataset have the same widths.
#' @return new.dat The fst.dat data frame with new values in BP, scaled to be the sequence in which points are plotted based on their position on the chromosome and the order the chromosomes are plotted in.
#' @seealso Flanagan & Jones 2017
#' @export
fst.plot<-function(fst.dat,scaffold.widths=NULL,scaffs.to.plot=NULL,
fst.name="Fst", chrom.name="Chrom", bp.name="BP",
y.lim=NULL,xlabels=NULL,xlab.indices=NULL,
axis.size=0.5,pt.cols=c("darkgrey","lightgrey"),pt.cex=0.5,...){
#make sure fsts are numeric
fst.dat[,fst.name]<-as.numeric(as.character(fst.dat[,fst.name]))
#if scaffold widths aren't provided, we add them ourselves
if(is.null(scaffold.widths)){
scaffold.widths<-data.frame(Chrom=levels(as.factor(fst.dat[,chrom.name])),
Max=tapply(as.numeric(as.character(fst.dat[,bp.name])),
fst.dat[,chrom.name],max))
}
colnames(scaffold.widths)<-c("Chrom","Max")
#if no specific scaffolds are provided, we plot them all
if(is.null(scaffs.to.plot)){
scaffs.to.plot<-scaffold.widths[,1]#unique(fst.dat[,chrom.name])
}
#set up new dataframe
new.dat<-data.frame(stringsAsFactors = F)
last.max<-0
for(i in 1:length(scaffs.to.plot)){
#pull out the data for this scaffold
if(nrow(scaffold.widths[scaffold.widths$Chrom %in% scaffs.to.plot[i],])>0){ #sanity check
chrom.dat<-fst.dat[fst.dat[,chrom.name] %in% scaffs.to.plot[i],]
if(nrow(chrom.dat)>0){
chrom.dat$plot.pos<-as.numeric(as.character(chrom.dat[,bp.name]))+last.max
new.dat<-rbind(new.dat,chrom.dat)
#last.max<-max(chrom.dat$plot.pos)+
# as.numeric(scaffold.widths[scaffold.widths[,1] %in% scaffs.to.plot[i],2])
}
last.max<-last.max+
as.numeric(scaffold.widths[scaffold.widths$Chrom %in% scaffs.to.plot[i],2])
}else{
print(paste(scaffs.to.plot[i], "has no designated width."))
}
}
#make sure everything is the correct class
new.dat$plot.pos<-as.numeric(as.character(new.dat$plot.pos))
new.dat[,chrom.name]<-as.factor(as.character(new.dat[,chrom.name]))
scaffs.to.plot<-as.factor(as.character(scaffs.to.plot))
#determine the axis limits
if(last.max>=max(new.dat$plot.pos)){
x.max<-last.max
}else{
x.max<-max(new.dat$plot.pos)#max(scaffold.widths[scaffold.widths[,1] %in% scaffs.to.plot,2],na.rm=T)
}
x.min<-min(new.dat$plot.pos,na.rm=T)
if(is.null(y.lim)){
y.max<-max(fst.dat[,fst.name])+0.1*max(fst.dat[,fst.name])
y.min<-min(fst.dat[,fst.name])-0.1*min(fst.dat[,fst.name])
if(min(fst.dat[,fst.name]) < 0) {
y.min<-min(fst.dat[,fst.name]) - 0.1*min(fst.dat[,fst.name])
} else {
y.min<-0
}
y.lim<-c(y.min,y.max)
}
#plot
colors<-data.frame(lg=as.character(new.dat[,chrom.name]),col=rep(pt.cols[1],nrow(new.dat)),
stringsAsFactors = F)
colors[as.numeric(factor(colors$lg,levels=scaffs.to.plot))%%2==0,"col"]<-pt.cols[2] #defining the levels maintains the order
plot(new.dat$plot.pos,new.dat[,fst.name],
xlim=c(x.min,x.max),ylim=y.lim,...,
cex=pt.cex, col=colors$col,
bty="n",axes=F, xlab="", ylab="")
#optionally add the y-axis
if(axis.size>0){
axis(2, at = seq(round(y.lim[1],2),round(y.lim[2],2),
round((y.lim[2]-y.lim[1])/2, digits=2)),
ylim =y.lim, pos=0,
labels=seq(round(y.lim[1],2),round(y.lim[2],2),
round((y.lim[2]-y.lim[1])/2, digits=2)),
las=1, xlab="", ylab="", cex.axis=axis.size)
}
#optionally add the x-axis
if(!is.null(xlabels)){
#is this a boolean or a list?
if(class(xlabels)=="logical"){
xlabels<-as.character(scaffs.to.plot)
}
#if there are not indices, they should just be the ones that match scaffolds
if(is.null(xlab.indices)){
xlab.indices<-which(scaffs.to.plot %in% xlabels)
}
for(i in 1:length(xlabels)){
text(x=median(new.dat[new.dat[,chrom.name] %in% scaffs.to.plot[xlab.indices[i]],"plot.pos"]),
y=(y.lim[1]-((y.lim[2]-y.lim[1])/20)),
labels=xlabels[i],adj=1,xpd=TRUE,cex=as.numeric(axis.size))
}
}
return(new.dat)
}
#' Plot genome-wide statistics from a data frame with rectangles.
#' @note This fst.plot function is more efficient but this will work for most cases (might be buggy in some cases)
#' @param fst.dat The data.frame containing at least three columns: the statistic to be plotted, the chromosome ID, and the BP ID for each locus. Each row is a locus.
#' @param ci.dat A vector containing two values, upper and lower cutoff values (in that order).
#' Points above or below the cutoffs will be colored based on sig.col. Default is NULL, which turns this option off.
#' @param sig.col A vector containing two color values, the first for points above the upper cutoff value and the second for points below the lower cutoff value.
#' The defaults are red and yellow.
#' @param pt.col The color of the points. The default is grey7.
#' @param fst.name The name of the column containing the statistic to be plotted. Default is "Fst".
#' @param chrom.name The name of the column containing the chromosome information for each locus. Default is "Chrom".
#' @param bp.name The name of the column containing the basepair information for each locus. Default is "BP".
#' @param axis.size The value of cex.axis passed to the plotting of the y-axis. Default is 0.5. Set axis.size = 0 to suppress plotting of the y-axis.
#' @param scaffold.order A vector or list containing the names of the chromosomes/scaffolds in the order in which you would like them to be plotted.
#' @param groups A vector indicating which chromosomes to plot (generally to exclude those scaffolds not found in this particular set of statistics due to pruning/filters)
#' @param print.names A TRUE/FALSE value indicating whether chromosome/scaffold IDs should be printed beneath the x-axis.
#' @param y.lim The limits for the y-axis.
#' @param group.boundaries A data.frame with first column naming the chromosomes/linkage groups, second column having the last number of loci on the chromosome for indexing purposes.
#' e.g.:
#' Chrom End
#' LG1 3945850
#' LG2 435215
#' This parameter is used to make multiple plots from the same overall dataset have the same widths.
#' @return xes The fst.dat data frame with new values in BP, scaled to be the sequence in which points are plotted based on their position on the chromosome and the order the chromosomes are plotted in.
#' @seealso Flanagan & Jones 2017
#' @export
fst.plot.rect<-function(fst.dat,ci.dat=NULL, sig.col=c("red","yellow"),pt.col="grey7",
fst.name="Fst", chrom.name="Chrom", bp.name="BP",axis.size=0.5,
scaffold.order=NULL,groups=NULL,print.names=FALSE,y.lim=NULL,
group.boundaries=NULL,pt.cex=0.5,...){
if(!is.null(scaffold.order)){
scaff.ord<-scaffold.order$component_id
lgs<-scaffold.order$object
} else{
if(!is.null(group.boundaries)){
scaff.ord<-unique(group.boundaries[,1])
lgs<-scaff.ord
}else{
scaff.ord<-unique(fst.dat[,chrom.name])
lgs<-scaff.ord
}
}
if(!is.null(groups)){
lgs<-groups
scaff.ord<-groups
}
fst.dat[,fst.name]<-as.numeric(as.character(fst.dat[,fst.name]))
these.scaffs<-scaff.ord[scaff.ord %in% unique(fst.dat[,chrom.name])]
all.scaff<-split(fst.dat, factor(fst.dat[,chrom.name]))
#keep only the scaffolds you're plotting
if(!is.null(groups))
{
all.scaff<-all.scaff[names(all.scaff) %in% groups]
}
group.boundaries<-group.boundaries[scaff.ord,]
last.max<-0
rect.xs<-NULL
addition.values<-0
xlist<-NULL
#set up the rectangles
for(i in 1:length(scaff.ord)){
if(is.null(group.boundaries)){
new.max<-last.max+nrow(all.scaff[[as.character(scaff.ord[i])]])
}else{
new.max<-as.numeric(group.boundaries[(group.boundaries[1,]) %in% scaff.ord[i],2])+
as.numeric(as.character(last.max))
}
rect.xs<-rbind(rect.xs,c(last.max, new.max))
rownames(rect.xs)[i]<-scaff.ord[i]
addition.values<-c(addition.values, new.max)
last.max<-new.max
}
rownames(rect.xs)<-scaff.ord
for(i in 1:length(all.scaff)){
if(is.null(group.boundaries)){
#then this is done by relative position only
all.scaff[[i]]<-all.scaff[[i]][order(all.scaff[[i]][,bp.name]),]
all.scaff[[i]][,bp.name]<-
seq(rect.xs[rownames(rect.xs) %in% names(all.scaff)[i],1]+1,
rect.xs[rownames(rect.xs) %in% names(all.scaff)[i],1]+nrow(all.scaff[[i]]),1)
}else{
#then it takes genome space into account
all.scaff[[i]]<-
all.scaff[[i]][order(all.scaff[[i]][,bp.name]),]
all.scaff[[i]][,bp.name]<-
as.numeric(rect.xs[rownames(rect.xs) %in% names(all.scaff)[i],1])+
as.numeric(as.character(all.scaff[[i]][,bp.name]))
}
}
#change BP to plot
x.max<-max(rect.xs,na.rm=T)
x.min<-min(rect.xs,na.rm=T)
if(is.null(y.lim)){
y.max<-max(fst.dat[,fst.name])+0.1*max(fst.dat[,fst.name])
y.min<-min(fst.dat[,fst.name])-0.1*min(fst.dat[,fst.name])
if(min(fst.dat[,fst.name]) < 0) {
y.min<-min(fst.dat[,fst.name]) - 0.1*min(fst.dat[,fst.name])
} else {
y.min<-0
}
y.lim<-c(y.min,y.max)
}
displacement<-y.lim[1]-((y.lim[2]-y.lim[1])/30)
plot(c(x.min,x.max),y.lim,xlim=c(x.min,x.max),
ylim=y.lim, col=pt.col,...,
bty="n",type="n", axes=F, xlab="", ylab="")
for(i in 1:nrow(rect.xs)){
if(i%%2 == 0) {
rect.color<-"white"
} else {
rect.color<-"gray75"
}
rect(rect.xs[i,1],y.lim[1],rect.xs[i,2],y.lim[2],
col=rect.color, border=NA)
if(print.names==T){
text(x=mean(rect.xs[i,]),
y=displacement,labels=rownames(rect.xs)[i],
adj=1,xpd=T,srt=45)
}
}
for(i in 1:length(all.scaff)){
points(all.scaff[[i]][,bp.name],
all.scaff[[i]][,fst.name],
pch=19, cex=pt.cex,col=pt.col,
xlim=c(x.min,x.max),ylim=y.lim)
if(!is.null(ci.dat)){
temp.sig<-all.scaff[[i]][all.scaff[[i]][,fst.name] >= ci.dat[1],]
points(temp.sig[,bp.name], temp.sig[,fst.name],
col=sig.col[1], pch=19, cex=0.5)
temp.sig<-all.scaff[[i]][all.scaff[[i]][,fst.name] <= ci.dat[2],]
points(temp.sig[,bp.name], temp.sig[,fst.name],
col=sig.col[2], pch=19, cex=0.5)
}
}
if(axis.size>0){
axis(2, at = seq(round(y.lim[1],2),round(y.lim[2],2),
round((y.lim[2]-y.lim[1])/2, digits=2)),
ylim =y.lim, pos=0,
labels=seq(round(y.lim[1],2),round(y.lim[2],2),
round((y.lim[2]-y.lim[1])/2, digits=2)),
las=1,tck = -0.01, xlab="", ylab="", cex.axis=axis.size)
}
xes<-do.call("rbind",all.scaff)
return(xes)
}
#' This plots the output of structure
#' @param structure.out A data.frame containing the structure output.
#' @param k The value of K used in Structure
#' @param pop.order The order in which the populations are plotted.
#' @param filename The name of the jpeg for the output file.
#' @param make.file A boolean (TRUE/FALSE) indicating whether the jpeg should be created
#' @param plot.new A boolean (TRUE/FALSE) indicating whether this is being added to an existing plot
#' @param colors A list of colors for the structure colors (if not provided, defaults to rainbow palette)
#' @param xlabel A boolean (TRUE/FALSE) indicating whether x labels should be plotted (default is TRUE)
#' @param ylabel An optional label for the y-axis.
#' @param xlabcol An optional vector of colors for x-axis labels
#' @param lab.cex Size of the labels
#' @export
plotting.structure<-function(structure.out, k, pop.order,
filename=paste("str.k",k,".jpeg",sep=""),make.file=TRUE,lab.cex=1,
plot.new=TRUE,colors=NULL,xlabel=TRUE,ylabel=NULL,xlabcol=NULL){
str.split<-split(structure.out,structure.out[,1])
if(is.null(colors)){
bar.colors<-rainbow(k,s=0.5)
} else {
bar.colors<-colors
}
if(is.null(xlabcol)){
xlabcol<-rep("black",length(str.split))
}
if(make.file==TRUE){
jpeg(filename,width=7, height=1.25, units="in", res=300)
par(mfrow=c(1,length(str.split)),mar=c(1,0,0,0), oma=c(1,0,0,0),cex=0.5)
} else {
if(plot.new==TRUE){
par(mfrow=c(1,length(str.split)),mar=c(1,0,0,0), oma=c(1,0,0,0),cex=0.5)
}
}
for(i in 1:length(str.split)){
pop.index<-pop.order[i]
barplot(height=as.matrix(t(str.split[[pop.index]][,-1])),
beside=FALSE, space=0, border=NA, col=bar.colors,
xlab="", ylab="", xaxt='n', yaxt='n')#, new=plot.new)
if(xlabel==TRUE){
mtext(pop.index, 1, line=0.5, cex=lab.cex, outer=F,col=xlabcol[i])}
if(!is.null(ylabel)){
if(i == 1) { mtext(ylabel,2,cex=lab.cex) }
}
}
if(make.file==TRUE) {dev.off()}
}
#' Plot covariance matrix from treemix
#' @param stem The filename basic stem for that run
#' @param poporder The list of populations in the order to plot them.
#' @return cp The covariance matrix in the plotting order.
treemix.cov.plot<-function(stem,poporder,colors=c("blue","yellow","red"),...){
if("package:lattice" %in% search() == FALSE || "package:grid" %in% search()==FALSE){
stop("ERROR: packages lattice and grid must be loaded")
}
cov<-read.table(gzfile(paste(stem, ".cov.gz", sep = "")), as.is = T, head = T, quote = "", comment.char = "")
#reorder
covplot = data.frame(matrix(nrow = nrow(cov), ncol = ncol(cov)))
for(i in 1:length(poporder)){
for( j in 1:length(poporder)){
covplot[i, j] = cov[which(names(cov)==poporder[i]), which(names(cov)==poporder[j])]
rownames(covplot)[i]<-poporder[i]
colnames(covplot)[j]<-poporder[j]
}
}
cp<-as.matrix(covplot)
cp[lower.tri(cp)]<-NA
cp[upper.tri(cp)]<-covplot[upper.tri(covplot)]
#set up the colors
pal<-colorRampPalette(colors)
ncol=80
cols<-pal(ncol)
cpl<-levelplot(cp,col.regions=cols,alpha.regions=0.7,
scales = list(x=list(rot=90),tck = 0),xlab="",ylab="")
print(cpl,...)
trellis.focus("legend", side="right", clipp.off=TRUE, highlight=FALSE)
grid.text("covariance", 0.2, 0, hjust=0.5, vjust=1.2)
trellis.unfocus()
return(cp)
}
#' Add a legend to the margins of a multiplot figure
#' @param ... legend parameters
#' @return Nothing is returned
#' @notes Modified from https://stackoverflow.com/questions/3932038/plot-a-legend-outside-of-the-plotting-area-in-base-graphics
#' @example
#' plot(rnorm(50), rnorm(50), col=c("steelblue", "indianred"), pch=c(15,19))
#' outer.legend("top",legend=c("A","B"),pch=c(15,19),col=c("steelblue", "indianred"),ncol=2)
#' @export
outer.legend <- function(...) {
opar <- par(fig=c(0, 1, 0, 1), oma=c(0, 0, 0, 0),
mar=c(0, 0, 0, 0), new=TRUE)
on.exit(par(opar))
plot(0, 0, type='n', bty='n', xaxt='n', yaxt='n')
legend(...)
}
#' Create violin plots with
#' @param ... legend parameters
#' @return Optionally returns the summary statistics of the data.
#' @notes Modified from vioplot() in library(vioplot)
#' @example
#' mu<-2
#' si<-0.6
#' bimodal<-c(rnorm(1000,-mu,si),rnorm(1000,mu,si))
#' uniform<-runif(2000,-4,4)
#' normal<-rnorm(2000,0,3)
#' gwsca.vioplot(bimodal,uniform,normal,col=c("red","blue","green"))
#' @include sm
#' @export
gwsca.vioplot <- function(x,...,range=1.5,h=NULL,ylim=NULL,names=NULL, horizontal=FALSE,
col="magenta", border="black", lty=1, lwd=1, rectCol="black", colMed="white", pchMed=19, at, add=FALSE, wex=1,
drawRect=TRUE,plot.axes=TRUE,axis.box=FALSE,plot.ann=TRUE)
{
# process multiple datas
datas <- list(x,...)
n <- length(datas)
if(missing(at)) at <- 1:n
# pass 1
#
# - calculate base range
# - estimate density
#
# setup parameters for density estimation
upper <- vector(mode="numeric",length=n)
lower <- vector(mode="numeric",length=n)
q1 <- vector(mode="numeric",length=n)
q3 <- vector(mode="numeric",length=n)
med <- vector(mode="numeric",length=n)
base <- vector(mode="list",length=n)
height <- vector(mode="list",length=n)
baserange <- c(Inf,-Inf)
# global args for sm.density function-call
args <- list(display="none")
if (!(is.null(h)))
args <- c(args, h=h)
for(i in 1:n) {
data<-datas[[i]]
# calculate plot parameters
# 1- and 3-quantile, median, IQR, upper- and lower-adjacent
data.min <- min(data)
data.max <- max(data)
q1[i]<-quantile(data,0.25)
q3[i]<-quantile(data,0.75)
med[i]<-median(data)
iqd <- q3[i]-q1[i]
upper[i] <- min( q3[i] + range*iqd, data.max )
lower[i] <- max( q1[i] - range*iqd, data.min )
# strategy:
# xmin = min(lower, data.min))
# ymax = max(upper, data.max))
#
est.xlim <- c( min(lower[i], data.min), max(upper[i], data.max) )
# estimate density curve
smout <- do.call("sm.density", c( list(data, xlim=est.xlim), args ) )
# calculate stretch factor
#
# the plots density heights is defined in range 0.0 ... 0.5
# we scale maximum estimated point to 0.4 per data
#
hscale <- 0.4/max(smout$estimate) * wex
# add density curve x,y pair to lists
base[[i]] <- smout$eval.points
height[[i]] <- smout$estimate * hscale
# calculate min,max base ranges
t <- range(base[[i]])
baserange[1] <- min(baserange[1],t[1])
baserange[2] <- max(baserange[2],t[2])
}
# pass 2
#
# - plot graphics
# setup parameters for plot
if(!add){
xlim <- if(n==1)
at + c(-.5, .5)
else
range(at) + min(diff(at))/2 * c(-1,1)
if (is.null(ylim)) {
ylim <- baserange
}
}
if (is.null(names)) {
label <- 1:n
} else {
label <- names
}
# setup colors and borders
if(length(col) < n){
col<-c(col,rep(col,n-length(col)))
}
if(length(border)<n){
border<-c(border,rep(border,n-length(border)))
}
if(length(colMed)<n){
colMed<-c(colMed,rep(colMed,n-length(colMed)))
}
boxwidth <- 0.05 * wex
# setup plot
if(!add)
plot.new()
if(!horizontal) {
if(!add){
plot.window(xlim = xlim, ylim = ylim)
if(plot.axes){
if(plot.ann){
axis(2)
axis(1,at = at, label=label )
}else{
axis(2,labels=F)
axis(1,at = at, labels=F )
}
}
}
if(axis.box){ box() }
for(i in 1:n) {
# plot left/right density curve
polygon( c(at[i]-height[[i]], rev(at[i]+height[[i]])),
c(base[[i]], rev(base[[i]])),
col = col[i], border=border[i], lty=lty, lwd=lwd)
if(drawRect){
# plot IQR
lines( at[c( i, i)], c(lower[i], upper[i]) ,lwd=lwd, lty=lty)
# plot 50% KI box
rect( at[i]-boxwidth/2, q1[i], at[i]+boxwidth/2, q3[i], col=rectCol)
# plot median point
points( at[i], med[i], pch=pchMed, col=colMed )
}
}
}
else {
if(!add){
plot.window(xlim = ylim, ylim = xlim,bty=axis.bty)
if(plot.axes){
if(plot.ann){
axis(2)
axis(1,at = at, label=label )
}else{
axis(2,labels=F)
axis(1,at = at, labels=F )
}
}
}
if(axis.box){ box() }
for(i in 1:n) {
# plot left/right density curve
polygon( c(base[[i]], rev(base[[i]])),
c(at[i]-height[[i]], rev(at[i]+height[[i]])),
col = col[i], border=border[i], lty=lty, lwd=lwd)
if(drawRect){
# plot IQR
lines( c(lower[i], upper[i]), at[c(i,i)] ,lwd=lwd, lty=lty)
# plot 50% KI box
rect( q1[i], at[i]-boxwidth/2, q3[i], at[i]+boxwidth/2, col=rectCol)
# plot median point
points( med[i], at[i], pch=pchMed, col=colMed )
}
}
}
invisible (list( upper=upper, lower=lower, median=med, q1=q1, q3=q3))
}