ggplot2/ 0000755 0001751 0000144 00000000000 12114411470 011641 5 ustar hornik users ggplot2/MD5 0000644 0001751 0000144 00000051715 12114411470 012162 0 ustar hornik users a8481dde4e6366e1c98c38e25a60ce09 *DESCRIPTION
b0e2c27896c6311e1e8a06f1406d75e0 *NAMESPACE
8298f7bc3ec5ab60baac889eb6c831d6 *NEWS
cdc165b0b74d5b1cfd879769181ec510 *R/aaa-.r
dc3d3aab5c3802286ba7ad449eb6645d *R/aaa-constants.r
ae3f1d04a847f7593b3bf8836667104f *R/aes-colour-fill-alpha.r
821d0759319d37cfb974286a280c9ac5 *R/aes-group-order.r
733c7a9a947c30697e3ddb85ab08d944 *R/aes-linetype-size-shape.r
26e076e6333d7400c1603faa7781c1c1 *R/aes-position.r
2f5636b06947da866e2de3206fcf8ab0 *R/aes.r
ec76f496165349653ce58dda55ab4060 *R/annotation-custom.r
466f11d4b6932c2743166c594db6eae6 *R/annotation-logticks.r
b980276fc6b0634c3b43a20f0a2e2061 *R/annotation-map.r
fc7ae95535ec205a2fe554f0e0ef22f0 *R/annotation-raster.r
96bee574f5054fc0fbf55ebaa76cabc1 *R/annotation.r
156e572d485fde7adbff14cf0c05ce0b *R/autoplot.r
62aaf848259fcb7f4b350ff67acb990f *R/bench.r
730026efd522ee584c63c4575f6e2b51 *R/coord-.r
ab13bd1bc481f073ed166080817ea44a *R/coord-cartesian-.r
16feb9d43c4d09600f9dbd700fe50a2f *R/coord-fixed.r
cc9622bcbc7ab527f537ffec6e7088b3 *R/coord-flip.r
27cd6c317dd6caceb6acc53837f9ede9 *R/coord-map.r
3da104d697aaff354286c05f24c0b0c3 *R/coord-munch.r
ca4435bb4a62eb3c56dc4da7e86e49fb *R/coord-polar.r
6cad54068e3731a1c83fcf18e31efb64 *R/coord-transform.r
46888370c9fc6579da7e7b0879c5ab19 *R/facet-.r
9b7abe1dfbfdd87ebe4ccbb9ddd05737 *R/facet-grid-.r
6582f033d70914a7ff8a34adfc8a00d4 *R/facet-labels.r
a8bdd31838cc1dc8553493e9ca3edca8 *R/facet-layout.r
c1b757c44b4b7fb483b51396cb032000 *R/facet-locate.r
1534b4f9dae20090e0ddc7364bc72fca *R/facet-null.r
ec37671843792b0e848e43cd5d117737 *R/facet-viewports.r
afff0480da1871dd98227f22a1f4d0de *R/facet-wrap.r
b5ea8f828872428e2cd545b6a2bcaa9d *R/fortify-lm.r
eb936fc87c719c92e4cd00d2e0d3db9e *R/fortify-map.r
0781a7193e77311d3652c0a26e3ace8a *R/fortify-multcomp.r
d698473b30629cf5c2a1b4fe8fcc239d *R/fortify-spatial.r
c66a8210303d12e2fd9ae738de3c80be *R/fortify.r
84d3db481f87ff9d8a356fc70455edf7 *R/geom-.r
5ac2256187aa8389e25ced8c3654df79 *R/geom-abline.r
5f3535690fd257e85fc9830fedd98cf2 *R/geom-bar-.r
f6aabd443b95a624eeef95d10cb9a4e5 *R/geom-bar-histogram.r
f8834f3ae2b4dd73fb2f458ca386845f *R/geom-bin2d.r
6f93f7e8856b4e8f693ef36f74b2d6af *R/geom-blank.r
b7b1ba7b38b750c778b5b4d9dd60f7b6 *R/geom-boxplot.r
f89f62a4771b8235486a721e4f7edf91 *R/geom-crossbar.r
bbb969602ad4726f07b8f47e0e045f8f *R/geom-defaults.r
48520da055a141e0f40c272f660d03b0 *R/geom-dotplot.r
3427bab8fe3b8b62dc8099eed3593906 *R/geom-error.r
19bd1eb401094ce7f5be89e63650e82c *R/geom-errorh.r
9363f7e61c12375012710cac58c089cb *R/geom-freqpoly.r
5d2de1907f582a3480deff97a961bde9 *R/geom-hex.r
945f11becbafd976228fd1bb7b7955a2 *R/geom-hline.r
a89b8b5600e9d6fd98e5bdcd90b160de *R/geom-linerange.r
6897f36f55964f8286be02137e206e47 *R/geom-map.r
e3950aa2d3c3e922400efceca8a06dd7 *R/geom-path-.r
bf878d11dcb897ecef17541ea8a046bb *R/geom-path-contour.r
60e9c5e5b491d45ec0c3ab8181b1aff9 *R/geom-path-density2d.r
2dc4ab51b3c59edf1ce6a80ad242a6bd *R/geom-path-line.r
51e68049a1070d460097551d9c5458d6 *R/geom-path-step.r
ac048bc7f2741bd1cbbba7581af94dee *R/geom-point-.r
818ff3f54e006d46812a34aa8dac1160 *R/geom-point-jitter.r
c4ff344620a297654ad59fb89628818e *R/geom-pointrange.r
4b3b8102b51f97ac79f3f5b5c2c25836 *R/geom-polygon.r
bbbdea8f534809cf26b586c011d7c5ff *R/geom-quantile.r
15434417882afed1b3abddce75047c12 *R/geom-raster.r
01b8f2a9a51200c853ccd77e270ed66d *R/geom-rect.r
b364e888a1e006ad4ea8096c02b4cd99 *R/geom-ribbon-.r
56d9a7db16135a425fd37c1e7bfe4380 *R/geom-ribbon-density.r
609ff55cb6571c4c706ecb9a9df1e0e8 *R/geom-rug.r
e6c3d0257b133b328f14f6c66235f580 *R/geom-segment.r
06ee79739ea7568fc7fa409d8c525fea *R/geom-smooth.r
f13c34536947ff33c9e059f6fb44c7df *R/geom-text.r
7a312bb3081a867fcd3078491b80a3d1 *R/geom-tile.r
89fd74daef645c5aec59ba89d97f6193 *R/geom-violin.r
fbc31911c59baaddc2fa915f75914ff6 *R/geom-vline.r
c4bf756d21c84a8542fd6071de4e98e8 *R/ggplot2.r
a16f5e7db9df6da53fa0b73fd9ea6dc7 *R/grob-absolute.r
59073fb400325d5aacec56c908a62be5 *R/grob-dotstack.r
a95eedcd254245038c02583eca451496 *R/grob-null.r
6b4b5ebf999737e4788193fc421604f4 *R/guide-colorbar.r
32bcfddd0d4f788b9558de374cced279 *R/guide-legend.r
d97690d6d583e86f025be2a9429605d1 *R/guides-.r
3af4e324ffbb2bf024d90a4d98f9580e *R/guides-axis.r
ba942d2a3cac6427ad5e432d6344deec *R/guides-grid.r
c78cf3ebdfe741464530b1fd74979fcc *R/labels.r
55b65267b558cbff7ae87c8200c5b1a3 *R/layer.r
b8dc88ca7b246c1f856d97ad0dbc5894 *R/limits.r
2563cc48c409528da1a632c30d35c992 *R/matrix.r
507e7f65ffa6ab71f3f36015e3ffa773 *R/panel.r
b08a2294565e0155be791f0394db953a *R/plot-build.r
a9d6f62b2221cf9aee7342c5a5d8abd7 *R/plot-construction.r
1fe2bd58d7d34c6370ec8680bac55641 *R/plot-last.r
d44ed7cee7180f23e30d7bfb43b68557 *R/plot-render.r
898fa70042b03446748daa7d2ad1b7a9 *R/plot.r
25eecd71bdbda3dd0357f17bd40ddea6 *R/position-.r
b9725a3356cd9ad7d603ae630a7b2da9 *R/position-collide.r
3b6c1ad7cf9ab5cb52328fc2c04d330a *R/position-dodge.r
bae3978e0f907c21e26dc4aa2c929fb4 *R/position-fill.r
5f0742181315d120ef24343cc7e89915 *R/position-identity.r
fd316941e9fd8eb8537c579a3302df6d *R/position-jitter.r
87c45a8daeb86d8e415f125f763636ac *R/position-stack.r
49f635097439d8aeea4407e786796d88 *R/quick-plot.r
a50cf57f38afabcd774b149b6b63bc83 *R/save.r
aa677b621332bcbf01407ca5229dadfc *R/scale-.r
0b94bc43c9a1f19a11efcc0f9e1f7eab *R/scale-alpha.r
d2d7f41130b5a88899f9cb15cde0c2d6 *R/scale-area.r
ec2f962e810d9eaff052b39aa73b7aef *R/scale-brewer.r
e922db62ed12e535ebeadf79c72dac75 *R/scale-continuous.r
411ae283f14a9cbfaf89b450ce9295ea *R/scale-date.r
bd9a20524f0d5f728fe59d0aef7718db *R/scale-datetime.r
216ca4997f765eb174c13db53436f3dd *R/scale-discrete-.r
fd8f838856c003bc69939aea0f0aa780 *R/scale-gradient.r
e05bb9a55b15069a2ea9404b09525810 *R/scale-gradient2.r
228c009cb66c0eafdeda9e92d44db1be *R/scale-gradientn.r
bf02cee25c672069385cc20ec0c8afd6 *R/scale-grey.r
812ba631431e610c460e32be53fd4cd9 *R/scale-hue.r
ec6c426256d89a7236fa9c547bfa6b8e *R/scale-identity.r
ba7b404533f49db0b916d3e0deea7bad *R/scale-linetype.r
73941853b55fbe85ee43d514616cf278 *R/scale-manual.r
621f0c32a080738b66f290c0a7ecdf4f *R/scale-shape.r
59866fc36aa00a75c17a227c830dd106 *R/scale-size.r
5501500faea17cce988ed90e08ccad09 *R/scales-.r
913469f5bdd833a806b3f05bd06e3269 *R/stat-.r
100bcca190ae776c187a64a9d90bf392 *R/stat-bin.r
e04072f2f78615a5b2b8b9fed837069a *R/stat-bin2d.r
655a60570160ec9cbada68e0e3ca81fc *R/stat-bindot.r
72b80b2e70f00c77743d471c95d7b35a *R/stat-binhex.r
8c780eb83459452d0cf2fc7e9b289cfc *R/stat-boxplot.r
235bef1027e06ea8a0601c0784b1424c *R/stat-contour.r
bad50ec69ed8cc4b65486c7f3c1431d0 *R/stat-density-2d.r
2d4674031c3003793c49f0650cfd090d *R/stat-density.r
914a84e1cb5c26a7eabe49c5a6bfe131 *R/stat-ecdf.r
4bd724861e96053ce912ef90a9122b9c *R/stat-function.r
1aa6d8d13dd3c1ebc055dc8a15d115b5 *R/stat-identity.r
279f0e942ed40c9c3e0da7c7bf9f2431 *R/stat-qq.r
77f819801f9a9e0b2c454e7a1495178d *R/stat-quantile.r
9b03451d84893346d904947bdcb23ea2 *R/stat-smooth-methods.r
9d30760907d8d03aad7b2b9c0ea0de28 *R/stat-smooth.r
d7297e51a7ca5fc19a36205d364f8c8f *R/stat-spoke.r
96119f89a7493a8035104e66fa51ece7 *R/stat-sum.r
c9ffea7b3cd36374aba20d5069cd2a3e *R/stat-summary-2d.r
82e4a422d748d706b82ae7dba4290aa4 *R/stat-summary-hex.r
9b5cb76c8b6622182c858acd6a4ddf87 *R/stat-summary.r
7b6e46124c9b52aef0ac1d1f141638d8 *R/stat-unique.r
7b419d8ad895280d4afc810f3c319ff1 *R/stat-vline.r
b2a578fe70d950d21dfa1ee91198edae *R/stat-ydensity.r
3cd3f00683a2712f83f7343c450823ba *R/summary.r
df52bbff80d38abe06678cd140ffd9f2 *R/templates.r
1657c2eb4da3283b00f6da87b578df08 *R/theme-defaults.r
4817702b925e5aa7bcca20edb047911a *R/theme-elements.r
b4ae203e46e8dbdd3df16e281cfd42aa *R/theme.r
35bad6637d640ff42f356aa4f32d2880 *R/translate-qplot-base.r
848208d3ba4fa95b9772c30ab7719b07 *R/translate-qplot-ggplot.r
fee87f2af65cb375fde0c9e2861fe20e *R/translate-qplot-gpl.r
44c20592c21fb28a06bd6bd649c10fa0 *R/translate-qplot-lattice.r
fa4087800994bd078cf0a495b3f2f93b *R/utilities-break.r
529807804c64e4144ec5048f49660ea4 *R/utilities-grid.r
7d2253be1f20087c6d0316d0443b73b7 *R/utilities-help.r
1831f357299303b55978c2cda95b32b4 *R/utilities-layer.r
afc6431171cfd73e050e71df95bfa0dd *R/utilities-matrix.r
c7fde74a4a34021d39442b0ae7d8552d *R/utilities-resolution.r
57c5dfa7816f7df6c73f04705350ddd8 *R/utilities-table.r
5e4f767a7a86173e4ef339b664c705e1 *R/utilities.r
34d407a106599d53ab46fdd91be6eab3 *R/xxx-digest.r
610971f2b52b5165ac7e29106eff0b0a *R/zxx.r
1eaf05da9731eb13f290fba1abd4b073 *R/zzz.r
b4fab9a4162bad65843f1af6f2568dae *README.md
c5bbe13cd390f0c20a6f97dbc2c712f2 *build/partial.rdb
9cb6a35588a5dd6989b03aece1b60e03 *data/datalist
4096c2eeb1224845fc5f0e25e9974c25 *data/diamonds.rda
8985076e2ad3bed814a263e66cda6536 *data/economics.rda
3ae982c0a646d089158019dd7cff7270 *data/midwest.rda
9d8747e779836d5c6e49034c45cf8b98 *data/movies.rda
d4a17298bd70c76813a5413330c1cd23 *data/mpg.rda
1617a2dd8416c15f6d258ae6cfe2baf5 *data/msleep.rda
f11e86b50338713740fae032ed3d32bc *data/presidential.rda
401d0becb289a0ca4b041bb64e3b8aa0 *data/seals.rda
d5d8dadfa9a1796813880c6dd466051b *inst/CITATION
7a09459ca2898424c3714a03f20665fd *inst/staticdocs/footer.html
923198a65466326dfb62fec20e793e3c *inst/staticdocs/head.html
1636c128fb7de2919590069e9d19d17a *inst/staticdocs/index.r
866901e6be1bdbaba1c9c2d7b879e8dc *inst/test_ns/DESCRIPTION
b21b353b8831ab5ccca59122881140d3 *inst/test_ns/NAMESPACE
81187edd664288ddb04c48475fbcb663 *inst/test_ns/R/my-plot.r
06a9f7ef332826077bd8e50b13121112 *inst/test_ns/man/my_plot.Rd
54a5e91c31e50f11f6cfcf0a56fea081 *inst/tests/helper-plot-data.r
740526641fb432626a257d0becf6fd1a *inst/tests/test-aes-grouping.r
d238d83a85d5579410180f485ba7b7ea *inst/tests/test-aes-setting.r
38c1a42c898de0abf1f995e748276833 *inst/tests/test-aes.r
196e9a7accdbb9fb1f2e13f4aece3918 *inst/tests/test-boxplot.r
92e9538a12d82532d919860a548e00a2 *inst/tests/test-build.r
0465e5e3f7e11018338ea4bdf774ad20 *inst/tests/test-coord-polar.r
70db5dd20f4b1a8a0164cf522feec0fd *inst/tests/test-coord-train.r
8b9dd7f814320cdeb5954ce0f4292a66 *inst/tests/test-data.r
c4ec1dc18f683b9afdefb6ee82b4f5d2 *inst/tests/test-dotplot.r
1b12e4284c255e898648b3e81edee1d4 *inst/tests/test-empty-data.r
ea4aa03be81acb5157bc833e4b97365c *inst/tests/test-facet-.r
a2c0ce251e99c0b018439d607b0c7451 *inst/tests/test-facet-layout.r
827676b38f580ed2c48bbdb375962295 *inst/tests/test-facet-locate.r
0d8de00a68ac094bed41ebe50710aedf *inst/tests/test-fortify.r
6318ef949123e4e13c938ffc0e3d4010 *inst/tests/test-labels.r
df4857f8b4cb04d4846337dd0021b5e1 *inst/tests/test-qplot.r
a5c8acb60c96d7e0f7210a8c15b452b3 *inst/tests/test-scale-manual.r
369b0bf3b04cbc0d462ec7bd40f7b6ea *inst/tests/test-scales-breaks-labels.r
3d9276f75fee9feb42e5b9773568f8be *inst/tests/test-scales.r
0fd040a1a7d2ad8ddcd32b93cfe22ce4 *inst/tests/test-stats.r
640dc2d0eb7ef9a9c47129a70f1ae465 *inst/tests/test-theme.r
f3cbac27a85b4d7022031b7dfbe80e2d *inst/tests/test-utilities.r
16aeac0d13e4203be6c6677c02cb6ac9 *man/absoluteGrob.Rd
8c59bdf467a2341257524a06d12bf751 *man/add_theme.Rd
48515c5fab3181ad53687c13d3bc7728 *man/aes.Rd
7f0268389edbd543590ab20f72c4e546 *man/aes_all.Rd
2f508fdb273bacaf2882a4effcecc477 *man/aes_auto.Rd
4889de6f483e4079fac585a2a92588e9 *man/aes_colour_fill_alpha.Rd
e909864117cd52d01c932d4fa02aabdc *man/aes_group_order.Rd
d334b490b3496de05acd9c12d612dfd7 *man/aes_linetype_size_shape.Rd
eb6a3d6a8e76ebb2d8fecf1acf01771a *man/aes_position.Rd
3382823074948794bc5449627edd1ec3 *man/aes_string.Rd
e7874d09f0afd7d01e19112b4e48d319 *man/annotate.Rd
efa994a5941ffdb03dc0c954590a94d7 *man/annotation_custom.Rd
e3105bd4f1ca0256fd37b1a71b524975 *man/annotation_logticks.Rd
c440509810d49e6438a8698ec95e9ad8 *man/annotation_map.Rd
e8f45fdecf5d239f5d172c001de6aab4 *man/annotation_raster.Rd
393d6cd345f15044dbccc0fc1fbcccc8 *man/autoplot.Rd
3ce5324191cfe1f4576ef322a7ac814b *man/benchplot.Rd
33f26a4c3f709c607370b58182324866 *man/borders.Rd
0b5a8125d4bad4068151e37b446650d0 *man/calc_element.Rd
1a7fc8e2b4ddb698e1eb734a1888af7d *man/continuous_scale.Rd
d34c77ebd995ddff20015b6441396e44 *man/coord.Rd
d4560d8c1d434d6b1969c67ea6feab18 *man/coord_cartesian.Rd
198428d7c27059306765abfb1cb7e0e9 *man/coord_expand_defaults.Rd
8fe89dcc188c784453283cae8362436f *man/coord_fixed.Rd
1a92e019a78f44be33b30ea8d13dd4b5 *man/coord_flip.Rd
c21e0ae69f763926ec02d03998af01b0 *man/coord_map.Rd
4f75d31c5433fd6bbe4b1b140f2c2f30 *man/coord_polar.Rd
be90cdf6f48758df386904cb1e0340ea *man/coord_trans.Rd
cc75f9311945e00800acb2cc383b5c6e *man/cut_interval.Rd
1f083848b4454297935ed8002d432d08 *man/cut_number.Rd
7cd340627cfffd0588ec01efe119282c *man/cweave.Rd
8dffced7acdd73572b0f897495fd484f *man/diamonds.Rd
ed317052cda52383f79a6cc803ded516 *man/discrete_scale.Rd
66c51e6282fbdd4a6ea92aeeaf2f7468 *man/economics.Rd
9201d3655e0d2681d6f302acee35dd6d *man/element_blank.Rd
10dbf678e0aa4c6053010b87735fff50 *man/element_line.Rd
32d5e3ca63a01a6723bdf7dbe78ac4e6 *man/element_rect.Rd
18c93cfcc019ea5e4dca58a7ad0254d9 *man/element_text.Rd
1f4a6518a545649170b4f6630033fa47 *man/expand_limits.Rd
fc0007c0b99136ba561d5f83445f0f6c *man/facet.Rd
2ceea38d8c4982b3a5f20d52bada6636 *man/facet_grid.Rd
bd47b24e7720e45cf0e493b1708de99c *man/facet_null.Rd
f57a0979f4214aea4be33ff16a35b98e *man/facet_wrap.Rd
ad9a52790670dd0f25a8adc4b6846508 *man/fortify-multcomp.Rd
aa54f670390829f838de4a1f5f223928 *man/fortify.Rd
7b991855af7377a4e7fc5ba9019a6e5e *man/fortify.lm.Rd
d2032405c06f63e3cff901d0c2fa7285 *man/fortify.map.Rd
10e9282c972588bea0c6e1276d288c60 *man/fortify.sp.Rd
9d2de08867c752df6073a8ee84492027 *man/geom_abline.Rd
55eee75c1601c95a7171abafd0031082 *man/geom_area.Rd
716ab0e1cea0ec1efd100700d2302802 *man/geom_bar.Rd
265dcb094bb678164c6d7f2152b5c3f2 *man/geom_bin2d.Rd
7e436461f5ef6b9776042f10a3b5cea0 *man/geom_blank.Rd
444ea49a70b544baad302ef0fd7ad539 *man/geom_boxplot.Rd
315278ff76400b029d27ad4abfdec95b *man/geom_contour.Rd
e56c6035bef0da33e85937a89592f766 *man/geom_crossbar.Rd
e6812e01526f280024ec38687585e9a9 *man/geom_density.Rd
8c6bd54adf9b7efa06fe5ba7a99b77e6 *man/geom_density2d.Rd
30681808473da3e9cd672911a2587dba *man/geom_dotplot.Rd
10b44e28f18c77f272f713fb0c396521 *man/geom_errorbar.Rd
5d46766eb0de0cb23e3af6160c12ed18 *man/geom_errorbarh.Rd
1e590519dd98a717d95bc0e691efc652 *man/geom_freqpoly.Rd
9d6db3b63912b82de455be4f83d37ceb *man/geom_hex.Rd
858c1ac63ec2173db2ecc2685006d53f *man/geom_histogram.Rd
05e997f7dd5a9c4c5d4021abcfc3bf0a *man/geom_hline.Rd
8ac6dd0f01b2379c9c67c541098a6da8 *man/geom_jitter.Rd
ce9355e3a1c5e5c887c20b0fda11fae4 *man/geom_line.Rd
bb693a40276af193970e71a4b0c64913 *man/geom_linerange.Rd
9e43b2ec31c2ef9165dbdb3c593b872d *man/geom_map.Rd
354b975cea027771965b028f82b4c7bf *man/geom_path.Rd
0831ae36392538c1e60361b862debdd5 *man/geom_point.Rd
daceb836a1a8d03ae3e692ed3d21bd90 *man/geom_pointrange.Rd
847e619ce8374639d3bcc964b308c3a7 *man/geom_polygon.Rd
8ee0fe25436ad26608b8bd06408d6d7b *man/geom_quantile.Rd
18e8cbb591ac4f0e7e703be76aa6f582 *man/geom_raster.Rd
62e37a830b42d6215aa33245de5758da *man/geom_rect.Rd
976f710a3aa1b7276d7c8551ac191340 *man/geom_ribbon.Rd
0a12e30560e6d7dd0023bb56d2517d57 *man/geom_rug.Rd
b442cfc5be5a16800eb7a784ca1ad23c *man/geom_segment.Rd
5d534acaa2fa0b54e1a3eacbb4cb58d6 *man/geom_smooth.Rd
eb47dd70c3a99f23ba4aa8c4711a3d52 *man/geom_step.Rd
77a04b2deea526b2ad3a7bac8bd8ebb0 *man/geom_text.Rd
7cd3e9f99d79412b3f4c12e24a641946 *man/geom_tile.Rd
14c703c7d09ac0eaaf78185c50b34af9 *man/geom_violin.Rd
572cea5856774208823d60283d18a1c2 *man/geom_vline.Rd
143a3afcc226d7d0af5f04c8682c636e *man/gg-add.Rd
9bf0640589a09029fff3886636b758c4 *man/gg_dep.Rd
16b0138513709ece3bbd7e6e9382937c *man/ggfluctuation.Rd
7beb1db580ceb3931b981e4eede3901f *man/ggmissing.Rd
877f2848360ec22736d2239ed769f8cf *man/ggorder.Rd
a988d0bff727b0608579d65373190a4f *man/ggpcp.Rd
f151d88a6cef612dbbc21b02a35bd3d6 *man/ggplot.Rd
52513056e66e78b84f32bc44024acaac *man/ggplot.data.frame.Rd
2bbfff326c3bc5638703bf039cbf7283 *man/ggplot2.Rd
e9285c4d6200f92c1c0792280cb4a27d *man/ggplotGrob.Rd
c2ebf1d0f9d2c215314e58d280733242 *man/ggplot_build.Rd
990d440ce353930c6e6aa085ea5a07ac *man/ggplot_gtable.Rd
f15898088591e71642fe9fdd6a7cd9ef *man/ggsave.Rd
5247e8cc2e5a23b5860b81d12962e134 *man/ggscale.Rd
ad9f2cd99b9d5844774cfb09596ee0ae *man/ggstructure.Rd
152b7f161d5b89daf01b6952bc3011f8 *man/guide_colourbar.Rd
31fce153247e86fa77286c95e67cb812 *man/guide_legend.Rd
a2323fc0e4867724a619e697ac001c66 *man/guides.Rd
b7420217cb903b2dc2973961683d835c *man/hmisc.Rd
9dee3f314202d4fc488dd129caa85de5 *man/interleave.Rd
76c692c6530f2210183ac091c5a2dfac *man/is.coord.Rd
d98ad64f5a8bdcb597009121f2f373f0 *man/is.facet.Rd
60b34e72f6e6412a317f10b33a4d5775 *man/is.ggplot.Rd
8011140ccd8cec0499f1d7a24343b610 *man/is.rel.Rd
b1b68d9b22cdefbaf25beeb5247e17d7 *man/is.theme.Rd
4984e605e7bf0bad1112a5d260071ba4 *man/label_both.Rd
eb0ce6c1393f2344ad31aa73952af8f7 *man/label_bquote.Rd
587b537d6c9f4cd3b74eab03aaa4bc49 *man/label_parsed.Rd
0ed9bf4b7c87adbf38560d9a74375b7a *man/label_value.Rd
09febaf96deaa96c7b90584b22e89683 *man/labs.Rd
b29b0c31ba29e9844bffd6020c46df4b *man/last_plot.Rd
80b34a8bee023f0600ef6657014496e6 *man/layer.Rd
2762d7f21a3cf2529acbbd8745fa8ca6 *man/limits.Rd
b3a7bf62a36bfe4d3c67a03b39c8d9e8 *man/map_data.Rd
074cbad6e456988198c7467b9e4bcbcf *man/mean_se.Rd
f02c570c24918618e61d3001825b7ee2 *man/midwest.Rd
5f1e5983c574b4f66ecb8097dad02c6d *man/movies.Rd
a4806ff6d4b870c19a071532b5163fd2 *man/mpg.Rd
47b3e52794e392ed6b552a90c86e4aeb *man/msleep.Rd
34dd7a626dcd84588acdd9d3bcd501ad *man/opts.Rd
00bdbf6bae684fd888df9a9e48d0fb99 *man/plotmatrix.Rd
5bdcf97196cb9f7cc71b8ce8bfc6bd05 *man/position_dodge.Rd
559631d3055ddc145bfda74cfec500c2 *man/position_fill.Rd
ebd4285b90632ec8a6420e050173bd85 *man/position_identity.Rd
9d06805d1d827079dfe6a3238147d187 *man/position_jitter.Rd
ab4a87ca1886ab7360a28924a7a4833d *man/position_stack.Rd
ac1e91d5585340e4cc76589d88a9edc3 *man/presidential.Rd
853f2f249b83aa4a4b418a64f051f592 *man/print.ggplot.Rd
bd9566cbee356cdf513d6f619ae43681 *man/qplot.Rd
6d4350b101436d0d3f34cf78d185da57 *man/rel.Rd
0acc1392857c43b0809f1ae380613d5b *man/resolution.Rd
508d46677598b489b99bdcbbe9108087 *man/rweave.Rd
7408246a1dd45760d9415b4e8b52a637 *man/scale_alpha.Rd
6f724ca1e9c0d96bf73af017532818dc *man/scale_area.Rd
17f1b699683ac877f335fc3452c1e0b3 *man/scale_brewer.Rd
45e96c78bdfea81148bd4cf3a2e89a18 *man/scale_continuous.Rd
1beb44e296a5d1347cc266991579cf17 *man/scale_date.Rd
1cb1b47cd87d305fa777397de4b015d3 *man/scale_datetime.Rd
0daafa594ee8e5a7235819a2431fd97c *man/scale_discrete.Rd
624e7a1dfa7e44976304f97b5b1887ed *man/scale_gradient.Rd
6e657bf2b08238c4fe9ae438095c3357 *man/scale_gradient2.Rd
90b4091419fc942918e325c707a393b0 *man/scale_gradientn.Rd
6edc3841c3756b333013bc103c2f3641 *man/scale_grey.Rd
edb37737fcbfac52ab01c8706233d456 *man/scale_hue.Rd
709d463aee9bf3764e4867f3b6de8dd2 *man/scale_identity.Rd
3f2d791ea0ea8ebda0954878c986a738 *man/scale_linetype.Rd
b5c95675a9a8866736de3a10b3ccbc56 *man/scale_manual.Rd
d2a34ce18ab49428a1d12c7a3a04788b *man/scale_shape.Rd
e107c52a7a21560ee80428266f56434a *man/scale_size.Rd
d8992c12a1271ff99859005bf7a1299d *man/scale_size_area.Rd
8d0aadf97c6a1d014267ecc9360b9a36 *man/seals.Rd
4a91a098bb010e9d226007b3339465c1 *man/should_stop.Rd
95647a0ba47477d0859c160a15064f4f *man/stat_abline.Rd
d96256024cc5727a6583ae92141be514 *man/stat_bin.Rd
eb8025d57a00da47178fdb8f8c028bc6 *man/stat_bin2d.Rd
4c16af34caaf4a06b79b0d1a2c378766 *man/stat_bindot.Rd
4ade66a4a13d513ff30e6c976f6171ef *man/stat_binhex.Rd
e5e43769ffaa6fd08d71dd5f4e09af56 *man/stat_boxplot.Rd
1ba75982d7c49aba9e751bbe412fbdee *man/stat_contour.Rd
9b7dd5bd0f1661bc82dbbdda2f42e51a *man/stat_density.Rd
f608a1ba79d67c045cf194dc96415932 *man/stat_density2d.Rd
6abd9651d521e9f152508fb6f4cdd32d *man/stat_ecdf.Rd
ff2922881d62938f9eff7a4dd7cc49c3 *man/stat_function.Rd
540f7aff74ba9b2f1dc8d0bb98b53258 *man/stat_hline.Rd
a88cd92639b1584f9ec227cff4615e9e *man/stat_identity.Rd
dcb55d0b1f61443d078dcfa81e38895f *man/stat_qq.Rd
ccf706eb15987d26dcd41ec2f0e96c77 *man/stat_quantile.Rd
dfa0d475cab6b7ee010d21065ab8ecfc *man/stat_smooth.Rd
7c8be194b1a5fc6cb4d4e6207a782eee *man/stat_spoke.Rd
6690b2633df5dfb60a91904148bd1ec4 *man/stat_sum.Rd
13541ac66e18e00684fd04af8b612f73 *man/stat_summary.Rd
af49d4166c5bbcd041c1eebd7113eaf2 *man/stat_summary2d.Rd
ff969e2ff834e2ac5ff61a7be24fad43 *man/stat_summary_hex.Rd
93c6a2cf5aa5084084dcd7e630600c00 *man/stat_unique.Rd
5023474d338e73a610a2fe9606e7203b *man/stat_vline.Rd
2906bed985c4195c28e1ff133cd3aec6 *man/stat_ydensity.Rd
07450b4d2de2fa5bc07a246582fc0242 *man/summary.ggplot.Rd
fdd4abdb2bf29592e8b0c349ee4327e5 *man/theme.Rd
96930d94e0d4c65472e853b6975a9a45 *man/theme_blank.Rd
a1ec7cf071b2e250d22fa00ea24a63ab *man/theme_bw.Rd
6883032a5fd2003e825df1f5cd8a2927 *man/theme_classic.Rd
4c5517b8d019a18f4b7a9d31f69daa6e *man/theme_grey.Rd
f71863431a58e7e0f4642db6ed510bb2 *man/theme_minimal.Rd
6fae43aa64823a09e4a043676dd80f53 *man/theme_update.Rd
bea98576a0986cf8dbe47e982cb6b0bb *man/translate_qplot_base.Rd
3235f908c962515794b0ed70a06fac49 *man/translate_qplot_ggplot.Rd
e6f02c978528db770e703bddb2fbde94 *man/translate_qplot_gpl.Rd
026263dc4ac4f7319dc69ca2fe0d62e8 *man/translate_qplot_lattice.Rd
4276cbcc0e0dc0d32834c5adb4ac3a7d *man/update_defaults.Rd
89baa2be7add4ce5410160291522ce84 *man/update_element.Rd
f0731588d00937d08b2afd2e88e5add2 *man/update_labels.Rd
cd642e034911fdead3ebe9cec3cce622 *man/waiver.Rd
e868504746796454f51864acba92cc63 *man/xylim.Rd
4ca881973a6a28f78ee623155eddd9f1 *man/zeroGrob.Rd
18ce871dfe61dcdd288c02929f1b55d7 *tests/test-all.R
ggplot2/inst/ 0000755 0001751 0000144 00000000000 12114161113 012612 5 ustar hornik users ggplot2/inst/staticdocs/ 0000755 0001751 0000144 00000000000 12114161113 014752 5 ustar hornik users ggplot2/inst/staticdocs/head.html 0000644 0001751 0000144 00000002035 12114161113 016541 0 ustar hornik users
{{pagetitle}}. {{#package}}{{package}} {{version}}{{/package}}
ggplot2/inst/staticdocs/index.r 0000644 0001751 0000144 00000043072 12114161113 016252 0 ustar hornik users library(staticdocs)
list(
readme = "",
index = list(
sd_section("Geoms",
"Geoms, short for geometric objects, describe the type of plot you will produce.",
c(
"geom_abline",
"geom_area",
"geom_bar",
"geom_bin2d",
"geom_blank",
"geom_boxplot",
"geom_contour",
"geom_crossbar",
"geom_density",
"geom_density2d",
"geom_dotplot",
"geom_errorbar",
"geom_errorbarh",
"geom_freqpoly",
"geom_hex",
"geom_histogram",
"geom_hline",
"geom_jitter",
"geom_line",
"geom_linerange",
"geom_map",
"geom_path",
"geom_point",
"geom_pointrange",
"geom_polygon",
"geom_quantile",
"geom_raster",
"geom_rect",
"geom_ribbon",
"geom_rug",
"geom_segment",
"geom_smooth",
"geom_step",
"geom_text",
"geom_tile",
"geom_violin",
"geom_vline"
)
),
sd_section("Statistics",
"It's often useful to transform your data before plotting, and that's what statistical transformations do.",
c(
"stat_bin",
"stat_bin2d",
"stat_bindot",
"stat_binhex",
"stat_boxplot",
"stat_contour",
"stat_density",
"stat_density2d",
"stat_ecdf",
"stat_function",
"stat_identity",
"stat_qq",
"stat_quantile",
"stat_smooth",
"stat_spoke",
"stat_sum",
"stat_summary",
"stat_summary_hex",
"stat_summary2d",
"stat_unique",
"stat_ydensity"
)
),
sd_section("Scales",
"Scales control the mapping between data and aesthetics.",
c(
"expand_limits",
"guides",
"guide_legend",
"guide_colourbar",
"scale_alpha",
"scale_area",
"scale_colour_brewer",
"scale_colour_gradient",
"scale_colour_gradient2",
"scale_colour_gradientn",
"scale_colour_grey",
"scale_colour_hue",
"scale_identity",
"scale_manual",
"scale_linetype",
"scale_shape",
"scale_size",
"scale_x_continuous",
"scale_x_date",
"scale_x_datetime",
"scale_x_discrete",
"labs",
"update_labels",
"xlim"
)
),
sd_section("Coordinate systems",
"Coordinate systems adjust the mapping from coordinates to the 2d plane of the computer screen.",
c(
"coord_cartesian",
"coord_fixed",
"coord_flip",
"coord_map",
"coord_polar",
"coord_trans"
)
),
sd_section("Faceting",
"Facets display subsets of the dataset in different panels.",
c(
"facet_grid",
"facet_null",
"facet_wrap",
"label_both",
"label_bquote",
"label_parsed",
"label_value"
)
),
sd_section("Position adjustments",
"Position adjustments can be used to fine tune positioning of objects to achieve effects like dodging, jittering and stacking.",
c(
"position_dodge",
"position_fill",
"position_identity",
"position_stack",
"position_jitter"
)
),
sd_section("Data",
"Data sets included in ggplot2 and used in examples",
c(
"diamonds",
"economics",
"midwest",
"movies",
"mpg",
"msleep",
"presidential",
"seals"
)
),
sd_section("Anotation",
"Specialised functions for adding annotations to a plot",
c(
"annotate",
"annotation_custom",
"annotation_logticks",
"annotation_map",
"annotation_raster",
"borders"
)
),
sd_section("Fortify",
"Fortify methods make it possible to use ggplot2 with objects of
various types, not just data frames.",
c(
"fortify",
"fortify-multcomp",
"fortify.lm",
"fortify.map",
"fortify.sp",
"map_data"
)
),
sd_section("Themes",
"Themes control non-data components of the plot",
c(
"add_theme",
"calc_element",
"element_blank",
"element_line",
"element_rect",
"element_text",
"is.rel",
"is.theme",
"opts",
"rel",
"theme",
"theme_bw",
"theme_grey",
"theme_update",
"update_element"
)
),
sd_section("Plot creation", "",
c(
"ggplot",
"qplot",
"+.gg",
"autoplot",
"ggplot.data.frame",
"is.ggplot",
"print.ggplot"
)
),
sd_section("Aesthetics",
"",
c(
"aes",
"aes_all",
"aes_auto",
"aes_string",
"aes_colour_fill_alpha",
"aes_group_order",
"aes_linetype_size_shape",
"aes_position"
)
)
),
icons = list(
coord_cartesian = sd_icon({
gTree(children = gList(
segmentsGrob(c(0, 0.25), c(0.25, 0), c(1, 0.25), c(0.25, 1),
gp=gpar(col="grey50", lwd=0.5)),
segmentsGrob(c(0, 0.75), c(0.75, 0), c(1, 0.75), c(0.75, 1),
gp=gpar(col="grey50", lwd=0.5)),
segmentsGrob(c(0, 0.5), c(0.5, 0), c(1, 0.5), c(0.5, 1))
))
}),
coord_fixed = sd_icon({
textGrob("=", gp = gpar(cex=3))
}),
coord_flip = sd_icon({
angles <- seq(0, pi/2, length=20)[-c(1, 20)]
gTree(children=gList(
segmentsGrob(0, 0, 0, 1),
segmentsGrob(0, 0, 1, 0),
linesGrob(0.9 * sin(angles), 0.9 * cos(angles),
arrow=arrow(length=unit(0.05, "npc"))),
linesGrob(0.5 * sin(angles), 0.5 * cos(angles),
arrow=arrow(ends="first", length= unit(0.05, "npc")))
))
}),
coord_map = sd_icon({
nz <- data.frame(map("nz", plot=FALSE)[c("x","y")])
nz$x <- nz$x - min(nz$x, na.rm=TRUE)
nz$y <- nz$y - min(nz$y, na.rm=TRUE)
nz <- nz / max(nz, na.rm=TRUE)
linesGrob(nz$x, nz$y, default.units="npc")
}),
coord_polar = sd_icon({
circleGrob(r = c(0.1, 0.25, 0.45), gp = gpar(fill = NA))
}),
coord_transform = sd_icon({
breaks <- cumsum(1 / 2^(1:5))
gTree(children = gList(
segmentsGrob(breaks, 0, breaks, 1),
segmentsGrob(0, breaks, 1, breaks)
))
}),
facet_grid = sd_icon({
gTree(children = gList(
rectGrob(0, 1, width=0.95, height=0.05, hjust=0, vjust=1,
gp=gpar(fill="grey60", col=NA)),
rectGrob(0.95, 0.95, width=0.05, height=0.95, hjust=0, vjust=1,
gp=gpar(fill="grey60", col=NA)),
segmentsGrob(c(0, 0.475), c(0.475, 0), c(1, 0.475), c(0.475, 1))
))
}),
facet_null = sd_icon({
gTree(children = gList(
rectGrob(0, 1, width=0.95, height=0.05, hjust=0, vjust=1,
gp=gpar(fill="grey60", col=NA)),
rectGrob(0.95, 0.95, width=0.05, height=0.95, hjust=0, vjust=1,
gp=gpar(fill="grey60", col=NA)),
segmentsGrob(c(0, 0.475), c(0.475, 0), c(1, 0.475), c(0.475, 1))
))
}),
geom_abline = sd_icon(linesGrob(c(0, 1), c(0.2, 0.8))),
geom_bar = sd_icon({
rectGrob(c(0.3, 0.7), c(0.4, 0.8), height = c(0.4, 0.8), width = 0.3,
vjust = 1, gp = gpar(fill = "grey20", col = NA))
}),
geom_histogram = sd_icon({
y <- c(0.2, 0.3, 0.5, 0.6,0.2, 0.8, 0.5, 0.3)
rectGrob(seq(0.1, 0.9, by = 0.1), y, height = y, width = 0.1, vjust = 1,
gp = gpar(fill = "grey20", col = NA))
}),
geom_boxplot = sd_icon({
gTree(children = gList(
segmentsGrob(c(0.3, 0.7), c(0.1, 0.2), c(0.3, 0.7), c(0.7, 0.95)),
rectGrob(c(0.3, 0.7), c(0.6, 0.8), width = 0.3, height = c(0.4, 0.4),
vjust = 1),
segmentsGrob(c(0.15, 0.55), c(0.5, 0.6), c(0.45, 0.85), c(0.5, 0.6))
))
}),
geom_crossbar = sd_icon({
gTree(children = gList(
rectGrob(c(0.3, 0.7), c(0.6, 0.8), width = 0.3, height = c(0.4, 0.4), vjust = 1),
segmentsGrob(c(0.15, 0.55), c(0.5, 0.6), c(0.45, 0.85), c(0.5, 0.6))
))
}),
geom_dotplot = sd_icon({
xpos <- c(1,1,2,3,3,3,4,4,5,5,5,5,6,7,7,7,8,8,9)/10
ypos <- c(1,2,1,1,2,3,1,2,1,2,3,4,1,1,2,3,1,2,1)/10
pointsGrob(x = xpos, y = ypos, pch = 19, size = unit(.1, "npc"),
gp = gpar(col = "black", cex = 0.5), default.units = "npc")
}),
geom_errorbar = sd_icon({
gTree(children = gList(
segmentsGrob(c(0.3, 0.7), c(0.3, 0.5), c(0.3, 0.7), c(0.7, 0.9)),
segmentsGrob(c(0.15, 0.55), c(0.3, 0.5), c(0.45, 0.85), c(0.3, 0.5)),
segmentsGrob(c(0.15, 0.55), c(0.7, 0.9), c(0.45, 0.85), c(0.7, 0.9))
))
}),
geom_errorbarh = sd_icon({
gTree(children = gList(
segmentsGrob(c(0.5, 0.3), c(0.70, 0.30), c(0.9, 0.7), c(0.70, 0.30)),
segmentsGrob(c(0.5, 0.3), c(0.55, 0.15), c(0.5, 0.3), c(0.85, 0.45)),
segmentsGrob(c(0.9, 0.7), c(0.55, 0.15), c(0.9, 0.7), c(0.85, 0.45))
))
}),
geom_freqpoly = sd_icon({
y <- c(0.2, 0.3, 0.5, 0.6,0.2, 0.8, 0.5, 0.3)
linesGrob(seq(0.1, 0.9, by = 0.1), y, gp = gpar(col = "grey20"))
}),
geom_hline = sd_icon({
linesGrob(c(0, 1), c(0.5, 0.5))
}),
geom_linerange = sd_icon({
segmentsGrob(c(0.3, 0.7), c(0.1, 0.2), c(0.3, 0.7), c(0.7, 0.95))
}),
geom_path = sd_icon({
linesGrob(c(0.2, 0.4, 0.8, 0.6, 0.5), c(0.2, 0.7, 0.4, 0.1, 0.5))
}),
geom_contour = sd_icon({
gTree(children = gList(
polygonGrob(c(0.45,0.5,0.6, 0.5), c(0.5, 0.4, 0.55, 0.6)),
polygonGrob(c(0.25,0.6,0.8, 0.5), c(0.5, 0.2, 0.75, 0.9),
gp = gpar(fill = NA))
))
}),
geom_density2d = sd_icon(inherit = "geom_contour"),
geom_line = sd_icon({
pos <- seq(0, 1, length = 5)
linesGrob(pos, c(0.2, 0.7, 0.4, 0.8, 0.3))
}),
geom_step = sd_icon({
n <- 15
xs <- rep(0:n, each = 2)[-2*(n + 1)] / 15
ys <- c(0, rep(1:n, each = 2)) / 15
linesGrob(xs, ys, gp = gpar(col = "grey20"))
}),
geom_point = sd_icon({
pos <- seq(0.1, 0.9, length = 6)
pointsGrob(x = pos, y = pos, pch = 19,
gp = gpar(col = "black", cex = 0.5), default.units = "npc")
}),
geom_jitter = sd_icon({
pos <- seq(0.1, 0.9, length = 6)
pointsGrob(x = pos, y = jitter(pos, 3), pch = 19,
gp = gpar(col = "black", cex = 0.5), default.units = "npc")
}),
geom_pointrange = sd_icon({
gTree(children = gList(
segmentsGrob(c(0.3, 0.7), c(0.1, 0.2), c(0.3, 0.7), c(0.7, 0.95)),
pointsGrob(c(0.3, 0.7), c(0.4, 0.6), pch = 19,
gp = gpar(col = "black", cex = 0.5), default.units = "npc")
))
}),
geom_polygon = sd_icon({
polygonGrob(c(0.1, 0.4, 0.7, 0.9, 0.6, 0.3),
c(0.5, 0.8, 0.9, 0.4, 0.2, 0.3), gp = gpar(fill = "grey20", col = NA))
}),
geom_quantile = sd_icon({
gTree(children = gList(
linesGrob(c(0, 0.3, 0.5, 0.8, 1), c(0.8, 0.65, 0.6, 0.6, 0.8)),
linesGrob(c(0, 0.3, 0.5, 0.8, 1), c(0.55, 0.45, 0.5, 0.45, 0.55)),
linesGrob(c(0, 0.3, 0.5, 0.8, 1), c(0.3, 0.25, 0.4, 0.3, 0.2))
))
}),
geom_raster = sd_icon({
rectGrob(c(0.25, 0.25, 0.75, 0.75), c(0.25, 0.75, 0.75, 0.25),
width = 0.5, height = c(0.67, 0.5, 0.67, 0.5),
gp = gpar(col = "grey20", fill = c('#804070', '#668040')))
}),
geom_rect = sd_icon({
rectGrob(c(0.3, 0.7), c(0.4, 0.8), height = c(0.4, 0.8), width = 0.3,
vjust = 1, gp = gpar(fill = "grey20", col = NA))
}),
geom_ribbon = sd_icon({
polygonGrob(c(0, 0.3, 0.5, 0.8, 1, 1, 0.8, 0.5, 0.3, 0),
c(0.5, 0.3, 0.4, 0.2, 0.3, 0.7, 0.5, 0.6, 0.5, 0.7),
gp = gpar(fill = "grey20", col = NA))
}),
geom_area = sd_icon({
polygonGrob(c(0, 0,0.3, 0.5, 0.8, 1, 1),
c(0, 1,0.5, 0.6, 0.3, 0.8, 0),
gp = gpar(fill = "grey20", col = NA))
}),
geom_density = sd_icon({
x <- seq(0, 1, length = 80)
y <- dnorm(x, mean = 0.5, sd = 0.15)
linesGrob(x, 0.05 + y / max(y) * 0.9, default = "npc")
}),
geom_segment = sd_icon({
segmentsGrob(c(0.1, 0.3, 0.5, 0.7), c(0.3, 0.5, 0.1, 0.9),
c(0.2, 0.5, 0.7, 0.9), c(0.8, 0.7, 0.4, 0.3))
}),
geom_smooth = sd_icon({
gTree(children = gList(
polygonGrob(c(0, 0.3, 0.5, 0.8, 1, 1, 0.8, 0.5, 0.3, 0),
c(0.5, 0.3, 0.4, 0.2, 0.3, 0.7, 0.5, 0.6, 0.5, 0.7),
gp = gpar(fill = "grey60", col = NA)),
linesGrob(c(0, 0.3, 0.5, 0.8, 1), c(0.6, 0.4, 0.5, 0.4, 0.6))
))
}),
geom_text = sd_icon({
textGrob("text", rot = 45, gp = gpar(cex = 1.2))
}),
geom_tile = sd_icon({
rectGrob(c(0.25, 0.25, 0.75, 0.75), c(0.25, 0.75, 0.75, 0.25),
width = 0.5, height = c(0.67, 0.5, 0.67, 0.5),
gp = gpar(col = "grey20", fill = c('#804070', '#668040')))
}),
geom_violin = sd_icon({
y <- seq(-.3, .3, length = 40)
x1 <- dnorm(y, mean = -.15, sd = 0.05) +
1.5 * dnorm(y, mean = 0.1, sd = 0.1)
x2 <- dnorm(y, mean = -.1, sd = 0.1) + dnorm(y, mean = 0.1, sd = 0.1)
y <- c(y, rev(y))
x1 <- c(x1, -rev(x1)) / max(8 * x1)
x2 <- c(x2, -rev(x2)) / max(8 * x2)
gp <- gpar(fill = "black")
gTree(children = gList(
polygonGrob(x1 + .30, y + .35, default = "npc", gp = gp),
polygonGrob(x2 + .70, y + .55, default = "npc", gp = gp))
)
}),
geom_vline = sd_icon({
linesGrob(c(0.5, 0.5), c(0, 1))
}),
position_dodge = sd_icon({
y <- c(0.5, 0.3)
rectGrob(c(0.25, 0.75), y, width = 0.4, height = y,
gp = gpar(col = "grey60", fill = c('#804070', '#668040')), vjust = 1)
}),
position_fill = sd_icon({
y <- c(0.5, 0.8)
rectGrob(0.5, c(0.625, 1), width = 0.4, height = c(0.625, 0.375),
gp = gpar(col = "grey60", fill = c('#804070', '#668040')), vjust = 1)
}),
position_identity = sd_icon({
rectGrob(0.5, c(0.5, 0.3), width = 0.4, height = c(0.5, 0.3),
gp = gpar(col = "grey60", fill = c('#804070', '#668040')), vjust = 1)
}),
position_jitter = sd_icon(inherit = "geom_jitter" ),
position_stack = sd_icon({
y <- c(0.5, 0.8)
rectGrob(0.5, c(0.5, 0.8), width = 0.4, height = c(0.5, 0.3),
gp = gpar(col = "grey60", fill = c('#804070', '#668040')), vjust = 1)
}),
scale_alpha = sd_icon({
x <- c(0.1, 0.3, 0.5, 0.7, 0.9)
rectGrob(x, width=0.25,
gp=gpar(fill=alpha("black", x), col=NA)
)
}),
scale_colour_brewer = sd_icon({
rectGrob(c(0.1, 0.3, 0.5, 0.7, 0.9), width=0.21,
gp=gpar(fill=RColorBrewer::brewer.pal(5, "PuOr"), col=NA)
)
}),
scale_colour_gradient = sd_icon({
g <- scale_fill_gradient()
scale_train(g, 1:5)
rectGrob(c(0.1, 0.3, 0.5, 0.7, 0.9), width=0.21,
gp=gpar(fill=scale_map(g, 1:5), col=NA)
)
}),
scale_colour_gradient2 = sd_icon({
g <- scale_fill_gradient2()
scale_train(g, 1:5 - 3)
rectGrob(c(0.1, 0.3, 0.5, 0.7, 0.9), width=0.21,
gp=gpar(fill=scale_map(g, 1:5 - 3), col=NA)
)
}),
scale_colour_gradientn = sd_icon({
g <- scale_fill_gradientn(colours = rainbow(7))
scale_train(g, 1:5)
rectGrob(c(0.1, 0.3, 0.5, 0.7, 0.9), width=0.21,
gp=gpar(fill = scale_map(g, 1:5), col=NA)
)
}),
scale_colour_grey = sd_icon({
rectGrob(c(0.1, 0.3, 0.5, 0.7, 0.9), width=0.21,
gp=gpar(fill=gray(seq(0, 1, length=5)), col=NA)
)
}),
scale_colour_hue = sd_icon({
rectGrob(c(0.1, 0.3, 0.5, 0.7, 0.9), width=0.21,
gp=gpar(fill=hcl(seq(0, 360, length=6)[-6], c=100, l=65), col=NA)
)
}),
scale_identity = sd_icon({
textGrob("f(x) = x", gp=gpar(cex=1.2))
}),
scale_linetype = sd_icon({
gTree(children=gList(
segmentsGrob(0, 0.25, 1, 0.25, gp=gpar(lty=1)),
segmentsGrob(0, 0.50, 1, 0.50, gp=gpar(lty=2)),
segmentsGrob(0, 0.75, 1, 0.75, gp=gpar(lty=3))
))
}),
scale_manual = sd_icon({
textGrob("DIY", gp=gpar(cex=1.2))
}),
scale_shape = sd_icon({
gTree(children=gList(
circleGrob(0.7, 0.7, r=0.1),
segmentsGrob(0.2, 0.3, 0.4, 0.3),
segmentsGrob(0.3, 0.2, 0.3, 0.4),
polygonGrob(c(0.2, 0.2, 0.4, 0.4), c(0.8, 0.6, 0.6, 0.8)),
polygonGrob(c(0.6, 0.7, 0.8), c(0.2, 0.4, 0.2))
))
}),
scale_size = sd_icon({
pos <- c(0.15, 0.3, 0.5, 0.75)
circleGrob(pos, pos, r=(c(0.1, 0.2, 0.3, 0.4)/2.5), gp=gpar(fill="grey50", col=NA))
}),
scale_x_date = sd_icon({
textGrob("14/10/1979", gp=gpar(cex=1))
}),
scale_x_datetime = sd_icon({
textGrob("14/10/1979\n10:14am", gp=gpar(cex=0.9))
}),
stat_bin = sd_icon(inherit = "geom_histogram" ),
stat_bindot = sd_icon(inherit = "geom_dotplot" ),
stat_boxplot = sd_icon(inherit = "geom_boxplot" ),
stat_contour = sd_icon(inherit = "geom_contour" ),
stat_density2d = sd_icon(inherit = "geom_density2d" ),
stat_ecdf = sd_icon(inherit = "geom_step"),
stat_density = sd_icon(inherit = "geom_density" ),
stat_identity = sd_icon({
textGrob('f(x) = x', gp = gpar(cex = 1.2))
}),
stat_quantile = sd_icon(inherit = "geom_quantile" ),
stat_smooth = sd_icon(inherit = "geom_smooth" ),
stat_sum = sd_icon({
textGrob(expression(Sigma), gp = gpar(cex = 4))
}),
# The line stats will be removed in the future
stat_abline = sd_icon(inherit = "geom_abline" ),
stat_vline = sd_icon(inherit = "geom_vline" ),
stat_hline = sd_icon(inherit = "geom_hline" ),
stat_ydensity = sd_icon(inherit = "geom_violin" )
)) ggplot2/inst/staticdocs/footer.html 0000644 0001751 0000144 00000000644 12114161113 017142 0 ustar hornik users Back to top
What do you think of the documentation? Please let me know by filling out this short online survey.
Built by staticdocs. Styled with bootstrap.
ggplot2/inst/test_ns/ 0000755 0001751 0000144 00000000000 12114160774 014305 5 ustar hornik users ggplot2/inst/test_ns/R/ 0000755 0001751 0000144 00000000000 12114160774 014506 5 ustar hornik users ggplot2/inst/test_ns/R/my-plot.r 0000644 0001751 0000144 00000000361 12114160774 016272 0 ustar hornik users #' Create a plot.
#'
#' @export
#' @import ggplot2
#' @examples
#' plot(my_plot())
my_plot <- function() {
df <- data.frame(x = 1:10, y = sample(10), z = runif(1))
ggplot(df) + geom_point(aes_string(x = "x", y = "y", colour = "z"))
} ggplot2/inst/test_ns/DESCRIPTION 0000644 0001751 0000144 00000000445 12114160774 016016 0 ustar hornik users Package: nstest
Type: Package
Title: Test ggplot2 NAMESPACE
Version: 0.1
Author: Hadley Wickham
Maintainer: Hadley Wickham
Description: Check to see if ggplot2 namespace set up correctly.
Imports:
ggplot2
License: GPL-2
Collate:
'my-plot.r'
ggplot2/inst/test_ns/man/ 0000755 0001751 0000144 00000000000 12114160774 015060 5 ustar hornik users ggplot2/inst/test_ns/man/my_plot.Rd 0000644 0001751 0000144 00000000213 12114160774 017026 0 ustar hornik users \name{my_plot}
\alias{my_plot}
\title{Create a plot.}
\usage{
my_plot()
}
\description{
Create a plot.
}
\examples{
plot(my_plot())
}
ggplot2/inst/test_ns/NAMESPACE 0000644 0001751 0000144 00000000040 12114160774 015516 0 ustar hornik users export(my_plot)
import(ggplot2)
ggplot2/inst/CITATION 0000644 0001751 0000144 00000000612 12114160774 013762 0 ustar hornik users citHeader("To cite ggplot2 in publications, please use:")
citEntry(entry = "book",
author = "Hadley Wickham",
title = "ggplot2: elegant graphics for data analysis",
publisher = "Springer New York",
year = "2009",
isbn = "978-0-387-98140-6",
url = "http://had.co.nz/ggplot2/book",
textVersion = "H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009."
) ggplot2/inst/tests/ 0000755 0001751 0000144 00000000000 12114161113 013754 5 ustar hornik users ggplot2/inst/tests/helper-plot-data.r 0000644 0001751 0000144 00000001371 12114160774 017317 0 ustar hornik users pdata <- function(x) ggplot_build(x)$data
# Transform the data as the coordinate system does
cdata <- function(plot) {
pieces <- ggplot_build(plot)
lapply(pieces$data, function(d) {
ddply(d, "PANEL", function(panel_data) {
scales <- panel_scales(pieces$panel, panel_data$PANEL[1])
details <- coord_train(plot$coord, scales)
coord_transform(plot$coord, panel_data, details)
})
})
}
pranges <- function(plot) {
panels <- ggplot_build(plot)$panel
x_ranges <- lapply(panels$x_scales, scale_limits)
y_ranges <- lapply(panels$y_scales, scale_limits)
npscales <- plot$scales$non_position_scales()
npranges <- lapply(npscales$scales$scales, scale_limits)
c(list(x = x_ranges, y = y_ranges), npranges)
}
ggplot2/inst/tests/test-dotplot.r 0000644 0001751 0000144 00000003561 12114160774 016622 0 ustar hornik users context("Dotplot")
set.seed(111)
dat <- data.frame(x = LETTERS[1:2], y = rnorm(30), g = LETTERS[3:5])
test_that("Dodging works", {
p <- ggplot(dat, aes(x = x, y = y, fill = g)) +
geom_dotplot(binwidth=.2, binaxis="y", position="dodge", stackdir="center")
bp <- ggplot_build(p)
df <- bp$data[[1]]
# Number of levels in the dodged variable
ndodge <- 3
# The amount of space allocated within each dodge group
dwidth <- .9 / ndodge
# This should be the x position for each before dodging
xbase <- ceiling(df$group / ndodge)
# This is the offset from dodging
xoffset <- (df$group-1) %% ndodge - (ndodge-1) / 2
xoffset <- xoffset * dwidth
# Check actual x locations equal predicted x locations
expect_true(all(abs(df$x - (xbase + xoffset)) < 1e-6))
# Check that xmin and xmax are in the right place
expect_true(all(abs(df$xmax - df$x - dwidth/2) < 1e-6))
expect_true(all(abs(df$x - df$xmin - dwidth/2) < 1e-6))
})
test_that("Binning works", {
bp <- ggplot_build(ggplot(dat, aes(x=y)) + geom_dotplot(binwidth=.4, method="histodot"))
x <- bp$data[[1]]$x
# Need ugly hack to make sure mod function doesn't give values like -3.99999
# due to floating point error
expect_true(all(abs((x - min(x) + 1e-7) %% .4) < 1e-6))
bp <- ggplot_build(ggplot(dat, aes(x=y)) + geom_dotplot(binwidth=.4, method="dotdensity"))
x <- bp$data[[1]]$x
# This one doesn't ensure that dotdensity works, but it does check that it's not
# doing fixed bin sizes
expect_false(all(abs((x - min(x) + 1e-7) %% .4) < 1e-6))
})
test_that("NA's result in warning from stat_bindot", {
set.seed(122)
dat <- data.frame(x=rnorm(20))
dat$x[c(2,10)] <- NA
# Need to assign it to a var here so that it doesn't automatically print
expect_that(bp <- ggplot_build(ggplot(dat, aes(x)) + geom_dotplot(binwidth=.2)),
gives_warning("Removed 2 rows.*stat_bindot"))
})
ggplot2/inst/tests/test-data.r 0000644 0001751 0000144 00000001657 12114160774 016052 0 ustar hornik users context("Data")
test_that("stringsAsFactors doesn't affect results", {
sAF <- getOption("stringsAsFactors")
dat.character <- data.frame(x=letters[5:1], y=1:5, stringsAsFactors=FALSE)
dat.factor <- data.frame(x=letters[5:1], y=1:5, stringsAsFactors=TRUE)
base <- ggplot(, aes(x, y)) + geom_point()
xlabels <- function(x) x$panel$ranges[[1]]$x.labels
options(stringsAsFactors = TRUE)
char_true <- ggplot_build(base %+% dat.character)
factor_true <- ggplot_build(base %+% dat.factor)
options(stringsAsFactors = FALSE)
char_false <- ggplot_build(base %+% dat.character)
factor_false <- ggplot_build(base %+% dat.factor)
options(stringsAsFactors = sAF)
expect_that(xlabels(char_true), equals(letters[1:5]))
expect_that(xlabels(char_false), equals(letters[1:5]))
expect_that(xlabels(factor_true), equals(letters[1:5]))
expect_that(xlabels(factor_false), equals(letters[1:5]))
}) ggplot2/inst/tests/test-empty-data.r 0000644 0001751 0000144 00000011760 12114160774 017202 0 ustar hornik users context('Empty data')
df0 <- data.frame(mpg=numeric(0), wt=numeric(0), am=numeric(0), cyl=numeric(0))
test_that("layers with empty data are silently omitted", {
# Empty data (no visible points)
d <- pdata(ggplot(df0, aes(x=mpg,y=wt)) + geom_point())
expect_equal(nrow(d[[1]]), 0)
d <- pdata(ggplot() + geom_point(data=df0, aes(x=mpg,y=wt)))
expect_equal(nrow(d[[1]]), 0)
# Regular mtcars data, x=mpg, y=wt, normal points and points from empty data frame
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() + geom_point(data=df0))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), 0)
# Regular mtcars data, but points only from empty data frame
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point(data=df0))
expect_equal(nrow(d[[1]]), 0)
})
test_that("plots with empty data and vectors for aesthetics work", {
# Empty data with x and y mapped to vector of values
d <- pdata(qplot(1:5, 1:5))
expect_equal(nrow(d[[1]]), 5)
d <- pdata(ggplot(mapping=aes(x=1:5, y=1:5)) + geom_point())
expect_equal(nrow(d[[1]]), 5)
d <- pdata(ggplot() + geom_point(aes(x=1:5, y=1:5)))
expect_equal(nrow(d[[1]]), 5)
})
test_that("layers with empty data are silently omitted with facets", {
# Empty data, facet_wrap, throws error
expect_error(ggplot_build(ggplot(df0, aes(x=mpg, y=wt)) + geom_point() + facet_wrap(~ cyl)))
# Empty data, facet_grid, throws error
expect_error(ggplot_build(ggplot(df0, aes(x=x, y=y)) + geom_point() + facet_grid(am ~ cyl)))
# points from mtcars points and points from empty data frame, facet_wrap
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() + geom_point(data=df0) + facet_wrap(~ cyl))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), 0)
# points from mtcars points and points from empty data frame, facet_grid
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() + geom_point(data=df0) + facet_grid(am ~ cyl))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), 0)
})
test_that("data is not inherited when when data=data.frame()", {
# Should error when totally empty data frame because there's no x and y
expect_error(ggplot_build(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() +
geom_point(data=data.frame())))
# No extra points when x and y vars exist, but are empty
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() +
geom_point(data = data.frame(mpg=numeric(0), wt=numeric(0))))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), 0)
# No extra points when x and y vars don't exist but are set
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() +
geom_point(data=data.frame(mpg=numeric(0), wt=numeric(0)), x = 20, y = 3, colour = "red", size = 5))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), 0)
# No extra points when x and y vars exist, but are empty, even when aesthetics are set
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() +
geom_point(data=data.frame(mpg=numeric(0), wt=numeric(0)), x = 20, y = 3, colour = "red", size = 5))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), 0)
})
test_that("data is inherited when data=NULL", {
# NULL should inherit data
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() +
geom_point(data=NULL))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), nrow(mtcars))
# NULL should inherit data when all aesthetics are set
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() +
geom_point(data=NULL, x = 20, y = 3, colour = "red", size = 5))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), nrow(mtcars))
# NULL should inherit data when facet_wrap is used
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() +
geom_point(data=NULL) +
facet_wrap(~ cyl))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), nrow(mtcars))
# NULL should inherit data when all aesthetics are set and facet_wrap is used
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() +
geom_point(data=NULL, x = 20, y = 3, colour = "red", size = 5) +
facet_wrap(~ cyl))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), nrow(mtcars))
expect_equal(sort(d[[1]]$PANEL), sort(d[[2]]$PANEL))
# NULL should inherit data when facet_grid is used
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() +
geom_point(data=NULL) +
facet_grid(am ~ cyl))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), nrow(mtcars))
# NULL should inherit data when all aesthetics are set and facet_grid is used
d <- pdata(ggplot(mtcars, aes(x=mpg, y=wt)) + geom_point() +
geom_point(data=NULL, x = 20, y = 3, colour = "red", size = 5) +
facet_grid(am ~ cyl))
expect_equal(nrow(d[[1]]), nrow(mtcars))
expect_equal(nrow(d[[2]]), nrow(mtcars))
expect_equal(sort(d[[1]]$PANEL), sort(d[[2]]$PANEL))
# In the future, the behavior of NULL may change, and a test for waiver will
# also be added.
})
ggplot2/inst/tests/test-utilities.r 0000644 0001751 0000144 00000002617 12114161113 017135 0 ustar hornik users context("Utilities")
test_that("finite.cases.data.frame", {
# All finite --------------------------------------------------------------
expect_identical(finite.cases(data.frame(x=4)), TRUE) # 1x1
expect_identical(finite.cases(data.frame(x=4, y=11)), TRUE) # 1x2
expect_identical(finite.cases(data.frame(x=4:5)), c(TRUE, TRUE)) # 2x1
expect_identical(finite.cases(data.frame(x=4:5, y=11:12)), c(TRUE, TRUE)) # 2x2
# Has one NA --------------------------------------------------------------
expect_identical(finite.cases(data.frame(x=NA)), FALSE) # 1x1
expect_identical(finite.cases(data.frame(x=4, y=NA)), FALSE) # 1x2
expect_identical(finite.cases(data.frame(x=c(4,NA))), c(TRUE, FALSE)) # 2x1
expect_identical(finite.cases(data.frame(x=c(4,NA), y=c(11,NA))), c(TRUE, FALSE)) # 2x2
expect_identical(finite.cases(data.frame(x=c(4,NA), y=c(NA,12))), c(FALSE, FALSE)) # 2x2
expect_identical(finite.cases(data.frame(x=c(4,5), y=c(NA,12))), c(FALSE, TRUE)) # 2x2
# Testing NaN and Inf, using miscellaneous data shapes --------------------
expect_identical(finite.cases(data.frame(x=c(4,NaN))), c(TRUE, FALSE))
expect_identical(finite.cases(data.frame(x=Inf)), FALSE)
expect_identical(finite.cases(data.frame(x=c(4,5), y=c(-Inf,12))), c(FALSE, TRUE))
})
ggplot2/inst/tests/test-build.r 0000644 0001751 0000144 00000002473 12114160774 016235 0 ustar hornik users # Test the complete path from plot specification to rendered data
context("Plot building")
df <- data.frame(x = 1:3, y = 3:1, z = letters[1:3])
test_that("there is one data frame for each layer", {
l1 <- ggplot(df, aes(x, y)) + geom_point()
l2 <- ggplot(df, aes(x, y)) + geom_point() + geom_line()
l3 <- ggplot(df, aes(x, y)) + geom_point() + geom_line() + geom_point()
expect_that(length(pdata(l1)), equals(1))
expect_that(length(pdata(l2)), equals(2))
expect_that(length(pdata(l3)), equals(3))
})
test_that("position aesthetics coerced to correct type", {
l1 <- ggplot(df, aes(x, y)) + geom_point()
d1 <- pdata(l1)[[1]]
expect_that(d1$x, is_a("numeric"))
expect_that(d1$y, is_a("numeric"))
l2 <- ggplot(df, aes(x, z)) + geom_point() + scale_x_discrete()
d2 <- pdata(l2)[[1]]
expect_that(d2$x, is_a("integer"))
expect_that(d2$y, is_a("integer"))
})
test_that("non-position aesthetics are mapped", {
l1 <- ggplot(df, aes(x, y, fill = z, colour = z, shape = z, size = z)) +
geom_point()
d1 <- pdata(l1)[[1]]
expect_that(sort(names(d1)), equals(sort(c("x", "y", "fill", "group",
"colour", "shape", "size", "PANEL"))))
l2 <- l1 + scale_colour_manual(values = c("blue", "red", "yellow"))
d2 <- pdata(l2)[[1]]
expect_that(d2$colour, equals(c("blue", "red", "yellow")))
})
ggplot2/inst/tests/test-facet-locate.r 0000644 0001751 0000144 00000012710 12114160774 017460 0 ustar hornik users context("Facetting (location)")
df <- expand.grid(a = 1:2, b = 1:2)
df_a <- unique(df["a"])
df_b <- unique(df["b"])
df_c <- unique(data.frame(c = 1))
test_that("two col cases with no missings adds single extra column", {
vscyl <- layout_grid(list(mtcars), "cyl", "vs")
loc <- locate_grid(mtcars, vscyl, "cyl", "vs")
expect_that(nrow(loc), equals(nrow(mtcars)))
expect_that(ncol(loc), equals(ncol(mtcars) + 1))
match <- unique(loc[c("cyl", "vs", "PANEL")])
expect_that(nrow(match), equals(5))
})
test_that("margins add extra data", {
panel <- layout_grid(list(df), "a", "b", margins = "b")
loc <- locate_grid(df, panel, "a", "b", margins = "b")
expect_that(nrow(loc), equals(nrow(df) * 2))
})
test_that("grid: missing facet columns are duplicated", {
panel <- layout_grid(list(df), "a", "b")
loc_a <- locate_grid(df_a, panel, "a", "b")
expect_that(nrow(loc_a), equals(4))
expect_that(loc_a$PANEL, equals(factor(1:4)))
loc_b <- locate_grid(df_b, panel, "a", "b")
expect_that(nrow(loc_b), equals(4))
expect_that(loc_b$PANEL, equals(factor(1:4)))
loc_c <- locate_grid(df_c, panel, "a", "b")
expect_that(nrow(loc_c), equals(4))
expect_that(loc_c$PANEL, equals(factor(1:4)))
})
test_that("wrap: missing facet columns are duplicated", {
panel <- layout_wrap(list(df), c("a", "b"), ncol = 1)
loc_a <- locate_wrap(df_a, panel, c("a", "b"))
expect_that(nrow(loc_a), equals(4))
expect_that(loc_a$PANEL, equals(factor(1:4)))
expect_that(loc_a$a, equals(c(1, 1, 2, 2)))
loc_b <- locate_wrap(df_b, panel, c("a", "b"))
expect_that(nrow(loc_b), equals(4))
expect_that(loc_b$PANEL, equals(factor(1:4)))
loc_c <- locate_wrap(df_c, panel, c("a", "b"))
expect_that(nrow(loc_c), equals(4))
expect_that(loc_c$PANEL, equals(factor(1:4)))
})
# Missing behaviour ----------------------------------------------------------
a3 <- data.frame(
# a = c(1:3, NA), Not currently supported
b = factor(c(1:3, NA)),
c = factor(c(1:3, NA), exclude = NULL)
)
test_that("wrap: missing values located correctly", {
panel_b <- layout_wrap(list(a3), "b", ncol = 1)
loc_b <- locate_wrap(data.frame(b = NA), panel_b, "b")
expect_equal(as.character(loc_b$PANEL), "4")
panel_c <- layout_wrap(list(a3), "c", ncol = 1)
loc_c <- locate_wrap(data.frame(c = NA), panel_c, "c")
expect_equal(as.character(loc_c$PANEL), "4")
})
test_that("grid: missing values located correctly", {
panel_b <- layout_grid(list(a3), "b")
loc_b <- locate_grid(data.frame(b = NA), panel_b, "b")
expect_equal(as.character(loc_b$PANEL), "4")
panel_c <- layout_grid(list(a3), "c")
loc_c <- locate_grid(data.frame(c = NA), panel_c, "c")
expect_equal(as.character(loc_c$PANEL), "4")
})
# Facet order ----------------------------------------------------------------
get_layout <- function(p) ggplot_build(p)$panel$layout
# Data with factor f with levels CBA
d <- data.frame(x = 1:9, y = 1:9,
fx = factor(rep(letters[1:3], each = 3), levels = letters[3:1]),
fy = factor(rep(LETTERS[1:3], each = 3), levels = LETTERS[3:1]))
# Data with factor f with only level B
d2 <- data.frame(x = 1:9, y = 2:10, fx = "a", fy = "B")
test_that("grid: facet order follows default data frame order", {
# Facets should be in order:
# CBA for rows 1:3
# cba for cols 1:3
lay <- get_layout(ggplot(d, aes(x, y)) + facet_grid(fy ~ fx) + geom_point())
expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW])
expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL])
# When adding d2, facets should still be in order:
# CBA for rows 1:3
# cba for cols 1:3
lay <- get_layout(ggplot(d, aes(x, y)) + facet_grid(fy ~ fx) +
geom_blank(data = d2) + geom_point())
expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW])
expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL])
# With no default data: should search each layer in order
# BCA for rows 1:3
# acb for cols 1:3
lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_grid(fy ~ fx) +
geom_blank(data = d2) + geom_point(data=d))
expect_equal(as.character(lay$fy), c("B","C","A")[lay$ROW])
expect_equal(as.character(lay$fx), c("a","c","b")[lay$COL])
# Same as previous, but different layer order.
# CBA for rows 1:3
# cba for cols 1:3
lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_grid(fy ~ fx) +
geom_point(data = d) + geom_blank(data = d2))
expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW])
expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL])
})
test_that("wrap: facet order follows default data frame order", {
# Facets should be in order:
# cba for panels 1:3
lay <- get_layout(ggplot(d, aes(x, y)) + facet_wrap(~ fx) + geom_point())
expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL])
# When adding d2, facets should still be in order:
# cba for panels 1:3
lay <- get_layout(ggplot(d, aes(x, y)) + facet_wrap(~ fx) +
geom_blank(data = d2) + geom_point())
expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL])
# With no default data: should search each layer in order
# acb for panels 1:3
lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_wrap(~ fx) +
geom_blank(data = d2) + geom_point(data=d))
expect_equal(as.character(lay$fx), c("a","c","b")[lay$PANEL])
# Same as previous, but different layer order.
# cba for panels 1:3
lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_wrap(~ fx) +
geom_point(data = d) + geom_blank(data = d2))
expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL])
})
ggplot2/inst/tests/test-aes-setting.r 0000644 0001751 0000144 00000001166 12114160774 017357 0 ustar hornik users context("Aes - setting values")
test_that("Aesthetic parameters must match length of data", {
df <- data.frame(x = 1:5, y = 1:5)
p <- ggplot(df, aes(x, y))
set_colours <- function(colours) {
pdf(file=NULL)
print(p + geom_point(colour = colours))
dev.off()
}
set_colours("red")
expect_error(set_colours(rep("red", 2)), "Incompatible lengths")
dev.off() # Need to manually close device because of error
expect_error(set_colours(rep("red", 3)), "Incompatible lengths")
dev.off()
expect_error(set_colours(rep("red", 4)), "Incompatible lengths")
dev.off()
set_colours(rep("red", 5))
}) ggplot2/inst/tests/test-coord-polar.r 0000644 0001751 0000144 00000003430 12114161113 017335 0 ustar hornik users context("coord_polar")
test_that("Polar distance calculation", {
dat <- data.frame(
theta = c(0, 2*pi, 2, 6, 6, 1, 1, 0),
r = c(0, 0, 0.5, 0.5, 1, 1, 0.75, .5))
scales <- list(x = scale_x_continuous(limits=c(0, 2*pi)),
y = scale_y_continuous(limits=c(0, 1)))
coord <- coord_train(coord_polar(), scales)
dists <- coord_distance(coord_polar(), dat$theta, dat$r, coord)
# dists is normalized by dividing by this value, so we'll add it back
# The maximum length of a spiral arc, from (t,r) = (0,0) to (2*pi,1)
maxlen <- spiral_arc_length(1 / (2 * pi), 0, 2 * pi)
# These are the expected lengths. I think they're correct...
expect_equal(dists,
c(0, -1.225737494, -2, -0.5, -5, -0.25, -0.6736885011) / maxlen)
# The picture can be visualized with:
# ggplot(dat, aes(x=theta, y=r)) + geom_path() +
# geom_point(alpha=0.3) + coord_polar()
})
test_that("Polar distance calculation ignores NA's", {
# These are r and theta values; we'll swap them around for testing
x1 <- c(0, 0.5, 0.5, NA, 1)
x2 <- c(0, 1, 2, 0, 1)
dists <- dist_polar(x1, x2)
expect_equal(is.na(dists), c(FALSE, FALSE, TRUE, TRUE))
dists <- dist_polar(x2, x1)
expect_equal(is.na(dists), c(FALSE, FALSE, TRUE, TRUE))
# NA on the end
x1 <- c(0, 0.5, 0.5, 1, NA)
x2 <- c(0, 1, 2, 0, 1)
dists <- dist_polar(x1, x2)
expect_equal(is.na(dists), c(FALSE, FALSE, FALSE, TRUE))
dists <- dist_polar(x2, x1)
expect_equal(is.na(dists), c(FALSE, FALSE, FALSE, TRUE))
# NAs in each vector - also have NaN
x1 <- c(0, 0.5, 0.5, 1, NA)
x2 <- c(NaN, 1, 2, NA, 1)
dists <- dist_polar(x1, x2)
expect_equal(is.na(dists), c(TRUE, FALSE, TRUE, TRUE))
dists <- dist_polar(x2, x1)
expect_equal(is.na(dists), c(TRUE, FALSE, TRUE, TRUE))
})
ggplot2/inst/tests/test-scale-manual.r 0000644 0001751 0000144 00000003771 12114160774 017502 0 ustar hornik users context("scale_manual")
test_that("names of values used in manual scales", {
s <- scale_colour_manual(values = c("8" = "c","4" = "a","6" = "b"))
scale_train(s, c("4", "6", "8"))
expect_equal(scale_map(s, c("4", "6", "8")), c("a", "b", "c"))
})
dat <- data.frame(g = c("B","A","A"))
p <- ggplot(dat, aes(g, fill = g)) + geom_bar()
col <- c("A" = "red", "B" = "green", "C" = "blue")
cols <- function(x) ggplot_build(x)$data[[1]][, "fill"]
test_that("named values work regardless of order", {
fill_scale <- function(order) scale_fill_manual(values = col[order],
na.value = "black")
# Order of value vector shouldn't matter
expect_equal(cols(p + fill_scale(1:3)), c("red", "green"))
expect_equal(cols(p + fill_scale(1:2)), c("red", "green"))
expect_equal(cols(p + fill_scale(2:1)), c("red", "green"))
expect_equal(cols(p + fill_scale(c(3, 2, 1))), c("red", "green"))
expect_equal(cols(p + fill_scale(c(3, 1, 2))), c("red", "green"))
expect_equal(cols(p + fill_scale(c(1, 3, 2))), c("red", "green"))
})
test_that("missing values replaced with na.value", {
df <- data.frame(x = 1, y = 1:3, z = factor(c(1:2, NA), exclude = NULL))
pdata <- ggplot_build(qplot(x, y, data = df, colour = z) +
scale_colour_manual(values = c("black", "black"), na.value = "red"))
expect_equal(pdata$data[[1]]$colour, c("black", "black", "red"))
})
test_that("insufficient values raise an error", {
df <- data.frame(x = 1, y = 1:3, z = factor(c(1:2, NA), exclude = NULL))
p <- qplot(x, y, data = df, colour = z)
expect_error(ggplot_build(p + scale_colour_manual(values = "black")),
"Insufficient values")
# Should be sufficient
ggplot_build(p + scale_colour_manual(values = c("black", "black")))
})
test_that("values are matched when scale contains more unique valuesthan are in the data", {
s <- scale_colour_manual(values = c("8" = "c", "4" = "a",
"22" = "d", "6" = "b"))
scale_train(s, c("4", "6", "8"))
expect_equal(scale_map(s, c("4", "6", "8")), c("a", "b", "c"))
})
ggplot2/inst/tests/test-fortify.r 0000644 0001751 0000144 00000002267 12114160774 016621 0 ustar hornik users context("Fortify")
library(sp)
test_that("Spatial polygons have correct ordering", {
make_square <- function(x = 0, y = 0, height = 1, width = 1){
delx <- width/2
dely <- height/2
Polygon(matrix(c(x + delx, x - delx,x - delx,x + delx,x + delx ,
y - dely,y - dely,y + dely,y + dely,y - dely), ncol = 2))
}
make_hole <- function(x = 0, y = 0, height = .5, width = .5){
p <- make_square(x = x, y = y, height = height, width = width)
p@hole <- TRUE
p
}
fake_data <- data.frame(ids = 1:5, region = c(1,1,2,3,4))
rownames(fake_data) <- 1:5
polys <- list(Polygons(list(make_square(), make_hole()), 1),
Polygons(list(make_square(1,0), make_square(2, 0)), 2),
Polygons(list(make_square(1,1)), 3),
Polygons(list(make_square(0,1)), 4),
Polygons(list(make_square(0,3)), 5))
polys_sp <- SpatialPolygons(polys)
fake_sp <- SpatialPolygonsDataFrame(polys_sp, fake_data)
# now reorder regions
polys2 <- rev(polys)
polys2_sp <- SpatialPolygons(polys2)
fake_sp2 <- SpatialPolygonsDataFrame(polys2_sp, fake_data)
expect_equivalent(fortify(fake_sp), arrange(fortify(fake_sp2), id, order))
})
ggplot2/inst/tests/test-labels.r 0000644 0001751 0000144 00000000703 12114160774 016372 0 ustar hornik users context("Labels")
test_that("Setting guide labels", {
expect_identical(xlab("my label")$x, "my label")
expect_identical(labs(x = "my label")$x, "my label")
expect_identical(ylab("my label")$y, "my label")
expect_identical(labs(y = "my label")$y, "my label")
# Colour
expect_identical(labs(colour = "my label")$colour, "my label")
# American spelling
expect_identical(labs(color = "my label")$colour, "my label")
})
ggplot2/inst/tests/test-scales.r 0000644 0001751 0000144 00000011724 12114160774 016407 0 ustar hornik users context("Scales")
test_that("buidling a plot does not affect its scales", {
dat <- data.frame(x = rnorm(20), y = rnorm(20))
p <- ggplot(dat, aes(x, y)) + geom_point()
expect_equal(length(p$scales$scales), 0)
ggplot_build(p)
expect_equal(length(p$scales$scales), 0)
})
test_that("ranges update only for variables listed in aesthetics", {
sc <- scale_alpha()
scale_train_df(sc, data.frame(alpha = 1:10))
expect_equal(sc$range$range, c(1, 10))
scale_train_df(sc, data.frame(alpha = 50))
expect_equal(sc$range$range, c(1, 50))
scale_train_df(sc, data.frame(beta = 100))
expect_equal(sc$range$range, c(1, 50))
scale_train_df(sc, data.frame())
expect_equal(sc$range$range, c(1, 50))
})
test_that("mapping works", {
sc <- scale_alpha(range = c(0, 1), na.value = 0)
scale_train_df(sc, data.frame(alpha = 1:10))
expect_equal(
scale_map_df(sc, data.frame(alpha = 1:10))[[1]],
round_any(seq(0, 1, length = 10), 1 / 500))
expect_equal(scale_map_df(sc, data.frame(alpha = NA))[[1]], 0)
expect_equal(
scale_map_df(sc, data.frame(alpha = c(-10, 11)))[[1]],
c(0, 0))
})
test_that("identity scale preserves input values", {
df <- data.frame(x = 1:3, z = letters[1:3])
p1 <- ggplot(df,
aes(x, z, colour = z, fill = z, shape = z, size = x, alpha = x)) +
geom_point() +
scale_colour_identity() +
scale_fill_identity() +
scale_shape_identity() +
scale_size_identity() +
scale_alpha_identity()
d1 <- pdata(p1)[[1]]
expect_that(d1$colour, equals(as.character(df$z)))
expect_that(d1$fill, equals(as.character(df$z)))
expect_that(d1$shape, equals(as.character(df$z)))
expect_that(d1$size, equals(as.numeric(df$z)))
expect_that(d1$alpha, equals(as.numeric(df$z)))
})
test_that("position scales updated by all position aesthetics", {
df <- data.frame(x = 1:3, y = 1:3)
aesthetics <- list(
aes(xend = x, yend = x),
aes(xmin = x, ymin = x),
aes(xmax = x, ymax = x),
aes(xintercept = x, yintercept = y)
)
base <- ggplot(df, aes(x = 1, y = 1)) + geom_point()
plots <- lapply(aesthetics, function(x) base %+% x)
ranges <- lapply(plots, pranges)
lapply(ranges, function(range) {
expect_that(range$x[[1]], equals(c(1, 3)))
expect_that(range$y[[1]], equals(c(1, 3)))
})
})
test_that("position scales generate after stats", {
df <- data.frame(x = factor(c(1, 1, 1)))
plot <- ggplot(df, aes(x)) + geom_bar()
ranges <- pranges(plot)
expect_that(ranges$x[[1]], equals(c("1")))
expect_that(ranges$y[[1]], equals(c(0, 3)))
})
test_that("oob affects position values", {
dat <- data.frame(x=c("a", "b", "c"), y=c(1, 5, 10))
base <- ggplot(dat, aes(x=x, y=y)) +
geom_bar(stat="identity") +
annotate("point", x = "a", y = c(-Inf, Inf))
y_scale <- function(limits, oob = censor) {
scale_y_continuous(limits = limits, oob = oob, expand = c(0, 0))
}
base + scale_y_continuous(limits=c(-0,5))
expect_warning(low_censor <- cdata(base + y_scale(c(0, 5), censor)),
"Removed 1 rows containing missing values")
expect_warning(mid_censor <- cdata(base + y_scale(c(3, 7), censor)),
"Removed 2 rows containing missing values")
low_squish <- cdata(base + y_scale(c(0, 5), squish))
mid_squish <- cdata(base + y_scale(c(3, 7), squish))
# Points are always at the top and bottom
expect_equal(low_censor[[2]]$y, c(0, 1))
expect_equal(mid_censor[[2]]$y, c(0, 1))
expect_equal(low_squish[[2]]$y, c(0, 1))
expect_equal(mid_squish[[2]]$y, c(0, 1))
# Bars depend on limits and oob
expect_equal(low_censor[[1]]$y, c(0.2, 1))
expect_equal(mid_censor[[1]]$y, c(0.5))
expect_equal(low_squish[[1]]$y, c(0.2, 1, 1))
expect_equal(mid_squish[[1]]$y, c(0, 0.5, 1))
})
test_that("scales looked for in appropriate place", {
xlabel <- function(x) ggplot_build(x)$panel$x_scales[[1]]$name
p0 <- qplot(mpg, wt, data = mtcars) + scale_x_continuous("0")
expect_equal(xlabel(p0), "0")
scale_x_continuous <- function(...) ggplot2::scale_x_continuous("1")
p1 <- qplot(mpg, wt, data = mtcars)
expect_equal(xlabel(p1), "1")
f <- function() {
scale_x_continuous <- function(...) ggplot2::scale_x_continuous("2")
qplot(mpg, wt, data = mtcars)
}
p2 <- f()
expect_equal(xlabel(p2), "2")
rm(scale_x_continuous)
p4 <- qplot(mpg, wt, data = mtcars)
expect_equal(xlabel(p4), NULL)
})
test_that("find_global searches in the right places", {
testenv <- new.env(parent = globalenv())
# This should find the scale object in the package environment
expect_identical(find_global("scale_colour_hue", testenv),
ggplot2::scale_colour_hue)
# Set an object with the same name in the environment
testenv$scale_colour_hue <- "foo"
# Now it should return the new object
expect_identical(find_global("scale_colour_hue", testenv), "foo")
# If we search in the empty env, we should end up with the object
# from the ggplot2 namespace
expect_identical(find_global("scale_colour_hue", emptyenv()),
ggplot2::scale_colour_hue)
})
ggplot2/inst/tests/test-boxplot.r 0000644 0001751 0000144 00000000600 12114160774 016613 0 ustar hornik users context("Boxplot")
# thanks wch for providing the test code
test_that("geom_boxplot range includes all outliers", {
dat <- data.frame(x=1, y=c(-(1:20)^3, (1:20)^3) )
p <- ggplot_build(ggplot(dat, aes(x,y)) + geom_boxplot())
miny <- p$panel$ranges[[1]]$y.range[1]
maxy <- p$panel$ranges[[1]]$y.range[2]
expect_true(miny <= min(dat$y))
expect_true(maxy >= max(dat$y))
})
ggplot2/inst/tests/test-scales-breaks-labels.r 0000644 0001751 0000144 00000020537 12114160774 021116 0 ustar hornik users context("Scales: breaks and labels")
test_that("labels match breaks, even when outside limits", {
sc <- scale_y_continuous(breaks=1:4, labels=1:4, limits = c(1, 3))
expect_equal(scale_breaks(sc), c(1:3, NA))
expect_equal(scale_labels(sc), 1:4)
expect_equal(scale_breaks_minor(sc), c(1, 1.5, 2, 2.5, 3))
})
test_that("labels must match breaks", {
expect_that(scale_x_discrete(breaks = 1:3, labels = 1:2),
throws_error("unequal lengths"))
expect_that(scale_x_continuous(breaks = 1:3, labels = 1:2),
throws_error("unequal lengths"))
})
test_that("labels don't have extra spaces", {
labels <- c("a", "abc", "abcdef")
sc1 <- scale_x_discrete(limits = labels)
sc2 <- scale_fill_discrete(limits = labels)
expect_equal(scale_labels(sc1), labels)
expect_equal(scale_labels(sc2), labels)
})
test_that("out-of-range breaks are dropped", {
# Limits are explicitly specified, automatic labels
sc <- scale_x_continuous(breaks=1:5, limits = c(2, 4))
bi <- scale_break_info(sc)
expect_equal(bi$labels, as.character(2:4))
expect_equal(bi$major, c(0, 0.5, 1))
expect_equal(bi$major_source, 2:4)
# Limits and labels are explicitly specified
sc <- scale_x_continuous(breaks=1:5, labels=letters[1:5], limits = c(2, 4))
bi <- scale_break_info(sc)
expect_equal(bi$labels, letters[2:4])
expect_equal(bi$major, c(0, 0.5, 1))
expect_equal(bi$major_source, 2:4)
# Limits are specified, and all breaks are out of range
sc <- scale_x_continuous(breaks=c(1,5), labels=letters[c(1,5)], limits = c(2, 4))
bi <- scale_break_info(sc)
expect_equal(length(bi$labels), 0)
expect_equal(length(bi$major), 0)
expect_equal(length(bi$major_source), 0)
# limits aren't specified, automatic labels
# limits are set by the data
sc <- scale_x_continuous(breaks=1:5)
scale_train_df(sc, data.frame(x=2:4))
bi <- scale_break_info(sc)
expect_equal(bi$labels, as.character(2:4))
expect_equal(bi$major_source, 2:4)
expect_equal(bi$major, c(0, 0.5, 1))
# Limits and labels are specified
sc <- scale_x_continuous(breaks=1:5, labels=letters[1:5])
scale_train_df(sc, data.frame(x=2:4))
bi <- scale_break_info(sc)
expect_equal(bi$labels, letters[2:4])
expect_equal(bi$major_source, 2:4)
expect_equal(bi$major, c(0, 0.5, 1))
# Limits aren't specified, and all breaks are out of range of data
sc <- scale_x_continuous(breaks=c(1,5), labels=letters[c(1,5)])
scale_train_df(sc, data.frame(x=2:4))
bi <- scale_break_info(sc)
expect_equal(length(bi$labels), 0)
expect_equal(length(bi$major), 0)
expect_equal(length(bi$major_source), 0)
})
test_that("no minor breaks when only one break", {
sc1 <- scale_x_discrete(limits = "a")
sc2 <- scale_x_continuous(limits = 1)
expect_equal(length(scale_breaks_minor(sc1)), 0)
expect_equal(length(scale_breaks_minor(sc2)), 0)
})
init_scale <- function(...) {
sc <- scale_x_discrete(...)
scale_train(sc, factor(1:100))
expect_that(length(scale_limits(sc)), equals(100))
sc
}
test_that("discrete labels match breaks", {
sc <- init_scale(breaks = 0:5 * 10)
expect_equal(length(scale_breaks(sc)), 5)
expect_equal(length(scale_labels(sc)), 5)
expect_equivalent(scale_labels(sc), scale_breaks(sc))
sc <- init_scale(breaks = 0:5 * 10, labels = letters[1:6])
expect_equal(length(scale_breaks(sc)), 5)
expect_equal(length(scale_labels(sc)), 5)
expect_equal(scale_labels(sc), letters[2:6])
sc <- init_scale(breaks = 0:5 * 10, labels =
function(x) paste(x, "-", sep = ""))
expect_equal(scale_labels(sc), c("10-", "20-", "30-", "40-", "50-"))
pick_5 <- function(x) sample(x, 5)
sc <- init_scale(breaks = pick_5)
expect_equal(length(scale_breaks(sc)), 5)
expect_equal(length(scale_labels(sc)), 5)
})
test_that("scale breaks with numeric log transformation", {
sc <- scale_x_continuous(limits = c(1, 1e5), trans = log10_trans())
expect_equal(scale_breaks(sc), c(0, 2, 4)) # 1, 100, 10000
expect_equal(scale_breaks_minor(sc), c(0, 1, 2, 3, 4, 5))
})
test_that("continuous scales with no data have no breaks or labels", {
sc <- scale_x_continuous()
expect_equal(scale_breaks(sc), numeric())
expect_equal(scale_labels(sc), character())
expect_equal(scale_limits(sc), c(0, 1))
})
test_that("discrete scales with no data have no breaks or labels", {
sc <- scale_x_discrete()
expect_equal(scale_breaks(sc), numeric())
expect_equal(scale_labels(sc), character())
expect_equal(scale_limits(sc), c(0, 1))
})
test_that("suppressing breaks, minor_breask, and labels", {
expect_equal(scale_breaks(scale_x_continuous(breaks = NULL, limits = c(1, 3))), NULL)
expect_equal(scale_breaks(scale_x_discrete(breaks = NULL, limits = c(1, 3))), NULL)
expect_equal(scale_breaks_minor(scale_x_continuous(minor_breaks = NULL, limits = c(1, 3))), NULL)
expect_equal(scale_labels(scale_x_continuous(labels = NULL, limits = c(1, 3))), NULL)
expect_equal(scale_labels(scale_x_discrete(labels = NULL, limits = c(1, 3))), NULL)
# date, datetime
lims <- as.Date(c("2000/1/1", "2000/2/1"))
expect_equal(scale_breaks(scale_x_date(breaks = NULL, limits = lims)), NULL)
# NA is deprecated, should throw warning
expect_warning(s <- scale_breaks(scale_x_date(breaks = NA, limits = lims)))
expect_equal(s, NULL)
expect_equal(scale_labels(scale_x_date(labels = NULL, limits = lims)), NULL)
expect_warning(s <- scale_labels(scale_x_date(labels = NA, limits = lims)))
expect_equal(s, NULL)
expect_equal(scale_breaks_minor(scale_x_date(minor_breaks= NULL, limits = lims)), NULL)
expect_warning(s <-scale_breaks_minor(scale_x_date(minor_breaks= NA, limits = lims)))
expect_equal(s, NULL)
# date, datetime
lims <- as.POSIXct(c("2000/1/1 0:0:0", "2010/1/1 0:0:0"))
expect_equal(scale_breaks(scale_x_datetime(breaks = NULL, limits = lims)), NULL)
expect_warning(s <- scale_breaks(scale_x_datetime(breaks = NA, limits = lims)))
expect_equal(s, NULL)
expect_equal(scale_labels(scale_x_datetime(labels = NULL, limits = lims)), NULL)
expect_warning(s <- scale_labels(scale_x_datetime(labels = NA, limits = lims)))
expect_equal(s, NULL)
expect_equal(scale_breaks_minor(scale_x_datetime(minor_breaks= NULL, limits = lims)), NULL)
expect_warning(s <- scale_breaks_minor(scale_x_datetime(minor_breaks= NA, limits = lims)))
expect_equal(s, NULL)
})
test_that("scale_breaks with explicit NA options (deprecated)", {
# NA is deprecated, should throw warning
# X
sxc <- scale_x_continuous(breaks=NA)
scale_train(sxc, 1:3)
expect_warning(s <- scale_breaks(sxc))
expect_identical(s, NULL)
expect_warning(s <- scale_breaks_minor(sxc))
expect_identical(s, NULL)
# Y
syc <- scale_y_continuous(breaks=NA)
scale_train(syc, 1:3)
expect_warning(s <- scale_breaks(syc))
expect_identical(s, NULL)
expect_warning(s <- scale_breaks_minor(syc))
expect_identical(s, NULL)
# Alpha
sac <- scale_alpha_continuous(breaks=NA)
scale_train(sac,1:3)
expect_warning(s <- scale_breaks(sac))
expect_identical(s, NULL)
# Size
ssc <- scale_size_continuous(breaks=NA)
scale_train(ssc,1:3)
expect_warning(s <- scale_breaks(ssc))
expect_identical(s, NULL)
# Fill
sfc <- scale_fill_continuous(breaks=NA)
scale_train(sfc,1:3)
expect_warning(s <- scale_breaks(sfc))
expect_identical(s, NULL)
# Colour
scc <- scale_colour_continuous(breaks=NA)
scale_train(scc,1:3)
expect_warning(s <- scale_breaks(scc))
expect_identical(s, NULL)
})
test_that("breaks can be specified by names of labels", {
labels <- setNames(LETTERS[1:4], letters[1:4])
s <- scale_x_discrete(limits = letters[1:4], labels = labels)
expect_equal(as.vector(scale_breaks(s)), letters[1:4])
expect_equal(as.vector(scale_labels(s)), LETTERS[1:4])
s <- scale_x_discrete(limits = letters[1:4], labels = rev(labels))
expect_equal(as.vector(scale_breaks(s)), letters[1:4])
expect_equal(as.vector(scale_labels(s)), LETTERS[1:4])
s <- scale_x_discrete(limits = letters[1:4], labels = labels[1:2])
expect_equal(as.vector(scale_breaks(s)), letters[1:4])
expect_equal(as.vector(scale_labels(s)), c("A", "B", "c", "d"))
s <- scale_x_discrete(limits = letters[1:4], labels = labels[3:4])
expect_equal(as.vector(scale_breaks(s)), letters[1:4])
expect_equal(as.vector(scale_labels(s)), c("a", "b", "C", "D"))
s <- scale_x_discrete(limits = letters[1:3], labels = labels)
expect_equal(as.vector(scale_breaks(s)), letters[1:3])
expect_equal(as.vector(scale_labels(s)), LETTERS[1:3])
})
ggplot2/inst/tests/test-aes.r 0000644 0001751 0000144 00000005347 12114160774 015711 0 ustar hornik users context("Creating aesthetic mappings")
test_that("function aes", {
expect_equal(aes(x = mpg, y = wt),
structure(list(x = bquote(mpg), y = bquote(wt)), class = "uneval"))
expect_equal(aes(x = mpg ^ 2, y = wt / cyl),
structure(list(x = bquote(mpg ^ 2), y = bquote(wt / cyl)), class = "uneval"))
})
test_that("function aes_string", {
expect_equal(aes_string(x = "mpg", y = "wt"),
structure(list(x = bquote(mpg), y = bquote(wt)), class = "uneval"))
expect_equal(aes_string(x = "mpg ^ 2", y = "wt / cyl"),
structure(list(x = bquote(mpg ^ 2), y = bquote(wt / cyl)), class = "uneval"))
})
test_that("function aes_all", {
expect_equal(aes_all(names(mtcars)),
structure(
list(
mpg = bquote(mpg),
cyl = bquote(cyl),
disp = bquote(disp),
hp = bquote(hp),
drat = bquote(drat),
wt = bquote(wt),
qsec = bquote(qsec),
vs = bquote(vs),
am = bquote(am),
gear = bquote(gear),
carb = bquote(carb)),
class = "uneval"))
expect_equal(aes_all(c("x", "y", "col", "pch")),
structure(list(x = bquote(x), y = bquote(y), colour = bquote(col), shape = bquote(pch)), class = "uneval"))
})
test_that("function aes_auto", {
df <- data.frame(x = 1, y = 1, colour = 1, label = 1, pch = 1)
expect_equal(aes_auto(df),
structure(list(colour = bquote(colour), label = bquote(label), shape = bquote(pch), x = bquote(x), y = bquote(y)), class = "uneval"))
expect_equal(aes_auto(names(df)),
structure(list(colour = bquote(colour), label = bquote(label), shape = bquote(pch), x = bquote(x), y = bquote(y)), class = "uneval"))
df <- data.frame(xp = 1:3, y = 1:3, colour = 1:3, txt = letters[1:3], foo = 1:3)
expect_equal(aes_auto(df, x = xp, label = txt),
structure(list(colour = bquote(colour), y = bquote(y), x = bquote(xp), label = bquote(txt)), class = "uneval"))
expect_equal(aes_auto(names(df), x = xp, label = txt),
structure(list(colour = bquote(colour), y = bquote(y), x = bquote(xp), label = bquote(txt)), class = "uneval"))
expect_equal(aes_auto(x = xp, label = txt, data = df),
structure(list(colour = bquote(colour), y = bquote(y), x = bquote(xp), label = bquote(txt)), class = "uneval"))
df <- data.frame(foo = 1:3)
expect_equal(aes_auto(df, x = xp, y = yp),
structure(list(x = bquote(xp), y = bquote(yp)), class = "uneval"))
expect_equal(aes_auto(df), structure(setNames(list(), character(0)), class = "uneval"))
})
ggplot2/inst/tests/test-qplot.r 0000644 0001751 0000144 00000001154 12114160774 016270 0 ustar hornik users context("qplot")
test_that("qplot works with variables in data frame and parent env", {
df <- data.frame(x = 1:10, a = 1:10)
y <- 1:10
b <- 1:10
expect_is(qplot(x, y, data = df), "ggplot")
expect_is(qplot(x, y, data = df, colour = a), "ggplot")
expect_is(qplot(x, y, data = df, colour = b), "ggplot")
bin <- 1
expect_is(qplot(x, data = df, binwidth = bin), "ggplot")
})
test_that("qplot works in non-standard environments", {
env <- new.env(parent = globalenv())
expr <- quote({
`-1-` <- 10
x <- 1:10
qplot(x, breaks = 0:`-1-`)
})
expect_is(eval(expr, env), "ggplot")
})
ggplot2/inst/tests/test-facet-.r 0000644 0001751 0000144 00000003331 12114160774 016267 0 ustar hornik users context("Facetting")
df <- data.frame(x = 1:3, y = 3:1, z = letters[1:3])
test_that("facets split up the data", {
l1 <- ggplot(df, aes(x, y)) + geom_point() + facet_wrap(~ z)
d1 <- pdata(l1)[[1]]
expect_that(d1$PANEL, equals(factor(1:3)))
l2 <- ggplot(df, aes(x, y)) + geom_point() + facet_grid(. ~ z)
l3 <- ggplot(df, aes(x, y)) + geom_point() + facet_grid(z ~ .)
d2 <- pdata(l2)[[1]]
d3 <- pdata(l3)[[1]]
expect_that(d2, equals(d3))
expect_that(sort(names(d2)), equals(sort(c("x", "y", "group", "PANEL"))))
expect_that(d2$PANEL, equals(factor(1:3)))
})
test_that("facets with free scales scale independently", {
l1 <- ggplot(df, aes(x, y)) + geom_point() +
facet_wrap(~ z, scales = "free")
d1 <- cdata(l1)[[1]]
expect_that(length(unique(d1$x)), equals(1))
expect_that(length(unique(d1$y)), equals(1))
l2 <- ggplot(df, aes(x, y)) + geom_point() +
facet_grid(. ~ z, scales = "free")
d2 <- cdata(l2)[[1]]
expect_that(length(unique(d2$x)), equals(1))
expect_that(length(unique(d2$y)), equals(3))
l3 <- ggplot(df, aes(x, y)) + geom_point() +
facet_grid(z ~ ., scales = "free")
d3 <- cdata(l3)[[1]]
expect_that(length(unique(d3$x)), equals(3))
expect_that(length(unique(d3$y)), equals(1))
})
test_that("shrink parameter affects scaling", {
l1 <- ggplot(df, aes(1, y)) + geom_point()
r1 <- pranges(l1)
expect_that(r1$x[[1]], equals(c(1, 1)))
expect_that(r1$y[[1]], equals(c(1, 3)))
l2 <- ggplot(df, aes(1, y)) + stat_summary(fun.y = "mean")
r2 <- pranges(l2)
expect_that(r2$y[[1]], equals(c(2, 2)))
l3 <- ggplot(df, aes(1, y)) + stat_summary(fun.y = "mean") +
facet_null(shrink = FALSE)
r3 <- pranges(l3)
expect_that(r3$y[[1]], equals(c(1, 3)))
})
ggplot2/inst/tests/test-facet-layout.r 0000644 0001751 0000144 00000010675 12114160774 017536 0 ustar hornik users context("Facetting (layout)")
a <- data.frame(a = c(1, 1, 2, 2), b = c(1, 2, 1, 1))
b <- data.frame(a = 3)
c <- data.frame(b = 3)
empty <- data.frame()
test_that("all: no rows and cols gives null layout", {
expect_that(layout_grid(list(a)), equals(layout_null()))
expect_that(layout_wrap(list(a)), equals(layout_null()))
})
test_that("grid: single row and single col equivalent", {
row <- layout_grid(list(a), row = "a")
col <- layout_grid(list(a), col = "a")
expect_that(row$ROW, equals(1:2))
expect_that(row$ROW, equals(col$COL))
expect_that(row[c("PANEL", "a")], equals(col[c("PANEL", "a")]))
row <- layout_grid(list(a, b), row = "a")
col <- layout_grid(list(a, b), col = "a")
expect_that(row$ROW, equals(1:3))
expect_that(row$ROW, equals(col$COL))
expect_that(row[c("PANEL", "a")], equals(col[c("PANEL", "a")]))
})
test_that("grid: includes all combinations", {
d <- data.frame(a = c(1, 2), b = c(2, 1))
all <- layout_grid(list(d), row = "a", col = "b")
expect_that(nrow(all), equals(4))
})
test_that("wrap and grid equivalent for 1d data", {
rowg <- layout_grid(list(a), row = "a")
roww <- layout_wrap(list(a), "a", ncol = 1)
expect_that(roww, equals(rowg))
colg <- layout_grid(list(a), col = "a")
colw <- layout_wrap(list(a), "a", nrow = 1)
expect_that(colw, equals(colg))
})
test_that("grid: crossed rows/cols create no more combinations than necessary", {
one <- layout_grid(list(a), "a", "b")
expect_that(nrow(one), equals(4))
one_a <- layout_grid(list(a, empty), "a", "b")
expect_that(nrow(one_a), equals(4))
two <- layout_grid(list(a, b), "a", "b")
expect_that(nrow(two), equals(4 + 2))
three <- layout_grid(list(a, b, c), "a", "b")
expect_that(nrow(three), equals(9))
four <- layout_grid(list(b, c), "a", "b")
expect_that(nrow(four), equals(1))
})
test_that("grid: nested rows/cols create no more combinations than necessary", {
one <- layout_grid(list(mpg), c("drv", "cyl"))
expect_that(one$PANEL, equals(factor(1:9)))
expect_that(one$ROW, equals(1:9))
})
test_that("grid: margins add correct combinations", {
one <- layout_grid(list(a), "a", "b", margins = TRUE)
expect_that(nrow(one), equals(4 + 2 + 2 + 1))
})
test_that("wrap: as.table reverses rows", {
one <- layout_wrap(list(a), "a", ncol = 1, as.table = FALSE)
expect_that(one$ROW, equals(c(2, 1)))
two <- layout_wrap(list(a), "a", nrow = 1, as.table = FALSE)
expect_that(two$ROW, equals(c(1, 1)))
})
test_that("grid: as.table reverses rows", {
one <- layout_grid(list(a), "a", as.table = FALSE)
expect_that(as.character(one$a), equals(c("2", "1")))
two <- layout_grid(list(a), "a", as.table = TRUE)
expect_that(as.character(two$a), equals(c("1", "2")))
})
# Drop behaviour -------------------------------------------------------------
a2 <- data.frame(
a = factor(1:3, levels = 1:4),
b = factor(1:3, levels = 4:1)
)
test_that("layout_wrap: drop = FALSE preserves unused levels", {
wrap_a <- layout_wrap(list(a2), "a", drop = FALSE)
expect_equal(nrow(wrap_a), 4)
expect_equal(as.character(wrap_a$a), as.character(1:4))
wrap_b <- layout_wrap(list(a2), "b", drop = FALSE)
expect_equal(nrow(wrap_b), 4)
expect_equal(as.character(wrap_b$b), as.character(4:1))
})
test_that("layout_grid: drop = FALSE preserves unused levels", {
grid_a <- layout_grid(list(a2), "a", drop = FALSE)
expect_equal(nrow(grid_a), 4)
expect_equal(as.character(grid_a$a), as.character(1:4))
grid_b <- layout_grid(list(a2), "b", drop = FALSE)
expect_equal(nrow(grid_b), 4)
expect_equal(as.character(grid_b$b), as.character(4:1))
grid_ab <- layout_grid(list(a2), "a", "b", drop = FALSE)
expect_equal(nrow(grid_ab), 16)
expect_equal(as.character(grid_ab$a), as.character(rep(1:4, each = 4)))
expect_equal(as.character(grid_ab$b), as.character(rep(4:1, 4)))
})
# Missing behaviour ----------------------------------------------------------
a3 <- data.frame(
a = c(1:3, NA),
b = factor(c(1:3, NA)),
c = factor(c(1:3, NA), exclude = NULL)
)
test_that("missing values get a panel", {
wrap_a <- layout_wrap(list(a3), "a")
wrap_b <- layout_wrap(list(a3), "b")
wrap_c <- layout_wrap(list(a3), "c")
grid_a <- layout_grid(list(a3), "a")
grid_b <- layout_grid(list(a3), "b")
grid_c <- layout_grid(list(a3), "c")
expect_equal(nrow(wrap_a), 4)
expect_equal(nrow(wrap_b), 4)
expect_equal(nrow(wrap_c), 4)
expect_equal(nrow(grid_a), 4)
expect_equal(nrow(grid_b), 4)
expect_equal(nrow(grid_c), 4)
}) ggplot2/inst/tests/test-stats.r 0000644 0001751 0000144 00000011034 12114160774 016265 0 ustar hornik users context("Stats")
test_that("plot succeeds even if some computation fails", {
p1 <- ggplot(mtcars, aes(disp, mpg)) +
geom_point() +
facet_grid(gear ~ carb)
p2 <- p1 + geom_smooth()
b1 <- ggplot_build(p1)
expect_equal(length(b1$data), 1)
expect_warning(b2 <- ggplot_build(p2))
expect_equal(length(b2$data), 2)
})
# helper function for stat calc tests.
test_stat <- function(stat) {
stat$data <- transform(stat$data, PANEL = 1)
dat <- stat$compute_aesthetics(stat$data, ggplot())
dat <- add_group(dat)
stat$calc_statistic(dat, NULL)
}
context("stat-bin")
test_that("stat_sum", {
dat <- data.frame(x = c("a", "b", "c"), y = c(1, 5, 10))
# Should get a message when mapping/setting y and also using stat_bin
expect_message(p <- ggplot_build(ggplot(dat, aes(x=x, y=y)) + geom_bar()),
"Mapping a variable to y and also using stat=\"bin\"")
expect_message(p <- ggplot_build(ggplot(dat, aes(x=x, y=y)) + geom_bar(stat="bin")),
"Mapping a variable to y and also using stat=\"bin\"")
expect_message(p <- ggplot_build(ggplot(dat, aes(x=x)) + geom_bar(y=5)),
"Mapping a variable to y and also using stat=\"bin\"")
# This gives an error and a message (it would probably be OK if just one
# of these happened, but this test looks for both)
dat2 <- data.frame(x = c("a", "b", "c", "a", "b", "c"), y = c(1, 5, 10, 2, 3, 4))
expect_message(expect_error(
p <- ggplot_build(ggplot(dat2, aes(x=x, y=y)) + geom_bar())))
})
context("stat-sum")
test_that("stat_sum", {
d <- diamonds[1:1000, ]
ret <- test_stat(stat_sum(aes(x = cut, y = clarity), data = d))
expect_equal(dim(ret), c(38, 5))
expect_equal(sum(ret$n), nrow(d))
expect_true(all(ret$prop == 1))
ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = 1), data = d))
expect_equal(dim(ret), c(38, 5))
expect_equal(sum(ret$n), nrow(d))
expect_equal(sum(ret$prop), 1)
ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = cut), data = d))
expect_equal(dim(ret), c(38, 5))
expect_equal(sum(ret$n), nrow(d))
expect_true(all(ddply(ret, .(x), summarise, prop = sum(prop))$prop == 1))
ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = cut, colour = cut), data = d))
expect_equal(dim(ret), c(38, 6))
expect_equal(ret$x, ret$colour)
expect_equal(sum(ret$n), nrow(d))
expect_true(all(ddply(ret, .(x), summarise, prop = sum(prop))$prop == 1))
ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = clarity), data = d))
expect_equal(dim(ret), c(38, 5))
expect_equal(sum(ret$n), nrow(d))
expect_true(all(ddply(ret, .(y), summarise, prop = sum(prop))$prop == 1))
ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = clarity, colour = cut), data = d))
expect_equal(dim(ret), c(38, 6))
expect_equal(ret$x, ret$colour)
expect_equal(sum(ret$n), nrow(d))
expect_true(all(ddply(ret, .(y), summarise, prop = sum(prop))$prop == 1))
ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = 1, weight = price), data = d))
expect_equal(dim(ret), c(38, 5))
expect_equal(sum(ret$n), sum(d$price))
expect_equal(sum(ret$prop), 1)
})
# helper function for stat calc tests.
test_stat_scale <- function(stat, scale) {
stat$data <- transform(stat$data, PANEL = 1)
dat <- stat$compute_aesthetics(stat$data, ggplot())
dat <- add_group(dat)
stat$calc_statistic(dat, scale)
}
context("stat-bin2d")
test_that("stat-bin2d", {
d <- diamonds[1:1000,]
full_scales <- list(x = scale_x_continuous(limits = range(d$carat, na.rm=TRUE)),
y = scale_y_continuous(limits = range(d$depth, na.rm=TRUE)))
ret <- test_stat_scale(stat_bin2d(aes(x = carat, y = depth), data=d), full_scales)
expect_equal(dim(ret), c(191,12))
d$carat[1] <- NA
d$depth[2] <- NA
full_scales <- list(x = scale_x_continuous(limits = range(d$carat, na.rm=TRUE)),
y = scale_y_continuous(limits = range(d$depth, na.rm=TRUE)))
ret <- test_stat_scale(stat_bin2d(aes(x = carat, y = depth), data=d), full_scales)
expect_equal(dim(ret), c(191,12))
})
context("stat-density2d")
test_that("stat-density2d", {
full_scales <- list(x = scale_x_continuous(limits=c(1,6)),
y = scale_y_continuous(limits=c(5,40)))
ret <- test_stat_scale(stat_density2d(aes(x = wt, y = mpg), data = mtcars), full_scales)
# Check that the contour data goes beyond data range.
# The specific values below are sort of arbitrary; but they go beyond the range
# of the data
expect_true(min(ret$x) < 1.2)
expect_true(max(ret$x) > 5.8)
expect_true(min(ret$y) < 8)
expect_true(max(ret$y) > 35)
})
ggplot2/inst/tests/test-theme.r 0000644 0001751 0000144 00000014617 12114160774 016243 0 ustar hornik users context("Themes")
test_that("Modifying theme element properties with + operator", {
# Changing a "leaf node" works
t <- theme_grey() + theme(axis.title.x = element_text(colour='red'))
expect_identical(t$axis.title.x, element_text(colour='red'))
# Make sure the theme class didn't change or get dropped
expect_true(is.theme(t))
# Make sure the element class didn't change or get dropped
expect_true(inherits(t$axis.title.x, "element"))
expect_true(inherits(t$axis.title.x, "element_text"))
# Modifying an intermediate node works
t <- theme_grey() + theme(axis.title = element_text(colour='red'))
expect_identical(t$axis.title, element_text(colour='red'))
# Modifying a root node changes only the specified properties
t <- theme_grey() + theme(text = element_text(colour='red'))
expect_identical(t$text$colour, 'red')
expect_identical(t$text$family, theme_grey()$text$family)
expect_identical(t$text$face, theme_grey()$text$face)
expect_identical(t$text$size, theme_grey()$text$size)
# Descendent is unchanged
expect_identical(t$axis.title.x, theme_grey()$axis.title.x)
# Adding element_blank replaces element
t <- theme_grey() + theme(axis.text.y = element_blank())
expect_identical(t$axis.text.y, element_blank())
# Adding a non-blank element to an element_blank() replaces it
t <- t + theme(axis.text.y = element_text(colour='red'))
expect_identical(t$axis.text.y, element_text(colour='red'))
# Adding empty theme() has no effect
t <- theme_grey() + theme()
expect_identical(t, theme_grey())
expect_error(theme_grey() + "asdf")
})
test_that("Adding theme object to ggplot object with + operator", {
p <- qplot(1:3, 1:3)
p <- p + theme(axis.title = element_text(size = 20))
expect_true(p$theme$axis.title$size == 20)
# Should update specified properties, but not reset other properties
p <- p + theme(text = element_text(colour='red'))
expect_true(p$theme$text$colour == 'red')
tt <- theme_grey()$text
tt$colour <- 'red'
expect_identical(p$theme$text, tt)
})
test_that("Replacing theme elements with %+replace% operator", {
# Changing a "leaf node" works
t <- theme_grey() %+replace% theme(axis.title.x = element_text(colour='red'))
expect_identical(t$axis.title.x, element_text(colour='red'))
# Make sure the class didn't change or get dropped
expect_true(is.theme(t))
# Changing an intermediate node works
t <- theme_grey() %+replace% theme(axis.title = element_text(colour='red'))
expect_identical(t$axis.title, element_text(colour='red'))
# Descendent is unchanged
expect_identical(t$axis.title.x, theme_grey()$axis.title.x)
# Adding empty theme() has no effect
t <- theme_grey() %+replace% theme()
expect_identical(t, theme_grey())
expect_error(theme_grey() + "asdf")
})
test_that("Calculating theme element inheritance", {
t <- theme_grey() + theme(axis.title = element_text(colour='red'))
# Check that properties are passed along from axis.title to axis.title.x
e <- calc_element('axis.title.x', t)
expect_identical(e$colour, 'red')
expect_false(is.null(e$family))
expect_false(is.null(e$face))
expect_false(is.null(e$size))
# Check that rel() works for relative sizing, and is applied at each level
t <- theme_grey(base_size=12) +
theme(axis.title = element_text(size=rel(0.5))) +
theme(axis.title.x = element_text(size=rel(0.5)))
e <- calc_element('axis.title', t)
expect_identical(e$size, 6)
ex <- calc_element('axis.title.x', t)
expect_identical(ex$size, 3)
# Check that a theme_blank in a parent node gets passed along to children
t <- theme_grey() + theme(text = element_blank())
expect_identical(calc_element('axis.title.x', t), element_blank())
})
test_that("Complete and non-complete themes interact correctly with each other", {
# The 'complete' attribute of t1 + t2 is the OR of their 'complete' attributes.
# But for _element properties_, the one on the right modifies the one on the left.
t <- theme_bw() + theme(text = element_text(colour='red'))
expect_true(attr(t, "complete"))
expect_equal(t$text$colour, 'red')
# A complete theme object (like theme_bw) always trumps a non-complete theme object
t <- theme(text = element_text(colour='red')) + theme_bw()
expect_true(attr(t, "complete"))
expect_equal(t$text$colour, theme_bw()$text$colour)
# Adding two non-complete themes: the one on the right modifies the one on the left.
t <- theme(text = element_text(colour='blue')) +
theme(text = element_text(colour='red'))
expect_false(attr(t, "complete"))
expect_equal(t$text$colour, 'red')
})
test_that("Complete and non-complete themes interact correctly with ggplot objects", {
# Check that adding two theme successive theme objects to a ggplot object
# works like adding the two theme object to each other
p <- ggplot_build(qplot(1:3, 1:3) + theme_bw() + theme(text=element_text(colour='red')))
expect_true(attr(p$plot$theme, "complete"))
# Compare the theme objects, after sorting the items, because item order can differ
pt <- p$plot$theme
tt <- theme_bw() + theme(text=element_text(colour='red'))
pt <- pt[order(names(pt))]
tt <- tt[order(names(tt))]
expect_identical(pt, tt)
p <- ggplot_build(qplot(1:3, 1:3) + theme(text=element_text(colour='red')) + theme_bw())
expect_true(attr(p$plot$theme, "complete"))
# Compare the theme objects, after sorting the items, because item order can differ
pt <- p$plot$theme
tt <- theme(text=element_text(colour='red')) + theme_bw()
pt <- pt[order(names(pt))]
tt <- tt[order(names(tt))]
expect_identical(pt, tt)
p <- ggplot_build(qplot(1:3, 1:3) + theme(text=element_text(colour='red', face='italic')))
expect_false(attr(p$plot$theme, "complete"))
expect_equal(p$plot$theme$text$colour, "red")
expect_equal(p$plot$theme$text$face, "italic")
p <- ggplot_build(qplot(1:3, 1:3) + theme(text=element_text(colour='red')) +
theme(text=element_text(face='italic')))
expect_false(attr(p$plot$theme, "complete"))
expect_equal(p$plot$theme$text$colour, "red")
expect_equal(p$plot$theme$text$face, "italic")
# Only gets red property; because of the way lists are processed in R, the
# the second item doesn't get used properly. But I think that's OK.
p <- ggplot_build(qplot(1:3, 1:3) +
theme(text=element_text(colour='red'), text=element_text(face='italic')))
expect_false(attr(p$plot$theme, "complete"))
expect_equal(p$plot$theme$text$colour, "red")
expect_equal(p$plot$theme$text$face, "plain")
})
ggplot2/inst/tests/test-aes-grouping.r 0000644 0001751 0000144 00000004167 12114160774 017540 0 ustar hornik users context("Aesthetics (grouping)")
df <- data.frame(
x = 1:4,
a = c("a", "a", "b", "b"),
b = c("a", "b", "a", "b")
)
library(plyr)
group <- function(x) pdata(x)[[1]]$group
groups <- function(x) length(unique(group(x)))
test_that("one group per combination of discrete vars", {
plot <- ggplot(df, aes(x, x)) + geom_point()
expect_that(group(plot), equals(c(1, 1, 1, 1)))
plot <- ggplot(df, aes(x, a)) + geom_point()
expect_that(group(plot), equals(c(1, 1, 2, 2)))
plot <- ggplot(df, aes(x, b)) + geom_point()
expect_that(group(plot), equals(c(1, 2, 1, 2)))
plot <- ggplot(df, aes(a, b)) + geom_point()
expect_that(groups(plot), equals(4))
})
test_that("label is not used as a grouping var", {
plot <- ggplot(df, aes(x, x, label = a)) + geom_point()
expect_that(group(plot), equals(c(1, 1, 1, 1)))
plot <- ggplot(df, aes(x, x, colour = a, label = b)) + geom_point()
expect_that(group(plot), equals(c(1, 1, 2, 2)))
})
test_that("group aesthetic overrides defaults", {
plot <- ggplot(df, aes(x, x, group = x)) + geom_point()
expect_that(groups(plot), equals(4))
plot <- ggplot(df, aes(a, b, group = 1)) + geom_point()
expect_that(groups(plot), equals(1))
})
# test_that("group param overrides defaults", {
# plot <- ggplot(df, aes(a, b)) + geom_point(group = 1)
# expect_that(groups(plot), equals(1))
# })
test_that("order affects plotting order of points", {
base <- ggplot(df, aes(a, x)) + geom_point()
ord1 <- ggplot_build(base)$data[[1]]
ord2 <- ggplot_build(base + aes(order = x))$data[[1]]
rev1 <- ggplot_build(base + aes(order = -x))$data[[1]]
rev2 <- ggplot_build(base + aes(order = desc(x)))$data[[1]]
expect_equal(ord1$y, 1:4)
expect_equal(ord2$y, 1:4)
expect_equal(rev1$y, 4:1)
expect_equal(rev2$y, 4:1)
})
test_that("order affects plotting order of bars", {
base <- ggplot(df, aes(a, fill = b)) + geom_bar()
ord1 <- ggplot_build(base)$data[[1]]
ord2 <- ggplot_build(base + aes(order = a))$data[[1]]
rev1 <- ggplot_build(base + aes(order = desc(b)))$data[[1]]
expect_equal(ord1$group, 1:4)
expect_equal(ord2$group, 1:4)
expect_equal(rev1$group, c(2, 1, 4, 3))
}) ggplot2/inst/tests/test-coord-train.r 0000644 0001751 0000144 00000002502 12114160774 017350 0 ustar hornik users context("coord_train")
test_that("NA's don't appear in breaks", {
# Returns true if any major/minor breaks have an NA
any_NA_major_minor <- function(trained) {
ns <- names(trained)[grepl("(\\.major)|(\\.minor)$", names(trained))]
for (n in ns) {
if (!is.null(trained[n]) && any(is.na(trained[n])))
return(TRUE)
}
return(FALSE)
}
scales <- list(x = scale_x_continuous(limits=c(1, 12)),
y = scale_y_continuous(limits=c(1, 12)))
# First have to test that scale_breaks_positions will return a vector with NA
# This is a test to make sure the later tests will be useful!
# It's possible that changes to the the way that breaks are calculated will
# make it so that scale_break_positions will no longer give NA for range 1, 12
expect_true(any(is.na(scale_break_positions(scales$x))))
expect_true(any(is.na(scale_break_positions(scales$y))))
# Check the various types of coords to make sure they don't have NA breaks
expect_false(any_NA_major_minor(coord_train(coord_polar(), scales)))
expect_false(any_NA_major_minor(coord_train(coord_cartesian(), scales)))
expect_false(any_NA_major_minor(coord_train(coord_trans(), scales)))
expect_false(any_NA_major_minor(coord_train(coord_fixed(), scales)))
expect_false(any_NA_major_minor(coord_train(coord_map(), scales)))
})
ggplot2/R/ 0000755 0001751 0000144 00000000000 12114161113 012036 5 ustar hornik users ggplot2/R/aes-linetype-size-shape.r 0000644 0001751 0000144 00000005072 12114160774 016706 0 ustar hornik users #' Differentiation related aesthetics: linetype, size, shape
#'
#' This page demonstrates the usage of a sub-group
#' of aesthetics; linetype, size and shape.
#'
#' @name aes_linetype_size_shape
#' @aliases linetype size shape
#' @examples
#'
#' # Line types should be specified with either an integer, a name, or with a string of
#' # an even number (up to eight) of hexidecimal digits which give the lengths in
#' # consecutive positions in the string.
#' # 0 = blank, 1 = solid, 2 = dashed, 3 = dotted, 4 = dotdash, 5 = longdash, 6 = twodash
#'
#' # Data
#' df <- data.frame(x = 1:10 , y = 1:10)
#' f <- ggplot(df, aes(x = x, y = y))
#' f + geom_line(linetype = 2)
#' f + geom_line(linetype = "dotdash")
#
#' # An example with hex strings, the string "33" specifies three units on followed
#' # by three off and "3313" specifies three units on followed by three off followed
#' # by one on and finally three off.
#' f + geom_line(linetype = "3313")
#'
#' # Mapping line type from a variable
#' library(plyr)
#' library(reshape2)
#' rescale01 <- function(x) (x - min(x)) / diff(range(x))
#' ec_scaled <- data.frame(
#' date = economics$date,
#' colwise(rescale01)(economics[, -(1:2)]))
#' ecm <- melt(ec_scaled, id = "date")
#' qplot(date, value, data = ecm, geom = "line", linetype = variable)
#'
#' # Size examples
#' # Should be specified with a numerical value (in millimetres),
#' # or from a variable source
#' p <- ggplot(mtcars, aes(wt, mpg))
#' p + geom_point(size = 4)
#' p + geom_point(aes(size = qsec))
#' p + geom_point(size = 2.5) + geom_hline(yintercept = 25, size = 3.5)
#'
#' # Shape examples
#' # Shape takes four types of values: an integer in [0, 25],
#' # a single character-- which uses that character as the plotting symbol,
#' # a . to draw the smallest rectangle that is visible (i.e., about one pixel)
#' # an NA to draw nothing
#' p + geom_point()
#' p + geom_point(shape = 5)
#' p + geom_point(shape = "k", size = 3)
#' p + geom_point(shape = ".")
#' p + geom_point(shape = NA)
#'
#' # Shape can also be mapped from a variable
#' p + geom_point(aes(shape = factor(cyl)))
#'
#' # A look at all 25 symbols
#' df2 <- data.frame(x = 1:5 , y = 1:25, z = 1:25)
#' s <- ggplot(df2, aes(x = x, y = y))
#' s + geom_point(aes(shape = z), size = 4) + scale_shape_identity()
#' # While all symbols have a foreground colour, symbols 19-25 also take a
#' # background colour (fill)
#' s + geom_point(aes(shape = z), size = 4, colour = "Red") +
#' scale_shape_identity()
#' s + geom_point(aes(shape = z), size = 4, colour = "Red", fill = "Black") +
#' scale_shape_identity()
NULL
ggplot2/R/scales-.r 0000644 0001751 0000144 00000011311 12114161113 013545 0 ustar hornik users # Scales object encapsultes multiple scales.
# All input and output done with data.frames to facilitate
# multiple input and output variables
Scales <- setRefClass("Scales", fields = "scales", methods = list(
find = function(aesthetic) {
vapply(scales, function(x) any(aesthetic %in% x$aesthetics), logical(1))
},
has_scale = function(aesthetic) {
any(find(aesthetic))
},
add = function(scale) {
prev_aes <- find(scale$aesthetics)
if (any(prev_aes)) {
# Get only the first aesthetic name in the returned vector -- it can
# sometimes be c("x", "xmin", "xmax", ....)
scalename <- scales[prev_aes][[1]]$aesthetics[1]
message("Scale for '", scalename,
"' is already present. Adding another scale for '", scalename,
"', which will replace the existing scale.")
}
# Remove old scale for this aesthetic (if it exists)
scales <<- c(scales[!prev_aes], list(scale))
},
clone = function() {
new_scales <- lapply(scales, scale_clone)
Scales$new(new_scales)
},
n = function() {
length(scales)
},
input = function() {
unlist(lapply(scales, "[[", "aesthetics"))
},
initialize = function(scales = NULL) {
initFields(scales = scales)
},
non_position_scales = function(.) {
Scales$new(scales[!find("x") & !find("y")])
},
get_scales = function(output) {
scale <- scales[find(output)]
if (length(scale) == 0) return()
scale[[1]]
}
))
# Train scale from a data frame
scales_train_df <- function(scales, df, drop = FALSE) {
if (empty(df) || length(scales$scales) == 0) return()
lapply(scales$scales, scale_train_df, df = df)
}
# Map values from a data.frame. Returns data.frame
scales_map_df <- function(scales, df) {
if (empty(df) || length(scales$scales) == 0) return()
mapped <- unlist(lapply(scales$scales, scale_map_df, df = df), recursive = FALSE)
quickdf(c(mapped, df[setdiff(names(df), names(mapped))]))
}
# Transform values to cardinal representation
scales_transform_df <- function(scales, df) {
if (empty(df) || length(scales$scales) == 0) return(df)
transformed <- unlist(lapply(scales$scales, scale_transform_df, df = df),
recursive = FALSE)
quickdf(c(transformed, df[setdiff(names(df), names(transformed))]))
}
# @param aesthetics A list of aesthetic-variable mappings. The name of each
# item is the aesthetic, and the value of each item is the variable in data.
scales_add_defaults <- function(scales, data, aesthetics, env) {
if (is.null(aesthetics)) return()
names(aesthetics) <- unlist(lapply(names(aesthetics), aes_to_scale))
new_aesthetics <- setdiff(names(aesthetics), scales$input())
# No new aesthetics, so no new scales to add
if (is.null(new_aesthetics)) return()
datacols <- tryapply(
aesthetics[new_aesthetics], eval,
envir = data, enclos = env
)
for(aes in names(datacols)) {
type <- scale_type(datacols[[aes]])
scale_name <- paste("scale", aes, type, sep="_")
# Skip aesthetics with no scales (e.g. group, order, etc)
scale_f <- find_global(scale_name, env)
if (is.null(scale_f)) next
scales$add(scale_f())
}
}
# Add missing but required scales.
# @param aesthetics A character vector of aesthetics. Typically c("x", "y").
scales_add_missing <- function(plot, aesthetics, env) {
# Keep only aesthetics that aren't already in plot$scales
aesthetics <- setdiff(aesthetics, plot$scales$input())
for (aes in aesthetics) {
scale_name <- paste("scale", aes, "continuous", sep="_")
scale_f <- find_global(scale_name, env)
plot$scales$add(scale_f())
}
}
# Look for object first in parent environment and if not found, then in
# ggplot2 namespace environment. This makes it possible to override default
# scales by setting them in the parent environment.
find_global <- function(name, env) {
if (exists(name, env)) {
return(get(name, env))
}
nsenv <- asNamespace("ggplot2")
if (exists(name, nsenv)) {
return(get(name, nsenv))
}
NULL
}
# Determine default type of a scale
scale_type <- function(x) UseMethod("scale_type")
#' @S3method scale_type default
scale_type.default <- function(x) {
message("Don't know how to automatically pick scale for object of type ",
paste(class(x), collapse = "/"), ". Defaulting to continuous")
"continuous"
}
#' @S3method scale_type logical
scale_type.logical <- function(x) "discrete"
#' @S3method scale_type character
scale_type.character <- function(x) "discrete"
#' @S3method scale_type factor
scale_type.factor <- function(x) "discrete"
#' @S3method scale_type POSIXt
scale_type.POSIXt <- function(x) "datetime"
#' @S3method scale_type Date
scale_type.Date <- function(x) "date"
#' @S3method scale_type numeric
scale_type.numeric <- function(x) "continuous"
ggplot2/R/stat-boxplot.r 0000644 0001751 0000144 00000006011 12114160774 014673 0 ustar hornik users #' Calculate components of box and whisker plot.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "boxplot")}
#'
#' @param coef length of the whiskers as multiple of IQR. Defaults to 1.5
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @inheritParams stat_identity
#' @return A data frame with additional columns:
#' \item{width}{width of boxplot}
#' \item{ymin}{lower whisker = smallest observation greater than or equal to lower hinge - 1.5 * IQR}
#' \item{lower}{lower hinge, 25\% quantile}
#' \item{notchlower}{lower edge of notch = median - 1.58 * IQR / sqrt(n)}
#' \item{middle}{median, 50\% quantile}
#' \item{notchupper}{upper edge of notch = median + 1.58 * IQR / sqrt(n)}
#' \item{upper}{upper hinge, 75\% quantile}
#' \item{ymax}{upper whisker = largest observation less than or equal to upper hinge + 1.5 * IQR}
#' @seealso See \code{\link{geom_boxplot}} for examples.
#' @export
#' @examples
#' # See geom_boxplot for examples
stat_boxplot <- function (mapping = NULL, data = NULL, geom = "boxplot", position = "dodge",
na.rm = FALSE, coef = 1.5, ...) {
StatBoxplot$new(mapping = mapping, data = data, geom = geom,
position = position, na.rm = na.rm, coef = coef, ...)
}
StatBoxplot <- proto(Stat, {
objname <- "boxplot"
required_aes <- c("x", "y")
default_geom <- function(.) GeomBoxplot
calculate_groups <- function(., data, na.rm = FALSE, width = NULL, ...) {
data <- remove_missing(data, na.rm, c("y", "weight"), name="stat_boxplot",
finite = TRUE)
data$weight <- data$weight %||% 1
width <- width %||% resolution(data$x) * 0.75
.super$calculate_groups(., data, na.rm = na.rm, width = width, ...)
}
calculate <- function(., data, scales, width=NULL, na.rm = FALSE, coef = 1.5, ...) {
with(data, {
qs <- c(0, 0.25, 0.5, 0.75, 1)
if (length(unique(weight)) != 1) {
try_require("quantreg")
stats <- as.numeric(coef(rq(y ~ 1, weights = weight, tau=qs)))
} else {
stats <- as.numeric(quantile(y, qs))
}
names(stats) <- c("ymin", "lower", "middle", "upper", "ymax")
iqr <- diff(stats[c(2, 4)])
outliers <- y < (stats[2] - coef * iqr) | y > (stats[4] + coef * iqr)
if (any(outliers)) {
stats[c(1, 5)] <- range(c(stats[2:4], y[!outliers]), na.rm=TRUE)
}
if (length(unique(x)) > 1) width <- diff(range(x)) * 0.9
df <- as.data.frame(as.list(stats))
df$outliers <- I(list(y[outliers]))
if (is.null(weight)) {
n <- sum(!is.na(y))
} else {
# Sum up weights for non-NA positions of y and weight
n <- sum(weight[!is.na(y) & !is.na(weight)])
}
df$notchupper <- df$middle + 1.58 * iqr / sqrt(n)
df$notchlower <- df$middle - 1.58 * iqr / sqrt(n)
transform(df,
x = if (is.factor(x)) x[1] else mean(range(x)),
width = width
)
})
}
})
ggplot2/R/scale-date.r 0000644 0001751 0000144 00000010117 12114160774 014237 0 ustar hornik users #' Position scale, date
#'
#' @rdname scale_date
#' @inheritParams scale_x_continuous
#' @param breaks A vector of breaks, a function that given the scale limits
#' returns a vector of breaks, or a character vector, specifying the width
#' between breaks. For more information about the first two, see
#' \code{\link{continuous_scale}}, for more information about the last,
#' see \code{\link[scales]{date_breaks}}`.
#' @param minor_breaks Either \code{NULL} for no minor breaks, \code{waiver()}
#' for the default breaks (one minor break between each major break), a
#' numeric vector of positions, or a function that given the limits returns
#' a vector of minor breaks.
#' @family position scales
#' @export
#' @examples
#' # We'll start by creating some nonsense data with dates
#' df <- data.frame(
#' date = seq(Sys.Date(), len=100, by="1 day")[sample(100, 50)],
#' price = runif(50)
#' )
#' df <- df[order(df$date), ]
#' dt <- qplot(date, price, data=df, geom="line") + theme(aspect.ratio = 1/4)
#'
#' # We can control the format of the labels, and the frequency of
#' # the major and minor tickmarks. See ?format.Date and ?seq.Date
#' # for more details.
#' library(scales) # to access breaks/formatting functions
#' dt + scale_x_date()
#' dt + scale_x_date(labels = date_format("%m/%d"))
#' dt + scale_x_date(labels = date_format("%W"))
#' dt + scale_x_date(labels = date_format("%W"), breaks = date_breaks("week"))
#'
#' dt + scale_x_date(breaks = date_breaks("months"),
#' labels = date_format("%b"))
#' dt + scale_x_date(breaks = date_breaks("4 weeks"),
#' labels = date_format("%d-%b"))
#'
#' # We can use character string for breaks.
#' # See \code{\link{by}} argument in \code{\link{seq.Date}}.
#' dt + scale_x_date(breaks = "2 weeks")
#' dt + scale_x_date(breaks = "1 month", minor_breaks = "1 week")
#'
#' # The date scale will attempt to pick sensible defaults for
#' # major and minor tick marks
#' qplot(date, price, data=df[1:10,], geom="line")
#' qplot(date, price, data=df[1:4,], geom="line")
#'
#' df <- data.frame(
#' date = seq(Sys.Date(), len=1000, by="1 day"),
#' price = runif(500)
#' )
#' qplot(date, price, data=df, geom="line")
#'
#' # A real example using economic time series data
#' qplot(date, psavert, data=economics)
#' qplot(date, psavert, data=economics, geom="path")
#'
#' end <- max(economics$date)
#' last_plot() + scale_x_date(limits = c(as.Date("2000-1-1"), end))
#' last_plot() + scale_x_date(limits = c(as.Date("2005-1-1"), end))
#' last_plot() + scale_x_date(limits = c(as.Date("2006-1-1"), end))
#'
#' # If we want to display multiple series, one for each variable
#' # it's easiest to first change the data from a "wide" to a "long"
#' # format:
#' library(reshape2) # for melt
#' em <- melt(economics, id = "date")
#'
#' # Then we can group and facet by the new "variable" variable
#' qplot(date, value, data = em, geom = "line", group = variable)
#' qplot(date, value, data = em, geom = "line", group = variable) +
#' facet_grid(variable ~ ., scale = "free_y")
scale_x_date <- function(..., expand = waiver(), breaks = pretty_breaks(),
minor_breaks = waiver()) {
scale_date(c("x", "xmin", "xmax", "xend"), expand = expand, breaks = breaks,
minor_breaks = minor_breaks, ...)
}
#' @rdname scale_date
#' @export
scale_y_date <- function(..., expand = waiver(), breaks = pretty_breaks(),
minor_breaks = waiver()) {
scale_date(c("y", "ymin", "ymax", "yend"), expand = expand, breaks = breaks,
minor_breaks = minor_breaks, ...)
}
# base class for scale_{xy}_date
scale_date <- function(aesthetics, expand = waiver(), breaks = pretty_breaks(),
minor_breaks = waiver(), ...) {
if (is.character(breaks)) {
breaks_str <- breaks
breaks <- date_breaks(breaks_str)
}
if (is.character(minor_breaks)) {
mbreaks_str <- minor_breaks
minor_breaks <- date_breaks(mbreaks_str)
}
continuous_scale(aesthetics, "date", identity, breaks = breaks,
minor_breaks = minor_breaks, guide = "none", expand = expand,
trans = "date", ...)
}
#' @S3method scale_map date
scale_map.date <- function(scale, x, limits = scale_limits(scale)) {
x
}
ggplot2/R/scale-identity.r 0000644 0001751 0000144 00000004774 12114160774 015167 0 ustar hornik users #' Use values without scaling.
#'
#' @name scale_identity
#' @param ... Other arguments passed on to \code{\link{discrete_scale}} or
#' \code{\link{continuous_scale}}
#' @param guide Guide to use for this scale - defaults to \code{"none"}.
#' @examples
#' colour <- c("red", "green", "blue", "yellow")
#' qplot(1:4, 1:4, fill = colour, geom = "tile")
#' qplot(1:4, 1:4, fill = colour, geom = "tile") + scale_fill_identity()
#'
#' # To get a legend guide, specify guide = "legend"
#' qplot(1:4, 1:4, fill = colour, geom = "tile") +
#' scale_fill_identity(guide = "legend")
#' # But you'll typically also need to supply breaks and labels:
#' qplot(1:4, 1:4, fill = colour, geom = "tile") +
#' scale_fill_identity("trt", labels = letters[1:4], breaks = colour,
#' guide = "legend")
#'
#' # cyl scaled to appropriate size
#' qplot(mpg, wt, data = mtcars, size = cyl)
#'
#' # cyl used as point size
#' qplot(mpg, wt, data = mtcars, size = cyl) + scale_size_identity()
NULL
#' @rdname scale_identity
#' @export
scale_colour_identity <- function(..., guide = "none") {
identity_scale(discrete_scale("colour", "identity", identity_pal(), ..., guide = guide))
}
#' @rdname scale_identity
#' @export
scale_fill_identity <- function(..., guide = "none") {
identity_scale(discrete_scale("fill", "identity", identity_pal(), ..., guide = guide))
}
#' @rdname scale_identity
#' @export
scale_shape_identity <- function(..., guide = "none") {
identity_scale(continuous_scale("shape", "identity", identity_pal(), ..., guide = guide))
}
#' @rdname scale_identity
#' @export
scale_linetype_identity <- function(..., guide = "none") {
identity_scale(discrete_scale("linetype", "identity", identity_pal(), ..., guide = guide))
}
#' @rdname scale_identity
#' @export
scale_alpha_identity <- function(..., guide = "none") {
identity_scale(continuous_scale("alpha", "identity", identity_pal(), ..., guide = guide))
}
#' @rdname scale_identity
#' @export
scale_size_identity <- function(..., guide = "none") {
identity_scale(continuous_scale("size", "identity", identity_pal(), ..., guide = guide))
}
identity_scale <- function(x) {
structure(x, class = c("identity", class(x)))
}
#' @S3method scale_map identity
scale_map.identity <- function(scale, x) {
if (is.factor(x)) {
as.character(x)
} else {
x
}
}
#' @S3method scale_train identity
scale_train.identity <- function(scale, x) {
# do nothing if no guide, otherwise train so we know what breaks to use
if (scale$guide == "none") return()
NextMethod()
}
ggplot2/R/stat-.r 0000644 0001751 0000144 00000003730 12114160774 013270 0 ustar hornik users Stat <- proto(TopLevel, expr={
objname <- ""
desc <- ""
# Should the values produced by the statistic also be transformed
# in the second pass when recently added statistics are trained to
# the scales
retransform <- TRUE
default_geom <- function(.) Geom
default_aes <- function(.) aes()
default_pos <- function(.) .$default_geom()$default_pos()
required_aes <- c()
aesthetics <- list()
calculate <- function(., data, scales, ...) {}
calculate_groups <- function(., data, scales, ...) {
if (empty(data)) return(data.frame())
force(data)
force(scales)
# # Alternative approach: cleaner, but much slower
# # Compute statistic for each group
# stats <- ddply(data, "group", function(group) {
# .$calculate(group, scales, ...)
# })
# stats$ORDER <- seq_len(nrow(stats))
#
# # Combine statistics with original columns
# unique <- ddply(data, .(group), uniquecols)
# stats <- merge(stats, unique, by = "group")
# stats[stats$ORDER, ]
groups <- split(data, data$group)
stats <- lapply(groups, function(group)
.$calculate(data = group, scales = scales, ...))
stats <- mapply(function(new, old) {
if (empty(new)) return(data.frame())
unique <- uniquecols(old)
missing <- !(names(unique) %in% names(new))
cbind(
new,
unique[rep(1, nrow(new)), missing,drop=FALSE]
)
}, stats, groups, SIMPLIFY=FALSE)
do.call(rbind.fill, stats)
}
pprint <- function(., newline=TRUE) {
cat("stat_", .$objname ,": ", sep="") # , clist(.$parameters())
if (newline) cat("\n")
}
parameters <- function(.) {
params <- formals(get("calculate", .))
params[setdiff(names(params), c(".","data","scales"))]
}
class <- function(.) "stat"
new <- function(., mapping=aes(), data=NULL, geom=NULL, position=NULL, ...){
do.call("layer", list(mapping=mapping, data=data, geom=geom, stat=., position=position, ...))
}
})
ggplot2/R/geom-errorh.r 0000644 0001751 0000144 00000003703 12114161113 014452 0 ustar hornik users #' Horizontal error bars
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "errorbarh")}
#'
#' @seealso \code{\link{geom_errorbar}}: vertical error bars
#' @inheritParams geom_point
#' @export
#' @examples
#' df <- data.frame(
#' trt = factor(c(1, 1, 2, 2)),
#' resp = c(1, 5, 3, 4),
#' group = factor(c(1, 2, 1, 2)),
#' se = c(0.1, 0.3, 0.3, 0.2)
#' )
#'
#' # Define the top and bottom of the errorbars
#'
#' p <- ggplot(df, aes(resp, trt, colour = group))
#' p + geom_point() +
#' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se))
#' p + geom_point() +
#' geom_errorbarh(aes(xmax = resp + se, xmin = resp - se, height = .2))
geom_errorbarh <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", ...) {
GeomErrorbarh$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomErrorbarh <- proto(Geom, {
objname <- "errorbarh"
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(colour = "black", size=0.5, linetype=1, height=0.5, alpha = NA)
guide_geom <- function(.) "path"
required_aes <- c("x", "xmin", "xmax", "y")
reparameterise <- function(., df, params) {
df$height <- df$height %||%
params$height %||% (resolution(df$y, FALSE) * 0.9)
transform(df,
ymin = y - height / 2, ymax = y + height / 2, height = NULL
)
}
draw <- function(., data, scales, coordinates, height = NULL, ...) {
GeomPath$draw(with(data, data.frame(
x = as.vector(rbind(xmax, xmax, NA, xmax, xmin, NA, xmin, xmin)),
y = as.vector(rbind(ymin, ymax, NA, y, y, NA, ymin, ymax)),
colour = rep(colour, each = 8),
alpha = rep(alpha, each = 8),
size = rep(size, each = 8),
linetype = rep(linetype, each = 8),
group = rep(1:(nrow(data)), each = 8),
stringsAsFactors = FALSE,
row.names = 1:(nrow(data) * 8)
)), scales, coordinates, ...)
}
})
ggplot2/R/labels.r 0000644 0001751 0000144 00000003537 12114160774 013507 0 ustar hornik users #' Update axis/legend labels
#'
#' @param p plot to modify
#' @param labels named list of new labels
#' @export
#' @examples
#' p <- qplot(mpg, wt, data = mtcars)
#' update_labels(p, list(x = "New x"))
#' update_labels(p, list(x = expression(x / y ^ 2)))
#' update_labels(p, list(x = "New x", y = "New Y"))
#' update_labels(p, list(colour = "Fail silently"))
update_labels <- function(p, labels) {
p <- plot_clone(p)
p$labels <- defaults(labels, p$labels)
p
}
#' Change axis labels and legend titles
#'
#' @param label The text for the axis or plot title.
#' @param ... a list of new names in the form aesthetic = "new name"
#' @export
#' @examples
#' p <- qplot(mpg, wt, data = mtcars)
#' p + labs(title = "New plot title")
#' p + labs(x = "New x label")
#' p + xlab("New x label")
#' p + ylab("New y label")
#' p + ggtitle("New plot title")
#'
#' # This should work indepdendently of other functions that modify the
#' # the scale names
#' p + ylab("New y label") + ylim(2, 4)
#' p + ylim(2, 4) + ylab("New y label")
#'
#' # The labs function also modifies legend labels
#' p <- qplot(mpg, wt, data = mtcars, colour = cyl)
#' p + labs(colour = "Cylinders")
#'
#' # Can also pass in a list, if that is more convenient
#' p + labs(list(title = "Title", x = "X", y = "Y"))
labs <- function(...) {
args <- list(...)
if (is.list(args[[1]])) args <- args[[1]]
args <- rename_aes(args)
structure(args, class = "labels")
}
#' @rdname labs
#' @export
xlab <- function(label) {
labs(x = label)
}
#' @rdname labs
#' @export
ylab <- function(label) {
labs(y = label)
}
#' @rdname labs
#' @export
ggtitle <- function(label) {
labs(title = label)
}
# Convert aesthetic mapping into text labels
make_labels <- function(mapping) {
remove_dots <- function(x) {
gsub("\\.\\.([a-zA-z._]+)\\.\\.", "\\1", x)
}
lapply(mapping, function(x) remove_dots(deparse(x)))
}
ggplot2/R/coord-cartesian-.r 0000644 0001751 0000144 00000006202 12114161113 015353 0 ustar hornik users #' Cartesian coordinates.
#'
#' The Cartesian coordinate system is the most familiar, and common, type of
#' coordinate system. Setting limits on the coordinate system will zoom the
#' plot (like you're looking at it with a magnifying glass), and will not
#' change the underlying data like setting limits on a scale will.
#'
#' @param xlim limits for the x axis
#' @param ylim limits for the y axis
#' @param wise deprecated in 0.9.1
#' @export
#' @examples
#' # There are two ways of zooming the plot display: with scales or
#' # with coordinate systems. They work in two rather different ways.
#'
#' (p <- qplot(disp, wt, data=mtcars) + geom_smooth())
#'
#' # Setting the limits on a scale will throw away all data that's not
#' # inside these limits. This is equivalent to plotting a subset of
#' # the original data
#' p + scale_x_continuous(limits = c(325, 500))
#'
#' # Setting the limits on the coordinate system performs a visual zoom
#' # the data is unchanged, and we just view a small portion of the original
#' # plot. See how the axis labels are the same as the original data, and
#' # the smooth continue past the points visible on this plot.
#' p + coord_cartesian(xlim = c(325, 500))
#'
#' # You can see the same thing with this 2d histogram
#' (d <- ggplot(diamonds, aes(carat, price)) +
#' stat_bin2d(bins = 25, colour="grey50"))
#'
#' # When zooming the scale, the we get 25 new bins that are the same
#' # size on the plot, but represent smaller regions of the data space
#' d + scale_x_continuous(limits = c(0, 2))
#'
#' # When zooming the coordinate system, we see a subset of original 50 bins,
#' # displayed bigger
#' d + coord_cartesian(xlim = c(0, 2))
coord_cartesian <- function(xlim = NULL, ylim = NULL, wise = NULL) {
if (!is.null(wise))
gg_dep("0.9.0", "wise argument to coord_cartesian is ignored")
coord(limits = list(x = xlim, y = ylim), subclass = "cartesian")
}
#' @S3method is.linear cartesian
is.linear.cartesian <- function(coord) TRUE
#' @S3method coord_distance cartesian
coord_distance.cartesian <- function(coord, x, y, details) {
max_dist <- dist_euclidean(details$x.range, details$y.range)
dist_euclidean(x, y) / max_dist
}
#' @S3method coord_transform cartesian
coord_transform.cartesian <- function(., data, details) {
rescale_x <- function(data) rescale(data, from = details$x.range)
rescale_y <- function(data) rescale(data, from = details$y.range)
data <- transform_position(data, rescale_x, rescale_y)
transform_position(data, squish_infinite, squish_infinite)
}
#' @S3method coord_train cartesian
coord_train.cartesian <- function(coord, scales) {
c(train_cartesian(scales$x, coord$limits$x, "x"),
train_cartesian(scales$y, coord$limits$y, "y"))
}
train_cartesian <- function(scale, limits, name) {
# first, calculate the range that is the numerical limits in data space
# expand defined by scale OR coord
if (is.null(limits)) {
expand <- coord_expand_defaults(coord, scale)
range <- scale_dimension(scale, expand)
} else {
range <- range(scale_transform(scale, limits))
}
out <- scale_break_info(scale, range)
names(out) <- paste(name, names(out), sep = ".")
out
}
ggplot2/R/scale-discrete-.r 0000644 0001751 0000144 00000010524 12114160774 015203 0 ustar hornik users #' Discrete position.
#'
#' You can use continuous positions even with a discrete position scale -
#' this allows you (e.g.) to place labels between bars in a bar chart.
#' Continuous positions are numeric values starting at one for the first
#' level, and increasing by one for each level (i.e. the labels are placed
#' at integer positions). This is what allows jittering to work.
#'
#'
#' @param ... common discrete scale parameters: \code{name}, \code{breaks},
#' \code{labels}, \code{na.value}, \code{limits} and \code{guide}. See
#' \code{\link{discrete_scale}} for more details
#' @param expand a numeric vector of length two giving multiplicative and
#' additive expansion constants. These constants ensure that the data is
#' placed some distance away from the axes.
#' @rdname scale_discrete
#' @family position scales
#' @export
#' @examples
#' \donttest{
#' qplot(cut, data=diamonds, stat="bin")
#' qplot(cut, data=diamonds, geom="bar")
#'
#' # The discrete position scale is added automatically whenever you
#' # have a discrete position.
#'
#' (d <- qplot(cut, clarity, data=subset(diamonds, carat > 1), geom="jitter"))
#'
#' d + scale_x_discrete("Cut")
#' d + scale_x_discrete("Cut", labels = c("Fair" = "F","Good" = "G",
#' "Very Good" = "VG","Perfect" = "P","Ideal" = "I"))
#'
#' d + scale_y_discrete("Clarity")
#' d + scale_x_discrete("Cut") + scale_y_discrete("Clarity")
#'
#' # Use limits to adjust the which levels (and in what order)
#' # are displayed
#' d + scale_x_discrete(limits=c("Fair","Ideal"))
#'
#' # you can also use the short hand functions xlim and ylim
#' d + xlim("Fair","Ideal", "Good")
#' d + ylim("I1", "IF")
#'
#' # See ?reorder to reorder based on the values of another variable
#' qplot(manufacturer, cty, data=mpg)
#' qplot(reorder(manufacturer, cty), cty, data=mpg)
#' qplot(reorder(manufacturer, displ), cty, data=mpg)
#'
#' # Use abbreviate as a formatter to reduce long names
#' qplot(reorder(manufacturer, cty), cty, data=mpg) +
#' scale_x_discrete(labels = abbreviate)
#' }
scale_x_discrete <- function(..., expand = waiver()) {
sc <- discrete_scale(c("x", "xmin", "xmax", "xend"), "position_d", identity, ...,
expand = expand, guide = "none")
sc$range_c <- ContinuousRange$new()
sc
}
#' @rdname scale_discrete
#' @export
scale_y_discrete <- function(..., expand = waiver()) {
sc <- discrete_scale(c("y", "ymin", "ymax", "yend"), "position_d", identity, ...,
expand = expand, guide = "none")
sc$range_c <- ContinuousRange$new()
sc
}
# The discrete position scale maintains two separate ranges - one for
# continuous data and one for discrete data. This complicates training and
# mapping, but makes it possible to place objects at non-integer positions,
# as is necessary for jittering etc.
#' @S3method scale_train position_d
scale_train.position_d <- function(scale, x) {
if (is.discrete(x)) {
scale$range$train(x, drop = scale$drop)
} else {
scale$range_c$train(x)
}
}
# If range not available from discrete range, implies discrete scale been
# used with purely continuous data, so construct limits accordingly
#' @S3method scale_limits position_d
scale_limits.position_d <- function(scale) {
dis_limits <- function(x) seq.int(floor(min(x)), ceiling(max(x)), by = 1L)
scale$limits %||% scale$range$range %||% dis_limits(scale$range_c$range)
}
#' @S3method scale_is_empty position_d
scale_is_empty.position_d <- function(scale) {
NextMethod() && is.null(scale$range_c$range)
}
#' @S3method scale_reset position_d
scale_reset.position_d <- function(scale, x) {
# Can't reset discrete scale because no way to recover values
scale$range_c$reset()
}
#' @S3method scale_map position_d
scale_map.position_d <- function(scale, x, limits = scale_limits(scale)) {
if (is.discrete(x)) {
seq_along(limits)[match(as.character(x), limits)]
} else {
x
}
}
#' @S3method scale_dimension position_d
scale_dimension.position_d <- function(scale, expand = scale$expand) {
if(is.waive(expand))
expand <- c(0, 0)
disc_range <- c(1, length(scale_limits(scale)))
disc <- expand_range(disc_range, 0, expand[2], 1)
cont <- expand_range(scale$range_c$range, expand[1], 0, expand[2])
range(disc, cont)
}
#' @S3method scale_clone position_d
scale_clone.position_d <- function(scale) {
new <- scale
new$range <- DiscreteRange$new()
new$range_c <- ContinuousRange$new()
new
}
ggplot2/R/stat-unique.r 0000644 0001751 0000144 00000001301 12114160774 014507 0 ustar hornik users #' Remove duplicates.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "unique")}
#'
#' @export
#' @inheritParams stat_identity
#' @examples
#' ggplot(mtcars, aes(vs, am)) + geom_point(alpha = 0.1)
#' ggplot(mtcars, aes(vs, am)) + geom_point(alpha = 0.1, stat="unique")
stat_unique <- function (mapping = NULL, data = NULL, geom = "point", position = "identity", ...) {
StatUnique$new(mapping = mapping, data = data, geom = geom, position = position, ...)
}
StatUnique <- proto(Stat, {
objname <- "unique"
desc <- "Remove duplicates"
default_geom <- function(.) GeomPoint
calculate_groups <- function(., data, scales, ...) unique(data)
})
ggplot2/R/geom-path-density2d.r 0000644 0001751 0000144 00000002134 12114161113 016005 0 ustar hornik users #' Contours from a 2d density estimate.
#'
#' Perform a 2D kernel density estimatation using kde2d and display the
#' results with contours.
#'
#' This can be useful for dealing with overplotting.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "density2d")}
#'
#' @seealso \code{\link{geom_contour}} for contour drawing geom,
#' \code{\link{stat_sum}} for another way of dealing with overplotting
#' @inheritParams geom_point
#' @inheritParams geom_path
#' @export
#' @examples
#' # See stat_density2d for examples
geom_density2d <- function (mapping = NULL, data = NULL, stat = "density2d", position = "identity",
lineend = "butt", linejoin = "round", linemitre = 1, na.rm = FALSE, ...) {
GeomDensity2d$new(mapping = mapping, data = data, stat = stat, position = position,
lineend = lineend, linejoin = linejoin, linemitre = linemitre, na.rm = na.rm, ...)
}
GeomDensity2d <- proto(GeomPath, {
objname <- "density2d"
default_stat <- function(.) StatDensity2d
default_aes <- function(.) aes(colour="#3366FF", size = 0.5, linetype = 1, alpha = NA)
})
ggplot2/R/translate-qplot-gpl.r 0000644 0001751 0000144 00000005053 12114160774 016152 0 ustar hornik users #' Translating between qplot and Graphics Production Library (GPL)
#'
#' The Grammar of Graphics uses two specifications. A concise format is used to
#' caption figures, and a more detailed xml format stored on disk.
#'
#' @name translate_qplot_gpl
#' @examples
#'
#' # The following example of the concise format is adapted from Figure 1.5,
#' # page 13, of Leland Wilkinson's "The Grammar of Graphics."
#' # Springer, 2nd edition, 2005.
#'
#' # DATA: source("demographics")
#' # DATA: longitude, latitude = map(source("World"))
#' # TRANS: bd = max(birth - death, 0)
#' # COORD: project.mercator()
#' # ELEMENT: point(position(lon * lat), size(bd), color(color.red))
#' # ELEMENT: polygon(position(longitude * latitude))
#'
#' # This is relatively simple to adapt to the syntax of ggplot2:
#'
#' # ggplot() is used to specify the default data and default aesthetic mappings.
#' # Data is provided as standard R data.frames existing in the global environment;
#' # it does not need to be explicitly loaded. We also use a slightly
#' # different world dataset, with columns lat and long. This lets us use the
#' # same aesthetic mappings for both datasets. Layers can override the default
#' # data and aesthetic mappings provided by the plot.
#'
#' # We replace TRANS with an explicit transformation by R code.
#'
#' # ELEMENTs are replaced with layers, which explicitly specify the data
#' # source. Each geom has a default statistic which is used to transform the
#' # data prior to plotting. For the geoms in this example, the default statistic
#' # is the identity function. Fixed aesthetics (the colour red in this example)
#' # are supplied as additional arguments to the layer, rather than as special
#' # constants.
#'
#' # The SCALE component has been omitted from this example (so that the
#' # defaults are used). In both the ggplot2 and GoG examples, scales are
#' # defined by default. In ggplot you can override the defaults by adding a
#' # scale object, e.g., scale colour or scale size.
#'
#' # COORD uses a slightly different format. In general, most of the components
#' # specifications in ggplot are slightly different to those in GoG, in order to
#' # be more familiar to R users.
#'
#' # Each component is added together with + to create the final plot.
#'
#' # Resulting ggplot2 code:
#' # demographics <- transform(demographics, bd = pmax(birth - death, 0))
#' # p <- ggplot(demographic, aes(lon, lat))
#' # p <- p + geom_polyogon(data = world)
#' # p <- p + geom_point(aes(size = bd), colour = "red")
#' # p <- p + coord_map(projection = "mercator")
#' # print(p)
NULL
ggplot2/R/panel.r 0000644 0001751 0000144 00000015175 12114161113 013331 0 ustar hornik users # Panel object.
#
# A panel figures out how data is positioned within a panel of a plot,
# coordinates information from scales, facets and coords. Eventually all
# state will move out of facets and coords, and live only in panels and
# stats, simplifying these data structures to become strategies.
#
# Information about a panel is built up progressively over time, which
# is why the initial object is empty to start with.
new_panel <- function() {
structure(list(), class = "panel")
}
# Learn the layout of panels within a plot.
#
# This is determined by the facet, which returns a data frame, than
# when joined to the data to be plotted tells us which panel it should
# appear in, where that panel appears in the grid, and what scales it
# uses.
#
# As well as the layout info, this function also adds empty lists in which
# to house the x and y scales.
#
# @param the panel object to train
# @param the facetting specification
# @param data a list of data frames (one for each layer), and one for the plot
# @param plot_data the default data frame
# @return an updated panel object
train_layout <- function(panel, facet, data, plot_data) {
layout <- facet_train_layout(facet, c(list(plot_data), data))
panel$layout <- layout
panel$shrink <- facet$shrink
panel
}
# Map data to find out where it belongs in the plot.
#
# Layout map ensures that all layer data has extra copies of data for margins
# and missing facetting variables, and has a PANEL variable that tells that
# so it know what panel it belongs to. This is a change from the previous
# design which added facetting variables directly to the data frame and
# caused problems when they had names of aesthetics (like colour or group).
#
# @param panel a trained panel object
# @param the facetting specification
# @param data list of data frames (one for each layer)
# @param plot_data default plot data frame
map_layout <- function(panel, facet, data, plot_data) {
lapply(data, function(data) {
if (is.waive(data)) data <- plot_data
facet_map_layout(facet, data, panel$layout)
})
}
# Train position scales with data
#
# If panel-specific scales are not already present, will clone from
# the scales provided in the parameter
#
# @param panel the panel object to train
# @param data a list of data frames (one for each layer)
# @param x_scale x scale for the plot
# @param y_scale y scale for the plot
train_position <- function(panel, data, x_scale, y_scale) {
# Initialise scales if needed, and possible.
layout <- panel$layout
if (is.null(panel$x_scales) && !is.null(x_scale)) {
panel$x_scales <- rlply(max(layout$SCALE_X), scale_clone(x_scale))
}
if (is.null(panel$y_scales) && !is.null(y_scale)) {
panel$y_scales <- rlply(max(layout$SCALE_Y), scale_clone(y_scale))
}
# loop over each layer, training x and y scales in turn
for(layer_data in data) {
match_id <- match(layer_data$PANEL, layout$PANEL)
if (!is.null(x_scale)) {
x_vars <- intersect(x_scale$aesthetics, names(layer_data))
SCALE_X <- layout$SCALE_X[match_id]
scale_apply(layer_data, x_vars, scale_train, SCALE_X, panel$x_scales)
}
if (!is.null(y_scale)) {
y_vars <- intersect(y_scale$aesthetics, names(layer_data))
SCALE_Y <- layout$SCALE_Y[match_id]
scale_apply(layer_data, y_vars, scale_train, SCALE_Y, panel$y_scales)
}
}
panel
}
reset_scales <- function(panel) {
if (!panel$shrink) return()
l_ply(panel$x_scales, scale_reset)
l_ply(panel$y_scales, scale_reset)
}
# Map data with scales.
#
# This operation must be idempotent because it is applied twice: both before
# and after statistical transformation.
#
# @param data a list of data frames (one for each layer)
map_position <- function(panel, data, x_scale, y_scale) {
layout <- panel$layout
lapply(data, function(layer_data) {
match_id <- match(layer_data$PANEL, layout$PANEL)
# Loop through each variable, mapping across each scale, then joining
# back together
x_vars <- intersect(x_scale$aesthetics, names(layer_data))
names(x_vars) <- x_vars
SCALE_X <- layout$SCALE_X[match_id]
new_x <- scale_apply(layer_data, x_vars, scale_map, SCALE_X,
panel$x_scales)
layer_data[, x_vars] <- new_x
y_vars <- intersect(y_scale$aesthetics, names(layer_data))
names(y_vars) <- y_vars
SCALE_Y <- layout$SCALE_Y[match_id]
new_y <- scale_apply(layer_data, y_vars, scale_map, SCALE_Y,
panel$y_scales)
layer_data[, y_vars] <- new_y
layer_data
})
}
# Function for applying scale function to multiple variables in a given
# data set. Implement in such a way to minimise copying and hence maximise
# speed
scale_apply <- function(data, vars, f, scale_id, scales) {
if (length(vars) == 0) return()
if (nrow(data) == 0) return()
n <- length(scales)
if (any(is.na(scale_id))) stop()
# This is a hack for ggplot2 0.9.3 to make it compatible with both plyr 1.7.1 and
# plyr 1.8 (and above). This should be removed for the next release of ggplot2.
# Tag: deprecated
if (packageVersion("plyr") <= package_version("1.7.1")) {
scale_index <- plyr:::split_indices(seq_len(nrow(data)), scale_id, n)
} else {
scale_index <- plyr:::split_indices(scale_id, n)
}
lapply(vars, function(var) {
pieces <- lapply(seq_along(scales), function(i) {
f(scales[[i]], data[[var]][scale_index[[i]]])
})
# Join pieces back together, if necessary
if (!is.null(pieces)) {
unlist(pieces)[order(unlist(scale_index))]
}
})
}
panel_scales <- function(panel, i) {
this_panel <- panel$layout[panel$layout$PANEL == i, ]
list(
x = panel$x_scales[[this_panel$SCALE_X]],
y = panel$y_scales[[this_panel$SCALE_Y]]
)
}
# Compute ranges and dimensions of each panel, using the coord.
train_ranges <- function(panel, coord) {
compute_range <- function(ix, iy) {
# TODO: change coord_train method to take individual x and y scales
coord_train(coord, list(x = panel$x_scales[[ix]], y = panel$y_scales[[iy]]))
}
panel$ranges <- Map(compute_range,
panel$layout$SCALE_X, panel$layout$SCALE_Y)
panel
}
# Calculate statistics
#
# @param layers list of layers
# @param data a list of data frames (one for each layer)
calculate_stats <- function(panel, data, layers) {
lapply(seq_along(data), function(i) {
d <- data[[i]]
l <- layers[[i]]
ddply(d, "PANEL", function(panel_data) {
scales <- panel_scales(panel, panel_data$PANEL[1])
l$calc_statistic(panel_data, scales)
})
})
}
xlabel <- function(panel, labels) {
panel$x_scales[[1]]$name %||% labels$x
}
ylabel <- function(panel, labels) {
panel$y_scales[[1]]$name %||% labels$y
}
ggplot2/R/scale-hue.r 0000644 0001751 0000144 00000003652 12114160774 014111 0 ustar hornik users #' Qualitative colour scale with evenly spaced hues.
#'
#' @param na.value Colour to use for missing values
#' @param ... Other arguments passed on to \code{\link{discrete_scale}}
#' to control name, limits, breaks, labels and so forth.
#' @inheritParams scales::hue_pal
#' @rdname scale_hue
#' @export
#' @family colour scales
#' @examples
#' \donttest{
#' dsamp <- diamonds[sample(nrow(diamonds), 1000), ]
#' (d <- qplot(carat, price, data=dsamp, colour=clarity))
#'
#' # Change scale label
#' d + scale_colour_hue()
#' d + scale_colour_hue("clarity")
#' d + scale_colour_hue(expression(clarity[beta]))
#'
#' # Adjust luminosity and chroma
#' d + scale_colour_hue(l=40, c=30)
#' d + scale_colour_hue(l=70, c=30)
#' d + scale_colour_hue(l=70, c=150)
#' d + scale_colour_hue(l=80, c=150)
#'
#' # Change range of hues used
#' d + scale_colour_hue(h=c(0, 90))
#' d + scale_colour_hue(h=c(90, 180))
#' d + scale_colour_hue(h=c(180, 270))
#' d + scale_colour_hue(h=c(270, 360))
#'
#' # Vary opacity
#' # (only works with pdf, quartz and cairo devices)
#' d <- ggplot(dsamp, aes(carat, price, colour = clarity))
#' d + geom_point(alpha = 0.9)
#' d + geom_point(alpha = 0.5)
#' d + geom_point(alpha = 0.2)
#'
#' # Colour of missing values is controlled with na.value:
#' miss <- factor(sample(c(NA, 1:5), nrow(mtcars), rep = TRUE))
#' qplot(mpg, wt, data = mtcars, colour = miss)
#' qplot(mpg, wt, data = mtcars, colour = miss) +
#' scale_colour_hue(na.value = "black")
#' }
scale_colour_hue <- function(..., h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction = 1, na.value = "grey50") {
discrete_scale("colour", "hue", hue_pal(h, c, l, h.start, direction),
na.value = na.value, ...)
}
#' @rdname scale_hue
#' @export
scale_fill_hue <- function(..., h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction = 1, na.value = "grey50") {
discrete_scale("fill", "hue", hue_pal(h, c, l, h.start, direction),
na.value = na.value, ...)
}
ggplot2/R/utilities-layer.r 0000644 0001751 0000144 00000001461 12114160774 015364 0 ustar hornik users # Ensure that the data frame contains a grouping variable.
#
# If the \code{group} variable is not present, then a new group
# variable is generated from the interaction of all discrete (factor or
# character) vectors, excluding \code{label}.
#
# @param data.frame
# @value data.frame with group variable
# @keyword internal
add_group <- function(data) {
if (empty(data)) return(data)
if (is.null(data$group)) {
disc <- vapply(data, is.discrete, logical(1))
disc[names(disc) == "label"] <- FALSE
if (any(disc)) {
data$group <- id(data[disc], drop = TRUE)
} else {
data$group <- 1L
}
} else {
data$group <- id(data["group"], drop = TRUE)
}
data
}
order_groups <- function(data) {
if (is.null(data$order)) return(data)
data[order(data$order), ]
}
ggplot2/R/aes-group-order.r 0000644 0001751 0000144 00000007346 12114160774 015262 0 ustar hornik users #' Aesthetics: group, order
#'
#' @name aes_group_order
#' @aliases group order
#'
#' @examples
#' \donttest{
#'
#' # By default, the group is set to the interaction of all discrete variables in the
#' # plot. This often partitions the data correctly, but when it does not, or when
#' # no discrete variable is used in the plot, you will need to explicitly define the
#' # grouping structure, by mapping group to a variable that has a different value
#' # for each group.
#'
#' # For most applications you can simply specify the grouping with
#' # various aesthetics (colour, shape, fill, linetype) or with facets.
#'
#' p <- ggplot(mtcars, aes(wt, mpg))
#' # A basic scatter plot
#' p + geom_point(size = 4)
#' # The colour aesthetic
#' p + geom_point(aes(colour = factor(cyl)), size = 4)
#' # Or you can use shape to distinguish the data
#' p + geom_point(aes(shape = factor(cyl)), size = 4)
#'
#' # Using fill
#' a <- ggplot(mtcars, aes(factor(cyl)))
#' a + geom_bar()
#' a + geom_bar(aes(fill = factor(cyl)))
#' a + geom_bar(aes(fill = factor(vs)))
#'
#' # Using linetypes
#' library(reshape2) # for melt
#' library(plyr) # for colwise
#' rescale01 <- function(x) (x - min(x)) / diff(range(x))
#' ec_scaled <- data.frame(
#' date = economics$date,
#' colwise(rescale01)(economics[, -(1:2)]))
#' ecm <- melt(ec_scaled, id = "date")
#' f <- ggplot(ecm, aes(date, value))
#' f + geom_line(aes(linetype = variable))
#'
#' # Using facets
#' k <- ggplot(diamonds, aes(carat, ..density..)) + geom_histogram(binwidth = 0.2)
#' k + facet_grid(. ~ cut)
#'
#' # There are three common cases where the default is not enough, and we
#' # will consider each one below. In the following examples, we will use a simple
#' # longitudinal dataset, Oxboys, from the nlme package. It records the heights
#' # (height) and centered ages (age) of 26 boys (Subject), measured on nine
#' # occasions (Occasion).
#'
#' # Multiple groups with one aesthetic
#' library(nlme)
#' h <- ggplot(Oxboys, aes(age, height))
#' # A single line tries to connect all the observations
#' h + geom_line()
#' # The group aesthetic maps a different line for each subject
#' h + geom_line(aes(group = Subject))
#'
#' # Different groups on different layers
#' h <- h + geom_line(aes(group = Subject))
#' # Using the group aesthetic with both geom_line() and geom_smooth()
#' # groups the data the same way for both layers
#' h + geom_smooth(aes(group = Subject), method = "lm", se = FALSE)
#' # Changing the group aesthetic for the smoother layer
#' # fits a single line of best fit across all boys
#' h + geom_smooth(aes(group = 1), size = 2, method = "lm", se = FALSE)
#'
#' # Overriding the default grouping
#' # The plot has a discrete scale but you want to draw lines that connect across
#' # groups. This is the strategy used in interaction plots, profile plots, and parallel
#' # coordinate plots, among others. For example, we draw boxplots of height at
#' # each measurement occasion
#' boysbox <- ggplot(Oxboys, aes(Occasion, height))
#' boysbox + geom_boxplot()
#' # There is no need to specify the group aesthetic here; the default grouping
#' # works because occasion is a discrete variable. To overlay individual trajectories
#' # we again need to override the default grouping for that layer with aes(group = Subject)
#' boysbox <- boysbox + geom_boxplot()
#' boysbox + geom_line(aes(group = Subject), colour = "blue")
#'
#' # Use the order aesthetic to change stacking order of bar charts
#' w <- ggplot(diamonds, aes(clarity, fill = cut))
#' w + geom_bar()
#' w + geom_bar(aes(order = desc(cut)))
#'
#' # Can also be used to change plot order of scatter plots
#' d <- ggplot(diamonds, aes(carat, price, colour = cut))
#' d + geom_point()
#' d + geom_point(aes(order = sample(seq_along(carat))))
#' }
NULL
ggplot2/R/stat-bin2d.r 0000644 0001751 0000144 00000007261 12114160774 014212 0 ustar hornik users #' Count number of observation in rectangular bins.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "bin2d")}
#'
#' @inheritParams stat_identity
#' @param bins numeric vector giving number of bins in both vertical and
#' horizontal directions. Set to 30 by default.
#' @param drop if \code{TRUE} removes all cells with 0 counts.
#' @seealso \code{\link{stat_binhex}} for hexagonal binning
#' @export
#' @examples
#' \donttest{
#' d <- ggplot(diamonds, aes(carat, price))
#' d + stat_bin2d()
#' d + geom_bin2d()
#'
#' # You can control the size of the bins by specifying the number of
#' # bins in each direction:
#' d + stat_bin2d(bins = 10)
#' d + stat_bin2d(bins = 30)
#'
#' # Or by specifying the width of the bins
#' d + stat_bin2d(binwidth = c(1, 1000))
#' d + stat_bin2d(binwidth = c(.1, 500))
#'
#' # Or with a list of breaks
#' x <- seq(min(diamonds$carat), max(diamonds$carat), by = 0.1)
#' y <- seq(min(diamonds$price), max(diamonds$price), length = 50)
#' d + stat_bin2d(breaks = list(x = x, y = y))
#'
#' # With qplot
#' qplot(x, y, data = diamonds, geom="bin2d",
#' xlim = c(4, 10), ylim = c(4, 10))
#' qplot(x, y, data = diamonds, geom="bin2d", binwidth = c(0.1, 0.1),
#' xlim = c(4, 10), ylim = c(4, 10))
#' }
stat_bin2d <- function (mapping = NULL, data = NULL, geom = NULL, position = "identity",
bins = 30, drop = TRUE, ...) {
StatBin2d$new(mapping = mapping, data = data, geom = geom, position = position,
bins = bins, drop = drop, ...)
}
StatBin2d <- proto(Stat, {
objname <- "bin2d"
default_aes <- function(.) aes(fill = ..count..)
required_aes <- c("x", "y")
default_geom <- function(.) GeomRect
calculate <- function(., data, scales, binwidth = NULL, bins = 30, breaks = NULL, origin = NULL, drop = TRUE, ...) {
range <- list(
x = scale_dimension(scales$x, c(0, 0)),
y = scale_dimension(scales$y, c(0, 0))
)
# Determine origin, if omitted
if (is.null(origin)) {
origin <- c(NA, NA)
} else {
stopifnot(is.numeric(origin))
stopifnot(length(origin) == 2)
}
originf <- function(x) if (is.integer(x)) -0.5 else min(x, na.rm = TRUE)
if (is.na(origin[1])) origin[1] <- originf(data$x)
if (is.na(origin[2])) origin[2] <- originf(data$y)
# Determine binwidth, if omitted
if (is.null(binwidth)) {
binwidth <- c(NA, NA)
if (is.integer(data$x)) {
binwidth[1] <- 1
} else {
binwidth[1] <- diff(range$x) / bins
}
if (is.integer(data$y)) {
binwidth[2] <- 1
} else {
binwidth[2] <- diff(range$y) / bins
}
}
stopifnot(is.numeric(binwidth))
stopifnot(length(binwidth) == 2)
# Determine breaks, if omitted
if (is.null(breaks)) {
breaks <- list(
seq(origin[1], max(range$x) + binwidth[1], binwidth[1]),
seq(origin[2], max(range$y) + binwidth[2], binwidth[2])
)
} else {
stopifnot(is.list(breaks))
stopifnot(length(breaks) == 2)
stopifnot(all(sapply(breaks, is.numeric)))
}
names(breaks) <- c("x", "y")
xbin <- cut(data$x, sort(breaks$x), include.lowest = TRUE)
ybin <- cut(data$y, sort(breaks$y), include.lowest = TRUE)
if (is.null(data$weight)) data$weight <- 1
counts <- as.data.frame(
xtabs(weight ~ xbin + ybin, data), responseName = "count")
if (drop) counts <- subset(counts, count > 0)
within(counts,{
xint <- as.numeric(xbin)
xmin <- breaks$x[xint]
xmax <- breaks$x[xint + 1]
yint <- as.numeric(ybin)
ymin <- breaks$y[yint]
ymax <- breaks$y[yint + 1]
density <- count / sum(count, na.rm = TRUE)
})
}
})
ggplot2/R/geom-segment.r 0000644 0001751 0000144 00000006275 12114161113 014622 0 ustar hornik users #' Single line segments.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "segment")}
#'
#' @inheritParams geom_point
#' @param arrow specification for arrow heads, as created by arrow()
#' @param lineend Line end style (round, butt, square)
#' @seealso \code{\link{geom_path}} and \code{\link{geom_line}} for multi-
#' segment lines and paths.
#' @export
#' @examples
#' library(grid) # needed for arrow function
#' p <- ggplot(seals, aes(x = long, y = lat))
#' (p <- p + geom_segment(aes(xend = long + delta_long, yend = lat + delta_lat), arrow = arrow(length = unit(0.1,"cm"))))
#'
#' if (require("maps")) {
#'
#' xlim <- range(seals$long)
#' ylim <- range(seals$lat)
#' usamap <- data.frame(map("world", xlim = xlim, ylim = ylim, plot =
#' FALSE)[c("x","y")])
#' usamap <- rbind(usamap, NA, data.frame(map('state', xlim = xlim, ylim
#' = ylim, plot = FALSE)[c("x","y")]))
#' names(usamap) <- c("long", "lat")
#'
#' p + geom_path(data = usamap) + scale_x_continuous(limits = xlim)
#' }
#'
#' # You can also use geom_segment to recreate plot(type = "h") :
#' counts <- as.data.frame(table(x = rpois(100,5)))
#' counts$x <- as.numeric(as.character(counts$x))
#' with(counts, plot(x, Freq, type = "h", lwd = 10))
#'
#' qplot(x, Freq, data = counts, geom = "segment",
#' yend = 0, xend = x, size = I(10))
#'
#' # Adding line segments
#' library(grid) # needed for arrow function
#' b <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
#' b + geom_segment(aes(x = 2, y = 15, xend = 2, yend = 25))
#' b + geom_segment(aes(x = 2, y = 15, xend = 3, yend = 15))
#' b + geom_segment(aes(x = 5, y = 30, xend = 3.5, yend = 25), arrow = arrow(length = unit(0.5, "cm")))
geom_segment <- function (mapping = NULL, data = NULL, stat = "identity",
position = "identity", arrow = NULL, lineend = "butt", na.rm = FALSE, ...) {
GeomSegment$new(mapping = mapping, data = data, stat = stat,
position = position, arrow = arrow, lineend = lineend, na.rm = na.rm, ...)
}
GeomSegment <- proto(Geom, {
objname <- "segment"
draw <- function(., data, scales, coordinates, arrow = NULL,
lineend = "butt", na.rm = FALSE, ...) {
data <- remove_missing(data, na.rm = na.rm,
c("x", "y", "xend", "yend", "linetype", "size", "shape"),
name = "geom_segment")
if (empty(data)) return(zeroGrob())
if (is.linear(coordinates)) {
return(with(coord_transform(coordinates, data, scales),
segmentsGrob(x, y, xend, yend, default.units="native",
gp = gpar(col=alpha(colour, alpha), fill = alpha(colour, alpha),
lwd=size * .pt, lty=linetype, lineend = lineend),
arrow = arrow)
))
}
data$group <- 1:nrow(data)
starts <- subset(data, select = c(-xend, -yend))
ends <- rename(subset(data, select = c(-x, -y)), c("xend" = "x", "yend" = "y"),
warn_missing = FALSE)
pieces <- rbind(starts, ends)
pieces <- pieces[order(pieces$group),]
GeomPath$draw_groups(pieces, scales, coordinates, arrow = arrow, ...)
}
default_stat <- function(.) StatIdentity
required_aes <- c("x", "y", "xend", "yend")
default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = NA)
guide_geom <- function(.) "path"
})
ggplot2/R/scale-shape.r 0000644 0001751 0000144 00000002174 12114160774 014426 0 ustar hornik users #' Scale for shapes, aka glyphs.
#'
#' A continuous variable can not be mapped to shape.
#'
#' @param solid Are the shapes solid, \code{TRUE}, or hollow \code{FALSE}?
#' @inheritParams scale_x_discrete
#' @rdname scale_shape
#' @export
#' @examples
#' dsmall <- diamonds[sample(nrow(diamonds), 100), ]
#'
#' (d <- qplot(carat, price, data=dsmall, shape=cut))
#' d + scale_shape(solid = TRUE) # the default
#' d + scale_shape(solid = FALSE)
#' d + scale_shape(name="Cut of diamond")
#' d + scale_shape(name="Cut of\ndiamond")
#'
#' # To change order of levels, change order of
#' # underlying factor
#' levels(dsmall$cut) <- c("Fair", "Good", "Very Good", "Premium", "Ideal")
#'
#' # Need to recreate plot to pick up new data
#' qplot(price, carat, data=dsmall, shape=cut)
#'
#' # Or for short:
#' d %+% dsmall
scale_shape <- function(..., solid = TRUE) {
discrete_scale("shape", "shape_d", shape_pal(solid), ...)
}
#' @rdname scale_shape
#' @export
scale_shape_discrete <- scale_shape
#' @rdname scale_shape
#' @export
scale_shape_continuous <- function(...) {
stop("A continuous variable can not be mapped to shape", call. = FALSE)
}
ggplot2/R/utilities-table.r 0000644 0001751 0000144 00000002241 12114160774 015334 0 ustar hornik users compute_grob_widths <- function(grob_layout, widths) {
cols <- split(grob_layout, grob_layout$l)
do.call("unit.c", lapply(cols, compute_grob_dimensions, dims = widths))
}
compute_grob_heights <- function(grob_layout, heights) {
cols <- split(grob_layout, grob_layout$t)
do.call("unit.c", lapply(cols, compute_grob_dimensions, dims = heights))
}
compute_grob_dimensions <- function(grob_layout, dims) {
# If any don't have explicit dims, then width is NULL
if (!any(grob_layout$type %in% names(dims))) {
return(unit(1, "null"))
}
grob_layout <- subset(grob_layout, type %in% names(dims))
dims <- unique(Map(function(type, pos) {
type_width <- dims[[type]]
if (length(type_width) == 1) type_width else type_width[pos]
}, grob_layout$type, grob_layout$id))
units <- vapply(dims, is.unit, logical(1))
if (all(units)) {
if (all(lapply(dims, attr, "unit") == "null")) unit(max(unlist(dims)), "null")
else do.call("max", dims)
} else {
raw_max <- unit(max(unlist(dims[!units])), "cm")
if (any(units)) {
unit_max <- max(do.call("unit.c", dims[units]))
max(raw_max, unit_max)
}
else {
raw_max
}
}
}
ggplot2/R/geom-abline.r 0000644 0001751 0000144 00000007134 12114160774 014421 0 ustar hornik users #' Line specified by slope and intercept.
#'
#' The abline geom adds a line with specified slope and intercept to the
#' plot.
#'
#' With its siblings \code{geom_hline} and \code{geom_vline}, it's useful for
#' annotating plots. You can supply the parameters for geom_abline,
#' intercept and slope, in two ways: either explicitly as fixed values, or
#' in a data frame. If you specify the fixed values
#' (\code{geom_abline(intercept=0, slope=1)}) then the line will be the same
#' in all panels. If the intercept and slope are stored in the data, then
#' they can vary from panel to panel. See the examples for more ideas.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "abline")}
#'
#' @seealso \code{\link{stat_smooth}} to add lines derived from the data,
#' \code{\link{geom_hline}} for horizontal lines,
#' \code{\link{geom_vline}} for vertical lines
#' \code{\link{geom_segment}}
#' @param show_guide should a legend be drawn? (defaults to \code{FALSE})
#' @inheritParams geom_point
#' @export
#' @examples
#' p <- qplot(wt, mpg, data = mtcars)
#'
#' # Fixed slopes and intercepts
#' p + geom_abline() # Can't see it - outside the range of the data
#' p + geom_abline(intercept = 20)
#'
#' # Calculate slope and intercept of line of best fit
#' coef(lm(mpg ~ wt, data = mtcars))
#' p + geom_abline(intercept = 37, slope = -5)
#' p + geom_abline(intercept = 10, colour = "red", size = 2)
#'
#' # See ?stat_smooth for fitting smooth models to data
#' p + stat_smooth(method="lm", se=FALSE)
#'
#' # Slopes and intercepts as data
#' p <- ggplot(mtcars, aes(x = wt, y=mpg), . ~ cyl) + geom_point()
#' df <- data.frame(a=rnorm(10, 25), b=rnorm(10, 0))
#' p + geom_abline(aes(intercept=a, slope=b), data=df)
#'
#' # Slopes and intercepts from linear model
#' library(plyr)
#' coefs <- ddply(mtcars, .(cyl), function(df) {
#' m <- lm(mpg ~ wt, data=df)
#' data.frame(a = coef(m)[1], b = coef(m)[2])
#' })
#' str(coefs)
#' p + geom_abline(data=coefs, aes(intercept=a, slope=b))
#'
#' # It's actually a bit easier to do this with stat_smooth
#' p + geom_smooth(aes(group=cyl), method="lm")
#' p + geom_smooth(aes(group=cyl), method="lm", fullrange=TRUE)
#'
#' # With coordinate transforms
#' p + geom_abline(intercept = 37, slope = -5) + coord_flip()
#' p + geom_abline(intercept = 37, slope = -5) + coord_polar()
geom_abline <- function (mapping = NULL, data = NULL, stat = "abline", position = "identity", show_guide = FALSE, ...) {
GeomAbline$new(mapping = mapping, data = data, stat = stat, position = position, show_guide = show_guide, ...)
}
GeomAbline <- proto(Geom, {
objname <- "abline"
new <- function(., mapping = NULL, ...) {
mapping <- compact(defaults(mapping, aes(group = 1)))
class(mapping) <- "uneval"
.super$new(., ..., mapping = mapping, inherit.aes = FALSE)
}
draw <- function(., data, scales, coordinates, ...) {
ranges <- coord_range(coordinates, scales)
data$x <- ranges$x[1]
data$xend <- ranges$x[2]
data$y <- ranges$x[1] * data$slope + data$intercept
data$yend <- ranges$x[2] * data$slope + data$intercept
GeomSegment$draw(unique(data), scales, coordinates)
}
guide_geom <- function(.) "abline"
default_stat <- function(.) StatAbline
default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = NA)
draw_legend <- function(., data, ...) {
data <- aesdefaults(data, .$default_aes(), list(...))
with(data,
ggname(.$my_name(), segmentsGrob(0, 0, 1, 1, default.units="npc",
gp=gpar(col=alpha(colour, alpha), lwd=size * .pt, lty=linetype,
lineend="butt")))
)
}
})
ggplot2/R/stat-function.r 0000644 0001751 0000144 00000004423 12114160774 015036 0 ustar hornik users #' Superimpose a function.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "function")}
#'
#' @param fun function to use
#' @param n number of points to interpolate along
#' @param args list of additional arguments to pass to \code{fun}
#' @inheritParams stat_identity
#' @return a data.frame with additional columns:
#' \item{x}{x's along a grid}
#' \item{y}{value of function evaluated at corresponding x}
#' @export
#' @examples
#' x <- rnorm(100)
#' base <- qplot(x, geom = "density")
#' base + stat_function(fun = dnorm, colour = "red")
#' base + stat_function(fun = dnorm, colour = "red", arg = list(mean = 3))
#'
#' # Plot functions without data
#' # Examples adapted from Kohske Takahashi
#'
#' # Specify range of x-axis
#' qplot(c(0, 2), stat = "function", fun = exp, geom = "line")
#' ggplot(data.frame(x = c(0, 2)), aes(x)) + stat_function(fun = exp)
#' # Plot a normal curve
#' ggplot(data.frame(x = c(-5, 5)), aes(x)) + stat_function(fun = dnorm)
#' # With qplot
#' qplot(c(-5, 5), stat = "function", fun = dnorm, geom = "line")
#' # Or
#' qplot(c(-5, 5), geom = "blank") + stat_function(fun = dnorm)
#' # To specify a different mean or sd, use the args parameter to supply new values
#' ggplot(data.frame(x = c(-5, 5)), aes(x)) + stat_function(fun = dnorm, args = list(mean = 2, sd = .5))
#'
#' # Two functions on the same plot
#' f <- ggplot(data.frame(x = c(0, 10)), aes(x))
#' f + stat_function(fun = sin, colour = "red") + stat_function(fun = cos, colour = "blue")
#'
#' # Using a custom function
#' test <- function(x) {x ^ 2 + x + 20}
#' f + stat_function(fun = test)
stat_function <- function (mapping = NULL, data = NULL, geom = "path", position = "identity",
fun, n = 101, args = list(), ...) {
StatFunction$new(mapping = mapping, data = data, geom = geom,
position = position, fun = fun, n = n, args = args, ...)
}
StatFunction <- proto(Stat, {
objname <- "function"
default_geom <- function(.) GeomPath
default_aes <- function(.) aes(y = ..y..)
calculate <- function(., data, scales, fun, n=101, args = list(), ...) {
range <- scale_dimension(scales$x, c(0, 0))
xseq <- seq(range[1], range[2], length=n)
data.frame(
x = xseq,
y = do.call(fun, c(list(xseq), args))
)
}
})
ggplot2/R/geom-rect.r 0000644 0001751 0000144 00000004234 12114160774 014122 0 ustar hornik users #' 2d rectangles.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "rect")}
#'
#' @inheritParams geom_point
#' @export
#' @examples
#' df <- data.frame(
#' x = sample(10, 20, replace = TRUE),
#' y = sample(10, 20, replace = TRUE)
#' )
#' ggplot(df, aes(xmin = x, xmax = x + 1, ymin = y, ymax = y + 2)) +
#' geom_rect()
geom_rect <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", ...) {
GeomRect$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomRect <- proto(Geom, {
objname <- "rect"
default_stat <- function(.) StatIdentity
default_pos <- function(.) PositionIdentity
default_aes <- function(.) aes(colour=NA, fill="grey20", size=0.5, linetype=1, alpha = NA)
required_aes <- c("xmin", "xmax", "ymin", "ymax")
draw <- draw_groups <- function(., data, scales, coordinates, ...) {
if (!is.linear(coordinates)) {
aesthetics <- setdiff(
names(data), c("x", "y", "xmin","xmax", "ymin", "ymax")
)
polys <- alply(data, 1, function(row) {
poly <- with(row, rect_to_poly(xmin, xmax, ymin, ymax))
aes <- as.data.frame(row[aesthetics],
stringsAsFactors = FALSE)[rep(1,5), ]
GeomPolygon$draw(cbind(poly, aes), scales, coordinates)
})
ggname("bar",do.call("grobTree", polys))
} else {
with(coord_transform(coordinates, data, scales),
ggname(.$my_name(), rectGrob(
xmin, ymax,
width = xmax - xmin, height = ymax - ymin,
default.units = "native", just = c("left", "top"),
gp=gpar(
col=colour, fill=alpha(fill, alpha),
lwd=size * .pt, lty=linetype, lineend="butt"
)
))
)
}
}
guide_geom <- function(.) "polygon"
})
# Convert rectangle to polygon
# Useful for non-Cartesian coordinate systems where it's easy to work purely in terms of locations, rather than locations and dimensions.
#
# @keyword internal
rect_to_poly <- function(xmin, xmax, ymin, ymax) {
data.frame(
y = c(ymax, ymax, ymin, ymin, ymax),
x = c(xmin, xmax, xmax, xmin, xmin)
)
}
ggplot2/R/scale-size.r 0000644 0001751 0000144 00000003775 12114161113 014274 0 ustar hornik users #' Size scale.
#'
#' @name scale_size
#' @inheritParams scale_x_continuous
#' @param range a numeric vector of length 2 that specifies the minimum and
#' maximum size of the plotting symbol after transformation.
#' @examples
#' \donttest{
#' (p <- qplot(mpg, cyl, data=mtcars, size=cyl))
#' p + scale_size("cylinders")
#' p + scale_size("number\nof\ncylinders")
#'
#' p + scale_size(range = c(0, 10))
#' p + scale_size(range = c(1, 2))
#'
#' # Map area, instead of width/radius
#' # Perceptually, this is a little better
#' p + scale_area()
#' p + scale_area(range = c(1, 25))
#'
#' # Also works with factors, but not a terribly good
#' # idea, unless your factor is ordered, as in this example
#' qplot(mpg, cyl, data=mtcars, size=factor(cyl))
#'
#' # To control the size mapping for discrete variable, use
#' # scale_size_manual:
#' last_plot() + scale_size_manual(values=c(2,4,6))
#' }
NULL
#' @rdname scale_size
#' @export
scale_size_continuous <- function(..., range = c(1, 6)) {
continuous_scale("size", "size_c", rescale_pal(range), ...)
}
#' @rdname scale_size
#' @export
scale_size <- scale_size_continuous
#' @rdname scale_size
#' @export
scale_size_discrete <- function(..., range = c(1, 6)) {
discrete_scale("size", "size_d",
function(n) seq(range[1], range[2], length = n), ...)
}
#' Scale area instead of radius, for size.
#'
#' When \code{scale_size_area} is used, the default behavior is to scale the
#' area of points to be proportional to the value.
#'
#' Note that this controls the size scale, so it will also control
#' the thickness of lines. Line thickness will be proportional to the square
#' root of the value, which is probably undesirable in most cases.
#'
#' @param ... Other arguments passed on to \code{\link{continuous_scale}}
#' to control name, limits, breaks, labels and so forth.
#' @param max_size Size of largest points.
#' @export
scale_size_area <- function(..., max_size = 6) {
continuous_scale("size", "area",
palette = abs_area(max_size),
rescaler = rescale_max, ...)
}
ggplot2/R/aaa-.r 0000644 0001751 0000144 00000003041 12114160774 013032 0 ustar hornik users # INCLUDES <- "web/graphics"
# FILETYPE <- "html"
# Upper case first letter of string
# This comes from the examples of some R function.
#
# @keyword internal
firstUpper <- function(s) {
paste(toupper(substring(s, 1,1)), substring(s, 2), sep="")
}
TopLevel <- proto(expr = {
find_all <- function(., only.documented = FALSE) {
names <- ls(pattern=paste("^", firstUpper(.$class()), "[A-Z].+", sep=""), parent.env(TopLevel))
objs <- structure(lapply(names, get), names=names)
if (only.documented) objs <- objs[sapply(objs, function(x) get("doc", x))]
objs
}
find <- function(., name) {
fullname <- paste(firstUpper(.$class()), firstUpper(name), sep="")
if (!exists(fullname)) {
stop("No ", .$class(), " called ", name, call.=FALSE)
}
get(fullname)
}
my_name <- function(., prefix=TRUE) {
if (!prefix) return(.$objname)
paste(.$class(), .$objname, sep="_")
}
my_names <- function(.) .$my_name()
myName <- function(.) {
ps(firstUpper(.$class()), ps(firstUpper(strsplit(.$objname, "_")[[1]])))
}
params <- function(.) {
param <- .$parameters()
if (length(param) == 0) return()
if(!exists("required_aes", .)) return(param)
aesthetics <- c(.$required_aes, names(.$default_aes()))
param[setdiff(names(param), aesthetics)]
}
})
#' @S3method print proto
print.proto <- function(x, ...) x$pprint(...)
pprint <- function(x, ...) print(as.list(x), ...)
# name.proto <- function (...) {
# proto(print.proto = print.default, f = proto::name.proto)$f(...)
# }
ggplot2/R/aes-position.r 0000644 0001751 0000144 00000003506 12114160774 014653 0 ustar hornik users #' Position related aesthetics: x, y, xmin, xmax, ymin, ymax, xend, yend
#'
#' This page demonstrates the usage of a sub-group
#' of aesthetics; x, y, xmin, xmax, ymin, ymax, xend, and yend.
#'
#' @name aes_position
#' @aliases x y xmin xmax ymin ymax xend yend
#' @examples
#'
#' # Generate data: means and standard errors of means for prices
#' # for each type of cut
#' dmod <- lm(price ~ cut, data = diamonds)
#' cuts <- data.frame(cut = unique(diamonds$cut), predict(dmod, data.frame(cut =
#' unique(diamonds$cut)), se = TRUE)[c("fit", "se.fit")])
#' se <- ggplot(cuts, aes(x = cut, y = fit, ymin = fit - se.fit,
#' ymax = fit + se.fit, colour = cut))
#' se + geom_pointrange()
#'
#' # Boxplot with precomputed statistics
#' # generate sample data
#' library(plyr)
#' abc <- adply(matrix(rnorm(100), ncol = 5), 2, quantile, c(0, .25, .5, .75, 1))
#' b <- ggplot(abc, aes(x = X1, ymin = "0%", lower = "25%", middle = "50%", upper = "75%", ymax = "100%"))
#' b + geom_boxplot(stat = "identity")
#'
#' # Using annotate
#' p <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
#' p + annotate("rect", xmin = 2, xmax = 3.5, ymin = 2, ymax = 25, fill = "dark grey", alpha = .5)
#'
#' # Geom_segment examples
#' library(grid)
#' p + geom_segment(aes(x = 2, y = 15, xend = 2, yend = 25), arrow = arrow(length = unit(0.5, "cm")))
#' p + geom_segment(aes(x = 2, y = 15, xend = 3, yend = 15), arrow = arrow(length = unit(0.5, "cm")))
#' p + geom_segment(aes(x = 5, y = 30, xend = 3.5, yend = 25), arrow = arrow(length = unit(0.5, "cm")))
#'
#' # You can also use geom_segment to recreate plot(type = "h") :
#' counts <- as.data.frame(table(x = rpois(100, 5)))
#' counts$x <- as.numeric(as.character(counts$x))
#' with(counts, plot(x, Freq, type = "h", lwd = 10))
#'
#' qplot(x, Freq, data = counts, geom = "segment", yend = 0, xend = x, size = I(10))
NULL
ggplot2/R/zzz.r 0000644 0001751 0000144 00000000762 12114160774 013077 0 ustar hornik users .onAttach <- function(...) {
if (!interactive() || stats::runif(1) > 0.1) return()
tips <- c(
"Need help? Try the ggplot2 mailing list: http://groups.google.com/group/ggplot2.",
paste("Find out what's changed in ggplot2 with\n",
"news(Version == \"", utils::packageVersion("ggplot2"),
"\", package = \"ggplot2\")", sep = ""),
"Use suppressPackageStartupMessages to eliminate package startup messages."
)
tip <- sample(tips, 1)
packageStartupMessage(tip)
}
ggplot2/R/position-identity.r 0000644 0001751 0000144 00000000661 12114160774 015733 0 ustar hornik users #' Don't adjust position
#'
#' @param width Manually specify width (does not affect all position
#' adjustments)
#' @param height Manually specify height (does not affect all position
#' adjustments)
#' @family position adjustments
#' @export
position_identity <- function (width = NULL, height = NULL) {
PositionIdentity$new(width = width, height = height)
}
PositionIdentity <- proto(Position, {
objname <- "identity"
})
ggplot2/R/scale-area.r 0000644 0001751 0000144 00000001616 12114161113 014222 0 ustar hornik users #' Scale area instead of radius (for size).
#'
#' \code{\link{scale_area}} is deprecated and will be removed in a future
#' version of ggplot2. Use \code{\link{scale_size_area}} instead. Note that the
#' default behavir of \code{\link{scale_size_area}} is slightly different: by
#' default, it makes the area proportional to the numeric value.
#'
#' @param ... Other arguments passed on to \code{\link{continuous_scale}}
#' to control name, limits, breaks, labels and so forth.
#' @param range Range of output sizes. Should be greater than 0.
#' @export
scale_area <- function(..., range = c(1, 6)) {
gg_dep("0.9.2", paste(sep = "\n",
"scale_area is deprecated. Use scale_size_area instead.",
" Note that the behavior of scale_size_area is slightly different:",
" by default it makes the area proportional to the numeric value."))
continuous_scale("size", "area", area_pal(range), ...)
}
ggplot2/R/facet-viewports.r 0000644 0001751 0000144 00000002575 12114160774 015370 0 ustar hornik users # Assign viewports to a matrix of grobs
#
# Uses the structure (and names) of the matrix of grobs, to automatically
# assign each grob to the appropriate viewport
assign_viewports <- function(grobs) {
make_grid <- function(type) {
data.frame(
type = type,
x = c(row(grobs[[type]])),
y = c(col(grobs[[type]]))
)
}
assign_vp <- function(type, x, y) {
ggname(type, editGrob(grobs[[type]][[x, y]], vp = vp_path(x, y, type)))
}
grid <- ldply(names(grobs), make_grid)
mlply(grid, assign_vp)
}
# Setup matrix of viewports for a layout with given parameters
setup_viewports <- function(type, data, offset = c(0,0), clip = "on") {
rows <- nrow(data)
cols <- ncol(data)
vp <- function(x,y) {
# cat(vp_name(x, y, type), ": ", x + offset[1], ", ", y + offset[2], "\n", sep="")
viewport(
name = vp_name(x, y, type),
layout.pos.row = x + offset[1],
layout.pos.col = y + offset[2],
clip=clip
)
}
pos <- expand.grid(x = seq_len(rows), y= seq_len(cols))
do.call("vpList", mlply(pos, vp))
}
# Calculate viewport path.
# Helps ensure a common naming scheme throughout ggplot.
vp_path <- function(row, col, type) {
vpPath("panels", vp_name(row, col, type))
}
# Compute viewport name.
# Helps ensure a common naming scheme throughout ggplot.
vp_name <- function(row, col, type) {
paste(type, row, col, sep="_")
}
ggplot2/R/plot-last.r 0000644 0001751 0000144 00000000617 12114160774 014160 0 ustar hornik users .plot_store <- function() {
.last_plot <- NULL
list(
get = function() .last_plot,
set = function(value) .last_plot <<- value
)
}
.store <- .plot_store()
# Set last plot created or modified
set_last_plot <- function(value) .store$set(value)
#' Retrieve the last plot to be modified or created.
#'
#' @seealso \code{\link{ggsave}}
#' @export
last_plot <- function() .store$get()
ggplot2/R/geom-boxplot.r 0000644 0001751 0000144 00000016301 12114161113 014636 0 ustar hornik users #' Box and whiskers plot.
#'
#' The upper and lower "hinges" correspond to the first and third quartiles
#' (the 25th and 75th percentiles). This differs slightly from the method used
#' by the \code{boxplot} function, and may be apparent with small samples.
#' See \code{\link{boxplot.stats}} for for more information on how hinge
#' positions are calculated for \code{boxplot}.
#'
#' The upper whisker extends from the hinge to the highest value that is within
#' 1.5 * IQR of the hinge, where IQR is the inter-quartile range, or distance
#' between the first and third quartiles. The lower whisker extends from the
#' hinge to the lowest value within 1.5 * IQR of the hinge. Data beyond the
#' end of the whiskers are outliers and plotted as points (as specified by Tukey).
#'
#' In a notched box plot, the notches extend \code{1.58 * IQR / sqrt(n)}.
#' This gives a roughly 95% confidence interval for comparing medians.
#' See McGill et al. (1978) for more details.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "boxplot")}
#'
#' @seealso \code{\link{stat_quantile}} to view quantiles conditioned on a
#' continuous variable, \code{\link{geom_jitter}} for another way to look
#' at conditional distributions"
#' @inheritParams geom_point
#' @param outlier.colour colour for outlying points
#' @param outlier.shape shape of outlying points
#' @param outlier.size size of outlying points
#' @param notch if \code{FALSE} (default) make a standard box plot. If
#' \code{TRUE}, make a notched box plot. Notches are used to compare groups;
#' if the notches of two boxes do not overlap, this is strong evidence that
#' the medians differ.
#' @param notchwidth for a notched box plot, width of the notch relative to
#' the body (default 0.5)
#' @export
#'
#' @references McGill, R., Tukey, J. W. and Larsen, W. A. (1978) Variations of
#' box plots. The American Statistician 32, 12-16.
#'
#' @examples
#' \donttest{
#' p <- ggplot(mtcars, aes(factor(cyl), mpg))
#'
#' p + geom_boxplot()
#' qplot(factor(cyl), mpg, data = mtcars, geom = "boxplot")
#'
#' p + geom_boxplot() + geom_jitter()
#' p + geom_boxplot() + coord_flip()
#' qplot(factor(cyl), mpg, data = mtcars, geom = "boxplot") +
#' coord_flip()
#'
#' p + geom_boxplot(notch = TRUE)
#' p + geom_boxplot(notch = TRUE, notchwidth = .3)
#'
#' p + geom_boxplot(outlier.colour = "green", outlier.size = 3)
#'
#' # Add aesthetic mappings
#' # Note that boxplots are automatically dodged when any aesthetic is
#' # a factor
#' p + geom_boxplot(aes(fill = cyl))
#' p + geom_boxplot(aes(fill = factor(cyl)))
#' p + geom_boxplot(aes(fill = factor(vs)))
#' p + geom_boxplot(aes(fill = factor(am)))
#'
#' # Set aesthetics to fixed value
#' p + geom_boxplot(fill = "grey80", colour = "#3366FF")
#' qplot(factor(cyl), mpg, data = mtcars, geom = "boxplot",
#' colour = I("#3366FF"))
#'
#' # Scales vs. coordinate transforms -------
#' # Scale transformations occur before the boxplot statistics are computed.
#' # Coordinate transformations occur afterwards. Observe the effect on the
#' # number of outliers.
#' library(plyr) # to access round_any
#' m <- ggplot(movies, aes(y = votes, x = rating,
#' group = round_any(rating, 0.5)))
#' m + geom_boxplot()
#' m + geom_boxplot() + scale_y_log10()
#' m + geom_boxplot() + coord_trans(y = "log10")
#' m + geom_boxplot() + scale_y_log10() + coord_trans(y = "log10")
#'
#' # Boxplots with continuous x:
#' # Use the group aesthetic to group observations in boxplots
#' qplot(year, budget, data = movies, geom = "boxplot")
#' qplot(year, budget, data = movies, geom = "boxplot",
#' group = round_any(year, 10, floor))
#'
#' # Using precomputed statistics
#' # generate sample data
#' abc <- adply(matrix(rnorm(100), ncol = 5), 2, quantile, c(0, .25, .5, .75, 1))
#' b <- ggplot(abc, aes(x = X1, ymin = `0%`, lower = `25%`, middle = `50%`, upper = `75%`, ymax = `100%`))
#' b + geom_boxplot(stat = "identity")
#' b + geom_boxplot(stat = "identity") + coord_flip()
#' b + geom_boxplot(aes(fill = X1), stat = "identity")
#' }
geom_boxplot <- function (mapping = NULL, data = NULL, stat = "boxplot", position = "dodge",
outlier.colour = "black", outlier.shape = 16, outlier.size = 2,
notch = FALSE, notchwidth = .5, ...) {
GeomBoxplot$new(mapping = mapping, data = data, stat = stat,
position = position, outlier.colour = outlier.colour, outlier.shape = outlier.shape,
outlier.size = outlier.size, notch = notch, notchwidth = notchwidth, ...)
}
GeomBoxplot <- proto(Geom, {
objname <- "boxplot"
reparameterise <- function(., df, params) {
df$width <- df$width %||%
params$width %||% (resolution(df$x, FALSE) * 0.9)
if (!is.null(df$outliers)) {
suppressWarnings({
out_min <- vapply(df$outliers, min, numeric(1))
out_max <- vapply(df$outliers, max, numeric(1))
})
df$ymin_final <- pmin(out_min, df$ymin)
df$ymax_final <- pmax(out_max, df$ymax)
}
transform(df,
xmin = x - width / 2, xmax = x + width / 2, width = NULL
)
}
draw <- function(., data, ..., fatten = 2, outlier.colour = NULL, outlier.shape = NULL, outlier.size = 2,
notch = FALSE, notchwidth = .5) {
common <- data.frame(
colour = data$colour,
size = data$size,
linetype = data$linetype,
fill = alpha(data$fill, data$alpha),
group = data$group,
stringsAsFactors = FALSE
)
whiskers <- data.frame(
x = data$x,
xend = data$x,
y = c(data$upper, data$lower),
yend = c(data$ymax, data$ymin),
alpha = NA,
common)
box <- data.frame(
xmin = data$xmin,
xmax = data$xmax,
ymin = data$lower,
y = data$middle,
ymax = data$upper,
ynotchlower = ifelse(notch, data$notchlower, NA),
ynotchupper = ifelse(notch, data$notchupper, NA),
notchwidth = notchwidth,
alpha = data$alpha,
common)
if (!is.null(data$outliers) && length(data$outliers[[1]] >= 1)) {
outliers <- data.frame(
y = data$outliers[[1]],
x = data$x[1],
colour = outlier.colour %||% data$colour[1],
shape = outlier.shape %||% data$shape[1],
size = outlier.size %||% data$size[1],
fill = NA,
alpha = NA,
stringsAsFactors = FALSE)
outliers_grob <- GeomPoint$draw(outliers, ...)
} else {
outliers_grob <- NULL
}
ggname(.$my_name(), grobTree(
outliers_grob,
GeomSegment$draw(whiskers, ...),
GeomCrossbar$draw(box, fatten = fatten, ...)
))
}
guide_geom <- function(.) "boxplot"
draw_legend <- function(., data, ...) {
data <- aesdefaults(data, .$default_aes(), list(...))
gp <- with(data, gpar(col=colour, fill=alpha(fill, alpha), lwd=size * .pt, lty = linetype))
gTree(gp = gp, children = gList(
linesGrob(0.5, c(0.1, 0.25)),
linesGrob(0.5, c(0.75, 0.9)),
rectGrob(height=0.5, width=0.75),
linesGrob(c(0.125, 0.875), 0.5)
))
}
default_stat <- function(.) StatBoxplot
default_pos <- function(.) PositionDodge
default_aes <- function(.) aes(weight=1, colour="grey20", fill="white", size=0.5, alpha = NA, shape = 16, linetype = "solid")
required_aes <- c("x", "lower", "upper", "middle", "ymin", "ymax")
})
ggplot2/R/position-jitter.r 0000644 0001751 0000144 00000003300 12114160774 015374 0 ustar hornik users #' Jitter points to avoid overplotting.
#'
#' @family position adjustments
#' @param width degree of jitter in x direction. Defaults to 40\% of the
#' resolution of the data.
#' @param height degree of jitter in y direction. Defaults to 40\% of the
#' resolution of the data
#' @export
#' @examples
#' qplot(am, vs, data = mtcars)
#'
#' # Default amount of jittering will generally be too much for
#' # small datasets:
#' qplot(am, vs, data = mtcars, position = "jitter")
#' # Control the amount as follows
#' qplot(am, vs, data = mtcars, position = position_jitter(w = 0.1, h = 0.1))
#'
#' # With ggplot
#' ggplot(mtcars, aes(x = am, y = vs)) + geom_point(position = "jitter")
#' ggplot(mtcars, aes(x = am, y = vs)) + geom_point(position = position_jitter(w = 0.1, h = 0.1))
#'
#' # The default works better for large datasets, where it will
#' # take up as much space as a boxplot or a bar
#' qplot(class, hwy, data = mpg, geom = c("boxplot", "jitter"))
position_jitter <- function (width = NULL, height = NULL) {
PositionJitter$new(width = width, height = height)
}
PositionJitter <- proto(Position, {
objname <- "jitter"
adjust <- function(., data) {
if (empty(data)) return(data.frame())
check_required_aesthetics(c("x", "y"), names(data), "position_jitter")
if (is.null(.$width)) .$width <- resolution(data$x, zero = FALSE) * 0.4
if (is.null(.$height)) .$height <- resolution(data$y, zero = FALSE) * 0.4
trans_x <- NULL
trans_y <- NULL
if(.$width > 0) {
trans_x <- function(x) jitter(x, amount = .$width)
}
if(.$height > 0) {
trans_y <- function(x) jitter(x, amount = .$height)
}
transform_position(data, trans_x, trans_y)
}
})
ggplot2/R/bench.r 0000644 0001751 0000144 00000001324 12114160774 013314 0 ustar hornik users #' Benchmark plot creation time.
#' Broken down into construct, build, render and draw times.
#'
#' @param x code to create ggplot2 plot
#' @export
#' @keywords internal
#' @examples
#' benchplot(qplot(mpg, wt, data = mtcars))
#' benchplot(qplot(mpg, wt, data = mtcars) + facet_grid(.~ cyl))
benchplot <- function(x) {
construct <- system.time(force(x))
stopifnot(inherits(x, "ggplot"))
build <- system.time(data <- ggplot_build(x))
render <- system.time(grob <- ggplot_gtable(data))
draw <- system.time(grid.draw(grob))
times <- rbind(construct, build, render, draw)[, 1:3]
unrowname(data.frame(
step = c("construct", "build", "render", "draw", "TOTAL"),
rbind(times, colSums(times))))
}
ggplot2/R/utilities-help.r 0000644 0001751 0000144 00000001646 12114161113 015171 0 ustar hornik users aesthetics <- function(x) {
req_aes <- x$required_aes
def_aes <- names(x$default_aes())
def_aes <- setdiff(def_aes, req_aes)
if (length(req_aes) == 0){
# Suppress warnings which occur when sorting NULL
return(suppressWarnings(sort(names(x$default_aes()))))
}
if (length(def_aes) == 0){
return(paste("\\strong{", sort(x$required_aes), "}",sep = ""))
}
return(c(paste("\\strong{", sort(x$required_aes), "}", sep = ""), sort(def_aes)))
}
geom_aesthetics <- function(x) {
aesthetics(Geom$find(x))
}
stat_aesthetics <- function(x) {
aesthetics(Stat$find(x))
}
rd_aesthetics <- function(type, name) {
obj <- get(firstUpper(type))
aes <- aesthetics(obj$find(name))
paste("\\code{", type, "_", name, "} ",
"understands the following aesthetics (required aesthetics are in bold):\n\n",
"\\itemize{\n",
paste(" \\item \\code{", aes, "}", collapse = "\n", sep = ""),
"\n}\n", sep = "")
}
ggplot2/R/stat-vline.r 0000644 0001751 0000144 00000007155 12114160774 014333 0 ustar hornik users #' Add a line with slope and intercept.
#'
#' @keywords internal
#' @inheritParams stat_identity
#' @seealso \code{\link{geom_abline}} for code examples.
#' @export
#' @examples
#' # see geom_abline
stat_abline <- function (mapping = NULL, data = NULL, geom = "abline", position = "identity", ...) {
StatAbline$new(mapping = mapping, data = data, geom = geom, position = position, ...)
}
StatAbline <- proto(Stat, {
objname <- "abline"
calculate <- function(., data, scales, intercept = NULL, slope = NULL, ...) {
if (is.null(intercept)) {
if (is.null(data$intercept)) data$intercept <- 0
} else {
data <- data[rep(1, length(intercept)), , drop = FALSE]
data$intercept <- intercept
}
if (is.null(slope)) {
if (is.null(data$slope)) data$slope <- 1
} else {
data <- data[rep(1, length(slope)), , drop = FALSE]
data$slope <- slope
}
unique(data)
}
default_geom <- function(.) GeomAbline
})
#' Add a vertical line
#'
#' @keywords internal
#' @inheritParams stat_identity
#' @seealso \code{\link{geom_vline}} for code examples.
#' @export
#' @examples
#' # see geom_vline
stat_vline <- function (mapping = NULL, data = NULL, geom = "vline", position = "identity",
xintercept, ...) {
StatVline$new(mapping = mapping, data = data, geom = geom, position = position,
xintercept = xintercept, ...)
}
StatVline <- proto(Stat, {
objname <- "vline"
calculate <- function(., data, scales, xintercept = NULL, intercept, ...) {
if (!missing(intercept)) {
stop("stat_vline now uses xintercept instead of intercept")
}
data <- compute_intercept(data, xintercept, "x")
unique(within(data, {
x <- xintercept
xend <- xintercept
}))
}
required_aes <- c()
default_geom <- function(.) GeomVline
})
#' Add a horizontal line
#'
#' @keywords internal
#' @inheritParams stat_identity
#' @seealso \code{\link{geom_hline}} for code examples.
#' @export
#' @examples
#' # see geom_hline
stat_hline <- function (mapping = NULL, data = NULL, geom = "hline", position = "identity",
yintercept, ...) {
StatHline$new(mapping = mapping, data = data, geom = geom, position = position,
yintercept = yintercept, ...)
}
StatHline <- proto(Stat, {
calculate <- function(., data, scales, yintercept = NULL, intercept, ...) {
if (!missing(intercept)) {
stop("stat_hline now uses yintercept instead of intercept")
}
data <- compute_intercept(data, yintercept, "y")
unique(within(data, {
y <- yintercept
yend <- yintercept
}))
}
objname <- "hline"
desc <- "Add a horizontal line"
required_aes <- c()
default_geom <- function(.) GeomHline
examples <- function(.) {
# See geom_hline for examples
}
})
# Compute intercept for vline and hline from data and parameters
#
# @keyword internal
compute_intercept <- function(data, intercept, var = "x") {
ivar <- paste(var, "intercept", sep = "")
if (is.null(intercept)) {
# Intercept comes from data, default to 0 if not set
if (is.null(data[[ivar]])) data[[ivar]] <- 0
} else if (is.numeric(intercept)) {
# Intercept is a numeric vector of positions
data <- data[rep(1, length(intercept)), ]
data[[ivar]] <- intercept
} else if (is.character(intercept) || is.function(intercept)) {
# Intercept is a function
f <- match.fun(intercept)
trans <- function(data) {
data[[ivar]] <- f(data[[var]])
data
}
data <- ddply(data, .(group), trans)
} else {
stop("Invalid intercept type: should be a numeric vector, a function",
", or a name of a function", call. = FALSE)
}
data
}
ggplot2/R/stat-bin.r 0000644 0001751 0000144 00000012575 12114161113 013754 0 ustar hornik users #' Bin data.
#'
#' Missing values are currently silently dropped.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "bin")}
#'
#' @inheritParams stat_identity
#' @param binwidth Bin width to use. Defaults to 1/30 of the range of the
#' data
#' @param breaks Actual breaks to use. Overrides bin width and origin
#' @param origin Origin of first bin
#' @param width Width of bars when used with categorical data
#' @param right If \code{TRUE}, right-closed, left-open, if \code{FALSE},
#" the default, right-open, left-closed.
#' @param drop If TRUE, remove all bins with zero counts
#' @return New data frame with additional columns:
#' \item{count}{number of points in bin}
#' \item{density}{density of points in bin, scaled to integrate to 1}
#' \item{ncount}{count, scaled to maximum of 1}
#' \item{ndensity}{density, scaled to maximum of 1}
#' @export
#' @examples
#' \donttest{
#' simple <- data.frame(x = rep(1:10, each = 2))
#' base <- ggplot(simple, aes(x))
#' # By default, right = TRUE, and intervals are of the form (a, b]
#' base + stat_bin(binwidth = 1, drop = FALSE, right = TRUE, col = "black")
#' # If right = FALSE intervals are of the form [a, b)
#' base + stat_bin(binwidth = 1, drop = FALSE, right = FALSE, col = "black")
#'
#' m <- ggplot(movies, aes(x=rating))
#' m + stat_bin()
#' m + stat_bin(binwidth=0.1)
#' m + stat_bin(breaks=seq(4,6, by=0.1))
#' # See geom_histogram for more histogram examples
#'
#' # To create a unit area histogram, use aes(y = ..density..)
#' (linehist <- m + stat_bin(aes(y = ..density..), binwidth=0.1,
#' geom="line", position="identity"))
#' linehist + stat_density(colour="blue", fill=NA)
#'
#' # Also works with categorical variables
#' ggplot(movies, aes(x=mpaa)) + stat_bin()
#' qplot(mpaa, data=movies, stat="bin")
#' }
stat_bin <- function (mapping = NULL, data = NULL, geom = "bar", position = "stack",
width = 0.9, drop = FALSE, right = FALSE, binwidth = NULL, origin = NULL, breaks = NULL, ...) {
StatBin$new(mapping = mapping, data = data, geom = geom, position = position,
width = width, drop = drop, right = right, binwidth = binwidth, origin = origin, breaks = breaks, ...)
}
StatBin <- proto(Stat, {
objname <- "bin"
informed <- FALSE
calculate_groups <- function(., data, ...) {
if (!is.null(data$y) || !is.null(match.call()$y)) {
# Deprecate this behavior
gg_dep("0.9.2", paste(sep = "\n",
"Mapping a variable to y and also using stat=\"bin\".",
" With stat=\"bin\", it will attempt to set the y value to the count of cases in each group.",
" This can result in unexpected behavior and will not be allowed in a future version of ggplot2.",
" If you want y to represent counts of cases, use stat=\"bin\" and don't map a variable to y.",
" If you want y to represent values in the data, use stat=\"identity\".",
" See ?geom_bar for examples."))
}
.$informed <- FALSE
.super$calculate_groups(., data, ...)
}
calculate <- function(., data, scales, binwidth=NULL, origin=NULL, breaks=NULL, width=0.9, drop = FALSE, right = FALSE, ...) {
range <- scale_dimension(scales$x, c(0, 0))
if (is.null(breaks) && is.null(binwidth) && !is.integer(data$x) && !.$informed) {
message("stat_bin: binwidth defaulted to range/30. Use 'binwidth = x' to adjust this.")
.$informed <- TRUE
}
bin(data$x, data$weight, binwidth=binwidth, origin=origin, breaks=breaks, range=range, width=width, drop = drop, right = right)
}
default_aes <- function(.) aes(y = ..count..)
required_aes <- c("x")
default_geom <- function(.) GeomBar
})
bin <- function(x, weight=NULL, binwidth=NULL, origin=NULL, breaks=NULL, range=NULL, width=0.9, drop = FALSE, right = TRUE) {
if (length(na.omit(x)) == 0) return(data.frame())
if (is.null(weight)) weight <- rep(1, length(x))
weight[is.na(weight)] <- 0
if (is.null(range)) range <- range(x, na.rm = TRUE, finite=TRUE)
if (is.null(binwidth)) binwidth <- diff(range) / 30
if (is.integer(x)) {
bins <- x
x <- sort(unique(bins))
width <- width
} else if (diff(range) == 0) {
width <- width
bins <- x
} else { # if (is.numeric(x))
if (is.null(breaks)) {
if (is.null(origin)) {
breaks <- fullseq(range, binwidth, pad = TRUE)
} else {
breaks <- seq(origin, max(range) + binwidth, binwidth)
}
}
# Adapt break fuzziness from base::hist - this protects from floating
# point rounding errors
diddle <- 1e-07 * stats::median(diff(breaks))
if (right) {
fuzz <- c(-diddle, rep.int(diddle, length(breaks) - 1))
} else {
fuzz <- c(rep.int(-diddle, length(breaks) - 1), diddle)
}
fuzzybreaks <- sort(breaks) + fuzz
bins <- cut(x, fuzzybreaks, include.lowest=TRUE, right = right)
left <- breaks[-length(breaks)]
right <- breaks[-1]
x <- (left + right)/2
width <- diff(breaks)
}
results <- data.frame(
count = as.numeric(tapply(weight, bins, sum, na.rm=TRUE)),
x = x,
width = width
)
if (sum(results$count, na.rm = TRUE) == 0) {
return(results)
}
res <- within(results, {
count[is.na(count)] <- 0
density <- count / width / sum(abs(count), na.rm=TRUE)
ncount <- count / max(abs(count), na.rm=TRUE)
ndensity <- density / max(abs(density), na.rm=TRUE)
})
if (drop) res <- subset(res, count > 0)
res
}
ggplot2/R/position-fill.r 0000644 0001751 0000144 00000002223 12114160774 015024 0 ustar hornik users #' Stack overlapping objects on top of one another, and standardise to have
#' equal height.
#'
#' @inheritParams position_identity
#' @family position adjustments
#' @seealso See \code{\link{geom_bar}} and \code{\link{geom_area}} for
#' more examples.
#' @export
#' @examples
#' \donttest{
#' # See ?geom_bar and ?geom_area for more examples
#' ggplot(mtcars, aes(x=factor(cyl), fill=factor(vs))) +
#' geom_bar(position="fill")
#'
#' cde <- geom_histogram(position="fill", binwidth = 500)
#'
#' ggplot(diamonds, aes(x=price)) + cde
#' ggplot(diamonds, aes(x=price, fill=cut)) + cde
#' ggplot(diamonds, aes(x=price, fill=clarity)) + cde
#' ggplot(diamonds, aes(x=price, fill=color)) + cde
#' }
position_fill <- function (width = NULL, height = NULL) {
PositionFill$new(width = width, height = height)
}
PositionFill <- proto(Position, {
objname <- "fill"
adjust <- function(., data) {
if (empty(data)) return(data.frame())
check_required_aesthetics(c("x", "ymax"), names(data), "position_fill")
if (!all(data$ymin == 0)) warning("Filling not well defined when ymin != 0")
collide(data, .$width, .$my_name(), pos_fill)
}
})
ggplot2/R/scale-brewer.r 0000644 0001751 0000144 00000002472 12114160774 014615 0 ustar hornik users #' Sequential, diverging and qualitative colour scales from colorbrewer.org
#'
#' See \url{http://colorbrewer2.org} for more information.
#'
#' @inheritParams scales::brewer_pal
#' @inheritParams scale_colour_hue
#' @family colour scales
#' @rdname scale_brewer
#' @export
#' @examples
#' dsamp <- diamonds[sample(nrow(diamonds), 1000), ]
#' (d <- qplot(carat, price, data=dsamp, colour=clarity))
#'
#' # Change scale label
#' d + scale_colour_brewer()
#' d + scale_colour_brewer("clarity")
#' d + scale_colour_brewer(expression(clarity[beta]))
#'
#' # Select brewer palette to use, see ?scales::brewer_pal for more details
#' d + scale_colour_brewer(type="seq")
#' d + scale_colour_brewer(type="seq", palette=3)
#'
#' d + scale_colour_brewer(palette="Blues")
#' d + scale_colour_brewer(palette="Set1")
#'
#' # scale_fill_brewer works just the same as
#' # scale_colour_brewer but for fill colours
#' ggplot(diamonds, aes(x=price, fill=cut)) +
#' geom_histogram(position="dodge", binwidth=1000) +
#' scale_fill_brewer()
scale_colour_brewer <- function(..., type = "seq", palette = 1) {
discrete_scale("colour", "brewer", brewer_pal(type, palette), ...)
}
#' @export
#' @rdname scale_brewer
scale_fill_brewer <- function(..., type = "seq", palette = 1) {
discrete_scale("fill", "brewer", brewer_pal(type, palette), ...)
}
ggplot2/R/grob-absolute.r 0000644 0001751 0000144 00000002021 12114160774 014775 0 ustar hornik users #' Absolute grob
#'
#' This grob has fixed dimesions and position.
#'
#' It's still experimental
#'
#' @S3method grobHeight absoluteGrob
#' @S3method grobWidth absoluteGrob
#' @S3method grobX absoluteGrob
#' @S3method grobY absoluteGrob
#' @S3method grid.draw absoluteGrob
#' @keywords internal
absoluteGrob <- function(grob, width = NULL, height = NULL,
xmin = NULL, ymin = NULL, vp = NULL) {
gTree(
children = grob,
width = width, height = height,
xmin = xmin, ymin = ymin,
vp = vp, cl="absoluteGrob"
)
}
grobHeight.absoluteGrob <- function(x) {
x$height %||% grobHeight(x$children)
}
grobWidth.absoluteGrob <- function(x) {
x$width %||% grobWidth(x$children)
}
grobX.absoluteGrob <- function(x, theta) {
if (!is.null(x$xmin) && theta == "west") return(x$xmin)
grobX(x$children, theta)
}
grobY.absoluteGrob <- function(x, theta) {
if (!is.null(x$ymin) && theta == "south") return(x$ymin)
grobY(x$children, theta)
}
grid.draw.absoluteGrob <- function(x, recording = TRUE) {
grid:::drawGTree(x)
}
ggplot2/R/geom-error.r 0000644 0001751 0000144 00000006002 12114160774 014311 0 ustar hornik users #' Error bars.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "errorbar")}
#'
#' @seealso \code{\link{geom_pointrange}}: range indicated by straight line,
#' with point in the middle; \code{\link{geom_linerange}}: range indicated
#' by straight line; \code{\link{geom_crossbar}}: hollow bar with middle
#' indicated by horizontal line; \code{\link{stat_summary}}: examples of
#' these guys in use, \code{\link{geom_smooth}} for continuous analog
#' @inheritParams geom_point
#' @export
#' @examples
#' # Create a simple example dataset
#' df <- data.frame(
#' trt = factor(c(1, 1, 2, 2)),
#' resp = c(1, 5, 3, 4),
#' group = factor(c(1, 2, 1, 2)),
#' se = c(0.1, 0.3, 0.3, 0.2)
#' )
#' df2 <- df[c(1,3),]
#'
#' # Define the top and bottom of the errorbars
#' limits <- aes(ymax = resp + se, ymin=resp - se)
#'
#' p <- ggplot(df, aes(fill=group, y=resp, x=trt))
#' p + geom_bar(position="dodge", stat="identity")
#'
#' # Because the bars and errorbars have different widths
#' # we need to specify how wide the objects we are dodging are
#' dodge <- position_dodge(width=0.9)
#' p + geom_bar(position=dodge) + geom_errorbar(limits, position=dodge, width=0.25)
#'
#' p <- ggplot(df2, aes(fill=group, y=resp, x=trt))
#' p + geom_bar(position=dodge)
#' p + geom_bar(position=dodge) + geom_errorbar(limits, position=dodge, width=0.25)
#'
#' p <- ggplot(df, aes(colour=group, y=resp, x=trt))
#' p + geom_point() + geom_errorbar(limits, width=0.2)
#' p + geom_pointrange(limits)
#' p + geom_crossbar(limits, width=0.2)
#'
#' # If we want to draw lines, we need to manually set the
#' # groups which define the lines - here the groups in the
#' # original dataframe
#' p + geom_line(aes(group=group)) + geom_errorbar(limits, width=0.2)
geom_errorbar <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", ...) {
GeomErrorbar$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomErrorbar <- proto(Geom, {
objname <- "errorbar"
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(colour = "black", size=0.5, linetype=1, width=0.5, alpha = NA)
guide_geom <- function(.) "path"
required_aes <- c("x", "ymin", "ymax")
reparameterise <- function(., df, params) {
df$width <- df$width %||%
params$width %||% (resolution(df$x, FALSE) * 0.9)
transform(df,
xmin = x - width / 2, xmax = x + width / 2, width = NULL
)
}
draw <- function(., data, scales, coordinates, width = NULL, ...) {
GeomPath$draw(with(data, data.frame(
x = as.vector(rbind(xmin, xmax, NA, x, x, NA, xmin, xmax)),
y = as.vector(rbind(ymax, ymax, NA, ymax, ymin, NA, ymin, ymin)),
colour = rep(colour, each = 8),
alpha = rep(alpha, each = 8),
size = rep(size, each = 8),
linetype = rep(linetype, each = 8),
group = rep(1:(nrow(data)), each = 8),
stringsAsFactors = FALSE,
row.names = 1:(nrow(data) * 8)
)), scales, coordinates, ...)
}
})
ggplot2/R/translate-qplot-ggplot.r 0000644 0001751 0000144 00000007351 12114160774 016667 0 ustar hornik users #' Translating between qplot and ggplot
#'
#' Within ggplot2, there are two basic methods to create plots, with qplot()
#' and ggplot(). qplot() is designed primarily for interactive use: it makes
#' a number of assumptions that speed most cases, but when designing multilayered
#' plots with different data sources it can get in the way. This section
#' describes what those defaults are, and how they map to the fuller ggplot()
#' syntax.
#'
#' @name translate_qplot_ggplot
#' @examples
#'
#' # By default, qplot() assumes that you want a scatterplot,
#' # i.e., you want to use geom_point()
#' # qplot(x, y, data = data)
#' # ggplot(data, aes(x, y)) + geom_point()
#'
#' # Using Aesthetics
#'
#' # If you map additional aesthetics, these will be added to the defaults. With
#' # qplot() there is no way to use different aesthetic mappings (or data) in
#' # different layers
#' # qplot(x, y, data = data, shape = shape, colour = colour)
#' # ggplot(data, aes(x, y, shape = shape, colour = colour)) + geom_point()
#' #
#' # Aesthetic parameters in qplot() always try to map the aesthetic to a
#' # variable. If the argument is not a variable but a value, effectively a new column
#' # is added to the original dataset with that value. To set an aesthetic to a
#' # value and override the default appearance, you surround the value with I() in
#' # qplot(), or pass it as a parameter to the layer.
#' # qplot(x, y, data = data, colour = I("red"))
#' # ggplot(data, aes(x, y)) + geom_point(colour = "red")
#'
#' # Changing the geom parameter changes the geom added to the plot
#' # qplot(x, y, data = data, geom = "line")
#' # ggplot(data, aes(x, y)) + geom_line()
#'
#' # Not all geoms require both x and y, e.g., geom_bar() and geom_histogram().
#' # For these two geoms, if the y aesthetic is not supplied, both qplot and
#' # ggplot commands default to "count" on the y-axis
#' # ggplot(data, aes(x)) + geom_bar()
#' # qplot(x, data = data, geom = "bar")
#'
#' # If a vector of multiple geom names is supplied to the geom argument, each
#' # geom will be added in turn
#' # qplot(x, y, data = data, geom = c("point", "smooth"))
#' # ggplot(data, aes(x, y)) + geom_point() + geom_smooth()
#'
#' # Unlike the rest of ggplot2, stats and geoms are independent
#' # qplot(x, y, data = data, stat = "bin")
#' # ggplot(data, aes(x, y)) + geom_point(stat = "bin")
#' #
#' # Any layer parameters will be passed on to all layers. Most layers will ignore
#' # parameters that they don't need
#' # qplot(x, y, data = data, geom = c("point", "smooth"), method = "lm")
#' # ggplot(data, aes(x, y)) + geom_point(method = "lm") + geom_smooth(method = "lm")
#'
#' # Scales and axes
#'
#' # You can control basic properties of the x and y scales with the xlim, ylim,
#' # xlab and ylab arguments
#' # qplot(x, y, data = data, xlim = c(1, 5), xlab = "my label")
#' # ggplot(data, aes(x, y)) + geom_point() +
#' # scale_x_continuous("my label", limits = c(1, 5))
#'
#' # qplot(x, y, data = data, xlim = c(1, 5), ylim = c(10, 20))
#' # ggplot(data, aes(x, y)) + geom_point() +
#' # scale_x_continuous(limits = c(1, 5)) + scale_y_continuous(limits = c(10, 20))
#'
#' # Like plot(), qplot() has a convenient way of log transforming the axes.
#' # qplot(x, y, data = data, log = "xy")
#' # ggplot(data, aes(x, y)) + geom_point() + scale_x_log10() + scale_y_log10()
#' # There are many other possible transformations, but not all are
#' # accessible from within qplot(), see ?scale_continuous for more
#'
#' # Plot options
#'
#' # qplot() recognises the same options as plot does, and converts them to their
#' # ggplot2 equivalents. See ?theme for more on ggplot options
#' # qplot(x, y, data = data, main="title", asp = 1)
#' # ggplot(data, aes(x, y)) + geom_point() + labs(title = "title") + theme(aspect.ratio = 1)
NULL
ggplot2/R/scale-grey.r 0000644 0001751 0000144 00000002130 12114160774 014264 0 ustar hornik users #' Sequential grey colour scale.
#'
#' Based on \code{\link{gray.colors}}
#'
#' @inheritParams scales::grey_pal
#' @inheritParams scale_colour_hue
#' @family colour scales
#' @rdname scale_grey
#' @export
#' @examples
#' p <- qplot(mpg, wt, data=mtcars, colour=factor(cyl))
#' p + scale_colour_grey()
#' p + scale_colour_grey(end = 0)
#'
#' # You may want to turn off the pale grey background with this scale
#' p + scale_colour_grey() + theme_bw()
#'
#' # Colour of missing values is controlled with na.value:
#' miss <- factor(sample(c(NA, 1:5), nrow(mtcars), rep = TRUE))
#' qplot(mpg, wt, data = mtcars, colour = miss) + scale_colour_grey()
#' qplot(mpg, wt, data = mtcars, colour = miss) +
#' scale_colour_grey(na.value = "green")
scale_colour_grey <- function(..., start = 0.2, end = 0.8, na.value = "red") {
discrete_scale("colour", "grey", grey_pal(start, end),
na.value = na.value, ...)
}
#' @rdname scale_grey
#' @export
scale_fill_grey <- function(..., start = 0.2, end = 0.8, na.value = "grey50") {
discrete_scale("fill", "grey", grey_pal(start, end),
na.value = na.value, ...)
}
ggplot2/R/stat-smooth.r 0000644 0001751 0000144 00000016236 12114160774 014527 0 ustar hornik users #' Add a smoother.
#'
#' Aids the eye in seeing patterns in the presence of overplotting.
#'
#' Calculation is performed by the (currently undocumented)
#' \code{predictdf} generic function and its methods. For most methods
#' the confidence bounds are computed using the \code{\link{predict}}
#' method - the exceptions are \code{loess} which uses a t-based
#' approximation, and for \code{glm} where the normal confidence interval
#' is constructed on the link scale, and then back-transformed to the response
#' scale.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "smooth")}
#'
#' @param method smoothing method (function) to use, eg. lm, glm, gam, loess,
#' rlm. For datasets with n < 1000 default is \code{\link{loess}}. For datasets
#' with 1000 or more observations defaults to gam, see \code{\link[mgcv]{gam}}
#' for more details.
#' @param formula formula to use in smoothing function, eg. \code{y ~ x},
#' \code{y ~ poly(x, 2)}, \code{y ~ log(x)}
#' @param se display confidence interval around smooth? (TRUE by default, see
#' level to control
#' @param fullrange should the fit span the full range of the plot, or just
#' the data
#' @param level level of confidence interval to use (0.95 by default)
#' @param n number of points to evaluate smoother at
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @param ... other arguments are passed to smoothing function
#' @inheritParams stat_identity
#' @return a data.frame with additional columns
#' \item{y}{predicted value}
#' \item{ymin}{lower pointwise confidence interval around the mean}
#' \item{ymax}{upper pointwise confidence interval around the mean}
#' \item{se}{standard error}
#' @seealso
#' \code{\link{lm}} for linear smooths,
#' \code{\link{glm}} for generalised linear smooths,
#' \code{\link{loess}} for local smooths
#' @export
#' @examples
#' \donttest{
#' c <- ggplot(mtcars, aes(qsec, wt))
#' c + stat_smooth()
#' c + stat_smooth() + geom_point()
#'
#' # Adjust parameters
#' c + stat_smooth(se = FALSE) + geom_point()
#'
#' c + stat_smooth(span = 0.9) + geom_point()
#' c + stat_smooth(level = 0.99) + geom_point()
#' c + stat_smooth(method = "lm") + geom_point()
#'
#' library(splines)
#' library(MASS)
#' c + stat_smooth(method = "lm", formula = y ~ ns(x,3)) +
#' geom_point()
#' c + stat_smooth(method = rlm, formula= y ~ ns(x,3)) + geom_point()
#'
#' # The default confidence band uses a transparent colour.
#' # This currently only works on a limited number of graphics devices
#' # (including Quartz, PDF, and Cairo) so you may need to set the
#' # fill colour to a opaque colour, as shown below
#' c + stat_smooth(fill = "grey50", size = 2, alpha = 1)
#' c + stat_smooth(fill = "blue", size = 2, alpha = 1)
#'
#' # The colour of the line can be controlled with the colour aesthetic
#' c + stat_smooth(fill="blue", colour="darkblue", size=2)
#' c + stat_smooth(fill="blue", colour="darkblue", size=2, alpha = 0.2)
#' c + geom_point() +
#' stat_smooth(fill="blue", colour="darkblue", size=2, alpha = 0.2)
#'
#' # Smoothers for subsets
#' c <- ggplot(mtcars, aes(y=wt, x=mpg)) + facet_grid(. ~ cyl)
#' c + stat_smooth(method=lm) + geom_point()
#' c + stat_smooth(method=lm, fullrange = TRUE) + geom_point()
#'
#' # Geoms and stats are automatically split by aesthetics that are factors
#' c <- ggplot(mtcars, aes(y=wt, x=mpg, colour=factor(cyl)))
#' c + stat_smooth(method=lm) + geom_point()
#' c + stat_smooth(method=lm, aes(fill = factor(cyl))) + geom_point()
#' c + stat_smooth(method=lm, fullrange=TRUE, alpha = 0.1) + geom_point()
#'
#' # Use qplot instead
#' qplot(qsec, wt, data=mtcars, geom=c("smooth", "point"))
#'
#' # Example with logistic regression
#' data("kyphosis", package="rpart")
#' qplot(Age, Kyphosis, data=kyphosis)
#' qplot(Age, data=kyphosis, facets = . ~ Kyphosis, binwidth = 10)
#' qplot(Age, Kyphosis, data=kyphosis, position="jitter")
#' qplot(Age, Kyphosis, data=kyphosis, position=position_jitter(height=0.1))
#'
#' qplot(Age, as.numeric(Kyphosis) - 1, data = kyphosis) +
#' stat_smooth(method="glm", family="binomial")
#' qplot(Age, as.numeric(Kyphosis) - 1, data=kyphosis) +
#' stat_smooth(method="glm", family="binomial", formula = y ~ ns(x, 2))
#' }
stat_smooth <- function (mapping = NULL, data = NULL, geom = "smooth", position = "identity",
method = "auto", formula = y ~ x, se = TRUE, n = 80, fullrange = FALSE,
level = 0.95, na.rm = FALSE, ...) {
StatSmooth$new(mapping = mapping, data = data, geom = geom, position = position,
method = method, formula = formula, se = se, n = n, fullrange = fullrange,
level = level, na.rm = na.rm, ...)
}
StatSmooth <- proto(Stat, {
objname <- "smooth"
calculate_groups <- function(., data, scales, method="auto", formula=y~x, ...) {
rows <- daply(data, .(group), function(df) length(unique(df$x)))
if (all(rows == 1) && length(rows) > 1) {
message("geom_smooth: Only one unique x value each group.",
"Maybe you want aes(group = 1)?")
return(data.frame())
}
# Figure out what type of smoothing to do: loess for small datasets,
# gam with a cubic regression basis for large data
# This is based on the size of the _largest_ group.
if (is.character(method) && method == "auto") {
groups <- count(data, "group")
if (max(groups$freq) < 1000) {
method <- "loess"
message('geom_smooth: method="auto" and size of largest group is <1000,',
' so using loess.',
' Use \'method = x\' to change the smoothing method.')
} else {
try_require("mgcv")
method <- "gam"
formula <- y ~ s(x, bs = "cs")
message('geom_smooth: method="auto" and size of largest group is >=1000,',
' so using gam with formula: y ~ s(x, bs = "cs").',
' Use \'method = x\' to change the smoothing method.')
}
}
.super$calculate_groups(., data, scales, method = method, formula = formula, ...)
}
calculate <- function(., data, scales, method="auto", formula=y~x, se = TRUE, n=80, fullrange=FALSE, xseq = NULL, level=0.95, na.rm = FALSE, ...) {
data <- remove_missing(data, na.rm, c("x", "y"), name="stat_smooth")
if (length(unique(data$x)) < 2) {
# Not enough data to perform fit
return(data.frame())
}
if (is.null(data$weight)) data$weight <- 1
if (is.null(xseq)) {
if (is.integer(data$x)) {
if (fullrange) {
xseq <- scale_dimension(scales$x, c(0, 0))
} else {
xseq <- sort(unique(data$x))
}
} else {
if (fullrange) {
range <- scale_dimension(scales$x, c(0, 0))
} else {
range <- range(data$x, na.rm=TRUE)
}
xseq <- seq(range[1], range[2], length=n)
}
}
if (is.character(method)) method <- match.fun(method)
method.special <- function(...)
method(formula, data=data, weights=weight, ...)
model <- safe.call(method.special, list(...), names(formals(method)))
predictdf(model, xseq, se, level)
}
required_aes <- c("x", "y")
default_geom <- function(.) GeomSmooth
})
ggplot2/R/geom-hline.r 0000644 0001751 0000144 00000005044 12114160774 014264 0 ustar hornik users #' Horizontal line.
#'
#' This geom allows you to annotate the plot with horizontal lines (see
#' \code{\link{geom_vline}} and \code{\link{geom_abline}} for other types of
#' lines).
#'
#' There are two ways to use it. You can either specify the intercept of
#' the line in the call to the geom, in which case the line will be in the
#' same position in every panel. Alternatively, you can supply a different
#' intercept for each panel using a data.frame. See the examples for the
#' differences
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "hline")}
#'
#' @seealso \code{\link{geom_vline}} for vertical lines,
#' \code{\link{geom_abline}} for lines defined by a slope and intercept,
#' \code{\link{geom_segment}} for a more general approach
#' @export
#' @inheritParams geom_point
#' @param show_guide should a legend be drawn? (defaults to \code{FALSE})
#' @examples
#' p <- ggplot(mtcars, aes(x = wt, y=mpg)) + geom_point()
#'
#' p + geom_hline(aes(yintercept=mpg))
#' p + geom_hline(yintercept=20)
#' p + geom_hline(yintercept=seq(10, 30, by=5))
#'
#' # With coordinate transforms
#' p + geom_hline(aes(yintercept=mpg)) + coord_equal()
#' p + geom_hline(aes(yintercept=mpg)) + coord_flip()
#' p + geom_hline(aes(yintercept=mpg)) + coord_polar()
#'
#' # To display different lines in different facets, you need to
#' # create a data frame.
#' p <- qplot(mpg, wt, data=mtcars, facets = vs ~ am)
#'
#' hline.data <- data.frame(z = 1:4, vs = c(0,0,1,1), am = c(0,1,0,1))
#' p + geom_hline(aes(yintercept = z), hline.data)
geom_hline <- function (mapping = NULL, data = NULL, stat = "hline", position = "identity", show_guide = FALSE, ...) {
GeomHline$new(mapping = mapping, data = data, stat = stat, position = position, show_guide = show_guide, ...)
}
GeomHline <- proto(Geom, {
objname <- "hline"
new <- function(., data = NULL, mapping = NULL, yintercept = NULL, ...) {
if (is.numeric(yintercept)) {
data <- data.frame(yintercept = yintercept)
yintercept <- NULL
mapping <- aes_all(names(data))
}
.super$new(., data = data, mapping = mapping, inherit.aes = FALSE,
yintercept = yintercept, ...)
}
draw <- function(., data, scales, coordinates, ...) {
ranges <- coord_range(coordinates, scales)
data$x <- ranges$x[1]
data$xend <- ranges$x[2]
GeomSegment$draw(unique(data), scales, coordinates)
}
default_stat <- function(.) StatHline
default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = NA)
guide_geom <- function(.) "path"
})
ggplot2/R/coord-transform.r 0000644 0001751 0000144 00000011503 12114160774 015354 0 ustar hornik users #' Transformed cartesian coordinate system.
#'
#' \code{coord_trans} is different to scale transformations in that it occurs after
#' statistical transformation and will affect the visual appearance of geoms - there is
#' no guarantee that straight lines will continue to be straight.
#'
#' All current transformations only work with continuous values - see
#' \code{\link[scales]{trans_new}} for list of transformations, and instructions on
#' how to create your own.
#'
#' @param xtrans,ytrans transformers for x and y axes
#' @param limx,limy limits for x and y axes. (Named so for backward
#' compatability)
#' @export
#' @examples
#' \donttest{
#' # See ?geom_boxplot for other examples
#'
#' # Three ways of doing transformating in ggplot:
#' # * by transforming the data
#' qplot(log10(carat), log10(price), data=diamonds)
#' # * by transforming the scales
#' qplot(carat, price, data=diamonds, log="xy")
#' qplot(carat, price, data=diamonds) + scale_x_log10() + scale_y_log10()
#' # * by transforming the coordinate system:
#' qplot(carat, price, data=diamonds) + coord_trans(x = "log10", y = "log10")
#'
#' # The difference between transforming the scales and
#' # transforming the coordinate system is that scale
#' # transformation occurs BEFORE statistics, and coordinate
#' # transformation afterwards. Coordinate transformation also
#' # changes the shape of geoms:
#'
#' d <- subset(diamonds, carat > 0.5)
#' qplot(carat, price, data = d, log="xy") +
#' geom_smooth(method="lm")
#' qplot(carat, price, data = d) +
#' geom_smooth(method="lm") +
#' coord_trans(x = "log10", y = "log10")
#'
#' # Here I used a subset of diamonds so that the smoothed line didn't
#' # drop below zero, which obviously causes problems on the log-transformed
#' # scale
#'
#' # With a combination of scale and coordinate transformation, it's
#' # possible to do back-transformations:
#' library(scales)
#' qplot(carat, price, data=diamonds, log="xy") +
#' geom_smooth(method="lm") +
#' coord_trans(x = exp_trans(10), y = exp_trans(10))
#' # cf.
#' qplot(carat, price, data=diamonds) + geom_smooth(method = "lm")
#'
#' # Also works with discrete scales
#' df <- data.frame(a = abs(rnorm(26)),letters)
#' plot <- ggplot(df,aes(a,letters)) + geom_point()
#'
#' plot + coord_trans(x = "log10")
#' plot + coord_trans(x = "sqrt")
#' }
coord_trans <- function(xtrans = "identity", ytrans = "identity", limx = NULL, limy = NULL) {
# @kohske
# Now limits are implemented.
# But for backward compatibility, xlim -> limx, ylim -> ylim
# Because there are many examples such as
# > coord_trans(x = "log10", y = "log10")
# Maybe this is changed.
if (is.character(xtrans)) xtrans <- as.trans(xtrans)
if (is.character(ytrans)) ytrans <- as.trans(ytrans)
coord(trans = list(x = xtrans, y = ytrans), limits = list(x = limx, y = limy), subclass = "trans")
}
#' @S3method coord_distance trans
coord_distance.trans <- function(coord, x, y, details) {
max_dist <- dist_euclidean(details$x.range, details$y.range)
dist_euclidean(coord$trans$x$transform(x), coord$trans$y$transform(y)) / max_dist
}
#' @S3method coord_transform trans
coord_transform.trans <- function(coord, data, details) {
trans_x <- function(data) transform_value(coord$trans$x, data, details$x.range)
trans_y <- function(data) transform_value(coord$trans$y, data, details$y.range)
data <- transform_position(data, trans_x, trans_y)
transform_position(data, squish_infinite, squish_infinite)
}
transform_value <- function(trans, value, range) {
rescale(trans$transform(value), 0:1, range)
}
#' @S3method coord_train trans
coord_train.trans <- function(coord, scales) {
c(train_trans(scales$x, coord$limits$x, coord$trans$x, "x"),
train_trans(scales$y, coord$limits$y, coord$trans$y, "y"))
}
train_trans <- function(scale, limits, trans, name) {
# first, calculate the range that is the numerical limits in data space
# expand defined by scale OR coord
# @kohske
# Expansion of data range sometimes go beyond domain,
# so in trasn, expansion takes place at the fnial stage.
if (is.null(limits)) {
range <- scale_dimension(scale, c(0, 0))
} else {
range <- range(scale_transform(scale, limits))
}
# breaks on data space
out <- scale_break_info(scale, range)
# trans'd range
out$range <- trans$transform(out$range)
# expansion if limits are not specified
if (is.null(limits)) {
expand <- coord_expand_defaults(coord, scale)
out$range <- expand_range(out$range, expand[1], expand[2])
}
# major and minor values in plot space
out$major_source <- transform_value(trans, out$major_source, out$range)
out$minor_source <- transform_value(trans, out$minor_source, out$range)
out <- list(range = out$range, labels = out$labels,
major = out$major_source, minor = out$minor_source)
names(out) <- paste(name, names(out), sep = ".")
out
}
ggplot2/R/theme-defaults.r 0000644 0001751 0000144 00000011056 12114161113 015133 0 ustar hornik users #' A theme with grey background and white gridlines.
#'
#' @param base_size base font size
#' @param base_family base font family
#' @aliases theme_gray theme_grey
#' @export theme_gray theme_grey
theme_grey <- function(base_size = 12, base_family = "") {
theme(
# Elements in this first block aren't used directly, but are inherited
# by others
line = element_line(colour = "black", size = 0.5, linetype = 1,
lineend = "butt"),
rect = element_rect(fill = "white", colour = "black", size = 0.5, linetype = 1),
text = element_text(family = base_family, face = "plain",
colour = "black", size = base_size,
hjust = 0.5, vjust = 0.5, angle = 0, lineheight = 0.9),
axis.text = element_text(size = rel(0.8), colour = "grey50"),
strip.text = element_text(size = rel(0.8)),
axis.line = element_blank(),
axis.text.x = element_text(vjust = 1),
axis.text.y = element_text(hjust = 1),
axis.ticks = element_line(colour = "grey50"),
axis.title.x = element_text(),
axis.title.y = element_text(angle = 90),
axis.ticks.length = unit(0.15, "cm"),
axis.ticks.margin = unit(0.1, "cm"),
legend.background = element_rect(colour = NA),
legend.margin = unit(0.2, "cm"),
legend.key = element_rect(fill = "grey95", colour = "white"),
legend.key.size = unit(1.2, "lines"),
legend.key.height = NULL,
legend.key.width = NULL,
legend.text = element_text(size = rel(0.8)),
legend.text.align = NULL,
legend.title = element_text(size = rel(0.8), face = "bold", hjust = 0),
legend.title.align = NULL,
legend.position = "right",
legend.direction = NULL,
legend.justification = "center",
legend.box = NULL,
panel.background = element_rect(fill = "grey90", colour = NA),
panel.border = element_blank(),
panel.grid.major = element_line(colour = "white"),
panel.grid.minor = element_line(colour = "grey95", size = 0.25),
panel.margin = unit(0.25, "lines"),
strip.background = element_rect(fill = "grey80", colour = NA),
strip.text.x = element_text(),
strip.text.y = element_text(angle = -90),
plot.background = element_rect(colour = "white"),
plot.title = element_text(size = rel(1.2)),
plot.margin = unit(c(1, 1, 0.5, 0.5), "lines"),
complete = TRUE
)
}
theme_gray <- theme_grey
#' A theme with white background and black gridlines.
#'
#' @param base_size base font size
#' @param base_family base font family
#' @export
theme_bw <- function(base_size = 12, base_family = "") {
# Starts with theme_grey and then modify some parts
theme_grey(base_size = base_size, base_family = base_family) %+replace%
theme(
axis.text = element_text(size = rel(0.8)),
axis.ticks = element_line(colour = "black"),
legend.key = element_rect(colour = "grey80"),
panel.background = element_rect(fill = "white", colour = NA),
panel.border = element_rect(fill = NA, colour = "grey50"),
panel.grid.major = element_line(colour = "grey90", size = 0.2),
panel.grid.minor = element_line(colour = "grey98", size = 0.5),
strip.background = element_rect(fill = "grey80", colour = "grey50"),
strip.background = element_rect(fill = "grey80", colour = "grey50")
)
}
#' A minimalistic theme with no background annotations.
#'
#' @param base_size base font size
#' @param base_family base font family
#' @export
theme_minimal <- function(base_size = 12, base_family = "") {
# Starts with theme_bw and then modify some parts
theme_bw(base_size = base_size, base_family = base_family) %+replace%
theme(
legend.background = element_blank(),
legend.key = element_blank(),
panel.background = element_blank(),
panel.border = element_blank(),
strip.background = element_blank(),
plot.background = element_blank()
)
}
#' A classic-looking theme, with x and y axis lines and no gridlines.
#'
#' @param base_size base font size
#' @param base_family base font family
#' @export
theme_classic <- function(base_size = 12, base_family = ""){
theme_bw(base_size = base_size, base_family = base_family) %+replace%
theme(
panel.border = element_blank(),
axis.line = element_line(colour = "black"),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank()
)
}
ggplot2/R/xxx-digest.r 0000644 0001751 0000144 00000004743 12114160774 014351 0 ustar hornik users bolus <- function(x) UseMethod("bolus")
bolus.proto <- function(x) x$bolus()
# Create a bolus object
# A bolus is a list suitable for digesting.
#
# Most ggplot objects have components that should be hashed when creating
# a digest (especially since most ggplot objects are proto objects and
# are also self-documenting). The bolus methods ensure that only appropriate
# components are digested.
#
# @alias bolus
# @alias bolus.proto
# @alias digest.ggplot
# @alias digest.proto
# @keyword internal
#X hash_tests <- list(
#X list(
#X ggplot() + scale_x_continuous() + scale_y_continuous(),
#X ggplot() + scale_y_continuous() + scale_x_continuous()
#X ),
#X list(
#X qplot(mpg, wt, data=mtcars, na.rm = FALSE),
#X ggplot(mtcars, aes(y=wt, x=mpg)) + geom_point()
#X ),
#X list(
#X qplot(mpg, wt, data=mtcars, xlab = "blah"),
#X qplot(mpg, wt, data=mtcars) + xlab("blah")
#X )
#X )
#X
#X lapply(hash_tests, function(equal) {
#X hashes <- lapply(equal, digest.ggplot)
#X
#X if (length(unique(hashes)) != 1) {
#X lapply(equal, function(x) print(str(bolus(x))))
#X stop("Above plots not equal")
#X }
#X })
bolus.ggplot <- function(x, ...) {
sort.by.name <- function(x) {
if (is.null(names(x))) return(x)
x[order(names(x))]
}
with(x, list(
data = digest::digest(data),
mapping = sort.by.name(mapping),
layers = sapply(layers, function(x) x$hash()),
scales = digest(scales),
facet = facet$hash(),
coord = coordinates$hash(),
theme = digest::digest(defaults(x$theme, theme_get()))
))
}
digest.proto <- function(x, ...) x$hash(, ...)
digest.ggplot <- function(x, ...) {
if (is.null(x)) return()
digest::digest(bolus(x), ...)
}
TopLevel$settings <- function(.) {
mget(setdiff(ls(., all.names=TRUE), c(".that", ".super")), .)
}
Layer$hash <- TopLevel$hash <- function(., ...) {
digest::digest(.$bolus(), ...)
}
TopLevel$bolus <- function(.) {
list(
name = .$objname,
settings = .$settings()
)
}
Layer$bolus <- function(.) {
params <- c(.$geom_params, .$stat_params)
params <- params[!duplicated(params)]
if (!is.null(params) && length(params) > 1) params <- params[order(names(params))]
mapping <- .$mapping
if (!is.null(mapping)) mapping <- mapping[order(names(mapping))]
list(
geom = .$geom$objname,
stat = .$stat$objname,
pos = .$position$objname,
pos_parms = .$position$settings(),
data = .$data,
mapping = mapping,
params = params,
legend = .$legend
)
}
ggplot2/R/stat-quantile.r 0000644 0001751 0000144 00000007006 12114161113 015017 0 ustar hornik users #' Continuous quantiles.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "quantile")}
#'
#' @param quantiles conditional quantiles of y to calculate and display
#' @param formula formula relating y variables to x variables
#' @param method Quantile regression method to use. Currently only supports
#' \code{\link[quantreg]{rq}}.
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @inheritParams stat_identity
#' @return a data.frame with additional columns:
#' \item{quantile}{quantile of distribution}
#' @export
#' @examples
#' \donttest{
#' msamp <- movies[sample(nrow(movies), 1000), ]
#' m <- ggplot(msamp, aes(year, rating)) + geom_point()
#' m + stat_quantile()
#' m + stat_quantile(quantiles = 0.5)
#' q10 <- seq(0.05, 0.95, by=0.05)
#' m + stat_quantile(quantiles = q10)
#'
#' # You can also use rqss to fit smooth quantiles
#' m + stat_quantile(method = "rqss")
#' # Note that rqss doesn't pick a smoothing constant automatically, so
#' # you'll need to tweak lambda yourself
#' m + stat_quantile(method = "rqss", lambda = 10)
#' m + stat_quantile(method = "rqss", lambda = 100)
#'
#' # Use 'votes' as weights for the quantile calculation
#' m + stat_quantile(aes(weight=votes))
#'
#' # Change scale
#' m + stat_quantile(aes(colour = ..quantile..), quantiles = q10)
#' m + stat_quantile(aes(colour = ..quantile..), quantiles = q10) +
#' scale_colour_gradient2(midpoint = 0.5)
#'
#' # Set aesthetics to fixed value
#' m + stat_quantile(colour = "red", size = 2, linetype = 2)
#'
#' # Use qplot instead
#' qplot(year, rating, data=movies, geom="quantile")
#' }
stat_quantile <- function (mapping = NULL, data = NULL, geom = "quantile", position = "identity",
quantiles = c(0.25, 0.5, 0.75), formula = NULL, method = "rq",
na.rm = FALSE, ...) {
StatQuantile$new(mapping = mapping, data = data, geom = geom,
position = position, quantiles = quantiles, formula = formula,
method = method, na.rm = na.rm, ...)
}
StatQuantile <- proto(Stat, {
objname <- "quantile"
default_geom <- function(.) GeomQuantile
default_aes <- function(.) aes()
required_aes <- c("x", "y")
calculate <- function(., data, scales, quantiles = c(0.25, 0.5, 0.75),
formula = NULL, xseq = NULL, method = "rq", lambda = 1, na.rm = FALSE,
...) {
try_require("quantreg")
if (is.null(formula)) {
if (method == "rqss") {
try_require("MatrixModels")
formula <- eval(substitute(y ~ qss(x, lambda = lambda)),
list(lambda = lambda))
} else {
formula <- y ~ x
}
message("Smoothing formula not specified. Using: ",
deparse(formula))
}
if (is.null(data$weight)) data$weight <- 1
if (is.null(xseq)) {
xmin <- min(data$x, na.rm = TRUE)
xmax <- max(data$x, na.rm = TRUE)
xseq <- seq(xmin, xmax, length = 100)
}
grid <- data.frame(x = xseq)
data <- as.data.frame(data)
data <- remove_missing(data, na.rm, c("x", "y"), name = "stat_quantile")
method <- match.fun(method)
ldply(quantiles, quant_pred, data = data, method = method,
formula = formula, weight = weight, grid = grid, ...)
}
})
quant_pred <- function(quantile, data, method, formula, weight, grid, ...) {
model <- method(formula, data = data, tau = quantile, weight = weight, ...)
grid$y <- predict(model, newdata = grid)
grid$quantile <- quantile
grid$group <- paste(data$group[1], quantile, sep = "-")
grid
}
ggplot2/R/stat-summary-hex.r 0000644 0001751 0000144 00000005452 12114160774 015473 0 ustar hornik users ##' Apply function for 2D hexagonal bins.
##'
##' @section Aesthetics:
##' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "summaryhex")}
##'
##' \code{stat_summary2d} is hexagonal version of \code{\link{stat_summary}}. The data are devided by \code{x} and \code{y}.
##' \code{z} in each cell is passed to arbitral summary function.
##'
##' \code{stat_summary-hex} requires the following aesthetics:
##'
##' \itemize{
##' \item \code{x}: horizontal position
##' \item \code{y}: vertical position
##' \item \code{z}: value passed to the summary function
##' }
##'
##' @seealso \code{\link{stat_summary2d}} for rectangular summarization. \code{\link{stat_bin2d}} for the hexagon-ing options.
##' @title Apply funciton for 2D hexagonal bins.
##' @inheritParams stat_identity
##' @param bins see \code{\link{stat_binhex}}
##' @param drop drop if the output of \code{fun} is \code{NA}.
##' @param fun function for summary.
##' @param ... parameters passed to \code{fun}
##' @export
##' @examples
##' d <- ggplot(diamonds, aes(carat, depth, z = price))
##' d + stat_summary_hex()
##'
##' # Specifying function
##' d + stat_summary_hex(fun = function(x) sum(x^2))
##' d + stat_summary_hex(fun = var, na.rm = TRUE)
stat_summary_hex <- function (mapping = NULL, data = NULL, geom = "hex", position = "identity",
bins = 30, drop = TRUE, fun = mean, ...) {
StatSummaryhex$new(mapping = mapping, data = data, geom = geom, position = position,
bins = bins, drop = drop, fun = fun, ...)
}
StatSummaryhex <- proto(Stat, {
objname <- "summaryhex"
default_aes <- function(.) aes(fill = ..value..)
required_aes <- c("x", "y", "z")
default_geom <- function(.) GeomHex
calculate <- function(., data, scales, binwidth = NULL, bins = 30, drop = TRUE, fun = mean, ...) {
try_require("hexbin")
data <- remove_missing(data, FALSE, c("x", "y", "z"), name="stat_summary_hex")
if (is.null(binwidth)) {
binwidth <- c(
diff(scale_dimension(scales$x, c(0, 0))) / bins,
diff(scale_dimension(scales$y, c(0, 0))) / bins
)
}
try_require("hexbin")
# Convert binwidths into bounds + nbins
x <- data$x
y <- data$y
xbnds <- c(
round_any(min(x), binwidth[1], floor) - 1e-6,
round_any(max(x), binwidth[1], ceiling) + 1e-6
)
xbins <- diff(xbnds) / binwidth[1]
ybnds <- c(
round_any(min(y), binwidth[1], floor) - 1e-6,
round_any(max(y), binwidth[2], ceiling) + 1e-6
)
ybins <- diff(ybnds) / binwidth[2]
# Call hexbin
hb <- hexbin(
x, xbnds = xbnds, xbins = xbins,
y, ybnds = ybnds, shape = ybins / xbins,
IDs = TRUE
)
value <- tapply(data$z, hb@cID, fun, ...)
# Convert to data frame
ret <- data.frame(hcell2xy(hb), value)
if (drop) ret <- na.omit(ret)
ret
}
})
ggplot2/R/geom-tile.r 0000644 0001751 0000144 00000006363 12114160774 014127 0 ustar hornik users #' Tile plane with rectangles.
#'
#' Similar to \code{\link{levelplot}} and \code{\link{image}}.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "tile")}
#'
#' @inheritParams geom_point
#' @export
#' @examples
#' \donttest{
#' # Generate data
#' pp <- function (n,r=4) {
#' x <- seq(-r*pi, r*pi, len=n)
#' df <- expand.grid(x=x, y=x)
#' df$r <- sqrt(df$x^2 + df$y^2)
#' df$z <- cos(df$r^2)*exp(-df$r/6)
#' df
#' }
#' p <- ggplot(pp(20), aes(x=x,y=y))
#'
#' p + geom_tile() #pretty useless!
#'
#' # Add aesthetic mappings
#' p + geom_tile(aes(fill=z))
#'
#' # Change scale
#' p + geom_tile(aes(fill=z)) + scale_fill_gradient(low="green", high="red")
#'
#' # Use qplot instead
#' qplot(x, y, data=pp(20), geom="tile", fill=z)
#' qplot(x, y, data=pp(100), geom="tile", fill=z)
#'
#' # Missing values
#' p <- ggplot(pp(20)[sample(20*20, size=200),], aes(x=x,y=y,fill=z))
#' p + geom_tile()
#'
#' # Input that works with image
#' image(t(volcano)[ncol(volcano):1,])
#' library(reshape2) # for melt
#' ggplot(melt(volcano), aes(x=Var1, y=Var2, fill=value)) + geom_tile()
#'
#' # inspired by the image-density plots of Ken Knoblauch
#' cars <- ggplot(mtcars, aes(y=factor(cyl), x=mpg))
#' cars + geom_point()
#' cars + stat_bin(aes(fill=..count..), geom="tile", binwidth=3, position="identity")
#' cars + stat_bin(aes(fill=..density..), geom="tile", binwidth=3, position="identity")
#'
#' cars + stat_density(aes(fill=..density..), geom="tile", position="identity")
#' cars + stat_density(aes(fill=..count..), geom="tile", position="identity")
#'
#' # Another example with with unequal tile sizes
#' x.cell.boundary <- c(0, 4, 6, 8, 10, 14)
#' example <- data.frame(
#' x = rep(c(2, 5, 7, 9, 12), 2),
#' y = factor(rep(c(1,2), each=5)),
#' z = rep(1:5, each=2),
#' w = rep(diff(x.cell.boundary), 2)
#' )
#'
#' qplot(x, y, fill=z, data=example, geom="tile")
#' qplot(x, y, fill=z, data=example, geom="tile", width=w)
#' qplot(x, y, fill=factor(z), data=example, geom="tile", width=w)
#'
#' # You can manually set the colour of the tiles using
#' # scale_manual
#' col <- c("darkblue", "blue", "green", "orange", "red")
#' qplot(x, y, fill=col[z], data=example, geom="tile", width=w, group=1) + scale_fill_identity(labels=letters[1:5], breaks=col)
#' }
geom_tile <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", ...) {
GeomTile$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomTile <- proto(Geom, {
objname <- "tile"
reparameterise <- function(., df, params) {
df$width <- df$width %||% params$width %||% resolution(df$x, FALSE)
df$height <- df$height %||% params$height %||% resolution(df$y, FALSE)
transform(df,
xmin = x - width / 2, xmax = x + width / 2, width = NULL,
ymin = y - height / 2, ymax = y + height / 2, height = NULL
)
}
draw_groups <- function(., data, scales, coordinates, ...) {
# data$colour[is.na(data$colour)] <- data$fill[is.na(data$colour)]
GeomRect$draw_groups(data, scales, coordinates, ...)
}
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(fill="grey20", colour=NA, size=0.1, linetype=1, alpha = NA)
required_aes <- c("x", "y")
guide_geom <- function(.) "polygon"
})
ggplot2/R/annotation-map.r 0000644 0001751 0000144 00000003565 12114160774 015173 0 ustar hornik users #' @include geom-map.r
NULL
#' Annotation: maps.
#'
#' @param map data frame representing a map. Most map objects can be
#' converted into the right format by using \code{\link{fortify}}
#' @param ... other arguments used to modify aesthetics
#' @export
#' @examples
#' library(maps)
#' usamap <- map_data("state")
#'
#' seal.sub <- subset(seals, long > -130 & lat < 45 & lat > 40)
#' ggplot(seal.sub, aes(x = long, y = lat)) +
#' annotation_map(usamap, fill = "NA", colour = "grey50") +
#' geom_segment(aes(xend = long + delta_long, yend = lat + delta_lat))
#'
#' seal2 <- transform(seal.sub,
#' latr = cut(lat, 2),
#' longr = cut(long, 2))
#'
#' ggplot(seal2, aes(x = long, y = lat)) +
#' annotation_map(usamap, fill = "NA", colour = "grey50") +
#' geom_segment(aes(xend = long + delta_long, yend = lat + delta_lat)) +
#' facet_grid(latr ~ longr, scales = "free", space = "free")
annotation_map <- function(map, ...) {
# Get map input into correct form
stopifnot(is.data.frame(map))
if (!is.null(map$lat)) map$y <- map$lat
if (!is.null(map$long)) map$x <- map$long
if (!is.null(map$region)) map$id <- map$region
stopifnot(all(c("x", "y", "id") %in% names(map)))
GeomAnnotationMap$new(geom_params = list(map = map, ...), data =
NULL, inherit.aes = FALSE)
}
GeomAnnotationMap <- proto(GeomMap, {
objname <- "map"
draw_groups <- function(., data, scales, coordinates, map, ...) {
# Munch, then set up id variable for polygonGrob -
# must be sequential integers
coords <- coord_munch(coordinates, map, scales)
coords$group <- coords$group %||% coords$id
grob_id <- match(coords$group, unique(coords$group))
polygonGrob(coords$x, coords$y, default.units = "native",
id = grob_id,
gp = gpar(
col = data$colour, fill = alpha(data$fill, data$alpha),
lwd = data$size * .pt))
}
required_aes <- c()
})
ggplot2/R/scale-gradient.r 0000644 0001751 0000144 00000005774 12114160774 015134 0 ustar hornik users #' Smooth gradient between two colours
#'
#' Default colours are generated with \pkg{munsell} and
#' \code{mnsl(c("2.5PB 2/4", "2.5PB 7/10")}. Generally, for continuous
#' colour scales you want to keep hue constant, but vary chroma and
#' luminance. The \pkg{munsell} package makes this easy to do using the
#' Munsell colour system.
#'
#' @inheritParams scale_colour_hue
#' @inheritParams scales::seq_gradient_pal
#' @param guide Type of legend. Use \code{"colourbar"} for continuous
#' colour bar, or \code{"legend"} for discrete colour legend.
#' @seealso \code{\link[scales]{seq_gradient_pal}} for details on underlying
#' palette
#' @rdname scale_gradient
#' @family colour scales
#' @export
#' @examples
#' \donttest{
#' # It's hard to see, but look for the bright yellow dot
#' # in the bottom right hand corner
#' dsub <- subset(diamonds, x > 5 & x < 6 & y > 5 & y < 6)
#' (d <- qplot(x, y, data=dsub, colour=z))
#' # That one point throws our entire scale off. We could
#' # remove it, or manually tweak the limits of the scale
#'
#' # Tweak scale limits. Any points outside these limits will not be
#' # plotted, and will not affect the calculation of statistics, etc
#' d + scale_colour_gradient(limits=c(3, 10))
#' d + scale_colour_gradient(limits=c(3, 4))
#' # Setting the limits manually is also useful when producing
#' # multiple plots that need to be comparable
#'
#' # Alternatively we could try transforming the scale:
#' d + scale_colour_gradient(trans = "log")
#' d + scale_colour_gradient(trans = "sqrt")
#'
#' # Other more trivial manipulations, including changing the name
#' # of the scale and the colours.
#'
#' d + scale_colour_gradient("Depth")
#' d + scale_colour_gradient(expression(Depth[mm]))
#'
#' d + scale_colour_gradient(limits=c(3, 4), low="red")
#' d + scale_colour_gradient(limits=c(3, 4), low="red", high="white")
#' # Much slower
#' d + scale_colour_gradient(limits=c(3, 4), low="red", high="white", space="Lab")
#' d + scale_colour_gradient(limits=c(3, 4), space="Lab")
#'
#' # scale_fill_continuous works similarly, but for fill colours
#' (h <- qplot(x - y, data=dsub, geom="histogram", binwidth=0.01, fill=..count..))
#' h + scale_fill_continuous(low="black", high="pink", limits=c(0,3100))
#'
#' # Colour of missing values is controlled with na.value:
#' miss <- sample(c(NA, 1:5), nrow(mtcars), rep = TRUE)
#' qplot(mpg, wt, data = mtcars, colour = miss)
#' qplot(mpg, wt, data = mtcars, colour = miss) +
#' scale_colour_gradient(na.value = "black")
#' }
scale_colour_gradient <- function(..., low = "#132B43", high = "#56B1F7", space = "Lab", na.value = "grey50", guide = "colourbar") {
continuous_scale("colour", "gradient", seq_gradient_pal(low, high, space),
na.value = na.value, guide = guide, ...)
}
#' @rdname scale_gradient
#' @export
scale_fill_gradient <- function(..., low = "#132B43", high = "#56B1F7", space = "Lab", na.value = "grey50", guide = "colourbar") {
continuous_scale("fill", "gradient", seq_gradient_pal(low, high, space),
na.value = na.value, guide = guide, ...)
}
ggplot2/R/plot-render.r 0000644 0001751 0000144 00000016304 12114160774 014474 0 ustar hornik users #' Build a plot with all the usual bits and pieces.
#'
#' This function builds all grobs necessary for displaying the plot, and
#' stores them in a special data structure called a \code{\link{gtable}}.
#' This object is amenable to programmatic manipulation, should you want
#' to (e.g.) make the legend box 2 cm wide, or combine multiple plots into
#' a single display, preserving aspect ratios across the plots.
#'
#' @seealso \code{\link{print.ggplot}} and \code{link{benchplot}} for
#' for functions that contain the complete set of steps for generating
#' a ggplot2 plot.
#' @return a \code{\link{gtable}} object
#' @keywords internal
#' @param plot plot object
#' @param data plot data generated by \code{\link{ggplot_build}}
#' @export
ggplot_gtable <- function(data) {
plot <- data$plot
panel <- data$panel
data <- data$data
theme <- plot_theme(plot)
build_grob <- function(layer, layer_data) {
if (nrow(layer_data) == 0) return()
dlply(layer_data, "PANEL", function(df) {
panel_i <- match(df$PANEL[1], panel$layout$PANEL)
layer$make_grob(df, scales = panel$ranges[[panel_i]], cs = plot$coord)
}, .drop = FALSE)
}
# helper function return the position of panels in plot_table
find_panel <- function(table) {
summarise(subset(table$layout, grepl("^panel", name)),
t = min(t), r = max(r), b = max(b), l = min(l))
}
# List by layer, list by panel
geom_grobs <- Map(build_grob, plot$layer, data)
plot_table <- facet_render(plot$facet, panel, plot$coordinates,
plot_theme(plot), geom_grobs)
# Axis labels
labels <- coord_labels(plot$coordinates, list(
x = xlabel(panel, plot$labels),
y = ylabel(panel, plot$labels)
))
xlabel <- element_render(theme, "axis.title.x", labels$x)
ylabel <- element_render(theme, "axis.title.y", labels$y)
panel_dim <- find_panel(plot_table)
xlab_height <- grobHeight(xlabel) +
if (is.null(labels$x)) unit(0, "lines") else unit(0.5, "lines")
plot_table <- gtable_add_rows(plot_table, xlab_height)
plot_table <- gtable_add_grob(plot_table, xlabel, name = "xlab",
l = panel_dim$l, r = panel_dim$r, t = -1, clip = "off")
ylab_width <- grobWidth(ylabel) +
if (is.null(labels$y)) unit(0, "lines") else unit(0.5, "lines")
plot_table <- gtable_add_cols(plot_table, ylab_width, pos = 0)
plot_table <- gtable_add_grob(plot_table, ylabel, name = "ylab",
l = 1, b = panel_dim$b, t = panel_dim$t, clip = "off")
# Legends
position <- theme$legend.position
if (length(position) == 2) {
coords <- position
position <- "manual"
}
legend_box <- if (position != "none") {
build_guides(plot$scales, plot$layers, plot$mapping, position, theme, plot$guides, plot$labels)
} else {
zeroGrob()
}
if (is.zero(legend_box)) {
position <- "none"
} else {
# these are a bad hack, since it modifies the contents fo viewpoint directly...
legend_width <- gtable_width(legend_box) + theme$legend.margin
legend_height <- gtable_height(legend_box) + theme$legend.margin
# Set the justification of the legend box
# First value is xjust, second value is yjust
just <- valid.just(theme$legend.justification)
xjust <- just[1]
yjust <- just[2]
if (position == "manual") {
xpos <- theme$legend.position[1]
ypos <- theme$legend.position[2]
# x and y are specified via theme$legend.position (i.e., coords)
legend_box <- editGrob(legend_box,
vp = viewport(x = xpos, y = ypos, just = c(xjust, yjust),
height = legend_height, width = legend_width))
} else {
# x and y are adjusted using justification of legend box (i.e., theme$legend.justification)
legend_box <- editGrob(legend_box,
vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust)))
}
}
panel_dim <- find_panel(plot_table)
# for align-to-device, use this:
# panel_dim <- summarise(plot_table$layout, t = min(t), r = max(r), b = max(b), l = min(l))
if (position == "left") {
plot_table <- gtable_add_cols(plot_table, legend_width, pos = 0)
plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off",
t = panel_dim$t, b = panel_dim$b, l = 1, r = 1, name = "guide-box")
} else if (position == "right") {
plot_table <- gtable_add_cols(plot_table, legend_width, pos = -1)
plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off",
t = panel_dim$t, b = panel_dim$b, l = -1, r = -1, name = "guide-box")
} else if (position == "bottom") {
plot_table <- gtable_add_rows(plot_table, legend_height, pos = -1)
plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off",
t = -1, b = -1, l = panel_dim$l, r = panel_dim$r, name = "guide-box")
} else if (position == "top") {
plot_table <- gtable_add_rows(plot_table, legend_height, pos = 0)
plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off",
t = 1, b = 1, l = panel_dim$l, r = panel_dim$r, name = "guide-box")
} else if (position == "manual") {
# should guide box expand whole region or region withoug margin?
plot_table <- gtable_add_grob(plot_table, legend_box,
t = panel_dim$t, b = panel_dim$b, l = panel_dim$l, r = panel_dim$r,
clip = "off", name = "guide-box")
}
# Title
title <- element_render(theme, "plot.title", plot$labels$title)
title_height <- grobHeight(title) +
if (is.null(plot$labels$title)) unit(0, "lines") else unit(0.5, "lines")
pans <- subset(plot_table$layout, grepl("^panel", name))
plot_table <- gtable_add_rows(plot_table, title_height, pos = 0)
plot_table <- gtable_add_grob(plot_table, title, name = "title",
t = 1, b = 1, l = min(pans$l), r = max(pans$r), clip = "off")
# Margins
plot_table <- gtable_add_rows(plot_table, theme$plot.margin[1], pos = 0)
plot_table <- gtable_add_cols(plot_table, theme$plot.margin[2])
plot_table <- gtable_add_rows(plot_table, theme$plot.margin[3])
plot_table <- gtable_add_cols(plot_table, theme$plot.margin[4], pos = 0)
if (inherits(theme$plot.background, "element")) {
plot_table <- gtable_add_grob(plot_table,
element_render(theme, "plot.background"),
t = 1, l = 1, b = -1, r = -1, name = "background", z = -Inf)
plot_table$layout <- plot_table$layout[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1)),]
plot_table$grobs <- plot_table$grobs[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1))]
}
plot_table
}
#' Draw plot on current graphics device.
#'
#' @param x plot to display
#' @param newpage draw new (empty) page first?
#' @param vp viewport to draw plot in
#' @param ... other arguments not used by this method
#' @keywords hplot
#' @export
#' @method print ggplot
print.ggplot <- function(x, newpage = is.null(vp), vp = NULL, ...) {
set_last_plot(x)
if (newpage) grid.newpage()
data <- ggplot_build(x)
gtable <- ggplot_gtable(data)
if (is.null(vp)) {
grid.draw(gtable)
} else {
if (is.character(vp)) seekViewport(vp) else pushViewport(vp)
grid.draw(gtable)
upViewport()
}
invisible(data)
}
#' @rdname print.ggplot
#' @method plot ggplot
#' @export
plot.ggplot <- print.ggplot
#' Generate a ggplot2 plot grob.
#'
#' @param x ggplot2 object
#' @keywords internal
#' @export
ggplotGrob <- function(x) {
ggplot_gtable(ggplot_build(x))
}
ggplot2/R/stat-smooth-methods.r 0000644 0001751 0000144 00000004003 12114160774 016155 0 ustar hornik users # Prediction data frame
# Get predictions with standard errors into data frame
#
# @keyword internal
# @alias predictdf.default
# @alias predictdf.glm
# @alias predictdf.loess
# @alias predictdf.locfit
predictdf <- function(model, xseq, se, level) UseMethod("predictdf")
#' @S3method predictdf default
predictdf.default <- function(model, xseq, se, level) {
pred <- stats::predict(model, newdata = data.frame(x = xseq), se = se,
level = level, interval = if(se) "confidence" else "none")
if (se) {
fit <- as.data.frame(pred$fit)
names(fit) <- c("y", "ymin", "ymax")
data.frame(x = xseq, fit, se = pred$se)
} else {
data.frame(x = xseq, y = as.vector(pred))
}
}
#' @S3method predictdf glm
predictdf.glm <- function(model, xseq, se, level) {
pred <- stats::predict(model, newdata = data.frame(x = xseq), se = se,
type = "link")
if (se) {
std <- qnorm(level / 2 + 0.5)
data.frame(
x = xseq,
y = model$family$linkinv(as.vector(pred$fit)),
ymin = model$family$linkinv(as.vector(pred$fit - std * pred$se)),
ymax = model$family$linkinv(as.vector(pred$fit + std * pred$se)),
se = as.vector(pred$se)
)
} else {
data.frame(x = xseq, y = model$family$linkinv(as.vector(pred)))
}
}
#' @S3method predictdf loess
predictdf.loess <- function(model, xseq, se, level) {
pred <- stats::predict(model, newdata = data.frame(x = xseq), se = se)
if (se) {
y = pred$fit
ci <- pred$se.fit * qt(level / 2 + .5, pred$df)
ymin = y - ci
ymax = y + ci
data.frame(x = xseq, y, ymin, ymax, se = pred$se.fit)
} else {
data.frame(x = xseq, y = as.vector(pred))
}
}
#' @S3method predictdf locfit
predictdf.locfit <- function(model, xseq, se, level) {
pred <- predict(model, newdata = data.frame(x = xseq), se.fit = se)
if (se) {
y = pred$fit
ymin = y - pred$se.fit
ymax = y + pred$se.fit
data.frame(x = xseq, y, ymin, ymax, se = pred$se.fit)
} else {
data.frame(x = xseq, y = as.vector(pred))
}
}
ggplot2/R/geom-polygon.r 0000644 0001751 0000144 00000007124 12114161113 014641 0 ustar hornik users #' Polygon, a filled path.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "polygon")}
#'
#' @seealso
#' \code{\link{geom_path}} for an unfilled polygon,
#' \code{\link{geom_ribbon}} for a polygon anchored on the x-axis
#' @export
#' @inheritParams geom_point
#' @examples
#' # When using geom_polygon, you will typically need two data frames:
#' # one contains the coordinates of each polygon (positions), and the
#' # other the values associated with each polygon (values). An id
#' # variable links the two together
#'
#' ids <- factor(c("1.1", "2.1", "1.2", "2.2", "1.3", "2.3"))
#'
#' values <- data.frame(
#' id = ids,
#' value = c(3, 3.1, 3.1, 3.2, 3.15, 3.5)
#' )
#'
#' positions <- data.frame(
#' id = rep(ids, each = 4),
#' x = c(2, 1, 1.1, 2.2, 1, 0, 0.3, 1.1, 2.2, 1.1, 1.2, 2.5, 1.1, 0.3,
#' 0.5, 1.2, 2.5, 1.2, 1.3, 2.7, 1.2, 0.5, 0.6, 1.3),
#' y = c(-0.5, 0, 1, 0.5, 0, 0.5, 1.5, 1, 0.5, 1, 2.1, 1.7, 1, 1.5,
#' 2.2, 2.1, 1.7, 2.1, 3.2, 2.8, 2.1, 2.2, 3.3, 3.2)
#' )
#'
#' # Currently we need to manually merge the two together
#' datapoly <- merge(values, positions, by=c("id"))
#'
#' (p <- ggplot(datapoly, aes(x=x, y=y)) + geom_polygon(aes(fill=value, group=id)))
#'
#' # Which seems like a lot of work, but then it's easy to add on
#' # other features in this coordinate system, e.g.:
#'
#' stream <- data.frame(
#' x = cumsum(runif(50, max = 0.1)),
#' y = cumsum(runif(50,max = 0.1))
#' )
#'
#' p + geom_line(data = stream, colour="grey30", size = 5)
#'
#' # And if the positions are in longitude and latitude, you can use
#' # coord_map to produce different map projections.
geom_polygon <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", ...) {
GeomPolygon$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomPolygon <- proto(Geom, {
objname <- "polygon"
draw_groups <- function(., ...) .$draw(...)
draw <- function(., data, scales, coordinates, ...) {
n <- nrow(data)
if (n == 1) return()
# Check if group is numeric, to make polygonGrob happy (factors are numeric,
# but is.numeric() will report FALSE because it actually checks something else)
if (mode(data$group) != "numeric")
data$group <- factor(data$group)
munched <- coord_munch(coordinates, data, scales)
# Sort by group to make sure that colors, fill, etc. come in same order
munched <- munched[order(munched$group), ]
# For gpar(), there is one entry per polygon (not one entry per point).
# We'll pull the first value from each group, and assume all these values
# are the same within each group.
first_idx <- !duplicated(munched$group)
first_rows <- munched[first_idx, ]
ggname(.$my_name(), gTree(children = gList(
polygonGrob(munched$x, munched$y, default.units = "native",
id = munched$group,
gp = gpar(
col = first_rows$colour,
fill = alpha(first_rows$fill, first_rows$alpha),
lwd = first_rows$size * .pt,
lty = first_rows$linetype
)
)
)))
}
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(colour="NA", fill="grey20", size=0.5, linetype=1, alpha = NA)
required_aes <- c("x", "y")
guide_geom <- function(.) "polygon"
draw_legend <- function(., data, ...) {
data <- aesdefaults(data, .$default_aes(), list(...))
with(data, grobTree(
rectGrob(gp = gpar(col = colour, fill = alpha(fill, alpha), lty = linetype)),
linesGrob(gp = gpar(col = colour, lwd = size * .pt, lineend="butt", lty = linetype))
))
}
})
ggplot2/R/scale-.r 0000644 0001751 0000144 00000044654 12114161113 013402 0 ustar hornik users #' Components of a scale:
#'
#' Guide related:
#' * name
#' * breaks
#' * labels
#' * expand
#'
#' Mapping related:
#' * aesthetic
#' * limits
#' * palette
#' * trans
#'
#' Scales are an S3 class with a single mutable component implemented with
#' a reference class - the range of the data. This mutability makes working
#' with scales much easier, because it makes it possible to distribute the
#' training, without having to worry about collecting all the pieces back
#' together again.
#'
#' @name ggscale
#' @S3method print scale
NULL
#' Continuous scale constructor.
#'
#' @export
#' @inheritParams discrete_scale
#' @param minor_breaks Used with date or datetime scales. Either \code{NULL} for
#' no minor breaks, \code{waiver()} for the default breaks (one minor break
#' between each major break), a numeric vector of positions, or a function
#' that given the limits returns a vector of minor breaks.
#' @param limits A numeric vector of length two describing the scale limits.
#' @param rescaler Used by diverging and n colour gradients
#' (i.e. \code{\link{scale_colour_gradient2}}, \code{\link{scale_colour_gradientn}}).
#' @param oob What to do with values outside scale limits (out of bounds)?
#' @keywords internal
continuous_scale <- function(aesthetics, scale_name, palette, name = NULL, breaks = waiver(), minor_breaks = waiver(), labels = waiver(), legend = NULL, limits = NULL, rescaler = rescale, oob = censor, expand = waiver(), na.value = NA_real_, trans = "identity", guide="legend") {
if (!is.null(legend)) {
gg_dep("0.8.9", "\"legend\" argument in scale_XXX is deprecated. Use guide=\"none\" for suppress the guide display.")
if (legend == FALSE) guide = "none"
else if (legend == TRUE) guide = "legend"
}
bad_labels <- is.vector(breaks) && is.vector(labels) &&
length(breaks) != length(labels)
if (bad_labels) {
stop("Breaks and labels have unequal lengths", call. = FALSE)
}
if (is.null(breaks) && !is_position_aes(aesthetics) && guide != "none") {
guide <- "none"
}
trans <- as.trans(trans)
if (!is.null(limits)) {
limits <- trans$trans(limits)
}
structure(list(
call = match.call(),
aesthetics = aesthetics,
scale_name = scale_name,
palette = palette,
range = ContinuousRange$new(),
limits = limits,
trans = trans,
na.value = na.value,
expand = expand,
rescaler = rescaler, # Used by diverging and n colour gradients
oob = oob,
name = name,
breaks = breaks,
minor_breaks = minor_breaks,
labels = labels,
legend = legend,
guide = guide
), class = c(scale_name, "continuous", "scale"))
}
#' Discrete scale constructor.
#'
#' @export
#' @param aesthetics the names of the aesthetics that this scale works with
#' @param scale_name the name of the scale
#' @param palette a palette function that when called with a single integer
#' argument (the number of levels in the scale) returns the values that
#' they should take
#' @param name the name of the scale - used as the axis label or the legend
#' title
#' @param drop drop unused factor levels from the scale (\code{TRUE} or
#' \code{FALSE})
#' @param breaks control the breaks in the guide. There are four possible
#' types of input:
#' \itemize{
#' \item \code{NULL}: don't display any breaks
#' \item a character vector giving the breaks as they should appear on the
#' axis or in the legend.
#' \item \code{waiver()} to use the default break computation.
#' \item a function, that when called with a single argument, a character
#' vector giving the limits of the scale, returns a character vector
#' specifying which breaks to display.
#' }
#' This parameter does not affect in any way how the data is scaled - it
#' only affects the appearance of the legend.
#' @param limits A character vector specifying the data range for the scale.
# The limits control what levels are displayed in the plot, their order,
#' and the default order of their display in guides.
#' @param labels \code{NULL} for no labels, \code{waiver()} for default
#' labels (labels the same as breaks), a character vector the same length
#' as breaks, or a named character vector whose names are used to match
#' replacement the labels for matching breaks.
#' @param legend deprecated. Use \code{guide} instead.
#' @param expand a numeric vector of length two, giving a multiplicative and
#' additive constant used to expand the range of the scales so that there
#' is a small gap between the data and the axes.
#' @param na.value how should missing values be displayed?
#' @param guide the name of, or actual function, used to create the
#' guide.
discrete_scale <- function(aesthetics, scale_name, palette, name = NULL, breaks = waiver(), labels = waiver(), legend = NULL, limits = NULL, expand = waiver(), na.value = NA, drop = TRUE, guide="legend") {
if (!is.null(legend)) {
gg_dep("0.8.9", "\"legend\" argument in scale_XXX is deprecated. Use guide=\"none\" for suppress the guide display.")
if (legend == FALSE) guide = "none"
else if (legend == TRUE) guide = "legend"
}
bad_labels <- is.vector(breaks) && is.vector(labels) &&
length(breaks) != length(labels)
if (bad_labels) {
stop("Breaks and labels have unequal lengths", call. = FALSE)
}
if (is.null(breaks) && !is_position_aes(aesthetics) && guide != "none") {
guide <- "none"
}
structure(list(
call = match.call(),
aesthetics = aesthetics,
scale_name = scale_name,
palette = palette,
range = DiscreteRange$new(),
limits = limits,
na.value = na.value,
expand = expand,
name = name,
breaks = breaks,
labels = labels,
legend = legend,
drop = drop,
guide = guide
), class = c(scale_name, "discrete", "scale"))
}
# Train scale from a data frame.
#
# @return updated range (invisibly)
# @seealso \code{\link{scale_train}} for scale specific generic method
scale_train_df <- function(scale, df) {
if (empty(df)) return()
aesthetics <- intersect(scale$aesthetics, names(df))
for(aesthetic in aesthetics) {
scale_train(scale, df[[aesthetic]])
}
invisible()
}
# Train an individual scale from a vector of data.
#
scale_train <- function(scale, x) {
if (length(x) == 0) return()
UseMethod("scale_train")
}
#' @S3method scale_train continuous
scale_train.continuous <- function(scale, x) {
scale$range$train(x)
}
#' @S3method scale_train discrete
scale_train.discrete <- function(scale, x) {
scale$range$train(x, drop = scale$drop)
}
# Reset scale, untraining ranges
scale_reset <- function(scale, x) UseMethod("scale_reset")
#' @S3method scale_reset default
scale_reset.default <- function(scale, x) {
scale$range$reset()
}
scale_is_empty <- function(scale) UseMethod("scale_is_empty")
#' @S3method scale_is_empty default
scale_is_empty.default <- function(scale) {
is.null(scale$range$range) && is.null(scale$limits)
}
# @return list of transformed variables
scale_transform_df <- function(scale, df) {
if (empty(df)) return()
aesthetics <- intersect(scale$aesthetics, names(df))
if (length(aesthetics) == 0) return()
lapply(df[aesthetics], scale_transform, scale = scale)
}
scale_transform <- function(scale, x) UseMethod("scale_transform")
#' @S3method scale_transform continuous
scale_transform.continuous <- function(scale, x) {
scale$trans$trans(x)
}
#' @S3method scale_transform discrete
scale_transform.discrete <- function(scale, x) {
x
}
# @return list of mapped variables
scale_map_df <- function(scale, df, i = NULL) {
if (empty(df)) return()
aesthetics <- intersect(scale$aesthetics, names(df))
names(aesthetics) <- aesthetics
if (length(aesthetics) == 0) return()
if (is.null(i)) {
lapply(aesthetics, function(j) scale_map(scale, df[[j]]))
} else {
lapply(aesthetics, function(j) scale_map(scale, df[[j]][i]))
}
}
# @kohske
# scale_map tentatively accept limits argument.
# scale_map replaces oob (i.e., outside limits) values with NA.
#
# Previously limits are always scale_limits(scale).
# But if this function is called to get breaks,
# and breaks spans oob, the oob breaks is replaces by NA.
# This makes impossible to display oob breaks.
# Now coord_train calls this function with limits determined by coord (with expansion).
scale_map <- function(scale, x, limits) UseMethod("scale_map")
#' @S3method scale_map continuous
scale_map.continuous <- function(scale, x, limits = scale_limits(scale)) {
x <- scale$oob(scale$rescaler(x, from = limits))
# Points are rounded to the nearest 500th, to reduce the amount of
# work that the scale palette must do - this is particularly important
# for colour scales which are rather slow. This shouldn't have any
# perceptual impacts.
x <- round_any(x, 1 / 500)
uniq <- unique(x)
pal <- scale$palette(uniq)
scaled <- pal[match(x, uniq)]
ifelse(!is.na(scaled), scaled, scale$na.value)
}
#' @S3method scale_map discrete
scale_map.discrete <- function(scale, x, limits = scale_limits(scale)) {
n <- sum(!is.na(limits))
pal <- scale$palette(n)
if (is.null(names(pal))) {
pal_match <- pal[match(as.character(x), limits)]
} else {
pal_match <- pal[match(as.character(x), names(pal))]
pal_match <- unname(pal_match)
}
ifelse(is.na(x) | is.na(pal_match), scale$na.value, pal_match)
}
scale_limits <- function(scale) {
if (scale_is_empty(scale)) return(c(0, 1))
UseMethod("scale_limits")
}
#' @S3method scale_limits default
scale_limits.default <- function(scale) {
scale$limits %||% scale$range$range
}
# @kohske
# this (internal) function always returns a vector of length 2 of giving
# multiplicative and additive expansion constants.
# if scale' expand is specified, return it.
# if is.waive, return c(0, 0)
scale_expand <- function(scale) UseMethod("scale_expand")
#' @S3method scale_expand default
scale_expand.default <- function(scale) {
if (is.waive(scale$expand)) c(0, 0)
else scale$expand
}
# The phyical size of the scale, if a position scale
# Unlike limits, this always returns a numeric vector of length 2
# @kohske
# scale_dimension uses scale_expand(scale) for expansion by default.
scale_dimension <- function(scale, expand = scale_expand(scale)) UseMethod("scale_dimension")
#' @S3method scale_dimension continuous
scale_dimension.continuous <- function(scale, expand = scale_expand(scale)) {
expand_range(scale_limits(scale), expand[1], expand[2])
}
#' @S3method scale_dimension discrete
scale_dimension.discrete <- function(scale, expand = scale_expand(scale)) {
expand_range(length(scale_limits(scale)), expand[1], expand[2])
}
scale_breaks <- function(scale, limits = scale_limits(scale)) {
if (scale_is_empty(scale)) return(numeric())
UseMethod("scale_breaks")
}
#' @S3method scale_breaks continuous
scale_breaks.continuous <- function(scale, limits = scale_limits(scale)) {
# Limits in transformed space need to be converted back to data space
limits <- scale$trans$inv(limits)
if (is.null(scale$breaks)) {
return(NULL)
} else if (length(scale$breaks) == 1 && !is.function(scale$breaks) && is.na(scale$breaks)) {
gg_dep("0.8.9", "breaks = NA is deprecated. Please use breaks = NULL to remove breaks in the scale.")
return(NULL)
} else if (zero_range(as.numeric(limits))) {
breaks <- limits[1]
} else if (is.waive(scale$breaks)) {
breaks <- scale$trans$breaks(limits)
} else if (is.function(scale$breaks)) {
breaks <- scale$breaks(limits)
} else {
breaks <- scale$breaks
}
# Breaks in data space need to be converted back to transformed space
# And any breaks outside the dimensions need to be flagged as missing
#
# @kohske
# TODO: replace NA with something else for flag.
# guides cannot discriminate oob from missing value.
breaks <- censor(scale$trans$trans(breaks), scale$trans$trans(limits))
if (length(breaks) == 0) {
stop("Zero breaks in scale for ", paste(scale$aesthetics, collapse = "/"),
call. = FALSE)
}
breaks
}
#' @S3method scale_breaks discrete
scale_breaks.discrete <- function(scale, limits = scale_limits(scale)) {
if (is.null(scale$breaks)) {
return(NULL)
} else if (length(scale$breaks) == 1 && !is.function(scale$breaks) && is.na(scale$breaks)) {
gg_dep("0.8.9", "breaks = NA is deprecated. Please use breaks = NULL to remove breaks in the scale.")
return(NULL)
} else if (is.waive(scale$breaks)) {
breaks <- limits
} else if (is.function(scale$breaks)) {
breaks <- scale$breaks(limits)
} else {
breaks <- scale$breaks
}
# Breaks can only occur only on values in domain
in_domain <- intersect(breaks, scale_limits(scale))
structure(in_domain, pos = match(in_domain, breaks))
}
# The numeric position of scale breaks, used by coord/guide
scale_break_positions <- function(scale, range = scale_limits(scale)) {
scale_map(scale, scale_breaks(scale, range))
}
scale_breaks_minor<- function(scale, n = 2, b = scale_break_positions(scale), limits = scale_limits(scale)) {
UseMethod("scale_breaks_minor")
}
#' @S3method scale_breaks_minor continuous
scale_breaks_minor.continuous <- function(scale, n = 2, b = scale_break_positions(scale), limits = scale_limits(scale)) {
if (zero_range(as.numeric(limits))) {
return()
}
if (is.null(scale$minor_breaks)) {
return(NULL)
} else if (length(scale$minor_breaks) == 1 && !is.function(scale$minor_breaks) && is.na(scale$minor_breaks)) {
gg_dep("0.8.9", "minor_breaks = NA is deprecated. Please use minor_breaks = NULL to remove minor breaks in the scale.")
return(NULL)
} else if (is.waive(scale$minor_breaks)) {
if (is.null(b)) {
breaks <- NULL
} else {
b <- b[!is.na(b)]
if (length(b) < 2) return()
bd <- diff(b)[1]
if (min(limits) < min(b)) b <- c(b[1] - bd, b)
if (max(limits) > max(b)) b <- c(b, b[length(b)] + bd)
breaks <- unique(unlist(mapply(seq, b[-length(b)], b[-1], length=n+1,
SIMPLIFY = FALSE)))
}
} else if (is.function(scale$minor_breaks)) {
# Find breaks in data space, and convert to numeric
breaks <- scale$minor_breaks(scale$trans$inv(limits))
breaks <- scale$trans$trans(breaks)
} else {
breaks <- scale$minor_breaks
}
# Any minor breaks outside the dimensions need to be thrown away
discard(breaks, limits)
}
#' @S3method scale_breaks_minor discrete
scale_breaks_minor.discrete <- function(...) NULL
scale_breaks_minor_positions <- function(scale) {
scale_map(scale, scale_breaks_minor(scale))
}
scale_labels <- function(scale, breaks = scale_breaks(scale)) {
if (scale_is_empty(scale)) return(character())
UseMethod("scale_labels")
}
#' @S3method scale_labels continuous
scale_labels.continuous <- function(scale, breaks = scale_breaks(scale)) {
if (is.null(breaks)) return(NULL)
breaks <- scale$trans$inv(breaks)
if (is.null(scale$labels)) {
return(NULL)
} else if (length(scale$labels) == 1 && !is.function(scale$labels) && is.na(scale$labels)) {
gg_dep("0.8.9", "labels = NA is deprecated. Please use labels = NULL to remove labels in the scale.")
return(NULL)
} else if (is.waive(scale$labels)) {
labels <- scale$trans$format(breaks)
} else if (is.function(scale$labels)) {
labels <- scale$labels(breaks)
} else {
labels <- scale$labels
}
if (length(labels) != length(breaks)) {
stop("Breaks and labels are different lengths")
}
labels
}
#' @S3method scale_labels discrete
scale_labels.discrete <- function(scale, breaks = scale_breaks(scale)) {
if (is.null(breaks)) return(NULL)
if (is.null(scale$labels)) {
return(NULL)
} else if (length(scale$labels) == 1 && !is.function(scale$labels) && is.na(scale$labels)) {
gg_dep("0.8.9", "labels = NA is deprecated. Please use labels = NULL to remove labels in the scale.")
return(NULL)
}else if (is.waive(scale$labels)) {
format(scale_breaks(scale), justify = "none", trim = TRUE)
} else if (is.function(scale$labels)) {
scale$labels(breaks)
} else {
if (!is.null(names(scale$labels))) {
# If labels have names, use them to match with breaks
labels <- breaks
map <- match(names(scale$labels), labels, nomatch = 0)
labels[map] <- scale$labels[map != 0]
labels
} else {
labels <- scale$labels
# Need to ensure that if breaks were dropped, corresponding labels are too
pos <- attr(breaks, "pos")
if (!is.null(pos)) {
labels <- labels[pos]
}
labels
}
}
}
named_labels <- function(breaks, labels) {
breaks[match(names(labels), breaks, nomatch = 0)] <- labels
breaks
}
print.scale <- function(x, ...) {
print(x$call)
}
scale_clone <- function(scale) UseMethod("scale_clone")
#' @S3method scale_clone continuous
scale_clone.continuous <- function(scale) {
new <- scale
new$range <- ContinuousRange$new()
new
}
#' @S3method scale_clone discrete
scale_clone.discrete <- function(scale) {
new <- scale
new$range <- DiscreteRange$new()
new
}
scale_break_info <- function(scale, range = NULL) UseMethod("scale_break_info")
#' @S3method scale_break_info discrete
scale_break_info.discrete <- function(scale, range = NULL) {
# for discrete, limits != range
limits <- scale_limits(scale)
major <- scale_breaks(scale, limits)
if (is.null(major)) {
labels <- major_n <- NULL
} else {
labels <- scale_labels(scale, major)
labels <- labels[!is.na(labels)]
major <- scale_map(scale, major)
major <- major[!is.na(major)]
# rescale breaks [0, 1], which are used by coord/guide
major_n <- rescale(major, from = range)
}
list(range = range, labels = labels,
major = major_n, minor = NULL,
major_source = major, minor_source = NULL)
}
#' @S3method scale_break_info continuous
scale_break_info.continuous <- function(scale, range = NULL) {
# range
if (is.null(range)) range <- scale_dimension(scale)
# major breaks
major <- scale_breaks(scale, range)
# labels
labels <- scale_labels(scale, major)
# drop oob breaks/labels by testing major == NA
if (!is.null(labels)) labels <- labels[!is.na(major)]
if (!is.null(major)) major <- major[!is.na(major)]
# minor breaks
minor <- scale_breaks_minor(scale, b = major, limits = range)
if (!is.null(minor)) minor <- minor[!is.na(minor)]
# rescale breaks [0, 1], which are used by coord/guide
major_n <- rescale(major, from = range)
minor_n <- rescale(minor, from = range)
list(range = range, labels = labels,
major = major_n, minor = minor_n,
major_source = major, minor_source = minor)
}
ggplot2/R/fortify.r 0000644 0001751 0000144 00000001477 12114160774 013730 0 ustar hornik users #' Fortify a model with data.
#'
#' Method to convert a generic R object into a data frame useful for plotting.
#' Takes its name from the idea of fortifying the original data with model fit
#' statistics, and vice versa.
#'
#' @seealso \code{\link{fortify.lm}}
#' @S3method fortify data.frame
#' @S3method fortify NULL
#' @S3method fortify default
#' @param model model or other R object to convert to data frame
#' @param data original dataset, if needed
#' @param ... other arguments passed to methods
#' @export
fortify <- function(model, data, ...) UseMethod("fortify")
fortify.data.frame <- function(model, data, ...) model
fortify.NULL <- function(model, data, ...) waiver()
fortify.default <- function(model, data, ...) {
stop("ggplot2 doesn't know how to deal with data of class ", class(model), call. = FALSE)
}
ggplot2/R/utilities-grid.r 0000644 0001751 0000144 00000001264 12114160774 015176 0 ustar hornik users # Name ggplot grid object
# Convenience function to name grid objects
#
# @keyword internal
ggname <- function(prefix, grob) {
grob$name <- grobName(grob, prefix)
grob
}
width_cm <- function(x) {
if (is.grob(x)) {
convertWidth(grobWidth(x), "cm", TRUE)
} else if (is.list(x)) {
vapply(x, width_cm, numeric(1))
} else if (is.unit(x)) {
convertWidth(x, "cm", TRUE)
} else {
stop("Unknown input")
}
}
height_cm <- function(x) {
if (is.grob(x)) {
convertWidth(grobHeight(x), "cm", TRUE)
} else if (is.list(x)) {
vapply(x, height_cm, numeric(1))
} else if (is.unit(x)) {
convertHeight(x, "cm", TRUE)
} else {
stop("Unknown input")
}
}
ggplot2/R/geom-ribbon-density.r 0000644 0001751 0000144 00000001620 12114160774 016111 0 ustar hornik users #' Display a smooth density estimate.
#'
#' A smooth density estimate calculated by \code{\link{stat_density}}.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "density")}
#'
#' @seealso \code{\link{geom_histogram}} for the histogram and
#' \code{\link{stat_density}} for examples.
#' @inheritParams geom_point
#' @export
#' @examples
#' # See stat_density for examples
geom_density <- function (mapping = NULL, data = NULL, stat = "density", position = "identity",
na.rm = FALSE, ...) {
GeomDensity$new(mapping = mapping, data = data, stat = stat, position = position,
na.rm = na.rm, ...)
}
GeomDensity <- proto(GeomArea, {
objname <- "density"
default_stat <- function(.) StatDensity
default_pos <- function(.) PositionIdentity
default_aes <- function(.) defaults(aes(fill=NA, weight=1, colour="black", alpha = NA), GeomArea$default_aes())
})
ggplot2/R/geom-map.r 0000644 0001751 0000144 00000007014 12114160774 013741 0 ustar hornik users #' @include geom-polygon.r
NULL
#' Polygons from a reference map.
#'
#' Does not affect position scales.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "map")}
#'
#' @export
#' @param map Data frame that contains the map coordinates. This will
#' typically be created using \code{\link{fortify}} on a spatial object.
#' It must contain columns \code{x} or \code{long}, \code{y} or
#' \code{lat}, and \code{region} or \code{id}.
#' @inheritParams geom_point
#' @examples
#' # When using geom_polygon, you will typically need two data frames:
#' # one contains the coordinates of each polygon (positions), and the
#' # other the values associated with each polygon (values). An id
#' # variable links the two together
#'
#' ids <- factor(c("1.1", "2.1", "1.2", "2.2", "1.3", "2.3"))
#'
#' values <- data.frame(
#' id = ids,
#' value = c(3, 3.1, 3.1, 3.2, 3.15, 3.5)
#' )
#'
#' positions <- data.frame(
#' id = rep(ids, each = 4),
#' x = c(2, 1, 1.1, 2.2, 1, 0, 0.3, 1.1, 2.2, 1.1, 1.2, 2.5, 1.1, 0.3,
#' 0.5, 1.2, 2.5, 1.2, 1.3, 2.7, 1.2, 0.5, 0.6, 1.3),
#' y = c(-0.5, 0, 1, 0.5, 0, 0.5, 1.5, 1, 0.5, 1, 2.1, 1.7, 1, 1.5,
#' 2.2, 2.1, 1.7, 2.1, 3.2, 2.8, 2.1, 2.2, 3.3, 3.2)
#' )
#'
#' ggplot(values) + geom_map(aes(map_id = id), map = positions) +
#' expand_limits(positions)
#' ggplot(values, aes(fill = value)) +
#' geom_map(aes(map_id = id), map = positions) +
#' expand_limits(positions)
#' ggplot(values, aes(fill = value)) +
#' geom_map(aes(map_id = id), map = positions) +
#' expand_limits(positions) + ylim(0, 3)
#'
#' # Better example
#' crimes <- data.frame(state = tolower(rownames(USArrests)), USArrests)
#' library(reshape2) # for melt
#' crimesm <- melt(crimes, id = 1)
#' if (require(maps)) {
#' states_map <- map_data("state")
#' ggplot(crimes, aes(map_id = state)) + geom_map(aes(fill = Murder), map = states_map) + expand_limits(x = states_map$long, y = states_map$lat)
#' last_plot() + coord_map()
#' ggplot(crimesm, aes(map_id = state)) + geom_map(aes(fill = value), map = states_map) + expand_limits(x = states_map$long, y = states_map$lat) + facet_wrap( ~ variable)
#' }
geom_map <- function(mapping = NULL, data = NULL, map, stat = "identity", ...) {
# Get map input into correct form
stopifnot(is.data.frame(map))
if (!is.null(map$lat)) map$y <- map$lat
if (!is.null(map$long)) map$x <- map$long
if (!is.null(map$region)) map$id <- map$region
stopifnot(all(c("x", "y", "id") %in% names(map)))
GeomMap$new(geom_params = list(map = map, ...), mapping = mapping,
data = data, stat = stat, ...)
}
GeomMap <- proto(GeomPolygon, {
objname <- "map"
draw_groups <- function(., data, scales, coordinates, map, ...) {
# Only use matching data and map ids
common <- intersect(data$map_id, map$id)
data <- data[data$map_id %in% common, , drop = FALSE]
map <- map[map$id %in% common, , drop = FALSE]
# Munch, then set up id variable for polygonGrob -
# must be sequential integers
coords <- coord_munch(coordinates, map, scales)
coords$group <- coords$group %||% coords$id
grob_id <- match(coords$group, unique(coords$group))
# Align data with map
data_rows <- match(coords$id[!duplicated(grob_id)], data$map_id)
data <- data[data_rows, , drop = FALSE]
polygonGrob(coords$x, coords$y, default.units = "native", id = grob_id,
gp = gpar(
col = data$colour, fill = alpha(data$fill, data$alpha),
lwd = data$size * .pt))
}
required_aes <- c("map_id")
})
ggplot2/R/fortify-multcomp.r 0000644 0001751 0000144 00000004224 12114160774 015557 0 ustar hornik users #' Fortify methods for objects produced by \pkg{multcomp}
#'
#' @param model an object of class \code{glht}, \code{confint.glht},
#' \code{summary.glht} or \code{\link[multcomp]{cld}}
#' @param data,... other arguments to the generic ignored in this method.
#' @name fortify-multcomp
#' @examples
#' if (require("multcomp")) {
#' amod <- aov(breaks ~ wool + tension, data = warpbreaks)
#' wht <- glht(amod, linfct = mcp(tension = "Tukey"))
#'
#' fortify(wht)
#' ggplot(wht, aes(lhs, estimate)) + geom_point()
#'
#' CI <- confint(wht)
#' fortify(CI)
#' ggplot(CI, aes(lhs, estimate, ymin = lwr, ymax = upr)) +
#' geom_pointrange()
#'
#' fortify(summary(wht))
#' ggplot(mapping = aes(lhs, estimate)) +
#' geom_linerange(aes(ymin = lwr, ymax = upr), data = CI) +
#' geom_point(aes(size = p), data = summary(wht)) +
#' scale_size(trans = "reverse")
#'
#' cld <- cld(wht)
#' fortify(cld)
#' }
NULL
#' @method fortify glht
#' @rdname fortify-multcomp
#' @export
fortify.glht <- function(model, data, ...) {
unrowname(data.frame(
lhs = rownames(model$linfct),
rhs = model$rhs,
estimate = coef(model),
check.names = FALSE,
stringsAsFactors = FALSE))
}
#' @rdname fortify-multcomp
#' @method fortify confint.glht
#' @export
fortify.confint.glht <- function(model, data, ...) {
coef <- model$confint
colnames(coef) <- tolower(colnames(coef))
unrowname(data.frame(
lhs = rownames(coef),
rhs = model$rhs,
coef,
check.names = FALSE,
stringsAsFactors = FALSE))
}
#' @method fortify summary.glht
#' @rdname fortify-multcomp
#' @export
fortify.summary.glht <- function(model, data, ...) {
coef <- as.data.frame(
model$test[c("coefficients", "sigma", "tstat", "pvalues")])
names(coef) <- c("estimate", "se", "t", "p")
unrowname(data.frame(
lhs = rownames(coef),
rhs = model$rhs,
coef,
check.names = FALSE,
stringsAsFactors = FALSE))
}
#' @method fortify cld
#' @rdname fortify-multcomp
#' @export
fortify.cld <- function(model, data, ...) {
unrowname(data.frame(
lhs = names(model$mcletters$Letters),
letters = model$mcletters$Letters,
check.names = FALSE,
stringsAsFactors = FALSE))
}
ggplot2/R/geom-freqpoly.r 0000644 0001751 0000144 00000002140 12114160774 015020 0 ustar hornik users #' Frequency polygon.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "freqpoly")}
#'
#' @seealso \code{\link{geom_histogram}}: histograms
#' @inheritParams geom_point
#' @export
#' @examples
#' qplot(carat, data = diamonds, geom = "freqpoly")
#' qplot(carat, data = diamonds, geom = "freqpoly", binwidth = 0.1)
#' qplot(carat, data = diamonds, geom = "freqpoly", binwidth = 0.01)
#'
#' qplot(price, data = diamonds, geom = "freqpoly", binwidth = 1000)
#' qplot(price, data = diamonds, geom = "freqpoly", binwidth = 1000,
#' colour = color)
#' qplot(price, ..density.., data = diamonds, geom = "freqpoly",
#' binwidth = 1000, colour = color)
geom_freqpoly <- function (mapping = NULL, data = NULL, stat = "bin", position = "identity", ...) {
GeomFreqpoly$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomFreqpoly <- proto(Geom, {
objname <- "freqpoly"
default_aes <- function(.) GeomPath$default_aes()
default_stat <- function(.) StatBin
draw <- function(., ...) GeomPath$draw(...)
guide_geom <- function(.) "path"
})
ggplot2/R/aes.r 0000644 0001751 0000144 00000013732 12114161113 012777 0 ustar hornik users # all_aes <- function(y) c(names(y$default_aes()), y$required_aes)
# geom_aes <- unlist(lapply(Geom$find_all(), all_aes))
# stat_aes <- unlist(lapply(Stat$find_all(), all_aes))
# all <- sort(unique(c(names(.base_to_ggplot), geom_aes, stat_aes)))
# dput(all)
.all_aesthetics <- c("adj", "alpha", "angle", "bg", "cex", "col", "color", "colour", "fg", "fill", "group", "hjust", "label", "linetype", "lower", "lty", "lwd", "max", "middle", "min", "order", "pch", "radius", "sample", "shape", "size", "srt", "upper", "vjust", "weight", "width", "x", "xend", "xmax", "xmin", "xintercept", "y", "yend", "ymax", "ymin", "yintercept", "z")
.base_to_ggplot <- c(
"col" = "colour",
"color" = "colour",
"pch" = "shape",
"cex" = "size",
"lty" = "linetype",
"lwd" = "size",
"srt" = "angle",
"adj" = "hjust",
"bg" = "fill",
"fg" = "colour",
"min" = "ymin",
"max" = "ymax"
)
#' Generate aesthetic mappings that describe how variables in the data are
#' mapped to visual properties (aesthetics) of geoms.
#'
#' \code{aes} creates a list of unevaluated expressions. This function also
#' performs partial name matching, converts color to colour, and old style R
#' names to ggplot names (eg. pch to shape, cex to size)
#'
#' @param x x value
#' @param y y value
#' @param ... List of name value pairs giving aesthetics to map.
#' @seealso \code{\link{aes_string}} for passing quoted variable names.
#" Useful when creating plots within user defined functions. Also,
#' \code{\link{aes_colour_fill_alpha}}, \code{\link{aes_group_order}},
#' \code{\link{aes_linetype_size_shape}} and \code{\link{aes_position}}
#' for more specific examples with different aesthetics.
#' @S3method str uneval
#' @S3method print uneval
#' @S3method "[" uneval
#' @S3method as.character uneval
#' @export
#' @examples
#' aes(x = mpg, y = wt)
#' aes(x = mpg ^ 2, y = wt / cyl)
aes <- function(x, y, ...) {
aes <- structure(as.list(match.call()[-1]), class="uneval")
rename_aes(aes)
}
print.uneval <- function(x, ...) str(unclass(x))
str.uneval <- function(object, ...) str(unclass(object), ...)
"[.uneval" <- function(x, i, ...) structure(unclass(x)[i], class = "uneval")
as.character.uneval <- function(x, ...) {
char <- as.character(unclass(x))
names(char) <- names(x)
char
}
# Rename American or old-style aesthetics name
rename_aes <- function(x) {
# Convert prefixes to full names
full <- match(names(x), .all_aesthetics)
names(x)[!is.na(full)] <- .all_aesthetics[full[!is.na(full)]]
rename(x, .base_to_ggplot, warn_missing = FALSE)
}
# Look up the scale that should be used for a given aesthetic
aes_to_scale <- function(var) {
var[var %in% c("x", "xmin", "xmax", "xend", "xintercept")] <- "x"
var[var %in% c("y", "ymin", "ymax", "yend", "yintercept")] <- "y"
var
}
# Figure out if an aesthetic is a position aesthetic or not
is_position_aes <- function(vars) {
aes_to_scale(vars) %in% c("x", "y")
}
#' Generate aesthetic mappings from a string
#'
#' Aesthetic mappings describe how variables in the data are mapped to visual
#' properties (aesthetics) of geoms. Compared to aes this function operates
#' on strings rather than expressions.
#'
#' \code{aes_string} is particularly useful when writing functions that create
#' plots because you can use strings to define the aesthetic mappings, rather
#' than having to mess around with expressions.
#'
#' @param ... List of name value pairs
#' @seealso \code{\link{aes}}
#' @export
#' @examples
#' aes_string(x = "mpg", y = "wt")
#' aes(x = mpg, y = wt)
aes_string <- function(...) {
mapping <- list(...)
mapping[sapply(mapping, is.null)] <- "NULL"
parsed <- lapply(mapping, function(x) parse(text = x)[[1]])
structure(rename_aes(parsed), class = "uneval")
}
#' Given a character vector, create a set of identity mappings
#'
#' @param vars vector of variable names
#' @export
#' @examples
#' aes_all(names(mtcars))
#' aes_all(c("x", "y", "col", "pch"))
aes_all <- function(vars) {
names(vars) <- vars
vars <- rename_aes(vars)
structure(
lapply(vars, function(x) parse(text=x)[[1]]),
class = "uneval"
)
}
#' Automatic aesthetic mapping
#'
#' @param data data.frame or names of variables
#' @param ... aesthetics that need to be explicitly mapped.
#' @export
#' @examples
#' df <- data.frame(x = 1, y = 1, colour = 1, label = 1, pch = 1)
#' aes_auto(df)
#' aes_auto(names(df))
#'
#' df <- data.frame(xp = 1, y = 1, colour = 1, txt = 1, foo = 1)
#' aes_auto(df, x = xp, label = txt)
#' aes_auto(names(df), x = xp, label = txt)
#'
#' df <- data.frame(foo = 1:3)
#' aes_auto(df, x = xp, y = yp)
#' aes_auto(df)
aes_auto <- function(data = NULL, ...) {
# detect names of data
if (is.null(data)) {
stop("aes_auto requires data.frame or names of data.frame.")
} else if (is.data.frame(data)) {
vars <- names(data)
} else {
vars <- data
}
# automatically detected aes
vars <- intersect(.all_aesthetics, vars)
names(vars) <- vars
aes <- lapply(vars, function(x) parse(text=x)[[1]])
# explicitly defined aes
if (length(match.call()) > 2) {
args <- as.list(match.call()[-1])
aes <- c(aes, args[names(args) != "data"])
}
structure(rename_aes(aes), class = "uneval")
}
# Aesthetic defaults
# Convenience method for setting aesthetic defaults
#
# @param data values from aesthetic mappings
# @param y. defaults
# @param params. user specified values
# @value a data.frame, with all factors converted to character strings
aesdefaults <- function(data, y., params.) {
updated <- modifyList(y., params. %||% list())
cols <- tryapply(defaults(data, updated), function(x) eval(x, data, globalenv()))
# Need to be careful here because stat_boxplot uses a list-column to store
# a vector of outliers
cols <- Filter(function(x) is.atomic(x) || is.list(x), cols)
list_vars <- sapply(cols, is.list)
cols[list_vars] <- lapply(cols[list_vars], I)
df <- data.frame(cols, stringsAsFactors = FALSE)
factors <- sapply(df, is.factor)
df[factors] <- lapply(df[factors], as.character)
df
}
ggplot2/R/stat-summary.r 0000644 0001751 0000144 00000016660 12114161113 014700 0 ustar hornik users #' Summarise y values at every unique x.
#'
#' \code{stat_summary} allows for tremendous flexibilty in the specification
#' of summary functions. The summary function can either operate on a data
#' frame (with argument name \code{fun.data}) or on a vector (\code{fun.y},
#' \code{fun.ymax}, \code{fun.ymin}).
#'
#' A simple vector function is easiest to work with as you can return a single
#' number, but is somewhat less flexible. If your summary function operates
#' on a data.frame it should return a data frame with variables that the geom
#' can use.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "summary")}
#'
#' @seealso \code{\link{geom_errorbar}}, \code{\link{geom_pointrange}},
#' \code{\link{geom_linerange}}, \code{\link{geom_crossbar}} for geoms to
#' display summarised data
#' @inheritParams stat_identity
#' @return a data.frame with additional columns:
#' \item{fun.data}{Complete summary function. Should take data frame as
#' input and return data frame as output}
#' \item{fun.ymin}{ymin summary function (should take numeric vector and
#' return single number)}
#' \item{fun.y}{y summary function (should take numeric vector and return
#' single number)}
#' \item{fun.ymax}{ymax summary function (should take numeric vector and
#' return single number)}
#' @export
#' @examples
#' \donttest{
#' # Basic operation on a small dataset
#' d <- qplot(cyl, mpg, data=mtcars)
#' d + stat_summary(fun.data = "mean_cl_boot", colour = "red")
#'
#' p <- qplot(cyl, mpg, data = mtcars, stat="summary", fun.y = "mean")
#' p
#' # Don't use ylim to zoom into a summary plot - this throws the
#' # data away
#' p + ylim(15, 30)
#' # Instead use coord_cartesian
#' p + coord_cartesian(ylim = c(15, 30))
#'
#' # You can supply individual functions to summarise the value at
#' # each x:
#'
#' stat_sum_single <- function(fun, geom="point", ...) {
#' stat_summary(fun.y=fun, colour="red", geom=geom, size = 3, ...)
#' }
#'
#' d + stat_sum_single(mean)
#' d + stat_sum_single(mean, geom="line")
#' d + stat_sum_single(median)
#' d + stat_sum_single(sd)
#'
#' d + stat_summary(fun.y = mean, fun.ymin = min, fun.ymax = max,
#' colour = "red")
#'
#' d + aes(colour = factor(vs)) + stat_summary(fun.y = mean, geom="line")
#'
#' # Alternatively, you can supply a function that operates on a data.frame.
#' # A set of useful summary functions is provided from the Hmisc package:
#'
#' stat_sum_df <- function(fun, geom="crossbar", ...) {
#' stat_summary(fun.data=fun, colour="red", geom=geom, width=0.2, ...)
#' }
#'
#' d + stat_sum_df("mean_cl_boot")
#' d + stat_sum_df("mean_sdl")
#' d + stat_sum_df("mean_sdl", mult=1)
#' d + stat_sum_df("median_hilow")
#'
#' # There are lots of different geoms you can use to display the summaries
#'
#' d + stat_sum_df("mean_cl_normal")
#' d + stat_sum_df("mean_cl_normal", geom = "errorbar")
#' d + stat_sum_df("mean_cl_normal", geom = "pointrange")
#' d + stat_sum_df("mean_cl_normal", geom = "smooth")
#'
#' # Summaries are more useful with a bigger data set:
#' mpg2 <- subset(mpg, cyl != 5L)
#' m <- ggplot(mpg2, aes(x=cyl, y=hwy)) +
#' geom_point() +
#' stat_summary(fun.data = "mean_sdl", geom = "linerange",
#' colour = "red", size = 2, mult = 1) +
#' xlab("cyl")
#' m
#' # An example with highly skewed distributions:
#' set.seed(596)
#' mov <- movies[sample(nrow(movies), 1000), ]
#' m2 <- ggplot(mov, aes(x= factor(round(rating)), y=votes)) + geom_point()
#' m2 <- m2 + stat_summary(fun.data = "mean_cl_boot", geom = "crossbar",
#' colour = "red", width = 0.3) + xlab("rating")
#' m2
#' # Notice how the overplotting skews off visual perception of the mean
#' # supplementing the raw data with summary statistics is _very_ important
#'
#' # Next, we'll look at votes on a log scale.
#'
#' # Transforming the scale means the data are transformed
#' # first, after which statistics are computed:
#' m2 + scale_y_log10()
#' # Transforming the coordinate system occurs after the
#' # statistic has been computed. This means we're calculating the summary on the raw data
#' # and stretching the geoms onto the log scale. Compare the widths of the
#' # standard errors.
#' m2 + coord_trans(y="log10")
#' }
stat_summary <- function (mapping = NULL, data = NULL, geom = "pointrange", position = "identity", ...) {
StatSummary$new(mapping = mapping, data = data, geom = geom, position = position, ...)
}
StatSummary <- proto(Stat, {
objname <- "summary"
default_geom <- function(.) GeomPointrange
required_aes <- c("x", "y")
calculate_groups <- function(., data, scales, fun.data = NULL, fun.y = NULL, fun.ymax = NULL, fun.ymin = NULL, na.rm = FALSE, ...) {
data <- remove_missing(data, na.rm, c("x", "y"), name = "stat_summary")
if (!missing(fun.data)) {
# User supplied function that takes complete data frame as input
fun.data <- match.fun(fun.data)
fun <- function(df, ...) {
fun.data(df$y, ...)
}
} else {
# User supplied individual vector functions
fs <- compact(list(ymin = fun.ymin, y = fun.y, ymax = fun.ymax))
fun <- function(df, ...) {
res <- llply(fs, function(f) do.call(f, list(df$y, ...)))
names(res) <- names(fs)
as.data.frame(res)
}
}
summarise_by_x(data, fun, ...)
}
})
# Summarise a data.frame by parts
# Summarise a data frame by unique value of x
#
# This function is used by \code{\link{stat_summary}} to break a
# data.frame into pieces, summarise each piece, and join the pieces
# back together, retaining original columns unaffected by the summary.
#
# @param \code{\link{data.frame}} to summarise
# @param vector to summarise by
# @param summary function (must take and return a data.frame)
# @param other arguments passed on to summary function
# @keyword internal
summarise_by_x <- function(data, summary, ...) {
summary <- ddply(data, .(group, x), summary, ...)
unique <- ddply(data, .(group, x), uniquecols)
unique$y <- NULL
merge(summary, unique, by = c("x", "group"))
}
#' Wrap up a selection of summary functions from Hmisc to make it easy to use
#' with \code{\link{stat_summary}}.
#'
#' See the Hmisc documentation for details of their options.
#'
#' @param x a numeric vector
#' @param ... other arguments passed on to the respective Hmisc function.
#' @seealso \code{\link[Hmisc]{smean.cl.boot}},
#' \code{\link[Hmisc]{smean.cl.normal}}, \code{\link[Hmisc]{smean.sdl}},
#' \code{\link[Hmisc]{smedian.hilow}}
#' @name hmisc
NULL
wrap_hmisc <- function(fun) {
function(x, ...) {
try_require("Hmisc")
result <- safe.call(fun, list(x = x, ...))
rename(
data.frame(t(result)),
c(Median = "y", Mean = "y", Lower = "ymin", Upper = "ymax"),
warn_missing = FALSE
)
}
}
#' @export
#' @rdname hmisc
mean_cl_boot <- wrap_hmisc("smean.cl.boot")
#' @export
#' @rdname hmisc
mean_cl_normal <- wrap_hmisc("smean.cl.normal")
#' @export
#' @rdname hmisc
mean_sdl <- wrap_hmisc("smean.sdl")
#' @export
#' @rdname hmisc
median_hilow <- wrap_hmisc("smedian.hilow")
#' Calculate mean and standard errors on either side.
#'
#' @param x numeric vector
#' @param mult number of multiples of standard error
#' @seealso for use with \code{\link{stat_summary}}
#' @export
mean_se <- function(x, mult = 1) {
x <- na.omit(x)
se <- mult * sqrt(var(x) / length(x))
mean <- mean(x)
data.frame(y = mean, ymin = mean - se, ymax = mean + se)
}
ggplot2/R/layer.r 0000644 0001751 0000144 00000020531 12114161113 013336 0 ustar hornik users # Create a new layer
# Layer objects store the layer of an object.
#
# They have the following attributes:
#
# * data
# * geom + parameters
# * statistic + parameters
# * position + parameters
# * aesthetic mapping
# * flag for display guide: TRUE/FALSE/NA. in the case of NA, decision depends on a guide itself.
#
# Can think about grob creation as a series of data frame transformations.
Layer <- proto(expr = {
geom <- NULL
geom_params <- NULL
stat <- NULL
stat_params <- NULL
data <- NULL
mapping <- NULL
position <- NULL
params <- NULL
inherit.aes <- FALSE
new <- function (., geom=NULL, geom_params=NULL, stat=NULL, stat_params=NULL, data=NULL, mapping=NULL, position=NULL, params=NULL, ..., inherit.aes = TRUE, legend = NA, subset = NULL, show_guide = NA) {
# now, as for the guide, we can choose only if the layer is included or not in the guide: guide = TRUE or guide = FALSE
# in future, it may be better if we can choose which aes of this layer is included in the guide, e.g.: guide = c(colour = TRUE, size = FALSE)
if (!is.na(legend)) {
gg_dep("0.8.9", "\"legend\" argument in geom_XXX and stat_XXX is deprecated. Use show_guide = TRUE or show_guide = FALSE for display or suppress the guide display.")
show_guide = legend
}
if (!is.na(show_guide) && !is.logical(show_guide)) {
warning("`show_guide` in geom_XXX and stat_XXX must be logical.")
show_guide = FALSE
}
if (is.null(geom) && is.null(stat)) stop("Need at least one of stat and geom")
data <- fortify(data)
if (!is.null(mapping) && !inherits(mapping, "uneval")) stop("Mapping should be a list of unevaluated mappings created by aes or aes_string")
if (is.character(geom)) geom <- Geom$find(geom)
if (is.character(stat)) stat <- Stat$find(stat)
if (is.character(position)) position <- Position$find(position)$new()
if (is.null(geom)) geom <- stat$default_geom()
if (is.null(stat)) stat <- geom$default_stat()
if (is.null(position)) position <- geom$default_pos()$new()
match.params <- function(possible, params) {
if ("..." %in% names(possible)) {
params
} else {
params[match(names(possible), names(params), nomatch=0)]
}
}
if (is.null(geom_params) && is.null(stat_params)) {
params <- c(params, list(...))
params <- rename_aes(params) # Rename American to British spellings etc
geom_params <- match.params(geom$parameters(), params)
stat_params <- match.params(stat$parameters(), params)
stat_params <- stat_params[setdiff(names(stat_params),
names(geom_params))]
} else {
geom_params <- rename_aes(geom_params)
}
proto(.,
geom=geom, geom_params=geom_params,
stat=stat, stat_params=stat_params,
data=data, mapping=mapping, subset=subset,
position=position,
inherit.aes = inherit.aes,
show_guide = show_guide,
)
}
clone <- function(.) as.proto(.$as.list(all.names=TRUE))
use_defaults <- function(., data) {
df <- aesdefaults(data, .$geom$default_aes(), NULL)
# Override mappings with atomic parameters
gp <- intersect(c(names(df), .$geom$required_aes), names(.$geom_params))
gp <- gp[unlist(lapply(.$geom_params[gp], is.atomic))]
# Check that mappings are compatable length: either 1 or the same length
# as the data
param_lengths <- vapply(.$geom_params[gp], length, numeric(1))
bad <- param_lengths != 1L & param_lengths != nrow(df)
if (any(bad)) {
stop("Incompatible lengths for set aesthetics: ",
paste(names(bad), collapse = ", "), call. = FALSE)
}
df[gp] <- .$geom_params[gp]
df
}
layer_mapping <- function(., mapping = NULL) {
# For certain geoms, it is useful to be able to ignore the default
# aesthetics and only use those set in the layer
if (.$inherit.aes) {
aesthetics <- compact(defaults(.$mapping, mapping))
} else {
aesthetics <- .$mapping
}
# Drop aesthetics that are set or calculated
set <- names(aesthetics) %in% names(.$geom_params)
calculated <- is_calculated_aes(aesthetics)
aesthetics[!set & !calculated]
}
pprint <- function(.) {
if (is.null(.$geom)) {
cat("Empty layer\n")
return(invisible());
}
if (!is.null(.$mapping)) {
cat("mapping:", clist(.$mapping), "\n")
}
.$geom$print(newline=FALSE)
cat(clist(.$geom_params), "\n")
.$stat$print(newline=FALSE)
cat(clist(.$stat_params), "\n")
.$position$print()
}
compute_aesthetics <- function(., data, plot) {
aesthetics <- .$layer_mapping(plot$mapping)
if (!is.null(.$subset)) {
include <- data.frame(eval.quoted(.$subset, data, plot$env))
data <- data[rowSums(include, na.rm = TRUE) == ncol(include), ]
}
# Override grouping if set in layer.
if (!is.null(.$geom_params$group)) {
aesthetics["group"] <- .$geom_params$group
}
scales_add_defaults(plot$scales, data, aesthetics, plot$plot_env)
# Evaluate aesthetics in the context of their data frame
evaled <- compact(
eval.quoted(aesthetics, data, plot$plot_env))
lengths <- vapply(evaled, length, integer(1))
n <- if (length(lengths) > 0) max(lengths) else 0
wrong <- lengths != 1 & lengths != n
if (any(wrong)) {
stop("Aesthetics must either be length one, or the same length as the data",
"Problems:", paste(aesthetics[wrong], collapse = ", "), call. = FALSE)
}
if (empty(data) && n > 0) {
# No data, and vectors suppled to aesthetics
evaled$PANEL <- 1
} else {
evaled$PANEL <- data$PANEL
}
data.frame(evaled)
}
calc_statistic <- function(., data, scales) {
if (empty(data)) return(data.frame())
check_required_aesthetics(.$stat$required_aes,
c(names(data), names(.$stat_params)),
paste("stat_", .$stat$objname, sep=""))
res <- NULL
try(res <- do.call(.$stat$calculate_groups, c(
list(data=as.name("data"), scales=as.name("scales")),
.$stat_params)
))
if (is.null(res)) return(data.frame())
res
}
map_statistic <- function(., data, plot) {
if (empty(data)) return(data.frame())
# Assemble aesthetics from layer, plot and stat mappings
aesthetics <- .$mapping
if (.$inherit.aes) {
aesthetics <- defaults(aesthetics, plot$mapping)
}
aesthetics <- defaults(aesthetics, .$stat$default_aes())
aesthetics <- compact(aesthetics)
new <- strip_dots(aesthetics[is_calculated_aes(aesthetics)])
if (length(new) == 0) return(data)
# Add map stat output to aesthetics
stat_data <- as.data.frame(lapply(new, eval, data, baseenv()))
names(stat_data) <- names(new)
# Add any new scales, if needed
scales_add_defaults(plot$scales, data, new, plot$plot_env)
# Transform the values, if the scale say it's ok
# (see stat_spoke for one exception)
if (.$stat$retransform) {
stat_data <- scales_transform_df(plot$scales, stat_data)
}
cunion(stat_data, data)
}
reparameterise <- function(., data) {
if (empty(data)) return(data.frame())
.$geom$reparameterise(data, .$geom_params)
}
adjust_position <- function(., data) {
ddply(data, "PANEL", function(data) {
.$position$adjust(data)
})
}
make_grob <- function(., data, scales, cs) {
if (empty(data)) return(zeroGrob())
data <- .$use_defaults(data)
check_required_aesthetics(.$geom$required_aes,
c(names(data), names(.$geom_params)),
paste("geom_", .$geom$objname, sep=""))
do.call(.$geom$draw_groups, c(
data = list(as.name("data")),
scales = list(as.name("scales")),
coordinates = list(as.name("cs")),
.$geom_params
))
}
class <- function(.) "layer"
})
#' Create a new layer
#'
#' @keywords internal
#' @export
layer <- Layer$new
# Determine if aesthetic is calculated
is_calculated_aes <- function(aesthetics) {
match <- "\\.\\.([a-zA-z._]+)\\.\\."
stats <- rep(FALSE, length(aesthetics))
grepl(match, sapply(aesthetics, deparse))
}
# Strip dots from expressions
strip_dots <- function(aesthetics) {
match <- "\\.\\.([a-zA-z._]+)\\.\\."
strings <- lapply(aesthetics, deparse)
strings <- lapply(strings, gsub, pattern = match, replacement = "\\1")
lapply(strings, function(x) parse(text = x)[[1]])
}
ggplot2/R/facet-wrap.r 0000644 0001751 0000144 00000017403 12114161113 014257 0 ustar hornik users #' Wrap a 1d ribbon of panels into 2d.
#'
#' @param nrow number of rows
#' @param ncol number of columns
#' @param facets formula specifying variables to facet by
#' @param scales should scales be fixed (\code{"fixed"}, the default),
#' free (\code{"free"}), or free in one dimension (\code{"free_x"},
#' \code{"free_y"})
#' @inheritParams facet_grid
#' @export
#' @examples
#' \donttest{
#' d <- ggplot(diamonds, aes(carat, price, fill = ..density..)) +
#' xlim(0, 2) + stat_binhex(na.rm = TRUE) + theme(aspect.ratio = 1)
#' d + facet_wrap(~ color)
#' d + facet_wrap(~ color, ncol = 1)
#' d + facet_wrap(~ color, ncol = 4)
#' d + facet_wrap(~ color, nrow = 1)
#' d + facet_wrap(~ color, nrow = 3)
#'
#' # Using multiple variables continues to wrap the long ribbon of
#' # plots into 2d - the ribbon just gets longer
#' # d + facet_wrap(~ color + cut)
#'
#' # To change plot order of facet wrap,
#' # change the order of varible levels with factor()
#' diamonds$color <- factor(diamonds$color, levels = c("G", "J", "D", "E", "I", "F", "H"))
#' # Repeat first example with new order
#' d <- ggplot(diamonds, aes(carat, price, fill = ..density..)) +
#' xlim(0, 2) + stat_binhex(na.rm = TRUE) + theme(aspect.ratio = 1)
#' d + facet_wrap(~ color)
#'
#' # You can choose to keep the scales constant across all panels
#' # or vary the x scale, the y scale or both:
#' p <- qplot(price, data = diamonds, geom = "histogram", binwidth = 1000)
#' p + facet_wrap(~ color)
#' p + facet_wrap(~ color, scales = "free_y")
#'
#' p <- qplot(displ, hwy, data = mpg)
#' p + facet_wrap(~ cyl)
#' p + facet_wrap(~ cyl, scales = "free")
#'
#' # Use as.table to to control direction of horizontal facets, TRUE by default
#' p + facet_wrap(~ cyl, as.table = FALSE)
#'
#' # Add data that does not contain all levels of the faceting variables
#' cyl6 <- subset(mpg, cyl == 6)
#' p + geom_point(data = cyl6, colour = "red", size = 1) +
#' facet_wrap(~ cyl)
#' p + geom_point(data = transform(cyl6, cyl = 7), colour = "red") +
#' facet_wrap(~ cyl)
#' p + geom_point(data = transform(cyl6, cyl = NULL), colour = "red") +
#' facet_wrap(~ cyl)
#' }
facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", shrink = TRUE, as.table = TRUE, drop = TRUE) {
scales <- match.arg(scales, c("fixed", "free_x", "free_y", "free"))
free <- list(
x = any(scales %in% c("free_x", "free")),
y = any(scales %in% c("free_y", "free"))
)
facet(
facets = as.quoted(facets), free = free, shrink = shrink,
as.table = as.table, drop = drop,
ncol = ncol, nrow = nrow,
subclass = "wrap"
)
}
#' @S3method facet_train_layout wrap
facet_train_layout.wrap <- function(facet, data) {
panels <- layout_wrap(data, facet$facets, facet$nrow, facet$ncol,
facet$as.table, facet$drop)
n <- nrow(panels)
nrow <- max(panels$ROW)
# Add scale identification
panels$SCALE_X <- if (facet$free$x) seq_len(n) else 1L
panels$SCALE_Y <- if (facet$free$y) seq_len(n) else 1L
# Figure out where axes should go
panels$AXIS_X <- if (facet$free$x) TRUE else panels$ROW == nrow
panels$AXIS_Y <- if (facet$free$y) TRUE else panels$COL == 1
panels
}
#' @S3method facet_map_layout wrap
facet_map_layout.wrap <- function(facet, data, layout) {
locate_wrap(data, layout, facet$facets)
}
# How to think about facet wrap:
# * vector of panels
# * every panel has strips (strip_pos) and axes (axis_pos)
# * if scales fixed, most axes empty
# * combine panels, strips and axes, then wrap into 2d
# * finally: add title, labels and legend
#
#' @S3method facet_render wrap
facet_render.wrap <- function(facet, panel, coord, theme, geom_grobs) {
# If coord is (non-cartesian or flip) and (x is free or y is free)
# then print a warning
if ((!inherits(coord, "cartesian") || inherits(coord, "flip")) &&
(facet$free$x || facet$free$y)) {
stop("ggplot2 does not currently support free scales with a non-cartesian coord or coord_flip.\n")
}
# If user hasn't set aspect ratio, and we have fixed scales, then
# ask the coordinate system if it wants to specify one
aspect_ratio <- theme$aspect.ratio
if (is.null(aspect_ratio) && !facet$free$x && !facet$free$y) {
aspect_ratio <- coord_aspect(coord, panel$ranges[[1]])
}
if (is.null(aspect_ratio)) {
aspect_ratio <- 1
respect <- FALSE
} else {
respect <- TRUE
}
layout <- panel$layout
ncol <- max(layout$COL)
nrow <- max(layout$ROW)
n <- nrow(layout)
panels <- facet_panels(facet, panel, coord, theme, geom_grobs)
axes <- facet_axes(facet, panel, coord, theme)
strips <- facet_strips(facet, panel, theme)
# Should become facet_arrange_grobs
# Locate each element in panel
find_pos <- function(layout, loc, size) {
n <- nrow(layout)
l <- size[1] * (layout$COL - 1) + loc[1]
t <- size[2] * (layout$ROW - 1) + loc[2]
data.frame(t = t, r = l, b = t, l = l, id = seq_len(n))
}
locs <- list(
panel = c(2, 2),
strip_t = c(2, 1),
axis_l = c(1, 2),
axis_b = c(2, 3),
hspace = c(2, 4),
vspace = c(3, 2)
)
grobs <- list(
panel = panels,
strip_t = strips$t,
axis_l = axes$l,
axis_b = axes$b
)
info <- ldply(locs, find_pos, layout = layout, size = c(3, 4))
names(info)[1] <- "type"
info$clip <- ifelse(info$type == "panel", "on", "off")
info$name <- paste(info$type, info$id, sep = "-")
# Bare numbers are taken as cm
# If not listed, assume is unit(1, "null")
widths <- list(
axis_l = width_cm(grobs$axis_l),
vspace = ifelse(layout$COL == ncol, 0, height_cm(theme$panel.margin))
)
heights <- list(
panel = unit(aspect_ratio, "null"),
strip_t = height_cm(grobs$strip_t),
axis_b = height_cm(grobs$axis_b),
hspace = ifelse(layout$ROW == nrow, 0, height_cm(theme$panel.margin))
)
col_widths <- compute_grob_widths(info, widths)
row_heights <- compute_grob_heights(info, heights)
# Create the gtable for the legend
gt <- gtable(widths = col_widths, heights = row_heights, respect = respect)
# Keep only the rows in info that refer to grobs
info <- info[info$type %in% names(grobs), ]
grobs <- unlist(grobs, recursive = FALSE)
# Add the grobs
gt <- gtable_add_grob(gt, grobs, l = info$l, t = info$t, r = info$r,
b = info$b, name = info$name, clip = info$clip)
gt
}
#' @S3method facet_panels wrap
facet_panels.wrap <- function(facet, panel, coord, theme, geom_grobs) {
panels <- panel$layout$PANEL
lapply(panels, function(i) {
fg <- coord_render_fg(coord, panel$range[[i]], theme)
bg <- coord_render_bg(coord, panel$range[[i]], theme)
geom_grobs <- lapply(geom_grobs, "[[", i)
panel_grobs <- c(list(bg), geom_grobs, list(fg))
ggname(paste("panel", i, sep = "-"),
gTree(children = do.call("gList", panel_grobs)))
})
}
#' @S3method facet_strips wrap
facet_strips.wrap <- function(facet, panel, theme) {
labels_df <- panel$layout[names(facet$facets)]
labels_df[] <- llply(labels_df, format, justify = "none")
labels <- apply(labels_df, 1, paste, collapse=", ")
list(t = llply(labels, ggstrip, theme = theme))
}
#' @S3method facet_axes wrap
facet_axes.wrap <- function(facet, panel, coord, theme) {
panels <- panel$layout$PANEL
axes <- list()
axes$b <- lapply(panels, function(i) {
if (panel$layout$AXIS_X[i]) {
grob <- coord_render_axis_h(coord, panel$range[[i]], theme)
} else {
grob <- zeroGrob()
}
ggname(paste("axis-b-", i, sep = ""), grob)
})
axes$l <- lapply(panels, function(i) {
if (panel$layout$AXIS_Y[i]) {
grob <- coord_render_axis_v(coord, panel$range[[i]], theme)
} else {
grob <- zeroGrob()
}
ggname(paste("axis-l-", i, sep = ""), grob)
})
axes
}
#' @S3method facet_vars wrap
facet_vars.wrap <- function(facet) {
paste(lapply(facet$facets, paste, collapse = ", "), collapse = " ~ ")
}
ggplot2/R/scale-continuous.r 0000644 0001751 0000144 00000010030 12114161113 015506 0 ustar hornik users #' Continuous position scales (x & y).
#'
#' @param ... common continuous scale parameters: \code{name}, \code{breaks},
#' \code{labels}, \code{na.value}, \code{limits} and \code{trans}. See
#' \code{\link{continuous_scale}} for more details
#' @param expand a numeric vector of length two giving multiplicative and
#' additive expansion constants. These constants ensure that the data is
#' placed some distance away from the axes.
#' @family position scales
#' @rdname scale_continuous
#' @export
#' @examples
#' \donttest{
#' (m <- qplot(rating, votes, data=subset(movies, votes > 1000),
#' na.rm = TRUE))
#'
#' # Manipulating the default position scales lets you:
#'
#' # * change the axis labels
#' m + scale_y_continuous("number of votes")
#' m + scale_y_continuous(expression(votes^alpha))
#'
#' # * modify the axis limits
#' m + scale_y_continuous(limits=c(0, 5000))
#' m + scale_y_continuous(limits=c(1000, 10000))
#' m + scale_x_continuous(limits=c(7, 8))
#'
#' # you can also use the short hand functions xlim and ylim
#' m + ylim(0, 5000)
#' m + ylim(1000, 10000)
#' m + xlim(7, 8)
#'
#' # * choose where the ticks appear
#' m + scale_x_continuous(breaks=1:10)
#' m + scale_x_continuous(breaks=c(1,3,7,9))
#'
#' # * manually label the ticks
#' m + scale_x_continuous(breaks=c(2,5,8), labels=c("two", "five", "eight"))
#' m + scale_x_continuous(breaks=c(2,5,8), labels=c("horrible", "ok", "awesome"))
#' m + scale_x_continuous(breaks=c(2,5,8), labels=expression(Alpha, Beta, Omega))
#'
#' # There are a few built in transformation that you can use:
#' m + scale_y_log10()
#' m + scale_y_sqrt()
#' m + scale_y_reverse()
#' # You can also create your own and supply them to the trans argument.
#' # See ?scale::trans_new
#'
#' # You can control the formatting of the labels with the formatter
#' # argument. Some common formats are built into the scales package:
#' x <- rnorm(10) * 100000
#' y <- seq(0, 1, length = 10)
#' p <- qplot(x, y)
#' library(scales)
#' p + scale_y_continuous(labels = percent)
#' p + scale_y_continuous(labels = dollar)
#' p + scale_x_continuous(labels = comma)
#'
#' # qplot allows you to do some of this with a little less typing:
#' # * axis limits
#' qplot(rating, votes, data=movies, ylim=c(1e4, 5e4))
#' # * axis labels
#' qplot(rating, votes, data=movies, xlab="My x axis", ylab="My y axis")
#' # * log scaling
#' qplot(rating, votes, data=movies, log="xy")
#' }
scale_x_continuous <- function(..., expand = waiver()) {
continuous_scale(c("x", "xmin", "xmax", "xend", "xintercept"), "position_c", identity,
..., expand = expand, guide = "none")
}
#' @rdname scale_continuous
#' @export
scale_y_continuous <- function(..., expand = waiver()) {
continuous_scale(c("y", "ymin", "ymax", "yend", "yintercept", "ymin_final", "ymax_final"), "position_c", identity,
..., expand = expand, guide = "none")
}
# Position aesthetics don't map, because the coordinate system takes
# care of it. But they do need to be made in to doubles, so stat methods
# can tell the difference between continuous and discrete data.
#' @S3method scale_map position_c
scale_map.position_c <- function(scale, x, limits = scale_limits(scale)) {
scaled <- as.numeric(scale$oob(x, limits))
ifelse(!is.na(scaled), scaled, scale$na.value)
}
# Transformed scales ---------------------------------------------------------
#' @rdname scale_continuous
#' @export
scale_x_log10 <- function(...) {
scale_x_continuous(..., trans = log10_trans())
}
#' @rdname scale_continuous
#' @export
scale_y_log10 <- function(...) {
scale_y_continuous(..., trans = log10_trans())
}
#' @rdname scale_continuous
#' @export
scale_x_reverse <- function(...) {
scale_x_continuous(..., trans = reverse_trans())
}
#' @rdname scale_continuous
#' @export
scale_y_reverse <- function(...) {
scale_y_continuous(..., trans = reverse_trans())
}
#' @rdname scale_continuous
#' @export
scale_x_sqrt <- function(...) {
scale_x_continuous(..., trans = sqrt_trans())
}
#' @rdname scale_continuous
#' @export
scale_y_sqrt <- function(...) {
scale_y_continuous(..., trans = sqrt_trans())
}
ggplot2/R/plot-construction.r 0000644 0001751 0000144 00000007412 12114160774 015747 0 ustar hornik users #' Modify a ggplot or theme object by adding on new components.
#'
#' This operator allows you to add objects to a ggplot or theme object.
#'
#' If the first object is an object of class \code{ggplot}, you can add
#' the following types of objects, and it will return a modified ggplot
#' object.
#'
#' \itemize{
#' \item \code{data.frame}: replace current data.frame
#' (must use \code{\%+\%})
#' \item \code{uneval}: replace current aesthetics
#' \item \code{layer}: add new layer
#' \item \code{theme}: update plot theme
#' \item \code{scale}: replace current scale
#' \item \code{coord}: override current coordinate system
#' \item \code{facet}: override current coordinate faceting
#' }
#'
#' If the first object is an object of class \code{theme}, you can add
#' another theme object. This will return a modified theme object.
#'
#' For theme objects, the \code{+} operator and the \code{\%+replace\%}
#' can be used to modify elements in themes.
#'
#' The \code{+} operator completely replaces elements
#' with elements from e2.
#'
#' In contrast, the \code{\%+replace\%} operator does not replace the
#' entire element; it only updates element properties which are present
#' (not NULL) in the second object.
#'
#' @examples
#'
#' ### Adding objects to a ggplot object
#' p <- qplot(wt, mpg, colour = hp, data = mtcars)
#'
#' p + coord_cartesian(ylim = c(0, 40))
#' p + scale_colour_continuous(breaks = c(100, 300))
#' p + guides(colour = "colourbar")
#'
#' # Use a different data frame
#' m <- mtcars[1:10, ]
#' p %+% m
#'
#'
#' ### Adding objects to a theme object
#' # Compare these results of adding theme objects to other theme objects
#' add_el <- theme_grey() + theme(text = element_text(family = "Times"))
#' rep_el <- theme_grey() %+replace% theme(text = element_text(family = "Times"))
#'
#' add_el$text
#' rep_el$text
#'
#' @param e1 An object of class \code{ggplot} or \code{theme}
#' @param e2 A component to add to \code{e1}
#'
#' @export
#'
#' @seealso \code{\link{theme}}
#' @method + gg
#' @rdname gg-add
"+.gg" <- function(e1, e2) {
# Get the name of what was passed in as e2, and pass along so that it
# can be displayed in error messages
e2name <- deparse(substitute(e2))
if (is.theme(e1)) add_theme(e1, e2, e2name)
else if (is.ggplot(e1)) add_ggplot(e1, e2, e2name)
}
#' @rdname gg-add
#' @export
"%+%" <- `+.gg`
add_ggplot <- function(p, object, objectname) {
if (is.null(object)) return(p)
p <- plot_clone(p)
if (is.data.frame(object)) {
p$data <- object
} else if (is.theme(object)) {
p$theme <- update_theme(p$theme, object)
} else if (inherits(object, "scale")) {
p$scales$add(object)
} else if(inherits(object, "labels")) {
p <- update_labels(p, object)
} else if(inherits(object, "guides")) {
p <- update_guides(p, object)
} else if(inherits(object, "uneval")) {
p$mapping <- defaults(object, p$mapping)
labels <- lapply(object, deparse)
names(labels) <- names(object)
p <- update_labels(p, labels)
} else if (is.coord(object)) {
p$coordinates <- object
p
} else if (is.facet(object)) {
p$facet <- object
p
} else if(is.list(object)) {
for (o in object) {
p <- p + o
}
} else if(is.proto(object)) {
p <- switch(object$class(),
layer = {
p$layers <- append(p$layers, object)
# Add any new labels
mapping <- make_labels(object$mapping)
default <- make_labels(object$stat$default_aes())
new_labels <- defaults(mapping, default)
p$labels <- defaults(p$labels, new_labels)
p
},
coord = {
p$coordinates <- object
p
}
)
} else {
stop("Don't know how to add ", objectname, " to a plot",
call. = FALSE)
}
set_last_plot(p)
p
}
ggplot2/R/position-.r 0000644 0001751 0000144 00000002304 12114160774 014155 0 ustar hornik users # Position adjustment occurs over all groups within a geom
# They work only with discrete x scales and may affect x and y position.
# Should occur after statistics and scales have been applied.
Position <- proto(TopLevel, expr = {
adjust <- function(., data, scales, ...) data
class <- function(.) "position"
width <- NULL
height <- NULL
new <- function(., width = NULL, height = NULL) {
.$proto(width = width, height = height)
}
parameters <- function(.) {
pnames <- setdiff(names(formals(get("new", .))), ".")
values <- lapply(pnames, get, envir = .)
names(values) <- pnames
values
}
pprint <- function(., newline=TRUE) {
cat("position_", .$objname, ": (", clist(.$parameters()), ")", sep="")
if (newline) cat("\n")
}
})
# Convenience function to ensure that all position variables
# (x, xmin, xmax, xend) are transformed in the same way
transform_position <- function(df, trans_x = NULL, trans_y = NULL, ...) {
scales <- aes_to_scale(names(df))
if (!is.null(trans_x)) {
df[scales == "x"] <- lapply(df[scales == "x"], trans_x, ...)
}
if (!is.null(trans_y)) {
df[scales == "y"] <- lapply(df[scales == "y"], trans_y, ...)
}
df
}
ggplot2/R/utilities-resolution.r 0000644 0001751 0000144 00000001547 12114160774 016460 0 ustar hornik users #' Compute the "resolution" of a data vector.
#'
#' The resolution is is the smallest non-zero distance between adjacent
#' values. If there is only one unique value, then the resolution is defined
#' to be one.
#'
#' If x is an integer vector, then it is assumed to represent a discrete
#' variable, and the resolution is 1.
#'
#' @param x numeric vector
#' @param zero should a zero value be automatically included in the
#' computation of resolution
#' @export
#' @examples
#' resolution(1:10)
#' resolution((1:10) - 0.5)
#' resolution((1:10) - 0.5, FALSE)
#' resolution(c(1,2, 10, 20, 50))
#' resolution(as.integer(c(1, 10, 20, 50))) # Returns 1
resolution <- function(x, zero = TRUE) {
if (is.integer(x) || zero_range(range(x, na.rm = TRUE)))
return(1)
x <- unique(as.numeric(x))
if (zero) {
x <- unique(c(0, x))
}
min(diff(sort(x)))
}
ggplot2/R/facet-layout.r 0000644 0001751 0000144 00000011217 12114160774 014634 0 ustar hornik users # Layout panels in a 2d grid.
#
# @params data list of data frames, one for each layer
# @params rows variables that form the rows
# @params cols variables that form the columns
# @return a data frame with columns \code{PANEL}, \code{ROW} and \code{COL},
# that match the facetting variable values up with their position in the
# grid
layout_grid <- function(data, rows = NULL, cols = NULL, margins = NULL, drop = TRUE, as.table = TRUE) {
if (length(rows) == 0 && length(cols) == 0) return(layout_null())
rows <- as.quoted(rows)
cols <- as.quoted(cols)
base_rows <- layout_base(data, rows, drop = drop)
if (!as.table) {
rev_order <- function(x) factor(x, levels = rev(ulevels(x)))
base_rows[] <- lapply(base_rows, rev_order)
}
base_cols <- layout_base(data, cols, drop = drop)
base <- df.grid(base_rows, base_cols)
# Add margins
base <- add_margins(base, list(names(rows), names(cols)), margins)
# Work around bug in reshape2
base <- unique(base)
# Create panel info dataset
panel <- id(base, drop = TRUE)
panel <- factor(panel, levels = seq_len(attr(panel, "n")))
rows <- if (is.null(names(rows))) 1L else id(base[names(rows)], drop = TRUE)
cols <- if (is.null(names(cols))) 1L else id(base[names(cols)], drop = TRUE)
panels <- data.frame(PANEL = panel, ROW = rows, COL = cols, base)
arrange(panels, PANEL)
}
# Layout out panels in a 1d ribbon.
#
# @params drop should missing combinations be excluded from the plot?
# @keywords internal
layout_wrap <- function(data, vars = NULL, nrow = NULL, ncol = NULL, as.table = TRUE, drop = TRUE) {
vars <- as.quoted(vars)
if (length(vars) == 0) return(layout_null())
base <- unrowname(layout_base(data, vars, drop = drop))
id <- id(base, drop = TRUE)
n <- attr(id, "n")
dims <- wrap_dims(n, nrow, ncol)
layout <- data.frame(PANEL = factor(id, levels = seq_len(n)))
if (as.table) {
layout$ROW <- as.integer((id - 1L) %/% dims[2] + 1L)
} else {
layout$ROW <- as.integer(dims[1] - (id - 1L) %/% dims[2])
}
layout$COL <- as.integer((id - 1L) %% dims[2] + 1L)
panels <- cbind(layout, unrowname(base))
panels[order(panels$PANEL), ]
}
layout_null <- function(data) {
data.frame(PANEL = 1, ROW = 1, COL = 1)
}
# Base layout function that generates all combinations of data needed for
# facetting
# The first data frame in the list should be the default data for the plot.
# Other data frames in the list are ones that are added to layers.
#
# @params data list of data frames (one for each layer)
# @keywords internal
layout_base <- function(data, vars = NULL, drop = TRUE) {
if (length(vars) == 0) return(data.frame())
# For each layer, compute the facet values
values <- compact(llply(data, quoted_df, vars = vars))
# Form the base data frame which contains all combinations of facetting
# variables that appear in the data
has_all <- unlist(llply(values, length)) == length(vars)
if (!any(has_all)) {
stop("At least one layer must contain all variables used for facetting")
}
base <- unique(ldply(values[has_all]))
if (!drop) {
base <- unique_combs(base)
}
# Systematically add on missing combinations
for (value in values[!has_all]) {
if (empty(value)) next;
old <- base[setdiff(names(base), names(value))]
new <- unique(value[intersect(names(base), names(value))])
if (drop) {
new <- unique_combs(new)
}
base <- rbind(base, df.grid(old, new))
}
if (is.null(base)) {
stop("Faceting variables must have at least one value")
}
base
}
ulevels <- function(x) {
if (is.factor(x)) {
x <- addNA(x, TRUE)
factor(levels(x), levels(x), exclude = NULL)
} else {
sort(unique(x))
}
}
unique_combs <- function(df) {
if (length(df) == 0) return()
unique_values <- llply(df, ulevels)
rev(expand.grid(rev(unique_values), stringsAsFactors = FALSE,
KEEP.OUT.ATTRS = TRUE))
}
df.grid <- function(a, b) {
if (nrow(a) == 0) return(b)
if (nrow(b) == 0) return(a)
indexes <- expand.grid(
i_a = seq_len(nrow(a)),
i_b = seq_len(nrow(b))
)
unrowname(cbind(
a[indexes$i_a, , drop = FALSE],
b[indexes$i_b, , drop = FALSE]
))
}
quoted_df <- function(data, vars) {
values <- eval.quoted(vars, data, emptyenv(), try = TRUE)
as.data.frame(compact(values))
}
# Arrange 1d structure into a grid
wrap_dims <- function(n, nrow = NULL, ncol = NULL) {
if (is.null(ncol) && is.null(nrow)) {
rc <- grDevices::n2mfrow(n)
nrow <- rc[2]
ncol <- rc[1]
} else if (is.null(ncol)) {
ncol <- ceiling(n / nrow)
} else if (is.null(nrow)) {
nrow <- ceiling(n / ncol)
}
stopifnot(nrow * ncol >= n)
c(nrow, ncol)
}
ggplot2/R/matrix.r 0000644 0001751 0000144 00000002763 12114161113 013535 0 ustar hornik users #' Code to create a scatterplot matrix (experimental)
#'
#' @param data data frame
#' @param mapping any additional aesthetic mappings (do not use x and y)
#' @param colour default point colour
#' @keywords hplot
#' @export
#' @examples
#' plotmatrix(mtcars[, 1:3])
#' plotmatrix(mtcars[, 1:3]) + geom_smooth(method="lm")
plotmatrix <- function(data, mapping=aes(), colour="black") {
gg_dep("0.9.2", "This function is deprecated. For a replacement, see the ggpairs function in the GGally package.")
# data <- rescaler(data, "range")
grid <- expand.grid(x=1:ncol(data), y=1:ncol(data))
grid <- subset(grid, x != y)
all <- do.call("rbind", lapply(1:nrow(grid), function(i) {
xcol <- grid[i, "x"]
ycol <- grid[i, "y"]
data.frame(
xvar = names(data)[ycol],
yvar = names(data)[xcol],
x = data[, xcol], y = data[, ycol], data
)
}))
all$xvar <- factor(all$xvar, levels=names(data))
all$yvar <- factor(all$yvar, levels=names(data))
densities <- do.call("rbind", lapply(1:ncol(data), function(i) {
data.frame(
xvar = names(data)[i],
yvar = names(data)[i],
x = data[, i]
)
}))
mapping <- defaults(mapping, aes_string(x="x", y="y"))
class(mapping) <- "uneval"
ggplot(all, mapping) + facet_grid(xvar ~ yvar, scales = "free") +
geom_point(colour = colour, na.rm = TRUE) +
stat_density(
aes(x = x, y = ..scaled.. * diff(range(x)) + min(x)),
data = densities, position ="identity", colour = "grey20", geom = "line"
)
}
ggplot2/R/scale-gradient2.r 0000644 0001751 0000144 00000005462 12114160774 015210 0 ustar hornik users #' Diverging colour gradient
#'
#' @inheritParams scale_colour_hue
#' @inheritParams scales::div_gradient_pal
#' @param midpoint The midpoint (in data value) of the diverging scale.
#' Defaults to 0.
#' @param guide Type of legend. Use \code{"colourbar"} for continuous
#' colour bar, or \code{"legend"} for discrete colour legend.
#' @family colour scales
#' @rdname scale_gradient2
#' @export
#' @examples
#' \donttest{
#' dsub <- subset(diamonds, x > 5 & x < 6 & y > 5 & y < 6)
#' dsub$diff <- with(dsub, sqrt(abs(x-y))* sign(x-y))
#' (d <- qplot(x, y, data=dsub, colour=diff))
#'
#' d + scale_colour_gradient2()
#' # Change scale name
#' d + scale_colour_gradient2(expression(sqrt(abs(x - y))))
#' d + scale_colour_gradient2("Difference\nbetween\nwidth and\nheight")
#'
#' # Change limits and colours
#' d + scale_colour_gradient2(limits=c(-0.2, 0.2))
#'
#' # Using "muted" colours makes for pleasant graphics
#' # (and they have better perceptual properties too)
#' library(scales) # for muted
#' d + scale_colour_gradient2(low="red", high="blue")
#' d + scale_colour_gradient2(low=muted("red"), high=muted("blue"))
#'
#' # Using the Lab colour space also improves perceptual properties
#' # at the price of slightly slower operation
#' d + scale_colour_gradient2(space="Lab")
#'
#' # About 5% of males are red-green colour blind, so it's a good
#' # idea to avoid that combination
#' d + scale_colour_gradient2(high=muted("green"))
#'
#' # We can also make the middle stand out
#' d + scale_colour_gradient2(mid=muted("green"), high="white", low="white")
#'
#' # or use a non zero mid point
#' (d <- qplot(carat, price, data=diamonds, colour=price/carat))
#' d + scale_colour_gradient2(midpoint=mean(diamonds$price / diamonds$carat))
#'
#' # Fill gradients work much the same way
#' p <- qplot(letters[1:5], 1:5, fill= c(-3, 3, 5, 2, -2), geom="bar")
#' p + scale_fill_gradient2("fill")
#' # Note how positive and negative values of the same magnitude
#' # have similar intensity
#' }
scale_colour_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"), midpoint = 0, space = "rgb", na.value = "grey50", guide = "colourbar") {
continuous_scale("colour", "gradient2",
div_gradient_pal(low, mid, high, space), na.value = na.value, guide = guide, ...,
rescaler = mid_rescaler(mid = midpoint))
}
#' @rdname scale_gradient2
#' @export
scale_fill_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"), midpoint = 0, space = "rgb", na.value = "grey50", guide = "colourbar") {
continuous_scale("fill", "gradient2",
div_gradient_pal(low, mid, high, space), na.value = na.value, guide = guide, ...,
rescaler = mid_rescaler(mid = midpoint))
}
mid_rescaler <- function(mid) {
function(x, to = c(0, 1), from = range(x, na.rm = TRUE)) {
rescale_mid(x, to, from, mid)
}
}
ggplot2/R/geom-bar-histogram.r 0000644 0001751 0000144 00000011650 12114160774 015724 0 ustar hornik users #' Histogram
#'
#' \code{geom_histogram} is an alias for \code{\link{geom_bar}} plus
#' \code{\link{stat_bin}} so you will need to look at the documentation for
#' those objects to get more information about the parameters.
#'
#' By default, \code{stat_bin} uses 30 bins - this is not a good default,
#' but the idea is to get you experimenting with different binwidths. You
#' may need to look at a few to uncover the full story behind your data.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "histogram")}
#'
#' @export
#' @inheritParams geom_point
#' @examples
#' \donttest{
#' set.seed(5689)
#' movies <- movies[sample(nrow(movies), 1000), ]
#' # Simple examples
#' qplot(rating, data=movies, geom="histogram")
#' qplot(rating, data=movies, weight=votes, geom="histogram")
#' qplot(rating, data=movies, weight=votes, geom="histogram", binwidth=1)
#' qplot(rating, data=movies, weight=votes, geom="histogram", binwidth=0.1)
#'
#' # More complex
#' m <- ggplot(movies, aes(x=rating))
#' m + geom_histogram()
#' m + geom_histogram(aes(y = ..density..)) + geom_density()
#'
#' m + geom_histogram(binwidth = 1)
#' m + geom_histogram(binwidth = 0.5)
#' m + geom_histogram(binwidth = 0.1)
#'
#' # Add aesthetic mappings
#' m + geom_histogram(aes(weight = votes))
#' m + geom_histogram(aes(y = ..count..))
#' m + geom_histogram(aes(fill = ..count..))
#'
#' # Change scales
#' m + geom_histogram(aes(fill = ..count..)) +
#' scale_fill_gradient("Count", low = "green", high = "red")
#'
#' # Often we don't want the height of the bar to represent the
#' # count of observations, but the sum of some other variable.
#' # For example, the following plot shows the number of movies
#' # in each rating.
#' qplot(rating, data=movies, geom="bar", binwidth = 0.1)
#' # If, however, we want to see the number of votes cast in each
#' # category, we need to weight by the votes variable
#' qplot(rating, data=movies, geom="bar", binwidth = 0.1,
#' weight=votes, ylab = "votes")
#'
#' m <- ggplot(movies, aes(x = votes))
#' # For transformed scales, binwidth applies to the transformed data.
#' # The bins have constant width on the transformed scale.
#' m + geom_histogram() + scale_x_log10()
#' m + geom_histogram(binwidth = 1) + scale_x_log10()
#' m + geom_histogram() + scale_x_sqrt()
#' m + geom_histogram(binwidth = 10) + scale_x_sqrt()
#'
#' # For transformed coordinate systems, the binwidth applies to the
#' # raw data. The bins have constant width on the original scale.
#'
#' # Using log scales does not work here, because the first
#' # bar is anchored at zero, and so when transformed becomes negative
#' # infinity. This is not a problem when transforming the scales, because
#' # no observations have 0 ratings.
#' m + geom_histogram(origin = 0) + coord_trans(x = "log10")
#' # Use origin = 0, to make sure we don't take sqrt of negative values
#' m + geom_histogram(origin = 0) + coord_trans(x = "sqrt")
#' m + geom_histogram(origin = 0, binwidth = 1000) + coord_trans(x = "sqrt")
#'
#' # You can also transform the y axis. Remember that the base of the bars
#' # has value 0, so log transformations are not appropriate
#' m <- ggplot(movies, aes(x = rating))
#' m + geom_histogram(binwidth = 0.5) + scale_y_sqrt()
#' m + geom_histogram(binwidth = 0.5) + scale_y_reverse()
#'
#' # Set aesthetics to fixed value
#' m + geom_histogram(colour = "darkgreen", fill = "white", binwidth = 0.5)
#'
#' # Use facets
#' m <- m + geom_histogram(binwidth = 0.5)
#' m + facet_grid(Action ~ Comedy)
#'
#' # Often more useful to use density on the y axis when facetting
#' m <- m + aes(y = ..density..)
#' m + facet_grid(Action ~ Comedy)
#' m + facet_wrap(~ mpaa)
#'
#' # Multiple histograms on the same graph
#' # see ?position, ?position_fill, etc for more details.
#' set.seed(6298)
#' diamonds_small <- diamonds[sample(nrow(diamonds), 1000), ]
#' ggplot(diamonds_small, aes(x=price)) + geom_bar()
#' hist_cut <- ggplot(diamonds_small, aes(x=price, fill=cut))
#' hist_cut + geom_bar() # defaults to stacking
#' hist_cut + geom_bar(position="fill")
#' hist_cut + geom_bar(position="dodge")
#'
#' # This is easy in ggplot2, but not visually effective. It's better
#' # to use a frequency polygon or density plot. Like this:
#' ggplot(diamonds_small, aes(price, ..density.., colour = cut)) +
#' geom_freqpoly(binwidth = 1000)
#' # Or this:
#' ggplot(diamonds_small, aes(price, colour = cut)) +
#' geom_density()
#' # Or if you want to be fancy, maybe even this:
#' ggplot(diamonds_small, aes(price, fill = cut)) +
#' geom_density(alpha = 0.2)
#' # Which looks better when the distributions are more distinct
#' ggplot(diamonds_small, aes(depth, fill = cut)) +
#' geom_density(alpha = 0.2) + xlim(55, 70)
#' }
geom_histogram <- function (mapping = NULL, data = NULL, stat = "bin", position = "stack", ...) {
GeomHistogram$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomHistogram <- proto(GeomBar, {
objname <- "histogram"
})
ggplot2/R/facet-null.r 0000644 0001751 0000144 00000004205 12114160774 014270 0 ustar hornik users #' Facet specification: a single panel.
#'
#' @inheritParams facet_grid
#' @export
#' @examples
#' # facet_null is the default facetting specification if you
#' # don't override it with facet_grid or facet_wrap
#' ggplot(mtcars, aes(mpg, wt)) + geom_point()
#' qplot(mpg, wt, data = mtcars)
facet_null <- function(shrink = TRUE) {
facet(shrink = shrink, subclass = "null")
}
#' @S3method facet_train_layout null
facet_train_layout.null <- function(facet, data) {
data.frame(
PANEL = 1L, ROW = 1L, COL = 1L,
SCALE_X = 1L, SCALE_Y = 1L)
}
#' @S3method facet_map_layout null
facet_map_layout.null <- function(facet, data, layout) {
# Need the is.waive check for special case where no data, but aesthetics
# are mapped to vectors, like qplot(1:5, 1:5)
if (is.waive(data) || empty(data))
return(cbind(data, PANEL = integer(0)))
data$PANEL <- 1L
data
}
#' @S3method facet_render null
facet_render.null <- function(facet, panel, coord, theme, geom_grobs) {
range <- panel$ranges[[1]]
# Figure out aspect ratio
aspect_ratio <- theme$aspect.ratio %||% coord_aspect(coord, range)
if (is.null(aspect_ratio)) {
aspect_ratio <- 1
respect <- FALSE
} else {
respect <- TRUE
}
fg <- coord_render_fg(coord, range, theme)
bg <- coord_render_bg(coord, range, theme)
# Flatten layers - we know there's only one panel
geom_grobs <- lapply(geom_grobs, "[[", 1)
panel_grobs <- c(list(bg), geom_grobs, list(fg))
panel_grob <- gTree(children = do.call("gList", panel_grobs))
axis_h <- coord_render_axis_h(coord, range, theme)
axis_v <- coord_render_axis_v(coord, range, theme)
all <- matrix(list(
axis_v, panel_grob,
zeroGrob(), axis_h
), ncol = 2, byrow = TRUE)
layout <- gtable_matrix("layout", all,
widths = unit.c(grobWidth(axis_v), unit(1, "null")),
heights = unit.c(unit(aspect_ratio, "null"), grobHeight(axis_h)),
respect = respect, clip = c("off", "off", "on", "off"),
z = matrix(c(3, 2, 1, 4), ncol = 2, byrow = TRUE)
)
layout$layout$name <- c("axis-l", "spacer", "panel", "axis-b")
layout
}
#' @S3method facet_vars null
facet_vars.null <- function(facet) ""
ggplot2/R/theme-elements.r 0000644 0001751 0000144 00000025556 12114161113 015152 0 ustar hornik users #' Theme element: blank.
#' This theme element draws nothing, and assigns no space
#'
#' @export
element_blank <- function() {
structure(
list(),
class = c("element_blank", "element")
)
}
#' Theme element: rectangle.
#'
#' Most often used for backgrounds and borders.
#'
#' @param fill fill colour
#' @param colour border colour
#' @param size border size
#' @param linetype border linetype
#' @param color an alias for \code{colour}
#' @export
element_rect <- function(fill = NULL, colour = NULL, size = NULL,
linetype = NULL, color = NULL) {
if (!is.null(color)) colour <- color
structure(
list(fill = fill, colour = colour, size = size, linetype = linetype),
class = c("element_rect", "element")
)
}
#' Theme element: line.
#'
#' @param colour line colour
#' @param size line size
#' @param linetype line type
#' @param lineend line end
#' @param color an alias for \code{colour}
#' @export
element_line <- function(colour = NULL, size = NULL, linetype = NULL,
lineend = NULL, color = NULL) {
if (!is.null(color)) colour <- color
structure(
list(colour = colour, size = size, linetype = linetype, lineend = lineend),
class = c("element_line", "element")
)
}
#' Theme element: text.
#'
#' @param family font family
#' @param face font face ("plain", "italic", "bold", "bold.italic")
#' @param colour text colour
#' @param size text size (in pts)
#' @param hjust horizontal justification (in [0, 1])
#' @param vjust vertical justification (in [0, 1])
#' @param angle angle (in [0, 360])
#' @param lineheight line height
#' @param color an alias for \code{colour}
#' @export
element_text <- function(family = NULL, face = NULL, colour = NULL,
size = NULL, hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL,
color = NULL) {
if (!is.null(color)) colour <- color
structure(
list(family = family, face = face, colour = colour, size = size,
hjust = hjust, vjust = vjust, angle = angle, lineheight = lineheight),
class = c("element_text", "element")
)
}
#' @S3method print element
print.element <- function(x, ...) str(x)
#' Relative sizing for theme elements
#'
#' @param x A number representing the relative size
#' @examples
#' qplot(1:3, 1:3) + theme(axis.title.x = element_text(size = rel(2.5)))
#' @export
rel <- function(x) {
structure(x, class = "rel")
}
#' @S3method print rel
print.rel <- function(x, ...) print(noquote(paste(x, " *", sep = "")))
#' Reports whether x is a rel object
#' @param x An object to test
is.rel <- function(x) inherits(x, "rel")
#' Deprecated theme_xx functions
#'
#' The \code{theme_xx} functions have been deprecated. They are replaced
#' with the \code{element_xx} functions.
#' @param ... Arguments to be passed to the appropriate \code{element_xx}
#' function.
#'
#' @export
theme_blank <- function(...) {
gg_dep("0.9.1", "'theme_blank' is deprecated. Use 'element_blank' instead.")
element_blank(...)
}
#' @rdname theme_blank
#' @export
theme_rect <- function(...) {
gg_dep("0.9.1", "theme_rect is deprecated. Use 'element_rect' instead.")
element_rect(...)
}
#' @rdname theme_blank
#' @export
theme_line <- function(...) {
gg_dep("0.9.1", "theme_line is deprecated. Use 'element_line' instead.")
element_line(...)
}
#' @rdname theme_blank
#' @export
theme_segment <- function(...) {
gg_dep("0.9.1", "theme_segment is deprecated. Use 'element_line' instead.")
element_line(...)
}
#' @rdname theme_blank
#' @export
theme_text <- function(...) {
gg_dep("0.9.1", "theme_text is deprecated. Use 'element_text' instead.")
element_text(...)
}
# Given a theme object and element name, return a grob for the element
element_render <- function(theme, element, ..., name = NULL) {
# Get the element from the theme, calculating inheritance
el <- calc_element(element, theme)
if (is.null(el)) {
message("Theme element ", element, " missing")
return(zeroGrob())
}
ggname(ps(element, name, sep = "."), element_grob(el, ...))
}
# Returns NULL if x is length 0
len0_null <- function(x) {
if (length(x) == 0) NULL
else x
}
# Returns a grob for an element object
element_grob <- function(element, ...)
UseMethod("element_grob")
#' @S3method element_grob element_blank
element_grob.element_blank <- function(element, ...) zeroGrob()
#' @S3method element_grob element_rect
element_grob.element_rect <- function(element, x = 0.5, y = 0.5,
width = 1, height = 1,
fill = NULL, colour = NULL, size = NULL, linetype = NULL, ...) {
# The gp settings can override element_gp
gp <- gpar(lwd = len0_null(size * .pt), col = colour, fill = fill, lty = linetype)
element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour,
fill = element$fill, lty = element$linetype)
rectGrob(x, y, width, height, gp = modifyList(element_gp, gp), ...)
}
#' @S3method element_grob element_text
element_grob.element_text <- function(element, label = "", x = NULL, y = NULL,
family = NULL, face = NULL, colour = NULL, size = NULL,
hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL,
default.units = "npc", ...) {
vj <- vjust %||% element$vjust
hj <- hjust %||% element$hjust
angle <- angle %||% element$angle
if (is.null(angle)) {
stop("Text element requires non-NULL value for 'angle'.")
}
angle <- angle %% 360
if (angle == 90) {
xp <- vj
yp <- hj
} else if (angle == 180) {
xp <- 1 - hj
yp <- vj
} else if (angle == 270) {
xp <- vj
yp <- 1 - hj
}else {
xp <- hj
yp <- vj
}
x <- x %||% xp
y <- y %||% yp
# The gp settings can override element_gp
gp <- gpar(fontsize = size, col = colour,
fontfamily = family, fontface = face,
lineheight = lineheight)
element_gp <- gpar(fontsize = element$size, col = element$colour,
fontfamily = element$family, fontface = element$face,
lineheight = element$lineheight)
textGrob(
label, x, y, hjust = hj, vjust = vj,
default.units = default.units,
gp = modifyList(element_gp, gp),
rot = angle, ...
)
}
#' @S3method element_grob element_line
element_grob.element_line <- function(element, x = 0:1, y = 0:1,
colour = NULL, size = NULL, linetype = NULL, lineend = NULL,
default.units = "npc", id.lengths = NULL, ...) {
# The gp settings can override element_gp
gp <- gpar(lwd=len0_null(size * .pt), col=colour, lty=linetype, lineend = lineend)
element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour,
lty = element$linetype, lineend = element$lineend)
polylineGrob(
x, y, default.units = default.units,
gp = modifyList(element_gp, gp),
id.lengths = id.lengths, ...
)
}
# Define an element's class and what other elements it inherits from
#
# @param class The name of class (like "element_line", "element_text",
# or the reserved "character", which means a character vector (not
# "character" class)
# @param inherit A vector of strings, naming the elements that this
# element inherits from.
el_def <- function(class = NULL, inherit = NULL, description = NULL) {
list(class = class, inherit = inherit, description = description)
}
# This data structure represents the theme elements and the inheritance
# among them.
.element_tree <- list(
line = el_def("element_line"),
rect = el_def("element_rect"),
text = el_def("element_text"),
title = el_def("element_text", "text"),
axis.line = el_def("element_line", "line"),
axis.text = el_def("element_text", "text"),
axis.title = el_def("element_text", "title"),
axis.ticks = el_def("element_line", "line"),
legend.key.size = el_def("unit"),
panel.grid = el_def("element_line", "line"),
panel.grid.major = el_def("element_line", "panel.grid"),
panel.grid.minor = el_def("element_line", "panel.grid"),
strip.text = el_def("element_text", "text"),
axis.line.x = el_def("element_line", "axis.line"),
axis.line.y = el_def("element_line", "axis.line"),
axis.text.x = el_def("element_text", "axis.text"),
axis.text.y = el_def("element_text", "axis.text"),
axis.ticks.length = el_def("unit"),
axis.ticks.x = el_def("element_line", "axis.ticks"),
axis.ticks.y = el_def("element_line", "axis.ticks"),
axis.title.x = el_def("element_text", "axis.title"),
axis.title.y = el_def("element_text", "axis.title"),
axis.ticks.margin = el_def("unit"),
legend.background = el_def("element_rect", "rect"),
legend.margin = el_def("unit"),
legend.key = el_def("element_rect", "rect"),
legend.key.height = el_def("unit", "legend.key.size"),
legend.key.width = el_def("unit", "legend.key.size"),
legend.text = el_def("element_text", "text"),
legend.text.align = el_def("character"),
legend.title = el_def("element_text", "title"),
legend.title.align = el_def("character"),
legend.position = el_def("character"), # Need to also accept numbers
legend.direction = el_def("character"),
legend.justification = el_def("character"),
legend.box = el_def("character"),
legend.box.just = el_def("character"),
panel.background = el_def("element_rect", "rect"),
panel.border = el_def("element_rect", "rect"),
panel.margin = el_def("unit"),
panel.grid.major.x = el_def("element_line", "panel.grid.major"),
panel.grid.major.y = el_def("element_line", "panel.grid.major"),
panel.grid.minor.x = el_def("element_line", "panel.grid.minor"),
panel.grid.minor.y = el_def("element_line", "panel.grid.minor"),
strip.background = el_def("element_rect", "rect"),
strip.text.x = el_def("element_text", "strip.text"),
strip.text.y = el_def("element_text", "strip.text"),
plot.background = el_def("element_rect", "rect"),
plot.title = el_def("element_text", "title"),
plot.margin = el_def("unit"),
aspect.ratio = el_def("character")
)
# Check that an element object has the proper class
#
# Given an element object and the name of the element, this function
# checks it against the element inheritance tree to make sure the
# element is of the correct class
#
# It throws error if invalid, and returns invisible() if valid.
#
# @param el an element
# @param elname the name of the element
validate_element <- function(el, elname) {
eldef <- .element_tree[[elname]]
if (is.null(eldef)) {
stop('"', elname, '" is not a valid theme element name.')
}
# NULL values for elements are OK
if (is.null(el)) return()
if (eldef$class == "character") {
# Need to be a bit looser here since sometimes it's a string like "top"
# but sometimes its a vector like c(0,0)
if (!is.character(el) && !is.numeric(el))
stop("Element ", elname, " must be a string or numeric vector.")
} else if (!inherits(el, eldef$class) && !inherits(el, "element_blank")) {
stop("Element ", elname, " must be a ", eldef$class, " object.")
}
invisible()
}
ggplot2/R/geom-rug.r 0000644 0001751 0000144 00000005006 12114160774 013760 0 ustar hornik users #' Marginal rug plots.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "rug")}
#'
#' @inheritParams geom_point
#' @param sides A string that controls which sides of the plot the rugs appear on.
#' It can be set to a string containing any of \code{"trbl"}, for top, right,
#' bottom, and left.
#' @export
#' @examples
#' p <- ggplot(mtcars, aes(x=wt, y=mpg))
#' p + geom_point()
#' p + geom_point() + geom_rug()
#' p + geom_point() + geom_rug(sides="b") # Rug on bottom only
#' p + geom_point() + geom_rug(sides="trbl") # All four sides
#' p + geom_point() + geom_rug(position='jitter')
geom_rug <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", sides = "bl", ...) {
GeomRug$new(mapping = mapping, data = data, stat = stat, position = position, sides = sides, ...)
}
GeomRug <- proto(Geom, {
objname <- "rug"
draw <- function(., data, scales, coordinates, sides, ...) {
rugs <- list()
data <- coord_transform(coordinates, data, scales)
if (!is.null(data$x)) {
if(grepl("b", sides)) {
rugs$x_b <- segmentsGrob(
x0 = unit(data$x, "native"), x1 = unit(data$x, "native"),
y0 = unit(0, "npc"), y1 = unit(0.03, "npc"),
gp = gpar(col = alpha(data$colour, data$alpha), lty = data$linetype, lwd = data$size * .pt)
)
}
if(grepl("t", sides)) {
rugs$x_t <- segmentsGrob(
x0 = unit(data$x, "native"), x1 = unit(data$x, "native"),
y0 = unit(1, "npc"), y1 = unit(0.97, "npc"),
gp = gpar(col = alpha(data$colour, data$alpha), lty = data$linetype, lwd = data$size * .pt)
)
}
}
if (!is.null(data$y)) {
if(grepl("l", sides)) {
rugs$y_l <- segmentsGrob(
y0 = unit(data$y, "native"), y1 = unit(data$y, "native"),
x0 = unit(0, "npc"), x1 = unit(0.03, "npc"),
gp = gpar(col = alpha(data$colour, data$alpha), lty = data$linetype, lwd = data$size * .pt)
)
}
if(grepl("r", sides)) {
rugs$y_r <- segmentsGrob(
y0 = unit(data$y, "native"), y1 = unit(data$y, "native"),
x0 = unit(1, "npc"), x1 = unit(0.97, "npc"),
gp = gpar(col = alpha(data$colour, data$alpha), lty = data$linetype, lwd = data$size * .pt)
)
}
}
gTree(children = do.call("gList", rugs))
}
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = NA)
guide_geom <- function(.) "path"
})
ggplot2/R/translate-qplot-lattice.r 0000644 0001751 0000144 00000005712 12114160774 017017 0 ustar hornik users #' Translating between qplot and lattice
#'
#' The major difference between lattice and ggplot2 is that lattice uses a formula based
#' interface. ggplot2 does not because the formula does not generalise well
#' to more complicated situations.
#'
#' @name translate_qplot_lattice
#' @examples
#' \donttest{
#' library(lattice)
#'
#' xyplot(rating ~ year, data=movies)
#' qplot(year, rating, data=movies)
#'
#' xyplot(rating ~ year | Comedy + Action, data = movies)
#' qplot(year, rating, data = movies, facets = ~ Comedy + Action)
#' # Or maybe
#' qplot(year, rating, data = movies, facets = Comedy ~ Action)
#'
#' # While lattice has many different functions to produce different types of
#' # graphics (which are all basically equivalent to setting the panel argument),
#' # ggplot2 has qplot().
#'
#' stripplot(~ rating, data = movies, jitter.data = TRUE)
#' qplot(rating, 1, data = movies, geom = "jitter")
#'
#' histogram(~ rating, data = movies)
#' qplot(rating, data = movies, geom = "histogram")
#'
#' bwplot(Comedy ~ rating ,data = movies)
#' qplot(factor(Comedy), rating, data = movies, type = "boxplot")
#'
#' xyplot(wt ~ mpg, mtcars, type = c("p","smooth"))
#' qplot(mpg, wt, data = mtcars, geom = c("point","smooth"))
#'
#' xyplot(wt ~ mpg, mtcars, type = c("p","r"))
#' qplot(mpg, wt, data = mtcars, geom = c("point","smooth"), method = "lm")
#'
#' # The capabilities for scale manipulations are similar in both ggplot2 and
#' # lattice, although the syntax is a little different.
#'
#' xyplot(wt ~ mpg | cyl, mtcars, scales = list(y = list(relation = "free")))
#' qplot(mpg, wt, data = mtcars) + facet_wrap(~ cyl, scales = "free")
#'
#' xyplot(wt ~ mpg | cyl, mtcars, scales = list(log = 10))
#' qplot(mpg, wt, data = mtcars, log = "xy")
#'
#' xyplot(wt ~ mpg | cyl, mtcars, scales = list(log = 2))
#' library(scales) # Load scales for log2_trans
#' qplot(mpg, wt, data = mtcars) + scale_x_continuous(trans = log2_trans()) +
#' scale_y_continuous(trans = log2_trans())
#'
#' xyplot(wt ~ mpg, mtcars, group = cyl, auto.key = TRUE)
#' # Map directly to an aesthetic like colour, size, or shape.
#' qplot(mpg, wt, data = mtcars, colour = cyl)
#'
#' xyplot(wt ~ mpg, mtcars, xlim = c(20,30))
#' # Works like lattice, except you can't specify a different limit
#' # for each panel/facet
#' qplot(mpg, wt, data = mtcars, xlim = c(20,30))
#'
#' # Both lattice and ggplot2 have similar options for controlling labels on the plot.
#'
#' xyplot(wt ~ mpg, mtcars, xlab = "Miles per gallon", ylab = "Weight",
#' main = "Weight-efficiency tradeoff")
#' qplot(mpg, wt, data = mtcars, xlab = "Miles per gallon", ylab = "Weight",
#' main = "Weight-efficiency tradeoff")
#'
#' xyplot(wt ~ mpg, mtcars, aspect = 1)
#' qplot(mpg, wt, data = mtcars, asp = 1)
#'
#' # par.settings() is equivalent to + theme() and trellis.options.set()
#' # and trellis.par.get() to theme_set() and theme_get().
#' # More complicated lattice formulas are equivalent to rearranging the data
#' # before using ggplot2.
#' }
NULL
ggplot2/R/geom-raster.r 0000644 0001751 0000144 00000010243 12114160774 014462 0 ustar hornik users #' @include geom-.r
NULL
#' High-performance rectangular tiling.
#'
#' This is a special case of \code{\link{geom_tile}} where all tiles are
#' the same size. It is implemented highly efficiently using the internal
#' \code{rasterGrob} function.
#'
#' By default, \code{geom_raster} add a vertical and horizontal padding.
#' The size of padding depends on the resolution of data.
#' If you want to manually set the padding (e.g. want zero-padding),
#' you can change the behavior by setting \code{hpad} and \code{vpad}.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "raster")}
#'
#' @inheritParams geom_point
#' @param hjust,vjust horizontal and vertical justification of the grob. Each
#' justification value should be a number between 0 and 1. Defaults to 0.5
#' for both, centering each pixel over its data location.
#' @param interpolate If \code{TRUE} interpolate linearly, if \code{FALSE}
#' (the default) don't interpolate.
#' @export
#' @examples
#' \donttest{
#' # Generate data
#' pp <- function (n,r=4) {
#' x <- seq(-r*pi, r*pi, len=n)
#' df <- expand.grid(x=x, y=x)
#' df$r <- sqrt(df$x^2 + df$y^2)
#' df$z <- cos(df$r^2)*exp(-df$r/6)
#' df
#' }
#' qplot(x, y, data = pp(20), fill = z, geom = "raster")
#' # Interpolation worsens the apperance of this plot, but can help when
#' # rendering images.
#' qplot(x, y, data = pp(20), fill = z, geom = "raster", interpolate = TRUE)
#'
#' # For the special cases where it is applicable, geom_raster is much
#' # faster than geom_tile:
#' pp200 <- pp(200)
#' base <- ggplot(pp200, aes(x, y, fill = z))
#' benchplot(base + geom_raster())
#' benchplot(base + geom_tile())
#'
#' # justification
#' df <- expand.grid(x = 0:5, y = 0:5)
#' df$z <- runif(nrow(df))
#' # default is compatible with geom_tile()
#' ggplot(df, aes(x, y, fill = z)) + geom_raster()
#' # zero padding
#' ggplot(df, aes(x, y, fill = z)) + geom_raster(hjust = 0, vjust = 0)
#' }
geom_raster <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", hjust = 0.5, vjust = 0.5, interpolate = FALSE, ...) {
stopifnot(is.numeric(hjust), length(hjust) == 1)
stopifnot(is.numeric(vjust), length(vjust) == 1)
GeomRaster$new(mapping = mapping, data = data, stat = stat, position = position, hjust = hjust, vjust = vjust, interpolate = interpolate, ...)
}
GeomRaster <- proto(Geom, {
objname <- "raster"
reparameterise <- function(., df, params) {
hjust <- params$hjust %||% 0.5
vjust <- params$vjust %||% 0.5
w <- resolution(df$x, FALSE)
h <- resolution(df$y, FALSE)
df$xmin <- df$x - w * (1 - hjust)
df$xmax <- df$x + w * hjust
df$ymin <- df$y - h * (1 - vjust)
df$ymax <- df$y + h * vjust
df
}
# This is a dummy function to make sure that vjust and hjust are recongised
# as parameters and are accessible to reparameterise.
draw <- function(vjust = 0.5, hjust = 0.5) {}
draw_groups <- function(., data, scales, coordinates, interpolate = FALSE, ...) {
if (!inherits(coordinates, "cartesian")) {
stop("geom_raster only works with Cartesian coordinates", call. = FALSE)
}
data <- remove_missing(data, TRUE, c("x", "y", "fill"),
name = "geom_raster")
data <- coord_transform(coordinates, data, scales)
# Convert vector of data to raster
x_pos <- as.integer((data$x - min(data$x)) / resolution(data$x, FALSE))
y_pos <- as.integer((data$y - min(data$y)) / resolution(data$y, FALSE))
nrow <- max(y_pos) + 1
ncol <- max(x_pos) + 1
raster <- matrix(NA_character_, nrow = nrow, ncol = ncol)
raster[cbind(nrow - y_pos, x_pos + 1)] <- alpha(data$fill, data$alpha)
# Figure out dimensions of raster on plot
x_rng <- c(min(data$xmin, na.rm = TRUE), max(data$xmax, na.rm = TRUE))
y_rng <- c(min(data$ymin, na.rm = TRUE), max(data$ymax, na.rm = TRUE))
rasterGrob(raster, x = mean(x_rng), y = mean(y_rng),
width = diff(x_rng), height = diff(y_rng),
default.units = "native", interpolate = interpolate)
}
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(fill = "grey20", alpha = NA)
required_aes <- c("x", "y")
guide_geom <- function(.) "polygon"
})
ggplot2/R/geom-ribbon-.r 0000644 0001751 0000144 00000010762 12114160774 014520 0 ustar hornik users #' Ribbons, y range with continuous x values.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "ribbon")}
#'
#' @seealso
#' \code{\link{geom_bar}} for discrete intervals (bars),
#' \code{\link{geom_linerange}} for discrete intervals (lines),
#' \code{\link{geom_polygon}} for general polygons"
#' @inheritParams geom_point
#' @export
#' @examples
#' \donttest{
#' # Generate data
#' huron <- data.frame(year = 1875:1972, level = as.vector(LakeHuron))
#' library(plyr) # to access round_any
#' huron$decade <- round_any(huron$year, 10, floor)
#'
#' h <- ggplot(huron, aes(x=year))
#'
#' h + geom_ribbon(aes(ymin=0, ymax=level))
#' h + geom_area(aes(y = level))
#'
#' # Add aesthetic mappings
#' h + geom_ribbon(aes(ymin=level-1, ymax=level+1))
#' h + geom_ribbon(aes(ymin=level-1, ymax=level+1)) + geom_line(aes(y=level))
#'
#' # Take out some values in the middle for an example of NA handling
#' huron[huron$year > 1900 & huron$year < 1910, "level"] <- NA
#' h <- ggplot(huron, aes(x=year))
#' h + geom_ribbon(aes(ymin=level-1, ymax=level+1)) + geom_line(aes(y=level))
#'
#' # Another data set, with multiple y's for each x
#' m <- ggplot(movies, aes(y=votes, x=year))
#' (m <- m + geom_point())
#'
#' # The default summary isn't that useful
#' m + stat_summary(geom="ribbon", fun.ymin="min", fun.ymax="max")
#' m + stat_summary(geom="ribbon", fun.data="median_hilow")
#'
#' # Use qplot instead
#' qplot(year, level, data=huron, geom=c("area", "line"))
#' }
geom_ribbon <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",
na.rm = FALSE, ...) {
GeomRibbon$new(mapping = mapping, data = data, stat = stat, position = position,
na.rm = na.rm, ...)
}
GeomRibbon <- proto(Geom, {
objname <- "ribbon"
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(colour=NA, fill="grey20", size=0.5, linetype=1, alpha = NA)
required_aes <- c("x", "ymin", "ymax")
guide_geom <- function(.) "polygon"
draw <- function(., data, scales, coordinates, na.rm = FALSE, ...) {
if (na.rm) data <- data[complete.cases(data[required_aes]), ]
data <- data[order(data$group, data$x), ]
# Check that aesthetics are constant
aes <- unique(data[c("colour", "fill", "size", "linetype", "alpha")])
if (nrow(aes) > 1) {
stop("Aesthetics can not vary with a ribbon")
}
aes <- as.list(aes)
# Instead of removing NA values from the data and plotting a single
# polygon, we want to "stop" plotting the polygon whenever we're
# missing values and "start" a new polygon as soon as we have new
# values. We do this by creating an id vector for polygonGrob that
# has distinct polygon numbers for sequences of non-NA values and NA
# for NA values in the original data. Example: c(NA, 2, 2, 2, NA, NA,
# 4, 4, 4, NA)
missing_pos <- !complete.cases(data[required_aes])
ids <- cumsum(missing_pos) + 1
ids[missing_pos] <- NA
positions <- summarise(data,
x = c(x, rev(x)), y = c(ymax, rev(ymin)), id = c(ids, rev(ids)))
munched <- coord_munch(coordinates,positions, scales)
ggname(.$my_name(), polygonGrob(
munched$x, munched$y, id = munched$id,
default.units = "native",
gp = gpar(
fill = alpha(aes$fill, aes$alpha),
col = aes$colour,
lwd = aes$size * .pt,
lty = aes$linetype)
))
}
})
#' Area plot.
#'
#' An area plot is the continuous analog of a stacked bar chart (see
#' \code{\link{geom_bar}}), and can be used to show how composition of the
#' whole varies over the range of x. Choosing the order in which different
#' components is stacked is very important, as it becomes increasing hard to
#' see the individual pattern as you move up the stack.
#'
#' An area plot is a special case of \code{\link{geom_ribbon}}, where the
#' minimum of the range is fixed to 0, and the position adjustment defaults
#' to position_stacked.
#'
#' @inheritParams geom_point
#' @export
#' @examples
#' # see geom_ribbon
geom_area <- function (mapping = NULL, data = NULL, stat = "identity", position = "stack",
na.rm = FALSE, ...) {
GeomArea$new(mapping = mapping, data = data, stat = stat, position = position,
na.rm = na.rm, ...)
}
GeomArea <- proto(GeomRibbon,{
objname <- "area"
default_aes <- function(.) aes(colour=NA, fill="grey20", size=0.5, linetype=1, alpha = NA)
default_pos <- function(.) PositionStack
required_aes <- c("x", "y")
reparameterise <- function(., df, params) {
transform(df, ymin = 0, ymax = y)
}
})
ggplot2/R/coord-map.r 0000644 0001751 0000144 00000015721 12114161113 014110 0 ustar hornik users #' Map projections.
#'
#' This coordinate system provides the full range of map projections available
#' in the mapproj package.
#'
#' This is still experimental, and if you have any advice to offer regarding
#' a better (or more correct) way to do this, please let me know
#'
#' @export
#' @param projection projection to use, see
#' \code{\link[mapproj]{mapproject}} for list
#' @param ... other arguments passed on to
#' \code{\link[mapproj]{mapproject}}
#' @param orientation projection orientation, which defaults to
#' \code{c(90, 0, mean(range(x)))}. This is not optimal for many
#' projections, so you will have to supply your own. See
#' \code{\link[mapproj]{mapproject}} for more information.
#' @param xlim manually specific x limits (in degrees of lontitude)
#' @param ylim manually specific y limits (in degrees of latitude)
#' @export
#' @examples
#' if (require("maps")) {
#' # Create a lat-long dataframe from the maps package
#' nz <- map_data("nz")
#' nzmap <- ggplot(nz, aes(x=long, y=lat, group=group)) +
#' geom_polygon(fill="white", colour="black")
#'
#' # Use cartesian coordinates
#' nzmap
#' # With default mercator projection
#' nzmap + coord_map()
#' # Other projections
#' nzmap + coord_map("cylindrical")
#' nzmap + coord_map("azequalarea",orientation=c(-36.92,174.6,0))
#'
#' states <- map_data("state")
#' usamap <- ggplot(states, aes(x=long, y=lat, group=group)) +
#' geom_polygon(fill="white", colour="black")
#'
#' # Use cartesian coordinates
#' usamap
#' # With mercator projection
#' usamap + coord_map()
#' # See ?mapproject for coordinate systems and their parameters
#' usamap + coord_map("gilbert")
#' usamap + coord_map("lagrange")
#'
#' # For most projections, you'll need to set the orientation yourself
#' # as the automatic selection done by mapproject is not available to
#' # ggplot
#' usamap + coord_map("orthographic")
#' usamap + coord_map("stereographic")
#' usamap + coord_map("conic", lat0 = 30)
#' usamap + coord_map("bonne", lat0 = 50)
#'
#' # World map, using geom_path instead of geom_polygon
#' world <- map_data("world")
#' worldmap <- ggplot(world, aes(x=long, y=lat, group=group)) +
#' geom_path() +
#' scale_y_continuous(breaks=(-2:2) * 30) +
#' scale_x_continuous(breaks=(-4:4) * 45)
#'
#' # Orthographic projection with default orientation (looking down at North pole)
#' worldmap + coord_map("ortho")
#' # Looking up up at South Pole
#' worldmap + coord_map("ortho", orientation=c(-90, 0, 0))
#' # Centered on New York (currently has issues with closing polygons)
#' worldmap + coord_map("ortho", orientation=c(41, -74, 0))
#' }
coord_map <- function(projection="mercator", ..., orientation = NULL, xlim = NULL, ylim = NULL) {
try_require("mapproj")
coord(
projection = projection,
orientation = orientation,
limits = list(x = xlim, y = ylim),
params = list(...),
subclass = "map"
)
}
#' @S3method coord_transform map
coord_transform.map <- function(coord, data, details) {
trans <- mproject(coord, data$x, data$y, details$orientation)
out <- cunion(trans[c("x", "y")], data)
out$x <- rescale(out$x, 0:1, details$x.proj)
out$y <- rescale(out$y, 0:1, details$y.proj)
out
}
mproject <- function(coord, x, y, orientation) {
suppressWarnings(mapproject(x, y,
projection = coord$projection,
parameters = coord$params,
orientation = orientation
))
}
#' @S3method coord_distance map
coord_distance.map <- function(coord, x, y, details) {
max_dist <- dist_central_angle(details$x.range, details$y.range)
dist_central_angle(x, y) / max_dist
}
#' @S3method coord_aspect map
coord_aspect.map <- function(coord, ranges) {
diff(ranges$y.proj) / diff(ranges$x.proj)
}
#' @S3method coord_train map
coord_train.map <- function(coord, scales) {
# range in scale
ranges <- list()
for (n in c("x", "y")) {
scale <- scales[[n]]
limits <- coord$limits[[n]]
if (is.null(limits)) {
expand <- coord_expand_defaults(coord, scale, n)
range <- scale_dimension(scale, expand)
} else {
range <- range(scale_transform(scale, limits))
}
ranges[[n]] <- range
}
orientation <- coord$orientation %||% c(90, 0, mean(ranges$x))
# Increase chances of creating valid boundary region
grid <- expand.grid(
x = seq(ranges$x[1], ranges$x[2], length = 50),
y = seq(ranges$y[1], ranges$y[2], length = 50)
)
ret <- list(x = list(), y = list())
# range in map
proj <- mproject(coord, grid$x, grid$y, orientation)$range
ret$x$proj <- proj[1:2]
ret$y$proj <- proj[3:4]
for (n in c("x", "y")) {
out <- scale_break_info(scales[[n]], ranges[[n]])
ret[[n]]$range <- out$range
ret[[n]]$major <- out$major_source
ret[[n]]$minor <- out$minor_source
ret[[n]]$labels <- out$labels
}
details <- list(
orientation = orientation,
x.range = ret$x$range, y.range = ret$y$range,
x.proj = ret$x$proj, y.proj = ret$y$proj,
x.major = ret$x$major, x.minor = ret$x$minor, x.labels = ret$x$labels,
y.major = ret$y$major, y.minor = ret$y$minor, y.labels = ret$y$labels
)
details
}
#' @S3method coord_render_bg map
coord_render_bg.map <- function(coord, details, theme) {
xrange <- expand_range(details$x.range, 0.2)
yrange <- expand_range(details$y.range, 0.2)
# Limit ranges so that lines don't wrap around globe
xmid <- mean(xrange)
ymid <- mean(yrange)
xrange[xrange < xmid - 180] <- xmid - 180
xrange[xrange > xmid + 180] <- xmid + 180
yrange[yrange < ymid - 90] <- ymid - 90
yrange[yrange > ymid + 90] <- ymid + 90
xgrid <- with(details, expand.grid(
y = c(seq(yrange[1], yrange[2], len = 50), NA),
x = x.major
))
ygrid <- with(details, expand.grid(
x = c(seq(xrange[1], xrange[2], len = 50), NA),
y = y.major
))
xlines <- coord_transform(coord, xgrid, details)
ylines <- coord_transform(coord, ygrid, details)
if (nrow(xlines) > 0) {
grob.xlines <- element_render(
theme, "panel.grid.major.x",
xlines$x, xlines$y, default.units = "native"
)
} else {
grob.xlines <- zeroGrob()
}
if (nrow(ylines) > 0) {
grob.ylines <- element_render(
theme, "panel.grid.major.y",
ylines$x, ylines$y, default.units = "native"
)
} else {
grob.ylines <- zeroGrob()
}
ggname("grill", grobTree(
element_render(theme, "panel.background"),
grob.xlines, grob.ylines
))
}
#' @S3method coord_render_axis_h map
coord_render_axis_h.map <- function(coord, details, theme) {
if (is.null(details$x.major)) return(zeroGrob())
x_intercept <- with(details, data.frame(
x = x.major,
y = y.range[1]
))
pos <- coord_transform(coord, x_intercept, details)
guide_axis(pos$x, details$x.labels, "bottom", theme)
}
#' @S3method coord_render_axis_v map
coord_render_axis_v.map <- function(coord, details, theme) {
if (is.null(details$y.major)) return(zeroGrob())
x_intercept <- with(details, data.frame(
x = x.range[1],
y = y.major
))
pos <- coord_transform(coord, x_intercept, details)
guide_axis(pos$y, details$y.labels, "left", theme)
}
ggplot2/R/stat-bindot.r 0000644 0001751 0000144 00000017767 12114160774 014507 0 ustar hornik users #' Bin data for dot plot.
#'
#' Missing values are currently silently dropped.
#' If weights are used, they must be integer values.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "bindot")}
#'
#' @inheritParams stat_identity
#' @param binaxis The axis to bin along, "x" (default) or "y"
#' @param method "dotdensity" (default) for dot-density binning, or
#' "histodot" for fixed bin widths (like stat_bin)
#' @param binwidth When \code{method} is "dotdensity, this specifies maximum bin width.
#' When \code{method} is "histodot", this specifies bin width.
#' Defaults to 1/30 of the range of the data
#' @param binpositions When \code{method} is "dotdensity", "bygroup" (default)
#' determines positions of the bins for each group separately. "all" determines
#' positions of the bins with all the data taken together; this is used for
#' aligning dot stacks across multiple groups.
#' @param origin When \code{method} is "histodot", origin of first bin
#' @param right When \code{method} is "histodot", should intervals be closed
#' on the right (a, b], or not [a, b)
#' @param width When \code{binaxis} is "y", the spacing of the dot stacks
#' for dodging.
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @param drop If TRUE, remove all bins with zero counts
#'
#' @return New data frame with additional columns:
#' \item{x}{center of each bin, if binaxis is "x"}
#' \item{y}{center of each bin, if binaxis is "x"}
#' \item{binwidth}{max width of each bin if method is "dotdensity";
#' width of each bin if method is "histodot"}
#' \item{count}{number of points in bin}
#' \item{ncount}{count, scaled to maximum of 1}
#' \item{density}{density of points in bin, scaled to integrate to 1,
#' if method is "histodot"}
#' \item{ndensity}{density, scaled to maximum of 1, if method is "histodot"}
#' @seealso See \code{\link{geom_dotplot}} for examples.
#' @export
#' @examples
#' # See geom_dotplot for examples
#'
stat_bindot <- function (mapping = NULL, data = NULL, geom = "dotplot", position = "identity",
binwidth = NULL, origin = NULL, width = 0.9, binaxis = "x", method = "dotdensity",
binpositions = "bygroup", drop = FALSE, right = TRUE, na.rm = FALSE, ...) {
StatBindot$new(mapping = mapping, data = data, geom = geom, position = position,
binwidth = binwidth, origin = origin, width = width, binaxis = binaxis,
method = method, binpositions = binpositions, drop = drop, right = right,
na.rm = na.rm, ...)
}
StatBindot <- proto(Stat, {
objname <- "bindot"
informed <- FALSE
calculate_groups <- function(., data, na.rm = FALSE, binwidth = NULL, binaxis = "x",
method = "dotdensity", binpositions = "bygroup", ...) {
data <- remove_missing(data, na.rm, c(binaxis, "weight"), name="stat_bindot",
finite = TRUE)
.$informed <- FALSE
# If using dotdensity and binning over all, we need to find the bin centers
# for all data before it's split into groups.
if (method == "dotdensity" && binpositions == "all") {
if (binaxis == "x") {
newdata <- densitybin(x = data$x, weight = data$weight, binwidth = binwidth,
method = method)
data <- arrange(data, x)
newdata <- arrange(newdata, x)
} else if (binaxis == "y") {
newdata <- densitybin(x = data$y, weight = data$weight, binwidth = binwidth,
method = method)
data <- arrange(data, y)
newdata <- arrange(newdata, x)
}
data$bin <- newdata$bin
data$binwidth <- newdata$binwidth
data$weight <- newdata$weight
data$bincenter <- newdata$bincenter
}
.super$calculate_groups(., data, binwidth = binwidth, binaxis = binaxis,
method = method, binpositions = binpositions, ...)
}
calculate <- function(., data, scales, binwidth = NULL, binaxis = "x",
method = "dotdensity", binpositions = "bygroup",
origin = NULL, breaks = NULL, width = 0.9, drop = FALSE,
right = TRUE, ...) {
# This function taken from integer help page
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) {
abs(x - round(x)) < tol
}
# Check that weights are whole numbers (for dots, weights must be whole)
if (!is.null(data$weight) && any(!is.wholenumber(data$weight)) &&
any(data$weight < 0)) {
stop("Weights for stat_bindot must be nonnegative integers.")
}
if (binaxis == "x") {
range <- scale_dimension(scales$x, c(0, 0))
values <- data$x
} else if (binaxis == "y") {
range <- scale_dimension(scales$y, c(0, 0))
values <- data$y
# The middle of each group, on the stack axis
midline <- mean(range(data$x))
}
if (is.null(breaks) && is.null(binwidth) && !is.integer(values) && !.$informed) {
message("stat_bindot: binwidth defaulted to range/30. Use 'binwidth = x' to adjust this.")
.$informed <- TRUE
}
if(method == "histodot") {
# Use the function from stat_bin
data <- bin(x = values, weight = data$weight, binwidth = binwidth, origin = origin,
breaks=breaks, range = range, width = width, drop = drop, right = right)
# Change "width" column to "binwidth" for consistency
names(data)[names(data) == "width"] <- "binwidth"
names(data)[names(data) == "x"] <- "bincenter"
} else if (method == "dotdensity") {
# If bin centers are found by group instead of by all, find the bin centers
# (If binpositions=="all", then we'll already have bin centers.)
if (binpositions == "bygroup")
data <- densitybin(x = values, weight = data$weight, binwidth = binwidth,
method = method, range = range)
# Collapse each bin and get a count
data <- ddply(data, .(bincenter), summarise, binwidth = binwidth[1], count = sum(weight))
if (sum(data$count, na.rm = TRUE) != 0) {
data$count[is.na(data$count)] <- 0
data$ncount <- data$count / max(abs(data$count), na.rm = TRUE)
if (drop) data <- subset(data, count > 0)
}
}
if (binaxis == "x") {
names(data)[names(data) == "bincenter"] <- "x"
# For x binning, the width of the geoms is same as the width of the bin
data$width <- data$binwidth
} else if (binaxis == "y") {
names(data)[names(data) == "bincenter"] <- "y"
# For y binning, set the x midline. This is needed for continuous x axis
data$x <- midline
}
return(data)
}
default_aes <- function(.) aes(y = ..count..)
required_aes <- c("x")
default_geom <- function(.) GeomDotplot
})
# This does density binning, but does not collapse each bin with a count.
# It returns a data frame with the original data (x), weights, bin #, and the bin centers.
densitybin <- function(x, weight = NULL, binwidth = NULL, method = method, range = NULL) {
if (length(na.omit(x)) == 0) return(data.frame())
if (is.null(weight)) weight <- rep(1, length(x))
weight[is.na(weight)] <- 0
if (is.null(range)) range <- range(x, na.rm = TRUE, finite = TRUE)
if (is.null(binwidth)) binwidth <- diff(range) / 30
# Sort weight and x, by x
weight <- weight[order(x)]
x <- x[order(x)]
cbin <- 0 # Current bin ID
bin <- rep.int(NA, length(x)) # The bin ID for each observation
binend <- -Inf # End position of current bin (scan left to right)
# Scan list and put dots in bins
for (i in 1:length(x)) {
# If past end of bin, start a new bin at this point
if (x[i] >= binend) {
binend <- x[i] + binwidth
cbin <- cbin + 1
}
bin[i] <- cbin
}
results <- data.frame(x, bin, binwidth, weight)
results <- ddply(results, .(bin), function(df) {
df$bincenter = (min(df$x) + max(df$x)) / 2
return(df)
})
return(results)
}
ggplot2/R/autoplot.r 0000644 0001751 0000144 00000001435 12114160774 014107 0 ustar hornik users #' Create a complete ggplot appropriate to a particular data type
#'
#' \code{autoplot} uses ggplot2 to draw a particular plot for an object of a
#' particular class in a single command. This defines the S3 generic that
#' other classes and packages can extend.
#'
#' @param object an object, whose class will determine the behaviour of autoplot
#' @param ... other arguments passed to specific methods
#' @return a ggplot object
#' @export
#' @seealso \code{\link{ggplot}} and \code{\link{fortify}}
autoplot <- function(object, ...) {
UseMethod("autoplot")
}
#' @S3method autoplot default
autoplot.default <- function(object, ...) {
error.msg <- paste("Objects of type",class(object),"not supported by autoplot. Please use qplot() or ggplot() instead.\n")
stop(error.msg, call.=FALSE)
}
ggplot2/R/geom-hex.r 0000644 0001751 0000144 00000003120 12114160774 013742 0 ustar hornik users #' Hexagon bining.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "hex")}
#'
#' @export
#' @inheritParams geom_point
#' @examples
#' # See ?stat_binhex for examples
geom_hex <- function (mapping = NULL, data = NULL, stat = "binhex", position = "identity", ...) {
GeomHex$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomHex <- proto(Geom, {
objname <- "hex"
draw <- function(., data, scales, coordinates, ...) {
with(coord_transform(coordinates, data, scales),
ggname(.$my_name(), hexGrob(x, y, col=colour,
fill = alpha(fill, alpha)))
)
}
required_aes <- c("x", "y")
default_aes <- function(.) aes(colour=NA, fill = "grey50", size=0.5, alpha = NA)
default_stat <- function(.) StatBinhex
guide_geom <- function(.) "polygon"
})
# Draw hexagon grob
# Modified from code by Nicholas Lewin-Koh and Martin Maechler
#
# @param x positions of hex centres
# @param y positions
# @param vector of hex sizes
# @param border colour
# @param fill colour
# @keyword internal
hexGrob <- function(x, y, size = rep(1, length(x)), colour = "grey50", fill = "grey90") {
stopifnot(length(y) == length(x))
dx <- resolution(x, FALSE)
dy <- resolution(y, FALSE) / sqrt(3) / 2 * 1.15
hexC <- hexcoords(dx, dy, n = 1)
n <- length(x)
polygonGrob(
x = rep.int(hexC$x, n) * rep(size, each = 6) + rep(x, each = 6),
y = rep.int(hexC$y, n) * rep(size, each = 6) + rep(y, each = 6),
default.units = "native",
id.lengths = rep(6, n), gp = gpar(col = colour, fill = fill)
)
}
ggplot2/R/scale-alpha.r 0000644 0001751 0000144 00000002141 12114160774 014405 0 ustar hornik users #' Alpha scales.
#'
#' \code{scale_alpha} is an alias for \code{scale_alpha_continuous} since
#' that is the most common use of alpha, and it saves a bit of typing.
#'
#' @param ... Other arguments passed on to \code{\link{continuous_scale}}
#' or \code{\link{discrete_scale}} as appropriate, to control name, limits,
#' breaks, labels and so forth.
#' @param range range of output alpha values. Should lie between 0 and 1.
#' @export
#' @examples
#' (p <- qplot(mpg, cyl, data = mtcars, alpha = cyl))
#' p + scale_alpha("cylinders")
#' p + scale_alpha("number\nof\ncylinders")
#'
#' p + scale_alpha(range = c(0.4, 0.8))
#'
#' (p <- qplot(mpg, cyl, data=mtcars, alpha = factor(cyl)))
#' p + scale_alpha_discrete(range = c(0.4, 0.8))
scale_alpha <- function(..., range = c(0.1, 1)) {
continuous_scale("alpha", "alpha_c", rescale_pal(range), ...)
}
#' @rdname scale_alpha
#' @export
scale_alpha_continuous <- scale_alpha
#' @rdname scale_alpha
#' @export
scale_alpha_discrete <- function(..., range = c(0.1, 1)) {
discrete_scale("alpha", "alpha_d",
function(n) seq(range[1], range[2], length = n), ...)
}
ggplot2/R/annotation-custom.r 0000644 0001751 0000144 00000005113 12114160774 015717 0 ustar hornik users #' @include geom-.r
NULL
#' Annotation: Custom grob.
#'
#' This is a special geom intended for use as static annnotations
#' that are the same in every panel. These anotations will not
#' affect scales (i.e. the x and y axes will not grow to cover the range
#' of the grob, and the grob will not be modified by any ggplot settings or mappings).
#'
#' Most useful for adding tables, inset plots, and other grid-based decorations.
#'
#' @param grob grob to display
#' @param xmin,xmax x location (in data coordinates) giving horizontal
#' location of raster
#' @param ymin,ymax y location (in data coordinates) giving vertical
#' location of raster
#' @export
#' @note \code{annotation_custom} expects the grob to fill the entire viewport
#' defined by xmin, xmax, ymin, ymax. Grobs with a different (absolute) size
#' will be center-justified in that region.
#' Inf values can be used to fill the full plot panel (see examples).
#' @examples
#' # Dummy plot
#' base <- qplot(1:10, 1:10, geom = "blank") + theme_bw()
#' # Adding a table
#' \donttest{
#' require(gridExtra)
#' base + annotation_custom(grob = tableGrob(head(iris[ ,1:3])),
#' xmin = 3, xmax = 6, ymin = 2, ymax = 8)
#' # full panel
#' base + annotation_custom(grob = roundrectGrob(),
#' xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf)
#' }
#' # Inset plot
#' g <- ggplotGrob(qplot(1, 1) +
#' theme(plot.background = element_rect(colour = "black")))
#' base +
#' annotation_custom(grob = g, xmin = 1, xmax = 10, ymin = 8, ymax = 10)
annotation_custom <- function (grob, xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf) {
GeomCustomAnn$new(geom_params = list(grob = grob, xmin = xmin,
xmax = xmax, ymin = ymin, ymax = ymax), stat = "identity",
position = "identity", data = NULL, inherit.aes = TRUE)
}
GeomCustomAnn <- proto(Geom, {
objname <- "custom_ann"
draw_groups <- function(., data, scales, coordinates, grob, xmin, xmax,
ymin, ymax, ...) {
if (!inherits(coordinates, "cartesian")) {
stop("annotation_custom only works with Cartesian coordinates",
call. = FALSE)
}
corners <- data.frame(x = c(xmin, xmax), y = c(ymin, ymax))
data <- coord_transform(coordinates, corners, scales)
x_rng <- range(data$x, na.rm = TRUE)
y_rng <- range(data$y, na.rm = TRUE)
vp <- viewport(x = mean(x_rng), y = mean(y_rng),
width = diff(x_rng), height = diff(y_rng),
just = c("center","center"))
editGrob(grob, vp = vp)
}
default_aes <- function(.)
aes(xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf)
})
ggplot2/R/guides-grid.r 0000644 0001751 0000144 00000002041 12114160774 014435 0 ustar hornik users # Produce a grob to be used as for panel backgrounds
guide_grid <- function(theme, x.minor, x.major, y.minor, y.major) {
x.minor <- setdiff(x.minor, x.major)
y.minor <- setdiff(y.minor, y.major)
ggname("grill", grobTree(
element_render(theme, "panel.background"),
if(length(y.minor) > 0) element_render(
theme, "panel.grid.minor.y",
x = rep(0:1, length(y.minor)), y = rep(y.minor, each=2),
id.lengths = rep(2, length(y.minor))
),
if(length(x.minor) > 0) element_render(
theme, "panel.grid.minor.x",
x = rep(x.minor, each=2), y = rep(0:1, length(x.minor)),
id.lengths = rep(2, length(x.minor))
),
if(length(y.major) > 0) element_render(
theme, "panel.grid.major.y",
x = rep(0:1, length(y.major)), y = rep(y.major, each=2),
id.lengths = rep(2, length(y.major))
),
if(length(x.major) > 0) element_render(
theme, "panel.grid.major.x",
x = rep(x.major, each=2), y = rep(0:1, length(x.major)),
id.lengths = rep(2, length(x.major))
)
))
}
ggplot2/R/coord-polar.r 0000644 0001751 0000144 00000020151 12114161113 014441 0 ustar hornik users #' Polar coordinates.
#'
#' The polar coordinate system is most commonly used for pie charts, which
#' are a stacked bar chart in polar coordinates.
#'
#' @param theta variable to map angle to (\code{x} or \code{y})
#' @param start offset of starting point from 12 o'clock in radians
#' @param direction 1, clockwise; -1, anticlockwise
#' @export
#' @examples
#' \donttest{
#' # NOTE: Use these plots with caution - polar coordinates has
#' # major perceptual problems. The main point of these examples is
#' # to demonstrate how these common plots can be described in the
#' # grammar. Use with EXTREME caution.
#'
#' # A coxcomb plot = bar chart + polar coordinates
#' cxc <- ggplot(mtcars, aes(x = factor(cyl))) +
#' geom_bar(width = 1, colour = "black")
#' cxc + coord_polar()
#' # A new type of plot?
#' cxc + coord_polar(theta = "y")
#'
#' # A pie chart = stacked bar chart + polar coordinates
#' pie <- ggplot(mtcars, aes(x = factor(1), fill = factor(cyl))) +
#' geom_bar(width = 1)
#' pie + coord_polar(theta = "y")
#'
#' # The bullseye chart
#' pie + coord_polar()
#'
#' # Hadley's favourite pie chart
#' df <- data.frame(
#' variable = c("resembles", "does not resemble"),
#' value = c(80, 20)
#' )
#' ggplot(df, aes(x = "", y = value, fill = variable)) +
#' geom_bar(width = 1, stat = "identity") +
#' scale_fill_manual(values = c("red", "yellow")) +
#' coord_polar("y", start = pi / 3) +
#' labs(title = "Pac man")
#'
#' # Windrose + doughnut plot
#' movies$rrating <- cut_interval(movies$rating, length = 1)
#' movies$budgetq <- cut_number(movies$budget, 4)
#'
#' doh <- ggplot(movies, aes(x = rrating, fill = budgetq))
#'
#' # Wind rose
#' doh + geom_bar(width = 1) + coord_polar()
#' # Race track plot
#' doh + geom_bar(width = 0.9, position = "fill") + coord_polar(theta = "y")
#' }
coord_polar <- function(theta = "x", start = 0, direction = 1) {
theta <- match.arg(theta, c("x", "y"))
r <- if (theta == "x") "y" else "x"
coord(
theta = theta, r = r,
start = start, direction = sign(direction),
subclass = "polar"
)
}
#' @S3method coord_aspect polar
coord_aspect.polar <- function(coord, details) 1
#' @S3method coord_distance polar
coord_distance.polar <- function(coord, x, y, details) {
if (coord$theta == "x") {
r <- rescale(y, from = details$r.range)
theta <- theta_rescale_no_clip(coord, x, details)
} else {
r <- rescale(x, from = details$r.range)
theta <- theta_rescale_no_clip(coord, y, details)
}
dist_polar(r, theta)
}
#' @S3method coord_range polar
coord_range.polar <- function(coord, scales) {
setNames(list(scales$theta.range, scales$r.range), c(coord$theta, coord$r))
}
#' @S3method coord_train polar
coord_train.polar <- function(coord, scales) {
ret <- list(x = list(), y = list())
for (n in c("x", "y")) {
scale <- scales[[n]]
limits <- coord$limits[[n]]
if (is.null(limits)) {
expand <- coord_expand_defaults(coord, scale, n)
range <- scale_dimension(scale, expand)
} else {
range <- range(scale_transform(scale, limits))
}
out <- scale_break_info(scale, range)
ret[[n]]$range <- out$range
ret[[n]]$major <- out$major_source
ret[[n]]$minor <- out$minor_source
ret[[n]]$labels <- out$labels
}
details <- list(
x.range = ret$x$range, y.range = ret$y$range,
x.major = ret$x$major, x.minor = ret$x$minor, x.labels = ret$x$labels,
y.major = ret$y$major, y.minor = ret$y$minor, y.labels = ret$y$labels
)
if (coord$theta == "y") {
names(details) <- gsub("x\\.", "r.", names(details))
names(details) <- gsub("y\\.", "theta.", names(details))
} else {
names(details) <- gsub("x\\.", "theta.", names(details))
names(details) <- gsub("y\\.", "r.", names(details))
}
details
}
rename_data <- function(coord, data) {
if (coord$theta == "y") {
rename(data, c("y" = "theta", "x" = "r"), warn_missing = FALSE)
} else {
rename(data, c("y" = "r", "x" = "theta"), warn_missing = FALSE)
}
}
theta_rescale_no_clip <- function(coord, x, details) {
rotate <- function(x) (x + coord$start) * coord$direction
rotate(rescale(x, c(0, 2 * pi), details$theta.range))
}
theta_rescale <- function(coord, x, details) {
rotate <- function(x) (x + coord$start) %% (2 * pi) * coord$direction
rotate(rescale(x, c(0, 2 * pi), details$theta.range))
}
r_rescale <- function(coord, x, details) {
rescale(x, c(0, 0.4), details$r.range)
}
#' @S3method coord_expand_defaults polar
coord_expand_defaults.polar <- function(coord, scale, aesthetic) {
if (coord$theta == aesthetic) {
expand_default(scale, c(0, 0.5), c(0, 0))
} else {
expand_default(scale, c(0, 0), c(0, 0))
}
}
#' @S3method coord_transform polar
coord_transform.polar <- function(coord, data, details) {
data <- rename_data(coord, data)
data$r <- r_rescale(coord, data$r, details)
data$theta <- theta_rescale(coord, data$theta, details)
data$x <- data$r * sin(data$theta) + 0.5
data$y <- data$r * cos(data$theta) + 0.5
data
}
#' @S3method coord_render_axis_v polar
coord_render_axis_v.polar <- function(coord, details, theme) {
x <- r_rescale(coord,details$r.major, details) + 0.5
guide_axis(x, details$r.labels, "left", theme)
}
#' @S3method coord_render_axis_h polar
coord_render_axis_h.polar <- function(coord, details, theme) {
guide_axis(NA, "", "bottom", theme)
}
#' @S3method coord_render_bg polar
coord_render_bg.polar <- function(coord, details, theme) {
details <- rename_data(coord, details)
theta <- if (length(details$theta.major) > 0) theta_rescale(coord, details$theta.major, details)
thetamin <- if (length(details$theta.minor) > 0) theta_rescale(coord, details$theta.minor, details)
thetafine <- seq(0, 2 * pi, length=100)
r <- 0.4
rfine <- c(r_rescale(coord, details$r.major, details), 0.45)
# This gets the proper theme element for theta and r grid lines:
# panel.grid.major.x or .y
majortheta <- paste("panel.grid.major.", coord$theta, sep = "")
minortheta <- paste("panel.grid.minor.", coord$theta, sep = "")
majorr <- paste("panel.grid.major.", coord$r, sep = "")
ggname("grill", grobTree(
element_render(theme, "panel.background"),
if (length(theta) > 0) element_render(
theme, majortheta, name = "angle",
x = c(rbind(0, 0.45 * sin(theta))) + 0.5,
y = c(rbind(0, 0.45 * cos(theta))) + 0.5,
id.lengths = rep(2, length(theta)),
default.units="native"
),
if (length(thetamin) > 0) element_render(
theme, minortheta, name = "angle",
x = c(rbind(0, 0.45 * sin(thetamin))) + 0.5,
y = c(rbind(0, 0.45 * cos(thetamin))) + 0.5,
id.lengths = rep(2, length(thetamin)),
default.units="native"
),
element_render(
theme, majorr, name = "radius",
x = rep(rfine, each=length(thetafine)) * sin(thetafine) + 0.5,
y = rep(rfine, each=length(thetafine)) * cos(thetafine) + 0.5,
id.lengths = rep(length(thetafine), length(rfine)),
default.units="native"
)
))
}
#' @S3method coord_render_fg polar
coord_render_fg.polar <- function(coord, details, theme) {
if (is.null(details$theta.major)) {
return(element_render(theme, "panel.border"))
}
theta <- theta_rescale(coord, details$theta.major, details)
labels <- details$theta.labels
# Combine the two ends of the scale if they are close
theta <- theta[!is.na(theta)]
ends_apart <- (theta[length(theta)] - theta[1]) %% (2*pi)
if (ends_apart < 0.05) {
n <- length(labels)
if (is.expression(labels)) {
combined <- substitute(paste(a, "/", b),
list(a = labels[[1]], b = labels[[n]]))
} else {
combined <- paste(labels[1], labels[n], sep="/")
}
labels[[n]] <- combined
labels <- labels[-1]
theta <- theta[-1]
}
grobTree(
if (length(labels) > 0) element_render(
theme, "axis.text.x",
labels, 0.45 * sin(theta) + 0.5, 0.45 * cos(theta) + 0.5,
hjust = 0.5, vjust = 0.5,
default.units="native"
),
element_render(theme, "panel.border")
)
}
#' @S3method coord_labels polar
coord_labels.polar <- function(coord, scales) {
if (coord$theta == "y") {
list(x = scales$y, y = scales$x)
} else {
scales
}
}
ggplot2/R/guides-.r 0000644 0001751 0000144 00000022765 12114160774 013606 0 ustar hornik users #' Set guides for each scale.
#'
#' Guides for each scale can be set in call of \code{scale_*} with argument
#' \code{guide}, or in \code{guides}.
#'
#' @param ... List of scale guide pairs
#' @return A list containing the mapping between scale and guide.
#' @export
#' @family guides
#' @examples
#' \donttest{
#' # ggplot object
#'
#' dat <- data.frame(x = 1:5, y = 1:5, p = 1:5, q = factor(1:5),
#' r = factor(1:5))
#' p <- ggplot(dat, aes(x, y, colour = p, size = q, shape = r)) + geom_point()
#'
#' # without guide specification
#' p
#'
#' # Show colorbar guide for colour.
#' # All these examples below have a same effect.
#'
#' p + guides(colour = "colorbar", size = "legend", shape = "legend")
#' p + guides(colour = guide_colorbar(), size = guide_legend(),
#' shape = guide_legend())
#' p +
#' scale_colour_continuous(guide = "colorbar") +
#' scale_size_discrete(guide = "legend") +
#' scale_shape(guide = "legend")
#'
#' # Guides are integrated where possible
#'
#' p + guides(colour = guide_legend("title"), size = guide_legend("title"),
#' shape = guide_legend("title"))
#' # same as
#' g <- guide_legend("title")
#' p + guides(colour = g, size = g, shape = g)
#'
#' p + theme(legend.position = "bottom")
#'
#' # position of guides
#'
#' p + theme(legend.position = "bottom", legend.box = "horizontal")
#'
#' # Set order for multiple guides
#'
#' qplot(data = mpg, x = displ, y = cty, size = hwy, colour = cyl, shape = drv) +
#' guides(colour = guide_colourbar(order = 1),
#' alpha = guide_legend(order = 2),
#' size = guide_legend(order = 3))
#' }
guides <- function(...) {
args <- list(...)
if (is.list(args[[1]]) && !inherits(args[[1]], "guide")) args <- args[[1]]
args <- rename_aes(args)
structure(args, class = "guides")
}
update_guides <- function(p, guides) {
p <- plot_clone(p)
p$guides <- defaults(guides, p$guides)
p
}
# building guides - called in ggplotGrob (plot-render.r)
#
# the procedure is as follows:
#
# 1. guides_train()
# train each scale and generate guide definition for all guides
# here, one gdef for one scale
#
# 2. guides_merge()
# merge gdefs if they are overlayed
# number of gdefs may be less than number of scales
#
# 3. guides_geom()
# process layer information and generate geom info.
#
# 4. guides_gengrob()
# generate ggrob from each gdef
# one ggrob for one gdef
#
# 5. guides_build()
# arrange all ggrobs
build_guides <- function(scales, layers, default_mapping, position, theme, guides, labels) {
# set themes w.r.t. guides
# should these theme$legend.XXX be renamed to theme$guide.XXX ?
# by default, guide boxes are vertically aligned
theme$legend.box <- theme$legend.box %||% "vertical"
# size of key (also used for bar in colorbar guide)
theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size
theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size
# by default, direction of each guide depends on the position of the guide.
theme$legend.direction <-
theme$legend.direction %||%
if (length(position) == 1 && position %in% c("top", "bottom", "left", "right"))
switch(position[1], top =, bottom = "horizontal", left =, right = "vertical")
else
"vertical"
# justification of legend boxes
theme$legend.box.just <-
theme$legend.box.just %||%
if (length(position) == 1 && position %in% c("top", "bottom", "left", "right"))
switch(position, bottom =, top = c("center", "top"), left =, right = c("left", "top"))
else
c("center", "center")
# scales -> data for guides
gdefs <- guides_train(scales = scales, theme = theme, guides = guides, labels = labels)
if (length(gdefs) == 0) return(zeroGrob())
# merge overlay guides
gdefs <- guides_merge(gdefs)
# process layer information
gdefs <- guides_geom(gdefs, layers, default_mapping)
if (length(gdefs) == 0) return(zeroGrob())
# generate grob of each guides
ggrobs <- guides_gengrob(gdefs, theme)
# build up guides
grobs <- guides_build(ggrobs, theme)
grobs
}
# validate guide object
validate_guide <- function(guide) {
# if guide is specified by character, then find the corrsponding guide
if (is.character(guide))
match.fun(paste("guide_", guide, sep=""))()
else if (inherits(guide, "guide"))
guide
else
stop("Unknown guide: ", guide)
}
# train each scale in scales and generate the definition of guide
guides_train <- function(scales, theme, guides, labels) {
gdefs <- list()
for(scale in scales$scales) {
# guides(XXX) is stored in guides[[XXX]],
# which is prior to scale_ZZZ(guide=XXX)
# guide is determined in order of:
# + guides(XXX) > + scale_ZZZ(guide=XXX) > default(i.e., legend)
output <- scale$aesthetics[1]
guide <- guides[[output]] %||% scale$guide
# this should be changed to testing guide == "none"
# scale$legend is backward compatibility
# if guides(XXX=FALSE), then scale_ZZZ(guides=XXX) is discarded.
if (guide=="none" || (is.logical(guide) && !guide)) next
if ((!is.null(scale$legend) && !scale$legend) || is.null(scale_limits(scale))) next # for backward compatibility
# check the validity of guide.
# if guide is character, then find the guide object
guide <- validate_guide(guide)
# check the consistency of the guide and scale.
if (guide$available_aes != "any" && ! scale$aesthetics %in% guide$available_aes)
stop (paste("Guide '", guide$name, "' cannot be used for '", scale$aesthetics, "'.", sep=""))
# title of this grob
if (is.waive(guide$title)) guide$title <- scale$name %||% labels[[output]]
# direction of this grob
guide$direction <- guide$direction %||% theme$legend.direction
# each guide object trains scale within the object,
# so Guides (i.e., the container of guides) need not to know about them
guide <- guide_train(guide, scale)
if (!is.null(guide)) gdefs[[length(gdefs)+1]] <- guide
}
gdefs
}
# merge overlapped guides
guides_merge <- function(gdefs) {
# split gdefs based on hash, and apply Reduce (guide_merge) to each gdef groug.
gdefs <- lapply(gdefs, function(g) {
if (g$order == 0) {
order <- "99"
} else {
order <- sprintf("%02d", g$order)
}
g$hash <- paste(order, g$hash, sep = "_")
g
})
tapply(gdefs, sapply(gdefs, function(g)g$hash), function(gs)Reduce(guide_merge, gs))
}
# process layer information
guides_geom <- function(gdefs, layers, default_mapping) {
compact(lapply(gdefs, guide_geom, layers, default_mapping))
}
# generate grob from each gdef (needs to write this function?)
guides_gengrob <- function(gdefs, theme) {
# common drawing process for all guides
gdefs <- lapply(gdefs,
function(g) {
g$title.position <- g$title.position %||% switch(g$direction, vertical="top", horizontal="left")
if (!g$title.position %in% c("top", "bottom", "left", "right")) stop("title position \"", g$title.position, "\" is invalid")
g
})
lapply(gdefs, guide_gengrob, theme)
}
# build up all guide boxes into one guide-boxes.
guides_build <- function(ggrobs, theme) {
n <- length(ggrobs)
theme$guide.margin <- theme$guide.margin %||% unit(0.5, "lines")
theme$guide.vmargin <- theme$guide.vmargin %||% theme$guide.margin
theme$guide.hmargin <- theme$guide.hmargin %||% theme$guide.margin
widths <- do.call("unit.c", lapply(ggrobs, function(g)sum(g$widths)))
heights <- do.call("unit.c", lapply(ggrobs, function(g)sum(g$heights)))
# Set the justification of each legend within the legend box
# First value is xjust, second value is yjust
just <- valid.just(theme$legend.box.just)
xjust <- just[1]
yjust <- just[2]
# setting that is different for vergical and horizontal guide-boxes.
if (theme$legend.box == "horizontal") {
# Set justification for each legend
for (i in seq_along(ggrobs)) {
ggrobs[[i]] <- editGrob(ggrobs[[i]],
vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust),
height = heightDetails(ggrobs[[i]])))
}
guides <- gtable_row(name = "guides",
grobs = ggrobs,
widths = widths, height = max(heights))
# add space between the guide-boxes
guides <- gtable_add_col_space(guides, theme$guide.hmargin)
} else if (theme$legend.box == "vertical") {
# Set justification for each legend
for (i in seq_along(ggrobs)) {
ggrobs[[i]] <- editGrob(ggrobs[[i]],
vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust),
width = widthDetails(ggrobs[[i]])))
}
guides <- gtable_col(name = "guides",
grobs = ggrobs,
width = max(widths), heights = heights)
# add space between the guide-boxes
guides <- gtable_add_row_space(guides, theme$guide.vmargin)
}
# add margins around the guide-boxes.
guides <- gtable_add_cols(guides, theme$guide.hmargin, pos = 0)
guides <- gtable_add_cols(guides, theme$guide.hmargin, pos = ncol(guides))
guides <- gtable_add_rows(guides, theme$guide.vmargin, pos = 0)
guides <- gtable_add_rows(guides, theme$guide.vmargin, pos = nrow(guides))
guides$name <- "guide-box"
guides
}
# S3 dispatches
#' @S3method guide_train legend
#' @S3method guide_train colorbar
guide_train <- function(...) UseMethod("guide_train")
#' @S3method guide_merge legend
#' @S3method guide_merge colorbar
guide_merge <- function(...) UseMethod("guide_merge")
#' @S3method guide_geom legend
#' @S3method guide_geom colorbar
guide_geom <- function(...) UseMethod("guide_geom")
#' @S3method guide_gengrob legend
#' @S3method guide_gengrob colorbar
guide_gengrob <- function(...) UseMethod("guide_gengrob")
ggplot2/R/geom-path-step.r 0000644 0001751 0000144 00000004051 12114160774 015067 0 ustar hornik users #' Connect observations by stairs.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "step")}
#'
#' @inheritParams geom_point
#' @param direction direction of stairs: 'vh' for vertical then horizontal, or
#' 'hv' for horizontal then vertical
#' @export
#' @examples
#' # Simple quantiles/ECDF from examples(plot)
#' x <- sort(rnorm(47))
#' qplot(seq_along(x), x, geom="step")
#'
#' # Steps go horizontally, then vertically (default)
#' qplot(seq_along(x), x, geom="step", direction = "hv")
#' plot(x, type = "s")
#' # Steps go vertically, then horizontally
#' qplot(seq_along(x), x, geom="step", direction = "vh")
#' plot(x, type = "S")
#'
#' # Also works with other aesthetics
#' df <- data.frame(
#' x = sort(rnorm(50)),
#' trt = sample(c("a", "b"), 50, rep = TRUE)
#' )
#' qplot(seq_along(x), x, data = df, geom="step", colour = trt)
geom_step <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",
direction = "hv", ...) {
GeomStep$new(mapping = mapping, data = data, stat = stat, position = position,
direction = direction, ...)
}
GeomStep <- proto(Geom, {
objname <- "step"
details <- "Equivalent to plot(type='s')."
default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = NA)
draw <- function(., data, scales, coordinates, direction = "hv", ...) {
data <- stairstep(data, direction)
GeomPath$draw(data, scales, coordinates, ...)
}
guide_geom <- function(.) "path"
default_stat <- function(.) StatIdentity
})
# Calculate stairsteps
# Used by \code{\link{geom_step}}
#
# @keyword internal
stairstep <- function(data, direction="hv") {
direction <- match.arg(direction, c("hv", "vh"))
data <- as.data.frame(data)[order(data$x), ]
n <- nrow(data)
if (direction == "vh") {
xs <- rep(1:n, each = 2)[-2*n]
ys <- c(1, rep(2:n, each=2))
} else {
ys <- rep(1:n, each = 2)[-2*n]
xs <- c(1, rep(2:n, each=2))
}
data.frame(
x = data$x[xs],
y = data$y[ys],
data[xs, setdiff(names(data), c("x", "y"))]
)
}
ggplot2/R/limits.r 0000644 0001751 0000144 00000006172 12114160774 013544 0 ustar hornik users #' Convenience functions to set the limits of the x and y axis.
#'
#' Observations not in this range will be dropped completely and
#' not passed to any other layers.
#'
#' @param ... if numeric, will create a continuous scale, if factor or
#' character, will create a discrete scale.
#' @seealso For changing x or y axis limits \strong{without} dropping data
#' observations, see \code{\link{coord_cartesian}}.
#' @rdname xylim
#' @export
#' @examples
#' # xlim
#' xlim(15, 20)
#' xlim(20, 15)
#' xlim(c(10, 20))
#' xlim("a", "b", "c")
#' qplot(mpg, wt, data=mtcars) + xlim(15, 20)
#'
#' # ylim
#' ylim(15, 20)
#' ylim(c(10, 20))
#' ylim("a", "b", "c")
#' qplot(mpg, wt, data=mtcars) + ylim(15, 20)
xlim <- function(...) {
limits(c(...), "x")
}
#' @rdname xylim
#' @export
ylim <- function(...) {
limits(c(...), "y")
}
#' Generate correct scale type for specified limits
#'
#' @param limts vector of limits
#' @param var name of variable
#' @keywords internal
#' @S3method limits numeric
#' @S3method limits character
#' @S3method limits factor
#' @S3method limits Date
#' @S3method limits POSIXct
#' @S3method limits POSIXlt
#' @examples
#' ggplot2:::limits(c(1, 5), "x")
#' ggplot2:::limits(c(5, 1), "x")
#' ggplot2:::limits(c("A", "b", "c"), "x")
#' ggplot2:::limits(c("A", "b", "c"), "fill")
#' ggplot2:::limits(as.Date(c("2008-01-01", "2009-01-01")), "x")
limits <- function(lims, var) UseMethod("limits")
limits.numeric <- function(lims, var) {
stopifnot(length(lims) == 2)
if (lims[1] > lims[2]) {
trans <- "reverse"
} else {
trans <- "identity"
}
make_scale("continuous", var, limits = lims, trans = trans)
}
make_scale <- function(type, var, ...) {
scale <- match.fun(paste("scale_", var, "_", type, sep = ""))
scale(...)
}
limits.character <- function(lims, var) {
make_scale("discrete", var, limits = lims)
}
limits.factor <- function(lims, var) {
make_scale("discrete", var, limits = as.character(lims))
}
limits.Date <- function(lims, var) {
stopifnot(length(lims) == 2)
make_scale("date", var, limits = lims)
}
limits.POSIXct <- function(lims, var) {
stopifnot(length(lims) == 2)
make_scale("datetime", var, limits = lims)
}
limits.POSIXlt <- function(lims, var) {
stopifnot(length(lims) == 2)
make_scale("datetime", var, limits = as.POSIXct(lims))
}
#' Expand the plot limits with data.
#'
#. Sometimes you may want to ensure limits include a single value, for all
#' panels or all plots. This function is a thin wrapper around
#' \code{\link{geom_blank}} that makes it easy to add such values.
#'
#' @param ... named list of aesthetics specifying the value (or values) that
#' should be included in each scale.
#' @export
#' @examples
#' p <- qplot(mpg, wt, data = mtcars)
#' p + expand_limits(x = 0)
#' p + expand_limits(y = c(1, 9))
#' p + expand_limits(x = 0, y = 0)
#'
#' qplot(mpg, wt, data = mtcars, colour = cyl) +
#' expand_limits(colour = seq(2, 10, by = 2))
#' qplot(mpg, wt, data = mtcars, colour = factor(cyl)) +
#' expand_limits(colour = factor(seq(2, 10, by = 2)))
expand_limits <- function(...) {
data <- data.frame(...)
geom_blank(aes_all(names(data)), data, inherit.aes = FALSE)
}
ggplot2/R/stat-summary-2d.r 0000644 0001751 0000144 00000007165 12114160774 015217 0 ustar hornik users #' Apply function for 2D rectangular bins.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "summary2d")}
#'
#' \code{stat_summary2d} is 2D version of \code{\link{stat_summary}}. The data are devided by \code{x} and \code{y}.
#' \code{z} in each cell is passed to arbitral summary function.
#'
#' \code{stat_summary2d} requires the following aesthetics:
#'
#' \itemize{
#' \item \code{x}: horizontal position
#' \item \code{y}: vertical position
#' \item \code{z}: value passed to the summary function
#' }
#'
#' @seealso \code{\link{stat_summary_hex}} for hexagonal summarization. \code{\link{stat_bin2d}} for the binning options.
#' @title Apply funciton for 2D rectangular bins.
#' @inheritParams stat_identity
#' @param bins see \code{\link{stat_bin2d}}
#' @param drop drop if the output of \code{fun} is \code{NA}.
#' @param fun function for summary.
#' @param ... parameters passed to \code{fun}
#' @export
#' @examples
#' \donttest{
#' d <- ggplot(diamonds, aes(carat, depth, z = price))
#' d + stat_summary2d()
#'
#' # Specifying function
#' d + stat_summary2d(fun = function(x) sum(x^2))
#' d + stat_summary2d(fun = var)
#' }
stat_summary2d <- function (mapping = NULL, data = NULL, geom = NULL, position = "identity",
bins = 30, drop = TRUE, fun = mean, ...) {
StatSummary2d$new(mapping = mapping, data = data, geom = geom, position = position,
bins = bins, drop = drop, fun = fun, ...)
}
StatSummary2d <- proto(Stat, {
objname <- "Summary2d"
default_aes <- function(.) aes(fill = ..value..)
required_aes <- c("x", "y", "z")
default_geom <- function(.) GeomRect
calculate <- function(., data, scales, binwidth = NULL, bins = 30, breaks = NULL, origin = NULL, drop = TRUE, fun = mean, ...) {
data <- remove_missing(data, FALSE, c("x", "y", "z"), name="stat_summary2d")
range <- list(
x = scale_dimension(scales$x, c(0, 0)),
y = scale_dimension(scales$y, c(0, 0))
)
# Determine origin, if omitted
if (is.null(origin)) {
origin <- c(NA, NA)
} else {
stopifnot(is.numeric(origin))
stopifnot(length(origin) == 2)
}
originf <- function(x) if (is.integer(x)) -0.5 else min(x)
if (is.na(origin[1])) origin[1] <- originf(data$x)
if (is.na(origin[2])) origin[2] <- originf(data$y)
# Determine binwidth, if omitted
if (is.null(binwidth)) {
binwidth <- c(NA, NA)
if (is.integer(data$x)) {
binwidth[1] <- 1
} else {
binwidth[1] <- diff(range$x) / bins
}
if (is.integer(data$y)) {
binwidth[2] <- 1
} else {
binwidth[2] <- diff(range$y) / bins
}
}
stopifnot(is.numeric(binwidth))
stopifnot(length(binwidth) == 2)
# Determine breaks, if omitted
if (is.null(breaks)) {
breaks <- list(
seq(origin[1], max(range$x) + binwidth[1], binwidth[1]),
seq(origin[2], max(range$y) + binwidth[2], binwidth[2])
)
} else {
stopifnot(is.list(breaks))
stopifnot(length(breaks) == 2)
stopifnot(all(sapply(breaks, is.numeric)))
}
names(breaks) <- c("x", "y")
xbin <- cut(data$x, sort(breaks$x), include.lowest=TRUE)
ybin <- cut(data$y, sort(breaks$y), include.lowest=TRUE)
if (is.null(data$weight)) data$weight <- 1
ans <- ddply(data.frame(data, xbin, ybin), .(xbin, ybin), function(d) data.frame(value = fun(d$z, ...)))
if (drop) ans <- na.omit(ans)
within(ans,{
xint <- as.numeric(xbin)
xmin <- breaks$x[xint]
xmax <- breaks$x[xint + 1]
yint <- as.numeric(ybin)
ymin <- breaks$y[yint]
ymax <- breaks$y[yint + 1]
})
}
})
ggplot2/R/scale-datetime.r 0000644 0001751 0000144 00000006442 12114160774 015124 0 ustar hornik users #' Position scale, date
#'
#' @rdname scale_datetime
#' @family position scales
#' @inheritParams scale_x_continuous
#' @param breaks A vector of breaks, a function that given the scale limits
#' returns a vector of breaks, or a character vector, specifying the width
#' between breaks. For more information about the first two, see
#' \code{\link{continuous_scale}}, for more information about the last,
#' see \code{\link[scales]{date_breaks}}`.
#' @param minor_breaks Either \code{NULL} for no minor breaks, \code{waiver()}
#' for the default breaks (one minor break between each major break), a
#' numeric vector of positions, or a function that given the limits returns
#' a vector of minor breaks.
#' @export
#' @examples
#' start <- ISOdate(2001, 1, 1, tz = "")
#' df <- data.frame(
#' day30 = start + round(runif(100, max = 30 * 86400)),
#' day7 = start + round(runif(100, max = 7 * 86400)),
#' day = start + round(runif(100, max = 86400)),
#' hour10 = start + round(runif(100, max = 10 * 3600)),
#' hour5 = start + round(runif(100, max = 5 * 3600)),
#' hour = start + round(runif(100, max = 3600)),
#' min10 = start + round(runif(100, max = 10 * 60)),
#' min5 = start + round(runif(100, max = 5 * 60)),
#' min = start + round(runif(100, max = 60)),
#' sec10 = start + round(runif(100, max = 10)),
#' y = runif(100)
#' )
#'
#' # Automatic scale selection
#' qplot(sec10, y, data = df)
#' qplot(min, y, data = df)
#' qplot(min5, y, data = df)
#' qplot(min10, y, data = df)
#' qplot(hour, y, data = df)
#' qplot(hour5, y, data = df)
#' qplot(hour10, y, data = df)
#' qplot(day, y, data = df)
#' qplot(day30, y, data = df)
#'
#' # Manual scale selection
#' qplot(day30, y, data = df)
#' library(scales) # to access breaks/formatting functions
#' last_plot() + scale_x_datetime(breaks = date_breaks("2 weeks"))
#' last_plot() + scale_x_datetime(breaks = date_breaks("10 days"))
#' library(scales) # to access breaks/formatting functions
#' last_plot() + scale_x_datetime(breaks = date_breaks("10 days"),
#' labels = date_format("%d/%m"))
#' last_plot() + scale_x_datetime(breaks = date_breaks("1 day"),
#' minor_breaks = date_breaks("2 hour"))
scale_x_datetime <- function(..., expand = waiver(), breaks = pretty_breaks(),
minor_breaks = waiver()) {
scale_datetime(c("x", "xmin", "xmax", "xend"), expand = expand,
breaks = breaks, minor_breaks = minor_breaks, ...)
}
#' @S3method scale_map datetime
scale_map.datetime <- function(scale, x, limits = scale_limits(scale)) {
x
}
#' @rdname scale_datetime
#' @export
scale_y_datetime <- function(..., expand = waiver(), breaks = pretty_breaks(),
minor_breaks = waiver()) {
scale_datetime(c("y", "ymin", "ymax", "yend"), expand = expand,
breaks = breaks, minor_breaks = minor_breaks, ...)
}
# base class for scale_{xy}_datetime
scale_datetime <- function(aesthetics, expand = waiver(), breaks = pretty_breaks(),
minor_breaks = waiver(), ...) {
if (is.character(breaks)) {
breaks_str <- breaks
breaks <- date_breaks(breaks_str)
}
if (is.character(minor_breaks)) {
mbreaks_str <- minor_breaks
minor_breaks <- date_breaks(mbreaks_str)
}
continuous_scale(aesthetics, "datetime", identity, breaks = breaks,
minor_breaks = minor_breaks, guide = "none", expand = expand,
trans = "time", ...)
}
ggplot2/R/scale-manual.r 0000644 0001751 0000144 00000005135 12114160774 014603 0 ustar hornik users #' Create your own discrete scale.
#'
#' @name scale_manual
#' @inheritParams scale_x_discrete
#' @param values a set of aesthetic values to map data values to. If this
#' is a named vector, then the values will be matched based on the names.
#' If unnamed, values will be matched in order (usually alphabetical) with
#' the limits of the scale. Any data values that don't match will be
#' given \code{na.value}.
#' @examples
#' \donttest{
#' p <- qplot(mpg, wt, data = mtcars, colour = factor(cyl))
#'
#' p + scale_colour_manual(values = c("red","blue", "green"))
#' p + scale_colour_manual(
#' values = c("8" = "red","4" = "blue","6" = "green"))
#' # With rgb hex values
#' p + scale_colour_manual(values = c("#FF0000", "#0000FF", "#00FF00"))
#'
#' # As with other scales you can use breaks to control the appearance
#' # of the legend
#' cols <- c("8" = "red","4" = "blue","6" = "darkgreen", "10" = "orange")
#' p + scale_colour_manual(values = cols)
#' p + scale_colour_manual(values = cols, breaks = c("4", "6", "8"))
#' p + scale_colour_manual(values = cols, breaks = c("8", "6", "4"))
#' p + scale_colour_manual(values = cols, breaks = c("4", "6", "8"),
#' labels = c("four", "six", "eight"))
#'
#' # And limits to control the possible values of the scale
#' p + scale_colour_manual(values = cols, limits = c("4", "8"))
#' p + scale_colour_manual(values = cols, limits = c("4", "6", "8", "10"))
#'
#' # Notice that the values are matched with limits, and not breaks
#' p + scale_colour_manual(limits = c(6, 8, 4), breaks = c(8, 4, 6),
#' values = c("grey50", "grey80", "black"))
#' }
NULL
#' @rdname scale_manual
#' @export
scale_colour_manual <- function(..., values) {
manual_scale("colour", values, ...)
}
#' @rdname scale_manual
#' @export
scale_fill_manual <- function(..., values) {
manual_scale("fill", values, ...)
}
#' @rdname scale_manual
#' @export
scale_size_manual <- function(..., values) {
manual_scale("size", values, ...)
}
#' @rdname scale_manual
#' @export
scale_shape_manual <- function(..., values) {
manual_scale("shape", values, ...)
}
#' @rdname scale_manual
#' @export
scale_linetype_manual <- function(..., values) {
manual_scale("linetype", values, ...)
}
#' @rdname scale_manual
#' @export
scale_alpha_manual <- function(..., values) {
manual_scale("alpha", values, ...)
}
manual_scale <- function(aesthetic, values, ...) {
pal <- function(n) {
if (n > length(values)) {
stop("Insufficient values in manual scale. ", n, " needed but only ",
length(values), " provided.", call. = FALSE)
}
values
}
discrete_scale(aesthetic, "manual", pal, ...)
}
ggplot2/R/geom-path-.r 0000644 0001751 0000144 00000016744 12114160774 014207 0 ustar hornik users #' Connect observations in original order
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "path")}
#'
#' @inheritParams geom_point
#' @param lineend Line end style (round, butt, square)
#' @param linejoin Line join style (round, mitre, bevel)
#' @param linemitre Line mitre limit (number greater than 1)
#' @param arrow Arrow specification, as created by ?grid::arrow
#' @seealso \code{\link{geom_line}}: Functional (ordered) lines;
#' \code{\link{geom_polygon}}: Filled paths (polygons);
#' \code{\link{geom_segment}}: Line segments
#' @export
#' @examples
#' \donttest{
#' # Generate data
#' library(plyr)
#' myear <- ddply(movies, .(year), colwise(mean, .(length, rating)))
#' p <- ggplot(myear, aes(length, rating))
#' p + geom_path()
#'
#' # Add aesthetic mappings
#' p + geom_path(aes(size = year))
#' p + geom_path(aes(colour = year))
#'
#' # Change scale
#' p + geom_path(aes(size = year)) + scale_size(range = c(1, 3))
#'
#' # Set aesthetics to fixed value
#' p + geom_path(colour = "green")
#'
#' # Control line join parameters
#' df <- data.frame(x = 1:3, y = c(4, 1, 9))
#' base <- ggplot(df, aes(x, y))
#' base + geom_path(size = 10)
#' base + geom_path(size = 10, lineend = "round")
#' base + geom_path(size = 10, linejoin = "mitre", lineend = "butt")
#'
#' # Use qplot instead
#' qplot(length, rating, data=myear, geom="path")
#'
#' # Using economic data:
#' # How is unemployment and personal savings rate related?
#' qplot(unemploy/pop, psavert, data=economics)
#' qplot(unemploy/pop, psavert, data=economics, geom="path")
#' qplot(unemploy/pop, psavert, data=economics, geom="path", size=as.numeric(date))
#'
#' # How is rate of unemployment and length of unemployment?
#' qplot(unemploy/pop, uempmed, data=economics)
#' qplot(unemploy/pop, uempmed, data=economics, geom="path")
#' qplot(unemploy/pop, uempmed, data=economics, geom="path") +
#' geom_point(data=head(economics, 1), colour="red") +
#' geom_point(data=tail(economics, 1), colour="blue")
#' qplot(unemploy/pop, uempmed, data=economics, geom="path") +
#' geom_text(data=head(economics, 1), label="1967", colour="blue") +
#' geom_text(data=tail(economics, 1), label="2007", colour="blue")
#'
#' # geom_path removes missing values on the ends of a line.
#' # use na.rm = T to suppress the warning message
#' df <- data.frame(
#' x = 1:5,
#' y1 = c(1, 2, 3, 4, NA),
#' y2 = c(NA, 2, 3, 4, 5),
#' y3 = c(1, 2, NA, 4, 5),
#' y4 = c(1, 2, 3, 4, 5))
#' qplot(x, y1, data = df, geom = c("point","line"))
#' qplot(x, y2, data = df, geom = c("point","line"))
#' qplot(x, y3, data = df, geom = c("point","line"))
#' qplot(x, y4, data = df, geom = c("point","line"))
#'
#' # Setting line type vs colour/size
#' # Line type needs to be applied to a line as a whole, so it can
#' # not be used with colour or size that vary across a line
#'
#' x <- seq(0.01, .99, length=100)
#' df <- data.frame(x = rep(x, 2), y = c(qlogis(x), 2 * qlogis(x)), group = rep(c("a","b"), each=100))
#' p <- ggplot(df, aes(x=x, y=y, group=group))
#'
#' # Should work
#' p + geom_line(linetype = 2)
#' p + geom_line(aes(colour = group), linetype = 2)
#' p + geom_line(aes(colour = x))
#'
#' # Should fail
#' should_stop(p + geom_line(aes(colour = x), linetype=2))
#'
#' # Use the arrow parameter to add an arrow to the line
#' # See ?grid::arrow for more details
#' library(grid)
#' c <- ggplot(economics, aes(x = date, y = pop))
#' # Arrow defaults to "last"
#' c + geom_path(arrow = arrow())
#' c + geom_path(arrow = arrow(angle = 15, ends = "both", length = unit(0.6, "inches")))
#' }
geom_path <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",
lineend = "butt", linejoin = "round", linemitre = 1, na.rm = FALSE, arrow = NULL, ...) {
GeomPath$new(mapping = mapping, data = data, stat = stat, position = position,
lineend = lineend, linejoin = linejoin, linemitre = linemitre, na.rm = na.rm, arrow = arrow, ...)
}
GeomPath <- proto(Geom, {
objname <- "path"
draw_groups <- function(., ...) .$draw(...)
draw <- function(., data, scales, coordinates, arrow = NULL, lineend = "butt", linejoin = "round", linemitre = 1, ..., na.rm = FALSE) {
if (!anyDuplicated(data$group)) {
message("geom_path: Each group consist of only one observation. Do you need to adjust the group aesthetic?")
}
keep <- function(x) {
# from first non-missing to last non-missing
first <- match(FALSE, x, nomatch = 1) - 1
last <- length(x) - match(FALSE, rev(x), nomatch = 1) + 1
c(
rep(FALSE, first),
rep(TRUE, last - first),
rep(FALSE, length(x) - last))
}
# Drop missing values at the start or end of a line - can't drop in the
# middle since you expect those to be shown by a break in the line
missing <- !complete.cases(data[c("x", "y", "size", "colour",
"linetype")])
kept <- ave(missing, data$group, FUN=keep)
data <- data[kept, ]
# must be sorted on group
data <- arrange(data, group)
if (!all(kept) && !na.rm) {
warning("Removed ", sum(!kept), " rows containing missing values",
" (geom_path).", call. = FALSE)
}
munched <- coord_munch(coordinates, data, scales)
# Silently drop lines with less than two points, preserving order
rows <- ave(seq_len(nrow(munched)), munched$group, FUN = length)
munched <- munched[rows >= 2, ]
if (nrow(munched) < 2) return(zeroGrob())
# Work out whether we should use lines or segments
attr <- ddply(munched, .(group), function(df) {
data.frame(
solid = identical(unique(df$linetype), 1),
constant = nrow(unique(df[, c("alpha", "colour","size", "linetype")])) == 1
)
})
solid_lines <- all(attr$solid)
constant <- all(attr$constant)
if (!solid_lines && !constant) {
stop("geom_path: If you are using dotted or dashed lines",
", colour, size and linetype must be constant over the line",
call.=FALSE)
}
# Work out grouping variables for grobs
n <- nrow(munched)
group_diff <- munched$group[-1] != munched$group[-n]
start <- c(TRUE, group_diff)
end <- c(group_diff, TRUE)
if (!constant) {
with(munched,
segmentsGrob(
x[!end], y[!end], x[!start], y[!start],
default.units="native", arrow = arrow,
gp = gpar(
col = alpha(colour, alpha)[!end], fill = alpha(colour, alpha)[!end],
lwd = size[!end] * .pt, lty = linetype[!end],
lineend = lineend, linejoin = linejoin, linemitre = linemitre
)
)
)
} else {
id <- match(munched$group, unique(munched$group))
with(munched,
polylineGrob(
x, y, id = id,
default.units = "native", arrow = arrow,
gp = gpar(
col = alpha(colour, alpha)[start], fill = alpha(colour, alpha)[start],
lwd = size[start] * .pt, lty = linetype[start],
lineend = lineend, linejoin = linejoin, linemitre = linemitre)
)
)
}
}
draw_legend <- function(., data, ...) {
data$arrow <- NULL
data <- aesdefaults(data, .$default_aes(), list(...))
with(data,
ggname(.$my_name(), segmentsGrob(0.1, 0.5, 0.9, 0.5, default.units="npc",
gp=gpar(col=alpha(colour, alpha), lwd=size * .pt,
lty=linetype, lineend="butt")))
)
}
default_stat <- function(.) StatIdentity
required_aes <- c("x", "y")
default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = NA)
guide_geom <- function(.) "path"
})
ggplot2/R/stat-density-2d.r 0000644 0001751 0000144 00000006342 12114160774 015175 0 ustar hornik users #' 2d density estimation.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "density2d")}
#'
#' @param contour If \code{TRUE}, contour the results of the 2d density
#' estimation
#' @param n number of grid points in each direction
#' @param ... other arguments passed on to \code{\link{kde2d}}
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @inheritParams stat_identity
#' @return A data frame in the same format as \code{\link{stat_contour}}
#' @importFrom MASS kde2d
#' @export
#' @examples
#' \donttest{
#' library("MASS")
#' data(geyser, "MASS")
#'
#' m <- ggplot(geyser, aes(x = duration, y = waiting)) +
#' geom_point() + xlim(0.5, 6) + ylim(40, 110)
#' m + geom_density2d()
#'
#' dens <- kde2d(geyser$duration, geyser$waiting, n = 50,
#' lims = c(0.5, 6, 40, 110))
#' densdf <- data.frame(expand.grid(duration = dens$x, waiting = dens$y),
#' z = as.vector(dens$z))
#' m + geom_contour(aes(z=z), data=densdf)
#'
#' m + geom_density2d() + scale_y_log10()
#' m + geom_density2d() + coord_trans(y="log10")
#'
#' m + stat_density2d(aes(fill = ..level..), geom="polygon")
#'
#' qplot(duration, waiting, data=geyser, geom=c("point","density2d")) +
#' xlim(0.5, 6) + ylim(40, 110)
#'
#' # If you map an aesthetic to a categorical variable, you will get a
#' # set of contours for each value of that variable
#' set.seed(4393)
#' dsmall <- diamonds[sample(nrow(diamonds), 1000), ]
#' qplot(x, y, data = dsmall, geom = "density2d", colour = cut)
#' qplot(x, y, data = dsmall, geom = "density2d", linetype = cut)
#' qplot(carat, price, data = dsmall, geom = "density2d", colour = cut)
#' d <- ggplot(dsmall, aes(carat, price)) + xlim(1,3)
#' d + geom_point() + geom_density2d()
#'
#' # If we turn contouring off, we can use use geoms like tiles:
#' d + stat_density2d(geom="tile", aes(fill = ..density..), contour = FALSE)
#' last_plot() + scale_fill_gradient(limits=c(1e-5,8e-4))
#'
#' # Or points:
#' d + stat_density2d(geom="point", aes(size = ..density..), contour = FALSE)
#' }
stat_density2d <- function (mapping = NULL, data = NULL, geom = "density2d", position = "identity",
na.rm = FALSE, contour = TRUE, n = 100, ...) {
StatDensity2d$new(mapping = mapping, data = data, geom = geom,
position = position, na.rm = na.rm, contour = contour, n = n, ...)
}
StatDensity2d <- proto(Stat, {
objname <- "density2d"
default_geom <- function(.) GeomDensity2d
default_aes <- function(.) aes(colour = "#3366FF", size = 0.5)
required_aes <- c("x", "y")
calculate <- function(., data, scales, na.rm = FALSE, contour = TRUE, n = 100, ...) {
df <- data.frame(data[, c("x", "y")])
df <- remove_missing(df, na.rm, name = "stat_density2d", finite = TRUE)
dens <- safe.call(kde2d, list(x = df$x, y = df$y, n = n,
lims = c(scale_dimension(scales$x), scale_dimension(scales$y)), ...))
df <- with(dens, data.frame(expand.grid(x = x, y = y), z = as.vector(z)))
df$group <- data$group[1]
if (contour) {
StatContour$calculate(df, scales, ...)
} else {
names(df) <- c("x", "y", "density", "group")
df$level <- 1
df$piece <- 1
df
}
}
})
ggplot2/R/geom-.r 0000644 0001751 0000144 00000002573 12114160774 013250 0 ustar hornik users Geom <- proto(TopLevel, expr={
class <- function(.) "geom"
parameters <- function(.) {
params <- formals(get("draw", .))
params <- params[setdiff(names(params), c(".","data","scales", "coordinates", "..."))]
required <- rep(NA, length(.$required_aes))
names(required) <- .$required_aes
aesthetics <- c(.$default_aes(), required)
c(params, aesthetics[setdiff(names(aesthetics), names(params))])
}
required_aes <- c()
default_aes <- function(.) {}
default_pos <- function(.) PositionIdentity
guide_geom <- function(.) "point"
draw <- function(...) {}
draw_groups <- function(., data, scales, coordinates, ...) {
if (empty(data)) return(zeroGrob())
groups <- split(data, factor(data$group))
grobs <- lapply(groups, function(group) .$draw(group, scales, coordinates, ...))
ggname(paste(.$objname, "s", sep=""), gTree(
children = do.call("gList", grobs)
))
}
new <- function(., mapping=NULL, data=NULL, stat=NULL, position=NULL, ...){
do.call("layer", list(mapping=mapping, data=data, stat=stat, geom=., position=position, ...))
}
pprint <- function(., newline=TRUE) {
cat("geom_", .$objname, ": ", sep="") # , clist(.$parameters())
if (newline) cat("\n")
}
reparameterise <- function(., data, params) data
# Html documentation ----------------------------------
})
ggplot2/R/quick-plot.r 0000644 0001751 0000144 00000013107 12114161113 014313 0 ustar hornik users #' Quick plot
#'
#' \code{qplot} is the basic plotting function in the ggplot2 package,
#' designed to be familiar if you're used to \code{\link{plot}}
#' from the base package. It is a convenient wrapper for creating
#' a number of different types of plots using a consistent
#' calling scheme. See \url{http://had.co.nz/ggplot2/book/qplot.pdf}
#' for the chapter in the \code{ggplot2} book which describes the usage
#' of \code{qplot} in detail.
#'
#' @param x x values
#' @param y y values
#' @param ... other aesthetics passed for each layer
#' @param data data frame to use (optional). If not specified, will create
#' one, extracting vectors from the current environment.
#' @param facets faceting formula to use. Picks \code{\link{facet_wrap}} or
#' \code{\link{facet_grid}} depending on whether the formula is one sided
#' or two-sided
#' @param margins whether or not margins will be displayed
#' @param geom character vector specifying geom to use. Defaults to
#' "point" if x and y are specified, and "histogram" if only x is specified.
#' @param stat character vector specifying statistics to use
#' @param position character vector giving position adjustment to use
#' @param xlim limits for x axis
#' @param ylim limits for y axis
#' @param log which variables to log transform ("x", "y", or "xy")
#' @param main character vector or expression for plot title
#' @param xlab character vector or expression for x axis label
#' @param ylab character vector or expression for y axis label
#' @param asp the y/x aspect ratio
#' @aliases qplot quickplot
#' @export qplot quickplot
#' @examples
#' \donttest{
#' # Use data from data.frame
#' qplot(mpg, wt, data=mtcars)
#' qplot(mpg, wt, data=mtcars, colour=cyl)
#' qplot(mpg, wt, data=mtcars, size=cyl)
#' qplot(mpg, wt, data=mtcars, facets=vs ~ am)
#'
#' # It will use data from local environment
#' hp <- mtcars$hp
#' wt <- mtcars$wt
#' cyl <- mtcars$cyl
#' vs <- mtcars$vs
#' am <- mtcars$am
#' qplot(hp, wt)
#' qplot(hp, wt, colour=cyl)
#' qplot(hp, wt, size=cyl)
#' qplot(hp, wt, facets=vs ~ am)
#'
#' qplot(1:10, rnorm(10), colour = runif(10))
#' qplot(1:10, letters[1:10])
#' mod <- lm(mpg ~ wt, data=mtcars)
#' qplot(resid(mod), fitted(mod))
#' qplot(resid(mod), fitted(mod), facets = . ~ vs)
#'
#' f <- function() {
#' a <- 1:10
#' b <- a ^ 2
#' qplot(a, b)
#' }
#' f()
#'
#' # qplot will attempt to guess what geom you want depending on the input
#' # both x and y supplied = scatterplot
#' qplot(mpg, wt, data = mtcars)
#' # just x supplied = histogram
#' qplot(mpg, data = mtcars)
#' # just y supplied = scatterplot, with x = seq_along(y)
#' qplot(y = mpg, data = mtcars)
#'
#' # Use different geoms
#' qplot(mpg, wt, data = mtcars, geom="path")
#' qplot(factor(cyl), wt, data = mtcars, geom=c("boxplot", "jitter"))
#' }
qplot <- function(x, y = NULL, ..., data, facets = NULL, margins=FALSE, geom = "auto", stat=list(NULL), position=list(NULL), xlim = c(NA, NA), ylim = c(NA, NA), log = "", main = NULL, xlab = deparse(substitute(x)), ylab = deparse(substitute(y)), asp = NA) {
argnames <- names(as.list(match.call(expand.dots=FALSE)[-1]))
arguments <- as.list(match.call()[-1])
aesthetics <- compact(arguments[.all_aesthetics])
aesthetics <- aesthetics[!is.constant(aesthetics)]
aes_names <- names(aesthetics)
aesthetics <- rename_aes(aesthetics)
class(aesthetics) <- "uneval"
if (missing(data)) {
# If data not explicitly specified, will be pulled from workspace
data <- data.frame()
# Faceting variables must be in a data frame, so pull those out
facetvars <- all.vars(facets)
facetvars <- facetvars[facetvars != "."]
names(facetvars) <- facetvars
facetsdf <- as.data.frame(lapply(facetvars, get))
if (nrow(facetsdf)) data <- facetsdf
}
# Work out plot data, and modify aesthetics, if necessary
if ("auto" %in% geom) {
if (stat == "qq" || "sample" %in% aes_names) {
geom[geom == "auto"] <- "point"
stat <- "qq"
} else if (missing(y)) {
geom[geom == "auto"] <- "histogram"
if (is.null(ylab)) ylab <- "count"
} else {
if (missing(x)) {
aesthetics$x <- bquote(seq_along(.(y)), aesthetics)
}
geom[geom == "auto"] <- "point"
}
}
env <- parent.frame()
p <- ggplot(data, aesthetics, environment = env)
if (is.null(facets)) {
p <- p + facet_null()
} else if (is.formula(facets) && length(facets) == 2) {
p <- p + facet_wrap(facets)
} else {
p <- p + facet_grid(facets = deparse(facets), margins = margins)
}
if (!is.null(main)) p <- p + ggtitle(main)
# Add geoms/statistics
if (is.proto(position)) position <- list(position)
mapply(function(g, s, ps) {
if(is.character(g)) g <- Geom$find(g)
if(is.character(s)) s <- Stat$find(s)
if(is.character(ps)) ps <- Position$find(ps)
# Have to use non-standard evaluation because we can't evaluate ...
params <- arguments[setdiff(names(arguments), c(aes_names, argnames))]
# 1: mapply, 2: qplot, 3: caller of qplot
params <- lapply(params, eval, parent.frame(3))
p <<- p + layer(geom=g, stat=s, geom_params=params, stat_params=params, position=ps)
}, geom, stat, position)
logv <- function(var) var %in% strsplit(log, "")[[1]]
if (logv("x")) p <- p + scale_x_log10()
if (logv("y")) p <- p + scale_y_log10()
if (!is.na(asp)) p <- p + theme(aspect.ratio = asp)
if (!missing(xlab)) p <- p + xlab(xlab)
if (!missing(ylab)) p <- p + ylab(ylab)
if (!missing(xlim)) p <- p + xlim(xlim)
if (!missing(ylim)) p <- p + ylim(ylim)
p
}
quickplot <- qplot
# is.constant
is.constant <- function(x) {
sapply(x, function(x) "I" %in% all.names(asOneSidedFormula(x)))
}
ggplot2/R/geom-path-contour.r 0000644 0001751 0000144 00000001560 12114160774 015607 0 ustar hornik users #' Display contours of a 3d surface in 2d.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "contour")}
#'
#' @inheritParams geom_point
#' @inheritParams geom_path
#' @seealso \code{\link{geom_density2d}}: 2d density contours
#' @export
#' @examples
#' # See stat_contour for examples
geom_contour <- function (mapping = NULL, data = NULL, stat = "contour", position = "identity",
lineend = "butt", linejoin = "round", linemitre = 1, na.rm = FALSE, ...) {
GeomContour$new(mapping = mapping, data = data, stat = stat, position = position,
lineend = lineend, linejoin = linejoin, linemitre = linemitre, na.rm = na.rm, ...)
}
GeomContour <- proto(GeomPath, {
objname <- "contour"
default_aes <- function(.) aes(weight=1, colour="#3366FF", size = 0.5, linetype = 1, alpha = NA)
default_stat <- function(.) StatContour
})
ggplot2/R/ggplot2.r 0000644 0001751 0000144 00000016770 12114160774 013626 0 ustar hornik users #' ggplot2.
#'
#' @name ggplot2
#' @docType package
#' @import plyr digest scales grid reshape2 proto gtable
NULL
#' Prices of 50,000 round cut diamonds
#'
#' A dataset containing the prices and other attributes of almost 54,000
#' diamonds. The variables are as follows:
#'
#' \itemize{
#' \item price. price in US dollars (\$326--\$18,823)
#' \item carat. weight of the diamond (0.2--5.01)
#' \item cut. quality of the cut (Fair, Good, Very Good, Premium, Ideal)
#' \item colour. diamond colour, from J (worst) to D (best)
#' \item clarity. a measurement of how clear the diamond is (I1 (worst), SI1, SI2, VS1, VS2, VVS1, VVS2, IF (best))
#' \item x. length in mm (0--10.74)
#' \item y. width in mm (0--58.9)
#' \item z. depth in mm (0--31.8)
#' \item depth. total depth percentage = z / mean(x, y) = 2 * z / (x + y) (43--79)
#' \item table. width of top of diamond relative to widest point (43--95)
#' }
#'
#' @docType data
#' @keywords datasets
#' @name diamonds
#' @usage data(diamonds)
#' @format A data frame with 53940 rows and 10 variables
NULL
#' US economic time series.
#'
#' This dataset was produced from US economic time series data available from \url{http://research.stlouisfed.org/fred2}.
#'
#' \itemize{
#' \item date. Month of data collection
#'
#' \item psavert, personal savings rate, \url{http://research.stlouisfed.org/fred2/series/PSAVERT/}
#' \item pce, personal consumption expenditures, in billions of dollars, \url{http://research.stlouisfed.org/fred2/series/PCE}
#' \item unemploy, number of unemployed in thousands, \url{http://research.stlouisfed.org/fred2/series/UNEMPLOY}
#' \item uempmed, median duration of unemployment, in week, \url{http://research.stlouisfed.org/fred2/series/UEMPMED}
#' \item pop, total population, in thousands, \url{http://research.stlouisfed.org/fred2/series/POP}
#'
#' }
#'
#' @docType data
#' @keywords datasets
#' @name economics
#' @usage data(economics)
#' @format A data frame with 478 rows and 6 variables
NULL
#' Midwest demographics.
#'
#' Demographic information of midwest counties
#'
#' The variables are as follows:
#'
#' \itemize{
#' \item PID
#' \item county
#' \item state
#' \item area
#' \item poptotal. Total population
#' \item popdensity. Population density
#' \item popwhite. Number of whites.
#' \item popblack. Number of blacks.
#' \item popamerindian. Number of American Indians.
#' \item popasian. Number of Asians.
#' \item popother. Number of other races.
#' \item percwhite. Percent white.
#' \item percblack. Percent black.
#' \item percamerindan. Percent American Indian.
#' \item percasian. Percent Asian.
#' \item percother. Percent other races.
#' \item popadults. Number of adults.
#' \item perchsd.
#' \item percollege. Percent college educated.
#' \item percprof. Percent profession.
#' \item poppovertyknown.
#' \item percpovertyknown
#' \item percbelowpoverty
#' \item percchildbelowpovert
#' \item percadultpoverty
#' \item percelderlypoverty
#' \item inmetro. In a metro area.
#' \item category'
#' }
#'
#' @docType data
#' @keywords datasets
#' @name midwest
#' @usage data(midwest)
#' @format A data frame with 437 rows and 28 variables
NULL
#' Movie information and user ratings from IMDB.com.
#'
#' The internet movie database, \url{http://imdb.com/}, is a website devoted
#' to collecting movie data supplied by studios and fans. It claims to be the
#' biggest movie database on the web and is run by amazon. More about
#' information imdb.com can be found online,
#' \url{http://imdb.com/help/show_leaf?about}, including information about
#' the data collection process,
#' \url{http://imdb.com/help/show_leaf?infosource}.
#'
#' Movies were selected for inclusion if they had a known length and had been rated by at least one imdb user. The data set contains the following fields:
#'
#' \itemize{
#' \item title. Title of the movie.
#' \item year. Year of release.
#' \item budget. Total budget (if known) in US dollars
#' \item length. Length in minutes.
#' \item rating. Average IMDB user rating.
#' \item votes. Number of IMDB users who rated this movie.
#' \item r1-10. Multiplying by ten gives percentile (to nearest 10\%) of users who rated this movie a 1.
#' \item mpaa. MPAA rating.
#' \item action, animation, comedy, drama, documentary, romance, short. Binary variables representing if movie was classified as belonging to that genre.
#' }
#'
#' @docType data
#' @keywords datasets
#' @usage data(movies)
#' @name movies
#' @format A data frame with 28819 rows and 24 variables
#' @references \url{http://had.co.nz/data/movies/}
NULL
#' Fuel economy data from 1999 and 2008 for 38 popular models of car
#'
#' This dataset contains a subset of the fuel economy data that the EPA makes
#' available on \url{http://fueleconomy.gov}. It contains only models which
#' had a new release every year between 1999 and 2008 - this was used as a
#' proxy for the popularity of the car.
#'
#' \itemize{
#' \item manufacturer.
#' \item model.
#' \item displ. engine displacement, in litres
#' \item year.
#' \item cyl. number of cylinders
#' \item trans. type of transmission
#' \item drv. f = front-wheel drive, r = rear wheel drive, 4 = 4wd
#' \item cty. city miles per gallon
#' \item hwy. highway miles per gallon
#' \item fl.
#' \item class.
#' }
#'
#' @docType data
#' @keywords datasets
#' @name mpg
#' @usage data(mpg)
#' @format A data frame with 234 rows and 11 variables
NULL
#' An updated and expanded version of the mammals sleep dataset.
#'
#' This is an updated and expanded version of the mammals sleep dataset.
#' Updated sleep times and weights were taken from V. M. Savage and G. B.
#' West. A quantitative, theoretical framework for understanding mammalian
#' sleep. Proceedings of the National Academy of Sciences, 104 (3):1051-1056,
#' 2007.
#'
#' Additional variables order, conservation status and vore were added from
#' wikipedia.
#'
#' \itemize{
#' \item name. common name
#' \item genus.
#' \item vore. carnivore, omnivore or herbivore?
#' \item order.
#' \item conservation. the conservation status of the animal
#' \item sleep\_total. total amount of sleep, in hours
#' \item sleep\_rem. rem sleep, in hours
#' \item sleep\_cycle. length of sleep cycle, in hours
#' \item awake. amount of time spent awake, in hours
#' \item brainwt. brain weight in kilograms
#' \item bodywt. body weight in kilograms
#' }
#'
#' @docType data
#' @keywords datasets
#' @name msleep
#' @usage data(msleep)
#' @format A data frame with 83 rows and 11 variables
NULL
#' Terms of 10 presidents from Eisenhower to Bush W.
#'
#' The names of each president, the start and end date of their term, and
#' their party of 10 US presidents from Eisenhower to Bush W.
#'
#' @docType data
#' @keywords datasets
#' @name presidential
#' @usage data(presidential)
#' @format A data frame with 10 rows and 4 variables
NULL
#' Vector field of seal movements.
#'
#' This vector field was produced from the data described in Brillinger, D.R.,
#' Preisler, H.K., Ager, A.A. and Kie, J.G. "An exploratory data analysis
#' (EDA) of the paths of moving animals". J. Statistical Planning and
#' Inference 122 (2004), 43-63, using the methods of Brillinger, D.R.,
#' "Learning a potential function from a trajectory", Signal Processing
#' Letters. December (2007).
#'
#' @name seals
#' @usage data(seals)
#' @docType data
#' @keywords datasets
#' @format A data frame with 1155 rows and 4 variables
#' @references \url{http://www.stat.berkeley.edu/~brill/Papers/jspifinal.pdf}
NULL
ggplot2/R/annotation-raster.r 0000644 0001751 0000144 00000005113 12114160774 015705 0 ustar hornik users #' @include geom-.r
#' @include geom-raster.r
NULL
#' Annotation: High-performance rectangular tiling.
#'
#' This is a special version of \code{\link{geom_raster}} optimised for static
#' annotations that are the same in every panel. These annotations will not
#' affect scales (i.e. the x and y axes will not grow to cover the range
#' of the raster, and the raster must already have its own colours).
#'
#' Most useful for adding bitmap images.
#'
#' @param raster raster object to display
#' @param xmin,xmax x location (in data coordinates) giving horizontal
#' location of raster
#' @param ymin,ymax y location (in data coordinates) giving vertical
#' location of raster
#' @param interpolate If \code{TRUE} interpolate linearly, if \code{FALSE}
#' (the default) don't interpolate.
#' @export
#' @examples
#' # Generate data
#' rainbow <- matrix(hcl(seq(0, 360, length = 50 * 50), 80, 70), nrow = 50)
#' qplot(mpg, wt, data = mtcars) +
#' annotation_raster(rainbow, 15, 20, 3, 4)
#' # To fill up whole plot
#' qplot(mpg, wt, data = mtcars) +
#' annotation_raster(rainbow, -Inf, Inf, -Inf, Inf) +
#' geom_point()
#'
#' rainbow2 <- matrix(hcl(seq(0, 360, length = 10), 80, 70), nrow = 1)
#' qplot(mpg, wt, data = mtcars) +
#' annotation_raster(rainbow2, -Inf, Inf, -Inf, Inf) +
#' geom_point()
#' rainbow2 <- matrix(hcl(seq(0, 360, length = 10), 80, 70), nrow = 1)
#' qplot(mpg, wt, data = mtcars) +
#' annotation_raster(rainbow2, -Inf, Inf, -Inf, Inf, interpolate = TRUE) +
#' geom_point()
annotation_raster <- function (raster, xmin, xmax, ymin, ymax, interpolate = FALSE) {
raster <- as.raster(raster)
GeomRasterAnn$new(geom_params = list(raster = raster, xmin = xmin,
xmax = xmax, ymin = ymin, ymax = ymax, interpolate = interpolate),
stat = "identity", position = "identity", data = NULL, inherit.aes = TRUE)
}
GeomRasterAnn <- proto(GeomRaster, {
objname <- "raster_ann"
reparameterise <- function(., df, params) {
df
}
draw_groups <- function(., data, scales, coordinates, raster, xmin, xmax,
ymin, ymax, interpolate = FALSE, ...) {
if (!inherits(coordinates, "cartesian")) {
stop("annotation_raster only works with Cartesian coordinates",
call. = FALSE)
}
corners <- data.frame(x = c(xmin, xmax), y = c(ymin, ymax))
data <- coord_transform(coordinates, corners, scales)
x_rng <- range(data$x, na.rm = TRUE)
y_rng <- range(data$y, na.rm = TRUE)
rasterGrob(raster, x_rng[1], y_rng[1],
diff(x_rng), diff(y_rng), default.units = "native",
just = c("left","bottom"), interpolate = interpolate)
}
})
ggplot2/R/fortify-map.r 0000644 0001751 0000144 00000006766 12114160774 014511 0 ustar hornik users #' Fortify method for map objects.
#'
#' This function turns a map into a data frame that can more easily be
#' plotted with ggplot2.
#'
#' @method fortify map
#' @S3method fortify map
#' @seealso \code{\link{map_data}} and \code{\link{borders}}
#' @param model map object
#' @param data not used by this method
#' @param ... not used by this method
#' @examples
#' if (require("maps")) {
#' ca <- map("county", "ca", plot = FALSE, fill = TRUE)
#' head(fortify(ca))
#' qplot(long, lat, data = ca, geom = "polygon", group = group)
#'
#' tx <- map("county", "texas", plot = FALSE, fill = TRUE)
#' head(fortify(tx))
#' qplot(long, lat, data = tx, geom = "polygon", group = group,
#' colour = I("white"))
#' }
fortify.map <- function(model, data, ...) {
df <- as.data.frame(model[c("x", "y")])
names(df) <- c("long", "lat")
df$group <- cumsum(is.na(df$long) & is.na(df$lat)) + 1
df$order <- 1:nrow(df)
names <- do.call("rbind", lapply(strsplit(model$names, "[:,]"), "[", 1:2))
df$region <- names[df$group, 1]
df$subregion <- names[df$group, 2]
df[complete.cases(df$lat, df$long), ]
}
#' Create a data frame of map data.
#'
#' @param map name of map provided by the \pkg{maps} package. These
#' include \code{\link[maps]{county}}, \code{\link[maps]{france}},
#' \code{\link[maps]{italy}}, \code{\link[maps]{nz}},
#' \code{\link[maps]{state}}, \code{\link[maps]{usa}},
#' \code{\link[maps]{world}}, \code{\link[maps]{world2}}.
#' @param region name of subregions to include. Defaults to \code{.} which
#' includes all subregion. See documentation for \code{\link[maps]{map}}
#' for more details.
#' @param exact should the \code{region} be treated as a regular expression
#' (\code{FALSE}) or as a fixed string (\code{TRUE}).
#' @param ... all other arguments passed on to \code{\link[maps]{map}}
#' @export
#' @examples
#' if (require("maps")) {
#' states <- map_data("state")
#' arrests <- USArrests
#' names(arrests) <- tolower(names(arrests))
#' arrests$region <- tolower(rownames(USArrests))
#'
#' choro <- merge(states, arrests, sort = FALSE, by = "region")
#' choro <- choro[order(choro$order), ]
#' qplot(long, lat, data = choro, group = group, fill = assault,
#' geom = "polygon")
#' qplot(long, lat, data = choro, group = group, fill = assault / murder,
#' geom = "polygon")
#' }
map_data <- function(map, region = ".", exact = FALSE, ...) {
try_require("maps")
fortify(map(map, region, exact = exact, plot = FALSE, fill = TRUE, ...))
}
#' Create a layer of map borders.
#'
#' @param database map data, see \code{\link[maps]{map}} for details
#' @param regions map region
#' @param fill fill colour
#' @param colour border colour
#' @param ... other arguments passed onto \code{\link{geom_polygon}}
#' @export
#' @examples
#' if (require("maps")) {
#'
#' ia <- map_data("county", "iowa")
#' mid_range <- function(x) mean(range(x))
#' library(plyr)
#' seats <- ddply(ia, .(subregion), colwise(mid_range, .(lat, long)))
#' ggplot(ia, aes(long, lat)) +
#' geom_polygon(aes(group = group), fill = NA, colour = "grey60") +
#' geom_text(aes(label = subregion), data = seats, size = 2, angle = 45)
#'
#' data(us.cities)
#' capitals <- subset(us.cities, capital == 2)
#' ggplot(capitals, aes(long, lat)) +
#' borders("state") +
#' geom_point(aes(size = pop)) +
#' scale_area()
#'
#' }
borders <- function(database = "world", regions = ".", fill = NA, colour = "grey50", ...) {
df <- map_data(database, regions)
geom_polygon(aes(long, lat, group = group), data = df,
fill = fill, colour = colour, ...)
}
ggplot2/R/geom-quantile.r 0000644 0001751 0000144 00000001745 12114160774 015013 0 ustar hornik users #' Add quantile lines from a quantile regression.
#'
#' This can be used as a continuous analogue of a geom_boxplot.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "quantile")}
#'
#' @export
#' @inheritParams geom_point
#' @inheritParams geom_path
#' @seealso See \code{\link{stat_quantile}} for examples.
#' @examples
#' # See stat_quantile for examples
geom_quantile <- function (mapping = NULL, data = NULL, stat = "quantile", position = "identity",
lineend = "butt", linejoin = "round", linemitre = 1, na.rm = FALSE, ...) {
GeomQuantile$new(mapping = mapping, data = data, stat = stat, position = position,
lineend = lineend, linejoin = linejoin, linemitre = linemitre, na.rm = na.rm, ...)
}
GeomQuantile <- proto(GeomPath, {
objname <- "quantile"
default_stat <- function(.) StatQuantile
default_aes <- function(.) defaults(aes(weight=1, colour="#3366FF", size=0.5), GeomPath$default_aes())
guide_geom <- function(.) "path"
})
ggplot2/R/stat-qq.r 0000644 0001751 0000144 00000004613 12114160774 013633 0 ustar hornik users #' Calculation for quantile-quantile plot.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "qq")}
#'
#' @param distribution Distribution function to use, if x not specified
#' @param dparams Parameters for distribution function
#' @param ... Other arguments passed to distribution function
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @inheritParams stat_identity
#' @return a data.frame with additional columns:
#' \item{sample}{sample quantiles}
#' \item{theoretical}{theoretical quantiles}
#' @export
#' @examples
#' \donttest{
#' # From ?qqplot
#' y <- rt(200, df = 5)
#' qplot(sample = y, stat="qq")
#'
#' # qplot is smart enough to use stat_qq if you use sample
#' qplot(sample = y)
#' qplot(sample = precip)
#'
#' qplot(sample = y, dist = qt, dparams = list(df = 5))
#'
#' df <- data.frame(y)
#' ggplot(df, aes(sample = y)) + stat_qq()
#' ggplot(df, aes(sample = y)) + geom_point(stat = "qq")
#'
#' # Use fitdistr from MASS to estimate distribution params
#' library(MASS)
#' params <- as.list(fitdistr(y, "t")$estimate)
#' ggplot(df, aes(sample = y)) + stat_qq(dist = qt, dparam = params)
#'
#' # Using to explore the distribution of a variable
#' qplot(sample = mpg, data = mtcars)
#' qplot(sample = mpg, data = mtcars, colour = factor(cyl))
#' }
stat_qq <- function (mapping = NULL, data = NULL, geom = "point", position = "identity",
distribution = qnorm, dparams = list(), na.rm = FALSE, ...) {
StatQq$new(mapping = mapping, data = data, geom = geom, position = position,
distribution = distribution, dparams = dparams, na.rm = na.rm, ...)
}
StatQq <- proto(Stat, {
objname <- "qq"
default_geom <- function(.) GeomPoint
default_aes <- function(.) aes(y = ..sample.., x = ..theoretical..)
required_aes <- c("sample")
calculate <- function(., data, scales, quantiles = NULL, distribution = qnorm, dparams = list(), na.rm = FALSE) {
data <- remove_missing(data, na.rm, "sample", name = "stat_qq")
sample <- sort(data$sample)
n <- length(sample)
# Compute theoretical quantiles
if (is.null(quantiles)) {
quantiles <- ppoints(n)
} else {
stopifnot(length(quantiles) == n)
}
theoretical <- safe.call(distribution, c(list(p = quantiles), dparams))
data.frame(sample, theoretical)
}
})
ggplot2/R/guide-colorbar.r 0000644 0001751 0000144 00000036411 12114160774 015140 0 ustar hornik users #' Contiuous colour bar guide.
#'
#' Colour bar guide shows continuous color scales mapped onto values.
#' Colour bar is available with \code{scale_fill} and \code{scale_colour}.
#' For more information, see the inspiration for this function:
#' \href{http://www.mathworks.com/help/techdoc/ref/colorbar.html}{Matlab's colorbar function}.
#'
#' Guides can be specified in each scale or in \code{\link{guides}}.
#' \code{guide="legend"} in scale is syntax sugar for
#' \code{guide=guide_legend()} - but the second form allows you to specify
#' more options. As for how to specify the guide for each
#' scales, see \code{\link{guides}}.
#'
#' @inheritParams guide_legend
#' @param barwidth A numeric or a unit object specifying the width of the
#' colorbar. Default value is \code{legend.key.width} or
#' \code{legend.key.size} in \code{\link{theme}} or theme.
#' @param barheight A numeric or a unit object specifying the height of the
#' colorbar. Default value is \code{legend.key.height} or
#' \code{legend.key.size} in \code{\link{theme}} or theme.
#' @param nbin A numeric specifying the number of bins for drawing colorbar. A
#' smoother colorbar for a larger value.
#' @param raster A logical. If \code{TRUE} then the colorbar is rendered as a
#' raster object. If \code{FALSE} then the colorbar is rendered as a set of
#' rectangles. Note that not all graphics devices are capable of rendering
#' raster image.
#' @param ticks A logical specifying if tick marks on colorbar should be
#' visible.
#' @param draw.ulim A logical specifying if the upper limit tick marks should
#' be visible.
#' @param draw.llim A logical specifying if the lower limit tick marks should
#' be visible.
#' @param direction A character string indicating the direction of the guide.
#' One of "horizontal" or "vertical."
#' @param default.unit A character string indicating unit for \code{barwidth}
# and \code{barheight}.
#' @param reverse logical. If \code{TRUE} the colorbar is reversed. By default,
#' the highest value is on the top and the lowest value is on the bottom
#' @param ... ignored.
#' @return A guide object
#' @export
#' @family guides
#' @examples
#' library(reshape2) # for melt
#' df <- melt(outer(1:4, 1:4), varnames = c("X1", "X2"))
#'
#' p1 <- ggplot(df, aes(X1, X2)) + geom_tile(aes(fill = value))
#' p2 <- p1 + geom_point(aes(size = value))
#'
#' # Basic form
#' p1 + scale_fill_continuous(guide = "colorbar")
#' p1 + scale_fill_continuous(guide = guide_colorbar())
#' p1 + guides(fill = guide_colorbar())
#'
#' # Control styles
#'
#' # bar size
#' p1 + guides(fill = guide_colorbar(barwidth = 0.5, barheight = 10))
#'
#' # no label
#' p1 + guides(fill = guide_colorbar(label = FALSE))
#'
#' # no tick marks
#' p1 + guides(fill = guide_colorbar(ticks = FALSE))
#'
#' # label position
#' p1 + guides(fill = guide_colorbar(label.position = "left"))
#'
#' # label theme
#' p1 + guides(fill = guide_colorbar(label.theme = element_text(colour = "blue", angle = 0)))
#'
#' # small number of bins
#' p1 + guides(fill = guide_colorbar(nbin = 3))
#'
#' # large number of bins
#' p1 + guides(fill = guide_colorbar(nbin = 100))
#'
#' # make top- and bottom-most ticks invisible
#' p1 + scale_fill_continuous(limits = c(0,20), breaks=c(0, 5, 10, 15, 20),
#' guide = guide_colorbar(nbin=100, draw.ulim = FALSE, draw.llim = FALSE))
#'
#' # guides can be controlled independently
#' p2 +
#' scale_fill_continuous(guide = "colorbar") +
#' scale_size(guide = "legend")
#' p2 + guides(fill = "colorbar", size = "legend")
#'
#' p2 +
#' scale_fill_continuous(guide = guide_colorbar(direction = "horizontal")) +
#' scale_size(guide = guide_legend(direction = "vertical"))
guide_colourbar <- function(
# title
title = waiver(),
title.position = NULL,
title.theme = NULL,
title.hjust = NULL,
title.vjust = NULL,
# label
label = TRUE,
label.position = NULL,
label.theme = NULL,
label.hjust = NULL,
label.vjust = NULL,
# bar
barwidth = NULL,
barheight = NULL,
nbin = 20,
raster = TRUE,
# ticks
ticks = TRUE,
draw.ulim= TRUE,
draw.llim = TRUE,
# general
direction = NULL,
default.unit = "line",
reverse = FALSE,
order = 0,
...) {
if (!is.null(barwidth) && !is.unit(barwidth)) barwidth <- unit(barwidth, default.unit)
if (!is.null(barheight) && !is.unit(barheight)) barheight <- unit(barheight, default.unit)
structure(list(
# title
title = title,
title.position = title.position,
title.theme = title.theme,
title.hjust = title.hjust,
title.vjust = title.vjust,
# label
label = label,
label.position = label.position,
label.theme = label.theme,
label.hjust = label.hjust,
label.vjust = label.vjust,
# bar
barwidth = barwidth,
barheight = barheight,
nbin = nbin,
raster = raster,
# ticks
ticks = ticks,
draw.ulim = draw.ulim,
draw.llim = draw.llim,
# general
direction = direction,
default.unit = default.unit,
reverse = reverse,
order = order,
# parameter
available_aes = c("colour", "color", "fill"),
..., name="colorbar"),
class=c("guide", "colorbar"))
}
guide_train.colorbar <- function(guide, scale) {
# do nothing if scale are inappropriate
if (length(intersect(scale$aesthetics, c("color", "colour", "fill"))) == 0) {
warning("colorbar guide needs colour or fill scales.")
return(NULL)
}
if (!inherits(scale, "continuous")) {
warning("colorbar guide needs continuous scales.")
return(NULL)
}
# ticks - label (i.e. breaks)
output <- scale$aesthetics[1]
breaks <- scale_breaks(scale)
guide$key <- data.frame(scale_map(scale, breaks), I(scale_labels(scale, breaks)), breaks,
stringsAsFactors = FALSE)
# .value = breaks (numeric) is used for determining the position of ticks in gengrob
names(guide$key) <- c(output, ".label", ".value")
# bar specification (number of divs etc)
.bar <- discard(pretty(scale_limits(scale), n = guide$nbin), scale_limits(scale))
guide$bar <- data.frame(colour=scale_map(scale, .bar), value=.bar, stringsAsFactors = FALSE)
if (guide$reverse) {
guide$key <- guide$key[nrow(guide$key):1, ]
guide$bar <- guide$bar[nrow(guide$bar):1, ]
}
guide$hash <- with(guide, digest(list(title, key$.label, bar, name)))
guide
}
# simply discards the new guide
guide_merge.colorbar <- function(guide, new_guide) {
guide
}
# this guide is not geom-based.
guide_geom.colorbar <- function(guide, ...) {
guide
}
guide_gengrob.colorbar <- function(guide, theme) {
# settings of location and size
switch(guide$direction,
"horizontal" = {
label.position <- guide$label.position %||% "bottom"
if (!label.position %in% c("top", "bottom")) stop("label position \"", label.position, "\" is invalid")
barwidth <- convertWidth(guide$barwidth %||% (theme$legend.key.width * 5), "mm")
barheight <- convertHeight(guide$barheight %||% theme$legend.key.height, "mm")
},
"vertical" = {
label.position <- guide$label.position %||% "right"
if (!label.position %in% c("left", "right")) stop("label position \"", label.position, "\" is invalid")
barwidth <- convertWidth(guide$barwidth %||% theme$legend.key.width, "mm")
barheight <- convertHeight(guide$barheight %||% (theme$legend.key.height * 5), "mm")
})
barwidth.c <- c(barwidth)
barheight.c <- c(barheight)
barlength.c <- switch(guide$direction, "horizontal" = barwidth.c, "vertical" = barheight.c)
nbreak <- nrow(guide$key)
# gap between keys etc
hgap <- c(convertWidth(unit(0.3, "lines"), "mm"))
vgap <- hgap
grob.bar <-
if (guide$raster) {
image <- switch(guide$direction, horizontal = t(guide$bar$colour), vertical = rev(guide$bar$colour))
rasterGrob(image = image, width=barwidth.c, height=barheight.c, default.units = "mm", gp=gpar(col=NA), interpolate = TRUE)
} else {
switch(guide$direction,
horizontal = {
bw <- barwidth.c / nrow(guide$bar)
bx <- (seq(nrow(guide$bar)) - 1) * bw
rectGrob(x = bx, y = 0, vjust = 0, hjust = 0, width = bw, height = barheight.c, default.units = "mm",
gp = gpar(col = NA, fill = guide$bar$colour))
},
vertical = {
bh <- barheight.c / nrow(guide$bar)
by <- (seq(nrow(guide$bar)) - 1) * bh
rectGrob(x = 0, y = by, vjust = 0, hjust = 0, width = barwidth.c, height = bh, default.units = "mm",
gp = gpar(col = NA, fill = guide$bar$colour))
})
}
# tick and label position
tic_pos.c <- rescale(guide$key$.value, c(0.5, guide$nbin-0.5), guide$bar$value[c(1, nrow(guide$bar))]) * barlength.c / guide$nbin
label_pos <- unit(tic_pos.c, "mm")
if (!guide$draw.ulim) tic_pos.c <- tic_pos.c[-1]
if (!guide$draw.llim) tic_pos.c <- tic_pos.c[-length(tic_pos.c)]
# title
# hjust of title should depend on title.position
title.theme <- guide$title.theme %||% calc_element("legend.title", theme)
title.hjust <- title.x <- guide$title.hjust %||% theme$legend.title.align %||% 0
title.vjust <- title.y <- guide$title.vjust %||% 0.5
grob.title <- {
if (is.null(guide$title))
zeroGrob()
else {
g <- element_grob(title.theme, label=guide$title,
hjust = title.hjust, vjust = title.vjust, x = title.x, y = title.y)
ggname("guide.title", g)
}
}
title_width <- convertWidth(grobWidth(grob.title), "mm")
title_width.c <- c(title_width)
title_height <- convertHeight(grobHeight(grob.title), "mm")
title_height.c <- c(title_height)
# label
label.theme <- guide$label.theme %||% calc_element("legend.text", theme)
grob.label <- {
if (!guide$label)
zeroGrob()
else {
hjust <- x <- guide$label.hjust %||% theme$legend.text.align %||%
if (any(is.expression(guide$key$.label))) 1 else switch(guide$direction, horizontal = 0.5, vertical = 0)
vjust <- y <- guide$label.vjust %||% 0.5
switch(guide$direction, horizontal = {x <- label_pos; y <- vjust}, "vertical" = {x <- hjust; y <- label_pos})
label <- guide$key$.label
# If any of the labels are quoted language objects, convert them
# to expressions. Labels from formatter functions can return these
if (any(vapply(label, is.call, logical(1)))) {
label <- lapply(label, function(l) {
if (is.call(l)) substitute(expression(x), list(x = l))
else l
})
label <- do.call(c, label)
}
g <- element_grob(element = label.theme, label = label,
x = x, y = y, hjust = hjust, vjust = vjust)
ggname("guide.label", g)
}
}
label_width <- convertWidth(grobWidth(grob.label), "mm")
label_width.c <- c(label_width)
label_height <- convertHeight(grobHeight(grob.label), "mm")
label_height.c <- c(label_height)
# ticks
grob.ticks <-
if (!guide$ticks) zeroGrob()
else {
switch(guide$direction,
"horizontal" = {
x0 = rep(tic_pos.c, 2)
y0 = c(rep(0, nbreak), rep(barheight.c * (4/5), nbreak))
x1 = rep(tic_pos.c, 2)
y1 = c(rep(barheight.c * (1/5), nbreak), rep(barheight.c, nbreak))
},
"vertical" = {
x0 = c(rep(0, nbreak), rep(barwidth.c * (4/5), nbreak))
y0 = rep(tic_pos.c, 2)
x1 = c(rep(barwidth.c * (1/5), nbreak), rep(barwidth.c, nbreak))
y1 = rep(tic_pos.c, 2)
})
segmentsGrob(x0 = x0, y0 = y0, x1 = x1, y1 = y1,
default.units = "mm", gp = gpar(col="white", lwd=0.5, lineend="butt"))
}
# layout of bar and label
switch(guide$direction,
"horizontal" = {
switch(label.position,
"top" = {
bl_widths <- barwidth.c
bl_heights <- c(label_height.c, vgap, barheight.c)
vps <- list(bar.row = 3, bar.col = 1,
label.row = 1, label.col = 1)
},
"bottom" = {
bl_widths <- barwidth.c
bl_heights <- c(barheight.c, vgap, label_height.c)
vps <- list(bar.row = 1, bar.col = 1,
label.row = 3, label.col = 1)
})
},
"vertical" = {
switch(label.position,
"left" = {
bl_widths <- c(label_width.c, vgap, barwidth.c)
bl_heights <- barheight.c
vps <- list(bar.row = 1, bar.col = 3,
label.row = 1, label.col = 1)
},
"right" = {
bl_widths <- c(barwidth.c, vgap, label_width.c)
bl_heights <- barheight.c
vps <- list(bar.row = 1, bar.col = 1,
label.row = 1, label.col = 3)
})
})
# layout of title and bar+label
switch(guide$title.position,
"top" = {
widths <- c(bl_widths, max(0, title_width.c-sum(bl_widths)))
heights <- c(title_height.c, vgap, bl_heights)
vps <- with(vps,
list(bar.row = bar.row+2, bar.col = bar.col,
label.row = label.row+2, label.col = label.col,
title.row = 1, title.col = 1:length(widths)))
},
"bottom" = {
widths <- c(bl_widths, max(0, title_width.c-sum(bl_widths)))
heights <- c(bl_heights, vgap, title_height.c)
vps <- with(vps,
list(bar.row = bar.row, bar.col = bar.col,
label.row = label.row, label.col = label.col,
title.row = length(heights), title.col = 1:length(widths)))
},
"left" = {
widths <- c(title_width.c, hgap, bl_widths)
heights <- c(bl_heights, max(0, title_height.c-sum(bl_heights)))
vps <- with(vps,
list(bar.row = bar.row, bar.col = bar.col+2,
label.row = label.row, label.col = label.col+2,
title.row = 1:length(heights), title.col = 1))
},
"right" = {
widths <- c(bl_widths, hgap, title_width.c)
heights <- c(bl_heights, max(0, title_height.c-sum(bl_heights)))
vps <- with(vps,
list(bar.row = bar.row, bar.col = bar.col,
label.row = label.row, label.col = label.col,
title.row = 1:length(heights), title.col = length(widths)))
})
# background
grob.background <- element_render(theme, "legend.background")
# padding
padding <- unit(1.5, "mm")
widths <- c(padding, widths, padding)
heights <- c(padding, heights, padding)
gt <- gtable(widths = unit(widths, "mm"), heights = unit(heights, "mm"))
gt <- gtable_add_grob(gt, grob.background, name = "background", clip = "off",
t = 1, r = -1, b = -1, l = 1)
gt <- gtable_add_grob(gt, grob.bar, name = "bar", clip = "off",
t = 1 + min(vps$bar.row), r = 1 + max(vps$bar.col),
b = 1 + max(vps$bar.row), l = 1 + min(vps$bar.col))
gt <- gtable_add_grob(gt, grob.label, name = "label", clip = "off",
t = 1 + min(vps$label.row), r = 1 + max(vps$label.col),
b = 1 + max(vps$label.row), l = 1 + min(vps$label.col))
gt <- gtable_add_grob(gt, grob.title, name = "title", clip = "off",
t = 1 + min(vps$title.row), r = 1 + max(vps$title.col),
b = 1 + max(vps$title.row), l = 1 + min(vps$title.col))
gt <- gtable_add_grob(gt, grob.ticks, name = "ticks", clip = "off",
t = 1 + min(vps$bar.row), r = 1 + max(vps$bar.col),
b = 1 + max(vps$bar.row), l = 1 + min(vps$bar.col))
gt
}
#' @export
#' @rdname guide_colourbar
guide_colorbar <- guide_colourbar
ggplot2/R/guide-legend.r 0000644 0001751 0000144 00000047022 12114160774 014573 0 ustar hornik users #' Legend guide.
#'
#' Legend type guide shows key (i.e., geoms) mapped onto values.
#' Legend guides for various scales are integrated if possible.
#'
#' Guides can be specified in each scale or in \code{\link{guides}}.
#' \code{guide="legend"} in scale is syntactic sugar for
#' \code{guide=guide_legend()}. As for how to specify the guide for each
#' scales in more detail, see \code{\link{guides}}.
#'
#' @param title A character string or expression indicating a title of guide.
#' If \code{NULL}, the title is not shown. By default
#' (\code{\link{waiver}}), the name of the scale object or tha name
#' specified in \code{\link{labs}} is used for the title.
#' @param title.position A character string indicating the position of a
#' title. One of "top" (default for a vertical guide), "bottom", "left"
#' (default for a horizontal guide), or "right."
#' @param title.theme A theme object for rendering the title text. Usually the
#' object of \code{\link{element_text}} is expected. By default, the theme is
#' specified by \code{legend.title} in \code{\link{theme}} or theme.
#' @param title.hjust A number specifying horizontal justification of the
#' title text.
#' @param title.vjust A number specifying vertical justification of the title
#' text.
#' @param label logical. If \code{TRUE} then the labels are drawn. If
#' \code{FALSE} then the labels are invisible.
#' @param label.position A character string indicating the position of a
#' label. One of "top", "bottom" (default for horizontal guide), "left", or
#' "right" (default for vertical gudie).
#' @param label.theme A theme object for rendering the label text. Usually the
#' object of \code{\link{element_text}} is expected. By default, the theme is
#' specified by \code{legend.text} in \code{\link{theme}} or theme.
#' @param label.hjust A numeric specifying horizontal justification of the
#' label text.
#' @param label.vjust A numeric specifying vertical justification of the label
#' text.
#' @param keywidth A numeric or a unit object specifying the width of the
#' legend key. Default value is \code{legend.key.width} or
#' \code{legend.key.size} in \code{\link{theme}} or theme.
#' @param keyheight A numeric or a unit object specifying the height of the
#' legend key. Default value is \code{legend.key.height} or
#' \code{legend.key.size} in \code{\link{theme}} or theme.
#' @param direction A character string indicating the direction of the guide.
#' One of "horizontal" or "vertical."
#' @param default.unit A character string indicating unit for \code{keywidth}
#' and \code{keyheight}.
#' @param override.aes A list specifying aesthetic parameters of legend key.
#' See details and examples.
#' @param nrow The desired number of rows of legends.
#' @param ncol The desired number of column of legends.
#' @param byrow logical. If \code{FALSE} (the default) the legend-matrix is
#' filled by columns, otherwise the legend-matrix is filled by rows.
#' @param reverse logical. If \code{TRUE} the order of legends is reversed.
#' @param order positive integer less that 99 that specify the order of
#' this guide in the multiple guides. If 0 (default), the order is determined
#' by a secret algorithm.
#' @param ... ignored.
#' @return A guide object
#' @export
#' @family guides
#' @examples
#' \donttest{
#' library(reshape2) # for melt
#' df <- melt(outer(1:4, 1:4), varnames = c("X1", "X2"))
#'
#' p1 <- ggplot(df, aes(X1, X2)) + geom_tile(aes(fill = value))
#' p2 <- p1 + geom_point(aes(size = value))
#'
#' # Basic form
#' p1 + scale_fill_continuous(guide = "legend")
#' p1 + scale_fill_continuous(guide = guide_legend())
#'
#' # Guide title
#'
#' p1 + scale_fill_continuous(guide = guide_legend(title = "V")) # title text
#' p1 + scale_fill_continuous(name = "V") # same
#' p1 + scale_fill_continuous(guide = guide_legend(title = NULL)) # no title
#'
#' # Control styles
#'
#' # key size
#' p1 + guides(fill = guide_legend(keywidth = 3, keyheight = 1))
#'
#' # title position
#' p1 + guides(fill = guide_legend(title = "LEFT", title.position = "left"))
#'
#' # title text styles via element_text
#' p1 + guides(fill = guide_legend(
#' title.theme = element_text(size=15, face="italic", colour = "red", angle = 45)))
#'
#' # label position
#' p1 + guides(fill = guide_legend(label.position = "bottom"))
#'
#' # label styles
#' p1 + scale_fill_continuous(breaks = c(5, 10, 15),
#' labels = paste("long", c(5, 10, 15)),
#' guide = guide_legend(direction = "horizontal", title.position = "top",
#' label.position="bottom", label.hjust = 0.5, label.vjust = 0.5,
#' label.theme = element_text(angle = 90)))
#'
#' # Set aesthetic of legend key
#'
#' # very low alpha value make it difficult to see legend key
#' p3 <- qplot(carat, price, data = diamonds, colour = color,
#' alpha = I(1/100))
#' p3
#'
#' # override.aes overwrites the alpha
#' p3 + guides(colour = guide_legend(override.aes = list(alpha = 1)))
#'
#' # multiple row/col legends
#' p <- qplot(1:20, 1:20, colour = letters[1:20])
#' p + guides(col = guide_legend(nrow = 8))
#' p + guides(col = guide_legend(ncol = 8))
#' p + guides(col = guide_legend(nrow = 8, byrow = TRUE))
#' p + guides(col = guide_legend(ncol = 8, byrow = TRUE))
#'
#' # reversed order legend
#' p + guides(col = guide_legend(reverse = TRUE))
#' }
guide_legend <- function(
# title
title = waiver(),
title.position = NULL,
title.theme = NULL,
title.hjust = NULL,
title.vjust = NULL,
# label
label = TRUE,
label.position = NULL,
label.theme = NULL,
label.hjust = NULL,
label.vjust = NULL,
# key
keywidth = NULL,
keyheight = NULL,
# general
direction = NULL,
default.unit = "line",
override.aes = list(),
nrow = NULL,
ncol = NULL,
byrow = FALSE,
reverse = FALSE,
order = 0,
...) {
if (!is.null(keywidth) && !is.unit(keywidth)) keywidth <- unit(keywidth, default.unit)
if (!is.null(keyheight) && !is.unit(keyheight)) keyheight <- unit(keyheight, default.unit)
structure(list(
# title
title = title,
title.position = title.position,
title.theme = title.theme,
title.hjust = title.hjust,
title.vjust = title.vjust,
# label
label = label,
label.position = label.position,
label.theme = label.theme,
label.hjust = label.hjust,
label.vjust = label.vjust,
# size of key
keywidth = keywidth,
keyheight = keyheight,
# general
direction = direction,
default.unit = default.unit,
override.aes = override.aes,
nrow = nrow,
ncol = ncol,
byrow = byrow,
reverse = reverse,
order = order,
# parameter
available_aes = c("any"),
..., name="legend"),
class=c("guide", "legend"))
}
guide_train.legend <- function(guide, scale) {
breaks <- scale_breaks(scale)
key <- data.frame(
values = scale_map(scale, breaks),
labels = I(scale_labels(scale)),
stringsAsFactors = FALSE)
# this is a quick fix for #118
# some scales have NA as na.value (e.g., size)
# some scales have non NA as na.value (e.g., "grey50" for colour)
# drop rows if data (instead of the mapped value) is NA
#
# Also, drop out-of-range values for continuous scale
# (should use scale$oob?)
if (inherits(scale, "continuous")) {
limits <- scale_limits(scale)
noob <- !is.na(breaks) & limits[1] <= breaks & breaks <= limits[2]
key <- key[noob, , drop = FALSE]
} else {
key <- key[!is.na(breaks), , drop = FALSE]
}
if (empty(key) || all(is.na(breaks))) return(NULL)
names(key) <- c(scale$aesthetics[1], ".label")
if (guide$reverse) key <- key[nrow(key):1, ]
guide$key <- key
guide$hash <- with(guide, digest(list(title, key$.label, direction, name)))
guide
}
guide_merge.legend <- function(guide, new_guide) {
guide$key <- merge(guide$key, new_guide$key, sort=FALSE)
guide$override.aes <- c(guide$override.aes, new_guide$override.aes)
if (any(duplicated(names(guide$override.aes)))) warning("Duplicated override.aes is ignored.")
guide$override.aes <- guide$override.aes[!duplicated(names(guide$override.aes))]
guide
}
guide_geom.legend <- function(guide, layers, default_mapping) {
# TODO: how to deal with same geoms of multiple layers.
#
# currently all geoms are overlayed irrespective to that they are duplicated or not.
# but probably it is better to sensitive to that and generate only one geom like this:
#
# geoms <- unique(sapply(layers, function(layer) if (is.na(layer$legend) || layer$legend) layer$geom$guide_geom() else NULL))
#
# but in this case, some conflicts occurs, e.g.,
#
# d <- data.frame(x=1:5, y=1:5, v=factor(1:5))
# ggplot(d, aes(x, y, colour=v, group=1)) + geom_point() + geom_line(colour="red", legend=T) + geom_rug(colour="blue", legend=T)
#
# geom_line generate path geom with red and geom_rug generate it with blue.
# how to deal with them ?
# arrange common data for vertical and horizontal guide
guide$geoms <- llply(layers, function(layer) {
all <- names(c(layer$mapping, default_mapping, layer$stat$default_aes()))
geom <- c(layer$geom$required_aes, names(layer$geom$default_aes()))
matched <- intersect(intersect(all, geom), names(guide$key))
matched <- setdiff(matched, names(layer$geom_params))
data <-
if (length(matched) > 0) {
# This layer contributes to the legend
if (is.na(layer$show_guide) || layer$show_guide) {
# Default is to include it
layer$use_defaults(guide$key[matched])
} else {
NULL
}
} else {
# This layer does not contribute to the legend
if (is.na(layer$show_guide) || !layer$show_guide) {
# Default is to exclude it
NULL
} else {
layer$use_defaults(NULL)[rep(1, nrow(guide$key)), ]
}
}
if (is.null(data)) return(NULL)
# override.aes in guide_legend manually changes the geom
for (aes in intersect(names(guide$override.aes), names(data))) data[[aes]] <- guide$override.aes[[aes]]
geom <- Geom$find(layer$geom$guide_geom())
params <- c(layer$geom_params, layer$stat_params)
list(geom = geom, data = data, params = params)
}
)
# remove null geom
guide$geoms <- compact(guide$geoms)
# Finally, remove this guide if no layer is drawn
if (length(guide$geoms) == 0) guide <- NULL
guide
}
guide_gengrob.legend <- function(guide, theme) {
# default setting
label.position <- guide$label.position %||% "right"
if (!label.position %in% c("top", "bottom", "left", "right")) stop("label position \"", label.position, "\" is invalid")
nbreak <- nrow(guide$key)
# gap between keys etc
hgap <- c(convertWidth(unit(0.3, "lines"), "mm"))
vgap <- hgap
# title
title.theme <- guide$title.theme %||% calc_element("legend.title", theme)
title.hjust <- title.x <- guide$title.hjust %||% theme$legend.title.align %||% 0
title.vjust <- title.y <- guide$title.vjust %||% 0.5
grob.title <- {
if (is.null(guide$title))
zeroGrob()
else {
g <- element_grob(title.theme, label=guide$title,
hjust = title.hjust, vjust = title.vjust, x = title.x, y = title.y)
ggname("guide.title", g)
}
}
title_width <- convertWidth(grobWidth(grob.title), "mm")
title_width.c <- c(title_width)
title_height <- convertHeight(grobHeight(grob.title), "mm")
title_height.c <- c(title_height)
# Label
# Rules of lable adjustment
#
# label.theme in param of guide_legend() > theme$legend.text.align > default
# hjust/vjust in theme$legend.text and label.theme are ignored.
#
# Default:
# If label includes expression, the label is right-alignd (hjust = 0). Ohterwise, left-aligned (x = 1, hjust = 1).
# Vertical adjustment is always mid-alined (vjust = 0.5).
label.theme <- guide$label.theme %||% calc_element("legend.text", theme)
grob.labels <- {
if (!guide$label)
zeroGrob()
else {
hjust <- x <- guide$label.hjust %||% theme$legend.text.align %||%
if (any(is.expression(guide$key$.label))) 1 else 0
vjust <- y <- guide$label.vjust %||% 0.5
lapply(guide$key$.label,
function(label, ...) {
g <- element_grob(element = label.theme, label = label,
x = x, y = y, hjust = hjust, vjust = vjust)
ggname("guide.label", g)
}
)
}
}
label_widths <- lapply(grob.labels, function(g)convertWidth(grobWidth(g), "mm"))
label_heights <- lapply(grob.labels, function(g)convertHeight(grobHeight(g), "mm"))
label_widths.c <- unlist(label_widths)
label_heights.c <- unlist(label_heights)
# key size
key_width <- convertWidth(guide$keywidth %||% theme$legend.key.width %||% theme$legend.key.size, "mm")
key_height <- convertHeight(guide$keyheight %||% theme$legend.key.height %||% theme$legend.key.size, "mm")
key_width.c <- c(key_width)
key_height.c <- c(key_height)
key_size_mat <- do.call("cbind", llply(guide$geoms, function(g) g$data$size))
key_sizes <- if (is.null(key_size_mat)) rep(0, nbreak) else apply(key_size_mat, 1, max)
if (!is.null(guide$nrow) && !is.null(guide$ncol) && guide$nrow * guide$ncol < nbreak)
stop("nrow x ncol need to be larger than the number of breaks")
legend.nrow <- guide$nrow %||%
if (!is.null(guide$ncol)) ceiling(nbreak/guide$ncol)
else switch(guide$direction, horizontal = 1, vertical = nbreak)
legend.ncol <- guide$ncol %||%
if (!is.null(guide$nrow)) ceiling(nbreak/guide$nrow)
else switch(guide$direction, horizontal = nbreak, vertical = 1)
key_sizes <- matrix(c(key_sizes, rep(0, legend.nrow * legend.ncol - nbreak)),
legend.nrow, legend.ncol, byrow = guide$byrow)
key_widths.c <- pmax(key_width.c, apply(key_sizes, 2, max))
key_heights.c <-pmax(key_height.c, apply(key_sizes, 1, max))
label_widths.c <- apply(matrix(c(label_widths.c, rep(0, legend.nrow * legend.ncol - nbreak)),
legend.nrow, legend.ncol, byrow = guide$byrow),
2, max)
label_heights.c <- apply(matrix(c(label_heights.c, rep(0, legend.nrow * legend.ncol - nbreak)),
legend.nrow, legend.ncol, byrow = guide$byrow),
1, max)
if (guide$byrow) vps <- data.frame(ceiling(seq(nbreak)/legend.ncol), (seq(nbreak)-1)%%legend.ncol+1)
else vps <- data.frame(arrayInd(seq(nbreak), dim(key_sizes)))
names(vps) <- c("R", "C")
# layout of key-label depends on the direction of the guide
if (guide$byrow == TRUE) {
switch(label.position,
"top" = {
kl_widths <- pmax(label_widths.c, key_widths.c)
kl_heights <- head(interleave(label_heights.c, vgap/2, key_heights.c, vgap/2), -1)
vps <- transform(vps, key.row = R*4-1, key.col = C, label.row = R*4-3, label.col = C)
},
"bottom" = {
kl_widths <- pmax(label_widths.c, key_widths.c)
kl_heights <- head(interleave(key_heights.c, vgap/2, label_heights.c, vgap/2), -1)
vps <- transform(vps, key.row = R*4-3, key.col = C, label.row = R*4-1, label.col = C)
},
"left" = {
kl_widths <- head(interleave(label_widths.c, hgap/2, key_widths.c, hgap/2), -1)
kl_heights <- head(interleave(pmax(label_heights.c, key_heights.c), vgap/2), -1)
vps <- transform(vps, key.row = R*2-1, key.col = C*4-1, label.row = R*2-1, label.col = C*4-3)
},
"right" = {
kl_widths <- head(interleave(key_widths.c, hgap/2, label_widths.c, hgap/2), -1)
kl_heights <- head(interleave(pmax(label_heights.c, key_heights.c), vgap/2), -1)
vps <- transform(vps, key.row = R*2-1, key.col = C*4-3, label.row = R*2-1, label.col = C*4-1)
})
} else {
switch(label.position,
"top" = {
kl_widths <- head(interleave(pmax(label_widths.c, key_widths.c), hgap/2), -1)
kl_heights <- head(interleave(label_heights.c, vgap/2, key_heights.c, vgap/2), -1)
vps <- transform(vps, key.row = R*4-1, key.col = C*2-1, label.row = R*4-3, label.col = C*2-1)
},
"bottom" = {
kl_widths <- head(interleave(pmax(label_widths.c, key_widths.c), hgap/2), -1)
kl_heights <- head(interleave(key_heights.c, vgap/2, label_heights.c, vgap/2), -1)
vps <- transform(vps, key.row = R*4-3, key.col = C*2-1, label.row = R*4-1, label.col = C*2-1)
},
"left" = {
kl_widths <- head(interleave(label_widths.c, hgap/2, key_widths.c, hgap/2), -1)
kl_heights <- pmax(key_heights.c, label_heights.c)
vps <- transform(vps, key.row = R, key.col = C*4-1, label.row = R, label.col = C*4-3)
},
"right" = {
kl_widths <- head(interleave(key_widths.c, hgap/2, label_widths.c, hgap/2), -1)
kl_heights <- pmax(key_heights.c, label_heights.c)
vps <- transform(vps, key.row = R, key.col = C*4-3, label.row = R, label.col = C*4-1)
})
}
# layout the title over key-label
switch(guide$title.position,
"top" = {
widths <- c(kl_widths, max(0, title_width.c-sum(kl_widths)))
heights <- c(title_height.c, vgap, kl_heights)
vps <- transform(vps, key.row = key.row+2, key.col = key.col, label.row = label.row+2, label.col = label.col)
vps.title.row = 1; vps.title.col = 1:length(widths)
},
"bottom" = {
widths <- c(kl_widths, max(0, title_width.c-sum(kl_widths)))
heights <- c(kl_heights, vgap, title_height.c)
vps <- transform(vps, key.row = key.row, key.col = key.col, label.row = label.row, label.col = label.col)
vps.title.row = length(heights); vps.title.col = 1:length(widths)
},
"left" = {
widths <- c(title_width.c, hgap, kl_widths)
heights <- c(kl_heights, max(0, title_height.c-sum(kl_heights)))
vps <- transform(vps, key.row = key.row, key.col = key.col+2, label.row = label.row, label.col = label.col+2)
vps.title.row = 1:length(heights); vps.title.col = 1
},
"right" = {
widths <- c(kl_widths, hgap, title_width.c)
heights <- c(kl_heights, max(0, title_height.c-sum(kl_heights)))
vps <- transform(vps, key.row = key.row, key.col = key.col, label.row = label.row, label.col = label.col)
vps.title.row = 1:length(heights); vps.title.col = length(widths)
})
# grob for key
grob.keys <- list()
for (i in 1:nbreak) {
# layout position
pos.row <- vps$key.row[i]
pos.col <- vps$key.col[i]
# bg. of key
grob.keys[[length(grob.keys)+1]] <- element_render(theme, "legend.key")
# overlay geoms
for(geom in guide$geoms)
grob.keys[[length(grob.keys)+1]] <- geom$geom$draw_legend(geom$data[i, ], geom$params)
}
# background
grob.background <- element_render(theme, "legend.background")
ngeom <- length(guide$geoms) + 1
kcols <- rep(vps$key.col, each = ngeom)
krows <- rep(vps$key.row, each = ngeom)
# padding
padding <- unit(1.5, "mm")
widths <- c(padding, widths, padding)
heights <- c(padding, heights, padding)
# Create the gtable for the legend
gt <- gtable(widths = unit(widths, "mm"), heights = unit(heights, "mm"))
gt <- gtable_add_grob(gt, grob.background, name = "background", clip = "off",
t = 1, r = -1, b = -1, l = 1)
gt <- gtable_add_grob(gt, grob.title, name = "title", clip = "off",
t = 1 + min(vps.title.row), r = 1 + max(vps.title.col),
b = 1 + max(vps.title.row), l = 1 + min(vps.title.col))
gt <- gtable_add_grob(gt, grob.keys,
name = paste("key", krows, kcols, c("bg", seq(ngeom-1)), sep = "-"), clip = "off",
t = 1 + krows, r = 1 + kcols,
b = 1 + krows, l = 1 + kcols)
gt <- gtable_add_grob(gt, grob.labels,
name = paste("label", vps$label.row, vps$label.col, sep = "-"), clip = "off",
t = 1 + vps$label.row, r = 1 + vps$label.col,
b = 1 + vps$label.row, l = 1 + vps$label.col)
gt
}
ggplot2/R/summary.r 0000644 0001751 0000144 00000002470 12114160774 013735 0 ustar hornik users #' Displays a useful description of a ggplot object
#'
#' @param object ggplot2 object to summarise
#' @param ... other arguments ignored (for compatibility with generic)
#' @keywords internal
#' @method summary ggplot
#' @export
#' @examples
#' summary(qplot(mpg, wt, data=mtcars))
summary.ggplot <- function(object, ...) {
wrap <- function(x) paste(
paste(strwrap(x, exdent = 2), collapse = "\n"),
"\n", sep =""
)
defaults <- function() {
paste(mapply(function(x, n) {
paste(n, deparse(x), sep="=")
}, object$mapping, names(object$mapping)), collapse=", ")
}
# cat("Title: ", object$title, "\n", sep="")
# cat("-----------------------------------\n")
if (!is.null(object$data)) {
output <- paste(
"data: ", paste(names(object$data), collapse=", "),
" [", nrow(object$data), "x", ncol(object$data), "] ",
"\n", sep="")
cat(wrap(output))
}
if (length(object$mapping) > 0) {
cat("mapping: ", clist(object$mapping), "\n", sep="")
}
if (object$scales$n() > 0) {
cat("scales: ", paste(object$scales$input(), collapse = ", "), "\n")
}
cat("faceting: ")
print(object$facet)
if (length(object$layers) > 0)
cat("-----------------------------------\n")
invisible(lapply(object$layers, function(x) {print(x); cat("\n")}))
}
ggplot2/R/coord-.r 0000644 0001751 0000144 00000007305 12114160774 013425 0 ustar hornik users #' New coordinate system.
#'
#' Internal use only.
#'
#' @param ... object fields
#' @keywords internal
#' @export
coord <- function(..., subclass = c()) {
structure(list(...), class = c(subclass, "coord"))
}
#' Is this object a coordinate system?
#'
#' @export is.coord
#' @keywords internal
is.coord <- function(x) inherits(x, "coord")
distance <- function(., x, y, details) {
max_dist <- dist_euclidean(details$x.range, details$y.range)
dist_euclidean(x, y) / max_dist
}
coord_aspect <- function(coord, ranges)
UseMethod("coord_aspect")
#' @S3method coord_aspect default
coord_aspect.default <- function(coord, ranges) NULL
coord_labels <- function(coord, scales) UseMethod("coord_labels")
#' @S3method coord_labels default
coord_labels.default <- function(coord, scales) scales
coord_render_fg <- function(coord, scales, theme)
UseMethod("coord_render_fg")
#' @S3method coord_render_fg default
coord_render_fg.default <- function(coord, scales, theme)
element_render(theme, "panel.border")
coord_render_bg <- function(coord, scales, theme)
UseMethod("coord_render_bg")
#' @S3method coord_render_bg default
coord_render_bg.default <- function(coord, details, theme) {
x.major <- if(length(details$x.major) > 0) unit(details$x.major, "native")
x.minor <- if(length(details$x.minor) > 0) unit(details$x.minor, "native")
y.major <- if(length(details$y.major) > 0) unit(details$y.major, "native")
y.minor <- if(length(details$y.minor) > 0) unit(details$y.minor, "native")
guide_grid(theme, x.minor, x.major, y.minor, y.major)
}
coord_render_axis_h <- function(coord, scales, theme)
UseMethod("coord_render_axis_h")
#' @S3method coord_render_axis_h default
coord_render_axis_h.default <- function(coord, details, theme) {
guide_axis(details$x.major, details$x.labels, "bottom", theme)
}
coord_render_axis_v <- function(coord, scales, theme)
UseMethod("coord_render_axis_v")
#' @S3method coord_render_axis_v default
coord_render_axis_v.default <- function(coord, details, theme) {
guide_axis(details$y.major, details$y.labels, "left", theme)
}
coord_range <- function(coord, scales)
UseMethod("coord_range")
#' @S3method coord_range default
coord_range.default <- function(coord, scales) {
return(list(x = scales$x.range, y = scales$y.range))
}
coord_train <- function(coord, scales)
UseMethod("coord_train")
coord_transform <- function(coord, data, range)
UseMethod("coord_transform")
coord_distance <- function(coord, x, y, details)
UseMethod("coord_distance")
is.linear <- function(coord) UseMethod("is.linear")
#' @S3method is.linear default
is.linear.default <- function(coord) FALSE
#' Set the default expand values for the scale, if NA
#' @keywords internal
coord_expand_defaults <- function(coord, scale, aesthetic = NULL)
UseMethod("coord_expand_defaults")
#' @S3method coord_expand_defaults default
coord_expand_defaults.default <- function(coord, scale, aesthetic = NULL) {
# Expand the same regardless of whether it's x or y
# @kohske TODO:
# Here intentionally verbose. These constants may be held by coord as, say,
# coord$default.expand <- list(discrete = ..., continuous = ...)
#
# @kohske
# Now scale itself is not changed.
# This function only returns expanded (numeric) limits
discrete <- c(0, 0.6)
continuous <- c(0.05, 0)
expand_default(scale, discrete, continuous)
}
# This is a utility function used by coord_expand_defaults, to expand a single scale
expand_default <- function(scale, discrete = c(0, 0), continuous = c(0, 0)) {
# Default expand values for discrete and continuous scales
if (is.waive(scale$expand)) {
if (inherits(scale, "discrete")) discrete
else if (inherits(scale, "continuous")) continuous
} else {
return(scale$expand)
}
}
ggplot2/R/position-collide.r 0000644 0001751 0000144 00000006271 12114160774 015520 0 ustar hornik users # Detect and prevent collisions.
# Powers dodging, stacking and filling.
collide <- function(data, width = NULL, name, strategy, check.width = TRUE) {
# Determine width
if (!is.null(width)) {
# Width set manually
if (!(all(c("xmin", "xmax") %in% names(data)))) {
data <- within(data, {
xmin <- x - width / 2
xmax <- x + width / 2
})
}
} else {
if (!(all(c("xmin", "xmax") %in% names(data)))) {
data$xmin <- data$x
data$xmax <- data$x
}
# Width determined from data, must be floating point constant
widths <- unique(with(data, xmax - xmin))
widths <- widths[!is.na(widths)]
if (!zero_range(range(widths))) {
warning(name, " requires constant width: output may be incorrect",
call. = FALSE)
}
width <- widths[1]
}
# Reorder by x position, relying on stable sort to preserve existing
# ordering, which may be by group or order.
data <- data[order(data$xmin), ]
# Check for overlap
intervals <- as.numeric(t(unique(data[c("xmin", "xmax")])))
intervals <- intervals[!is.na(intervals)]
if (length(unique(intervals)) > 1 & any(diff(scale(intervals)) < -1e-6)) {
warning(name, " requires non-overlapping x intervals", call. = FALSE)
# This is where the algorithm from [L. Wilkinson. Dot plots.
# The American Statistician, 1999.] should be used
}
if (!is.null(data$ymax)) {
ddply(data, .(xmin), strategy, width = width)
} else if (!is.null(data$y)) {
message("ymax not defined: adjusting position using y instead")
transform(
ddply(transform(data, ymax = y), .(xmin), strategy, width = width),
y = ymax
)
} else {
stop("Neither y nor ymax defined")
}
}
# Stack overlapping intervals.
# Assumes that each set has the same horizontal position
pos_stack <- function(df, width) {
if (nrow(df) == 1) return(df)
n <- nrow(df) + 1
y <- with(df, ifelse(is.na(y), 0, y))
if (all(is.na(df$x))) {
heights <- rep(NA, n)
} else {
heights <- c(0, cumsum(y))
}
within(df, {
ymin <- heights[-n]
ymax <- heights[-1]
y <- ymax
})
}
# Stack overlapping intervals and set height to 1.
# Assumes that each set has the same horizontal position.
pos_fill <- function(df, width) {
within(pos_stack(df, width), {
ymin <- ymin / max(ymax)
ymax <- ymax / max(ymax)
y <- ymax
})
}
# Dodge overlapping interval.
# Assumes that each set has the same horizontal position.
pos_dodge <- function(df, width) {
n <- length(unique(df$group))
if (n == 1) return(df)
if (!all(c("xmin", "xmax") %in% names(df))) {
df$xmin <- df$x
df$xmax <- df$x
}
d_width <- max(df$xmax - df$xmin)
diff <- width - d_width
# df <- data.frame(n = c(2:5, 10, 26), div = c(4, 3, 2.666666, 2.5, 2.2, 2.1))
# qplot(n, div, data = df)
# Have a new group index from 1 to number of groups.
# This might be needed if the group numbers in this set don't include all of 1:n
groupidx <- match(df$group, sort(unique(df$group)))
# Find the center for each group, then use that to calculate xmin and xmax
df$x <- df$x + width * ((groupidx - 0.5) / n - .5)
df$xmin <- df$x - d_width / n / 2
df$xmax <- df$x + d_width / n / 2
df
}
ggplot2/R/save.r 0000644 0001751 0000144 00000011305 12114160774 013173 0 ustar hornik users #' Save a ggplot with sensible defaults
#'
#' ggsave is a convenient function for saving a plot. It defaults to
#' saving the last plot that you displayed, and for a default size uses
#' the size of the current graphics device. It also guesses the type of
#' graphics device from the extension. This means the only argument you
#' need to supply is the filename.
#'
#' \code{ggsave} currently recognises the extensions eps/ps, tex (pictex),
#' pdf, jpeg, tiff, png, bmp, svg and wmf (windows only).
#'
#' @param filename file name/filename of plot
#' @param plot plot to save, defaults to last plot displayed
#' @param device device to use, automatically extract from file name extension
#' @param path path to save plot to (if you just want to set path and not
#' filename)
#' @param scale scaling factor
#' @param width width (defaults to the width of current plotting window)
#' @param height height (defaults to the height of current plotting window)
#' @param units units for width and height when either one is explicitly specified (in, cm, or mm)
#' @param dpi dpi to use for raster graphics
#' @param limitsize when \code{TRUE} (the default), \code{ggsave} will not
#' save images larger than 50x50 inches, to prevent the common error of
#' specifying dimensions in pixels.
#' @param ... other arguments passed to graphics device
#' @export
#' @examples
#' \donttest{
#' ratings <- qplot(rating, data=movies, geom="histogram")
#' qplot(length, data=movies, geom="histogram")
#' ggsave(file="length-hist.pdf")
#' ggsave(file="length-hist.png")
#' ggsave(ratings, file="ratings.pdf")
#' ggsave(ratings, file="ratings.pdf", width=4, height=4)
#' # make twice as big as on screen
#' ggsave(ratings, file="ratings.pdf", scale=2)
#' }
ggsave <- function(filename = default_name(plot), plot = last_plot(),
device = default_device(filename), path = NULL, scale = 1,
width = par("din")[1], height = par("din")[2], units = c("in", "cm", "mm"),
dpi = 300, limitsize = TRUE, ...) {
if (!inherits(plot, "ggplot")) stop("plot should be a ggplot2 plot")
eps <- ps <- function(..., width, height)
grDevices::postscript(..., width=width, height=height, onefile=FALSE,
horizontal = FALSE, paper = "special")
tex <- function(..., width, height)
grDevices::pictex(..., width=width, height=height)
pdf <- function(..., version="1.4")
grDevices::pdf(..., version=version)
svg <- function(...)
grDevices::svg(...)
wmf <- function(..., width, height)
grDevices::win.metafile(..., width=width, height=height)
emf <- function(..., width, height)
grDevices::win.metafile(..., width=width, height=height)
png <- function(..., width, height)
grDevices::png(..., width=width, height=height, res = dpi, units = "in")
jpg <- jpeg <- function(..., width, height)
grDevices::jpeg(..., width=width, height=height, res = dpi, units = "in")
bmp <- function(..., width, height)
grDevices::bmp(..., width=width, height=height, res = dpi, units = "in")
tiff <- function(..., width, height)
grDevices::tiff(..., width=width, height=height, res = dpi, units = "in")
default_name <- function(plot) {
paste(digest.ggplot(plot), ".pdf", sep="")
}
default_device <- function(filename) {
pieces <- strsplit(filename, "\\.")[[1]]
ext <- tolower(pieces[length(pieces)])
match.fun(ext)
}
units <- match.arg(units)
convert_to_inches <- function(x, units) {
x <- switch(units,
`in` = x,
cm = x / 2.54,
mm = x / 2.54 /10
)
}
convert_from_inches <- function(x, units) {
x <- switch(units,
`in` = x,
cm = x * 2.54,
mm = x * 2.54 * 10
)
}
# dimensions need to be in inches for all graphic devices
# convert width and height into inches when they are specified
if (!missing(width)) {
width <- convert_to_inches(width, units)
}
if (!missing(height)) {
height <- convert_to_inches(height, units)
}
# if either width or height is not specified, display an information message
# units are those specified by the user
if (missing(width) || missing(height)) {
message("Saving ", prettyNum(convert_from_inches(width * scale, units), digits=3), " x ", prettyNum(convert_from_inches(height * scale, units), digits=3), " ", units, " image")
}
width <- width * scale
height <- height * scale
if (limitsize && (width >= 50 || height >= 50)) {
stop("Dimensions exceed 50 inches (height and width are specified in inches/cm/mm, not pixels).",
" If you are sure you want these dimensions, use 'limitsize=FALSE'.")
}
if (!is.null(path)) {
filename <- file.path(path, filename)
}
device(file=filename, width=width, height=height, ...)
on.exit(capture.output(dev.off()))
print(plot)
invisible()
}
ggplot2/R/guides-axis.r 0000644 0001751 0000144 00000007365 12114160774 014472 0 ustar hornik users # Grob for axes
#
# @param position of ticks
# @param labels at ticks
# @param position of axis (top, bottom, left or right)
# @param range of data values
guide_axis <- function(at, labels, position="right", theme) {
position <- match.arg(position, c("top", "bottom", "right", "left"))
# Quick fix for conflicts #297 and #118
# Previously, at = NA if there is no breaks (breaks = NA).
# Fix for oob bug changed so that at = numeric(0) if there is no breaks.
# Temporally, at is set as NA if there is no breaks.
# see also SHA: f332070fca77399a84ea7a116e8c63f6990abaf6, SHA: 2ae13ad0a856c24cab6a69b523da0936ef7a94d8
if (length(at) == 0) at <- NA
at <- unit(at, "native")
length <- theme$axis.ticks.length
label_pos <- length + theme$axis.ticks.margin
nticks <- length(at)
zero <- unit(0, "npc")
one <- unit(1, "npc")
label_render <- switch(position,
top = , bottom = "axis.text.x",
left = , right = "axis.text.y"
)
label_x <- switch(position,
top = ,
bottom = at,
right = label_pos,
left = one - label_pos
)
label_y <- switch(position,
top = label_pos,
bottom = one - label_pos,
right = ,
left = at,
)
if (is.list(labels)) {
if (any(sapply(labels, is.language))) {
labels <- do.call(expression, labels)
} else {
labels <- unlist(labels)
}
}
labels <- switch(position,
top = ,
bottom = element_render(theme, label_render, labels, x = label_x),
right = ,
left = element_render(theme, label_render, labels, y = label_y))
line <- switch(position,
top = element_render(theme, "axis.line.x", c(0, 1), c(0, 0), id.lengths = 2),
bottom = element_render(theme, "axis.line.x", c(0, 1), c(1, 1), id.lengths = 2),
right = element_render(theme, "axis.line.y", c(0, 0), c(0, 1), id.lengths = 2),
left = element_render(theme, "axis.line.y", c(1, 1), c(0, 1), id.lengths = 2)
)
ticks <- switch(position,
top = element_render(theme, "axis.ticks.x",
x = rep(at, each=2),
y = rep(unit.c(zero, length), nticks),
id.lengths = rep(2, nticks)),
bottom = element_render(theme, "axis.ticks.x",
x = rep(at, each=2),
y = rep(unit.c(one-length, one), nticks),
id.lengths = rep(2, nticks)),
right = element_render(theme, "axis.ticks.y",
x = rep(unit.c(zero, length), nticks),
y = rep(at, each=2),
id.lengths = rep(2, nticks)),
left = element_render(theme, "axis.ticks.y",
x = rep(unit.c(one-length, one), nticks),
y = rep(at, each=2),
id.lengths = rep(2, nticks))
)
# Create the gtable for the ticks + labels
gt <- switch(position,
top = gtable_col("axis",
grobs = list(labels, ticks),
width = one,
heights = unit.c(grobHeight(labels), label_pos)),
bottom = gtable_col("axis",
grobs = list(ticks, labels),
width = one,
heights = unit.c(label_pos, grobHeight(labels))),
right = gtable_row("axis",
grobs = list(ticks, labels),
widths = unit.c(label_pos, grobWidth(labels)),
height = one),
left = gtable_row("axis",
grobs = list(labels, ticks),
widths = unit.c(grobWidth(labels), label_pos),
height = one)
)
# Viewport for justifying the axis grob
justvp <- switch(position,
top = viewport(y = 0, just = "bottom", height = gtable_height(gt)),
bottom = viewport(y = 1, just = "top", height = gtable_height(gt)),
right = viewport(x = 0, just = "left", width = gtable_width(gt)),
left = viewport(x = 1, just = "right", width = gtable_width(gt))
)
absoluteGrob(
gList(line, gt),
width = gtable_width(gt),
height = gtable_height(gt),
vp = justvp
)
}
ggplot2/R/geom-pointrange.r 0000644 0001751 0000144 00000003250 12114160774 015330 0 ustar hornik users #' An interval represented by a vertical line, with a point in the middle.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "pointrange")}
#'
#' @inheritParams geom_point
#' @seealso
#' \code{\link{geom_errorbar}} for error bars,
#' \code{\link{geom_linerange}} for range indicated by straight line, + examples,
#' \code{\link{geom_crossbar}} for hollow bar with middle indicated by horizontal line,
#' \code{\link{stat_summary}} for examples of these guys in use,
#' \code{\link{geom_smooth}} for continuous analog"
#' @export
#' @examples
#' # See geom_linerange for examples
geom_pointrange <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", ...) {
GeomPointrange$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomPointrange <- proto(Geom, {
objname <- "pointrange"
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(colour = "black", size=0.5, linetype=1, shape=16, fill=NA, alpha = NA)
guide_geom <- function(.) "pointrange"
required_aes <- c("x", "y", "ymin", "ymax")
draw <- function(., data, scales, coordinates, ...) {
if (is.null(data$y)) return(GeomLinerange$draw(data, scales, coordinates, ...))
ggname(.$my_name(),gTree(children=gList(
GeomLinerange$draw(data, scales, coordinates, ...),
GeomPoint$draw(transform(data, size = size * 4), scales, coordinates, ...)
)))
}
draw_legend <- function(., data, ...) {
data <- aesdefaults(data, .$default_aes(), list(...))
grobTree(
GeomPath$draw_legend(data, ...),
GeomPoint$draw_legend(transform(data, size = size * 4), ...)
)
}
})
ggplot2/R/fortify-lm.r 0000644 0001751 0000144 00000005107 12114160774 014330 0 ustar hornik users #' Supplement the data fitted to a linear model with model fit statistics.
#'
#' If you have missing values in your model data, you may need to refit
#' the model with \code{na.action = na.exclude}.
#'
#'
#' @return The original data with extra columns:
#' \item{.hat}{Diagonal of the hat matrix}
#' \item{.sigma}{Estimate of residual standard deviation when
#' corresponding observation is dropped from model}
#' \item{.cooksd}{Cooks distance, \code{\link{cooks.distance}}}
#' \item{.fitted}{Fitted values of model}
#' \item{.resid}{Residuals}
#' \item{.stdresid}{Standardised residuals}
#' @param model linear model
#' @param data data set, defaults to data used to fit model
#' @param ... not used by this method
#' @method fortify lm
#' @S3method fortify lm
#' @examples
#'
#' mod <- lm(mpg ~ wt, data = mtcars)
#' head(fortify(mod))
#' head(fortify(mod, mtcars))
#'
#' plot(mod, which = 1)
#' qplot(.fitted, .resid, data = mod) +
#' geom_hline(yintercept = 0) +
#' geom_smooth(se = FALSE)
#' qplot(.fitted, .stdresid, data = mod) +
#' geom_hline(yintercept = 0) +
#' geom_smooth(se = FALSE)
#' qplot(.fitted, .stdresid, data = fortify(mod, mtcars),
#' colour = factor(cyl))
#' qplot(mpg, .stdresid, data = fortify(mod, mtcars), colour = factor(cyl))
#'
#' plot(mod, which = 2)
#' # qplot(sample =.stdresid, data = mod, stat = "qq") + geom_abline()
#'
#' plot(mod, which = 3)
#' qplot(.fitted, sqrt(abs(.stdresid)), data = mod) + geom_smooth(se = FALSE)
#'
#' plot(mod, which = 4)
#' qplot(seq_along(.cooksd), .cooksd, data = mod, geom = "bar",
#' stat="identity")
#'
#' plot(mod, which = 5)
#' qplot(.hat, .stdresid, data = mod) + geom_smooth(se = FALSE)
#' ggplot(mod, aes(.hat, .stdresid)) +
#' geom_vline(size = 2, colour = "white", xintercept = 0) +
#' geom_hline(size = 2, colour = "white", yintercept = 0) +
#' geom_point() + geom_smooth(se = FALSE)
#'
#' qplot(.hat, .stdresid, data = mod, size = .cooksd) +
#' geom_smooth(se = FALSE, size = 0.5)
#'
#' plot(mod, which = 6)
#' ggplot(mod, aes(.hat, .cooksd)) +
#' geom_vline(xintercept = 0, colour = NA) +
#' geom_abline(slope = seq(0, 3, by = 0.5), colour = "white") +
#' geom_smooth(se = FALSE) +
#' geom_point()
#' qplot(.hat, .cooksd, size = .cooksd / .hat, data = mod) + scale_area()
fortify.lm <- function(model, data = model$model, ...) {
infl <- influence(model, do.coef = FALSE)
data$.hat <- infl$hat
data$.sigma <- infl$sigma
data$.cooksd <- cooks.distance(model, infl)
data$.fitted <- predict(model)
data$.resid <- resid(model)
data$.stdresid <- rstandard(model, infl)
data
}
ggplot2/R/aaa-constants.r 0000644 0001751 0000144 00000000027 12114160774 014770 0 ustar hornik users .pt <- 1 / 0.352777778
ggplot2/R/stat-density.r 0000644 0001751 0000144 00000011343 12114161113 014653 0 ustar hornik users #' 1d kernel density estimate.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "density")}
#'
#' @param adjust see \code{\link{density}} for details
#' @param kernel kernel used for density estimation, see
#' \code{\link{density}} for details
#' @param trim if \code{TRUE}, the default, densities are trimmed to the
#' actual range of the data. If \code{FALSE}, they are extended by the
#' default 3 bandwidths (as specified by the \code{cut} parameter to
#' \code{\link{density}})
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @inheritParams stat_identity
#' @return data.frame with additional columns:
#' \item{density}{density estimate}
#' \item{count}{density * number of points - useful for stacked density
#' plots}
#' \item{scaled}{density estimate, scaled to maximum of 1}
#' @seealso \code{\link{stat_bin}} for the histogram
#' @export
#' @examples
#' \donttest{
#' m <- ggplot(movies, aes(x = rating))
#' m + geom_density()
#'
#' # Adjust parameters
#' m + geom_density(kernel = "rectangular")
#' m + geom_density(kernel = "biweight")
#' m + geom_density(kernel = "epanechnikov")
#' m + geom_density(adjust=1/5) # Very rough
#' m + geom_density(adjust=5) # Very smooth
#'
#' # Adjust aesthetics
#' m + geom_density(aes(fill=factor(Drama)), size=2)
#' # Scale so peaks have same height:
#' m + geom_density(aes(fill=factor(Drama), y = ..scaled..), size=2)
#'
#' m + geom_density(colour="darkgreen", size=2)
#' m + geom_density(colour="darkgreen", size=2, fill=NA)
#' m + geom_density(colour="darkgreen", size=2, fill="green")
#'
#' # Change scales
#' (m <- ggplot(movies, aes(x=votes)) + geom_density(trim = TRUE))
#' m + scale_x_log10()
#' m + coord_trans(x="log10")
#' m + scale_x_log10() + coord_trans(x="log10")
#'
#' # Also useful with
#' m + stat_bin()
#'
#' # Make a volcano plot
#' ggplot(diamonds, aes(x = price)) +
#' stat_density(aes(ymax = ..density.., ymin = -..density..),
#' fill = "grey50", colour = "grey50",
#' geom = "ribbon", position = "identity") +
#' facet_grid(. ~ cut) +
#' coord_flip()
#'
#' # Stacked density plots
#' # If you want to create a stacked density plot, you need to use
#' # the 'count' (density * n) variable instead of the default density
#'
#' # Loses marginal densities
#' qplot(rating, ..density.., data=movies, geom="density", fill=mpaa, position="stack")
#' # Preserves marginal densities
#' qplot(rating, ..count.., data=movies, geom="density", fill=mpaa, position="stack")
#'
#' # You can use position="fill" to produce a conditional density estimate
#' qplot(rating, ..count.., data=movies, geom="density", fill=mpaa, position="fill")
#'
#' # Need to be careful with weighted data
#' m <- ggplot(movies, aes(x=rating, weight=votes))
#' m + geom_histogram(aes(y = ..count..)) + geom_density(fill=NA)
#'
#' m <- ggplot(movies, aes(x=rating, weight=votes/sum(votes)))
#' m + geom_histogram(aes(y=..density..)) + geom_density(fill=NA, colour="black")
#'
#' library(plyr) # to access round_any
#' movies$decade <- round_any(movies$year, 10)
#' m <- ggplot(movies, aes(x=rating, colour=decade, group=decade))
#' m + geom_density(fill=NA)
#' m + geom_density(fill=NA) + aes(y = ..count..)
#'
#' # Use qplot instead
#' qplot(length, data=movies, geom="density", weight=rating)
#' qplot(length, data=movies, geom="density", weight=rating/sum(rating))
#' }
stat_density <- function (mapping = NULL, data = NULL, geom = "area", position = "stack",
adjust = 1, kernel = "gaussian", trim = FALSE, na.rm = FALSE, ...) {
StatDensity$new(mapping = mapping, data = data, geom = geom, position = position,
adjust = adjust, kernel = kernel, trim = trim, na.rm = na.rm, ...)
}
StatDensity <- proto(Stat, {
objname <- "density"
calculate <- function(., data, scales, adjust=1, kernel="gaussian", trim=FALSE, na.rm = FALSE, ...) {
data <- remove_missing(data, na.rm, "x", name = "stat_density",
finite = TRUE)
n <- nrow(data)
if (n < 3) return(data.frame())
if (is.null(data$weight)) data$weight <- rep(1, n) / n
range <- scale_dimension(scales$x, c(0, 0))
xgrid <- seq(range[1], range[2], length=200)
dens <- density(data$x, adjust=adjust, kernel=kernel, weight=data$weight, from=range[1], to=range[2])
densdf <- as.data.frame(dens[c("x","y")])
densdf$scaled <- densdf$y / max(densdf$y, na.rm = TRUE)
if (trim) densdf <- subset(densdf, x > min(data$x, na.rm = TRUE) & x < max(data$x, na.rm = TRUE))
densdf$count <- densdf$y * n
rename(densdf, c(y = "density"), warn_missing = FALSE)
}
default_geom <- function(.) GeomArea
default_aes <- function(.) aes(y = ..density.., fill=NA)
required_aes <- c("x")
})
ggplot2/R/fortify-spatial.r 0000644 0001751 0000144 00000005356 12114160774 015363 0 ustar hornik users #' Fortify method for classes from the sp package.
#'
#' To figure out the correct variable name for region, inspect
#' \code{as.data.frame(model)}.
#'
#' @param model \code{SpatialPolygonsDataFrame} to convert into a dataframe.
#' @param data not used by this method
#' @param region name of variable used to split up regions
#' @param ... not used by this method
#' @name fortify.sp
#' @examples
#' if (require("maptools")) {
#' sids <- system.file("shapes/sids.shp", package="maptools")
#' nc1 <- readShapePoly(sids,
#' proj4string = CRS("+proj=longlat +datum=NAD27"))
#' nc1_df <- fortify(nc1)
#' }
NULL
#' @rdname fortify.sp
#' @export
#' @method fortify SpatialPolygonsDataFrame
fortify.SpatialPolygonsDataFrame <- function(model, data, region = NULL, ...) {
attr <- as.data.frame(model)
# If not specified, split into regions based on polygons
if (is.null(region)) {
coords <- ldply(model@polygons,fortify)
message("Regions defined for each Polygons")
} else {
cp <- polygons(model)
try_require("maptools")
# Union together all polygons that make up a region
unioned <- unionSpatialPolygons(cp, attr[, region])
coords <- fortify(unioned)
coords$order <- 1:nrow(coords)
}
coords
}
#' @rdname fortify.sp
#' @export
#' @method fortify SpatialPolygons
fortify.SpatialPolygons <- function(model, data, ...) {
ldply(model@polygons, fortify)
}
#' @rdname fortify.sp
#' @export
#' @method fortify Polygons
fortify.Polygons <- function(model, data, ...) {
subpolys <- model@Polygons
pieces <- ldply(seq_along(subpolys), function(i) {
df <- fortify(subpolys[[model@plotOrder[i]]])
df$piece <- i
df
})
within(pieces,{
order <- 1:nrow(pieces)
id <- model@ID
piece <- factor(piece)
group <- interaction(id, piece)
})
}
#' @rdname fortify.sp
#' @export
#' @method fortify Polygon
fortify.Polygon <- function(model, data, ...) {
df <- as.data.frame(model@coords)
names(df) <- c("long", "lat")
df$order <- 1:nrow(df)
df$hole <- model@hole
df
}
#' @rdname fortify.sp
#' @export
#' @method fortify SpatialLinesDataFrame
fortify.SpatialLinesDataFrame <- function(model, data, ...) {
ldply(model@lines, fortify)
}
#' @rdname fortify.sp
#' @export
#' @method fortify Lines
fortify.Lines <- function(model, data, ...) {
lines <- model@Lines
pieces <- ldply(seq_along(lines), function(i) {
df <- fortify(lines[[i]])
df$piece <- i
df
})
within(pieces,{
order <- 1:nrow(pieces)
id <- model@ID
piece <- factor(piece)
group <- interaction(id, piece)
})
}
#' @rdname fortify.sp
#' @export
#' @method fortify Line
fortify.Line <- function(model, data, ...) {
df <- as.data.frame(model@coords)
names(df) <- c("long", "lat")
df$order <- 1:nrow(df)
df
}
ggplot2/R/facet-.r 0000644 0001751 0000144 00000003241 12114160774 013374 0 ustar hornik users #' Facet specification.
#'
#' Create new facetting specification. For internal use only.
#'
#' @param ... object fields
#' @param shrink shrink scales to fit output of statistics, not raw data
#' @keywords internal
#' @export
facet <- function(..., shrink = TRUE, subclass = c()) {
structure(list(..., shrink = shrink), class = c(subclass, "facet"))
}
#' Is this object a facetting specification?
#'
#' @param x object to test
#' @keywords internal
#' @export
is.facet <- function(x) inherits(x, "facet")
# Figure out layout from data from plot and all layers.
#
# This creates the layout data frame which maps from data values to
# panel coordinates: ROW, COL and PANEL. It also records the panels that
# contribute to each x and y scale.
#
# @param data a list of data frames (one for the plot and one for each
# layer)
facet_train_layout <- function(facet, data)
UseMethod("facet_train_layout")
facet_map_layout <- function(facet, data, layout)
UseMethod("facet_map_layout")
facet_render <- function(facet, panels_grob, coord, theme, geom_grobs)
UseMethod("facet_render")
facet_strips <- function(facet, panel, theme)
UseMethod("facet_strips")
facet_panels <- function(facet, panel, coord, theme, geom_grobs)
UseMethod("facet_panels")
facet_axes <- function(facet, panel, coord, theme)
UseMethod("facet_axes")
# Text description of facetting variables
facet_vars <- function(facet)
UseMethod("facet_vars")
#' @S3method format facet
format.facet <- function(x, ...) {
name <- paste(rev(class(x)), collapse = "_")
paste(name, "(", facet_vars(x), ")", sep = "")
}
#' @S3method print facet
print.facet <- function(x, ...) {
cat(format(x, ...), "\n")
}
ggplot2/R/stat-ecdf.r 0000644 0001751 0000144 00000003016 12114160774 014107 0 ustar hornik users #' Empirical Cumulative Density Function
#'
#' @inheritParams stat_identity
#' @param n if NULL, do not interpolate. If not NULL, this is the number
#' of points to interpolate with.
#' @return a data.frame with additional columns:
#' \item{x}{x in data}
#' \item{y}{cumulative density corresponding x}
#' @export
#' @examples
#' \donttest{
#' qplot(rnorm(1000), stat = "ecdf", geom = "step")
#'
#' df <- data.frame(x = c(rnorm(100, 0, 3), rnorm(100, 0, 10)),
#' g = gl(2, 100))
#'
#' ggplot(df, aes(x, colour = g)) + stat_ecdf()
#' }
stat_ecdf <- function (mapping = NULL, data = NULL, geom = "step", position = "identity", n = NULL, ...) {
StatEcdf$new(mapping = mapping, data = data, geom = geom, position = position, n = n, ...)
}
StatEcdf <- proto(Stat, {
objname <- "ecdf"
calculate <- function(., data, scales, n = NULL, ...) {
# If n is NULL, use raw values; otherwise interpolate
if (is.null(n)) {
xvals <- unique(data$x)
} else {
xvals <- seq(min(data$x), max(data$x), length.out = n)
}
y <- ecdf(data$x)(xvals)
# make point with y = 0, from plot.stepfun
rx <- range(xvals)
if (length(xvals) > 1L) {
dr <- max(0.08 * diff(rx), median(diff(xvals)))
} else {
dr <- abs(xvals)/16
}
x0 <- rx[1] - dr
x1 <- rx[2] + dr
y0 <- 0
y1 <- 1
data.frame(x = c(x0, xvals, x1), y = c(y0, y, y1))
}
default_aes <- function(.) aes(y = ..y..)
required_aes <- c("x")
default_geom <- function(.) GeomStep
})
ggplot2/R/geom-text.r 0000644 0001751 0000144 00000006342 12114160774 014153 0 ustar hornik users #' Textual annotations.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "text")}
#'
#' @inheritParams geom_point
#' @param parse If TRUE, the labels will be parsed into expressions and
#' displayed as described in ?plotmath
#' @export
#' @examples
#' \donttest{
#' p <- ggplot(mtcars, aes(x=wt, y=mpg, label=rownames(mtcars)))
#'
#' p + geom_text()
#' # Change size of the label
#' p + geom_text(size=10)
#' p <- p + geom_point()
#'
#' # Set aesthetics to fixed value
#' p + geom_text()
#' p + geom_point() + geom_text(hjust=0, vjust=0)
#' p + geom_point() + geom_text(angle = 45)
#'
#' # Add aesthetic mappings
#' p + geom_text(aes(colour=factor(cyl)))
#' p + geom_text(aes(colour=factor(cyl))) + scale_colour_discrete(l=40)
#'
#' p + geom_text(aes(size=wt))
#' p + geom_text(aes(size=wt)) + scale_size(range=c(3,6))
#'
#' # You can display expressions by setting parse = TRUE. The
#' # details of the display are described in ?plotmath, but note that
#' # geom_text uses strings, not expressions.
#' p + geom_text(aes(label = paste(wt, "^(", cyl, ")", sep = "")),
#' parse = TRUE)
#'
#' # Add an annotation not from a variable source
#' c <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
#' c + geom_text(data = NULL, x = 5, y = 30, label = "plot mpg vs. wt")
#' # Or, you can use annotate
#' c + annotate("text", label = "plot mpg vs. wt", x = 2, y = 15, size = 8, colour = "red")
#'
#' # Use qplot instead
#' qplot(wt, mpg, data = mtcars, label = rownames(mtcars),
#' geom=c("point", "text"))
#' qplot(wt, mpg, data = mtcars, label = rownames(mtcars), size = wt) +
#' geom_text(colour = "red")
#'
#' # You can specify family, fontface and lineheight
#' p <- ggplot(mtcars, aes(x=wt, y=mpg, label=rownames(mtcars)))
#' p + geom_text(fontface=3)
#' p + geom_text(aes(fontface=am+1))
#' p + geom_text(aes(family=c("serif", "mono")[am+1]))
#' }
geom_text <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",
parse = FALSE, ...) {
GeomText$new(mapping = mapping, data = data, stat = stat, position = position,
parse = parse, ...)
}
GeomText <- proto(Geom, {
objname <- "text"
draw_groups <- function(., ...) .$draw(...)
draw <- function(., data, scales, coordinates, ..., parse = FALSE, na.rm = FALSE) {
data <- remove_missing(data, na.rm,
c("x", "y", "label"), name = "geom_text")
lab <- data$label
if (parse) {
lab <- parse(text = lab)
}
with(coord_transform(coordinates, data, scales),
textGrob(lab, x, y, default.units="native",
hjust=hjust, vjust=vjust, rot=angle,
gp = gpar(col = alpha(colour, alpha), fontsize = size * .pt,
fontfamily = family, fontface = fontface, lineheight = lineheight))
)
}
draw_legend <- function(., data, ...) {
data <- aesdefaults(data, .$default_aes(), list(...))
with(data,
textGrob("a", 0.5, 0.5, rot = angle,
gp=gpar(col=alpha(colour, alpha), fontsize = size * .pt))
)
}
default_stat <- function(.) StatIdentity
required_aes <- c("x", "y", "label")
default_aes <- function(.) aes(colour="black", size=5 , angle=0, hjust=0.5,
vjust=0.5, alpha = NA, family="", fontface=1, lineheight=1.2)
guide_geom <- function(x) "text"
})
ggplot2/R/grob-null.r 0000644 0001751 0000144 00000001067 12114160774 014142 0 ustar hornik users #' The zero grob draws nothing and has zero size.
#'
#' @S3method widthDetails zeroGrob
#' @S3method heightDetails zeroGrob
#' @S3method grobWidth zeroGrob
#' @S3method grobHeight zeroGrob
#' @S3method drawDetails zeroGrob
#' @keywords internal
zeroGrob <- function() .zeroGrob
.zeroGrob <- grob(cl = "zeroGrob", name = "NULL")
widthDetails.zeroGrob <-
heightDetails.zeroGrob <-
grobWidth.zeroGrob <-
grobHeight.zeroGrob <- function(x) unit(0, "cm")
drawDetails.zeroGrob <- function(x, recording) {}
is.zero <- function(x) is.null(x) || inherits(x, "zeroGrob")
ggplot2/R/position-stack.r 0000644 0001751 0000144 00000003621 12114160774 015206 0 ustar hornik users #' Stack overlapping objects on top of one another.
#'
#' @inheritParams position_identity
#' @family position adjustments
#' @export
#' @examples
#' # Stacking is the default behaviour for most area plots:
#' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + geom_bar()
#'
#' # To change stacking order, use factor() to change order of levels
#' mtcars$vs <- factor(mtcars$vs, levels = c(1,0))
#' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + geom_bar()
#'
#' ggplot(diamonds, aes(price)) + geom_histogram(binwidth=500)
#' ggplot(diamonds, aes(price, fill = cut)) + geom_histogram(binwidth=500)
#'
#' # Stacking is also useful for time series
#' data.set <- data.frame(
#' Time = c(rep(1, 4),rep(2, 4), rep(3, 4), rep(4, 4)),
#' Type = rep(c('a', 'b', 'c', 'd'), 4),
#' Value = rpois(16, 10)
#' )
#'
#' qplot(Time, Value, data = data.set, fill = Type, geom = "area")
#' # If you want to stack lines, you need to say so:
#' qplot(Time, Value, data = data.set, colour = Type, geom = "line")
#' qplot(Time, Value, data = data.set, colour = Type, geom = "line",
#' position = "stack")
#' # But realise that this makes it *much* harder to compare individual
#' # trends
position_stack <- function (width = NULL, height = NULL) {
PositionStack$new(width = width, height = height)
}
PositionStack <- proto(Position, {
objname <- "stack"
adjust <- function(., data) {
if (empty(data)) return(data.frame())
data <- remove_missing(data, FALSE,
c("x", "y", "ymin", "ymax", "xmin", "xmax"), name = "position_stack")
if (is.null(data$ymax) && is.null(data$y)) {
message("Missing y and ymax in position = 'stack'. ",
"Maybe you want position = 'identity'?")
return(data)
}
if (!is.null(data$ymin) && !all(data$ymin == 0))
warning("Stacking not well defined when ymin != 0", call. = FALSE)
collide(data, .$width, .$my_name(), pos_stack)
}
})
ggplot2/R/utilities-matrix.r 0000644 0001751 0000144 00000005627 12114160774 015564 0 ustar hornik users #' Row weave.
#'
#' Weave together two (or more) matrices by row.
#'
#' Matrices must have same dimensions.
#'
#' @param ... matrices to weave together
#' @keywords internal
#' @S3method rweave list
#' @S3method rweave matrix
#X a <- matrix(1:10 * 2, ncol = 2)
#X b <- matrix(1:10 * 3, ncol = 2)
#X c <- matrix(1:10 * 5, ncol = 2)
rweave <- function(...) UseMethod("rweave")
rweave.list <- function(...) do.call("rweave", ...)
rweave.matrix <- function(...) {
matrices <- list(...)
stopifnot(equal_dims(matrices))
n <- nrow(matrices[[1]])
p <- length(matrices)
interleave <- rep(1:n, each = p) + seq(0, p - 1) * n
do.call("rbind", matrices)[interleave, , drop = FALSE]
}
# Col union
# Form the union of columns in a and b. If there are columns of the same name in both a and b, take the column from a.
#
# @param data frame a
# @param data frame b
# @keyword internal
cunion <- function(a, b) {
if (length(a) == 0) return(b)
if (length(b) == 0) return(a)
cbind(a, b[setdiff(names(b), names(a))])
}
#' Col weave
#'
#' Weave together two (or more) matrices by column
#'
#' Matrices must have same dimensions
#'
#' @param ... matrices to weave together
#' @keywords internal
#' @S3method cweave list
#' @S3method cweave matrix
cweave <- function(...) UseMethod("cweave")
cweave.list <- function(...) do.call("cweave", ...)
cweave.matrix <- function(...) {
matrices <- list(...)
stopifnot(equal_dims(matrices))
n <- ncol(matrices[[1]])
p <- length(matrices)
interleave <- rep(1:n, each = p) + seq(0, p - 1) * n
do.call("cbind", matrices)[, interleave, drop = FALSE]
}
#' Interleave (or zip) multiple vectors into a single vector.
#'
#' @param ... vectors to interleave
#' @keywords internal
#' @S3method interleave list
#' @S3method interleave unit
#' @S3method interleave default
interleave <- function(...) UseMethod("interleave")
interleave.list <- function(...) do.call("interleave", ...)
interleave.unit <- function(...) {
do.call("unit.c", do.call("interleave.default", llply(list(...), as.list)))
}
interleave.default <- function(...) {
vectors <- list(...)
# Check lengths
lengths <- unique(setdiff(laply(vectors, length), 1))
if (length(lengths) == 0) lengths <- 1
stopifnot(length(lengths) <= 1)
# Replicate elements of length one up to correct length
singletons <- laply(vectors, length) == 1
vectors[singletons] <- llply(vectors[singletons], rep, lengths)
# Interleave vectors
n <- lengths
p <- length(vectors)
interleave <- rep(1:n, each = p) + seq(0, p - 1) * n
unlist(vectors, recursive=FALSE)[interleave]
}
# Equal dims?
# Check that a list of matrices have equal dimensions
#
# @param list of matrices
# @keyword internal
equal_dims <- function(matrices) {
are.matrices <- laply(matrices, is.matrix)
stopifnot(all(are.matrices))
cols <- laply(matrices, ncol)
rows <- laply(matrices, ncol)
length(unique(cols) == 1) && length(unique(rows) == 1)
}
ggplot2/R/translate-qplot-base.r 0000644 0001751 0000144 00000012162 12114160774 016301 0 ustar hornik users #' Translating between qplot and base graphics
#'
#' There are two types of graphics functions in base graphics, those that draw
#' complete graphics and those that add to existing graphics.
#'
#' qplot() has been designed to mimic plot(), and can do the job of all other
#' high-level plotting commands. There are only two graph types from base
#' graphics that cannot be replicated with ggplot2: filled.contour() and
#' persp()
#'
#' @name translate_qplot_base
#' @examples
#' \donttest{
#'
#' # High-level plotting commands
#'
#' x <- runif(10)
#' y <- 1:10
#' plot(x, y); dotchart(x, y)
#' qplot(x, y)
#'
#' plot(x, y, type = "l")
#' qplot(x, y, geom = "line")
#'
#' plot(x, y, type = "s")
#' qplot(x, y, geom = "step")
#'
#' plot(x, y, type = "b")
#' qplot(x, y, geom = c("point", "line"))
#'
#' boxplot(x, y)
#' qplot(x, y, geom = "boxplot")
#'
#' hist(x)
#' qplot(x, geom = "histogram")
#'
#' # cdplot(factor(x), y)
#' # qplot(x, fill = y, geom = "density", position = "fill")
#'
#' # coplot(y ~ x | a + b)
#' # qplot(x, y, facets = a ~ b)
#'
#' # Many of the geoms are parameterised differently than base graphics. For
#' # example, hist() is parameterised in terms of the number of bins, while
#' # geom_histogram() is parameterised in terms of the width of each bin.
#' hist(x, bins = 10)
#' qplot(x, geom = "histogram", binwidth = .1)
#'
#' # qplot() often requires data in a slightly different format to the base
#' # graphics functions. For example, the bar geom works with untabulated data,
#' # not tabulated data like barplot(); the tile and contour geoms expect data
#' # in a data frame, not a matrix like image() and contour().
#' barplot(table(x))
#' qplot(x, geom = "bar")
#'
#' barplot(x)
#' qplot(seq_along(x), x, geom = "bar", stat = "identity")
#'
#' # image(x)
#' # qplot(X1, X2, data = melt(x), geom = "tile", fill = value)
#'
#' # contour(x)
#' # qplot(X1, X2, data = melt(x), geom = "contour", fill = value)
#'
#' # Generally, the base graphics functions work with individual vectors, not
#' # data frames like ggplot2. qplot() will try to construct a data frame if one
#' # is not specified, but it is not always possible. If you get strange errors,
#' # you may need to create the data frame yourself.
#' df <- data.frame(x = x, y = y)
#' with(df, plot(x, y))
#' qplot(x, y, data = df)
#'
#' # By default, qplot() maps values to aesthetics with a scale. To override
#' # this behaviour and set aesthetics, overriding the defaults, you need to use I().
#' plot(x, y, col = "red", cex = 1)
#' qplot(x, y, colour = I("red"), size = I(1))
#'
#' # Low-level drawing
#'
#' # The low-level drawing functions which add to an existing plot are equivalent
#' # to adding a new layer in ggplot2.
#'
#' # Base function ggplot2 layer
#' # curve() geom_curve()
#' # hline() geom_hline()
#' # lines() geom_line()
#' # points() geom_point()
#' # polygon() geom_polygon()
#' # rect() geom_rect()
#' # rug() geom_rug()
#' # segments() geom_segment()
#' # text() geom_text()
#' # vline() geom_vline()
#' # abline(lm(y ~ x)) geom_smooth(method = "lm")
#' # lines(density(x)) geom_density()
#' # lines(loess(x, y)) geom_smooth()
#'
#' plot(x, y)
#' lines(x, y)
#'
#' qplot(x, y) + geom_line()
#'
#' # Or, building up piece-meal
#' qplot(x, y)
#' last_plot() + geom_line()
#'
#' # Legends, axes and grid lines
#'
#' # In ggplot2, the appearance of legends and axes is controlled by the scales.
#' # Axes are produced by the x and y scales, while all other scales produce legends.
#' # See ?theme for help changing the appearance of axes and legends.
#' # The appearance of grid lines is controlled by the grid.major and grid.minor
#' # theme options, and their position by the breaks of the x and y scales.
#'
#' # Colour palettes
#'
#' # Instead of global colour palettes, ggplot2 has scales for individual plots. Much
#' # of the time you can rely on the default colour scale (which has somewhat better
#' # perceptual properties), but if you want to reuse an existing colour palette, you
#' # can use scale_colour_manual(). You will need to make sure that the colour
#' # is a factor for this to work.
#'
#' palette(rainbow(5))
#' plot(1:5, 1:5, col = 1:5, pch = 19, cex = 4)
#'
#' qplot(1:5, 1:5, col = factor(1:5), size = I(4))
#' last_plot() + scale_colour_manual(values = rainbow(5))
#'
#' # In ggplot2, you can also use palettes with continuous values,
#' # with intermediate values being linearly interpolated.
#'
#' qplot(0:100, 0:100, col = 0:100, size = I(4)) +
#' scale_colour_gradientn(colours = rainbow(7))
#' last_plot() + scale_colour_gradientn(colours = terrain.colors(7))
#'
#' # Graphical parameters
#'
#' # The majority of par settings have some analogue within the theme system, or
#' # in the defaults of the geoms and scales. The appearance plot border drawn
#' # by box() can be controlled in a similar way by the panel.background and
#' # plot.background theme elements. Instead of using title(), the plot title is
#' # set with the title option. See ?theme for more theme elements.
#' last_plot() + labs(title = "My Plot Title")
#' }
NULL
ggplot2/R/coord-munch.r 0000644 0001751 0000144 00000014630 12114161113 014443 0 ustar hornik users coord_munch <- function(coord, data, range, segment_length = 0.01) {
if (is.linear(coord)) return(coord_transform(coord, data, range))
# range has theta and r values; get corresponding x and y values
ranges <- coord_range(coord, range)
# Convert any infinite locations into max/min
# Only need to work with x and y because for munching, those are the
# only position aesthetics that are transformed
data$x[data$x == -Inf] <- ranges$x[1]
data$x[data$x == Inf] <- ranges$x[2]
data$y[data$y == -Inf] <- ranges$y[1]
data$y[data$y == Inf] <- ranges$y[2]
# Calculate distances using coord distance metric
dist <- coord_distance(coord, data$x, data$y, range)
dist[data$group[-1] != data$group[-nrow(data)]] <- NA
# Munch and then transform result
munched <- munch_data(data, dist, segment_length)
coord_transform(coord, munched, range)
}
# For munching, only grobs are lines and polygons: everything else is
# transfomed into those special cases by the geom.
#
# @param dist distance, scaled from 0 to 1 (maximum distance on plot)
# @keyword internal
munch_data <- function(data, dist = NULL, segment_length = 0.01) {
n <- nrow(data)
if (is.null(dist)) {
data <- add_group(data)
dist <- dist_euclidean(data$x, data$y)
}
# How many pieces for each old segment
extra <- floor(dist / segment_length) + 1
extra[is.na(extra)] <- 1
# Generate extra pieces for x and y values
x <- unlist(mapply(interp, data$x[-n], data$x[-1], extra, SIMPLIFY = FALSE))
y <- unlist(mapply(interp, data$y[-n], data$y[-1], extra, SIMPLIFY = FALSE))
# Replicate other aesthetics: defined by start point
id <- rep(seq_len(nrow(data) - 1), extra)
aes_df <- data[id, setdiff(names(data), c("x", "y"))]
unrowname(data.frame(x = x, y = y, aes_df))
}
# Interpolate.
# Interpolate n evenly spaced steps from start to end - (end - start) / n.
interp <- function(start, end, n) {
if (n == 1) return(start)
start + seq(0, 1, length = n) * (end - start)
}
# Euclidean distance between points.
# NA indicates a break / terminal points
dist_euclidean <- function(x, y) {
n <- length(x)
sqrt((x[-n] - x[-1]) ^ 2 + (y[-n] - y[-1]) ^ 2)
}
# Compute central angle between two points.
# Multiple by radius of sphere to get great circle distance
# @arguments longitude
# @arguments latitude
dist_central_angle <- function(lon, lat) {
# Convert to radians
lat <- lat * pi / 180
lon <- lon * pi / 180
hav <- function(x) sin(x / 2) ^ 2
ahav <- function(x) 2 * asin(x)
n <- length(lat)
ahav(sqrt(hav(diff(lat)) + cos(lat[-n]) * cos(lat[-1]) * hav(diff(lon))))
}
# Polar dist.
# Polar distance between points. This does not give the straight-line
# distance between points in polar space. Instead, it gives the distance
# along lines that _were_ straight in cartesian space, but have been
# warped into polar space. These lines are all spiral arcs, circular
# arcs, or segments of rays.
dist_polar <- function(r, theta) {
# Pretending that theta is x and r is y, find the slope and intercepts
# for each line segment.
# This is just like finding the x-intercept of a line in cartesian coordinates.
lf <- find_line_formula(theta, r)
# Rename x and y columns to r and t, since we're working in polar
# Note that 'slope' actually means the spiral slope, 'a' in the spiral
# formula r = a * theta
lf <- rename(lf, c(x1 = "t1", x2 = "t2", y1 = "r1", y2 = "r2",
yintercept = "r_int", xintercept = "t_int"), warn_missing = FALSE)
# Re-normalize the theta values so that intercept for each is 0
# This is necessary for calculating spiral arc length.
# If the formula is r=a*theta, there's a big difference between
# calculating the arc length from theta = 0 to pi/2, vs.
# theta = 2*pi to pi/2
lf$tn1 <- lf$t1 - lf$t_int
lf$tn2 <- lf$t2 - lf$t_int
# Add empty distance column
lf$dist <- NA_real_
# There are three types of lines, which we handle in turn:
# - Spiral arcs (r and theta change)
# - Circular arcs (r is constant)
# - Rays (theta is constant)
# Get spiral arc length for segments that have non-zero, non-infinite slope
# (spiral_arc_length only works for actual spirals, not circle arcs or rays)
# Use the _normalized_ theta values for arc length calculation
# Also make sure to ignore NA's because they cause problems when used on left
# side assignment.
idx <- !is.na(lf$slope) & lf$slope != 0 & !is.infinite(lf$slope)
idx[is.na(idx)] <- FALSE
lf$dist[idx] <-
spiral_arc_length(lf$slope[idx], lf$tn1[idx], lf$tn2[idx])
# Get cicular arc length for segments that have zero slope (r1 == r2)
idx <- !is.na(lf$slope) & lf$slope == 0
lf$dist[idx] <- lf$r1[idx] * (lf$t2[idx] - lf$t1[idx])
# Get radial length for segments that have infinite slope (t1 == t2)
idx <- !is.na(lf$slope) & is.infinite(lf$slope)
lf$dist[idx] <- lf$r1[idx] - lf$r2[idx]
# Find the maximum possible length, a spiral line from
# (r=0, theta=0) to (r=1, theta=2*pi)
max_dist <- spiral_arc_length(1 / (2 * pi), 0, 2 * pi)
# Final distance values, normalized
abs(lf$dist / max_dist)
}
# Given n points, find the slope, xintercept, and yintercept of
# the lines connecting them.
#
# This returns a data frame with length(x)-1 rows
#
# @param x A vector of x values
# @param y A vector of y values
# @examples
# find_line_formula(c(4, 7), c(1, 5))
# find_line_formula(c(4, 7, 9), c(1, 5, 3))
find_line_formula <- function(x, y) {
slope <- diff(y) / diff(x)
yintercept <- y[-1] - (slope * x[-1])
xintercept <- x[-1] - (y[-1] / slope)
data.frame(x1 = x[-length(x)], y1 = y[-length(y)],
x2 = x[-1], y2 = y[-1],
slope = slope, yintercept = yintercept, xintercept = xintercept)
}
# Spiral arc length
#
# Each segment consists of a spiral line of slope 'a' between angles
# 'theta1' and 'theta2'. Because each segment has its own _normalized_
# slope, the ending theta2 value may not be the same as the starting
# theta1 value of the next point.
#
# @param a A vector of spiral "slopes". Each spiral is defined as r = a * theta.
# @param theta1 A vector of starting theta values.
# @param theta2 A vector of ending theta values.
# @examples
# spiral_arc_length(a = c(0.2, 0.5), c(0.5 * pi, pi), c(pi, 1.25 * pi))
spiral_arc_length <- function(a, theta1, theta2) {
# Archimedes' spiral arc length formula from
# http://mathworld.wolfram.com/ArchimedesSpiral.html
0.5 * a * (
(theta1 * sqrt(1 + theta1 * theta1) + asinh(theta1)) -
(theta2 * sqrt(1 + theta2 * theta2) + asinh(theta2)))
}
ggplot2/R/plot.r 0000644 0001751 0000144 00000011074 12114160774 013216 0 ustar hornik users #' Create a new ggplot plot
#'
#' \code{ggplot()} initializes a ggplot object. It can be used to
#' declare the input data frame for a graphic and to specify the
#' set of plot aesthetics intended to be common throughout all
#' subsequent layers unless specifically overridden.
#'
#' \code{ggplot()} is typically used to construct a plot
#' incrementally, using the + operator to add layers to the
#' existing ggplot object. This is advantageous in that the
#' code is explicit about which layers are added and the order
#' in which they are added. For complex graphics with multiple
#' layers, initialization with \code{ggplot} is recommended.
#'
#' There are three common ways to invoke \code{ggplot}:
#' \itemize{
#' \item \code{ggplot(df, aes(x, y, ))}
#' \item \code{ggplot(df)}
#' \item \code{ggplot()}
#' }
#' The first method is recommended if all layers use the same
#' data and the same set of aesthetics, although this method
#' can also be used to add a layer using data from another
#' data frame. See the first example below. The second
#' method specifies the default data frame to use for the plot,
#' but no aesthetics are defined up front. This is useful when
#' one data frame is used predominantly as layers are added,
#' but the aesthetics may vary from one layer to another. The
#' third method initializes a skeleton \code{ggplot} object which
#' is fleshed out as layers are added. This method is useful when
#' multiple data frames are used to produce different layers, as
#' is often the case in complex graphics.
#'
#' The examples below illustrate how these methods of
#' invoking \code{ggplot} can be used in constructing a
#' graphic.
#' @seealso \url{http://had.co.nz/ggplot2}
#' @export
#' @keywords internal
#' @param data default data set
#' @param ... other arguments passed to specific methods
#' @examples
#
#' df <- data.frame(gp = factor(rep(letters[1:3], each = 10)),
#' y = rnorm(30))
#' # Compute sample mean and standard deviation in each group
#' library(plyr)
#' ds <- ddply(df, .(gp), summarise, mean = mean(y), sd = sd(y))
#'
#' # Declare the data frame and common aesthetics.
#' # The summary data frame ds is used to plot
#' # larger red points in a second geom_point() layer.
#' # If the data = argument is not specified, it uses the
#' # declared data frame from ggplot(); ditto for the aesthetics.
#' ggplot(df, aes(x = gp, y = y)) +
#' geom_point() +
#' geom_point(data = ds, aes(y = mean),
#' colour = 'red', size = 3)
#' # Same plot as above, declaring only the data frame in ggplot().
#' # Note how the x and y aesthetics must now be declared in
#' # each geom_point() layer.
#' ggplot(df) +
#' geom_point(aes(x = gp, y = y)) +
#' geom_point(data = ds, aes(x = gp, y = mean),
#' colour = 'red', size = 3)
#' # Set up a skeleton ggplot object and add layers:
#' ggplot() +
#' geom_point(data = df, aes(x = gp, y = y)) +
#' geom_point(data = ds, aes(x = gp, y = mean),
#' colour = 'red', size = 3) +
#' geom_errorbar(data = ds, aes(x = gp, y = mean,
#' ymin = mean - sd, ymax = mean + sd),
#' colour = 'red', width = 0.4)
ggplot <- function(data = NULL, ...) UseMethod("ggplot")
#' @S3method ggplot default
ggplot.default <- function(data = NULL, mapping = aes(), ...) {
ggplot.data.frame(fortify(data, ...), mapping)
}
#' Reports whether x is a ggplot object
#' @param x An object to test
#' @export
is.ggplot <- function(x) inherits(x, "ggplot")
#' Create a new ggplot plot from a data frame
#'
#' @param data default data frame for plot
#' @param mapping default list of aesthetic mappings (these can be colour,
#' size, shape, line type -- see individual geom functions for more details)
#' @param ... ignored
#' @param environment in which evaluation of aesthetics should occur
#' @seealso \url{http://had.co.nz/ggplot2}
#' @method ggplot data.frame
#' @export
ggplot.data.frame <- function(data, mapping=aes(), ..., environment = globalenv()) {
if (!missing(mapping) && !inherits(mapping, "uneval")) stop("Mapping should be created with aes or aes_string")
p <- structure(list(
data = data,
layers = list(),
scales = Scales$new(),
mapping = mapping,
theme = list(),
coordinates = coord_cartesian(),
facet = facet_null(),
plot_env = environment
), class = c("gg", "ggplot"))
p$labels <- make_labels(mapping)
set_last_plot(p)
p
}
plot_clone <- function(plot) {
p <- plot
p$scales <- plot$scales$clone()
p$layers <- lapply(plot$layers, function(x) x$clone())
p
}
ggplot2/R/facet-locate.r 0000644 0001751 0000144 00000004565 12114160774 014576 0 ustar hornik users # Take single layer of data and combine it with panel information to split
# data into different panels. Adds in extra data for missing facetting
# levels and for margins.
#
# @params data a data frame
locate_grid <- function(data, panels, rows = NULL, cols = NULL, margins = FALSE) {
if (empty(data)) {
return(cbind(data, PANEL = integer(0)))
}
rows <- as.quoted(rows)
cols <- as.quoted(cols)
vars <- c(names(rows), names(cols))
# Compute facetting values and add margins
margin_vars <- list(intersect(names(rows), names(data)),
intersect(names(cols), names(data)))
data <- add_margins(data, margin_vars, margins)
facet_vals <- quoted_df(data, c(rows, cols))
# If any facetting variables are missing, add them in by
# duplicating the data
missing_facets <- setdiff(vars, names(facet_vals))
if (length(missing_facets) > 0) {
to_add <- unique(panels[missing_facets])
data_rep <- rep.int(1:nrow(data), nrow(to_add))
facet_rep <- rep(1:nrow(to_add), each = nrow(data))
data <- unrowname(data[data_rep, , drop = FALSE])
facet_vals <- unrowname(cbind(
facet_vals[data_rep, , drop = FALSE],
to_add[facet_rep, , drop = FALSE]))
}
# Add PANEL variable
if (nrow(facet_vals) == 0) {
# Special case of no facetting
data$PANEL <- 1
} else {
facet_vals[] <- lapply(facet_vals[], as.factor)
facet_vals[] <- lapply(facet_vals[], addNA, ifany = TRUE)
keys <- join.keys(facet_vals, panels, by = vars)
data$PANEL <- panels$PANEL[match(keys$x, keys$y)]
}
arrange(data, PANEL)
}
locate_wrap <- function(data, panels, vars) {
if (empty(data)) {
return(cbind(data, PANEL = integer(0)))
}
vars <- as.quoted(vars)
facet_vals <- quoted_df(data, vars)
facet_vals[] <- lapply(facet_vals[], as.factor)
missing_facets <- setdiff(names(vars), names(facet_vals))
if (length(missing_facets) > 0) {
to_add <- unique(panels[missing_facets])
data_rep <- rep.int(1:nrow(data), nrow(to_add))
facet_rep <- rep(1:nrow(to_add), each = nrow(data))
data <- unrowname(data[data_rep, , drop = FALSE])
facet_vals <- unrowname(cbind(
facet_vals[data_rep, , drop = FALSE],
to_add[facet_rep, , drop = FALSE]))
}
keys <- join.keys(facet_vals, panels, by = names(vars))
data$PANEL <- panels$PANEL[match(keys$x, keys$y)]
data[order(data$PANEL), ]
}
ggplot2/R/geom-vline.r 0000644 0001751 0000144 00000006012 12114160774 014276 0 ustar hornik users #' Line, vertical.
#'
#' This geom allows you to annotate the plot with vertical lines (see
#' \code{\link{geom_hline}} and \code{\link{geom_abline}} for other types of
#' lines.
#'
#' There are two ways to use it. You can either specify the intercept of the
#' line in the call to the geom, in which case the line will be in the same
#' position in every panel. Alternatively, you can supply a different
#' intercept for each panel using a data.frame. See the examples for the
#' differences.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "vline")}
#'
#' @param show_guide should a legend be drawn? (defaults to \code{FALSE})
#' @inheritParams geom_point
#' @seealso
#' \code{\link{geom_hline}} for horizontal lines,
#' \code{\link{geom_abline}} for lines defined by a slope and intercept,
#' \code{\link{geom_segment}} for a more general approach"
#' @export
#' @examples
#' # Fixed lines
#' p <- ggplot(mtcars, aes(x = wt, y = mpg)) + geom_point()
#' p + geom_vline(xintercept = 5)
#' p + geom_vline(xintercept = 1:5)
#' p + geom_vline(xintercept = 1:5, colour="green", linetype = "longdash")
#' p + geom_vline(aes(xintercept = wt))
#'
#' # With coordinate transforms
#' p + geom_vline(aes(xintercept = wt)) + coord_equal()
#' p + geom_vline(aes(xintercept = wt)) + coord_flip()
#' p + geom_vline(aes(xintercept = wt)) + coord_polar()
#'
#' p2 <- p + aes(colour = factor(cyl))
#' p2 + geom_vline(xintercept = 15)
#'
#' # To display different lines in different facets, you need to
#' # create a data frame.
#' p <- qplot(mpg, wt, data=mtcars, facets = vs ~ am)
#' vline.data <- data.frame(z = c(15, 20, 25, 30), vs = c(0, 0, 1, 1), am = c(0, 1, 0, 1))
#' p + geom_vline(aes(xintercept = z), vline.data)
geom_vline <- function (mapping = NULL, data = NULL, stat = "vline", position = "identity", show_guide = FALSE, ...) {
GeomVline$new(mapping = mapping, data = data, stat = stat, position = position, show_guide = show_guide, ...)
}
GeomVline <- proto(Geom, {
objname <- "vline"
new <- function(., data = NULL, mapping = NULL, xintercept = NULL, ...) {
if (is.numeric(xintercept)) {
data <- data.frame(xintercept = xintercept)
xintercept <- NULL
mapping <- aes_all(names(data))
}
.super$new(., data = data, mapping = mapping, inherit.aes = FALSE,
xintercept = xintercept, ...)
}
draw <- function(., data, scales, coordinates, ...) {
ranges <- coord_range(coordinates, scales)
data$y <- ranges$y[1]
data$yend <- ranges$y[2]
GeomSegment$draw(unique(data), scales, coordinates)
}
default_stat <- function(.) StatVline
default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = NA)
guide_geom <- function(.) "vline"
draw_legend <- function(., data, ...) {
data <- aesdefaults(data, .$default_aes(), list(...))
with(data,
ggname(.$my_name(), segmentsGrob(0.5, 0, 0.5, 1, default.units="npc",
gp=gpar(col=alpha(colour, alpha), lwd=size * .pt, lty=linetype, lineend="butt")))
)
}
})
ggplot2/R/geom-bin2d.r 0000644 0001751 0000144 00000001727 12114160774 014167 0 ustar hornik users #' Add heatmap of 2d bin counts.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "bin2d")}
#'
#' @export
#' @inheritParams geom_point
#' @examples
#' d <- ggplot(diamonds, aes(x = x, y = y)) + xlim(4,10) + ylim(4,10)
#' d + geom_bin2d()
#' d + geom_bin2d(binwidth = c(0.1, 0.1))
#'
#' # See ?stat_bin2d for more examples
geom_bin2d <- function (mapping = NULL, data = NULL, stat = "bin2d", position = "identity", ...) {
GeomBin2d$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomBin2d <- proto(Geom, {
draw <- function(., data, scales, coordinates, ...) {
GeomRect$draw(data, scales, coordinates, ...)
}
objname <- "bin2d"
guide_geom <- function(.) "polygon"
default_stat <- function(.) StatBin2d
required_aes <- c("xmin", "xmax", "ymin", "ymax")
default_aes <- function(.) {
aes(colour = NA, fill = "grey60", size = 0.5, linetype = 1, weight = 1, , alpha = NA)
}
})
ggplot2/R/position-dodge.r 0000644 0001751 0000144 00000002662 12114161113 015153 0 ustar hornik users #' Adjust position by dodging overlaps to the side.
#'
#' @inheritParams position_identity
#' @family position adjustments
#' @export
#' @examples
#' \donttest{
#' ggplot(mtcars, aes(x=factor(cyl), fill=factor(vs))) +
#' geom_bar(position="dodge")
#' ggplot(diamonds, aes(x=price, fill=cut)) + geom_bar(position="dodge")
#' # see ?geom_boxplot and ?geom_bar for more examples
#'
#' # Dodging things with different widths is tricky
#' df <- data.frame(x=c("a","a","b","b"), y=1:4, g = rep(1:2, 2))
#' (p <- qplot(x, y, data=df, group=g, position="dodge", geom="bar",
#' stat="identity"))
#'
#' p + geom_linerange(aes(ymin = y-1, ymax = y+1), position="dodge")
#' # You need to explicitly specify the width for dodging
#' p + geom_linerange(aes(ymin = y-1, ymax = y+1),
#' position = position_dodge(width = 0.9))
#'
#' # Similarly with error bars:
#' p + geom_errorbar(aes(ymin = y-1, ymax = y+1), width = 0.2,
#' position="dodge")
#' p + geom_errorbar(aes(ymin = y-1, ymax = y+1, width = 0.2),
#' position = position_dodge(width = 0.90))
#' }
position_dodge <- function (width = NULL, height = NULL) {
PositionDodge$new(width = width, height = height)
}
PositionDodge <- proto(Position, {
objname <- "dodge"
adjust <- function(., data) {
if (empty(data)) return(data.frame())
check_required_aesthetics("x", names(data), "position_dodge")
collide(data, .$width, .$my_name(), pos_dodge, check.width = FALSE)
}
})
ggplot2/R/geom-point-jitter.r 0000644 0001751 0000144 00000003070 12114160774 015612 0 ustar hornik users #' Points, jittered to reduce overplotting.
#'
#' The jitter geom is a convenient default for geom_point with position =
#' 'jitter'. See \code{\link{position_jitter}} to see how to adjust amount
#' of jittering.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "jitter")}
#'
#' @inheritParams geom_point
#' @seealso
#' \code{\link{geom_point}} for regular, unjittered points,
#' \code{\link{geom_boxplot}} for another way of looking at the conditional
#' distribution of a variable,
#' \code{\link{position_jitter}} for examples of using jittering with other
#' geoms
#' @export
#' @examples
#' p <- ggplot(mpg, aes(displ, hwy))
#' p + geom_point()
#' p + geom_point(position = "jitter")
#'
#' # Add aesthetic mappings
#' p + geom_jitter(aes(colour = cyl))
#'
#' # Vary parameters
#' p + geom_jitter(position = position_jitter(width = .5))
#' p + geom_jitter(position = position_jitter(height = .5))
#'
#' # Use qplot instead
#' qplot(displ, hwy, data = mpg, geom = "jitter")
#' qplot(class, hwy, data = mpg, geom = "jitter")
#' qplot(class, hwy, data = mpg, geom = c("boxplot", "jitter"))
#' qplot(class, hwy, data = mpg, geom = c("jitter", "boxplot"))
geom_jitter <- function (mapping = NULL, data = NULL, stat = "identity", position = "jitter",
na.rm = FALSE, ...) {
GeomJitter$new(mapping = mapping, data = data, stat = stat, position = position,
na.rm = na.rm, ...)
}
GeomJitter <- proto(GeomPoint, {
objname <- "jitter"
default_stat <- function(.) StatIdentity
default_pos <- function(.) PositionJitter
})
ggplot2/R/coord-fixed.r 0000644 0001751 0000144 00000003066 12114161113 014431 0 ustar hornik users #' Cartesian coordinates with fixed relationship between x and y scales.
#'
#' A fixed scale coordinate system forces a specified ratio between the
#' physical representation of data units on the axes. The ratio represents the
#' number of units on the y-axis equivalent to one unit on the x-axis. The
#' default, \code{ratio = 1}, ensures that one unit on the x-axis is the same
#' length as one unit on the y-axis. Ratios higher than one make units on the
#' y axis longer than units on the x-axis, and vice versa. This is similar to
#' \code{\link[MASS]{eqscplot}}, but it works for all types of graphics.
#'
#' @aliases coord_fixed coord_equal
#' @export coord_fixed coord_equal
#' @inheritParams coord_cartesian
#' @param ratio aspect ratio, expressed as \code{y / x}
#' @examples
#' # ensures that the ranges of axes are equal to the specified ratio by
#' # adjusting the plot aspect ratio
#'
#' qplot(mpg, wt, data = mtcars) + coord_fixed(ratio = 1)
#' qplot(mpg, wt, data = mtcars) + coord_fixed(ratio = 5)
#' qplot(mpg, wt, data = mtcars) + coord_fixed(ratio = 1/5)
#'
#' # Resize the plot to see that the specified aspect ratio is maintained
coord_fixed <- function(ratio = 1, xlim = NULL, ylim = NULL, wise = NULL) {
if (!is.null(wise))
gg_dep("0.9.0", "wise argument to coord_cartesian is ignored")
coord(limits = list(x = xlim, y = ylim), ratio = ratio,
subclass = c("fixed", "cartesian"))
}
coord_equal <- coord_fixed
#' @S3method coord_aspect fixed
coord_aspect.fixed <- function(coord, ranges) {
diff(ranges$y.range) / diff(ranges$x.range) * coord$ratio
}
ggplot2/R/geom-dotplot.r 0000644 0001751 0000144 00000026123 12114161113 014637 0 ustar hornik users #' Dot plot
#'
#' In a dot plot, the width of a dot corresponds to the bin width
#' (or maximum width, depending on the binning algorithm), and dots are
#' stacked, with each dot representing one observation.
#'
#' With dot-density binning, the bin positions are determined by the data and
#' \code{binwidth}, which is the maximum width of each bin. See Wilkinson
#' (1999) for details on the dot-density binning algorithm.
#'
#' With histodot binning, the bins have fixed positions and fixed widths, much
#' like a histogram.
#'
#' When binning along the x axis and stacking along the y axis, the numbers on
#' y axis are not meaningful, due to technical limitations of ggplot2. You can
#' hide the y axis, as in one of the examples, or manually scale it
#' to match the number of dots.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "dotplot")}
#'
#' @inheritParams geom_point
#' @param binaxis which axis to bin along "x" (default) or "y"
#' @param method "dotdensity" (default) for dot-density binning, or
#' "histodot" for fixed bin widths (like stat_bin)
#' @param binwidth When \code{method} is "dotdensity", this specifies maximum bin width.
#' When method is "histodot", this specifies bin width.
#' Defaults to 1/30 of the range of the data
#' @param binpositions When \code{method} is "dotdensity", "bygroup" (default)
#' determines positions of the bins for each group separately. "all" determines
#' positions of the bins with all the data taken together; this is used for
#' aligning dot stacks across multiple groups.
#' @param stackdir which direction to stack the dots. "up" (default),
#' "down", "center", "centerwhole" (centered, but with dots aligned)
#' @param stackratio how close to stack the dots. Default is 1, where dots just
#' just touch. Use smaller values for closer, overlapping dots.
#' @param dotsize The diameter of the dots relative to \code{binwidth}, default 1.
#' @param stackgroups should dots be stacked across groups? This has the effect
#' that \code{position = "stack"} should have, but can't (because this geom has
#' some odd properties).
#' @export
#'
#' @references Wilkinson, L. (1999) Dot plots. The American Statistician,
#' 53(3), 276-281.
#'
#' @examples
#'
#' ggplot(mtcars, aes(x = mpg)) + geom_dotplot()
#' ggplot(mtcars, aes(x = mpg)) + geom_dotplot(binwidth = 1.5)
#'
#' # Use fixed-width bins
#' ggplot(mtcars, aes(x = mpg)) +
#' geom_dotplot(method="histodot", binwidth = 1.5)
#'
#' # Some other stacking methods
#' ggplot(mtcars, aes(x = mpg)) +
#' geom_dotplot(binwidth = 1.5, stackdir = "center")
#' ggplot(mtcars, aes(x = mpg)) +
#' geom_dotplot(binwidth = 1.5, stackdir = "centerwhole")
#'
#' # y axis isn't really meaningful, so hide it
#' ggplot(mtcars, aes(x = mpg)) + geom_dotplot(binwidth = 1.5) +
#' scale_y_continuous(name = "", breaks = NA)
#'
#' # Overlap dots vertically
#' ggplot(mtcars, aes(x = mpg)) + geom_dotplot(binwidth = 1.5, stackratio = .7)
#'
#' # Expand dot diameter
#' ggplot(mtcars, aes(x =mpg)) + geom_dotplot(binwidth = 1.5, dotsize = 1.25)
#'
#'
#' # Examples with stacking along y axis instead of x
#' ggplot(mtcars, aes(x = 1, y = mpg)) +
#' geom_dotplot(binaxis = "y", stackdir = "center")
#'
#' ggplot(mtcars, aes(x = factor(cyl), y = mpg)) +
#' geom_dotplot(binaxis = "y", stackdir = "center")
#'
#' ggplot(mtcars, aes(x = factor(cyl), y = mpg)) +
#' geom_dotplot(binaxis = "y", stackdir = "centerwhole")
#'
#' ggplot(mtcars, aes(x = factor(vs), fill = factor(cyl), y = mpg)) +
#' geom_dotplot(binaxis = "y", stackdir = "center", position = "dodge")
#'
#' # binpositions="all" ensures that the bins are aligned between groups
#' ggplot(mtcars, aes(x = factor(am), y = mpg)) +
#' geom_dotplot(binaxis = "y", stackdir = "center", binpositions="all")
#'
#' # Stacking multiple groups, with different fill
#' ggplot(mtcars, aes(x = mpg, fill = factor(cyl))) +
#' geom_dotplot(stackgroups = TRUE, binwidth = 1, binpositions = "all")
#'
#' ggplot(mtcars, aes(x = mpg, fill = factor(cyl))) +
#' geom_dotplot(stackgroups = TRUE, binwidth = 1, method = "histodot")
#'
#' ggplot(mtcars, aes(x = 1, y = mpg, fill = factor(cyl))) +
#' geom_dotplot(binaxis = "y", stackgroups = TRUE, binwidth = 1, method = "histodot")
#'
geom_dotplot <- function (mapping = NULL, data = NULL, stat = "bindot", position = "identity",
na.rm = FALSE, binwidth = NULL, binaxis = "x", method="dotdensity", binpositions = "bygroup", stackdir = "up",
stackratio = 1, dotsize = 1, stackgroups = FALSE, ...) {
GeomDotplot$new(mapping = mapping, data = data, stat = stat, position = position,
na.rm = na.rm, binwidth = binwidth, binaxis = binaxis, method = method, binpositions = binpositions,
stackdir = stackdir, stackratio = stackratio, dotsize = dotsize, stackgroups = stackgroups, ...)
}
GeomDotplot <- proto(Geom, {
objname <- "dotplot"
new <- function(., mapping = NULL, data = NULL, stat = NULL, position = NULL, ...){
# This code is adapted from Layer$new. It's needed to pull out the stat_params
# and geom_params, then manually add binaxis to both sets of params. Otherwise
# Layer$new will give binaxis only to the geom.
stat <- Stat$find(stat)
match.params <- function(possible, params) {
if ("..." %in% names(possible)) {
params
} else {
params[match(names(possible), names(params), nomatch = 0)]
}
}
params <- list(...)
# American names must be changed here so that they'll go to geom_params;
# otherwise they'll end up in stat_params
params <- rename_aes(params)
geom_params <- match.params(.$parameters(), params)
stat_params <- match.params(stat$parameters(), params)
stat_params <- stat_params[setdiff(names(stat_params), names(geom_params))]
# Add back binaxis
stat_params <- c(stat_params, binaxis=params$binaxis)
# If identical(position, "stack") or position is position_stack() (the test
# is kind of complex), tell them to use stackgroups=TRUE instead. Need to
# use identical() instead of ==, because == will fail if object is
# position_stack() or position_dodge()
if (!is.null(position) && (identical(position, "stack") || (is.proto(position) && position$objname == "stack")))
message("position=\"stack\" doesn't work properly with geom_dotplot. Use stackgroups=TRUE instead.")
if (params$stackgroups && params$method == "dotdensity" && params$binpositions == "bygroup")
message('geom_dotplot called with stackgroups=TRUE and method="dotdensity". You probably want to set binpositions="all"')
do.call("layer", list(mapping = mapping, data = data, stat = stat, geom = ., position = position,
geom_params = geom_params, stat_params = stat_params, ...))
}
reparameterise <- function(., df, params) {
df$width <- df$width %||%
params$width %||% (resolution(df$x, FALSE) * 0.9)
# Set up the stacking function and range
if(params$stackdir == "up") {
stackdots <- function(a) a - .5
stackaxismin <- 0
stackaxismax <- 1
} else if (params$stackdir == "down") {
stackdots <- function(a) -a + .5
stackaxismin <- -1
stackaxismax <- 0
} else if (params$stackdir == "center") {
stackdots <- function(a) a - 1 - max(a - 1) / 2
stackaxismin <- -.5
stackaxismax <- .5
} else if (params$stackdir == "centerwhole") {
stackdots <- function(a) a - 1 - floor(max(a - 1) / 2)
stackaxismin <- -.5
stackaxismax <- .5
}
# Fill the bins: at a given x (or y), if count=3, make 3 entries at that x
df <- df[rep(1:nrow(df), df$count), ]
# Next part will set the position of each dot within each stack
# If stackgroups=TRUE, split only on x (or y) and panel; if not stacking, also split by group
plyvars <- c(params$binaxis, "PANEL")
if (!params$stackgroups)
plyvars <- c(plyvars, "group")
# Within each x, or x+group, set countidx=1,2,3, and set stackpos according to stack function
df <- ddply(df, plyvars, function(xx) {
xx$countidx <- 1:nrow(xx)
xx$stackpos <- stackdots(xx$countidx)
xx
})
# Set the bounding boxes for the dots
if (params$binaxis == "x") {
# ymin, ymax, xmin, and xmax define the bounding rectangle for each stack
# Can't do bounding box per dot, because y position isn't real.
# After position code is rewritten, each dot should have its own bounding box.
df$xmin <- df$x - df$binwidth / 2
df$xmax <- df$x + df$binwidth / 2
df$ymin <- stackaxismin
df$ymax <- stackaxismax
df$y <- 0
} else if (params$binaxis == "y") {
# ymin, ymax, xmin, and xmax define the bounding rectangle for each stack
# Can't do bounding box per dot, because x position isn't real.
# xmin and xmax aren't really the x bounds, because of the odd way the grob
# works. They're just set to the standard x +- width/2 so that dot clusters
# can be dodged like other geoms.
# After position code is rewritten, each dot should have its own bounding box.
df <- ddply(df, .(group), transform,
ymin = min(y) - binwidth[1] / 2,
ymax = max(y) + binwidth[1] / 2)
df$xmin <- df$x + df$width * stackaxismin
df$xmax <- df$x + df$width * stackaxismax
# Unlike with y above, don't change x because it will cause problems with dodging
}
df
}
draw <- function(., data, scales, coordinates, na.rm = FALSE, binaxis = "x",
stackdir = "up", stackratio = 1, dotsize = 1, stackgroups = FALSE, ...) {
data <- remove_missing(data, na.rm, c("x", "y", "size", "shape"), name = "geom_dotplot")
if (empty(data)) return(zeroGrob())
if (!is.linear(coordinates)) {
warning("geom_dotplot does not work properly with non-linear coordinates.")
}
tdata <- coord_transform(coordinates, data, scales)
# Swap axes if using coord_flip
if ("flip" %in% attr(coordinates, "class"))
binaxis <- ifelse (binaxis == "x", "y", "x")
if (binaxis == "x") {
stackaxis = "y"
dotdianpc <- dotsize * tdata$binwidth[1] / (max(scales$x.range) - min(scales$x.range))
} else if (binaxis == "y") {
stackaxis = "x"
dotdianpc <- dotsize * tdata$binwidth[1] / (max(scales$y.range) - min(scales$y.range))
}
ggname(.$my_name(),
dotstackGrob(stackaxis = stackaxis, x = tdata$x, y = tdata$y, dotdia = dotdianpc,
stackposition = tdata$stackpos, stackratio = stackratio,
default.units = "npc",
gp = gpar(col = alpha(tdata$colour, tdata$alpha),
fill = alpha(tdata$fill, tdata$alpha)))
)
}
guide_geom <- function(.) "dotplot"
draw_legend <- function(., data, ...) {
data$shape <- 21
data <- aesdefaults(data, .$default_aes(), list(...))
with(data,
pointsGrob(0.5, 0.5, size = unit(.5, "npc"), pch = shape,
gp = gpar(
col = alpha(colour, alpha),
fill = alpha(fill, alpha))
)
)
}
default_stat <- function(.) StatBindot
required_aes <- c("x", "y")
default_aes <- function(.) aes(y=..count.., colour="black", fill = "black", alpha = NA)
})
ggplot2/R/theme.r 0000644 0001751 0000144 00000055533 12114161113 013336 0 ustar hornik users #' Get, set and update themes.
#'
#' Use \code{theme_update} to modify a small number of elements of the current
#' theme or use \code{theme_set} to completely override it.
#'
#' @param ... named list of theme settings
#' @seealso \code{\link{\%+replace\%}} and \code{\link{+.gg}}
#' @export
#' @examples
#' qplot(mpg, wt, data = mtcars)
#' old <- theme_set(theme_bw())
#' qplot(mpg, wt, data = mtcars)
#' theme_set(old)
#' qplot(mpg, wt, data = mtcars)
#'
#' old <- theme_update(panel.background = element_rect(colour = "pink"))
#' qplot(mpg, wt, data = mtcars)
#' theme_set(old)
#' theme_get()
#'
#' qplot(mpg, wt, data=mtcars, colour=mpg) +
#' theme(legend.position=c(0.95, 0.95), legend.justification = c(1, 1))
#' last_plot() +
#' theme(legend.background = element_rect(fill = "white", colour = "white", size = 3))
theme_update <- function(...) {
# Make a call to theme, then add to theme
theme_set(theme_get() %+replace% do.call(theme, list(...)))
}
#' Reports whether x is a theme object
#' @param x An object to test
#' @export
is.theme <- function(x) inherits(x, "theme")
#' @S3method print theme
print.theme <- function(x, ...) str(x)
#' Set theme elements
#'
#'
#' Use this function to modify theme settings.
#'
#' Theme elements can inherit properties from other theme elements.
#' For example, \code{axis.title.x} inherits from \code{axis.title},
#' which in turn inherits from \code{text}. All text elements inherit
#' directly or indirectly from \code{text}; all lines inherit from
#' \code{line}, and all rectangular objects inherit from \code{rect}.
#'
#' For more examples of modifying properties using inheritance, see
#' \code{\link{+.gg}} and \code{\link{\%+replace\%}}.
#'
#' To see a graphical representation of the inheritance tree, see the
#' last example below.
#'
#' @section Theme elements:
#' The individual theme elements are:
#'
#' \tabular{ll}{
#' line \tab all line elements
#' (\code{element_line}) \cr
#' rect \tab all rectangluar elements
#' (\code{element_rect}) \cr
#' text \tab all text elements
#' (\code{element_text}) \cr
#' title \tab all title elements: plot, axes, legends
#' (\code{element_text}; inherits from \code{text}) \cr
#'
#' axis.title \tab label of axes
#' (\code{element_text}; inherits from \code{text}) \cr
#' axis.title.x \tab x axis label
#' (\code{element_text}; inherits from \code{axis.title}) \cr
#' axis.title.y \tab y axis label
#' (\code{element_text}; inherits from \code{axis.title}) \cr
#' axis.text \tab tick labels along axes
#' (\code{element_text}; inherits from \code{text}) \cr
#' axis.text.x \tab x axis tick labels
#' (\code{element_text}; inherits from \code{axis.text}) \cr
#' axis.text.y \tab y axis tick labels
#' (\code{element_text}; inherits from \code{axis.text}) \cr
#' axis.ticks \tab tick marks along axes
#' (\code{element_line}; inherits from \code{line}) \cr
#' axis.ticks.x \tab x axis tick marks
#' (\code{element_line}; inherits from \code{axis.ticks}) \cr
#' axis.ticks.y \tab y axis tick marks
#' (\code{element_line}; inherits from \code{axis.ticks}) \cr
#' axis.ticks.length \tab length of tick marks
#' (\code{unit}) \cr
#' axis.ticks.margin \tab space between tick mark and tick label
#' (\code{unit}) \cr
#' axis.line \tab lines along axes
#' (\code{element_line}; inherits from \code{line}) \cr
#' axis.line.x \tab line along x axis
#' (\code{element_line}; inherits from \code{axis.line}) \cr
#' axis.line.y \tab line along y axis
#' (\code{element_line}; inherits from \code{axis.line}) \cr
#'
#' legend.background \tab background of legend
#' (\code{element_rect}; inherits from \code{rect}) \cr
#' legend.margin \tab extra space added around legend
#' (\code{unit}) \cr
#' legend.key \tab background underneath legend keys
#' (\code{element_rect}; inherits from \code{rect}) \cr
#' legend.key.size \tab size of legend keys
#' (\code{unit}; inherits from \code{legend.key.size}) \cr
#' legend.key.height \tab key background height
#' (\code{unit}; inherits from \code{legend.key.size}) \cr
#' legend.key.width \tab key background width
#' (\code{unit}; inherits from \code{legend.key.size}) \cr
#' legend.text \tab legend item labels
#' (\code{element_text}; inherits from \code{text}) \cr
#' legend.text.align \tab alignment of legend labels
#' (number from 0 (left) to 1 (right)) \cr
#' legend.title \tab title of legend
#' (\code{element_text}; inherits from \code{title}) \cr
#' legend.title.align \tab alignment of legend title
#' (number from 0 (left) to 1 (right)) \cr
#' legend.position \tab the position of legends.
#' ("left", "right", "bottom", "top", or two-element
#' numeric vector) \cr
#' legend.direction \tab layout of items in legends
#' ("horizontal" or "vertical") \cr
#' legend.justification \tab anchor point for positioning legend inside plot
#' ("center" or two-element numeric vector) \cr
#' legend.box \tab arrangement of multiple legends
#' ("horizontal" or "vertical") \cr
#' legend.box.just \tab justification of each legend within the overall
#' bounding box, when there are multiple legends
#' ("top", "bottom", "left", or "right")\cr
#'
#' panel.background \tab background of plotting area, drawn underneath plot
#' (\code{element_rect}; inherits from \code{rect}) \cr
#' panel.border \tab border around plotting area, drawn on top of plot
#' so that it covers tick marks and grid lines. This should
#' be used with \code{fill=NA}
#' (\code{element_rect}; inherits from \code{rect}) \cr
#' panel.margin \tab margin around facet panels
#' (\code{unit}) \cr
#' panel.grid \tab grid lines
#' (\code{element_line}; inherits from \code{line}) \cr
#' panel.grid.major \tab major grid lines
#' (\code{element_line}; inherits from \code{panel.grid}) \cr
#' panel.grid.minor \tab minor grid lines
#' (\code{element_line}; inherits from \code{panel.grid}) \cr
#' panel.grid.major.x \tab vertical major grid lines
#' (\code{element_line}; inherits from \code{panel.grid.major}) \cr
#' panel.grid.major.y \tab horizontal major grid lines
#' (\code{element_line}; inherits from \code{panel.grid.major}) \cr
#' panel.grid.minor.x \tab vertical minor grid lines
#' (\code{element_line}; inherits from \code{panel.grid.minor}) \cr
#' panel.grid.minor.y \tab horizontal minor grid lines
#' (\code{element_line}; inherits from \code{panel.grid.minor}) \cr
#'
#' plot.background \tab background of the entire plot
#' (\code{element_rect}; inherits from \code{rect}) \cr
#' plot.title \tab plot title (text appearance)
#' (\code{element_text}; inherits from \code{title}) \cr
#' plot.margin \tab margin around entire plot
#' (\code{unit} with the sizes of the top, right, bottom, and
#' left margins) \cr
#'
#' strip.background \tab background of facet labels
#' (\code{element_rect}; inherits from \code{rect}) \cr
#' strip.text \tab facet labels
#' (\code{element_text}; inherits from \code{text}) \cr
#' strip.text.x \tab facet labels along horizontal direction
#' (\code{element_text}; inherits from \code{strip.text}) \cr
#' strip.text.y \tab facet labels along vertical direction
#' (\code{element_text}; inherits from \code{strip.text}) \cr
#' }
#'
#' @param ... a list of element name, element pairings that modify the
#' existing theme.
#' @param complete set this to TRUE if this is a complete theme, such as
#' the one returned \code{by theme_grey()}. Complete themes behave
#' differently when added to a ggplot object.
#'
#' @seealso \code{\link{+.gg}}
#' @seealso \code{\link{\%+replace\%}}
#' @seealso \code{\link{rel}}
#' @export
#' @examples
#' \donttest{
#' p <- qplot(mpg, wt, data = mtcars)
#' p
#' p + theme(panel.background = element_rect(colour = "pink"))
#' p + theme_bw()
#'
#' # Scatter plot of gas mileage by vehicle weight
#' p <- ggplot(mtcars, aes(x = wt, y = mpg)) + geom_point()
#' # Calculate slope and intercept of line of best fit
#' coef(lm(mpg ~ wt, data = mtcars))
#' p + geom_abline(intercept = 37, slope = -5)
#' # Calculate correlation coefficient
#' with(mtcars, cor(wt, mpg, use = "everything", method = "pearson"))
#' #annotate the plot
#' p + geom_abline(intercept = 37, slope = -5) +
#' geom_text(data = data.frame(), aes(4.5, 30, label = "Pearson-R = -.87"))
#'
#' # Change the axis labels
#' # Original plot
#' p
#' p + xlab("Vehicle Weight") + ylab("Miles per Gallon")
#' # Or
#' p + labs(x = "Vehicle Weight", y = "Miles per Gallon")
#'
#' # Change title appearance
#' p <- p + labs(title = "Vehicle Weight-Gas Mileage Relationship")
#' # Set title to twice the base font size
#' p + theme(plot.title = element_text(size = rel(2)))
#' p + theme(plot.title = element_text(size = rel(2), colour = "blue"))
#'
#' # Changing plot look with themes
#' DF <- data.frame(x = rnorm(400))
#' m <- ggplot(DF, aes(x = x)) + geom_histogram()
#' # Default is theme_grey()
#' m
#' # Compare with
#' m + theme_bw()
#'
#' # Manipulate Axis Attributes
#' library(grid) # for unit
#' m + theme(axis.line = element_line(size = 3, colour = "red", linetype = "dotted"))
#' m + theme(axis.text = element_text(colour = "blue"))
#' m + theme(axis.text.y = element_blank())
#' m + theme(axis.ticks = element_line(size = 2))
#' m + theme(axis.title.y = element_text(size = rel(1.5), angle = 90))
#' m + theme(axis.title.x = element_blank())
#' m + theme(axis.ticks.length = unit(.85, "cm"))
#'
#' # Legend Attributes
#' z <- ggplot(mtcars, aes(wt, mpg, colour = factor(cyl))) + geom_point()
#' z
#' z + theme(legend.position = "none")
#' z + theme(legend.position = "bottom")
#' # Or use relative coordinates between 0 and 1
#' z + theme(legend.position = c(.5, .5))
# # Add a border to the whole legend
#' z + theme(legend.background = element_rect(colour = "black"))
#' # Legend margin controls extra space around outside of legend:
#' z + theme(legend.background = element_rect(), legend.margin = unit(1, "cm"))
#' z + theme(legend.background = element_rect(), legend.margin = unit(0, "cm"))
#' # Or to just the keys
#' z + theme(legend.key = element_rect(colour = "black"))
#' z + theme(legend.key = element_rect(fill = "yellow"))
#' z + theme(legend.key.size = unit(2.5, "cm"))
#' z + theme(legend.text = element_text(size = 20, colour = "red", angle = 45))
#' z + theme(legend.title = element_text(face = "italic"))
#'
#' # To change the title of the legend use the name argument
#' # in one of the scale options
#' z + scale_colour_brewer(name = "My Legend")
#' z + scale_colour_grey(name = "Number of \nCylinders")
#'
#' # Panel and Plot Attributes
#' z + theme(panel.background = element_rect(fill = "black"))
#' z + theme(panel.border = element_rect(linetype = "dashed", colour = "black"))
#' z + theme(panel.grid.major = element_line(colour = "blue"))
#' z + theme(panel.grid.minor = element_line(colour = "red", linetype = "dotted"))
#' z + theme(panel.grid.major = element_line(size = 2))
#' z + theme(panel.grid.major.y = element_blank(), panel.grid.minor.y = element_blank())
#' z + theme(plot.background = element_rect())
#' z + theme(plot.background = element_rect(fill = "green"))
#'
#' # Faceting Attributes
#' set.seed(4940)
#' dsmall <- diamonds[sample(nrow(diamonds), 1000), ]
#' k <- ggplot(dsmall, aes(carat, ..density..)) + geom_histogram(binwidth = 0.2) +
#' facet_grid(. ~ cut)
#' k + theme(strip.background = element_rect(colour = "purple", fill = "pink",
#' size = 3, linetype = "dashed"))
#' k + theme(strip.text.x = element_text(colour = "red", angle = 45, size = 10,
#' hjust = 0.5, vjust = 0.5))
#' k + theme(panel.margin = unit(5, "lines"))
#' k + theme(panel.margin = unit(0, "lines"))
#'
#'
#' # Modify a theme and save it
#' mytheme <- theme_grey() + theme(plot.title = element_text(colour = "red"))
#' p + mytheme
#'
#'
#' ## Run this to generate a graph of the element inheritance tree
#' build_element_graph <- function(tree) {
#' require(igraph)
#' require(plyr)
#'
#' inheritdf <- function(name, item) {
#' if (length(item$inherit) == 0)
#' data.frame()
#' else
#' data.frame(child = name, parent = item$inherit)
#' }
#'
#' edges <- rbind.fill(mapply(inheritdf, names(tree), tree))
#'
#' # Explicitly add vertices (since not all are in edge list)
#' vertices <- data.frame(name = names(tree))
#' graph.data.frame(edges, vertices = vertices)
#' }
#'
#' g <- build_element_graph(ggplot2:::.element_tree)
#' V(g)$label <- V(g)$name
#'
#' set.seed(324)
#' par(mar=c(0,0,0,0)) # Remove unnecessary margins
#' plot(g, layout=layout.fruchterman.reingold, vertex.size=4, vertex.label.dist=.25)
#'
#' }
theme <- function(..., complete = FALSE) {
elements <- list(...)
# Check that all elements have the correct class (element_text, unit, etc)
mapply(validate_element, elements, names(elements))
structure(elements, class = c("theme", "gg"), complete = complete)
}
#' Build a theme (or partial theme) from theme elements
#'
#' \code{opts} is deprecated. See the \code{\link{theme}} function.
#' @param ... Arguments to be passed on to the \code{theme} function.
#'
#' @export
opts <- function(...) {
gg_dep("0.9.1", "'opts' is deprecated. Use 'theme' instead.")
# Add check for deprecated elements
extra <- NULL
elements <- list(...)
if (!is.null(elements[["title"]])) {
# This is kind of a hack, but fortunately it will be removed in future versions
gg_dep("0.9.1", paste(sep = "\n",
'Setting the plot title with opts(title="...") is deprecated.',
' Use labs(title="...") or ggtitle("...") instead.'))
title <- elements$title
elements$title <- NULL
return(list(ggtitle(title), do.call(theme, elements)))
}
do.call(theme, elements)
}
# Combine plot defaults with current theme to get complete theme for a plot
plot_theme <- function(x) {
defaults(x$theme, theme_get())
}
.theme <- (function() {
theme <- theme_gray()
list(
get = function() theme,
set = function(new) {
missing <- setdiff(names(theme_gray()), names(new))
if (length(missing) > 0) {
warning("New theme missing the following elements: ",
paste(missing, collapse = ", "), call. = FALSE)
}
old <- theme
theme <<- new
invisible(old)
}
)
})()
#' @rdname theme_update
#' @export
theme_get <- .theme$get
#' @rdname theme_update
#' @param new new theme (a list of theme elements)
#' @export
theme_set <- .theme$set
#' @rdname gg-add
#' @export
"%+replace%" <- function(e1, e2) {
if (!is.theme(e1) || !is.theme(e2)) {
stop("%+replace% requires two theme objects", call. = FALSE)
}
# Can't use modifyList here since it works recursively and drops NULLs
e1[names(e2)] <- e2
e1
}
#' Modify properties of an element in a theme object
#'
#' @param t1 A theme object
#' @param t2 A theme object that is to be added to \code{t1}
#' @param t2name A name of the t2 object. This is used for printing
#' informative error messages.
#'
#' @seealso +.gg
#'
add_theme <- function(t1, t2, t2name) {
if (!is.theme(t2)) {
stop("Don't know how to add ", t2name, " to a theme object",
call. = FALSE)
}
# Iterate over the elements that are to be updated
for (item in names(t2)) {
x <- t1[[item]]
y <- t2[[item]]
if (is.null(x) || inherits(x, "element_blank")) {
# If x is NULL or element_blank, then just assign it y
x <- y
} else if (is.null(y) || is.character(y) || is.numeric(y) ||
inherits(y, "element_blank")) {
# If y is NULL, or a string or numeric vector, or is element_blank, just replace x
x <- y
} else {
# If x is not NULL, then copy over the non-NULL properties from y
# Get logical vector of non-NULL properties in y
idx <- !vapply(y, is.null, logical(1))
# Get the names of TRUE items
idx <- names(idx[idx])
# Update non-NULL items
x[idx] <- y[idx]
}
# Assign it back to t1
# This is like doing t1[[item]] <- x, except that it preserves NULLs.
# The other form will simply drop NULL values
t1[item] <- list(x)
}
# If either theme is complete, then the combined theme is complete
attr(t1, "complete") <- attr(t1, "complete") || attr(t2, "complete")
t1
}
# Update a theme from a plot object
#
# This is called from add_ggplot.
#
# If newtheme is a *complete* theme, then it is meant to replace
# oldtheme; this function just returns newtheme.
#
# Otherwise, it adds elements from newtheme to oldtheme:
# If oldtheme doesn't already contain those elements,
# it searches the current default theme, grabs the elements with the
# same name as those from newtheme, and puts them in oldtheme. Then
# it adds elements from newtheme to oldtheme.
# This makes it possible to do things like:
# qplot(1:3, 1:3) + theme(text = element_text(colour = 'red'))
# and have 'text' keep properties from the default theme. Otherwise
# you would have to set all the element properties, like family, size,
# etc.
#
# @param oldtheme an existing theme, usually from a plot object, like
# plot$theme. This could be an empty list.
# @param newtheme a new theme object to add to the existing theme
update_theme <- function(oldtheme, newtheme) {
# If the newtheme is a complete one, don't bother searching
# the default theme -- just replace everything with newtheme
if (attr(newtheme, "complete"))
return(newtheme)
# These are elements in newtheme that aren't already set in oldtheme.
# They will be pulled from the default theme.
newitems <- ! names(newtheme) %in% names(oldtheme)
newitem_names <- names(newtheme)[newitems]
oldtheme[newitem_names] <- theme_get()[newitem_names]
# Update the theme elements with the things from newtheme
# Turn the 'theme' list into a proper theme object first, and preserve
# the 'complete' attribute. It's possible that oldtheme is an empty
# list, and in that case, set complete to FALSE.
oldtheme <- do.call(theme, c(oldtheme,
complete = isTRUE(attr(oldtheme, "complete"))))
oldtheme + newtheme
}
##' Update contents of a theme. (Deprecated)
##'
##' This function is deprecated. Use \code{\link{\%+replace\%}} or
##' \code{\link{+.gg}} instead.
##'
##' @title Update theme param
##' @param name name of a theme element
##' @param ... Pairs of name and value of theme parameters.
##' @return Updated theme element
##' @seealso \code{\link{\%+replace\%}} and \code{\link{+.gg}}
##' @export
##' @examples
##' \dontrun{
##' x <- element_text(size = 15)
##' update_element(x, colour = "red")
##' # Partial matching works
##' update_element(x, col = "red")
##' # So does positional
##' update_element(x, "Times New Roman")
##' # And it throws an error if you use an argument that doesn't exist
##' update_element(x, noargument = 12)
##' # Or multiple arguments with the same name
##' update_element(x, size = 12, size = 15)
##'
##' # Will look up element if given name
##' update_element("axis.text.x", colour = 20)
##' # Throws error if incorrectly named
##' update_element("axis.text", colour = 20)
##' }
update_element <- function(name, ...) {
gg_dep("0.9.1", "update_element is deprecated. Use '+.gg' instead.")
if (is.character(name)) {
ele <- theme_get()[[name]]
if (is.null(ele)) {
stop("Could not find theme element ", name, call. = FALSE)
}
} else {
ele <- name
}
stopifnot(inherits(ele, "element"))
modifyList(ele, list(...))
}
#' Calculate the element properties, by inheriting properties from its parents
#'
#' @param element The name of the theme element to calculate
#' @param theme A theme object (like theme_grey())
#' @param verbose If TRUE, print out which elements this one inherits from
#' @examples
#' t <- theme_grey()
#' calc_element('text', t)
#'
#' # Compare the "raw" element definition to the element with calculated inheritance
#' t$axis.text.x
#' calc_element('axis.text.x', t, verbose = TRUE)
#'
#' # This reports that axis.text.x inherits from axis.text,
#' # which inherits from text. You can view each of them with:
#' t$axis.text.x
#' t$axis.text
#' t$text
#'
#' @export
calc_element <- function(element, theme, verbose = FALSE) {
if (verbose) message(element, " --> ", appendLF = FALSE)
# If this is element_blank, don't inherit anything from parents
if (inherits(theme[[element]], "element_blank")) {
if (verbose) message("element_blank (no inheritance)")
return(theme[[element]])
}
# If the element is defined (and not just inherited), check that
# it is of the class specified in .element_tree
if (!is.null(theme[[element]]) &&
!inherits(theme[[element]], .element_tree[[element]]$class)) {
stop(element, " should have class ", .element_tree[[element]]$class)
}
# Get the names of parents from the inheritance tree
pnames <- .element_tree[[element]]$inherit
# If no parents, this is a "root" node. Just return this element.
if (is.null(pnames)) {
# Check that all the properties of this element are non-NULL
nullprops <- vapply(theme[[element]], is.null, logical(1))
if (any(nullprops)) {
stop("Theme element '", element, "' has NULL property: ",
paste(names(nullprops)[nullprops], collapse = ", "))
}
if (verbose) message("nothing (top level)")
return(theme[[element]])
}
# Calculate the parent objects' inheritance
if (verbose) message(paste(pnames, collapse = ", "))
parents <- lapply(pnames, calc_element, theme, verbose)
# Combine the properties of this element with all parents
Reduce(combine_elements, parents, theme[[element]])
}
# Combine the properties of two elements
#
# @param e1 An element object
# @param e2 An element object which e1 inherits from
combine_elements <- function(e1, e2) {
# If e2 is NULL, nothing to inherit
if (is.null(e2)) return(e1)
# If e1 is NULL, or if e2 is element_blank, inherit everything from e2
if (is.null(e1) || inherits(e2, "element_blank")) return(e2)
# If e1 has any NULL properties, inherit them from e2
n <- vapply(e1[names(e2)], is.null, logical(1))
e1[n] <- e2[n]
# Calculate relative sizes
if (is.rel(e1$size)) {
e1$size <- e2$size * unclass(e1$size)
}
e1
}
ggplot2/R/aes-colour-fill-alpha.r 0000644 0001751 0000144 00000004142 12114160774 016316 0 ustar hornik users #' Colour related aesthetics: colour, fill and alpha
#'
#' This page demonstrates the usage of a sub-group
#' of aesthetics; colour, fill and alpha.
#'
#' @name aes_colour_fill_alpha
#' @aliases colour color fill alpha
#' @examples
#' \donttest{
#'
#' # Bar chart example
#' c <- ggplot(mtcars, aes(factor(cyl)))
#' # Default plotting
#' c + geom_bar()
#' # To change the interior colouring use fill aesthetic
#' c + geom_bar(fill = "red")
#' # Compare with the colour aesthetic which changes just the bar outline
#' c + geom_bar(colour = "red")
#' # Combining both, you can see the changes more clearly
#' c + geom_bar(fill = "white", colour = "red")
#'
#' # The aesthetic fill also takes different colouring scales
#' # setting fill equal to a factor varible uses a discrete colour scale
#' k <- ggplot(mtcars, aes(factor(cyl), fill = factor(vs)))
#' k + geom_bar()
#'
#' # Fill aesthetic can also be used with a continuous variable
#' m <- ggplot(movies, aes(x = rating))
#' m + geom_histogram()
#' m + geom_histogram(aes(fill = ..count..))
#'
#' # Some geoms don't use both aesthetics (i.e. geom_point or geom_line)
#' b <- ggplot(economics, aes(x = date, y = unemploy))
#' b + geom_line()
#' b + geom_line(colour = "green")
#' b + geom_point()
#' b + geom_point(colour = "red")
#'
#' # For large datasets with overplotting the alpha
#' # aesthetic will make the points more transparent
#' df <- data.frame(x = rnorm(5000), y = rnorm(5000))
#' h <- ggplot(df, aes(x,y))
#' h + geom_point()
#' h + geom_point(alpha = 0.5)
#' h + geom_point(alpha = 1/10)
#'
#' #If a geom uses both fill and colour, alpha will only modify the fill colour
#' c + geom_bar(fill = "dark grey", colour = "black")
#' c + geom_bar(fill = "dark grey", colour = "black", alpha = 1/3)
#'
#' # Alpha can also be used to add shading
#' j <- b + geom_line()
#' j
#' yrng <- range(economics$unemploy)
#' j <- j + geom_rect(aes(NULL, NULL, xmin = start, xmax = end, fill = party),
#' ymin = yrng[1], ymax = yrng[2], data = presidential)
#' j
#' library(scales) # to access the alpha function
#' j + scale_fill_manual(values = alpha(c("blue", "red"), .3))
#' }
NULL
ggplot2/R/geom-defaults.r 0000644 0001751 0000144 00000001420 12114160774 014766 0 ustar hornik users #' Modify geom/stat aesthetic defaults for future plots
#'
#' @param stat,geom name of geom/stat to modify
#' @param new named list of aesthetics
#' @export
#' @examples
#' update_geom_defaults("point", list(colour = "darkblue"))
#' qplot(mpg, wt, data = mtcars)
#' update_geom_defaults("point", list(colour = "black"))
#' @rdname update_defaults
update_geom_defaults <- function(geom, new) {
g <- Geom$find(geom)
old <- g$default_aes()
aes <- defaults(new, old)
g$default_aes <- eval(substitute(function(.) aes, list(aes = aes)))
}
#' @rdname update_defaults
#' @export
update_stat_defaults <- function(stat, new) {
g <- Stat$find(stat)
old <- g$default_aes()
aes <- defaults(new, old)
g$default_aes <- eval(substitute(function(.) aes, list(aes = aes)))
}
ggplot2/R/annotation-logticks.r 0000644 0001751 0000144 00000020562 12114161113 016215 0 ustar hornik users #' Annotation: log tick marks
#'
#' This annotation adds log tick marks with diminishing spacing.
#' These tick marks probably make sense only for base 10.
#'
#' @param base the base of the log (default 10)
#' @param sides a string that controls which sides of the plot the log ticks appear on.
#' It can be set to a string containing any of \code{"trbl"}, for top, right,
#' bottom, and left.
#' @param short a \code{unit} object specifying the length of the short tick marks
#' @param mid a \code{unit} object specifying the length of the middle tick marks.
#' In base 10, these are the "5" ticks.
#' @param long a \code{unit} object specifying the length of the long tick marks.
#' In base 10, these are the "1" (or "10") ticks.
#' @param scaled is the data already log-scaled? This should be \code{TRUE}
#' (default) when the data is already transformed with \code{log10()} or when
#' using \code{scale_y_log10}. It should be \code{FALSE} when using
#' \code{coord_trans(y = "log10")}.
#' @param colour Colour of the tick marks.
#' @param size Thickness of tick marks, in mm.
#' @param linetype Linetype of tick marks (\code{solid}, \code{dashed}, etc.)
#' @param alpha The transparency of the tick marks.
#' @param color An alias for \code{colour}.
#' @param ... Other parameters passed on to the layer
#'
#' @export
#' @seealso \code{\link{scale_y_continuous}}, \code{\link{scale_y_log10}} for log scale
#' transformations.
#' @seealso \code{\link{coord_trans}} for log coordinate transformations.
#'
#' @examples
#' # Make a log-log plot (without log ticks)
#' library(MASS)
#' library(scales)
#' a <- ggplot(Animals, aes(x = body, y = brain)) + geom_point() +
#' scale_x_log10(breaks = trans_breaks("log10", function(x) 10^x),
#' labels = trans_format("log10", math_format(10^.x))) +
#' scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x),
#' labels = trans_format("log10", math_format(10^.x))) +
#' theme_bw()
#'
#' a + annotation_logticks() # Default: log ticks on bottom and left
#' a + annotation_logticks(sides = "lr") # Log ticks for y, on left and right
#' a + annotation_logticks(sides = "trbl") # All four sides
#'
#' # Hide the minor grid lines because they don't align with the ticks
#' a + annotation_logticks(sides = "trbl") + theme(panel.grid.minor = element_blank())
#'
#'
#' # Another way to get the same results as 'a' above: log-transform the data before
# plotting it. Also hide the minor grid lines.
#' b <- ggplot(Animals, aes(x = log10(body), y = log10(brain))) + geom_point() +
#' scale_x_continuous(name = "body", labels = math_format(10^.x)) +
#' scale_y_continuous(name = "brain", labels = math_format(10^.x)) +
#' theme_bw()+ theme(panel.grid.minor = element_blank())
#'
#' b + annotation_logticks()
#'
#'
#' # This shows log(x) on the axes
#' d <- ggplot(Animals, aes(x = log10(body), y = log10(brain))) + geom_point() +
#' theme_bw()
#'
#' d + annotation_logticks()
#'
#'
#' # Using a coordinate transform requires scaled = FALSE
#' t <- ggplot(Animals, aes(x = body, y = brain)) + geom_point() +
#' coord_trans(xtrans = "log10", ytrans = "log10") + theme_bw()
#'
#' t + annotation_logticks(scaled = FALSE)
#'
#'
#' # Change the length of the ticks
#' library(grid)
#' a + annotation_logticks(short = unit(.5,"mm"), mid = unit(3,"mm"), long = unit(4,"mm"))
#'
annotation_logticks <- function (base = 10, sides = "bl", scaled = TRUE,
short = unit(0.1, "cm"), mid = unit(0.2, "cm"), long = unit(0.3, "cm"),
colour = "black", size = 0.5, linetype = 1, alpha = 1, color = NULL, ...) {
if (!is.null(color))
colour <- color
layer(
geom = "logticks",
geom_params = list(base = base, sides = sides, raw = raw, scaled = scaled,
short = short, mid = mid, long = long, colour = colour,
size = size, linetype = linetype, alpha = alpha, ...),
stat = "identity",
data = data.frame(x = NA),
mapping = NULL,
inherit.aes = FALSE,
show_guide = FALSE
)
}
GeomLogticks <- proto(Geom, {
objname <- "logticks"
draw_groups <- function(., data, scales, coordinates, base = 10, sides = "bl",
scaled = TRUE, short = unit(0.1, "cm"), mid = unit(0.2, "cm"),
long = unit(0.3, "cm"), ...) {
ticks <- list()
# Convert these units to numbers so that they can be put in data frames
short <- convertUnit(short, "cm", valueOnly = TRUE)
mid <- convertUnit(mid, "cm", valueOnly = TRUE)
long <- convertUnit(long, "cm", valueOnly = TRUE)
if (grepl("[b|t]", sides)) {
# Get positions of x tick marks
xticks <- calc_logticks(base = base,
minpow = floor(scales$x.range[1]), maxpow = ceiling(scales$x.range[2]),
start = 0, shortend = short, midend = mid, longend = long)
if (scaled)
xticks$value <- log(xticks$value, base)
names(xticks)[names(xticks)=="value"] <- "x" # Rename to 'x' for coord_transform
xticks <- coord_transform(coordinates, xticks, scales)
# Make the grobs
if(grepl("b", sides)) {
ticks$x_b <- with(data, segmentsGrob(
x0 = unit(xticks$x, "native"), x1 = unit(xticks$x, "native"),
y0 = unit(xticks$start, "cm"), y1 = unit(xticks$end, "cm"),
gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = size * .pt)
))
}
if(grepl("t", sides)) {
ticks$x_t <- with(data, segmentsGrob(
x0 = unit(xticks$x, "native"), x1 = unit(xticks$x, "native"),
y0 = unit(1, "npc") - unit(xticks$start, "cm"), y1 = unit(1, "npc") - unit(xticks$end, "cm"),
gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = size * .pt)
))
}
}
if (grepl("[l|r]", sides)) {
yticks <- calc_logticks(base = base,
minpow = floor(scales$y.range[1]), maxpow = ceiling(scales$y.range[2]),
start = 0, shortend = short, midend = mid, longend = long)
if (scaled)
yticks$value <- log(yticks$value, base)
names(yticks)[names(yticks)=="value"] <- "y" # Rename to 'y' for coord_transform
yticks <- coord_transform(coordinates, yticks, scales)
# Make the grobs
if(grepl("l", sides)) {
ticks$y_l <- with(data, segmentsGrob(
y0 = unit(yticks$y, "native"), y1 = unit(yticks$y, "native"),
x0 = unit(yticks$start, "cm"), x1 = unit(yticks$end, "cm"),
gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = size * .pt)
))
}
if(grepl("r", sides)) {
ticks$y_r <- with(data, segmentsGrob(
y0 = unit(yticks$y, "native"), y1 = unit(yticks$y, "native"),
x0 = unit(1, "npc") - unit(yticks$start, "cm"), x1 = unit(1, "npc") - unit(yticks$end, "cm"),
gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = size * .pt)
))
}
}
gTree(children = do.call("gList", ticks))
}
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(colour = "black", size = 0.5, linetype = 1, alpha = 1)
})
# Calculate the position of log tick marks
# Returns data frame with:
# - value: the position of the log tick on the data axis, for example 1, 2, ..., 9, 10, 20, ...
# - start: on the other axis, start position of the line (usually 0)
# - end: on the other axis, end position of the line (for example, .1, .2, or .3)
calc_logticks <- function(base = 10, ticks_per_base = base - 1,
minpow = 0, maxpow = minpow + 1, start = 0, shortend = .1, midend = .2, longend = .3) {
# Number of blocks of tick marks
reps <- maxpow - minpow
# For base 10: 1, 2, 3, ..., 7, 8, 9, 1, 2, ...
ticknums <- rep(seq(1, base-1, length.out = ticks_per_base), reps)
# For base 10: 1, 1, 1, ..., 1, 1, 1, 2, 2, ... (for example)
powers <- rep(seq(minpow, maxpow-1), each = ticks_per_base)
ticks <- ticknums * base^powers
ticks <- c(ticks, base^maxpow) # Add the last tick mark
# Set all of the ticks short
tickend <- rep(shortend, length(ticks))
# Get the position within each cycle, 0, 1, 2, ..., 8, 0, 1, 2. ...
cycleIdx <- ticknums - 1
# Set the "major" ticks long
tickend[cycleIdx == 0] <- longend
# Where to place the longer tick marks that are between each base
# For base 10, this will be at each 5
longtick_after_base <- floor(ticks_per_base/2)
tickend[ cycleIdx == longtick_after_base ] <- midend
tickdf <- data.frame(value = ticks, start = start, end = tickend)
return(tickdf)
}
ggplot2/R/plot-build.r 0000644 0001751 0000144 00000005761 12114161113 014305 0 ustar hornik users #' Build ggplot for rendering.
#'
#' This function takes the plot object, and performs all steps necessary to
#' produce an object that can be rendered. This function outputs two pieces:
#' a list of data frames (one for each layer), and a panel object, which
#' contain all information about axis limits, breaks etc.
#'
#' @param plot ggplot object
#' @seealso \code{\link{print.ggplot}} and \code{link{benchplot}} for
#' for functions that contain the complete set of steps for generating
#' a ggplot2 plot.
#' @keywords internal
#' @export
ggplot_build <- function(plot) {
if (length(plot$layers) == 0) stop("No layers in plot", call.=FALSE)
plot <- plot_clone(plot)
layers <- plot$layers
layer_data <- lapply(layers, function(y) y$data)
scales <- plot$scales
# Apply function to layer and matching data
dlapply <- function(f) {
out <- vector("list", length(data))
for(i in seq_along(data)) {
out[[i]] <- f(d = data[[i]], p = layers[[i]])
}
out
}
# Initialise panels, add extra data for margins & missing facetting
# variables, and add on a PANEL variable to data
panel <- new_panel()
panel <- train_layout(panel, plot$facet, layer_data, plot$data)
data <- map_layout(panel, plot$facet, layer_data, plot$data)
# Compute aesthetics to produce data with generalised variable names
data <- dlapply(function(d, p) p$compute_aesthetics(d, plot))
data <- lapply(data, add_group)
# Transform all scales
data <- lapply(data, scales_transform_df, scales = scales)
# Map and train positions so that statistics have access to ranges
# and all positions are numeric
scale_x <- function() scales$get_scales("x")
scale_y <- function() scales$get_scales("y")
panel <- train_position(panel, data, scale_x(), scale_y())
data <- map_position(panel, data, scale_x(), scale_y())
# Apply and map statistics
data <- calculate_stats(panel, data, layers)
data <- dlapply(function(d, p) p$map_statistic(d, plot))
data <- lapply(data, order_groups)
# Make sure missing (but required) aesthetics are added
scales_add_missing(plot, c("x", "y"))
# Reparameterise geoms from (e.g.) y and width to ymin and ymax
data <- dlapply(function(d, p) p$reparameterise(d))
# Apply position adjustments
data <- dlapply(function(d, p) p$adjust_position(d))
# Reset position scales, then re-train and map. This ensures that facets
# have control over the range of a plot: is it generated from what's
# displayed, or does it include the range of underlying data
reset_scales(panel)
panel <- train_position(panel, data, scale_x(), scale_y())
data <- map_position(panel, data, scale_x(), scale_y())
# Train and map non-position scales
npscales <- scales$non_position_scales()
if (npscales$n() > 0) {
lapply(data, scales_train_df, scales = npscales)
data <- lapply(data, scales_map_df, scales = npscales)
}
# Train coordinate system
panel <- train_ranges(panel, plot$coordinates)
list(data = data, panel = panel, plot = plot)
}
ggplot2/R/facet-labels.r 0000644 0001751 0000144 00000004726 12114160774 014570 0 ustar hornik users #' Label facets with their value.
#' This is the default labelling scheme.
#'
#' @param variable variable name passed in by facetter
#' @param value variable value passed in by facetter
#' @family facet labellers
#' @export
#' @examples
#' p <- qplot(wt, mpg, data = mtcars)
#' p + facet_grid(. ~ cyl)
#' p + facet_grid(. ~ cyl, labeller = label_value)
label_value <- function(variable, value) as.character(value)
#' Label facets with value and variable.
#'
#' @param variable variable name passed in by facetter
#' @param value variable value passed in by facetter
#' @family facet labellers
#' @export
#' @examples
#' p <- qplot(wt, mpg, data = mtcars)
#' p + facet_grid(. ~ cyl)
#' p + facet_grid(. ~ cyl, labeller = label_both)
label_both <- function(variable, value) paste(variable, value, sep = ": ")
#' Label facets with parsed label.
#'
#' @seealso \code{\link{plotmath}}
#' @param variable variable name passed in by facetter
#' @param value variable value passed in by facetter
#' @family facet labellers
#' @export
#' @examples
#' mtcars$cyl2 <- factor(mtcars$cyl, labels = c("alpha", "beta", "gamma"))
#' qplot(wt, mpg, data = mtcars) + facet_grid(. ~ cyl2)
#' qplot(wt, mpg, data = mtcars) + facet_grid(. ~ cyl2,
#' labeller = label_parsed)
label_parsed <- function(variable, value) {
llply(as.character(value), function(x) parse(text = x))
}
#' Label facet with 'bquoted' expressions
#'
#' See \code{\link{bquote}} for details on the syntax of the argument. The
#' label value is x.
#'
#' @param expr labelling expression to use
#' @family facet labellers
#' @seealso \code{\link{plotmath}}
#' @export
#' @examples
#' p <- qplot(wt, mpg, data = mtcars)
#' p + facet_grid(. ~ vs, labeller = label_bquote(alpha ^ .(x)))
#' p + facet_grid(. ~ vs, labeller = label_bquote(.(x) ^ .(x)))
label_bquote <- function(expr = beta ^ .(x)) {
quoted <- substitute(expr)
function(variable, value) {
value <- as.character(value)
lapply(value, function(x)
eval(substitute(bquote(expr, list(x = x)), list(expr = quoted))))
}
}
# Grob for strip labels
ggstrip <- function(text, horizontal=TRUE, theme) {
text_theme <- if (horizontal) "strip.text.x" else "strip.text.y"
if (is.list(text)) text <- text[[1]]
label <- element_render(theme, text_theme, text)
ggname("strip", absoluteGrob(
gList(
element_render(theme, "strip.background"),
label
),
width = grobWidth(label) + unit(0.5, "lines"),
height = grobHeight(label) + unit(0.5, "lines")
))
}
ggplot2/R/coord-flip.r 0000644 0001751 0000144 00000003416 12114160774 014277 0 ustar hornik users #' Flipped cartesian coordinates.
#'
#' Flipped cartesian coordinates so that horizontal becomes vertical, and
#' vertical, horizontal. This is primarily useful for converting geoms and
#' statistics which display y conditional on x, to x conditional on y.
#'
#' @export
#' @param ... Other arguments passed onto \code{\link{coord_cartesian}}
#' @examples
#' \donttest{
#' # Very useful for creating boxplots, and other interval
#' # geoms in the horizontal instead of vertical position.
#' qplot(cut, price, data=diamonds, geom="boxplot")
#' last_plot() + coord_flip()
#'
#' qplot(cut, data=diamonds, geom="bar")
#' last_plot() + coord_flip()
#'
#' h <- qplot(carat, data=diamonds, geom="histogram")
#' h
#' h + coord_flip()
#' h + coord_flip() + scale_x_reverse()
#'
#' # You can also use it to flip lines and area plots:
#' qplot(1:5, (1:5)^2, geom="area")
#' last_plot() + coord_flip()
#' }
coord_flip <- function(...) {
coord <- coord_cartesian(...)
structure(coord, class = c("flip", class(coord)))
}
flip_labels <- function(x) {
old_names <- names(x)
new_names <- old_names
new_names <- gsub("^x", "z", new_names)
new_names <- gsub("^y", "x", new_names)
new_names <- gsub("^z", "y", new_names)
setNames(x, new_names)
}
#' @S3method is.linear flip
is.linear.flip <- function(coord) TRUE
#' @S3method coord_transform flip
coord_transform.flip <- function(coord, data, details) {
data <- flip_labels(data)
NextMethod()
}
#' @S3method coord_range flip
coord_range.flip <- function(coord, scales) {
return(list(x = scales$y.range, y = scales$x.range))
}
#' @S3method coord_train flip
coord_train.flip <- function(coord, scales) {
flip_labels(NextMethod())
}
#' @S3method coord_labels flip
coord_labels.flip <- function(coord, scales) {
flip_labels(NextMethod())
}
ggplot2/R/stat-binhex.r 0000644 0001751 0000144 00000005510 12114160774 014464 0 ustar hornik users #' Bin 2d plane into hexagons.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "binhex")}
#'
#' @seealso \code{\link{stat_bin2d}} for rectangular binning
#' @param bins numeric vector specifying number of bins in both x and y
#' directions. Set to 30 by default.
#' @inheritParams stat_identity
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @export
#' @examples
#' \donttest{
#' d <- ggplot(diamonds, aes(carat, price))
#' d + stat_binhex()
#' d + geom_hex()
#'
#' # You can control the size of the bins by specifying the number of
#' # bins in each direction:
#' d + stat_binhex(bins = 10)
#' d + stat_binhex(bins = 30)
#'
#' # Or by specifying the width of the bins
#' d + stat_binhex(binwidth = c(1, 1000))
#' d + stat_binhex(binwidth = c(.1, 500))
#'
#' # With qplot
#' qplot(x, y, data = diamonds, geom="hex", xlim = c(4, 10), ylim = c(4, 10))
#' qplot(x, y, data = diamonds, geom="hex", xlim = c(4, 10), ylim = c(4, 10),
#' binwidth = c(0.1, 0.1))
#' }
stat_binhex <- function (mapping = NULL, data = NULL, geom = "hex", position = "identity",
bins = 30, na.rm = FALSE, ...) {
StatBinhex$new(mapping = mapping, data = data, geom = geom, position = position,
bins = bins, na.rm = na.rm, ...)
}
StatBinhex <- proto(Stat, {
objname <- "binhex"
default_aes <- function(.) aes(fill = ..count..)
required_aes <- c("x", "y")
default_geom <- function(.) GeomHex
calculate <- function(., data, scales, binwidth = NULL, bins = 30, na.rm = FALSE, ...) {
try_require("hexbin")
data <- remove_missing(data, na.rm, c("x", "y"), name="stat_hexbin")
if (is.null(binwidth)) {
binwidth <- c(
diff(scale_dimension(scales$x, c(0, 0))) / bins,
diff(scale_dimension(scales$y, c(0, 0))) / bins
)
}
hexBin(data$x, data$y, binwidth)
}
})
# Bin 2d plane into hexagons
# Wrapper around \code{\link[hexbin]{hcell2xy}} that returns a data frame
#
# @param x positions
# @param y positions
# @param numeric vector of length 2 giving binwidth in x and y directions
# @keyword internal
hexBin <- function(x, y, binwidth) {
try_require("hexbin")
# Convert binwidths into bounds + nbins
xbnds <- c(
round_any(min(x), binwidth[1], floor) - 1e-6,
round_any(max(x), binwidth[1], ceiling) + 1e-6
)
xbins <- diff(xbnds) / binwidth[1]
ybnds <- c(
round_any(min(y), binwidth[2], floor) - 1e-6,
round_any(max(y), binwidth[2], ceiling) + 1e-6
)
ybins <- diff(ybnds) / binwidth[2]
# Call hexbin
hb <- hexbin(
x, xbnds = xbnds, xbins = xbins,
y, ybnds = ybnds, shape = ybins / xbins,
)
# Convert to data frame
data.frame(
hcell2xy(hb),
count = hb@count,
density = hb@count / sum(hb@count, na.rm=TRUE)
)
}
ggplot2/R/stat-identity.r 0000644 0001751 0000144 00000002776 12114161113 015037 0 ustar hornik users #' Identity statistic.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "identity")}
#'
#' @param mapping The aesthetic mapping, usually constructed with
#' \code{\link{aes}} or \code{\link{aes_string}}. Only needs to be set
#' at the layer level if you are overriding the plot defaults.
#' @param data A layer specific dataset - only needed if you want to override
#' the plot defaults.
#' @param geom The geometric object to use display the data
#' @param position The position adjustment to use for overlappling points
#' on this layer
#' @param width The width of the tiles.
#' @param height The height of the tiles.
#' @param ... other arguments passed on to \code{\link{layer}}. This can
#' include aesthetics whose values you want to set, not map. See
#' \code{\link{layer}} for more details.
#' @export
#' @examples
#' # Doesn't do anything, so hard to come up a useful example
stat_identity <- function (mapping = NULL, data = NULL, geom = "point",
position = "identity", width = NULL, height = NULL, ...) {
StatIdentity$new(mapping = mapping, data = data, geom = geom,
position = position, width = width, height = height,...)
}
StatIdentity <- proto(Stat, {
objname <- "identity"
default_geom <- function(.) GeomPoint
calculate_groups <- function(., data, scales, width = NULL, height = NULL, ...) {
if (!is.null(width)) data$width <- width
if (!is.null(height)) data$height <- height
data
}
desc_outputs <- list()
})
ggplot2/R/geom-linerange.r 0000644 0001751 0000144 00000004044 12114160774 015130 0 ustar hornik users #' An interval represented by a vertical line.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "linerange")}
#'
#' @seealso \code{\link{geom_errorbar}}: error bars;
#' \code{\link{geom_pointrange}}: range indicated by straight line, with
#' point in the middle; \code{\link{geom_crossbar}}: hollow bar with middle
#' indicated by horizontal line; \code{\link{stat_summary}}: examples of
#' these guys in use; \code{\link{geom_smooth}}: for continuous analog
#' @export
#' @inheritParams geom_point
#' @examples
#' # Generate data: means and standard errors of means for prices
#' # for each type of cut
#' dmod <- lm(price ~ cut, data=diamonds)
#' cuts <- data.frame(cut=unique(diamonds$cut), predict(dmod, data.frame(cut = unique(diamonds$cut)), se=TRUE)[c("fit","se.fit")])
#'
#' qplot(cut, fit, data=cuts)
#' # With a bar chart, we are comparing lengths, so the y-axis is
#' # automatically extended to include 0
#' qplot(cut, fit, data=cuts, geom="bar")
#'
#' # Display estimates and standard errors in various ways
#' se <- ggplot(cuts, aes(cut, fit,
#' ymin = fit - se.fit, ymax=fit + se.fit, colour = cut))
#' se + geom_linerange()
#' se + geom_pointrange()
#' se + geom_errorbar(width = 0.5)
#' se + geom_crossbar(width = 0.5)
#'
#' # Use coord_flip to flip the x and y axes
#' se + geom_linerange() + coord_flip()
geom_linerange <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", ...) {
GeomLinerange$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomLinerange <- proto(Geom, {
objname <- "linerange"
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(colour = "black", size=0.5, linetype=1, alpha = NA)
guide_geom <- function(.) "path"
required_aes <- c("x", "ymin", "ymax")
draw <- function(., data, scales, coordinates, ...) {
munched <- coord_transform(coordinates, data, scales)
ggname(.$my_name(), GeomSegment$draw(transform(data, xend=x, y=ymin, yend=ymax), scales, coordinates, ...))
}
})
ggplot2/R/annotation.r 0000644 0001751 0000144 00000004433 12114160774 014413 0 ustar hornik users #' Create an annotation layer.
#'
#' This function adds geoms to a plot. Unlike typical a geom function,
#' the properties of the geoms are not mapped from variables of a data frame,
#' but are instead in as vectors. This is useful for adding small annotations
#' (such as text labels) or if you have your data in vectors, and for some
#' reason don't want to put them in a data frame.
#'
#' Note that all position aesthetics are scaled (i.e. they will expand the
#' limits of the plot so they are visible), but all other aesthetics are
#' set. This means that layers created with this function will never
#' affect the legend.
#'
#' @param geom name of geom to use for annotation
#' @param x,y,xmin,ymin,xmax,ymax positionining aesthetics - you must
#' specify at least one of these.
#' @param ... other aesthetics. These are not scaled so you can do (e.g.)
#' \code{colour = "red"} to get a red point.
#' @export
#' @examples
#' p <- ggplot(mtcars, aes(x = wt, y = mpg)) + geom_point()
#' p + annotate("text", x = 4, y = 25, label = "Some text")
#' p + annotate("text", x = 2:5, y = 25, label = "Some text")
#' p + annotate("rect", xmin = 3, xmax = 4.2, ymin = 12, ymax = 21,
#' alpha = .2)
#' p + annotate("segment", x = 2.5, xend = 4, y = 15, yend = 25,
#' colour = "blue")
#' p + annotate("pointrange", x = 3.5, y = 20, ymin = 12, ymax = 28,
#' colour = "red", size = 1.5)
#'
#' p + annotate("text", x = 2:3, y = 20:21, label = c("my label", "label 2"))
annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL, ymin = NULL, ymax = NULL, ...) {
position <- compact(list(
x = x, xmin = xmin, xmax = xmax,
y = y, ymin = ymin, ymax = ymax
))
aesthetics <- c(position, list(...))
# Check that all aesthetic have compatible lengths
lengths <- vapply(aesthetics, length, integer(1))
unequal <- length(unique(setdiff(lengths, 1L))) > 1L
if (unequal) {
bad <- lengths != 1L
details <- paste(names(aesthetics)[bad], " (", lengths[bad], ")",
sep = "", collapse = ", ")
stop("Unequal parameter lengths: ", details, call. = FALSE)
}
data <- data.frame(position)
layer(
geom = geom,
geom_params = list(...),
stat = "identity",
data = data,
mapping = aes_all(names(data)),
inherit.aes = FALSE,
show_guide = FALSE
)
}
ggplot2/R/utilities.r 0000644 0001751 0000144 00000020364 12114161113 014241 0 ustar hornik users
# Null default
# Analog of || from ruby
#
# @keyword internal
# @name nulldefault-infix
"%||%" <- function(a, b) {
if (!is.null(a)) a else b
}
# Check required aesthetics are present
# This is used by geoms and stats to give a more helpful error message
# when required aesthetics are missing.
#
# @param character vector of required aesthetics
# @param character vector of present aesthetics
# @param name of object for error message
# @keyword internal
check_required_aesthetics <- function(required, present, name) {
missing_aes <- setdiff(required, present)
if (length(missing_aes) == 0) return()
stop(name, " requires the following missing aesthetics: ", paste(missing_aes, collapse=", "), call. = FALSE)
}
# Concatenate a named list for output
# Print a \code{list(a=1, b=2)} as \code{(a=1, b=2)}
#
# @param list to concatenate
# @keyword internal
#X clist(list(a=1, b=2))
#X clist(par()[1:5])
clist <- function(l) {
paste(paste(names(l), l, sep=" = ", collapse=", "), sep="")
}
# Abbreviated paste
# Alias for paste with a shorter name and convenient defaults
#
# @param character vectors to be concatenated
# @param default separator
# @param default collapser
# @keyword internal
ps <- function(..., sep="", collapse="") do.call(paste, compact(list(..., sep=sep, collapse=collapse)))
# Quietly try to require a package
# Queitly require a package, returning an error message if that package is not installed.
#
# @param name of package
# @keyword internal
try_require <- function(package) {
available <- suppressMessages(suppressWarnings(sapply(package, require, quietly = TRUE, character.only = TRUE, warn.conflicts=FALSE)))
missing <- package[!available]
if (length(missing) > 0)
stop(paste(package, collapse=", "), " package required for this functionality. Please install and try again.", call. = FALSE)
}
# Return unique columns
# This is used for figuring out which columns are constant within a group
#
# @keyword internal
uniquecols <- function(df) {
df <- df[1, sapply(df, function(x) length(unique(x)) == 1), drop=FALSE]
rownames(df) <- 1:nrow(df)
df
}
# A "safe" version of do.call
# \code{safe.call} works like \code{\link{do.call}} but it will only supply arguments that exist in the function specification.
#
# If ... is present in the param list, all parameters will be passed through
# unless \code{ignore.dots = TRUE}. Positional arguments are not currently
# supported.
#
# @param function to call
# @arugments named list of parameters to be supplied to function
# @param parameter names of function
# @param
# @keyword internal
safe.call <- function(f, params, f.params = names(formals(f)), ignore.dots = TRUE) {
if (!ignore.dots && "..." %in% f.params) {
safe.params <- params
} else {
safe.params <- params[intersect(f.params, names(params))]
}
do.call(f, safe.params)
}
# Convenience function to remove missing values from a data.frame
# Remove all non-complete rows, with a warning if \code{na.rm = FALSE}.
#
# ggplot is somewhat more accomodating of missing values than R generally.
# For those stats which require complete data, missing values will be
# automatically removed with a warning. If \code{na.rm = TRUE} is supplied
# to the statistic, the warning will be suppressed.
#
# @param data.frame
# @param suppress warning that rows are being removed?
# @argumnets variables to check for missings in
# @param optional function name to make warning message more informative
# @keyword internal
#X a <- remove_missing(movies)
#X a <- remove_missing(movies, na.rm = TRUE)
#X qplot(mpaa, budget, data=movies, geom="boxplot")
remove_missing <- function(df, na.rm=FALSE, vars = names(df), name="", finite = FALSE) {
vars <- intersect(vars, names(df))
if (name != "") name <- ps(" (", name, ")")
if (finite) {
missing <- !finite.cases(df[, vars, drop = FALSE])
str <- "non-finite"
} else {
missing <- !complete.cases(df[, vars, drop = FALSE])
str <- "missing"
}
if (any(missing)) {
df <- df[!missing, ]
if (!na.rm) warning("Removed ", sum(missing), " rows containing ", str,
" values", name, ".", call. = FALSE)
}
df
}
finite.cases <- function(x) UseMethod("finite.cases")
# Returns a logical vector of same length as nrow(x). If all data on a row
# is finite (not NA, NaN, Inf, or -Inf) return TRUE; otherwise FALSE.
#' @S3method finite.cases data.frame
finite.cases.data.frame <- function(x) {
finite_cases <- vapply(x, is.finite, logical(nrow(x)))
# Need a special case test when x has exactly one row, because rowSums
# doesn't respect dimensions for 1x1 matrices. vapply returns a vector (not
# a matrix when the input has one row.
if (is.vector(finite_cases)) {
all(finite_cases)
} else {
# Find all the rows where all are TRUE
rowSums(as.matrix(finite_cases)) == ncol(x)
}
}
# "Invert" a list
# Keys become values, values become keys
#
# @param list to invert
# @keyword internal
invert <- function(L) {
t1 <- unlist(L)
names(t1) <- rep(names(L), lapply(L, length))
tapply(names(t1), t1, c)
}
# Inside
# Return logical vector indicating if x is inside the interval
#
# @keyword internal
"%inside%" <- function(x, interval) {
x >= interval[1] & x <= interval[2]
}
#' Used in examples to illustrate when errors should occur.
#'
#' @param expr code to evaluate.
#' @export
#' @keywords internal
#' @examples
#' should_stop(stop("Hi!"))
#' should_stop(should_stop("Hi!"))
should_stop <- function(expr) {
res <- try(print(force(expr)), TRUE)
if (!inherits(res, "try-error")) stop("No error!", call. = FALSE)
invisible()
}
#' A waiver object.
#'
#' A waiver is a "flag" object, similar to \code{NULL}, that indicates the
#' calling function should just use the default value. It is used in certain
#' functions to distinguish between displaying nothing (\code{NULL}) and
#' displaying a default value calculated elsewhere (\code{waiver()})
#'
#' @export
#' @keywords internal
waiver <- function() structure(NULL, class="waiver")
is.waive <- function(x) inherits(x, "waiver")
rescale01 <- function(x) {
rng <- range(x, na.rm = TRUE)
(x - rng[1]) / (rng[2] - rng[1])
}
# This is a hack for ggplot2 0.9.3 to make it compatible with both plyr 1.7.1 and
# plyr 1.8 (and above). This should be removed for the next release of ggplot2.
# Tag: deprecated
if (packageVersion("plyr") <= package_version("1.7.1")) {
rename <- function(x, replace, warn_missing) {
plyr::rename(x, replace)
}
} else {
rename <- plyr::rename
}
#' Give a deprecation error, warning, or messsage, depending on version number.
#'
#' Version numbers have the format .., like 0.9.2.
#' This function compares the current version number of ggplot2 against the
#' specified \code{version}, which is the most recent version before the
#' function (or other object) was deprecated.
#'
#' \code{gg_dep} will give an error, warning, or message, depending on the
#' difference between the current ggplot2 version and the specified
#' \code{version}.
#'
#' If the current major number is greater than \code{version}'s major number,
#' or if the current minor number is more than 1 greater than \code{version}'s
#' minor number, give an error.
#'
#' If the current minor number differs from \code{version}'s minor number by
#' one, give a warning.
#'
#' If the current subminor number differs from \code{version}'s subminor
#' number, print a message.
#'
#' @param version The last version of ggplot2 where this function was good
#' (in other words, the last version where it was not deprecated).
#' @param msg The message to print.
#' @export
gg_dep <- function(version, msg) {
v <- as.package_version(version)
cv <- packageVersion("ggplot2")
# If current major number is greater than last-good major number, or if
# current minor number is more than 1 greater than last-good minor number,
# give error.
if (cv[[1,1]] > v[[1,1]] || cv[[1,2]] > v[[1,2]] + 1) {
stop(msg, " (Defunct; last used in version ", version, ")",
call. = FALSE)
# If minor number differs by one, give warning
} else if (cv[[1,2]] > v[[1,2]]) {
warning(msg, " (Deprecated; last used in version ", version, ")",
call. = FALSE)
# If only subminor number is greater, give message
} else if (cv[[1,3]] > v[[1,3]]) {
message(msg, " (Deprecated; last used in version ", version, ")")
}
invisible()
}
ggplot2/R/utilities-break.r 0000644 0001751 0000144 00000003104 12114160774 015330 0 ustar hornik users #' Cut numeric vector into intervals of equal length.
#'
#' @param x numeric vector
#' @param n number of intervals to create, OR
#' @param length length of each interval
#' @param ... other arguments passed on to \code{\link{cut}}
#' @seealso \code{\link{cut_number}}
#' @export
#' @examples
#' table(cut_interval(1:100, n = 10))
#' table(cut_interval(1:100, n = 11))
#' table(cut_interval(1:100, length = 10))
cut_interval <- function(x, n = NULL, length = NULL, ...) {
cut(x, breaks(x, "width", n, length), include.lowest = TRUE, ...)
}
#' Cut numeric vector into intervals containing equal number of points.
#'
#' @param x numeric vector
#' @param n number of intervals to create
#' @param ... other arguments passed on to \code{\link{cut}}
#' @seealso \code{\link{cut_interval}}
#' @export
#' @examples
#' table(cut_number(runif(1000), n = 10))
cut_number <- function(x, n = NULL, ...) {
cut(x, breaks(x, "n", n), include.lowest = TRUE, ...)
}
breaks <- function(x, equal, nbins = NULL, binwidth = NULL) {
equal <- match.arg(equal, c("numbers", "width"))
if ((!is.null(nbins) && !is.null(binwidth)) || (is.null(nbins) && is.null(binwidth))) {
stop("Specify exactly one of n and width")
}
rng <- range(x, na.rm = TRUE, finite = TRUE)
if (equal == "width") {
if (!is.null(binwidth)) {
fullseq(rng, binwidth)
} else {
seq(rng[1], rng[2], length = nbins + 1)
}
} else {
if (!is.null(binwidth)) {
probs <- seq(0, 1, by = binwidth)
} else {
probs <- seq(0, 1, length = nbins + 1)
}
quantile(x, probs, na.rm = TRUE)
}
}
ggplot2/R/scale-linetype.r 0000644 0001751 0000144 00000002240 12114161113 015135 0 ustar hornik users #' Scale for line patterns.
#'
#' Default line types based on a set supplied by Richard Pearson,
#' University of Manchester. Line types can not be mapped to continuous
#' values.
#'
#' @inheritParams scale_x_discrete
#' @param na.value The linetype to use for \code{NA} values.
#' @rdname scale_linetype
#' @export
#' @examples
#' library(reshape2) # for melt
#' library(plyr) # for ddply
#' ecm <- melt(economics, id = "date")
#' rescale01 <- function(x) (x - min(x)) / diff(range(x))
#' ecm <- ddply(ecm, "variable", transform, value = rescale01(value))
#'
#' qplot(date, value, data=ecm, geom="line", group=variable)
#' qplot(date, value, data=ecm, geom="line", linetype=variable)
#' qplot(date, value, data=ecm, geom="line", colour=variable)
#'
#' # See scale_manual for more flexibility
scale_linetype <- function(..., na.value = "blank") {
discrete_scale("linetype", "linetype_d", linetype_pal(),
na.value = na.value, ...)
}
#' @rdname scale_linetype
#' @export
scale_linetype_continuous <- function(...) {
stop("A continuous variable can not be mapped to linetype", call. = FALSE)
}
#' @rdname scale_linetype
#' @export
scale_linetype_discrete <- scale_linetype
ggplot2/R/templates.r 0000644 0001751 0000144 00000015421 12114161113 014222 0 ustar hornik users #' Make a parallel coordinates plot.
#'
#' One way to think about a parallel coordinates plot, is as plotting
#' the data after it has been transformed to gain a new variable. This
#' function does this using \code{\link[reshape2]{melt}}.
#'
#' This gives us enormous flexibility as we have separated out the
#' type of drawing (lines by tradition) and can now use any of the existing
#' geom functions. In particular this makes it very easy to create parallel
#' boxplots, as shown in the example.
#'
#' @param data data frame
#' @param vars variables to include in parallel coordinates plot
#' @param ... other arguments passed on plot creation
#' @export
#' @examples
#' \dontrun{
#' ggpcp(mtcars) + geom_line()
#' ggpcp(mtcars, vars=names(mtcars[2:6])) + geom_line()
#' ggpcp(mtcars) + geom_boxplot(aes(group=variable))
#'
#' p <- ggpcp(mtcars, vars=names(mtcars[2:6]))
#' p + geom_line()
#' p + geom_line(aes(colour=mpg))
#' }
ggpcp <- function(data, vars=names(data), ...) {
gg_dep("0.9.1", "ggpcp is deprecated.")
scaled <- as.data.frame(lapply(data[, vars], rescale01))
data <- cunion(scaled, data)
data$ROWID <- 1:nrow(data)
molten <- melt(data, m=vars)
ggplot(molten, aes_string(x = "variable", y = "value", group = "ROWID"),
...)
}
#' Create a fluctuation plot.
#'
#' A fluctutation diagram is a graphical representation of a contingency
#' table. This function only supports 2D contingency tables
#' at present but extension to higher dimensions should be
#' relatively straightforward.
#'
#' With the default size fluctuation diagram, area is proportional to the
#' count (length of sides proportional to sqrt(count)).
#'
#' @param table a table of values, or a data frame with three columns,
#' the last column being frequency
#' @param type "size", or "colour" to create traditional heatmap
#' @param floor don't display cells smaller than this value
#' @param ceiling round cells to at most this value
#' @param na.rm If \code{TRUE}, silently remove missing values.
#' @export
#' @examples
#' \dontrun{
#' ggfluctuation(table(movies$Action, movies$Comedy))
#' ggfluctuation(table(movies$Action, movies$mpaa))
#' ggfluctuation(table(movies$Action, movies$Comedy), type="colour")
#' ggfluctuation(table(warpbreaks$breaks, warpbreaks$tension))
#' }
ggfluctuation <- function(table, type="size", floor=0, ceiling=max(table$freq, na.rm=TRUE)) {
gg_dep("0.9.1", "ggfluctuation is deprecated.")
if (is.table(table)) table <- as.data.frame(t(table))
oldnames <- names(table)
names(table) <- c("x","y", "result")
table <- transform(table,
x = as.factor(x),
y = as.factor(y),
freq = result
)
if (type =="size") {
table <- transform(table,
freq = sqrt(pmin(freq, ceiling) / ceiling),
border = ifelse(is.na(freq), "grey90", ifelse(freq > ceiling, "grey30", "grey50"))
)
table[is.na(table$freq), "freq"] <- 1
table <- subset(table, freq * ceiling >= floor)
}
if (type=="size") {
nx <- length(levels(table$x))
ny <- length(levels(table$y))
p <- ggplot(table,
aes_string(x="x", y="y", height="freq", width="freq", fill="border")) +
geom_tile(colour="white") +
scale_fill_identity() +
theme(aspect.ratio = ny / nx)
# geom_rect(aes(xmin = as.numeric(x), ymin = as.numeric(y), xmax = as.numeric(x) + freq, ymax = as.numeric(y) + freq), colour="white") +
} else {
p <- ggplot(table, aes_string(x="x", y="y", fill="freq")) +
geom_tile(colour="grey50") +
scale_fill_gradient2(low="white", high="darkgreen")
}
p$xlabel <- oldnames[1]
p$ylabel <- oldnames[2]
p
}
#' Create a plot to illustrate patterns of missing values.
#'
#' The missing values plot is a useful tool to get a rapid
#' overview of the number and pattern of missing values in a
#' dataset. Its strength
#' is much more apparent when used with interactive graphics, as you can
#' see in Mondrian (\url{http://rosuda.org/mondrian}) where this plot was
#' copied from.
#'
#' @param data input data.frame
#' @param avoid whether missings should be stacked or dodged, see
#' \code{\link{geom_bar}} for more details
#' @param order if \code{TRUE}, order variables by number of missings
#' @param missing.only if \code{TRUE}, only display variables with some
#' missing data
#' @seealso \code{\link{ggstructure}}, \code{\link{ggorder}}
#' @export
#' @examples
#' \dontrun{
#' mmissing <- movies
#' mmissing[sample(nrow(movies), 1000), sample(ncol(movies), 5)] <- NA
#' ggmissing(mmissing)
#' ggmissing(mmissing, order=FALSE, missing.only = FALSE)
#' ggmissing(mmissing, avoid="dodge") + scale_y_sqrt()
#' }
ggmissing <- function(data, avoid="stack", order=TRUE, missing.only = TRUE) {
gg_dep("0.9.1", "ggmissing is deprecated.")
missings <- mapply(function(var, name) cbind(as.data.frame(table(missing=factor(is.na(var), levels=c(TRUE, FALSE), labels=c("yes", "no")))), variable=name),
data, names(data), SIMPLIFY=FALSE
)
df <- do.call("rbind", missings)
prop <- df[df$missing == "yes", "Freq"] / (df[df$missing == "no", "Freq"] + df[df$missing == "yes", "Freq"])
df$prop <- rep(prop, each=2)
if (order) {
var <- df$variable
var <- factor(var, levels = levels(var)[order(1 - prop)])
df$variable <- var
}
if (missing.only) {
df <- df[df$prop > 0 & df$prop < 1, , drop=FALSE]
df$variable <- factor(df$variable)
}
ggplot(df, aes_string(y="Freq", x="variable", fill="missing")) + geom_bar(position=avoid)
}
#' A plot which aims to reveal gross structural anomalies in the data.
#'
#' @param data data set to plot
#' @export
#' @examples
#' \dontrun{
#' ggstructure(mtcars)
#' }
ggstructure <- function(data) {
gg_dep("0.9.1", "ggstructure is deprecated.")
ggpcp(data) +
aes_string(y="ROWID", fill="value", x="variable") +
geom_tile() +
scale_y_continuous("row number", expand = c(0, 1)) +
scale_fill_gradient2(low="blue", mid="white", high="red", midpoint=0)
}
#' A plot to investigate the order in which observations were recorded.
#'
#' @param data data set to plot
#' @export
ggorder <- function(data) {
gg_dep("0.9.1", "ggorder is deprecated.")
ggpcp(data) +
aes_string(x="ROWID", group="variable", y="value") +
facet_grid(. ~ variable) +
geom_line() +
scale_x_continuous("row number")
}
# Distribution plot.
ggdist <- function(data, vars=names(data), facets = . ~ .) {
gg_dep("0.9.1", "ggdist is deprecated.")
cat <- sapply(data[vars], is.factor)
facets <- deparse(substitute(facets))
grid.newpage()
pushViewport(viewport(layout=grid.layout(ncol = ncol(data))))
mapply(function(name, cat, i) {
p <- ggplot(data) +
facet_grid(facets) +
aes_string(x=name, y=1) +
geom_bar()
pushViewport(viewport(layout.pos.col=i))
grid.draw(ggplotGrob(p))
popViewport()
}, names(data[vars]), cat, 1:ncol(data[vars]))
invisible()
}
ggplot2/R/stat-ydensity.r 0000644 0001751 0000144 00000011072 12114161113 015043 0 ustar hornik users #' 1d kernel density estimate along y axis, for violin plot.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "ydensity")}
#'
#' @inheritParams stat_density
#' @inheritParams stat_identity
#' @param trim If \code{TRUE} (default), trim the tails of the violins
#' to the range of the data. If \code{FALSE}, don't trim the tails.
#' @param scale if "area" (default), all violins have the same area (before trimming
#' the tails). If "count", areas are scaled proportionally to the number of
#' observations. If "width", all violins have the same maximum width.
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#'
#' @return A data frame with additional columns:
#' \item{density}{density estimate}
#' \item{scaled}{density estimate, scaled to maximum of 1}
#' \item{count}{density * number of points - probably useless for violin plots}
#' \item{violinwidth}{density scaled for the violin plot, according to area, counts
#' or to a constant maximum width}
#' \item{n}{number of points}
#' \item{width}{width of violin bounding box}
#' @seealso \code{\link{geom_violin}} for examples, and \code{\link{stat_density}}
#' for examples with data along the x axis.
#' @export
#' @examples
#' # See geom_violin for examples
#' # Also see stat_density for similar examples with data along x axis
stat_ydensity <- function (mapping = NULL, data = NULL, geom = "violin", position = "dodge",
adjust = 1, kernel = "gaussian", trim = TRUE, scale = "area", na.rm = FALSE, ...) {
StatYdensity$new(mapping = mapping, data = data, geom = geom, position = position,
adjust = adjust, kernel = kernel, trim = trim, scale = scale,
na.rm = na.rm, ...)
}
StatYdensity <- proto(Stat, {
objname <- "ydensity"
calculate_groups <- function(., data, na.rm = FALSE, width = NULL,
scale = "area", ...) {
data <- remove_missing(data, na.rm, "y", name = "stat_ydensity", finite = TRUE)
data <- .super$calculate_groups(., data, na.rm = na.rm, width = width, ...)
# choose how violins are scaled relative to each other
scale <- match.arg(scale, c("area", "equal", "count", "width"))
if (scale == "equal") {
gg_dep("0.9.2", "scale=\"area\" is deprecated; in the future, use scale=\"equal\" instead.")
scale <- "area"
}
data$violinwidth <- switch(scale,
# area : keep the original densities but scale them to a max width of 1
# for plotting purposes only
area = data$density / max(data$density),
# count: use the original densities scaled to a maximum of 1 (as above)
# and then scale them according to the number of observations
count = (data$density / max(data$density)) * data$n / max(data$n),
# width: constant width (density scaled to a maximum of 1)
width = data$scaled
)
data
}
calculate <- function(., data, scales, width=NULL, adjust=1, kernel="gaussian",
trim=TRUE, na.rm = FALSE, ...) {
n <- nrow(data)
# if less than 3 points, return a density of 1 everywhere
if (n < 3) {
return(data.frame(data, density = 1, scaled = 1, count = 1))
}
# initialize weights if they are not supplied by the user
if (is.null(data$weight)) { data$weight <- rep(1, n) / n }
# compute the density
dens <- density(data$y, adjust = adjust, kernel = kernel,
weight = data$weight, n = 200)
# NB: stat_density restricts to the scale range, here we leave that
# free so violins can extend the y scale
densdf <- data.frame(y = dens$x, density = dens$y)
# scale density to a maximum of 1
densdf$scaled <- densdf$density / max(densdf$density, na.rm = TRUE)
# trim density outside of the data range
if (trim) {
densdf <- subset(densdf, y > min(data$y, na.rm = TRUE) & y < max(data$y, na.rm = TRUE))
}
# NB: equivalently, we could have used these bounds in the from and
# to arguments of density()
# scale density by the number of observations
densdf$count <- densdf$density * n
# record the number of observations to be able to scale the density later
densdf$n <- n
# coordinate on the x axis
densdf$x <- if (is.factor(data$x)) data$x[1] else mean(range(data$x))
# width of the bounding box of the violin plot on the x axis for continuous x
if (length(unique(data$x)) > 1) { width <- diff(range(data$x)) * 0.9 }
densdf$width <- width
densdf
}
default_geom <- function(.) GeomViolin
required_aes <- c("x", "y")
})
ggplot2/R/zxx.r 0000644 0001751 0000144 00000002372 12114160774 013072 0 ustar hornik users # Default scales -------------------------------------------------------------
#' @export
#' @rdname scale_hue
scale_colour_discrete <- scale_colour_hue
#' @export
#' @rdname scale_gradient
scale_colour_continuous <- scale_colour_gradient
#' @export
#' @rdname scale_hue
scale_fill_discrete <- scale_fill_hue
#' @export
#' @rdname scale_gradient
scale_fill_continuous <- scale_fill_gradient
# British to American spellings ----------------------------------------------
#' @export
#' @rdname scale_brewer
scale_color_brewer <- scale_colour_brewer
#' @export
#' @rdname scale_gradient
scale_color_continuous <- scale_colour_gradient
#' @export
#' @rdname scale_hue
scale_color_discrete <- scale_colour_hue
#' @export
#' @rdname scale_gradient
scale_color_gradient <- scale_colour_gradient
#' @export
#' @rdname scale_gradient2
scale_color_gradient2 <- scale_colour_gradient2
#' @export
#' @rdname scale_gradientn
scale_color_gradientn <- scale_colour_gradientn
#' @export
#' @rdname scale_grey
scale_color_grey <- scale_colour_grey
#' @export
#' @rdname scale_hue
scale_color_hue <- scale_colour_hue
#' @export
#' @rdname scale_identity
scale_color_identity <- scale_colour_identity
#' @export
#' @rdname scale_manual
scale_color_manual <- scale_colour_manual
ggplot2/R/geom-crossbar.r 0000644 0001751 0000144 00000006552 12114161113 014774 0 ustar hornik users #' Hollow bar with middle indicated by horizontal line.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "crossbar")}
#'
#' @inheritParams geom_point
#' @param fatten a multiplicate factor to fatten middle bar by
#' @seealso \code{\link{geom_errorbar}} for error bars,
#' \code{\link{geom_pointrange}} and \code{\link{geom_linerange}} for other
#' ways of showing mean + error, \code{\link{stat_summary}} to compute
#' errors from the data, \code{\link{geom_smooth}} for the continuous analog.
#' @export
#' @examples
#' # See geom_linerange for examples
geom_crossbar <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",
fatten = 2, ...) {
GeomCrossbar$new(mapping = mapping, data = data, stat = stat,
position = position, fatten = fatten, ...)
}
GeomCrossbar <- proto(Geom, {
objname <- "crossbar"
reparameterise <- function(., df, params) {
GeomErrorbar$reparameterise(df, params)
}
default_stat <- function(.) StatIdentity
default_pos <- function(.) PositionIdentity
default_aes = function(.) aes(colour="black", fill=NA, size=0.5, linetype=1, alpha = NA)
required_aes <- c("x", "y", "ymin", "ymax")
guide_geom <- function(.) "crossbar"
draw_legend <- function(., data, ...) {
data <- aesdefaults(data, .$default_aes(), list(...))
gp <- with(data, gpar(col=colour, fill=alpha(fill, alpha), lwd=size * .pt, lty = linetype))
gTree(gp = gp, children = gList(
rectGrob(height=0.5, width=0.75),
linesGrob(c(0.125, 0.875), 0.5)
))
}
draw <- function(., data, scales, coordinates, fatten = 2, width = NULL, ...) {
middle <- transform(data, x = xmin, xend = xmax, yend = y, size = size * fatten, alpha = NA)
has_notch <- !is.null(data$ynotchlower) && !is.null(data$ynotchupper) &&
!is.na(data$ynotchlower) && !is.na(data$ynotchupper)
if (has_notch) {
if (data$ynotchlower < data$ymin || data$ynotchupper > data$ymax)
message("notch went outside hinges. Try setting notch=FALSE.")
notchindent <- (1 - data$notchwidth) * (data$xmax - data$xmin) / 2
middle$x <- middle$x + notchindent
middle$xend <- middle$xend - notchindent
box <- data.frame(
x = c(data$xmin, data$xmin, data$xmin + notchindent, data$xmin, data$xmin,
data$xmax, data$xmax, data$xmax - notchindent, data$xmax, data$xmax,
data$xmin),
y = c(data$ymax, data$ynotchupper, data$y, data$ynotchlower, data$ymin,
data$ymin, data$ynotchlower, data$y, data$ynotchupper, data$ymax,
data$ymax),
alpha = data$alpha, colour = data$colour, size = data$size,
linetype = data$linetype, fill = data$fill, group = data$group,
stringsAsFactors = FALSE)
} else {
# No notch
box <- data.frame(
x = c(data$xmin, data$xmin, data$xmax, data$xmax, data$xmin),
y = c(data$ymax, data$ymin, data$ymin, data$ymax, data$ymax),
alpha = data$alpha, colour = data$colour, size = data$size,
linetype = data$linetype, fill = data$fill, group = data$group,
stringsAsFactors = FALSE)
}
ggname(.$my_name(), gTree(children=gList(
GeomPolygon$draw(box, scales, coordinates, ...),
GeomSegment$draw(middle, scales, coordinates, ...)
)))
}
})
ggplot2/R/geom-blank.r 0000644 0001751 0000144 00000002505 12114160774 014253 0 ustar hornik users #' Blank, draws nothing.
#'
#' The blank geom draws nothing, but can be a useful way of ensuring common
#' scales between different plots.
#'
#' @export
#' @inheritParams geom_point
#' @examples
#' qplot(length, rating, data = movies, geom = "blank")
#' # Nothing to see here!
#'
#' # Take the following scatter plot
#' a <- ggplot(mtcars, aes(x = wt, y = mpg), . ~ cyl) + geom_point()
#' # Add to that some lines with geom_abline()
#' df <- data.frame(a = rnorm(10, 25), b = rnorm(10, 0))
#' a + geom_abline(aes(intercept = a, slope = b), data = df)
#' # Suppose you then wanted to remove the geom_point layer
#' # If you just remove geom_point, you will get an error
#' b <- ggplot(mtcars, aes(x = wt, y = mpg))
#' \dontrun{b + geom_abline(aes(intercept = a, slope = b), data = df)}
#' # Switching to geom_blank() gets the desired plot
#' c <- ggplot(mtcars, aes(x = wt, y = mpg)) + geom_blank()
#' c + geom_abline(aes(intercept = a, slope = b), data = df)
geom_blank <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", ...) {
GeomBlank$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomBlank <- proto(Geom, {
objname <- "blank"
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes()
draw_legend <- function(., data, ...) {
zeroGrob()
}
})
ggplot2/R/stat-sum.r 0000644 0001751 0000144 00000004660 12114161113 014004 0 ustar hornik users #' Sum unique values. Useful for overplotting on scatterplots.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "sum")}
#'
#' @seealso \code{\link{ggfluctuation}} for a fluctuation diagram,
#' @inheritParams stat_identity
#' @return a data.frame with additional columns
#' \item{n}{number of observations at position}
#' \item{prop}{percent of points in that panel at that position}
#' @export
#' @examples
#' \donttest{
#' d <- ggplot(diamonds, aes(x = cut, y = clarity))
#' # By default, all categorical variables in the plot form grouping
#' # variables, and the default behavior in stat_sum is to show the
#' # proportion. Specifying stat_sum with no group identifier leads to
#' # a plot which is not meaningful:
#' d + stat_sum()
#' # To correct this problem and achieve a more desirable plot, we need
#' # to specify which group the proportion is to be calculated over.
#' # There are several ways to do this:
#'
#' # by overall proportion
#' d + stat_sum(aes(group = 1))
#' d + stat_sum(aes(group = 1)) + scale_size(range = c(3, 10))
#' d + stat_sum(aes(group = 1)) + scale_area(range = c(3, 10))
#'
#' # by cut
#' d + stat_sum(aes(group = cut))
#' d + stat_sum(aes(group = cut, colour = cut))
#'
#' # by clarity
#' d + stat_sum(aes(group = clarity))
#' d + stat_sum(aes(group = clarity, colour = cut))
#'
#' # Instead of proportions, can also use sums
#' d + stat_sum(aes(size = ..n..))
#'
#' # Can also weight by another variable
#' d + stat_sum(aes(group = 1, weight = price))
#' d + stat_sum(aes(group = 1, weight = price, size = ..n..))
#'
#' # Or using qplot
#' qplot(cut, clarity, data = diamonds)
#' qplot(cut, clarity, data = diamonds, stat = "sum", group = 1)
#' }
stat_sum <- function (mapping = NULL, data = NULL, geom = "point", position = "identity", ...) {
StatSum$new(mapping = mapping, data = data, geom = geom, position = position, ...)
}
StatSum <- proto(Stat, {
objname <- "sum"
default_aes <- function(.) aes(size = ..prop..)
required_aes <- c("x", "y")
default_geom <- function(.) GeomPoint
calculate_groups <- function(., data, scales, ...) {
if (is.null(data$weight)) data$weight <- 1
group_by <- setdiff(intersect(names(data), .all_aesthetics), "weight")
counts <- count(data, group_by, wt_var = "weight")
counts <- rename(counts, c(freq = "n"), warn_missing = FALSE)
counts$prop <- ave(counts$n, counts$group, FUN = prop.table)
counts
}
})
ggplot2/R/geom-point-.r 0000644 0001751 0000144 00000013431 12114160774 014372 0 ustar hornik users #' Points, as for a scatterplot
#'
#' The point geom is used to create scatterplots.
#'
#' The scatterplot is useful for displaying the relationship between two
#' continuous variables, although it can also be used with one continuous
#' and one categorical variable, or two categorical variables. See
#' \code{\link{geom_jitter}} for possibilities.
#'
#' The \emph{bubblechart} is a scatterplot with a third variable mapped to
#' the size of points. There are no special names for scatterplots where
#' another variable is mapped to point shape or colour, however.
#'
#' The biggest potential problem with a scatterplot is overplotting: whenever
#' you have more than a few points, points may be plotted on top of one
#' another. This can severely distort the visual appearance of the plot.
#' There is no one solution to this problem, but there are some techniques
#' that can help. You can add additional information with
#' \code{\link{stat_smooth}}, \code{\link{stat_quantile}} or
#' \code{\link{stat_density2d}}. If you have few unique x values,
#' \code{\link{geom_boxplot}} may also be useful. Alternatively, you can
#' summarise the number of points at each location and display that in some
#' way, using \code{\link{stat_sum}}. Another technique is to use transparent
#' points, \code{geom_point(alpha = 0.05)}.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "point")}
#'
#' @seealso \code{\link{scale_size}} to see scale area of points, instead of
#' radius, \code{\link{geom_jitter}} to jitter points to reduce (mild)
#' overplotting
#' @param mapping The aesthetic mapping, usually constructed with
#' \code{\link{aes}} or \code{\link{aes_string}}. Only needs to be set
#' at the layer level if you are overriding the plot defaults.
#' @param data A layer specific dataset - only needed if you want to override
#' the plot defaults.
#' @param stat The statistical transformation to use on the data for this
#' layer.
#' @param position The position adjustment to use for overlappling points
#' on this layer
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @param ... other arguments passed on to \code{\link{layer}}. This can
#' include aesthetics whose values you want to set, not map. See
#' \code{\link{layer}} for more details.
#' @export
#' @examples
#' \donttest{
#' p <- ggplot(mtcars, aes(wt, mpg))
#' p + geom_point()
#'
#' # Add aesthetic mappings
#' p + geom_point(aes(colour = qsec))
#' p + geom_point(aes(alpha = qsec))
#' p + geom_point(aes(colour = factor(cyl)))
#' p + geom_point(aes(shape = factor(cyl)))
#' p + geom_point(aes(size = qsec))
#'
#' # Change scales
#' p + geom_point(aes(colour = cyl)) + scale_colour_gradient(low = "blue")
#' p + geom_point(aes(size = qsec)) + scale_area()
#' p + geom_point(aes(shape = factor(cyl))) + scale_shape(solid = FALSE)
#'
#' # Set aesthetics to fixed value
#' p + geom_point(colour = "red", size = 3)
#' qplot(wt, mpg, data = mtcars, colour = I("red"), size = I(3))
#'
#' # Varying alpha is useful for large datasets
#' d <- ggplot(diamonds, aes(carat, price))
#' d + geom_point(alpha = 1/10)
#' d + geom_point(alpha = 1/20)
#' d + geom_point(alpha = 1/100)
#'
#' # You can create interesting shapes by layering multiple points of
#' # different sizes
#' p <- ggplot(mtcars, aes(mpg, wt))
#' p + geom_point(colour="grey50", size = 4) + geom_point(aes(colour = cyl))
#' p + aes(shape = factor(cyl)) +
#' geom_point(aes(colour = factor(cyl)), size = 4) +
#' geom_point(colour="grey90", size = 1.5)
#' p + geom_point(colour="black", size = 4.5) +
#' geom_point(colour="pink", size = 4) +
#' geom_point(aes(shape = factor(cyl)))
#'
#' # These extra layers don't usually appear in the legend, but we can
#' # force their inclusion
#' p + geom_point(colour="black", size = 4.5, show_guide = TRUE) +
#' geom_point(colour="pink", size = 4, show_guide = TRUE) +
#' geom_point(aes(shape = factor(cyl)))
#'
#' # Transparent points:
#' qplot(mpg, wt, data = mtcars, size = I(5), alpha = I(0.2))
#'
#' # geom_point warns when missing values have been dropped from the data set
#' # and not plotted, you can turn this off by setting na.rm = TRUE
#' mtcars2 <- transform(mtcars, mpg = ifelse(runif(32) < 0.2, NA, mpg))
#' qplot(wt, mpg, data = mtcars2)
#' qplot(wt, mpg, data = mtcars2, na.rm = TRUE)
#'
#' # Use qplot instead
#' qplot(wt, mpg, data = mtcars)
#' qplot(wt, mpg, data = mtcars, colour = factor(cyl))
#' qplot(wt, mpg, data = mtcars, colour = I("red"))
#' }
geom_point <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",
na.rm = FALSE, ...) {
GeomPoint$new(mapping = mapping, data = data, stat = stat, position = position,
na.rm = na.rm, ...)
}
GeomPoint <- proto(Geom, {
objname <- "point"
draw_groups <- function(., ...) .$draw(...)
draw <- function(., data, scales, coordinates, na.rm = FALSE, ...) {
data <- remove_missing(data, na.rm,
c("x", "y", "size", "shape"), name = "geom_point")
if (empty(data)) return(zeroGrob())
with(coord_transform(coordinates, data, scales),
ggname(.$my_name(), pointsGrob(x, y, size=unit(size, "mm"), pch=shape,
gp=gpar(col=alpha(colour, alpha), fill = alpha(fill, alpha), fontsize = size * .pt)))
)
}
draw_legend <- function(., data, ...) {
data <- aesdefaults(data, .$default_aes(), list(...))
with(data,
pointsGrob(0.5, 0.5, size=unit(size, "mm"), pch=shape,
gp=gpar(
col=alpha(colour, alpha),
fill=alpha(fill, alpha),
fontsize = size * .pt)
)
)
}
default_stat <- function(.) StatIdentity
required_aes <- c("x", "y")
default_aes <- function(.) aes(shape=16, colour="black", size=2, fill = NA, alpha = NA)
})
ggplot2/R/scale-gradientn.r 0000644 0001751 0000144 00000003536 12114160774 015304 0 ustar hornik users #' Smooth colour gradient between n colours
#'
#' @inheritParams scales::gradient_n_pal
#' @inheritParams scale_colour_hue
#' @param guide Type of legend. Use \code{"colourbar"} for continuous
#' colour bar, or \code{"legend"} for discrete colour legend.
#' @family colour scales
#' @rdname scale_gradientn
#' @export
#' @examples
#' \donttest{
#' # scale_colour_gradient make it easy to use existing colour palettes
#'
#' dsub <- subset(diamonds, x > 5 & x < 6 & y > 5 & y < 6)
#' dsub$diff <- with(dsub, sqrt(abs(x-y))* sign(x-y))
#' (d <- qplot(x, y, data=dsub, colour=diff))
#'
#' d + scale_colour_gradientn(colours = rainbow(7))
#' breaks <- c(-0.5, 0, 0.5)
#' d + scale_colour_gradientn(colours = rainbow(7),
#' breaks = breaks, labels = format(breaks))
#'
#' d + scale_colour_gradientn(colours = topo.colors(10))
#' d + scale_colour_gradientn(colours = terrain.colors(10))
#'
#' # You can force them to be symmetric by supplying a vector of
#' # values, and turning rescaling off
#' max_val <- max(abs(dsub$diff))
#' values <- seq(-max_val, max_val, length = 11)
#'
#' d + scale_colour_gradientn(colours = topo.colors(10),
#' values = values, rescaler = function(x, ...) x, oob = identity)
#' d + scale_colour_gradientn(colours = terrain.colors(10),
#' values = values, rescaler = function(x, ...) x, oob = identity)
#' }
scale_colour_gradientn <- function(..., colours, values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar") {
continuous_scale("colour", "gradientn",
gradient_n_pal(colours, values, space), na.value = na.value, guide = guide, ...)
}
#' @rdname scale_gradientn
#' @export
scale_fill_gradientn <- function(..., colours, values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar") {
continuous_scale("fill", "gradientn",
gradient_n_pal(colours, values, space), na.value = na.value, guide = guide, ...)
}
ggplot2/R/stat-contour.r 0000644 0001751 0000144 00000010720 12114161113 014663 0 ustar hornik users #' Calculate contours of 3d data.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "contour")}
#'
#' @inheritParams stat_identity
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @return A data frame with additional column:
#' \item{level}{height of contour}
#' @export
#' @examples
#' \donttest{
#' # Generate data
#' library(reshape2) # for melt
#' volcano3d <- melt(volcano)
#' names(volcano3d) <- c("x", "y", "z")
#'
#' # Basic plot
#' v <- ggplot(volcano3d, aes(x, y, z = z))
#' v + stat_contour()
#'
#' # Setting bins creates evenly spaced contours in the range of the data
#' v + stat_contour(bins = 2)
#' v + stat_contour(bins = 10)
#'
#' # Setting binwidth does the same thing, parameterised by the distance
#' # between contours
#' v + stat_contour(binwidth = 2)
#' v + stat_contour(binwidth = 5)
#' v + stat_contour(binwidth = 10)
#' v + stat_contour(binwidth = 2, size = 0.5, colour = "grey50") +
#' stat_contour(binwidth = 10, size = 1)
#'
#' # Add aesthetic mappings
#' v + stat_contour(aes(size = ..level..))
#' v + stat_contour(aes(colour = ..level..))
#'
#' # Change scale
#' v + stat_contour(aes(colour = ..level..), size = 2) +
#' scale_colour_gradient(low = "brown", high = "white")
#'
#' # Set aesthetics to fixed value
#' v + stat_contour(colour = "red")
#' v + stat_contour(size = 2, linetype = 4)
#'
#' # Try different geoms
#' v + stat_contour(geom="polygon", aes(fill=..level..))
#' v + geom_tile(aes(fill = z)) + stat_contour()
#'
#' # Use qplot instead
#' qplot(x, y, z = z, data = volcano3d, geom = "contour")
#' qplot(x, y, z = z, data = volcano3d, stat = "contour", geom = "path")
#' }
stat_contour <- function (mapping = NULL, data = NULL, geom = "path", position = "identity",
na.rm = FALSE, ...) {
StatContour$new(mapping = mapping, data = data, geom = geom,
position = position, na.rm = na.rm, ...)
}
StatContour <- proto(Stat, {
objname <- "contour"
calculate <- function(., data, scales, bins=NULL, binwidth=NULL, breaks = NULL, complete = FALSE, na.rm = FALSE, ...) {
data <- remove_missing(data, na.rm, name = "stat_contour", finite = TRUE)
# If no parameters set, use pretty bins
if (is.null(bins) && is.null(binwidth) && is.null(breaks)) {
breaks <- pretty(range(data$z), 10)
}
# If provided, use bins to calculate binwidth
if (!is.null(bins)) {
binwidth <- diff(range(data$z)) / bins
}
# If necessary, compute breaks from binwidth
if (is.null(breaks)) {
breaks <- fullseq(range(data$z), binwidth)
}
contour_lines(data, breaks, complete = complete)
}
default_geom <- function(.) GeomPath
default_aes <- function(.) aes(order = ..level..)
required_aes <- c("x", "y", "z")
})
# v3d <- reshape2::melt(volcano)
# names(v3d) <- c("x", "y", "z")
#
# breaks <- seq(95, 195, length = 10)
# contours <- contour_lines(v3d, breaks)
# qplot(x, y, data = contours, geom = "path") + facet_wrap(~ piece)
contour_lines <- function(data, breaks, complete = FALSE) {
z <- tapply(data$z, data[c("x", "y")], identity)
cl <- contourLines(
x = sort(unique(data$x)), y = sort(unique(data$y)), z = z,
levels = breaks)
if (length(cl) == 0) {
warning("Not possible to generate contour data", call. = FALSE)
return(data.frame())
}
# Convert list of lists into single data frame
lengths <- vapply(cl, function(x) length(x$x), integer(1))
levels <- vapply(cl, "[[", "level", FUN.VALUE = double(1))
xs <- unlist(lapply(cl, "[[", "x"), use.names = FALSE)
ys <- unlist(lapply(cl, "[[", "y"), use.names = FALSE)
pieces <- rep(seq_along(cl), lengths)
# Add leading zeros so that groups can be properly sorted later
groups <- paste(data$group[1], sprintf("%03d", pieces), sep = "-")
data.frame(
level = rep(levels, lengths),
x = xs,
y = ys,
piece = pieces,
group = groups
)
}
# 1 = clockwise, -1 = counterclockwise, 0 = 0 area
# From http://stackoverflow.com/questions/1165647
# x <- c(5, 6, 4, 1, 1)
# y <- c(0, 4, 5, 5, 0)
# poly_dir(x, y)
poly_dir <- function(x, y) {
xdiff <- c(x[-1], x[1]) - x
ysum <- c(y[-1], y[1]) + y
sign(sum(xdiff * ysum))
}
# To fix breaks and complete the polygons, we need to add 0-4 corner points.
#
# contours <- ddply(contours, "piece", mutate, dir = poly_dir(x, y))
# qplot(x, y, data = contours, geom = "path", group = piece,
# colour = factor(dir))
# last_plot() + facet_wrap(~ level)
ggplot2/R/geom-path-line.r 0000644 0001751 0000144 00000005301 12114160774 015042 0 ustar hornik users #' Connect observations, ordered by x value.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "line")}
#'
#' @seealso \code{\link{geom_path}}: connect observations in data order,
#' \code{\link{geom_segment}}: draw line segments,
#' \code{\link{geom_ribbon}}: fill between line and x-axis
#' @inheritParams geom_point
#' @export
#' @examples
#' # Summarise number of movie ratings by year of movie
#' mry <- do.call(rbind, by(movies, round(movies$rating), function(df) {
#' nums <- tapply(df$length, df$year, length)
#' data.frame(rating=round(df$rating[1]), year = as.numeric(names(nums)), number=as.vector(nums))
#' }))
#'
#' p <- ggplot(mry, aes(x=year, y=number, group=rating))
#' p + geom_line()
#'
#' # Add aesthetic mappings
#' p + geom_line(aes(size = rating))
#' p + geom_line(aes(colour = rating))
#'
#' # Change scale
#' p + geom_line(aes(colour = rating)) + scale_colour_gradient(low="red")
#' p + geom_line(aes(size = rating)) + scale_size(range = c(0.1, 3))
#'
#' # Set aesthetics to fixed value
#' p + geom_line(colour = "red", size = 1)
#'
#' # Use qplot instead
#' qplot(year, number, data=mry, group=rating, geom="line")
#'
#' # Using a time series
#' qplot(date, pop, data=economics, geom="line")
#' qplot(date, pop, data=economics, geom="line", log="y")
#' qplot(date, pop, data=subset(economics, date > as.Date("2006-1-1")), geom="line")
#' qplot(date, pop, data=economics, size=unemploy/pop, geom="line")
#'
#' # Use the arrow parameter to add an arrow to the line
#' # See ?grid::arrow for more details
#' c <- ggplot(economics, aes(x = date, y = pop))
#' # Arrow defaults to "last"
#' library(grid)
#' c + geom_line(arrow = arrow())
#' c + geom_line(arrow = arrow(angle = 15, ends = "both", type = "closed"))
#'
#' # See scale_date for examples of plotting multiple times series on
#' # a single graph
#'
#' # A simple pcp example
#'
#' y2005 <- runif(300, 20, 120)
#' y2010 <- y2005 * runif(300, -1.05, 1.5)
#' group <- rep(LETTERS[1:3], each = 100)
#'
#' df <- data.frame(id = seq_along(group), group, y2005, y2010)
#' library(reshape2) # for melt
#' dfm <- melt(df, id.var = c("id", "group"))
#' ggplot(dfm, aes(variable, value, group = id, colour = group)) +
#' geom_path(alpha = 0.5)
geom_line <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", ...) {
GeomLine$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomLine <- proto(GeomPath, {
objname <- "line"
draw <- function(., data, scales, coordinates, arrow = NULL, ...) {
data <- data[order(data$group, data$x), ]
GeomPath$draw(data, scales, coordinates, arrow, ...)
}
default_stat <- function(.) StatIdentity
})
ggplot2/R/stat-spoke.r 0000644 0001751 0000144 00000002336 12114160774 014333 0 ustar hornik users #' Convert angle and radius to xend and yend.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "spoke")}
#'
#' @inheritParams stat_identity
#' @return a data.frame with additional columns
#' \item{xend}{x position of end of line segment}
#' \item{yend}{x position of end of line segment}
#' @export
#' @examples
#' df <- expand.grid(x = 1:10, y=1:10)
#' df$angle <- runif(100, 0, 2*pi)
#' df$speed <- runif(100, 0, 0.5)
#'
#' qplot(x, y, data=df) + stat_spoke(aes(angle=angle), radius = 0.5)
#' last_plot() + scale_y_reverse()
#'
#' qplot(x, y, data=df) + stat_spoke(aes(angle=angle, radius=speed))
stat_spoke <- function (mapping = NULL, data = NULL, geom = "segment", position = "identity", ...) {
StatSpoke$new(mapping = mapping, data = data, geom = geom, position = position, ...)
}
StatSpoke <- proto(Stat, {
objname <- "spoke"
retransform <- FALSE
calculate <- function(., data, scales, radius = 1, ...) {
transform(data,
xend = x + cos(angle) * radius,
yend = y + sin(angle) * radius
)
}
default_aes <- function(.) aes(xend = ..xend.., yend = ..yend..)
required_aes <- c("x", "y", "angle", "radius")
default_geom <- function(.) GeomSegment
})
ggplot2/R/facet-grid-.r 0000644 0001751 0000144 00000035013 12114161113 014305 0 ustar hornik users #' Lay out panels in a grid.
#'
#' @param facets a formula with the rows (of the tabular display) on the LHS
#' and the columns (of the tabular display) on the RHS; the dot in the
#' formula is used to indicate there should be no faceting on this dimension
#' (either row or column). The formula can also be provided as a string
#' instead of a classical formula object
#' @param margins either a logical value or a character
#' vector. Margins are additional facets which contain all the data
#' for each of the possible values of the faceting variables. If
#' \code{FALSE}, no additional facets are included (the
#' default). If \code{TRUE}, margins are included for all faceting
#' variables. If specified as a character vector, it is the names of
#' variables for which margins are to be created.
#' @param scales Are scales shared across all facets (the default,
#' \code{"fixed"}), or do they vary across rows (\code{"free_x"}),
#' columns (\code{"free_y"}), or both rows and columns (\code{"free"})
#' @param space If \code{"fixed"}, the default, all panels have the same size.
#' If \code{"free_y"} their height will be proportional to the length of the
#' y scale; if \code{"free_x"} their width will be proportional to the
#' length of the x scale; or if \code{"free"} both height and width will
#' vary. This setting has no effect unless the appropriate scales also vary.
#' @param labeller A function that takes two arguments (\code{variable} and
#' \code{value}) and returns a string suitable for display in the facet
#' strip. See \code{\link{label_value}} for more details and pointers
#' to other options.
#' @param as.table If \code{TRUE}, the default, the facets are laid out like
#' a table with highest values at the bottom-right. If \code{FALSE}, the
#' facets are laid out like a plot with the highest value at the top-right.
#' @param shrink If \code{TRUE}, will shrink scales to fit output of
#' statistics, not raw data. If \code{FALSE}, will be range of raw data
#' before statistical summary.
#' @param drop If \code{TRUE}, the default, all factor levels not used in the
#' data will automatically be dropped. If \code{FALSE}, all factor levels
#' will be shown, regardless of whether or not they appear in the data.
#' @export
#' @examples
#' \donttest{
#' p <- ggplot(mtcars, aes(mpg, wt)) + geom_point()
#' # With one variable
#' p + facet_grid(. ~ cyl)
#' p + facet_grid(cyl ~ .)
#'
#' # With two variables
#' p + facet_grid(vs ~ am)
#' p + facet_grid(am ~ vs)
#' p + facet_grid(vs ~ am, margins=TRUE)
#'
#' # To change plot order of facet grid,
#' # change the order of variable levels with factor()
#'
#' set.seed(6809)
#' diamonds <- diamonds[sample(nrow(diamonds), 1000), ]
#' diamonds$cut <- factor(diamonds$cut,
#' levels = c("Ideal", "Very Good", "Fair", "Good", "Premium"))
#'
#' # Repeat first example with new order
#' p <- ggplot(diamonds, aes(carat, ..density..)) +
#' geom_histogram(binwidth = 1)
#' p + facet_grid(. ~ cut)
#'
#' qplot(mpg, wt, data=mtcars, facets = . ~ vs + am)
#' qplot(mpg, wt, data=mtcars, facets = vs + am ~ . )
#'
#' # You can also use strings, which makes it a little easier
#' # when writing functions that generate faceting specifications
#' # p + facet_grid("cut ~ .")
#'
#' # see also ?plotmatrix for the scatterplot matrix
#'
#' # If there isn't any data for a given combination, that panel
#' # will be empty
#' qplot(mpg, wt, data=mtcars) + facet_grid(cyl ~ vs)
#'
# If you combine a facetted dataset with a dataset that lacks those
# facetting variables, the data will be repeated across the missing
# combinations:
#' p <- qplot(mpg, wt, data=mtcars, facets = vs ~ cyl)
#'
#' df <- data.frame(mpg = 22, wt = 3)
#' p + geom_point(data = df, colour="red", size = 2)
#'
#' df2 <- data.frame(mpg = c(19, 22), wt = c(2,4), vs = c(0, 1))
#' p + geom_point(data = df2, colour="red", size = 2)
#'
#' df3 <- data.frame(mpg = c(19, 22), wt = c(2,4), vs = c(1, 1))
#' p + geom_point(data = df3, colour="red", size = 2)
#'
#'
#' # You can also choose whether the scales should be constant
#' # across all panels (the default), or whether they should be allowed
#' # to vary
#' mt <- ggplot(mtcars, aes(mpg, wt, colour = factor(cyl))) + geom_point()
#'
#' mt + facet_grid(. ~ cyl, scales = "free")
#' # If scales and space are free, then the mapping between position
#' # and values in the data will be the same across all panels
#' mt + facet_grid(. ~ cyl, scales = "free", space = "free")
#'
#' mt + facet_grid(vs ~ am, scales = "free")
#' mt + facet_grid(vs ~ am, scales = "free_x")
#' mt + facet_grid(vs ~ am, scales = "free_y")
#' mt + facet_grid(vs ~ am, scales = "free", space="free")
#' mt + facet_grid(vs ~ am, scales = "free", space="free_x")
#' mt + facet_grid(vs ~ am, scales = "free", space="free_y")
#'
#' # You may need to set your own breaks for consistent display:
#' mt + facet_grid(. ~ cyl, scales = "free_x", space="free") +
#' scale_x_continuous(breaks = seq(10, 36, by = 2))
#' # Adding scale limits override free scales:
#' last_plot() + xlim(10, 15)
#'
#' # Free scales are particularly useful for categorical variables
#' qplot(cty, model, data=mpg) +
#' facet_grid(manufacturer ~ ., scales = "free", space = "free")
#' # particularly when you reorder factor levels
#' mpg <- within(mpg, {
#' model <- reorder(model, cty)
#' manufacturer <- reorder(manufacturer, cty)
#' })
#' last_plot() %+% mpg + theme(strip.text.y = element_text())
#'
#' # Use as.table to to control direction of horizontal facets, TRUE by default
#' h <- ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point()
#' h + facet_grid(cyl ~ vs)
#' h + facet_grid(cyl ~ vs, as.table = FALSE)
#'
#' # Use labeller to control facet labels, label_value is default
#' h + facet_grid(cyl ~ vs, labeller = label_both)
#' # Using label_parsed, see ?plotmath for more options
#' mtcars$cyl2 <- factor(mtcars$cyl, labels = c("alpha", "beta", "sqrt(x, y)"))
#' k <- qplot(wt, mpg, data = mtcars)
#' k + facet_grid(. ~ cyl2)
#' k + facet_grid(. ~ cyl2, labeller = label_parsed)
#' # For label_bquote the label value is x.
#' p <- qplot(wt, mpg, data = mtcars)
#' p + facet_grid(. ~ vs, labeller = label_bquote(alpha ^ .(x)))
#' p + facet_grid(. ~ vs, labeller = label_bquote(.(x) ^ .(x)))
#'
#' # Margins can be specified by logically (all yes or all no) or by specific
#' # variables as (character) variable names
#' mg <- ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point()
#' mg + facet_grid(vs + am ~ gear)
#' mg + facet_grid(vs + am ~ gear, margins = TRUE)
#' mg + facet_grid(vs + am ~ gear, margins = "am")
#' # when margins are made over "vs", since the facets for "am" vary
#' # within the values of "vs", the marginal facet for "vs" is also
#' # a margin over "am".
#' mg + facet_grid(vs + am ~ gear, margins = "vs")
#' mg + facet_grid(vs + am ~ gear, margins = "gear")
#' mg + facet_grid(vs + am ~ gear, margins = c("gear", "am"))
#' }
facet_grid <- function(facets, margins = FALSE, scales = "fixed", space = "fixed", shrink = TRUE, labeller = "label_value", as.table = TRUE, drop = TRUE) {
scales <- match.arg(scales, c("fixed", "free_x", "free_y", "free"))
free <- list(
x = any(scales %in% c("free_x", "free")),
y = any(scales %in% c("free_y", "free"))
)
space <- match.arg(space, c("fixed", "free_x", "free_y", "free"))
space_free <- list(
x = any(space %in% c("free_x", "free")),
y = any(space %in% c("free_y", "free"))
)
# Facets can either be a formula, a string, or a list of things to be
# convert to quoted
if (is.character(facets)) {
facets <- as.formula(facets)
}
if (is.formula(facets)) {
lhs <- function(x) if(length(x) == 2) NULL else x[-3]
rhs <- function(x) if(length(x) == 2) x else x[-2]
rows <- as.quoted(lhs(facets))
rows <- rows[!sapply(rows, identical, as.name("."))]
cols <- as.quoted(rhs(facets))
cols <- cols[!sapply(cols, identical, as.name("."))]
}
if (is.list(facets)) {
rows <- as.quoted(facets[[1]])
cols <- as.quoted(facets[[2]])
}
if (length(rows) + length(cols) == 0) {
stop("Must specify at least one variable to facet by", call. = FALSE)
}
facet(
rows = rows, cols = cols, margins = margins, shrink = shrink,
free = free, space_free = space_free,
labeller = labeller, as.table = as.table, drop = drop,
subclass = "grid"
)
}
#' @S3method facet_train_layout grid
facet_train_layout.grid <- function(facet, data) {
layout <- layout_grid(data, facet$rows, facet$cols, facet$margins,
drop = facet$drop, as.table = facet$as.table)
# Relax constraints, if necessary
layout$SCALE_X <- if (facet$free$x) layout$COL else 1L
layout$SCALE_Y <- if (facet$free$y) layout$ROW else 1L
layout
}
#' @S3method facet_map_layout grid
facet_map_layout.grid <- function(facet, data, layout) {
locate_grid(data, layout, facet$rows, facet$cols, facet$margins)
}
#' @S3method facet_render grid
facet_render.grid <- function(facet, panel, coord, theme, geom_grobs) {
axes <- facet_axes(facet, panel, coord, theme)
strips <- facet_strips(facet, panel, theme)
panels <- facet_panels(facet, panel, coord, theme, geom_grobs)
# adjust the size of axes to the size of panel
axes$l$heights <- panels$heights
axes$b$widths <- panels$widths
# adjust the size of the strips to the size of the panels
strips$r$heights <- panels$heights
strips$t$widths <- panels$widths
# Combine components into complete plot
top <- strips$t
top <- gtable_add_cols(top, strips$r$widths)
top <- gtable_add_cols(top, axes$l$widths, pos = 0)
center <- cbind(axes$l, panels, strips$r, z = c(2, 1, 3))
bottom <- axes$b
bottom <- gtable_add_cols(bottom, strips$r$widths)
bottom <- gtable_add_cols(bottom, axes$l$widths, pos = 0)
complete <- rbind(top, center, bottom, z = c(1, 2, 3))
complete$respect <- panels$respect
complete$name <- "layout"
bottom <- axes$b
complete
}
#' @S3method facet_strips grid
facet_strips.grid <- function(facet, panel, theme) {
col_vars <- unique(panel$layout[names(facet$cols)])
row_vars <- unique(panel$layout[names(facet$rows)])
list(
r = build_strip(panel, row_vars, facet$labeller, theme, "r"),
t = build_strip(panel, col_vars, facet$labeller, theme, "t")
)
}
build_strip <- function(panel, label_df, labeller, theme, side = "right") {
side <- match.arg(side, c("top", "left", "bottom", "right"))
horizontal <- side %in% c("top", "bottom")
labeller <- match.fun(labeller)
# No labelling data, so return empty row/col
if (empty(label_df)) {
if (horizontal) {
widths <- unit(rep(0, max(panel$layout$COL)), "null")
return(gtable_row_spacer(widths))
} else {
heights <- unit(rep(0, max(panel$layout$ROW)), "null")
return(gtable_col_spacer(heights))
}
}
# Create matrix of labels
labels <- matrix(list(), nrow = nrow(label_df), ncol = ncol(label_df))
for (i in seq_len(ncol(label_df))) {
labels[, i] <- labeller(names(label_df)[i], label_df[, i])
}
# Render as grobs
grobs <- apply(labels, c(1,2), ggstrip, theme = theme,
horizontal = horizontal)
# Create layout
name <- paste("strip", side, sep = "-")
if (horizontal) {
grobs <- t(grobs)
# Each row is as high as the highest and as a wide as the panel
row_height <- function(row) max(laply(row, height_cm))
heights <- unit(apply(grobs, 1, row_height), "cm")
widths <- unit(rep(1, ncol(grobs)), "null")
} else {
# Each row is wide as the widest and as high as the panel
col_width <- function(col) max(laply(col, width_cm))
widths <- unit(apply(grobs, 2, col_width), "cm")
heights <- unit(rep(1, nrow(grobs)), "null")
}
strips <- gtable_matrix(name, grobs, heights = heights, widths = widths)
if (horizontal) {
gtable_add_col_space(strips, theme$panel.margin)
} else {
gtable_add_row_space(strips, theme$panel.margin)
}
}
#' @S3method facet_axes grid
facet_axes.grid <- function(facet, panel, coord, theme) {
axes <- list()
# Horizontal axes
cols <- which(panel$layout$ROW == 1)
grobs <- lapply(panel$ranges[cols], coord_render_axis_h,
coord = coord, theme = theme)
axes$b <- gtable_add_col_space(gtable_row("axis-b", grobs),
theme$panel.margin)
# Vertical axes
rows <- which(panel$layout$COL == 1)
grobs <- lapply(panel$ranges[rows], coord_render_axis_v,
coord = coord, theme = theme)
axes$l <- gtable_add_row_space(gtable_col("axis-l", grobs),
theme$panel.margin)
axes
}
#' @S3method facet_panels grid
facet_panels.grid <- function(facet, panel, coord, theme, geom_grobs) {
# If user hasn't set aspect ratio, and we have fixed scales, then
# ask the coordinate system if it wants to specify one
aspect_ratio <- theme$aspect.ratio
if (is.null(aspect_ratio) && !facet$free$x && !facet$free$y) {
aspect_ratio <- coord_aspect(coord, panel$ranges[[1]])
}
if (is.null(aspect_ratio)) {
aspect_ratio <- 1
respect <- FALSE
} else {
respect <- TRUE
}
# Add background and foreground to panels
panels <- panel$layout$PANEL
ncol <- max(panel$layout$COL)
nrow <- max(panel$layout$ROW)
panel_grobs <- lapply(panels, function(i) {
fg <- coord_render_fg(coord, panel$range[[i]], theme)
bg <- coord_render_bg(coord, panel$range[[i]], theme)
geom_grobs <- lapply(geom_grobs, "[[", i)
panel_grobs <- c(list(bg), geom_grobs, list(fg))
gTree(children = do.call("gList", panel_grobs))
})
panel_matrix <- matrix(panel_grobs, nrow = nrow, ncol = ncol, byrow = TRUE)
# @kohske
# Now size of each panel is calculated using PANEL$ranges, which is given by
# coord_train called by train_range.
# So here, "scale" need not to be referred.
#
# In general, panel has all information for building facet.
if (facet$space_free$x) {
ps <- panel$layout$PANEL[panel$layout$ROW == 1]
widths <- vapply(ps, function(i) diff(panel$range[[i]]$x.range), numeric(1))
panel_widths <- unit(widths, "null")
} else {
panel_widths <- rep(unit(1, "null"), ncol)
}
if (facet$space_free$y) {
ps <- panel$layout$PANEL[panel$layout$COL == 1]
heights <- vapply(ps, function(i) diff(panel$range[[i]]$y.range), numeric(1))
panel_heights <- unit(heights, "null")
} else {
panel_heights <- rep(unit(1 * aspect_ratio, "null"), nrow)
}
panels <- gtable_matrix("panel", panel_matrix,
panel_widths, panel_heights, respect = respect)
panels <- gtable_add_col_space(panels, theme$panel.margin)
panels <- gtable_add_row_space(panels, theme$panel.margin)
panels
}
#' @S3method facet_vars grid
facet_vars.grid <- function(facet) {
paste(lapply(list(facet$rows, facet$cols), paste, collapse = ", "),
collapse = " ~ ")
}
ggplot2/R/geom-violin.r 0000644 0001751 0000144 00000007742 12114160774 014474 0 ustar hornik users #' Violin plot.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "violin")}
#'
#' @inheritParams geom_point
#' @param trim If \code{TRUE} (default), trim the tails of the violins
#' to the range of the data. If \code{FALSE}, don't trim the tails.
#' @param scale if "area" (default), all violins have the same area (before trimming
#' the tails). If "count", areas are scaled proportionally to the number of
#' observations. If "width", all violins have the same maximum width.
#' @export
#' @examples
#' \donttest{
#' p <- ggplot(mtcars, aes(factor(cyl), mpg))
#'
#' p + geom_violin()
#' qplot(factor(cyl), mpg, data = mtcars, geom = "violin")
#'
#' p + geom_violin() + geom_jitter(height = 0)
#' p + geom_violin() + coord_flip()
#' qplot(factor(cyl), mpg, data = mtcars, geom = "violin") +
#' coord_flip()
#'
#' # Scale maximum width proportional to sample size:
#' p + geom_violin(scale = "count")
#'
#' # Scale maximum width to 1 for all violins:
#' p + geom_violin(scale = "width")
#'
#' # Default is to trim violins to the range of the data. To disable:
#' p + geom_violin(trim = FALSE)
#'
#' # Use a smaller bandwidth for closer density fit (default is 1).
#' p + geom_violin(adjust = .5)
#'
#' # Add aesthetic mappings
#' # Note that violins are automatically dodged when any aesthetic is
#' # a factor
#' p + geom_violin(aes(fill = cyl))
#' p + geom_violin(aes(fill = factor(cyl)))
#' p + geom_violin(aes(fill = factor(vs)))
#' p + geom_violin(aes(fill = factor(am)))
#'
#' # Set aesthetics to fixed value
#' p + geom_violin(fill = "grey80", colour = "#3366FF")
#' qplot(factor(cyl), mpg, data = mtcars, geom = "violin",
#' colour = I("#3366FF"))
#'
#' # Scales vs. coordinate transforms -------
#' # Scale transformations occur before the density statistics are computed.
#' # Coordinate transformations occur afterwards. Observe the effect on the
#' # number of outliers.
#' library(plyr) # to access round_any
#' m <- ggplot(movies, aes(y = votes, x = rating,
#' group = round_any(rating, 0.5)))
#' m + geom_violin()
#' m + geom_violin() + scale_y_log10()
#' m + geom_violin() + coord_trans(y = "log10")
#' m + geom_violin() + scale_y_log10() + coord_trans(y = "log10")
#'
#' # Violin plots with continuous x:
#' # Use the group aesthetic to group observations in violins
#' qplot(year, budget, data = movies, geom = "violin")
#' qplot(year, budget, data = movies, geom = "violin",
#' group = round_any(year, 10, floor))
#' }
geom_violin <- function (mapping = NULL, data = NULL, stat = "ydensity", position = "dodge",
trim = TRUE, scale = "area", ...) {
GeomViolin$new(mapping = mapping, data = data, stat = stat,
position = position, trim = trim, scale = scale, ...)
}
GeomViolin <- proto(Geom, {
objname <- "violin"
reparameterise <- function(., df, params) {
df$width <- df$width %||%
params$width %||% (resolution(df$x, FALSE) * 0.9)
# ymin, ymax, xmin, and xmax define the bounding rectangle for each group
ddply(df, .(group), transform,
ymin = min(y),
ymax = max(y),
xmin = x - width / 2,
xmax = x + width / 2)
}
draw <- function(., data, ...) {
# Find the points for the line to go all the way around
data <- transform(data, xminv = x - violinwidth * (x-xmin),
xmaxv = x + violinwidth * (xmax-x))
# Make sure it's sorted properly to draw the outline
newdata <- rbind(arrange(transform(data, x = xminv), y),
arrange(transform(data, x = xmaxv), -y))
# Close the polygon: set first and last point the same
# Needed for coord_polar and such
newdata <- rbind(newdata, newdata[1,])
ggname(.$my_name(), GeomPolygon$draw(newdata, ...))
}
guide_geom <- function(.) "polygon"
default_stat <- function(.) StatYdensity
default_pos <- function(.) PositionDodge
default_aes <- function(.) aes(weight=1, colour="grey20", fill="white", size=0.5, alpha = NA, linetype = "solid")
required_aes <- c("x", "y")
})
ggplot2/R/geom-smooth.r 0000644 0001751 0000144 00000004672 12114160774 014504 0 ustar hornik users #' Add a smoothed conditional mean.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "smooth")}
#'
#' @inheritParams geom_point
#' @seealso The default stat for this geom is \code{\link{stat_smooth}} see
#' that documentation for more options to control the underlying statistical transformation.
#' @export
#' @examples
#' # See stat_smooth for examples of using built in model fitting
#' # if you need some more flexible, this example shows you how to
#' # plot the fits from any model of your choosing
#' qplot(wt, mpg, data=mtcars, colour=factor(cyl))
#'
#' model <- lm(mpg ~ wt + factor(cyl), data=mtcars)
#' grid <- with(mtcars, expand.grid(
#' wt = seq(min(wt), max(wt), length = 20),
#' cyl = levels(factor(cyl))
#' ))
#'
#' grid$mpg <- stats::predict(model, newdata=grid)
#'
#' qplot(wt, mpg, data=mtcars, colour=factor(cyl)) + geom_line(data=grid)
#'
#' # or with standard errors
#'
#' err <- stats::predict(model, newdata=grid, se = TRUE)
#' grid$ucl <- err$fit + 1.96 * err$se.fit
#' grid$lcl <- err$fit - 1.96 * err$se.fit
#'
#' qplot(wt, mpg, data=mtcars, colour=factor(cyl)) +
#' geom_smooth(aes(ymin = lcl, ymax = ucl), data=grid, stat="identity")
geom_smooth <- function (mapping = NULL, data = NULL, stat = "smooth", position = "identity", ...) {
GeomSmooth$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomSmooth <- proto(Geom, {
objname <- "smooth"
draw <- function(., data, scales, coordinates, ...) {
ribbon <- transform(data, colour = NA)
path <- transform(data, alpha = NA)
has_ribbon <- function(x) !is.null(data$ymax) && !is.null(data$ymin)
gList(
if (has_ribbon(data)) GeomRibbon$draw(ribbon, scales, coordinates),
GeomLine$draw(path, scales, coordinates)
)
}
guide_geom <- function(.) "smooth"
default_stat <- function(.) StatSmooth
required_aes <- c("x", "y")
default_aes <- function(.) aes(colour="#3366FF", fill="grey60", size=0.5, linetype=1, weight=1, alpha=0.4)
draw_legend <- function(., data, params, ...) {
data <- aesdefaults(data, .$default_aes(), list(...))
data$fill <- alpha(data$fill, data$alpha)
data$alpha <- 1
if (is.null(params$se) || params$se) {
gTree(children = gList(
rectGrob(gp = gpar(col = NA, fill = data$fill)),
GeomPath$draw_legend(data, ...)
))
} else {
GeomPath$draw_legend(data, ...)
}
}
})
ggplot2/R/grob-dotstack.r 0000644 0001751 0000144 00000003570 12114160774 015005 0 ustar hornik users dotstackGrob <- function (
x = unit(0.5, "npc"), # x pos of the dotstack's origin
y = unit(0.5, "npc"), # y pos of the dotstack's origin
stackaxis = "y",
dotdia = unit(1, "npc"), # Dot diameter in the non-stack axis, should be in npc
stackposition = 0, # Position of each dot in the stack, relative to origin
stackratio = 1, # Stacking height of dots (.75 means 25% dot overlap)
default.units = "npc", name = NULL, gp = gpar(), vp = NULL)
{
if (!is.unit(x))
x <- unit(x, default.units)
if (!is.unit(y))
y <- unit(y, default.units)
if (!is.unit(dotdia))
dotdia <- unit(dotdia, default.units)
if (attr(dotdia,"unit") != "npc")
warning("Unit type of dotdia should be 'npc'")
grob(x = x, y = y, stackaxis = stackaxis, dotdia = dotdia,
stackposition = stackposition, stackratio = stackratio,
name = name, gp = gp, vp = vp, cl = "dotstackGrob")
}
#' @S3method drawDetails dotstackGrob
drawDetails.dotstackGrob <- function(x, recording = TRUE) {
# Need absolute coordinates because when using npc coords with circleGrob,
# the radius is in the _smaller_ of the two axes. We need the radius
# to instead be defined in terms of the non-stack axis.
xmm <- convertX(x$x, "mm", valueOnly = TRUE)
ymm <- convertY(x$y, "mm", valueOnly = TRUE)
if(x$stackaxis == "x") {
dotdiamm <- convertY(x$dotdia, "mm", valueOnly = TRUE)
xpos <- xmm + dotdiamm * (x$stackposition * x$stackratio + (1 - x$stackratio) / 2)
ypos <- ymm
} else if(x$stackaxis == "y") {
dotdiamm <- convertX(x$dotdia, "mm", valueOnly = TRUE)
xpos <- xmm
ypos <- ymm + dotdiamm * (x$stackposition * x$stackratio + (1 - x$stackratio) / 2)
}
grid.draw(
circleGrob(x = xpos, y = ypos, r = dotdiamm / 2, default.units = "mm",
name = x$name, gp = x$gp, vp = x$vp),
)
}
ggplot2/R/geom-bar-.r 0000644 0001751 0000144 00000014365 12114161113 014000 0 ustar hornik users #' Bars, rectangles with bases on x-axis
#'
#' The bar geom is used to produce 1d area plots: bar charts for categorical
#' x, and histograms for continuous y. stat_bin explains the details of
#' these summaries in more detail. In particular, you can use the
#' \code{weight} aesthetic to create weighted histograms and barcharts where
#' the height of the bar no longer represent a count of observations, but a
#' sum over some other variable. See the examples for a practical
#' example.
#'
#' The heights of the bars commonly represent one of two things: either a
#' count of cases in each group, or the values in a column of the data frame.
#' By default, \code{geom_bar} uses \code{stat="bin"}. This makes the height
#' of each bar equal to the number of cases in each group, and it is
#' incompatible with mapping values to the \code{y} aesthetic. If you want
#' the heights of the bars to represent values in the data, use
#' \code{stat="identity"} and map a value to the \code{y} aesthetic.
#'
#' By default, multiple x's occuring in the same place will be stacked a top
#' one another by position_stack. If you want them to be dodged from
#' side-to-side, see \code{\link{position_dodge}}. Finally,
#' \code{\link{position_fill}} shows relative propotions at each x by stacking
#' the bars and then stretching or squashing to the same height.
#'
#' Sometimes, bar charts are used not as a distributional summary, but
#' instead of a dotplot. Generally, it's preferable to use a dotplot (see
#' \code{geom_point}) as it has a better data-ink ratio. However, if you do
#' want to create this type of plot, you can set y to the value you have
#' calculated, and use \code{stat='identity'}
#'
#' A bar chart maps the height of the bar to a variable, and so the base of
#' the bar must always been shown to produce a valid visual comparison.
#' Naomi Robbins has a nice
#' \href{http://www.b-eye-network.com/view/index.php?cid=2468}{article on this topic}.
#' This is the reason it doesn't make sense to use a log-scaled y axis with a bar chart
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "bar")}
#'
#' @seealso \code{\link{stat_bin}} for more details of the binning alogirithm,
#' \code{\link{position_dodge}} for creating side-by-side barcharts,
#' \code{\link{position_stack}} for more info on stacking,
#' @export
#' @inheritParams geom_point
#' @examples
#' \donttest{
#' # Generate data
#' c <- ggplot(mtcars, aes(factor(cyl)))
#'
#' # By default, uses stat="bin", which gives the count in each category
#' c + geom_bar()
#' c + geom_bar(width=.5)
#' c + geom_bar() + coord_flip()
#' c + geom_bar(fill="white", colour="darkgreen")
#'
#' # Use qplot
#' qplot(factor(cyl), data=mtcars, geom="bar")
#' qplot(factor(cyl), data=mtcars, geom="bar", fill=factor(cyl))
#'
#' # When the data contains y values in a column, use stat="identity"
#' library(plyr)
#' # Calculate the mean mpg for each level of cyl
#' mm <- ddply(mtcars, "cyl", summarise, mmpg = mean(mpg))
#' ggplot(mm, aes(x = factor(cyl), y = mmpg)) + geom_bar(stat = "identity")
#'
#' # Stacked bar charts
#' qplot(factor(cyl), data=mtcars, geom="bar", fill=factor(vs))
#' qplot(factor(cyl), data=mtcars, geom="bar", fill=factor(gear))
#'
#' # Stacked bar charts are easy in ggplot2, but not effective visually,
#' # particularly when there are many different things being stacked
#' ggplot(diamonds, aes(clarity, fill=cut)) + geom_bar()
#' ggplot(diamonds, aes(color, fill=cut)) + geom_bar() + coord_flip()
#'
#' # Faceting is a good alternative:
#' ggplot(diamonds, aes(clarity)) + geom_bar() +
#' facet_wrap(~ cut)
#' # If the x axis is ordered, using a line instead of bars is another
#' # possibility:
#' ggplot(diamonds, aes(clarity)) +
#' geom_freqpoly(aes(group = cut, colour = cut))
#'
#' # Dodged bar charts
#' ggplot(diamonds, aes(clarity, fill=cut)) + geom_bar(position="dodge")
#' # compare with
#' ggplot(diamonds, aes(cut, fill=cut)) + geom_bar() +
#' facet_grid(. ~ clarity)
#'
#' # But again, probably better to use frequency polygons instead:
#' ggplot(diamonds, aes(clarity, colour=cut)) +
#' geom_freqpoly(aes(group = cut))
#'
#' # Often we don't want the height of the bar to represent the
#' # count of observations, but the sum of some other variable.
#' # For example, the following plot shows the number of diamonds
#' # of each colour
#' qplot(color, data=diamonds, geom="bar")
#' # If, however, we want to see the total number of carats in each colour
#' # we need to weight by the carat variable
#' qplot(color, data=diamonds, geom="bar", weight=carat, ylab="carat")
#'
#' # A bar chart used to display means
#' meanprice <- tapply(diamonds$price, diamonds$cut, mean)
#' cut <- factor(levels(diamonds$cut), levels = levels(diamonds$cut))
#' qplot(cut, meanprice)
#' qplot(cut, meanprice, geom="bar", stat="identity")
#' qplot(cut, meanprice, geom="bar", stat="identity", fill = I("grey50"))
#'
#' # Another stacked bar chart example
#' k <- ggplot(mpg, aes(manufacturer, fill=class))
#' k + geom_bar()
#' # Use scales to change aesthetics defaults
#' k + geom_bar() + scale_fill_brewer()
#' k + geom_bar() + scale_fill_grey()
#'
#' # To change plot order of class varible
#' # use factor() to change order of levels
#' mpg$class <- factor(mpg$class, levels = c("midsize", "minivan",
#' "suv", "compact", "2seater", "subcompact", "pickup"))
#' m <- ggplot(mpg, aes(manufacturer, fill=class))
#' m + geom_bar()
#' }
geom_bar <- function (mapping = NULL, data = NULL, stat = "bin", position = "stack", ...) {
GeomBar$new(mapping = mapping, data = data, stat = stat, position = position, ...)
}
GeomBar <- proto(Geom, {
objname <- "bar"
default_stat <- function(.) StatBin
default_pos <- function(.) PositionStack
default_aes <- function(.) aes(colour=NA, fill="grey20", size=0.5, linetype=1, weight = 1, alpha = NA)
required_aes <- c("x")
reparameterise <- function(., df, params) {
df$width <- df$width %||%
params$width %||% (resolution(df$x, FALSE) * 0.9)
transform(df,
ymin = pmin(y, 0), ymax = pmax(y, 0),
xmin = x - width / 2, xmax = x + width / 2, width = NULL
)
}
draw_groups <- function(., data, scales, coordinates, ...) {
GeomRect$draw_groups(data, scales, coordinates, ...)
}
guide_geom <- function(.) "polygon"
})
ggplot2/NEWS 0000644 0001751 0000144 00000212622 12114161113 012341 0 ustar hornik users ggplot2 0.9.3.1
----------------------------------------------------------------
BUG FIXES
* The theme element `legend.box.just` now can be set. It was not properly
recognized before.
* `stat_density2d` previously resulted in errors when geom="polygon". This
is fixed. (Fixes #741 and #749)
* `annotation_logticks` previously drew one set of logticks for each group,
and inherited aesthetic mappings like colour. It no longer does this. (Fixes
#767)
* Plots with geom_crossbar not display correct symbol in legend. (Fixes #768)
* Grouping is no longer set automatically by `stat_summary()`, allowing for
summary paths. This reverts a change made for 0.9.3. (Fixes #732 and #739)
ggplot2 0.9.3
----------------------------------------------------------------
* The `plotmatrix` function has been deprecated and prints a warning
message.
* `stat_bin` now produces warning messages when it is used with set or
mapped y values. Previously, it was possible to use `stat_bin` and
also set/map y values; if there was one y value per group, it would
display the y values from the data, instead of the counts of cases for
each group. This usage is deprecated and will be removed in a future
version of ggplot2. (Winston Chang. Fixes #632)
* Several small changes were made so that ggplot2 is compatible with
plyr <= 1.7.1 as well as plyr > 1.7.1.
* `geom_polygon` draws multiple polygons as a single grob instead of as
separate grobs. This results in much better performance. For example,
drawing a world map is about 12 times faster. (Winston Chang. Fixes #666)
MINOR FEATURES
* A new theme `theme_minimal` has been added. This theme is based on
`theme_bw`, but does not have outlines around many of the rectangular
elements. (Baptiste Auguie)
* A new theme `theme_classic` has been added. This theme has is based on
`theme_bw`. It has x and y axis lines, but no box around the plotting area
and no grid lines. (Thanks to David Kahle)
* `geom_segment` allows setting `lineend`. (Jean-Olivier Irisson)
* `ggsave` raises an error when making images larger than 50x50 inches.
This prevents accidentally creating extremely large bitmap images that
hang R and eat up memory. (Winston Chang. Fixes #517)
* `train_cartesian` and `train_trans` are no longer memoized. Previously
the results of these functions were saved and so they would not
respond changes in the operating environment, such as a change in
locale. (Winston Chang. Fixes #592)
* In `stat_ydensity` and `geom_violin`, the `scale` argument now accepts
the value "width", for equal widths. Additionally `scale="equal"` has
been deprecated, in favor of "area". (Jean-Olivier Irisson)
* `stat_quantile` now supports `rqss`.
* `scale_size_area` has been added as a replacement for `scale_area`. This
makes the naming more consistent. The new scale also by default makes the
area of points proportional to the value, which is different from what
`scale_area` does. (Fixes #635)
* Functions now have gradual deprecation behavior with the `gg_dep` function.
* Scales for required but missing aesthetics (x and y) are now automatically
added. (Fixes #676)
* `geom_crossbar` previous raised a warning when notches were used and the
notches went outside the hinges. This has been changed to a message.
BUG FIXES
* With `geom_segment`, when a variable mapped to `linetype` had an NA
value, it would raise an error. This is now fixed. (Winston Chang.
Fixes #623)
* When using `coord_map` with some projections, latitude lines wrapped
around the globe and added extra lines. (Winston Chang. Fixes #562)
* `stat_summary` now calculates a unique value at each x. (Winston
Chang. Fixes #622)
* Colorbar guides now supports language objects returned from functions
like `math_format()`, and will render them as expressions. (Kohske
Takahashi)
* When using `coord_polar`, NA or NaN values caused errors. They are now
ignored instead. (Winston Chang)
* Text theme elements used in `guide_legend`, such as `label.theme`, caused
confusing errors when the angle wasn't set. Now it produces a more
informative error message.
* Theme elements now have their subclass listed first, before the `element`
class. (Thanks to Jeffrey Arnold)
* Previously when free scales were used with non-cartesian coords, they just
wouldn't work. Now ggplot throws an error with an informative message.
(Fixes #673)
* `geom_dotplot` previously worked with `position="dodge", but did not work
when using `position=position_dodge()`. It now works with both. (Fixes
#709)
* For linetype scales, NA values previously caused errors. Now `na.value`
for linetype scales defaults to "blank". (Fixes #711)
ggplot2 0.9.2.1
----------------------------------------------------------------
BUG FIXES
* find_global now searches for objects in the namespace environment
instead of the package environment. This fixes problems when ggplot2
is imported to another package but not attached.
ggplot2 0.9.2
----------------------------------------------------------------
THEME SYSTEM
* The theme system has been completely rewritten. (Winston Chang)
* The functions `theme_text`, `theme_line`, and so on have been renamed to
`element_text`, `element_line`, and so on.
* The `opts()` function has been renamed to `theme()`.
* To set the plot title, use `labs(title = "...")` or `ggtitle("...")
instead of `opts(title = "...")`.
* Elements are now just lists of properties, instead of functions that
return grobs.
* Theme elements now can inherit properties. For example, `axis.title.x`
inherits properties from `axis.title`, which in turn inherits from
`text`. The inheritance tree is stored in ggplot2::.element_tree.
* Theme objects can now be added to each other with `+`, without a ggplot
object. There is also a new `%replace%` operator for adding theme
objects together.
* Vertical and horizontal grid lines can now be controlled independently,
with `axis.grid.major.x`, `axis.grid.major.y` (and the same for minor);
`axis.ticks.x` and `axis.ticks.y`; and `axis.line.x` and `axis.line.y`.
* The `size` property of theme elements can be defined relative to the
parent objects, using the `rel()` function.
MINOR FEATURES
* ggplot2 now uses the external gtable package instead of internal gtable
functions.
* The condition that set parameters (e.g. `colour = "red"`) could only be of
length one has been relaxed - they may now be of length one, or exactly the
same length as the data. Recycling is not done because it makes it harder to
spot problems. This makes `annotate` considerably more flexible. (Fixes
#489)
* `stat_contour` is now somewhat faster
* new stat class `stat_ecdf` that shows empirical cumulative distribution
function. (Kohske Takahashi)
* Dependency on `gpclib` removed, and `fortify.SpatialPolygonsDataFrame` will
now use `rgeos` if available - this is particularly useful if you're not
able to use the non-free `gpclib`.
* `ggsave` now supports emf output files.
* all "template" plots (`plotmatrix`, `ggorder` etc) have been deprecated and
will be removed in a future version. These plots are poorly tested and
poorly supported and really belong in a separate package.
* The default guide for continuous color/fill scale is now colourbar.
(Kohske Takahashi. Fixes #555)
* The arrowhead of geom-path and geom-segment with `arrow = TRUE` is
now filled with the same colour as the path.
* The algorithm for calculating breaks locations has been changed from
`pretty_breaks()` to `extended_breaks()` from the 'labeling' package
by Justin Talbot. (Winston Chang. Fixes #580)
* `scale_type`, the function used to pick which type of scale should be
used for a given type of input variable is now an S3 generic. That
means that if you want to add a new default type of scale you can
provide a method - it should return a string giving the name of the
scale to use (e.g. "continuous", "discrete", "date")
* When there are multiple guides (legends), the order that they are
displayed can now be controlled manually. (Kohske Takahashi. Fixes
#470)
* When a scale for a given aesthetic is added to a plot more than once,
display a message indicating that the first scale will be replaced.
(Winston Chang. Fixes #518)
DOCUMENTATION
* All geoms and stats now document their aesthetics. (Thanks to joranE.
Fixes #447)
BUG FIXES
* `scale_x_continuous` now respects `na.value` (Fixes #522)
* `geom_map` now correctly uses set aesthetics (e.g. `colour = "green"`)
* Setting breaks outside the limits of the x or y axis no longer causes
errors. (Kohske Takahashi. Fixes #552)
* `facet_locate` no longer evaluates unneeded expressions. (Winston
Chang. Fixes #565)
* `annotation_map` now gets group id from munched data. (Winston Chang.
Fixes #568)
* `geom_raster` now supports alpha. (Kohske Takahashi. Fixes #596)
* Both axis lines are now drawn above the plotting area panel.
(Winston Chang. Fixes #585)
* The jitter resolution is now correctly calculated when the data
does _not_ include zero. (Thanks to Karl Ove Hufthammer. Fixes #572)
* Legend icons for `geom_boxplot` now display linetype. (Kohske
Takahashi. Fixes #608)
* Facets now appear in the correct order when layers with different
factor levels are added. (Winston Chang. Fixes #543)
* Distances in polar coordinates are calculated along spiral arcs,
instead of straight-line distance. (Winston Chang. Fixes #471)
* `fortify.SpatialPolygonsDataFrame` now uses the correct ordering.
(Charlotte Wickham. Fixes #434)
* `stat_vline` and `stat_hline` no longer throw errors when
`xintercept` and `yintercept` are passed to them. (Winston Chang.
Fixes #624)
ggplot2 0.9.1
----------------------------------------------------------------
MINOR FEATURES
* `ggstructure` and `ggorder`, which call `ggpcp`, no longer have a
`scale` argument since `ggpcp` does not have one.
* built in datasets have been checked to make sure they use characters,
factors and ordered factors appropriately
* `geom_raster` and `annotation_raster` gain new `interpolate` argument for
controlling whether or not rasters are interpolated
* Added `plot` as an alias for `print` for ggplot objects.
* Visual tests have been moved to /visual_test and modified to work with the
vtest package. (Thanks to Winston Chang)
* `geom_dotplot`: now supports stacking. It uses `stackgroups = TRUE` instead
of the usual position="stack", for technical reasons. It also will stack in
the x direction when binning along the y axis. (Thanks to Winston Chang)
* `geom_rug` now allows control over which sides to put the rug lines, with
the `sides` argument. (Thanks to Winston Chang)
* `annotation_logticks`: a new geom that adds tick marks on the inside of the
plotting rectangle that have diminishing spacing for log-10 axes. (Thanks
to Winston Chang)
* Coordinate expansion is now handled by an interaction of the scale and
coord, rather than by the scale only. Also, the `wise` argument is no
longer needed. (Thanks to Winston Chang and Kohske Takahashi)
BUG FIXES
* `facet_grid` no longer drops duplicate cases (Fixes #443)
* `munch_range` properly reports the x and y range. (Thanks to Winston Chang)
* `stat_bin2d` handles data with NA in the position variables. Error was
triggered when scale was limited to a range smaller than the range of
the data. (Bug reported by Tao Gao; diagnosed and fixed by Brian Diggs)
* `scale_*_identity` will now produce a legend when `guide = "legend"` and no
breaks or labels are supplied (Fixes #453)
* `geom_map` now works with `coord_map` (Fixes #480)
* discrete scales now accept named vectors of labels again (Fixes #427)
* `geom_raster` works better with categorical input (Fixes #463)
* `qplot` no longer uses non-standard evaluation for geom/stat arguments - it
doesn't seem to be needed and was causing problems when qplot was used in
special environments (e.g. in knitr) (Fixes #377)
* `coord_train.polar` and `coord_train.trans` remove NAs from breaks.
(Thanks to Winston Chang. Fixes #422)
* Theta breaks with `coord_polar` have equal angular spacing. (Thanks to
Winston Chang and Kohske Takahashi. Fixes #288)
* Empty data frames are now handled correctly: layers with empty data are
dropped silently, instead of inheriting data from the plot. (Thanks to
Winston Chang. Fixes #31, #332, #506 and #507)
* The alpha value of set colours is now preserved by default. To return to the
old behaviour, set `alpha = 1`. (Fixes #475)
* `scale_*_manual` will throw an error if you have too few values. (Fixes
#512)
* `facet_wrap` gets the `as.table` argument back. (Fixes #497)
* `resolution` now returns 1 when range is zero. (Fixes #526)
* Titles are displayed above legend when legend is on top. (Thanks to
Kohske Takahashi. Fixes #432)
* Specifying breaks outside coord limits works. (Thanks to Kohske Takahashi.
Fixes #430)
* `renames_aes` now uses exact matching instead of partial matching. (Thanks
to Winston Chang. Fixes #529)
* `labs()` now works with American spellings. (Thanks to Winston Chang.
Fixes #521)
* `stat_density2d` sets the limits for `kde2d` from the limits of the x and
y scales. (Thanks to Winston Chang)
ggplot2 0.9.0
----------------------------------------------------------------
NEW FEATURES
* `annotation_custom`: a new geom intended for use as static annnotations that
are the same in every panel. Can be used to add inset plots, tables, and
other grid-based decorations inside the plot area (Contributed by Baptiste
Auguié).
* `geom_map`: a new special case of `geom_polygon` useful when you are drawing
maps, particularly choropleth maps. It is matched with `annotation_map`, an
even faster special case when you want the same map drawn in each panel.
* `geom_raster` is a special case of `geom_tile` for equally sized rectangular
tiles. It uses the raster functionality of R graphics devices for massively
increased speed and much decreased file sizes. It is matched with
`annotation_raster`, an even faster special case, for when you want to draw
the same raster in each panel.
* `geom_violin`: an implementation of violin plots, which are a way of
visualizing kernel density estimates. (Thanks to Winston Chang)
* `geom_dotplot`: dot plots, as described in Wilkinson (1999). To bin the
data, it uses `stat_bindot` to bin the data, which has two methods: histodot
and dot-density. Histodot binning uses fixed-width bins just like
`stat_bin`, while dot-density binning uses variable-width bins. A new grob,
`grob_dotstack` is used to render the dots. (Thanks to Winston Chang)
* New fortify methods have been added for objects produced by the `multcomp`
package.
* `stat_summary2d` and `stat_summary_hex`. These are work like `stat_bin2d`
and stat_binhex but allow any summarisation function (instead of just
count). They are 2d analogs of `stat_summary`
* `facet_grid`: The space argument now supports `free_x` and `free_y` next to
`free` and `fixed, this allows the user to adjust the spatial scaling of the
facets in either the x or y direction. This is especially useful when the
scales are very different. In this case space = `free` could make some
facets very small. (Thanks to Willem Ligtenberg)
DOCUMENTATION
* Thorough clean up and checking, including documenting all arguments, adding
systematic cross-references, and adding commonly requested examples. Thanks
to Jake Russ and Dennis Murphy for the help.
* Complete series of aesthetics pages (grouped subsets of aesthetics) with
examples of how to use the major ones, see e.g. `?fill`, `?shape`, `?x`,
* Added a complete list of theme opts with usage examples in `?opts`
* Added "translate" pages to demonstrate usage between qplot and ggplot, GPL,
base and lattice graphics: `?translate_qplot_base`, `?translate_qplot_gpl`,
`?translate_qplot_lattice`, `?translate_qplot_ggplot`,
SCALES
* Scales have been rewritten to use the new `scales` package, which does a
much better job at defining what a scale is and making it easier for you to
create your own scales. Scales should now behave much more consistently, and
it should be easier for me to add new features in the future.
* `breaks` parameter can now be a function, which will be passed the scale
limits and expected to return a character vector of breaks
* `labels` parameter can now be a function - this replaces the previous
formatter function that only some scales possessed, and the `major` argument
to the data time scales. This function should take a vector of breaks as
input, and return a character vector or list of expressions as output. See
`comma_format`, `dollar_format`, `percent_format`, `scientific_format`,
`parse_format` and `math_format` for examples
* Transformations are now provided by the scales package - see `?trans_new`
for list of available transformations, and how to create your own. The
transformations in this package should do a better job at computing default
breaks.
* Transformations for continuous scales are now detected automatically when
the default scales are added. This ensures that dates and date times will
display correctly when used for any aesthetic - previously they only worked
with position scales. The system is now also easier to extend to new types
of continuous data that you might want to plot. (Fixes #48)
* All scales now accept a `na.value` parameter which provides an aesthetic
value to be used for `NA` values in the data. Colour/fill scales default to
grey, which should stand out as different from non-missing values.
* The new `oob` (out of bounds) parameter controls how scales deals with
values outside the limits. The default action is `censor` - see `clip` for
another option.
* Only `scale_x_log10`, `scale_x_sqrt` and `scale_x_reverse` provided as
convenience functions for x and y scales. Use e.g. `scale_x_continuous(trans
= "log")` to access others
* `set_default_scale` has been removed. If you want to change the default
scale for an aesthetic, just create a function called
`scale_aesthetic_continuous` or `scale_aesthetic_discrete` that returns the
scale that you want. For example:
p <- qplot(mpg, wt, data = mtcars, colour = factor(cyl))
p
scale_colour_discrete <- scale_colour_brewer
p
* Scales now automatically shrink to what is actually displayed on the plot,
not the underlying data used for statistical transformation. If you want the
old behaviour, supply `shrink = FALSE` to the facetting specification.
(Fixes #125)
* `scale_colour_gradient` and `scale_fill_gradient` now use a colour scheme
with constant hue but varying chroma and luminance. This is better because
it creates a natural ordering inline with the order of the colour values.
FACETS
* Converted from proto to S3 objects, and class methods (somewhat) documented
in `facet.r`. This should make it easier to develop new types of facetting
specifications.
* The new `facet_null` specification is applied in the default case of no
faceting. This special case is implemented more efficiently and results in
substantial performance improvements for non-facetted plots.
* Facetting variables will no longer interfere with aesthetic mappings -
`facet_wrap(~ colour)` will no longer affect the colour of points.
DEVELOPMENT
* ggplot2 has moved away from the two (!!) homegrown documentation systems
that it previously relied on, and now uses roxygen extensively. The current
downside is that this means that ggplot2 website can no longer be updated,
but I hope work with the `helpr` package will resolve that shortly.
* ggplot2 now uses a `NAMESPACE`, and only exports functions that should be
user visible - this should make it play considerably more nicely with other
packages in the R ecosystem. Note that this means you now need to explicitly
load `plyr` (and other packages) if you are using them elsewhere in your
code.
* ggplot2 now has a start on a set of automated tests. As this test suite
expands it will help me ensure that bugs stay fixed, and that old bugs don't
come back in new versions. A test suite also gives me more confidence when
I'm modifying code, which should help with general code quality.
COORDS
* Converted from proto to S3 objects, and class methods (somewhat) documented
in `coord.r`. This should make it easier to develop new types of coordinate
systems.
* Added a new method `coord_range` for finding the x and y range even after
coordinates have been transformed to other names (eg., theta and r). (Thanks
to Winston Chang)
RENDERING
* When printing a ggplot2 object, the rendered plot information is returned
invisibly. You can capture this with (e.g.) `x <- print(qplot(mpg, wt, data
= mtcars))` and in the future will be able to use it to get information
about the plot computations, such as the range of all the scales, and the
exact data that is plotted.
* Drawing a plot takes place in three documented steps: `ggplot_build` which
creates a list of data frames ready for rendering builds, `ggplot_gtable`
which creates a `gtable` of grobs, and `grid.draw` which renders the grobs
on screen. Each of these returns a data structure which should be useful for
understanding and modifying the rendered plot. This is still a work in
progress, so please ask questions if anything is confusing.
* The `drop` and `keep` parameters to `ggsave` and `print.ggplot` have been
dropped, as the data structure returned by `ggplot_gtable` is sufficiently
rich enough to remove the need for them.
* Axis labels are now centred underneath the panels (not the whole plot), and
stick close to the panels regardless of the aspect ratio.
GUIDES
* Guides (particularly legends) have been rewritten by Kohske Takahashi to
provide considerably more layout flexibility.
* `guide_legend` now supports multi-row/column legend and reversed order,
gives more flexible positioning of title and label, and can override
aesthetics settings. This is useful, for example, when alpha value in a
panel is very low but you want to show vivid legend.
* `guide_colorbar` is a guide specially for continuous colour scales as
produced by colour and fill scales.
MINOR CHANGES
* `geom_text` now supports `fontfamily`, `fontface`, and `lineheight`
aesthetics for finer control over text display. (Thanks to Kohske Takahashi
for the patch. Fixes #60)
* `collide`, which powers `position_dodge` and `position_stack`, now does not
error on single x values (Thanks to Brian Diggs for a fix. #157)
* `...` in `ggplot` now passed on to `fortify` method when used with an object
other than a data frame
* `geom_boxplot`: outlier colour and shape now default to values set by the
aesthetic mapping (thanks to suggestion by Ben Bolker), the width of the
median line is now `fatten` times the width of the other lines (thanks to
suggestion by Di Cook), and the line type can now be set. Notched box
plots are now supported by setting `notch = TRUE` (thanks to Winston Chang
for the patch).
* `ggsave` can work with cm and mm `units` (Thanks to patch from Jean-Olivier
Irisson)
* `scale_shape` finally returns an error when you try and use it with a
continuous variable
* `stat_contour` no longer errors if all breaks outside z range (fixes #195).
* `geom_text` remove rows with missing values with warning (fixes #191)
* New generic function `autoplot` for the creation of complete plots
specific to a given data structure. Default implementation throws
an error. It is designed to have implementations provided by other
packages. (Thanks to suggestion by Brian Diggs)
* `ggpcp` loses the `scale` argument because it relied on reshape(1) code
* `map_data` passes `...` on to `maps::map` (Fixes #223)
* `coord_fixed` accepts `xlim` and `ylim` parameters to zoom in on x and y
scales (Fixes #91)
* ggplot2 will occasionally display a useful hint or tip on startup. Use
`suppressPackageStartupMessages` to eliminate
* `stat_binhex` uses correct bin width for computing y axis bounds. (Fixes
#299, thanks to Dave Henderson for bug report and fix.)
* `stat_smooth` now adjusts confidence intervals from `loess` using a
t-based approximation
* `stat_smooth` reports what method is used when method is "auto". It also
picks the method based on the size of the largest group, not individually by
group. (Thanks to Winston Chang)
* `stat_bin` and `geom_histogram` now use right-open, left-closed intervals by
default. Use `right = TRUE` to return to previous behaviour.
* `geom_vline`, `geom_hline`, and `geom_abline` now work with non-Cartesian
coordinate systems. (Thanks to Winston Chang)
ggplot2 0.8.9
----------------------------------------------------------------
A big thanks to Koshke Takahashi, who supplied the majority of improvements
in this release!
GUIDE IMPROVEMENTS
* key size: can specify width and height separately
* axis: can partially handle text rotation (issue #149)
* legend: now can specify the direction of element by opts(legend.direction =
"vertical") or opts(legend.direction = "horizontal"), and legend box is
center aligned if horizontal
* legend: now can override the alignment of legend box by
opts(legend.box = "vertical") or opts(legend.box = "horizontal")
* legend: now can override legend title alignment with opts(legend.title.align
= 0) or opts(legend.title.align = 1)
* legend: can override legend text alignment with opts(legend.text.align = 0)
or opts(legend.text.align = 1)
BUG FIXES
* theme_*: can specify font-family for all text elements other than geom_text
* facet_grid: fixed hirozontal spacing when nrow of horizontal strip >= 2
* facet_grid: now can manually specify the relative size of each row and column
* is.zero: now correctly works
* +: adding NULL to a plot returns the plot (idempotent under addition)
(thanks to suggestion by Matthew O'Meara)
* +: meaningful error message if + doesn't know how to deal with an object
type
* coord_cartesian and coord_flip: now can wisely zoom when wise = TRUE
* coord_polar: fix point division bugs
* facet_grid: now labels in facet_grid are correctly aligned when the number
of factors is more then one (fixes #87 and #65)
* geom_hex: now correctly applies alpha to fill colour not outline colour
(thanks to bug report from Ian Fellows)
* geom_polygon: specifying linetype now works (thanks to fix from Kohske
Takahashi)
* hcl: can now set c and l, and preserves names (thanks to suggestion by
Richard Cotton)
* mean_se: a new summary function to work with stat_summary that calculates
mean and one standard error on either side (thanks to contribution from
Kohske Takahashi)
* pos_stack: now works with NAs in x
* scale_alpha: setting limits to a range inside the data now works (thanks to
report by Dr Proteome)
* scale_colour_continuous: works correctly with single continuous value (fixes
#73)
* scale_identity: now show legends (fix #119)
* stat_function: now works without y values
* stat_smooth: draw line if only 2 unique x values, not three as previously
* guides: fixed #126
* stat_smooth: once again works if n > 1000 and SE = F (thanks to bug report
from Theiry Onkelinx and fix from Kohske Takahashi)
* stat_smooth: works with locfit (fix #129)
* theme_text handles alignment better when angle = 90
ggplot2 0.8.8
----------------------------------------------------------------
Bug fixes:
* coord_equal finally works as expected (thanks to continued prompting from
Jean-Olivier Irisson)
* coord_equal renamed to coord_fixed to better represent capabilities
* coord_polar and coord_polar: new munching system that uses distances (as
defined by the coordinate system) to figure out how many pieces each segment
should be broken in to (thanks to prompting from Jean-Olivier Irisson)
* fix ordering bug in facet_wrap (thanks to bug report by Frank Davenport)
* geom_errorh correctly responds to height parameter outside of aes
* geom_hline and geom_vline will not impact legend when used for fixed
intercepts
* geom_hline/geom_vline: intercept values not set quite correctly which
caused a problem in conjunction with transformed scales (reported by Seth
Finnegan)
* geom_line: can now stack lines again with position = "stack" (fixes #74)
* geom_segment: arrows now preserved in non-Cartesian coordinate system (fixes
#117)
* geom_smooth now deals with missing values in the same way as geom_line
(thanks to patch from Karsten Loesing)
* guides: check all axis labels for expressions (reported by Benji Oswald)
* guides: extra 0.5 line margin around legend (fixes #71)
* guides: non-left legend positions now work once more (thanks to patch from
Karsten Loesing)
* label_bquote works with more expressions (factors now cast to characters,
thanks to Baptiste Auguie for bug report)
* scale_color: add missing US spellings
* stat: panels with no non-missing values trigged errors with some statistics.
(reported by Giovanni Dall'Olio)
* stat: statistics now also respect layer parameter inherit.aes (thanks to bug
report by Lorenzo Isella and investigation by Brian Diggs)
* stat_bin no longer drops 0-count bins by default
* stat_bin: fix small bug when dealing with single bin with NA position
(reported by John Rauser)
* stat_binhex: uses range of data from scales when computing binwidth so hexes
are the same size in all facets (thanks to Nicholas Lewin-Koh for the bug
report)
* stat_qq has new dparam parameter for specifying distribution parameters
(thanks to Yunfeng Zhang for the bug report)
* stat_smooth now uses built-in confidence interval (with small sample
correction) for linear models (thanks to suggestion by Ian Fellows)
* stat_spoke: correctly calculate stat_spoke (cos and sin were flipped, thanks
to Jean-Olivier Irisson for bug report and fix)
ggplot2 0.8.7
----------------------------------------------------------------
* coord_map gains xlim and ylim arguments to control region of projection
* corrected label generation for computed aesthetics (..x..) and special
names (`x x`)
* fullseq: now always returns vector of length two, even when range is 0
* geom_point legend takes more care to ensure that fill colours will be shown
* legend: fixed scale merging bug when labels were set manually
* scale_area: gains a legend argument like all other scales
* scale_colour_brewer: gains na.colour argument to set colour of missing
values
* stat_bin2d: fix typo in breaks calculation
* stat_bin: deals with floating point rounding issues using the same
algorithm as base::hist
* stat_density2d: fixed bug when contour = FALSE (Thanks to Takahashi Kohske)
ggplot2 0.8.6
----------------------------------------------------------------
NEW FEATURES
* trans_log1p: new log + 1 transformer contributed by Jean-Olivier Irisson
BUG FIXES
* aesthetics: fixed bug when overriding aesthetics with NULL
* annotate: adds layers with legend = FALSE
* coord_equal: correctly place tick marks (Fixes #61)
* documentation: usage statements should now be spread over multiple lines
* fortify.SpatialPolygonsDataFrame: fixed bug when region variable had missing values
* legend: don't try and display legend when unnecessary scale added
* legend: text labels now correctly left-aligned when non-numeric
* order aesthetic now correctly affects position adjustments (Fixes #70)
* qplot loads facetting variables from global environment more correctly
* scale_date and scale_date_time now work with infinite positions
* scale_date and scale_date_time now take expand argument
* scales were not getting automatically added in many situations (Fixes #69)
* scale_manual was not returning labels in the correct format and so legends
were not getting merged correctly
* stat_contour: fix error if x or y coordinates were negative
* stat_bin: now copes with bars of zero height (Fixes #72)
* stat_qq: always use sorted data (rather than interpolated quantiles) on
sample axis. This makes it behave more like qqnorm
* stat_quantile: correctly group results
* xlim now works with datetimes
* all plyr functions prefixed with their namespace to avoid clashes with other
packages (thanks to Steve Lianoglou)
ggplot2 0.8.5
----------------------------------------------------------------
NEW FEATURES
* geom_text gains parse argument which makes it possible to display
expressions. (Implements #50)
* all scales now have legend parameter, which defaults to TRUE. Setting to
false will prevent that scale from contributing to the legend (Implements
#27)
* default axis labels and legend titles are now stored in the options, instead
of in each scale. This fixes a long standing bug where it was not easy to
set the label for computed variable, such as the y axis on a histogram.
Additionally, it means default scales are only added to the plot until just
prior to plotting, instead of the previous behaviour where scales where
added as layers were added - this could cause problems if you later modified
the underlying data. (Implements #28)
* coord_equal: when ratio = NULL (the default), it will adjust the aspect
ratio of the plot, rather than trying to extend the shortest axis.
* x and y positions can be set to Inf or -Inf to refer to the top/right and
bottom/left extents of the panel. (Implements #18)
* expand_limits(): a new function to make it easy to force the inclusion of
any set of values in the limits of any aesthetic.
NEW FEATURES (MINOR)
* aesthetics: when _setting_ an aesthetic, you may only set it to a single
value. This was always a good idea, but now it is enforced with an
informative error message.
* stat_contour bump up default number of contours
* stat_density2d: make number of grid points used for density estimation
user controllable (implements #9)
* geom_bin now allows you to set whether bins used intervals of the form
(a, b] or [a, b) with the "right" parameter (implements #20)
* geom_path: linejoin, lineend and linemitre are now user controllable
(implements #24)
* scales: all scales check that breaks are supplied if labels are, and
that breaks and labels are the same length (implements #40)
* scales: if breaks are a named vector, the names will be used as labels
(thanks to suggestion by David Kahle)
* scale_colour_gradient, scale_colour_gradient2 & scale_colour_gradientn now
have formatter argument to match scale_continuous
* updated citation to refer to the ggplot2 book
BUG FIXES
* coord_cartesian now correctly sets limits when one or both of the position
scales are non-linear. (fixes #17)
* coord_equal: now works with non-linear scales (fixes #13)
* coord_map sets aspect ratio correctly (fixes #4)
* coord_polar correctly combines labels on end of axis if expressions
(fixes #39)
* coord_trans now respects scale expand parameter (expansion occurs after
transformation) (fixes #14)
* facet_grid with scales = "free" and space = "free" now calculates space
correctly if the range of the scale is < 1 (fixes #1)
* facet_grid works once more when facetting with multiple variables in one
direction (fixes #11)
* facet_wrap now sets aspect ratio correctly
* facet_wrap now maintains original order of data
* geom_hline and geom_vline now work with coord_flip (fixes #30)
* geom_path drops missing values at start and end of each line (fixes #41)
* scale_shape_discrete, scale_size_continuous, scale_alpha and
scale_linetype_discrete added to scales to match naming convention of all
other scales (fixes #47)
* legends now correctly calculate label widths (fixes #38)
* legends will only merge if both the title and all labels are the same.
(fixes #16)
* legends: fix for bug #19: Legend with three constraints doesn't work
* stat_contour & stat_density2d: fix grouping bugs (issue #7)
* xlim, ylim: fix bug when setting limits of discrete scales
ggplot2 0.8.4
----------------------------------------------------------------
* aes and aes_string both convert prefixes to full names
* aesthetics: corrected list of aesthetics to include american spelling of
colour as well as base R abbreviations
* aesthetics: fix bug in detecting which aesthetics are calculated
* aes_string treats NULL as "NULL"
* annotate now works with missing x and y (e.g. for geom_rect)
* continuous scale limits now automatically sorted
* coord_polar: fix bug if breaks not all inside limits
* facet_wrap: can now specify both ncol and nrow without getting an error
* facet_wrap: now works with statistics that produce both x and y values (e.g.
stat_qq)
* fullseq now adds additional break on bottom if necessary, so that the
include.lowest argument in cut never comes into play (this the source of a
potential bug in histograms)
* geom_boxplot: alpha now affects fill colour of boxes only
* geom_path correctly switches to segments if varying alpha used (thanks to
Karl Ove Hufthammer for the report and Baptiste Auguie for the fix)
* geom_point: the alpha aesthetic now also affects the fill.
* geom_ribbon always sorts input to avoid problems with certain pathological
inputs
* geom_smooth was incorrectly applying alpha to line colour in the legend
* nullGrob renamed to zeroGrob to avoid name conflict with grid
* position_collide now works with missing values
* position_stack: fixed bug in detection of overlap for negative values
* scale_discrete_position now uses drop argument to force dropping of unused
levels
* scale_gradient, scale_gradient2 and scale_gradientn now uses label
parameters, if supplied
* scale_x_inverse, scale_y_inverse now actually work, and added recip as alias
* stat_qq now correctly groups results
* stat_smooth will not try and fit a line to 2 or fewer points (previously
didn't try for only 1 point)
* stat_spoke now works with reversed scales
* grouping: now consistent between different geoms (Issue #33)
ggplot2 0.8.3
----------------------------------------------------------------
New features
* alpha: new aesthetic, with scale alpha. Where a geom has both fill and colour, alpha affects the fill.
* annotate: new annotate function to make it easier to add annotations to plots
* facet_grid now takes strip label function from parameter labeller, not theme setting
* facet_grid: gains as.table argument to control direction of horizontal facets
* fortify: full set of methods for turning data from the sp package into data frames that can be plotted with ggplot2
* geom_errorbarh: new geom for horizontal error bars
* labels_parsed and labels_bquote functions to make it easier to display expressions on facet labels
* scale_manual now supports breaks and limits
* subset: experimental new feature. Layers now have a subset argument, which takes subsets formatted like .(var1 < 5, var2 == 3) etc.
* xlim and ylim now work recognise Date and POSIXct classes to create date and date_time scales respectively
Dealing with missing values
* facet_wrap: add drop argument to control whether or not panels for non-existent combinations of facetting variables should be dropped or not. Defaults to TRUE
* scale_discrete: empty factor levels will be preserved, unless drop = TRUE
Bug fixes
* added presidents dataset from book to package
* American spelling of color accepted in as geom parameter, and all colour
scales have alias spelled color (e.g. scale_color_hue)
* facet_wrap: contents guaranteed to be clipped to panel
* facet_wrap: corrected labelling when facetting by multiple variables (thank
to Charlotte Wickham for a clear test case)
* geom_histogram now works with negative weights (provided position =
"identity"). This is useful for creating back to back histograms.
* geom_step: improve legend
* geom_text: better legend
* geom_vline, geom_hline, geom_abline: should work in yet more situations
* resolution: fixed bug in computation of resolution that lead to (e.g.)
incorrect boxplot widths when there was only a single x value in a group.
* position_stack: fixed bug in detection of overlap for very large bins
* scale_discrete: factor levels no longer mistakenly reordered
* scale_hue: now spans full range of hue if it less than 360 degrees
* scale_hue: rotated default hue range by 15 degrees to avoid unfortunate
red-green contrast in two colour case
* show now works with ggplot objects
* stat_sum: fixed bug which resulted in dropped aesthetics
* stat_summary: now warns when dropping records with missing values
* stat_summary: should be a little faster
* stat_summary: correctly passes ... arguments on fun.data
* theme_bw: corrected justification of axis.text.y
* trans: bug fixes to logistic transformation
* order aesthetic should work again
ggplot2 0.8.2
----------------------------------------------------------------
New features
* borders, fortify.map and map_data to make it easier to draw map borders and
choropleth maps
* cut_interval and cut_number utility functions to discretise continuous
variables
* stat_summary has reparameterised to make it easier to specify different
summary functions. It now has four parameters: fun.y, fun.ymin and
fun.ymax; and fun.data. See the documentation for stat_summary for more
details
Minor improvements
* ggfluctuation: default to aspect ratio that produces squares
* ggsave: filename now first parameter, not second
* qplot: if sample aesthetic is used, stat automatically set to qq
* scale_datetime: improved breaks calculation
* scale_gradient: better default colour scheme from red to blue (thanks to
Charlotte Wickham for providing the Munsell colours)
* scale_size and scale_area: increased default size range
* stats: all give useful error message if missing a required aesthetic
* theme_set warns if missing needed theme elements
* theme_text: now possible to right and left align text with hjust=0 and hjust=1 respectively
Bug fixes
* be explicit about is.discrete to avoid clash with Hmisc
* facet_wrap: work around R bug so no longer crashers when ncol = 1
* geom_errorbar now works correctly with dashed lines
* geom_path will now silently ignore lines with less than 2 points (instead of
throwing a mysterious error as before)
* geom_path now responds to the size aesthetic once more
* geom_polygon etc now correctly displays linetype on legends
* geom_step now works with multiple groups
* geom_vline and geom_hline: fix bug when mapping intercept to variable in
data frame
* ggsave: path parameter correctly sets path
* guides: fix broken legend from default stat aesthetics (e.g. for stat_sum)
* scale_manual now works better with missing values
* scale_manual: labels now correctly sets legend labels.
* stat_density_2d: no longer passes unnecessary parameters to kde2d causing an
error message (seen when setting aesthetics with qplot)
* stat_pointrange: better relationship between point and line widths
* stat_sum now correctly preserves other aesthetic columns (should be a bit faster too)
ggplot2 0.8.1
----------------------------------------------------------------
New features
* new labs, xlab & ylab functions for easily modifying axis labels and legend titles
* qplot now guesses what geom you want based on the position aesthetics that you provide:
* both x & y: scatterplot
* only x: histogram
* only y: scatterplot of seq_along(y) vs y
* scale_datetime: a first attempt at a scale for date time objects of class POSIXt
Aesthetic improvements
* legends should now work in cases where you have multiple layers the use the
same geom and have different aesthetic mappings
* theme: new theme setting legend.key.size determines size of keys in legend
* theme: new theme setting plot.margins to control the plot margins
* tweaks to plot and legend layout
Other minor improvements
* geom_point warns if missing values present in data and not displayed on plot
* geom_smooth gives a more accurate warning when you have incorrectly specified the grouping
* geom_smooth will switch to an alternative smoothing method (mgcv::gam(y ~
s(x, bs = "cr"))), when there are more than 1000 observations
* layers gain a legend argument, which allow you to force the layer either
into (TRUE) or out of (FALSE) the legend
Bug fixes
* coord_equal now calculates scales correctly again
* coord_flip: flips axes labels again too
* coord_trans fix bug where transformation incorrect
* facet_grid: fix bug where tick labels where being produced outside the range of the axes
* facet_wrap: fixed bug with ncol = 1 or nrow = 1
* facet_wrap: labels correctly clipped to axis ranges
* facet_wrap: labels will match panels even when factor levels are not in alphabetical order
* facet_wrap: now works when a layer doesn't contain every level of the faceting variables
* geom_abline should now work in a wider variety of situations
* geom_smooth now gives correct asymmetric standard errors with generalised
linear models (thanks to Thierry Onkelinx)
* geom_vline and geom_hline now correctly transform their intercepts if the
scale is transformed
* geom_vline and geom_hline: now use xintercept and yintercept instead of intercept
* legend.position and legend.justification work again
* position_dodge now works for any number of elements with smaller widths, not just 2!
* scale_discrete_position: does a better job of calculating axis limits when
plotting a mixture of continuous and discrete values (e.g. with geom_jitter)
* summary: tweaks to improve output
ggplot2 0.8 (2008-11-18)
----------------------------------------
* The two biggest new features in this release are the (long awaited) ability
to have scales that vary between facets, and a faceting system that works
like lattice (facet_wrap). From qplot, you can use facet_wrap by specifying
one sided formula (~ colour, as opposed to . ~ color). To see some potential
uses for these new features, see the "Positioning" chapter of the book.
Implementing these changes has required a rewrite of large parts of the
coordinate systems code, so if anything seems strange with non-Cartesian
coordinate systems, please get in touch.
* I've also made another round of tweaks to make the plots more aesthetically
pleasing.This includes using a bright blue colour for geoms used to add
statistical summaries to plots (contour, smooth, and quantiles), and
tweaking the default colour scheme for the continuous colour scale.Please
let me know what you think.Remember that most of these options are
controllable with the theming system - see the book chapter "Polishing your
plots for publication".
* Accompanying this new release of the package is an updated and expanded
version of the book. The content of the book is now largely complete (~170
pages), and over the coming months I will be working on make it polished and
easy to understand.See http://had.co.nz/ggplot2/book.I love to hear your
feedback about the book, but at this point please don't bother reporting
minor typos, I would much rather hear about what you want to do, but can't
figure out from the book.
Other new features:
* geom_bin2d/stat_bin2d & geom_hex/stat_binhex: for 2d square and hexagon binning, particularly useful for alleviating overplotting in scatterplots
* geom_freqpoly: draws frequency polygons (= stat_bin + geom_line)
* scale_position: both discrete and continuous gain a new formatter argument
to control the default formatting of the axis labels. See also the handy
numeric formatters: dollar, comma and percent
* the xlim and ylim functions now produce discrete scales when appropriate,
and generate a reverse scale if the minimum is greater than the maximum
Improvements
* coord_map gains experimental axis labels
* facet_grid: new support for varying scales in rows and columns
* facet_wrap: new faceter which wraps a 1d ribbon of panels into 2d, in a
similar way to lattice
* geom_bin: gains a drop argument to control whether or not 0 count bins
should be removed
* geom_path and geom_line gain arrows argument to match geom_segment
* ggsave now checks that you are using it with a ggplot plot
* ggsave now produces postscript files that are suitable for embedding in
another document
* ggsave now recognises the .svg extension and will produce svg files, if
possible
* ggsave: default dpi changed to 300, on the assumption that you are saving
the plot for printing
* qplot: uses facet_wrap if formula looks like ~ a + b (as opposed to a ~ b)
Aesthetic tweaks
* geom_bar, geom_polygon, geom_rect, ...: default fill colour is now much
closer to black to match the defaults in other geoms (point, line, etc)
* geom_line, geom_path, geom_segment: lines have squared ends
* geom_point, geom_pointrange and geom_boxplot: now use shape = 16 instead of
19. This shape does not have a border from R 2.8 on, and so will look
better when displayed transparently.
* geom_contour, geom_density2d, geom_quantile and geom_smooth use a bright
blue colour for lines, to make them stand out when used with black points
* scale_gradient: tweaked default colours to make more aesthetically pleasing
* theme: new theme setting panel.margin (a unit) controls gap between panels
in facetted plots (for both grid and wrap)
* theme_gray: removed black border around strips
* theme_bw: tweaks to make black and white theme look a little nicer
Bug fixes
* coord_cartesian now correctly clips instead of dropping points outside of its limits
* facet_grid: margins now grouped correctly in default case (non-aesthetic
variables ignored when generating default group value)
* facet_grid: fix long standing bug when combining datasets with different
levels of facetting variable
* geom_smooth calls stat::predict explicitly to avoid conflicts with packages
that override predict for S4 model classes
* grid: correctly expose subcomponents of strips and axes
* mapping aesthetics to functions of stat output now works in a much wider
variety of cases
* order aesthetic should now work with bars (and in general more geoms)
* position_dodge now works with points and other geoms that lack xmin and xmax
* scale_area works once more
* scale_discrete_position: empty levels are no longer displayed by default, if
you want them, use breaks = levels(myfactor)
* scale_discrete_position: fixed bug when limits were set
* scale_discrete_position: more aesthetically pleasing expansion for a wider
ranges of plots (picks expansion based on whether or not geom with width
used, e.g. bars)
* scale_gradient*: axes are correctly labelled when a transformation is used
* scale_x_log10, scale_y_sqrt etc now correctly transform output from
statistics as well as raw data
* scale_z_* now removed because no longer used by anything
* stat_bin: correctly returns 0 when no observations in a bin (was previously
returning NA)
* stat_quantreg: deal with yet another new output format from quantreg
* stat_contour now has arguments to control the position of the contours,
rather than relying on the z scale
* theme: panel.empty setting removed as it is no longer used
* theme_grey now aliased to theme_gray
* theme_line: setting size works correctly
* theme_rect, theme_segment: size now measured in mm, to be consistent with
the rest of ggplot
ggplot2 0.7
----------------------------------------------------------------
* ggplot2 0.7 introduces a new theming system which allows you to control
(almost) every aspect of the appearance of the plot. This system is
documented in the book chapter "Polishing your plots for publication",
available from http://had.co.nz/ggplot2/book/polishing.pdf.
Bugs fixed
* geom_boxplot: now displays outliers even if only one present
* geom_jitter: setting one jitter direction to 0 now works
* geom_segment: should now work correctly in all coordinate systems (note that
arrows only work in Cartesian coordinates)
* ggsave: correctly uses dpi for raster devices and default dpi changed to 72
(thanks to Brian Ripley for pointing this out)
* ggsave: current device no longer closes if error occurs
* position_jitter: now works correctly with 0 jitter
* remove_missing: some statistics were calculated incorrectly when missing
values were present
* scales: extra scales ignored (again)
* scales: legends respect fixed parameters of the layer
* scales: legends won't appear when aesthetics are mapped to NULL, or set to fixed value
* scales: xend and yend now transformed correctly
* scale_date: breaks are now rounded to correct position
New functionality
* geom_point: can now control colour and fill separately for point glyphs with
borders
* geom_step: now has parameter direction which can take values vh (vertical
then horizontal) or hv (horizontal then vertical) describing the shape of the
stairs
* qplot: new asp argument to set aspect ratio
* qplot: now captures the environment in which it was run, which should make
it much more robust at finding the variables you expect it to find
* qplot: now treats any arguments wrapped in I() as parameters, not
aesthetics, e.g. qplot(mpg, wt, data=mtcars, colour = I("red")) or
qplot(mpg, wt, data=mtcars, size = I(5))
* scale_continuous: new minor_breaks argument to controls position of minor
breaks
* scale_discrete: new discrete position scales which make it possible to
manually position elements
* scale_gradientn: new colour scale which creates gradient between any list of
colours
More consistent interfaces
* can use color instead of colour, and old R names throughout ggplot2
* geom_jitter: Arguments changed to height and width to match other position
adjustments
* scales: any point outside of limits is dropped (this was previously the
behaviour for discrete scales, but not continuous scales)
* scales: limits are consistent across discrete and continuous scales (limits
c(1, NA) form no longer works for continuous scales)
* scales: order of legends reversed to match order of x axis (and to be
consistent with previous versions)
* scale_date: new limits argument to set axis limits
* scale_discrete: all discrete scales accept breaks argument
* scale_discrete: all discrete scales have limits and labels argument to
better control legends
* scale_discrete: character and logical vectors now reliably treated as
discrete scales
* stat_density2d, geom_density2d: density2d used consistently (instead of
density_2d in some places)
Improved aesthetics
* coord_polar: more tweaks to grid lines to enhance appearance
* coord_polar: new expand argument to control whether axes should be expanded
outside the range of the data
* geom_contour, geom_smooth, geom_quantile: now use blue lines
* position_stack, position_dodge: should be more informative if conditions for
stacking/dodging not met
* position_jitter: default amount of jittering tweaked to align with boxplots
etc.
* scales: background colour of legends key matches plot
* themes: Complete rewrite of theming system, see new book chapter for details
* themes: direct access to plot options via $ is now disabled
Improved documentation and error messages
* facet_grid: documentation improved
* qplot: Better error messages when needed variables are missing
* scale_discrete: improved error message for too many values in domain
* scale_size: improved documentation for discrete variables
* online documentation generally tweaked and primped to work a little better
and look a little nicer
* website now includes a search box
* links from rdoc now point to correct pages
ggplot2 0.6
----------------------------------------------------------------
The two big changes in this release are improved documentation and legends.
* all major ggplot2 components now have their own built in documentation, so
that (e.g.) ?stat_smooth or ?geom_point now give you useful information
* the legend code is now considerably more sophisticated and will attempt to
merge together legends for the same variable
* also, legends are drawn based on the geoms used (instead of the scales
used, as previously) so should match the plot much better (e.g. for
geom_smooth, geom_boxplot, geom_vline, geom_abline, geom_pointrange).
These features are new, so there are likely to be a few bugs that I haven't discovered. Please me know if you discover any.
Other additions and corrections
* coord_equal: should now work correctly in all situations
* coord_polar: add start and direction parameters, giving more control over
the layout of the polar coords
* coord_polar: added my favourite pie chart example
* coord_trans now deals with groups appropriately, at the cost of decreased
speed
* geom_abline, geom_vline, geom_hline: should now behave better in a wider
variety of settings
* geom_boxplot: deals with continuous x-axis and grouping much better
* geom_boxplot: now has it's own legend which actually looks like a boxplot
* geom_boxplot: reports if missing values removed
* geom_crossbar: the middle line is now display thicker than the other lines,
controlled by the parameter fatten (thanks to Heike Hofmann for the
suggestion)
* geom_density: fix scale adjustment bug in geom_density
* geom_line, geom_text: all size measurements (now lines and text as well) are
measured in mm, lines/paths default to paths 0.5mm wide
* geom_rug: new to add marginal rug plots
* geom_smooth: added example showing how to use geom_smooth with your own
models
* geom_smooth: fixed bug where if se=FALSE x axis always includes 0
* geom_vline, geom_hline: yet another rewrite which should make them more
powerful and less error prone.
* ggsave reports width and height of saved image
* position_stack: fixed bug when data was empty
* qplot: allow qplot to use computed aesthetics too
* scale_continuous: tweaks to minor breaks to make appearance better on wider
range of coordinate systems
* scale_discrete: all discrete scales now have labels argument which you can
use to override the factor levels
* scale_discrete: now works correctly with character vectors
* scale_size: changed default range to [0.5, 3] to better reflect new sizing
decisions
* scale_size: legends resize to avoid overlaps
* scale_x_continuous, scale_y_continuous: new convenience functions xlim and
ylim (and zlim) that make it even easier to adjust the limits of the x, y,
and z axes
* stat_bin, geom_area: fixed bug in combination of stat_bin and geom_area that
made it difficult to draw frequency polygons
* stat_bin: fixed bug which resulted in increased counts when the x axis was a
categorical variable with a single level (thanks to Bob Muenchen for
pointing this out!)
* stat_bin: no longer incorrectly warns that binwidth is unspecified when
breaks are set
* stat_bin: now takes origin argument to manually specify origin of first bin
(default is round_any(min(range), bin_width, floor))
* stat_boxplot, stat_contour, stat_density_2d, stat_qq, stat_density: na.rm
parameter added to the following statistics (thanks to Leena Choi for
suggesting this)
* stat_function: new, makes it easy to superimpose a function on the plot
* stat_qq: axes flipped to agree with base R
* stat_qq: now uses sample aesthetic to select variable for summary
* stat_quantile: updated to work with latest version of quantreg
* stat_spoke: new, to make it possible to use geom_segment parameterised by
angle and radius (thanks to Jiho for the suggestion)
* stat_summary: better documentation
* stat_summary: convenient auto wrapping of simple summary functions
Miscellaneous changes:
* it's now easy to change the default scales (and their arguments) with the
set_default_scale function, see ?set_default_scale for more details (thanks
to Bob Muenchen for the suggestion)
* new order aesthetic which controls the order in which elements are plotted
* min and max are now scaled the same way as y
* functions are silently dropped (e.g. aes(colour=col))
* scales do not try and map variables that don't exist (fixes some rather
obscure bugs)
* aes(mpg, wt) is now equivalent to aes(x = mpg, y = wt)
ggplot2 0.5.7
----------------------------------------------------------------
New geoms, scales and aesthetics
* stat_step and geom_step to draw staircase plots (like plot(type="s"))
* order aesthetic (currently only for lines/paths) allows you to control the
drawing order within a group
* scale_manual makes it easier to let ggplot uses the exact
colours/sizes/linetypes that you want
* scale_reverse allows you to reverse the scale of x and y axes
* scale_grey is a new black and white scale for categorical data (colour and
fill)
Improved options handling
* new function opts() to allow modification of plot options by addition
* update(p, theme_bw) and p + theme_bw now work
These changes mean that you can modify plot options in the same way that you modify all other aspects of the plot, e.g. qplot(mpg, wt, data=mptcars) + opts(title = "Fuel economy vs weight")
Improved documentation
* many tweaks to the online documentation, particular including the actual
code you need to run for each object!
* every page now has a link to a form where you can submit feedback on exactly
you do or don't like about a page
* required aesthetics now listed in documentation
* geom_polygon now has a decent example
* numerous minor corrections suggested by Jörg Beyer
* separated plotting advice from details of plot construction (what vs how),
thanks to Bert Gunter for this suggestion
Improved map projections (with coord_map)
* coord_map defaults to orientation = c(90, 0, mean(range(y))) - this ensures
that multiple layers line up correctly, but means you will have to specify
the orientation yourself for many projections
* coord_map now respects limits set by scales
* removed useless ticks from coord_map
If you're using ggplot to draw maps and have thought of other features that would make your life easier, please let me know.
Bug fixes
* adding data and aesthetics in separate steps should now work
* layers with set parameters will not use mapped aesthetics
* use LazyLoad: false instead of SaveData: true for better future
compatability
* coord_cartesian: fixed bug that prevented you from overriding the default
axis expansion
* coord_equal: now scales correctly if ratio < 1
* geom_abline: fix bug where slope was ignored
* geom_jitter now works correctly with groups and categorical values (was
actually a bug in how scale_discrete deals with continuous values)
* geom_path: automatically switch between polylineGrob and segmentsGrob when
drawing paths so that setting line type now works properly
* geom_segment now uses both ends of segments to calculate axis limits
* plotmatrix: fix bug in scatterplot matrix where all scatterplots were
transposed!
* qplot: should now work better within functions
* quickplot added as an alias of qplot, to avoid confusion with qunif, etc
* scale_*: better error message if you add a scale without a matching
aesthetic mapping in the plot
* scale_identity no longer converts everything to character
* scale_identity: grob argument renamed to guide
* stat_*: made all statistics more robust to errors
* stat_quantile: fixed bug when only drawing a single quantile
* stat_smooth: returns silently if <2 non-missing data points
Minor aesthetic improvements
* coord_polar now specifies aspect.ratio by default, and I've made a few other
tweaks to make polar coordinates plot look nicer
* geom_bar no longer draws gray borders by default, but instead uses the same
colour as fill (this eliminates a tiny gap between neighbouring bars)
* plotmatrix: tweaks to improve display of scatterplot matrix
* scale_brewer: added option to reverse palette
* scale_colour: colour and fill legends now look exactly the same (previously
colour was missing a grey border)
* scale_discrete has slightly larger expansion (0.75 vs 0.5)
* stat_bar: only output bars with > 0 count
ggplot2 0.5.6
----------------------------------------------------------------
Improved error messages and other notifications:
* all geoms and position adjustments should now give an informative error
message when required aesthetics are missing
* better error messages if data not a data frame, or mapping not created by
aes or aes_string
* better errors for qplot when variables missing or data invalid
* better error if somehow you are missing necessary scales
* stat_bin informs you of the default choice of binwidth
* stat_smooth gives helpful error messages for common problems
* printing a geom now displays the data set that it uses (if not the default)
Other improvements:
* colour and fill legends now surround by background plot colour
* can now draw arrow heads with geom_segment, and have added an example
demonstrating drawing a vector field
* density plots should always include 0 on y axis
* default boxplot outlier changed colour to black
* stat_smooth supports categorical variables a little better
* implemented hash methods for all ggplot objects. This is the first step in
making it easier for me to compare all examples between versions for quality
control purposes
New data:
* seals, contributed by David Brillinger and Charlotte Wickham, used for
vector field example
Bug fixes:
* geoms hline, vline and abline now all work correctly when a grouping variable is used
* block histograms (where individuals are identifiable) now work correctly
* all ggplot objects should now print properly from the command line
* fixed bug in geom_path when only 1 point
* segments geom now works correctly for more coordinate systems
* order variables in scatterplot matrix by order of variables in data.frame
* geom_density deals with missing values correctly when displaying scaled densities
* fixed bug in calculating categorical ranges
* fixed bug in drawing error bars
Subtractions
* now relies on R 2.6
* removed grid.gedit and grid.gremove, and code replaced by grid.ls
ggplot2 0.5.5
----------------------------------------------------------------
Improvements:
* ggplot now gives rather more helpful errors if you have misspecified a
variable name in the aesthetic mapping
* changed default hline and vline intercepts to 0
* added "count" output variable from stat_density for creating
stacked/conditional density plots
* added parameters to geom_boxplot to control appearance of outlying points
* overriding aesthetics with fixed values that have already been set with
aesthetics now actually works
* slightly better names for xaxis and yaxis grobs
* added aes_string function to make it easier to construction aesthetic
mapping specifications in functions
* continuous scales now have labels argument so that you can manually specify
labels if desired
* stat_density now calculates densities on a common grid across groups. This
means that position_fill and position_stack now work properly
* if numeric, legend labels right aligned
* polar coordinates much improved, and with better examples
Documentation:
* fixed argument documentation for qplot
* added (very) rudimentary documentation about what functions return
* documentation now lists extra variables created by statistics
Bug fixes:
* coord_flip now works with segment and all interval geoms
* geom_errorbar now works in all coordinate systems
* derived y axes (eg. on histogram) are now labelled correctly
* fixed bug in stat_quantile caused by new output format from predict.rq
* fixed bug if x or y are constant
* fixed bug in histogram where sometimes lowest bar was omitted
* fixed bug in stat_qq which prevent setting aesthetics
* fixed bug in qplot(..., geom="density", position="identity")
* fixed stat_qq so that unnecessary arguments are no longer passed to the
distribution function
Subtractions:
* removed grid argument from ggsave, replaced by ggtheme(theme_bw)
* removed add argument from qplot
ggplot2 0.5.4
----------------------------------------------------------------
* border now drawn on top of geoms, instead of below - this results in better
appearance when adjusting scale limits
* ggplot() + aes() now modifies existing default aesthetic mapping, rather
than overwriting
* polish examples in facet_grid
ggplot2 0.5.3
----------------------------------------------------------------
* added experimental scatterplot matrix, see ?plotmatrix
* added new border.colour and grid.minor.colour options for better control
over plot apperance
* updated theme_bw to do better when drawing a plot with white background
* better default colour choices for gradients (and more discussion in examples)
* fixed bug in ScaleGradient2 where scales with different positive and
negative ranges were not scaled correctly
* allow expressions as result from strip.text
* fixed rare bug in geom_vline and geom_hline
* fixed example in geom_abline
* tweaked display of multiline axis labels
ggplot2 0.5.2
----------------------------------------------------------------
* add argument to position dodge so it's now possible to accurately dodge things with different widths to their physical widths
* added median summary
New examples:
* logistic regression example in stat_smooth
Bugs fixed:
* evaluation of arguments to layer is no longer delayed
* can use categorical xseq with stat_smooth
* x and y axes named incorrectly (thanks to Dieter Menne for spotting this)
* can now pass position objects to qplot
* y jitter calculated correctly, and jittered data rescales axis now
* removed silly legend from quantile plot
* extra arguments not being passed on to geoms/stats
* fixed bug in stat_summary when summarising a factor
* fixed bugs in stat_summary, geom_ribbon, and coord_trans examples
ggplot2 0.5.1
----------------------------------------------------------------
* renamed scale_manual to scale_identity to map position_identity and
stat_identity
* ensured all grob consistently named
* renamed aesthetics argument to mapping to be consistent with description in
book
* added useful utilities for modifying grobs
* bug fixes to x axis range with interval geoms
* added ability to turn legend off for single scale (currently undocumented)
* added economics data set and matching examples
ggplot2 0.5
----------------------------------------------------------------
* complete rewrite of ggplot code base
* id/grouping completely rewritten so that automatically grouped when any of
the aesthetics is a categorical variable.This behaviour is defined in the
Grammar of Graphics, and makes things like qplot(wt, data=mtcars,
geom="density", colour=factor(cyl)) work nicely
ggplot2/DESCRIPTION 0000644 0001751 0000144 00000010347 12114411470 013354 0 ustar hornik users Package: ggplot2
Type: Package
Title: An implementation of the Grammar of Graphics
Version: 0.9.3.1
Author: Hadley Wickham , Winston Chang
Maintainer: Hadley Wickham
Description: An implementation of the grammar of graphics in R. It
combines the advantages of both base and lattice graphics:
conditioning and shared axes are handled automatically, and you
can still build up a plot step by step from multiple data
sources. It also implements a sophisticated multidimensional
conditioning system and a consistent interface to map data to
aesthetic attributes. See the ggplot2 website for more
information, documentation and examples.
Depends: R (>= 2.14), stats, methods
Imports: plyr (>= 1.7.1), digest, grid, gtable (>= 0.1.1), reshape2,
scales (>= 0.2.3), proto, MASS
Suggests: quantreg, Hmisc, mapproj, maps, hexbin, maptools, multcomp,
nlme, testthat
Enhances: sp
License: GPL-2
URL: http://had.co.nz/ggplot2/
LazyData: true
Collate: 'aaa-.r' 'aaa-constants.r' 'aes-colour-fill-alpha.r'
'aes-linetype-size-shape.r' 'aes.r' 'annotation.r' 'bench.r'
'coord-.r' 'coord-cartesian-.r' 'coord-fixed.r' 'coord-flip.r'
'coord-map.r' 'coord-munch.r' 'coord-polar.r'
'coord-transform.r' 'facet-.r' 'facet-grid-.r' 'facet-labels.r'
'facet-layout.r' 'facet-locate.r' 'facet-null.r'
'facet-viewports.r' 'facet-wrap.r' 'fortify-lm.r'
'fortify-map.r' 'fortify-spatial.r' 'fortify.r' 'geom-.r'
'geom-abline.r' 'geom-bar-.r' 'geom-bar-histogram.r'
'geom-bin2d.r' 'geom-blank.r' 'geom-boxplot.r'
'geom-crossbar.r' 'geom-defaults.r' 'geom-dotplot.r'
'geom-error.r' 'geom-errorh.r' 'geom-freqpoly.r' 'geom-hex.r'
'geom-hline.r' 'geom-linerange.r' 'geom-polygon.r' 'geom-map.r'
'geom-path-.r' 'geom-path-contour.r' 'geom-path-density2d.r'
'geom-path-line.r' 'geom-path-step.r' 'geom-point-.r'
'geom-point-jitter.r' 'geom-pointrange.r' 'geom-quantile.r'
'geom-rect.r' 'geom-ribbon-.r' 'geom-ribbon-density.r'
'geom-rug.r' 'geom-segment.r' 'geom-smooth.r' 'geom-text.r'
'geom-tile.r' 'geom-violin.r' 'geom-vline.r' 'ggplot2.r'
'grob-absolute.r' 'grob-dotstack.r' 'grob-null.r'
'guide-colorbar.r' 'guide-legend.r' 'guides-.r' 'guides-axis.r'
'guides-grid.r' 'labels.r' 'layer.r' 'limits.r' 'matrix.r'
'panel.r' 'plot-build.r' 'plot-construction.r' 'plot-last.r'
'plot-render.r' 'plot.r' 'position-.r' 'position-collide.r'
'position-dodge.r' 'position-fill.r' 'position-identity.r'
'position-jitter.r' 'position-stack.r' 'quick-plot.r' 'save.r'
'scale-.r' 'scale-alpha.r' 'scale-area.r' 'scale-brewer.r'
'scale-continuous.r' 'scale-date.r' 'scale-datetime.r'
'scale-discrete-.r' 'scale-gradient.r' 'scale-gradient2.r'
'scale-gradientn.r' 'scale-grey.r' 'scale-hue.r'
'scale-identity.r' 'scale-linetype.r' 'scale-manual.r'
'scale-shape.r' 'scale-size.r' 'scales-.r' 'stat-.r'
'stat-summary-2d.r' 'stat-summary-hex.r' 'stat-bin.r'
'stat-bin2d.r' 'stat-binhex.r' 'stat-boxplot.r'
'stat-contour.r' 'stat-density-2d.r' 'stat-density.r'
'stat-bindot.r' 'stat-function.r' 'stat-identity.r' 'stat-qq.r'
'stat-quantile.r' 'stat-smooth-methods.r' 'stat-smooth.r'
'stat-spoke.r' 'stat-sum.r' 'stat-summary.r' 'stat-unique.r'
'stat-vline.r' 'stat-ydensity.r' 'stat-ecdf.r' 'summary.r'
'templates.r' 'theme-defaults.r' 'theme-elements.r' 'theme.r'
'utilities-break.r' 'utilities-grid.r' 'utilities-layer.r'
'utilities-matrix.r' 'utilities-resolution.r'
'utilities-table.r' 'utilities.r' 'xxx-digest.r' 'zxx.r'
'geom-raster.r' 'annotation-raster.r' 'annotation-map.r'
'autoplot.r' 'zzz.r' 'fortify-multcomp.r' 'annotation-custom.r'
'aes-group-order.r' 'aes-position.r' 'translate-qplot-base.r'
'translate-qplot-ggplot.r' 'translate-qplot-gpl.r'
'translate-qplot-lattice.r' 'annotation-logticks.r'
'utilities-help.r'
Packaged: 2013-03-01 17:44:46 UTC; ubuntu
NeedsCompilation: no
Repository: CRAN
Date/Publication: 2013-03-02 15:56:56
ggplot2/build/ 0000755 0001751 0000144 00000000000 12114164416 012745 5 ustar hornik users ggplot2/build/partial.rdb 0000644 0001751 0000144 00000463435 12114164416 015111 0 ustar hornik users ‹ ìýyÉ™.ˆf‰ÔJ"(E‰’H…H-¤B$µ”(‰¥Rm¶Ü²Ë]‹WÙê$$áÂÂB‚’è>Ýî³vŸ½Ï™93sçÎ̽·ÿ<Ÿâ~ˆóAü›pûæ›ùLdˆ%#mÿº~N?Ab<ñ¾±ÇûülÂqœcαbðŒQòýàÿ>pœ1Âóøù½ §Bw
žÞõZ×îv½Öôgü˜ð«_V_wÜÝ %þƒñŸ|öåÇñoúíJÛÛ ²:K?EÙ8'ç>ûW'ƒµS«{ôGè¿ÿ;ö•±Ïš•XþÇ¿ùúóÕG±ïòš•VµÖŒ“ubß+tj
Ïï¸ýàoOÒ/žÿ—~×ÿÅ㕺ëûøkÇ8áñÕ‹ŸU:üÃ;Aêÿ§C¯Õt^ŒÎó»fçn§±÷Ëàÿ¾®í¯õõÝ/·jõꃇ›Ü[_«®í<Ú¼»»»_ou6î6Üæ]¡~Ê_Vc{[eQ–Ë""Ï_àÔ?ÆþšPEi_éÖ½ø‡Þ‹ëø«¨8è—Çþ1f(ü™î!}o,øÞø?Žší«~o"…Çø×ŸýìëïˆGÆhNÖO¬çVGˆQmŸN#T>‰¹žxåÖk®Ÿ’ï{@¡`l×e?# CõróeP!Ìß÷*µšWeۇ̯·ö=æ6«¬Öìx튷ß)KrC5®"½j°Ê:µN=É•ÆPM„e¤Ëö«Œ²¿+ Å*•Îñ/?ùâÓÏøŒ£
8âÑ,–§Œ N½Üp÷÷ƒî‡m±}óòe‰UÝŽÛý!èp:Á‹ÑwKÒ¯pµIøé§Ú¯pŸÿí·üZ§Öj¿ZÕkÆu¸PÞk½}½{|üâóç/¿ú¬ÄÊåòŠ4uÞ¸ÞGú¾Ag8ðÝÝ$gwŽBðØvÊþ˜€xá¢.²ý3âÑ,•cŒIò( F
ΑžF±X„>ꯉž+ðãÏtåù…¼Æc¼n¼êU沺·ë]ͶǪm÷mó[®z;îA½ã³NK¶réwçO~’CåN B'ŒTn¼R‡‘l34r!<‹ôYcÍÐñWÁì#©¢ìÆ€“HOê·B+
5R±·¯u¼FŠAò·ŸBzÊ~LÙŸm§á
ÍôHòîyyf×öžÄˆH\XDZÉRCR§b¤î|½Œí=¿³çujŠ%và¸õú!«´š~§}PéxUÙÚ%ÂÓÀ§HëÑN2ö¶Öٓ⳨VB> :©Õ'UñXP’
Äf€³HÏlˆ‚ñõ·)ÙN/ }!ûÖÿld‚!^Dú¢¶MŒ³V[Å æ€W¾bÜ &ƒx8¼Û® 7Þ°cKÀ{Hß³cóÀûH+Í‰Ž¶eöE³~(Ûp> >AZÔø„±¦çUiK£[ßë°`´»¬îzí`àûÆ«³Ú;l0·í±Ö¯Ý®Ñ®ìLF–â¤õ_`†…li‘”ñ1¹ìBPlgVZ¼’vQ4†lÏ#}Þþx‡²ŸmS(xŽy
»Î!oÂì†]ã´ð¤À¬ Æ_Šc®c1Fåçpy,³Vµ1jVY+h¯Âv«¢-Ýs00§Hë»nÃ.·Ù¡Æí’§ßL£Ò o }#ûÖ€JfÙÞDú¦}7¤ìo ˆÇ6
q'ÏÖ@è²l
håYYh¾5X¥±ªùÁ̳NÛmú;vÃ
W¡;ðƒÑ@“üM¶r‰2ïkŸ ?˜eÑj~@2 Uó£æLÖûÏ£’ g‘69óIñ~*
ôÿáÌgÌQœùè¹eQ@<¶iŸ«÷_@Þœ,½ÿßÛQ`W N!=e¬X¢ »ëäVsàw^ÔÙ’ën&[á¤hWë;ÿº»¿_§½ýVÙñ£¦‰·’D/¢® —^ʾàŽOÙ^Gúº}ï£ìoˆÇ69<ǼKÈû’“e#0V.ËvUD¨ <ôieÿ¯Áη‚ž½ÌùwÈí}¶ïú~0þ;Ùº$Š“ÀÛHßΡ./£þ.©Ë´õµã*mQ*ßGZé OJ›“²´v†C()e›²´FÙÍ}\/³¯©Í¯¸MVkVêUaÁgo÷Z¾ô`•Î7‘ÞÔfz‹±7nýÀóÃ…5>‰
fÛ%Öæ®
w¿Ì¾ò(¢Â-ãÞ©Öî‘VYòÕHøÒh“Ÿc½£µÔ9ñ…Õ²,½k D(ê
Yû™WUϯ´kû½t_ÍRŽ‹ùÚû"lœ£ž½OéÒ¡Yí„€x4Ke†±Ÿ’Mׂé‚_#«ßõ™$³ë¨#B͸äïð0ðÞ€þ©GÓˆÐe Îz$AYÞ@Z6~\¥!
7·‘Îc'ìÊdpp12‘7*&B„
ÀiGã8ªœ‰Pvc@ô†î€¬”?¾åÓbßÎA=ñ¹Í`râvÂU¶ 'ðËŒý\~/hÎ Ÿ"¿ø„…Ó>ÿ`¿~uVnÛmxAæ‡ä…k %¡gSðƒ›°9Bs'ž²h@äXçm+˜ú™W×a¼wûõZ¥Ö ÞÍ
Þ§ö.0D3È“_‰æ†f/*Ô]lÃPáò":;
s¢ŠÙË2_[B{
GWß[–$²‚ÌWàp¸Ñc¨º&^ZéëÖZ)²‘õÙ¶‰xN o#Ôx˵M”Ý8ðÒw´ëkj…©T
ŠHÖŠˆM øi}~D§@ëu:HEÄüÀB‡>Úw›^ÝÜ~§Õþ܆¹>BZi)%Î36mý“ûjØlÉ¡KÝ?Ú7nû0pòVC–ý0¾c”}Ðö„eL3•0”5- }ïÛØ¯{~oÕ¢Võ\_z"S[Bów¤N½ÂZJÊpr[urÄPöÇÔ›ÄпN€=ï.ÙJò£Å½ àûH«ßŽ_’..¢1+ ëãå»°˜»Žæx9ŒPp<¥Ëáòtjç$Þ <ç C@Ã^ƒþû¿£ÏŽ÷ýa!ØÀ‰ø/èó“”!ë¼÷»ßÓg'ÿ!öÚ£†(Ä38ó´Òj6½
@|}g"þ?Øûþ)ý¶ÐÊ$Ý÷?f»/ØA³È;A¯çGcÁV½ÞzK3
a£f¹í}wP£Høº¥ ?ÚnÕ«+uâüé_j¿ŽÒ5ù÷Œµã4x¬-:üÒÇØ*b©È7Püð¸“Ø@I‹“jë)»ã(“HŸÔ7•Rp^²ú6íÜúþ^Ú‘ã—ò‹À„]éÑ9ɵ>”]˜°+mË])ûóÆöi¬ù‡W ÿ8Ÿ8ž¯‡Op4ë'*zë -ë ÇáÇ#çZ³vãpŠãNï.¹¾eJ;e?+`l„kÍAxëcm9ïKOäë |{—£Y9EûÎá¾ôàþÜâ„sä¢QÖ.rnA(•µí"ô\0v¤Úš‹÷‹ópÁ-òt‘“pŽf]dܯýVÚ=NÂ%§‘VšiɹÇI¸áûH+ìôï̈ÇÐÛŸ
ͱ[)}“Ÿ÷œÞõ¹˜Vð qñ*€ñ—/¾ú:å/ãa
û‹¨hÖœÞ
UýÐCÒÅBÙŸ<ñcÂoOW›n£Vù¼ÆË<ëô†
é&äG+; $Ëø÷ëÉ&4IúÆ™ìg£W~ë0%Ž1³’\
½>*ÔVnÉ©sÄ£iVKûìé*ûŽ–Ì–ßvJ¬±¿ÛéÖèTܶ/ íªP¾ü¡YbƒºqõñXXbŸ‡Û¯á^4‚bênl*É F¸€ô‚6ÉçûìΑ°}+l‰}â6ou˜ïy¬ÞI>èøü¾oÛmîz¬µÓݬ’~‡àNøéçÚïÁâïÑÛöÛbkò¶)œîOýY·MaßÎ mÞ§J®WênÇK
ðI5œpÛó;l§Ö‘¦¾ º›ŽÉ‹•–·³\o,-ûkFmÑÑfH¾®ƒá"Ò‹ÚDKƒLòÞ8_¤WÈSÈ›¥š”¢¼¾VbÑÊ
EÆl{U
ŠøÈÁä_@8#–¿uÿÚBÞÍø×ƒ¥pKüÝë~í7ZÎ^¸%¸Qx¦5‚ C=Œ£Ô”~¾„B÷ Éý@|¹áuöZÕÅzƒjÜÛ
Ã
Ê×ø30$Ô»1£Wã!oŽfj<è6¿Jêçé™Rå
}£Áè£pm}.G
f‰¶þ–ßnLméáVЮ®”X9h[+‡õÞ „w}—åkýcPÿøhÉk¾ÆFu‡Þƒ
¶[v·ÚÍV»±LÔÆƒà¶…Ö:…O@–pé
ýŽ7ÞÂRÙ÷N¹üÔÙöJÔmUwä©
º„æ:^yOûys4ãi·Ó<ŽH…£·µ¬Ò„?IBáè—&áÉzm»í¶—÷ë‡mùÚüˆN"=©MªLÃ(?t¢jÀ«Û”—ÉëKlç ÎÅ—d)Múû JÈçîemÒóŒ5ˆrßèOÉM^€¡pKN“ã*;Ò,Íj8`m¬ürýWA«$ü¼ñ+yÎ? OB~DmU›óØ_É3ù3äN¨w*Wüíi¿Ó^MSžÑK° BËj2ú Þb‡öRŒzÎÄÖ[žýÁ˜ÐÜÕ2ùFûGÈ›£™F{s‰½ +n¥–uÙvÃ<ׯyíp ÜŠ‚ˆD7õz£Oiþ_€3¡0Õõê®`PL5¿ÛnìoEí¥0H–¯ûƒçzõ–gjðëõpugëë/¿QÞÿ9x
“*ëöû%òæhÆ~ç—¢ûv•V«]5iÙ¤§K~-ï+ð"4×ó<‘Xp¾¾Êëzm_aXÿ5X¼˜£òûºÛVx…o@›PëfNb¶…Wü,|BÖ|>ñ£6*½sAÙ
Ú¹8«Kç§Nt.’£™›²òû÷?CüÌIÜ¿7Úã´ÐÉ),çž3f¹©>(»Pˆˆd,Û”ísÊn(³Ñ4‹«4èp«ÕpÂ質׮½ñªÑR!Ð"‘»|ìt£‘h’<Åp!H’ÍÏaµ„|Ó]Mài`pó¡7¼ñ;\@Zi/K΀_!¼ŠôÕì
øçðB†4Ó¶á‚ò^«]ûm«Ùqë‘!§*i
ªŠkÀÖŸvÈ7º¿€™f×è¿q>ˆ_xi¥xr&ûØáÒ&›ú“¥ìÆ€<’RSZA&ûÆkGnCƒ•µWbtXFZaIÞ^ ýe¦öz&š¾y»cHax i“ÝuŠÅþVúKçHÈ»¬-ö—°RÂ+H«éyˆ¿•ÃRöóâ1ôötBÊsë~+eôLFøÊÉuNñ
þÀQ}N¡EãW(ŽÊ¥‘øäó|ü¿_#?G%OúFüŒÚø1ñÛ_VqQüÆu”Oí·½}·íŸG»Ï~ß}Á€æ@íSá_ÞvÛi•–¢ìK¯ËOO"-ìt8f漣ÎõýÿòÏõï¦~¨ZAAuËÿç6ëêÕÅò:,Zòÿ÷ºß‹
“NÆO‘V*œÄ\G“®JÅv¥PöçÄc¨Rn|n`¶½JÇmîRŠp/aÛõ½0Fù»U÷]M6ÎÁj‰°„tÉ`¢\°#`«Æ(û²€xkl䨑ªÊÕŠÅòÊÕC&[½]kjjV?Dú¡6ùù¸fu@²òí¢qê„ m{W§¶eïCÄ©%í}F—ÎqjÅR1.N-Y,ô’pEÔ‚ð{(Oζ@*ýn˜ ªX»Š©¨Ö 'Q U¡oNÔ^Hˆ)ÄY§O U³EJ]Æ ì& ©ÚÙÇ>LHU´ Tb0LH5dê©<Âá†Ó'š¥]ðP¾üÞÒ=;v1¼ïô ¤ª¶j©Dâ0A U‘ŒETQx<áô‚â˜H¥Ègž1h^Cté)ÛóHŸ×.éñe?+ Û4øÒG3ƒQùa×$ò&ÌnØ¥": ›™t%%Ç\ÇbŒ²H%ÎE`‚@ªbíf"ZD¥
¡¸³n
¨dÆíM¤oÚwCÊþ–€1T[4¦Pðój
Î!o¾‚–Qk JŒ
Nª\²fk©@ê9§§–œ ªX¹fR§QÉ„³H›œùŒ œ jËí(û‹Æ¢ùØ¢!H&åêýÂ`0CïWH"†ß/8жRgá§O U±Z3H=º&Lˆ‘‘U#@å‚I@’@ª-ïƒKñئ!´¾¹6CT’
5
©¢@r‚@ªæ¬QTa1/I ÕZ]ŠÊÇúu™¶¾¦$ )œoL
E›ÕÒÚEaB(Ú¬–Ö(»1§§Ænfí#Tb8ÜtúR™f$:›&L÷§}¥ûÀԬ웲+7>Ԭ웲[>vúRmõ¡”ýc©Š4¤^‚q
£ý¬GX|jEÙòÑ–Rk§W-”ýyc·5ß~4T®žÓ¦?—(çˆG±¥:K‡6Û&Ä£Y*O#Ôm7’gcµPn®Šø´[ÕƒŠÇÖ«´âF‚sïVöÜvz¬ºQ$‡nVªŸÒ!W¯¸o·ÕW‚Þ•Â A?Ûií¶ÝF¤;Ti5;µæAë èѤ•‡À—ð!Òµ¹?aÑöíZ3Ô—skÍH”m"êsYÿ ÑpÛµ 7¾JÍšì\iBs{[·¨’°V“ÿ‚aÌAÝm—ÂQrh&N¯$É—#aBÌÍC'ÞzµÝ½´ÍÔcPDføi%+ëª)»;NO^øŽsä2–‘²$ M˜pŽ&hv‚¯Ò5ú¨‚¼#^LN4?jÏ5Ñ5'QõL‘ýcŒÙ½vdâ{!g“Êf‹Õ[ÍÝ`–ÚööÛ#£h7h‰š©qé¿LˆŒ§Þþt[Û¾×~®›û%¶}@$ƒ'\µb~«á±hªý&h‚ÜíºI»É¾°Ne°ý_fýsAgÕv+Ѷ ~!Ýâ_CBAóү;‚ùö^Nc Êþ˜€zc ûºth×qBÀX( õèë®÷ú‚ûÓôV£n-÷Ü·…?í¼•^b5_͵@ÈþI绫T‹†XVÂSî4ºp+{,òBjµ*[b¢î«9ö÷»«¡pm¥U?h4Å@Â\ÆöãC¾].}—ylWœÄ¸wÖ–ö„aŒ¡¥=ñ[Ã.Ÿ¤jˆN8åhlÒÈ
j(»1 ß[T»õqä·4Þ”–¼'ÓÀNwÓPÍLÐ+¼ R7À[H+–É×ÍEà2ÒJ}ß‘r8‡µÏ†ûç«4ADg¸‰´þBg0„ë
ÜÂv’FnÞwn¨eK
Qó ±4¬ñU–¿(¼knL"Ѱ‡/;4‡¯5ƒžk?ЃµèÜ7¿À‚Ö6z1ÙõwÍM"å[RáêS-é{‡²nJ<
âÉÚM);~liýáÐZo>VæâñÑòò IÖˆˆíiàc¤õ½à#›î
Óz£Šž~öüÞJÖE¨·]¡gñw‘÷ÝL,¾õPµjPrµÎ¡t7u6O˜ ô••ýß…Í
Ûuš•s1lGƒö2†VÄ{…*›®!½–c#E<>JZ>BZÞ =u¤ì7Ä£I㬰x%½Â°UkWa gËm—Ì:²æhf©!•S6Öþ¿¶FÞÝ
:J倮öðÖÙfxl¿îVh¬ROÏö MhnT·Ã¦•oI;höù¿ÛŒÖ¶»gÏ^‡ß¢%p¥“ç¢Þ‘¹aáëöÚ
Ü©¶ª»<˜I÷¬vZ«„$ß Ý3
3iÑ’÷Œ¢ ’™ž1©¹ìÖuXˆ
‹À+H+]šKizSNPvà<ÒóÙ·ø”ݘӓ¤sŽ„ñS´ŒÓeöyI—k¥€ˆÈUà
Ò+9˜ª°q˜¡©žíšêNИ*P,/#}9{K}ë|)vK}ë|Su#°Àü½Ö[?˜ŒÔƒøvÒ÷[áæ
s¥÷}:½]ç'Hë÷nX´ÔñŽú±°û¢þ¸»îM#àà‡fð«¶×©Ðú2“?M-Š¥%)RgŒù߸~H
CópÍM¥‡a¢”CšÙ†m"kŽf†a›Œ}ÕjÃÓ†G;{ݳáMÙð¤æsƒŸYµF®·ÈP]éA˜0pIН¯~¸#:ùpmKÖš~Çs«´ünuèLJ0îúž×ôÚa×Àj[Ò+¢jš¹ÃK,p|o' F‹p¸“ÐeÍ–}ùÓ¢:šÖ©ÿQPÃË ²sK"txi×ß)»ëÀûHëïìœZ!‡HW6T;€BZ"µúç¶×éóZÊZ
zQÖ¦ýúÀø¿ßzë½ñÚ%~¾Úâ§ue_`&µå˜œH/€3ám°'ÿ%'è¢[¼‡¼5V]fR‚ô‡F_à2Õ@ÐW¸4f5Zj'–$ø¤ùñF¥áÕ€e¼[|ï–¬«EàÒkÙ{1ew¸Žôºý˜²ßmÁ,8štV²–¾'2nøÁ¦þÖ=ôƒF’Áð»)a•}AšÐ\3ŒeÂåZ•½©Q˜(îѵk~«Yf?r[û²µ½Mg@£¿Y“ç.êšËÈÏu?EÞ„ús]úI-Þý½NgÿñÝ»oß¾-o¯z‡ÞjÓë¼mµ¿-e{÷MÍ{{·Ö¬zïÊû{ûÏ*µêÖÆý‡ÒÞ$%:'½AøÔéÆå’“ÄK¬§Â#³uéz&6Ï€Ÿ#ý¹v=Y÷Vj§µ_«H’•‹H
v {á—ËbÙN!=¥]wp\¡µ”Á&pTÚ_¯¶<Ÿ”ÐéC0piÊï*ÑsÀ'N7Ì€&á2ëÍ2êÝU?°¼CFN£S n¯åü9ê“PØ5T·§^áÈ{BÎ7‘W¼Ìé,ä÷"ïí"Ã-ÚÄóîm@I~¤©9|i¥K!¿qÝâ"³â±Þ½€Å¼p4;¢0¶ùñ”¡·òé;¢c/¸ùï~OŸü‡Ø;+7?ó´Òj6½PöÃè;<¡ÊS¦#B“Ô‰M©îvDÚÁY:”V½ÞzK‹˜Âàå¶÷ÝAM;޽i®ÖdÛzu屬¾×ý^$C5¡æë(ù~OÀX#.AƒÜïº.•êbì$¹b©È·Nã(Šq'±u’,'ÕÖSn›Ž£O"}Rß8TJa@ünÉRHÛ{ïâ‘§•˜ëÉW~§ÝâNû2.T¥43Nmù(»pÎéS•²ÕTPö—ÄcÝ7ÅÀì9ø&e;ÌÑ7)ûSêûæ‘·wëû{®ì é8|‚0!IVþq>A˜‰Ä–PöçŒÝÍ·æ|tëÞmùïÆOäë'àÍúljJ«Þ:žUœ€Sœ€¥U-UÎANÀ)NÀ*F,SÚAè™06õ´æ BÀü<DpŠ<ä$œ‚£YpÈ)Õ=NÂ%§‘žÎÞ=NÂ%ßGZ©ÛÒsÊ~F@<ÖÝC ÎÃ=¸~·ÍœÜãTòcÈ=N‘Œm¹Ëº4ÈBœEZ©
•s‘Sp„›$¶\ú]ŒE™µæ"¸E!)À-x£•“‹pƒàh¸ñk¿•v\‚ÐbRž{L|º˜W2—˜ÈÇ=ÄÄÝc.ÁÑðD-TÒœb±:™€Uæ8¡ìgTž$æz*4Èn«Õ·°MnÀµlÔ×Ùµ
€²?& C0þòÅW_§ü…dæ(š8Gz5ÎÇÖò`•ØÐ·âzÐìŶè}ÿþÏ’íe4Filô
ëÏ`7c6$¹¡=6*Ô&í%ì™#E>/µùü~¨ÍGüíÔŽÓw¢kóÒ´~øQ÷„¨Iëf…=]eÑñr£S E}]Ï_Þq+V{¹rX_Y‘6ý o"}3»v!•Ç‘7G3g\>_:r 7ÓFSbo÷jªö&ŠÇ‚¸Q<\Bj¦êÀ¥¾ÌŸã?Gúsí—)VØž ¯|U &„E¤‹Ú¬.aõ¶Víìm•ȳû
Œ…xþšìŽ–YðC¥ÕjW_ïÔkû
Eø5ˆ. ½ Mòî’´ž·µXfÇ,4ZþÞZ¬ºíowÛž×\”gý
˜ÞEún>þäÍÑŒŸYbßøûŽFiJ?
BAcP“R)$#¶Ì‘`öo·©²ƒ6Èm+ÔæÏ@“PˆG¤IùÃÑ)—Xh¢b¿#ý?q‘þ0“üòæhÆ$?Yb?¥Ë£Ý~z9Œm|˜í/ì—X,ô›üì …3ðšo2Y¯m·Ýöáò~ý°-_ͯ@„péIýör‰}¯"…eÜðÜ&kìOî;E¥xe‡©79SYÿ
L ͵—
ÁU«AQvp‹¿À¡ÝÚ÷J¬Aï±¾ÒrTð_ƒ2¡¹@•/øÐ³
;ß$´‡Ä:d,öfdÖÁ/z†-ÿ>¯ñ„/~‘C[ñÈ›£™¶âüû
1V†G–Oåæ‚¡ ¥ÉmKµSxã+Øí6x
715ßá™ê;ìzn[á-*`Nøég9Xkys46¡ê·Öð|®çú‡Ô«ást]îÖ{;;´øòÆÃ¯ñKR_ÆÃš›P}¼$ì¯R ó°ÏÞ†Þ¨á6ƒ¹c- ßEõ Ãlۣˋ$ý"; Oø1Òk¿ÈC´ÍÕšÛh5«X¨o´¸°êÊAçhË,oÚ» Løé‡úƒ¥dòÁ¼§J]w·ö„æKòNZCÞÍ8éâûÜx0ÂÝ£ÜmµªÌw¼v3È’z†>•èo@ŽpéEm¢åAvÛWåÒ¤¿QÂ2ÒemÒ3ŒÆ=^çõÛ¶»¿ü׌¬SšZtgžÑ¦öéE`£ñ»èÎ[ð¿ÀK‚ö«J“Œðª£b‘0Þ
™I×MúU O(\zÕ]ìZ¢èr~m»VlAÞ`›`BXDº¨ÍêÚ0ƒ•æÙ7ÂkH_Óæ¹Æ"ÏÙi{ßí·‚ùу$cñÀ`ùºRô“Â(gT ×^Ë¡ýys4Ó€Î,±O£PCò6è´ºøç*]=ˆ¶µïS˜ƒùxBƒ+ÚKÅè–fÕ“ŽQ'¿Ÿ\Ää5©Ãiê K(D’Ô¤~‰÷M»íZu¹Ì‚Þ m“4Á7 Ex éK9xø[äÍÑŒ‡´Ä>&•Ÿ]·Ö,Q˜Œmw;˜ Ä×Ϧ»ˆ^³BN뇻¾ý¦|ôÔ ?Bú#í×XÜ`ó +Íù< W‘^Õé›z£ß‚¡¹Ñ©¼þ%òæhÆV·–Ø;`jú–"ØRà…X4úXôš^ø
©ïðÏÀ›ÐÜ*ÌÖRO“§_l+Œ`Hr[;‰b[ÒïðWàýWFßáY0¢õåHO«»ÃÆ´‹â^UÌà¾)ý
æ„Ï~¦ýç–º2Qó ÍëwàBxésÚ¼–£u:Ìûú^«¦³_ö7 H¨¥cv„î÷iªUb{<ö\à›=‰èhW¢Óê¸õ#Ò)m·Ó£R,ýŽW äg—¾¯ý:·—è
š^¤|x¤È¨á¡âÝõFiÂÿ$ o#}[ª;š¹”ð.[áK”ØaÝÝÞZP0¥ ú„榺òýÌ¿BÞÍô3×—Ž„Hã2¸Õš¿_wÃ)ùFì_ƒáu¤¯kS}DdöÛµŠG[jwŸöÔxý_Qê6¼×á;ýùÿ7 Lhn/í“€ÇNC¸Yé/‹|WJѦŒ‰’~-ÿ&ö„æ–