Browse code

backup

Zuguang Gu authored on 23/08/2018 20:29:32
Showing20 changed files

... ...
@@ -56,4 +56,10 @@ setGeneric('row_dend', function(object, ...) standardGeneric('row_dend'))
56 56
 setGeneric('copy_all', function(object, ...) standardGeneric('copy_all'))
57 57
 setGeneric('resize', function(object, ...) standardGeneric('resize'))
58 58
 setGeneric('adjust_heatmap_list', function(object, ...) standardGeneric('adjust_heatmap_list'))
59
+setGeneric('width', function(object, ...) standardGeneric('width'))
60
+setGeneric('height', function(object, ...) standardGeneric('height'))
61
+setGeneric('size', function(object, ...) standardGeneric('size'))
62
+setGeneric('width<-', function(object, value, ...) standardGeneric('width<-'))
63
+setGeneric('height<-', function(object, value, ...) standardGeneric('height<-'))
64
+setGeneric('size<-', function(object, value, ...) standardGeneric('size<-'))
59 65
 
... ...
@@ -24,8 +24,9 @@ AnnotationFunction = setClass("AnnotationFunction",
24 24
 	)
25 25
 )
26 26
 
27
+
27 28
 anno_width_and_height = function(which, width = NULL, height = NULL, 
28
-	default = unit(1, "cm")) {
29
+	default = unit(10, "mm")) {
29 30
 
30 31
 	if(which == "column") {
31 32
 		if(is.null(height)) {
... ...
@@ -33,6 +34,8 @@ anno_width_and_height = function(which, width = NULL, height = NULL,
33 34
 		} else {
34 35
 			if(!is_abs_unit(height)) {
35 36
 				stop("height can only be an absolute unit.")
37
+			} else {
38
+				height = convertHeight(height, "mm")
36 39
 			}
37 40
 		}
38 41
 		if(is.null(width)) {
... ...
@@ -45,6 +48,8 @@ anno_width_and_height = function(which, width = NULL, height = NULL,
45 48
 		} else {
46 49
 			if(!is_abs_unit(width)) {
47 50
 				stop("width can only be an absolute unit.")
51
+			} else {
52
+				width = convertWidth(width, "mm")
48 53
 			}
49 54
 		}
50 55
 		if(is.null(height)) {
... ...
@@ -61,11 +66,15 @@ AnnotationFunction = function(fun, fun_name = "", which = c("column", "row"),
61 66
 
62 67
 	which = match.arg(which)[1]
63 68
 
69
+	verbose = ht_global_opt$verbose
70
+	
64 71
 	anno = new("AnnotationFunction")
65 72
 
66 73
 	anno@which = which
67 74
 	anno@fun_name = fun_name
68 75
 
76
+	if(verbose) qqcat("construct AnnotationFunction with '@{fun_name}()'\n")
77
+
69 78
 	anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
70 79
 	anno@width = anno_size$width
71 80
 	anno@height = anno_size$height
... ...
@@ -163,11 +172,14 @@ setMethod(f = "draw",
163 172
         pushViewport(viewport(width = 0.8, height = 0.8))
164 173
     }
165 174
 
175
+    verbose = ht_global_opt$verbose
176
+    if(verbose) qqcat("draw annotation generated by @{object@fun_name}\n")
177
+
166 178
     if(missing(index)) index = seq_len(object@n)
167 179
 
168 180
     anno_height = object@height
169 181
     anno_width = object@width
170
-    
182
+
171 183
     # names should be passed to the data viewport
172 184
 	pushViewport(viewport(width = anno_width, height = anno_height))
173 185
 	object@fun(index)
... ...
@@ -241,2323 +253,57 @@ setMethod(f = "show",
241 253
 	
242 254
 })
243 255
 
244
-anno_empty = function(which = c("column", "row"), border = TRUE, width = NULL, height = NULL) {
245
-	
246
-	if(is.null(.ENV$current_annotation_which)) {
247
-		which = match.arg(which)[1]
248
-	} else {
249
-		which = .ENV$current_annotation_which
250
-	}
251
-
252
-	anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
253
-	
254
-	fun = function(index) {
255
-		if(border) grid.rect()
256
-	}
257
-
258
-	anno = AnnotationFunction(
259
-		fun = fun,
260
-		fun_name = "anno_empty",
261
-		which = which,
262
-		var_import = list(border),
263
-		subset_rule = list(),
264
-		subsetable = TRUE,
265
-		height = anno_size$height,
266
-		width = anno_size$width
267
-	)
268
-	return(anno) 
269
-}
270
-
271
-subset_matrix_by_row = function(x, i) x[i, , drop = FALSE]
272
-subset_vector = function(x, i) x[i]
273
-
274
-anno_simple = function(x, col, na_col = "grey", 
275
-	which = c("column", "row"), border = FALSE, gp = gpar(col = NA),
276
-	pch = NULL, pt_size = unit(1, "snpc")*0.8, pt_gp = gpar(), 
277
-	width = NULL, height = NULL) {
278
-
279
-	if(is.null(.ENV$current_annotation_which)) {
280
-		which = match.arg(which)[1]
281
-	} else {
282
-		which = .ENV$current_annotation_which
283
-	}
284
-
285
-	if(is.data.frame(x)) x = as.matrix(x)
286
-	if(is.matrix(x)) {
287
-		if(ncol(x) == 1) {
288
-			x = x[, 1]
289
-		}
290
-	}
291
-	input_is_matrix = is.matrix(x)
292
-
293
-	anno_size = anno_width_and_height(which, width, height, 
294
-		unit(5, "mm")*ifelse(input_is_matrix, ncol(x), 1))
295
-	
296
-	if(missing(col)) {
297
-		col = default_col(x)
298
-	}
299
-	if(is.atomic(col)) {
300
-		color_mapping = ColorMapping(name = "foo", colors = col, na_col = na_col)
301
-    } else if(is.function(col)) {
302
-        color_mapping = ColorMapping(name = "foo", col_fun = col, na_col = na_col)
303
-    } else if(inherits(col, "ColorMapping")) {
304
-    	color_mapping = col
305
-    } else {
306
-    	stop_wrap("`col` should be a named vector/a color mapping function/a ColorMapping object.")
307
-    }
308
-
309
-    value = x
310
-    gp = subset_gp(gp, 1)  # gp controls border
311
-
312
-    if(is.matrix(value)) {
313
-		n = nrow(value)
314
-		nr = n
315
-		nc = ncol(value)
316
-	} else {
317
-		n = length(value)
318
-		nr = n
319
-		nc = 1
320
-	}
321
-	
322
-    if(!is.null(pch)) {
323
-    	if(input_is_matrix) {
324
-		    pch = normalize_graphic_param_to_mat(pch, ifelse(is.matrix(x), ncol(x), 1), n, "pch")
325
-		    pt_size = pt_size[1]*(1/nc)
326
-		    pt_gp = subset_gp(pt_gp, 1)
327
-		} else {
328
-			if(length(pch) == 1) pch = rep(pch, n)
329
-			if(length(pt_size) == 1) pt_size = rep(pt_size, n)
330
-			pt_gp = recycle_gp(pt_gp, n)
331
-		}
332
-	}
333
-
334
-	row_fun = function(index) {
335
-		
336
-		n = length(index)
337
-		y = (n - seq_len(n) + 0.5) / n
338
-        if(is.matrix(value)) {
339
-            nc = ncol(value)
340
-            for(i in seq_len(nc)) {
341
-                fill = map_to_colors(color_mapping, value[index, i])
342
-                grid.rect(x = (i-0.5)/nc, y, height = 1/n, width = 1/nc, 
343
-                	gp = do.call("gpar", c(list(fill = fill), gp)))
344
-                if(!is.null(pch)) {
345
-					l = !is.na(pch[, i])
346
-					grid.points(x = rep((i-0.5)/nc, sum(l)), y = y[l], pch = pch[l, i], 
347
-						size = pt_size, gp = pt_gp)
348
-				}
349
-            }
350
-        } else {
351
-			fill = map_to_colors(color_mapping, value[index])
352
-			grid.rect(x = 0.5, y, height = 1/n, width = 1, gp = do.call("gpar", c(list(fill = fill), gp)))
353
-			if(!is.null(pch)) {
354
-				l = !is.na(pch)
355
-				grid.points(x = rep(0.5, sum(l)), y = y[l], pch = pch[l], size = pt_size[l], 
356
-					gp = subset_gp(pt_gp, which(l)))
357
-			}
358
-        }
359
-        if(border) grid.rect(gp = gpar(fill = "transparent"))
360
-	}
361
-
362
-	column_fun = function(index) {
363
-		n = length(index)
364
-		x = (seq_len(n) - 0.5) / n
365
-        if(is.matrix(value)) {
366
-            nc = ncol(value)
367
-            for(i in seq_len(nc)) {
368
-                fill = map_to_colors(color_mapping, value[index, i])
369
-                grid.rect(x, y = (nc-i +0.5)/nc, width = 1/n, height = 1/nc, gp = do.call("gpar", c(list(fill = fill), gp)))
370
-                if(!is.null(pch)) {
371
-					l = !is.na(pch[, i])
372
-					grid.points(x[l], y = rep((nc-i +0.5)/nc, sum(l)), pch = pch[l, i], size = pt_size, gp = pt_gp)
373
-				}
374
-            }
375
-        } else {
376
-			fill = map_to_colors(color_mapping, value[index])
377
-			grid.rect(x, y = 0.5, width = 1/n, height = 1, gp = do.call("gpar", c(list(fill = fill), gp)))
378
-			if(!is.null(pch)) {
379
-				l = !is.na(pch)
380
-				grid.points(x[l], y = rep(0.5, sum(l)), pch = pch[l], size = pt_size[l], gp = subset_gp(pt_gp, which(l)))
381
-			}
382
-        }
383
-        if(border) grid.rect(gp = gpar(fill = "transparent"))
384
-	}
385
-
386
-	if(which == "row") {
387
-		fun = row_fun
388
-	} else if(which == "column") {
389
-		fun = column_fun
390
-	}
391
-
392
-	anno = AnnotationFunction(
393
-		fun = fun,
394
-		fun_name = "anno_simple",
395
-		which = which,
396
-		width = anno_size$width,
397
-		height = anno_size$height,
398
-		n = n,
399
-		data_scale = c(0.5, nc + 0.5),
400
-		var_import = list(value, gp, border, color_mapping, pt_gp, pt_size, pch)
401
-	)
402
-
403
-	anno@subset_rule = list()
404
-	if(input_is_matrix) {
405
-		anno@subset_rule$value = subset_matrix_by_row
406
-		if(!is.null(pch)) {
407
-			anno@subset_rule$pch = subset_matrix_by_row
408
-		}
409
-	} else {
410
-		anno@subset_rule$value = subset_vector
411
-		if(!is.null(pch)) {
412
-			anno@subset_rule$pch = subset_vector
413
-			anno@subset_rule$pt_size = subset_vector
414
-			anno@subset_rule$pt_gp = subset_gp
415
-		}
416
-	}
417
-
418
-	anno@subsetable = TRUE
419
-
420
-	return(anno)      
421
-}
422
-
423
-anno_image = function(image, which = c("column", "row"), border = TRUE, 
424
-	gp = gpar(fill = NA, col = NA), space = unit(1, "mm"), width = NULL, height = NULL) {
425
-
426
-	allowed_image_type = c("png", "svg", "pdf", "eps", "jpeg", "jpg", "tiff")
427
-
428
-	if(inherits(image, "character")) { ## they are file path
429
-		image_type = tolower(gsub("^.*\\.(\\w+)$", "\\1", image))
430
-		if(! all(image_type %in% allowed_image_type)) {
431
-			stop("image file should be of png/svg/pdf/eps/jpeg/jpg/tiff.")
432
-		}
433
-	} else {
434
-		stop("`image` should be a vector of path.")
435
-	}
436
-
437
-	n_image = length(image)
438
-	image_list = vector("list", n_image)
439
-	image_class = vector("character", n_image)
440
-	for(i in seq_along(image)) {
441
-		if(image_type[i] == "png") {
442
-			if(!requireNamespace("png")) {
443
-				stop("Need png package to read png images.")
444
-			}
445
-			image_list[[i]] = png::readPNG(image[i])
446
-			image_class[i] = "raster"
447
-		} else if(image_type[i] %in% c("jpeg", "jpg")) {
448
-			if(!requireNamespace("jpeg")) {
449
-				stop("Need jpeg package to read jpeg/jpg images.")
450
-			}
451
-			image_list[[i]] = jpeg::readJPEG(image[i])
452
-			image_class[i] = "raster"
453
-		} else if(image_type[i] == "tiff") {
454
-			if(!requireNamespace("tiff")) {
455
-				stop("Need tiff package to read tiff images.")
456
-			}
457
-			image_list[[i]] = tiff::readTIFF(image[i])
458
-			image_class[i] = "raster"
459
-		} else if(image_type[i] %in% c("pdf", "eps")) {
460
-			if(!requireNamespace("grImport")) {
461
-				stop("Need grImport package to read pdf/eps images.")
462
-			}
463
-			temp_file = tempfile()
464
-			getFromNamespace("PostScriptTrace", ns = "grImport")(image[[i]], temp_file)
465
-			image_list[[i]] = grImport::readPicture(temp_file)
466
-			file.remove(temp_file)
467
-			image_class[i] = "grImport::Picture"
468
-		} else if(image_type[i] == "svg") {
469
-			if(!requireNamespace("grImport2")) {
470
-				stop("Need grImport2 package to read svg images.")
471
-			}
472
-			if(!requireNamespace("rsvg")) {
473
-				stop("Need rsvg package to convert svg images.")
474
-			}
475
-			temp_file = tempfile()
476
-			rsvg::rsvg_svg(image[i], temp_file)
477
-			image_list[[i]] = grImport2::readPicture(temp_file)
478
-			file.remove(temp_file)
479
-			image_class[i] = "grImport2::Picture"
480
-		}
481
-	}
482
-	yx_asp = sapply(image_list, function(x) {
483
-		if(inherits(x, "array")) {
484
-			nrow(x)/ncol(x)
485
-		} else if(inherits(x, "Picture")) {
486
-			max(x@summary@yscale)/max(x@summary@xscale)
487
-		}
488
-	})
489
-
490
-	if(is.null(.ENV$current_annotation_which)) {
491
-		which = match.arg(which)[1]
492
-	} else {
493
-		which = .ENV$current_annotation_which
494
-	}
495
-
496
-	space = space[1]
497
-
498
-	anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
499
-
500
-	gp = recycle_gp(gp, n_image)
501
-	
502
-	column_fun = function(index) {
503
-		n = length(index)
504
-
505
-		pushViewport(viewport())
506
-		asp = convertHeight(unit(1, "npc") - space*2, "mm", valueOnly = TRUE)/convertWidth(unit(1/n, "npc") - space*2, "mm", value = TRUE)
507
-		grid.rect(x = (1:n - 0.5)/n, width = 1/n, gp = subset_gp(gp, index))
508
-		for(i in seq_len(n)) {
509
-			if(yx_asp[ index[i] ] > asp) {
510
-				height = unit(1, "npc") - space*2
511
-				width = convertHeight(height, "mm")*yx_asp[ index[i] ]
512
-			} else {
513
-				width = unit(1/n, "npc") - space*2
514
-				height = yx_asp[ index[i] ]*convertWidth(width, "mm")
515
-			}
516
-			if(image_class[ index[i] ] == "raster") {
517
-				grid.raster(image_list[[i]], x = (i-0.5)/n, width = width, height = height)
518
-			} else if(image_class[ index[i] ] == "grImport::Picture") {
519
-				grid.picture = getFromNamespace("grid.picture", ns = "grImport")
520
-				grid.picture(image_list[[i]], x = (i-0.5)/n, width = width, height = height)
521
-			} else if(image_class[ index[i] ] == "grImport2::Picture") {
522
-				grid.picture = getFromNamespace("grid.picture", ns = "grImport2")
523
-				grid.picture(image_list[[i]], x = (i-0.5)/n, width = width, height = height)
524
-			}
525
-		}
526
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
527
-		popViewport()
528
-	}
529
-
530
-	row_fun = function(index) {
531
-		n = length(index)
532
-
533
-		pushViewport(viewport())
534
-		asp = convertHeight(unit(1/n, "npc") - space*2, "mm", valueOnly = TRUE)/convertWidth(unit(1, "npc") - space*2, "mm", value = TRUE)
535
-		grid.rect(y = (n - 1:n + 0.5)/n, height = 1/n, gp = subset_gp(gp, index))
536
-		for(i in seq_len(n)) {
537
-			if(yx_asp[ index[i] ] > asp) {
538
-				height = unit(1/n, "npc") - space*2
539
-				width = convertHeight(height, "mm")*(1/yx_asp[ index[i] ])
540
-			} else {
541
-				width = unit(1, "npc") - space*2
542
-				height = yx_asp[ index[i] ]*convertWidth(width, "mm")
543
-			}
544
-			if(image_class[ index[i] ] == "raster") {
545
-				grid.raster(image_list[[i]], y = (n - i + 0.5)/n, width = width, height = height)
546
-			} else if(image_class[ index[i] ] == "grImport::Picture") {
547
-				grid.picture = getFromNamespace("grid.picture", ns = "grImport")
548
-				grid.picture(image_list[[i]], y = (n - i + 0.5)/n, width = width, height = height)
549
-			} else if(image_class[ index[i] ] == "grImport2::Picture") {
550
-				grid.picture = getFromNamespace("grid.picture", ns = "grImport2")
551
-				grid.picture(image_list[[i]], y = (n - i + 0.5)/n, width = width, height = height)
552
-			}
553
-		}
554
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
555
-		popViewport()
556
-	}
557
-	
558
-	if(which == "row") {
559
-		fun = row_fun
560
-	} else if(which == "column") {
561
-		fun = column_fun
562
-	}
563
-
564
-	anno = AnnotationFunction(
565
-		fun = fun,
566
-		fun_name = "anno_image",
567
-		which = which,
568
-		width = anno_size$width,
569
-		height = anno_size$height,
570
-		n = n_image,
571
-		data_scale = c(0.5, 1.5),
572
-		var_import = list(gp, border, space, yx_asp, image_list, image_class)
573
-	)
574
-
575
-	anno@subset_rule$gp = subset_vector
576
-	anno@subset_rule$image_list = subset_vector
577
-	anno@subset_rule$image_class = subset_vector
578
-
579
-	anno@subsetable = TRUE
580
-
581
-	return(anno)   
582
-}
583
-
584
-default_axis_param = function(which) {
585
-	list(
586
-		at = NULL, 
587
-		labels = NULL, 
588
-		labels_rot = ifelse(which == "column", 0, 90), 
589
-		gp = gpar(fontsize = 8), 
590
-		side = ifelse(which == "column", "left", "bottom"), 
591
-		facing = "outside"
592
-	)
593
-}
594
-
595
-validate_axis_param = function(axis_param, which) {
596
-	dft = default_axis_param(which)
597
-	for(nm in names(axis_param)) {
598
-		dft[[nm]] = axis_param[[nm]]
599
-	}
600
-	return(dft)
601
-}
602
-
603
-construct_axis_grob = function(axis_param, which, data_scale) {
604
-	axis_param_default = default_axis_param(which)
605
-
606
-	for(nm in setdiff(names(axis_param_default), names(axis_param))) {
607
-		axis_param[[nm]] = axis_param_default[[nm]]
608
-	}
609
-	
610
-	if(is.null(axis_param$at)) {
611
-		at = pretty_breaks(data_scale)
612
-		axis_param$at = at
613
-		axis_param$labels = at
614
-	}
615
-	if(is.null(axis_param$labels)) {
616
-		axis_param$labels = axis_param$at
617
-	}
618
-	axis_grob = do.call(annotation_axis_grob, axis_param)
619
-	
620
-	return(axis_grob)
621
-}
622
-
623
-# == title
624
-# Using points as annotation
625
-#
626
-# == param
627
-# -x a vector of numeric values.
628
-# -which is the annotation a column annotation or a row annotation?
629
-# -border whether show border of the annotation compoment
630
-# -gp graphic parameters.
631
-# -pch point type.
632
-# -size point size.
633
-# -ylim data ranges.
634
-# -axis whether add axis.
635
-# -axis_side if it is placed as column annotation, value can only be "left" or "right".
636
-#            If it is placed as row annotation, value can only be "bottom" or "top".
637
-# -axis_gp graphic parameters for axis
638
-# -axis_direction if the annotation is row annotation, should the axis be from left to right (default) or follow the reversed direction?
639
-# -... for future use.
640
-#
641
-# == value
642
-# A graphic function which can be set in `HeatmapAnnotation` constructor method.
643
-#
644
-# == author
645
-# Zuguang Gu <z.gu@dkfz.de>
646
-#
647
-anno_points = function(x, which = c("column", "row"), border = TRUE, gp = gpar(), pch = 16, 
648
-	size = unit(2, "mm"), ylim = NULL, extend = 0.05, axis = TRUE,
649
-	axis_param = default_axis_param(which),
650
-	width = NULL, height = NULL) {
651
-
652
-	if(is.null(.ENV$current_annotation_which)) {
653
-		which = match.arg(which)[1]
654
-	} else {
655
-		which = .ENV$current_annotation_which
656
-	}
657
-
658
-	if(is.data.frame(x)) x = as.matrix(x)
659
-	if(is.matrix(x)) {
660
-		if(ncol(x) == 1) {
661
-			x = x[, 1]
662
-		}
663
-	}
664
-	input_is_matrix = is.matrix(x)
665
-
666
-	anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
667
-
668
-	if(is.matrix(x)) {
669
-		n = nrow(x)
670
-		nr = n
671
-		nc = ncol(x)
672
-	} else {
673
-		n = length(x)
674
-		nr = n
675
-		nc = 1
676
-	}
677
-
678
-	if(is.atomic(x)) {
679
-		gp = recycle_gp(gp, n)
680
-		if(length(pch) == 1) pch = rep(pch, n)
681
-		if(length(size) == 1) size = rep(size, n)
682
-	} else if(input_is_matrix) {
683
-		gp = recycle_gp(gp, nc)
684
-		if(length(pch) == 1) pch = rep(pch, nc)
685
-		if(length(size) == 1) size = rep(size, nc)
686
-	}
687
-	
688
-	if(is.null(ylim)) {
689
-		data_scale = range(x, na.rm = TRUE)
690
-	} else {
691
-		data_scale = ylim
692
-	}
693
-	data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
694
-
695
-	value = x
696
-
697
-	axis_param = validate_axis_param(axis_param, which)
698
-	axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
699
-
700
-	row_fun = function(index) {
701
-		n = length(index)
702
-
703
-		pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
704
-		if(is.matrix(value)) {
705
-			for(i in seq_len(ncol(value))) {
706
-				grid.points(value[index, i], n - seq_along(index) + 1, gp = subset_gp(gp, i), 
707
-					default.units = "native", pch = pch[i], size = size[i])
708
-			}
709
-		} else {
710
-			grid.points(value[index], n - seq_along(index) + 1, gp = gp, default.units = "native", 
711
-				pch = pch[index], size = size[index])
712
-		}
713
-		if(axis) grid.draw(axis_grob)
714
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
715
-		popViewport()
716
-	}
717
-
718
-	column_fun = function(index) {
719
-		n = length(index)
720
-		
721
-		pushViewport(viewport(yscale = data_scale, xscale = c(0.5, n+0.5)))
722
-		if(is.matrix(value)) {
723
-			for(i in seq_len(ncol(value))) {
724
-				grid.points(seq_along(index), value[index, i], gp = subset_gp(gp, i), default.units = "native", pch = pch[i], size = size[i])
725
-			}
726
-		} else {
727
-			grid.points(seq_along(index), value[index], gp = gp, default.units = "native", pch = pch[index], size = size[index])
728
-		}
729
-		if(axis) grid.draw(axis_grob)
730
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
731
-		popViewport()
732
-	}
733
-
734
-	if(which == "row") {
735
-		fun = row_fun
736
-	} else if(which == "column") {
737
-		fun = column_fun
738
-	}
739
-
740
-	anno = AnnotationFunction(
741
-		fun = fun,
742
-		fun_name = "anno_points",
743
-		which = which,
744
-		width = anno_size$width,
745
-		height = anno_size$height,
746
-		n = n,
747
-		data_scale = data_scale,
748
-		var_import = list(value, gp, border, pch, size, axis, axis_param, axis_grob, data_scale)
749
-	)
750
-
751
-	anno@subset_rule$gp = subset_vector
752
-	if(input_is_matrix) {
753
-		anno@subset_rule$value = subset_matrix_by_row
754
-	} else {
755
-		anno@subset_rule$value = subset_vector
756
-		anno@subset_rule$gp = subset_gp
757
-		anno@subset_rule$size = subset_vector
758
-		anno@subset_rule$pch = subset_vector
759
-	}
760
-
761
-	anno@subsetable = TRUE
762
-
763
-	anno@extended = update_anno_extend(anno, axis_grob, axis_param)
764
-		
765
-	return(anno) 
766
-}
767
-
768
-update_anno_extend = function(anno, axis_grob, axis_param) {
769
-	extended = anno@extended
770
-	if(axis_param$facing == "outside") {
771
-		if(axis_param$side == "left") {
772
-			extended[[2]] = convertWidth(grobWidth(axis_grob), "mm", valueOnly = TRUE)
773
-		} else if(axis_param$side == "right") {
774
-			extended[[4]] = convertWidth(grobWidth(axis_grob), "mm", valueOnly = TRUE)
775
-		} else if(axis_param$side == "top") {
776
-			extended[[3]] = convertHeight(grobHeight(axis_grob), "mm", valueOnly = TRUE)
777
-		} else if(axis_param$side == "bottom") {
778
-			extended[[1]] = convertHeight(grobHeight(axis_grob), "mm", valueOnly = TRUE)
779
-		}
780
-	}
781
-	return(extended)
782
-}
783
-
784
-anno_lines = function(x, which = c("column", "row"), border = TRUE, gp = gpar(), 
785
-	add_points = TRUE, pch = 16, size = unit(2, "mm"), pt_gp = gpar(), ylim = NULL, 
786
-	extend = 0.05, axis = TRUE, axis_param = default_axis_param(which),
787
-	width = NULL, height = NULL) {
788
-
789
-	if(is.null(.ENV$current_annotation_which)) {
790
-		which = match.arg(which)[1]
791
-	} else {
792
-		which = .ENV$current_annotation_which
793
-	}
794
-
795
-	if(is.data.frame(x)) x = as.matrix(x)
796
-	if(is.matrix(x)) {
797
-		if(ncol(x) == 1) {
798
-			x = x[, 1]
799
-		}
800
-	}
801
-	input_is_matrix = is.matrix(x)
802
-
803
-	anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
804
-
805
-	if(is.matrix(x)) {
806
-		n = nrow(x)
807
-		nr = n
808
-		nc = ncol(x)
809
-	} else {
810
-		n = length(x)
811
-		nr = n
812
-		nc = 1
813
-	}
814
-
815
-	if(is.atomic(x)) {
816
-		gp = recycle_gp(gp, 1)
817
-		pt_gp = recycle_gp(pt_gp, n)
818
-		if(length(pch) == 1) pch = rep(pch, n)
819
-		if(length(size) == 1) size = rep(size, n)
820
-	} else if(input_is_matrix) {
821
-		gp = recycle_gp(gp, nc)
822
-		pt_gp = recycle_gp(pt_gp, nc)
823
-		if(length(pch) == 1) pch = rep(pch, nc)
824
-		if(length(size) == 1) size = rep(size, nc)
825
-	}
826
-	
827
-	if(is.null(ylim)) {
828
-		data_scale = range(x, na.rm = TRUE)
829
-	} else {
830
-		data_scale = ylim
831
-	}
832
-	data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
833
-
834
-	value = x
835
-
836
-	axis_param = validate_axis_param(axis_param, which)
837
-	axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
838
-
839
-	row_fun = function(index) {
840
-		n = length(index)
841
-
842
-		pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
843
-		if(is.matrix(value)) {
844
-			for(i in seq_len(ncol(value))) {
845
-				grid.lines(value[index, i], n - seq_along(index) + 1, gp = subset_gp(gp, i), 
846
-					default.units = "native")
847
-				if(add_points) {
848
-					grid.points(value[index, i], n - seq_along(index) + 1, gp = subset_gp(pt_gp, i), 
849
-						default.units = "native", pch = pch[i], size = size[i])
850
-				}
851
-			}
852
-		} else {
853
-			grid.lines(value[index, i], n - seq_along(index) + 1, gp = gp, 
854
-				default.units = "native")
855
-			if(add_points) {
856
-				grid.points(value[index], n - seq_along(index) + 1, gp = gp, default.units = "native", 
857
-					pch = pch[index], size = size[index])
858
-			}
859
-		}
860
-		if(axis) grid.draw(axis_grob)
861
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
862
-		popViewport()
863
-	}
256
+setMethod(f = "width",
257
+	signature = "AnnotationFunction",
258
+	definition = function(object) {
259
+	object@width
260
+})
864 261
 
865
-	column_fun = function(index) {
866
-		n = length(index)
867
-		
868
-		pushViewport(viewport(yscale = data_scale, xscale = c(0.5, n+0.5)))
869
-		if(is.matrix(value)) {
870
-			for(i in seq_len(ncol(value))) {
871
-				grid.lines(seq_along(index), value[index, i], gp = subset_gp(gp, i), 
872
-					default.units = "native")
873
-				if(add_points) {
874
-					grid.points(seq_along(index), value[index, i], gp = subset_gp(pt_gp, i), 
875
-						default.units = "native", pch = pch[i], size = size[i])
876
-				}
877
-			}
878
-		} else {
879
-			grid.lines(seq_along(index), value[index], gp = gp, default.units = "native")
880
-			if(add_points) {
881
-				grid.points(seq_along(index), value[index], gp = pt_gp, default.units = "native", 
882
-					pch = pch[index], size = size[index])
883
-			}
884
-		}
885
-		if(axis) grid.draw(axis_grob)
886
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
887
-		popViewport()
888
-	}
262
+setReplaceMethod(f = "width",
263
+	signature = "AnnotationFunction",
264
+	definition = function(object, value, ...) {
265
+	object@width = value
266
+	object
267
+})
889 268
 
890
-	if(which == "row") {
891
-		fun = row_fun
892
-	} else if(which == "column") {
893
-		fun = column_fun
894
-	}
269
+setMethod(f = "height",
270
+	signature = "AnnotationFunction",
271
+	definition = function(object) {
272
+	object@height
273
+})
895 274
 
896
-	anno = AnnotationFunction(
897
-		fun = fun,
898
-		fun_name = "anno_points",
899
-		which = which,
900
-		width = anno_size$width,
901
-		height = anno_size$height,
902
-		n = n,
903
-		data_scale = data_scale,
904
-		var_import = list(value, gp, border, pch, size, pt_gp, axis, axis_param, axis_grob, data_scale, add_points)
905
-	)
275
+setReplaceMethod(f = "height",
276
+	signature = "AnnotationFunction",
277
+	definition = function(object, value, ...) {
278
+	object@height = value
279
+	object
280
+})
906 281
 
907
-	anno@subset_rule$gp = subset_vector
908
-	if(input_is_matrix) {
909
-		anno@subset_rule$value = subset_matrix_by_row
282
+setMethod(f = "size",
283
+	signature = "AnnotationFunction",
284
+	definition = function(object) {
285
+	if(object@which == "row") {
286
+		object@width
910 287
 	} else {
911
-		anno@subset_rule$value = subset_vector
912
-		anno@subset_rule$gp = subset_gp
913
-		anno@subset_rule$pt_gp = subset_gp
914
-		anno@subset_rule$size = subset_vector
915
-		anno@subset_rule$pch = subset_vector
916
-	}
917
-
918
-	anno@subsetable = TRUE
919
-
920
-	anno@extended = update_anno_extend(anno, axis_grob, axis_param)
921
-		
922
-	return(anno) 
923
-}
924
-
925
-# == title
926
-# Using barplot as annotation
927
-#
928
-# == param
929
-# -x a vector of numeric values. If the value is a matrix, columns of the matrix will be represented as
930
-#    stacked barplots. Note for stacked barplots, each row in the matrix should only contain values with same sign (either all positive or all negative).
931
-# -baseline baseline for bars. The value should be "min" or "max", or a numeric value. It is enforced to be zero
932
-#       for stacked barplots.
933
-# -which is the annotation a column annotation or a row annotation?
934
-# -border whether show border of the annotation compoment
935
-# -bar_width relative width of the bars, should less than one
936
-# -gp graphic parameters. If it is the stacked barplots, the length of the graphic parameter should 
937
-#     be same as the number of stacks.
938
-# -ylim data ranges.
939
-# -axis whether add axis
940
-# -axis_side if it is placed as column annotation, value can only be "left" or "right".
941
-#            If it is placed as row annotation, value can only be "bottom" or "top".
942
-# -axis_gp graphic parameters for axis
943
-# -axis_direction if the annotation is row annotation, should the axis be from left to right (default) or follow the reversed direction?
944
-# -... for future use.
945
-#
946
-# == value
947
-# A graphic function which can be set in `HeatmapAnnotation` constructor method.
948
-#
949
-# == author
950
-# Zuguang Gu <z.gu@dkfz.de>
951
-#
952
-anno_barplot = function(x, baseline = 0, which = c("column", "row"), border = TRUE, bar_width = 0.6,
953
-	gp = gpar(fill = "#CCCCCC"), ylim = NULL, extend = 0.05, axis = TRUE, 
954
-	axis_param = default_axis_param(which),
955
-	width = NULL, height = NULL) {
956
-
957
-	if(inherits(x, "list")) x = do.call("cbind", x)
958
-	if(inherits(x, "data.frame")) x = as.matrix(x)
959
-	if(inherits(x, "matrix")) {
960
-		sg = apply(x, 1, function(xx) all(sign(xx) %in% c(1, 0)) || all(sign(xx) %in% c(-1, 0)))
961
-		if(!all(sg)) {
962
-			stop_wrap("Since `x` is a matrix, the sign of each row should be either all positive or all negative.")
963
-		}
964
-	}
965
-	# convert everything to matrix
966
-	if(is.null(dim(x))) x = matrix(x, ncol = 1)
967
-	nc = ncol(x)
968
-	if(missing(gp)) {
969
-		gp = gpar(fill = grey(seq(0, 1, length = nc+2))[-c(1, nc+2)])
288
+		object@height
970 289
 	}
290
+})
971 291
 
972
-	data_scale = range(rowSums(x, na.rm = TRUE), na.rm = TRUE)
973
-	if(!is.null(ylim)) data_scale = ylim
974
-	if(baseline == "min") {
975
-		data_scale = data_scale + c(0, extend)*(data_scale[2] - data_scale[1])
976
-	} else if(baseline == "max") {
977
-		data_scale = data_scale + c(-extend, 0)*(data_scale[2] - data_scale[1])
292
+setReplaceMethod(f = "size",
293
+	signature = "AnnotationFunction",
294
+	definition = function(object, value, ...) {
295
+	if(object@which == "row") {
296
+		object@width = value
978 297
 	} else {
979
-		if(is.numeric(baseline)) {
980
-			if(baseline == 0 && all(rowSums(x) == 1)) {
981
-				data_scale = c(0, 1)
982
-			} else if(baseline <= min(x)) {
983
-				data_scale = c(baseline, extend*(data_scale[2] - baseline) + data_scale[2])
984
-			} else if(baseline >= rowSums(x)) {
985
-				data_scale = c(-extend*(baseline - data_scale[1]) + data_scale[1], baseline)
986
-			} else {
987
-				data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
988
-			}
989
-		}
298
+		object@height = value
990 299
 	}
300
+	object
301
+})
991 302
 
992
-	if(is.null(.ENV$current_annotation_which)) {
993
-		which = match.arg(which)[1]
303
+nobs.AnnotationFunction = function(x) {
304
+	if(x@n > 0) {
305
+		x@n
994 306
 	} else {
995
-		which = .ENV$current_annotation_which
996
-	}
997
-
998
-	anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
999
-
1000
-	if(nc == 1) {
1001
-		gp = recycle_gp(gp, nrow(x))
1002
-	} else  {
1003
-		gp = recycle_gp(gp, nc)
1004
-	}
1005
-
1006
-	value = x
1007
-	axis_param = validate_axis_param(axis_param, which)
1008
-	axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
1009
-
1010
-	row_fun = function(index) {
1011
-		n = length(index)
1012
-		
1013
-		pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
1014
-		if(ncol(value) == 1) {
1015
-			width = value[index] - baseline
1016
-			x_coor = width/2+baseline
1017
-			grid.rect(x = x_coor, y = n - seq_along(index) + 1, width = abs(width), height = 1*bar_width, default.units = "native", gp = subset_gp(gp, index))
1018
-		} else {
1019
-			for(i in seq_len(ncol(value))) {
1020
-				width = value[index, i]
1021
-				x_coor = rowSums(value[index, seq_len(i-1), drop = FALSE]) + width/2
1022
-				grid.rect(x = x_coor, y = n - seq_along(index) + 1, width = abs(width), height = 1*bar_width, default.units = "native", gp = subset_gp(gp, i))
1023
-			}
1024
-		}
1025
-		if(axis) grid.draw(axis_grob)
1026
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
1027
-		popViewport()
1028
-	}
1029
-	column_fun = function(index) {
1030
-		n = length(index)
1031
-	
1032
-		pushViewport(viewport(yscale = data_scale, xscale = c(0.5, n+0.5)))
1033
-		if(ncol(value) == 1) {
1034
-			height = value[index] - baseline
1035
-			y_coor = height/2+baseline
1036
-			grid.rect(y = y_coor, x = seq_along(index), height = abs(height), width = 1*bar_width, default.units = "native", gp = subset_gp(gp, index))
1037
-		} else {
1038
-			for(i in seq_len(ncol(value))) {
1039
-				height = value[index, i]
1040
-				y_coor = rowSums(value[index, seq_len(i-1), drop = FALSE]) + height/2
1041
-				grid.rect(y = y_coor, x = seq_along(index), height = abs(height), width = 1*bar_width, default.units = "native", gp = subset_gp(gp, i))
1042
-			}
1043
-		}
1044
-		if(axis) grid.draw(axis_grob)
1045
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
1046
-		popViewport()
1047
-	}
1048
-	
1049
-	if(which == "row") {
1050
-		fun = row_fun
1051
-	} else if(which == "column") {
1052
-		fun = column_fun
1053
-	}
1054
-	n = nrow(value)
1055
-
1056
-	anno = AnnotationFunction(
1057
-		fun = fun,
1058
-		fun_name = "anno_barplot",
1059
-		which = which,
1060
-		width = anno_size$width,
1061
-		height = anno_size$height,
1062
-		n = n,
1063
-		data_scale = data_scale,
1064
-		var_import = list(value, gp, border, bar_width, baseline, axis, axis_param, axis_grob, data_scale)
1065
-	)
1066
-
1067
-	anno@subset_rule$value = subset_matrix_by_row
1068
-	if(ncol(value) == 1) {
1069
-		anno@subset_rule$gp = subset_gp
1070
-	}
1071
-		
1072
-	anno@subsetable = TRUE
1073
-
1074
-	anno@extended = update_anno_extend(anno, axis_grob, axis_param)
1075
-
1076
-	return(anno) 
1077
-}
1078
-
1079
-# == title
1080
-# Using boxplot as annotation
1081
-#
1082
-# == param
1083
-# -x a matrix or a list. If ``x`` is a matrix and if ``which`` is ``column``, statistics for boxplot
1084
-#    is calculated by columns, if ``which`` is ``row``, the calculation is by rows.
1085
-# -which is the annotation a column annotation or a row annotation?
1086
-# -border whether show border of the annotation compoment
1087
-# -gp graphic parameters
1088
-# -ylim data ranges.
1089
-# -outline whether draw outliers
1090
-# -pch point type
1091
-# -size point size
1092
-# -axis whether add axis
1093
-# -axis_side if it is placed as column annotation, value can only be "left" or "right".
1094
-#            If it is placed as row annotation, value can only be "bottom" or "top".
1095
-# -axis_gp graphic parameters for axis
1096
-# -axis_direction if the annotation is row annotation, should the axis be from left to right (default) or follow the reversed direction?
1097
-#
1098
-# == value
1099
-# A graphic function which can be set in `HeatmapAnnotation` constructor method.
1100
-#
1101
-# == author
1102
-# Zuguang Gu <z.gu@dkfz.de>
1103
-#
1104
-anno_boxplot = function(x, which = c("column", "row"), border = TRUE,
1105
-	gp = gpar(fill = "#CCCCCC"), ylim = NULL, extend = 0.05, outline = TRUE, box_width = 0.6,
1106
-	pch = 1, size = unit(2, "mm"), axis = TRUE, axis_param = default_axis_param(which),
1107
-	width = NULL, height = NULL) {
1108
-
1109
-	if(is.null(.ENV$current_annotation_which)) {
1110
-		which = match.arg(which)[1]
1111
-	} else {
1112
-		which = .ENV$current_annotation_which
1113
-	}
1114
-
1115
-	anno_size = anno_width_and_height(which, width, height, unit(2, "cm"))
1116
-
1117
-	## convert matrix all to list (or data frame)
1118
-	if(is.matrix(x)) {
1119
-		if(which == "column") {
1120
-			value = as.data.frame(x)
1121
-		} else if(which == "row") {
1122
-			value = as.data.frame(t(x))
1123
-		}
1124
-	} else {
1125
-		value = x
1126
-	}
1127
-
1128
-	if(is.null(ylim)) {
1129
-		if(!outline) {
1130
-			boxplot_stats = boxplot(value, plot = FALSE)$stats
1131
-			data_scale = range(boxplot_stats)
1132
-		} else {
1133
-			data_scale = range(value, na.rm = TRUE)
1134
-		}
1135
-	} else {
1136
-		data_scale = ylim
1137
-	}
1138
-	data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
1139
-
1140
-	n = length(value)
1141
-	gp = recycle_gp(gp, n)
1142
-	if(length(pch) == 1) pch = rep(pch, n)
1143
-	if(length(size) == 1) size = rep(size, n)
1144
-
1145
-	axis_param = validate_axis_param(axis_param, which)
1146
-	axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
1147
-
1148
-	row_fun = function(index) {
1149
-
1150
-		n_all = length(value)
1151
-		value = value[index]
1152
-		boxplot_stats = boxplot(value, plot = FALSE)$stats
1153
-		
1154
-		n = length(index)
1155
-		gp = subset_gp(gp, index)
1156
-		pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
1157
-		
1158
-		grid.rect(x = boxplot_stats[2, ], y = n - seq_along(index) + 1,  
1159
-			height = 1*box_width, width = boxplot_stats[4, ] - boxplot_stats[2, ], just = "left", 
1160
-			default.units = "native", gp = gp)
1161
-
1162
-		grid.segments(boxplot_stats[5, ], n - seq_along(index) + 1 - 0.5*box_width, 
1163
-			          boxplot_stats[5, ], n - seq_along(index) + 1 + 0.5*box_width, 
1164
-			          default.units = "native", gp = gp)
1165
-		grid.segments(boxplot_stats[5, ], n - seq_along(index) + 1,
1166
-			          boxplot_stats[4, ], n - seq_along(index) + 1, 
1167
-			          default.units = "native", gp = gp)
1168
-		grid.segments(boxplot_stats[1, ], n - seq_along(index) + 1, 
1169
-			          boxplot_stats[2, ], n - seq_along(index) + 1, 
1170
-			          default.units = "native", gp = gp)
1171
-		grid.segments(boxplot_stats[1, ], n - seq_along(index) + 1 - 0.5*box_width, 
1172
-			          boxplot_stats[1, ], n - seq_along(index) + 1 + 0.5*box_width, 
1173
-			          default.units = "native", gp = gp)
1174
-		grid.segments(boxplot_stats[3, ], n - seq_along(index) + 1 - 0.5*box_width, 
1175
-			          boxplot_stats[3, ], n - seq_along(index) + 1 + 0.5*box_width, 
1176
-			          default.units = "native", gp = gp)
1177
-		if(outline) {
1178
-			for(i in seq_along(value)) {
1179
-				l1 = value[[i]] > boxplot_stats[5,i]
1180
-				if(sum(l1)) grid.points(y = rep(n - i + 1, sum(l1)), x = value[[i]][l1], 
1181
-					default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
1182
-				l2 = value[[i]] < boxplot_stats[1,i]
1183
-				if(sum(l2)) grid.points(y = rep(n - i + 1, sum(l2)), x = value[[i]][l2], 
1184
-					default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
1185
-			}
1186
-		}
1187
-		if(axis) grid.draw(axis_grob)
1188
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
1189
-		popViewport()
1190
-	}
1191
-	column_fun = function(index) {
1192
-		value = value[index]
1193
-		boxplot_stats = boxplot(value, plot = FALSE)$stats
1194
-
1195
-		n = length(index)
1196
-		gp = subset_gp(gp, index)
1197
-		pushViewport(viewport(xscale = c(0.5, n+0.5), yscale = data_scale))
1198
-		grid.rect(x = seq_along(index), y = boxplot_stats[2, ], 
1199
-			height = boxplot_stats[4, ] - boxplot_stats[2, ], width = 1*box_width, just = "bottom", 
1200
-			default.units = "native", gp = gp)
1201
-		
1202
-		grid.segments(seq_along(index) - 0.5*box_width, boxplot_stats[5, ],
1203
-			          seq_along(index) + 0.5*box_width, boxplot_stats[5, ], 
1204
-			          default.units = "native", gp = gp)
1205
-		grid.segments(seq_along(index), boxplot_stats[5, ],
1206
-			          seq_along(index), boxplot_stats[4, ], 
1207
-			          default.units = "native", gp = gp)
1208
-		grid.segments(seq_along(index), boxplot_stats[1, ],
1209
-			          seq_along(index), boxplot_stats[2, ], 
1210
-			          default.units = "native", gp = gp)
1211
-		grid.segments(seq_along(index) - 0.5*box_width, boxplot_stats[1, ],
1212
-			          seq_along(index) + 0.5*box_width, boxplot_stats[1, ], 
1213
-			          default.units = "native", gp = gp)
1214
-		grid.segments(seq_along(index) - 0.5*box_width, boxplot_stats[3, ],
1215
-			          seq_along(index) + 0.5*box_width, boxplot_stats[3, ], 
1216
-			          default.units = "native", gp = gp)
1217
-		if(outline) {	
1218
-			for(i in seq_along(value)) {
1219
-				l1 = value[[i]] > boxplot_stats[5,i]
1220
-				if(sum(l1)) grid.points(x = rep(i, sum(l1)), y = value[[i]][l1], 
1221
-					default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
1222
-				l2 = value[[i]] < boxplot_stats[1,i]
1223
-				if(sum(l2)) grid.points(x = rep(i, sum(l2)), y = value[[i]][l2], 
1224
-					default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
1225
-			}
1226
-		}
1227
-		if(axis) grid.draw(axis_grob)
1228
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
1229
-		popViewport()
1230
-	}
1231
-	
1232
-	if(which == "row") {
1233
-		fun = row_fun
1234
-	} else if(which == "column") {
1235
-		fun = column_fun
1236
-	}
1237
-
1238
-	anno = AnnotationFunction(
1239
-		fun = fun,
1240
-		fun_name = "anno_boxplot",
1241
-		which = which,
1242
-		n = n,
1243
-		width = anno_size$width,
1244
-		height = anno_size$height,
1245
-		data_scale = data_scale,
1246
-		var_import = list(value, gp, border, box_width, axis, axis_param, axis_grob, data_scale, pch, size, outline)
1247
-	)
1248
-
1249
-	anno@subset_rule$value = subset_vector
1250
-	anno@subset_rule$gp = subset_gp
1251
-	anno@subset_rule$pch = subset_vector
1252
-	anno@subset_rule$size = subset_vector
1253
-	
1254
-	anno@subsetable = TRUE
1255
-
1256
-	anno@extended = update_anno_extend(anno, axis_grob, axis_param)
1257
-
1258
-	return(anno) 
1259
-}
1260
-
1261
-# == title
1262
-# Using histogram as annotation
1263
-#
1264
-# == param
1265
-# -x a matrix or a list. If ``x`` is a matrix and if ``which`` is ``column``, statistics for histogram
1266
-#    is calculated by columns, if ``which`` is ``row``, the calculation is by rows.
1267
-# -which is the annotation a column annotation or a row annotation?
1268
-# -gp graphic parameters
1269
-# -... pass to `graphics::hist`
1270
-#
1271
-# == value
1272
-# A graphic function which can be set in `HeatmapAnnotation` constructor method.
1273
-#
1274
-# == author
1275
-# Zuguang Gu <z.gu@dkfz.de>
1276
-#
1277
-anno_histogram = function(x, which = c("column", "row"), n_breaks = 11, 
1278
-	border = FALSE, gp = gpar(fill = "#CCCCCC"), 
1279
-	axis = TRUE, axis_param = default_axis_param(which), 
1280
-	width = NULL, height = NULL) {
1281
-	
1282
-	if(is.null(.ENV$current_annotation_which)) {
1283
-		which = match.arg(which)[1]
1284
-	} else {
1285
-		which = .ENV$current_annotation_which
1286
-	}
1287
-
1288
-	anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
1289
-
1290
-	## convert matrix all to list (or data frame)
1291
-	if(is.matrix(x)) {
1292
-		if(which == "column") {
1293
-			value = as.data.frame(x)
1294
-		} else if(which == "row") {
1295
-			value = as.data.frame(t(x))
1296
-		}
1297
-	} else {
1298
-		value = x
1299
-	}
1300
-
1301
-	n = length(value)
1302
-	x_range =range(unlist(value), na.rm = TRUE)
1303
-	histogram_stats = lapply(value, hist, plot = FALSE, breaks = seq(x_range[1], x_range[2], length = n_breaks))
1304
-	histogram_breaks = lapply(histogram_stats, function(x) x$breaks)
1305
-	histogram_counts = lapply(histogram_stats, function(x) x$counts)
1306
-
1307
-	xscale = range(unlist(histogram_breaks), na.rm = TRUE)
1308
-	xscale = xscale + c(0, 0.05)*(xscale[2] - xscale[1])
1309
-	yscale = c(0, max(unlist(histogram_counts)))
1310
-	yscale[2] = yscale[2]*1.05
1311
-
1312
-	gp = recycle_gp(gp, n)
1313
-	axis_param = validate_axis_param(axis_param, which)
1314
-	axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
1315
-
1316
-	row_fun = function(index) {
1317
-		
1318
-		n_all = length(value)
1319
-		value = value[index]
1320
-		
1321
-		n = length(index)
1322
-		histogram_breaks = histogram_breaks[index]
1323
-		histogram_counts = histogram_counts[index]
1324
-
1325
-		gp = subset_gp(gp, index)
1326
-		for(i in seq_len(n)) {
1327
-			n_breaks = length(histogram_breaks[[i]])
1328
-			pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"), height = unit(1/n, "npc"), just = c("left", "bottom"), xscale = xscale, yscale = yscale))
1329
-			grid.rect(x = histogram_breaks[[i]][-1], y = 0, width = histogram_breaks[[i]][-1] - histogram_breaks[[i]][-n_breaks], height = histogram_counts[[i]], just = c("right", "bottom"), default.units = "native", gp = subset_gp(gp, i))	
1330
-			popViewport()
1331
-		}
1332
-		pushViewport(viewport(xscale = xscale))
1333
-		if(axis) grid.draw(axis_grob)
1334
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
1335
-		popViewport()
1336
-	}
1337
-	column_fun = function(index) {
1338
-		
1339
-		n_all = length(value)
1340
-		value = value[index]
1341
-		
1342
-		foo = yscale
1343
-		yscale = xscale
1344
-		xscale = foo
1345
-		histogram_breaks = histogram_breaks[index]
1346
-		histogram_counts = histogram_counts[index]
1347
-
1348
-		n = length(index)
1349
-		
1350
-		gp = subset_gp(gp, index)
1351
-		for(i in seq_len(n)) {
1352
-			n_breaks = length(histogram_breaks[[i]])
1353
-			pushViewport(viewport(y = unit(0, "npc"), x = unit(i/n, "npc"), width = unit(1/n, "npc"), 
1354
-				just = c("right", "bottom"), xscale = xscale, yscale = yscale))
1355
-			grid.rect(y = histogram_breaks[[i]][-1], x = 0, height = histogram_breaks[[i]][-1] - histogram_breaks[[i]][-n_breaks], 
1356
-				width = histogram_counts[[i]], just = c("left", "top"), default.units = "native", gp = subset_gp(gp, index[i]))	
1357
-			popViewport()
1358
-		}
1359
-		pushViewport(viewport(yscale = yscale))
1360
-		if(axis) grid.draw(axis_grob)
1361
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
1362
-		popViewport()
1363
-	}
1364
-	
1365
-	if(which == "row") {
1366
-		fun = row_fun
1367
-	} else if(which == "column") {
1368
-		fun = column_fun
1369
-	}
1370
-
1371
-	anno = AnnotationFunction(
1372
-		fun = fun,
1373
-		fun_name = "anno_histogram",
1374
-		which = which,
1375
-		width = anno_size$width,
1376
-		height = anno_size$height,
1377
-		n = n,
1378
-		data_scale = xscale,
1379
-		var_import = list(value, gp, border, axis, axis_param, axis_grob, xscale, yscale,
1380
-			histogram_breaks, histogram_counts)
1381
-	)
1382
-
1383
-	anno@subset_rule$value = subset_vector
1384
-	anno@subset_rule$gp = subset_gp
1385
-	anno@subset_rule$histogram_breaks = subset_vector
1386
-	anno@subset_rule$histogram_counts = subset_vector
1387
-	
1388
-	anno@subsetable = TRUE
1389
-
1390
-	anno@extended = update_anno_extend(anno, axis_grob, axis_param)
1391
-
1392
-	return(anno) 
1393
-}
1394
-
1395
-# == title
1396
-# Using kernel density as annotation
1397
-#
1398
-# == param
1399
-# -x a matrix or a list. If ``x`` is a matrix and if ``which`` is ``column``, statistics for density
1400
-#    is calculated by columns, if ``which`` is ``row``, the calculation is by rows.
1401
-# -which is the annotation a column annotation or a row annotation?
1402
-# -gp graphic parameters. Note it is ignored if ``type`` equals to ``heatmap``.
1403
-# -type which type of graphics is used to represent density distribution.
1404
-# -... pass to `stats::density`
1405
-#
1406
-# == value
1407
-# A graphic function which can be set in `HeatmapAnnotation` constructor method.
1408
-#
1409
-# == author
1410
-# Zuguang Gu <z.gu@dkfz.de>
1411
-#
1412
-anno_density = function(x, which = c("column", "row"), gp = gpar(fill = "#CCCCCC"),
1413
-	type = c("lines", "violin", "heatmap"), 
1414
-	heatmap_colors = rev(brewer.pal(name = "RdYlBu", n = 11)), 
1415
-	joyplot_scale = 1, border = TRUE,
1416
-	axis = TRUE, axis_param = default_axis_param(which),
1417
-	width = NULL, height = NULL) {
1418
-	
1419
-	if(is.null(.ENV$current_annotation_which)) {
1420
-		which = match.arg(which)[1]
1421
-	} else {
1422
-		which = .ENV$current_annotation_which
1423
-	}
1424
-
1425
-	anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
1426
-
1427
-	## convert matrix all to list (or data frame)
1428
-	if(is.matrix(x)) {
1429
-		if(which == "column") {
1430
-			value = as.data.frame(x)
1431
-		} else if(which == "row") {
1432
-			value = as.data.frame(t(x))
1433
-		}
1434
-	} else {
1435
-		value = x
1436
-	}
1437
-
1438
-	n = length(value)
1439
-	gp = recycle_gp(gp, n)
1440
-	type = match.arg(type)[1]
1441
-
1442
-	n_all = length(value)
1443
-	density_stats = lapply(value, density)
1444
-	density_x = lapply(density_stats, function(x) x$x)
1445
-	density_y = lapply(density_stats, function(x) x$y)
1446
-	
1447
-	min_density_x = min(unlist(density_x))
1448
-	max_density_x = max(unlist(density_x))
1449
-	
1450
-	xscale = range(unlist(density_x), na.rm = TRUE)
1451
-	xscale = xscale + c(0, 0.05)*(xscale[2] - xscale[1])
1452
-	if(type == "lines") {
1453
-		yscale = c(0, max(unlist(density_y)))
1454
-		yscale[2] = yscale[2]*1.05
1455
-	} else if(type == "violin") {
1456
-		yscale = max(unlist(density_y))
1457
-		yscale = c(-yscale*1.05, yscale*1.05)
1458
-	} else if(type == "heatmap") {
1459
-		xscale = range(unlist(density_x), na.rm = TRUE)
1460
-		yscale = c(0, 1)
1461
-		min_y = min(unlist(density_y))
1462
-		max_y = max(unlist(density_y))
1463
-		col_fun = colorRamp2(seq(min_y, max_y, 
1464
-			length = length(heatmap_colors)), heatmap_colors)
1465
-	}
1466
-
1467
-	axis_param = validate_axis_param(axis_param, which)
1468
-	axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
1469
-
1470
-	row_fun = function(index) {
1471
-		
1472
-		n = length(index)
1473
-		value = value[index]
1474
-		
1475
-		gp = subset_gp(gp, index)
1476
-		density_x = density_x[index]
1477
-		density_y = density_y[index]
1478
-
1479
-		for(i in seq_len(n)) {
1480
-			pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"), 
1481
-				just = c("left", "bottom"), height = unit(1/n, "npc"), xscale = xscale, 
1482
-				yscale = yscale))
1483
-			if(type == "lines") {
1484
-				grid.polygon(x = density_x[[i]], y = density_y[[i]]*joyplot_scale, 
1485
-					default.units = "native", gp = subset_gp(gp, i))
1486
-			} else if(type == "violin") {
1487
-				grid.polygon(x = c(density_x[[i]], rev(density_x[[i]])), 
1488
-					y = c(density_y[[i]], -rev(density_y[[i]])), default.units = "native", 
1489
-					gp = subset_gp(gp, i))
1490
-				box_stat = boxplot(value[[i]], plot = FALSE)$stat
1491
-				grid.lines(box_stat[1:2, 1], c(0, 0), default.units = "native", 
1492
-					gp = subset_gp(gp, i))
1493
-				grid.lines(box_stat[4:5, 1], c(0, 0), default.units = "native", 
1494
-					gp = subset_gp(gp, i))
1495
-				grid.points(box_stat[3, 1], 0, default.units = "native", pch = 3, 
1496
-					size = unit(1, "mm"), gp = subset_gp(gp, i))
1497
-			} else if(type == "heatmap") {
1498
-				n_breaks = length(density_x[[i]])
1499
-				grid.rect(x = density_x[[i]][-1], y = 0, 
1500
-					width = density_x[[i]][-1] - density_x[[i]][-n_breaks], height = 1, 
1501
-					just = c("right", "bottom"), default.units = "native", 
1502
-					gp = gpar(fill = col_fun((density_y[[i]][-1] + density_y[[i]][-n_breaks])/2), 
1503
-						col = NA))
1504
-				grid.rect(x = density_x[[i]][1], y = 0, width = density_x[[i]][1] - min_density_x, 
1505
-					height = 1, just = c("right", "bottom"), default.units = "native", 
1506
-					gp = gpar(fill = col_fun(0), col = NA))
1507
-				grid.rect(x = density_x[[i]][n_breaks], y = 0, 
1508
-					width = max_density_x - density_x[[i]][n_breaks], height = 1, 
1509
-					just = c("left", "bottom"), default.units = "native", 
1510
-					gp = gpar(fill = col_fun(0), col = NA))
1511
-			}
1512
-			popViewport()
1513
-		}
1514
-		pushViewport(viewport(xscale = xscale))
1515
-		if(axis) grid.draw(axis_grob)
1516
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
1517
-		popViewport()
1518
-	}
1519
-	column_fun = function(index) {
1520
-
1521
-		n_all = length(value)
1522
-		value = value[index]
1523
-		
1524
-		foo = yscale
1525
-		yscale = xscale
1526
-		xscale = foo
1527
-
1528
-		density_x = density_x[index]
1529
-		density_y = density_y[index]
1530
-		
1531
-		yscale = range(unlist(density_x), na.rm = TRUE)
1532
-		yscale = yscale + c(0, 0.05)*(yscale[2] - yscale[1])
1533
-		if(type == "lines") {
1534
-			xscale = c(0, max(unlist(density_y)))
1535
-			xscale[2] = xscale[2]*1.05
1536
-		} else if(type == "violin") {
1537
-			xscale = max(unlist(density_y))
1538
-			xscale = c(-xscale*1.05, xscale*1.05)
1539
-		} else if(type == "heatmap") {
1540
-			yscale = range(unlist(density_x), na.rm = TRUE)
1541
-			xscale = c(0, 1)
1542
-			min_y = min(unlist(density_y))
1543
-			max_y = max(unlist(density_y))
1544
-			col_fun = colorRamp2(seq(min_y, max_y, 
1545
-				length = length(heatmap_colors)), heatmap_colors)
1546
-		}
1547
-
1548
-		n = length(index)
1549
-		gp = subset_gp(gp, index)
1550
-
1551
-		for(i in rev(seq_len(n))) {
1552
-			pushViewport(viewport(y = unit(0, "npc"), x = unit(i/n, "npc"), width = unit(1/n, "npc"), 
1553
-				just = c("right", "bottom"), xscale = xscale, yscale = yscale))
1554
-			if(type == "lines") {
1555
-				grid.polygon(y = density_x[[i]], x = density_y[[i]]*joyplot_scale, 
1556
-					default.units = "native", gp = subset_gp(gp, index[i]))
1557
-			} else if(type == "violin") {
1558
-				grid.polygon(y = c(density_x[[i]], rev(density_x[[i]])), 
1559
-					x = c(density_y[[i]], -rev(density_y[[i]])), default.units = "native", 
1560
-					gp = subset_gp(gp, index[i]))
1561
-				box_stat = boxplot(value[[i]], plot = FALSE)$stat
1562
-				grid.lines(y = box_stat[1:2, 1], x = c(0, 0), default.units = "native", 
1563
-					gp = subset_gp(gp, i))
1564
-				grid.lines(y = box_stat[4:5, 1], x = c(0, 0), default.units = "native", 
1565
-					gp = subset_gp(gp, i))
1566
-				grid.points(y = box_stat[3, 1], x = 0, default.units = "native", pch = 3, 
1567
-					size = unit(1, "mm"), gp = subset_gp(gp, i))	
1568
-			} else if(type == "heatmap") {
1569
-				n_breaks = length(density_x[[i]])
1570
-				grid.rect(y = density_x[[i]][-1], x = 0, 
1571
-					height = density_x[[i]][-1] - density_x[[i]][-n_breaks], width = 1, 
1572
-					just = c("left", "top"), default.units = "native", 
1573
-					gp = gpar(fill = col_fun((density_y[[i]][-1] + density_y[[i]][-n_breaks])/2), 
1574
-						col = NA))
1575
-				grid.rect(y = density_x[[i]][1], x = 0, height = density_x[[i]][1] - min_density_x, 
1576
-					width = 1, just = c("left", "top"), default.units = "native", 
1577
-					gp = gpar(fill = col_fun(0), col = NA))
1578
-				grid.rect(y = density_x[[i]][n_breaks], x = 0, 
1579
-					height = max_density_x - density_x[[i]][n_breaks], width = 1, 
1580
-					just = c("left", "bottom"), default.units = "native", 
1581
-					gp = gpar(fill = col_fun(0), col = NA))
1582
-			}
1583
-			popViewport()
1584
-		}
1585
-		pushViewport(viewport(yscale = yscale))
1586
-		if(axis) grid.draw(axis_grob)
1587
-		if(border) grid.rect(gp = gpar(fill = "transparent"))
1588
-		popViewport()
1589
-	}
1590
-	
1591
-	if(which == "row") {
1592
-		fun = row_fun
1593
-	} else if(which == "column") {
1594
-		fun = column_fun
1595
-	}
1596
-
1597
-	anno = AnnotationFunction(
1598
-		fun = fun,
1599
-		fun_name = "anno_density",
1600
-		which = which,
1601
-		width = anno_size$width,
1602
-		height = anno_size$height,
1603
-		n = n,
1604
-		data_scale = xscale,
1605
-		var_import = list(value, gp, border, type, axis, axis_param, axis_grob, xscale, yscale, density_x,
1606
-			density_y, min_density_x, max_density_x, joyplot_scale)
1607
-	)
1608
-
1609
-	if(type == "heatmap") {
1610
-		anno@var_env$col_fun = col_fun
1611
-	}
1612
-
1613
-	anno@subset_rule$value = subset_vector
1614
-	anno@subset_rule$gp = subset_gp
1615
-	anno@subset_rule$density_x = subset_vector
1616
-	anno@subset_rule$density_y = subset_vector
1617
-	
1618
-	anno@subsetable = TRUE
1619
-
1620
-	anno@extended = update_anno_extend(anno, axis_grob, axis_param)
1621
-
1622
-	return(anno)
1623
-}
1624
-
1625
-# == title
1626
-# Using text as annotation
1627
-#
1628
-# == param
1629
-# -x a vector of text
1630
-# -which is the annotation a column annotation or a row annotation?
1631
-# -gp graphic parameters.
1632
-# -rot rotation of text
1633
-# -just justification of text, pass to `grid::grid.text`
1634
-# -offset if it is a row annotation, ``offset`` corresponds to the x-coordinates of text.
1635
-#         and if it is a column annotation, ``offset`` corresponds to the y-coordinates of text.
1636
-#         The value should be a `grid::unit` object.
1637
-#
1638
-# == value
1639
-# A graphic function which can be set in `HeatmapAnnotation` constructor method.
1640
-#
1641
-# == author
1642
-# Zuguang Gu <z.gu@dkfz.de>
1643
-#
1644
-anno_text = function(x, which = c("column", "row"), gp = gpar(), 
1645
-	rot = guess_rot(), just = guess_just(), 
1646
-	offset = guess_location(), location = guess_location(),
1647
-	width = NULL, height = NULL) {
1648
-
1649
-	if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
1650
-		which = get("which", envir = parent.frame())
1651
-	} else {
1652
-		which = match.arg(which)[1]
1653
-	}
1654
-
1655
-	n = length(x)
1656
-	gp = recycle_gp(gp, n)
1657
-
1658
-	guess_rot = function() {
1659
-		ifelse(which == "column", 90, 0)
1660
-	}
1661
-
1662
-	guess_just = function() {
1663
-		ifelse(which == "column", "right", "left")
1664
-	}
1665
-
1666
-	guess_location = function() {
1667
-		unit(ifelse(which == "column", 1, 0), "npc")
1668
-	}
1669
-
1670
-	rot = rot[1] %% 360
1671
-	just = just[1]
1672
-	if(!missing(offset)) {
1673
-		warning("`offset` is deprecated, use `location` instead.")
1674
-		if(missing(location)) {
1675
-			location = offset
1676
-		}
1677
-	}
1678
-	location = location[1]
1679
-	if(!inherits(location, "unit")) {
1680
-		location = unit(location, "npc")
1681
-	}
1682
-
1683
-	if(which == "column") {
1684
-		if("right" %in% just) {
1685
-			location = location - 0.5*grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
1686
-		} else if("left" %in% just) {
1687
-			location = location + 0.5*grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
1688
-		}
1689
-	}
1690
-
1691
-	if(which == "column") {
1692
-		if(missing(height)) {
1693
-			height = max_text_width(x, gp = gp)*abs(sin(rot/180*pi)) + grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
1694
-			height = convertHeight(height, "mm")
1695
-		}
1696
-		if(missing(width)) {
1697
-			width = unit(1, "npc")
1698
-		}
1699
-	}
1700
-	if(which == "row") {
1701
-		if(missing(width)) {
1702
-			width = max_text_width(x, gp = gp)*cos(rot/180*pi) + grobHeight(textGrob("A", gp = gp))*sin(rot/180*pi)
1703
-			width = convertWidth(width, "mm")
1704
-		}
1705
-		if(missing(height)) {
1706
-			height = unit(1, "npc")
1707
-		}
1708
-	}
1709
-
1710
-	anno_size = list(width = width, height = height)
1711
-
1712
-	value = x
1713
-
1714
-	row_fun = function(index) {
1715
-		n = length(index)
1716
-		grid.text(value[index], location, (n - seq_along(index) + 0.5)/n, gp = subset_gp(gp, index), just = just, rot = rot)
1717
-	}
1718
-	column_fun = function(index, k = NULL, N = NULL, vp_name = NULL) {
1719
-		n = length(index)
1720
-		grid.text(value[index], (seq_along(index) - 0.5)/n, location, gp = subset_gp(gp, index), just = just, rot = rot)
1721
-	}
1722
-
1723
-	if(which == "row") {
1724
-		fun = row_fun
1725
-	} else if(which == "column") {
1726
-		fun = column_fun
1727
-	}
1728
-
1729
-	anno = AnnotationFunction(
1730
-		fun = fun,
1731
-		fun_name = "anno_text",
1732
-		which = which,
1733
-		width = width,
1734
-		height = height,
1735
-		n = n,
1736
-		var_import = list(value, gp, just, rot, location)
1737
-	)
1738
-
1739
-	anno@subset_rule$value = subset_vector
1740
-	anno@subset_rule$gp = subset_gp
1741
-
1742
-	anno@subsetable = TRUE
1743
-
1744
-	return(anno)
1745
-}
1746
-
1747
-anno_joyplot = function(x, which = c("column", "row"), gp = gpar(fill = "#000000"),
1748
-	scale = 2, transparency = 0.6,
1749
-	axis = TRUE, axis_param = default_axis_param(which),
1750
-	width = NULL, height = NULL) {
1751
-	
1752
-	if(is.null(.ENV$current_annotation_which)) {
1753
-		which = match.arg(which)[1]
1754
-	} else {
1755
-		which = .ENV$current_annotation_which
1756
-	}
1757
-
1758
-	anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
1759
-
1760
-	## convert matrix all to list (or data frame)
1761
-	if(is.matrix(x) || is.data.frame(x)) {
1762
-		value = vector("list", ncol(x))
1763
-		for(i in seq_len(ncol(x))) {
1764
-			value[[i]] = cbind(seq_len(nrow(x), x[, i]))
1765
-		}
1766
-	} else if(inherits(x, "list")){
1767
-		if(all(sapply(x, is.atomic))) {
1768
-			if(length(unique(sapply(x, length))) == 1) {
1769
-				value = vector("list", length(x))
1770
-				for(i in seq_len(length(x))) {
1771
-					value[[i]] = cbind(seq_along(x[[i]]), x[[i]])
1772
-				}
1773
-			} else {
1774
-				stop("Since x is a list, x need to be a list of two-column matrices.")
1775
-			}
1776
-		} else {
1777
-			value = x
1778
-		}
1779
-	} else {
1780
-		stop("The input should be a list of two-column matrices or a matrix/data frame.")
1781
-	}
1782
-
1783
-	xscale = range(lapply(value, function(x) x[, 1]), na.rm = TRUE)
1784
-	xscale = xscale + c(-0.05, 0.05)*(xscale[2] - xscale[1])
1785
-	yscale = range(lapply(value, function(x) x[, 2]), na.rm = TRUE)
1786
-	yscale[1] = 0
1787
-	yscale[2] = yscale[2]*1.05
1788
-
1789
-	n = length(value)
1790
-
1791
-	if(!"fill" %in% names(gp)) {
1792
-		gp$fill = "#000000"
1793
-	} 
1794
-	gp = recycle_gp(gp, n)
1795
-	gp$fill = add_transparency(gp$fill, transparency)
1796
-	axis_param = validate_axis_param(axis_param, which)
1797
-	axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
1798
-
1799
-	row_fun = function(index) {
1800
-
1801
-		n_all = length(value)
1802
-		value = value[index]
1803
-		
1804
-		n = length(index)
1805
-		gp = subset_gp(gp, index)
1806
-
1807
-		for(i in seq_len(n)) {
1808
-			pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"), 
1809
-				just = c("left", "bottom"), height = unit(1/n, "npc"), xscale = xscale, 
1810
-				yscale = yscale))
1811
-			
1812
-			x0 = value[[i]][, 1]
1813
-			y0 = value[[i]][, 2]*scale
1814
-			x0 = c(x0[1], x0, x0[length(x0)])
1815
-			y0 = c(0, y0, 0)
1816
-			gppp = subset_gp(gp, i); gppp$col = NA
1817
-			grid.polygon(x = x0, y = y0, default.units = "native", gp = gppp)
1818
-			grid.lines(x = x0, y = y0, default.units = "native", 
1819
-				gp = subset_gp(gp, i))
1820
-			
1821
-			popViewport()
1822
-		}
1823
-		pushViewport(viewport(xscale = xscale))
1824
-		if(axis) grid.draw(axis_grob)
1825
-		popViewport()
1826
-	}
1827
-	column_fun = function(index) {
1828
-
1829
-		n_all = length(value)
1830
-		value = value[index]
1831
-		
1832
-		foo = yscale
1833
-		yscale = xscale
1834
-		xscale = foo
1835
-		
1836
-		n = length(index)
1837
-		
1838
-		gp = subset(gp, index)
1839
-
1840
-		for(i in seq_len(n)) {
1841
-			pushViewport(viewport(y = unit(0, "npc"), x = unit(i/n, "npc"), 
1842
-				width = unit(1/n, "npc"), just = c("right", "bottom"), xscale = xscale, 
1843
-				yscale = yscale))
1844
-			
1845
-			x0 = value[[i]][, 2]*scale
1846
-			y0 = value[[i]][ ,1]
1847
-			x0 = c(0, x0, 0)
1848
-			y0 = c(y0[1], y0, y0[length(y0)])
1849
-			gppp = subset_gp(gp, i); gppp$col = NA
1850
-			grid.polygon(y = y0, x = x0, default.units = "native", gp = gppp)
1851
-			grid.lines(y = y0, x = x0, default.units = "native", 
1852
-				gp = subset_gp(gp, i))
1853
-			
1854
-			popViewport()
1855
-		}
1856
-		pushViewport(viewport(yscale = yscale))
1857
-		if(axis) grid.draw(axis_grob)
1858
-		popViewport()
1859
-	}
1860
-	
1861
-	if(which == "row") {
1862
-		fun = row_fun
1863
-	} else if(which == "column") {
1864
-		fun = column_fun
1865
-	}
1866
-
1867
-	anno = AnnotationFunction(
1868
-		fun = fun,
1869
-		fun_name = "anno_joyplot",
1870
-		which = which,
1871
-		width = anno_size$width,
1872
-		height = anno_size$height,
1873
-		n = n,
1874
-		data_scale = xscale,
1875
-		var_import = list(value, gp, axis, axis_param, axis_grob, scale, yscale, xscale)
1876
-	)
1877
-
1878
-	anno@subset_rule$value = subset_vector
1879
-	anno@subset_rule$gp = subset_gp
1880
-
1881
-	anno@subsetable = TRUE
1882
-
1883
-	anno@extended = update_anno_extend(anno, axis_grob, axis_param)
1884
-
1885
-	return(anno)
1886
-}
1887
-
1888
-
1889
-anno_horizon = function(x, which = c("column", "row"), 
1890
-	gp = gpar(pos_fill = "#D73027", neg_fill = "#313695"),
1891
-	n_slice = 4, slice_size = NULL, negative_from_top = FALSE, 
1892
-	normalize = TRUE, border = FALSE, gap = unit(0, "mm"),
1893
-	axis = TRUE, axis_param = default_axis_param(which),
1894
-	width = NULL, height = NULL) {
1895
-
1896
-	if(is.null(.ENV$current_annotation_which)) {
1897
-		which = match.arg(which)[1]
1898
-	} else {
1899
-		which = .ENV$current_annotation_which
1900
-	}
1901
-
1902
-	anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
1903
-
1904
-	## convert matrix all to list (or data frame)
1905
-	if(is.matrix(x) || is.data.frame(x)) {
1906
-		value = vector("list", ncol(x))
1907
-		for(i in seq_len(ncol(x))) {
1908
-			value[[i]] = cbind(seq_len(nrow(x), x[, i]))
1909
-		}
1910
-	} else if(inherits(x, "list")){
1911
-		if(all(sapply(x, is.atomic))) {
1912
-			if(length(unique(sapply(x, length))) == 1) {
1913
-				value = vector("list", length(x))
1914
-				for(i in seq_len(length(x))) {
1915
-					value[[i]] = cbind(seq_along(x[[i]]), x[[i]])
1916
-				}
1917
-			} else {
1918
-				stop("Since x is a list, x need to be a list of two-column matrices.")
1919
-			}
1920
-		} else {
1921
-			value = x
1922
-		}
1923
-	} else {
1924
-		stop("The input should be a list of two-column matrices or a matrix/data frame.")
1925
-	}
1926
-
1927
-	if(is.null(gp$pos_fill)) gp$pos_fill = "#D73027"
1928
-	if(is.null(gp$neg_fill)) gp$neg_fill = "#313695"
1929
-
1930
-	if("fill" %in% names(gp)) {
1931
-		foo = unlist(lapply(value, function(x) x[, 2]))
1932
-		if(all(foo >= 0)) {
1933
-			gp$pos_fill = gp$fill
1934
-		} else if(all(foo <= 0)) {
1935
-			gp$neg_fill = gp$fill
1936
-		} else {
1937
-			gp = gpar(pos_fill = "#D73027", neg_fill = "#313695")
1938
-		}
1939
-	}
1940
-
1941
-	if(which == "column") {
1942
-		stop("anno_horizon() does not support column annotation. If you want, please email me.")
1943
-	}
1944
-
1945
-	if(normalize) {
1946
-		value = lapply(value, function(m) {
1947
-			m[, 2] = m[, 2]/max(abs(m[, 2]))
1948
-			m
1949
-		})
1950
-	}
1951
-
1952
-	n = length(value)
1953
-	xscale = range(lapply(value, function(x) x[, 1]), na.rm = TRUE)
1954
-	yscale = range(lapply(value, function(x) abs(x[, 2])), na.rm = TRUE)
1955
-	
1956
-	axis_param = validate_axis_param(axis_param, which)
1957
-	axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
1958
-
1959
-	row_fun = function(index) {
1960
-
1961
-		n_all = length(value)
1962
-		value = value[index]
1963
-		
1964
-		if(is.null(slice_size)) {
1965
-			slice_size = yscale[2]/n_slice
1966
-		} 
1967
-		n_slice = ceiling(yscale[2]/slice_size)
1968
-		
1969
-		n = length(index)
1970
-		
1971
-		gp = subset_gp(gp, index)
1972
-
1973
-		for(i in seq_len(n)) {
1974
-			pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"), just = c("left", "bottom"), 
1975
-				height = unit(1/n, "npc") - gap))
1976
-			sgp = subset_gp(gp, i)
1977
-			horizon_chart(value[[i]][, 1], value[[i]][, 2], n_slice = n_slice, slice_size = slice_size, 
1978
-				negative_from_top = negative_from_top, pos_fill = sgp$pos_fill, neg_fill = sgp$neg_fill)
1979
-			grid.rect(gp = gpar(fill = "transparent"))
1980
-			
1981
-			popViewport()
1982
-		}
1983
-		pushViewport(viewport(xscale = xscale))
1984
-		if(axis) grid.draw(axis_grob)
1985
-		popViewport()
1986
-	}
1987
-	column_fun = function(index) {
1988
-
1989
-	}
1990
-	
1991
-	if(which == "row") {
1992
-		fun = row_fun
1993
-	} else if(which == "column") {
1994
-		fun = column_fun
1995
-	}
1996
-
1997
-	anno = AnnotationFunction(
1998
-		fun = fun,
1999
-		fun_name = "anno_horizon",
2000
-		which = which,
2001
-		width = anno_size$width,
2002
-		height = anno_size$height,
2003
-		n = n,
2004
-		data_scale = xscale,
2005
-		var_import = list(value, gp, border, axis, axis_param, axis_grob, n_slice, slice_size,
2006
-			negative_from_top, xscale, yscale, gap)
2007
-	)
2008
-
2009
-	anno@subset_rule$value = subset_vector
2010
-	anno@subset_rule$gp = subset_gp
2011
-
2012
-	anno@subsetable = TRUE
2013
-
2014
-	anno@extended = update_anno_extend(anno, axis_grob, axis_param)
2015
-
2016
-	return(anno)
2017
-}
2018
-
2019
-horizon_chart = function(x, y, n_slice = 4, slice_size, pos_fill = "#D73027", neg_fill = "#313695",
2020
-	negative_from_top = FALSE) {
2021
-
2022
-	if(missing(slice_size)) {
2023
-		slice_size = max(abs(y))/n_slice
2024
-	}
2025
-	n_slice = ceiling(max(abs(y))/slice_size)
2026
-
2027
-	if(n_slice == 0) {
2028
-		return(invisible(NULL))
2029
-	}
2030
-
2031
-	pos_col_fun = colorRamp2(c(0, n_slice), c("white", pos_fill))
2032
-	neg_col_fun = colorRamp2(c(0, n_slice), c("white", neg_fill))
2033
-	pushViewport(viewport(xscale = range(x), yscale = c(0, slice_size)))
2034
-	for(i in seq_len(n_slice)) {
2035
-		l1 = y >= (i-1)*slice_size & y < i*slice_size
2036
-		l2 = y < (i-1)*slice_size
2037
-		l3 = y >= i*slice_size
2038
-		if(any(l1)) {
2039
-			x2 = x
2040
-			y2 = y
2041
-			y2[l1] = y2[l1] - slice_size*(i-1)
2042
-			y2[l3] = slice_size
2043
-			x2[l2] = NA
2044
-			y2[l2] = NA
2045
-
2046
-			add_horizon_polygon(x2, y2, gp = gpar(fill = pos_col_fun(i), col = NA), 
2047
-				default.units = "native")
2048
-		}
2049
-	}
2050
-	y = -y
2051
-	for(i in seq_len(n_slice)) {
2052
-		l1 = y >= (i-1)*slice_size & y < i*slice_size
2053
-		l2 = y < (i-1)*slice_size
2054
-		l3 = y >= i*slice_size
2055
-		if(any(l1)) {
2056
-			x2 = x
2057
-			y2 = y
2058
-			y2[l1] = y2[l1] - slice_size*(i-1)
2059
-			y2[l3] = slice_size
2060
-			x2[l2] = NA
2061
-			y2[l2] = NA
2062
-			add_horizon_polygon(x2, y2, slice_size = slice_size, from_top = negative_from_top, 
2063
-				gp = gpar(fill = neg_col_fun(i), col = NA), default.units = "native")
2064
-		}
2065
-	}
2066
-	popViewport()
2067
-}
2068
-
2069
-# x and y may contain NA, split x and y by NA gaps, align the bottom to y = 0
2070
-add_horizon_polygon = function(x, y, slice_size = NULL, from_top = FALSE, ...) {
2071
-	ltx = split_vec_by_NA(x)
2072
-	lty = split_vec_by_NA(y)
2073
-
2074
-	for(i in seq_along(ltx)) {
2075
-		x0 = ltx[[i]]
2076
-		y0 = lty[[i]]
2077
-		if(from_top) {
2078
-			x0 = c(x0[1], x0, x0[length(x0)])
2079
-			y0 = c(slice_size, slice_size - y0, slice_size)
2080
-		} else {
2081
-			x0 = c(x0[1], x0, x0[length(x0)])
2082
-			y0 = c(0, y0, 0)
2083
-		}
2084
-		grid.polygon(x0, y0, ...)
2085
-	}
2086
-}
2087
-
2088
-# https://stat.ethz.ch/pipermail/r-help/2010-April/237031.html
2089
-split_vec_by_NA = function(x) {
2090
-	idx = 1 + cumsum(is.na(x))
2091
-	not.na = !is.na(x)
2092
-	split(x[not.na], idx[not.na])
2093
-}
2094
-
2095
-
2096