diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..4de539b --- /dev/null +++ b/ChangeLog @@ -0,0 +1,54 @@ +2008-04-28 Martin Maechler + + * DESCRIPTION (Version): 1.13.4 + + * man/*.Rd: fixes to several man pages; + note that gplot.hexbin() now is *deprecated* ! + +2008-03-18 Patrick Aboyoun + + * man/panel.hexboxplot, man/panel.hexgrid, man/panel.hexloess: Added more information to man files. + * R/hexbinplot.R (panel.hexboxplot): removed unused singles argument. + +2008-03-12 Patrick Aboyoun + + * R/hexViewport.R (hexVP.abline): Fixed the handling of non-model objects as input. + +2008-02-28 Patrick Aboyoun + + * R/hexPlotMA.R (plotMAhex): Require users to specify status explicitly + rather than as the component MA$genes$Status + * R/hexPlotMA.R (plotMAhex): Replaced support of Biobase class exprSet with + ExpressionSet + +2006-09-28 Martin Maechler + + * NAMESPACE: add full list of colorspace dependencies + +2005-07-26 Martin Maechler + + * R/hexViewport.R (smartBnds): some rationalization + * R/hexViewport.R (rname): dito + +2005-07-19 Martin Maechler + + * DESCRIPTION (Version): 1.3.1 (not to confuse with the previous one). + + * man/gplot.hexbin.Rd: fix typo and usage for S4method + + * R/hexPlotMA.R (hexMA.loess): add argument 'n' + + * R/hexViewport.R (hexVP.loess): add argument 'n'; other "white + space cosmetic" in file + +2005-10-21 Nicholas Lewin-Koh + + * added Deepayan Sarkar's hexbinplot.R function for lattice hexbin + plots + + * Added my Hexplom function based on Deepayan's code + +2005-10-27 Nicholas Lewin-Koh + + * Added more panel functions, for hexboxplots and hdiffplots. + diff --git a/DESCRIPTION b/DESCRIPTION new file mode 100644 index 0000000..735fb51 --- /dev/null +++ b/DESCRIPTION @@ -0,0 +1,15 @@ +Package: hexbin +Version: 1.17.0 +Date: 2008-05-21 +Title: Hexagonal Binning Routines +Author: Dan Carr , ported by Nicholas + Lewin-Koh and Martin Maechler +Maintainer: Nicholas Lewin-Koh +Depends: R (>= 2.0.1), methods, stats, grid, lattice +Suggests: marray, cluster, affy, Biobase +Description: Binning and plotting functions for hexagonal bins. Now + uses and relies on grid graphics and formal (S4) classes and + methods. +Collate: BTC.R BTY.R grid.hexagons.R grid.hexlegend.R hbox.R hdiffplot.R hexbinList.R hexbinplot.R hexbin.s4.R hexpanel.R hexplom.R hexPlotMA.R hexutil.R hexViewport.R HO.R LINGRAY.R LOCS.R MAG.R RB.R smoothHexbin.R +License: GPL 2 +Packaged: Tue Dec 2 22:38:34 2008; nikko diff --git a/NAMESPACE b/NAMESPACE new file mode 100644 index 0000000..419eba2 --- /dev/null +++ b/NAMESPACE @@ -0,0 +1,86 @@ +useDynLib(hexbin) + +import(grid) ## too many things from grid +import(lattice) ## too many things from lattice +importFrom("graphics", plot) +#importFrom(colorspace, "HSV", "LUV", "coords", "hex") + +## Generics and functions defined in this package +export( + "erode", + "erode.hexbin", + "getHMedian", +## document those; the method aliases are there: +## "getFig", "getMargins", "getPlt", "getXscale", "getYscale", + "gplot.hexbin", + "grid.hexagons", + "grid.hexlegend", + "hboxplot", + "hcell2xy", + "hexbin", + "hexcoords", + "hexList", + "hexpolygon", + "hexViewport", + "hexVP.abline", + "plotMAhex", + "hexVP.loess", + "hexMA.loess", + "hsmooth", + "list2hexList", + "pushHexport", + "smooth.hexbin", + "hdiffplot", # but not all the helpers in ./R/hdiffplot.R + ## Stuff in hexutils + "hcell2xyInt", + "hgridcent", + "hexGraphPaper", + "hexTapply", + "optShape", + "inout.hex", + ## color stuff + "BTC", "BTY", "LinGray", "LinOCS", "heat.ob", "magent","plinrain", + + ## Lattice stuff: + + ## high-level functions + "hexbinplot", "hexplom", + + ## panel functions + "panel.hexbinplot", "panel.hexplom", "panel.hexboxplot", + "panel.hexgrid","panel.hexloess", + + ## utilities + "hexlegendGrob") + + +## S3 methods for lattice-type functions + +S3method("hexbinplot", "formula") +S3method("hexplom", "formula") +S3method("hexplom", "matrix") +S3method("hexplom", "data.frame") + + + +exportClasses("hexbin", + "erodebin", + "smoothbin", + "hexVP", + # could/should we keep this 'private' (?) : + "integer or NULL", + "hexbinList" + ) + +exportMethods( + "erode", +## undocumented: "getFig", "getMargins", "getPlt", "getXscale", "getYscale", + "hsmooth", + + "plot", + "summary", + "show", + "coerce" + ) + + diff --git a/R/BTC.R b/R/BTC.R new file mode 100644 index 0000000..5457fd8 --- /dev/null +++ b/R/BTC.R @@ -0,0 +1,268 @@ +BTC <- function(n, beg = 1, end = 256) +{ + if(beg < 1 || end < 1 || beg > 256 || end > 256) + stop("`beg' and `end' must be numbers in the interval [1,256]") + + M <- rbind(c(0,0,0), + c(0,0,40), + c(0,4,56), + c(0,9,61), + c(0,12,64), + c(0,14,66), + c(0,17,69), + c(0,20,73), + c(0,22,74), + c(0,25,78), + c(0,27,79), + c(0,30,83), + c(0,31,85), + c(0,33,86), + c(0,36,90), + c(0,38,91), + c(0,39,93), + c(0,41,95), + c(0,43,96), + c(0,46,100), + c(0,47,102), + c(0,49,103), + c(0,51,105), + c(0,52,107), + c(0,54,108), + c(0,55,110), + c(0,57,112), + c(0,57,112), + c(0,58,113), + c(0,60,115), + c(0,62,117), + c(0,63,119), + c(0,65,120), + c(0,66,122), + c(0,68,124), + c(0,70,125), + c(0,71,127), + c(0,73,129), + c(0,73,129), + c(0,74,130), + c(0,76,132), + c(0,78,134), + c(0,79,136), + c(0,81,137), + c(0,82,139), + c(0,84,141), + c(0,86,142), + c(0,87,144), + c(0,89,146), + c(0,90,147), + c(0,92,149), + c(0,94,151), + c(0,94,151), + c(0,95,153), + c(0,97,154), + c(0,98,156), + c(0,100,158), + c(0,102,159), + c(0,103,161), + c(0,105,163), + c(0,106,164), + c(0,108,166), + c(0,109,168), + c(0,111,170), + c(0,113,171), + c(0,114,173), + c(0,116,175), + c(0,117,176), + c(0,119,178), + c(0,121,180), + c(0,121,180), + c(0,122,181), + c(0,124,183), + c(0,125,185), + c(0,127,187), + c(0,129,188), + c(0,130,190), + c(0,132,192), + c(0,133,193), + c(0,135,195), + c(0,137,197), + c(0,138,198), + c(0,140,200), + c(0,141,202), + c(0,143,204), + c(0,143,204), + c(0,145,205), + c(0,146,207), + c(0,148,209), + c(0,149,210), + c(0,151,212), + c(0,153,214), + c(0,154,215), + c(0,156,217), + c(0,157,219), + c(0,159,221), + c(0,160,222), + c(0,160,222), + c(0,162,224), + c(0,164,226), + c(0,165,227), + c(0,167,229), + c(0,168,231), + c(0,170,232), + c(0,172,234), + c(0,173,236), + c(0,175,238), + c(0,175,238), + c(0,176,239), + c(0,178,241), + c(0,180,243), + c(0,181,244), + c(0,183,246), + c(2,184,248), + c(4,186,249), + c(4,186,249), + c(4,186,249), + c(6,188,251), + c(6,188,251), + c(9,189,253), + c(9,189,253), + c( 11,191,255), + c( 11,191,255), + c( 13,192,255), + c( 13,192,255), + c( 13,192,255), + c( 16,194,255), + c( 18,196,255), + c( 20,197,255), + c( 20,197,255), + c( 23,199,255), + c( 25,200,255), + c( 27,202,255), + c( 30,204,255), + c( 32,205,255), + c( 34,207,255), + c( 37,208,255), + c( 37,208,255), + c( 39,210,255), + c( 41,211,255), + c( 44,213,255), + c( 46,215,255), + c( 48,216,255), + c( 51,218,255), + c( 53,219,255), + c( 53,219,255), + c( 55,221,255), + c( 57,223,255), + c( 60,224,255), + c( 62,226,255), + c( 64,227,255), + c( 67,229,255), + c( 67,229,255), + c( 69,231,255), + c( 71,232,255), + c( 74,234,255), + c( 76,235,255), + c( 78,237,255), + c( 81,239,255), + c( 81,239,255), + c( 83,240,255), + c( 85,242,255), + c( 88,243,255), + c( 90,245,255), + c( 92,247,255), + c( 95,248,255), + c( 95,248,255), + c( 97,250,255), + c( 99,251,255), + c(102,253,255), + c(104,255,255), + c(106,255,255), + c(106,255,255), + c(108,255,255), + c(111,255,255), + c(113,255,255), + c(115,255,255), + c(115,255,255), + c(118,255,255), + c(120,255,255), + c(122,255,255), + c(122,255,255), + c(125,255,255), + c(127,255,255), + c(129,255,255), + c(129,255,255), + c(132,255,255), + c(134,255,255), + c(136,255,255), + c(136,255,255), + c(139,255,255), + c(141,255,255), + c(143,255,255), + c(143,255,255), + c(146,255,255), + c(148,255,255), + c(150,255,255), + c(150,255,255), + c(153,255,255), + c(155,255,255), + c(155,255,255), + c(157,255,255), + c(159,255,255), + c(159,255,255), + c(162,255,255), + c(164,255,255), + c(164,255,255), + c(166,255,255), + c(169,255,255), + c(171,255,255), + c(171,255,255), + c(173,255,255), + c(176,255,255), + c(176,255,255), + c(178,255,255), + c(180,255,255), + c(180,255,255), + c(183,255,255), + c(185,255,255), + c(185,255,255), + c(187,255,255), + c(190,255,255), + c(190,255,255), + c(192,255,255), + c(194,255,255), + c(197,255,255), + c(197,255,255), + c(199,255,255), + c(201,255,255), + c(204,255,255), + c(204,255,255), + c(206,255,255), + c(208,255,255), + c(210,255,255), + c(210,255,255), + c(213,255,255), + c(215,255,255), + c(217,255,255), + c(217,255,255), + c(220,255,255), + c(222,255,255), + c(224,255,255), + c(227,255,255), + c(229,255,255), + c(229,255,255), + c(231,255,255), + c(234,255,255), + c(236,255,255), + c(238,255,255), + c(241,255,255), + c(243,255,255), + c(243,255,255), + c(245,255,255), + c(248,255,255), + c(250,255,255), + c(255,255,255))[ round(seq(beg,end, length = n)), ] + + rgb(M[,1]/255, + M[,2]/255, + M[,3]/255) +} + + diff --git a/R/BTY.R b/R/BTY.R new file mode 100644 index 0000000..954c2a3 --- /dev/null +++ b/R/BTY.R @@ -0,0 +1,266 @@ +BTY <- function(n, beg = 1, end = 256) +{ + if(beg < 1 || end < 1 || beg > 256 || end > 256) + stop("`beg' and `end' must be numbers in the interval [1,256]") + + M <- rbind(c(7,7,254), + c(23,23,252), + c(30,30,250), + c(36,36,248), + c(40,40,247), + c(44,44,245), + c(47,47,243), + c(50,50,242), + c(52,52,240), + c(55,55,239), + c(57,57,238), + c(59,59,236), + c(61,61,235), + c(63,63,234), + c(65,65,233), + c(66,66,231), + c(68,68,230), + c(69,69,229), + c(71,71,228), + c(72,72,227), + c(74,74,226), + c(75,75,225), + c(76,76,225), + c(78,78,224), + c(79,79,223), + c(80,80,222), + c(81,81,221), + c(82,82,221), + c(84,84,220), + c(85,85,219), + c(86,86,218), + c(87,87,218), + c(88,88,217), + c(89,89,216), + c(90,90,216), + c(91,91,215), + c(92,92,214), + c(93,93,214), + c(94,94,213), + c(95,95,213), + c(96,96,212), + c(97,97,212), + c(98,98,211), + c(98,98,210), + c(99,99,210), + c(100,100,209), + c(101,101,209), + c(102,102,208), + c(103,103,208), + c(104,104,208), + c(105,105,207), + c(105,105,207), + c(106,106,206), + c(107,107,206), + c(108,108,205), + c(109,109,205), + c(110,110,204), + c(110,110,204), + c(111,111,204), + c(112,112,203), + c(113,113,203), + c(114,114,202), + c(114,114,202), + c(115,115,202), + c(116,116,201), + c(117,117,201), + c(118,118,200), + c(118,118,200), + c(119,119,200), + c(120,120,199), + c(121,121,199), + c(121,121,199), + c(122,122,198), + c(123,123,198), + c(124,124,198), + c(124,124,197), + c(125,125,197), + c(126,126,197), + c(127,127,196), + c(128,128,196), + c(128,128,195), + c(129,129,195), + c(130,130,195), + c(130,130,194), + c(131,131,194), + c(132,132,194), + c(133,133,193), + c(133,133,193), + c(134,134,193), + c(135,135,192), + c(136,136,192), + c(136,136,192), + c(137,137,191), + c(138,138,191), + c(139,139,191), + c(139,139,190), + c(140,140,190), + c(141,141,190), + c(142,142,189), + c(142,142,189), + c(143,143,189), + c(144,144,188), + c(144,144,188), + c(145,145,188), + c(146,146,187), + c(147,147,187), + c(147,147,187), + c(148,148,186), + c(149,149,186), + c(149,149,186), + c(150,150,185), + c(151,151,185), + c(152,152,185), + c(152,152,184), + c(153,153,184), + c(154,154,184), + c(154,154,183), + c(155,155,183), + c(156,156,182), + c(157,157,182), + c(157,157,182), + c(158,158,181), + c(159,159,181), + c(159,159,181), + c(160,160,180), + c(161,161,180), + c(162,162,180), + c(162,162,179), + c(163,163,179), + c(164,164,178), + c(164,164,178), + c(165,165,178), + c(166,166,177), + c(167,167,177), + c(167,167,176), + c(168,168,176), + c(169,169,176), + c(169,169,175), + c(170,170,175), + c(171,171,174), + c(172,172,174), + c(172,172,173), + c(173,173,173), + c(174,174,173), + c(174,174,172), + c(175,175,172), + c(176,176,171), + c(177,177,171), + c(177,177,170), + c(178,178,170), + c(179,179,169), + c(179,179,169), + c(180,180,168), + c(181,181,168), + c(181,181,167), + c(182,182,167), + c(183,183,166), + c(184,184,166), + c(184,184,165), + c(185,185,165), + c(186,186,164), + c(186,186,164), + c(187,187,163), + c(188,188,163), + c(189,189,162), + c(189,189,162), + c(190,190,161), + c(191,191,161), + c(191,191,160), + c(192,192,159), + c(193,193,159), + c(194,194,158), + c(194,194,158), + c(195,195,157), + c(196,196,157), + c(196,196,156), + c(197,197,155), + c(198,198,155), + c(199,199,154), + c(199,199,153), + c(200,200,153), + c(201,201,152), + c(201,201,151), + c(202,202,151), + c(203,203,150), + c(204,204,149), + c(204,204,149), + c(205,205,148), + c(206,206,147), + c(206,206,146), + c(207,207,146), + c(208,208,145), + c(209,209,144), + c(209,209,143), + c(210,210,143), + c(211,211,142), + c(211,211,141), + c(212,212,140), + c(213,213,139), + c(214,214,138), + c(214,214,138), + c(215,215,137), + c(216,216,136), + c(216,216,135), + c(217,217,134), + c(218,218,133), + c(219,219,132), + c(219,219,131), + c(220,220,130), + c(221,221,129), + c(221,221,128), + c(222,222,127), + c(223,223,126), + c(224,224,125), + c(224,224,124), + c(225,225,123), + c(226,226,122), + c(226,226,121), + c(227,227,119), + c(228,228,118), + c(229,229,117), + c(229,229,116), + c(230,230,114), + c(231,231,113), + c(232,232,112), + c(232,232,110), + c(233,233,109), + c(234,234,107), + c(234,234,106), + c(235,235,104), + c(236,236,103), + c(237,237,101), + c(237,237,100), + c(238,238,98), + c(239,239,96), + c(239,239,94), + c(240,240,92), + c(241,241,91), + c(242,242,89), + c(242,242,86), + c(243,243,84), + c(244,244,82), + c(245,245,80), + c(245,245,77), + c(246,246,74), + c(247,247,72), + c(247,247,69), + c(248,248,65), + c(249,249,62), + c(250,250,58), + c(250,250,54), + c(251,251,49), + c(252,252,44), + c(253,253,37), + c(253,253,28), + c(254,254,13))[ round(seq(beg,end, length = n)), ] + + rgb(M[,1]/255, + M[,2]/255, + M[,3]/255) +} diff --git a/R/HO.R b/R/HO.R new file mode 100644 index 0000000..c73a470 --- /dev/null +++ b/R/HO.R @@ -0,0 +1,267 @@ +heat.ob <- function(n,beg = 1,end = 256) +{ + if(beg < 1 || end < 1 || beg > 256 || end > 256) + stop("`beg' and `end' must be numbers in the interval [1,256]") + + M <- rbind(c(0, 0, 0), + c(35, 0, 0), + c(52, 0, 0), + c(60, 0, 0), + c(63, 1, 0), + c(64, 2, 0), + c(68, 5, 0), + c(69, 6, 0), + c(72, 8, 0), + c(74,10, 0), + c(77,12, 0), + c(78,14, 0), + c(81,16, 0), + c(83,17, 0), + c(85,19, 0), + c(86,20, 0), + c(89,22, 0), + c(91,24, 0), + c(92,25, 0), + c(94,26, 0), + c(95,28, 0), + c(98,30, 0), + c(100,31, 0), + c(102,33, 0), + c(103,34, 0), + c(105,35, 0), + c(106,36, 0), + c(108,38, 0), + c(109,39, 0), + c(111,40, 0), + c(112,42, 0), + c(114,43, 0), + c(115,44, 0), + c(117,45, 0), + c(119,47, 0), + c(119,47, 0), + c(120,48, 0), + c(122,49, 0), + c(123,51, 0), + c(125,52, 0), + c(125,52, 0), + c(126,53, 0), + c(128,54, 0), + c(129,56, 0), + c(129,56, 0), + c(131,57, 0), + c(132,58, 0), + c(134,59, 0), + c(134,59, 0), + c(136,61, 0), + c(137,62, 0), + c(137,62, 0), + c(139,63, 0), + c(139,63, 0), + c(140,65, 0), + c(142,66, 0), + c(142,66, 0), + c(143,67, 0), + c(143,67, 0), + c(145,68, 0), + c(145,68, 0), + c(146,70, 0), + c(146,70, 0), + c(148,71, 0), + c(148,71, 0), + c(149,72, 0), + c(149,72, 0), + c(151,73, 0), + c(151,73, 0), + c(153,75, 0), + c(153,75, 0), + c(154,76, 0), + c(154,76, 0), + c(154,76, 0), + c(156,77, 0), + c(156,77, 0), + c(157,79, 0), + c(157,79, 0), + c(159,80, 0), + c(159,80, 0), + c(159,80, 0), + c(160,81, 0), + c(160,81, 0), + c(162,82, 0), + c(162,82, 0), + c(163,84, 0), + c(163,84, 0), + c(165,85, 0), + c(165,85, 0), + c(166,86, 0), + c(166,86, 0), + c(166,86, 0), + c(168,87, 0), + c(168,87, 0), + c(170,89, 0), + c(170,89, 0), + c(171,90, 0), + c(171,90, 0), + c(173,91, 0), + c(173,91, 0), + c(174,93, 0), + c(174,93, 0), + c(176,94, 0), + c(176,94, 0), + c(177,95, 0), + c(177,95, 0), + c(179,96, 0), + c(179,96, 0), + c(180,98, 0), + c(182,99, 0), + c(182,99, 0), + c(183,100, 0), + c(183,100, 0), + c(185,102, 0), + c(185,102, 0), + c(187,103, 0), + c(187,103, 0), + c(188,104, 0), + c(188,104, 0), + c(190,105, 0), + c(191,107, 0), + c(191,107, 0), + c(193,108, 0), + c(193,108, 0), + c(194,109, 0), + c(196,110, 0), + c(196,110, 0), + c(197,112, 0), + c(197,112, 0), + c(199,113, 0), + c(200,114, 0), + c(200,114, 0), + c(202,116, 0), + c(202,116, 0), + c(204,117, 0), + c(205,118, 0), + c(205,118, 0), + c(207,119, 0), + c(208,121, 0), + c(208,121, 0), + c(210,122, 0), + c(211,123, 0), + c(211,123, 0), + c(213,124, 0), + c(214,126, 0), + c(214,126, 0), + c(216,127, 0), + c(217,128, 0), + c(217,128, 0), + c(219,130, 0), + c(221,131, 0), + c(221,131, 0), + c(222,132, 0), + c(224,133, 0), + c(224,133, 0), + c(225,135, 0), + c(227,136, 0), + c(227,136, 0), + c(228,137, 0), + c(230,138, 0), + c(230,138, 0), + c(231,140, 0), + c(233,141, 0), + c(233,141, 0), + c(234,142, 0), + c(236,144, 0), + c(236,144, 0), + c(238,145, 0), + c(239,146, 0), + c(241,147, 0), + c(241,147, 0), + c(242,149, 0), + c(244,150, 0), + c(244,150, 0), + c(245,151, 0), + c(247,153, 0), + c(247,153, 0), + c(248,154, 0), + c(250,155, 0), + c(251,156, 0), + c(251,156, 0), + c(253,158, 0), + c(255,159, 0), + c(255,159, 0), + c(255,160, 0), + c(255,161, 0), + c(255,163, 0), + c(255,163, 0), + c(255,164, 0), + c(255,165, 0), + c(255,167, 0), + c(255,167, 0), + c(255,168, 0), + c(255,169, 0), + c(255,169, 0), + c(255,170, 0), + c(255,172, 0), + c(255,173, 0), + c(255,173, 0), + c(255,174, 0), + c(255,175, 0), + c(255,177, 0), + c(255,178, 0), + c(255,179, 0), + c(255,181, 0), + c(255,181, 0), + c(255,182, 0), + c(255,183, 0), + c(255,184, 0), + c(255,187, 7), + c(255,188,10), + c(255,189,14), + c(255,191,18), + c(255,192,21), + c(255,193,25), + c(255,195,29), + c(255,197,36), + c(255,198,40), + c(255,200,43), + c(255,202,51), + c(255,204,54), + c(255,206,61), + c(255,207,65), + c(255,210,72), + c(255,211,76), + c(255,214,83), + c(255,216,91), + c(255,219,98), + c(255,221,105), + c(255,223,109), + c(255,225,116), + c(255,228,123), + c(255,232,134), + c(255,234,142), + c(255,237,149), + c(255,239,156), + c(255,240,160), + c(255,243,167), + c(255,246,174), + c(255,248,182), + c(255,249,185), + c(255,252,193), + c(255,253,196), + c(255,255,204), + c(255,255,207), + c(255,255,211), + c(255,255,218), + c(255,255,222), + c(255,255,225), + c(255,255,229), + c(255,255,233), + c(255,255,236), + c(255,255,240), + c(255,255,244), + c(255,255,247), + c(255,255,255))[ round(seq(beg,end,length = n)), ] + + rgb(M[,1]/255, + M[,2]/255, + M[,3]/255) + +} diff --git a/R/LINGRAY.R b/R/LINGRAY.R new file mode 100644 index 0000000..a448734 --- /dev/null +++ b/R/LINGRAY.R @@ -0,0 +1,111 @@ +LinGray <- function(n,beg = 1,end = 92) +{ + if(beg < 1 || end < 1 || beg > 256 || end > 256) + stop("`beg' and `end' must be numbers in the interval [1,256]") + + M <- rbind(c(0,0,0), + c(0,0,0), + c(1,1,1), + c(1,1,1), + c(2,2,2), + c(3,3,3), + c(4,4,4), + c(5,5,5), + c(6,6,6), + c(7,7,7), + c(8,8,8), + c(9,9,9), + c(10,10,10), + c(11,11,11), + c(12,12,12), + c(13,13,13), + c(14,14,14), + c(15,15,15), + c(16,16,16), + c(17,17,17), + c(18,18,18), + c(19,19,19), + c(20,20,20), + c(21,21,21), + c(22,22,22), + c(23,23,23), + c(24,24,24), + c(25,25,25), + c(26,26,26), + c(27,27,27), + c(28,28,28), + c(29,29,29), + c(30,30,30), + c(32,32,32), + c(34,34,34), + c(35,35,35), + c(37,37,37), + c(39,39,39), + c(41,41,41), + c(43,43,43), + c(45,45,45), + c(46,46,46), + c(47,47,47), + c(49,49,49), + c(51,51,51), + c(52,52,52), + c(54,54,54), + c(56,56,56), + c(59,59,59), + c(61,61,61), + c(64,64,64), + c(67,67,67), + c(69,69,69), + c(72,72,72), + c(75,75,75), + c(76,76,76), + c(78,78,78), + c(81,81,81), + c(84,84,84), + c(87,87,87), + c(91,91,91), + c(94,94,94), + c(97,97,97), + c(101,101,101), + c(104,104,104), + c(107,107,107), + c(108,108,108), + c(112,112,112), + c(116,116,116), + c(120,120,120), + c(124,124,124), + c(128,128,128), + c(132,132,132), + c(136,136,136), + c(141,141,141), + c(145,145,145), + c(147,147,147), + c(150,150,150), + c(154,154,154), + c(159,159,159), + c(164,164,164), + c(169,169,169), + c(174,174,174), + c(179,179,179), + c(185,185,185), + c(190,190,190), + c(195,195,195), + c(201,201,201), + c(207,207,207), + c(212,212,212), + c(216,216,216), + c(218,218,218), + c(224,224,224), + c(226,226,226), + c(230,230,230), + c(237,237,237), + c(243,243,243), + c(245,245,245), + c(252,252,252), + c(255,255,255), + c(255,255,255))[round(seq(beg,end,length = n)), ] + + rgb(M[,1]/255, + M[,2]/255, + M[,3]/255) +} diff --git a/R/LOCS.R b/R/LOCS.R new file mode 100644 index 0000000..fd73ae7 --- /dev/null +++ b/R/LOCS.R @@ -0,0 +1,266 @@ +LinOCS <- function(n,beg = 1,end = 256) +{ + if(beg < 1 || end < 1 || beg > 256 || end > 256) + stop("`beg' and `end' must be numbers in the interval [1,256]") + + M <- rbind(c(0,0,0), + c(0,0,0), + c(0,0,0), + c(1,0,0), + c(2,0,0), + c(2,0,0), + c(3,0,0), + c(3,0,0), + c(4,0,0), + c(5,0,0), + c(5,0,0), + c(6,0,0), + c(7,0,0), + c(7,0,0), + c(8,0,0), + c(9,0,0), + c(9,0,0), + c(10,0,0), + c(11,0,0), + c(12,0,0), + c(13,0,0), + c(14,0,0), + c(15,0,0), + c(16,0,0), + c(17,0,0), + c(18,0,0), + c(19,0,0), + c(20,0,0), + c(21,0,0), + c(22,0,0), + c(23,0,0), + c(25,0,0), + c(26,0,0), + c(27,0,0), + c(28,0,0), + c(30,0,0), + c(31,0,0), + c(33,0,0), + c(34,0,0), + c(35,0,0), + c(37,0,0), + c(39,0,0), + c(40,0,0), + c(43,0,0), + c(45,0,0), + c(46,0,0), + c(49,0,0), + c(51,0,0), + c(53,0,0), + c(54,0,0), + c(56,0,0), + c(58,0,0), + c(60,0,0), + c(62,0,0), + c(64,0,0), + c(67,0,0), + c(69,0,0), + c(71,0,0), + c(74,0,0), + c(76,0,0), + c(80,0,0), + c(81,0,0), + c(84,0,0), + c(86,0,0), + c(89,0,0), + c(92,0,0), + c(94,0,0), + c(97,0,0), + c(100,0,0), + c(103,0,0), + c(106,0,0), + c(109,0,0), + c(112,0,0), + c(115,0,0), + c(117,0,0), + c(122,0,0), + c(126,0,0), + c(128,0,0), + c(131,0,0), + c(135,0,0), + c(135,0,0), + c(135,1,0), + c(135,2,0), + c(135,3,0), + c(135,4,0), + c(135,6,0), + c(135,6,0), + c(135,8,0), + c(135,9,0), + c(135,10,0), + c(135,11,0), + c(135,13,0), + c(135,13,0), + c(135,15,0), + c(135,17,0), + c(135,17,0), + c(135,19,0), + c(135,21,0), + c(135,22,0), + c(135,23,0), + c(135,25,0), + c(135,26,0), + c(135,27,0), + c(135,29,0), + c(135,31,0), + c(135,32,0), + c(135,33,0), + c(135,35,0), + c(135,36,0), + c(135,38,0), + c(135,40,0), + c(135,42,0), + c(135,44,0), + c(135,46,0), + c(135,47,0), + c(135,49,0), + c(135,51,0), + c(135,52,0), + c(135,54,0), + c(135,56,0), + c(135,57,0), + c(135,59,0), + c(135,62,0), + c(135,63,0), + c(135,65,0), + c(135,67,0), + c(135,69,0), + c(135,72,0), + c(135,73,0), + c(135,76,0), + c(135,78,0), + c(135,80,0), + c(135,82,0), + c(135,84,0), + c(135,87,0), + c(135,88,0), + c(135,90,0), + c(135,93,0), + c(135,95,0), + c(135,98,0), + c(135,101,0), + c(135,103,0), + c(135,106,0), + c(135,107,0), + c(135,110,0), + c(135,113,0), + c(135,115,0), + c(135,118,0), + c(135,121,0), + c(135,124,0), + c(135,127,0), + c(135,129,0), + c(135,133,0), + c(135,135,0), + c(135,138,0), + c(135,141,0), + c(135,144,0), + c(135,148,0), + c(135,150,0), + c(135,155,0), + c(135,157,0), + c(135,160,0), + c(135,163,0), + c(135,166,0), + c(135,170,0), + c(135,174,0), + c(135,177,0), + c(135,180,0), + c(135,184,0), + c(135,188,0), + c(135,192,0), + c(135,195,0), + c(135,200,0), + c(135,203,0), + c(135,205,0), + c(135,210,0), + c(135,214,0), + c(135,218,0), + c(135,222,0), + c(135,226,0), + c(135,231,0), + c(135,236,0), + c(135,239,0), + c(135,244,0), + c(135,249,0), + c(135,254,0), + c(135,255,1), + c(135,255,5), + c(135,255,10), + c(135,255,15), + c(135,255,20), + c(135,255,23), + c(135,255,28), + c(135,255,33), + c(135,255,38), + c(135,255,43), + c(135,255,45), + c(135,255,49), + c(135,255,54), + c(135,255,59), + c(135,255,65), + c(135,255,70), + c(135,255,74), + c(135,255,80), + c(135,255,84), + c(135,255,90), + c(135,255,95), + c(135,255,98), + c(135,255,104), + c(135,255,110), + c(135,255,116), + c(135,255,120), + c(135,255,125), + c(135,255,131), + c(135,255,137), + c(135,255,144), + c(135,255,149), + c(135,255,154), + c(135,255,158), + c(135,255,165), + c(135,255,172), + c(135,255,179), + c(135,255,186), + c(135,255,191), + c(135,255,198), + c(135,255,203), + c(135,255,211), + c(135,255,216), + c(135,255,224), + c(135,255,232), + c(135,255,240), + c(135,255,248), + c(135,255,254), + c(135,255,255), + c(140,255,255), + c(146,255,255), + c(153,255,255), + c(156,255,255), + c(161,255,255), + c(168,255,255), + c(172,255,255), + c(177,255,255), + c(182,255,255), + c(189,255,255), + c(192,255,255), + c(199,255,255), + c(204,255,255), + c(210,255,255), + c(215,255,255), + c(220,255,255), + c(225,255,255), + c(232,255,255), + c(236,255,255), + c(240,255,255), + c(248,255,255), + c(255,255,255))[ round(seq(beg,end,length = n)), ] + + rgb(M[,1]/255, + M[,2]/255, + M[,3]/255) +} diff --git a/R/MAG.R b/R/MAG.R new file mode 100644 index 0000000..5721749 --- /dev/null +++ b/R/MAG.R @@ -0,0 +1,266 @@ +magent <- function(n, beg = 1, end = 256) +{ + if(beg < 1 || end < 1 || beg > 256 || end > 256) + stop("`beg' and `end' must be numbers in the interval [1,256]") + + M <- rbind(c(0, 0, 0), + c( 40, 0, 0), + c( 56, 0, 4), + c( 61, 0, 9), + c( 64, 0, 12), + c( 66, 0, 14), + c( 69, 0, 17), + c( 73, 0, 20), + c( 74, 0, 22), + c( 78, 0, 25), + c( 79, 0, 27), + c( 83, 0, 30), + c( 85, 0, 31), + c( 86, 0, 33), + c( 90, 0, 36), + c( 91, 0, 38), + c( 93, 0, 39), + c( 95, 0, 41), + c( 96, 0, 43), + c(100, 0, 46), + c(102, 0, 47), + c(103, 0, 49), + c(105, 0, 51), + c(107, 0, 52), + c(108, 0, 54), + c(110, 0, 55), + c(112, 0, 57), + c(112, 0, 57), + c(113, 0, 58), + c(115, 0, 60), + c(117, 0, 62), + c(119, 0, 63), + c(120, 0, 65), + c(122, 0, 66), + c(124, 0, 68), + c(125, 0, 70), + c(127, 0, 71), + c(129, 0, 73), + c(129, 0, 73), + c(130, 0, 74), + c(132, 0, 76), + c(134, 0, 78), + c(136, 0, 79), + c(137, 0, 81), + c(139, 0, 82), + c(141, 0, 84), + c(142, 0, 86), + c(144, 0, 87), + c(146, 0, 89), + c(147, 0, 90), + c(149, 0, 92), + c(151, 0, 94), + c(151, 0, 94), + c(153, 0, 95), + c(154, 0, 97), + c(156, 0, 98), + c(158, 0,100), + c(159, 0,102), + c(161, 0,103), + c(163, 0,105), + c(164, 0,106), + c(166, 0,108), + c(168, 0,109), + c(170, 0,111), + c(171, 0,113), + c(173, 0,114), + c(175, 0,116), + c(176, 0,117), + c(178, 0,119), + c(180, 0,121), + c(180, 0,121), + c(181, 0,122), + c(183, 0,124), + c(185, 0,125), + c(187, 0,127), + c(188, 0,129), + c(190, 0,130), + c(192, 0,132), + c(193, 0,133), + c(195, 0,135), + c(197, 0,137), + c(198, 0,138), + c(200, 0,140), + c(202, 0,141), + c(204, 0,143), + c(204, 0,143), + c(205, 0,145), + c(207, 0,146), + c(209, 0,148), + c(210, 0,149), + c(212, 0,151), + c(214, 0,153), + c(215, 0,154), + c(217, 0,156), + c(219, 0,157), + c(221, 0,159), + c(222, 0,160), + c(222, 0,160), + c(224, 0,162), + c(226, 0,164), + c(227, 0,165), + c(229, 0,167), + c(231, 0,168), + c(232, 0,170), + c(234, 0,172), + c(236, 0,173), + c(238, 0,175), + c(238, 0,175), + c(239, 0,176), + c(241, 0,178), + c(243, 0,180), + c(244, 0,181), + c(246, 0,183), + c(248, 2,184), + c(249, 4,186), + c(249, 4,186), + c(249, 4,186), + c(251, 6,188), + c(251, 6,188), + c(253, 9,189), + c(253, 9,189), + c(255, 11,191), + c(255, 11,191), + c(255, 13,192), + c(255, 13,192), + c(255, 13,192), + c(255, 16,194), + c(255, 18,196), + c(255, 20,197), + c(255, 20,197), + c(255, 23,199), + c(255, 25,200), + c(255, 27,202), + c(255, 30,204), + c(255, 32,205), + c(255, 34,207), + c(255, 37,208), + c(255, 37,208), + c(255, 39,210), + c(255, 41,211), + c(255, 44,213), + c(255, 46,215), + c(255, 48,216), + c(255, 51,218), + c(255, 53,219), + c(255, 53,219), + c(255, 55,221), + c(255, 57,223), + c(255, 60,224), + c(255, 62,226), + c(255, 64,227), + c(255, 67,229), + c(255, 67,229), + c(255, 69,231), + c(255, 71,232), + c(255, 74,234), + c(255, 76,235), + c(255, 78,237), + c(255, 81,239), + c(255, 81,239), + c(255, 83,240), + c(255, 85,242), + c(255, 88,243), + c(255, 90,245), + c(255, 92,247), + c(255, 95,248), + c(255, 95,248), + c(255, 97,250), + c(255, 99,251), + c(255,102,253), + c(255,104,255), + c(255,106,255), + c(255,106,255), + c(255,108,255), + c(255,111,255), + c(255,113,255), + c(255,115,255), + c(255,115,255), + c(255,118,255), + c(255,120,255), + c(255,122,255), + c(255,122,255), + c(255,125,255), + c(255,127,255), + c(255,129,255), + c(255,129,255), + c(255,132,255), + c(255,134,255), + c(255,136,255), + c(255,136,255), + c(255,139,255), + c(255,141,255), + c(255,143,255), + c(255,143,255), + c(255,146,255), + c(255,148,255), + c(255,150,255), + c(255,150,255), + c(255,153,255), + c(255,155,255), + c(255,155,255), + c(255,157,255), + c(255,159,255), + c(255,159,255), + c(255,162,255), + c(255,164,255), + c(255,164,255), + c(255,166,255), + c(255,169,255), + c(255,171,255), + c(255,171,255), + c(255,173,255), + c(255,176,255), + c(255,176,255), + c(255,178,255), + c(255,180,255), + c(255,180,255), + c(255,183,255), + c(255,185,255), + c(255,185,255), + c(255,187,255), + c(255,190,255), + c(255,190,255), + c(255,192,255), + c(255,194,255), + c(255,197,255), + c(255,197,255), + c(255,199,255), + c(255,201,255), + c(255,204,255), + c(255,204,255), + c(255,206,255), + c(255,208,255), + c(255,210,255), + c(255,210,255), + c(255,213,255), + c(255,215,255), + c(255,217,255), + c(255,217,255), + c(255,220,255), + c(255,222,255), + c(255,224,255), + c(255,227,255), + c(255,229,255), + c(255,229,255), + c(255,231,255), + c(255,234,255), + c(255,236,255), + c(255,238,255), + c(255,241,255), + c(255,243,255), + c(255,243,255), + c(255,245,255), + c(255,248,255), + c(255,250,255), + c(255,255,255)) [ round(seq(beg,end,length = n)), ] + + rgb(M[,1]/255, + M[,2]/255, + M[,3]/255) +} diff --git a/R/RB.R b/R/RB.R new file mode 100644 index 0000000..6e92aaa --- /dev/null +++ b/R/RB.R @@ -0,0 +1,266 @@ +plinrain <- function(n, beg = 1, end = 256) +{ + if(beg < 1 || end < 1 || beg > 256 || end > 256) + stop("`beg' and `end' must be numbers in the interval [1,256]") + + M <- rbind(c( 0, 0, 0), + c( 45, 0, 36), + c( 56, 0, 46), + c( 60, 0, 49), + c( 67, 0, 54), + c( 70, 0, 59), + c( 71, 0, 61), + c( 75, 0, 68), + c( 74, 0, 73), + c( 74, 0, 77), + c( 73, 0, 81), + c( 71, 0, 87), + c( 69, 1, 90), + c( 68, 2, 94), + c( 66, 3, 97), + c( 63, 6,102), + c( 61, 7,106), + c( 58, 10,109), + c( 56, 12,113), + c( 53, 15,116), + c( 48, 18,119), + c( 47, 20,121), + c( 44, 23,124), + c( 41, 27,128), + c( 40, 28,129), + c( 37, 32,132), + c( 34, 36,134), + c( 29, 43,137), + c( 25, 52,138), + c( 24, 57,139), + c( 24, 62,141), + c( 24, 64,142), + c( 23, 65,142), + c( 23, 69,143), + c( 23, 71,142), + c( 23, 71,142), + c( 23, 73,142), + c( 23, 75,142), + c( 23, 75,142), + c( 23, 78,142), + c( 23, 80,142), + c( 23, 80,142), + c( 23, 82,141), + c( 23, 85,141), + c( 23, 85,141), + c( 23, 87,140), + c( 23, 87,140), + c( 24, 90,140), + c( 24, 90,140), + c( 24, 93,139), + c( 24, 93,139), + c( 24, 93,139), + c( 24, 93,139), + c( 24, 97,139), + c( 24, 97,139), + c( 25,101,138), + c( 25,101,138), + c( 25,104,137), + c( 25,104,137), + c( 25,104,137), + c( 26,108,137), + c( 26,108,137), + c( 27,111,136), + c( 27,111,136), + c( 27,111,136), + c( 27,115,135), + c( 27,115,135), + c( 28,118,134), + c( 28,118,134), + c( 29,122,133), + c( 29,122,133), + c( 29,122,133), + c( 29,122,133), + c( 29,125,132), + c( 29,125,132), + c( 30,128,131), + c( 30,128,131), + c( 31,131,130), + c( 31,131,130), + c( 31,131,130), + c( 32,134,128), + c( 32,134,128), + c( 33,137,127), + c( 33,137,127), + c( 33,137,127), + c( 34,140,125), + c( 34,140,125), + c( 35,142,123), + c( 35,142,123), + c( 36,145,121), + c( 36,145,121), + c( 36,145,121), + c( 37,147,118), + c( 37,147,118), + c( 38,150,116), + c( 38,150,116), + c( 40,152,113), + c( 40,152,113), + c( 41,154,111), + c( 41,154,111), + c( 42,156,108), + c( 42,156,108), + c( 43,158,106), + c( 43,158,106), + c( 43,158,106), + c( 45,160,104), + c( 45,160,104), + c( 46,162,101), + c( 46,162,101), + c( 48,164, 99), + c( 48,164, 99), + c( 50,166, 97), + c( 50,166, 97), + c( 51,168, 95), + c( 53,170, 93), + c( 53,170, 93), + c( 53,170, 93), + c( 55,172, 91), + c( 55,172, 91), + c( 57,174, 88), + c( 57,174, 88), + c( 59,175, 86), + c( 62,177, 84), + c( 64,178, 82), + c( 64,178, 82), + c( 67,180, 80), + c( 67,180, 80), + c( 69,181, 79), + c( 72,183, 77), + c( 72,183, 77), + c( 72,183, 77), + c( 75,184, 76), + c( 77,186, 74), + c( 80,187, 73), + c( 83,189, 72), + c( 87,190, 72), + c( 91,191, 71), + c( 95,192, 70), + c( 99,193, 70), + c(103,194, 70), + c(107,195, 70), + c(111,196, 70), + c(111,196, 70), + c(115,196, 70), + c(119,197, 70), + c(123,197, 70), + c(130,198, 71), + c(133,199, 71), + c(137,199, 72), + c(140,199, 72), + c(143,199, 73), + c(143,199, 73), + c(147,199, 73), + c(150,199, 74), + c(153,199, 74), + c(156,199, 75), + c(160,200, 76), + c(167,200, 78), + c(170,200, 79), + c(173,200, 79), + c(173,200, 79), + c(177,200, 80), + c(180,200, 81), + c(183,199, 82), + c(186,199, 82), + c(190,199, 83), + c(196,199, 85), + c(199,198, 85), + c(199,198, 85), + c(203,198, 86), + c(206,197, 87), + c(212,197, 89), + c(215,196, 90), + c(218,195, 91), + c(224,194, 94), + c(224,194, 94), + c(230,193, 96), + c(233,192, 98), + c(236,190,100), + c(238,189,104), + c(240,188,106), + c(240,188,106), + c(242,187,110), + c(244,185,114), + c(245,184,116), + c(247,183,120), + c(248,182,123), + c(248,182,123), + c(250,181,125), + c(251,180,128), + c(252,180,130), + c(253,180,133), + c(253,180,133), + c(254,180,134), + c(254,179,138), + c(255,179,142), + c(255,179,145), + c(255,179,145), + c(255,179,152), + c(255,180,161), + c(255,180,164), + c(255,180,167), + c(255,180,167), + c(255,181,169), + c(255,181,170), + c(255,182,173), + c(255,183,176), + c(255,183,176), + c(255,184,179), + c(255,185,179), + c(255,185,182), + c(255,186,182), + c(255,186,182), + c(255,187,185), + c(255,188,185), + c(255,189,188), + c(255,189,188), + c(255,190,188), + c(255,191,191), + c(255,192,191), + c(255,194,194), + c(255,194,194), + c(255,197,197), + c(255,198,198), + c(255,200,200), + c(255,201,201), + c(255,201,201), + c(255,202,202), + c(255,203,203), + c(255,205,205), + c(255,206,206), + c(255,206,206), + c(255,208,208), + c(255,209,209), + c(255,211,211), + c(255,215,215), + c(255,216,216), + c(255,216,216), + c(255,218,218), + c(255,219,219), + c(255,221,221), + c(255,223,223), + c(255,226,226), + c(255,228,228), + c(255,230,230), + c(255,230,230), + c(255,232,232), + c(255,235,235), + c(255,237,237), + c(255,240,240), + c(255,243,243), + c(255,246,246), + c(255,249,249), + c(255,251,251), + c(255,253,253), + c(255,255,255))[ round(seq(beg,end, length = n)), ] + + rgb(M[,1]/255, + M[,2]/255, + M[,3]/255) +} diff --git a/R/grid.hexagons.R b/R/grid.hexagons.R new file mode 100644 index 0000000..f64d851 --- /dev/null +++ b/R/grid.hexagons.R @@ -0,0 +1,364 @@ + +hexcoords <- function(dx, dy = NULL, n = 1, sep = NULL) +{ + stopifnot(length(dx) == 1) + if(is.null(dy)) dy <- dx/sqrt(3) + if(is.null(sep)) + list(x = rep.int(c(dx, dx, 0, -dx, -dx, 0), n), + y = rep.int(c(dy,-dy, -2*dy, -dy, dy, 2*dy), n), + no.sep = TRUE) + else + list(x = rep.int(c(dx, dx, 0, -dx, -dx, 0, sep), n), + y = rep.int(c(dy,-dy, -2*dy, -dy, dy, 2*dy, sep), n), + no.sep = FALSE) +} + +hexpolygon <- +function(x, y, hexC = hexcoords(dx, dy, n = 1), dx, dy=NULL, + fill = 1, border = 0, hUnit = "native", ...) +{ + ## Purpose: draw hexagon [grid.]polygon()'s around (x[i], y[i])_i + ## Author: Martin Maechler, Jul 2004; Nicholas for grid + + n <- length(x) + stopifnot(length(y) == n) + stopifnot(is.list(hexC) && is.numeric(hexC$x) && is.numeric(hexC$y)) + if(hexC$no.sep) { + n6 <- rep.int(6:6, n) + if(!is.null(hUnit)) { + grid.polygon(x = unit(rep.int(hexC$x, n) + rep.int(x, n6),hUnit), + y = unit(rep.int(hexC$y, n) + rep.int(y, n6),hUnit), + id.lengths = n6, + gp = gpar(col= border, fill= fill)) + } + else { + grid.polygon(x = rep.int(hexC$x, n) + rep.int(x, n6), + y = rep.int(hexC$y, n) + rep.int(y, n6), + id.lengths = n6, + gp = gpar(col= border, fill= fill)) + } + } + else{ ## traditional graphics polygons: must be closed explicitly (+ 1 pt) + n7 <- rep.int(7:7, n) + polygon(x = rep.int(hexC$x, n) + rep.int(x, n7), + y = rep.int(hexC$y, n) + rep.int(y, n7), ...) + } +} + +grid.hexagons <- +function(dat, style = c("colorscale", "centroids", "lattice", + "nested.lattice", "nested.centroids", "constant.col"), + use.count=TRUE, cell.at=NULL, + minarea = 0.05, maxarea = 0.8, check.erosion = TRUE, + mincnt = 1, maxcnt = max(dat@count), trans = NULL, + colorcut = seq(0, 1, length = 17), + density = NULL, border = NULL, pen = NULL, + colramp = function(n){ LinGray(n,beg = 90, end = 15) }, + def.unit = "native", + verbose = getOption("verbose")) +{ + ## Warning: presumes the plot has the right shape and scales + ## See plot.hexbin() + ## Arguments: + ## dat = hexbin object + ## style = type of plotting + ## 'centroids' = symbol area is a function of the count, + ## approximate location near cell center of + ## mass without overplotting + ## 'lattice' = symbol area is a function of the count, + ## plot at lattice points + ## 'colorscale' = gray scale plot, + ## color number determined by + ## transformation and colorcut, + ## area = full hexagons. + ## 'nested.lattice'= plots two hexagons + ## background hexagon + ## area=full size + ## color number by count in powers of 10 starting at pen 2 + ## foreground hexagon + ## area by log10(cnt)-floor(log10(cnt)) + ## color number by count in powers of 10 starting at pen 12 + ## 'nested.centroids' = like nested.lattice + ## but counts < 10 are plotted + ## + ## minarea = minimum symbol area as fraction of the binning cell + ## maxarea = maximum symbol area as fraction of the binning cell + ## mincnt = minimum count accepted in plot + ## maxcnt = maximum count accepted in plot + ## trans = a transformation scaling counts into [0,1] to be applied + ## to the counts for options 'centroids','lattice','colorscale': + ## default=(cnt-mincnt)/(maxcnt-mincnt) + ## colorcut= breaks for translating values between 0 and 1 into + ## color classes. Default= seq(0,1,17), + ## density = for hexagon graph paper + ## border plot the border of the hexagon, use TRUE for + ## hexagon graph paper + ## Symbol size encoding: + ## Area= minarea + scaled.count*(maxarea-minarea) + ## When maxarea==1 and scaled.count==1, the hexagon cell + ## is completely filled. + ## + ## If small hexagons are hard to see increase minarea. + ## For gray scale encoding + ## Uses the counts scaled into [0,1] + ## Default gray cutpoints seq(0,1,17) yields 16 color classes + ## The color number for the first class starts at 2. + ## motif coding: black 15 white puts the first of the + ## color class above the background black + ## The function subtracts 1.e-6 from the lower cutpoint to include + ## the boundary + ## For nested scaling see the code + ## Count scaling alternatives + ## + ## log 10 and Poisson transformations + ## trans <- function(cnt) log10(cnt) + ## min inv <- function(y) 10^y + ## + ## trans <- function(cnt) sqrt(4*cnt+2) + ## inv <- function(y) (y^2-2)/4 + ## Perceptual considerations. + ## Visual response to relative symbol area is not linear and varies from + ## person to person. A fractional power transformation + ## to make the interpretation nearly linear for more people + ## might be considered. With areas bounded between minarea + ## and 1 the situation is complicated. + ## + ## The local background influences color interpretation. + ## Having defined color breaks to focus attention on + ## specific countours can help. + ## + ## Plotting the symbols near the center of mass is not only more accurate, + ## it helps to reduce the visual dominance of the lattice structure. Of + ## course higher resolution binning reduces the possible distance between + ## the center of mass for a bin and the bin center. When symbols + ## nearly fill their bin, the plot appears to vibrate. This can be + ## partially controlled by reducing maxarea or by reducing + ## contrast. + + + ##____________________Initial checks_______________________ + if(!is(dat,"hexbin")) + stop("first argument must be a hexbin object") + style <- match.arg(style) # so user can abbreviate + if(minarea <= 0) + stop("hexagons cannot have a zero area, change minarea") + if(maxarea > 1) + warning("maxarea > 1, hexagons may overplot") + ##_______________ Collect computing constants______________ + + if(use.count){ + cnt <- dat@count + } + else{ + cnt <- cell.at + if(is.null(cnt)){ + if(is.null(dat@cAtt)) stop("Cell attribute cAtt is null") + else cnt <- dat@cAtt + } + } + xbins <- dat@xbins + shape <- dat@shape + tmp <- hcell2xy(dat, check.erosion = check.erosion) + good <- mincnt <= cnt & cnt <= maxcnt + xnew <- tmp$x[good] + ynew <- tmp$y[good] + cnt <- cnt[good] + sx <- xbins/diff(dat@xbnds) + sy <- (xbins * shape)/diff(dat@ybnds) + + ##___________Transform Counts to Radius_____________________ + switch(style, + "centroids" = , + "lattice" = , + "constant.col" =, + "colorscale" = { + if(is.null(trans)) { + if( min(cnt,na.rm=TRUE)< 0){ + pcnt<- cnt + min(cnt) + rcnt <- { + if(maxcnt == mincnt) rep.int(1, length(cnt)) + else (pcnt - mincnt)/(maxcnt - mincnt) + } + } + else rcnt <- { + if(maxcnt == mincnt) rep.int(1, length(cnt)) + else (cnt - mincnt)/(maxcnt - mincnt) + } + } + else { + rcnt <- (trans(cnt) - trans(mincnt)) / + (trans(maxcnt) - trans(mincnt)) + if(any(is.na(rcnt))) + stop("bad count transformation") + } + area <- minarea + rcnt * (maxarea - minarea) + }, + "nested.lattice" = , + "nested.centroids" = { + diffarea <- maxarea - minarea + step <- 10^floor(log10(cnt)) + f <- (cnt/step - 1)/9 + area <- minarea + f * diffarea + area <- pmax(area, minarea) + } + ) + area <- pmin(area, maxarea) + radius <- sqrt(area) + + ##______________Set Colors_____________________________ + switch(style, + "centroids" = , + "constant.col" = , + "lattice" = { + if(is.null(pen)) pen <- rep.int(1, length(cnt)) + else if(length(pen)== length(cnt)) break + else if(length(pen)== 1) pen <- rep.int(pen,length(cnt)) + else stop("'pen' has wrong length") + }, + "nested.lattice" = , + "nested.centroids" = { + if(!is.null(pen) && length(dim(pen)) == 2) { + dp <- dim(pen) + lgMcnt <- ceiling(log10(max(cnt))) + if(dp[1] != length(cnt) && dp[1] != lgMcnt ) { + stop ("pen is not of right dimension") + } + if( dp[1] == lgMcnt ) { + ind <- ceiling(log10(dat@count)) ## DS: 'dat' was 'bin' (??) + ind[ind == 0] <- 1 + pen <- pen[ind,] + } + else break + } + else { + pen <- floor(log10(cnt)) + 2 + pen <- cbind(pen, pen+10) + } + }, + "colorscale" = { + ## MM: Following is quite different from bin2d's + nc <- length(colorcut) + if(colorcut[1] > colorcut[nc]){ + colorcut[1] <- colorcut[1] + 1e-06 + colorcut[nc] <- colorcut[nc] - 1e-06 + } else { + colorcut[1] <- colorcut[1] - 1e-06 + colorcut[nc] <- colorcut[nc] + 1e-06 + } + colgrp <- cut(rcnt, colorcut,labels = FALSE) + if(any(is.na(colgrp))) colgrp <- ifelse(is.na(colgrp),0,colgrp) + ##NL: colramp must be a function accepting an integer n + ## and returning n colors + clrs <- colramp(length(colorcut) - 1) + pen <- clrs[colgrp] + } + ) + + ##__________________ Construct a hexagon___________________ + ## The inner and outer radius for hexagon in the scaled plot + inner <- 0.5 + outer <- (2 * inner)/sqrt(3) + ## Now construct a point up hexagon symbol in data units + dx <- inner/sx + dy <- outer/(2 * sy) + rad <- sqrt(dx^2 + dy^2) + hexC <- hexcoords(dx, dy, sep=NULL) + ##_______________ Full Cell Plotting_____________________ + switch(style, + "constant.col" = , + "colorscale" = { + hexpolygon(xnew, ynew, hexC, + density = density, fill = pen, + border = if(!is.null(border)) border else pen) + + ## and that's been all for these styles + return(invisible(paste("done", sQuote(style)))) + }, + "nested.lattice" = , + "nested.centroids" = { + hexpolygon(xnew, ynew, hexC, + density = density, + fill = if (is.null(border) || border) 1 else pen[,1], + border = pen[,1]) + } + ) + + ##__________________ Symbol Center adjustments_______________ + if(style == "centroids" || style == "nested.centroids") { + xcm <- dat@xcm[good] + ycm <- dat@ycm[good] + ## Store 12 angles around a circle and the replicate the first + ## The actual length for these vectors is determined by using + ## factor use below + k <- sqrt(3)/2 + cosx <- c(1, k, .5, 0, -.5, -k, -1, -k, -.5, 0, .5, k, 1)/sx + siny <- c(0, .5, k, 1, k, .5, 0, -.5, -k, -1, -k, -.5, 0)/sy + ## Compute distances for differences after scaling into + ## [0,size] x [0,aspect*size] + ## Then there are size hexagons on the x axis + dx <- sx * (xcm - xnew) + dy <- sy * (ycm - ynew) + dlen <- sqrt(dx^2 + dy^2) + ## Find the closest approximating direction of the 12 vectors above + cost <- ifelse(dlen > 0, dx/dlen, 0) + tk <- (6 * acos(cost))/pi + tk <- round(ifelse(dy < 0, 12 - tk, tk)) + 1 + ## Select the available length for the approximating vector + hrad <- ifelse(tk %% 2 == 1, inner, outer) + ## Rad is either an inner or outer approximating radius. + ## If dlen + hrad*radius <= hrad, move the center dlen units. + ## Else move as much of dlen as possible without overplotting. + fr <- pmin(hrad * (1 - radius), dlen) # Compute the symbol centers + ## fr is the distance for the plot [0,xbins] x [0,aspect*xbins] + + ## cosx and siny give the x and y components of this distance + ## in data units + xnew <- xnew + fr * cosx[tk] + ynew <- ynew + fr * siny[tk] + } + ## ________________Sized Hexagon Plotting__________________ + ## scale the symbol by radius and add to the new center + n <- length(radius) + if(verbose) + cat('length = ',length(pen),"\n", 'pen = ', pen+1,"\n") + ##switch(style, + ## centroids = , + ## lattice = {if(is.null(pen))pen <- rep.int(1, n) + ## else pen <- rep.int(pen, n)}, + ## nested.lattice = , + ## nested.centroids ={ + ## if( + ## pen[,2] <- pen[,1] + 10 + ## } ) + + ## grid.polygon() closes automatically: now '6' where we had '7': + n6 <- rep.int(6:6, n) + pltx <- rep.int(hexC$x, n) * rep.int(radius, n6) + rep.int(xnew, n6) + plty <- rep.int(hexC$y, n) * rep.int(radius, n6) + rep.int(ynew, n6) + switch(style, + "centroids" = , + "lattice" = { + grid.polygon(pltx, plty, default.units=def.unit, id=NULL, + ## density = density, + id.lengths= n6, + gp=gpar(fill = pen, col = border)) + }, + "nested.lattice" = , + "nested.centroids" = { + grid.polygon(pltx, plty, default.units=def.unit, id=NULL, + id.lengths= n6, + gp=gpar(fill = pen[,2], + ## density = density, + col=if(!is.null(border)) border else pen[,2])) + + }) + +} + +if(FALSE){ ## considering 'hexagons' object + setMethod("hexagons", signature(dat="hexbin"), grid.hexagons) + + erode.hexagons <- function(ebin,pen="black",border="red"){ + print("Blank for now") + } +} diff --git a/R/grid.hexlegend.R b/R/grid.hexlegend.R new file mode 100644 index 0000000..2692a31 --- /dev/null +++ b/R/grid.hexlegend.R @@ -0,0 +1,157 @@ +grid.hexlegend <- +function(legend, ysize, lcex, inner, + style = "colorscale", + minarea = 0.05, maxarea = 0.8, mincnt = 1, maxcnt, trans = NULL, + inv = NULL, colorcut, density = NULL, border = NULL, pen = NULL, + colramp = function(n) { LinGray(n,beg = 90,end = 15) }, + leg.unit="native") +{ + ## the formal arg matching should happen + style <- match.arg(style, eval(formals(grid.hexagons)[["style"]])) + + if (style %in% c("centroids", "lattice", "colorscale")) { + ## _______________tranformations_______________________ + if(is.null(trans)) { + sc <- maxcnt - mincnt + bnds <- round(mincnt + sc * colorcut) + } + + else { + if(!is.function(trans) && !is.function(inv)) + stop("'trans' and 'inv' must both be functions if 'trans' is not NULL") + con <- trans(mincnt) + sc <- trans(maxcnt) - con + bnds <- round(inv(con + sc * colorcut)) + } + } + + if(style == "colorscale") { ## use own 'inner' + n <- length(bnds) + spacing <- ysize/(n + 3) + inner <- min(legend/3.5, (sqrt(3) * spacing)/2) + } + dx <- inner/2 + dy <- dx/sqrt(3) + hexC <- hexcoords(dx, dy, n = 1,sep=NULL) + + ## _______________Plotting______________________________ + switch(style, + "colorscale" = { + midx <- legend/3 + textx <- (2 * legend)/3 + tx <- hexC$x + midx + pen <- colramp(n) + for(i in seq(length = n-1)) { + grid.polygon(tx,hexC$y + i * spacing, + default.units=leg.unit,id=NULL,id.lengths=6, + gp=gpar(fill = pen[i], col = border)) + grid.text(as.character(bnds[i]), textx, (i - 0.5) * spacing, + default.units=leg.unit, gp=gpar(cex = lcex)) + } + grid.text(as.character(bnds[n]), textx, (n - 0.5) * spacing, + default.units=leg.unit, gp=gpar(cex = lcex)) + grid.text("Counts", legend/2, (n + 1.5) * spacing, + default.units=leg.unit, gp=gpar(cex = 1.7 * lcex)) + }, + + "centroids" = , + "lattice" = { + ## NL Solved hex overlap problem on legend + ## Need to tackle too many categories + radius <- sqrt(minarea + (maxarea - minarea) * colorcut) + n <- length(radius) + shift <- c(0, 2*dy*radius) + shift <- shift[1:n] + shift[2:(n+1)] + #labht <- max(strheight(as.character(bnds), cex = lcex)) + labht <- convertY(unit(get.gpar(names = "fontsize")[[1]]*lcex, + "points"),"native",valueOnly = TRUE) + shift <- pmax(labht, shift) + six <- rep.int(6:6, n) + xmid <- legend/3 + inc <- ysize/(n+3) + if(inc > max(shift)) y <- inc * 1:n + else { + y <- cumsum(shift) + extra.slop <- (n * inc) - y[n] # FIXME? y[n] == sum(shift) + shift[-1] <- shift[-1] + extra.slop/(n-1) + y <- cumsum(shift) + ## (y+(1/n)*extra.slop)-y[1] + ## delta <- max(log(shift))-min(log(shift)) + ## fudge <- extra.slop*(diff(log(shift))/delta) + ## y<- c(y[1], y[-1]+ fudge ) + } + textx <- rep.int((2 * legend)/3, n) + ## ____________________plotting______________________ + if(is.null(pen)) pen <- 1 + if(is.null(border)) border <- pen + grid.polygon(x = rep.int(hexC$x,n)* + rep.int(radius, six) + rep.int(xmid, 6 * n), + y = rep.int(hexC$y,n)* + rep.int(radius, six) + rep.int(y, six), + default.units=leg.unit, id=NULL, + id.lengths=rep.int(6,n), + gp=gpar(fill = pen, col = border)) + + grid.text(as.character(bnds), textx, y, + default.units=leg.unit, gp=gpar(cex = lcex)) + grid.text("Counts", legend/2, (n + 2) * inc, + default.units=leg.unit, gp=gpar(cex =1.7 * lcex)) + }, + + "nested.lattice" = , + "nested.centroids" = { + ## _____________x scaling_____________________________ + numb <- cut(floor(legend/inner), breaks = c(-1, 0, 2,4)) + ## Note: In old code + ## top breaks=c(-1,0,2,4,8), numb<- 5 and size=1:9 + if(is.na(numb)) + numb <- 4 + switch(numb, + {warning("not enough space for legend"); return()}, + size <- 5, + size <- c(1, 5, 9), + size <- c(1, 3, 5, 7, 9)) + xmax <- length(size) + radius <- sqrt(minarea + (maxarea - minarea) * (size - 1)/9) + txt <- as.character(size) + ##___________________y scaling_____________________ + lab <- c("Ones", "Tens", "Hundreds", + "Thousands", "10 Thousands", "100 Thousands", + "Millions", "10 Millions", + "100 Millions", "Billions") + power <- floor(log10(maxcnt)) + 1 + yinc <- 16 * dy + if(ysize/power < yinc) + {warning("Not enough height for legend"); return()} + xmid <- legend/10 + x <- inner * (1:xmax - (1 + xmax)/2) + xmid + n <- length(x) + tx <- rep.int(hexC$x, n) + ty <- rep.int(hexC$y, n) + six <- rep.int(6:6, n) + y <- rep.int(3 * dy - yinc, xmax) + ## ____________________plotting______________________ + if(is.null(pen)) { + pen <- 1:power +1 + pen <- cbind(pen, pen +10) + } + if(is.null(border)) border <- FALSE + for(i in 1:power) { + y <- y + yinc + hexpolygon(x, y, hexC, + col = pen[i,1], border = border) + grid.polygon(x= tx * rep.int(radius, six) + rep.int(x, six), + y= ty * rep.int(radius, six) + rep.int(y, six), + default.units=leg.unit, id=NULL, + id.lengths=rep(6,n), + gp=gpar(fill = pen[i,2], col = border)) + + grid.text(txt, x, y - 4.5 * dy, + default.units=leg.unit, gp=gpar(cex = lcex)) + ##adj= 0.5, cex = lcex) + grid.text(lab[i], xmid, y[1] + 4.5 * dy, + default.units=leg.unit, gp=gpar(cex = 1.7*lcex)) + ##adj= 0.5, cex = 1.7*lcex) + } + })## switch(style = *) +}## hex.legend() diff --git a/R/hbox.R b/R/hbox.R new file mode 100644 index 0000000..46913e3 --- /dev/null +++ b/R/hbox.R @@ -0,0 +1,83 @@ +hboxplot <- function(bin, xbnds = NULL, ybnds = NULL, + density, border = c(0,grey(.7)), + pen = c(2, 3), unzoom = 1.1, clip="off", reshape = FALSE, + xlab = NULL, ylab = NULL, main = "") +{ + + ##_______________ Collect computing constants______________ + + if(!is(bin,"hexbin")) + stop("first argument must be a hexbin object") + h.xy <- hcell2xy(bin,check.erosion=TRUE) + ##___zoom in scaling with expanding to avoid hexagons outside plot frame___ + + if(is(bin,"erodebin")) { + h.xy$x <- h.xy$x + h.xy$y <- h.xy$y + nxbnds <- if(is.null(xbnds)) range(h.xy$x) else xbnds + nybnds <- if(is.null(ybnds)) range(h.xy$y) else ybnds + ratiox <- diff(nxbnds)/diff(bin@xbnds) + ratioy <- diff(nybnds)/diff(bin@ybnds) + + ratio <- max(ratioy, ratiox) + nxbnds <- mean(nxbnds) + c(-1,1)*(unzoom * ratio * diff(bin@xbnds))/2 + nybnds <- mean(nybnds) + c(-1,1)*(unzoom * ratio * diff(bin@ybnds))/2 + } + else { + nxbnds <- if(is.null(xbnds)) bin@xbnds else xbnds + nybnds <- if(is.null(ybnds)) bin@ybnds else ybnds + } + margins <- unit(0.1 + c(5,4,4,3),"lines") + plot.vp <- hexViewport(bin, xbnds = nxbnds, ybnds = nybnds, + mar=margins, newpage = TRUE) + pushHexport(plot.vp) + grid.rect() + grid.xaxis() + grid.yaxis() + ## xlab, ylab, main : + if(is.null(xlab)) xlab <- bin@xlab + if(is.null(ylab)) ylab <- bin@ylab + if(nchar(xlab) > 0) + grid.text(xlab, y = unit(-2, "lines"), gp= gpar(fontsize= 16)) + if(nchar(ylab) > 0) + grid.text(ylab, x = unit(-2, "lines"), gp= gpar(fontsize= 16), rot = 90) + if(nchar(main) > 0) + grid.text(main, y = unit(1, "npc") + unit(1.5, "lines"), + gp = gpar(fontsize = 18)) + if(clip=="on") { + popViewport() + pushHexport(plot.vp, clip="on") + } + + cnt <- if(is(bin,"erodebin")) bin@count[bin@eroded] else bin@count + + xbins <- bin@xbins + shape <- bin@shape + xnew <- h.xy$x + ynew <- h.xy$y + + ##__________________ Construct a hexagon___________________ + dx <- (0.5 * diff(bin@xbnds))/xbins + dy <- (0.5 * diff(bin@ybnds))/(xbins * shape * sqrt(3)) + hexC <- hexcoords(dx, dy, sep = NULL) + + ##_______________ Full Cell Plotting_____________________ + hexpolygon(xnew, ynew, hexC, density = density, + fill = pen[2], border = border[2]) + + ##______________Plotting median___________________________ + + if(!is(bin,"erodebin")) { + ## No warning here, allow non-erode above! warning("No erode component") + } + else { + med <- which.max(bin@erode) + xnew <- xnew[med] + ynew <- ynew[med] + hexpolygon(xnew, ynew, hexC, density = density, + fill = pen[1], border = border[1]) + } + popViewport() + invisible(plot.vp) + +}# hboxplot() diff --git a/R/hdiffplot.R b/R/hdiffplot.R new file mode 100644 index 0000000..cdbe711 --- /dev/null +++ b/R/hdiffplot.R @@ -0,0 +1,330 @@ + +### FIXME: Need to check for bin erosion +### or fix hcell2xy so that it checks for bin erosion. +### --- Fixed hcell2xy, probably should do the same to other accessor functions +### NL + +get.xrange <- function(xy.lst, xbnds) +{ + range(unlist(lapply(xy.lst, + function(xy, bnd) + xy$x[(xy$x < max(bnd)) & (xy$x > min(bnd))], + xbnds))) +} + +get.yrange <- function(xy.lst, ybnds) +{ + range(unlist(lapply(xy.lst, + function(xy, bnd) + xy$y[(xy$y < max(bnd)) & (xy$y > min(bnd))], + ybnds))) +} + +make.bnds <- function(binlst, xy.lst, xbnds = NULL, ybnds = NULL) +{ + if(inherits(binlst,"hexbinList")) binlst <- binlst@hbins + if(is.null(xbnds)) xbnds <- binlst[[1]]@xbnds + if(is.null(ybnds)) ybnds <- binlst[[1]]@ybnds + + nxbnds <- get.xrange(xy.lst, xbnds) + nybnds <- get.yrange(xy.lst, ybnds) + + list(xbnds = xbnds, ybnds = ybnds, nxbnds = nxbnds, nybnds = nybnds) +} + +all.intersect <- function(binlist) +{ + ## This will not work if all the grids are not the same + ## Will have to rethink this if we move to non-aligned + ## hexagon bins. NL + if(inherits(binlist,"hexbinList")) binlist <- binlist@hbins + ans <- matrix(FALSE, nr = binlist[[1]]@dimen[1]*binlist[[1]]@dimen[2], + nc = length(binlist)) + for(i in 1:length(binlist)) { + if(is(binlist[[i]], "erodebin")) + ans[binlist[[i]]@cell[binlist[[i]]@eroded], i] <- TRUE + else ans[binlist[[i]]@cell, i] <- TRUE + } + ans +} + +## colordist <- function() { +## } + +## MM: FIXME : `` get(where) '' is a kludge! +mixcolors <- function (alpha, color1, where = class(color1)) +{ + alpha <- as.numeric(alpha) + c1 <- coords(as(color1, where)) + na <- length(alpha) + n1 <- nrow(c1) + if(na == 1) + alpha <- rep(alpha, n1) + stopifnot(sum(alpha) == 1) + get(where)(t(apply(c1, 2, function(cols, alpha) alpha%*%cols, alpha))) + +} + +mixcolors2 <- function (colors, alpha, where="hsv") +{ + # colors: an n x 3 matrix of colors + # alpha: an n x 1 vector of color mixing coefficents + # sum(alpha)==1 should be a restriction? + # where: the color space to mix in (not implemented yet) + # The reurn value is a single hex color forming the mixture + # This function is purely linear mixing, nolinear mixing + # would be quite interesting since the colorspaces are not really + # linear, ie mixing alonga manifold in LUV space. + alpha <- as.numeric(alpha) + na <- length(alpha) + n1 <- nrow(colors) + if (n1 < 2) { + warning("need more than two colors to mix") + colors + } + if(na == 1) + alpha <- rep(alpha, n1) + stopifnot(abs(sum(alpha)-1) <= 0.01) + #colors <- convertColor(colors,from="sRGB",to="Lab",scale.in=1) + mix <- t(apply(colors, 2, function(cols, alpha) alpha%*%cols, alpha)) + #convertColor(mix,from="hsv",to="hex",scale.out=1,clip=TRUE) + hsv(mix[1],mix[2],mix[3]) +} + +hdiffplot <- + function(bin1, bin2 = NULL, xbnds = NULL, ybnds = NULL, + focus = NULL, + col.control = list(medhex = "white", med.bord = "black", + focus = NULL, focus.border = NULL, + back.col = "grey"), + arrows = TRUE, size = unit(0.1, "inches"), lwd = 2, + eps = 1e-6, unzoom = 1.08, clip ="off", xlab = "", ylab = "", + main = deparse(mycall), ...) +{ + ## Arguments: + ## bin1 : hexagon bin object or a list of bin objects + ## bin2 : hexagon bin object or NULL + ## bin objects must have the same plotting bounds and shape + ## border : plot the border of the hexagon, use TRUE for + ## hexagon graph paper + + ## Having all the same parameters ensures that all hexbin + ## objects have the same hexagon grid, and there will be no + ## problems intersecting them. When we have a suitable solution to + ## the hexagon interpolation/intersection problem this will be relaxed. + fixx <- xbnds + fixy <- ybnds + + if(!inherits(bin1,"hexbinList")){ + if(is.null(bin2) & is.list(bin1)) { + bin1 <- as(bin1,"hexbinList") + } + else if(is.null(bin2) & (!is.list(bin1))) + stop(" need at least 2 hex bin objects, or a hexbinList") + else { + if(bin1@shape != bin2@shape) + stop("bin objects must have same shape parameter") + if(all(bin1@xbnds == bin2@xbnds) & all(bin1@ybnds == bin2@ybnds)) + equal.bounds <- TRUE + else stop("Bin objects need the same xbnds and ybnds") + if(bin1@xbins != bin2@xbins) + stop("Bin objects need the same number of bins") + nhb <- 2 + ## Need to make a binlist class, then can do as(bin1, bin2, "binlist") + ## or something similar (NL) + bin1 <- list(bin1 = bin1, bin2 = bin2) + bin1 <- as(bin1,"hexbinList") + } + } + mycall <- sys.call() + if(length(mycall) >= 4) { + mycall[4] <- as.call(quote(.....())) + if(length(mycall) > 4) mycall <- mycall[1:4] + } + if(is.null(focus)) focus <- 1:bin1@n + ##_______________ Collect computing constants______________ + tmph.xy <- lapply(bin1@hbins, hcell2xy, check.erosion = TRUE) + + ## Check for erode bins + eroded <- unlist(lapply(bin1@hbins, is, "erodebin")) + shape <- bin1@Shape + xbins <- bin1@Xbins + bnds <- make.bnds(bin1@hbins, tmph.xy, xbnds = fixx, ybnds = fixy) + ratiox <- diff(bnds$nxbnds)/diff(bnds$xbnds) + ratioy <- diff(bnds$nybnds)/diff(bnds$ybnds) + ratio <- max(ratioy, ratiox) + + nxbnds <- mean(bnds$nxbnds) + c(-1, 1)*(unzoom * ratio * diff(bnds$xbnds))/2 + nybnds <- mean(bnds$nybnds) + c(-1, 1)*(unzoom * ratio * diff(bnds$ybnds))/2 + + ##__________________ Construct plot region___________________ + hvp <- hexViewport(bin1@hbins[[1]], xbnds = nxbnds, ybnds = nybnds, + newpage = TRUE) + pushHexport(hvp) + grid.rect() + grid.xaxis() + grid.yaxis() + if(nchar(xlab) > 0) + grid.text(xlab, y = unit(-2, "lines"), gp = gpar(fontsize = 16)) + if(nchar(ylab) > 0) + grid.text(ylab, x = unit(-2, "lines"), gp = gpar(fontsize = 16), rot = 90) + if(nchar(main) > 0) + grid.text(main, y = unit(1, "npc") + unit(1.5, "lines"), + gp = gpar(fontsize = 18)) + + if(clip=='on'){ + popViewport() + pushHexport(hvp,clip="on") + } + ##__________________ Construct hexagon___________________ + dx <- (0.5 * diff(bin1@Xbnds))/xbins + dy <- (0.5 * diff(bin1@Ybnds))/(xbins * shape * sqrt(3)) + hexC <- hexcoords(dx = dx, dy = dy) + + ##__________________ Set up intersections and colors___________________ + if(length(focus) < bin1@n) { + bin1@hbins <- c(bin1@hbins[focus], bin1@hbins[-focus]) + bin1@Bnames <- c(bin1@Bnames[focus], bin1@Bnames[-focus]) + } + cell.stat <- all.intersect(bin1@hbins) + cell.stat.n <- apply(cell.stat, 1, sum) + i.depth <- max(cell.stat.n) + +### I will do this as a recursive function once I get +### The colors worked out! In fact for more than three +### bin objects there is no other way to do this but recursively!!! +### NL. -- Well this solution is like recursion :) + diff.cols <- vector(mode = "list", length = i.depth) + levcells <- which(cell.stat.n == 1) + whichbin <- apply(cell.stat[levcells, ], 1, which) + + ## Set all the focal colors for the unique bin cells + ## if not specified make them equally spaced on the color wheel + ## with high saturation and set the background bins to gray + nfcol <- length(focus) + nhb <- bin1@n + nbcol <- nhb-nfcol + fills <- + if(is.null(col.control$focus)) { + if(nbcol > 0) + matrix(c(seq(0, 360, length = nfcol+1)[1:nfcol]/360, rep(0, nbcol), + rep(1, nfcol), rep(0, nbcol),rep(1, nfcol), rep(.9, nbcol)), + nc=3) + ## V = c(rep(1, nfcol), seq(.9, .1, length=nbcol)) + + else #matrix(c(seq(0, 360, length = nhb+1), s=1, v=1)[1:nfcol] + matrix(c(seq(0, 360, length = nhb+1)/360, + rep(1,nhb+1), + rep(1,nhb+1)),nc=3)[1:nhb,] + } + else { + foc.col <- t(rgb2hsv(col2rgb(col.control$focus))) + if(nbcol > 0) { + bcol <- matrix(c(rep(0, 2*nbcol), rep(.9, nbcol)), nc = 3) + rbind(foc.col, bcol) + } + else foc.col + } + colnames(fills) <- c("h","s","v") + diff.cols[[1]] <- list(fill = fills, border = gray(.8)) + + ##_______________ Full Cell Plotting for Unique Bin1 Cells_________________ + + if(length(levcells) > 0) { + for(i in unique(whichbin)) { + pcells <- + if(eroded[i]) + bin1@hbins[[i]]@cell[bin1@hbins[[i]]@eroded] + else bin1@hbins[[i]]@cell + pcells <- which(pcells %in% levcells[whichbin == i]) + pfill <- diff.cols[[1]]$fill[i,] + pfill <- hsv(pfill[1],pfill[2],pfill[3]) + hexpolygon(x = tmph.xy[[i]]$x[pcells], + y = tmph.xy[[i]]$y[pcells], hexC, + border = diff.cols[[1]]$border , + fill = pfill) + } + } + + ## Now do the intersections. All intersections are convex + ## combinations of the colors of the overlapping unique bins in + ## the CIEluv colorspace. so if the binlist is of length 2 and + ## the focal hbins are "blue" and "yellow" respectively the + ## intersection would be green. First I need to get this to work + ## and then I can think about how to override this with an option + ## in color.control. -NL + + if(i.depth > 1) { + for(dl in 2:(i.depth)) { + levcells <- which(cell.stat.n == dl) + if(length(levcells) == 0) next + + whichbin <- apply(cell.stat[levcells, ], 1, + function(x) paste(which(x), sep = "", collapse = ":")) + inter.nm <- unique(whichbin) + #fills <- matrix(0, length(inter.nm), 3) + fills <- rep(hsv(1), length(inter.nm)) + i <- 1 + for(bn in inter.nm) { + who <- as.integer(unlist(strsplit(bn, ":"))) + fills[i] <- mixcolors2(diff.cols[[1]]$fill[who,], + 1/length(who),where = "LUV") + i <- i+1 + } + #fills <- LUV(fills) + diff.cols[[dl]] <- list(fill = fills, + border = gray((i.depth-dl)/i.depth)) + ##____Full Cell Plotting for Intersecting Cells at Intersection Depth i____ + i <- 1 + for(ints in inter.nm) { + bin.i <- as.integer(unlist(strsplit(ints, ":"))[1]) + pcells <- + if(eroded[bin.i]) + bin1@hbins[[bin.i]]@cell[bin1@hbins[[bin.i]]@eroded] + else bin1@hbins[[bin.i]]@cell + pcells <- which(pcells %in% levcells[whichbin == ints]) + hexpolygon(x = tmph.xy[[bin.i]]$x[pcells], + y = tmph.xy[[bin.i]]$y[pcells], hexC, + border = diff.cols[[dl]]$border , + fill = diff.cols[[dl]]$fill[i] ) + i <- i+1 + } + } + + } + + ##_____________________________Plot Median Cells___________________________ + + ## With all these colors floating around I think it would be worth + ## porting the 3d hexagon stuff to grid. Then it would be easier + ## to distinguish the medians because they would stand out like + ## little volcanoes :) NL + if(any(eroded)) { + hmeds <- matrix(unlist(lapply(bin1@hbins[eroded], + function(x) unlist(getHMedian(x)))), + nc = 2, byrow = TRUE) + hexpolygon(x = hmeds[, 1], y = hmeds[, 2], hexC, + border = col.control$med.b, fill = col.control$medhex) + if(arrows) { + for(i in focus) { + for(j in focus[focus < i]) { + if(abs(hmeds[i, 1] - hmeds[j, 1]) + + abs(hmeds[i, 2] - hmeds[j, 2]) > eps) + grid.lines(c(hmeds[i, 1],hmeds[j, 1]), + c(hmeds[i, 2], hmeds[j, 2]), + default.units = "native", + arrow=arrow(length=size)) + #grid.arrows(c(hmeds[i, 1], hmeds[j, 1]), + # c(hmeds[i, 2], hmeds[j, 2]), + # default.units = "native", + # length = size, gp = gpar(lwd = lwd)) + } + } + } + } + + ##________________Clean Up_______________________________________________ + + popViewport() + invisible(hvp) +} ## hdiffplot() diff --git a/R/hexPlotMA.R b/R/hexPlotMA.R new file mode 100644 index 0000000..8da7066 --- /dev/null +++ b/R/hexPlotMA.R @@ -0,0 +1,191 @@ +plotMAhex <- function (MA, array = 1, xlab = "A", ylab = "M", + main = colnames(MA)[array], + xlim = NULL, ylim = NULL, status = NULL, + values, pch, col, cex, nbin=40, + zero.weights = FALSE, + style = "colorscale", legend = 1.2, lcex = 1, + minarea = 0.04, maxarea = 0.8, mincnt = 2, + maxcnt = NULL, trans = NULL, inv = NULL, + colorcut = NULL, + border = NULL, density = NULL, pen = NULL, + colramp = function(n){ LinGray(n,beg = 90,end = 15) }, + newpage = TRUE, type = c("p", "l", "n"), + xaxt = c("s", "n"), yaxt = c("s", "n"), + verbose = getOption("verbose")) +{ + if(is.null(main))main <- "" + switch(class(MA),marrayRaw={ + x <- maA(MA[,array]) + y <- maM(MA[,array]) + w <- maW(MA[,array]) + },RGList = { + MA <- MA.RG(MA[, array]) + array <- 1 + x <- MA$A + y <- MA$M + w <- MA$w + }, MAList = { + x <- as.matrix(MA$A)[, array] + y <- as.matrix(MA$M)[, array] + if (is.null(MA$weights)) + w <- NULL + else + w <- as.matrix(MA$weights)[, array] + }, list = { + if (is.null(MA$A) || is.null(MA$M)) + stop("No data to plot") + x <- as.matrix(MA$A)[, array] + y <- as.matrix(MA$M)[, array] + if (is.null(MA$weights)) + w <- NULL + else + w <- as.matrix(MA$weights)[, array] + }, MArrayLM = { + x <- MA$Amean + y <- as.matrix(MA$coefficients)[, array] + if (is.null(MA$weights)) + w <- NULL + else + w <- as.matrix(MA$weights)[, array] + }, matrix = { + narrays <- ncol(MA) + if (narrays < 2) + stop("Need at least two arrays") + if (narrays > 5) + x <- apply(MA, 1, median, na.rm = TRUE) + else + x <- rowMeans(MA, na.rm = TRUE) + y <- MA[, array] - x + w <- NULL + }, ExpressionSet = { + if(!require(Biobase)) + stop("cannot process ExpressionSet objects without package Biobase") + narrays <- ncol(exprs(MA)) + if (narrays < 2) + stop("Need at least two arrays") + if (narrays > 5) + x <- apply(exprs(MA), 1, median, na.rm = TRUE) + else + x <- rowMeans(exprs(MA), na.rm = TRUE) + y <- exprs(MA)[, array] - x + w <- NULL + if (missing(main)) + main <- colnames(exprs(MA))[array] + }, AffyBatch = { + if(!require(affy)| !require(Biobase)) + stop("cannot process AffyBatch objects without package Biobase and affy") + narrays <- ncol(exprs(MA)) + if (narrays < 2) + stop("Need at least two arrays") + if (narrays > 5) + x <- apply(log2(exprs(MA)), 1, median, na.rm = TRUE) + else + x <- rowMeans(log2(exprs(MA)), na.rm = TRUE) + y <- log2(exprs(MA)[, array]) - x + w <- NULL + if (missing(main)) + main <- colnames(exprs(MA))[array] + }, stop("MA is invalid object")) + if (!is.null(w) && !zero.weights) { + i <- is.na(w) | (w <= 0) + y[i] <- NA + } + if (is.null(xlim)) + xlim <- range(x, na.rm = TRUE) + if (is.null(ylim)) + ylim <- range(y, na.rm = TRUE) + + hbin <- hexbin(x,y,xbins=nbin,xbnds=xlim,ybnds=ylim, IDs = TRUE) + hp <- plot(hbin, legend=legend, xlab = xlab, ylab = ylab, main = main, + type='n', newpage=newpage) + ## plot the hexagons + pushHexport(hp$plot.vp) + if(is.null(maxcnt)) maxcnt <- max(hbin@count) + if(is.null(colorcut)) colorcut<-seq(0, 1, length = min(17, maxcnt)) + grid.hexagons(hbin, style=style, minarea = minarea, maxarea = maxarea, + mincnt = mincnt, maxcnt= maxcnt, trans = trans, + colorcut = colorcut, density = density, border = border, + pen = pen, colramp = colramp) + if (is.null(status) || all(is.na(status))) { + if (missing(pch)) + pch <- 16 + if (missing(cex)) + cex <- 0.3 + if (missing(col)) { + clrs <- colramp(length(colorcut)-1) + col <- clrs[1] + } + pp <- inout.hex(hbin,mincnt) + grid.points(x[pp], y[pp], pch = pch[[1]], + gp=gpar(cex = cex[1], col=col, fill=col)) + } + else { + if (missing(values)) { + if (is.null(attr(status, "values"))) + values <- names(sort(table(status), decreasing = TRUE)) + else + values <- attr(status, "values") + } + sel <- !(status %in% values) + nonhi <- any(sel) + if (nonhi) grid.points(x[sel], y[sel], pch = 16, gp=gpar(cex = 0.3)) + nvalues <- length(values) + if (missing(pch)) { + if (is.null(attr(status, "pch"))) + pch <- rep(16, nvalues) + else + pch <- attr(status, "pch") + } + if (missing(cex)) { + if (is.null(attr(status, "cex"))) { + cex <- rep(1, nvalues) + if (!nonhi) + cex[1] <- 0.3 + } + else + cex <- attr(status, "cex") + } + if (missing(col)) { + if (is.null(attr(status, "col"))) { + col <- nonhi + 1:nvalues + } + else + col <- attr(status, "col") + } + pch <- rep(pch, length = nvalues) + col <- rep(col, length = nvalues) + cex <- rep(cex, length = nvalues) + for (i in 1:nvalues) { + sel <- status == values[i] + grid.points(x[sel], y[sel], pch = pch[[i]], gp=gpar(cex = cex[i], col = col[i])) + } + } + popViewport() + if (legend > 0) { + inner <- hexbin:::getPlt(hp$plot.vp, ret.unit="inches", numeric=TRUE)[1] + inner <- inner/hbin@xbins + ysize <- hexbin:::getPlt(hp$plot.vp, ret.unit="inches", numeric=TRUE)[2] + pushViewport(hp$legend.vp) + grid.hexlegend(legend, ysize=ysize, lcex = lcex, inner = inner, + style= style, minarea= minarea, maxarea= maxarea, + mincnt= mincnt, maxcnt= maxcnt, + trans=trans, inv=inv, + colorcut = colorcut, + density = density, border = border, pen = pen, + colramp = colramp) + + #if (is.list(pch)) + # legend(x = xlim[1], y = ylim[2], legend = values, + # fill = col, col = col, cex = 0.9) + #else legend(x = xlim[1], y = ylim[2], legend = values, + # pch = pch, , col = col, cex = 0.9) + popViewport() + } + invisible(list(hbin = hbin, plot.vp = hp$plot.vp, legend.vp = hp$legend.vp)) +} + +hexMA.loess <- function(pMA, span = .4, col = 'red', n = 200) +{ + fit <- hexVP.loess(pMA$hbin, pMA$plot.vp, span = span, col = col, n = n) + invisible(fit) +} diff --git a/R/hexViewport.R b/R/hexViewport.R new file mode 100644 index 0000000..5734617 --- /dev/null +++ b/R/hexViewport.R @@ -0,0 +1,250 @@ +setOldClass("unit") +setOldClass("viewport") + +smartBnds <- function(hbin, eps=.05) +{ + hxy <- hcell2xy(hbin) + xr <- range(hxy$x) + yr <- range(hxy$y) + dx <- diff(xr) + dy <- diff(yr) + lambda <- function(a) pmax(log(a), 1) + epsx <- c(-1,1)*(dx*eps/lambda(dx)) + epsy <- c(-1,1)*(dy*eps/lambda(dy)) + sx <- hbin@xbins/diff(hbin@xbnds) + sy <- (hbin@xbins * hbin@shape)/diff(hbin@ybnds) + inner <- 0.5 + outer <- 1/sqrt(3) + dx <- inner/sx + dy <- outer/sy + #xb <- dx/(hbin@xbins+1) + #yb <- dy/((1/sqrt(3))*(hbin@xbins+1)*hbin@shape) + list(xr = xr+ c(-dx,dx)+ epsx, + yr = yr+ c(-dy,dy)+ epsy) +} + +rname <- function(n, chars = letters) +{ + ## random name with n characters + paste(sample(chars, size = n, replace = TRUE), collapse="") +} + +setClass("hexVP", + representation(hexVp.on = "viewport", hexVp.off = "viewport", + mar = "unit", fig = "unit", plt = "unit", + xscale = "numeric", yscale = "numeric",shape="numeric", + hp.name="character") + ) + +hexViewport <- +function(x, offset = unit(0,"inches"), mar = NULL, + xbnds = NULL, ybnds = NULL, newpage = FALSE, + clip ="off", vp.name=NULL) +{ + if(!is(x,"hexbin")) + stop("first argument must be a hexbin object.") + stopifnot(is.unit(offset)) + + hvp <- new("hexVP") + if (newpage) + grid.newpage() + + if(is.null(mar)) { + mar <- unit(0.1 + c(5,4,4,2),"lines") + } + else { + if(!is.unit(mar)) stop("'mar' must be specified in unit()s") + if(length(mar) == 1) + mar <- rep(mar, 4) + else if(length(mar) != 4) + stop("'mar' must have length 1 or 4") + } + ## in both cases + mai <- as.numeric(convertUnit(mar, "inches")) + vpin <- c(convertWidth (unit(1,"npc"),"inches"), convertHeight(unit(1,"npc"),"inches")) + fig <- c(as.numeric(convertUnit(unit(vpin[1],"inches") - offset,"inches")), as.numeric(vpin[2])) + pin <- c(fig[1]-mai[2]-mai[4], fig[2]-mai[1]-mai[3]) + xsize <- pin[1] + ysize <- pin[2] + + ## The point is to optimize the placement + ## and plotting area of the plotting window with + ## the constraint that the margins are preserved + ## to within some epsilon. This is going to get even + ## harder for cases where the complex layouts are + ## being constructed. NL -- I think it is fixed now (NL --3/22/2005) + + ## Now find the maximum rectangle in fig that + ## has the correct aspect ratio and does not spill over epsilon into + ## the margins, i.e. ysize/xsize - aspect.ratio < eps and + ## xsize < fig[1], ysize < fig[2] + + if(x@shape * xsize <= ysize) { + ##center <- (ysize - x@shape * xsize)/2 + center <- (ysize - x@shape * xsize)/2 + mai[1] <- mai[1] + center + mai[3] <- mai[3] + center + ysize <- x@shape * xsize + } else { + center <- (xsize - ysize/x@shape)/2 + mai[2] <- mai[2] + center + mai[4] <- mai[4] + center + xsize <- ysize/x@shape + } + ##fig <- c(pin[1]+mai[2]+ mai[4],fig[2]) + pin <- c(xsize,ysize) + mar <- c(convertUnit(unit(mai[1],"inches"),"lines"), + convertUnit(unit(mai[2],"inches"),"lines"), + convertUnit(unit(mai[3],"inches"),"lines"), + convertUnit(unit(mai[4],"inches"),"lines")) + ##pin <- c(fig[1]-(mai[2] + mai[4]), + ## fig[2]-(mai[1] + mai[3])) + margins <- rep(as.numeric(mar), length.out = 4) + wd <- convertUnit(unit(pin[1],"inches"),"npc") + ## (unit(sum(margins[c(2, 4)]), "lines") + + ## convertUnit(unit(legend,"inches"),"lines")) + ## Oy, mi stupido! This is the problem, need to get the bounds right + ## here. Fixed, do we need to guard against others stupidity and put some + ## checks on xbnds and ybnds? (NL,4/1/2005) + if(is.null(vp.name)) + vp.name <- rname(5) + xyb <- smartBnds(x) + hvp@xscale <- xs <- if(is.null(xbnds)) xyb$xr else xbnds + hvp@yscale <- ys <- if(is.null(ybnds)) xyb$yr else ybnds + ht <- unit(1, "npc") - unit(sum(margins[c(1,3)]), "lines") + hvp@hexVp.off <- + viewport(x = unit(margins[2], "lines"), + y = unit(margins[1], "lines"), + width = wd, height = ht, xscale = xs, yscale = ys, + just = c("left", "bottom"), default.unit = "native", + clip = "off", name = paste(vp.name,".off",sep="")) + hvp@hexVp.on <- + viewport(x = unit(margins[2], "lines"), + y = unit(margins[1], "lines"), + width = wd, height = ht, xscale = xs, yscale = ys, + just = c("left", "bottom"), default.unit = "native", + clip = "on", name = paste(vp.name,".on",sep="")) + hvp@mar <- unit(mar,"lines") + hvp@fig <- convertUnit(unit(fig,"inches"),"npc") + hvp@plt <- convertUnit(unit(pin,"inches"),"npc") + hvp@shape <- x@shape + ##hvp@leg <-convertUnit(offset,"npc") + hvp +} + +## Potentially: +## setGeneric("grid:::pushViewport") +## setMethod("pushViewport", signature(x="hexVP"), +## function(hvp) { pushViewport(hvp@hexVp) }) + +pushHexport <- function(hvp, clip="off") +{ + if(!is(hvp, "hexVP")) + stop("1st argument must be 'hexVP' object") + pushViewport(if(clip=="on") hvp@hexVp.on else hvp@hexVp.off) +} + +## maybe in the future +## setMethod("push",signature("hexVP"), pushHexport) + +setGeneric("getMargins", function(x, ret.unit = "npc", numeric = FALSE) + standardGeneric("getMargins")) +setMethod("getMargins", "hexVP", + function(x, ret.unit = "npc", numeric = FALSE){ + mar <- convertUnit(x@mar,ret.unit) + if(numeric) as.numeric(mar) else mar + }) + +setGeneric("getPlt", function(x, ret.unit = "npc", numeric = FALSE) + standardGeneric("getPlt")) +setMethod("getPlt", "hexVP", + function(x, ret.unit = "npc", numeric = FALSE){ + plt <- convertUnit(x@plt,ret.unit) + if(numeric) as.numeric(plt) else plt + }) + +setGeneric("getFig", function(x, ret.unit = "npc", numeric = FALSE) + standardGeneric("getFig")) +setMethod("getFig", "hexVP", + function(x, ret.unit = "npc", numeric = FALSE){ + fig <- convertUnit(x@fig,ret.unit) + if(numeric) as.numeric(fig) else fig + }) + +## MM doesn't think it's ok to "pollute" the generic-space +## just for basic slot accessors : + +## setGeneric("getXscale", function(x)standardGeneric("getXscale")) +## setMethod("getXscale", "hexVP", function(x){ x@xscale }) + +## setGeneric("getYscale", function(x)standardGeneric("getYscale")) +## setMethod("getYscale", "hexVP", function(x){ x@yscale }) + +hexVP.abline <- function(hvp, a = NULL, b = NULL, h = numeric(0), + v = numeric(0), col = 'black', + lty = 1, lwd = 2, ...) +{ + pushHexport(hvp, clip = 'on') + col.line <- col + if (!is.null(a)) { + if (inherits(a, "lm")) { + coeff <- coef(a) + } + else if (!is.null(tryCatch(coef(a), error = function(e) NULL))) + coeff <- coef(a) + else coeff <- c(a, b) + if (length(coeff) == 1) + coeff <- c(0, coeff) + if (coeff[2] == 0) + h <- c(h, coeff[1]) + else if (!any(is.null(coeff))) { + xx <- current.viewport()$xscale + yy <- current.viewport()$yscale + x <- numeric(0) + y <- numeric(0) + ll <- function(i, j, k, l) + (yy[j] - coeff[1] - coeff[2] * xx[i]) * (yy[l] - coeff[1] - coeff[2] * xx[k]) + if (ll(1, 1, 2, 1) <= 0) { + y <- c(y, yy[1]) + x <- c(x, (yy[1] - coeff[1])/coeff[2]) + } + if (ll(2, 1, 2, 2) <= 0) { + x <- c(x, xx[2]) + y <- c(y, coeff[1] + coeff[2] * xx[2]) + } + if (ll(2, 2, 1, 2) <= 0) { + y <- c(y, yy[2]) + x <- c(x, (yy[2] - coeff[1])/coeff[2]) + } + if (ll(1, 2, 1, 1) <= 0) { + x <- c(x, xx[1]) + y <- c(y, coeff[1] + coeff[2] * xx[1]) + } + if (length(x) > 0) + grid.lines(x = x, y = y, default.units = "native", + gp = gpar(col = col.line, lty = lty, lwd = lwd)) + } + } + h <- as.numeric(h) + v <- as.numeric(v) + for (i in seq(along = h)) + grid.lines(y = rep(h[i], 2), default.units = "native", + gp = gpar(col = col.line, lty = lty, lwd = lwd)) + for (i in seq(along = v)) + grid.lines(x = rep(v[i], 2), default.units = "native", + gp = gpar(col = col.line, lty = lty, lwd = lwd)) + popViewport() +} + +hexVP.loess <- function(hbin, hvp = NULL, span = 0.4, col = 'red', n = 200) +{ + fit <- loess(hbin@ycm ~ hbin@xcm, weights = hbin@count, span = span) + if(!is.null(hvp)) { + pushHexport(hvp, clip = 'on') + grid.lines(seq(0,16, length = n), + predict(fit,seq(0,16, length = n)), + gp = gpar(col = col), default.units = 'native') + popViewport() + } + invisible(fit) +} diff --git a/R/hexbin.s4.R b/R/hexbin.s4.R new file mode 100644 index 0000000..8729b9b --- /dev/null +++ b/R/hexbin.s4.R @@ -0,0 +1,349 @@ +## namespace *internal* function: +addBit <- function(bnds, f = 0.05) bnds + c(-f, f) * diff(bnds) +hexbin <- + function(x, y = NULL, xbins = 30, shape = 1, + xbnds = range(x), ybnds = range(y), + xlab = NULL, ylab = NULL, IDs = FALSE) +{ + call <- match.call() + ## (x,y, xlab, ylab) dealing + xl <- if (!missing(x)) deparse(substitute(x)) + yl <- if (!missing(y)) deparse(substitute(y)) + xy <- xy.coords(x, y, xl, yl) + ch0 <- function(u) if(is.null(u)) "" else u + xlab <- if (is.null(xlab)) ch0(xy$xlab) else xlab + ylab <- if (is.null(ylab)) ch0(xy$ylab) else ylab + x <- xy$x + y <- xy$y + n <- length(x) + na <- is.na(x) | is.na(y) + has.na <- any(na) + if (has.na) { + ok <- !na + x <- x[ok] + y <- y[ok] + n0 <- n + na.pos <- which(na) + n <- length(x) + } + if(diff(xbnds) <= 0) + stop("xbnds[1] < xbnds[2] is not fulfilled") + if(!missing(xbnds) && any(sign(xbnds - range(x)) == c(1,-1))) + stop("'xbnds' must encompass range(x)") + if(diff(ybnds) <= 0) + stop("ybnds[1] < ybnds[2] is not fulfilled") + if(!missing(ybnds) && any(sign(ybnds - range(y)) == c(1,-1))) + stop("'ybnds' must encompass range(y)") + jmax <- floor(xbins + 1.5001) + #imax <- 2 * floor((xbins * shape)/sqrt(3) + 1.5001) + c1 <- 2 * floor((xbins *shape)/sqrt(3) + 1.5001) + imax <- trunc((jmax*c1 -1)/jmax + 1) + lmax <- jmax * imax + ans <- .Fortran("hbin", + x = as.double(x), + y = as.double(y), + cell = integer(lmax), + cnt = integer(lmax), + xcm = double(lmax), + ycm = double(lmax), + xbins = as.double(xbins), + shape = as.double(shape), + xbnds = as.double(xbnds), + ybnds = as.double(ybnds), + dim = as.integer(c(imax, jmax)), + n = as.integer(n), + cID = if(IDs) integer(n) else as.integer(-1), + PACKAGE = "hexbin")[-(1:2)] + + ## cut off extraneous stuff + if(!IDs) ans$cID <- NULL + if(IDs && has.na) { + ok <- as.integer(ok) + ok[!na] <- ans$cID + ok[na] <- NA + ans$cID <- ok + } + nc <- ans$n + length(ans$cell) <- nc + length(ans$cnt) <- nc + length(ans$xcm) <- nc + length(ans$ycm) <- nc + if(sum(ans$cnt) != n) warning("Lost counts in binning") + new("hexbin", + cell = ans$cell, count = ans$cnt, + xcm = ans$xcm, ycm = ans$ycm, xbins = ans$xbins, + shape = ans$shape, xbnds = ans$xbnds , ybnds = ans$ybnds, + dimen = c(imax, jmax), n = n, ncells = ans$n, + call = call, xlab = xlab, ylab = ylab, cID = ans$cID, cAtt = integer(0)) + #dimen = ans$dim +}## hexbin + +setClassUnion("integer or NULL",# < virtual class, used in 'cID' slot + members = c("integer","NULL")) +## MM: I've learned that we should think twice before defining such +## "or NULL" classes: +## setClassUnion("vector or NULL",# < virtual class, used in 'cAtt' slot +## members = c("vector","NULL")) + +setClass("hexbin", + representation(cell = "integer", count = "numeric",##count = "integer", + xcm = "numeric", ycm = "numeric", xbins = "numeric", + shape = "numeric", xbnds = "numeric", + ybnds = "numeric", dimen = "numeric", + n = "integer", ncells = "integer", call = "call", + xlab = "character", ylab = "character", + cID = "integer or NULL", cAtt = "vector")## "or NULL" + ) + + +#setIs("hexbin", function(hbin) class(hbin)=="hexbin") + +## FIXME: add 'validity checking method! + +setGeneric("hcell2xy", function(hbin, check.erosion = TRUE) + standardGeneric("hcell2xy")) +setMethod("hcell2xy", "hexbin", function(hbin, check.erosion = TRUE) +{ + xbins <- hbin@xbins + xbnds <- hbin@xbnds + c3 <- diff(xbnds)/xbins + ybnds <- hbin@ybnds + c4 <- (diff(ybnds) * sqrt(3))/(2 * hbin@shape * xbins) + jmax <- hbin@dimen[2] + cell <- hbin@cell - 1 + i <- cell %/% jmax + j <- cell %% jmax + y <- c4 * i + ybnds[1] + x <- c3 * ifelse(i %% 2 == 0, j, j + 0.5) + xbnds[1] + if(check.erosion && inherits(hbin,"erodebin")) + list(x = x[hbin@eroded], y = y[hbin@eroded]) + else + list(x = x, y = y) +}) + +setGeneric("getHexDxy", function(hbin) standardGeneric("getHexDxy")) +setMethod("getHexDxy", "hexbin", function(hbin){ + sx <- hbin@xbins/diff(hbin@xbnds) + sy <- (hbin@xbins * hbin@shape)/diff(hbin@ybnds) + list(dx=.5/sx, dy=(1/sqrt(3))/(2*sy)) +}) + + +setClass("erodebin", representation("hexbin", + eroded = "logical", + cdfcut = "numeric", + erode = "integer")) + +setGeneric("erode", function(hbin, cdfcut = 0.5) standardGeneric("erode")) + +## currently define the 'hexbin' method (also) as standalone function: +erode.hexbin <- function(hbin, cdfcut = 0.5) +{ + if(!is(hbin,"hexbin")) stop("first argument must be a hexbin object") + #bin.att <- attributes(hbin) + cell <- hbin@cell + cnt <- hbin@count + tmp <- sort(cnt) + cdf <- cumsum(tmp)/sum(cnt) + good <- cdfcut <= cdf + if(!any(good)) + return("no cells selected") + crit <- min(tmp[good]) + good <- crit <= cnt + cell <- cell[good] + cnt <- cnt[good] + #hbin@cell <- cell + #hbin@count <- cnt + n <- length(cell) + bdim <- hbin@dimen + L <- bdim[1] * bdim[2] + ans <- .Fortran("herode", + cell = as.integer(cell), + cnt = as.integer(cnt), + n = n, + bdim = as.integer(bdim), + erode = integer(L), + ncnt = integer(L), + ncell = integer(L), + sides = integer(L), + neib = integer(6 * L), + exist = logical(L + 1), + PACKAGE = "hexbin") $ erode + length(ans) <- n + ehbin <- new("erodebin", hbin, cdfcut = cdfcut, eroded = good, erode = ans) + #hbin@erode <- ans + #class(hbin) <- c(class(hbin),"erodebin") + ehbin +} +setMethod("erode", "hexbin", erode.hexbin) + +setGeneric("getHMedian", function(ebin) standardGeneric("getHMedian")) +setMethod("getHMedian", "erodebin", function(ebin) + { + xy <- hcell2xy(ebin) + stopifnot(1 == length(med <- which.max(ebin@erode))) + med.x <- xy$x[med] + med.y <- xy$y[med] + + list(x = med.x, y = med.y) + }) + +## Still define the 'hexbin' plot method (also) as standalone function: +## This is deprecated! +gplot.hexbin <- + function(x, style = "colorscale", + legend = 1.2, lcex = 1, + minarea = 0.04, maxarea = 0.8, mincnt = 1, maxcnt = max(x@count), + trans = NULL, inv = NULL, + colorcut = seq(0, 1, length = min(17, maxcnt)), + border = NULL, density = NULL, pen = NULL, + colramp = function(n) LinGray(n, beg = 90, end = 15), + xlab = NULL, ylab = NULL, main = "", newpage = TRUE, + type = c("p", "l", "n"), xaxt = c("s", "n"), yaxt = c("s", "n"), + clip="on", verbose = getOption("verbose")) +{ + if(!is(x,"hexbin")) + stop("first argument must be a hexbin object") + if(minarea < 0) + stop("Minimum area must be non-negative") + if(maxarea > 1) + warning("Maximum area should be <= 1 this leads to overlapping hexagons") + if(minarea > maxarea) + stop("Minarea must be <= maxarea") + if (length(colorcut) > 1) { # a sequence 0,...,1 + if(colorcut[1] != 0) + stop("Colorcut lower boundary must be 0") + if(colorcut[length(colorcut)] != 1) + stop("Colorcut upper boundary must be 1") + } + else { + colorcut <- + if(colorcut > 1) seq(0, 1, length = min(c(17, colorcut, maxcnt))) + else 1 + } + + if(is.logical(legend)) { + if(legend) + stop("Give the legend width") + else legend <- 0 + } else stopifnot(is.numeric(legend) && length(legend) == 1) + + type <- match.arg(type) + xaxt <- match.arg(xaxt) + yaxt <- match.arg(yaxt) + + ## ----- plotting starts ------------------------ + if (newpage) grid.newpage() + hv.ob <- hexViewport(x, offset = unit(legend,"inches")) + pushViewport(hv.ob@hexVp.off) + grid.rect() + if(xaxt != "n") grid.xaxis() + if(yaxt != "n") grid.yaxis() + ## xlab, ylab, main : + if(is.null(xlab)) xlab <- x@xlab + if(is.null(ylab)) ylab <- x@ylab + if(nchar(xlab) > 0) + grid.text(xlab, y = unit(-2, "lines"), gp = gpar(fontsize = 16)) + if(nchar(ylab) > 0) + grid.text(ylab, x = unit(-2, "lines"), gp = gpar(fontsize = 16), rot = 90) + if(nchar(main) > 0) + grid.text(main, y = unit(1, "npc") + unit(1.5, "lines"), + gp = gpar(fontsize = 18)) + if(type != "n") { + if(clip == "on") { + popViewport() + pushViewport(hv.ob@hexVp.on) + } + grid.hexagons(x, style = style, minarea = minarea, maxarea = maxarea, + mincnt = mincnt, maxcnt = maxcnt, check.erosion = FALSE, + trans = trans, colorcut = colorcut, density = density, + border = border, pen = pen, + colramp = colramp, verbose = verbose) + } + + popViewport()# plot + #popViewport()# fig + ## ----- Legend ------------------------ + if(legend > 0) { + if(!is.null(trans) && is.null(inv)) + stop("Must supply the inverse transformation") + if(verbose) + cat("plot.hexbin( legend > 0): ... hex.legend()\n") + inner <- getPlt(hv.ob, ret.unit = "inches", numeric = TRUE)[1]/x@xbins + ##inner <- as.numeric(convertUnit(hv.ob@plt[1],"inches"))/x@xbins + ##outer <- (inner * sqrt(3))/2 + ##switch(style, + ## lattice = , + ## centroids = { + ## if(length(colorcut) * outer > ysize - 1) { + ## warning("Colorcut is being shortened") + ## colorcut <- seq(0, 1, + ## max(1, floor((ysize - 1)/outer))) + ## } + ## } + ## ) + ysize <- getPlt(hv.ob, ret.unit = "inches", numeric = TRUE)[2] + #as.numeric(convertUnit(hv.ob@plt[2],"inches")) + legVp <- viewport(x = unit(1,"npc") - + convertX(unit(legend,"inches"), "npc"), + #y = convertY(unit(mai[1],"inches"),"npc"), + y = hv.ob@mar[1], + #height = unit(1,"npc") - + #convertY(unit(mai[3]+mai[1],"inches"),"npc"), + height = unit(1,"npc")-(hv.ob@mar[1]+ hv.ob@mar[3]), + width = convertUnit(unit(legend,"inches"),"npc"), + default.units = "native", + just = c("left","bottom"), + xscale = c(0, legend), + yscale = c(0, ysize)) + if(type != "n") { + pushViewport(legVp) + grid.hexlegend(legend, ysize = ysize, lcex = lcex, inner = inner, + style = style, minarea = minarea, maxarea = maxarea, + mincnt = mincnt, maxcnt = maxcnt, + trans = trans, inv = inv, colorcut = colorcut, + density = density, border = border, pen = pen, + colramp = colramp) + popViewport() + } + } + + invisible(list(plot.vp = hv.ob, legend.vp = if(legend) legVp)) +} ## gplot.hexbin() + +setMethod("plot", signature(x = "hexbin", y = "missing"), gplot.hexbin) + +setMethod("show", "hexbin", + function(object) { + cat("'hexbin' object from call:", deparse(object@call), "\n") + dm <- object@dimen + cat("n =", object@n, " points in nc =", object@ncells, + " hexagon cells in grid dimensions ", dm[1], "by", dm[2],"\n") + invisible(object) + }) + +setMethod("summary", "hexbin", + function(object, ...) { + show(object, ...) + print(summary(data.frame(cell = object@cell, count = object@count, + xcm = object@xcm, ycm = object@ycm), + ...)) + if(!is.null(object@cID)) { + cat("IDs: "); str(object@cID) + } + }) + + + +if(FALSE) { ##-- todo -- +#setMethod("identify" +identify.hexbin <- function(x, labels = x$cnt, offset = 0, ...) +{ + if(length(labels) != x$n) + stop("labels not the same length as number of cells") + ##NL: Should this be a warning? + + ## -> typically default method: + identify(hcell2xy(x), labels = labels, offset = offset, ...) +} +}#not yet diff --git a/R/hexbinList.R b/R/hexbinList.R new file mode 100644 index 0000000..7938ab6 --- /dev/null +++ b/R/hexbinList.R @@ -0,0 +1,106 @@ +hexList <- function(x,y=NULL,given=NULL,xbins=30,shape=1, + xbnds = NULL, ybnds = NULL, + xlab = NULL, ylab = NULL) +{ + xl <- if (!missing(x)) deparse(substitute(x)) + yl <- if (!missing(y)) deparse(substitute(y)) + xy <- xy.coords(x, y, xl, yl) + if(length(given)!=length(xy$x) | is.null(given)) + stop("Given is is different length from x and y") + if(is.factor(given)) + given <- as.character(given) + clss <- unique(given) + if(is.null(xbnds)) + xbnds <- range(xy$x) + if(is.null(ybnds)) + ybnds <- range(xy$y) + hbins <- vector(mode = "list",length=length(clss)) + i <- 1 + for(g in clss){ + hbins[[i]] <- hexbin(xy$x[given==g],xy$y[given==g], + xbins=xbins,shape=shape,xbnds=xbnds,ybnds=ybnds) + i <- i+1 + } + mx <- max(unlist(lapply(hbins,function(h)max(h@count)))) + mn <- min(unlist(lapply(hbins,function(h)min(h@count)))) + hl <- new("hexbinList",n=length(hbins),hbins=hbins, Xbnds=xbnds, + Ybnds=ybnds, Xbins=integer(xbins), Shape=shape, Bnames=clss, + CntBnds=c(mn,mx)) + hl +} + + +setClass("hexbinList", + representation(n="integer", hbins="vector", + Xbnds="numeric", Ybnds="numeric", + Xbins="numeric", Shape="numeric", + Bnames="character", CntBnds="numeric") + + ) + + +bnds.check <- function(binlst, xb = TRUE, yb = TRUE) +{ + xb <- + if(xb) { + b <- binlst[[1]]@xbnds + all(unlist(lapply(binlst, function(x, bnd) all(x@xbnds == bnd), b))) + } else TRUE + yb <- + if(yb) { + b <- binlst[[1]]@ybnds + all(unlist(lapply(binlst, function(y, bnd) all(y@ybnds == bnd), b))) + } else TRUE + xb & yb +} + +xbins.check <- function(binlst) +{ + xb <- binlst[[1]]@xbins + all(unlist(lapply(binlst, function(y, xbin)all(y@xbins == xbin), xb))) +} + +shape.check <- function(binlst) +{ + xs <- binlst[[1]]@shape + all(unlist(lapply(binlst, function(y, xsh)all(y@shape == xsh), xs))) +} + +list2hexList <- function(binlst) +{ + if(length(binlst) < 2) + stop(" need at least 2 hex bin objects") + if(!all(unlist(lapply(binlst, is, "hexbin")))) + stop("All Elements of list must be hexbin objects") + if(!bnds.check(binlst)) + stop("All bin objects in list need the same xbnds and ybnds") + if(!xbins.check(binlst)) + stop("All bin objects in list need the same number of bins") + if(!shape.check(binlst)) + stop("All bin objects in list need the same shape parameter") + mx <- max(unlist(lapply(binlst,function(h)max(h@count)))) + mn <- min(unlist(lapply(binlst,function(h)min(h@count)))) + xbins <- binlst[[1]]@xbins + xbnds <- binlst[[1]]@xbnds + ybnds <- binlst[[1]]@ybnds + shape <- binlst[[1]]@shape + hl <- new("hexbinList",n=length(binlst),hbins=binlst, Xbnds=xbnds, + Ybnds=ybnds, Xbins=xbins, Shape=shape, + Bnames=names(binlst), CntBnds=c(mn,mx)) + hl +} + +setAs("list","hexbinList",function(from)list2hexList(from)) + +#setMethod("[", "hexbinList", function(hbl,i,...) +#{ +# if( length(list(...)) > 0 ) +# stop("extra subscripts cannot be handled") +# if(missing(i)) hbl +# hbl@hbins[i] +#}) + +##setMethod("[[", "hexbinList", function(hbl) +##{ + +##}) diff --git a/R/hexbinplot.R b/R/hexbinplot.R new file mode 100644 index 0000000..4df675f --- /dev/null +++ b/R/hexbinplot.R @@ -0,0 +1,777 @@ +## lattice version of gplot.hexbin + +## There are two major problems. (1) For comparability across panels, +## we want the same mincnt and maxcnt in all panels. However, a +## suitable default can really only be determined at printing time, +## since it would depend on the physical dimensions of the panel. (2) +## there is no proper way to communicate the mincnt and maxcnt to the +## legend. + +## Tentative solution: the counts can be calculated once enough things +## are known, namely the aspect ratio, xbins and [xy]bnds. An +## important question then is whether [xy]bnds should be [xy]lim or +## range([xy]). Both should be allowed, since [xy]lim makes them +## comparable, range([xy]) potentially shows more detail. For +## relation != "same", both are more or less similar. An important +## observation is that with range([xy]), 'shape = aspect ratio of +## panel' does not guarantee symmetric hexagons, so shape has to be +## different for each panel. + +## Only feasible approach I can think of is to produce the trellis +## object first (with known aspect, so aspect="fill" is absolutely +## no-no), then analyze the limits and relevant panel arguments to get +## 'maxcnt' (essentially doing a dry run of the panel calculations). +## This needs undocumented knowledge of the trellis object, which is +## kinda not good, but at least it gets the job done. Once we know +## maxcnt, we can also set up a suitable legend function. + +## Unfortunately, this has the potential to screw up update calls that +## modify certain things. Is there any way to capture those? Maybe +## make a new class that inherits from "trellis". For now, we'll +## pretend that the problem doesn't exist. + + +## tool borrowed from lattice +updateList <- function (x, val) +{ + if (is.null(x)) x <- list() + modifyList(x, val) +} + + +prepanel.hexbinplot <- + function(x, y, type = character(0),...) +{ + if('tmd'%in%type){ + tmp <- x + x <- (y + x)/sqrt(2) + y <- (y - tmp)/sqrt(2) + } + ans <- + list(xlim = range(x, finite = TRUE), + ylim = range(y, finite = TRUE), + dx = IQR(x,na.rm=TRUE), + dy = IQR(y,na.rm=TRUE)) +} + + +panel.hexbinplot <- + function(x, y, ..., groups = NULL) +{ + if (is.null(groups)) panel.hexbin(x, y, ...) + else panel.hexpose(x, y, ..., groups = groups) +} + + +panel.hexbin <- + function(x, y, + xbins = 30, + xbnds = c("data", "panel"), # was: xbnds = c("panel", "data"), + ybnds = c("data", "panel"), # was: ybnds = c("panel", "data"), + + ## special args + .prelim = FALSE, + .cpl = current.panel.limits(), + .xlim = .cpl$xlim, + .ylim = .cpl$ylim, + .aspect.ratio = 1, # default useful with splom(, panel = panel.hexbin) + + type = character(0), + ..., + check.erosion = FALSE) +{ + if ("tmd" %in% type) { + tmp <- x + x <- (y + x)/sqrt(2) + y <- (y - tmp)/sqrt(2) + } + if (is.character(xbnds)) + xbnds <- + switch(match.arg(xbnds), + panel = .xlim, + data = range(x, finite = TRUE)) + if (is.character(ybnds)) + ybnds <- + switch(match.arg(ybnds), + panel = .ylim, + data = range(y, finite = TRUE)) + shape <- + .aspect.ratio * (diff(ybnds) / diff(.ylim)) / + (diff(xbnds) / diff(.xlim)) + if (!missing(check.erosion)) + warning("explicit 'check.erosion' specification ignored") + h <- hexbin(x = x, y = y, + xbins = xbins, shape = shape, + xbnds = xbnds, ybnds = ybnds) + if (.prelim) + return(max(h@count)) + + ## have to do this because grid.hexagons croaks with unrecognized + ## arguments: + args <- list(dat = h, check.erosion = FALSE, ...) + keep <- names(args) %in% names(formals(grid.hexagons)) + + if ('g' %in% type) panel.grid(h = -1, v = -1) + if ('hg' %in% type) panel.hexgrid(h) + + do.call("grid.hexagons", args[keep]) + + if ("r" %in% type) panel.lmline(x, y, ...) + if ("smooth" %in% type) panel.hexloess(h,...) + invisible() +} + +panel.hexboxplot <- + function(x, y, + xbins = 30, + xbnds = c("data", "panel"), # was: xbnds = c("panel", "data"), + ybnds = c("data", "panel"), # was: ybnds = c("panel", "data"), + + ## special args + .prelim = FALSE, + .cpl = current.panel.limits(), + .xlim = .cpl$xlim, + .ylim = .cpl$ylim, + .aspect.ratio = 1, + + type = character(0), + cdfcut=.25, + shadow=.05, + ..., + check.erosion = TRUE) +{ + if (is.character(xbnds)) + xbnds <- + switch(match.arg(xbnds), + panel = .xlim, + data = range(x, finite = TRUE)) + if (is.character(ybnds)) + ybnds <- + switch(match.arg(ybnds), + panel = .ylim, + data = range(y, finite = TRUE)) + shape <- + .aspect.ratio * (diff(ybnds) / diff(.ylim)) / + (diff(xbnds) / diff(.xlim)) + if (!missing(check.erosion)) + warning("explicit 'check.erosion' specification ignored") + h <-hexbin(x = x, y = y, + xbins = xbins, shape = shape, + xbnds = xbnds, ybnds = ybnds,IDs=TRUE) + + if (.prelim) + return(max(h@count)) + + ## have to do this because grid.hexagons croaks with unrecognized + ## arguments: + args <- list(dat = h, check.erosion = FALSE, ...) + keep <- names(args) %in% names(formals(grid.hexagons)) + if ('hg' %in% type) panel.hexgrid(h) + if ('g' %in% type) panel.grid(h = -1, v = -1) + if(shadow) { + eh <- erode(h,cdfcut=shadow) + h.xy <- hcell2xy(eh,check.erosion=TRUE) + dx <- (0.5 * diff(eh@xbnds))/eh@xbins + dy <- (0.5 * diff(eh@ybnds))/(eh@xbins * h@shape * sqrt(3)) + hexC <- hexcoords(dx, dy, sep = NULL) + hexpolygon(h.xy$x,h.xy$y, hexC, density = density, + fill = NA, border = gray(.75)) + } + eh <- erode(h,cdfcut=cdfcut) + h.xy <- hcell2xy(eh,check.erosion=TRUE) + dx <- (0.5 * diff(eh@xbnds))/eh@xbins + dy <- (0.5 * diff(eh@ybnds))/(eh@xbins * h@shape * sqrt(3)) + hexC <- hexcoords(dx, dy, sep = NULL) + hexpolygon(h.xy$x,h.xy$y, hexC, density = density, + fill = "green", border = gray(.75)) + med <- which.max(eh@erode) + xnew <- h.xy$x[med] + ynew <- h.xy$y[med] + hexpolygon(xnew, ynew, hexC, density = density, + fill = "red", border =gray(.25)) + invisible() +} + +panel.hexpose <- + function(x, y, groups, subscripts, + xbins = 30, + xbnds = c("data", "panel"), # was: xbnds = c("panel", "data"), + ybnds = c("data", "panel"), # was: ybnds = c("panel", "data"), + + ## special args + .prelim = FALSE, + .cpl = current.panel.limits(), + .xlim = .cpl$xlim, + .ylim = .cpl$ylim, + .aspect.ratio = 1, + #erode Args + cdfcut=.05, + #hdiff Args + hexpose.focus=c(1,2), + hexpose.focus.colors=c("yellow","blue"), + hexpose.focus.border=c("cyan","orange"), + hexpose.median.color="red", + hexpose.median.border="black", + arrows = TRUE, + size = unit(0.1, "inches"), + arrow.lwd = 2, + eps = 1e-6, + type = character(0), + ..., + check.erosion = TRUE) +{ + if (is.character(xbnds)) + xbnds <- + switch(match.arg(xbnds), + panel = .xlim, + data = range(x, finite = TRUE)) + if (is.character(ybnds)) + ybnds <- + switch(match.arg(ybnds), + panel = .ylim, + data = range(y, finite = TRUE)) + shape <- + .aspect.ratio * (diff(ybnds) / diff(.ylim)) / + (diff(xbnds) / diff(.xlim)) + if (is.numeric(groups)) groups <- as.character(groups[subscripts]) + else groups <- groups[subscripts] + binL <- hexList(x, y, given=groups, xbins=xbins, shape=shape, + xbnds=xbnds, ybnds=ybnds) + if ('hs' %in% type) lapply(binL@hbins,smooth.hexbin) + binL@hbins <- lapply(binL@hbins,erode,cdfcut=cdfcut) + if ('hg' %in% type) panel.hexgrid(binL@hbins[[1]]) ## ??? + if ('g' %in% type) panel.grid(h = -1, v = -1) + eroded <- unlist(lapply(binL@hbins, is, "erodebin")) + tmph.xy <- lapply(binL@hbins, hcell2xy, check.erosion = TRUE) + + ##__________________ Construct hexagon___________________ + dx <- (0.5 * diff(binL@Xbnds))/xbins + dy <- (0.5 * diff(binL@Ybnds))/(xbins * binL@Shape * sqrt(3)) + hexC <- hexcoords(dx = dx, dy = dy) + + ##__________________ Set up intersections and colors___________________ + ## Reorder so that the focus bin objects are at the top of the list + if(length(hexpose.focus) < binL@n) { + binL@hbins <- c(binL@hbins[hexpose.focus], binL@hbins[-hexpose.focus]) + binL@Bnames <- c(binL@Bnames[hexpose.focus], binL@Bnames[-hexpose.focus]) + } + cell.stat <- all.intersect(binL@hbins) + cell.stat.n <- apply(cell.stat, 1, sum) + i.depth <- max(cell.stat.n) + + diff.cols <- vector(mode = "list", length = i.depth) + levcells <- which(cell.stat.n == 1) + whichbin <- apply(cell.stat[levcells, ], 1, which) + ## Set all the focal colors for the unique bin cells + ## if not specified make them equally spaced on the color wheel + ## with high saturation and set the background bins to gray + nfcol <- length(hexpose.focus) + nhb <- binL@n + nbcol <- nhb-nfcol + fills <- + if(is.null(hexpose.focus.colors)) { + if(nbcol > 0) + hsv(h = c(seq(0, 1, length = nfcol+1)[1:nfcol],rep(0, nbcol)), + s = c(rep(1, nfcol), rep(0, nbcol)), + ## V = c(rep(1, nfcol), seq(.9, .1, length=nbcol)) + v = c(rep(1, nfcol), rep(.9, nbcol))) + else hsv(h=seq(0, 1, length = nhb+1))[1:nfcol] + } + else { + foc.col <- t(col2rgb(hexpose.focus.colors))/255 + if(nbcol > 0) { + bcol <- t(col2rgb(rep(grey(.6),nbcol)))/255 + rbind(foc.col, bcol) + } + else foc.col + } + diff.cols[[1]] <- list(fill = fills, border = gray(.8)) + + ##_______________ Full Cell Plotting for Unique BinL Cells_________________ + + if(length(levcells) > 0) { + for(i in unique(whichbin)) { + pcells <- + if(eroded[i]) + binL@hbins[[i]]@cell[binL@hbins[[i]]@eroded] + else binL@hbins[[i]]@cell + pcells <- which(pcells %in% levcells[whichbin == i]) + + hexpolygon(x = tmph.xy[[i]]$x[pcells], + y = tmph.xy[[i]]$y[pcells], hexC, + border = hexpose.focus.border[i] , + fill = hexpose.focus.colors[i] ) + } + } + + ## Now do the intersections. All intersections are convex + ## combinations of the colors of the overlapping unique bins in + ## the CIEluv colorspace. so if the binlist is of length 2 and + ## the focal hbins are "blue" and "yellow" respectively the + ## intersection would be green. First I need to get this to work + ## and then I can think about how to override this with an option + ## in color.control. -NL + + if(i.depth > 1) { + for(dl in 2:(i.depth)) { + levcells <- which(cell.stat.n == dl) + if(length(levcells) == 0) next + + whichbin <- apply(cell.stat[levcells, ], 1, + function(x)paste(which(x), sep = "", collapse = ":")) + inter.nm <- unique(whichbin) + fills <- matrix(0, length(inter.nm), 3) + i <- 1 + for(bn in inter.nm) { + who <- as.integer(unlist(strsplit(bn, ":"))) + ## FIXME (DS): this doesn't work + fills[i, ] <- mixcolors2(1/length(who), + diff.cols[[1]]$fill[who,]) + i <- i+1 + } + fills <- rgb(fills[,1],fills[,2],fills[,3]) + diff.cols[[dl]] <- list(fill = fills, + border = gray((i.depth-dl)/i.depth)) + ##____Full Cell Plotting for Intersecting Cells at Intersection Depth i____ + i <- 1 + for(ints in inter.nm) { + bin.i <- as.integer(unlist(strsplit(ints, ":"))[1]) + pcells <- + if(eroded[bin.i]) + binL@hbins[[bin.i]]@cell[binL@hbins[[bin.i]]@eroded] + else binL@hbins[[bin.i]]@cell + pcells <- which(pcells %in% levcells[whichbin == ints]) + hexpolygon(x = tmph.xy[[bin.i]]$x[pcells], + y = tmph.xy[[bin.i]]$y[pcells], hexC, + border = diff.cols[[dl]]$border , + fill = diff.cols[[dl]]$fill[i] ) + i <- i+1 + } + } + } + + if(any(eroded)) { + hmeds <- matrix(unlist(lapply(binL@hbins[eroded], + function(x)unlist(getHMedian(x)))), + nc = 2, byrow = TRUE) + hexpolygon(x = hmeds[, 1], y = hmeds[, 2], hexC, + border = hexpose.median.border, + fill = hexpose.median.color) + if(arrows) { + for(i in hexpose.focus) { + for(j in hexpose.focus[hexpose.focus < i]) { + if(abs(hmeds[i, 1] - hmeds[j, 1]) + + abs(hmeds[i, 2] - hmeds[j, 2]) > eps) + grid.arrows(c(hmeds[i, 1], hmeds[j, 1]), + c(hmeds[i, 2], hmeds[j, 2]), + default.units = "native", + length = size, gp = gpar(lwd = arrow.lwd)) + } + } + } + } + invisible() +} + + +hexbinplot <- function(x, data, ...) UseMethod("hexbinplot") + + +hexbinplot.formula <- + function(x, data = NULL, + prepanel = prepanel.hexbinplot, + panel = panel.hexbinplot, + groups = NULL, + aspect = "xy", + trans = NULL, + inv = NULL, + colorkey = TRUE, + ..., + maxcnt, + legend = NULL, + legend.width = TRUE, + subset = TRUE) +{ + ocall <- sys.call(sys.parent()) + ocall[[1]] <- quote(hexbinplot) + ccall <- match.call() + if (is.logical(legend.width)) legend.width <- 1.2 * as.numeric(legend.width) + if (is.character(aspect) && aspect == "fill") + stop("aspect = 'fill' not permitted") + if (!is.null(trans) && is.null(inv)) + stop("Must supply the inverse transformation 'inv'") + ccall$data <- data + ccall$prepanel <- prepanel + ccall$panel <- panel + ccall$aspect <- aspect + ccall$trans <- trans + ccall$inv <- inv + ccall$legend <- legend + ccall[[1]] <- quote(lattice::xyplot) + ans <- eval(ccall, parent.frame()) + + ## panel needs to know aspect ratio to calculate shape + ans <- update(ans, .aspect.ratio = ans$aspect.ratio) + + ## also need maxcnt, o.w. can't draw legend, panels not comparable + ## either + if (missing(maxcnt)) + maxcnt <- + max(mapply(panel.hexbinplot, ## note: not 'panel' + x = lapply(ans$panel.args, "[[", "x"), + y = lapply(ans$panel.args, "[[", "y"), + .xlim = + if (is.list(ans$x.limits)) ans$x.limits + else rep(list(ans$x.limits), length(ans$panel.args)), + .ylim = + if (is.list(ans$y.limits)) ans$y.limits + else rep(list(ans$y.limits), length(ans$panel.args)), + MoreArgs = + c(ans$panel.args.common, + list(.prelim = TRUE, .cpl = NA)))) + ans <- update(ans, maxcnt = maxcnt) + if (colorkey) + ans <- + update(ans, + legend = updateList(ans$legend, + list(right = + list(fun = hexlegendGrob, + args = + list(maxcnt = maxcnt, + trans = trans, + inv = inv, + legend = legend.width, + ...))))) + ans$call <- ocall + ans +} + + + +old.hexbinplot.formula <- + function(x, data = parent.frame(), + prepanel = prepanel.hexbinplot, + panel = if (is.null(groups)) panel.hexbinplot + else panel.hexpose, + groups=NULL, + aspect = "xy", + trans = NULL, + inv = NULL, + colorkey = TRUE, + ..., + maxcnt, + legend = NULL, + legend.width = TRUE) +{ + if (is.logical(legend.width)) + legend.width <- 1.2 * as.numeric(legend.width) + if (is.character(aspect) && aspect == "fill") + stop("aspect = 'fill' not permitted") + if (!is.null(trans) && is.null(inv)) + stop("Must supply the inverse transformation 'inv'") + groups <- eval(substitute(groups), data, parent.frame()) + ## There must be a better way to handle this, ugh. + ans <- + if(is.null(groups)) + { + xyplot(x, data = data, + prepanel = prepanel, + panel = panel, + aspect = aspect, + trans = trans, + inv = inv, + legend = legend, + ...) + } + else + { + xyplot(x, data = data, + prepanel = prepanel, + panel = panel, + groups=groups, + aspect = aspect, + trans = trans, + inv = inv, + legend = legend, + ...) + } + ## panel needs to know aspect ratio to calculate shape + ans <- update(ans, .aspect.ratio = ans$aspect.ratio) + + ## also need maxcnt, o.w. can't draw legend, panels not comparable + ## either + if (missing(maxcnt)) + maxcnt <- + max(mapply(panel.hexbinplot, ## note: not 'panel' + x = lapply(ans$panel.args, "[[", "x"), + y = lapply(ans$panel.args, "[[", "y"), + .xlim = + if (is.list(ans$x.limits)) ans$x.limits + else rep(list(ans$x.limits), length(ans$panel.args)), + .ylim = + if (is.list(ans$y.limits)) ans$y.limits + else rep(list(ans$y.limits), length(ans$panel.args)), + MoreArgs = + c(ans$panel.args.common, + list(.prelim = TRUE, .cpl = NA)))) + ans <- update(ans, maxcnt = maxcnt) + if (colorkey) + ans <- + update(ans, + legend = updateList(ans$legend, + list(right = + list(fun = hexlegendGrob, + args = + list(maxcnt = maxcnt, + trans = trans, + inv = inv, + legend = legend.width, + ...))))) + ans +} + + +## want a grob instead of actual plotting + +hexlegendGrob <- + function(legend = 1.2, + inner = legend / 5, + cex.labels = 1, + cex.title = 1.2, + style = "colorscale", + minarea = 0.05, maxarea = 0.8, + mincnt = 1, maxcnt, + trans = NULL, inv = NULL, + colorcut = seq(0, 1, length = 17), + density = NULL, border = NULL, pen = NULL, + colramp = function(n) { LinGray(n,beg = 90,end = 15) }, + ..., + vp = NULL, + draw = FALSE) +{ + ## the formal arg matching should happen + style <- match.arg(style, eval(formals(grid.hexagons)[["style"]])) + if (style %in% c("centroids", "lattice", "colorscale")) { + ## _______________tranformations_______________________ + if(is.null(trans)) + { + sc <- maxcnt - mincnt + bnds <- round(mincnt + sc * colorcut) + } + else + { + if(!is.function(trans) && !is.function(inv)) + stop("'trans' and 'inv' must both be functions if 'trans' is not NULL") + con <- trans(mincnt) + sc <- trans(maxcnt) - con + bnds <- round(inv(con + sc * colorcut)) + } + } + + ## grob + ans <- + switch(style, + "colorscale" = { + + n <- length(bnds) + pen <- colramp(n-1) + + ## rectangles instead of polygons + ## pol <- + ## rectGrob(x = 0.5, y = 1:(n-1)/n, + ## height = 1/n, + ## default.units = "npc", + ## gp = gpar(fill = pen, col = border)) + + hexxy <- hexcoords(dx = 1, n = 1)[c("x", "y")] + maxxy <- max(abs(unlist(hexxy))) + hexxy <- lapply(hexxy, function(x) 0.5 * x/ maxxy) + + pol <- + polygonGrob(x = 0.5 + rep(hexxy$x, n-1), + y = (rep(1:(n-1), each = 6) + hexxy$y) / n, + id.lengths = rep(6, n-1), + gp = gpar(fill = pen, col = border), + default.units = "npc") + txt <- + textGrob(as.character(bnds), + x = 0.5, + y = (0:(n-1) + 0.5) / n, + gp = gpar(cex = cex.labels), + default.units = "npc") + ttl <- textGrob("Counts", gp = gpar(cex = cex.title)) + + key.layout <- + grid.layout(nrow = 2, ncol = 2, + heights = + unit(c(1.5, 1), + c("grobheight", "grobheight"), + data = list(ttl, txt)), + widths = + unit(c(1/n, 1), + c("grobheight", "grobwidth"), + data = list(pol, txt)), + respect = TRUE) + key.gf <- frameGrob(layout = key.layout, vp = vp) + key.gf <- placeGrob(key.gf, ttl, row = 1, col = 1:2) + key.gf <- placeGrob(key.gf, pol, row = 2, col = 1) + key.gf <- placeGrob(key.gf, txt, row = 2, col = 2) + key.gf + }, + "centroids" = , + "lattice" = { + warning("legend shows relative sizes") + + ## Note: it may not be impossible to get absolute + ## sizes. The bigger problem is that when + ## [xy]bnds="data", the sizes (for the same count) may + ## not be the same across panels. IMO, that's a more + ## useful feature than getting the absolute sizes + ## right. + + radius <- sqrt(minarea + (maxarea - minarea) * colorcut) + n <- length(radius) + if(is.null(pen)) pen <- 1 + if(is.null(border)) border <- pen + + hexxy <- hexcoords(dx = 1, n = 1)[c("x", "y")] + maxxy <- max(abs(unlist(hexxy))) + hexxy <- lapply(hexxy, function(x) 0.5 * x/ maxxy) + + pol <- + polygonGrob(x = 0.5 + rep(radius, each = 6) * rep(hexxy$x, n), + y = (rep(0.5 + 1:n, each = 6) + + rep(radius, each = 6) * hexxy$y - 1) / n, + id.lengths = rep(6, n), + gp = gpar(fill = pen, col = border), + default.units = "npc") + txt <- + textGrob(as.character(bnds), + x = 0.5, + y = (1:n - 0.5) / n, + gp = gpar(cex = cex.labels), + default.units = "npc") + ttl <- textGrob("Counts", gp = gpar(cex = cex.title)) + + key.layout <- + grid.layout(nrow = 2, ncol = 2, + heights = + unit(c(1.5, 1), + c("grobheight", "grobheight"), + data = list(ttl, txt)), + widths = + unit(c(1/n, 1), + c("grobheight", "grobwidth"), + data = list(pol, txt)), + respect = TRUE) + key.gf <- frameGrob(layout = key.layout, vp = vp) + + key.gf <- placeGrob(key.gf, ttl, row = 1, col = 1:2) + key.gf <- placeGrob(key.gf, pol, row = 2, col = 1) + key.gf <- placeGrob(key.gf, txt, row = 2, col = 2) + key.gf + }, + "nested.lattice" = , + "nested.centroids" = { + dx <- inner/2 + dy <- dx/sqrt(3) + hexC <- hexcoords(dx, dy, n = 1, sep = NULL) + + ## _____________x scaling_____________________________ + numb <- cut(floor(legend/inner), breaks = c(-1, 0, 2,4)) + ## Note: In old code + ## top breaks=c(-1,0,2,4,8), numb<- 5 and size=1:9 + if (is.na(numb)) numb <- 4 + switch(numb, + { + warning("not enough space for legend") + return(textGrob("")) + }, + size <- 5, + size <- c(1, 5, 9), + size <- c(1, 3, 5, 7, 9)) + xmax <- length(size) + radius <- sqrt(minarea + (maxarea - minarea) * (size - 1)/9) + txt <- as.character(size) + ##___________________y scaling_____________________ + lab <- c("Ones", "Tens", "Hundreds", + "Thousands", "10 Thousands", "100 Thousands", + "Millions", "10 Millions", + "100 Millions", "Billions") + power <- floor(log10(maxcnt)) + 1 + yinc <- 16 * dy + ysize <- yinc * power + xmid <- 0 + x <- inner * (1:xmax - (1 + xmax)/2) + xmid + n <- length(x) + tx <- rep.int(hexC$x, n) + ty <- rep.int(hexC$y, n) + six <- rep.int(6:6, n) + ## y <- rep.int(3 * dy - yinc, xmax) + y <- rep.int(3 * dy - 0.75 * yinc, xmax) + + if (is.null(pen)) { + pen <- 1:power +1 + pen <- cbind(pen, pen +10) + } + if (is.null(border)) border <- TRUE + + key.layout <- + grid.layout(nrow = 1, ncol = 1, + heights = unit(ysize, "inches"), + widths = unit(legend, "inches"), + respect = TRUE) + key.gf <- frameGrob(layout = key.layout, vp = vp) + + ## for debugging + ## key.gf <- + ## placeGrob(key.gf, rectGrob(gp = gpar(fill = "transparent"))) + + n6 <- rep.int(6, n) + for(i in 1:power) { + y <- y + yinc + key.gf <- + placeGrob(key.gf, + polygonGrob(x = unit(legend / 2 + rep.int(hexC$x, n) + rep.int(x, n6), "inches"), + y = unit(rep.int(hexC$y, n) + rep.int(y, n6), "inches"), + id.lengths = n6, + gp = + gpar(col = pen[i, 1], + fill = if (border) 1 else pen[i, 1])), + row = 1, col = 1) + + key.gf <- + placeGrob(key.gf, + polygonGrob(x = legend / 2 + tx * rep.int(radius, six) + rep.int(x, six), + y = ty * rep.int(radius, six) + rep.int(y, six), + default.units = "inches", id=NULL, + id.lengths=rep(6,n), + gp = gpar(fill = pen[i,2], col = border)), + row = 1, col = 1) + + key.gf <- + placeGrob(key.gf, + textGrob(txt, + x = legend / 2 + x, + y = y - 4.5 * dy, + default.units = "inches", + gp = gpar(cex = cex.labels)), + row = 1, col = 1) + key.gf <- + placeGrob(key.gf, + textGrob(lab[i], + x = legend / 2 + xmid, + y = y[1] + 4.5 * dy, + default.units = "inches", + gp = gpar(cex = 1.3 * cex.title)), + row = 1, col = 1) + } + key.gf + }) + if (draw) + { + grid.draw(ans) + invisible(ans) + } + else ans +} diff --git a/R/hexpanel.R b/R/hexpanel.R new file mode 100644 index 0000000..e70f756 --- /dev/null +++ b/R/hexpanel.R @@ -0,0 +1,34 @@ +panel.hexloess <- +function(bin, w=NULL, span = 2/3, degree = 1, family = c("symmetric", + "gaussian"), evaluation = 50, lwd = add.line$lwd, lty = add.line$lty, + col, col.line = add.line$col, ...) +{ + x <- bin@xcm + y <- bin@ycm + if(is.null(w))w <- bin@count + control <- loess.control(...) + notna <- !(is.na(x) | is.na(y)) + new.x <- seq(min(x[notna]), max(x[notna]), length = evaluation) + family <- match.arg(family) + iterations <- if (family == "gaussian") 1 else control$iterations + fit <- stats:::simpleLoess(y, x, w, span, degree, FALSE, FALSE, + normalize = FALSE, "none", "interpolate", + control$cell, iterations, control$trace.hat) + kd <- fit$kd + z <- .C("loess_ifit", as.integer(kd$parameter), as.integer(kd$a), + as.double(kd$xi), as.double(kd$vert), as.double(kd$vval), + as.integer(evaluation), as.double(x), fit = double(evaluation), + PACKAGE = "stats")$fit + if (length(x) > 0) { + if (!missing(col) && missing(col.line)) { + col.line <- col + } + add.line <- trellis.par.get("add.line") + panel.lines(new.x, z, col = col.line, lty = lty, lwd = lwd) + } +} + +panel.hexgrid <- function(h, border=grey(.85)) +{ + hexGraphPaper(h,border=border) +} diff --git a/R/hexplom.R b/R/hexplom.R new file mode 100644 index 0000000..d242107 --- /dev/null +++ b/R/hexplom.R @@ -0,0 +1,348 @@ +panel.hexplom <- + function(...) + panel.hexbinplot(...) + + +hexplom <- function(x, data, ...) +{ + UseMethod("hexplom") +} + + + + + +hexplom.data.frame <- + function (x, data = NULL, ..., groups = NULL, subset = TRUE) +{ + ocall <- sys.call(sys.parent()) + ocall[[1]] <- quote(hexplom) + ccall <- match.call() + if (!is.null(ccall$data)) + warning("explicit 'data' specification ignored") + ccall$data <- list(x = x, groups = groups, subset = subset) + ccall$x <- ~x + ccall$groups <- groups + ccall$subset <- subset + ccall[[1]] <- quote(hexbin::hexplom) + ans <- eval.parent(ccall) + ans$call <- ocall + ans +} + +hexplom.matrix <- + function (x, data = NULL, ..., groups = NULL, subset = TRUE) +{ + ocall <- sys.call(sys.parent()) + ocall[[1]] <- quote(hexplom) + ccall <- match.call() + if (!is.null(ccall$data)) + warning("explicit 'data' specification ignored") + ccall$data <- list(x = x, groups = groups, subset = subset) + ccall$x <- ~x + ccall$groups <- groups + ccall$subset <- subset + ccall[[1]] <- quote(hexbin::hexplom) + ans <- eval.parent(ccall) + ans$call <- ocall + ans +} + + +hexplom.formula <- + function(x, data = NULL, ...) +{ + ocall <- sys.call(sys.parent()) + ocall[[1]] <- quote(hexplom) + ccall <- match.call() + ccall[[1]] <- quote(lattice::splom) + if (is.null(ccall$panel)) ccall$panel <- panel.hexplom + ans <- eval.parent(ccall) + ans$call <- ocall + ans +} + + + + +old.hexplom.formula <- + function(x, + data = parent.frame(), + auto.key = FALSE, + aspect = 1, + between = list(x = 0.5, y = 0.5), + #panel = if (is.null(groups)) "panel.hexplom" + #else "panel.superpose", + panel = panel.hexplom, + prepanel = NULL, + scales = list(), + strip = TRUE, + groups = NULL, + xlab = "Scatter Plot Matrix", + xlim, + ylab = NULL, + ylim, + superpanel = "panel.pairs", + pscales = 5, + varnames, + drop.unused.levels = lattice.getOption("drop.unused.levels"), + ..., + default.scales = list(draw = FALSE, relation = "same", axs = "i"), + subset = TRUE) +{ + ## dots <- eval(substitute(list(...)), data, parent.frame()) + dots <- list(...) + + #groups <- eval(substitute(groups), data, parent.frame()) + if(!is.null(groups))stop("groups not implemented yet") + subset <- eval(substitute(subset), data, parent.frame()) + + ## Step 1: Evaluate x, y, etc. and do some preprocessing + + ## right.name <- deparse(substitute(formula)) + ## formula <- eval(substitute(formula), data, parent.frame()) + form <- + ## if (inherits(formula, "formula")) + latticeParseFormula(x, data, + subset = subset, groups = groups, + multiple = FALSE, + outer = FALSE, subscripts = TRUE, + drop = drop.unused.levels) +## else { +## if (is.matrix(formula)) { +## list(left = NULL, +## right = as.data.frame(formula)[subset,], +## condition = NULL, +## left.name = "", +## right.name = right.name, +## groups = groups, +## subscr = seq(length = nrow(formula))[subset]) +## } +## else if (is.data.frame(formula)) { +## list(left = NULL, +## right = formula[subset,], +## condition = NULL, +## left.name = "", +## right.name = right.name, +## groups = groups, +## subscr = seq(length = nrow(formula))[subset]) +## } +## else stop("invalid formula") +## } + + + ## We need to be careful with subscripts here. It HAS to be there, + ## and it's to be used to index x, y, z (and not only groups, + ## unlike in xyplot etc). This means we have to subset groups as + ## well, which is about the only use for the subscripts calculated + ## in latticeParseFormula, after which subscripts is regenerated + ## as a straight sequence indexing the variables + + if (!is.null(form$groups)) groups <- form$groups[form$subscr] + subscr <- seq(length = nrow(form$right)) + + if (!is.function(panel)) panel <- eval(panel) + if (!is.function(strip)) strip <- eval(strip) + + prepanel <- + if (is.function(prepanel)) prepanel + else if (is.character(prepanel)) get(prepanel) + else eval(prepanel) + + cond <- form$condition + number.of.cond <- length(cond) + x <- as.data.frame(form$right) + + if (number.of.cond == 0) { + strip <- FALSE + cond <- list(as.factor(rep(1, nrow(x)))) + number.of.cond <- 1 + } + + if (!missing(varnames)) colnames(x) <- + eval(substitute(varnames), data, parent.frame()) + + ## create a skeleton trellis object with the + ## less complicated components: + + foo <- do.call(lattice:::trellis.skeleton, + c(list(cond = cond, + aspect = aspect, + between = between, + panel = superpanel, + strip = strip, + xlab = xlab, + ylab = ylab, + xlab.default = "Scatter Plot Matrix"), dots)) + + dots <- foo$dots # arguments not processed by trellis.skeleton + foo <- foo$foo + foo$call <- match.call() + + ## Step 2: Compute scales.common (leaving out limits for now) + + ## FIXME: It is not very clear exactly what effect scales is + ## supposed to have. Not much in Trellis (probably), but there are + ## certain components which are definitely relevant, and certain + ## others (like log) which can be used in innovative + ## ways. However, I'm postponing all that to later, if at all + + if (!is.list(scales)) scales <- list() + + ## some defaults for scales + +# if (is.null(scales$draw)) scales$draw <- FALSE +# if (is.null(scales$relation)) scales$relation <- "same" +# if (is.null(scales$axs)) scales$axs <- "i" + + scales <- updateList(default.scales, scales) + foo <- c(foo, + do.call(lattice:::construct.scales, scales)) + + + ## Step 3: Decide if limits were specified in call: + + have.xlim <- !missing(xlim) + if (!is.null(foo$x.scales$limit)) { + have.xlim <- TRUE + xlim <- foo$x.scales$limit + } + have.ylim <- !missing(ylim) + if (!is.null(foo$y.scales$limit)) { + have.ylim <- TRUE + ylim <- foo$y.scales$limit + } + + ## Step 4: Decide if log scales are being used (has to be NO): + + have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log + have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log + + ## immaterial, since scales has no effect. + +# if (have.xlog) { +# xlog <- foo$x.scales$log +# xbase <- +# if (is.logical(xlog)) 10 +# else if (is.numeric(xlog)) xlog +# else if (xlog == "e") exp(1) +# +# x <- log(x, xbase) +# if (have.xlim) xlim <- log(xlim, xbase) +# } +# if (have.ylog) { +# ylog <- foo$y.scales$log +# ybase <- +# if (is.logical(ylog)) 10 +# else if (is.numeric(ylog)) ylog +# else if (ylog == "e") exp(1) +# +# y <- log(y, ybase) +# if (have.ylim) ylim <- log(ylim, ybase) +# } + + ## Step 5: Process cond + + cond.max.level <- unlist(lapply(cond, nlevels)) + + ## id.na used only to see if any plotting is needed. Not used + ## subsequently, unlike other functions + + id.na <- FALSE + for (j in 1:ncol(x)) + id.na <- id.na | is.na(x[,j]) + for (var in cond) + id.na <- id.na | is.na(var) + if (!any(!id.na)) stop("nothing to draw") + ## Nothing simpler ? + + + ## Step 6: Evaluate layout, panel.args.common and panel.args + + + foo$panel.args.common <- + c(list(z = x, + panel = panel, + panel.subscripts = TRUE, + groups = groups, # xscales = foo$x.scales, yscales =foo$y.scales, + .aspect.ratio=aspect, + pscales = pscales), + dots) + + nplots <- prod(cond.max.level) + if (nplots != prod(sapply(foo$condlevels, length))) stop("mismatch") + foo$panel.args <- vector(mode = "list", length = nplots) + + + cond.current.level <- rep(1, number.of.cond) + + + for (panel.number in seq(length = nplots)) + { + + ##id <- !id.na WHY ? + for(i in 1:number.of.cond) + { + var <- cond[[i]] + id <- if (is.shingle(var)) + ((var >= + levels(var)[[cond.current.level[i]]][1]) + & (var <= + levels(var)[[cond.current.level[i]]][2])) + else (as.numeric(var) == cond.current.level[i]) + } + + foo$panel.args[[panel.number]] <- + list(subscripts = subscr[id]) + + cond.current.level <- + lattice:::cupdate(cond.current.level, + cond.max.level) + } + + + more.comp <- c(lattice:::limits.and.aspect( + lattice:::prepanel.default.splom, + prepanel = prepanel, + have.xlim = have.xlim, xlim = xlim, + have.ylim = have.ylim, ylim = ylim, + x.relation = foo$x.scales$relation, + y.relation = foo$y.scales$relation, + panel.args.common = foo$panel.args.common, + panel.args = foo$panel.args, + aspect = aspect, + nplots = nplots, + x.axs = foo$x.scales$axs, + y.axs = foo$y.scales$axs), + lattice::: cond.orders(foo)) + foo[names(more.comp)] <- more.comp + + + + if (is.null(foo$legend) && !is.null(groups) && + (is.list(auto.key) || (is.logical(auto.key) && auto.key))) + { + foo$legend <- + list(list(fun = "drawSimpleKey", + args = + updateList(list(text = levels(as.factor(groups)), + points = TRUE, + rectangles = FALSE, + lines = FALSE), + if (is.list(auto.key)) auto.key else list()))) + foo$legend[[1]]$x <- foo$legend[[1]]$args$x + foo$legend[[1]]$y <- foo$legend[[1]]$args$y + foo$legend[[1]]$corner <- foo$legend[[1]]$args$corner + + names(foo$legend) <- + if (any(c("x", "y", "corner") %in% names(foo$legend[[1]]$args))) + "inside" + else + "top" + if (!is.null(foo$legend[[1]]$args$space)) + names(foo$legend) <- foo$legend[[1]]$args$space + } + + class(foo) <- "trellis" + foo +} diff --git a/R/hexutil.R b/R/hexutil.R new file mode 100644 index 0000000..a605481 --- /dev/null +++ b/R/hexutil.R @@ -0,0 +1,122 @@ +hcell2xyInt <- function(hbin, xbins=NULL, xbnds=NULL, ybnds=NULL, shape=NULL) +{ + if(missing(hbin) && (is.null(xbnds) || is.null(ybnds))) + stop("Need a hexbin object or boundaries to make lattice") + if(missing(hbin) && (is.null(xbins) || is.null(shape))) + stop("Need xbins and shape to make a lattice") + if(!missing(hbin)) { + xbins <- hbin@xbins + shape <- hbin@shape + xbnds <- if(is.null(xbnds)) hbin@xbnds else xbnds + ybnds <- if(is.null(ybnds)) hbin@ybnds else ybnds + dimen <- hbin@dimen + + } + if(missing(hbin)) { + jmax <- floor(xbins + 1.5001) + imax <- 2 * floor((xbins *shape)/sqrt(3) + 1.5001) + dimen <- c(imax, jmax) + } + cell <- 1:(dimen[1]*dimen[2])-1 + i <- cell %/% dimen[2] + j <- cell %% dimen[2] + list(i=i+1, j=j+1) +} + +hgridcent <- function(xbins, xbnds, ybnds, shape, edge.add=0) +{ + ## auxiliary for hexGraphPaper(): + jmax <- floor(xbins + 1.5001) + c1 <- 2 * floor((xbins *shape)/sqrt(3) + 1.5001) + imax <- (jmax*c1 -1)/jmax + 1 + dimen <- c(imax, jmax) + c3 <- diff(xbnds)/xbins + c4 <- (diff(ybnds) * sqrt(3))/(2 * shape * xbins) + if(edge.add > 0) { + xbnds <- xbnds + 1.5*c(-edge.add*c3, edge.add*c3) + ybnds <- ybnds + c(-edge.add*c4, edge.add*c4) + dimen <- dimen + rep.int(2*edge.add, 2) + } + jmax <- dimen[2] + cell <- 1:(dimen[1]*dimen[2]) + i <- cell %/% jmax + j <- cell %% jmax + y <- c4 * i + ybnds[1] + x <- c3 * ifelse(i %% 2 == 0, j, j + 0.5) + xbnds[1] + list(x = x, y = y, dimen = dimen, dx=c3, dy=c4) +} + +hexGraphPaper <- + function(hb, xbnds=NULL, ybnds=NULL, xbins=30, shape=1, + add=TRUE, fill.edges=1, fill=0, border=1) +{ + if(missing(hb) && (is.null(xbnds) || is.null(ybnds))) + stop("Need a hexbin object or boundaries to make lattice") + if(!missing(hb)) { + xbins <- hb@xbins + shape <- hb@shape + xbnds <- if(is.null(xbnds)) hb@xbnds else xbnds + ybnds <- if(is.null(ybnds)) hb@ybnds else ybnds + dimen <- hb@dimen + } + xy <- hgridcent(xbins, xbnds, ybnds, shape, edge.add=fill.edges) + if(add){ + sx <- xbins/diff(xbnds) + sy <- (xbins * shape)/diff(ybnds) + inner <- 0.5 + outer <- (2 * inner)/sqrt(3) + dx <- inner/sx + dy <- outer/(2 * sy) + if(add){ + hexC <- hexcoords(dx, dy, sep=NULL) + hexpolygon (xy$x, xy$y, hexC, dx, dy, + fill = fill, border = border, hUnit = "native") + } + } + invisible(xy) +} + +hexTapply <- function(hbin,dat,FUN=sum,...,simplify=TRUE) +{ + if(is.null(hbin@cID)) + stop("Must have cell ID's to do this operation \n + please re-bin data using IDs = TRUE") + if((length(dat)> 0) && (length(dat) != length(hbin@cID))) + stop("Length of IDs does not match the length of the data") + tapply(dat,hbin@cID,FUN,...,simplify=simplify) +} + +optShape <- function(vp, height=NULL, width=NULL, mar=NULL) +{ + if(missing(vp) && (is.null(height) || is.null(width))) + stop("Need a viewport object or height and width of the plotting region.") + if(!missing(vp)) { + if("hexVP" %in% class(vp)) { + height <- vp@plt[2] + width <- vp@plt[1] + } + else if("viewport"%in%class(vp)) { + #height <- convertHeight(unit(1,"npc"),"inches") + #width <- convertWidth (unit(1,"npc"),"inches") + height <- convertUnit(vp$height,"inches") + width <- convertUnit(vp$width,"inches") + } + else + stop("need valid viewport or hexViewport") + } + if(!is.null(mar)){ + height <- height - mar[1] - mar[3] + width <- width - mar[2] - mar[4] + } + + shape <- as.numeric(height)/as.numeric(width) + shape +} + +inout.hex <- function(hbin,mincnt) +{ + if(is.null(hbin@cID)) + stop("bin object must have a cID slot, \n try re-binning with ID = TRUE") + tI <- table(hbin@cID) + which(hbin@cID%in%(names(tI)[tI .Fortran("hbin", *) + +hboxplot + |--> hcell2xy() + |--> hexpolygon() + \-----\-> hexcoords() + +hcell + \--> .Fortran("hcell", *) + +hcell2xy + +hdiffplot + \--> hcell2xy(), plot(), hexpolygon(), hexcoords() + +erode.hexbin + \--> .Fortran("herode", *) + +hexagons + \--> hcell2xy(), plot(), hexpolygon(), hexcoords(), polygon() + +hex.legend + \--> hexcoords(), hexpolygon() + +hmatplot + |--> hcell2xy() + |--> hboxplot + \--> hdiffplot {2 x} + +plot.hexbin --> [ LinGraY() ] + |--> hex.legend() + |--> hexagons() + + +smooth.hexbin + \--> .Fortran("hsm" , * ) + +hray + \--> { polygon, lines } diff --git a/TODO b/TODO new file mode 100644 index 0000000..aba86e8 --- /dev/null +++ b/TODO @@ -0,0 +1,31 @@ +o The new 3D plots -- should rather make the new functions "internal" + and choosable with *arguments* from given functions ! + +o hexbin *class* {as mentioned by man/hexbin.Rd } -- done + +o find the references (on paper) and read ! + --> "References" in ./Biocore-notes + + ftp://www.galaxy.gmu.edu/pub/faculty/dcarr/eda/bin2d/ + ftp://www.galaxy.gmu.edu/pub/faculty/dcarr/software/bin2d.rev/ + + +o example(hmatplot) is still doing many pages instead of one + + +------------ +March 5, 2005 +o Implement conversions between different hexagon coordinate systems + +o Smoothing on a hexagonal basis using tensor products + + smoothing histograms + + smoothing the intensity of a Poisson process + +o Family of hex apply functions + +o Hbin list class and constructors + +--- + +o Use standard convertColor() function more and + and try to get rid of dependency on 'colorspace' diff --git a/data/NHANES.rda b/data/NHANES.rda new file mode 100644 index 0000000..6540520 Binary files /dev/null and b/data/NHANES.rda differ diff --git a/inst/doc/hexagon_binning.Rnw b/inst/doc/hexagon_binning.Rnw new file mode 100644 index 0000000..0005171 --- /dev/null +++ b/inst/doc/hexagon_binning.Rnw @@ -0,0 +1,498 @@ +%% Emacs: use Rnw-mode if available, else noweb +%% NOTE -- ONLY EDIT THE .Rnw FILE ! + +%\VignetteIndexEntry{Hexagon Binning} +%\VignetteDepends{hexbin, grid, cluster, marray} +%\VignetteKeywords{Over plotting, Large data set, Visualization} +%\VignettePackage{hexbin} + +\documentclass[]{article} + +\usepackage[authoryear,round]{natbib} +\usepackage{amsmath} +\usepackage{hyperref} + + +\author{Nicholas Lewin-Koh\footnote{with minor assistance by Martin M\"achler}} + +\begin{document} + +\title{Hexagon Binning: an Overview} +\maketitle{} + +\section{Overview} +Hexagon binning is a form of bivariate histogram useful for visualizing +the structure in datasets with large $n$. The underlying concept of +hexagon binning is extremely simple; +\begin{enumerate} +\item the $xy$ plane over the set (range($x$), range($y$)) is tessellated +by a regular grid of hexagons. + +\item the number of points falling in each hexagon are counted and +stored in a data structure + +\item the hexagons with count $ > 0$ are plotted using a color ramp or +varying the radius of the hexagon in proportion to the counts. +\end{enumerate} + +The underlying algorithm is extremely fast and effective for displaying the +structure of datasets with $n \ge 10^6$. +If the size of the grid and the cuts in the color ramp are chosen in a +clever fashion than the structure inherent in the data should emerge +in the binned plots. The same caveats apply to hexagon binning as +apply to histograms and care should be exercised in choosing the +binning parameters. + +The hexbin package is a set of function for creating, manipulating and plotting +hexagon bins. The package extends the basic hexagon binning ideas with +several functions for doing bivariate smoothing, finding an +approximate bivariate median, and looking at the difference between +two sets of bins on the same scale. The basic functions can be +incorporated into many types of plots. This package is based on the +original package for splus by Dan Carr at George Mason University and +is mostly the fruit of his graphical genius and intuition. + +\section{Theory and Algorithm} +Why hexagons? There are many reasons for using hexagons, at least over +squares. Hexagons have symmetry of nearest neighbors which is lacking +in square bins. Hexagons are the maximum number of sides a polygon can +have for a regular tesselation of the plane, so in terms of packing a +hexagon is 13\% more efficient for covering the plane than +squares. This property translates into better sampling efficiency at +least for elliptical shapes. Lastly hexagons are visually less biased +for displaying densities than other regular tesselations. For instance +with squares our eyes are drawn to the horizontal and vertical lines +of the grid. The following figure adapted from \cite[]{carretal}shows +this effectively. + +\begin{figure}[H] + \centering +<>= +library("hexbin")#,lib.loc="/home/nikko/R-devel/hex.devel/tst") +x <- rnorm(1000) +y <- rnorm(1000) +##-- Hexagon Bins: -- +hbin <- hexbin(x,y, xbins = 25) +grid.newpage() +pushViewport(viewport(layout=grid.layout(1, 2))) +pushViewport(viewport(layout.pos.col=1,layout.pos.row=1)) +plot(hbin, style="lattice", legend=0, xlab = "X", ylab = "Y", newpage=FALSE) +popViewport() + +##-- Manual "square" binning: -- +## grid +rx <- range(x); bx <- seq(rx[1],rx[2], length=29) +ry <- range(y); by <- seq(ry[1],ry[2], length=29) +## midpoints +mx <- (bx[-1]+bx[-29])/2 +my <- (by[-1]+by[-29])/2 +gg <- as.matrix(expand.grid(mx,my))# dim = (28^2, 2) +zz <- unname(table(cut(x, b = bx), cut(y, b = by)))# 28 x 28 +ind <- zz > 0 +if(FALSE) ## ASCII image: + symnum(unname(ind)) +sq.size <- zz[ind]^(1/3) / max(zz) +## if we used base graphics: +## symbols(gg[ind,], squares = sq.size, inches = FALSE, fg = 2, bg = 2) +pushViewport(viewport(layout.pos.col=2, layout.pos.row=1)) +vp <- plot(hbin, style="lattice", legend=0, + xlab = "X", ylab = "Y", newpage=FALSE, type="n") +pushHexport(vp$plot, clip="on") +grid.rect(x= gg[ind,1], y=gg[ind,2], width = sq.size, height= sq.size, + default.units = "native", gp = gpar(col="black",fill="black")) +popViewport() +@ + \caption[bivariate: squares and hexagons]{A bivariate point set binned + into squares and hexagons. Bins are + scaled approximately equal, and the size of the glyph is proportional + to the count in that bin.} + \label{fig:compHexSq} +\end{figure} + + +We can see in Figure~\ref{fig:compHexSq} that when the data are plotted +as squares centered on a regular lattice our eye is drawn to the regular lines +which are parrallel to the underlying grid. Hexagons tend to break up +the lines. + +How does does the hexagon binning algorithm work? + +\begin{enumerate} +\item Squash $Y$ by $\sqrt{3}$ +\item Create a dual lattice +\item Bin each point into pair of near neighbor rectangles +\item Pick closest of the rectangle centers (adjusting for $\sqrt{3}$) +\end{enumerate} + + +<< nearNeighbor, echo = false, results = hide >>= +x <- -2:2 +sq <- expand.grid(list(x = x, y = c(-1,0,1))) +fc.sq <- rbind(sq,sq+.5) # face centered squares +fc.sq$y <- sqrt(3)*fc.sq$y # stretch y by the sqrt(3) +nr <- length(fc.sq$x)/2 +@ + +\begin{figure}[H] + \centering +<< fig = TRUE,width = 4,height = 8,echo = FALSE >>= +par(mfrow = c(3,1)) +par(mai = c(.1667,0.2680,0.1667,0.2680)) ##par(mai=.25*par("mai")) +plot(fc.sq$x, fc.sq$y, pch = 16, cex = .5) +nr <- length(fc.sq$x)/2 +points(fc.sq$x[1:nr], fc.sq$y[1:nr], pch = 15, cex = .7, col = 5) +points(-.25,.15, col = 2, pch = 16, cex = .5) + +par(mai = c(.1667, 0.2680, 0.1667, 0.2680))##par(mai=.25*par("mai")) +plot(fc.sq$x, fc.sq$y, pch = 16, cex = .5) +nr <- length(fc.sq$x)/2 +points(fc.sq$x[1:nr], fc.sq$y[1:nr], pch = 15, cex = .7, col = 5) +px <- c(-1,-2,-2,-1)+1 +py <- sqrt(3)*(c(0,0,-1,-1)+1) +polygon(px, py, density = 0, col = 5) +polygon(px+.5, py-sqrt(3)/2, density = 0) +points(-.25, .15, col = 2, pch = 16, cex = .5) + +par(mai = c(.1667, 0.2680, 0.1667, 0.2680))##par(mai=.25*par("mai")) +plot(fc.sq$x, fc.sq$y, pch = 16, cex = .5) +nr <- length(fc.sq$x)/2 +points(fc.sq$x[1:nr], fc.sq$y[1:nr], pch = 15, cex = .7, col = 5) +px <- c(-1,-2,-2,-1) + 1 +py <- sqrt(3)*(c(0,0,-1,-1) + 1) +polygon(px, py, density = 0, col = 5) +polygon(px+.5, py-sqrt(3)/2, density = 0) +px <- c(-.5,-.5,0,.5, .5, 0) +py <- c(-.5, .5,1,.5,-.5,-1) /sqrt(3) +polygon(px, py, col = gray(.5), density = 0) +polygon(px-.5, py+sqrt(3)/2, density = 0, col = 4) +points(-.25, .15, col = 2, pch = 16, cex = .5) +plot.new() +arrows(-.25, .15, 0, 0, angle = 10, length = .05) +@ +\caption[Near Neighbor Rectangles]{} +\label{fig:binalg} +\end{figure} + +Figure~\ref{fig:binalg} shows graphically how the algorithm works. In +the first panel we see the the dual lattice laid out in black and blue +points. The red point is an arbitrary point to be binned. The second +panel shows the near neigbor rectangles for each lattcie around the +point to be binned, the intersection of the rectangles contains the +point. The last panel shows the simple test for locating the point in +the hexagon, the closest of the two corners which are not +intersections is the center of the hexagon to which the point should +be allocated. The binning can be calculated in one pass through the +data, and is clearly $O(n)$ with a small constant. Storage is vastly +reduced compared to the original data. + +\section{Basic Hexagon Binning Functions} +Using the basic hexagon binning functions are not much more involved +than using the basic plotting functions. The following little example +shows the basic features of the basic plot and binning functions. +We start by loading the package and generating a toy example data set. + +<< basic, fig = TRUE, results = hide >>= +x <- rnorm(20000) +y <- rnorm(20000) +hbin <- hexbin(x,y, xbins = 40) +plot(hbin) +@ +There are two things to note here. The first is that the function +\texttt{gplot.hexbin} is defined as a \texttt{plot} method for the S4 class +\texttt{hexbin}. The second is that the default color scheme for the +hexplot is a gray scale. However, there is an argument to plot, +\texttt{colramp}, that allows the use of any function that excepts an +argument \texttt{n} and returns $n$ colors. Several functions are supplied +that provide alternative color-ramps to R's built in color ramp functions, +see \texttt{help(ColorRamps)}. + +<< showcol, fig = TRUE, width = 7, height = 4, echo = FALSE >>= +#nf <- layout(matrix(c(1,1,2,2,4,3,3,4), ncol=4, nrow=2, byrow=TRUE), +# widths = rep(1,4), heights=rep(1,2)) +grid.newpage() +mar <- unit(0.1 + c(5,4,4,2),"lines") +mai <- as.numeric(convertUnit(mar, "inches")) +vpin <- c(convertWidth (unit(1,"npc"),"inches"), + convertHeight(unit(1,"npc"),"inches")) +shape <- optShape(height = vpin[2],width = vpin[1]/3,mar = mai) + +x <- rnorm(20000) +y <- rnorm(20000) +hbin <- hexbin(x,y, xbins = 40, shape = shape) +grid.newpage() +pushViewport(viewport(layout = grid.layout(1, 3))) +pushViewport(viewport(layout.pos.col = 1,layout.pos.row = 1)) +plot(hbin, legend = 0, xlab = "X", ylab = "Y", newpage = FALSE) +popViewport() +pushViewport(viewport(layout.pos.col = 2,layout.pos.row = 1)) +plot(hbin, legend = 0, xlab = "X", ylab = "Y", + newpage = FALSE, colramp = terrain.colors) +popViewport() +pushViewport(viewport(layout.pos.col = 3,layout.pos.row = 1)) +plot(hbin, legend = 0, xlab = "X", ylab = "Y", + newpage = FALSE, colramp = BTY) +popViewport() +@ + +The figure shows three examples of using hexagons in a plot for large $n$ with +different color schemes. Upper left: the default gray scale, upper right: the +R base \texttt{terrain.colors()}, and lower middle: \texttt{BTY()}, a +blue to yellow color ramp supplied with hexbin on a perceptually linear +scale. + +The hexbin package supplies a plotting method for the hexbin data +structure. The plotting method \texttt{gplot.hexbin} accepts all the +parameters for the hexagon function and supplies a legend as well, for +easy interpretation of the plot. Figure~2 shows a hex binned plot with +a legend. A function \texttt{grid.hexlegend} is supplied for creating user +specified hexagon legends. + +\section{Extended Hexagon Functions} +So far we have looked at the basic hexagon plot. The hexbin package +supplies several extensions to the basic hexbin, and the associated +hexplot. The extensions discussed in this section will be smoothing +hexbin objects using the hsmooth function, apporximating a bivariate +median with hexagons and a version of a bivariate boxplot, and using +eroded hexbin objects to look at the overlap of two bivariate populations. + +\subsection{Smoothing with \texttt{hsmooth}} +At this point the hexbin package only provides a single option for +smoothig using a discrete kernel. Several improvements are in +development including an apply function over neighborhoods and spline +functions using a hexagonal basis or tensor products. The apply +function should facilitate constructing more sophisticated kernel +smoothers. The hexagon splines will provide an alternative to +smoothing on a square grid and allow interpolation of hexagons to +finer grids. + +The current implementation uses the center cell, immediate +neighbors and second neighbors to smooth the counts. The counts for +each resulting cell is a linear combination of the counts in the +defined neighborhood, including the center cell and weights. The +counts are blurred over the the domain, and the domain increases +because of shifting. Generally the dimension of the occupied cells of +the lattice increases by one, sometimes two. + +Some examples of using the hsmooth function are given below. Notice in +the plots that the first plot is with no smoothing, weights are +\texttt{c(1,0,0)} meaning that only the center cell is used with +identity weights. The second plot shows a first order kernel using +weights \texttt{c(24,12,0)}, while the third plot uses weights for +first and second order neighbors specified as \texttt{c(48,24,12)}. +The code segment generating these plots rescales the smoothed counts +so that they are on the original scale. + +<< showsmth, fig = TRUE, width = 8, height = 4, echo = FALSE >>= +#nf <- layout(matrix(c(1,1,2,2,4,3,3,4), ncol=4, nrow=2, byrow=TRUE), +# widths = rep(1,4), heights=rep(1,2)) +x <- rnorm(10000) +y <- rnorm(10000) +grid.newpage() +mar <- unit(0.1 + c(5,4,4,2),"lines") +mai <- as.numeric(convertUnit(mar, "inches")) +vpin <- c(convertWidth (unit(1,"npc"), "inches"), + convertHeight(unit(1,"npc"), "inches")) +shape <- optShape(height = vpin[2],width = vpin[1]/3,mar = mai) +hbin <- hexbin(x,y, xbins = 30,shape = shape) +hsmbin1 <- hsmooth(hbin, c( 1, 0,0)) +hsmbin2 <- hsmooth(hbin, c(24,12,0)) +hsmbin2@count <- as.integer(ceiling(hsmbin2@count/sum(hsmbin2@wts))) +hsmbin3 <- hsmooth(hbin,c(48,24,12)) +hsmbin3@count <- as.integer(ceiling(hsmbin3@count/sum(hsmbin3@wts))) +pushViewport(viewport(layout = grid.layout(1, 3))) +pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) +plot(hsmbin1, legend = 0, xlab = "X", ylab = "Y", newpage= FALSE,colramp = BTY) +popViewport() +pushViewport(viewport(layout.pos.col = 2,layout.pos.row = 1)) +plot(hsmbin2, legend = 0, xlab = "X", ylab = "Y", newpage= FALSE,colramp = BTY) +popViewport() +pushViewport(viewport(layout.pos.col = 3,layout.pos.row = 1)) +plot(hsmbin3, legend = 0, xlab = "X", ylab = "Y", newpage= FALSE,colramp = BTY) +popViewport() +@ +\subsection{Bin Erosion and the \texttt{hboxplot}} +The next tool to introduce, gray level erosion, extends the idea of +the boxplot. The idea is to extract cells in a way that the most +exposed cells are removed first, ie cells with fewer neighbors, but +cells with lower counts are removed preferentially to cells with +higher counts. The algorithm works as follows: +Mark the high count cells containing a given fraction, cdfcut, of +the total counts. Mark all the cells if cdfcut is zero. +The algorithm then performs gray-level erosion on the +marked cells. Each erosion cycle removes counts from cells. The +counts removed from each cell are a multiple of the cell's exposed-face +count. The algorithm choses the multiple so at least one cell will be +empty or have a count deficit on each erosion cycle. The erode vector +contains an erosion number for each cell. The value of erode is + +\begin{center} + $6\times$(The erosion cycle at cell removal) $ - $ + (The cell deficit at removal) +\end{center} + +The cell with the highest erosion number is a candidate bivariate +median. A few ties in the erosion order are common. + +The notion of an ordering to the median is nice because it allows us +to create a version of a bivariate box plot built on hexagons. The +following example comes from a portion of the ''National Health and Nutrition +Examination Survey'' included in \texttt{hexbin} as the sample data +set NHANES. The data consist of 9575 persons and mesures various +clincal factors. Here in Figure~\ref{hbox} we show the levels of +transferin, a measure of iron binding against hemoglobin for all + +\begin{figure}[H] + \centering + +<< hbox, fig = TRUE, width = 6, height = 4, echo = FALSE >>= +data(NHANES) +#grid.newpage() +mar <- unit(0.1 + c(5,4,4,2),"lines") +mai <- as.numeric(convertUnit(mar, "inches")) +#vpin <- c(convertWidth (unit(1,"npc"), "inches"), +# convertHeight(unit(1,"npc"), "inches")) +vpin <- c(unit(6,"inches"),unit(4, "inches")) +shape <- optShape(height = vpin[2], width = vpin[1], mar = mai) +hb <- hexbin(NHANES$Transferin, NHANES$Hemoglobin, shape = shape) +hbhp <- hboxplot(erode(hb,cdfcut = .05),unzoom = 1.3) +pushHexport(hbhp,clip = 'on') +hexGraphPaper(hb,fill.edges = 3) +popViewport() +@ +\caption{Hexagon "boxplots" showing the top 95 percent of the data for + males and females. The red hexagons are an estimate of the bivariate median.} +\label{hbox} +\end{figure} + +Note that we have added ``hexagon graph paper'' to the plot. This can +be done for any hexbin plot, using the command +\texttt{hexGraphPaper()} where the main argument is the hexbin object. + +\subsection{Comparing Distributions and the \texttt{hdiffplot}} +With univariate data, if there are multiple groups, one often uses a +density estimate to overlay densities, and compare two or more +distirbutions. The hdiffplot is the bivariate analog. The idea behind +the hdiff plot is to plot one or more bin objects representing +multiple groups to compare the distributions. The following example +uses the National Health data supplied in the hexbin package, +(\texttt{NHANES}). Below we show a comparison of males and females, +the bivariate relationship is transferin, which is a derived measure +of the ability of blood to bind oxygen, vs the level of hemoglobin. +Note that in the call to \texttt{hdiffplot} we erode the bins to +calculate the bivariate medians, and only display the upper 75\% of +the data. +\begin{figure}[H] + \centering +<< hdiff, fig = TRUE, width = 6, height = 4, echo = TRUE >>= +#grid.newpage() +shape <- optShape(height = vpin[2],width = vpin[1],mar = mai) +xbnds <- range(NHANES$Transferin,na.rm = TRUE) +ybnds <- range(NHANES$Hemoglobin,na.rm = TRUE) +hbF <- hexbin(NHANES$Transferin[NHANES$Sex == "F"], + NHANES$Hemoglobin[NHANES$Sex == "F"], + xbnds = xbnds, ybnds = ybnds, shape = shape) +hbM <- hexbin(NHANES$Transferin[NHANES$Sex == "M"], + NHANES$Hemoglobin[NHANES$Sex == "M"], + xbnds = xbnds, ybnds = ybnds, shape = shape) +plot.new() +hdiffplot(erode(hbF,cdfcut = .25),erode(hbM,cdfcut = .25),unzoom = 1.3) +@ +\caption{A difference plot of transferin vs hemoglobin for males and females.} +\label{hdiffplot} +\end{figure} + + + +\subsection{Plotting a Third Concomitant Variable} +In many cases, such as with spatial data, one may want to plot the +levels of a third variable in each hexagon. The grid.hexagons function +has a pair of arguments, \texttt{use.count} and \texttt{cell.at}. If +\texttt{use.count = FALSE} and \texttt{cell.at} is a numeric vector of +the same length as \texttt{hexbin@count} then the attribute vector +will be used instead of the counts. \texttt{hexTapply} will +sumarrerize values for each hexagon according to the supplied function +and return the table in the right order to use as an attribute +vector. Another alternative is to set the \texttt{cAtt} slot of the +hexbin obeject and grid.hexagons will automatically plot the attribute +if \texttt{use.count = FALSE} and \texttt{cell.at = NULL}. + +Here is an example using spatial data. Often in cartographers use +graduated symbols to display varying numerical quantities across a region. + + + +\section{Example: cDNA Chip Normalization} +This example is taken from the marray package, which +supplies methods and classes for the normalization and diagnostic +plots of cDNA microarrays. In this example the goal is not to make any +comments about the normalization methodology, but rather to show how +the diagnostic plots can be enhanced using hexagon binning due to the +large number of points ($n = 8,448$ cDNA probes per chip). + +We look at the diagnostic plot $M$ vs $A$, where $M$ is the +log--ratio, $M = \log <- 2 \frac{R}{G}$ and $A$ is the overall intensity, +$A = \log <- 2\sqrt{RG}$. Figure~3 shows the plot using points and on the +right hexagons. The hexagon binned plot shows that most of the pairs +are well below zero, and that the overall shape is more like a comet +with most of the mass at the bottom of the curve, rather than a thick +bar of points curving below the line. + +<< marray1, fig = TRUE, results = hide >>= +### Need to redo this part. +library("marray") +data(swirl, package = "marray") ## use swirl dataset + +hb1 <- hexbin(maA(swirl[,1]), maM(swirl[,1]), xbins = 40) +grid.newpage() +pushViewport(viewport(layout = grid.layout(1, 2))) + +pushViewport(viewport(layout.pos.col = 1,layout.pos.row = 1)) +nb <- plot(hb1, type = 'n', xlab = 'A', ylab = 'M', + main = "M vs A plot with points", legend = 0, newpage = FALSE) +pushHexport(nb$plot.vp) +grid.points(maA(swirl[,1]), maM(swirl[,1]),pch = 16,gp = gpar(cex = .4)) +popViewport() +nb$hbin <- hb1 +hexVP.abline(nb$plot.vp,h = 0,col = gray(.6)) +hexMA.loess(nb) +popViewport() + +pushViewport(viewport(layout.pos.col = 2,layout.pos.row = 1)) +hb <- plotMAhex(swirl[,1], newpage = FALSE, + main = "M vs A plot with hexagons", legend = 0) +hexVP.abline(hb$plot.vp,h = 0,col = gray(.6)) +hexMA.loess(hb) +popViewport() +@ + + + +\section{Manipulating Hexbins} +The underlying functions for hexbin have been rewritten and now depend +on the grid graphics system. The support unit for all hexagon plots is +the hexViewport. The function \texttt{hexViewport()} takes a hexbin +object as input and creates a viewport scaled to the current device or +viewport so that the aspect ratio is scaled appropriately for the +hexagons. Unlike in the base graphic functions where the aspect ratio +is maintained by shifting the range of the axes, here the extra space +is shifted into the margins. Currently hexViewport returns a +hexViewport object that has information on the margins and +its own pushViewport method. In the next example we will 1st show how +to manipulate an existing plot using grid commands and second show how to +create a custom plotting function using \texttt{hexViewport} and grid. + +\subsection{Adding to an existing plot} +Adding to an existing plot requires the use of grid +functions. For instance, in the following code, +<< addto,fig = TRUE,echo = TRUE >>= +hplt <- plot(hb1,style = 'centroid',border = gray(.65)) +pushHexport(hplt$plot.vp) +ll.fit <- loess(hb1@ycm ~ hb1@xcm, weights = hb1@count, span = .4) +pseq <- seq(hb1@xbnds[1]+1, hb1@xbnds[2]-1, length = 100) +grid.lines(pseq, predict(ll.fit,pseq), + gp = gpar(col = 2), default.units = "native") +@ +we have to use \texttt{grid.lines()}, as opposed to \texttt{lines()}. + + +\end{document} diff --git a/inst/doc/hexagon_binning.pdf b/inst/doc/hexagon_binning.pdf new file mode 100644 index 0000000..9217eac Binary files /dev/null and b/inst/doc/hexagon_binning.pdf differ diff --git a/man/NHANES.Rd b/man/NHANES.Rd new file mode 100644 index 0000000..ef1afab --- /dev/null +++ b/man/NHANES.Rd @@ -0,0 +1,60 @@ +\name{NHANES} +\alias{NHANES} +\docType{data} +\title{NHANES Data : National Health and Nutrition Examination Survey} +\usage{data(NHANES)} +\description{ + This is a somewhat large interesting dataset, a data frame of 15 + variables (columns) on 9575 persons (rows). +} +\format{ + This data frame contains the following columns: + \describe{ + \item{Cancer.Incidence}{binary factor with levels \code{No} and \code{Yes}.} + \item{Cancer.Death}{binary factor with levels \code{No} and \code{Yes}.} + \item{Age}{numeric vector giving age of the person in years.} + \item{Smoke}{a factor with levels \code{Current}, \code{Past}, + \code{Nonsmoker}, and \code{Unknown}.} + \item{Ed}{numeric vector of \eqn{\{0,1\}} codes giving the education level.} + \item{Race}{numeric vector of \eqn{\{0,1\}} codes giving the + person's race.%% FIXME : 0 = ? 1 = ? + } + \item{Weight}{numeric vector giving the weight in kilograms} + \item{BMI}{numeric vector giving Body Mass Index, i.e., + \code{Weight/Height^2} where Height is in meters, and missings + (61\% !) are coded as \code{0} originally.}%% rather FIXME? + \item{Diet.Iron}{numeric giving Dietary iron.} + \item{Albumin}{numeric giving albumin level in g/l.} + \item{Serum.Iron}{numeric giving Serum iron in \eqn{\mu}{u}g/l.} + \item{TIBC}{numeric giving Total Iron Binding Capacity in \eqn{\mu}{u}g/l.} + \item{Transferin}{numeric giving Transferin Saturation which is just + \code{100*serum.iron/TIBC}.} + \item{Hemoglobin}{numeric giving Hemoglobin level.} + \item{Sex}{a factor with levels \code{F} (female) and \code{M} (male).} + } +} +% \details{ +% } +\source{ + unknown%____ FIXME ____ +} +\references{ +% ~~ possibly secondary sources and usages ~~ +} +\examples{ +data(NHANES) +summary(NHANES) +## Missing Data overview : +nNA <- sapply(NHANES, function(x)sum(is.na(x))) +cbind(nNA[nNA > 0]) +# Which are just these 6 : +\dontrun{ +Diet.Iron 141 +Albumin 252 +Serum.Iron 1008 +TIBC 853 +Transferin 1019 +Hemoglobin 759 +}%dont +} +\keyword{datasets} diff --git a/man/colramp.Rd b/man/colramp.Rd new file mode 100644 index 0000000..807b72e --- /dev/null +++ b/man/colramp.Rd @@ -0,0 +1,58 @@ +\name{ColorRamps} +\title{Color Ramps on Perceptually Linear Scales} +\alias{ColorRamps} +\alias{LinGray} +\alias{BTC} +\alias{BTY} +\alias{LinOCS} +\alias{heat.ob} +\alias{magent} +\alias{plinrain} +\description{ + Functions for returning colors on perceptually linear scales, + where steps correspond to \sQuote{just detectable differences}. +} +\usage{ +LinGray (n, beg=1, end=92) +BTC (n, beg=1, end=256) +LinOCS (n, beg=1, end=256) +heat.ob (n, beg=1, end=256) +magent (n, beg=1, end=256) +plinrain(n, beg=1, end=256) +} +\arguments{ + \item{n}{number of colors to return from the ramp} + \item{beg}{begining of ramp, integer from 1-255} + \item{end}{end of ramp, integer from 1-255} +} +\value{ + returns an array of colors +} +\details{ + Several precalulated color ramps, that are on a perceptually linear + color scale. A perceptually linear color scale is a scale where each + jump corresponds to a \dQuote{just detectable difference} in color and the + scale is percieved as linear by the human eye (emprically determined). + + When using the ramps, if \code{beg} is less than \code{end} the ramp + will be reversed. +} +\references{ + Haim Levkowitz (1997) + \emph{Color Theory and Modeling for Computer Graphics, + Visualization, and Multimedia Applications}. + Kluwer Academic Publishers, Boston/London/Dordrecht. + \url{http://www.cs.uml.edu/~haim/ColorCenter/} +} +\seealso{ + \code{\link[grDevices]{rainbow}}, \code{\link[grDevices]{terrain.colors}}, \code{\link[grDevices]{rgb}}, + \code{\link[grDevices]{hsv}} +} +\examples{ +h <- hexbin(rnorm(10000),rnorm(10000)) +plot(h, colramp= BTY) +## looks better if you shave the tails: +plot(h, colramp= function(n){LinOCS(n,beg=15,end=225)}) +} +\author{Nicholas Lewin-Koh} +\keyword{color} diff --git a/man/erode.hexbin.Rd b/man/erode.hexbin.Rd new file mode 100644 index 0000000..7eaf584 --- /dev/null +++ b/man/erode.hexbin.Rd @@ -0,0 +1,85 @@ +\name{erode.hexbin} +\alias{erode} +\alias{erode.hexbin} +\alias{erode,hexbin-method} +\alias{erodebin-class} + +\title{Erosion of a Hexagon Count Image} +\description{ + This erosion algorithm removes counts from hexagon cells at a rate + proportional to the cells' exposed surface area. When a cell becomes + empty, algorithm removes the emptied cell and notes the removal + order. Cell removal increases the exposure of any neighboring cells. + The last cell removed is a type of bivariate median. +} + +\usage{ +erode(hbin, cdfcut = 0.5) +erode.hexbin(hbin, cdfcut = 0.5) +} + +\arguments{ + \item{hbin}{an object of class \code{\link{hexbin}}.} + \item{cdfcut}{number in (0,1) indicating the confidence level for the + limits.} +} + +\value{ + An \code{"erodebin"} object (with all the slots from \code{hbin}) and + additionally with + high count cells and a component \code{erode} that gives the erosion order. +} + +\details{ + The algorithm extracts high count cells with containing a given + fraction (cdfcut) of the total counts. The algorithm extracts all + cells if cdfcut=0. The algorithm performs gray-level erosion on the + extracted cells. Each erosion cycle removes counts from cells. The + counts removed for each cell are a multiple of the cell's exposed-face + count. The algorithm choses the multiple so at least one cell will be + empty or have a count deficit on each erosion cycle. The erode vector + contain an erosion number for each cell. The value of erode is + + 6*erosion\_cycle\_ at\_ cell\_ removal - cell\_deficit\_at\_removal + + Cells with low values are eroded first. The cell with the highest + erosion number is a candidate bivariate median. A few ties in erode + are common. +} + +\seealso{ + \code{\link{hexbin}}, \code{\link{smooth.hexbin}}, + \code{\link{hcell2xy}}, %%FIXME\code{\link{hcell}}, + %% \code{\link{hboxplot}}, \code{\link{hdiffplot}}, + %% \code{\link{hmatplot}}, + \code{\link{gplot.hexbin}}, + \code{\link{grid.hexagons}}, \code{\link{grid.hexlegend}} +} + +\examples{ +set.seed(153) +x <- rnorm(10000) +y <- rnorm(10000) +bin <- hexbin(x,y) + +smbin <- smooth.hexbin(bin) +erodebin <- erode.hexbin(smbin, cdfcut=.5) +plot(erodebin) + +## bivariate boxplot +hboxplot(erodebin, main = "hboxplot(erodebin)") + + +%% MM: This looks wrong -- both the graphic and the logic in "par" here : +# show erosion order +plot(bin,style= "lat", minarea=1, maxarea=1, + legend=FALSE, border=gray(.7)) + +%% FIXME: {compare with example in "hexbin0"} +grid.hexagons(erodebin,style= "lat", minarea=1, maxarea=1,pen="green") +xy <- hcell2xy(erodebin) +grid.text(lab = as.character(erodebin@erode), xy$x, xy$y, + gp = gpar(col="white", cex=0.65)) + +} +\keyword{hplot} diff --git a/man/getHMedian.Rd b/man/getHMedian.Rd new file mode 100644 index 0000000..447511d --- /dev/null +++ b/man/getHMedian.Rd @@ -0,0 +1,34 @@ +\name{getHMedian} +\alias{getHMedian} +\alias{getHMedian,erodebin-method} +\title{Get coordiantes of the median cell after the erode operation} +\description{ + A method for a eroded hexbin object to extract the coordinates of the + median cell. The median is simply the cell with the highest erosion + number or the last cell to be eroded. +} +\usage{ +getHMedian(ebin) +} +\arguments{ + \item{ebin}{result of \code{\link{erode.hexbin}()}.} +} +\section{Methods}{ + \describe{ + \item{ebin = "erodebin"}{...} + } +} +\seealso{\code{\link{erode.hexbin}} +} +\examples{ +set.seed(153) +x <- rnorm(10000) +y <- rnorm(10000) +bin <- hexbin(x,y) + +smbin <- smooth.hexbin(bin) +erodebin <- erode.hexbin(smbin, cdfcut=.5) +getHMedian(erodebin) +} +\keyword{methods} + diff --git a/man/gplot.hexbin.Rd b/man/gplot.hexbin.Rd new file mode 100644 index 0000000..bc04efd --- /dev/null +++ b/man/gplot.hexbin.Rd @@ -0,0 +1,144 @@ +\name{gplot.hexbin} +\alias{gplot.hexbin} +\alias{plot,hexbin,missing-method} +\title{Plotting Hexagon Cells with a Legend} +\description{ + Plots Hexagons visualizing the counts in an hexbin object. Different + styles are availables. Provides a legend indicating the count + representations. +} +\usage{ +%% In future: No longer export gplot.hexbin() ! +gplot.hexbin(x, style = "colorscale", legend = 1.2, lcex = 1, + minarea = 0.04, maxarea = 0.8, mincnt = 1, maxcnt = max(x@count), + trans = NULL, inv = NULL, colorcut = seq(0, 1, length = min(17, maxcnt)), + border = NULL, density = NULL, pen = NULL, + colramp = function(n) LinGray(n,beg = 90,end = 15), + xlab = "", ylab = "", main = "", newpage = TRUE, + type = c("p", "l", "n"), xaxt = c("s", "n"), yaxt = c("s", "n"), + clip = "on", verbose = getOption("verbose")) +%% FIXME: This is the S4 plot method for 'hexbin' +%% currently also exported "standalone" - for testing,debugging.. +%% we'd really don't want to repeat the argument list; use \synopsis{.} ? +\S4method{plot}{hexbin,missing}(x, style = "colorscale", legend = 1.2, lcex = 1, + minarea = 0.04, maxarea = 0.8, mincnt = 1, maxcnt = max(x@count), + trans = NULL, inv = NULL, colorcut = seq(0, 1, length = min(17, maxcnt)), + border = NULL, density = NULL, pen = NULL, + colramp = function(n) LinGray(n,beg = 90,end = 15), + xlab = "", ylab = "", main = "", newpage = TRUE, + type = c("p", "l", "n"), xaxt = c("s", "n"), yaxt = c("s", "n"), + clip = "on", verbose = getOption("verbose")) +} +\arguments{ + \item{x}{an object of class \code{\link{hexbin}}.} +% \item{y}{(required by the S4 method for \code{\link{plot}} but unused +% here; must be missing)} + \item{style}{string specifying the style of hexagon plot, + see \code{\link{grid.hexagons}} for the possibilities.} + \item{legend}{numeric width of the legend in inches of \code{FALSE}. + In the latter case, or when \code{0}, no legend is not produced.} + \item{lcex}{characters expansion size for the text in the legend} + \item{minarea}{fraction of cell area for the lowest count} + \item{maxarea}{fraction of the cell area for the largest count} + \item{mincnt}{cells with fewer counts are ignored.} + \item{maxcnt}{cells with more counts are ignored.} + \item{trans}{\code{\link{function}} specifying a transformation for + the counts such as \code{sqrt}.} +% FIXME: use better description of these in hexagons() -- or use same +% ---- help page ?! + \item{inv}{the inverse transformation of \code{trans}.} + \item{colorcut}{vector of values covering [0, 1] that determine + hexagon color class boundaries and hexagon legend size boundaries. + Alternatively, an integer (\code{<= maxcnt}) specifying the + \emph{number} of equispaced colorcut values in [0,1].} + \item{border, density, pen}{color for polygon borders and filling of + each hexagon drawn, passed to \code{\link{grid.hexagons}}.} + \item{colramp}{function accepting an integer \code{n} as an argument and + returning n colors.} + \item{xlab, ylab}{x- and y-axis label.} + \item{main}{main title.} + \item{newpage}{should a new page start?.} + \item{type, xaxt, yaxt}{strings to be used (when set to \code{"n"}) for + suppressing the plotting of hexagon symbols, or the x- or y-axis, + respectively.} + \item{clip}{either 'on' or 'off' are the allowed arguments, when on + everything is clipped to the plotting region.} + \item{verbose}{logical indicating if some diagnostic output should happen.} + \item{\dots}{all arguments of \code{gplot.hexbin} can also be used for + the S4 \code{\link{plot}} method.} +} +\details{ + This is the (S4) \code{\link{plot}} method for \code{\link{hexbin}} (and + \code{erodebin}) objects (\link{erodebin-class}). + + To use the standalone function + \code{gplot.hexbin()} is \bold{\emph{deprecated}}. + For \code{style}, \code{minarea} etc, see the \bold{Details} section of + \code{\link{grid.hexagons}}'s help page. + + The legend functionality is somewhat preliminary. Later versions may + include refinements and handle extreme cases (small and large) for + cell size and counts. +} +\value{ + invisibly, a list with components + \item{plot.vp}{the \code{\link{hexViewport}} constructed and used.} + \item{legend.vp}{if a legend has been produced, its + \code{\link[grid]{viewport}}.} +} + +\references{ see in \code{\link{grid.hexagons}}.} +\author{ + Dan Carr \email{dcarr@voxel.galaxy.gmu.edu}, + ported by Nicholas Lewin-Koh \email{kohnicho@comp.nus.edu.sg} and + Martin Maechler. +} +\seealso{\code{\link{hexbin}}, \code{\link{hexViewport}}, + \code{\link{smooth.hexbin}}, + \code{\link{erode.hexbin}}, + \code{\link{hcell2xy}}, \code{\link{hboxplot}}, + \code{\link{hdiffplot}}. %%, \code{\link{hmatplot}}. +} +\examples{ +## 1) simple binning of spherical normal: +x <- rnorm(10000) +y <- rnorm(10000) +bin <- hexbin(x,y) + +## Plot method for hexbin ! +## ---- ------ -------- +plot(bin) +# nested lattice +plot(bin, style= "nested.lattice") + +# controlling the colorscheme +plot(bin, colramp=BTY, colorcut=c(0,.1,.2,.3,.4,.6,1)) + +## 2) A mixture distribution +x <- c(rnorm(5000),rnorm(5000,4,1.5)) +y <- c(rnorm(5000),rnorm(5000,2,3)) +bin <- hexbin(x,y) + +pens <- cbind(c("#ECE2F0","#A6BDDB","#1C9099"), + c("#FFF7BC","#FEC44F","#D95F0E")) +plot(bin, style = "nested.lattice", pen=pens) +# now really crazy +plot(bin, style = "nested.lattice", pen=pens,border=2,density=35) + +# lower resolution binning and overplotting with counts +bin <- hexbin(x,y,xbins=25) +P <- plot(bin, style="lattice", legend=FALSE, + minarea=1, maxarea=1, border="white") +## +%% FIXME! +pushHexport(P$plot.vp) +xy <- hcell2xy(bin) + # to show points rather than counts : +grid.points(x,y,pch=18,gp=gpar(cex=.3,col="green")) +grid.text(as.character(bin@count), xy$x,xy$y, + gp=gpar(cex=0.3, col="red"),default.units="native") +popViewport() + +# Be creative, have fun! +} +\keyword{hplot} diff --git a/man/grid.hexagons.Rd b/man/grid.hexagons.Rd new file mode 100644 index 0000000..46fcd94 --- /dev/null +++ b/man/grid.hexagons.Rd @@ -0,0 +1,198 @@ +\name{grid.hexagons} +\alias{grid.hexagons} +\title{Add Hexagon Cells to Plot} +\description{ + Plots cells in an hexbin object. The function distinquishes among + counts using 5 different styles. This function is the hexagon + plotting engine from the \code{plot} method for \code{\link{hexbin}} + objects. +} +\usage{ +grid.hexagons(dat, style = c("colorscale", "centroids", "lattice", + "nested.lattice", "nested.centroids", "constant.col"), + use.count=TRUE, cell.at=NULL, + minarea = 0.05, maxarea = 0.8, check.erosion = TRUE, + mincnt = 1, maxcnt = max(dat@count), trans = NULL, + colorcut = seq(0, 1, length = 17), + density = NULL, border = NULL, pen = NULL, + colramp = function(n){ LinGray(n,beg = 90, end = 15) }, + def.unit= "native", + verbose = getOption("verbose")) +} +\arguments{ + \item{dat}{an object of class \code{hexbin}, see \code{\link{hexbin}}.} + \item{style}{character string specifying the type of plotting; must be (a + unique abbrevation) of the values given in \sQuote{Usage} above.} + \item{use.count}{logical specifying if counts should be used.} + \item{cell.at}{numeric vector to be plotted instead of counts, must + besame length as the number of cells.} + \item{minarea}{numeric, the fraction of cell area for the lowest count.} + \item{maxarea}{the fraction of the cell area for the largest count.} + \item{check.erosion}{logical indicating only eroded points should be + used for \code{"erodebin"} objects; simply passed to + \code{\link{hcell2xy}}, see its documentation.} + \item{mincnt}{numeric; cells with counts smaller than \code{mincnt} + are not shown.} + \item{maxcnt}{cells with counts larger than this are not shown.} + \item{trans}{a transformation function (or \code{NULL}) for the counts, + e.g., \code{\link{sqrt}}.} + \item{colorcut}{a vector of values covering [0, 1] which determine + hexagon color class boundaries or hexagon size boundaries -- for + \code{style = "colorscale"} only.} + \item{density}{\code{\link[grid]{grid.polygon}} argument for shading. 0 causes + the polygon not to be filled. \emph{This is not implemented (for + \code{\link[grid]{grid.polygon}}) yet}.} + \item{border}{\code{\link[grid]{grid.polygon}()} argument. Draw the border for + each hexagon.} + \item{pen}{colors for \code{\link[grid]{grid.polygon}()}. Determines the color + with which the polygon will be filled.} + \item{colramp}{function of an integer argument \code{n} returning n + colors. \code{n} is determined }%% how? FIXME + \item{def.unit}{default \code{\link[grid]{unit}} to be used.}% FIXME + \item{verbose}{logical indicating if some diagnostic output should happen.} +} +\section{SIDE EFFECTS}{Adds hexagons to the plot.} + +\details{ + The six plotting styles have the following effect: + \describe{ + \item{\code{style="lattice"} or \code{"centroids"}:}{ + + Plots the hexagons in different sizes based on counts. The + \code{"lattice"} version centers the hexagons at the cell centers + whereas \code{"centroids"} moves the hexagon centers close to the + center of mass for the cells. In all cases the hexagons will not + plot outside the cell unless \code{maxarea > 1}. Counts are rescaled + into the interval [0,1] and colorcuts determine the class + boundaries for sizes and counts. The pen argument for this style + should be a single color or a vector of colors of + \code{length(bin@count)}.} + + \item{\code{style="colorscale"}:}{ + Counts are rescaled into the interval [0,1] and colorcuts determines + the class boundaries for the color classes. For this style, the + function passed as \code{colramp} is used to define the n colors for + the n+1 color cuts. The pen argument is ignored. + %% S-plus: In motif color options try polygon: black 16 white + See \code{\link{LinGray}} for the default \code{colramp} and + alternative \dQuote{color ramp} functions. + } + \item{\code{style="constant.col"}:}{ + This is an even simpler alternative to \code{"colorscale"}, + using constant colors (determined \code{pen} optionally). + } + + \item{\code{style="nested.lattice"} and \code{"nested.centroids"}:}{ + Counts are partitioned into classes by power of 10. The encoding + nests hexagon size within powers of 10 color contours. + + If the pen argument is used it should be a matrix of colors with 2 + columns and either \code{ceiling(log10(max(bin@count)))} or + \code{length(bin@count)} rows. The default uses the \R color palatte + so that pens numbers 2-11 determine colors for completely filled + cell Pen 2 is the color for 1's, Pen 3 is the color for 10's, etc. + Pens numbers 12-21 determine the color of the foreground hexagons. The + hexagon size shows the relative count for the power of 10. Different + color schemes give different effects including 3-D illusions + %% S-plus : + %% One motif color option for the first 4 powers is black \#BBB \#36F + %% \#0E3 \#F206 \#FFF4 \#FFF + %% + %% A second option is for the first 5 power is black \#FFF \#08F \#192 + %% \#F11 \#FF04 \#000 \#999 \#5CF \#AFA \#FAAF \#000 + } + } + + \emph{Hexagon size encoding \code{minarea} and \code{maxarea}} + determine the area of the smallest and largest hexagons + plotted. Both are expressed fractions of the bin cell size. Typical + values might be .04 and 1. When both values are 1, all plotted + hexagons are bin cell size, if \code{maxarea} is greater than 1 than + hexagons will overlap. This is sometimes interesting with the lattice + and centroid styles. + + \emph{Count scaling} + + \code{relcnt <- (trans(cnt)-trans(mincnt)) / (trans(maxcnt)-trans(mincnt))} + \cr + \code{area <- minarea + relcnt*maxarea} + + By default the transformation \code{trans()} is the identity + function. The legend routine requires the transformation inverse + for some options. + + \emph{Count windowing \code{mincnt} and \code{maxcnt}} + Only routine only plots cells with cnts in [mincnts, maxcnts] +} +\references{ + Carr, D. B. (1991) + Looking at Large Data Sets Using Binned Data Plots, + pp. 7--39 in \emph{Computing and Graphics in Statistics}; + Eds. A. Buja and P. Tukey, Springer-Verlag, New York. +} +\author{ + Dan Carr ; + ported and extended by Nicholas Lewin-Koh \email{nikko@hailmail.net}. +} +\seealso{\code{\link{hexbin}}, \code{\link{smooth.hexbin}}, + \code{\link{erode.hexbin}}, \code{\link{hcell2xy}},% \code{\link{hcell}}, + \code{\link{gplot.hexbin}}, \code{\link{hboxplot}}, \code{\link{hdiffplot}}, + \code{\link{grid.hexlegend}}% \code{\link{hmatplot}} +} + +\examples{ +set.seed(506) +x <- rnorm(10000) +y <- rnorm(10000) + +# bin the points +bin <- hexbin(x,y) + +# Typical approach uses plot( ) which controls the plot shape : +plot(bin, main = "Bivariate rnorm(10000)") + +## but we can have more manual control: + +# A mixture distribution +x <- c(rnorm(5000),rnorm(5000,4,1.5)) +y <- c(rnorm(5000),rnorm(5000,2,3)) +hb2 <- hexbin(x,y) + +# Show color control and overplotting of hexagons +## 1) setup coordinate system: +P <- plot(hb2, type="n", main = "Bivariate mixture (10000)")# asp=1 + +## 2) add hexagons (in the proper viewport): +pushHexport(P$plot.vp) +grid.hexagons(hb2, style= "lattice", border = gray(.1), pen = gray(.6), + minarea = .1, maxarea = 1.5) +popViewport() + +## How to treat 'singletons' specially: +P <- plot(hb2, type="n", main = "Bivariate mixture (10000)")# asp=1 +pushHexport(P$plot.vp) +grid.hexagons(hb2, style= "nested.centroids", mincnt = 2)# not the single ones +grid.hexagons(hb2, style= "centroids", maxcnt = 1, maxarea=0.04)# single points +popViewport() + + +%% FIXME --- this would mix grid- and traditional-graphics +%% ----- would need grid-graphics for 'gpclib' -- aaargs... +% # And if we had all the information... +% if(require(gpclib)){ +% h1 <- chull(x[1:5000], y[1:5000]) +% h2 <- chull(x[5001:10000], y[5001:10000]) +% h2 <- h2+5000 +% h1 <- as(cbind(x[1:5000],y [1:5000])[h1, ], "gpc.poly") +% h2 <- as(cbind(x,y)[h2, ], "gpc.poly") +% plot(hb2, type="n", main = "Bivariate mixture (10000)")# asp=1 +% +% plot(h1,poly.args = list(col ="#CCEBC5"),add = TRUE) +% plot(h2,poly.args = list(col ="#FBB4AE"),add = TRUE) +% plot(intersect(h1, h2), poly.args = list(col = 2), add = TRUE) +% grid.hexagons(hb2, style= "centroids", border = gray(.1), pen = gray(.6), +% minarea = .1, maxarea = 1.5) +% } + +} +\keyword{aplot} diff --git a/man/grid.hexlegend.Rd b/man/grid.hexlegend.Rd new file mode 100644 index 0000000..991d005 --- /dev/null +++ b/man/grid.hexlegend.Rd @@ -0,0 +1,81 @@ +\name{grid.hexlegend} +\alias{grid.hexlegend} +\title{Add a Legend to a Hexbin Plot} +\description{ + Plots the legend for the \code{plot} method of \code{\link{hexbin}}. + Provides a legend indicating the count representations. +} +\usage{ +grid.hexlegend(legend, ysize, lcex, inner, style = , + minarea = 0.05, maxarea = 0.8, mincnt = 1, maxcnt, trans = NULL, + inv = NULL, colorcut, density = NULL, border = NULL, pen = NULL, + colramp = function(n) { LinGray(n,beg = 90,end = 15) }, + leg.unit = "native") +} +\arguments{ + \item{legend}{positive number giving width of the legend in inches.} + \item{ysize}{height of legend in inches} + \item{lcex}{the characters expansion size for the text in the legend, + see \code{\link{par}(cex=)}.} + \item{inner}{the inner diameter of a hexagon in inches.} + \item{style}{the hexagon style; see \code{\link{grid.hexagons}}.} + \item{minarea, maxarea}{fraction of the cell area for the lowest and largest + count, respectively.} + \item{mincnt, maxcnt}{minimum and maximum count accepted in \code{plot}.} + \item{trans}{a transformation function for the counts such as + \code{\link{sqrt}}.} + \item{inv}{the inverse transformation function.} + \item{colorcut}{numeric vector of values covering [0, 1] the determine + hexagon color classes boundaries and hexagon legend size boundaries.} + \item{border}{argument for \code{\link{polygon}()}. Draw the border + for each hexagon.} + \item{density}{argument for \code{\link{polygon}()} filling. A + \code{0} causes the polygon not to be filled.} + \item{pen}{color argument used for \code{\link{polygon}(col = .)}. + Determines the color with which the polygon will be filled.} + \item{colramp}{function accepting an integer \code{n} as an argument and + returning n colors.} + \item{leg.unit}{unit to use}%FIXME + +} +\details{ + The \code{plot} method for \code{\link{hexbin}} objects calls this function + to produce a legend + by setting the graphics parameters, so \code{hex.legend} itself is not a + standalone function. + + The legend function is \bold{preliminary}. Later version will include + refinements and handle extreme cases (small and large) for cell size + and counts. + + See the \bold{Details} section of \code{\link{grid.hexagons}}'s help page. +} +\value{ + This function does not return any value. +} +\references{ see in \code{\link{grid.hexagons}}.} +\author{ + Dan Carr + + ported by Nicholas Lewin-Koh +} + +\seealso{\code{\link{hexbin}}, \code{\link{grid.hexagons}}, +% FIXME + \code{\link{smooth.hexbin}}, \code{\link{erode.hexbin}}, +% \code{\link{hcell}}, + \code{\link{hcell2xy}}, + \code{\link{gplot.hexbin}},% \code{\link{hboxplot}},% \code{\link{hdiffplot}}, +% \code{\link{hmatplot}} +} + +\examples{ +## Not a stand alone function; typically only called from plot.hexbin() +%% Hence we should not run it here! +%% FIXME: Improve hex.legend() such that it *can* be added to plots !!! +\dontrun{ + grid.hexlegend(legend = 2, ysize = 1,lcex=8,inner=0.2, + maxcnt = 100, colorcut = c(0.5,0.5)) +} +} +\keyword{aplot} diff --git a/man/hboxplot.Rd b/man/hboxplot.Rd new file mode 100644 index 0000000..feb359a --- /dev/null +++ b/man/hboxplot.Rd @@ -0,0 +1,97 @@ +\name{hboxplot} +\alias{hboxplot} +\title{2-D Generalization of Boxplot} + +\description{ + If \code{bin} is an \emph{eroded} \code{\link{hexbin}} object, i.e., + an \code{erodebin} object, \code{hboxplot()} plots the high counts cells + selected by \code{\link{erode}()}. By default, the high counts + cells contain 50 percent of the counts so analagous to the + interquartile \dQuote{range}. The function distinguishes the last + cells eroded using color. These cells correspond to one definition of the + bivariate median. +%% FIXME ^^ (bad style, content +- ok) +} + +\usage{ +hboxplot(bin, xbnds = NULL, ybnds = NULL, + density, border = c(0, grey(0.7)), pen = c(2, 3), + unzoom = 1.1, clip ="off", reshape = FALSE, + xlab = NULL, ylab = NULL, main = "") +} +\arguments{ + \item{bin}{an object of class \code{\link{hexbin}}.} + \item{xbnds,ybnds}{global x- and y-axis plotting limits for multiple + plots.} + \item{density, border}{arguments for \code{\link{polygon}()} each of + length two, the first for the median, the second for the other cells.} + \item{pen}{colors (\dQuote{pen numbers}) for \code{polygon()}.} + \item{unzoom}{plot limit expansion factor when \code{xbnds} is + missing.} + \item{clip}{either 'on' or 'off' are the allowed arguments, when on + everything is clipped to the plotting region.} + \item{reshape}{logical value to reshape the plot although \code{xbnds} + and \code{ybnds} are present.} + \item{xlab, ylab, main}{x- and y- axis labels and main title} +} + +\value{ + invisibly, the \code{\link{hexViewport}()} used internally. + Used to add to the plot afterwards. +} + +\references{ see in \code{\link{grid.hexagons}}.} + +\details{ + The \code{density}, \code{border}, and \code{pen} arguments correspond + to the \code{\link{polygon}} function calls for plotting two types of + cells. The cell types, pen numbers and suggested colors are\cr + \tabular{lll}{ + TYPE \tab PEN \tab COLOR \cr + cells of bin \tab 2 \tab light gray \cr + last eroded cells of bin (median cells)\tab 1 \tab black \cr + } + + The erode components of the hexbin objects must be present for the + medians cells to plot. + + When \code{xbnds} is missing or \code{reshape} is true, the plot + changes graphics parameters and resets them. When \code{xbnds} is + missing the function also zooms in based on the available data to + provide increased resolution. + + The zoom used the hexagon cell centers. The unzoom argument backs off + a bit so the whole hexagon will fit in the plot. + + \code{Hboxplot()} is used as a stand alone function, for producing separate + legends .....%%FIXME for \code{\link{hmatplot}()} and for panels in + %% \code{\link{hmatplot}()}. +} + +\seealso{ + \code{\link{hexbin}}, \code{\link{erode}}, + %\code{\link{smooth.hexbin}}, + \code{\link{hcell2xy}},% \code{\link{hcell}}, + \code{\link{gplot.hexbin}}, +% \code{\link{hmatplot}}, + \code{\link{grid.hexagons}}, \code{\link{grid.hexlegend}} +} + +\examples{ +\dontshow{set.seed(753)} +## boxplot of smoothed counts +x <- rnorm(10000) +y <- rnorm(10000) + +bin <- hexbin(x,y) +erodebin <- erode(smooth.hexbin(bin)) + +hboxplot(erodebin) +hboxplot(erodebin, density = c(32,7), border = c(2,4)) +hp <- hboxplot(erodebin, density = c(-1,17), + main = "hboxplot(erode*(smooth*(.)))") +pushHexport(hp) +grid.points(x[1:10], y[1:10])# just non-sense to show the principle +popViewport() +} +\keyword{hplot} diff --git a/man/hcell2xy.Rd b/man/hcell2xy.Rd new file mode 100644 index 0000000..83c926b --- /dev/null +++ b/man/hcell2xy.Rd @@ -0,0 +1,63 @@ +\name{hcell2xy} +\alias{hcell2xy} +\alias{hcell2xy,hexbin-method} + +\title{Compute X and Y Coordinates for Hexagon Cells} + +\description{ + Computes x and y coordinates from hexagon cell id's. +} +\usage{ +hcell2xy(hbin, check.erosion = TRUE) +} +\arguments{ + \item{hbin}{a object of class \code{"hexbin"}, typically produced by + \code{\link{hexbin}(*)}.} + \item{check.erosion}{logical indicating if only the eroded points + should be returned in the case where \code{hbin} inherits from + \code{"erodebin"} (see \code{\link{erodebin-class}}); is \code{TRUE} + by default.} +} +\value{ + A list with two components of the same length as \code{bin$cell}, + \item{x}{} + \item{y}{} +} + +%%FIXME \references{see in \code{\link{hcell}}.} + +\details{ + The hexbin object \code{hbin} contains all the needed information. + The purpose of this function is to reduce storage. The cost is + additional calculation. +} + +\seealso{%%FIXME \code{\link{hcell}}, \code{\link{hray}}, + \code{\link{hexbin}}. +} + +\examples{ +x <- rnorm(10000) +y <- rnorm(10000) +plot(x,y, pch=".") +hbin <- hexbin(x,y) +str(xys <- hcell2xy(hbin)) +points(xys, cex=1.5, col=2) ; title("hcell2xy( hexbin(..) )", col.main=2) + +%% __________ FIXME ________ +\dontshow{ +## Temporal trends with confidence bounds plotted on a map: +## Illustration only pending access to user functions +## mtapply() # like tapply but for matrices +## sens.season.slope() # computes sen's seasonal slope + +## This part does not work and commented out +#hbin <- hcell(dat$x,dat$y) # x and y are in map projection units +#newdat < dat[,c('month','year','value')] # extract columns +#stats <- mtapply(newdat,bin$cell,sens.season.slope,season=12) +#plot(mymap,type='l') # map boundaries in map projection units +#xy <- hcell2xy(hbin) # x and y coordinates for hexagon cell centers +#hray(xy$x, xy$y,val=stat[,1],lower= stat[,2],upper=stat[,3]) +} +} +\keyword{manip} diff --git a/man/hcell2xyInt.Rd b/man/hcell2xyInt.Rd new file mode 100644 index 0000000..93ac7e0 --- /dev/null +++ b/man/hcell2xyInt.Rd @@ -0,0 +1,47 @@ +\name{hcell2xyInt} +\alias{hcell2xyInt} +%- Also NEED an '\alias' for EACH other topic documented here. +\title{Change cell ids to 2d integer coordinate system} +\description{ + Transforms the cell representation of a a lattice into a 2d integer + coordinate system. +} +\usage{ + hcell2xyInt(hbin, xbins=NULL, xbnds=NULL, ybnds=NULL, shape=NULL) +} + +\arguments{ + \item{hbin}{a object of class \code{"hexbin"}, typically produced by + \code{\link{hexbin}(*)}.} + \item{xbins}{the number of bins partitioning the range of xbnds.} + \item{xbnds, ybnds}{horizontal and vertical limits of the binning + region in x or y units respectively; must be numeric vector of + length 2.} + \item{shape}{the \emph{shape} = yheight/xwidth of the plotting regions.} + +} +\details{ + Takes a grid defined by either the hexbin parameters or dimen in a + hexbin object and translates the cell ids for the grid into 2d integer + coordinates. +} +\value{ + An integer matrix with two columns, i and j representing the integer + xy coordinates of the hexagon grid. + \item{i}{Integer coordiante of the rows, increases from bottom to top} + \item{j}{Integer coordiante of the columns, increases from left to right} +} + +\author{Nicholas Lewin-Koh } + + +\seealso{\code{\link{hcell2xy}}} +\examples{ + x<-rnorm(10000) + y<-rnorm(10000) + hbin<-hexbin(x,y) + ijInt<-hcell2xyInt(hbin) +} + +\keyword{dplot} +\keyword{misc} diff --git a/man/hdiffplot.Rd b/man/hdiffplot.Rd new file mode 100644 index 0000000..3461019 --- /dev/null +++ b/man/hdiffplot.Rd @@ -0,0 +1,134 @@ +\name{hdiffplot} +\alias{hdiffplot} +\title{Plot of Domain and Median Differences of Two "hexbin" Objects} +\description{ + Let \code{bin1} and \code{bin2} represent two \code{\link{hexbin}} + objects with scaling, plot shapes, and bin sizes. This plot + distinguishes cells unique to \code{bin1}, cells in common, and cells + unique to \code{bin2} using color. When the erode components are + present, color also distinguishes the two erosion medians. An arrow + shows the vector from the median of \code{bin1} to the median of + \code{bin2}. +} +\usage{ +hdiffplot(bin1, bin2 = NULL, xbnds, ybnds, + focus = NULL,% if(is.null(bin2)) 1:length(bin1) else c(1, 2), + col.control = list(medhex = "white", med.bord = "black", + focus = NULL, focus.border = NULL, back.col = "grey"), + arrows = TRUE, size = unit(0.1, "inches"), lwd = 2, + eps = 1e-6, unzoom = 1.08, clip="off", xlab = "", ylab = "", + main = deparse(mycall), \dots) +} + +\arguments{ + \item{bin1, bin2}{two objects of class \code{\link{hexbin}}.} + \item{xbnds,ybnds}{global x- and y-axis plotting limits. Used + primarily for multiple comparison plots.} +%%%------- FIXME -------- + \item{focus}{a vector of integers specifying which hexbin objects + should be treated as focal. Excluded hexbins are treated as background.} + \item{col.control}{a list for detailed color control.}%% <<< FIXME + \item{arrows}{a logical indicating wheter or not to draw arrows + between the focal hexbin objects median cells.} +%not yet \item{density}{fill arguments to polygon} +%not yet \item{pen}{pen numbers for polgyon} + \item{border}{border arguments to polygon} + \item{size}{arrow type size in inches.} + \item{eps}{distance criteria for distinct medians} + \item{unzoom}{plot limit expansion factor when xbnds is missing} + \item{clip}{either 'on' or 'off' are the allowed arguments, when on + everything is clipped to the plotting region.} + \item{lwd}{Line width for arrows, ignored when \code{arrows=FALSE} or + when bins have no erosion component} + \item{xlab}{label for x-axis} + \item{ylab}{label for y-axis} + \item{main}{main title for the plot; automatically constructed by default.} + \item{\dots}{...............} +} + +% \value{ +% ((currently unspecified --- proposals are welcome))%% FIXME +% } + +\details{ + The hexbin objects for comparison, \code{bin1} and \code{bin2}, must + have the same plotting limits and cell size. The plot produces a + comparison overlay of the cells in the two objects. If external + global scaling is not supplied, the algorithm determines plotting + limits to increase resolution. For example, the objects may be the + result of the \code{\link{erode.hexbin}()} and include only high count cells + containing 50 of the counts. The density, border, and pen arguments + correspond to the polygon function calls for plotting six types of + cells. The cell types are respectively: + \tabular{l}{ + unique cells of bin1,\cr + joint cells,\cr + unique cells of bin2,\cr + median cell of bin1,\cr + median cell of bin2,\cr + median cell if identical.\cr + } + + The \code{erode} components of the hexbin objects must be present for the + medians to plot. The algorithm select a single cell for the median if + there are algorithmic ties. + +%% FIXME: no 'pen' argument anymore .. (?) + The \code{pen} numbers for types of cells start at Pen 2. Pen 1 is + presumed black. The suggested six additional colors are light blue, + light gray, light red, blue, red, and black. Carr (1991) shows an + example for black and white printing. That plot changes the six + colors to light gray, dark gray, white, black, black, and black. It + changes the 4th, 5th, and 6th argument of border to TRUE. It also + changes 4th, 5th and 6th argument of density to 0. In other words + cells in common do not show and medians cells appear as outlines. + + When \code{xbnds} is missing, the plot changes graphics parameters and + resets them. The function also zooms in based on the available data + to provide increased resolution. +} + +\references{ see in \code{\link{grid.hexagons}}.}%>> ./hexagons.Rd + +\seealso{ + \code{\link{hexbin}}, \code{\link{smooth.hexbin}}, \code{\link{erode.hexbin}}, + % MISSING: hthin, + \code{\link{hcell2xy}}, % \code{\link{hcell}}, + \code{\link{gplot.hexbin}}, + \code{\link{hboxplot}}, % \code{\link{hmatplot}}, + \code{\link{grid.hexagons}}, \code{\link{grid.hexlegend}}. +} +\examples{ +## Comparison of two bivariate boxplots +x1 <- rnorm(10000) +y1 <- rnorm(10000) +x2 <- rnorm(10000,mean=.5) +y2 <- rnorm(10000,mean=.5) +xbnds <- range(x1,x2) +ybnds <- range(y1,y2) + +bin1 <- hexbin(x1,y1,xbnds=xbnds,ybnds=ybnds) +bin2 <- hexbin(x2,y2,xbnds=xbnds,ybnds=ybnds) +erodebin1 <- erode.hexbin(smooth.hexbin(bin1)) +erodebin2 <- erode.hexbin(smooth.hexbin(bin2)) + +hdiffplot(erodebin1,erodebin2) + +## Compare *three* of them: -------------------- + +x3 <- rnorm(10000,mean=-1) +y3 <- rnorm(10000,mean=-.5) +xbnds <- range(x1,x2,x3) +ybnds <- range(y1,y2,y3) + +bin1 <- hexbin(x1,y1,xbnds=xbnds,ybnds=ybnds) +bin2 <- hexbin(x2,y2,xbnds=xbnds,ybnds=ybnds) +bin3 <- hexbin(x3,y3,xbnds=xbnds,ybnds=ybnds) +erodebin1 <- erode.hexbin(smooth.hexbin(bin1)) +erodebin2 <- erode.hexbin(smooth.hexbin(bin2)) +erodebin3 <- erode.hexbin(smooth.hexbin(bin3)) + +bnlst <- list(b1=erodebin1, b2=erodebin2, b3=erodebin3) +hdiffplot(bnlst) +} +\keyword{hplot} diff --git a/man/hexGraphPaper.Rd b/man/hexGraphPaper.Rd new file mode 100644 index 0000000..3da2c0c --- /dev/null +++ b/man/hexGraphPaper.Rd @@ -0,0 +1,66 @@ +\name{hexGraphPaper} +\alias{hexGraphPaper} +\alias{hgridcent} +\title{Create a Hexgon Grid} +\description{ + Creates a hexagon grid that can be added to a plot created with grid + graphics. +} +\usage{ +hexGraphPaper(hb, xbnds = NULL, ybnds = NULL, xbins = 30, shape = 1, + add = TRUE, fill.edges = 1, fill = 0, border = 1) + +hgridcent(xbins, xbnds, ybnds, shape, edge.add = 0) +} +\arguments{ + \item{hb}{a object of class \code{"hexbin"}, typically produced by + \code{\link{hexbin}(*)}.} + \item{xbnds, ybnds}{horizontal and vertical limits of the binning + region in x or y units respectively; must be numeric vector of + length 2.} + \item{xbins}{the number of bins partitioning the range of xbnds.} + \item{shape}{the \emph{shape} = yheight/xwidth of the plotting regions.} + \item{add}{a logical value indicating whether or not to add the grid + to the current plot.} + \item{fill.edges}{integer number of hexagons to add around the border} + \item{fill}{the fill color for the hexagons} + \item{border}{the color of the border of the hexagons} + \item{edge.add}{offset (typically \code{fill.edges} above) used in + \code{hgridcent}.} +} +\details{ + If a hexbin object is given then the parameters xbins and shape are + ignored. Different bounds can still be specified. The \code{fill.edges} + parameter should be an integer. \code{fill.edges} takes the current + grid and adds a layer of hexagons around the grid for each level of + fill. So for example if \code{fill.edges= 2} than the dimensions of + the grid would be \code{(i,j)+4}. + + \code{hgridcent()} is the utility function computing the resulting + list (see section \dQuote{Value}). + + \strong{WARNING! If using a hexVP be sure to set clip to "on", otherwise the + hexagon grid will bleed over the plot edges.} +} +\value{ + Invisibly returns a list with th following components + \item{x}{The x coordinates of the grid} + \item{y}{the y coordinates of the grid} + \item{dimen}{a vector of length 2 gining the rows and columns of the grid} + \item{dx}{the horizontal diameter of the hexagons} + \item{dy}{the vertical diameter of the hexagons} +} +\author{Nicholas Lewin-Koh} +\seealso{\code{\link{hcell2xy}}, \code{\link{hexpolygon}}, + \code{\link{grid.hexagons}}} +\examples{ + x <- rnorm(10000) + y <- rnorm(10000,x,x) + hbin <- hexbin(x,y) + hvp <- plot(hbin,type="n") + pushHexport(hvp$plot,clip="on") + hexGraphPaper(hbin,border=grey(.8)) + grid.hexagons(hbin) +} +\keyword{aplot} +\keyword{dplot} diff --git a/man/hexList.Rd b/man/hexList.Rd new file mode 100644 index 0000000..6438881 --- /dev/null +++ b/man/hexList.Rd @@ -0,0 +1,50 @@ +\name{hexList} +\alias{hexList} +\alias{hexbinList-class} +\alias{coerce,list,hexbinList-method} +\title{Conditional Bivariate Binning into Hexagon Cells } +\description{ + Creates a list of \code{\link{hexbin}} objects. Basic components are + a cell id and a count of points falling in each occupied cell. + Basic methods are \code{\link[methods]{show}()}, \code{plot()} %(\link{plot.hexbin}) + and \code{\link{summary}()}, but also \code{\link{erode}}. + % .. \code{\link{smooth.hexbin}} +} +\usage{ +hexList(x, y = NULL, given = NULL, xbins = 30, shape = 1, + xbnds = NULL, ybnds = NULL, xlab = NULL, ylab = NULL) +} +%- maybe also 'usage' for other objects documented here. +\arguments{ + \item{x}{ ~~Describe \code{x} here~~ } + \item{y}{ ~~Describe \code{y} here~~ } + \item{given}{ ~~Describe \code{given} here~~ } + \item{xbins}{ ~~Describe \code{xbins} here~~ } + \item{shape}{ ~~Describe \code{shape} here~~ } + \item{xbnds}{ ~~Describe \code{xbnds} here~~ } + \item{ybnds}{ ~~Describe \code{ybnds} here~~ } + \item{xlab}{ ~~Describe \code{xlab} here~~ } + \item{ylab}{ ~~Describe \code{ylab} here~~ } +} +\details{ + There is also a \code{\link[methods]{coerce}} method to produce + \code{hexbinList} objects from \code{\link{list}}s. + %% i.e., \code{as(list(....), "hexbinList")} should work +} +\value{ + + If it is a LIST, use + \item{comp1 }{Description of 'comp1'} + \item{comp2 }{Description of 'comp2'} + ... +} + +\author{Nicholas Lewin-Koh} +% \note{ ~~further notes~~ } + +\seealso{\code{\link{hexbin}}, \code{\link{hdiffplot}} } +\examples{ + +} +\keyword{dplot} +\keyword{misc} diff --git a/man/hexMA.loess.Rd b/man/hexMA.loess.Rd new file mode 100644 index 0000000..4f25d19 --- /dev/null +++ b/man/hexMA.loess.Rd @@ -0,0 +1,42 @@ +\name{hexMA.loess} +\alias{hexVP.loess} +\alias{hexMA.loess} +\title{Add Loess Fit to Hexplot } +\description{ + Fit a loess line using the hexagon centers of mass as the x and y + coordinates and the cell counts as weights. +} +\usage{ +hexMA.loess(pMA, span = 0.4, col = "red", n = 200) +hexVP.loess(hbin, hvp = NULL, span = 0.4, col = "red", n = 200) +} + +\arguments{ + \item{hbin}{an object of class \code{hexbin}, see \code{\link{hexbin}}.} + \item{hvp}{A \code{hexViewport} object.} + \item{pMA}{the list returned by \code{\link{plotMAhex}}.} + \item{span}{the parameter alpha which controls the degree of smoothing.} + \item{col}{line color for the loess fit.} + \item{n}{number of points at which the fit should be evaluated.} +} +\value{ + Returns invisibly the object associated with the loess fit. +} + +\author{Nicholas Lewin-Koh } + +\seealso{ \code{\link{hexVP.abline}}, \code{\link{plotMAhex}}, + \code{\link{gplot.hexbin}}, \code{\link{hexViewport}}; + \code{\link{loess}} +} +\examples{ + if(require(marray)){ + data(swirl) + %% the following had 'newpage = FALSE, ' -- why ?? + hb <- plotMAhex(swirl[,1], main = "M vs A plot with hexagons", legend=0) + hexVP.abline(hb$plot, h=0, col= gray(.6)) + hexMA.loess(hb) + } +} +\keyword{aplot} + diff --git a/man/hexTapply.Rd b/man/hexTapply.Rd new file mode 100644 index 0000000..159b624 --- /dev/null +++ b/man/hexTapply.Rd @@ -0,0 +1,58 @@ +\name{hexTapply} +\alias{hexTapply} + +\title{Apply function to data from each hexagon bin.} + +\description{ + A wrapper for tapply except that it operates with each hexagon bin + being the category. The function operates on the data associated on + the points from each bin. +} + +\usage{ +hexTapply(hbin, dat, FUN = sum, ..., simplify=TRUE) +} +\arguments{ + \item{hbin}{a object of class \code{"hexbin"}, typically produced by + \code{\link{hexbin}(*)}.} + \item{dat}{A vector of data the same length as \code{hbin@cID}} + \item{FUN}{the function to be applied. In the case of functions like + \code{+}, \code{\%*\%}, etc., the function name must be quoted. If + \code{FUN} is \code{NULL}, tapply returns a vector which can be used + to subscript the multi-way array \code{tapply} normally produces.} + \item{\dots}{optional arguments to \code{FUN}.} + \item{simplify}{If \code{FALSE}, \code{tapply} always returns an array + of mode \code{"list"}. If \code{TRUE} (the default), then if + \code{FUN} always returns a scalar, \code{tapply} returns an array + with the mode of the scalar.} +} +\details{ + This function is a wrapper for tapply, except that the cell id is + always the categorical variable. This function is specifically good for + adding variables to the cAtt slot of a hexbin object or for plotting + a third variable in a hexagon plot. See below for examples. +} + +\value{ + Returns a vector of the result of 'FUN' as in + \code{\link{tapply}}. See \code{\link{tapply}} for detailed + description of output. +} + +\author{Nicholas Lewin-Koh} +\seealso{ \code{\link{tapply}},\code{\link{hexbin}} } +\examples{ + data(NHANES) + hbin<-hexbin(log(NHANES$Diet.Iron+1),log(NHANES$BMI),xbins=25,IDs=TRUE) + hvp<-plot(hbin) + mtrans<-hexTapply(hbin,NHANES$Transferin,median,na.rm=TRUE) + pushHexport(hvp$plot.vp) + grid.hexagons(hbin,style='lattice',pen=0,border='red',use.count=FALSE, +cell.at=mtrans) + + + +} +\keyword{dplot} +\keyword{utilities}% at least one, from doc/KEYWORDS + diff --git a/man/hexVP-class.Rd b/man/hexVP-class.Rd new file mode 100644 index 0000000..5c7041e --- /dev/null +++ b/man/hexVP-class.Rd @@ -0,0 +1,71 @@ +\name{hexVP-class} +\docType{class} +\alias{hexVP-class} +\alias{getFig,hexVP-method} +\alias{getMargins,hexVP-method} +\alias{getPlt,hexVP-method} +\alias{getXscale,hexVP-method} +\alias{getYscale,hexVP-method} + +\title{Formal class "hexVP" of a Hexagon Viewport} +\description{ + Hexagon Viewports are \dQuote{value-added} grid viewports (see + \code{\link[grid]{viewport}}) where the extra slots contain scaling and + \dQuote{embedding} information. A hexViewport is created my taking the + available area in the cuurent viewport on the graphics device and + maximizing the amount of area with a fied aspect ratio. The default + when the shape parameter is 1, is a 1:1 aspect ratio in terms of the + size of the viewport, not the scale of the x and y axis. The plotting + area is centered within the existing margins and the maximum size + determined. Extra area is then allocated to the margins. This viewport + is replicated twice, once with clipping set to "on" and once with + clipping "off". This feature can be used for toggling clipping on and + off while editing the plot. +} +\section{Objects from the Class}{ + Objects are typically created by calls to \code{\link{hexViewport}()} + or by low level calls of the form \code{new("hexVP", ...)}. +} +\section{Slots}{ + \describe{ + \item{\code{hexVp.off}:}{Object of class \code{"viewport"} with + clipping set to off, see \code{\link[grid]{viewport}}.} + \item{\code{hexVp.off}:}{Object of class \code{"viewport"}, with the same + dimensions and parameters as hexVp.off, but with + clipping set to on, see \code{\link[grid]{viewport}}.} + \item{\code{mar}:}{\code{\link[grid]{unit}} vector of four margins + (typically in \code{"lines"}).} + \item{\code{fig}:}{\code{\link[unit]{unit}} vector of two figure sizes + (typically in \code{"npc"}).} + \item{\code{plt}:}{\code{\link[grid]{unit}} vector of two figure sizes + (typically in \code{"npc"}).} + %% MM {FIXME?}: Is n't this simply ``xlim'' - then call it so! + %% NL, yes it is, but xscale and yscale is the parameters used by grid. + \item{\code{xscale}:}{numeric of length two specifying x-range.} + \item{\code{yscale}:}{numeric of length two specifying y-range.} + } +} +\section{Methods}{ + These are methods accessing the slots of corresponding name. + \describe{ + \item{getFig}{\code{signature(hvp = "hexVP")}: ... } + \item{getMargins}{\code{signature(hvp = "hexVP")}: ... } + \item{getPlt}{\code{signature(hvp = "hexVP")}: ... } + \item{getXscale}{\code{signature(hvp = "hexVP")}: ... } + \item{getYscale}{\code{signature(hvp = "hexVP")}: ... } + } +} +\author{ + Nicholas Lewin-Koh \email{kohnicho@comp.nus.edu.sg}. +} +\seealso{ + The constructor function \code{\link{hexViewport}}. + \code{\link{hexbin}}, and its S4 plotting method, + \code{\link{gplot.hexbin}}. +} +\examples{ + example(hexViewport, echo=FALSE) + ## continued: + str(P$plot.vp) +} +\keyword{classes} diff --git a/man/hexVP.abline.Rd b/man/hexVP.abline.Rd new file mode 100644 index 0000000..2873760 --- /dev/null +++ b/man/hexVP.abline.Rd @@ -0,0 +1,47 @@ +\name{hexVP.abline} +\alias{hexVP.abline} +\title{Add a Straight Line to a HexPlot} +\description{ + This function adds one or more straight lines through the current + plot; it is the hexbin version of \code{\link[graphics]{abline}()}. +} +\usage{ +hexVP.abline(hvp, a = NULL, b = NULL, h = numeric(0), v = numeric(0), + col = "black", lty = 1, lwd = 2, \dots) +} +\arguments{ + \item{hvp}{A hexViewport object that is currently on the active device} + \item{a,b}{the intercept and slope or if \code{b} is \code{NULL}, + an \code{lm} object or a vector of length 2 with + \code{c(intercept,slope)}} + \item{h}{the y-value for a horizontal line.} + \item{v}{the x-value for a vertical line.} + \item{col, lty, lwd}{line color, type and width.} + \item{\dots}{further graphical parameters.} +} +\details{ + The first form specifies the line in intercept/slope form + (alternatively \code{a} can be specified on its own and is taken to + contain the slope and intercept in vector form). + + The \code{h=} and \code{v=} forms draw horizontal and vertical + lines at the specified coordinates. + + The \code{coef} form specifies the line by a vector containing the + slope and intercept. + + \code{lm} is a regression object which contains \code{reg$coef}. If it is + of length 1 then the value is taken to be the slope of a line + through the origin, otherwise, the first 2 values are taken to be + the intercept and slope. +} +\author{Nicholas Lewin-Koh} + +\seealso{\code{\link{gplot.hexbin}}, \code{\link{hexViewport}}, + \code{\link{hexMA.loess}} +} +\examples{ +%% FIXME: add some +} +\keyword{aplot} + diff --git a/man/hexViewport.Rd b/man/hexViewport.Rd new file mode 100644 index 0000000..a1956cc --- /dev/null +++ b/man/hexViewport.Rd @@ -0,0 +1,56 @@ +\name{hexViewport} +\alias{hexViewport} +\title{Compute a Grid Viewport for Hexagon / Hexbin Graphics} +\description{ + Builds a \code{grid} viewport for hexagon or \code{\link{hexbin}} + graphics. This builds on the concepts of the \pkg{grid} package, + see \code{\link[grid]{viewport}}. +} +\usage{% see ../R/hexViewport.R +hexViewport(x, offset = unit(0,"inches"), mar = NULL, + xbnds = NULL, ybnds = NULL, newpage = FALSE, + clip = "off", vp.name = NULL) +} +\arguments{ + \item{x}{a \code{\link{hexbin}} object.} + \item{offset}{a \code{\link[grid]{unit}} object.} + \item{mar}{margins as \code{\link[grid]{unit}}s, of length 4 or 1.} + \item{xbnds, ybnds}{bounds for x- and y- plotting range; these default + to the corresponding slots of \code{x}.} + \item{newpage}{logical indicating if a new graphics page should be + openend, i.e., \code{\link[grid]{grid.newpage}()}.} + \item{clip}{simply passed to \code{\link[grid]{viewport}()}.} + \item{vp.name}{name of viewport; defaults to random name.} +} +\details{ + %... +} +\value{ + an S4 object of class \code{"hexVP"}, see \link{hexVP-class} for more, + with its main slot \code{hexVp} a \code{\link[grid]{viewport}} for grid graphics. +} + +\seealso{\code{\link[grid]{viewport}} and the main + \emph{\dQuote{handlers}} \code{\link{pushHexport}} and + \code{\link[grid]{popViewport}}; further + \code{\link{gplot.hexbin}} and \code{\link{hboxplot}} which build on + \code{hexViewport}. +} +\examples{ +set.seed(131) +x <- rnorm(7777) +y <- rt (7777, df=3) + +## lower resolution binning and overplotting with counts +bin <- hexbin(x,y,xbins=25) +P <- plot(bin) +xy <- hcell2xy(bin) +pushHexport(P$plot.vp) +i <- bin@count <= 3 +grid.text(as.character(bin@count[i]), xy$x[i], xy$y[i], + default.units = "native") +grid.points(x[1:20],y[1:20]) # to show some points rather than counts +popViewport() +} +\keyword{hplot}% ? +\keyword{aplot} diff --git a/man/hexbin.Rd b/man/hexbin.Rd new file mode 100644 index 0000000..293abe6 --- /dev/null +++ b/man/hexbin.Rd @@ -0,0 +1,110 @@ +\name{hexbin} +\title{Bivariate Binning into Hexagon Cells} +\alias{hexbin} +\alias{hexbin-class} +\alias{integer or NULL-class} +\alias{show,hexbin-method} +\alias{summary,hexbin-method} +\description{ + Creates a \code{"hexbin"} object. Basic components are a cell id and + a count of points falling in each occupied cell. + + Basic methods are \code{\link[methods]{show}()}, \code{plot()} %(\link{plot.hexbin}) + and \code{\link{summary}()}, but also \code{\link{erode}}. + % .. \code{\link{smooth.hexbin}} +} +\usage{ +hexbin(x, y, xbins = 30, shape = 1, + xbnds = range(x), ybnds = range(y), + xlab = NULL, ylab = NULL, IDs = FALSE) +} +\arguments{ + \item{x, y}{vectors giving the coordinates of the bivariate data + points to be binned. Alternatively a single plotting structure can + be specified: see \code{\link[grDevices]{xy.coords}}. \code{\link{NA}}'s are + allowed and silently omitted.} + \item{xbins}{the number of bins partitioning the range of xbnds.} + \item{shape}{the \emph{shape} = yheight/xwidth of the plotting regions.} + \item{xbnds, ybnds}{horizontal and vertical limits of the binning + region in x or y units respectively; must be numeric vector of length 2.} + \item{xlab, ylab}{optional character strings used as labels for + \code{x} and \code{y}. If \code{NULL}, sensible defaults are used.} + \item{IDs}{logical indicating if the individual cell \dQuote{IDs} + should be returned, see also below.} +} +\value{ + an S4 object of class \code{"hexbin"}. + It has the following slots: + \item{cell}{vector of cell ids that can be mapped into the (x,y) + bin centers in data units.} + \item{count}{vector of counts in the cells.} + \item{xcm}{The x center of mass (average of x values) for the cell.} + \item{ycm}{The y center of mass (average of y values) for the cell.} + \item{xbins}{ number of hexagons across the x axis. hexagon inner + diameter =diff(xbnds)/xbins in x units} + \item{shape}{plot shape which is yheight(inches) / xwidth(inches)} + \item{xbnds}{x coordinate bounds for binning and plotting} + \item{ybnds}{y coordinate bounds for binning and plotting} + \item{dimen}{The i and j limits of cnt treated as a matrix cnt[i,j]} + \item{n}{number of (non NA) (x,y) points, i.e., \code{sum(* @count)}.} + \item{ncells}{number of cells, i.e., \code{length(* @count)}, etc} + \item{call}{the function call.} + \item{xlab, ylab}{character strings to be used as axis labels.} + \item{cID}{of class, \code{"integer or NULL"}, only if \code{IDs} + was true, an integer vector of length \code{n} where + \code{cID[i]} is the cell number of the i-th original point + \code{(x[i], y[i])}. Consequently, the \code{cell} and \code{count} + slots are the same as the \code{\link{names}} and entries of + \code{table(cID)}, see the example.} +} + +\seealso{ + \code{\link{hcell2xy}}%, \code{\link{hcell}}, +% FIXME + \code{\link{gplot.hexbin}},% \code{\link{hboxplot}}, +% \code{\link{hdiffplot}}, \code{\link{hmatplot}}, + \code{\link{grid.hexagons}}, \code{\link{grid.hexlegend}}. +} + +\references{ + Carr, D. B. et al. (1987) + Scatterplot Matrix Techniques for Large \eqn{N}. + \emph{JASA} \bold{83}, 398, 424--436. +} + +\details{ + Returns counts for non-empty cells only. The plot shape must be maintained for + hexagons to appear with equal sides. Some calculations are in single + precision. + + Note that when plotting a \code{hexbin} object, the + \pkg{grid} package is used. + You must use its graphics (or those from package \pkg{lattice} if you + know how) to add to such plots. +} + +\examples{ +set.seed(101) +x <- rnorm(10000) +y <- rnorm(10000) +(bin <- hexbin(x, y)) +## or +plot(hexbin(x, y + x*(x+1)/4), + main = "(X, X(X+1)/4 + Y) where X,Y ~ rnorm(10000)") + +## Using plot method for hexbin objects: +plot(bin, style = "nested.lattice") + +hbi <- hexbin(y ~ x, xbins = 80, IDs= TRUE) +str(hbi) +tI <- table(hbi@cID) +stopifnot(names(tI) == hbi@cell, + tI == hbi@count) + +## NA's now work too: +x[runif(6, 0, length(x))] <- NA +y[runif(7, 0, length(y))] <- NA +hbN <- hexbin(x,y) +summary(hbN) +} +\keyword{dplot} diff --git a/man/hexbinplot.Rd b/man/hexbinplot.Rd new file mode 100644 index 0000000..fe0b5a2 --- /dev/null +++ b/man/hexbinplot.Rd @@ -0,0 +1,222 @@ +\name{hexbinplot} +\alias{hexbinplot} +\alias{hexbinplot.formula} +\alias{panel.hexbinplot} +\alias{prepanel.hexbinplot} +\alias{hexlegendGrob} +\title{Trellis Hexbin Displays} +\description{ + + Display of hexagonally binned data, as implemented in the + \code{hexbin} packge, under the Trellis framework, with associated + utilities. \code{hexbinplot} is the high level generic function, with + the \code{"formula"} method doing the actual work. + \code{prepanel.hexbinplot} and \code{panel.hexbinplot} are associated + prepanel and panel functions. \code{hexlegendGrob} produces a + suitable legend. + +} +\usage{ + +hexbinplot(x, data, \dots) + +\method{hexbinplot}{formula}(x, data = NULL, + prepanel = prepanel.hexbinplot, + panel = panel.hexbinplot, + groups = NULL, + aspect = "xy", + trans = NULL, + inv = NULL, + colorkey = TRUE, + \dots, + maxcnt, + legend = NULL, + legend.width = TRUE, + subset) + +prepanel.hexbinplot(x, y, type = character(0), \dots) + +panel.hexbinplot(x, y, ..., groups = NULL) + +hexlegendGrob(legend = 1.2, + inner = legend / 5, + cex.labels = 1, + cex.title = 1.2, + style = "colorscale", + minarea = 0.05, maxarea = 0.8, + mincnt = 1, maxcnt, + trans = NULL, inv = NULL, + colorcut = seq(0, 1, length = 17), + density = NULL, border = NULL, pen = NULL, + colramp = function(n) { LinGray(n,beg = 90,end = 15) }, + \dots, + vp = NULL, + draw = FALSE) + + +} +\arguments{ + \item{x}{ For \code{hexbinplot}, the object on which method dispatch + is carried out. + + For the \code{"formula"} methods, a formula describing the form of + conditioning plot. Formulas that are valid for \code{xyplot} are + acceptable. + + In \code{panel.hexbinplot}, the x variable. + } + \item{y}{ In \code{panel.hexbinplot}, the y variable. } + + \item{data}{For the \code{formula} method, a data frame containing + values for any variables in the formula, as well as \code{groups} + and \code{subset} if applicable (using \code{groups} currently + causes an error with the default panel function). By default, the + environment where the function was called from is used. } + + \item{minarea, maxarea, mincnt, maxcnt, trans, inv, colorcut, density, + border, pen, colramp, style}{ see + \code{\link[hexbin:gplot.hexbin]{gplot.hexbin}} } + + \item{prepanel, panel, aspect}{ See + \code{\link[lattice]{xyplot}}. \code{aspect="fill"} is not + allowed. The current default of \code{"xy"} may not always be the + best choice, often \code{aspect=1} will be more reasonable. } + + \item{colorkey}{logical, whether a legend should be drawn. Currently + a legend can be drawn only on the right. } + + \item{legend.width, legend}{ width of the legend in inches when + \code{style} is \code{"nested.lattice"} or + \code{"nested.centroids"}. The name \code{legend.width} is used to + avoid conflict with the standard trellis argument \code{legend}. It + is possible to specify additional legends using the \code{legend} or + \code{key} arguments as long as they do not conflict with the + hexbin legend (i.e., are not on the right). } + + \item{inner}{ Inner radius in inches of hexagons in the legend when + \code{style} is \code{"nested.lattice"} or + \code{"nested.centroids"}. } + + \item{cex.labels, cex.title}{ in the legend, multiplier for numeric + labels and text annotation respectively } + + \item{type}{ character vector controlling additional augmentation of + the display. A \code{"g"} in \code{type} adds a reference grid, + \code{"r"} adds a regression line (y on x), \code{"smooth"} adds a + loess smooth } + \item{draw}{ logical, whether to draw the legend grob. Useful when + \code{hexlegendGrob} is used separately } + \item{vp}{ grid viewport to draw the legend in } + + \item{\dots}{ extra arguments, passed on as appropriate. Arguments to + \code{\link[hexbin:gplot.hexbin]{gplot.hexbin}}, + \code{\link[lattice]{xyplot}}, \code{panel.hexbinplot} and + \code{hexlegendGrob} can be supplied to the high level + \code{hexbinplot} call. + + \code{panel.hexbinplot} calls one of two (unexported) low-level + functions depending on whether \code{groups} is supplied (although + specifying \code{groups} currently leads to an error). Arguments of + the appropriate function can be supplied; some important ones are + + \describe{ + + \item{\code{xbins}:}{ number of hexagons covering x values. The + number of y-bins depends on this, the aspect ratio, and + \code{xbnds} and \code{ybnds}} + + \item{\code{xbnds, ybnds}:}{ Numeric vector specifying range of + values that should be covered by the binning. In a multi-panel + display, it is not necessarily a good idea to use the same + bounds (which along with \code{xbins} and the aspect ratio + determine the size of the hexagons) for all panels. For + example, when data is concentrated in small subregions of + different panels, more detail will be shown by using smaller + hexagons covering those regions. To control this, \code{xbnds} + and \code{ybnds} can also be character strings \code{"panel"} or + \code{"data"} (which are not very good names and may be changed + in future). In the first case, the bounds are taken to be the + limits of the panel, in the second case, the limits of the data + (packet) in that panel. Note that all panels will have the same + limits (enough to cover all the data) by default if + \code{relation="free"} in the standard trellis argument + \code{scales}, but not otherwise.} + + } + + } + + \item{groups}{ in \code{hexbinplot}, a grouping variable that is + evaluated in \code{data}, and passed on to the panel function. } + + \item{subset}{ an expression that is evaluated in evaluated in + \code{data} to produce a logical vector that is used to subset the + data before being used in the plot. } + +} +\details{ + + The panel function \code{panel.hexbinplot} creates a hexbin object + from data supplied to it and plots it using + \code{\link[hexbin:grid.hexagons]{grid.hexagons}}. To make panels + comparable, all panels have the same \code{maxcnt} value, by default + the maximum count over all panels. This default value can be + calculated only if the aspect ratio is known, and so + \code{aspect="fill"} is not allowed. The default choice of aspect + ratio is different from the choice in \code{hexbin} (namely, + \code{1}), which may sometimes give better results for multi-panel + displays. \code{xbnds} and \code{ybnds} can be numeric range vectors + as in \code{hexbin}, but they can also be character strings specifying + whether all panels should have the same bins. If they are not, then + bins in different panels could be of different sizes, in which case + \code{style="lattice"} and \code{style="centroids"} should be + interpreted carefully. + + + The dimensions of the legend and the size of the hexagons therein are + given in absolute units (inches) by \code{legend.width} and + \code{inner} only when \code{style} is \code{"nested.lattice"} or + \code{"nested.centroids"}. For other styles, the dimensions of the + legend are determined relative to the plot. Specifically, the height + of the legend is the same as the height of the plot (the panel and + strip regions combined), and the width is the minimum required to fit + the legend in the display. This is different in some ways from the + \code{hexbin} implementation. In particular, the size of the hexagons + in the legend are completely unrelated to the sizes in the panels, + which is pretty much unavoidable because the sizes need not be the + same across panels if \code{xbnds} or \code{ybnds} is \code{"data"}. + The size of the hexagons encode information when \code{style} is + \code{"lattice"} or \code{"centroids"}, consequently a warning is + issued when a legend is drawn with wither of these styles. + +} + +\value{ + \code{hexbinplot} produces an object of class \code{"trellis"}. The + code{update} method can be used to update components of the object and + the \code{print} method (usually called by default) will plot it on an + appropriate plotting device. \code{hexlegendGrob} produces a + \code{"grob"} (grid object). + +} +\author{ Deepayan Sarkar \email{deepayan@stat.wisc.edu}} +\seealso{ + \code{\link{hexbin}}, \code{\link[lattice]{xyplot}} +} + +\examples{ +mixdata <- + data.frame(x = c(rnorm(5000),rnorm(5000,4,1.5)), + y = c(rnorm(5000),rnorm(5000,2,3)), + a = gl(2, 5000)) +hexbinplot(y ~ x, mixdata, aspect = 1, + trans = sqrt, inv = function(x) x^2) +hexbinplot(y ~ x | a, mixdata) +hexbinplot(y ~ x | a, mixdata, style = "lattice", + xbnds = "data", ybnds = "data") +hexbinplot(y ~ x | a, mixdata, style = "nested.centroids") +hexbinplot(y ~ x | a, mixdata, style = "nested.centroids", + border = FALSE, type = c("g", "smooth")) +} + +\keyword{dplot} diff --git a/man/hexplom.Rd b/man/hexplom.Rd new file mode 100644 index 0000000..dec71f6 --- /dev/null +++ b/man/hexplom.Rd @@ -0,0 +1,95 @@ +\name{hexplom} +\title{Hexbin Plot Matrices} +\alias{hexplom} +\alias{hexplom.formula} +\alias{hexplom.data.frame} +\alias{hexplom.matrix} +\alias{panel.hexplom} + +\usage{ +hexplom(x, data, \dots) + +\method{hexplom}{formula}(x, data = NULL, \dots) + +\method{hexplom}{data.frame}(x, data = NULL, \dots, groups = NULL, subset = TRUE) + +\method{hexplom}{matrix}(x, data = NULL, \dots, groups = NULL, subset = TRUE) + +panel.hexplom(\dots) +} + +\description{ + \code{hexplom} draws Conditional Hexbin Plot Matrices. It is similar + to \code{splom}, expect that the default display is different. + Specifically, the default display is created using + \code{panel.hexplom}, which is an alias for \code{panel.hexbinplot}. +} + +\arguments{ + \item{x}{ + The object on which method dispatch is carried out. + + For the \code{"formula"} method, a formula describing the structure + of the plot, which should be of the form \code{~ x | g1 * g2 * + \dots}, where \code{x} is a data frame or matrix. Each of \code{g1, + g2, \dots} must be either factors or shingles. The conditioning + variables \code{g1, g2, \dots} may be omitted. + + For the \code{data.frame} and \code{matrix} methods, a data frame or + matrix as appropriate. + } + \item{data}{ + For the \code{formula} method, an optional data frame in which + variables in the formula (as well as \code{groups} and + \code{subset}, if any) are to be evaluated. By default, the + environment where the function was called from is used. + } + + \item{groups, subset, \dots}{ see \code{\link[lattice]{splom}}. The + non-standard evaluation of \code{groups} and \code{subset} only + applies in the \code{formula} method. Apart from arguments that + apply to \code{splom} (many of which are only documented in + \code{\link[lattice]{xyplot}}), additional arguments meant for + \code{panel.hexplom} (which is an alias for + \code{\link{panel.hexbinplot}}) may also be supplied. Such + arguments may include ones that control details of the hexbin + calculations, documented in \code{\link{gplot.hexbin}}} + +} +\value{ + + An object of class \code{"trellis"}. The + \code{\link[lattice:update.trellis]{update}} method can be used to + update components of the object and the + \code{\link[lattice:print.trellis]{print}} method (usually called by + default) will plot it on an appropriate plotting device. + +} + +\seealso{ + \code{\link[lattice]{splom}}, \code{\link[lattice]{xyplot}}, + \code{\link[lattice]{hexbinplot}}, + \code{\link[lattice]{Lattice}}, \code{\link[lattice]{panel.pairs}} +} + +\author{ Deepayan Sarkar \email{Deepayan.Sarkar@R-project.org}, + Nicholas Lewin-Koh \email{nikko@hailmail.net}} + +\examples{ + +## Simple hexplom +data(NHANES) +hexplom(~NHANES[,7:14], xbins=15) + +## With colors and conditioning +hexplom(~NHANES[,9:13] | Sex, data = NHANES, + xbins = 15, colramp = magent) + +## With custom panel function +hexplom(NHANES[,9:13], xbins = 20,colramp = BTY, + upper.panel = panel.hexboxplot) + + +} +\keyword{hplot} + diff --git a/man/hexpolygon.Rd b/man/hexpolygon.Rd new file mode 100644 index 0000000..1c3a181 --- /dev/null +++ b/man/hexpolygon.Rd @@ -0,0 +1,77 @@ +\name{hexpolygon} +\alias{hexpolygon} +\alias{hexcoords} +\title{Hexagon Coordinates and Polygon Drawing} +\description{ + Simple \sQuote{low-level} function for computing and drawing hexagons. + Can be used for \sQuote{grid} (package \pkg{grid}) or + \sQuote{traditional} (package \pkg{graphics}) graphics. +} +\usage{ +hexcoords(dx, dy = NULL, n = 1, sep = NULL) + +hexpolygon(x, y, hexC = hexcoords(dx, dy, n = 1), dx, dy = NULL, + fill = 1, border = 0, hUnit = "native", ...) +} +\arguments{ + \item{dx,dy}{horizontal and vertical width of the hexagon(s).} + \item{n}{number of hexagon \dQuote{repeats}.} + \item{sep}{separator value to be put between coordinates of different + hexagons. The default, \code{NULL} doesn't use a separator.} + \item{x,y}{numeric vectors of the same length specifying the hexagon + \emph{centers} around which to draw.} + \item{hexC}{a list as returned from \code{hexcoords()}. + Its component \code{no.sep} determines if grid or traditional + graphics are used. The default (via default of \code{hexcoords}) is + now to use grid graphics.} + \item{fill,border}{passed to \code{\link[grid]{grid.polygon}} (for \pkg{grid}).} + \item{hUnit}{string or \code{NULL} determining in which units (x,y) + values are.} + \item{\dots}{further arguments passed to \code{\link{polygon}} (for + \pkg{graphics}).} +} +\value{ + \code{hexcoords()} returns a list with components + \item{x,y}{numeric vectors of length \eqn{n \times 6}{n * 6} (or + \eqn{n \times 7}{n * 7} if \code{sep} is not NULL) + specifying the hexagon polygon coordinates (with \code{sep} appended + to each 6-tuple).} + \item{no.sep}{a logical indicating if \code{sep} was \code{NULL}.} + + \code{hexpolygon} returns what its last \code{\link[grid]{grid.polygon}(.)} + or \code{\link{polygon}(.)} call returns. +} +\author{Martin Maechler, originally.} +\seealso{\code{\link{grid.hexagons}} which builds on these.} +\examples{ +str(hexcoords(1, sep = NA)) # multiple of (6 + 1) +str(hexcoords(1, sep = NULL))# no separator -> multiple of 6 +\dontshow{ +stopifnot(3 * (6+1) == sapply(hexcoords(2, n = 3, sep = NA)[1:2], length), + 6 == sapply(hexcoords(1)[1:2], length)) +set.seed(1001) +} + +## hexpolygon()s: +x <- runif(20, -2, 2) +y <- x + rnorm(20) + +## 1) traditional 'graphics' +plot(x,y, asp = 1, "plot() + hexpolygon()") +hexpolygon(x,y, dx = 0.1, density = 25, col = 2, lwd = 1.5) + +## 2) "grid" : + +addBit <- function(bnds, f = 0.05) bnds + c(-f, f) * diff(bnds) +sc <- addBit(rxy <- range(x,y))# same extents (cheating asp=1) +grid.newpage() +pushViewport(plotViewport(.1+c(4,4,2,1), xscale = sc, yscale = sc)) +grid.rect() +grid.xaxis() +grid.yaxis() +grid.points(x,y) +hexpolygon(x,y, hexcoords(dx = 0.1, sep=NULL), border = "blue", fill=NA) +popViewport() +} +\keyword{dplot} +\keyword{aplot} diff --git a/man/hsmooth-methods.Rd b/man/hsmooth-methods.Rd new file mode 100644 index 0000000..ee8185a --- /dev/null +++ b/man/hsmooth-methods.Rd @@ -0,0 +1,28 @@ +\name{hsmooth-methods} +\docType{methods}% + generic -- still use this doctype ? +\alias{hsmooth}% generic +\alias{hsmooth-methods} +\alias{hsmooth,hexbin-method} +\title{Hexagon Bin Smoothing: Generic hsmooth() and Methods} +\description{ + Methods for the generic function \code{hsmooth} in package + \pkg{hexbin}: + There is currently only the one for \code{\link{hexbin}} objects. +} +\usage{ +\S4method{hsmooth}{hexbin}(bin, wts) +} +\arguments{ + \item{bin}{a \code{\link{hexbin}} object, or an extension such as + \code{\link{erodebin-class}}.} + \item{wts}{weights vector, see \code{\link{smooth.hexbin}}} +} +\section{Methods}{ + \describe{ + \item{bin = "hexbin"}{is just the \code{\link{smooth.hexbin}} + function (for back compatibility); see its documentation, also for + examples.} + } +} +\keyword{methods} + diff --git a/man/inout.hex.Rd b/man/inout.hex.Rd new file mode 100644 index 0000000..307e051 --- /dev/null +++ b/man/inout.hex.Rd @@ -0,0 +1,31 @@ +\name{inout.hex} +\alias{inout.hex} +\title{Check points for inclusion} +\description{ + Check which points are in hexagons with \code{count} <= mincnt. +} +\usage{ +inout.hex(hbin, mincnt) +} + +\arguments{ + \item{hbin}{an object of class \code{\link{hexbin}}.} + \item{mincnt}{Cutoff, id's for counts less than mincnt are returned} +} +\details{ + Check which points are in hexagons with \code{count} <= mincnt and + returns the row ids for those points. One can use the ids to plot low + ount hexagons as points instead. +} +\value{ + A vector with the row ids of points which fall in hexagons with + \code{count} less than or equal to mincnt +} + +\author{Nicholas Lewin-Koh} + + +\seealso{\code{\link{plotMAhex}}} + +\keyword{misc} + diff --git a/man/list2hexList.Rd b/man/list2hexList.Rd new file mode 100644 index 0000000..ab40823 --- /dev/null +++ b/man/list2hexList.Rd @@ -0,0 +1,25 @@ +\name{list2hexList} +\alias{list2hexList} +\title{Convert list to hexList} +\description{ + Converts a list of hexbin objects with same xbnds, ybnds, shape and + xbins to a \code{\link{hexList}} object. +} +\usage{ +list2hexList(binlst) +} +\arguments{ + \item{binlst}{A list of hexbin objects} +} + +\value{ + a \code{\link{hexList}} object +} + +\author{Nicholas Lewin-Koh} + + +\seealso{\code{\link{hexList}},\code{\link{hdiffplot}} } + +\keyword{misc} + diff --git a/man/old-classes.Rd b/man/old-classes.Rd new file mode 100644 index 0000000..efec494 --- /dev/null +++ b/man/old-classes.Rd @@ -0,0 +1,24 @@ +\name{old-classes} +\title{Class "unit" and "viewport" as S4 classes} +% +\docType{class} +\alias{unit-class} +\alias{viewport-class} +% +\description{Package "hexbin" now uses S4 classes throughout and hence + needs to \code{\link[methods]{setOldClass}} both \code{"unit"} and + \code{"viewport"} (which are S3 classes from the \pkg{grid} package), + in order to be able to use those in slots of its own classes. +} +\section{Objects from the Class}{A virtual Class: No objects may be + created from it.} +\section{Extends}{ + Class \code{"oldClass"}, directly. +} +\section{Methods}{ + No methods defined with class "unit" in the signature. +} +% \seealso{ +% add link to grid ?? +% } +\keyword{classes} diff --git a/man/optShape.Rd b/man/optShape.Rd new file mode 100644 index 0000000..973d950 --- /dev/null +++ b/man/optShape.Rd @@ -0,0 +1,49 @@ +\name{optShape} +\alias{optShape} +%- Also NEED an '\alias' for EACH other topic documented here. +\title{Optimal Shape Parameter for Hexbin Viewport} +\description{ + Takes a viewport or a given height and width and returns the shape + parameter that will fill the specified plotting region with the + appropriately shaped hexagons. If margins are specified the margins + are subtracted from height and width before the shape parameter is + specified. +} +\usage{ +optShape(vp, height = NULL, width = NULL, mar = NULL) +} +\arguments{ + \item{vp}{a \code{viewport} object, optional see details} + \item{height}{the height of the plotting region, can be numeric or units} + \item{width}{The width of the plotting region, can be numeric or units} + \item{mar}{A four element numeric or units vector describing the + margins in the order \code{c(bottom, left, top, right)}} +} +\value{ + a scalar numeric value specifiyng \code{shape}. +} +\author{Nicholas Lewin-Koh} +\section{Warning}{If a viewport is given as an argument it should + already be pushed on the graphics device or it will have null units + and a meaningless shape parameter will be returned. +} +\seealso{\code{\link{hexViewport}}, \code{\link{hexVP-class}}, + \code{\link{hexbin}}} +\examples{ +x <- rgamma(10000,.9) +m <- as.logical(rbinom(10000,1,.17)) +x[m] <- -x[m] +y <- rnorm(x,abs(x)) +vp <- plotViewport(xscale= range(x)+c(-.5,.5), + yscale= range(y)+c(-.5,.5), + default.units = "native") +grid.newpage() +pushViewport(vp) +grid.rect() +shape <- optShape(vp) +shape +hb <- hexbin(x,y,xbins=40,shape=shape) +grid.hexagons(hb,colramp=BTY) +} +\keyword{dplot} + diff --git a/man/panel.hexboxplot.Rd b/man/panel.hexboxplot.Rd new file mode 100644 index 0000000..870c566 --- /dev/null +++ b/man/panel.hexboxplot.Rd @@ -0,0 +1,49 @@ +\name{panel.hexboxplot} +\alias{panel.hexboxplot} +\title{Boxplot for hexbin lattice plot} +\description{ +A panel function to add a boxplot to a hexbin lattice plot. +} +\usage{ +panel.hexboxplot(x, y, xbins = 30, + xbnds = c("data", "panel"), ybnds = c("data", "panel"), + .prelim = FALSE, .cpl = current.panel.limits(), + .xlim = .cpl$xlim, .ylim = .cpl$ylim, + .aspect.ratio, type = character(0), cdfcut = 0.25, + shadow = 0.05, ..., check.erosion = TRUE) +} +\arguments{ + \item{x, y}{numeric vector or factor.} + \item{xbins}{the number of bins partitioning the range of xbnds.} + \item{xbnds, ybnds}{horizontal and vertical limits of the binning + region in x or y units respectively; must be numeric vector of + length 2.} + \item{.prelim, .cpl, .xlim, .ylim, .aspect.ratio}{for internal use.} + \item{type}{character vector controlling additional augmentation of + the display. A \code{"g"} in \code{type} adds a reference grid, an + \code{"hg"} adds a hexagonal grid.} + \item{cdfcut}{number in (0,1) indicating the confidence level for the + erosion limits. See \code{\link{erode.hexbin}} for more information.} + \item{shadow}{number in (0,1) indicating the confidence level for the + erosion limits of a boxplot shadow. See \code{\link{erode.hexbin}} + for more information.} + \item{\dots}{potential further arguments passed on.} + \item{check.erosion}{logical indicating only eroded points should be + used for \code{"erodebin"} objects; simply passed to + \code{\link{hcell2xy}}, see its documentation.} +} +\value{ + There is no return value from this function. The results are plotted on + the current active device. +} +\author{Nicholas Lewin-Koh \email{nikko@hailmail.net}} +\seealso{\code{\link{hexbinplot}}, \code{\link{panel.hexgrid}}, + \code{\link[lattice]{panel.boxplot}} +} +\examples{ +mixdata <- + data.frame(x = c(rnorm(5000),rnorm(5000,4,1.5)), + y = rep(1:2, 5000)) +hexbinplot(y ~ x, mixdata, panel = panel.hexboxplot) +} +\keyword{hplot} diff --git a/man/panel.hexgrid.Rd b/man/panel.hexgrid.Rd new file mode 100644 index 0000000..41ad9e7 --- /dev/null +++ b/man/panel.hexgrid.Rd @@ -0,0 +1,25 @@ +\name{panel.hexgrid} +\alias{panel.hexgrid} +\title{Hexagonal grid for a lattice plot} +\description{ +A panel function to add a hexagonal grid to a lattice plot. +} +\usage{ +panel.hexgrid(h, border = grey(0.85)) +} + +\arguments{ + \item{h}{an object of class \code{hexbin}.} + \item{border}{a color for the hexagon border colors} +} +\details{ +} +\value{ + There is no return value from this function. The results are plotted on + the current active device. +} +\author{Nicholas Lewin-Koh \email{nikko@hailmail.net}} +\seealso{\code{\link{hexbinplot}}, \code{\link{hexGraphPaper}}} +\examples{ +} +\keyword{hplot} diff --git a/man/panel.hexloess.Rd b/man/panel.hexloess.Rd new file mode 100644 index 0000000..bbf13d4 --- /dev/null +++ b/man/panel.hexloess.Rd @@ -0,0 +1,39 @@ +\name{panel.hexloess} +\alias{panel.hexloess} +\title{Loess line for hexbin lattice plot} +\description{ +A panel function to add a loess line to a hexbin lattice plot. +} +\usage{ +panel.hexloess(bin, w = NULL, span = 2/3, degree = 1, family = c("symmetric", "gaussian"), evaluation = 50, + lwd = add.line$lwd, lty = add.line$lty, col, col.line = add.line$col, \dots) +} +\arguments{ + \item{bin}{an object of class \code{hexbin}.} + \item{w}{optional counts for object \code{bin}.} + \item{span}{smoothness parameter for \code{loess}.} + \item{degree}{degree of local polynomial used.} + \item{family}{if \code{"gaussian"} fitting is by least-squares, and + if \code{"symmetric"} a re-descending M-estimator is used.} + \item{evaluation}{number of points at which to evaluate the smooth curve.} + \item{lwd}{line weight graphical parameter.} + \item{lty}{line type graphical parameter.} + \item{col}{same as \code{col.line}.} + \item{col.line}{line color graphical parameter.} + \item{\dots}{optional arguments to \code{\link[stats]{loess.control}}.} +} +\details{ +} +\value{ + There is no return value from this function. The results are plotted on + the current active device. +} +\author{Nicholas Lewin-Koh \email{nikko@hailmail.net}} +\seealso{ +\code{\link{hexbinplot}}, \code{\link{panel.hexgrid}}, +\code{\link[stats]{loess.smooth}}, \code{\link[stats]{loess.control}}, +\code{\link[lattice]{panel.loess}} +} +\examples{ +} +\keyword{hplot} diff --git a/man/plotMAhex.Rd b/man/plotMAhex.Rd new file mode 100644 index 0000000..04f4c13 --- /dev/null +++ b/man/plotMAhex.Rd @@ -0,0 +1,133 @@ +\name{plotMAhex} +\alias{plotMAhex} +\title{MA-plot using hexagon bins} +\description{ + Creates an MA-plot using hexagons with color/glyph coding for control spots. +} +\usage{ +plotMAhex(MA, array = 1, xlab = "A", ylab = "M", + main = colnames(MA)[array], xlim = NULL, ylim = NULL, + status = NULL, values, pch, col, cex, nbin = 40, + zero.weights = FALSE, style = "colorscale", legend = 1.2, + lcex = 1, minarea = 0.04, maxarea = 0.8, mincnt = 2, + maxcnt = NULL, trans = NULL, inv = NULL, colorcut = NULL, + border = NULL, density = NULL, pen = NULL, + colramp = function(n) { LinGray(n, beg = 90, end = 15) }, + newpage = TRUE, type = c("p", "l", "n"), + xaxt = c("s", "n"), yaxt = c("s", "n"), + verbose = getOption("verbose")) +} +\arguments{ + \item{MA}{an \code{RGList}, \code{MAList} or \code{MArrayLM} object, + or any list with components \code{M} containing log-ratios and + \code{A} containing average intensities. Alternatively a + \code{matrix}, \code{Affybatch} or \code{ExpressionSet} object.} + \item{array}{integer giving the array to be plotted. Corresponds to + columns of \code{M} and \code{A}.} + \item{xlab, ylab, main}{character strings giving label for x-axis, + y-axis or main tile of the plot.} + \item{xlim, ylim}{numeric vectors of length 2 giving limits for x-axis + (or y-axis respectively), defaulting to min and max of the data.} + \item{status}{character vector giving the control status of each spot + on the array, of same length as the number of rows of \code{MA$M}. + If omitted, all points are plotted in the default color, symbol and size.} + \item{values}{character vector giving values of \code{status} to be + highlighted on the plot. Defaults to unique values of \code{status}. + Ignored if there is no \code{status} vector.} + \item{pch}{vector or list of plotting characters. Default to integer code 16. + Ignored is there is no \code{status} vector.} + \item{col}{numeric or character vector of colors, of the same length + as \code{values}. Defaults to \code{1:length(values)}. Ignored if + there is no \code{status} vector.} + \item{cex}{numeric vector of plot symbol expansions, of the the same + length as \code{values}. Defaults to 0.2 for the most common status + value and 1 for the others. Ignored if there is no \code{status} vector.} + \item{nbin}{ ~~Describe \code{nbin} here~~ } %% << FIXME + \item{zero.weights}{logical, should spots with zero or negative + weights be plotted?} + \item{style}{string specifying the style of hexagon plot, + see \code{\link{grid.hexagons}} for the possibilities.} + \item{legend}{numeric width of the legend in inches of \code{FALSE}. + In the latter case, or when \code{0}, no legend is not produced.} + \item{lcex}{characters expansion size for the text in the legend.} + \item{minarea}{fraction of cell area for the lowest count.} + \item{maxarea}{fraction of the cell area for the largest count.} + \item{mincnt}{cells with fewer counts are ignored.} + \item{maxcnt}{cells with more counts are ignored.} + \item{trans}{\code{\link{function}} specifying a transformation for + the counts such as \code{sqrt}.} + \item{inv}{the inverse transformation of \code{trans}.} + \item{colorcut}{vector of values covering [0, 1] that determine + hexagon color class boundaries and hexagon legend size boundaries. + Alternatively, an integer (\code{<= maxcnt}) specifying the + \emph{number} of equispaced colorcut values in [0,1].} + \item{border, density, pen}{color for polygon borders and filling of + each hexagon drawn, passed to \code{\link{grid.hexagons}}.} + \item{colramp}{function accepting an integer \code{n} as an argument and + returning n colors.} + \item{newpage}{should a new page start?} + \item{type, xaxt, yaxt}{strings to be used (when set to \code{"n"}) for + suppressing the plotting of hexagon symbols, or the x- or y-axis, + respectively.} + \item{verbose}{logical indicating if some diagnostic output should happen.} +} + +\details{ + An MA-plot is a plot of log-intensity ratios (M-values) versus + log-intensity averages (A-values). If \code{MA} is an \code{RGList} or + \code{MAList} then this function produces an ordinary within-array + MA-plot. If \code{MA} is an \code{MArrayLM} object, then the plot is an + fitted model MA-plot in which the estimated coefficient is on the y-axis + and the average A-value is on the x-axis. + + If \code{MA} is a \code{matrix} or \code{ExpressionSet} object, then this + function produces a between-array MA-plot. In this case the A-values in + the plot are the average log-intensities across the arrays and the + M-values are the deviations of the log-intensities for the specified + array from the average. If there are more than five arrays, then the + average is computed robustly using medians. With five or fewer arrays, + it is computed by means. + + The \code{status} vector is intended to specify the control status of + each spot, for example "gene", "ratio control", "house keeping gene", + "buffer" and so on. The vector is usually computed using the function + \code{\link[limma]{controlStatus}} from package \pkg{limma} and a + spot-types file. However the function may be used to highlight any + subset of spots. + + The arguments \code{values}, \code{pch}, \code{col} and \code{cex} + can be included as attributes to \code{status} instead of being + passed as arguments to \code{plotMA}. + + See \code{\link[graphics]{points}} for possible values for \code{pch}, + \code{col} and \code{cex}. +} + +\value{ + A plot is created on the current graphics device. + and a list with the following items is returned invisibly: + \item{plot.vp}{the \code{\link{hexViewport}} constructed and used.} + \item{legend.vp}{if a legend has been produced, its + \code{\link[grid]{viewport}}.} + \item{hbin}{a \code{hexbin} object built with A as the x coordinate + and M as the y coordinate.} +} + +\references{See \url{http://www.statsci.org/micrarra/refs/maplots.html}} + +\author{Nicholas Lewin-Koh, adapted from code by Gordon Smyth} + +\seealso{\code{\link[limma]{plotMA}} from package \pkg{limma}, + and \code{\link{gplot.hexbin}}. +} + +\examples{ + if(require(marray)){ %% for the data only --> data(swirl, package="marray") + data(swirl) + hb <- plotMAhex(swirl[,1],newpage=FALSE, + main = "M vs A plot with hexagons", legend=0) + hexVP.abline(hb$plot.vp,h=0,col=gray(.6)) + hexMA.loess(hb) + } +} +\keyword{hplot} diff --git a/man/pushHexport.Rd b/man/pushHexport.Rd new file mode 100644 index 0000000..da4db31 --- /dev/null +++ b/man/pushHexport.Rd @@ -0,0 +1,28 @@ +\name{pushHexport} +\alias{pushHexport} +\title{Push a Hexagon Viewport ("hexVP")} +\description{ + Push a Hexagon Viewport (\code{"hexVP"}, see \link{hexVP-class}) on to + the tree of (grid) viewports, calling \code{\link[grid]{pushViewport}}. +} +\usage{ +pushHexport(hvp, clip = "off") +} +\arguments{ + \item{hvp}{a hexagon viewport, i.e., an object of class + \code{"hexVP"}, see \link{hexVP-class}, typically produced by + \code{\link{hexViewport}(..)}.} + \item{clip}{which viewport to push, either 'on' or 'off' are the + allowed arguments, see details.} +} +\seealso{the underlying \code{\link[grid]{pushViewport}} from the + \pkg{grid} package. +} +\details{ + A hexagon viewport (\code{"hexVP"}) object has slots for two replicate + viewports one with clipping turned on and one with clipping off. This + allows toggling the clipping option. +} +%\examples{ +%} +\keyword{dplot} diff --git a/man/smooth.hexbin.Rd b/man/smooth.hexbin.Rd new file mode 100644 index 0000000..92adc21 --- /dev/null +++ b/man/smooth.hexbin.Rd @@ -0,0 +1,84 @@ +\name{smooth.hexbin} +\alias{smooth.hexbin} +\alias{smoothbin-class} +\title{Hexagon Bin Smoothing} +\description{ + Given a \code{"hexbin"} (hexagon bin) object, compute a discrete + kernel smoother that covers seven cells, namely a center cell and its + six neighbors. With two iterations the kernel effectively covers + 1+6+12=19 cells. +} +\usage{ +smooth.hexbin(bin, wts=c(48,4,1)) +} +\arguments{ + \item{bin}{object of class \code{"hexbin"}, typically resulting from + \code{\link{hexbin}()} or \code{\link{erode,hexbin-method}}.} + \item{wts}{numeric vector of length 3 for relative weights of the + center, the six neighbor cells, and twelve second neighbors.} +} +\value{ + an object of class \code{"smoothbin"}, extending class + \code{"hexbin"}, see \code{\link{hexbin}}. + The object includes the additional slot \code{wts}. +} +\references{see \code{\link{grid.hexagons}} and \code{\link{hexbin}}.} + +\details{ + This discrete kernel smoother uses the center cell, immediate + neighbors and second neighbors to smooth the counts. The counts for + each resulting cell is a linear combination of previous cell counts + and weights. The weights are + \tabular{ll}{ + 1 center cell, \tab weight = wts[1]\cr + 6 immediate neighbors\tab weight = wts[2]\cr + 12 second neighbors \tab weight =wts[3]\cr + } + If a cell, its immediate and second neighbors all have a value of + \code{max(cnt)}, the new maximum count would be + \code{max(cnt)*sum(wts)}. It is possible for the counts to overflow. + + The domain for cells with positive counts increases. The hexbin + slots \code{xbins}, \code{xbnds}, \code{ybnds}, and \code{dimen} all + reflect this increase. + Note that usually \code{dimen[2] = xbins+1}. + + The intent was to provide a fast, iterated, immediate neighbor smoother. + However, the current hexbin plotting routines only support shifting + even numbered rows to the right. Future work can + + (1) add a shift indicator to hexbin objects that indicates left or + right shifting.\cr + (2) generalize plot.hexbin() and hexagons()\cr + (3) provide an iterated kernel.\cr + + With \code{wts[3]=0}, the smoother only uses the immediate neighbors. + With a shift indicator the domain could increase by 2 rows (one bottom + and on top) and 2 columns (one left and one right). However the current + implementation increases the domain by 4 rows and 4 columns, thus + reducing plotting resolution. +} + +\seealso{ + \code{\link{hexbin}}, \code{\link{erode.hexbin}}, %MISSING \code{\link{hthin}}, + \code{\link{hcell2xy}},% \code{\link{hcell}}, + \code{\link{gplot.hexbin}}, \code{\link{hboxplot}}, + %\code{\link{hdiffplot}}, \code{\link{hmatplot}}, + \code{\link{grid.hexagons}}, \code{\link{grid.hexlegend}}. +} +\examples{ +x <- rnorm(10000) +y <- rnorm(10000) +bin <- hexbin(x,y) +# show the smooth counts in gray level +smbin <- smooth.hexbin(bin) +plot(smbin, main = "smooth.hexbin(.)") + +# Compare the smooth and the origin +smbin1 <- smbin +smbin1@count <- as.integer(ceiling(smbin@count/sum(smbin@wts))) +plot(smbin1) +smbin2 <- smooth.hexbin(bin,wts=c(1,0,0)) # expand the domain for comparability +plot(smbin2) +} +\keyword{misc} diff --git a/src/hbin.f b/src/hbin.f new file mode 100644 index 0000000..00737b3 --- /dev/null +++ b/src/hbin.f @@ -0,0 +1,88 @@ + subroutine hbin(x,y,cell,cnt,xcm,ycm, size, shape, + * rx,ry, bnd, n, cellid) + +C Copyright 1991 +C Version Date: September 16, 1994 +C Programmer: Dan Carr +C Indexing: Left to right, bottom to top +C bnd(1) rows, bnd(2) columns +C Output: cell ids for non empty cells, revised bnd(1) + +c optionally also return cellid(1:n) +c Copyright (2004) Nicholas Lewin-Koh and Martin Maechler + + implicit none + + integer n, nc, cell(*), cnt(*), bnd(2), cellid(*) +c cellid(*): length 1 or n + double precision x(n), y(n), xcm(*),ycm(*), rx(2),ry(2), size + double precision shape + integer i, i1, i2, iinc + integer j1, j2, jinc + integer L, lmax, lat + double precision c1, c2, con1, con2, dist1 + double precision sx, sy, xmin, ymin, xr, yr + logical keepID + + keepID = (cellid(1) .eq. 0) +C_______Constants for scaling the data_____________________________ + + xmin = rx(1) + ymin = ry(1) + xr = rx(2)-xmin + yr = ry(2)-ymin + c1 = size/xr + c2 = size*shape/(yr*sqrt(3.)) + + jinc= bnd(2) + lat=jinc+1 + iinc= 2*jinc + lmax=bnd(1)*bnd(2) + con1=.25 + con2=1.0/3.0 + +C_______Binning loop________________________________________ + + do i=1,n + sx = c1 * (x(i) - xmin) + sy = c2 * (y(i) - ymin) + j1 = sx+.5 + i1 = sy+.5 + dist1=(sx-j1)**2 + 3.*(sy-i1)**2 + + if(dist1 .lt. con1) then + L=i1*iinc + j1+1 + elseif(dist1 .gt. con2) then + L=int(sy)*iinc + int(sx)+lat + else + j2 = sx + i2 = sy + if(dist1 .le. (sx-j2 -.5)**2 + 3.*(sy-i2 -.5)**2) then + L=i1*iinc+ j1+1 + else + L=i2*iinc+ j2+lat + endif + endif + + cnt(L)=cnt(L)+1 + if (keepID) cellid(i)=L + xcm(L)=xcm(L)+ (x(i)-xcm(L))/cnt(L) + ycm(L)=ycm(L)+ (y(i)-ycm(L))/cnt(L) + enddo + +C_______Compression of output________________________________________ + + nc=0 + do L=1,lmax + if(cnt(L) .gt. 0) then + nc=nc+1 + cell(nc)=L + cnt(nc)=cnt(L) + xcm(nc)=xcm(L) + ycm(nc)=ycm(L) + endif + enddo + n=nc + bnd(1)=(cell(nc)-1)/bnd(2)+1 + return + end diff --git a/src/hcell.f b/src/hcell.f new file mode 100644 index 0000000..2d6c78b --- /dev/null +++ b/src/hcell.f @@ -0,0 +1,62 @@ + subroutine hcell(x,y,cell,n,size,shape,rx,ry,bnd) +C Copyright 1991 +C Version Date: September 16, 1994 +C Programmer: Dan Carr +C Indexing: Left to right, bottom to top +C bnd(1) rows, bnd(2) columns +C Output: cell ids for none empty cells, revised bnd(1) + +c implicit none + integer n, cell(1), bnd(2) + double precision x(1), y(1), rx(2), ry(2), size, shape + integer i, i1, i2, iinc + integer j1, j2, jinc + integer L, lat, celmax + double precision c1, c2, con1, con2, dist1 + double precision sx, sy, xmin, ymin, xr, yr + +C_______Constants for scaling the data_____________________________ + + xmin = rx(1) + ymin = ry(1) + xr = rx(2)-xmin + yr = ry(2)-ymin + c1 = size/xr + c2 = size*shape/(yr*sqrt(3.)) + + jinc= bnd(2) + lat=jinc+1 + iinc= 2*jinc + con1=.25 + con2=1./3. + celmax=0 + +C_______Binning loop________________________________________ + + do i=1,n + sx = c1 * (x(i) - xmin) + sy = c2 * (y(i) - ymin) + j1 = sx+.5 + i1 = sy+.5 + dist1=(sx-j1)**2 + 3.*(sy-i1)**2 + + if(dist1.lt.con1)then + L=i1*iinc+j1+1 + elseif(dist1.gt.con2)then + L=int(sy)*iinc + int(sx)+lat + else + j2 = sx + i2 = sy + if( dist1.le.(sx-j2-.5)**2 + 3. * (sy - i2 -.5)**2) then + L=i1*iinc+j1+1 + else + L=i2*iinc+j2+lat + endif + endif + + cell(i)=L + celmax = max(celmax,L) + enddo + bnd(1)=(celmax-1)/bnd(2)+1 + return + end diff --git a/src/herode.f b/src/herode.f new file mode 100644 index 0000000..4945513 --- /dev/null +++ b/src/herode.f @@ -0,0 +1,245 @@ +C File: herode.f +C Version date: Jan 4, 1994 +C Programmer: Daniel B. Carr +C +C The vector erode returns the gray-level erosion order for hexagon cells. +C The erosion cycle is: +C cycle = (erode-1)/6 + 1 +C Many cells may be eroded in the same cycle +C A tie break is the cell count deficit at erosion time: +C deficit=erode - 6*cycle +C The last eroded cell might be considered a bivariate median +C +C The algorithm: +C Repeat until no cells are left in the list. +C Process list +C Reduce the cell counts by the a multiple of exposed sides +C If a cell count is zero or less after an erosion cycle +C let order=order + 6 +C report erode = order + cell count (count is <= 0) +C remove the cell from consideration +C update exposed side counts for existing neighbor cells +C if exposed sides was zero, temporarily store id's +C else +C compress list +C endif +C Add temporarily stored id's to list +C End Repeat + + subroutine herode(cell,cnt,n,bdim, + * erode,ncnt,ncell,sides,neib,exist) + +C +C + implicit none + + integer cell(1), cnt(1) ! cell id and count + integer n, bdim(2) ! number of cells and 2-D array bounds + integer erode(1) ! erosion status + integer ncell(1),ncnt(1) ! extracted id's and expanded counts + integer sides(1) ! number of exposed sides + integer neib(6,*) ! pointers to the neighbors + logical exist(0:*) ! cell existence + + integer nrow, ncol, Lmax ! dimensions + integer inc1(6), inc2(6) ! increments to get neighbors + integer i, icell, j, k, L ! subscripts + integer nc, nnc, nb, ninc, r, c !more subscripts + integer loop, order, maxcnt + + +C_______Zero cell ordering numbers________________________________ + + order=0 + +C_______Load the increment arrays and constants + + nrow = bdim(1) + ncol = bdim(2) + Lmax = nrow * ncol + nnc = n + +C______Load increment arrays to neigbors______________ +C +C order=right, up left, down left, up right, left, down right + + inc1(1)= 1 + inc1(2)= ncol-1 + inc1(3)= -ncol-1 + inc1(4)= ncol + inc1(5)=-1 + inc1(6)= -ncol + + inc2(1)= 1 + inc2(2)= ncol + inc2(3)= -ncol + inc2(4)= ncol+1 + inc2(5)=-1 + inc2(6)= -ncol+1 + + +c_______load working arrays_______________________________________________ + + do i=0,Lmax + exist(i)=.false. + enddo + + maxcnt=0 + do i=1,n + icell=cell(i) + ncnt(icell)=cnt(i) + exist(icell)=.true. + maxcnt=max(maxcnt,cnt(i)) + enddo + +C_______Store pointers to cell neighbors_________________________ +C +C A pointer of 0 means the neigbor in out of bounds +C Also find the max count +C Speed: Can avoid adding 1's to r and c +C but this code is easier to follow + do i=1,n + L=cell(i) + k = L -1 + r=k/ncol+1 + c=mod(k,ncol)+1 + if(mod(r,2).eq.1)then + do j = 1,6 + neib(j,L) = L + inc1(j) + enddo + + if (c .eq. 1) then + neib(2,L) = 0 + neib(3,L) = 0 + neib(5,L) = 0 + else if (c .eq. ncol) then + neib(1,L) = 0 + endif + + if (r .eq. 1) then + neib(3,L) = 0 + neib(6,L) = 0 + else if(r.eq.nrow)then + neib(2,L) = 0 + neib(4,L) =0 + endif + + else + do j= 1,6 + neib(j,L) = L + inc2(j) + enddo + + if (c .eq. 1) then + neib(5,L) = 0 + else if (c .eq. ncol) then + neib(1,L) = 0 + neib(4,L) = 0 + neib(6,L) = 0 + endif + + if (r .eq. nrow) then + neib(2,L) = 0 + neib(4,L) = 0 + endif + + endif + enddo + + +C_______Count exposed sides for cells in the contour_________________ + + do i=1,n + icell=cell(i) + sides(icell)=0 + do j=1,6 + if(.not. exist( neib(j,icell) ) )then + sides(icell)=sides(icell)+ 1 + endif + enddo + enddo + +C________Grab surface cells___________________________________________ + + nc=0 + do i=1,n + if(sides(cell(i)).gt.0)then + nc=nc+1 + ncell(nc)=cell(i) + endif + enddo + n=nc !n is now the number of exposed, non-empty cells + +C_______The outer loop________________________________________________ +C +C temporary indices +C nc: index for cells remaining on the list +C ninc: index for newly exposed cells added to back of list + + do while(n.gt.0) + +C Subtract exposed-side counts from the surface cell counts +C until at least one cell is empty. + + loop=maxcnt + do i=1,n + icell=ncell(i) + loop=min( (ncnt(icell)-1)/sides(icell) , loop) + enddo + loop=loop+1 !all loop values are 1 too small + +C update the counts, rank and remove eroded cells + + nc=0 + order=order+6 + ninc=n + do i=1,n + icell=ncell(i) + ncnt(icell)=ncnt(icell)-sides(icell)*loop + if(ncnt(icell).le.0)then + +C Remove the empty cell and store it's order + exist(icell)=.false. + erode(icell)=order+ncnt(icell) + +C Update the neighbors of the empty cell + do j=1,6 + nb=neib(j,icell) + if(exist(nb))then + +C Store cells for addition to surface list + if(sides(nb).eq.0)then + ninc=ninc+1 + ncell(ninc)=nb + endif + +C Update sides for the neighbors + sides(nb)=sides(nb)+1 + endif + enddo + else + +C Save remaining cells + nc=nc+1 + ncell(nc)=ncell(i) + endif + enddo + +C Add new surface cells if any + + do i=n+1,ninc,1 + nc=nc+1 + ncell(nc)=ncell(i) + enddo + n=nc + enddo + +C_______compress result___________________________________________ + + + do i=1,nnc + erode(i)=erode(cell(i)) + enddo + n=nnc + + return + end diff --git a/src/hsm.f b/src/hsm.f new file mode 100644 index 0000000..b282cc0 --- /dev/null +++ b/src/hsm.f @@ -0,0 +1,114 @@ +C File: hsm.f +C Programmer: Daniel B. Carr +C Version Date: January 3, 1994 +C +C This program is an hexagon cell smoother. It smooths into +C neighboring cells and hence expands. + +C The kernal is a crude integer kernel. +C The boundary hexagons get weight 1, the center hexagon +C gets weight, wt, which by default is set to six. +C +C + + subroutine hsm(cell,cnt,n,nmax,sm,ncol,wt) + + implicit none + + integer n, nmax, ncol + integer cell(*), cnt(*), sm(*), wt(*) + integer ind, ind1(6), ind2(12),ind3(6), ind4(12), loc + integer row, cnt1, cnt2, wta, wtb, wtc + integer i, j + +C__________Constants___________________________________________ + + ind1(1)=-1 + ind1(2)=ncol-1 + ind1(3)=ncol + ind1(4)=+1 + ind1(5)=-ncol + ind1(6)=-ncol-1 + + ind2(1)=-2 + ind2(2)=ncol-2 + ind2(3)=2*ncol-1 + ind2(4)=2*ncol + ind2(5)=2*ncol+1 + ind2(6)=ncol+1 + ind2(7)=2 + ind2(8)=-ncol+1 + ind2(9)=-2*ncol+1 + ind2(10)=-2*ncol + ind2(11)=-2*ncol-1 + ind2(12)=-ncol-2 + + ind3(1)=-1 + ind3(2)=ncol + ind3(3)=ncol+1 + ind3(4)=+1 + ind3(5)=-ncol+1 + ind3(6)=-ncol + + ind4(1)=-2 + ind4(2)=ncol-1 + ind4(3)=2*ncol-1 + ind4(4)=2*ncol + ind4(5)=2*ncol+1 + ind4(6)=ncol+2 + ind4(7)=2 + ind4(8)=-ncol+2 + ind4(9)=-2*ncol+1 + ind4(10)=-2*ncol + ind4(11)=-2*ncol-1 + ind4(12)=-ncol-1 + + wta = wt(1) + wtb = wt(2) + wtc = wt(3) + +C_________Smoothing_____________________________________ + + do i=1,n + sm(cell(i))=wta*cnt(i) + enddo + + do i=1,n + loc=cell(i) + row=(loc-1)/ncol + 1 + cnt1=wtb*cnt(i) + cnt2=wtc*cnt(i) + + if(mod(row,2).eq.1)then + do j=1,6 + ind=loc+ind1(j) + sm(ind)=sm(ind)+cnt1 + enddo + do j=1,12 + ind=loc+ind2(j) + sm(ind)=sm(ind)+cnt2 + enddo + else + do j=1,6 + ind=loc+ind3(j) + sm(ind)=sm(ind)+cnt1 + enddo + do j=1,12 + ind=loc+ind4(j) + sm(ind)=sm(ind)+cnt2 + enddo + endif + enddo + + n=0 + do i=1,nmax + if(sm(i).gt.0)then + n=n+1 + cell(n)=i + cnt(n)=sm(i) + endif + enddo + return + end + + diff --git a/tests/hdiffplot.R b/tests/hdiffplot.R new file mode 100644 index 0000000..921d061 --- /dev/null +++ b/tests/hdiffplot.R @@ -0,0 +1,36 @@ +library(hexbin) + +if(R.version$major != "1" || as.numeric(R.version$minor) >= 7) + RNGversion("1.6") +set.seed(213) +x1 <- rnorm(10000) +y1 <- rnorm(10000) + +x2 <- rnorm(10000,mean = .3) +y2 <- rnorm(10000,mean = .3) + +rx <- range(x1,x2) +ry <- range(y1,y2) + +str(bin1 <- hexbin(x1,y1, xbnds = rx, ybnds = ry)) +str(bin2 <- hexbin(x2,y2, xbnds = rx, ybnds = ry)) + +str(erode(bin1)) + +str(smbin1 <- smooth.hexbin(bin1)) +(smbin2 <- smooth.hexbin(bin2)) + +str(erodebin1 <- erode.hexbin(smbin1)) +(erodebin2 <- erode.hexbin(smbin2)) + +if(FALSE)## does not work -- what funny stuff is hdiffplot() doing??? + par(mfrow = c(2,1)) + +if(exists("hdiffplot", mode="function")) { ## not yet in new hexbin +hdiffplot(bin1,bin2, main = "Original N(0,*) Random bins") + +hdiffplot(smbin1,smbin2, main = "smooth.hexbin() smoothed bins") + +plot.new() +hdiffplot(erodebin1,erodebin2, main = "erode.hexbin()d smoothed bins") +}# not yet diff --git a/tests/hdiffplot.Rout.save b/tests/hdiffplot.Rout.save new file mode 100644 index 0000000..7250a40 --- /dev/null +++ b/tests/hdiffplot.Rout.save @@ -0,0 +1,155 @@ + +R version 2.8.0 Under development (unstable) (2008-04-27 r45520) +Copyright (C) 2008 The R Foundation for Statistical Computing +ISBN 3-900051-07-0 + +R is free software and comes with ABSOLUTELY NO WARRANTY. +You are welcome to redistribute it under certain conditions. +Type 'license()' or 'licence()' for distribution details. + +R is a collaborative project with many contributors. +Type 'contributors()' for more information and +'citation()' on how to cite R or R packages in publications. + +Type 'demo()' for some demos, 'help()' for on-line help, or +'help.start()' for an HTML browser interface to help. +Type 'q()' to quit R. + +> library(hexbin) +Loading required package: grid +Loading required package: lattice +> +> if(R.version$major != "1" || as.numeric(R.version$minor) >= 7) ++ RNGversion("1.6") +Warning message: +In RNGkind("Marsaglia-Multicarry", "Buggy Kinderman-Ramage") : + Buggy version of Kinderman-Ramage generator used. +> set.seed(213) +> x1 <- rnorm(10000) +> y1 <- rnorm(10000) +> +> x2 <- rnorm(10000,mean = .3) +> y2 <- rnorm(10000,mean = .3) +> +> rx <- range(x1,x2) +> ry <- range(y1,y2) +> +> str(bin1 <- hexbin(x1,y1, xbnds = rx, ybnds = ry)) +Formal class 'hexbin' [package "hexbin"] with 16 slots + ..@ cell : int [1:535] 16 20 48 70 74 75 76 80 99 101 ... + ..@ count : int [1:535] 1 1 1 1 1 1 1 1 1 1 ... + ..@ xcm : num [1:535] 0.370 1.338 0.721 -1.846 -0.965 ... + ..@ ycm : num [1:535] -3.66 -3.71 -3.54 -3.20 -3.24 ... + ..@ xbins : num 30 + ..@ shape : num 1 + ..@ xbnds : num [1:2] -3.8 4.3 + ..@ ybnds : num [1:2] -3.71 4.17 + ..@ dimen : num [1:2] 36 31 + ..@ n : int 10000 + ..@ ncells: int 535 + ..@ call : language hexbin(x = x1, y = y1, xbnds = rx, ybnds = ry) + ..@ xlab : chr "x1" + ..@ ylab : chr "y1" + ..@ cID : NULL + ..@ cAtt : int(0) +> str(bin2 <- hexbin(x2,y2, xbnds = rx, ybnds = ry)) +Formal class 'hexbin' [package "hexbin"] with 16 slots + ..@ cell : int [1:545] 41 51 75 76 104 107 110 114 136 138 ... + ..@ count : int [1:545] 1 1 1 1 1 2 1 1 2 1 ... + ..@ xcm : num [1:545] -1.141 1.445 -0.493 -0.324 -0.995 ... + ..@ ycm : num [1:545] -3.42 -3.45 -3.24 -3.35 -2.90 ... + ..@ xbins : num 30 + ..@ shape : num 1 + ..@ xbnds : num [1:2] -3.8 4.3 + ..@ ybnds : num [1:2] -3.71 4.17 + ..@ dimen : num [1:2] 36 31 + ..@ n : int 10000 + ..@ ncells: int 545 + ..@ call : language hexbin(x = x2, y = y2, xbnds = rx, ybnds = ry) + ..@ xlab : chr "x2" + ..@ ylab : chr "y2" + ..@ cID : NULL + ..@ cAtt : int(0) +> +> str(erode(bin1)) +Formal class 'erodebin' [package "hexbin"] with 19 slots + ..@ eroded: logi [1:535] FALSE FALSE FALSE FALSE FALSE FALSE ... + ..@ cdfcut: num 0.5 + ..@ erode : int [1:71] 12 35 34 57 52 4 30 101 138 150 ... + ..@ cell : int [1:535] 16 20 48 70 74 75 76 80 99 101 ... + ..@ count : int [1:535] 1 1 1 1 1 1 1 1 1 1 ... + ..@ xcm : num [1:535] 0.370 1.338 0.721 -1.846 -0.965 ... + ..@ ycm : num [1:535] -3.66 -3.71 -3.54 -3.20 -3.24 ... + ..@ xbins : num 30 + ..@ shape : num 1 + ..@ xbnds : num [1:2] -3.8 4.3 + ..@ ybnds : num [1:2] -3.71 4.17 + ..@ dimen : num [1:2] 36 31 + ..@ n : int 10000 + ..@ ncells: int 535 + ..@ call : language hexbin(x = x1, y = y1, xbnds = rx, ybnds = ry) + ..@ xlab : chr "x1" + ..@ ylab : chr "y1" + ..@ cID : NULL + ..@ cAtt : int(0) +> +> str(smbin1 <- smooth.hexbin(bin1)) +Formal class 'smoothbin' [package "hexbin"] with 17 slots + ..@ wts : num [1:3] 48 4 1 + ..@ cell : int [1:906] 17 18 19 21 22 23 51 52 53 54 ... + ..@ count : int [1:906] 1 1 1 1 1 1 1 4 5 2 ... + ..@ xcm : num [1:535] 0.370 1.338 0.721 -1.846 -0.965 ... + ..@ ycm : num [1:535] -3.66 -3.71 -3.54 -3.20 -3.24 ... + ..@ xbins : num 34 + ..@ shape : num 1 + ..@ xbnds : num [1:2] -4.34 4.84 + ..@ ybnds : num [1:2] -4.23 4.70 + ..@ dimen : num [1:2] 40 35 + ..@ n : int 10000 + ..@ ncells: int 535 + ..@ call : language hexbin(x = x1, y = y1, xbnds = rx, ybnds = ry) + ..@ xlab : chr "x1" + ..@ ylab : chr "y1" + ..@ cID : NULL + ..@ cAtt : int(0) +> (smbin2 <- smooth.hexbin(bin2)) +'hexbin' object from call: hexbin(x = x2, y = y2, xbnds = rx, ybnds = ry) +n = 10000 points in nc = 545 hexagon cells in grid dimensions 40 by 35 +> +> str(erodebin1 <- erode.hexbin(smbin1)) +Formal class 'erodebin' [package "hexbin"] with 19 slots + ..@ eroded: logi [1:906] FALSE FALSE FALSE FALSE FALSE FALSE ... + ..@ cdfcut: num 0.5 + ..@ erode : int [1:73] 11 35 95 100 117 88 6 39 167 232 ... + ..@ cell : int [1:906] 17 18 19 21 22 23 51 52 53 54 ... + ..@ count : int [1:906] 1 1 1 1 1 1 1 4 5 2 ... + ..@ xcm : num [1:535] 0.370 1.338 0.721 -1.846 -0.965 ... + ..@ ycm : num [1:535] -3.66 -3.71 -3.54 -3.20 -3.24 ... + ..@ xbins : num 34 + ..@ shape : num 1 + ..@ xbnds : num [1:2] -4.34 4.84 + ..@ ybnds : num [1:2] -4.23 4.70 + ..@ dimen : num [1:2] 40 35 + ..@ n : int 10000 + ..@ ncells: int 535 + ..@ call : language hexbin(x = x1, y = y1, xbnds = rx, ybnds = ry) + ..@ xlab : chr "x1" + ..@ ylab : chr "y1" + ..@ cID : NULL + ..@ cAtt : int(0) +> (erodebin2 <- erode.hexbin(smbin2)) +'hexbin' object from call: hexbin(x = x2, y = y2, xbnds = rx, ybnds = ry) +n = 10000 points in nc = 545 hexagon cells in grid dimensions 40 by 35 +> +> if(FALSE)## does not work -- what funny stuff is hdiffplot() doing??? ++ par(mfrow = c(2,1)) +> +> if(exists("hdiffplot", mode="function")) { ## not yet in new hexbin ++ hdiffplot(bin1,bin2, main = "Original N(0,*) Random bins") ++ ++ hdiffplot(smbin1,smbin2, main = "smooth.hexbin() smoothed bins") ++ ++ plot.new() ++ hdiffplot(erodebin1,erodebin2, main = "erode.hexbin()d smoothed bins") ++ }# not yet +> diff --git a/tests/hray.R b/tests/hray.R new file mode 100644 index 0000000..13a9cce --- /dev/null +++ b/tests/hray.R @@ -0,0 +1,31 @@ +library(hexbin) + +set.seed(572) + +x <- rnorm(100) +y <- rnorm(100) +val <- rnorm(100) +inc <- abs(rnorm(100,sd = .3)) +loB <- val-inc +hiB <- val+inc + +if(exists("hray", mode="function")) { # 'real soon now' + +## no confidence bounds +plot(x,y,type = 'n') +hray(x,y,val) + +## confidence bounds +plot(x,y,type = 'n') +hray(x,y,val, lo = loB, hi = hiB) + +## clockwise orientation +plot(x,y,type = 'n') +hray(x,y,val, loB, hiB, clockwise = TRUE) + +## no tics and small filled dots +plot(x,y,type = 'n') +hray(x,y,val, loB, hiB, ticlength = FALSE, + dotside = 20, dotlength = .025, dotden = -1) + +} diff --git a/tests/large.R b/tests/large.R new file mode 100644 index 0000000..aa42e04 --- /dev/null +++ b/tests/large.R @@ -0,0 +1,39 @@ +library(hexbin) + +if(FALSE) { ## the following is still quite a bit from working/useful : + +## what should that do? set a palette? +rgb <- matrix(c( + 15,15,15, + + 0, 0, 0, + 1, 9,15, + 9,15, 9, + 15, 9, 9, + + 0, 0, 0, + 0, 0, 0, + 0, 0, 0, + 0, 0, 0, + 0, 0, 0, + 0, 0, 0, + + 9, 9, 9, + 0, 2, 7, + 0, 7, 1, + 8, 1, 1, + + 15, 2, 2, + 11, 1, 1, + 8, 1, 1, + 5, 1, 1, + 5, 1, 1, + 15,15,15), ncol = 3, byrow = TRUE) + +##ps.options(rasters=600,color=rgb/15,background=2) +##ps.options(color=rgb/15,background=2) +postscript("large.ps",width = 10,height = 7.5) + +plot.hexbin(ans.25mil, style = "nest", lcex = .9) + +}## FALSE, i.e. nothing done diff --git a/tests/viewp-ex.R b/tests/viewp-ex.R new file mode 100644 index 0000000..152e733 --- /dev/null +++ b/tests/viewp-ex.R @@ -0,0 +1,20 @@ +library(hexbin) + +## a variation on Nicholas' post to bioconductor & example(hexViewport) +set.seed(545) +x <- rnorm(2^15) +y <- 3*x - .2*x^2 + rnorm(2^15) +hbin <- hexbin(x,y) + +## +hp <- hexViewport(hbin, newpage = TRUE) +pushHexport(hp) +grid.rect() +grid.xaxis() +grid.yaxis() +grid.hexagons(hbin, style = "centroid") +hloess <- loess(y ~ x, data = hcell2xy(hbin), weights = hbin @ count) +xx <- seq(hbin@xbnds[1], hbin@xbnds[2], length = 500) +grid.lines(xx, predict(hloess, xx), + gp = gpar(col = 'red', lwd = 2), default.units = "native") +popViewport() diff --git a/was-R_zzz.R b/was-R_zzz.R new file mode 100755 index 0000000..a5d120c --- /dev/null +++ b/was-R_zzz.R @@ -0,0 +1,10 @@ +#Lib load function +.First.lib <- function(libname, pkgname, where) { + require(grid) + require(methods) + require(colorspace) + library.dynam("hexbin", pkgname, libname) + #where <- match(paste("package:", pkgname, sep=""), search()) + #.initClasses(where) + +}