diff --git a/DESCRIPTION b/DESCRIPTION index 966b1de..cd9105f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: pcalg -Version: 2.2-4 -Date: 2015-07-22 +Version: 2.4-2 +Date: 2016-09-21 Title: Methods for Graphical Models and Causal Inference Description: Functions for causal structure learning and causal inference using graphical models. The main algorithms @@ -18,10 +18,14 @@ Authors@R: c(person("Markus","Kalisch", person("Alain", "Hauser", role="aut"), person("Martin","Maechler", role="aut"), person("Diego", "Colombo", role="ctb"), person("Doris", "Entner", role="ctb"), person("Patrik","Hoyer", role="ctb"), person("Antti", "Hyttinen", role="ctb"), - person("Jonas", "Peters", role="ctb")) + person("Jonas", "Peters", role="ctb"), person("Nicoletta", "Andri", + role="ctb"), person("Emilija", "Perkovic", role="ctb"), person("Preetam", + "Nandy", role="ctb"), person("Philipp", "Ruetimann", role="ctb"), + person("Daniel", "Stekhoven", role="ctb"), person("Manuel", "Schuerch", role="ctb")) Author: Markus Kalisch [aut, cre], Alain Hauser [aut], Martin Maechler [aut], - Diego Colombo [ctb], Doris Entner [ctb], Patrik Hoyer [ctb], - Antti Hyttinen [ctb], Jonas Peters [ctb] + Diego Colombo [ctb], Doris Entner [ctb], Patrik Hoyer [ctb], Antti Hyttinen [ctb], + Jonas Peters [ctb], Nicoletta Andri [ctb], Emilija Perkovic [ctb], Preetam Nandy [ctb], + Philipp Ruetimann [ctb], Daniel Stekhoven [ctb], Manuel Schuerch [ctb] Depends: R (>= 3.0.2) LinkingTo: Rcpp (>= 0.11.0), RcppArmadillo, BH Imports: stats, graphics, utils, methods, abind, graph, RBGL, igraph, @@ -33,6 +37,6 @@ NeedsCompilation: yes Encoding: UTF-8 License: GPL (>= 2) URL: http://pcalg.r-forge.r-project.org/ -Packaged: 2015-07-22 14:53:53 UTC; maechler +Packaged: 2016-09-23 09:30:59 UTC; maechler Repository: CRAN -Date/Publication: 2015-07-23 09:21:52 +Date/Publication: 2016-09-26 16:47:02 diff --git a/MD5 b/MD5 index b720573..008ecb4 100644 --- a/MD5 +++ b/MD5 @@ -1,152 +1,162 @@ 1c213fc1c5a5ec68e7a5ba9293440dc3 *ChangeLog -72d5dbaaccf6f40326223c297b424933 *DESCRIPTION -bf71c6ddb1dc28860a71530ad66e32b8 *NAMESPACE -c0b16b9192154e0816f60ceeecb8af0f *R/Aaux.R -3a7fa47f867bd79a23e636e9973bc241 *R/AllClasses.R +0db7b58816246c6f934fdc99bbc296d7 *DESCRIPTION +6f25f81b0ff82b5c4480cb90eff1dde5 *NAMESPACE +66963591a11cfdb002f5da9070f1500b *R/Aaux.R +5085e29e474ce52b4ea5fba61d5ad003 *R/AllClasses.R +709461024e0516af39a962661e2930d0 *R/deprecated.R bced89250587ee3eb4e5f5d3ccd07ab5 *R/gacFuns.R -6cf1f4d57cc0a920202e33f569bdac9c *R/genRandDAG.R -adecf819751e0b4bcf9de72e7d04a51e *R/gies.R -344228236787b8a3077d47b355342423 *R/jointIda.R -ffc1ac4b18dd263fcb0827c32a13a900 *R/lingamFuns.R -9649f2e6c9dc6c64e4836aed0943103f *R/pcalg.R +c0958d3ffcf9909629cad0a5980d360e *R/genRandDAG.R +58ff7ce957f0898b51a036318336090f *R/gies.R +07eb0f8f0d9432e3119ab7276ba592b7 *R/jointIda.R +386ed9be1a524de90dfac185433b009a *R/lingamFuns.R +1c5c600c1da1e2d4d4c54163938e1cc7 *R/pcalg.R 9187a45035684cf827be71af16325d2c *R/sysdata.rda 0db1ba6d57801a4d8fc6cdf996384a4d *R/zzz.R -19c9e7d6ccdf444ff479c1f7b7dfd0af *TODO -1dac936791d77cf63c94e78a3394238f *cleanup +d599e23940bca0203504c0fa6b09e01c *TODO +a9c25c5402e9df15259511faa9d1a721 *build/vignette.rds +f832779eae511757a99906c7670fc0ad *cleanup 7cbe431a233e6c454e24f7b92d63fe75 *data/datalist 1d8d4c43b9cbb9dc9dd57acd59f565bf *data/gmB.rda 52ed0493e175a338c2f12cc1c48a9f9b *data/gmD.rda 0c04f895b0adb530c7e8d4c6c503a842 *data/gmG.rda 6d96fac64134a91ecf0c244b4679ec0f *data/gmI.rda -01ad6c01910806745a34c7bc963c41b5 *data/gmInt.rda +385d41164301819ce274673db8743fc9 *data/gmInt.rda 1b3a78b432a5e46b991f5ae5eb4b77f3 *data/gmL.rda 811a9708268fbddd317bbca12ef93a55 *inst/CITATION -bd5974c599f2a4e7e29fcbf4accceb67 *inst/NEWS.Rd -47990df286c898e8821e60370c0b1e13 *inst/doc/mkVignettes.R -48cfd14676c835cce888970ebfcfae42 *inst/doc/pcalgDoc.pdf +2f13a20f69511d72dd63f9212308bc80 *inst/NEWS.Rd +4e33425acbef8bf36705d8a75622baa8 *inst/doc/mkVignettes.R +aa0819d2bcfb83844ff80ef66eeeafa7 *inst/doc/pcalgDoc.R +43598f8f02fb3b909c846a048c7360c8 *inst/doc/pcalgDoc.Rnw +c0a99493e33669ed2931c73e1e1ef2bf *inst/doc/pcalgDoc.pdf cee0b4475c720bf58c466e1495451b22 *inst/external/N_6_1000.rds +0d84fdc119d76d992b72f9bdbd0e613d *inst/external/gac-pags.rds e7a2a9117d97986b2ab6afc6b4f77478 *inst/external/test_conservative_pc_data1.rda 4dfbe2a4e41dc556b8812667b60d3549 *inst/external/test_conservative_pc_data2.rda 3e26e3a9f5736c6c9a28b9b0f1c178b2 *inst/include/pcalg/armaLapack.hpp 46f3b404de08d10a7028379313d69645 *inst/include/pcalg/constraint.hpp -5d01d1dbd1642b958494993d44f0b9bb *inst/include/pcalg/gies_debug.hpp -121f5b1748a7dca6032dc088de662034 *inst/include/pcalg/greedy.hpp -0c55a7e4825cac7fb2a1476888e2ba82 *inst/include/pcalg/score.hpp +29805523b6262448b7f609df27b0316b *inst/include/pcalg/gies_debug.hpp +1b36cef2466481f026f8dc31652bd3ca *inst/include/pcalg/greedy.hpp +57138081b90580b3734d87999d6b84ab *inst/include/pcalg/score.hpp aa3405ae18b89d66c1a0315e0bdbccee *inst/xtraR/graph2ftmatrix.R 67d5c8bab6246e9245b352a245069a17 *man/EssGraph-class.Rd 146b7ce241783ddaa4627949ae1f370a *man/GaussL0penIntScore-class.Rd ece5fe7ddfabe25249bb40c57200fb42 *man/GaussL0penObsScore-class.Rd 84f4260988cdcfafadee14e0bbe56cc9 *man/GaussParDAG-class.Rd -1708a0c5f8182965f3a160e9606aaab3 *man/LINGAM.Rd +4c1a2c4b81350916099f7952358f9550 *man/LINGAM.Rd 4733da421bc6790c136557833a08b0dc *man/ParDAG-class.Rd -7a629ea5557abb54fb86a81ae1659240 *man/Score-class.Rd -a20229f00ff57a30a20bf22c81c2522a *man/backdoor.Rd +84fcdb8aca0888d4a312f23d1c9ca46c *man/Score-class.Rd +8a41e2a67114f073aef8388fdf316531 *man/amatType.Rd +c78468dcaee10246f1e5370905773cfe *man/backdoor.Rd 6feb25e396846cbb7c1fc4de8d7e2eaa *man/beta.special.Rd e5e54569fa1222405f18ee7c189b68cd *man/beta.special.pcObj.Rd 25029c568795bdac3d6f3b8e9e05326a *man/binCItest.Rd -985ad15e7c9d156d03ad9b58436c4e5d *man/checkTriple.Rd +966d0b8af075b8f40c5f1021abb41f67 *man/checkTriple.Rd 4b0dfb506510f7cf16ebc7e3e6fb6339 *man/compareGraphs.Rd -3c683afce27467e33642cb17d6ba5156 *man/condIndFisherZ.Rd -1db62c3d0a3767bfbc1107a2b7bde1dc *man/corGraph.Rd -b56f2c964ee246d2f91dd4c5a3d526e5 *man/dag2cpdag.Rd -f5bb502b04b5243c0f1a715c35205d15 *man/dag2essgraph.Rd +297092d27f80a859b5d89a49a54926d1 *man/condIndFisherZ.Rd +b2ded6b2c0cd2cf0c30b845d07646736 *man/corGraph.Rd +f320034a84ee39090a1bf0596532772c *man/dag2cpdag.Rd +e57b4c2a4aec589210e386b72c2333fd *man/dag2essgraph.Rd 9825306a115fb2370a8bf8d481284983 *man/dag2pag.Rd 4e804b480585e6a4d57b1ac0f6100760 *man/disCItest.Rd -9b098d0a60f3a3aad11eae3f582995aa *man/dreach.Rd +3d880e7f58fe68731e9ed4ecb4c13bf4 *man/dreach.Rd e89cc00623c136f141b0427a7476889a *man/dsep.Rd -489e0cd6d854d9915368baa1803ff990 *man/dsepTest.Rd -305e579276cbc7133576a3175e81b01f *man/fci.Rd -e0951363e609e9b1827b03fc3b9cedbe *man/fciAlgo-class.Rd -d2d67c5c2f232189a81ce6177a834577 *man/fciPlus.Rd -6c654742667b21e8c40e43ccda32a229 *man/find.unsh.triple.Rd +3c0924e854ffc20b168281b2380d9b61 *man/dsepTest.Rd +771fa91efa266d4ffcb1818077481a4f *man/fci.Rd +4210c617d4929290e295ced5e0eeeb43 *man/fciAlgo-class.Rd +7fb4c8797b23d3d73252beee2610d45f *man/fciPlus.Rd +44127d2a6a6234ed84cf650a3273e504 *man/find.unsh.triple.Rd efed404b8bbbd6700520e6587d65d4ac *man/gAlgo-class.Rd -c02e1c7a066c595f58a6579c9f7bbd4a *man/gac.Rd -730b0cfa6bf222f070fabba144266d35 *man/gds.Rd -bb85025474a5b643644d9ab5aef842c0 *man/ges.Rd +6a4c08062ceace6c18475cdbe3537a17 *man/gac.Rd +cb526c1eceaf53b0239c888ecbbdbbaf *man/gds.Rd +a30b09aa0afd2979e7bda56aa6e64224 *man/ges.Rd fdc0ad5d17fff5f2c8734504041af969 *man/getGraph.Rd f7e5c22255b62a23431b08c2d3080b66 *man/getNextSet.Rd -187eb5ab007e8552c53e1becc80011df *man/gies.Rd +af8d2172db60544ae8e42676de890378 *man/gies.Rd cbb33c4976caf365b69cb9c76a7a493e *man/gmB.Rd 5d6bd5e0a6ddce6b8b4dae1dc02bd26c *man/gmD.Rd bfbfa5083afa919d56c211768f8b2d77 *man/gmG.Rd 66a7855809f1fd6e9a0ced7dbd612af6 *man/gmI.Rd 6a624691a6a19dd55526a9e9585ce0b3 *man/gmInt.Rd 0fc0725cd27113dfa0505deb9504b3ec *man/gmL.Rd -e249a045741380bb24994f464ce9e124 *man/ida.Rd -b1f8449bbf5fa4afbad9576ca94608f6 *man/idaFast.Rd +5ee7f4d28bc6ff22f49637600dd6c8d5 *man/ida.Rd +7aa46e96c96d02d55e876f3d52c2d5d7 *man/idaFast.Rd 90a088350b43454d621b4b315ab3d2cf *man/iplotPC.Rd -58b13b54e3cb4c41c9973acbb894602b *man/jointIda.Rd -57676fbcb3aa706227b17ad21f67ae3d *man/legal.path.Rd -1e5c083539584525a62b4f0cd478f60d *man/mat2targets.Rd +50527fcf426515db143b7ce841138a39 *man/jointIda.Rd +240d9c697a86a1aad34a623a487d3f5e *man/legal.path.Rd +7c28e6a542763fa65c25784a96d32e1f *man/mat2targets.Rd cd8a6e38249822fc7c54c66b96a6a967 *man/mcor.Rd -acc07ba5a8ab44b3e4a1d7130541cc27 *man/pag2mag.Rd -7c357eb02d8560fe13492af42276564f *man/pc.Rd -2ae695c62f2c7831eb2595a8f569e602 *man/pc.cons.intern.Rd -0a89d7e11b03c0b0580f70cdf0103deb *man/pcAlgo-class.Rd +67426f4203b1334a56a8715423083745 *man/pag2mag.Rd +7087d3196d5864e45e7e2a4099a2f44b *man/pc.Rd +01d980deb40fe93c7e3c2f5039882f9d *man/pc.cons.intern.Rd +3602e10d2bc8dd7eba856c8c516e4b57 *man/pcAlgo-class.Rd 143110b2d6797b5ef727a5c05d2790f8 *man/pcAlgo.Rd ead3182858e088744ab17467c15b2211 *man/pcSelect.Rd ef7c030654d7a92a9664076d2a0eac5f *man/pcSelect.presel.Rd da2af80714506529ddd6beba2a0f9730 *man/pcalg-internal.Rd -88cd7178faf6a1f8ab04ba0e74f24e0b *man/pcorOrder.Rd +69e62cafe0cebc0d0d4faac5ad06408e *man/pcorOrder.Rd +800c3348670b4ca01c406d5e5d67839c *man/pdag2allDags.Rd 208807c0c6b5ead3e89f414adc9136c1 *man/pdag2dag.Rd -300bfb3daac73f63c1eb49bfb6394626 *man/pdsep.Rd +455c45697da640068f415fa95e9d0f79 *man/pdsep.Rd 89b20dd90d54188d453dde9d8ca13d07 *man/plotAG.Rd -653d3378964e4452b39b37b5232e0710 *man/plotSG.Rd -2bbb8c781e491ab934fb63c8d2a5bce4 *man/possibleDe.Rd -44721d7643ca55ffcad06065550a51b0 *man/qreach.Rd +cd2ff5db948044a7784ca18d5b9e7562 *man/plotSG.Rd +fef9da909abe58d5e9f0831235db6cc4 *man/possibleDe.Rd +5782fc04b6408ebfc706d4d43d232fb1 *man/qreach.Rd d0196c418afe2af7c6bf89cd2a5d18e5 *man/r.gauss.pardag.Rd -d50b953ca9aeab50d864e88725eab49b *man/randDAG.Rd +31eca391a909dfc4cc61d91b10e40128 *man/randDAG.Rd d28b8fbb54c9bdd378363a74325fcb8a *man/randomDAG.Rd -98dbfb7e8b5ad7a813ee70b3105ac1fd *man/rfci.Rd +126a7ce6f483d58ce9e17bcb7cf81b49 *man/rfci.Rd d6eb86a8b2f04f416a59792f35cdaa2c *man/rmvDAG.Rd 27ab6d09110842495dd1b29fc14f1543 *man/rmvnorm.ivent.Rd 727b7b67d395b6f78abc4c3a55861382 *man/shd.Rd -e7e9595f3b10daac9dff67ee6ee2f3c3 *man/showAmat.Rd +f9e8f9a3f798f74875efa4e6834ddf67 *man/showAmat.Rd 146a479ea21765cd4b39a6c9023537e5 *man/showEdgeList.Rd -91bae38a853c228f88238ce3702d9e34 *man/simy.Rd -ebe7d3e6502076c8227ea3d9d415823d *man/skeleton.Rd +1c97ce27a92eb4ee8e87365904cd4106 *man/simy.Rd +aa5ef5fcc6669f7fe4e7c71cbc977dff *man/skeleton.Rd 1fd827271a88b3c218d7a4fec743fb7e *man/trueCov.Rd -6f6dbe29cd159577461509d101631c3a *man/udag2apag.Rd -3fd1dadc6b742137aece64afd2675bb0 *man/udag2pag.Rd -f5433522bb64ffd4623fb43817d5e06d *man/udag2pdag.Rd -336bd3f58604f1455e50ab4bffab4294 *man/unifDAG.Rd -0cbd2940967c142e025833d646b83053 *man/visibleEdge.Rd +6cf72cedd7cb73647586c65753dbd68f *man/udag2apag.Rd +15de4fbe76e6800999fcc014adf3bd21 *man/udag2pag.Rd +3f19bdfb286f52acc97cc8f985cd02af *man/udag2pdag.Rd +7d946c76d88711cd0313b051923d728f *man/unifDAG.Rd +abddab27448a30a0f87aea03c467e0ee *man/visibleEdge.Rd 0c704ef6f6822e7ec9dca44b4676eb9f *man/wgtMatrix.Rd 552b72ff784732d0a19ca3971a757291 *src/Makevars -c0b0045ea1c93212805e2221a2430419 *src/Makevars.win -0f0107546301dbbf5d84c3c73f0ba6be *src/constraint.cpp -906bf4e048d48761bbba140dd143d74e *src/gies.cpp -98afb8dfa2fd02134507511c207b72ad *src/greedy.cpp -0c404ef330cd447453260446f898a97d *src/score.cpp +0a42f766b2298588b51663ee586508d7 *src/Makevars.win +2ced878a9b224e806d51885fafbfa64d *src/constraint.cpp +fa352940accd184b6599e5e52609f8d1 *src/gies.cpp +e3db3f776260f352929fbe85b5000b5b *src/greedy.cpp +bc5cab68e323949bed42d3d87b68e5a2 *src/score.cpp 83187ba1f22cdb1b239e07027ddf489a *tests/discr100k.rda -f417aa1bd7c3493e07dcf7f9e2a021ff *tests/gacData.rda -f05a0e067c31279e29a2ad4101293589 *tests/test_LINGAM.R +e55f723241bfbf463ec914b2bcc694d0 *tests/test_LINGAM.R 3e75e91dc9507a780c188cd62c65636b *tests/test_amat2dag.R +f42c5cdb181390a941302634ad7080aa *tests/test_arges.R 886fbfd89fe8a61662163fa2df73ed98 *tests/test_backdoor.R 22798bd30fcb6cead206e33e37ee0005 *tests/test_backdoor.Rout.save -a04391fee2aff151ea84e39b43d6626f *tests/test_bicscore.R +7e1885e05cb8aa0014656e5da038fa7c *tests/test_bicscore.R 68d7fc06c8751108a3f33af93956220e *tests/test_bicscore.rda 319ad79c662ff38c00230095cb0ed7f5 *tests/test_causalEffect.R 34e640c8ea2bd339b3de3a165ee9e693 *tests/test_compareGraphs.R 8227eb269c25cb458eb571ccd1550ed1 *tests/test_dag2cpdag.R +ac433f470680b808ba31c6af0630b995 *tests/test_dag2essgraph.R +6ce990fb8ff052b09c27abe59affb678 *tests/test_displayAmat.R e11611f462df230cc44fc3571c714a87 *tests/test_dsep.R 89771d8a241abec27b4a3aaa729c1cd0 *tests/test_fci.R 580f7daaaf9136c97c4996442472fd09 *tests/test_fciPlus.R 5616660b37eb067761dfcd31c0251dc8 *tests/test_gSquareBin.R 254a3313c718ccb259af7da4170560ce *tests/test_gSquareDis.R -ae7d1151cae52ac33c9565d5765e8c04 *tests/test_gac.R -62df22839190befd25174cf3d6b7291e *tests/test_getNextSet.R -62581bba936e7119efac49ddd4dc6cbe *tests/test_gies.R +a61f759b18b2ab67fd7d5270bb796028 *tests/test_gac.R +c485aeb5ea3b876b560961245eefeef5 *tests/test_getNextSet.R +51842251933a1ec6a71f0dff0a86e25a *tests/test_gies.R 026eda288c19708953516ee13b1ee8e0 *tests/test_ida.R a1e602bf613715d98720c97fd1f33508 *tests/test_idaFast.R fa03439e1ca384721d7437519216d75e *tests/test_jointIda.R -42946d1b228bfe3aefc8e8f0326dbf18 *tests/test_mat2targets.R +36698c5a2890cba1dc1998623a1a8ede *tests/test_mat2targets.R cd913f44dcba8673b0839dc90c1772c5 *tests/test_pc.R -5bc4f47a900d94f0d39b7d8aec54e215 *tests/test_pcSelect.R +88820e832f56e6714216c8aed404fd2c *tests/test_pcSelect.R ecaacf0c68bf72d9d96eeeeffd824357 *tests/test_pcorOrder.R +67fbdda0dd8ab5f4fbd185ee85916d12 *tests/test_pdag2allDags.R 76fd1ade1f75af8bbdcc8d88b655fbdc *tests/test_pdag2dag.R -1703ad3e6c39b3db6066fdf3038b27cf *tests/test_randDAG.R -80b2fbd129b4dc711c790ccc559a6247 *tests/test_randDAG.Rout.save +9892d6cb3e3135fd456e84068b39eaa8 *tests/test_randDAG.R +f1f854473da4d9e5245b1bade561acf7 *tests/test_randDAG.Rout.save aee8ad2108a151b25666eaf0ed1b4205 *tests/test_randomDAG.R ff3c8f14106ff1abd140b6bd018dec50 *tests/test_rfci.R 7853e03d1c258ed44b17debd5812ac71 *tests/test_rmvDAG.R @@ -159,4 +169,4 @@ cd40b46d3274a112953423a19f78d4c4 *tests/test_wgtMatrix.R 35fe720fff87739bb6b7bfe79d204d33 *vignettes/Figure2FAT.pdf f930246d4cfb62c9d2fb0d954be5042d *vignettes/Mybib.bib b9564ddd59a06782310989e8f33db55e *vignettes/jsslogo.jpg -5d1cffaf8fa0e09882b92d5f6c5f95ee *vignettes/pcalgDoc.Rnw +43598f8f02fb3b909c846a048c7360c8 *vignettes/pcalgDoc.Rnw diff --git a/NAMESPACE b/NAMESPACE index 587ced2..f9cefed 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,7 +11,7 @@ importFrom("utils", combn, str) importFrom("graphics", par, plot.default, plot, title) -## try to import all we need, but not more +importMethodsFrom("methods", coerce, show) importFrom("methods", setClass, setClassUnion, setMethod, setOldClass, setValidity, getClass, getClassDef, callGeneric, as, is, extends, @@ -132,15 +132,18 @@ export(trueCov, gds, simy, mat2targets, - # targets2mat, + targets2mat, dag2essgraph, ## --- end{Alain} fciPlus, - LINGAM, + lingam, LINGAM, randDAG, unifDAG, unifDAG.approx, - gac) + gac, + ## no longer: use as(*,"amat") + ## displayAmat, + pdag2allDags) ## These are "internal" i.e., in man/pcalg-internal.Rd ## _FIXME ?_ --------------------- @@ -173,7 +176,12 @@ exportClasses("pcAlgo", "GaussL0penObsScore", "EssGraph") -exportMethods("summary", "show", "plot") +exportMethods(# needed? "coerce",# <- defined via setAs(., ..) used via as(A, "class_B") + "summary", "show", "plot") S3method(print, fciAlgo) +S3method(print, pcAlgo) +S3method(print, amat) +## FIXME: TODO +# S3method(print, LINGAM) diff --git a/R/Aaux.R b/R/Aaux.R index 5e9a1b0..d268fd2 100644 --- a/R/Aaux.R +++ b/R/Aaux.R @@ -16,6 +16,47 @@ log.q1pm <- function(r) log1p(2*r/(1-r)) +## MM: "Lifted" from Matrix package ~/R/Pkgs/Matrix/R/Auxiliaries.R +## "Theory" behind this: /u/maechler/R/MM/MISC/lower-tri-w.o-matrix.R +indTri <- function(n, upper = TRUE, diag = FALSE) { + ## Indices of (strict) upper/lower triangular part + ## == which(upper.tri(diag(n), diag=diag) or + ## which(lower.tri(diag(n), diag=diag) -- but + ## more efficiently for largish 'n' + stopifnot(length(n) == 1, n == (n. <- as.integer(n)), (n <- n.) >= 0) + if(n <= 2) { + if(n == 0) return(integer(0)) + if(n == 1) return(if(diag) 1L else integer(0)) + ## else n == 2 + v <- if(upper) 3L else 2L + return(if(diag) c(1L, v, 4L) else v) + } + + ## n >= 3 [also for n == 2 && diag (==TRUE)] : + + ## First, compute the 'diff(.)' of the result [fast, using integers] + n. <- if(diag) n else n - 1L + n1 <- n. - 1L + ## all '1' but a few + r <- rep.int(1L, choose(n.+1, 2) - 1) + tt <- if(diag) 2L else 3L + r[cumsum(if(upper) 1:n1 else n.:2)] <- if(upper) n:tt else tt:n + ## now have differences; revert to "original": + cumsum(c(if(diag) 1L else if(upper) n+1L else 2L, r)) +} + +##' Count Edges, for directed graphs, *not* as numEdges(g) +##' but such that "<-->" or "<--o" ... counts as 1 +##' (for undirected graphs, this is the same as numEdges(.)) +numGedges <- function(amat) { + dimnames(amat) <- NULL # speed + A <- (amat + t(amat)) != 0 + n <- nrow(A) + if(n <= 40) ## faster + sum(A[lower.tri(A)]) + else + sum(A[indTri(n)]) +} check.Rgraphviz <- function() { if(!requireNamespace("Rgraphviz")) diff --git a/R/AllClasses.R b/R/AllClasses.R index 778a8ac..4d109a4 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -2,25 +2,24 @@ ### Part 1 : S4 classes used by pc and r/fci ################################################## -## $Id: AllClasses.R 342 2015-07-22 14:26:29Z mmaechler $ +## $Id: AllClasses.R 402 2016-09-22 07:54:59Z mmaechler $ setClass("gAlgo", - representation(call = "call", + slots = c(call = "call", n = "integer", max.ord = "integer", n.edgetests= "numeric", sepset= "list", - pMax= "matrix"), "VIRTUAL") + pMax= "matrix"), + contains = "VIRTUAL") -setClass("fciAlgo", - representation(amat = "matrix", allPdsep = "list", - n.edgetestsPDSEP = "numeric", max.ordPDSEP = "integer"), - contains = "gAlgo") +setClass("fciAlgo", contains = "gAlgo", + slots = c(amat = "matrix", allPdsep = "list", + n.edgetestsPDSEP = "numeric", max.ordPDSEP = "integer")) -setClass("pcAlgo", - representation(graph = "graph", zMin = "matrix"), ## zMin for compatibility - contains = "gAlgo") +setClass("pcAlgo", contains = "gAlgo", + slots = c(graph = "graph", zMin = "matrix")) ## zMin for compatibility ## Methods @@ -34,71 +33,127 @@ if(FALSE) {## if we would importFrom("Matrix", ....) in NAMESPACE setMethod("getGraph", "pcAlgo", function(x) x@graph) setMethod("getGraph", "fciAlgo", function(x) as(x@amat, "graphAM")) +setOldClass("amat")# our Adjacency Matrics -- are S3 classes (but want some S4 methods) + +##' as(*, "matrix") methods --- give the adjacency matrices with a "type" attribute +##' as(*, "amat") methods --- adjacency matrix class "amat" with a "type" attribute +setAs("pcAlgo", "matrix", + function(from) structure(wgtMatrix(from@graph), type = "amat.cpdag")) +setAs("pcAlgo", "amat", + function(from) structure(wgtMatrix(from@graph), class = "amat", type = "cpdag")) + +setAs("fciAlgo", "matrix", + function(from) structure(from@amat, type = "amat.pag")) +setAs("fciAlgo", "amat", + function(from) structure(from@amat, class = "amat", type = "pag")) + + +##' auxiliary, hidden +show.pc.amat <- function(amat, zero.print, ...) { + cat("\nAdjacency Matrix G:\n") + print.table(amat, zero.print=zero.print, ...) +} + +##' auxiliary, hidden +show.fci.amat <- function(amat, zero.print, ...) { + cat("\nAdjacency Matrix G:", + "G[i,j] = 1/2/3 if edge mark of edge i-j at j is circle/head/tail.", + "", sep="\n") + print.table(amat, zero.print=zero.print, ...) +} + +print.amat <- function(x, zero.print = ".", ...) { + stopifnot(is.character(typ <- attr(x, "type")), length(typ) == 1, + is.matrix(x), (d <- dim(x))[1] == d[2]) + cat(sprintf("Adjacency Matrix 'amat' (%d x %d) of type %s:\n", + d[1], d[2], sQuote(typ))) + ## TODO: if dimension is too large, e.g. use Matrix::printSpMatrix2(x) + print.table(x, zero.print=zero.print, ...) + invisible(x) +} + setMethod("summary", "pcAlgo", - function(object) { - cat("\nObject of class 'pcAlgo', from Call: \n", - deparse(object@call), - "\n\nNmb. edgetests during skeleton estimation:\n") + function(object, amat = TRUE, zero.print = ".", ...) { + cat("Object of class 'pcAlgo', from Call:\n", + paste(deparse(object@call), sep = "\n", collapse = "\n"), + "\n\nNmb. edgetests during skeleton estimation:\n", sep = "") cat("===========================================\n") - cat("Max. order of algorithm: ",object@max.ord, - "\nNumber of edgetests from m = 0 up to m =",object@max.ord, - ": ",object@n.edgetests) - nbrs <- vapply(object@graph@edgeL, function(x) length(x$edges), 1L) + cat("Max. order of algorithm: ", object@max.ord, + "\nNumber of edgetests from m = 0 up to m =", object@max.ord, + ": ", object@n.edgetests) + g <- object@graph + nbrs <- vapply(g@edgeL, function(x) length(x$edges), 1L) cat("\n\nGraphical properties of skeleton:\n") cat("=================================\n") cat("Max. number of neighbours: ", max(nbrs), "at node(s)", which(nbrs==max(nbrs)), - "\nAvg. number of neighbours: ",mean(nbrs),"\n") + "\nAvg. number of neighbours: ", mean(nbrs),"\n") + if(amat) + show.pc.amat(as(g, "matrix"), zero.print=zero.print) }) setMethod("summary", "fciAlgo", - function(object) { - cat("Object of class 'fciAlgo'\n\n") - cat("Call: \n=====\n", deparse(object@call)) - cat("\n\nNmb. edgetests during skeleton estimation:\n==========================================") - cat("\nMax. order of algorithm: ",object@max.ord, - "\nNumber of edgetests from m = 0 up to m =",object@max.ord, - ": ",object@n.edgetests) - cat("\n\nAdd. nmb. edgetests when using PDSEP:\n=====================================") - cat("\nMax. order of algorithm: ",object@max.ordPDSEP, - "\nNumber of edgetests from m = 0 up to m =",object@max.ordPDSEP, - ": ",object@n.edgetestsPDSEP) - - myLength <- function(x) if(is.null(x)) NA_integer_ else length(x) - cat("\n\nSize distribution of SEPSET:") - myTab <- table(sapply(object@sepset, - function(x) vapply(x, myLength, 1L)), - useNA = "always") - print(myTab) - - cat("\nSize distribution of PDSEP:") - print(table(vapply(object@allPdsep, length, 1L))) - }) - - -setMethod("show", "pcAlgo", - function(object) { - cat("Object of class 'pcAlgo', from Call: \n", deparse(object@call),"\n") - amat <- as(object@graph, "matrix") - amat2 <- amat + 2*t(amat) - ude <- sum(amat2 == 3)/2 - de <- sum(amat2 == 1) - cat("Number of undirected edges: ", ude, "\n") - cat("Number of directed edges: ", de, "\n") - cat("Total number of edges: ", de + ude, "\n") - invisible(object) + function(object, amat = TRUE, zero.print = ".", ...) { + cat("Object of class 'fciAlgo', from Call:\n", + paste(deparse(object@call), sep = "\n", collapse = "\n"), sep="") + ## NB: fciPlus() result has *none* of these {apart from adj.mat}: + if(length(o.max <- object@max.ord)) { + cat("\n\nNmb. edgetests during skeleton estimation:\n", + "===========================================\n", sep="") + cat("Max. order of algorithm: ", o.max, + "\nNumber of edgetests from m = 0 up to m =", o.max, + ": ", object@n.edgetests) + } + if(length(o.maxP <- object@max.ordPDSEP)) { + cat("\n\nAdd. nmb. edgetests when using PDSEP:\n=====================================") + cat("\nMax. order of algorithm: ", o.maxP, + "\nNumber of edgetests from m = 0 up to m =", o.maxP, + ": ", object@n.edgetestsPDSEP) + } + if(length(object@sepset)) { + myLength <- function(x) if(is.null(x)) NA_integer_ else length(x) + cat("\n\nSize distribution of SEPSET:") + myTab <- table(sapply(object@sepset, + function(x) vapply(x, myLength, 1L)), + useNA = "always") + print(myTab) + } + if(length(object@allPdsep)) { + cat("\nSize distribution of PDSEP:") + print(table(vapply(object@allPdsep, length, 1L))) + } + ## + if(amat) + show.fci.amat(object@amat, zero.print=zero.print) }) -print.fciAlgo <- function(x, zero.print = ".", ...) { - cat("Object of class 'fciAlgo', from Call:", deparse(x@call), - "\nAdjacency Matrix G:", - "G[i,j] = 1/2/3 if edge mark of edge i-j at j is circle/head/tail.", - "", sep="\n") - print.table(x@amat, zero.print=zero.print, ...) +print.pcAlgo <- function(x, amat = FALSE, zero.print = ".", ...) { + cat("Object of class 'pcAlgo', from Call:\n", + paste(deparse(x@call), sep = "\n", collapse = "\n"), + "\n", sep="") + A <- as(x@graph, "matrix") + if(amat) + show.pc.amat(A, zero.print=zero.print, ...) + amat2 <- A + 2*t(A) + ude <- sum(amat2 == 3)/2 + de <- sum(amat2 == 1) + cat("Number of undirected edges: ", ude, "\n") + cat("Number of directed edges: ", de, "\n") + cat("Total number of edges: ", de + ude, "\n") invisible(x) } +setMethod("show", "pcAlgo", function(object) print.pcAlgo(object)) + +print.fciAlgo <- function(x, amat = FALSE, zero.print = ".", ...) { + cat("Object of class 'fciAlgo', from Call:\n", + paste(deparse(x@call), sep = "\n", collapse = "\n"), + "\n", sep="") + if(amat) + show.fci.amat(x@amat, zero.print=zero.print, ...) + invisible(x) +} setMethod("show", "fciAlgo", function(object) print.fciAlgo(object)) ## -> ../man/pcAlgo-class.Rd @@ -150,28 +205,29 @@ setMethod("plot", signature(x = "fciAlgo"), g <- as(amat,"graphNEL") nn <- nodes(g) p <- numNodes(g) - n.edges <- numEdges(g) - ah.list <- at.list <- rep("none",n.edges) - counter <- 0 - list.names <- NULL - amat[amat==1] <- "odot" - amat[amat==2] <- "normal" - amat[amat==3] <- "none" + ## n.edges <- numEdges(g) -- is too large: + ## rather count edges such that "<-->" counts as 1 : + n.edges <- numGedges(amat) + ahs <- ats <- rep("none", n.edges) + nms <- character(n.edges) + cmat <- array(c("0" = "none", "1" = "odot", + "2" = "normal", "3" = "none")[as.character(amat)], + dim = dim(amat), dimnames = dimnames(amat)) + iE <- 0L for (i in seq_len(p-1)) { + x <- nn[i] for (j in (i+1):p) { - x <- nn[i] y <- nn[j] - if (amat[x,y]!=0) { - counter <- counter + 1 - ah.list[[counter]] <- amat[x,y] - at.list[[counter]] <- amat[y,x] - list.names <- c(list.names,paste(x,"~",y,sep="")) + if (amat[x,y] != 0) { + iE <- iE + 1L + ahs[[iE]] <- cmat[x,y] + ats[[iE]] <- cmat[y,x] + nms[[iE]] <- paste0(x,"~",y) } } } - names(ah.list) <- names(at.list) <- list.names - edgeRenderInfo(g) <- list(arrowhead= ah.list, - arrowtail= at.list) + names(ahs) <- names(ats) <- nms + edgeRenderInfo(g) <- list(arrowhead = ahs, arrowtail = ats) ## XXX Sep/Oct 2010 --- still current -- FIXME ?? ## XXX undid change by MM, since edge marks didn't work anymore ## XXX "known bug in Rgraphviz, but not something they may fix soon" @@ -183,6 +239,193 @@ setMethod("plot", signature(x = "fciAlgo"), ### Part 2 : Reference classes and Methods used by GIES ####################################################### +#' Auxiliary function bringing targets in a standard format. +#' +#' At the same time, the function checks if the targets are valid; if not, +#' it throws an exception. +#' +#' @param p number of vertices +#' @param targets list of (unique) targets +#' @param target.index vector of target indices, or NULL +#' @return depends on arguments: +#' if target.index == NULL: list of sorted targets +#' if target.index != NULL: list with two entries, "targets" and "target.index" +.tidyTargets <- function(p, targets, target.index = NULL) { + stopifnot((p <- as.integer(p)) > 0) + + # Check and convert targets + if (!is.list(targets) || !all(sapply(targets, is.numeric))) { + stop("Argument 'targets' must be a list of integer vectors.") + } + rawTargets <- lapply(targets, function(v) unique(sort(as.integer(v)))) + targets <- unique(rawTargets) + if (length(targets) < length(rawTargets)) { + stop("List of targets must be unique.") + } + allTargets <- unlist(targets) + if (length(allTargets) > 0) { + if (any(is.na(allTargets))) { + stop("Argument 'targets' must not contain NAs.") + } + min.max <- range(allTargets) + if (min.max[1] <= 0 || min.max[2] > p) { + stop("Targets are out of range.") + } + } + + # Check validity of target index, if provided + if (!is.null(target.index)) { + if (!is.numeric(target.index)) { + stop("Argument 'target.index' must be an integer vector.") + } + target.index <- as.integer(target.index) + min.max <- range(target.index) + if (min.max[1] <= 0 || min.max[2] > length(targets)) { + stop("Target index is out of range.") + } + # target.index <- match(rawTargets, targets)[target.index] + } + + # Return value + if (is.null(target.index)) { + targets + } else { + list(targets = targets, target.index = target.index) + } +} + +#' Create a list of targets and a vector of target indices out of a +#' matrix indicating interventions +#' +#' @param A a n x p boolean matrix; A[i, j] is TRUE iff vertex j is intervened +#' in data point i +#' @return list with two entries, "targets" and "target.index". +#' targets is a list of unique intervention targets +#' target.index is a vector of size n; the intervention target of data point +#' i is given by targets[[target.index[i]]]. +mat2targets <- function(A) +{ + stopifnot(is.matrix(A) && is.logical(A) && all(dim(A) > 0)) + + targets.raw <- as.list(apply(A, 1, which)) + targets <- unique(targets.raw) + list(targets = targets, target.index = match(targets.raw, targets)) +} + +#' Create a boolean "intervention matrix" out of a list of targets +#' and a vector of target indices. Can be seen as the "inverse function" +#' of "mat2targets" +#' +#' @param p number of vertices +#' @param targets list of (unique) targets +#' @param target.index vector of target indices +targets2mat <- function(p, targets, target.index) +{ + ## Check validity of targets : targetList <- + .tidyTargets(p, targets, target.index) + + res <- matrix(FALSE, nrow = length(target.index), ncol = p) + for (i in seq_along(target.index)) + res[i, targets[[target.index[i]]]] <- TRUE + res +} + +#' Auxiliary function reading an edge list (as used in the constructors +#' of DAGs) out of an adjacency matrix or a graphNEL object +#' @param from adjacency matrix, graphNEL object, or object inherited +#' from ParDAG +#' @return list of in-edges; length of list = number of vertices, +#' entries for i-th vertex = indices sources of in-edges +inEdgeList <- function(from) +{ + if (is.matrix(from)) { + p <- nrow(from) + stopifnot(p == ncol(from)) + lapply(1:p, function(i) which(from[, i] != 0)) + } else if (class(from) == "graphNEL") { + nodeNames <- graph::nodes(from) + edgeList <- lapply(graph::inEdges(from), function(v) match(v, nodeNames)) + names(edgeList) <- NULL + edgeList + } else if (length(grep(".*ParDAG", class(from)) == 1)) { + from$.in.edges + }else { + stop(sprintf("Input of class '%s' is not supported.", class(from))) + } +} + +# TODO: for all reference classes, make sure the constructor also works +# without arguments; or find another way to make the $copy() method work... +# (The default implementation of the $copy() method calls the constructor +# without arguments) + +#' Virtual base class for all causal models +setRefClass("CausMod", + fields = list( + .nodes = "vector", + .in.edges = "list", + .struct.eqn = "list"), + + validity = function(object) { + ## Check node names + if (anyDuplicated(object$.nodes)) { + return("The node names must be unique") + } + + ## Check in-edges + if (!all(sapply(object$.in.edges, is.numeric))) { + return("The vectors in 'in.edges' must contain numbers.") + } + if (!all(unique(unlist(object$.in.edges)) %in% 1:object$node.count())) { + return(sprintf("Invalid edge source(s): edge sources must be in the range 1:%d.", + object$node.count())) + } + + return(TRUE) + }, + + methods = list( + #' Constructor + initialize = function(nodes, in.edges = NULL, struct.eqn = list()) { + .nodes <<- nodes + + if (is.null(in.edges)) { + .in.edges <<- replicate(length(nodes), integer(0), simplify = FALSE) + } else { + .in.edges <<- lapply(in.edges, as.integer) + } + + .struct.eqn <<- struct.eqn + }, + + #' Yields the number of nodes + node.count = function() { + length(.nodes) + }, + + #' Yields the total number of edges in the graph + edge.count = function() { + sum(sapply(.in.edges, length)) + }, + + #' Simulates (draws a sample of) interventional (or observational) data + simulate = function(n, target = integer(0), int.level = numeric(0)) { + stop("simulate() is not implemented in this class.") + }, + + #' Fits the structural equations using a scoring object + #' + #' @param score a scoring object compatible with the causal model + #' @param method to be implemented in derived classes; can be used + #' to specify the estimation method, e.g. "ML" or + #' similar + #' @return no value returned; the fitting objects are stored in .struct.eqn + fit = function(score, method = "default") { + .struct.eqn <<- score$global.fit(.self, method = method) + } + ), + contains = "VIRTUAL") + ##' Virtual base class for all parametric causal models. ##' The meaning of the "params" depends on the model used. setRefClass("ParDAG", @@ -194,8 +437,8 @@ setRefClass("ParDAG", validity = function(object) { if (anyDuplicated(object$.nodes)) return("The node names must be unique") - if (any(names(object$.in.edges) != object$.nodes)) - return("The elements of 'in.edges' must be named after the nodes.") + # if (any(names(object$.in.edges) != object$.nodes)) + # return("The elements of 'in.edges' must be named after the nodes.") if (!all(sapply(object$.in.edges, is.numeric))) return("The vectors in 'in.edges' must contain numbers.") @@ -212,11 +455,16 @@ setRefClass("ParDAG", initialize = function(nodes, in.edges = NULL, params = list()) { .nodes <<- nodes - if (is.null(in.edges)) + if (is.null(in.edges)) { .in.edges <<- replicate(length(nodes), integer(0), simplify = FALSE) - else + } else { .in.edges <<- lapply(1:length(in.edges), function(i) as.integer(in.edges[[i]])) - names(.in.edges) <<- nodes + } + # names(.in.edges) <<- nodes + names(.in.edges) <<- NULL + for (i in 1:length(nodes)) { + names(.in.edges[[i]]) <<- NULL + } .params <<- params }, @@ -231,28 +479,50 @@ setRefClass("ParDAG", sum(sapply(.in.edges, length)) }, + #' Yields the variable types. + #' Function must be overridden in inherited classes! + #' + #' @param vertex vector of indices of the vertices for which the + #' variable types should be reported. If vertex == NULL, the types of + #' all variables are returned. + var.type = function(vertex = NULL) { + stop("var.type() is not implemented in this class.") + }, + + #' Yields the levels of the factor variables. + #' Function must be overridden in inherited classes! + #' + #' @param vertex vector of indices of the vertices for which the + #' variable types should be reported. If vertex == NULL, the types of + #' all variables are returned. + levels = function(vertex = NULL) { + stop("var.type() is not implemented in this class.") + }, + #' Simulates (draws a sample of) interventional (or observational) data simulate = function(n, target = integer(0), int.level = numeric(0)) { stop("simulate() is not implemented in this class.") }, #' Fits parameters by MLE using a scoring object - mle.fit = function(score) { - .params <<- score$global.mle(.self) + fit = function(score) { + .params <<- score$global.fit(.self) } ), - "VIRTUAL") + contains = "VIRTUAL") #' Coercion to a graphNEL instance setAs("ParDAG", "graphNEL", function(from) { - reverseEdgeDirections( - new("graphNEL", - nodes = from$.nodes, - edgeL = from$.in.edges, - edgemode = "directed")) - }) + edgeList <- lapply(from$.in.edges, function(v) from$.nodes[v]) + names(edgeList) <- from$.nodes + result <- new("graphNEL", + nodes = from$.nodes, + edgeL = edgeList, + edgemode = "directed") + return(reverseEdgeDirections(result)) + }) #' Coercion to a (logical) matrix setAs("ParDAG", "matrix", @@ -276,7 +546,10 @@ setMethod("plot", "ParDAG", #' Virtual base class for all scoring classes setRefClass("Score", + contains = "VIRTUAL", + fields = list( + .nodes = "character", decomp = "logical", c.fcn = "character", pp.dat = "list", @@ -290,67 +563,60 @@ setRefClass("Score", if (length(targets.tmp[[i]]) != length(object$pp.dat$targets[[i]])) return("Target variables must not be listed multiple times.") } - if (length(unique(targets.tmp)) != length(targets.tmp)) + if (length(unique(targets.tmp)) != length(targets.tmp)) { return("Targets must not be listed multiple times.") + } - ## Check whether data is available from all intervention targets - if (unique(object$pp.dat$target.index) != 1:length(object$pp.dat$targets)) - return("Data from all intervention targets must be available") - - ## Check if dimensions of target.index and data conincide - if (length(object$pp.dat$target.index) != nrow(object$pp.dat$data)) - return("Length of target index vector does not coincide with sample size.") + ## Check node names + if (anyDuplicated(object$.nodes)) { + return("The node names must be unique") + } return(TRUE) }, methods = list( #' Constructor - #' - #' Note: all arguments must have a default value for inheritance, - #' see ?setRefClass; apart from that, the default values are meaningless - initialize = function(data = matrix(1, 1, 1), + initialize = function( targets = list(integer(0)), - target.index = rep(as.integer(1), nrow(data)), + nodes = character(0), ...) { - ## Order by ascending target indices (necessary for certain scoring objects) - if (is.unsorted(target.index)) - perm <- order(target.index) - else - perm <- 1:length(target.index) - - pp.dat$targets <<- lapply(targets, sort) - pp.dat$target.index <<- target.index[perm] - pp.dat$data <<- data[perm, ] - pp.dat$vertex.count <<- ncol(data) - pp.dat$total.data.count <<- as.integer(nrow(data)) - - ## Declare scores as not decomposable "by default" - decomp <<- FALSE - - ## No C++ scoring object by default - c.fcn <<- "none" + .nodes <<- nodes + pp.dat$targets <<- .tidyTargets(length(nodes), targets) + }, - ## R function objects - pp.dat$local.score <<- function(vertex, parents) local.score(vertex, parents) - pp.dat$global.score <<- function(edges) global.score(vertex, parents) - pp.dat$local.mle <<- function(vertex, parents) local.mle(vertex, parents) - pp.dat$global.mle <<- function(edges) global.mle(vertex, parents) + #' Yields a vector of node names + getNodes = function() { + .nodes + }, - callSuper(...) + #' Yields the number of nodes + node.count = function() { + length(.nodes) }, #' Checks whether a vertex is valid + #' @param vertex vector of vertex indices validate.vertex = function(vertex) { - stopifnot(is.whole(vertex)) - stopifnot(abs(vertex - round(vertex)) < sqrt(.Machine$double.eps)) - stopifnot(1 <= vertex && vertex <= pp.dat$vertex.count) + if (length(vertex) > 0) { + stopifnot(all(is.whole(vertex))) + min.max <- range(vertex) + stopifnot(1 <= min.max[1] && min.max[2] <= node.count()) + } }, #' Checks whether a vector is a valid list of parents validate.parents = function(parents) { - stopifnot(all(parents %in% 1:pp.dat$vertex.count)) - stopifnot(anyDuplicated(parents) == 0) + validate.vertex(parents) + stopifnot(anyDuplicated(parents) == 0L) + }, + + #' Creates an instance of the corresponding ParDAG class + create.dag = function() { + tryCatch( + new(.pardag.class, nodes = .nodes), + error = function(e) stop(paste("Instance of class '", .pardag.class, + "' cannot be created.", sep = ""))) }, #' Getter and setter function for the targets @@ -376,13 +642,14 @@ setRefClass("Score", #' Calculates the global score of a DAG which is only specified #' by its list of in-edges global.score.int = function(edges, ...) { - ## Calculate score in R - if (c.fcn == "none") + if (c.fcn == "none") { + ## Calculate score in R sum(sapply(1:pp.dat$vertex.count, function(i) local.score(i, edges[[i]], ...))) - ## Calculate score with the C++ library - else + } else { + ## Calculate score with the C++ library .Call("globalScore", c.fcn, pp.dat, edges, c.fcn.options(...), PACKAGE = "pcalg") + } }, #' Calculates the global score of a DAG @@ -390,33 +657,116 @@ setRefClass("Score", global.score.int(dag$.in.edges, ...) }, - #' Calculates the local MLE for a vertex and its parents - local.mle = function(vertex, parents, ...) { - stop("local.mle is not implemented in this class.") + #' Calculates a local model fit for a vertex and its parents + local.fit = function(vertex, parents, ...) { + if (!decomp) { + stop("local.fit can only be calculated for decomposable scores.") + } else { + stop("local.fit is not implemented in this class.") + } }, - #' Calculates the global MLE - global.mle = function(dag, ...) { - ## Calculate score in R + #' Calculates a global model fit + global.fit = function(dag, ...) { if (c.fcn == "none") { + ## Calculate score in R + if (decomp) { in.edge <- dag$.in.edges lapply(1:pp.dat$vertex.count, - function(i) local.mle(i, in.edge[[i]], ...)) - } - ## Calculate score with the C++ library - else + function(i) local.fit(i, in.edge[[i]], ...)) + } else { + stop("global.fit is not implemented in this class.") + } + } else { + ## Calculate score with the C++ library .Call("globalMLE", c.fcn, pp.dat, dag$.in.edges, c.fcn.options(...), - PACKAGE = "pcalg") + PACKAGE = "pcalg") + } } - ), + ) +) + +setRefClass("DataScore", + contains = "Score", + + validity = function(object) { + ## Check whether data is available from all intervention targets + if (sort(unique(object$pp.dat$target.index)) != 1:length(object$pp.dat$targets)) + return("Data from all intervention targets must be available") + + ## Check if dimensions of target.index and data conincide + if (length(object$pp.dat$target.index) != nrow(object$pp.dat$data)) + return("Length of target index vector does not coincide with sample size.") + + return(TRUE) + }, + + methods = list( + #' Constructor + #' + #' @param data data set, jointly interventional and observational. + #' Can either be a matrix or a data frame (this might + #' be different for inherited classes!) + #' @param targets unique list of targets represented in the data + #' @param target.index index vector for targets of data rows + #' @param nodes node labels + #' Note: all arguments must have a default value for inheritance, + #' see ?setRefClass; apart from that, the default values are meaningless + initialize = function(data = matrix(1, 1, 1), + targets = list(integer(0)), + target.index = rep(as.integer(1), nrow(data)), + nodes = colnames(data), + ...) { + ## Node names (stored in constructor of "Score"): + ## if data has no column names, correct them + if (is.null(nodes)) { + nodes <- as.character(1:ncol(data)) + } + targetList <- .tidyTargets(ncol(data), targets, target.index) + callSuper(targets = targetList$targets, nodes, ...) - "VIRTUAL") + ## Order by ascending target indices (necessary for certain scoring objects) + if (is.unsorted(targetList$target.index)) { + perm <- order(targetList$target.index) + } else { + perm <- 1:length(targetList$target.index) + } + + ## Store pre-processed data + # pp.dat$targets <<- lapply(targets, sort) + pp.dat$target.index <<- targetList$target.index[perm] + pp.dat$data <<- data[perm, ] + pp.dat$vertex.count <<- ncol(data) + + + ## Store list of index vectors of "non-interventions": for each vertex k, + ## store the indices of the data points for which k has NOT been intervened + A <- !targets2mat(pp.dat$vertex.count, pp.dat$targets, pp.dat$target.index) + # TODO: use apply!! + pp.dat$non.int <<- lapply(1:pp.dat$vertex.count, function(i) which(A[, i])) + pp.dat$data.count <<- as.integer(colSums(A)) + pp.dat$total.data.count <<- as.integer(nrow(data)) + + ## Declare scores as not decomposable "by default" + decomp <<- FALSE + + ## No C++ scoring object by default + c.fcn <<- "none" + + ## R function objects + pp.dat$local.score <<- function(vertex, parents) local.score(vertex, parents) + pp.dat$global.score <<- function(edges) global.score(vertex, parents) + pp.dat$local.fit <<- function(vertex, parents) local.fit(vertex, parents) + pp.dat$global.fit <<- function(edges) global.fit(vertex, parents) + } + ) +) #' l0-penalized log-likelihood for Gaussian models, with freely #' choosable penalty lambda. #' Special case: BIC where \lambda = 1/2 \log n (default value for lambda) setRefClass("GaussL0penIntScore", - contains = "Score", + contains = "DataScore", fields = list( .format = "character"), @@ -424,12 +774,14 @@ setRefClass("GaussL0penIntScore", validity = function(object) { p <- ncol(object$pp.dat$data) if (!is.null(object$pp.dat$scatter)) { - ## Data storage with precalculated scatter matrices - if (unique(object$pp.dat$scatter.index) != 1:length(object$pp.dat$scatter)) - return("The index list of distinct scatter matrices has an invalid range.") - if (any(sapply(object$pp.dat$scatter, function(mat) dim(mat) != c(p, p)))) - return("The scatter matrices have invalid dimensions.") + ## Data storage with precalculated scatter matrices + if (unique(object$pp.dat$scatter.index) != 1:length(object$pp.dat$scatter)) { + return("The index list of distinct scatter matrices has an invalid range.") + } + if (any(sapply(object$pp.dat$scatter, function(mat) dim(mat) != c(p, p)))) { + return("The scatter matrices have invalid dimensions.") } + } return(TRUE) }, @@ -439,13 +791,18 @@ setRefClass("GaussL0penIntScore", initialize = function(data = matrix(1, 1, 1), targets = list(integer(0)), target.index = rep(as.integer(1), nrow(data)), + nodes = colnames(data), lambda = 0.5*log(nrow(data)), - intercept = FALSE, + intercept = TRUE, format = c("raw", "scatter"), use.cpp = TRUE, ...) { - ## Store supplied data in sorted form - callSuper(data = data, targets = targets, target.index = target.index, ...) + ## Store supplied data in sorted form. Make sure data is a matrix for + ## linear-Gaussian data + if (!is.matrix(data)) { + data <- as.matrix(data) + } + callSuper(data = data, targets = targets, target.index = target.index, nodes = nodes, ...) ## Number of variables p <- ncol(data) @@ -458,63 +815,64 @@ setRefClass("GaussL0penIntScore", ## Store different settings pp.dat$lambda <<- lambda + pp.dat$intercept <<- intercept ## Store data format. Currently supporting scatter matrices ## and raw data only (recommended for high-dimensional data) - .format <<- match.arg(format) + .format <<- match.arg(format, several.ok = TRUE) + ## If format not specified by user, choose it based on dimensions ## TODO: check if this choice is reasonable... - if (length(format) > 1) - .format <<- ifelse(p >= nrow(data) || p >= 500, "raw", "scatter") - ## TODO change following line as soon as "raw" format is implemented and tested - .format <<- "scatter" + if (length(.format) > 1) { + .format <<- ifelse(p >= nrow(data) && length(pp.dat$targets) > 1, "raw", "scatter") + } ## Use C++ functions if requested - if (use.cpp) + if (use.cpp) { c.fcn <<- ifelse(.format == "scatter", "gauss.l0pen.scatter", "gauss.l0pen.raw") + } - ## Add column of ones to data matrix to calculate scatter matrices; - ## this allows the computation of an intercept if requested - pp.dat$intercept <<- intercept - data <- cbind(pp.dat$data, 1)# take matrix that is already pre-processed, - # having reordered rows! - - ## Create scatter matrices for different targets - ti.lb <- c(sapply(1:length(pp.dat$targets), function(i) match(i, pp.dat$target.index)), - length(pp.dat$target.index) + 1) - scatter.mat <- lapply(1:length(pp.dat$targets), - function(i) crossprod(data[ti.lb[i]:(ti.lb[i + 1] - 1), , drop = FALSE])) - - ## Find all interventions in which the different variables - ## are _not_ intervened - non.ivent <- matrix(FALSE, ncol = p, nrow = length(pp.dat$targets)) - pp.dat$scatter.index <<- integer(p) - pp.dat$data.count <<- integer(p) - max.si <- 0 - for (i in 1:p) { - ## Generate indices of (distinct) scatter matrices - non.ivent[ , i] <- sapply(seq_along(pp.dat$targets), - function(j) i %nin% pp.dat$targets[[j]]) - pp.dat$scatter.index[i] <<- max.si + 1 - j <- 1 - while (j < i) { - if (all(non.ivent[, i] == non.ivent[, j])) { - pp.dat$scatter.index[i] <<- pp.dat$scatter.index[j] - j <- i + ## Preprocess data if storage format is "scatter"; for "raw" format, + ## everything is already available in pp.dat + if (.format == "scatter") { + ## Add column of ones to data matrix to calculate scatter matrices; + ## this allows the computation of an intercept if requested + data <- cbind(pp.dat$data, 1)# take matrix that is already pre-processed, + # having reordered rows! + + ## Create scatter matrices for different targets + ti.lb <- c(sapply(1:length(pp.dat$targets), function(i) match(i, pp.dat$target.index)), + length(pp.dat$target.index) + 1) + scatter.mat <- lapply(1:length(pp.dat$targets), + function(i) crossprod(data[ti.lb[i]:(ti.lb[i + 1] - 1), , drop = FALSE])) + + ## Find all interventions in which the different variables + ## are _not_ intervened + non.ivent <- matrix(FALSE, ncol = p, nrow = length(pp.dat$targets)) + pp.dat$scatter.index <<- integer(p) + max.si <- 0 + for (i in 1:p) { + ## Generate indices of (distinct) scatter matrices + non.ivent[ , i] <- sapply(seq_along(pp.dat$targets), + function(j) i %nin% pp.dat$targets[[j]]) + pp.dat$scatter.index[i] <<- max.si + 1 + j <- 1 + while (j < i) { + if (all(non.ivent[, i] == non.ivent[, j])) { + pp.dat$scatter.index[i] <<- pp.dat$scatter.index[j] + j <- i + } + j <- j + 1 } - j <- j + 1 + if (pp.dat$scatter.index[i] == max.si + 1) + max.si <- max.si + 1 } - if (pp.dat$scatter.index[i] == max.si + 1) - max.si <- max.si + 1 - - ## Count data samples from "non-interventions" at i - pp.dat$data.count[i] <<- sum(ti.lb[which(non.ivent[, i]) + 1] - ti.lb[which(non.ivent[, i])]) - } - ## Calculate the distinct scatter matrices for the - ## "non-interventions" - pp.dat$scatter <<- lapply(1:max.si, - function(i) Reduce("+", scatter.mat[non.ivent[, match(i, pp.dat$scatter.index)]])) + ## Calculate the distinct scatter matrices for the + ## "non-interventions" + pp.dat$scatter <<- lapply(1:max.si, + function(i) Reduce("+", scatter.mat[non.ivent[, match(i, pp.dat$scatter.index)]])) + } # IF "scatter" }, #' Calculates the local score of a vertex and its parents @@ -523,82 +881,332 @@ setRefClass("GaussL0penIntScore", validate.vertex(vertex) validate.parents(parents) - ## Calculate score in R if (c.fcn == "none") { - ## If an intercept is allowed, add a fake parent node - parents <- sort(parents) - if (pp.dat$intercept) - parents <- c(pp.dat$vertex.count + 1, parents) - - sigma2 <- pp.dat$scatter[[pp.dat$scatter.index[vertex]]][vertex, vertex] - if (length(parents) != 0) { - b <- pp.dat$scatter[[pp.dat$scatter.index[vertex]]][vertex, parents] - sigma2 <- sigma2 - as.numeric(b %*% solve(pp.dat$scatter[[pp.dat$scatter.index[vertex]]][parents, parents], b)) + ## Calculate score in R + if (.format == "raw") { + ## calculate score from raw data matrix + ## Response vector for linear regression + Y <- pp.dat$data[pp.dat$non.int[[vertex]], vertex] + sigma2 <- sum(Y^2) + + if (length(parents) + pp.dat$intercept != 0) { + ## Get data matrix on which linear regression is based + Z <- pp.dat$data[pp.dat$non.int[[vertex]], parents, drop = FALSE] + if (pp.dat$intercept) + Z <- cbind(1, Z) + + ## Calculate the scaled error covariance using QR decomposition + Q <- qr.Q(qr(Z)) + sigma2 <- sigma2 - sum((Y %*% Q)^2) + } + } + else if (.format == "scatter") { + ## Calculate the score based on pre-calculated scatter matrices + ## If an intercept is allowed, add a fake parent node + parents <- sort(parents) + if (pp.dat$intercept) + parents <- c(pp.dat$vertex.count + 1, parents) + + pd.scMat <- pp.dat$scatter[[pp.dat$scatter.index[vertex]]] + sigma2 <- pd.scMat[vertex, vertex] + if (length(parents) != 0) { + b <- pd.scMat[vertex, parents] + sigma2 <- sigma2 - as.numeric(b %*% solve(pd.scMat[parents, parents], b)) + } } + ## Return local score return(-0.5*pp.dat$data.count[vertex]*(1 + log(sigma2/pp.dat$data.count[vertex])) - pp.dat$lambda*(1 + length(parents))) - } - ## Calculate score with the C++ library - else + } else { + ## Calculate score with the C++ library return(.Call("localScore", c.fcn, pp.dat, vertex, parents, c.fcn.options(...), PACKAGE = "pcalg")) + } # IF c.fcn }, #' Calculates the local MLE for a vertex and its parents - local.mle = function(vertex, parents, ...) { + #' + #' @param vertex vertex whose parameters shall be fitted + #' @param parents parents of the vertex + #' @param ... ignored; for compatibility with the base class + local.fit = function(vertex, parents, ...) { ## Check validity of arguments validate.vertex(vertex) validate.parents(parents) - ## Calculate score in R if (c.fcn == "none") { - ## If an intercept is allowed, add a fake parent node - parents <- sort(parents) - if (pp.dat$intercept) - parents <- c(pp.dat$vertex.count + 1, parents) - - sigma2 <- pp.dat$scatter[[pp.dat$scatter.index[vertex]]][vertex, vertex] - if (length(parents) != 0) { - beta <- solve(pp.dat$scatter[[pp.dat$scatter.index[vertex]]][parents, parents], - pp.dat$scatter[[pp.dat$scatter.index[vertex]]][vertex, parents]) - sigma2 <- sigma2 - pp.dat$scatter[[pp.dat$scatter.index[vertex]]][vertex, parents] %*% beta - } - else + ## Calculate score in R + if (.format == "raw") { + ## Calculate MLE from raw data matrix + ## Response vector for linear regression + Y <- pp.dat$data[pp.dat$non.int[[vertex]], vertex] beta <- numeric(0) + sigma2 <- sum(Y^2) - if (pp.dat$intercept) + ## Calculate regression coefficients + if (length(parents) + pp.dat$intercept != 0) { + ## Get data matrix on which linear regression is based + Z <- pp.dat$data[pp.dat$non.int[[vertex]], parents, drop = FALSE] + if (pp.dat$intercept) + Z <- cbind(1, Z) + + ## Calculate regression coefficients + qrZ <- qr(Z) + beta <- solve(qrZ, Y) + + ## Calculate the scaled error covariance using QR decomposition + sigma2 <- sigma2 - sum((Y %*% qr.Q(qrZ))^2) + } + } else if (.format == "scatter") { + ## Calculate MLE based on pre-calculated scatter matrices + ## If an intercept is allowed, add a fake parent node + parents <- sort(parents) + if (pp.dat$intercept) + parents <- c(pp.dat$vertex.count + 1, parents) + + pd.scMat <- pp.dat$scatter[[pp.dat$scatter.index[vertex]]] + sigma2 <- pd.scMat[vertex, vertex] + if (length(parents) != 0) { + beta <- solve(pd.scMat[parents, parents], + pd.scMat[vertex, parents]) + sigma2 <- sigma2 - pd.scMat[vertex, parents] %*% beta + } + else + beta <- numeric(0) + } # IF .format + + if (pp.dat$intercept) { return(c(sigma2/pp.dat$data.count[vertex], beta)) - else + } else { return(c(sigma2/pp.dat$data.count[vertex], 0, beta)) - } - ## Calculate score with the C++ library - else + } + } else { + ## Calculate score with the C++ library return(.Call("localMLE", c.fcn, pp.dat, vertex, parents, c.fcn.options(...), PACKAGE = "pcalg")) + } # IF c.fcn } ) ) ##' Observational score as special case -setRefClass("GaussL0penObsScore", - contains = "GaussL0penIntScore", +setRefClass("GaussL0penObsScore", contains = "GaussL0penIntScore", methods = list( #' Constructor initialize = function(data = matrix(1, 1, 1), + nodes = colnames(data), lambda = 0.5*log(nrow(data)), intercept = FALSE, + format = c("raw", "scatter"), use.cpp = TRUE, ...) { callSuper(data = data, targets = list(integer(0)), target.index = rep(as.integer(1), nrow(data)), + nodes = nodes, lambda = lambda, intercept = intercept, + format = format, use.cpp = use.cpp, ...) } ) ) +#' l0-penalized log-likelihood for general discrete models, with freely +#' choosable penalty lambda. +#' Special case: BIC where \lambda = 1/2 \log n (default value for lambda) +setRefClass("DiscrL0penIntScore", + contains = "DataScore", + + validity = function(object) { + # TODO write function! + + return(TRUE) + }, + + methods = list( + #' Constructor + initialize = function(data = matrix(1, 1, 1), + targets = list(integer(0)), + target.index = rep(as.integer(1), nrow(data)), + nodes = colnames(data), + lambda = 0.5*log(nrow(data)), + ...) { + ## Store supplied data in sorted form. Make sure data is a data.frame + ## for discrete data. + if (is.matrix(data)) { + data <- as.data.frame(apply(data, 2, factor)) + } + if (!is.data.frame(data)) { + stop("Argument 'data' must be supplied as data.frame (preferred) or matrix.") + } + callSuper(data = data, targets = targets, target.index = target.index, nodes = nodes, ...) + + ## Number of variables + p <- ncol(data) + + ## l0-penalty is decomposable + decomp <<- TRUE + + ## Underlying causal model class: Gaussian + .pardag.class <<- "DiscrParDAG" + + ## Store different settings + pp.dat$lambda <<- lambda + }, + + #' Calculates the local score of a vertex and its parents + local.score = function(vertex, parents, ...) { + ## Check validity of arguments + validate.vertex(vertex) + validate.parents(parents) + + # Extract subset of data relevant for calculation + # Y <- pp.dat$data[pp.dat$non.int[[vertex]], vertex] + Z <- pp.dat$data[pp.dat$non.int[[vertex]], c(vertex, parents), drop = FALSE] + + # Calculate contingency table + cont.table <- table(Z) + + # Normalize to get "local log-likelihood scores" + # (M[u, x] * log(M[u, x]/M[u]) + ll.elem <- function(x) { + s <- sum(x) + if (s > 0) { + y <- x + y[x == 0] <- 1 + x * log(y/s) + } else { + rep(0, length(x)) + # if all counts are 0: return result of maximum entropy + } + } + if (length(parents) > 0) { + ll <- apply(cont.table, 2L:length(dim(cont.table)), ll.elem) + } else { + ll <- ll.elem(cont.table) + } + + # Degrees of freedom (NOTE: calculation is correct if cont.table + # has only one dimension, because prod(integer(0)) == 1) + df <- prod(dim(cont.table)[-1]) * (length(levels(pp.dat$data[[vertex]])) - 1) + + # Return local score + return(sum(ll) - pp.dat$lambda*df) + }, + + #' Calculates the local MLE for a vertex and its parents + #' + #' @param vertex vertex whose parameters shall be fitted + #' @param parents parents of the vertex + #' @param ... ignored; for compatibility with the base class + local.fit = function(vertex, parents, ...) { + ## Check validity of arguments + validate.vertex(vertex) + validate.parents(parents) + + # Extract subset of data relevant for calculation + Z <- pp.dat$data[pp.dat$non.int[[vertex]], c(vertex, parents), drop = FALSE] + + # Calculate contingency table + cont.table <- table(Z) + + # Normalize to get conditional probability distribution + # TODO: perhaps outsource this function to sfsmisc + normalize <- function(x) { + s <- sum(x) + if (s > 0) { + x/s + } else { + rep(1/length(x), length(x)) + # if all counts are 0: return result of maximum entropy + } + } + if (length(parents) > 0) { + cpd <- apply(cont.table, 2L:length(dim(cont.table)), normalize) + } else { + cpd <- normalize(cont.table) + } + + # Return vectorized CPD + return(as.vector(cpd)) + }, + + #' Creates an instance of the corresponding ParDAG class. Sets the + #' correct levels + create.dag = function() { + new(.pardag.class, + nodes = .nodes, + levels = lapply(pp.dat$data, base::levels)) + } + ) +) + + +#' Score for causal additive models; very experimental... +setRefClass("CAMIntScore", contains = "Score", + + methods = list( + #' Constructor + #' + #' Uses the same arguments as the base class. However, the data is internally + #' stored as data frame and not as matrix! + initialize = function(data = data.frame(x = 1), + targets = list(integer(0)), + target.index = rep(as.integer(1), nrow(data)), + nodes = colnames(data), + lambda = 0.5*log(nrow(data)), + ...) { + ## Store supplied data in sorted form. Convert data to a data.frame + ## if necessary + if (!is.data.frame(data)) { + data <- as.data.frame(data) + } + callSuper(data = data, targets = targets, target.index = target.index, ...) + + ## l0-penalty is decomposable + decomp <<- TRUE + + ## Store settings + pp.dat$lambda <<- lambda + + ## Underlying causal model class: causal additive model with + ## Gaussian noise + .pardag.class <<- "GaussParDAG" + ## TODO: implement that class... + }, + + #' Calculates the local score of a vertex and its parents + local.score = function(vertex, parents, ...) { + ## Check validity of arguments + validate.vertex(vertex) + validate.parents(parents) + + ## Fit a GAM for vertex, taking its parents as explanatory variables + if (length(parents) > 0) { + formula.string <- paste(.nodes[parents], collapse = " + ") + } else { + formula.string <- "1" + } + formula.string <- paste(.nodes[vertex], formula.string, sep = " ~ ") + local.gam <- gam(as.formula(formula.string), family = gaussian(), + data = pp.dat$data, subset = pp.dat$non.int[[vertex]]) + + ## Return local score + s <- -0.5*pp.dat$data.count[vertex]*log(sum(resid(local.gam)^2)) - + pp.dat$lambda*sum(local.gam$edf) + # print(sprintf("RSS: %f, df: %f", sum(resid(local.gam)^2), sum(local.gam$edf))) + s + }, + + #' Calculates the local MLE for a vertex and its parents + #' TODO: implement that function after deciding for a format... + local.fit = function(vertex, parents, ...) { + numeric(length(parents) + 2) + } + ) +) + #' Interventional essential graph setRefClass("EssGraph", fields = list( @@ -609,11 +1217,6 @@ setRefClass("EssGraph", ), validity = function(object) { - ## Check nodes - if (any(names(object$.in.edges) != object$.nodes)) { - return("The elements of 'in.edges' must be named after the nodes.") - } - ## Check in-edges if (!all(sapply(object$.in.edges, is.numeric))) { return("The vectors in 'in.edges' must contain numbers.") @@ -658,10 +1261,10 @@ setRefClass("EssGraph", .nodes <<- as.character(nodes) ## Store in-edges - # TODO: improve error checking; possibly put it into separate function stopifnot(is.list(in.edges) && length(in.edges) == length(nodes)) + # More error checking is done in validity check .in.edges <<- in.edges - names(.in.edges) <<- .nodes + names(.in.edges) <<- NULL ## Store targets setTargets(targets) @@ -702,19 +1305,45 @@ setRefClass("EssGraph", #' Creates a list of options for the C++ function "causalInference"; #' internal function - causal.inf.options = function(caching = TRUE, - turning = TRUE, + causal.inf.options = function( + caching = TRUE, + phase = c("forward", "backward", "turning"), + iterate = length(phase) > 1, maxDegree = integer(0), maxSteps = 0, childrenOnly = integer(0), fixedGaps = NULL, - verbose = 0) { + adaptive = c("none", "vstructures", "triples"), + verbose = 0, + p = 0) { + # Check for deprecated calling convention and issue a warning + if (p > 0) { + warning(paste("Argument 'p' is deprecated in calls of ges() or gies", + "and will be disabled in future package versions;", + "please refer to the corresponding help page.", sep = " ")) + } + + # Error checks for supplied arguments + # TODO extend! + if (is.logical(adaptive)) { + adaptive <- ifelse(adaptive, "vstructures", "none") + warning(paste("The parameter 'adaptive' should not be provided as logical anymore;", + "cf. ?ges or gies", sep = " ")) + } + phase <- match.arg(phase, several.ok = TRUE) + stopifnot(is.logical(iterate)) + adaptive <- match.arg(adaptive) + if (is.null(fixedGaps)) { + adaptive <- "none" + } list(caching = caching, - turning = turning, + phase = phase, + iterate = iterate, maxDegree = maxDegree, maxSteps = maxSteps, childrenOnly = childrenOnly, fixedGaps = fixedGaps, + adaptive = adaptive, DEBUG.LEVEL = as.integer(verbose)) }, @@ -777,9 +1406,10 @@ setRefClass("EssGraph", #' Performs a causal inference from an arbitrary start DAG #' with a specified algorithm - caus.inf = function(algorithm, ...) { + caus.inf = function(algorithm = c("GIES", "GIES-F", "GIES-B", "GIES-T", "GIES-STEP", + "GDS", "SiMy"), ...) { stopifnot(!is.null(score <- getScore())) - stopifnot(algorithm %in% c("GIES", "GIES-F", "GIES-B", "GIES-T", "GIES-STEP", "GDS", "SiMy")) + algorithm <- match.arg(algorithm) new.graph <- .Call("causalInference", .in.edges, @@ -798,28 +1428,13 @@ setRefClass("EssGraph", } }, - #' Performs GIES from an arbitrary start DAG - gies = function(...) caus.inf("GIES", ...), - - #' Performs GDS from an arbitrary start DAG - gds = function(...) caus.inf("GDS", ...), - - #' DP search of Silander and Myllymäki (ignores the start DAG!) - silander = function(...) caus.inf("DP", ...), - - #' Calculates the parameters of a DAG via MLE (wrapper function only) - mle.fit = function(dag) { - stopifnot(!is.null(score <- getScore())) - dag$.params <- score$global.mle(dag) - return(dag) - }, - #' Yields a representative (estimating parameters via MLE) repr = function() { stopifnot(!is.null(score <- getScore())) - in.edges <- .Call("representative", .in.edges, PACKAGE = "pcalg") - result <- new(score$.pardag.class, nodes = .nodes, in.edges = in.edges) - result$.params <- score$global.mle(result) + + result <- score$create.dag() + result$.in.edges <- .Call("representative", .in.edges, PACKAGE = "pcalg") + result$.params <- score$global.fit(result) return(result) }, @@ -834,11 +1449,14 @@ setRefClass("EssGraph", )) ##' Coercion to a graphNEL instance -.ess2graph <- function(from) +.ess2graph <- function(from) { + edgeList <- lapply(from$.in.edges, function(v) from$.nodes[v]) + names(edgeList) <- from$.nodes reverseEdgeDirections(new("graphNEL", nodes = from$.nodes, - edgeL = from$.in.edges, + edgeL = edgeList, edgemode = "directed")) +} setAs("EssGraph", "graphNEL", .ess2graph) setAs("EssGraph", "graph", .ess2graph) @@ -848,10 +1466,10 @@ setAs("EssGraph", "graph", .ess2graph) ##' Coercion to a (logical) matrix setAs("EssGraph", "matrix", function(from) { - ip <- seq_len(p <- from$node.count()) - in.edge <- from$.in.edges - vapply(ip, function(i) ip %in% in.edge[[i]], logical(p)) - }) + ip <- seq_len(p <- from$node.count()) + vapply(ip, function(i) ip %in% from$.in.edges[[i]], + logical(p)) + }) #' Plot method (needs Rgraphviz to work!!) ## TODO maybe adapt method to make sure that undirected edges are not plotted as @@ -865,9 +1483,10 @@ setMethod("plot", "EssGraph", invisible(plot(.ess2graph(x), y, ...)) }) +######################################################################## + #' Gaussian causal model -setRefClass("GaussParDAG", - contains = "ParDAG", +setRefClass("GaussParDAG", contains = "ParDAG", validity = function(object) { if (any(names(object$.params) != object$.nodes)) @@ -880,6 +1499,25 @@ setRefClass("GaussParDAG", }, methods = list( + #' Yields the variable types. + #' + #' @param vertex vector of indices of the vertices for which the + #' variable types should be reported. If vertex == NULL, the types of + #' all variables are returned. + var.type = function(vertex = NULL) { + rep("numeric", ifelse(is.null(vertex), node.count, length(vertex))) + }, + + #' Yields the levels of the factor variables. Always NULL in a Gaussian + #' model. + #' + #' @param vertex vector of indices of the vertices for which the + #' variable types should be reported. If vertex == NULL, the types of + #' all variables are returned. + levels = function(vertex = NULL) { + vector("list", ifelse(is.null(vertex), node.count(), length(vertex))) + }, + #' Yields the intercept intercept = function() { sapply(.params, function(par.vec) par.vec[2]) @@ -887,7 +1525,7 @@ setRefClass("GaussParDAG", #' Sets the intercept set.intercept = function(value) { - for (i in 1:node.count()) + for (i in 1L:node.count()) .params[[i]][2] <<- value[i] }, @@ -989,13 +1627,25 @@ setRefClass("GaussParDAG", setAs("matrix", "GaussParDAG", def = function(from) { p <- nrow(from) + stopifnot(p == ncol(from)) + if (!isAcyclic(from)) stop("Input matrix does not correspond to an acyclic DAG.") - edgeL <- lapply(1:p, function(i) which(from[, i] != 0)) + + nodes <- rownames(from) + if (any(duplicated(nodes))) { + warning("Row names are not unique; will reset node names.") + nodes <- as.character(1:p) + } + if (is.null(nodes)) { + nodes <- as.character(1:p) + } + + edgeList <- inEdgeList(from) new("GaussParDAG", - nodes = as.character(1:p), - in.edges = edgeL, - param = lapply(1:p, function(i) c(0, 0, from[edgeL[[i]], i]))) + nodes = nodes, + in.edges = edgeList, + param = lapply(1:p, function(i) c(0, 0, from[edgeList[[i]], i]))) }) #' Coercion from a "graphNEL" object @@ -1049,3 +1699,130 @@ setMethod("predict", "GaussParDAG", fit }) + +######################################################################## + +#' General discrete causal model +setRefClass("DiscrParDAG", + contains = "ParDAG", + + fields = list( + # List of character vectors listing the levels of the variables + .levels = "list" + ), + + validity = function(object) { + if (any(names(object$.params) != object$.nodes)) { + return("The elements of 'params' must be named after the nodes.") + } + if (any(names(object$.levels) != object$.nodes)) { + return("The elements of 'levels' must be named after the nodes.") + } + if (!all(sapply(object$.levels, is.character))) { + return("Factor levels must be represented as characters.") + } + levelCount <- sapply(object$.levels, length) + if (!all(sapply(1:object$node.count(), + function(i) + length(object$.params[[i]]) == prod(levelCount[object$.in.edges[[i]]]) + ))) { + return("The number of parameters does not match the number of in-edges.") + } + + return(TRUE) + }, + + methods = list( + #' Constructor + initialize = function(nodes, in.edges = NULL, params = list(), levels = list()) { + .nodes <<- nodes + + if (is.null(in.edges)) { + .in.edges <<- replicate(length(nodes), integer(0), simplify = FALSE) + } else { + .in.edges <<- lapply(1:length(in.edges), function(i) as.integer(in.edges[[i]])) + } + # names(.in.edges) <<- nodes + names(.in.edges) <<- NULL + for (i in 1:length(nodes)) { + names(.in.edges[[i]]) <<- NULL + } + + .params <<- params + .levels <<- levels + }, + + #' Yields the variable types. + #' + #' @param vertex vector of indices of the vertices for which the + #' variable types should be reported. If vertex == NULL, the types of + #' all variables are returned. + var.type = function(vertex = NULL) { + rep("factor", ifelse(is.null(vertex), node.count, length(vertex))) + }, + + #' Yields the levels of the factor variables. + #' + #' @param vertex vector of indices of the vertices for which the + #' variable types should be reported. If vertex == NULL, the types of + #' all variables are returned. + levels = function(vertex = NULL) { + if (is.null(vertex)) { + .levels + } else { + validate.vertex(vertex) + .levels[vertex] + } + vector("list", ifelse(is.null(vertex), node.count(), length(vertex))) + }, + + #' Sets the variable levels + set.levels = function(vertex, levels) { + .levels[vertex] <<- levels + }, + + #' Yields the conditional probability distribution of a variable + #' given its parents + #' @param vertex index of vertex whose CPD is needed + #' @return array of dimension k + 1, where k is the in-degree of the + #' vertex. The first dimension refers to the levels of "vertex", the + #' following dimensions refer to the levels of the parents of "vertex". + cpd = function(vertex) { + array(.params[[vertex]], + dim = sapply(.levels[c(vertex, .in.edges[[vertex]])], length), + dimnames = .levels[.in.edges[[vertex]]]) + }, + + #' Yields an observational or interventional covariance matrix + #' + #' @param target intervention target + #' @param ivent.var variances of the intervention variables + #' @return (observational or interventional) covariance matrix + cov.mat = function(target = integer(0), ivent.var = numeric(0)) { + A <- -weight.mat() + A[, target] <- 0 + diag(A) <- 1 + A <- solve(A) + + all.var <- err.var() + all.var[target] <- ivent.var + + return(t(A) %*% diag(all.var) %*% A) + }, + + #' Simulates (draws a sample of) interventional (or observational) + #' data + #' + #' @param n + #' @param target + #' @param int.level intervention level: values of the intervened + #' variables. Either a vector of the same length + #' as "target", or a matrix with dimensions + #' n x length(target) + #' @return a vector with the simulated values if n = 1, or a matrix + #' with rows corresponding to different samples if n > 1 + simulate = function(n, target = integer(0), int.level = numeric(0)) { + stop("Function 'simulate' is not implemented yet for 'DiscrParDAG'") + } + ) +) diff --git a/R/deprecated.R b/R/deprecated.R new file mode 100644 index 0000000..7c48bc5 --- /dev/null +++ b/R/deprecated.R @@ -0,0 +1,671 @@ +pcAlgo <- function(dm = NA, C = NA, n = NA, alpha, corMethod = "standard", + verbose = FALSE, directed = FALSE, + G = NULL, datatype = 'continuous', NAdelete = TRUE, + m.max = Inf, u2pd = "rand", psepset = FALSE) { + ## !!! DEPRECATED !!! + ## Purpose: Perform PC-Algorithm, i.e., estimate skeleton of DAG given data + ## Output is an unoriented graph object + ## ---------------------------------------------------------------------- + ## Arguments: + ## - dm: Data matrix (rows: samples, cols: nodes) + ## - C: correlation matrix (only for continuous) + ## - n: sample size + ## - alpha: Significance level of individual partial correlation tests + ## - corMethod: "standard" or "Qn" for standard or robust correlation + ## estimation + ## - G: the adjacency matrix of the graph from which the algorithm + ## should start (logical) + ## - datatype: distinguish between discrete and continuous data + ## - NAdelete: delete edge if pval=NA (for discrete data) + ## - m.max: maximal size of conditioning set + ## - u2pd: Function for converting udag to pdag + ## "rand": udag2pdagu + ## "relaxed": udag2pdagRelaxed + ## "retry": udag2pdagSpecial + ## - psepset: Also check possible sep sets. + ## ---------------------------------------------------------------------- + ## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler + ## Modifications: Sarah Gerster, Diego Colombo + + .Deprecated(msg = "pcAlgo() is deprecated and only kept for backward compatibility. + Please use skeleton, pc, or fci instead\n") + cl <- match.call() + + if (any(is.na(dm))) { + stopifnot(all(!is.na(C)),!is.na(n), (p <- ncol(C)) > 0) + } else { + n <- nrow(dm) + p <- ncol(dm) + } + n <- as.integer(n) + + if (is.null(G)) { + ## G := complete graph : + G <- matrix(TRUE, p,p) + diag(G) <- FALSE + } else if (!(identical(dim(G),c(p,p)))) + stop("Dimensions of the dataset and G do not agree.") + + seq_p <- seq_len(p) + sepset <- pl <- vector("list",p) + for (i in seq_p) sepset[[i]] <- pl + zMin <- matrix(Inf, p,p) + n.edgetests <- numeric(1)# final length = max { ord} + done <- FALSE + ord <- 0 + + if (datatype == 'continuous') { + diag(zMin) <- 0 + if (any(is.na(C))) C <- mcor(dm, method = corMethod) + cutoff <- qnorm(1 - alpha/2) + while (!done && any(G) && ord <= m.max) { + n.edgetests[ord+1] <- 0 + done <- TRUE + ind <- which(G, arr.ind = TRUE) + ## For comparison with C++ sort according to first row + ind <- ind[order(ind[,1]), ] + remEdges <- nrow(ind) + if(verbose) + cat("Order=",ord,"; remaining edges:",remEdges,"\n", sep = '') + for (i in 1:remEdges) { + if(verbose && i%%100 == 0) cat("|i=",i,"|iMax=",remEdges,"\n") + x <- ind[i,1] + y <- ind[i,2] + if (G[y,x]) { + nbrsBool <- G[,x] + nbrsBool[y] <- FALSE + nbrs <- seq_p[nbrsBool] + length_nbrs <- length(nbrs) + if (length_nbrs >= ord) { + if (length_nbrs > ord) done <- FALSE + S <- seq(length = ord) + repeat { ## condition w.r.to all nbrs[S] of size 'ord' + n.edgetests[ord+1] <- n.edgetests[ord+1]+1 + z <- zStat(x,y, nbrs[S], C,n) + if (verbose) cat(paste("x:",x,"y:",y,"S:"),nbrs[S],paste("z:",z,"\n")) + if(abs(z) < zMin[x,y]) zMin[x,y] <- abs(z) + if (abs(z) <= cutoff) { + G[x,y] <- G[y,x] <- FALSE + sepset[[x]][[y]] <- nbrs[S] + break + } else { + nextSet <- getNextSet(length_nbrs, ord, S) + if(nextSet$wasLast) + break + S <- nextSet$nextSet + } + } + } + } ## end if(!done) + + } ## end for(i ..) + ord <- ord+1 + ## n.edgetests[ord] <- remEdges + } ## while + + for (i in 1:(p-1)) { + for (j in 2:p) { + zMin[i,j] <- zMin[j,i] <- min(zMin[i,j],zMin[j,i]) + } + } + } + else { + ## + ## + ## DISCRETE DATA ###################################################### + ## + if (datatype == 'discrete') { + dm.df <- as.data.frame(dm) + while (!done && any(G) && ord <= m.max) { + n.edgetests[ord+1] <- 0 + done <- TRUE + ind <- which(G, arr.ind = TRUE) + ## For comparison with C++ sort according to first row + ind <- ind[order(ind[,1]), ] + remEdges <- nrow(ind) + if(verbose) + cat("Order=",ord,"; remaining edges:",remEdges,"\n", sep = '') + for (i in 1:remEdges) { + if(verbose) { if(i%%100 == 0) cat("|i=",i,"|iMax=",remEdges,"\n") } + x <- ind[i,1] + y <- ind[i,2] + if (G[y,x]) { + nbrsBool <- G[,x] + nbrsBool[y] <- FALSE + nbrs <- seq_p[nbrsBool] + length_nbrs <- length(nbrs) + if (length_nbrs >= ord) { + if (length_nbrs > ord) done <- FALSE + S <- seq(length = ord) + repeat { ## condition w.r.to all nbrs[S] of size 'ord' + n.edgetests[ord+1] <- n.edgetests[ord+1]+1 + prob <- ci.test(x,y, nbrs[S], dm.df) + if (verbose) cat("x=",x," y=",y," S=",nbrs[S],":",prob,"\n") + if (is.na(prob)) prob <- if(NAdelete) 1 else 0 + if(prob >= alpha) { # independent + G[x,y] <- G[y,x] <- FALSE + sepset[[x]][[y]] <- nbrs[S] + break + } else { + nextSet <- getNextSet(length_nbrs, ord, S) + if(nextSet$wasLast) + break + S <- nextSet$nextSet + } + } + } + } ## end if(!done) + + } ## end for(i ..) + ord <- ord+1 + ## n.edgetests[ord] <- remEdges + } ## while + } else + stop("Datatype must be 'continuous' or 'discrete'.") + } + + if (psepset) { + amat <- G + ind <- which(G, arr.ind = TRUE) + storage.mode(amat) <- "integer" # (TRUE, FALSE) --> (1, 0) + ## Orient colliders + for (i in seq_len(nrow(ind))) { + x <- ind[i,1] + y <- ind[i,2] + allZ <- setdiff(which(amat[y,] == 1),x) ## x-y-z + + for (z in allZ) { + if (amat[x,z] == 0 && + !((y %in% sepset[[x]][[z]]) || + (y %in% sepset[[z]][[x]]))) { + if (verbose >= 2) { + cat("\n",x,"*->",y,"<-*",z,"\n") + cat("Sxz=",sepset[[z]][[x]],"and","Szx=",sepset[[x]][[z]],"\n") + } + + ## x o-> y <-o z + amat[x,y] <- amat[z,y] <- 2 + + } ## for + } ## if + } ## for + + ## Compute poss. sepsets + for (x in 1:p) { + attr(x,'class') <- 'possibledsep' + if (any(amat[x,] != 0)) { + tf1 <- setdiff(reach(x,-1,-1,amat), x) + for (y in seq_p[amat[x,] != 0]) { + ## tf = possible_d_sep(amat,x,y) + tf <- setdiff(tf1,y) + ## test + if (length(tf) > 0) { + az <- abs(zStat(x,y,tf,C,n)) + if (az < zMin[x,y]) zMin[x,y] <- az + if (az <= cutoff) { + ## delete x-y + amat[x, y] <- amat[y, x] <- 0 + ## save pos d-sepset in sepset + sepset[[x]][[y]] <- tf + } + if (verbose >= 2) + cat("Possible-D-Sep of", x, "and", y, "is", tf, " - |z| = ",az,"\n") + } + } + } + } + G[amat == 0] <- FALSE + G[amat == 1] <- TRUE + } ## end if(psepset) + + if(verbose) { cat("Final graph adjacency matrix:\n"); print(symnum(G)) } + + ## transform matrix to graph object (if not deprecated anyway: FIX to use correct node names!) + Gobject <- if (sum(G) == 0) { + new("graphNEL", nodes = as.character(seq_p)) + } else { + colnames(G) <- rownames(G) <- as.character(seq_p) + as(G,"graphNEL") + } + + res <- new("pcAlgo", graph = Gobject, + call = cl, n = n, max.ord = as.integer(ord-1), + n.edgetests = n.edgetests, sepset = sepset, + zMin = zMin) + if (directed) + switch (u2pd, + "rand" = udag2pdag (res), + "retry" = udag2pdagSpecial(res)$pcObj, + "relaxed" = udag2pdagRelaxed(res)) + else + res +} ## {pcAlgo} __ deprecated __ + +## DEPRECATED! -- use ida() -- +beta.special <- function(dat = NA, x.pos, y.pos, verbose = 0, a = 0.01, + myDAG = NA, myplot = FALSE, perfect = FALSE, + method = "local", collTest = TRUE, pcObj = NA, all.dags = NA, u2pd = "rand") +{ + ## Purpose: Estimate the causal effect of x on y; the pcObj and all DAGs + ## can be precomputed + ## ---------------------------------------------------------------------- + ## Arguments: + ## - dat: data + ## - x.pos, y.pos: Column of x and y in d.mat + ## - verbose: 0=no comments, 1=progress in BB, 2=detail on estimates + ## - a: significance level of tests for finding CPDAG + ## - myDAG: needed if bootstrp==FALSE + ## - myplot: plot estimated graph + ## - perfect: True cor matrix is calculated from myDAG + ## - method: "local" - local (all combinations of parents in regr.) + ## "global" - all DAGs + ## - collTest: True - Exclude orientations of undirected edges that + ## introduce a new collider + ## - pcObj: Fit of PC Algorithm (semidirected); if this is available, no + ## new fit is done + ## - all.dags: All DAGs in the format of function allDags; if this is + ## available, no new function call allDags is done + ## - u2pd: Function for converting udag to pdag + ## "rand": udag2pdag + ## "relaxed": udag2pdagRelaxed + ## "retry": udag2pdagSpecial + ## ---------------------------------------------------------------------- + ## Value: causal values + ## ---------------------------------------------------------------------- + ## Author: Markus Kalisch, Date: 21 Nov 2007, 11:18 + + cat("This function is deprecated and is only kept for backward compatibility. +Please use ida or idaFast instead\n") + + ## Covariance matrix: Perfect case / standard case + if (perfect) { + if(!is(myDAG, "graphNEL")) stop("For perfect-option the true DAG is needed!") + mcov <- trueCov(myDAG) + mcor <- cov2cor(mcov) + } else { + mcov <- cov(dat) + } + + ## estimate skeleton and CPDAG of given data + res <- + if (is(pcObj, "pcAlgo")) + pcObj + else if(perfect) + pcAlgo.Perfect(mcor, corMethod = "standard",directed = TRUE,u2pd = u2pd) + else + pcAlgo(dat, alpha = a, corMethod = "standard",directed = TRUE,u2pd = u2pd) + + ## prepare adjMatrix and skeleton {MM FIXME : can be improved} + amat <- ad.res <- wgtMatrix(res@graph) + amat[which(amat != 0)] <- 1 ## i->j if amat[j,i]==1 + amatSkel <- amat + t(amat) + amatSkel[amatSkel != 0] <- 1 + + if (method == "local") { +############################## + ## local method + ## Main Input: mcov +############################## + ## find unique parents of x + wgt.est <- ad.res + tmp <- wgt.est-t(wgt.est) + tmp[which(tmp < 0)] <- 0 + wgt.unique <- tmp + pa1 <- which(wgt.unique[x.pos,] != 0) + if (y.pos %in% pa1) { + ## x is parent of y -> zero effect + beta.hat <- 0 + } else { ## y.pos not in pa1 + ## find ambiguous parents of x + wgt.ambig <- wgt.est-wgt.unique + pa2 <- which(wgt.ambig[x.pos,] != 0) + if (verbose == 2) { + cat("\n\nx=",x.pos,"y=",y.pos,"\n") + cat("pa1=",pa1,"\n") + cat("pa2=",pa2,"\n") + } + + ## estimate beta + if (length(pa2) == 0) { + beta.hat <- lm.cov(mcov, y.pos, c(x.pos,pa1)) + if (verbose == 2) + cat("Fit - y:",y.pos, "x:",c(x.pos,pa1), "|b.hat=", beta.hat) + } else { + beta.hat <- NA + ii <- 1 + ## no member of pa2 + pa2.f <- pa2 + pa2.t <- NA + ## check for new collider + if (!collTest || !has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { + beta.hat[ii] <- lm.cov(mcov,y.pos,c(x.pos,pa1)) + if (verbose == 2) + cat("\ny:",y.pos,"x:",c(x.pos,pa1),"|b.hat=", beta.hat[ii]) + }## else { + ## cat("\nx:",x.pos," pa1:",pa1," pa2.t:",pa2.t," pa2.f:",pa2.f) + ## } + ## exactly one member of pa2 + for (i2 in seq_along(pa2)) { + ## check for new collider + pa2.f <- pa2[-i2] + pa2.t <- pa2[i2] + if (!collTest || !has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { + ii <- ii+1 + if (y.pos %in% pa2.t) { + ## cat("Y in Parents: ",y.pos," in ",pa2.t,"\n") + beta.hat[ii] <- 0 + } else { + beta.hat[ii] <- lm.cov(mcov,y.pos,c(x.pos,pa1,pa2[i2])) + } + if (verbose == 2) { cat("\ny:",y.pos,"x:",c(x.pos,pa1,pa2[i2]), + "|b.hat=",beta.hat[ii]) +} + } else { + ## cat("\nx:",x.pos," pa1:",pa1," pa2.t:",pa2.t," pa2.f:",pa2.f) + } + } + ## higher order subsets + if (length(pa2) > 1) { + for (i in 2:length(pa2)) { + pa.tmp <- combn(pa2, i, simplify = TRUE) + for (j in seq_len(ncol(pa.tmp))) { + pa2.t <- pa.tmp[,j] + pa2.f <- setdiff(pa2,pa2.t) + ## teste auf neuen collider + if (!collTest || !has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { + ii <- ii+1 + if (y.pos %in% pa2.t) { + cat("Y in Parents: ",y.pos," in ",pa2.t,"\n") + beta.hat[ii] <- 0 + } else { + beta.hat[ii] <- lm.cov(mcov,y.pos,c(x.pos,pa1,pa2.t)) + } + if (verbose == 2) { cat("\ny:",y.pos,"x:",c(x.pos,pa1,pa2.t), + "|b.hat=",beta.hat[ii]) +} + } else { + ## cat("\nx:",x.pos," pa1:",pa1," pa2.t:",pa2.t," pa2.f:",pa2.f) + } + } + } + } + } ## if pa2 + } ## if y in pa1 + } else { +############################## + ## global method + ## Main Input: mcov +############################## + p <- numNodes(res@graph) + am.pdag <- ad.res + am.pdag[am.pdag != 0] <- 1 + ## find all DAGs if not provided externally + if (is.na(all.dags)) { + ## allDags(am.pdag,am.pdag,NULL) + ad <- pdag2allDags(am.pdag)$dags + } else { + ad <- all.dags + } + n.dags <- nrow(ad) + beta.hat <- rep.int(NA,n.dags) + if (n.dags > 0) { + if (myplot) { + ## x11() + par(mfrow = c(ceiling(sqrt(n.dags)), round(sqrt(n.dags)) )) + } + for (i in 1:n.dags) { + ## compute effect for every DAG + gDag <- as(matrix(ad[i,],p,p),"graphNEL") + if (myplot) Rgraphviz::plot(gDag) + ## path from y to x + rev.pth <- RBGL::sp.between(gDag,as.character(y.pos), + as.character(x.pos))[[1]]$path + if (length(rev.pth) > 1) { + ## if reverse path exists, beta=0 + beta.hat[i] <- 0 + } else { + ## path from x to y + pth <- RBGL::sp.between(gDag,as.character(x.pos), + as.character(y.pos))[[1]]$path + if (length(pth) < 2) { + ## sic! There is NO path from x to y + beta.hat[i] <- 0 + } else { + ## There is a path from x to y + wgt.unique <- t(matrix(ad[i,],p,p)) ## wgt.est is wgtMatrix of DAG + pa1 <- which(wgt.unique[x.pos,] != 0) + if (y.pos %in% pa1) { + cat("Y in Parents: ",y.pos," in ",pa1,"\n") + beta.hat[i] <- 0 + } else { + beta.hat[i] <- lm.cov(mcov,y.pos,c(x.pos,pa1)) + } + if (verbose == 2) + cat("Fit - y:",y.pos,"x:",c(x.pos,pa1), "|b.hat=",beta.hat,"\n") + } ## if length(pth) + } ## if rev.pth + } ## for n.dags + } ## if n.dags + } ## if method + beta.hat +} ## {beta.special} + +## DEPRECATED! -- use ida() / idafast() -- +beta.special.pcObj <- function(x.pos,y.pos,pcObj,mcov = NA,amat = NA,amatSkel = NA, + t.amat = NA) +{ + ## Purpose: Estimate the causal effect of x on y; the pcObj has to be + ## precomputed. This method is intended to be a fast version of + ## + ## beta.special(dat=NA,x.pos,y.pos,verbose=0,a=NA,myDAG=NA,myplot=FALSE, + ## perfect=FALSE,method="local",collTest=TRUE,pcObj=pcObj,all.dags=NA,u2pd="relaxed") + ## + ## Thus, this is a faster version for the local method given a + ## precomputed PC-Algo Object (relaxed udag2pdag, so CPDAG might not + ## be a real CPDAG; this does not matter, since we try not to extend). + ## ---------------------------------------------------------------------- + ## Arguments: + ## - x.pos, y.pos: Column of x and y in d.mat + ## - pcObj: Fit of pc Algorithm (semidirected); if this is available, no + ## new fit is done + ## - mcov: covariance matrix of pcObj fit + ## - amat,amatSkel,g2,t.amat are variants of the adjacency matrix that + ## are used internally but can be precomputed; the relevant code + ## is commented out + ## ---------------------------------------------------------------------- + ## Value: List with two elements + ## - beta.res: beta.causal values + ## ---------------------------------------------------------------------- + ## Author: Markus Kalisch, Date: 21 Nov 2007, 11:18 + + cat("This function is deprecated and is only kept for backward compatibility. +Please use ida or idaFast instead\n") + + if (is.na(amat) | is.na(amatSkel) | is.na(t.amat)) { + ## Code for computing precomputable variables + ## prepare adjMatrix and skeleton {MM FIXME : can be improved} + amat <- wgtMatrix(pcObj@graph) + amat[which(amat != 0)] <- 1 ## i->j if amat[j,i]==1 + t.amat <- t(amat) + amatSkel <- amat + t.amat + amatSkel[amatSkel != 0] <- 1 + } + + ## find unique parents of x + tmp <- amat-t.amat + tmp[which(tmp < 0)] <- 0 + wgt.unique <- tmp + pa1 <- which(wgt.unique[x.pos,] != 0) + if (y.pos %in% pa1) { + cat("Y in Parents: ",y.pos," in ",pa1,"\n") + beta.hat <- 0 + } else { ## y.pos not in pa1 + ## find ambiguous parents of x + wgt.ambig <- amat-wgt.unique + pa2 <- which(wgt.ambig[x.pos,] != 0) + pa2 <- setdiff(pa2,y.pos) + ## estimate beta + if (length(pa2) == 0) { + beta.hat <- lm.cov(mcov,y.pos,c(x.pos,pa1)) + } else { + beta.hat <- NA + ii <- 1 + ## no member of pa2 + ## check for new collider + pa2.f <- pa2 + pa2.t <- NA + if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { + beta.hat[ii] <- lm.cov(mcov,y.pos,c(x.pos,pa1)) + } + ## exactly one member of pa2 + for (i2 in seq_along(pa2)) { + ## check for new collider + pa2.f <- pa2[-i2] + pa2.t <- pa2[i2] + if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { + ii <- ii+1 + beta.hat[ii] <- + if (y.pos %in% pa2.t) { + cat("Y in Parents: ",y.pos," in ",pa2.t,"\n") + 0 + } else lm.cov(mcov,y.pos,c(x.pos,pa1,pa2[i2])) + } + } + ## higher order subsets + if (length(pa2) > 1) { + for (i in 2:length(pa2)) { + pa.tmp <- combn(pa2, i, simplify = TRUE) + for (j in seq_len(ncol(pa.tmp))) { + ## teste auf neuen collider + pa2.t <- pa.tmp[,j] + pa2.f <- setdiff(pa2,pa2.t) + if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { + ii <- ii+1 + beta.hat[ii] <- + if (y.pos %in% pa2.t) { + cat("Y in Parents: ",y.pos," in ",pa2.t,"\n") + 0 + } else lm.cov(mcov,y.pos,c(x.pos,pa1,pa2.t)) + } + } + } + } ## if pa2 + } ## length(pa2) + } ## y.pos %in% pa2 + beta.hat +} ## {beta.special.pcObj} + +allDags <- function(gm,a,tmp, verbose = FALSE) +{ + ## Purpose: Find all DAGs for a given PDAG + ## ---------------------------------------------------------------------- + ## Arguments: + ## - gm: Adjacency matrix of initial PDAG; only 0-1 entries + ## i -> j iff gm(j,i)=1 + ## - a: copy of gm + ## - tmp: "current set of DAGs", initially NULL + ## ---------------------------------------------------------------------- + ## Value: + ## - one 0/1 adj.matrix per row + ## Reversion to graph: as(matrix(res[i,],p,p),"graphNEL") + ## Reversion to wgtMatrix (i->j iff a[j,i]=1): t(matrix(res[i,],p,p)) + ## ---------------------------------------------------------------------- + ## Author: Markus Kalisch, Date: 7 Apr 2008, 14:08 + .Deprecated(msg = "allDags() is deprecated and only kept for backward compatibility. Please use pdag2allDags() instead\n") + if (sum(a) == 0) { + if (verbose) { + cat("Last Call - Final Graph: \n") + print(gm) + cat("#################### \n") + } + tmp2 <- rbind(tmp,c(t(gm))) + if (all(!duplicated(tmp2))) tmp <- tmp2 + } else { + sinks <- find.sink(a) + if (verbose) { + cat("Main Call: ################## \n") + print(gm) + print(a) + cat("Sinks: ",sinks,"\n") + } + for(x in sinks) { + if (verbose) cat("Try removing", x," in a.\n") + gm2 <- gm + a2 <- a + if (adj.check(a,x)) { + inc.to.x <- a[, x] == 1 & a[x, ] == 1 + if (any(inc.to.x)) { + real.inc.to.x <- as.numeric(rownames(a)[inc.to.x]) + real.x <- as.numeric(rownames(a)[x]) + gm2[real.x, real.inc.to.x] <- 1 + gm2[real.inc.to.x, real.x] <- 0 + } + a2 <- a[-x,-x] + if (verbose) { + cat("Removed sink",as.numeric(rownames(a)[x]), + "in g (", x,"in a).\n") + cat("New graphs: \n") + print(gm2) + print(a) + } + tmp <- allDags(gm2, a2, tmp, verbose) + ## ------- *recursively* + } + } + } + tmp +} + +## ___DEPRECATED__ rather plot() --> setMethod("plot", "fciAlgo") in ./AllClasses.R +plotAG <- function(amat) +{ + ## Purpose: Plot ancestral graph + ## ---------------------------------------------------------------------- + ## Arguments: + ## - amat: Adjacency matrix + ## amat[i,j]=3 & amat[j,i]=1 iff i 1-3 j + ## "0": no edge; "1": circle; "2": arrow; "3": tail + ## ---------------------------------------------------------------------- + ## Author: Markus Kalisch, Date: 16 Feb 2009, 18:01 + check.Rgraphviz() + + g <- as(amat,"graphNEL") + nn <- nodes(g) + p <- numNodes(g) + n.edges <- numEdges(g) + ah.list <- at.list <- vector("list", n.edges) + l.names <- character(n.edges) + amat[amat == 1] <- "odot" + amat[amat == 2] <- "normal" + amat[amat == 3] <- "none" + iE <- 0 + for (i in 1:(p-1)) { + x <- nn[i] + for (j in (i+1):p) { + y <- nn[j] + if (amat[x,y] != 0) { + iE <- iE + 1 + ah.list[[iE]] <- amat[x,y] + at.list[[iE]] <- amat[y,x] + l.names[[iE]] <- paste0(x,"~",y) + } + } + } + names(ah.list) <- names(at.list) <- l.names + + edgeRenderInfo(g) <- list(arrowhead = ah.list, arrowtail = at.list) + Rgraphviz::renderGraph(Rgraphviz::layoutGraph(g)) +} + +showAmat <- function(object) { + .Deprecated(msg = "showAmat() is deprecated and only kept for backward compatibility. + Please use as(*, \"amat\") instead\n") + g <- getGraph(object) + cat("\nAdjacency Matrix G:", + "G[i,j] = 1/2 if edge mark of edge i-j at j is head/tail.", + "", sep = "\n") + wm <- wgtMatrix(g) + mTmp <- t(wm - 2*t(wm)) + mTmp[ mTmp < 0 ] <- 2 + mTmp +} diff --git a/R/genRandDAG.R b/R/genRandDAG.R index d1ff375..b63b965 100644 --- a/R/genRandDAG.R +++ b/R/genRandDAG.R @@ -446,87 +446,100 @@ if (FALSE) { setwd("/u/kalischm/research/packages/pcalg/pkg/R") source("genRandDAG.R") - ## Exact - load("/u/kalischm/research/packages/unifDAGs/tables100.RData") + ## Exact -------------------------------- resExact <- generate.tables(100) - ## identical(resExact[[1]], A) ## TRUE - ## identical(resExact[[2]], B) ## TRUE - ## identical(resExact[[3]], a) ## TRUE - - ## Approx - load("/u/kalischm/research/packages/unifDAGs/tables_approx100_20.RData") - resApprox <- approxK(N.inf=100, accuracy=20) - ## identical(resApprox[[1]], Ak) ## TRUE - ## identical(resApprox[[2]], Bsk) ## TRUE - - .unifDagPreComp <- list(A = resExact[[1]], B = resExact[[2]], - a = resExact[[3]], - Ak = resApprox[[1]], Bsk = resApprox[[2]]) + ## --------------- + ## check : + c1.file <- "/u/kalischm/research/packages/unifDAGs/tables100.RData" + if(file.exists(c1.file)) { + load(c1.file) + stopifnot(identical(resExact[[1]], A), + identical(resExact[[2]], B), + identical(resExact[[3]], a)) + } + + ## Approx -------------------------------- + resApprox <- approxK(N.inf=100, accuracy=20, A = resExact[["A"]], a = resExact[["a"]]) + ## ------- + ## check : + c2.file <- "/u/kalischm/research/packages/unifDAGs/tables_approx100_20.RData" + if(file.exists(c2.file)) { + load(c2.file) + stopifnot(identical(resApprox[[1]], Ak), + identical(resApprox[[2]], Bsk)) + } + ##---- The "precomputed data base" we use ------------------------------ + + .unifDagPreComp <- c(resExact, resApprox) + ##^^^^^^^^^^^^^ save(.unifDagPreComp, file = "/u/kalischm/research/packages/pcalg/pkg/sysdata.rda") } ## calculate numbers a_{n, k}, b_{n, k} and a_n up to N ################## ## can be done offline ################################### -generate.tables <- function(N, dir=getwd(), verbose=TRUE) { - - A <- as.bigz(matrix(0, N, N)) # a_{n, k} - B <- as.bigz(matrix(0, N, N)) # b_{n, k} - a <- as.bigz(rep(0, N)) # a_n +generate.tables <- function(N, verbose=TRUE) +{ + z0 <- as.bigz(0) + A <- matrix(z0, N, N) # a_{n, k} + B <- matrix(z0, N, N) # b_{n, k} + a <- rep(z0, N) # a_n A[1, 1] <- B[1, 1] <- a[1] <- 1 for(nn in 2:N) { - if(verbose) cat("\n N: ", nn, " K: ") - for(k in 1:(nn-1)) { + if(verbose) cat(sprintf(" N=%4d / K :", nn)) + for(k in seq_len(nn-1L)) { if(verbose) cat(" ", k) - sum <- as.bigz(0) - for(s in 1:(nn-k)) { - sum <- sum + (2^k-1)^as.bigz(s) * 2^as.bigz(k*(nn-k-s)) * A[nn-k, s] - } - B[nn, k] <- sum - A[nn, k] <- chooseZ(nn, k)*B[nn, k] + s <- seq_len(nn-k) + sum.s <- sum((2^k-1)^as.bigz(s) * 2^as.bigz(k*(nn-k-s)) * A[nn-k, s]) + B[nn, k] <- sum.s + A[nn, k] <- chooseZ(nn, k) * B[nn, k] } + if(verbose) cat("\n") A[nn, nn] <- B[nn, nn] <- 1 a[nn] <- sum(A[nn, 1:nn]) } + ## save(A, B, a, file=paste0(dir, "/tables", N, ".RData")) ## cat("\nTables saved in: ", paste0(dir, "/tables", N, ".RData")) - list(A, B, a) + list(A=A, B=B, a=a) } -## construct A_k and B_{s|k} ############################### -approx.Ak <- function(N.inf=100, accuracy=20) { - Ak <- as.bigz(rep(0, N.inf)) # A_k=lim_{n->oo}(A_{n, k}/a_n) +### Construct A_k and B_{s|k} =================================================== - acc <- 10^as.bigz(accuracy) - for(k in 1:N.inf) { - Ak[k] <- as.bigz(.unifDagPreComp$A[N.inf, k] * acc / .unifDagPreComp$a[N.inf]) - } - Ak[Ak!=0] -} +## using *rational* arithmetic ("bigq") "internally" : + + +approx.Ak <- function(N.inf=100, accuracy=20, A, a) { + ## Compute A_k := lim_{n->oo} A_{n, k} / a_n replacing oo ('Inf') by 'N.inf' + ## round( 10^acc * A_N / a_N ) : + Ak <- as.bigz(10^as.bigz(accuracy) * as.vector(A[N.inf,]) / as.vector(a[N.inf])) + ## typically reducing from 100 to only 10 non-0 ones : + Ak[Ak != 0] +} approx.Bsk <- function(Ak) { n.k <- length(Ak) - - Bsk <- as.bigq(matrix(0, n.k, n.k)) + Bsk <- matrix(as.bigz(0), n.k, n.k) for(kk in 1:n.k) { - for(ss in 1:n.k) { - Bsk[ss, kk] <- as.bigq((1-1/(2^kk))^ss) * as.bigq(Ak[ss]) - } + ss <- 1:n.k + ## bug in 'gmp' package: this does nothing !! + ## Bsk[, kk] <- as.bigz(as.bigq((1-1/(2^kk))^ss) * as.bigq(Ak)) + ## + ## workaround: + Bskk <- as.bigz(as.bigq((1-1/(2^kk))^ss) * as.bigq(Ak)) + for(s in ss) Bsk[s,kk] <- Bskk[s] } - as.bigz(Bsk) + Bsk } -## need table exact -approxK <- function(N.inf=100, accuracy=20, dir=getwd()) { - Ak <- approx.Ak(N.inf, accuracy) - Bsk <- approx.Bsk(Ak) - - ## save(Ak, Bsk, file=paste0(dir, "/tables_approx", N.inf, "_", accuracy, ".RData")) - ## cat("\nApprox-Tables saved in: ", paste0(dir, "/tables_approx", N.inf, "_", accuracy, ".RData")) - list(Ak, Bsk) +## Need (A, a) from the exact tables +approxK <- function(N.inf=100, accuracy=20, A, a) { + Ak <- approx.Ak(N.inf, accuracy, A=A, a=a) + list(Ak = Ak, + Bsk= approx.Bsk(Ak)) } diff --git a/R/gies.R b/R/gies.R index dca2368..cd721a8 100644 --- a/R/gies.R +++ b/R/gies.R @@ -1,7 +1,7 @@ ## GIES algorithm ## -## Author: Alain Hauser -## $Id: gies.R 339 2015-07-22 11:25:06Z mmaechler $ +## Author: Alain Hauser +## $Id: gies.R 393 2016-08-20 09:43:47Z alhauser $ ############################################################################### ################################################## @@ -99,6 +99,7 @@ r.gauss.pardag <- function(p, #' @param target.value value of intervention targets rmvnorm.ivent <- function(n, object, target = integer(0), target.value = numeric(0)) { + p <- object$node.count() ## Error checking stopifnot(length(target) == 0 || (1 <= min(target) && max(target) <= p)) @@ -125,55 +126,328 @@ rmvnorm.ivent <- function(n, object, target = integer(0), target.value = numeric ################################################## ## Structure learning algorithms ################################################## -caus.inf <- function(algorithm, p, targets, score, ...) + +##' Wrapper function for all causal inference algorithms. It's not recommended +##' to use it directly; adapted wrapper functions for the single algorithms are +##' provided +#' +##' @param algorithm name of the causal inference algorithm to be used +##' @param score scoring object to be used +##' @param labels node labels +##' @param targets unique list of targets. Normally determined from the scoring object +##' @param ... additional parameters passed to the algorithm chosen +caus.inf <- function( + algorithm = c("GIES", "GDS", "SiMy"), + score, + labels = score$getNodes(), + targets = score$getTargets(), + ...) { - essgraph <- new("EssGraph", nodes = as.character(1:p), targets = targets, score = score) - if (essgraph$caus.inf(algorithm, ...)) - list(essgraph = essgraph, repr = essgraph$repr()) + algorithm <- match.arg(algorithm) + + # Catching error occurring when a user called one of the causal + # inference algorithms using the old calling conventions: try to + # rearrange passed arguments, print a warning + # + # NOTE: old calling conventions were + # (algorithm, p, targets, score) for caus.inf + # (p, targets, score) for all functions allowing interventional data + # (p, score) for GES + if (is.numeric(score)) { + # This happens when the old calling convention is used with all + # mandatory arguments unnamed + p <- score + if (is.list(labels) && is(targets, "Score")) { + score <- targets + targets <- labels + labels <- as.character(1:p) + warning(paste("You are using a DEPRECATED calling convention for", + "gies(), gds() or simy(); please refer to the documentation", + "of these functions to adapt to the new calling conventions.")) + } else if (is(labels, "Score")) { + score <- labels + labels <- as.character(1:p) + warning(paste("You are using a DEPRECATED calling convention for", + "ges(); please refer to the documentation", + "to adapt to the new calling convention.")) + } + } else if (is.numeric(labels) && length(labels) == 1) { + # This happens when the old calling convention is used with only the + # 'score' argument named + labels <- as.character(1:labels) + warning(paste("You are using a DEPRECATED calling convention for", + "gies(), ges(), gds() or simy(); please refer to the documentation", + "of these functions to adapt to the new calling conventions.")) + } + + if (!is(score, "Score")) { + stop("'score' must be of a class inherited from the class 'Score'.") + } + if (!is.character(labels)) { + stop("'labels' must be a character vector.") + } + if (!is.list(targets) || !all(sapply(targets, is.numeric))) { + stop("'targets' must be a list of integer vectors.") + } + + essgraph <- new("EssGraph", nodes = labels, targets = targets, score = score) + if (essgraph$caus.inf(algorithm, ...)) { + if (algorithm == "GIES") { + ## GIES yields an essential graph; calculate a representative thereof + list(essgraph = essgraph, repr = essgraph$repr()) + } else { + ## GDS and SiMy yield a DAG; calculate the corresponding essential graph, + ## although calculations may come from a model class where Markov equivalence + ## does not hold! + list(essgraph = dag2essgraph(essgraph$repr(), targets = targets), + repr = essgraph$repr()) + } + } else stop("invalid 'algorithm' or \"EssGraph\" object") } -gies <- function(p, targets, score, fixedGaps = NULL, - turning = TRUE, maxDegree = integer(0), verbose = FALSE, ...) - caus.inf("GIES", p, targets, score, fixedGaps = fixedGaps, - turning = turning, maxDegree = maxDegree, verbose = verbose, ...) - -ges <- function(p, score, fixedGaps = NULL, - turning = TRUE, maxDegree = integer(0), verbose = FALSE, ...) - caus.inf("GIES", p, list(integer(0)), score, fixedGaps = fixedGaps, - turning = turning, maxDegree = maxDegree, verbose = verbose, ...) +##' Greedy Interventional Equivalence Search - GIES --> ../man/gies.Rd +##' +##' @param score scoring object to be used +##' @param labels node labels +##' @param targets unique list of targets. Normally determined from the scoring object +##' @param fixedGaps logical matrix indicating forbidden edges +##' @param adaptive sets the behaviour for adaptiveness in the forward phase (cf. "ARGES") +##' @param phase lists the phases that should be executed +##' @param iterate indicates whether the phases should be iterated. iterated = FALSE +##' means that the required phases are run just once +##' @param turning indicates whether the turning step should be included (DEPRECATED). +##' @param maxDegree maximum vertex degree allowed +##' @param verbose indicates whether debug output should be printed +##' @param ... additional parameters (currently none) +gies <- function( + score, + labels = score$getNodes(), + targets = score$getTargets(), + fixedGaps = NULL, + adaptive = c("none", "vstructures", "triples"), + phase = c("forward", "backward", "turning"), + iterate = length(phase) > 1, + turning = TRUE, + maxDegree = integer(0), + verbose = FALSE, + ...) +{ + # Catch calling convention of previous package versions: + # ges(p, targets, score, fixedGaps = NULL, ...) + # If this calling convention is used, issue a warning, but adjust the + # arguments + if (is.numeric(score) && is.list(labels) && inherits(targets, "Score")) { + score <- targets + targets <- labels + labels <- as.character(1:length(score$getNodes())) + warning(paste("You are using a deprecated calling convention for gies()", + "which will be disabled in future versions of the package;", + "cf. ?gies.", sep = " ")) + } + # If the old calling convention was used with named arguments, "p = ..." + # would assign a numerical value to "phase" (expanding arguments...) + if (is.numeric(phase)) { + phase <- c("forward", "backward", "turning") + warning(paste("You are using a deprecated calling convention for gies()", + "which will be disabled in future versions of the package;", + "cf. ?gies.", sep = " ")) + } + + # Issue warning if argument 'turning' was used + # TODO: do not check whether 'turning' is false, but whether 'turning' + # was provided as an argument. + if (!turning) { + phase <- c("forward", "backward") + iterate <- FALSE + warning(paste("The argument 'turning' is deprecated; please use 'phase' instead", + "(cf. ?gies)", sep = " ")) + } + + # Error checks + if (!inherits(score, "Score")) { + stop("Argument 'score' must be an instance of a class inherited from 'Score'.") + } + phase <- match.arg(phase, several.ok = TRUE) + # TODO extend... + + caus.inf( + "GIES", + score = score, + labels = labels, + targets = targets, + fixedGaps = fixedGaps, + adaptive = adaptive, + phase = phase, + iterate = iterate, + maxDegree = maxDegree, + verbose = verbose, + ...) +} -## TODO: make sure that the "representative" in the result is actually the last -## visited DAG instead of a random representative; adapt documentation accordingly -gds <- function(p, targets, score, verbose = FALSE, ...) - caus.inf("GDS", p, targets, score, verbose = verbose, ...) +##' Greedy Equivalence Search - GES --> ../man/ges.Rd +##' +##' @param score scoring object to be used +##' @param labels node labels +##' @param fixedGaps logical matrix indicating forbidden edges +##' @param adaptive sets the behaviour for adaptiveness in the forward phase (cf. "ARGES") +##' @param phase lists the phases that should be executed +##' @param iterate indicates whether the phases should be iterated. iterated = FALSE +##' means that the required phases are run just once +##' @param turning indicates whether the turning step should be included (DEPRECATED). +##' @param maxDegree maximum vertex degree allowed +##' @param verbose indicates whether debug output should be printed +##' @param ... additional parameters (currently none) +##' @param targets unique list of targets. Normally determined from the scoring object +ges <- function( + score, + labels = score$getNodes(), + fixedGaps = NULL, + adaptive = c("none", "vstructures", "triples"), + phase = c("forward", "backward", "turning"), + iterate = length(phase) > 1, + turning = TRUE, + maxDegree = integer(0), + verbose = FALSE, + ...) +{ + # Catch calling convention of previous package versions: + # ges(p, score, fixedGaps = NULL, ...) + # If this calling convention is used, issue a warning, but adjust the + # arguments + if (is.numeric(score) && inherits(labels, "Score")) { + score <- labels + labels <- as.character(1:length(score$getNodes())) + warning(paste("You are using a deprecated calling convention for ges()", + "which will be disabled in future versions of the package;", + "please refer to the help page of ges().", sep = " ")) + } + # If the old calling convention was used with named arguments, "p = ..." + # would assign a numerical value to "phase" (expanding arguments...) + if (is.numeric(phase)) { + phase <- c("forward", "backward", "turning") + warning(paste("You are using a deprecated calling convention for ges()", + "which will be disabled in future versions of the package;", + "cf. ?ges.", sep = " ")) + } + + # Issue warning if argument 'turning' was used + # TODO: do not check whether 'turning' is false, but whether 'turning' + # was provided as an argument. + if (!turning) { + phase <- c("forward", "backward") + iterate <- FALSE + warning(paste("The argument 'turning' is deprecated; please use 'phase' instead", + "(cf. ?ges)", sep = " ")) + } + + # Error checks + if (!inherits(score, "Score")) { + stop("Argument 'score' must be an instance of a class inherited from 'Score'.") + } + phase <- match.arg(phase, several.ok = TRUE) + # TODO extend... + + caus.inf( + "GIES", + score = score, + labels = labels, + targets = list(integer(0)), + fixedGaps = fixedGaps, + adaptive = adaptive, + phase = phase, + iterate = iterate, + maxDegree = maxDegree, + verbose = verbose, + ...) +} -simy <- function(p, targets, score, verbose = FALSE, ...) - caus.inf("SiMy", p, targets, score, verbose = verbose, ...) +##' Greedy DAG Search - GDS : greedy search in the DAG space --> ../man/gds.Rd +##' +##' @param score scoring object to be used +##' @param labels node labels +##' @param targets +##' @param fixedGaps logical matrix indicating forbidden edges +##' @param phase lists the phases that should be executed +##' @param iterate indicates whether the phases should be iterated. iterated = FALSE +##' means that the required phases are run just once +##' @param turning indicates whether the turning step should be included (DEPRECATED). +##' @param maxDegree maximum vertex degree allowed +##' @param verbose indicates whether debug output should be printed +##' @param ... additional parameters (currently none) +gds <- function( + score, + labels = score$getNodes(), + targets = score$getTargets(), + fixedGaps = NULL, + phase = c("forward", "backward", "turning"), + iterate = length(phase) > 1, + turning = TRUE, + maxDegree = integer(0), + verbose = FALSE, + ...) +{ + # Issue warning if argument 'turning' was used + # TODO: do not check whether 'turning' is false, but whether 'turning' + # was provided as an argument. + if (!turning) { + phase <- c("forward", "backward") + iterate <- FALSE + warning(paste("The argument 'turning' is deprecated; please use 'phase' instead", + "(cf. ?ges)", sep = " ")) + } + + phase <- match.arg(phase, several.ok = TRUE) + + caus.inf( + "GDS", + score = score, + labels = labels, + targets = targets, + fixedGaps = fixedGaps, + phase = phase, + iterate = iterate, + maxDegree = maxDegree, + verbose = verbose, + ...) +} -#' Create a list of targets and a vector of target indices out of a -#' matrix indicating interventions -#' -#' @param A a n x p boolean matrix; A[i, j] is TRUE iff vertex j is intervened -#' in data point i -#' @return list with two entries, "targets" and "target.index". -#' targets is a list of unique intervention targets -#' target.index is a vector of size n; the intervention target of data point -#' i is given by targets[[target.index[i]]]. -mat2targets <- function(A) +##' Dynamic programming approach of Silander and Myllimäki - SiMy --> ../man/simy.Rd +##' +##' @param score scoring object to be used +##' @param labels node labels +##' @param targets +##' @param verbose indicates whether debug output should be printed +##' @param ... additional parameters (currently none) +simy <- function(score, labels = score$getNodes(), targets = score$getTargets(), + verbose = FALSE, ...) { - targets.raw <- as.list(apply(A, 1, which)) - targets <- unique(targets.raw) - list(targets = targets, target.index = match(targets.raw, targets)) + caus.inf("SiMy", score = score, labels = labels, targets = targets, verbose = verbose, ...) } + +#' Converts a DAG to an (observational or interventional) essential graph dag2essgraph <- function(dag, targets = list(integer(0))) { - new("EssGraph", - nodes = dag$.nodes, - in.edges = .Call("dagToEssentialGraph", dag$.in.edges, targets), - targets = targets) + edgeListDAG <- inEdgeList(dag) + edgeListEssGraph <- .Call("dagToEssentialGraph", edgeListDAG, targets) + if (is.matrix(dag)) { + p <- nrow(dag) + result <- sapply(1:p, function(i) 1:p %in% edgeListEssGraph[[i]]) + rownames(result) <- rownames(dag) + colnames(result) <- colnames(dag) + result + } else if (inherits(dag, "graphNEL")) { + nodeNames <- nodes(dag) + names(edgeListEssGraph) <- nodeNames + result <- new("graphNEL", + nodes = nodeNames, + edgeL = lapply(edgeListEssGraph, function(v) nodeNames[v]), + edgemode = "directed") + reverseEdgeDirections(result) + } else { + new("EssGraph", + nodes = dag$.nodes, + in.edges = edgeListEssGraph, + targets = targets) + } } -#' Fast version of "gaussCItest", implemented in C++ -gaussCItest.fast <- function(x, y, S, suffStat) - .Call("condIndTestGauss", x, y, S, suffStat$n, suffStat$C) - diff --git a/R/jointIda.R b/R/jointIda.R index 1eb9afa..6ac2602 100644 --- a/R/jointIda.R +++ b/R/jointIda.R @@ -34,6 +34,9 @@ extract.parent.sets <- function(x.pos, amat.cpdag, isCPDAG = FALSE) { ## Function for getting locally valid parent sets all.locally.valid.parents.undir <- function(amat,x) { # x must be a scaler + ## by the call amat is guaranteed to have integer rownames + ## that are meaningful + ## See row: rownames(conn.comp.mat) <- all.nodes amat.V <- as.integer(rownames(amat)) pa.dir <- pasets.dir[[x.pos == amat.V[x]]] paset <- list(pa.dir) @@ -73,7 +76,8 @@ extract.parent.sets <- function(x.pos, amat.cpdag, isCPDAG = FALSE) { ii.x <- seq_along(x..) # = " 1:length(x..) " if(chordal[i] & nvar <= 12) { rownames(conn.comp.mat) <- colnames(conn.comp.mat) <- 1:nvar - all.extensions <- allDags(conn.comp.mat, conn.comp.mat, NULL) + ## all.extensions <- allDags(conn.comp.mat, conn.comp.mat, NULL) + all.extensions <- pdag2allDags(conn.comp.mat)$dags pa.fun <- function(amat,j) c(all.nodes[which(amat[,m.x.[j]] != 0)], pasets.dir[[match(x..[j],x.pos)]]) parent.sets.fun <- function(r) lapply(ii.x, pa.fun, diff --git a/R/lingamFuns.R b/R/lingamFuns.R index 132625b..d646c35 100644 --- a/R/lingamFuns.R +++ b/R/lingamFuns.R @@ -1,12 +1,39 @@ - ################################################## +### Copyright (c) 2013 - 2015 Jonas Peters [peters@stat.math.ethz.ch] + +## This program is free software; you can redistribute it and/or modify it under +## the terms of the GNU General Public License as published by the Free Software +## Foundation; either version 3 of the License, or (at your option) any later +## version. +## +## This program is distributed in the hope that it will be useful, but WITHOUT +## ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +## FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +## details. +## +## You should have received a copy of the GNU General Public License along with +## this program; if not, see . +################################################## ## exported ################################################## +lingam <- function(X, verbose = FALSE) +{ + structure(uselingam(X, verbose = verbose), class = "LINGAM") +} +setOldClass("LINGAM") + +setAs("LINGAM", "amat", function(from) { + structure(t(from$Bpruned != 0), class = "amat", type = "pag") +}) + + +## DEPRECATED: LINGAM <- function(X, verbose = FALSE) ## Copyright (c) 2013 - 2015 Jonas Peters [peters@stat.math.ethz.ch] ## All rights reserved. See the file COPYING for license terms. { - res <- uselingam(X, verbose = verbose) - list(B = res$B, Adj = t(res$B != 0)) + .Deprecated("lingam") + res <- uselingam(X, verbose = verbose) + list(B = res$Bpruned, Adj = t(res$Bpruned != 0)) } ################################################## @@ -135,6 +162,7 @@ estLiNGAM <- function(X, only.perm = FALSE, fastICA.tol = 1e-14, ##' @param p ##' @author Martin Maechler iperm <- function(p) sort.list(p, method="radix") + ## Version till July 2015: is ***MUCH** slower ## iperm <- function( p ) { ## q <- array(0,c(1,length(p))) @@ -305,15 +333,8 @@ prune <- function(X, k, method = 'resampling', # the pruning method {no other fo } } - diststdfinal <- rowMeans(diststdpieces) - cfinal <- rowMeans(cpieces) - - ## Finally, rename all the variables to the way we defined them - ## in the function definition - - Bpruned <- Bfinal - stde <- diststdfinal - ci <- cfinal + stde <- rowMeans(diststdpieces) + cfinal <- rowMeans(cpieces) }, 'olsboot' = { stop(gettextf("Method '%s' not implemented yet!", method), domain=NA) @@ -335,9 +356,7 @@ prune <- function(X, k, method = 'resampling', # the pruning method {no other fo if(verbose) cat('Done!\n') ## Return the result - list(Bpruned = Bpruned, - stde = stde, - ci = ci) + list(Bpruned = Bfinal, stde = stde, ci = cfinal) } ## SLT = Strict Lower Triangularity diff --git a/R/pcalg.R b/R/pcalg.R index e24462f..4f03b75 100644 --- a/R/pcalg.R +++ b/R/pcalg.R @@ -45,37 +45,37 @@ trueCov <- function(dag, back.compatible = FALSE) randomDAG <- function (n, prob, lB = 0.1, uB = 1, V = as.character(1:n)) { - stopifnot(n >= 2, is.numeric(prob), length(prob) == 1, - 0 <= prob, prob <= 1, - is.numeric(lB), is.numeric(uB), lB <= uB) - edL <- vector("list", n) - nmbEdges <- 0L - for (i in seq_len(n - 2)) { - listSize <- rbinom(1, n - i, prob) - nmbEdges <- nmbEdges + listSize - edgeList <- sample(seq(i + 1, n), size = listSize) - weightList <- runif(length(edgeList), min = lB, max = uB) - edL[[i]] <- list(edges = edgeList, weights = weightList) - } - ## i=n-1 separately - ## (because of sample(7,1) is actually sample(1:7,1) and not 7) - listSize <- rbinom(1, 1, prob) - if (listSize > 0) { - nmbEdges <- nmbEdges + 1 - edgeList <- n - weightList <- runif(1, min = lB, max = uB) - } else { - edgeList <- integer(0) - weightList <- numeric(0) - } - edL[[n-1]] <- list(edges = edgeList, weights = weightList) - if (nmbEdges > 0) { - edL[[n]] <- list(edges = integer(0), weights = numeric(0)) - names(edL) <- V - new("graphNEL", nodes = V, edgeL = edL, edgemode = "directed") - } - else - new("graphNEL", nodes = V, edgemode = "directed") + stopifnot(n >= 2, is.numeric(prob), length(prob) == 1, + 0 <= prob, prob <= 1, + is.numeric(lB), is.numeric(uB), lB <= uB) + edL <- vector("list", n) + nmbEdges <- 0L + for (i in seq_len(n - 2)) { + listSize <- rbinom(1, n - i, prob) + nmbEdges <- nmbEdges + listSize + edgeList <- sample(seq(i + 1, n), size = listSize) + weightList <- runif(length(edgeList), min = lB, max = uB) + edL[[i]] <- list(edges = edgeList, weights = weightList) + } + ## i=n-1 separately + ## (because of sample(7,1) is actually sample(1:7,1) and not 7) + listSize <- rbinom(1, 1, prob) + if (listSize > 0) { + nmbEdges <- nmbEdges + 1 + edgeList <- n + weightList <- runif(1, min = lB, max = uB) + } else { + edgeList <- integer(0) + weightList <- numeric(0) + } + edL[[n-1]] <- list(edges = edgeList, weights = weightList) + if (nmbEdges > 0) { + edL[[n]] <- list(edges = integer(0), weights = numeric(0)) + names(edL) <- V + new("graphNEL", nodes = V, edgeL = edL, edgemode = "directed") + } + else + new("graphNEL", nodes = V, edgemode = "directed") } @@ -114,7 +114,7 @@ wgtMatrix.0 <- function(g, transpose = TRUE) wgtMatrix <- function(g, transpose = TRUE) { res <- as(g, "matrix") # from 'graph' package, now reliable (we hope) if (transpose) ## default! - t(res) else res + t(res) else res } rmvDAG <- @@ -254,7 +254,7 @@ pcSelect <- function(y, dm, alpha, corMethod = "standard", if(abs(z) < zMin[x]) zMin[x] <- abs(z) if (verbose >= 2) cat(paste("x:",vNms[x-1],"y:",(ytmp <- round((p+1)/2)),"S:"), - c(ytmp,vNms)[nbrs[S]],paste("z:",z,"\n")) + c(ytmp,vNms)[nbrs[S]], paste("z:",z,"\n")) if (abs(z) <= cutoff) { G[x] <- FALSE break @@ -424,7 +424,7 @@ getNextSet <- function(n,k,set) { } mcor <- function(dm, method = c("standard", "Qn", "QnStable", - "ogkScaleTau2", "ogkQn", "shrink")) + "ogkScaleTau2", "ogkQn", "shrink")) { ## Purpose: Compute correlation matrix (perhaps elementwise) ## ---------------------------------------------------------------------- @@ -446,8 +446,8 @@ mcor <- function(dm, method = c("standard", "Qn", "QnStable", qnSum <- Qn(dm[,i] + dm[,j]) qnDiff <- Qn(dm[,i] - dm[,j]) res[j,i] <- res[i,j] <- - max(-1, - min(1, (qnSum^2 - qnDiff^2) / (4*Qn.[i]*Qn.[j]))) + max(-1, + min(1, (qnSum^2 - qnDiff^2) / (4*Qn.[i]*Qn.[j]))) } } res @@ -463,8 +463,8 @@ mcor <- function(dm, method = c("standard", "Qn", "QnStable", qnSum <- Qn(xQn.i + xQn[,j]) qnDiff <- Qn(xQn.i - xQn[,j]) res[j,i] <- res[i,j] <- - max(-1, - min(1, (qnSum^2 - qnDiff^2) / (qnSum^2 + qnDiff^2))) + max(-1, + min(1, (qnSum^2 - qnDiff^2) / (qnSum^2 + qnDiff^2))) } } res @@ -582,126 +582,122 @@ dag2cpdag <- function(g) ## Arguments: ## - dag: input DAG (graph object) ## ---------------------------------------------------------------------- - ## Author: Alain Hauser, Date: 13 Mar 2015 - nn <- nodes(g) ## *: to keep node labels - dag <- as(g, "GaussParDAG") - res <- as(dag2essgraph(dag), "graphNEL") - nodes(res) <- nn ## * - res + ## Author: Alain Hauser, Date: 14 Mar 2015 + dag2essgraph(g) } -#dag2cpdag <- function(g) -#{ -# ## Purpose: Compute the (unique) completed partially directed graph (CPDAG) -# ## that corresponds to the input DAG; result is a graph object -# ## ---------------------------------------------------------------------- -# ## Arguments: -# ## - dag: input DAG (graph object) -# ## ---------------------------------------------------------------------- -# ## Author: Diego Colombo, Date: 10 Jun 2013, 11:06 -# -# amat <- as(g, "matrix") -# amat[amat != 0] <- 1 -# skel.amat <- amat + t(amat) -# skel.amat[skel.amat == 2] <- 1 -# cpdag <- skel.amat -# -# ## search the v-structures in the DAG -# ind <- which((amat == 1 & t(amat) == 0), arr.ind = TRUE) -# tripleMatrix <- matrix(,0,3) -# ## Go through all edges -# for (i in seq_len(nrow(ind))) { ## MM(FIXME): growth of tripleMatrix -# x <- ind[i,1] -# y <- ind[i,2] -# indY <- setdiff(which((amat[,y] == 1 & amat[y,] == 0), arr.ind = TRUE),x) ## x-> y <- z -# if(length(newZ <- indY[amat[x,indY] == 0])) ## deparse.l.=0: no colnames -# tripleMatrix <- rbind(tripleMatrix, cbind(x, y, newZ, deparse.level=0), -# deparse.level=0) -# } -# if ((m <- nrow(tripleMatrix)) > 0) { -# deleteDupl <- logical(m)# all FALSE -# for (i in seq_len(m)) -# if (tripleMatrix[i,1] > tripleMatrix[i,3]) -# deleteDupl[i] <- TRUE -# if(any(deleteDupl)) -# tripleMatrix <- tripleMatrix[!deleteDupl,, drop=FALSE] -# -# ## orient the v-structures in the CPDAG -# for (i in seq_len(nrow(tripleMatrix))) { -# x <- tripleMatrix[i,1] -# y <- tripleMatrix[i,2] -# z <- tripleMatrix[i,3] -# cpdag[x,y] <- cpdag[z,y] <- 1 -# cpdag[y,x] <- cpdag[y,z] <- 0 -# } -# } -# -# ## orient the edges with the 3 orientation rules -# repeat { -# old_cpdag <- cpdag -# ## Rule 1 -# ind <- which((cpdag == 1 & t(cpdag) == 0), arr.ind = TRUE) -# for (i in seq_len(nrow(ind))) { -# a <- ind[i, 1] -# b <- ind[i, 2] -# isC <- ((cpdag[b, ] == 1 & cpdag[, b] == 1) & -# (cpdag[a, ] == 0 & cpdag[, a] == 0)) -# if (any(isC)) { -# indC <- which(isC) -# cpdag[b, indC] <- 1 -# cpdag[indC, b] <- 0 -# } -# } -# ## Rule 2 -# ind <- which((cpdag == 1 & t(cpdag) == 1), arr.ind = TRUE) -# for (i in seq_len(nrow(ind))) { -# a <- ind[i, 1] -# b <- ind[i, 2] -# isC <- ((cpdag[a, ] == 1 & cpdag[, a] == 0) & -# (cpdag[, b] == 1 & cpdag[b, ] == 0)) -# if (any(isC)) { -# cpdag[a, b] <- 1 -# cpdag[b, a] <- 0 -# } -# } -# ## Rule 3 -# ind <- which((cpdag == 1 & t(cpdag) == 1), arr.ind = TRUE) -# for (i in seq_len(nrow(ind))) { -# a <- ind[i, 1] -# b <- ind[i, 2] -# indC <- which((cpdag[a, ] == 1 & cpdag[, a] == 1) & -# (cpdag[, b] == 1 & cpdag[b, ] == 0)) -# if (length(indC) >= 2) { -# cmb.C <- combn(indC, 2) -# cC1 <- cmb.C[1, ] -# cC2 <- cmb.C[2, ] -# for (j in seq_along(cC1)) { -# c1 <- cC1[j] -# c2 <- cC2[j] -# if (c1 != c2 && cpdag[c1, c2] == 0 && cpdag[c2,c1] == 0) { -# cpdag[a, b] <- 1 -# cpdag[b, a] <- 0 -# break -# } -# } -# } -# } -# if (all(cpdag == old_cpdag)) -# break -# } -# as(cpdag,"graphNEL") -#} + #dag2cpdag <- function(g) + #{ + # ## Purpose: Compute the (unique) completed partially directed graph (CPDAG) + # ## that corresponds to the input DAG; result is a graph object + # ## ---------------------------------------------------------------------- + # ## Arguments: + # ## - dag: input DAG (graph object) + # ## ---------------------------------------------------------------------- + # ## Author: Diego Colombo, Date: 10 Jun 2013, 11:06 + # + # amat <- as(g, "matrix") + # amat[amat != 0] <- 1 + # skel.amat <- amat + t(amat) + # skel.amat[skel.amat == 2] <- 1 + # cpdag <- skel.amat + # + # ## search the v-structures in the DAG + # ind <- which((amat == 1 & t(amat) == 0), arr.ind = TRUE) + # tripleMatrix <- matrix(,0,3) + # ## Go through all edges + # for (i in seq_len(nrow(ind))) { ## MM(FIXME): growth of tripleMatrix + # x <- ind[i,1] + # y <- ind[i,2] + # indY <- setdiff(which((amat[,y] == 1 & amat[y,] == 0), arr.ind = TRUE),x) ## x-> y <- z + # if(length(newZ <- indY[amat[x,indY] == 0])) ## deparse.l.=0: no colnames + # tripleMatrix <- rbind(tripleMatrix, cbind(x, y, newZ, deparse.level=0), + # deparse.level=0) + # } + # if ((m <- nrow(tripleMatrix)) > 0) { + # deleteDupl <- logical(m)# all FALSE + # for (i in seq_len(m)) + # if (tripleMatrix[i,1] > tripleMatrix[i,3]) + # deleteDupl[i] <- TRUE + # if(any(deleteDupl)) + # tripleMatrix <- tripleMatrix[!deleteDupl,, drop=FALSE] + # + # ## orient the v-structures in the CPDAG + # for (i in seq_len(nrow(tripleMatrix))) { + # x <- tripleMatrix[i,1] + # y <- tripleMatrix[i,2] + # z <- tripleMatrix[i,3] + # cpdag[x,y] <- cpdag[z,y] <- 1 + # cpdag[y,x] <- cpdag[y,z] <- 0 + # } + # } + # + # ## orient the edges with the 3 orientation rules + # repeat { + # old_cpdag <- cpdag + # ## Rule 1 + # ind <- which((cpdag == 1 & t(cpdag) == 0), arr.ind = TRUE) + # for (i in seq_len(nrow(ind))) { + # a <- ind[i, 1] + # b <- ind[i, 2] + # isC <- ((cpdag[b, ] == 1 & cpdag[, b] == 1) & + # (cpdag[a, ] == 0 & cpdag[, a] == 0)) + # if (any(isC)) { + # indC <- which(isC) + # cpdag[b, indC] <- 1 + # cpdag[indC, b] <- 0 + # } + # } + # ## Rule 2 + # ind <- which((cpdag == 1 & t(cpdag) == 1), arr.ind = TRUE) + # for (i in seq_len(nrow(ind))) { + # a <- ind[i, 1] + # b <- ind[i, 2] + # isC <- ((cpdag[a, ] == 1 & cpdag[, a] == 0) & + # (cpdag[, b] == 1 & cpdag[b, ] == 0)) + # if (any(isC)) { + # cpdag[a, b] <- 1 + # cpdag[b, a] <- 0 + # } + # } + # ## Rule 3 + # ind <- which((cpdag == 1 & t(cpdag) == 1), arr.ind = TRUE) + # for (i in seq_len(nrow(ind))) { + # a <- ind[i, 1] + # b <- ind[i, 2] + # indC <- which((cpdag[a, ] == 1 & cpdag[, a] == 1) & + # (cpdag[, b] == 1 & cpdag[b, ] == 0)) + # if (length(indC) >= 2) { + # cmb.C <- combn(indC, 2) + # cC1 <- cmb.C[1, ] + # cC2 <- cmb.C[2, ] + # for (j in seq_along(cC1)) { + # c1 <- cC1[j] + # c2 <- cC2[j] + # if (c1 != c2 && cpdag[c1, c2] == 0 && cpdag[c2,c1] == 0) { + # cpdag[a, b] <- 1 + # cpdag[b, a] <- 0 + # break + # } + # } + # } + # } + # if (all(cpdag == old_cpdag)) + # break + # } + # as(cpdag,"graphNEL") + #} ## dag2cpdag <- function(dag) { - ## Purpose: Compute the (unique) completed partially directed graph (CPDAG) - ## that corresponds to the input DAG; result is a graph object - ## ---------------------------------------------------------------------- - ## Arguments: - ## - dag: input DAG (graph object) - ## ---------------------------------------------------------------------- - ## Author: Markus Kalisch, Date: 31 Oct 2006, 15:30 +## Purpose: Compute the (unique) completed partially directed graph (CPDAG) +## that corresponds to the input DAG; result is a graph object +## ---------------------------------------------------------------------- +## Arguments: +## - dag: input DAG (graph object) +## ---------------------------------------------------------------------- +## Author: Markus Kalisch, Date: 31 Oct 2006, 15:30 ## p <- numNodes(dag) ## ## transform DAG to adjacency matrix if any edges are present @@ -728,17 +724,17 @@ dag2cpdag <- function(g) ##} ## make.edge.df <- function(amat) { - ## Purpose: Generate a data frame describing some properties of a DAG - ## (for extending to a CPDAG) - ## The output contains xmin,xmax,head,tail,order (NA or number), - ## type (1="d",0="u") in lexikographic order - ## ---------------------------------------------------------------------- - ## Arguments: - ## - amat: Adjacency matrix of DAG [x_ij=1 means i->j] - ## ---------------------------------------------------------------------- - ## Author: Markus Kalisch, Date: 31 Oct 2006, 15:43 - - ## INPUT: Adjacency matrix +## Purpose: Generate a data frame describing some properties of a DAG +## (for extending to a CPDAG) +## The output contains xmin,xmax,head,tail,order (NA or number), +## type (1="d",0="u") in lexikographic order +## ---------------------------------------------------------------------- +## Arguments: +## - amat: Adjacency matrix of DAG [x_ij=1 means i->j] +## ---------------------------------------------------------------------- +## Author: Markus Kalisch, Date: 31 Oct 2006, 15:43 + +## INPUT: Adjacency matrix ## stopifnot(sum(amat)>0) ## e <- which(amat==1,arr.ind=TRUE) ## e.dup <- duplicated(t(apply(e,1,sort))) @@ -768,13 +764,13 @@ dag2cpdag <- function(g) ##} ## orderEdges <- function(amat) { - ## Purpose: Order the edges of a DAG according to Chickering - ## (for extension to CPDAG) - ## ---------------------------------------------------------------------- - ## Arguments: - ## - amat: Adjacency matrix of DAG - ## ---------------------------------------------------------------------- - ## Author: Markus Kalisch, Date: 31 Oct 2006, 15:42 +## Purpose: Order the edges of a DAG according to Chickering +## (for extension to CPDAG) +## ---------------------------------------------------------------------- +## Arguments: +## - amat: Adjacency matrix of DAG +## ---------------------------------------------------------------------- +## Author: Markus Kalisch, Date: 31 Oct 2006, 15:42 ## stopifnot(isAcyclic(amat)) ## ordered.nodes <- topOrder(amat) ## parents before children @@ -783,29 +779,29 @@ dag2cpdag <- function(g) ## eOrder <- 0 ## while(any(unOrdered <- is.na(edge.df$order))) { ## counter <- 0 - ## find y +## find y ## y <- NA ## found <- FALSE ## while(!found) { ## counter <- counter+1 ## node <- ordered.nodes[counter] - ## which edges are incident to node? +## which edges are incident to node? ## nbr.nodes <- which(amat[,node]==1) ## if(length(nbr.nodes)>0) { ## unlabeled <- rep.int(FALSE, length(nbr.nodes)) ## for(i in seq_along(nbr.nodes)) { ## x <- nbr.nodes[i] - ## is edge edge x-y unlabeled? +## is edge edge x-y unlabeled? ## unlabeled[i] <- length(intersect(which(edge.df$xmin==min(node,x) & ## edge.df$xmax==max(node,x)), ## which(unOrdered))) > 0 ## } - ## choose unlabeled edge with highest order node +## choose unlabeled edge with highest order node ## if(any(unlabeled)) { ## nbr.unlab <- nbr.nodes[unlabeled] # nbrnodes w. unlabeled edges ## tmp <- ordered.nodes[ordered.nodes %in% nbr.unlab] ## y <- tmp[length(tmp)] - ## y <- last(ordered.nodes[which(ordered.nodes %in% nbr.unlab)]) +## y <- last(ordered.nodes[which(ordered.nodes %in% nbr.unlab)]) ## edge.df$order[edge.df$xmin==min(node,y) & ## edge.df$xmax==max(node,y)] <- eOrder ## eOrder <- eOrder+1 @@ -821,16 +817,16 @@ dag2cpdag <- function(g) ## labelEdges <- function(amat) { - ## Purpose: Label the edges in a DAG with "compelled" and "reversible" - ## (for extension to a CPDAG) - ## ---------------------------------------------------------------------- - ## Arguments: - ## - amat: Adjacency matrix of DAG - ## ---------------------------------------------------------------------- - ## Author: Markus Kalisch, Date: 31 Oct 2006; prettified: MMaechler - - ## label=TRUE -> compelled - ## label=FALSE -> reversible +## Purpose: Label the edges in a DAG with "compelled" and "reversible" +## (for extension to a CPDAG) +## ---------------------------------------------------------------------- +## Arguments: +## - amat: Adjacency matrix of DAG +## ---------------------------------------------------------------------- +## Author: Markus Kalisch, Date: 31 Oct 2006; prettified: MMaechler + +## label=TRUE -> compelled +## label=FALSE -> reversible ## edge.df <- orderEdges(amat) ## lab <- rep(NA,dim(edge.df)[1]) ## edge.df <- edge.df[order(edge.df$order),] @@ -852,7 +848,7 @@ dag2cpdag <- function(g) ## break ## } ## } - ## edges going to y not starting from x +## edges going to y not starting from x ## cand <- which(y.is.head & Tail != x) ## if (length(cand) > 0) { ## valid.cand <- rep(FALSE,length(cand)) @@ -906,10 +902,10 @@ adj.check <- function(gm,x) { ## undirected neighbors of x un <- which(xr & xc) for(y in un) { - adj.x <- setdiff(nx, y) - adj.y <- setdiff(which(gm.1[y,] | gm.1[,y]), x) - if(!all(adj.x %in% adj.y)) - return(FALSE) + adj.x <- setdiff(nx, y) + adj.y <- setdiff(which(gm.1[y,] | gm.1[,y]), x) + if(!all(adj.x %in% adj.y)) + return(FALSE) } TRUE } @@ -918,6 +914,7 @@ adj.check <- function(gm,x) { amat2dag <- function(amat) { ## Purpose: Transform the adjacency matrix of an PDAG to the adjacency ## matrix of a SOME DAG in the equiv. class + ## Used in pdag2dag if extension is not possible ## ---------------------------------------------------------------------- ## Arguments: ## - amat: adjacency matrix; x -> y if amat[x,y]=1,amat[y,x]=0 @@ -972,7 +969,7 @@ udag2pdag <- function(gInput, verbose = FALSE) { for (z in allZ) { if (g[x,z] == 0 && !(y %in% gInput@sepset[[x]][[z]] || - y %in% gInput@sepset[[z]][[x]])) { + y %in% gInput@sepset[[z]][[x]])) { if (verbose) { cat("\n",x,"->",y,"<-",z,"\n") cat("Sxz=",gInput@sepset[[z]][[x]],"Szx=",gInput@sepset[[x]][[z]]) @@ -1018,7 +1015,7 @@ udag2pdag <- function(gInput, verbose = FALSE) { pdag[a,b] <- 1 pdag[b,a] <- 0 if (verbose) cat("\nRule 2: Kette ",a,"->",indC,"->", - b,":",a,"->",b,"\n") + b,":",a,"->",b,"\n") } } ## x11() @@ -1097,8 +1094,8 @@ shd <- function(g1,g2) ## ---------------------------------------------------------------------- ## Author: Markus Kalisch, Date: 1 Dec 2006, 17:21 - ## Idea: Transform g1 into g2 - ## Transform g1 and g2 into adjacency matrices + ## Idea: Transform g1 into g2 + ## Transform g1 and g2 into adjacency matrices if (is(g1, "pcAlgo")) g1 <- g1@graph if (is(g2, "pcAlgo")) g2 <- g2@graph @@ -1112,7 +1109,7 @@ shd <- function(g1,g2) } shd <- 0 - ## Remove superfluous edges from g1 + ## Remove superfluous edges from g1 s1 <- m1 + t(m1) s2 <- m2 + t(m2) s1[s1 == 2] <- 1 @@ -1121,11 +1118,11 @@ shd <- function(g1,g2) ind <- which(ds > 0) m1[ind] <- 0 shd <- shd + length(ind)/2 - ## Add missing edges to g1 + ## Add missing edges to g1 ind <- which(ds < 0) m1[ind] <- m2[ind] shd <- shd + length(ind)/2 - ## Compare Orientation + ## Compare Orientation d <- abs(m1-m2) ## return shd + sum((d + t(d)) > 0)/2 @@ -1145,247 +1142,6 @@ ci.test <- function(x,y, S = NULL, dm.df) { vcd::coindep_test(tab,3:(length(S)+2))$p.value } -pcAlgo <- function(dm = NA, C = NA, n = NA, alpha, corMethod = "standard", - verbose = FALSE, directed = FALSE, - G = NULL, datatype = 'continuous', NAdelete = TRUE, - m.max = Inf, u2pd = "rand", psepset = FALSE) { - ## Purpose: Perform PC-Algorithm, i.e., estimate skeleton of DAG given data - ## Output is an unoriented graph object - ## ---------------------------------------------------------------------- - ## Arguments: - ## - dm: Data matrix (rows: samples, cols: nodes) - ## - C: correlation matrix (only for continuous) - ## - n: sample size - ## - alpha: Significance level of individual partial correlation tests - ## - corMethod: "standard" or "Qn" for standard or robust correlation - ## estimation - ## - G: the adjacency matrix of the graph from which the algorithm - ## should start (logical) - ## - datatype: distinguish between discrete and continuous data - ## - NAdelete: delete edge if pval=NA (for discrete data) - ## - m.max: maximal size of conditioning set - ## - u2pd: Function for converting udag to pdag - ## "rand": udag2pdagu - ## "relaxed": udag2pdagRelaxed - ## "retry": udag2pdagSpecial - ## - psepset: Also check possible sep sets. - ## ---------------------------------------------------------------------- - ## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler - ## Modifications: Sarah Gerster, Diego Colombo - - .Deprecated(msg = "pcAlgo() is deprecated and only kept for backward compatibility. - Please use skeleton, pc, or fci instead\n") - cl <- match.call() - - if (any(is.na(dm))) { - stopifnot(all(!is.na(C)),!is.na(n), (p <- ncol(C)) > 0) - } else { - n <- nrow(dm) - p <- ncol(dm) - } - n <- as.integer(n) - - if (is.null(G)) { - ## G := complete graph : - G <- matrix(TRUE, p,p) - diag(G) <- FALSE - } else if (!(identical(dim(G),c(p,p)))) - stop("Dimensions of the dataset and G do not agree.") - - seq_p <- seq_len(p) - sepset <- pl <- vector("list",p) - for (i in seq_p) sepset[[i]] <- pl - zMin <- matrix(Inf, p,p) - n.edgetests <- numeric(1)# final length = max { ord} - done <- FALSE - ord <- 0 - - if (datatype == 'continuous') { - diag(zMin) <- 0 - if (any(is.na(C))) C <- mcor(dm, method = corMethod) - cutoff <- qnorm(1 - alpha/2) - while (!done && any(G) && ord <= m.max) { - n.edgetests[ord+1] <- 0 - done <- TRUE - ind <- which(G, arr.ind = TRUE) - ## For comparison with C++ sort according to first row - ind <- ind[order(ind[,1]), ] - remEdges <- nrow(ind) - if(verbose) - cat("Order=",ord,"; remaining edges:",remEdges,"\n", sep = '') - for (i in 1:remEdges) { - if(verbose && i%%100 == 0) cat("|i=",i,"|iMax=",remEdges,"\n") - x <- ind[i,1] - y <- ind[i,2] - if (G[y,x]) { - nbrsBool <- G[,x] - nbrsBool[y] <- FALSE - nbrs <- seq_p[nbrsBool] - length_nbrs <- length(nbrs) - if (length_nbrs >= ord) { - if (length_nbrs > ord) done <- FALSE - S <- seq(length = ord) - repeat { ## condition w.r.to all nbrs[S] of size 'ord' - n.edgetests[ord+1] <- n.edgetests[ord+1]+1 - z <- zStat(x,y, nbrs[S], C,n) - if (verbose) cat(paste("x:",x,"y:",y,"S:"),nbrs[S],paste("z:",z,"\n")) - if(abs(z) < zMin[x,y]) zMin[x,y] <- abs(z) - if (abs(z) <= cutoff) { - G[x,y] <- G[y,x] <- FALSE - sepset[[x]][[y]] <- nbrs[S] - break - } else { - nextSet <- getNextSet(length_nbrs, ord, S) - if(nextSet$wasLast) - break - S <- nextSet$nextSet - } - } - } - } ## end if(!done) - - } ## end for(i ..) - ord <- ord+1 - ## n.edgetests[ord] <- remEdges - } ## while - - for (i in 1:(p-1)) { - for (j in 2:p) { - zMin[i,j] <- zMin[j,i] <- min(zMin[i,j],zMin[j,i]) - } - } - } - else { - ## - ## - ## DISCRETE DATA ###################################################### - ## - if (datatype == 'discrete') { - dm.df <- as.data.frame(dm) - while (!done && any(G) && ord <= m.max) { - n.edgetests[ord+1] <- 0 - done <- TRUE - ind <- which(G, arr.ind = TRUE) - ## For comparison with C++ sort according to first row - ind <- ind[order(ind[,1]), ] - remEdges <- nrow(ind) - if(verbose) - cat("Order=",ord,"; remaining edges:",remEdges,"\n", sep = '') - for (i in 1:remEdges) { - if(verbose) { if(i%%100 == 0) cat("|i=",i,"|iMax=",remEdges,"\n") } - x <- ind[i,1] - y <- ind[i,2] - if (G[y,x]) { - nbrsBool <- G[,x] - nbrsBool[y] <- FALSE - nbrs <- seq_p[nbrsBool] - length_nbrs <- length(nbrs) - if (length_nbrs >= ord) { - if (length_nbrs > ord) done <- FALSE - S <- seq(length = ord) - repeat { ## condition w.r.to all nbrs[S] of size 'ord' - n.edgetests[ord+1] <- n.edgetests[ord+1]+1 - prob <- ci.test(x,y, nbrs[S], dm.df) - if (verbose) cat("x=",x," y=",y," S=",nbrs[S],":",prob,"\n") - if (is.na(prob)) prob <- if(NAdelete) 1 else 0 - if(prob >= alpha) { # independent - G[x,y] <- G[y,x] <- FALSE - sepset[[x]][[y]] <- nbrs[S] - break - } else { - nextSet <- getNextSet(length_nbrs, ord, S) - if(nextSet$wasLast) - break - S <- nextSet$nextSet - } - } - } - } ## end if(!done) - - } ## end for(i ..) - ord <- ord+1 - ## n.edgetests[ord] <- remEdges - } ## while - } else - stop("Datatype must be 'continuous' or 'discrete'.") - } - - if (psepset) { - amat <- G - ind <- which(G, arr.ind = TRUE) - storage.mode(amat) <- "integer" # (TRUE, FALSE) --> (1, 0) - ## Orient colliders - for (i in seq_len(nrow(ind))) { - x <- ind[i,1] - y <- ind[i,2] - allZ <- setdiff(which(amat[y,] == 1),x) ## x-y-z - - for (z in allZ) { - if (amat[x,z] == 0 && - !((y %in% sepset[[x]][[z]]) || - (y %in% sepset[[z]][[x]]))) { - if (verbose >= 2) { - cat("\n",x,"*->",y,"<-*",z,"\n") - cat("Sxz=",sepset[[z]][[x]],"and","Szx=",sepset[[x]][[z]],"\n") - } - - ## x o-> y <-o z - amat[x,y] <- amat[z,y] <- 2 - - } ## for - } ## if - } ## for - - ## Compute poss. sepsets - for (x in 1:p) { - attr(x,'class') <- 'possibledsep' - if (any(amat[x,] != 0)) { - tf1 <- setdiff(reach(x,-1,-1,amat), x) - for (y in seq_p[amat[x,] != 0]) { - ## tf = possible_d_sep(amat,x,y) - tf <- setdiff(tf1,y) - ## test - if (length(tf) > 0) { - az <- abs(zStat(x,y,tf,C,n)) - if (az < zMin[x,y]) zMin[x,y] <- az - if (az <= cutoff) { - ## delete x-y - amat[x, y] <- amat[y, x] <- 0 - ## save pos d-sepset in sepset - sepset[[x]][[y]] <- tf - } - if (verbose >= 2) - cat("Possible-D-Sep of", x, "and", y, "is", tf, " - |z| = ",az,"\n") - } - } - } - } - G[amat == 0] <- FALSE - G[amat == 1] <- TRUE - } ## end if(psepset) - - if(verbose) { cat("Final graph adjacency matrix:\n"); print(symnum(G)) } - - ## transform matrix to graph object (if not deprecated anyway: FIX to use correct node names!) - Gobject <- if (sum(G) == 0) { - new("graphNEL", nodes = as.character(seq_p)) - } else { - colnames(G) <- rownames(G) <- as.character(seq_p) - as(G,"graphNEL") - } - - res <- new("pcAlgo", graph = Gobject, - call = cl, n = n, max.ord = as.integer(ord-1), - n.edgetests = n.edgetests, sepset = sepset, - zMin = zMin) - if (directed) - switch (u2pd, - "rand" = udag2pdag (res), - "retry" = udag2pdagSpecial(res)$pcObj, - "relaxed" = udag2pdagRelaxed(res)) - else - res -} ## {pcAlgo} __ deprecated __ flipEdges <- function(amat,ind) { res <- amat @@ -1448,10 +1204,10 @@ pdag2dag <- function(g, keepVstruct = TRUE) { }## { while } graph <- if (not.yet) { - ## warning("PDAG not extendible: Random DAG on skeleton drawn") - as(amat2dag(gm), "graphNEL") - } else ## success : - as(t(gm2), "graphNEL") + ## warning("PDAG not extendible: Random DAG on skeleton drawn") + as(amat2dag(gm), "graphNEL") + } else ## success : + as(t(gm2), "graphNEL") } list(graph = graph, success = !not.yet) } @@ -1904,316 +1660,9 @@ udag2pdagRelaxed <- function(gInput, verbose = FALSE, unfVect = NULL, solve.conf } -## DEPRECATED! -- use ida() -- -beta.special <- function(dat = NA, x.pos, y.pos, verbose = 0, a = 0.01, - myDAG = NA, myplot = FALSE, perfect = FALSE, - method = "local", collTest = TRUE, pcObj = NA, all.dags = NA, u2pd = "rand") -{ - ## Purpose: Estimate the causal effect of x on y; the pcObj and all DAGs - ## can be precomputed - ## ---------------------------------------------------------------------- - ## Arguments: - ## - dat: data - ## - x.pos, y.pos: Column of x and y in d.mat - ## - verbose: 0=no comments, 1=progress in BB, 2=detail on estimates - ## - a: significance level of tests for finding CPDAG - ## - myDAG: needed if bootstrp==FALSE - ## - myplot: plot estimated graph - ## - perfect: True cor matrix is calculated from myDAG - ## - method: "local" - local (all combinations of parents in regr.) - ## "global" - all DAGs - ## - collTest: True - Exclude orientations of undirected edges that - ## introduce a new collider - ## - pcObj: Fit of PC Algorithm (semidirected); if this is available, no - ## new fit is done - ## - all.dags: All DAGs in the format of function allDags; if this is - ## available, no new function call allDags is done - ## - u2pd: Function for converting udag to pdag - ## "rand": udag2pdag - ## "relaxed": udag2pdagRelaxed - ## "retry": udag2pdagSpecial - ## ---------------------------------------------------------------------- - ## Value: causal values - ## ---------------------------------------------------------------------- - ## Author: Markus Kalisch, Date: 21 Nov 2007, 11:18 - - cat("This function is deprecated and is only kept for backward compatibility. -Please use ida or idaFast instead\n") - ## Covariance matrix: Perfect case / standard case - if (perfect) { - if(!is(myDAG, "graphNEL")) stop("For perfect-option the true DAG is needed!") - mcov <- trueCov(myDAG) - mcor <- cov2cor(mcov) - } else { - mcov <- cov(dat) - } - ## estimate skeleton and CPDAG of given data - res <- - if (is(pcObj, "pcAlgo")) - pcObj - else if(perfect) - pcAlgo.Perfect(mcor, corMethod = "standard",directed = TRUE,u2pd = u2pd) - else - pcAlgo(dat, alpha = a, corMethod = "standard",directed = TRUE,u2pd = u2pd) - - ## prepare adjMatrix and skeleton {MM FIXME : can be improved} - amat <- ad.res <- wgtMatrix(res@graph) - amat[which(amat != 0)] <- 1 ## i->j if amat[j,i]==1 - amatSkel <- amat + t(amat) - amatSkel[amatSkel != 0] <- 1 - if (method == "local") { -############################## - ## local method - ## Main Input: mcov -############################## - ## find unique parents of x - wgt.est <- ad.res - tmp <- wgt.est-t(wgt.est) - tmp[which(tmp < 0)] <- 0 - wgt.unique <- tmp - pa1 <- which(wgt.unique[x.pos,] != 0) - if (y.pos %in% pa1) { - ## x is parent of y -> zero effect - beta.hat <- 0 - } else { ## y.pos not in pa1 - ## find ambiguous parents of x - wgt.ambig <- wgt.est-wgt.unique - pa2 <- which(wgt.ambig[x.pos,] != 0) - if (verbose == 2) { - cat("\n\nx=",x.pos,"y=",y.pos,"\n") - cat("pa1=",pa1,"\n") - cat("pa2=",pa2,"\n") - } - - ## estimate beta - if (length(pa2) == 0) { - beta.hat <- lm.cov(mcov, y.pos, c(x.pos,pa1)) - if (verbose == 2) - cat("Fit - y:",y.pos, "x:",c(x.pos,pa1), "|b.hat=", beta.hat) - } else { - beta.hat <- NA - ii <- 1 - ## no member of pa2 - pa2.f <- pa2 - pa2.t <- NA - ## check for new collider - if (!collTest || !has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { - beta.hat[ii] <- lm.cov(mcov,y.pos,c(x.pos,pa1)) - if (verbose == 2) - cat("\ny:",y.pos,"x:",c(x.pos,pa1),"|b.hat=", beta.hat[ii]) - }## else { - ## cat("\nx:",x.pos," pa1:",pa1," pa2.t:",pa2.t," pa2.f:",pa2.f) - ## } - ## exactly one member of pa2 - for (i2 in seq_along(pa2)) { - ## check for new collider - pa2.f <- pa2[-i2] - pa2.t <- pa2[i2] - if (!collTest || !has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { - ii <- ii+1 - if (y.pos %in% pa2.t) { - ## cat("Y in Parents: ",y.pos," in ",pa2.t,"\n") - beta.hat[ii] <- 0 - } else { - beta.hat[ii] <- lm.cov(mcov,y.pos,c(x.pos,pa1,pa2[i2])) - } - if (verbose == 2) { cat("\ny:",y.pos,"x:",c(x.pos,pa1,pa2[i2]), - "|b.hat=",beta.hat[ii]) -} - } else { - ## cat("\nx:",x.pos," pa1:",pa1," pa2.t:",pa2.t," pa2.f:",pa2.f) - } - } - ## higher order subsets - if (length(pa2) > 1) { - for (i in 2:length(pa2)) { - pa.tmp <- combn(pa2, i, simplify = TRUE) - for (j in seq_len(ncol(pa.tmp))) { - pa2.t <- pa.tmp[,j] - pa2.f <- setdiff(pa2,pa2.t) - ## teste auf neuen collider - if (!collTest || !has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { - ii <- ii+1 - if (y.pos %in% pa2.t) { - cat("Y in Parents: ",y.pos," in ",pa2.t,"\n") - beta.hat[ii] <- 0 - } else { - beta.hat[ii] <- lm.cov(mcov,y.pos,c(x.pos,pa1,pa2.t)) - } - if (verbose == 2) { cat("\ny:",y.pos,"x:",c(x.pos,pa1,pa2.t), - "|b.hat=",beta.hat[ii]) -} - } else { - ## cat("\nx:",x.pos," pa1:",pa1," pa2.t:",pa2.t," pa2.f:",pa2.f) - } - } - } - } - } ## if pa2 - } ## if y in pa1 - } else { -############################## - ## global method - ## Main Input: mcov -############################## - p <- numNodes(res@graph) - am.pdag <- ad.res - am.pdag[am.pdag != 0] <- 1 - ## find all DAGs if not provided externally - ad <- if (is.na(all.dags)) allDags(am.pdag,am.pdag,NULL) else all.dags - n.dags <- nrow(ad) - beta.hat <- rep.int(NA,n.dags) - if (n.dags > 0) { - if (myplot) { - ## x11() - par(mfrow = c(ceiling(sqrt(n.dags)), round(sqrt(n.dags)) )) - } - for (i in 1:n.dags) { - ## compute effect for every DAG - gDag <- as(matrix(ad[i,],p,p),"graphNEL") - if (myplot) Rgraphviz::plot(gDag) - ## path from y to x - rev.pth <- RBGL::sp.between(gDag,as.character(y.pos), - as.character(x.pos))[[1]]$path - if (length(rev.pth) > 1) { - ## if reverse path exists, beta=0 - beta.hat[i] <- 0 - } else { - ## path from x to y - pth <- RBGL::sp.between(gDag,as.character(x.pos), - as.character(y.pos))[[1]]$path - if (length(pth) < 2) { - ## sic! There is NO path from x to y - beta.hat[i] <- 0 - } else { - ## There is a path from x to y - wgt.unique <- t(matrix(ad[i,],p,p)) ## wgt.est is wgtMatrix of DAG - pa1 <- which(wgt.unique[x.pos,] != 0) - if (y.pos %in% pa1) { - cat("Y in Parents: ",y.pos," in ",pa1,"\n") - beta.hat[i] <- 0 - } else { - beta.hat[i] <- lm.cov(mcov,y.pos,c(x.pos,pa1)) - } - if (verbose == 2) - cat("Fit - y:",y.pos,"x:",c(x.pos,pa1), "|b.hat=",beta.hat,"\n") - } ## if length(pth) - } ## if rev.pth - } ## for n.dags - } ## if n.dags - } ## if method - beta.hat -} ## {beta.special} - - - -## DEPRECATED! -- use ida() / idafast() -- -beta.special.pcObj <- function(x.pos,y.pos,pcObj,mcov = NA,amat = NA,amatSkel = NA, - t.amat = NA) -{ - ## Purpose: Estimate the causal effect of x on y; the pcObj has to be - ## precomputed. This method is intended to be a fast version of - ## - ## beta.special(dat=NA,x.pos,y.pos,verbose=0,a=NA,myDAG=NA,myplot=FALSE, - ## perfect=FALSE,method="local",collTest=TRUE,pcObj=pcObj,all.dags=NA,u2pd="relaxed") - ## - ## Thus, this is a faster version for the local method given a - ## precomputed PC-Algo Object (relaxed udag2pdag, so CPDAG might not - ## be a real CPDAG; this does not matter, since we try not to extend). - ## ---------------------------------------------------------------------- - ## Arguments: - ## - x.pos, y.pos: Column of x and y in d.mat - ## - pcObj: Fit of pc Algorithm (semidirected); if this is available, no - ## new fit is done - ## - mcov: covariance matrix of pcObj fit - ## - amat,amatSkel,g2,t.amat are variants of the adjacency matrix that - ## are used internally but can be precomputed; the relevant code - ## is commented out - ## ---------------------------------------------------------------------- - ## Value: List with two elements - ## - beta.res: beta.causal values - ## ---------------------------------------------------------------------- - ## Author: Markus Kalisch, Date: 21 Nov 2007, 11:18 - - cat("This function is deprecated and is only kept for backward compatibility. -Please use ida or idaFast instead\n") - - if (is.na(amat) | is.na(amatSkel) | is.na(t.amat)) { - ## Code for computing precomputable variables - ## prepare adjMatrix and skeleton {MM FIXME : can be improved} - amat <- wgtMatrix(pcObj@graph) - amat[which(amat != 0)] <- 1 ## i->j if amat[j,i]==1 - t.amat <- t(amat) - amatSkel <- amat + t.amat - amatSkel[amatSkel != 0] <- 1 - } - - ## find unique parents of x - tmp <- amat-t.amat - tmp[which(tmp < 0)] <- 0 - wgt.unique <- tmp - pa1 <- which(wgt.unique[x.pos,] != 0) - if (y.pos %in% pa1) { - cat("Y in Parents: ",y.pos," in ",pa1,"\n") - beta.hat <- 0 - } else { ## y.pos not in pa1 - ## find ambiguous parents of x - wgt.ambig <- amat-wgt.unique - pa2 <- which(wgt.ambig[x.pos,] != 0) - pa2 <- setdiff(pa2,y.pos) - ## estimate beta - if (length(pa2) == 0) { - beta.hat <- lm.cov(mcov,y.pos,c(x.pos,pa1)) - } else { - beta.hat <- NA - ii <- 1 - ## no member of pa2 - ## check for new collider - pa2.f <- pa2 - pa2.t <- NA - if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { - beta.hat[ii] <- lm.cov(mcov,y.pos,c(x.pos,pa1)) - } - ## exactly one member of pa2 - for (i2 in seq_along(pa2)) { - ## check for new collider - pa2.f <- pa2[-i2] - pa2.t <- pa2[i2] - if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { - ii <- ii+1 - beta.hat[ii] <- - if (y.pos %in% pa2.t) { - cat("Y in Parents: ",y.pos," in ",pa2.t,"\n") - 0 - } else lm.cov(mcov,y.pos,c(x.pos,pa1,pa2[i2])) - } - } - ## higher order subsets - if (length(pa2) > 1) { - for (i in 2:length(pa2)) { - pa.tmp <- combn(pa2, i, simplify = TRUE) - for (j in seq_len(ncol(pa.tmp))) { - ## teste auf neuen collider - pa2.t <- pa.tmp[,j] - pa2.f <- setdiff(pa2,pa2.t) - if (!has.new.coll(amat,amatSkel,x.pos,pa1,pa2.t,pa2.f)) { - ii <- ii+1 - beta.hat[ii] <- - if (y.pos %in% pa2.t) { - cat("Y in Parents: ",y.pos," in ",pa2.t,"\n") - 0 - } else lm.cov(mcov,y.pos,c(x.pos,pa1,pa2.t)) - } - } - } - } ## if pa2 - } ## length(pa2) - } ## y.pos %in% pa2 - beta.hat -} ## {beta.special.pcObj} ##' @title ##' @param C covariance matrix @@ -2278,65 +1727,6 @@ has.new.coll <- function(amat,amatSkel, x, pa1, pa2.t, pa2.f) { res } -allDags <- function(gm,a,tmp, verbose = FALSE) -{ - ## Purpose: Find all DAGs for a given PDAG - ## ---------------------------------------------------------------------- - ## Arguments: - ## - gm: Adjacency matrix of initial PDAG; only 0-1 entries - ## i -> j iff gm(j,i)=1 - ## - a: copy of gm - ## - tmp: "current set of DAGs", initially NULL - ## ---------------------------------------------------------------------- - ## Value: - ## - one 0/1 adj.matrix per row - ## Reversion to graph: as(matrix(res[i,],p,p),"graphNEL") - ## Reversion to wgtMatrix (i->j iff a[j,i]=1): t(matrix(res[i,],p,p)) - ## ---------------------------------------------------------------------- - ## Author: Markus Kalisch, Date: 7 Apr 2008, 14:08 - if (sum(a) == 0) { - if (verbose) { - cat("Last Call - Final Graph: \n") - print(gm) - cat("#################### \n") - } - tmp2 <- rbind(tmp,c(t(gm))) - if (all(!duplicated(tmp2))) tmp <- tmp2 - } else { - sinks <- find.sink(a) - if (verbose) { - cat("Main Call: ################## \n") - print(gm) - print(a) - cat("Sinks: ",sinks,"\n") - } - for(x in sinks) { - if (verbose) cat("Try removing", x," in a.\n") - gm2 <- gm - a2 <- a - if (adj.check(a,x)) { - inc.to.x <- a[, x] == 1 & a[x, ] == 1 - if (any(inc.to.x)) { - real.inc.to.x <- as.numeric(rownames(a)[inc.to.x]) - real.x <- as.numeric(rownames(a)[x]) - gm2[real.x, real.inc.to.x] <- 1 - gm2[real.inc.to.x, real.x] <- 0 - } - a2 <- a[-x,-x] - if (verbose) { - cat("Removed sink",as.numeric(rownames(a)[x]), - "in g (", x,"in a).\n") - cat("New graphs: \n") - print(gm2) - print(a) - } - tmp <- allDags(gm2, a2, tmp, verbose) - ## ------- *recursively* - } - } - } - tmp -} pcAlgo.Perfect <- function(C, cutoff = 1e-8, corMethod = "standard", verbose = 0, directed = FALSE, u2pd = "rand", psepset = FALSE) { @@ -2575,50 +1965,11 @@ reach <- function(a,b,c,adjacency) } -plotAG <- function(amat) -{ - ## Purpose: Plot ancestral graph - ## ---------------------------------------------------------------------- - ## Arguments: - ## - amat: Adjacency matrix - ## amat[i,j]=3 & amat[j,i]=1 iff i 1-3 j - ## "0": no edge; "1": circle; "2": arrow; "3": tail - ## ---------------------------------------------------------------------- - ## Author: Markus Kalisch, Date: 16 Feb 2009, 18:01 - check.Rgraphviz() - - g <- as(amat,"graphNEL") - nn <- nodes(g) - p <- numNodes(g) - n.edges <- numEdges(g) - ah.list <- at.list <- rep("none",n.edges) - counter <- 0 - list.names <- NULL - amat[amat == 1] <- "odot" - amat[amat == 2] <- "normal" - amat[amat == 3] <- "none" - for (i in 1:(p-1)) { - for (j in (i+1):p) { - x <- nn[i] - y <- nn[j] - if (amat[x,y] != 0) { - counter <- counter + 1 - ah.list[[counter]] <- amat[x,y] - at.list[[counter]] <- amat[y,x] - list.names <- c(list.names,paste(x,"~",y,sep = "")) - } - } - } - names(ah.list) <- names(at.list) <- list.names - - edgeRenderInfo(g) <- list(arrowhead = ah.list, arrowtail = at.list) - Rgraphviz::renderGraph(Rgraphviz::layoutGraph(g)) -} skeleton <- function(suffStat, indepTest, alpha, labels, p, method = c("stable", "original", "stable.fast"), m.max = Inf, fixedGaps = NULL, fixedEdges = NULL, - NAdelete = TRUE, verbose = FALSE) + NAdelete = TRUE, numCores = 1, verbose = FALSE) { ## Purpose: Perform undirected part of PC-Algorithm, i.e., ## estimate skeleton of DAG given data @@ -2634,12 +1985,14 @@ skeleton <- function(suffStat, indepTest, alpha, labels, p, ## - fixedEdges: Edges marked here are not changed (logical) ## - NAdelete: delete edge if pval=NA (for discrete data) ## - m.max: maximal size of conditioning set + ## - numCores: number of cores to be used for calculation if + ## method = "stable.fast" ## ---------------------------------------------------------------------- ## Value: ## - G, sepset, pMax, ord, n.edgetests ## ---------------------------------------------------------------------- ## Author: Markus Kalisch, Date: 09.12.2009 - ## Modification: Diego Colombo; Martin Maechler + ## Modification: Diego Colombo; Martin Maechler; Alain Hauser ## x,y,S konstruieren ##- tst <- try(indepTest(x,y,S, obj)) @@ -2690,6 +2043,11 @@ skeleton <- function(suffStat, indepTest, alpha, labels, p, else if (!identical(fixedEdges, t(fixedEdges)) ) stop("fixedEdges must be symmetric") + ## Check number of cores + stopifnot((is.integer(numCores) || is.numeric(numCores)) && numCores > 0) + if (numCores > 1 && method != "stable.fast") { + warning("Argument numCores ignored: parallelization only available for method = 'stable.fast'") + } if (method == "stable.fast") { ## Do calculation in C++... if (identical(indepTest, gaussCItest)) @@ -2699,7 +2057,8 @@ skeleton <- function(suffStat, indepTest, alpha, labels, p, options <- list( verbose = as.integer(verbose), m.max = as.integer(ifelse(is.infinite(m.max), p, m.max)), - NAdelete = NAdelete) + NAdelete = NAdelete, + numCores = numCores) res <- .Call("estimateSkeleton", G, suffStat, indepTestName, indepTest, alpha, fixedEdges, options); G <- res$amat ## sepset <- res$sepset @@ -2803,7 +2162,7 @@ pc <- function(suffStat, indepTest, alpha, labels, p, u2pd = c("relaxed", "rand", "retry"), skel.method = c("stable", "original", "stable.fast"), conservative = FALSE, maj.rule = FALSE, - solve.confl = FALSE, verbose = FALSE) + solve.confl = FALSE, numCores = 1, verbose = FALSE) { ## Purpose: Perform PC-Algorithm, i.e., estimate skeleton of DAG given data ## ---------------------------------------------------------------------- @@ -2825,6 +2184,7 @@ pc <- function(suffStat, indepTest, alpha, labels, p, ## "retry": udag2pdagSpecial ## - gTrue: Graph suffStatect of true DAG ## - conservative: If TRUE, conservative PC is done + ## - numCores: handed to skeleton(), used for parallelization ## ---------------------------------------------------------------------- ## Author: Markus Kalisch, Date: 26 Jan 2006; Martin Maechler ## Modifications: Sarah Gerster, Diego Colombo, Markus Kalisch @@ -2860,7 +2220,7 @@ pc <- function(suffStat, indepTest, alpha, labels, p, ## Skeleton skel <- skeleton(suffStat, indepTest, alpha, labels = labels, method = skel.method, fixedGaps = fixedGaps, fixedEdges = fixedEdges, - NAdelete = NAdelete, m.max = m.max, verbose = verbose) + NAdelete=NAdelete, m.max=m.max, numCores=numCores, verbose=verbose) skel@call <- cl # so that makes it into result ## Orient edges @@ -3498,7 +2858,7 @@ dsep <- function(a,b, S = NULL, g, john.pairs = NULL) ## Author: Markus Kalisch ## Check that g is a DAG - amatTmp <- wgtMatrix(g) + amatTmp <- wgtMatrix(g) ## i->j if amatTmp[j,i]!=0 amatTmp[amatTmp != 0] <- 1 if (max(amatTmp+t(amatTmp)) > 1) stop("dsep: Undirected edge in input graph!") p <- numNodes(g) @@ -3516,6 +2876,9 @@ dsep <- function(a,b, S = NULL, g, john.pairs = NULL) gS <- subGraph(anc.set,g) ## Moralize in amatM + ## !!! in the following line: + ## i->j if amat[i,j], i.e. different than default coding !!! + ## (*) amat <- wgtMatrix(gS, transpose = FALSE) if(all(a0 <- amat == 0)) ## if no edge in graph, nodes are d-separated @@ -3529,6 +2892,7 @@ dsep <- function(a,b, S = NULL, g, john.pairs = NULL) ## input is guaranteed to be directed x <- ind[i,1] y <- ind[i,2] ## x -> y + ## using different coding, see (*) -> OK allZ <- setdiff(which(amat[y,] == 0 & amat[,y] == 1), x) ## x -> y <- z for (z in allZ) if (amat[x,z] == 0 && amat[z,x] == 0) @@ -3717,7 +3081,14 @@ ida <- function(x.pos, y.pos, mcov, graphEst, method = c("local","global"), } ## find all DAGs if not provided externally - ad <- if(is.na(all.dags)) allDags(am.pdag,am.pdag,NULL) else all.dags + ## ad <- if(is.na(all.dags)) allDags(am.pdag,am.pdag,NULL) else all.dags + if (is.na(all.dags)) { + ## allDags(am.pdag,am.pdag,NULL) + ad <- pdag2allDags(am.pdag)$dags + } else { + ad <- all.dags + } + n.dags <- nrow(ad) beta.hat <- rep(NA,n.dags) for (i in 1:n.dags) { @@ -4456,7 +3827,7 @@ fci <- function(suffStat, indepTest, alpha, labels, p, fixedGaps = NULL, fixedEdges = NULL, NAdelete = TRUE, m.max = Inf, pdsep.max = Inf, rules = rep(TRUE, 10), doPdsep = TRUE, biCC = FALSE, conservative = FALSE, - maj.rule = FALSE, verbose = FALSE) + maj.rule = FALSE, numCores = 1, verbose = FALSE) { ## Purpose: Perform FCI-Algorithm, i.e., estimate PAG ## ---------------------------------------------------------------------- @@ -4488,6 +3859,7 @@ fci <- function(suffStat, indepTest, alpha, labels, p, ## anytime for the Anytime FCI and in this cas m.max must be specified; ## or it can be adaptive for Adaptive Anytime FCI and in this case ## m.max must not be specified. + ## - numCores: handed to skeleton(), used for parallelization ## ---------------------------------------------------------------------- ## Author: Markus Kalisch, Date: Dec 2009; update: Diego Colombo, 2012; Martin Maechler, 2013 @@ -4522,7 +3894,7 @@ fci <- function(suffStat, indepTest, alpha, labels, p, skel <- skeleton(suffStat, indepTest, alpha, labels = labels, method = skel.method, fixedGaps = fixedGaps, fixedEdges = fixedEdges, - NAdelete = NAdelete, m.max = m.max, verbose = verbose) + NAdelete=NAdelete, m.max=m.max, numCores=numCores, verbose=verbose) skel@call <- cl # so that makes it into result G <- as(skel@graph, "matrix") sepset <- skel@sepset @@ -5355,7 +4727,7 @@ rfci <- function(suffStat, indepTest, alpha, labels, p, fixedGaps = NULL, fixedEdges = NULL, NAdelete = TRUE, m.max = Inf, rules = rep(TRUE, 10), conservative = FALSE, maj.rule = FALSE, - verbose = FALSE) + numCores = 1, verbose = FALSE) { ## Purpose: Perform RFCI-Algorithm, i.e., estimate PAG ## ---------------------------------------------------------------------- @@ -5377,6 +4749,7 @@ rfci <- function(suffStat, indepTest, alpha, labels, p, ## - maj.rule: TRUE or FALSE variable containing if the majority rule is ## used instead of the normal conservative ## - labels: names of the variables or nodes + ## - numCores: handed to skeleton(), used for parallelization ## ---------------------------------------------------------------------- ## Author: Diego Colombo, 2011; modifications: Martin Maechler @@ -5402,7 +4775,7 @@ rfci <- function(suffStat, indepTest, alpha, labels, p, skel <- skeleton(suffStat, indepTest, alpha, labels = labels, method = skel.method, fixedGaps = fixedGaps, fixedEdges = fixedEdges, - NAdelete = NAdelete, m.max = m.max, verbose = verbose) + NAdelete=NAdelete, m.max=m.max, numCores=numCores, verbose=verbose) sk.A <- as(skel@graph, "matrix") sepset <- skel@sepset ## the list of all ordered unshielded triples (the graph g does not change it is just a search!) @@ -6553,18 +5926,6 @@ showEdgeList <- function(object, labels = NULL) invisible(list(undir = u, direct = d)) } -showAmat <- function(object) { - g <- getGraph(object) - cat("\nAdjacency Matrix G:", - "G[i,j] = 1/2 if edge mark of edge i-j at j is head/tail.", - "", sep = "\n") - wm <- wgtMatrix(g) - mTmp <- t(wm - 2*t(wm)) - mTmp[ mTmp < 0 ] <- 2 - mTmp -} - - ####################################################################### ## Generalized backdoor criterion ####################################################################### @@ -6610,7 +5971,7 @@ possibleDe <- function(amat,x) ## possible descendants of x on definite status paths ## ---------------------------------------------------------------------- ## Arguments: - ## - amat: matrix corresponding to the DAG, CPDAG, MAG, or PAG + ## - amat: adjacency matrix of type amat.pag ## - x: node of interest ## ---------------------------------------------------------------------- ## Value: @@ -7400,8 +6761,105 @@ fciPlus <- function(suffStat, indepTest, alpha, labels, p, verbose=TRUE) max.ordPDSEP = integer(0), n.edgetests = integer(0), n.edgetestsPDSEP = integer(0), sepset = list(), pMax = matrix(0,1,1), allPdsep = list()) +} ## {fciPlus} + +## MM: Das braucht's ja wirklich nicht; wir haben extra gute summary(.) Methoden, +## wobei ich ja vor allem jene for "fciAlgo" in der (vor)letzten Version schön verbessert habe. +## Ich wollte sowieso vorschlagen, dass pcAlgo für die adj.Matrix "dasselbe" macht wie fciAlgo ! +displayAmat <- function(obj) { + ## Convert object of class 'fciAlgo' or 'pcAlgo' to + ## corresponding adjacency matrix of type 'amat.pag' + ## or 'amat.cpdag' + co <- class(obj) + if (co == "fciAlgo") { + amat <- obj@amat + type <- "amat.pag" + } else { + if (co == "pcAlgo") { + type <- "amat.cpdag" + amat <- wgtMatrix(obj@graph) + } else { + stop("showAmat: Class of input is not supported.") + } + } + list(amat = amat, type = type) } +pdag2allDags <- function(gm, verbose = FALSE) { + nodeNms <- colnames(gm) + p <- ncol(gm) + rownames(gm) <- colnames(gm) <- as.character(1:p) + + res <- allDags.internal(gm = gm, a = gm, tmp = NULL, verbose = verbose) + list(dags = res, nodeNms = nodeNms) +} + +allDags.internal <- function(gm,a,tmp, verbose = FALSE) +{ + ## Purpose: Find all DAGs for a given PDAG + ## ---------------------------------------------------------------------- + ## Arguments: + ## - gm: Adjacency matrix of initial PDAG of type \code{amat.cpdag} + ## - a: copy of gm + ## - tmp: "current set of DAGs", initially NULL + ## ---------------------------------------------------------------------- + ## Value: + ## - one 0/1 adj.matrix per row + ## Reversion to graph: as(matrix(res[i,],p,p),"graphNEL") + ## Reversion to wgtMatrix (i->j iff a[j,i]=1): t(matrix(res[i,],p,p)) + ## ---------------------------------------------------------------------- + ## Author: Markus Kalisch, Date: 7 Apr 2008, 14:08 + if (sum(a) == 0) { + if (verbose) { + cat("Last Call - Final Graph: \n") + print(gm) + cat("#################### \n") + } + tmp2 <- rbind(tmp,c(t(gm))) + if (all(!duplicated(tmp2))) tmp <- tmp2 + } else { + sinks <- find.sink(a) + if (verbose) { + cat("Main Call: ################## \n") + print(gm) + print(a) + cat("Sinks: ",sinks,"\n") + } + for(x in sinks) { + if (verbose) cat("Try removing", x," in a.\n") + gm2 <- gm + a2 <- a + if (adj.check(a,x)) { + inc.to.x <- a[, x] == 1 & a[x, ] == 1 + if (any(inc.to.x)) { + real.inc.to.x <- as.numeric(rownames(a)[inc.to.x]) + real.x <- as.numeric(rownames(a)[x]) + gm2[real.x, real.inc.to.x] <- 1 + gm2[real.inc.to.x, real.x] <- 0 + } + a2 <- a[-x,-x] + if (verbose) { + cat("Removed sink",as.numeric(rownames(a)[x]), + "in g (", x,"in a).\n") + cat("New graphs: \n") + print(gm2) + print(a2) + } + tmp <- allDags.internal(gm2, a2, tmp, verbose) + ## ------- *recursively* + } + } + } + tmp +} + + + + + + +###-- This *MUST* remain at bottom of file ! +###-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ### MM: (ess-set-style 'DEFAULT) : we have much nesting ==> only indent by 2 ## Local Variables: ## eval: (ess-set-style 'DEFAULT 'quiet) diff --git a/TODO b/TODO index f683979..52a8ae4 100644 --- a/TODO +++ b/TODO @@ -1,27 +1,37 @@ ##-*- mode: org -*- Emacs org: use [Tab] ``all the time'' - -* TODO NAMESPACE and "internal" functions: +Priority: +Higher-order bullet point "inherits" max. priority of all +lower-order bullet points. +1 (top): Do before substantial writing starts +2: Do before submission +3: Do if there is enough time +4 = DONE + +* TODO (2) NAMESPACE and "internal" functions: ** DONE Look at ./NAMESPACE and replace *ALL* the Imports() by ImportsFrom(.) -** TODO What do we export / what not? <--> [[man/pcalg-internal.Rd]] +** TODO (2) What do we export / what not? <--> [[man/pcalg-internal.Rd]] The concept of such "internal" functions really *predates* the use of NAMESPACEs and is now obsolete. *** DONE Many of these should be *removed* for the .Rd page *and* from NAMESPACE. -*** TODO The others will be kept, but "well" documented, i.e., in a different .Rd file : - rfci.vStruc renamed; TODO (MM) - allDags mentioned in other help pages !! - amat2dag() in [[../tests/test_amat2dag.R]] -*** Goal: Get rid of [[man/pcalg-internal.Rd]] entirely. - -* TODO Remarks on specific functions and issues: -** TODO skeleton(): keep back compatibility update= c("stable","original") <<---MM +*** TODO (2) The others will be kept, but "well" documented, i.e., in a different .Rd file : +**** TODO (2,MK) rfci.vStruc renamed; TODO (MM) +**** DONE allDags mentioned in other help pages !! +**** TODO (2,MK) amat2dag() in [[../tests/test_amat2dag.R]] +*** TODO (3) Get rid of [[man/pcalg-internal.Rd]] entirely. + +* TODO (2)Remarks on specific functions and issues: +** TODO (2) skeleton(): keep back compatibility update= c("stable","original") <<---MM *** DONE in code -*** TODO but MM's tests show NOT QUITE back compatibility +*** TODO (2, MM), evt (3) but MM's tests show NOT QUITE back compatibility ** DONE pag2mag() return adj.matrix instead of *object* -> named pag2magAM() whereas dag2pag() does return more than just an adj.matrix. Change BEFORE release -** TODO pc(), probably fci() etc: loses variable labels and works with "1", "2",...??? +** TODO (2,MM) pc(), probably fci() etc: loses variable labels and works with "1", "2",...??? --> file:/u/maechler/R/MM/Pkg-ex/pcalg/Borsboom_mail.R is an example where he explicitly calls an other package just to get sensible labeled plots. -** TODO fci() et al : sparse matrices [Matrix] ? +** TODO (2,MK) Graph Node Labels <==> rownames(A): Still a mess, sometimes using as.numeric(rownames(.)), + e.g. in my.SpecialDag() in [[R/pcalg.R]] + +** TODO (3) fci() et al : sparse matrices [Matrix] ? - returns the adjacency matrix "@ amat" (among other things), a simple matrix with entries in {0,1,2,3}. It would be nice to allow *sparse* matrices here, @@ -30,14 +40,14 @@ This makes sense mostly if it's realistic to have quite sparse and relatively large sets of variables. -** TODO gAlgo-class: consider using setMethod(., "gAlgo") +** TODO (3) gAlgo-class: consider using setMethod(., "gAlgo") instead of all methods (plot, summary) for both pcAlgo and fciAlgo ** DONE myCItest() in Vignette vignettes/pcalgDoc.Rnw instead of lm() twice, use lm.fit *once* (*multivariate* regression). This will probably be much faster. -** TODO ida(): argument 'all.dags' is never used, i.e., never tested. +** TODO (2,MK) ida(): argument 'all.dags' is never used, i.e., never tested. ** DONE dsepTest(): gibt 0 / 1 zurück; wieso nicht FALSE/TRUE wie dsep()? A:"P-value" -** TODO I've introduced 'max.chordal = 10' to 'backdoor()' +** TODO (3) I've introduced 'max.chordal = 10' to 'backdoor()' which was hidden in the code previously. Have you ever tried larger/smaller? ** DONE gSquareBin(), gSquareDis(): - returns a P-value but not the test statistic. Should *really* return @@ -45,27 +55,23 @@ statistic, ...). But they have been documented to do what they do, and so we keep them. -** TODO pc(*, verbose=TRUE) for a "large" example with 18 vars: *much* output; +** TODO (2,MK) pc(*, verbose=TRUE) for a "large" example with 18 vars: *much* output; and the 10 rules at the very end. Better: verbose in { 0,1,2 (, 3) } and verbose=1 should give much less than TRUE now - - -* TODO Package 'ggm' has topOrder() for topological ordering. Should allow to use it, - e.g., optionally in unifDAG(.), or also rmvDAG() to fixup a non-top.ordered input. -** TODO MM: ggm::topOrder() can be made faster -* Parallelize option -* Allow 'tiers' (as in Tetrad), and 'background knowledge' (about orientations etc). - -* TODO Robustness examples that pcAlgo() had explicitly: add _examples_ using robust cov() -* / correlation methods? ---> indepTest argument: Qn ? --> Martin +* TODO (1, MM) Package 'ggm' has topOrder() for topological ordering. Should allow to use it, + e.g., optionally ('topOrder=FALSE') in unifDAG(.) and randDAG() to fixup a non-top.ordered input. +** TODO (3) MM: ggm::topOrder() can be made faster +* DONE (1, MM): as(, "amat") gives a "amat"-object with 'type' and print() method. + see also 'Adjacency Matrices' in the "Internal Programming" part below. +* TODO (3) Parallelize option +* TODO (3) Allow 'tiers' (as in Tetrad), and 'background knowledge' (about orientations etc). +* TODO (2,MM) Robustness examples that pcAlgo() had explicitly: add _examples_ using robust mcor() + 2 of pc(), fci(), rfci(), fciPlus() -------------------------------------------------------------------------- * DONE find.unsh.triple(): remove arg 'p' -* TODO MK[2013-12-17]: allDags(): noch keine Hilfeseite -> moechte bald eine grosse Aenderung der Funktion machen (inkl. Parameter) -* TODO MK[2013-12-17]: Letztest Bsp in fci(): p-1 statt p im Argument, weil eine (latente) Var gelöscht wurde - -* TODO MK[2013-12-17]: Make a fast dsep function for testing (using a lot of precomputation; e.g. ancestors, parents that are not married, so that finding moral graph becomes trivial; we then only need to check separation; could also tsort all nodes and precompute one moral graph for every element in the tsorted node sequence (~p graphs); then, the test boils down to a mere separation test - +* DONE MK[2013-12-17]: added and documented function pdag2allDags; deprecated function allDags +* TODO (2) MK[2013-12-17]: Letztest Bsp in fci(): p-1 statt p im Argument, weil eine (latente) Var gelöscht wurde * DONE Boost C++ library needed for Alain's GIES ** DONE does *need* a correct ./configure, somewhat analogous to Martin's Rmpfr. @@ -127,29 +133,25 @@ - -* TODO MK[2014-07-08]: Change convention: If something strange happens with a test, KEEP edge -* TODO MK[2014-07-08]: Make up some clever way to deal with NAs in the continuous case (phps also in other cases) and prepare test functions for users - ----------------- - -* Internal Programming - documentation & style guide(s) -- (Martin): - -** am[which(am != 0)] is faster than am[am != 0] +* TODO (3) MK[2014-07-08]: Change convention: If something strange happens with a test, KEEP edge +* TODO (3) MK[2014-07-08]: Make up some clever way to deal with NAs in the continuous case (phps also in other cases) and prepare test functions for users +* TODO (2,MM) Write a "doc" on Internal Programming - conventions and style guide +** (2) am[which(am != 0)] is faster than am[am != 0] for a *sparse* am of dim 50 x 50 ==> Using the more ugly notation is ok! --- But this will most probably change in R >= 3.3.0 -** Adjacency Matrices: -*** We should use *integer* {internal} ==> A[..,] <- 1 is *wrong*, should be A[..] <- 1L, etc -*** Document the different kinds of 'amat' (adjacency matrices) that we use. - symmetric ? / lower- or upper-triangular ? - E.g. [[man/backdoor.Rd]] has "Coding of adjacency matrix" (0,1,2,3) -*** Our code should make sure that ad-matrices are *integer* and hence use 1L, 0L, etc ! - -** Graph Node Labels <==> rownames(A): Still a mess, sometimes using as.numeric(rownames(.)), +** (3) Adjacency Matrices: +*** TODO (3) We should use *integer* {internal} ==> A[..,] <- 1 is *wrong*, should be A[..] <- 1L, etc +*** TODO (3) Our code should make sure that ad-matrices are *integer* and hence use 1L, 0L, etc ! +*** DONE Document the different kinds of 'amat' (adjacency matrices) that we use: + file:man/amatType.Rd (symmetric ? / lower- or upper-triangular ?) + E.f. file:man/backdoor.Rd has "Coding of adjacency matrix" (0,1,2,3) +** TODO (2,MK) Graph Node Labels <==> rownames(A): Still a mess, sometimes using as.numeric(rownames(.)), e.g. in my.SpecialDag() in [[R/pcalg.R]] *** In these cases graph labels are lost and replaced by "1", "2", .. this is typically entirely wrong. -** Help pages: +** TODO (2,MK) Help pages: *** For function \arguments{.}, in \item{}{}, use *lower* case descr. as in all practically all "base R" help pages. + +* TODO (2,MK) Add test for lingam() (exits only for LINGAM() ) diff --git a/build/vignette.rds b/build/vignette.rds new file mode 100644 index 0000000..a1b5bb9 Binary files /dev/null and b/build/vignette.rds differ diff --git a/cleanup b/cleanup index b3dbece..c01c5ea 100755 --- a/cleanup +++ b/cleanup @@ -4,6 +4,7 @@ # rm -rf autom4te.cache # rm -f config.log config.status +rm -f pcalg-Ex.R rm -f src/*.o src/*.so src/symbols.rds find . -name \*~ | xargs rm -f diff --git a/data/gmInt.rda b/data/gmInt.rda index 4597266..074264e 100644 Binary files a/data/gmInt.rda and b/data/gmInt.rda differ diff --git a/inst/NEWS.Rd b/inst/NEWS.Rd index 3b74997..620e10c 100644 --- a/inst/NEWS.Rd +++ b/inst/NEWS.Rd @@ -3,6 +3,26 @@ \name{NEWS} \title{pcalg News} \encoding{UTF-8} + +\section{CHANGES IN VERSION 2.3-0 (2015-..-.., svn ...)}{ + \itemize{ + \item \code{print()} and \code{summary()} methods for \code{pc()}, + \code{fci()}, etc. + + \item new \code{as(*, "amat")} methods to get the adjacency matrix + of a model, including a \code{print()} method for "amat"s. + + \code{?amatType} documents the different kinds of adjacency matrices + in \pkg{pcalg}. + + \item New functions ...... % FIXME -- only if *not* mentioned below + + \item Deprecated \code{LINGAM()} in favor of new \code{lingam()}. + \item Deprecated \code{allDags()} in favor of \code{pdag2allDags()}. + %% more deprecated ? + } +} + \section{CHANGES IN VERSION 2.2-4 (2015-07-22, svn r344)}{ \itemize{ \item Bug fix in \code{simulate()}. diff --git a/inst/doc/mkVignettes.R b/inst/doc/mkVignettes.R index cdb0161..bea1dcd 100644 --- a/inst/doc/mkVignettes.R +++ b/inst/doc/mkVignettes.R @@ -15,8 +15,9 @@ manualInst.vignette <- function(fstem, package="pcalg", verbose=FALSE) { pkgSrcDir <- switch(Sys.getenv("USER"), "maechler" = file.path("~/R/Pkgs", package),# or "~/R/Pkgs/pcalg-dev" - "kalischm" = ".....", # PATH of pcalg or pcalg-dev - stop("Must add your (username, pcalg-source) in file {inst/}doc/mkVignettes.R ")) + "kalischm" = ".....", # PATH of pcalg or pcalg-dev + "husi" = "~/versionControl/R/pcalg/pkg", # or .../branches/dev + stop("Must add your (username, pcalg-source) in file {inst/}doc/mkVignettes.R ")) srcDES <- read.dcf(file.path(pkgSrcDir, "DESCRIPTION")) ## now check, if 'Version', 'Date' agree: diff --git a/inst/doc/pcalgDoc.R b/inst/doc/pcalgDoc.R new file mode 100644 index 0000000..ae1fcc1 --- /dev/null +++ b/inst/doc/pcalgDoc.R @@ -0,0 +1,445 @@ +### R code from vignette source 'pcalgDoc.Rnw' +### Encoding: UTF-8 + +################################################### +### code chunk number 1: preliminaries +################################################### +op.orig <- +options(SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), + width = 75, digits = 5, + ## JSS : prompt = "R> " + ## Good looking: + prompt = "> ", continue = " " + ) + + +################################################### +### code chunk number 2: diagnose-lib +################################################### +if(FALSE && Sys.getenv("USER") == "maechler")## just for "testing" + print( .libPaths() ) + + +################################################### +### code chunk number 3: def-gmG (eval = FALSE) +################################################### +## ## Used to generate the 'gmG' Gaussian data originally: +## require("pcalg") +## set.seed(40) +## p <- 8 +## n <- 5000 +## gGtrue <- randomDAG(p, prob = 0.3) +## gmG <- list(x = rmvDAG(n, gGtrue), g = gGtrue) + + +################################################### +### code chunk number 4: exIntro1 +################################################### +library("pcalg") +data("gmG") + + +################################################### +### code chunk number 5: Iplot (eval = FALSE) +################################################### +## stopifnot(require(Rgraphviz))# needed for all our graph plots +## par(mfrow = c(1,2)) +## plot(gmG8$g, main = "") ; plot(pc.gmG, main = "") + + +################################################### +### code chunk number 6: exIntroPlot +################################################### +suffStat <- list(C = cor(gmG8$x), n = nrow(gmG8$x)) +pc.gmG <- pc(suffStat, indepTest = gaussCItest, + p = ncol(gmG8$x), alpha = 0.01) +stopifnot(require(Rgraphviz))# needed for all our graph plots +par(mfrow = c(1,2)) +plot(gmG8$g, main = "") ; plot(pc.gmG, main = "") + + +################################################### +### code chunk number 7: exIntroPlot +################################################### +stopifnot(require(Rgraphviz))# needed for all our graph plots +par(mfrow = c(1,2)) +plot(gmG8$g, main = "") ; plot(pc.gmG, main = "") + + +################################################### +### code chunk number 8: exIntro2 +################################################### +ida(1, 6, cov(gmG8$x), pc.gmG@graph) + + +################################################### +### code chunk number 9: exIntro3 +################################################### +idaFast(1, c(4,5,6), cov(gmG8$x), pc.gmG@graph) + + +################################################### +### code chunk number 10: skeleton-args +################################################### +showF <- function(f, width = 80) { + ## 'width': larger than default on purpose: + nam <- deparse(substitute(f)) + stopifnot(is.function(f)) + attr(f, "source") <- NULL # if ... + attr(f, "srcref") <- NULL + ll <- capture.output(str(f, width=width)) + ll[1] <- sub("function *", nam, ll[1]) + writeLines(ll) +} +showF(skeleton) + + +################################################### +### code chunk number 11: skelExpl1Plot +################################################### +## using data("gmG", package="pcalg") +suffStat <- list(C = cor(gmG8$x), n = nrow(gmG8$x)) +skel.gmG <- skeleton(suffStat, indepTest = gaussCItest, + p = ncol(gmG8$x), alpha = 0.01) +par(mfrow = c(1,2)) +plot(gmG8$g, main = ""); plot(skel.gmG, main = "") + + +################################################### +### code chunk number 12: skelExp2Plot +################################################### +data("gmD") +suffStat <- list(dm = gmD$x, nlev = c(3,2,3,4,2), adaptDF = FALSE) +skel.gmD <- skeleton(suffStat, indepTest = disCItest, + p = ncol(gmD$x), alpha = 0.01) +par(mfrow= 1:2); plot(gmD$g, main = ""); plot(skel.gmD, main = "") + + +################################################### +### code chunk number 13: pc-args +################################################### +showF(pc) + + +################################################### +### code chunk number 14: pcExpl-plot +################################################### +suffStat <- list(C = cor(gmG8$x), n = nrow(gmG8$x)) +pc.fit <- pc(suffStat, indepTest=gaussCItest, p = ncol(gmG8$x), alpha = 0.01) +par(mfrow= c(1,2)); plot(gmG8$g, main = ""); plot(pc.fit, main = "") + + +################################################### +### code chunk number 15: obs-score-args (eval = FALSE) +################################################### +## score <- new("GaussL0penObsScore", data = matrix(1, 1, 1), +## lambda = 0.5*log(nrow(data)), intercept = FALSE, use.cpp = TRUE, ...) + + +################################################### +### code chunk number 16: ges-args +################################################### +showF(ges) + + +################################################### +### code chunk number 17: pcExpl-plot +################################################### +score <- new("GaussL0penObsScore", gmG8$x) +ges.fit <- ges(score) +par(mfrow=1:2); plot(gmG8$g, main = ""); plot(ges.fit$essgraph, main = "") + + +################################################### +### code chunk number 18: fci-args +################################################### +showF(fci, width=75) + + +################################################### +### code chunk number 19: fciExpl-plot +################################################### +data("gmL") +suffStat1 <- list(C = cor(gmL$x), n = nrow(gmL$x)) +pag.est <- fci(suffStat1, indepTest = gaussCItest, + p = ncol(gmL$x), alpha = 0.01, labels = as.character(2:5)) +par(mfrow = 1:2); plot(gmL$g, main = ""); plot(pag.est) + + +################################################### +### code chunk number 20: rfci-args +################################################### +showF(rfci) + + +################################################### +### code chunk number 21: def-rfciExpl-plot (eval = FALSE) +################################################### +## data("gmL") +## suffStat1 <- list(C = cor(gmL$x), n = nrow(gmL$x)) +## pag.est <- rfci(suffStat1, indepTest = gaussCItest, +## p = ncol(gmL$x), alpha = 0.01, labels = as.character(2:5)) + + +################################################### +### code chunk number 22: int-score-args (eval = FALSE) +################################################### +## score <- new("GaussL0penIntScore", data = matrix(1, 1, 1), +## targets = list(integer(0)), target.index = rep(as.integer(1), nrow(data)), +## lambda = 0.5*log(nrow(data)), intercept = FALSE, use.cpp = TRUE, ...) + + +################################################### +### code chunk number 23: gies-args +################################################### +showF(gies) + + +################################################### +### code chunk number 24: def-gmInt (eval = FALSE) +################################################### +## ## Used to generate the 'gmInt' Gaussian data originally: +## set.seed(40) +## p <- 8 +## n <- 5000 +## gGtrue <- randomDAG(p, prob = 0.3) +## nodes(gGtrue) <- c("Author", "Bar", "Ctrl", "Goal", "V5", "V6", "V7", "V8") +## pardag <- as(gGtrue, "GaussParDAG") +## pardag$set.err.var(rep(1, p)) +## targets <- list(integer(0), 3, 5) +## target.index <- c(rep(1, 0.6*n), rep(2, n/5), rep(3, n/5)) +## +## x1 <- rmvnorm.ivent(0.6*n, pardag) +## x2 <- rmvnorm.ivent(n/5, pardag, targets[[2]], +## matrix(rnorm(n/5, mean = 4, sd = 0.02), ncol = 1)) +## x3 <- rmvnorm.ivent(n/5, pardag, targets[[3]], +## matrix(rnorm(n/5, mean = 4, sd = 0.02), ncol = 1)) +## gmInt <- list(x = rbind(x1, x2, x3), +## targets = targets, +## target.index = target.index, +## g = gGtrue) + + +################################################### +### code chunk number 25: load-gmInt +################################################### +data(gmInt) +n.tot <- length(gmInt$target.index) +n.obs <- sum(gmInt$target.index == 1) +n3 <- sum(gmInt$target.index == 2) +n5 <- sum(gmInt$target.index == 3) + + +################################################### +### code chunk number 26: load-gmInt +################################################### +data(gmInt) + + +################################################### +### code chunk number 27: gies-fit-plot +################################################### +score <- new("GaussL0penIntScore", gmInt$x, targets = gmInt$targets, + target.index = gmInt$target.index) +gies.fit <- gies(score) +simy.fit <- simy(score) +par(mfrow = c(1, 3)) ; plot(gmInt$g, main = "") +plot(gies.fit$essgraph, main = "") +plot(simy.fit$essgraph, main = "") + + +################################################### +### code chunk number 28: def-gmI (eval = FALSE) +################################################### +## set.seed(123) +## p <- 7 +## n <- 10000 +## myDAG <- randomDAG(p, prob = 0.2) +## datI <- rmvDAG(n, myDAG) +## gmI <- list(x = datI, g = myDAG) + + +################################################### +### code chunk number 29: idaExpl1 +################################################### +data("gmI") +suffStat <- list(C = cor(gmI$x), n = nrow(gmI$x)) +pc.gmI <- pc(suffStat, indepTest=gaussCItest, + p = ncol(gmI$x), alpha = 0.01) + + +################################################### +### code chunk number 30: idaExpl2 +################################################### +par(mfrow = c(1,2)) +plot(gmI$g, main = "") +plot(pc.gmI, main = "") + + +################################################### +### code chunk number 31: idaExpl3 +################################################### +am.pdag <- wgtMatrix(pc.gmI@graph) +ad <- allDags(am.pdag, am.pdag, NULL) +gDag <- vector("list", nrow(ad)) +for (i in 1:nrow(ad)) gDag[[i]] <- as(matrix(ad[i, ], 7, 7), "graphNEL") +par(mfrow = c(3,2)) +for (i in 1:6) plot(gDag[[i]], main = paste("DAG",i)) + + +################################################### +### code chunk number 32: plot-6DAGS +################################################### +sfsmisc::mult.fig(6) +for (i in 1:6) plot(gDag[[i]], main = paste("DAG",i)) + + +################################################### +### code chunk number 33: idaExpl4 +################################################### +ida(2, 5, cov(gmI$x), pc.gmI@graph, method = "global", verbose = FALSE) + + +################################################### +### code chunk number 34: ida-args +################################################### +showF(ida) + + +################################################### +### code chunk number 35: idaExpl5 +################################################### +ida(2,5, cov(gmI$x), pc.gmI@graph, method = "local") + + +################################################### +### code chunk number 36: idaFast-args +################################################### +showF(idaFast) + + +################################################### +### code chunk number 37: ida-idaFast +################################################### +(eff.est1 <- ida(2,5, cov(gmI$x), pc.gmI@graph, method="local")) +(eff.est2 <- ida(2,6, cov(gmI$x), pc.gmI@graph, method="local")) +(eff.est3 <- ida(2,7, cov(gmI$x), pc.gmI@graph, method="local")) + +(eff.estF <- idaFast(2, c(5,6,7), cov(gmI$x), pc.gmI@graph)) + + +################################################### +### code chunk number 38: backdoor-args +################################################### +showF(backdoor) + + +################################################### +### code chunk number 39: backdoorExCPDAG1 +################################################### +p <- 6 +amat <- t(matrix(c(0,0,1,1,0,1, 0,0,1,1,0,1, 0,0,0,0,1,0, + 0,0,0,0,1,1, 0,0,0,0,0,0, 0,0,0,0,0,0), 6,6)) +V <- as.character(1:6) +colnames(amat) <- rownames(amat) <- V +edL <- vector("list",length=6) +names(edL) <- V +edL[[1]] <- list(edges=c(3,4,6),weights=c(1,1,1)) +edL[[2]] <- list(edges=c(3,4,6),weights=c(1,1,1)) +edL[[3]] <- list(edges=5,weights=c(1)) +edL[[4]] <- list(edges=c(5,6),weights=c(1,1)) +g <- new("graphNEL", nodes=V, edgeL=edL, edgemode="directed") + +cov.mat <- trueCov(g) + +myCPDAG <- dag2cpdag(g) +true.amat <- as(myCPDAG, "matrix") +## true.amat[true.amat != 0] <- 1 + + +################################################### +### code chunk number 40: backdoorExpl +################################################### +par(mfrow = c(1,2)) +plot(g, main = "") +plot(myCPDAG, main = "") + + +################################################### +### code chunk number 41: backdoorExCPDAG2 +################################################### +backdoor(true.amat, 6, 3, type="cpdag") + + +################################################### +### code chunk number 42: turn-off-plus +################################################### +options(continue = " ") # MM: so we don't get the "+ " continuation lines + + +################################################### +### code chunk number 43: myCItest +################################################### +myCItest <- function(x,y,S, suffStat) { + if (length(S) == 0) { + x. <- suffStat[,x] + y. <- suffStat[,y] + } else { + rxy <- resid(lm.fit(y= suffStat[,c(x,y)], x= cbind(1, suffStat[,S]))) + x. <- rxy[,1]; y. <- rxy[,2] + } + cor.test(x., y.)$p.value +} + + +################################################### +### code chunk number 44: gaussCItest-ex +################################################### +suffStat <- list(C = cor(gmG8$x), n = 5000) +pc.gmG <- pc(suffStat, indepTest=gaussCItest, p = 8, alpha = 0.01) + + +################################################### +### code chunk number 45: myCItest-def-plot (eval = FALSE) +################################################### +## pc.myfit <- pc(suffStat = gmG8$x, indepTest = myCItest, +## p = 8, alpha = 0.01) +## par(mfrow = c(1,2)); plot(pc.gmG, main = ""); plot(pc.myfit, main = "") + + +################################################### +### code chunk number 46: myCItest-ex-plot +################################################### +pc.myfit <- pc(suffStat = gmG8$x, indepTest = myCItest, + p = 8, alpha = 0.01) +par(mfrow = c(1,2)); plot(pc.gmG, main = ""); plot(pc.myfit, main = "") + + +################################################### +### code chunk number 47: time-tests (eval = FALSE) +################################################### +## system.time(for(i in 1:10) +## pc.fit <- pc(suffStat, indepTest=gaussCItest, p = 8, alpha = 0.01)) +## ## User System verstrichen +## ## 0.593 0.000 0.594 +## system.time(for(i in 1:10) +## pc.myfit <- pc(gmG8$x, indepTest = myCItest, p = 8, alpha = 0.01)) +## ## Using resid(lm(..)) twice: +## ## User System verstrichen +## ## 44.864 0.007 44.937 +## ## Using resid(lm.fit(..)): +## ## 10.550 0.067 10.632 + + +################################################### +### code chunk number 48: sessionInfo +################################################### +toLatex(sessionInfo(), locale=FALSE) + + +################################################### +### code chunk number 49: finalizing +################################################### +options(op.orig) + + diff --git a/inst/doc/pcalgDoc.Rnw b/inst/doc/pcalgDoc.Rnw new file mode 100644 index 0000000..88fc9db --- /dev/null +++ b/inst/doc/pcalgDoc.Rnw @@ -0,0 +1,2090 @@ +%\documentclass[article]{jss} +\documentclass[nojss,shortnames,article]{jss} +% ----- for the package-vignette, don't use JSS logo, etc +% shortnames: just because we don't want to see 22 author names for {HughesEtAl00} +% but when submitting, do + +\usepackage[utf8]{inputenc} + +% get rid of too much vertical space between R input & output: +\fvset{listparameters={\setlength{\topsep}{0pt}}} +%\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}} +% +\usepackage{algorithmic} +\usepackage{algorithm} + +%% Mathematics +\usepackage{amsmath} + +%% Graphics +\usepackage{tikz} +\usetikzlibrary{snakes,arrows,shapes,decorations.markings} +\usepackage{xstring} + +%\VignetteIndexEntry{Causal Inference: The R package pcalg} +%%\VignetteDepends{pcalg, sfsmisc, Rgraphviz} +\SweaveOpts{engine=R,eps=FALSE,pdf=TRUE,width=7,height=4} +\SweaveOpts{keep.source=TRUE,strip.white=true, figs.only=TRUE} +% ^^^^^^^^^^^^^^^^ preserve comments (and all) in R chunks + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% almost as usual +\newcommand*{\AUT}[1]{{\normalsize #1} \\ {\small ETH Zurich}} +\author{ + \AUT{Markus Kalisch} \And + \AUT{Martin Mächler} \And + \AUT{Diego Colombo} \AND + {\normalsize Alain Hauser} \\ {\small University of Bern} \And + \AUT{Marloes H. Maathuis} \And + \AUT{Peter Bühlmann}} +%JSS:\title{Causal Inference using Graphical Models with the \proglang{R} Package \pkg{pcalg}} +%% Slightly modified title, to better distinguish from JSS paper: +\title{More Causal Inference with Graphical Models in \proglang{R} Package \pkg{pcalg}} +%% for pretty printing and a nice hypersummary also set: +\Plainauthor{Kalisch, Mächler, Colombo, Hauser, Maathuis, Bühlmann} %% comma-separated +%JSS:\Plaintitle{Causal Inference using Graphical Models: The R package pcalg} %% without formatting +\Plaintitle{More Causal Inference with Graphical Models in R Package pcalg} +\Shorttitle{More Causal Graphical Models: Package pcalg} %% a short title (if necessary) + +%% an abstract and keywords +\Abstract{ + The \pkg{pcalg} package for \proglang{R} \citep{citeR} can be + used for the following two purposes: Causal structure learning and + estimation of causal effects from observational and/or interventional + data. In this document, we give a brief overview of the methodology, and + demonstrate the package's functionality in both toy examples and + applications. + + This vignette is an updated and extended (FCI, RFCI, etc) version of + \cite{KalMMCMB:2012} which was for \pkg{pcalg} 1.1-4. +} + +\Keywords{IDA, PC, RFCI, FCI, GES, GIES, do-calculus, causality, graphical model, \proglang{R}} +\Plainkeywords{IDA, PC, RFCI, FCI, GES, GIES, do-calculus, causality, graphical models, R} %% without formatting +%% at least one keyword must be supplied + +%% publication information +%% NOTE: Typically, this can be left commented and will be filled out by the technical editor +%% \Volume{13} +%% \Issue{9} +%% \Month{September} +%% \Year{2004} +%% \Submitdate{2004-09-29} +%% \Acceptdate{2004-09-29} + +%% The address of (at least) one author should be given +%% in the following format: +\Address{ + Markus Kalisch\\ + Seminar f\"ur Statistik\\ + ETH Z\"urich\\ + 8092 Z\"urich, Switzerland\\ + E-mail: \email{kalisch@stat.math.ethz.ch}\\ + %% URL: \url{http://stat.ethz.ch/people/kalisch} +} +%% It is also possible to add a telephone and fax number +%% before the e-mail in the following format: +%% Telephone: +43/1/31336-5053 +%% Fax: +43/1/31336-734 + +%% for those who use Sweave please include the following line (with % symbols): +%% need no \usepackage{Sweave.sty} + +%% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Abbreviations, definitions, etc. +\DeclareMathOperator{\doop}{do} + +%% Different edge types in graphs +\newlength{\edgelength} +\setlength{\edgelength}{3.5ex} +%\DeclareRobustCommand{\gredge}[1]{\mathbin{\tikz[baseline] \draw[\StrSubstitute{#1}{<}{angle 60}] (0pt, 0.7ex) -- (\edgelength, 0.7ex);}} +\newcommand{\gredge}[1]{% + %% Replace arrow headings + \def\substarrow{#1} + \StrSubstitute{\substarrow}{<}{angle 60}[\substarrow] + \StrSubstitute{\substarrow}{>}{angle 60}[\substarrow] + %% Print edge + \mathbin{\tikz[baseline] \draw[\substarrow] (0pt, 0.7ex) -- (\edgelength, 0.7ex);}} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{document} + +<>= +op.orig <- +options(SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), + width = 75, digits = 5, + ## JSS : prompt = "R> " + ## Good looking: + prompt = "> ", continue = " " + ) +@ +%% include your article here, just as usual +%% Note that you should use the \pkg{}, \proglang{} and \code{} commands. + +\section{Introduction} +\label{sec:introduction} +%%THIS DOCUMENTATION IS STILL UNDER CONSTRUCTION! \\ %% FIXME + +Understanding cause-effect relationships between variables is of primary +interest in many fields of science. Usually, experimental intervention is +used to find these relationships. In many settings, however, experiments +are infeasible because of time, cost or ethical constraints. + +We therefore consider the problem of inferring causal information from +observational data. Under some assumptions, the algorithms +PC \citep[see][]{SpirtesEtAl00}, +FCI \citep[see][]{SpirtesEtAl00,SpirtesMeekRichardson99}, +RFCI \citep[see][]{rfci} and +GES \citep[see][]{Chickering2002} can +infer information about the causal structure from observational data; +there also exists a generalization of GES to interventional data, GIES +\citep[see][]{HauserBuhlmann2012}. These +algorithms tell us which variables could or could not be a cause of +some variable of interest. They do not, however, give information about the +size of the causal effects. We therefore developed the IDA method +\citep{MaKaBu09}, which can infer bounds on causal effects based on +observational data under some assumptions and in particular that no hidden +and selection variables are present. IDA is a two step approach that +combines the PC algorithm and Pearl's backdoor criterion \citep{Pearl93}, +which has been designed for DAGs without latent variables. IDA was validated on a +large-scale biological system \citep[see][]{NatMethods10}. Since the +assumption of no latent variables is a strong assumption when working with +real data and therefore often violated in practice, we generalized Pearl's +backdoor criterion \citep[see][]{MaCo2013-arc} to more general types of graphs, +i.e. CPDAGs, MAGs, and PAGs, that describe Markov equivalence classes of +DAGs with and without latent variables but without selection variables. + +For broader use of these methods, well documented and easy to use software +is indispensable. We therefore wrote the R package \pkg{pcalg}, which +contains implementations of the algorithms PC, FCI, RFCI, GES and GIES, +as well as of the IDA method and the generalized Pearl's backdoor +criterion. The objective of this paper is to introduce the R package +\pkg{pcalg}, explain the range of functions on simulated data sets and +summarize some applications. + +To get started, we show how two of the main functions (one for causal +structure learning and one for estimating causal effects from observational +data) can be used in a +typical application. Suppose we have a system described by some +variables and many observations of this system. Furthermore, assume +that it seems plausible that there are no hidden variables and no +feedback loops in the underlying causal system. The causal structure +of such a system can be conveniently represented by a directed acyclic +graph (DAG), where each node represents a variable and each directed edge +represents a direct cause. To fix ideas, we have simulated an example +data set with $p = 8$ continuous variables with Gaussian noise and $n += 5000$ observations, which we will now analyze. First, we load the +package \pkg{pcalg} and the data set. + + +%% FALSE below disables, even for Martin: +<>= +if(FALSE && Sys.getenv("USER") == "maechler")## just for "testing" + print( .libPaths() ) +<>= +## Used to generate the 'gmG' Gaussian data originally: +require("pcalg") +set.seed(40) +p <- 8 +n <- 5000 +gGtrue <- randomDAG(p, prob = 0.3) +gmG <- list(x = rmvDAG(n, gGtrue), g = gGtrue) +@ +<>= +library("pcalg") +data("gmG") +@ + + +In the next step, we use the function \code{pc()} to produce an estimate +of the underlying causal structure. Since this function is based on +conditional independence tests, we need to define two things. First, +we need a function that can compute conditional independence tests in +a way that is suitable for the data at hand. For standard data types +(Gaussian, discrete and binary) we provide predefined functions. See +the example section in the help file of \code{pc()} for more +details. Secondly, we need a summary of the data (sufficient +statistic) on which the conditional independence function can +work. Each conditional independence test can be performed at a certain +significance level \code{alpha}. This can be treated as a tuning +parameter. In the following code, we use the predefined function +\code{gaussCItest()} as conditional independence test and create the +corresponding sufficient statistic, consisting +of the correlation matrix of the data and the sample size. Then we use +the function \code{pc()} to estimate the causal structure and plot the +result. + +%% Define the 'Iplot' chunk here and use it twice below: +<>= +stopifnot(require(Rgraphviz))# needed for all our graph plots +par(mfrow = c(1,2)) +plot(gmG8$g, main = "") ; plot(pc.gmG, main = "") +@% two plots side by sid + +<>= +suffStat <- list(C = cor(gmG8$x), n = nrow(gmG8$x)) +pc.gmG <- pc(suffStat, indepTest = gaussCItest, + p = ncol(gmG8$x), alpha = 0.01) +<> +@ +\begin{figure}[htb] + \centering +<>= +<> +@ +\caption{True underlying causal DAG (left) and estimated causal structure + (right), representing a Markov equivalence class of DAGs that all encode + the same conditional independence information. (Due to the large sample + size, there were no sampling errors.)} +\label{fig:intro1} +\end{figure} + +As can be seen in Fig.~\ref{fig:intro1}, there are directed and bidirected +edges in the estimated causal structure. The directed edges show the +presence and direction of direct causal effects. A bidirected edge means +that the PC-algorithm was unable to decide whether the edge orientation +should be $\gredge{<-}$ or $\gredge{->}$. Thus, bidirected edges +represent some uncertainty in the resulting model. They reflect the fact +that in general one cannot estimate a unique DAG from observational data, +not even with an infinite amount of data, since several DAGs can describe +the same conditional independence information. + +On the inferred causal structure, we can estimate the causal effect +of an intervention. Denote the variable corresponding to node $i$ in the +graph by $V_i$. For example, suppose that, by external intervention, we +first set the variable $V_1$ to some value $\tilde{x}$, and then to the +value $\tilde{x}+1$. The recorded average change in variable $V_6$ +is the (total) causal effect of $V_1$ on $V_6$. More precisely, the causal +effect $C(V_1, V_6, \tilde{x})$ of $V_1$ from $V_1 = \tilde{x}$ on $V_6$ is +defined as +\begin{eqnarray*} +C(V_1, V_6, \tilde{x}) &=& E(V_1|\doop(V_6 = \tilde{x} + 1)) - E(V_1|\doop(V_6 = \tilde{x})) \ \mbox{or} \\ +C(V_1, V_6, \tilde{x}) &=& \frac{\partial}{\partial x} E(V_1|\doop(V_6 = x))|_{x=\tilde{x}}, +\end{eqnarray*} +where $\doop(V_6 = x)$ denotes Pearl's do-operator \citep[see][]{Pearl00}. If +the causal relationships are linear, these two expressions are equivalent +and do not depend on $\tilde{x}$. + +Since the causal structure was not identified uniquely in our example, we +cannot expect to get a unique number for the causal effect. Instead, we get +a set of possible causal effects. This set can be computed by using the +function \code{ida()}. To provide full quantitative information, we need to +pass the covariance matrix in addition to the estimated causal structure. + +<>= +ida(1, 6, cov(gmG8$x), pc.gmG@graph) +@ + +Since we simulated the data, we know that the true value of the causal +effect is \Sexpr{gGtrue <- gmG8$g; round(causalEffect(gGtrue, 6, 1), 2)}. %$ +Thus, one of the two +estimates is indeed close to the true value. Since both values are larger +than zero, we can conclude that variable $V_1$ has a positive causal effect +on variable $V_6$. Thus, we can always estimate a lower bound for the +absolute value of the causal effect. (Note that at this point we have no +p-value to control the sampling error.) + +If we would like to know the effect of a unit increase in variable $V_1$ on +variables $V_4$, $V_5$ and $V_6$, we could simply call \code{ida()} three +times. However, a faster way is to call the function \code{idaFast()}, which +was tailored for such situations. + +<>= +idaFast(1, c(4,5,6), cov(gmG8$x), pc.gmG@graph) +@ + +Each row in the output shows the estimated set of possible causal effects +on the target variable indicated by the row names. The true values for the +causal effects are \Sexpr{round(causalEffect(gGtrue, 4, 1),2)}, +\Sexpr{round(causalEffect(gGtrue, 5, 1),2)}, +\Sexpr{round(causalEffect(gGtrue, 6, 1),2)} for variables $V_4$, $V_5$ and +$V_6$, respectively. The first row, corresponding to variable $V_4$, quite +accurately indicates a causal effect that is very close to zero or no +effect at all. The second row of the output, corresponding to variable +$V_5$, is rather uninformative: Although one entry comes close to the true +value, the other estimate is close to zero. Thus, we cannot be sure if +there is a causal effect at all. The third row, corresponding to $V_6$ was +already discussed above. + +\section{Methodological background} + +In Section~\ref{sec:gm} we propose methods for estimating the causal +structure. In particular, we discuss algorithms for structure learning +\begin{itemize} + \item in the absence of hidden variables from observational data + such as PC \citep[see][]{SpirtesEtAl00}, + GES \citep[see][]{Chickering2002}, and the dynamic programming approach of + \cite{Silander2006}, + + \item from observational data accounting for hidden variables such as + FCI \citep[see][]{SpirtesEtAl00, SpirtesMeekRichardson99} + and RFCI \citep[see][]{rfci}, + + \item in the absence of hidden variables from jointly observational + and interventional data such as GIES \citep[see][]{HauserBuhlmann2012}. +\end{itemize} + +In Section~\ref{sec:bounds} we first describe the IDA method +\citep[see][]{MaKaBu09} to obtain bounds on causal effects from observational +data when no latent and selection variables are present. This method is +based on first estimating the causal structure and then applying +do-calculus \citep[see][]{Pearl00}. We then propose the generalized Pearl's +backdoor criterion \citep[see][]{MaCo2013-arc} that works with DAGs, CPDAGs, +MAGs, and PAGs as input and it assumes that there are arbitrarly many latent +variables but no selection variables. This method is based on two steps: +first it checks if the total causal effect of one variable $X$ onto another +variables $Y$ is identifiable via the generalized backdoor criterion in the +given type of graph, and if this is the case it explicitly gives a set of +variables that satisfies the generalized backdoor criterion with respect to +$X$ and $Y$ in the given graph. + +\subsection{Estimating causal structures with graphical models} \label{sec:gm} +Graphical models +can be thought of as maps of dependence structures of a given probability +distribution or a sample thereof \citep[see for example][]{lauritzen}. In +order to illustrate the analogy, let us consider a road map. In order to be +able to use a road map, one needs two given factors. First, one needs the +physical map with symbols such as dots and lines. Second, one needs a +rule for interpreting the symbols. For instance, a railroad map and a map +for electric circuits might look very much alike, but their interpretation +differs a lot. In the same sense, a graphical model is a map. First, a +graphical model consists of a graph with dots, lines and potentially edge +marks like arrowheads or circles. Second, a graphical model always comes +with a rule for interpreting this graph. In general, nodes in the graph +represent (random) variables and edges represent some kind of dependence. + +\subsubsection{Without hidden and selection variables} +An example of a graphical model is the DAG model. The physical map here is +a graph consisting of nodes and directed edges ($\gredge{<-}$ or +$\gredge{->}$). As a further restriction, the edges must be directed in a +way, so that it is not possible to trace a cycle when following the +arrowheads (i.e., no directed cycles). The interpretation rule is called +d-separation. This rule is a bit intricate and we refer the reader to +\cite{lauritzen} for more details. This interpretation rule can be used in +the following way: If two nodes $x$ and $y$ are d-separated by a set of +nodes $S$, then the corresponding random variables $V_{x}$ and $V_{y}$ are +conditionally independent given the set of random variables $V_{S}$. For the +following, we only deal with distributions whose list of conditional +independencies perfectly matches the list of d-separation relations of +some DAG; such distributions are called faithful. It has been shown +that the set of distributions that are faithful is the overwhelming +majority \citep{Meek95}, so that the assumption does not seem to be very +strict in practice. + +Since the DAG model encodes conditional independencies, it seems plausible +that information on the latter helps to infer aspects of the former. This +intuition is made precise in the PC algorithm (see \cite{SpirtesEtAl00}; PC +stands for the initials of its inventors Peter Spirtes and Clark Glymour) +which was proven to reconstruct the structure of the underlying DAG model given a +conditional independence oracle up to its Markov equivalence class which is +discussed in more detail below. In practice, the conditional independence oracle is +replaced by a statistical test for conditional independence. For situations +without hidden variables and under some further conditions it has been +shown that the PC algorithm using statistical tests instead of an +independence oracle is computationally feasible and consistent even for very +high-dimensional sparse DAGs \citep[see][]{KaBu07a}. + +As mentioned before, several DAGs can encode the same list of conditional +independencies. One can show that such DAGs must share certain +properties. To be more precise, we have to define a v-structure as the +subgraph $i \gredge{->} j \gredge{<-} k$ on the nodes $i$, $j$ and $k$ where +$i$ and $k$ are not adjacent (i.e., there is no edge between $i$ and +$k$). Furthermore, let the skeleton of a DAG be the graph that is obtained +by removing all arrowheads from the DAG. It was shown that two DAGs encode +the same conditional independence statements if and only if the +corresponding DAGs have the same skeleton and the same v-structures +\citep[see][]{VermaPearl90}. Such DAGs are called Markov-equivalent. In this way, +the space of DAGs can be partitioned into equivalence classes, where all +members of an equivalence class encode the same conditional independence +information. Conversely, if given a conditional independence oracle, one +can only determine a DAG up to its equivalence class. Therefore, the PC +algorithm cannot determine the DAG uniquely, but only the corresponding +equivalence class of the DAG. + +An equivalence class can be visualized by a graph that has the same +skeleton as every DAG in the equivalence class and directed edges only +where all DAGs in the equivalence class have the same directed edge. Edges +that point into one direction for some DAGs in the equivalence class and in +the other direction for other DAGs in the equivalence class are visualized +by bidirected edges (sometimes, undirected edges are used instead). This +graph is called a completed partially directed acyclic graph, CPDAG +\citep{SpirtesEtAl00}, or essential graph \citep{AnderssonMadiganPerlman97}. + +\begin{algorithm}[h] +\caption{Outline of the PC-algorithm} +\label{pc} +\begin{algorithmic} +\STATE \textbf{Input:} Vertex set V, conditional independence information, +significance level $\alpha$\\ +\STATE \textbf{Output:} Estimated CPDAG $\hat{G}$, separation sets $\hat{S}$\\ +%\STATE \textbf{EDGE TYPES:} $\gredge{->}$, $-$\\ +\hspace*{4em} \textbf{Edge types:} $\gredge{->}$, $\gredge{-}$\\ +\STATE \textbf{(P1)} Form the complete undirected graph on the vertex +set V\\ +\STATE \textbf{(P2)} Test conditional independence given subsets of +adjacency sets at a given significance level $\alpha$ and delete edges if +conditional independent\\ +\STATE \textbf{(P3)} Orient v-structures\\ +\STATE \textbf{(P4)} Orient remaining edges.\\ +\end{algorithmic} +\label{algo:pc} +\end{algorithm} + +We now describe the PC-algorithm, which is shown in Algorithm~\ref{algo:pc}, in more detail. The PC-algorithm starts with a complete +undirected graph, $G_0$, as stated in \textbf{(P1)} of Algorithm~\ref{algo:pc}. In stage \textbf{(P2)}, a series of conditional independence +tests is done and edges are deleted in the following way. First, all pairs +of nodes are tested for marginal independence. If two nodes $i$ and $j$ are +judged to be marginally independent at level $\alpha$, the edge between +them is deleted and the empty set is saved as separation sets +$\hat{S}[i,j]$ and $\hat{S}[j,i]$. After all pairs have been tested for +marginal independence and some edges might have been removed, a graph +results which we denote by $G_1$. In the second step, all pairs of nodes +$(i,j)$ still adjacent in $G_1$ are tested for conditional independence +given any single node in adj$(G_1,i)\setminus \{j\}$ or +adj$(G_1,j)\setminus \{i\}$ (adj$(G,i)$ denotes the set of nodes in graph +$G$ that are adjacent to node $i$) . If there is any node $k$ such that $V_i$ +and $V_j$ are conditionally independent given $V_k$, the edge between $i$ and +$j$ is removed and node $k$ is saved as separation sets (sepset) +$\hat{S}[i,j]$ and $\hat{S}[j,i]$. If all adjacent pairs have been tested +given one adjacent node, a new graph results which we denote by +$G_2$. The algorithm continues in this way by increasing the size of the +conditioning set step by step. The algorithm stops if all adjacency sets in +the current graph are smaller than the size of the conditioning set. The +result is the skeleton in which every edge is still undirected. Within +\textbf{(P3)}, each triple of vertices $(i,k,j)$ such that the pairs +$(i,k)$ and $(j,k)$ are each adjacent in the skeleton but $(i,j)$ are not +(such a triple is called an ``unshielded triple''), +is oriented based on the information saved in the conditioning sets +$\hat{S}[i,j]$ and $\hat{S}[j,i]$. More precisely, an unshielded triple +$i \gredge{-} k \gredge{-} j$ is oriented as $i +\gredge{->} k \gredge{<-} j$ if $k$ is not in $\hat{S}[j,i] = +\hat{S}[i,j]$. Finally, in \textbf{(P4)} it may be possible to orient some +of the remaining edges, since one can deduce that one of the two possible +directions of the edge is invalid because it introduces a new v-structure +or a directed cycle. Such edges are found by repeatedly applying rules +described in \cite{SpirtesEtAl00}, p.85. The resulting output is the +equivalence class (CPDAG) that describes the conditional independence +information in the data, in which every edge is either undirected or +directed. (To simplify visual presentation, undirected edges are depicted as +bidirected edges in the output as soon as at least one directed edge is +present. If no directed edge is present, all edges are undirected.) + +It is known that the PC algorithm is order-dependent in steps +\textbf{(P2)}--\textbf{(P4)}, meaning that the output depends from the order +in which the variables are given. \cite{CoMa2013-arc} proposed several +modifications of the PC algorithm (see Sections \ref{sec:skel} and +\ref{sec:pc}) that partly or fully remove these order-dependence issues in +each step. + +The PC algorithm presented so far is based on conditional independence +tests. Score-based methods form an alternative approach to causal +inference. They try to find a CPDAG that maximizes a \emph{score}, +typically a model selection criterion, which is calculated from data. + +One of the most popular scores is the Bayesian information criterion (BIC) +because its maximization leads to \emph{consistent} model selection in the +classical large-sample limit \citep{Haughton1988, Geiger2001}. However, +computing its maximum is an NP-hard problem \citep{Chickering1996}. An +exhaustive search is computationally infeasible due to the size of the +search space, the space of DAGs or CPDAGs, respectively. +\cite{Silander2006} have presented an exact dynamic programming algorithm +with an exponential time complexity. Its execution is feasible for models +with a few dozen variables. + +The greedy equivalence search (GES) of \cite{Chickering2002} makes the +maximization of the BIC computationally feasible for much larger graphs. +As the name of the algorithm implies, GES maximizes the BIC in a +\emph{greedy} way, but still guarantees consistency in the large-sample +limit. It still has exponential-time complexity in the worst case, but +only polynomial complexity in the average case where the size of the +largest clique in a graph grows only logarithmically with the number of +nodes \citep{Grimmett1975}. + +GES greedily optimizes the BIC in two phases: +\begin{itemize} + \item In the \emph{forward phase}, the algorithm starts with the empty + graph. It then sequentially moves to larger CPDAGs by operations that + correspond to adding single arrows in the space of DAGs. This phase is + aborted if no augmentation of the BIC is possible any more. + + \item In the \emph{backward phase}, the algorithm moves again into the + direction of \emph{smaller} graphs by operations that correspond to + removing single arrows in the space of DAGs. The algorithm terminates + as soon as no augmentation of the BIC is possible any more. +\end{itemize} +A key ingredient for the fast exploration of the search space in GES is an +evaluation of the greedy steps in a local fashion which avoids enumerating +all representative DAGs of an equivalence class and which exploits the +decomposability of the BIC score \citep{Chickering2002}. + +A causal structure without feedback loops and without hidden or selection +variable can be visualized using a DAG where the edges indicate direct +cause-effect relationships. Under some assumptions, \cite{Pearl00} showed +(Theorem 1.4.1) that there is a link between causal structures and graphical +models. Roughly speaking, if the underlying causal structure is a DAG, we +observe data generated from this DAG and then estimate a DAG model (i.e., a +graphical model) on this data, the estimated CPDAG represents the +equivalence class of the DAG model describing the causal structure. This +holds if we have enough samples and assuming that the true underlying +causal structure is indeed a DAG without latent or selection +variables. Note that even given an infinite amount of data, we usually +cannot identify the true DAG itself, but only its equivalence class. Every +DAG in this equivalence class can be the true causal structure. + +\subsubsection{With hidden or selection variables} +When discovering causal relations from nonexperimental data, two +difficulties arise. One is the problem of hidden (or latent) variables: +Factors influencing two or more measured variables may not themselves be +measured. The other is the problem of selection bias: Values of unmeasured +variables or features may influence whether a unit is included in the data +sample. + +In the case of hidden or selection variables, one could still visualize the +underlying causal structure with a DAG that includes all observed, hidden +and selection variables. However, when inferring the DAG from observational +data, we do not know all hidden and selection variables. + +We therefore seek to find a structure that represents all conditional +independence relationships among the observed variables given the selection +variables of the underlying causal structure. It turns out that this is +possible. However, the resulting object is in general not a DAG for the +following reason. Suppose, we have a DAG including observed, latent and +selection variables and we would like to visualize the conditional +independencies among the observed variables only. We could marginalize out +all latent variables and condition on all selection variables. It turns out +that the resulting list of conditional independencies can in general not be +represented by a DAG, since DAGs are not closed under marginalization or +conditioning \citep[see][]{RichardsonSpirtes02}. + +A class of graphical independence models that is closed under +marginalization and conditioning and that contains all DAG models is the +class of ancestral graphs. A detailed discussion of this class of graphs +can be found in \cite{RichardsonSpirtes02}. In this text, we only give a +brief introduction. + +Ancestral graphs have nodes, which represent random variables and edges +which represent some kind of dependence. The edges can be either directed +($\gredge{<-}$ or $\gredge{->}$), +undirected ($\gredge{-}$) or bidirected ($\gredge{<->}$) (note that in the +context of ancestral graphs, +undirected and bidirected edges do \emph{not} mean the same). There are two +rules that restrict the direction of edges in an ancestral graph: +\begin{description} + \item[1:] If $i$ and $j$ are joined by an edge with an arrowhead at $i$, then + there is no directed path from $i$ to $j$. (A path is a sequence of + adjacent vertices, and a directed path is a path along directed edges + that follows the direction of the arrowheads.) + \item[2:] There are no arrowheads present at a vertex which is an + endpoint of an undirected edge. +\end{description} +Maximal ancestral graphs (MAG), which we will use from now on, also +obey a third rule: +\begin{description} +\item[3:] Every missing edge corresponds to a conditional independence. +\end{description} + +The conditional independence statements of MAGs can be read off using the +concept of m-separation, which is a generalization the concept of +d-separation. Furthermore, part of the causal information in the underlying +DAG is represented in the MAG. If in the MAG there is an edge between node +$i$ and node $j$ with an arrowhead at node $i$, then there is no directed +path from node $i$ to node $j$ nor to any of the selection variables in the +underlying DAG (i.e., $i$ is not a cause of $j$ or of the selection +variables). If, on the other hand, there is a tail at node $i$, then there +is a directed path from node $i$ to node $j$ or to one of the selection +variables in the underlying DAG (i.e., $i$ is a cause of $j$ or of a +selection variable). + +Recall that finding a unique DAG from an independence oracle is in general +impossible. Therefore, one only reports on the equivalence class of DAGs in +which the true DAG must lie. The equivalence class is visualized using a +CPDAG. The same is true for MAGs: Finding a unique MAG from an independence +oracle is in general impossible. One only reports on the equivalence class +in which the true MAG lies. + +An equivalence class of a MAG can be uniquely represented by a partial +ancestral graph (PAG) \citep[see, e.g.,][]{Zhang08-orientation-rules}. +A PAG contains the following types of edges: $\gredge{o-o}$, $\gredge{o-}$, +$\gredge{o->}$, $\gredge{->}$, $\gredge{<->}$, $\gredge{-}$. +Roughly, the bidirected edges come from hidden variables, and the +undirected edges come from selection variables. The edges have the +following interpretation: (i) There is an edge between $x$ and $y$ if and +only if $V_x$ and $V_y$ are conditionally dependent given $V_S$ for all +sets $V_S$ consisting of all selection variables and a subset of the +observed variables; (ii) a tail on an edge means that this tail is present +in all MAGs in the equivalence class; (iii) an arrowhead on an edge means +that this arrowhead is present in all MAGs in the equivalence class; (iv) a +$\circ$-edgemark means that there is a at least one MAG in the equivalence class +where the edgemark is a tail, and at least one where the edgemark is an +arrowhead. + +An algorithm for finding the PAG given an independence oracle is the FCI +algorithm (``fast causal inference''; see \cite{SpirtesEtAl00} and +\cite{fci}). The orientation rules of this algorithm were slightly +extended and proven to be complete in \cite{Zhang08-orientation-rules}. FCI +is very similar to PC but makes additional conditional independence tests +and uses more orientation rules (see Section~\ref{sec:fci} for more +details). We refer the reader to \cite{Zhang08-orientation-rules} or +\cite{rfci} for a detailed discussion of the FCI algorithm. It turns out +that the FCI algorithm is computationally infeasible for large graphs. The +RFCI algorithm (``really fast causal inference''; see \cite{rfci}), is much +faster than FCI. The output of RFCI is in general slightly less informative +than the output of FCI, in particular with respect to conditional +independence information. However, it was shown in \cite{rfci} that any +causal information in the output of RFCI is correct and that both FCI and +RFCI are consistent in (different) sparse high-dimensional +settings. Finally, in simulations the estimation performances of the +algorithms are very similar. + +Since both these algorithms are build up from the PC algorithm, they are +also order-dependent, meaning that the output depends from the order +in which the variables are given. Starting from the solution proposed for +the PC algorithm, \cite{CoMa2013-arc} proposed several +modifications of the FCI and the RFCI algorithms (see Sections +\ref{sec:skel}, \ref{sec:fci}, and \ref{sec:rfci}) that partly or fully +remove these order-dependence issues in each of their steps. + +\subsubsection{From a mixture of observational and interventional data} + +We often have to deal with interventional data in causal inference. In +cell biology for example, data is often measured in different mutants, or +collected from gene knockdown experiments, or simply measured under +different experimental conditions. An intervention, denoted by Pearl's +do-calculus (see Section \ref{sec:introduction}), changes the joint +probability distribution of the system; therefore, data samples collected +from different intervention experiments are \emph{not} identically +distributed (although still independent). + +The algorithms PC and GES both rely on the i.i.d.\ assumption and are not +suited for causal inference from interventional data. The GIES algorithm, +which stands for ``greedy interventional equivalence search'', is a +generalization of GES to interventional data \citep[see][]{HauserBuhlmann2012}. +It does not only make sure that interventional +data points are handled correctly (instead of being wrongly treated as +observational data points), but also accounts for the improved +identifiablity of causal models under interventional data by returning an +\emph{interventional essential graph}. Just as in the observational case, +an interventional essential graph is a partially directed graph +representing an (interventional) Markov equivalence class of DAGs: a +directed edge between two vertices stands for an arrow with common +orientation among all representatives of the equivalence class, an +undirected edge stands for an arrow that has different orientations among +different representative DAGs; for more details, see \cite{HauserBuhlmann2012}. + +GIES traverses the search space of interventional essential graphs in a +similar way as GES traverses the search space of observational essential +graphs. In addition, a new search phase was introduced by +\cite{HauserBuhlmann2012} with movements which correspond to turning single +arrows in the space of DAGs. + +\subsection{Estimating bounds on causal effects} \label{sec:bounds} +One way of quantifying the causal effect of variable $V_x$ on $V_y$ is to +measure the state of $V_y$ if $V_x$ is forced to take value $V_x=x$ and compare +this to the value of $V_y$ if $V_x$ is forced to take the value $V_x=x+1$ or +$V_x=x+\delta$. If $V_x$ and $V_y$ are random variables, forcing $V_x=x$ could have +the effect of changing the distribution of $V_y$. Following the conventions +in \cite{Pearl00}, the resulting distribution after manipulation is denoted +by $P[V_y | \doop(V_x=x)]$. Note that this is different from the conditional +distribution $P[V_y | V_x=x]$. To illustrate this, imagine the following +simplistic situation. Suppose we observe a particular spot on +the street during some hour. The random variable $V_x$ denotes whether it +rained during that +hour ($V_x=1$ if it rained, $V_x=0$ otherwise). The random variable $V_y$ denotes +whether the street was wet at the end of that hour ($V_y=1$ +if it was wet, $V_y=0$ otherwise). If we assume $P(V_x=1) = 0.1$ (rather dry +region), $P(V_y=1|V_x=1) = 0.99$ (the street is almost always still wet at the +end of the hour when it rained during that hour) and $P(V_y=1|V_x=0) = 0.02$ +(other reasons for making the street wet are rare), we can compute the +conditional probability $P(V_x=1|V_y=1) = 0.85$. So, if we observe the street +to be wet, the probability that there was rain in the last hour is about +$0.85$. However, if we take a garden hose and force the street to be wet at +a randomly chosen hour, we get $P(V_x=1|\doop(V_y=1)) = P(V_x=1) = 0.1$. Thus, the +distribution of the random variable describing rain is quite different when +making an observation versus making an intervention. + +Oftentimes, only the change of the target distribution under intervention +is reported. We use the change in mean, i.e., $\frac{\partial}{\partial x} +E[V_y|\doop(V_x=x)]$, as a general measure for the causal effect of $V_x$ on +$V_y$. For multivariate Gaussian random variables, $E[V_y|\doop(V_x=x)]$ depends +linearly on $x$. Therefore, the derivative is constant which means that the +causal effect does not depend on $x$, and can also be interpreted as +$E[V_y|\doop(V_x=x+1)] - E[V_y|\doop(V_x=x)]$. For binary random variables +(with domain $\{0,1\}$) we define the causal effect of $V_x$ on $V_y$ as +$E(V_y|\doop(V_x=1)) - E(V_y|\doop(V_x=0)) = + P(V_y=1|\doop(V_x=1)) - P(V_y=1|\doop(V_x=0))$. + +The goal in the remainder of this section is to estimate the effect of an +intervention if only observational data is available. + +\subsubsection{Without hidden and selection variables} +If the causal structure is a known DAG and there are no hidden and +selection variables, \cite{Pearl00} (Th 3.4.1) suggested a set of inference rules +known as ``do-calculus'' whose +application transforms an expression involving a ``do'' into an expression +involving only conditional distributions. Thus, information on the +interventional distribution can be obtained by using information obtained +by observations and knowledge of the underlying causal structure. + +Unfortunately, the causal structure is rarely known in practice. However, +as discussed in Section~\ref{sec:gm}, we can estimate the Markov +equivalence class of the true causal DAG. Taking this into account, we +conceptually apply the do-calculus on each DAG within the equivalence class +and thus obtain a possible causal effect for each DAG in the equivalence +class (in practice, we developed a local method that is faster but yields a +similar result; see Section~\ref{sec:ida} for more details). Therefore, +even if we have an infinite amount of observations we can in general report +on a multiset of possible causal values (it is a multiset rather than a set +because it can contain duplicate values). One of these values is the true +causal effect. Despite the inherent ambiguity, this result can still be +very useful when the multiset has certain properties (e.g., all values are much +larger than zero). These ideas are incorporated in the IDA method +(\textbf{I}ntervention calculus when the \textbf{D}AG is \textbf{A}bsent). + +In addition to this fundamental limitation in estimating a causal effect, +errors due to finite sample size blur the result as with every statistical +method. Thus, we can typically only get an estimate of the set of possible +causal values. It was shown that this estimate is consistent in sparse +high-dimensional settings under some assumptions by \cite{MaKaBu09}. + +It has recently been shown empirically that despite the described +fundamental limitations in identifying the causal effect uniquely and +despite potential violations of the underlying assumptions, the +method performs well in identifying the most important causal effects in a +high-dimensional yeast gene expression data set \citep[see][]{NatMethods10}. + +\subsubsection{With hidden but no selection variables} + +If the causal DAG is known and no latent and selection variables are +present, one can estimate causal effects from observational data using for +example Pearl's backdoor criterion, as done in IDA. + +However, in practice the assumption of no latent variables is often +violated. Therefore, \cite{MaCo2013-arc} generalized Pearl's backdoor +criterion to more general types of graphs that describe Markov equivalence +classes of DAGs when allowing arbitrarily many latent but no selection +variables. This generalization works with DAGs, CPDAGs, MAGs, and PAGs as +input and it is based on a two step approach. In a first step, the causal +effect of one variable $X$ onto another variable $Y$ under investigation is +checked to be identifiable via the generalized backdoor criterion, meaning +that there exists a set of variables $W$ for which the generalized backdoor +criterion is satisfied with respect to $X$ and $Y$ in the given graph. If +the effect is indeed identifiable, in a second step the set $W$ is explicitly +given. + +\subsection{Summary of assumptions} +For all proposed methods, we assume that the data is faithful to the +unknown underlying causal DAG. For the individual methods, further +assumptions are made. + +\begin{description} +\item[PC algorithm:] No hidden or selection variables; consistent in + high-dimensional settings (the number of variables grows with the sample + size) if the underlying DAG is sparse, the data is multivariate normal + and satisfies some regularity conditions on the partial correlations, and + $\alpha$ is taken to zero appropriately. See \cite{KaBu07a} for full + details. Consistency in a standard asymptotic regime with a fixed number + of variables follows as a special case. + +\item[GES algorithm:] No hidden or selection variables; consistency in + a standard asymptotic regime with a fixed number of variables + \citep[see][]{Chickering2002}. + +\item[FCI algorithm:] Allows for hidden and selection variables; consistent + in high-dimensional settings if the so-called Possible-D-SEP sets + \citep[see][]{SpirtesEtAl00} are sparse, the data is multivariate normal and + satisfies some regularity conditions on the partial correlations, and + $\alpha$ is taken to zero appropriately. See \cite{rfci} for full + details. Consistency in a standard asymptotic regime with a fixed number + of variables follows as a special case. + +\item[RFCI algorithm:] Allows for hidden and selection variables; consistent + in high-dimensional settings if the underlying MAG is sparse (this is a + much weaker assumption than the one needed for FCI), the data is + multivariate normal and satisfies some regularity + conditions on the partial correlations, and $\alpha$ is taken to zero + appropriately. See \cite{rfci} for full details. Consistency in + a standard asymptotic regime with a fixed number of variables follows as + a special case. + +\item[GIES algorithm:] No hidden or selection variables; mix of observational + and interventional data. Interventional data alone is sufficient if + there is no variable which is intervened in \emph{all} data points. + +\item[IDA:] No hidden or selection variables; all conditional expectations + are linear; consistent in high-dimensional settings if the underlying DAG + is sparse, the data is multivariate Normal and satisfies some regularity + conditions on the partial correlations and conditional variances, and + $\alpha$ is taken to zero appropriately. See \cite{MaKaBu09} for full + details. + +\item[Generalized Backdoor Criterion:] allows for arbitrarily many hidden + but no selection variables. See \cite{MaCo2013-arc} for more details. +\end{description} + +\section{Package pcalg} +This package has two goals. First, it is intended to provide fast, flexible +and reliable implementations of the PC, FCI, RFCI, GES and GIES algorithms for +estimating causal structures and graphical models. Second, it provides an +implementation of the IDA method, which estimates bounds on causal effects +from observational data when no causal structure is known and hidden or +selection variables are absent, and it also provides a genralization of +Pearl's backdoor criterion to DAGs, CPDAGs, MAGs, nad PAGs, when hidden but +no selection variables are allowed. + +In the following, we describe the main functions of our package for +achieving these goals. The functions \code{skeleton()}, \code{pc()}, +\code{fci()}, \code{rfci()}, \code{ges()}, \code{gies()} and \code{simy()} +are intended for estimating graphical models. The functions \code{ida()} +and \code{idaFast()} are intended for estimating causal effects from +observational data, and the function \code{backdoor()} is intended for +checking if a causal effect is identifiable or not using the generalized +backdoor criterion and if it is identifiable for estimating a set that +actually satisfies the generalized backdoor criterion. + +Alternatives to this package for estimating graphical models in +\proglang{R} include: \cite{bnlearn, deal, gRain, gRbase} and \cite{gRc}. + +\subsection{skeleton}\label{sec:skel} +The function \code{skeleton()} estimates the skeleton of a DAG without +latent and selection variables using the PC algorithm +(steps (P1) and (P2) in Algorithm~\ref{algo:pc}), and it estimates an initial +skeleton of a DAG with arbitrarily many latent and selection variables +using the FCI and the RFCI algorithms. The function can be called with the +following arguments +\par\vspace*{-1.2ex} +<>= +showF <- function(f, width = 80) { + ## 'width': larger than default on purpose: + nam <- deparse(substitute(f)) + stopifnot(is.function(f)) + attr(f, "source") <- NULL # if ... + attr(f, "srcref") <- NULL + ll <- capture.output(str(f, width=width)) + ll[1] <- sub("function *", nam, ll[1]) + writeLines(ll) +} +showF(skeleton) +@ + +As was discussed in Section~\ref{sec:gm}, the main task in finding the skeleton +is to compute and test several conditional independencies. To keep the +function flexible, \code{skeleton()} takes as argument a function +\code{indepTest()} that performs these conditional independence tests and +returns a p-value. All information that is needed in the conditional +independence test can be passed in the argument \code{suffStat}. The only +exceptions are the number of variables \code{p} and the significance level +\code{alpha} for the conditional independence tests, which are passed +separately. For convenience, we have preprogrammed versions of +\code{indepTest()} for Gaussian data (\code{gaussCItest()}), discrete data +(\code{disCItest()}), and binary data (\code{binCItest()}). Each of these +independence test functions needs different arguments as input, described +in the respective help files. For example, when using \code{gaussCItest()}, +the input has to be a list containing the correlation matrix and the sample +size of the data. In the following code, we estimate the skeleton on the +data set \code{gmG} (which consists of $p=8$ variables and $n=5000$ +samples) and plot the results. The estimated skeleton and the true +underlying DAG are shown in Fig.~\ref{fig:skelExpl}. +\begin{figure} + \centering +<>= +## using data("gmG", package="pcalg") +suffStat <- list(C = cor(gmG8$x), n = nrow(gmG8$x)) +skel.gmG <- skeleton(suffStat, indepTest = gaussCItest, + p = ncol(gmG8$x), alpha = 0.01) +par(mfrow = c(1,2)) +plot(gmG8$g, main = ""); plot(skel.gmG, main = "") +@ +\caption{True underlying DAG (left) and estimated skeleton (right) fitted + on the simulated Gaussian data set \texttt{gmG}.} +\label{fig:skelExpl} +\end{figure} + +To give another example, we show how to fit a skeleton to the example +data set \code{gmD} (which consists of $p=5$ discrete +variables with 3, 2, 3, 4 and 2 levels and $n=10000$ samples). The +predefined test function \code{disCItest()} is based on the $G^2$ +statistic and takes as input a list containing the data matrix, a +vector specifying the number of levels for each variable and an option +which indicates if the degrees of freedom must be lowered by one for +each zero count. Finally, we plot the result. The estimated skeleton +and the true underlying DAG are shown in Fig.~\ref{fig:skel2}. +\begin{figure} + \centering +<>= +data("gmD") +suffStat <- list(dm = gmD$x, nlev = c(3,2,3,4,2), adaptDF = FALSE) +skel.gmD <- skeleton(suffStat, indepTest = disCItest, + p = ncol(gmD$x), alpha = 0.01) +par(mfrow= 1:2); plot(gmD$g, main = ""); plot(skel.gmD, main = "") +@ +\caption{True underlying DAG (left) and estimated skeleton (right) fitted + on the simulated discrete data set \code{gmD}.} +\label{fig:skel2} +\end{figure} + +In some situations, one may have prior information about the underlying +DAG, for example that certain edges are absent or present. Such information +can be incorporated into the algorithm via the arguments +\code{fixedGaps} (absent edges) and \code{fixedEdges} (present edges). +The information in \code{fixedGaps} and \code{fixedEdges} is used as +follows. The gaps given in \code{fixedGaps} are introduced in the very +beginning of the algorithm by removing the corresponding edges from the +complete undirected graph. Thus, these edges are guaranteed to be absent in the +resulting graph. Pairs $(i,j)$ in \code{fixedEdges} are skipped in +all steps of the algorithm, so that these edges are guaranteed to be +present in the resulting graph. + +If \code{indepTest()} returns \code{NA} and the option \code{NAdelete} is +\code{TRUE}, the corresponding edge is deleted. If this option is +\code{FALSE}, the edge is not deleted. + +The argument \code{m.max} is the maximum size of the conditioning sets that +are considered in the conditional independence tests. + +Throughout, the function works with the column positions of the +variables in the adjacency matrix, and not with the names of the variables. + +The PC algorithm is known to be order-dependent, in the sense that the +output depends on the order in which the variables are given. Therefore, +\cite{CoMa2013-arc} proposed a simple modification, called PC-stable, that yields +order-independent adjacencies in the skeleton. In this function we +implement their modified algorithm (the old order-dependent implementation +can be found in version 1.1-5). + +Since the FCI and RFCI algorithms are build up from the PC algorithm, they +are also order-dependent in the skeleton. To resolve their order-dependence +issues in the skeleton is more involved, see \cite{CoMa2013-arc}. However, this +function estimates an initial order-independent skeleton in these +algorithms (for additional details on how to make the final skeleton of FCI +fully order-independent see \ref{sec:fci} and \cite{CoMa2013-arc}). + +\subsection{pc} \label{sec:pc} + +The function \code{pc()} implements all steps (P1) to (P4) of the PC +algorithm shown in display algorithm~\ref{algo:pc}. First, the skeleton is +computed using the function \code{skeleton()} (steps (P1) and (P2)). Then, +as many edges as possible are oriented (steps (P3) and (P4)). The function +can be called as +% with the following arguments. +% \code{pc(suffStat, indepTest, p, alpha, verbose = FALSE, fixedGaps = NULL, \\ +% fixedEdges = NULL, NAdelete = TRUE, m.max = Inf, u2pd = "rand", \\ +% conservative = FALSE)} +\par\vspace*{-1.2ex} +<>= +showF(pc) +@ +\par\vspace*{-1ex} +where the arguments \code{suffStat}, \code{indepTest}, \code{p}, +\code{alpha}, \code{fixedGaps}, \code{fixedEdges}, \code{NAdelete} and +\code{m.max} are identical to those of \code{skeleton()}. + +The conservative PC algorithm (\code{conservative = TRUE}) is a slight +variation of the PC algorithm \citep[see][]{Ramsey06}. After the +skeleton is computed, all unshielded triplets $a \gredge{-} b \gredge{-} c$ are +checked in the following way. We test whether $V_a$ and $V_c$ are +independent conditioning on any subset of the neighbors of $a$ or any +subset of the neighbors of $c$. If $b$ is in no such conditioning set (and +not in the original sepset) or in all such conditioning sets (and in the +original sepset), the triple is marked as \emph{unambiguous}, no further +action is taken and the usual PC is continued. If, however, $b$ is in only some +conditioning sets, or if there was no subset $S$ of the adjacency set of +$a$ nor of $c$ such that $V_a$ and $V_c$ are conditionally independent +given $V_S$, the triple $a \gredge{-} b \gredge{-} c$ is marked as +\emph{ambiguous}. An ambiguous triple is not oriented as a +v-structure. Furthermore, no later orientation rule that needs to know +whether $a \gredge{-} b \gredge{-} c$ is a v-structure or not is +applied. Instead of using the conservative version, which is quite strict +towards the v-structures, \cite{CoMa2013-arc} introduced a less strict version +for the v-structures called majority rule. This adaptation can be called using +\code{maj.rule = TRUE}. In this case, the triple $a \gredge{-} b \gredge{-} +c$ is marked as \emph{ambiguous} if $b$ is in exactly 50 percent of such +conditioning sets, if it is in less than 50 percent it is set as a +v-structure, and if in more than 50 percent as a non v-structure, for more +details see \cite{CoMa2013-arc}. The usage of both the conservative and the +majority rule versions resolve the order-dependence issues of the +determination of the v-structures, see \cite{CoMa2013-arc} for more details. + +Sampling errors (or hidden variables) can lead to conflicting information +about edge directions. For example, one may find that $a \gredge{-} b +\gredge{-} c$ and $b \gredge{-} c \gredge{-} d$ +should both be directed as v-structures. This gives conflicting information +about the edge $b \gredge{-} c$, since it should be directed as $b +\gredge{<-} c$ in v-structure $a \gredge{->} b \gredge{<-} c$, while it +should be directed as $b \gredge{->} c$ in v-structure $b \gredge{->} c +\gredge{<-} d$. With the option \code{solve.confl = FALSE}, in such cases, +we simply overwrite the directions of the conflicting edge. In the example +above this means that we obtain $a \gredge{->} b \gredge{->} c \gredge{<-} d$ if +$a \gredge{-} b \gredge{-} c$ was visited first, and +$a \gredge{->} b \gredge{<-} c \gredge{<-} d$ if +$b \gredge{-} c \gredge{-} d$ was visited first, meaning that the final +orientation on the edge depends on the ordering in which the edges are +oriented. With the option \code{solve.confl = TRUE} (which is only +supported with option \code{u2pd = "relaxed"}), we first generate a list of +all (unambiguous) v-structures (in the example above $a \gredge{-} b +\gredge{-} c$ and $b \gredge{-} c \gredge{-} d$), and then we simply orient +them allow both directions on the edge $b \gredge{-} c$, namely we allow the +bi-directed edge $b \gredge{<->} c$ resolving the order-dependence issues +on the edge orientations. We denote bi-directed edges in the adjacency +matrix M of the graph as $M[b,c]=2$ and $M[c,b]=2$. In a similar way using +lists for the candidate edges for each orientation rule and allowing +bi-directed edges, the order-dependence issues in the orientation rules can +be solved. Note that bi-directed edges merely represents a conflicting +orientation and they should not to be interpreted causally. The usage of +these lists for the candidate edges and allowing bi-directed edges resolve +the order-dependence issues on the orientation of the v-structures and on +the edges using the three orientation rules, see \cite{CoMa2013-arc} for more +details. + +Note that calling (\code{conservative = TRUE}) or \code{maj.rule = TRUE}, +together with \code{solve.confl = TRUE} produces a fully order-independent +output, see \cite{CoMa2013-arc}. + +Sampling errors, non faithfulness, or hidden variables can also lead to +invalid CPDAGs, meaning that there does not exist a DAG that has the same +skeleton and v-structures as the graph found by the algorithm. An example +of this is an undirected cycle consisting of the edges $a \gredge{-} b +\gredge{-} c \gredge{-} d$ and $d \gredge{-} a$. In this case it +is impossible to direct the edges without creating a cycle or a new +v-structure. The optional argument \code{u2pd} specifies what should be +done in such a situation. If it is set to \code{"relaxed"}, the algorithm simply +outputs the invalid CPDAG. If \code{u2pd} is set to \code{"rand"}, all direction +information is discarded and a random DAG is generated on the skeleton. The +corresponding CPDAG is then returned. If +\code{u2pd} is set to \code{"retry"}, up to 100 combinations of possible +directions of the ambiguous edges are tried, and the first combination that +results in a valid CPDAG is chosen. If no valid combination is found, an +arbitrary CPDAG is generated on the skeleton as with \code{u2pd = "rand"}. + +As with the skeleton, the PC algorithm works with the column positions of the +variables in the adjacency matrix, and not with the names of the +variables. When plotting the object, undirected and bidirected edges are +equivalent. + +As an example, we estimate a CPDAG of the Gaussian data used in the +example for the skeleton in Section~\ref{sec:skel}. Again, we choose +the predefined \code{gaussCItest()} as conditional independence +test and create the corresponding test statistic. Finally, we plot the +result. The estimated CPDAG and the true underlying DAG are shown in +Fig.~\ref{fig:pcFit1}. + +\begin{figure} + \centering +<>= +suffStat <- list(C = cor(gmG8$x), n = nrow(gmG8$x)) +pc.fit <- pc(suffStat, indepTest=gaussCItest, p = ncol(gmG8$x), alpha = 0.01) +par(mfrow= c(1,2)); plot(gmG8$g, main = ""); plot(pc.fit, main = "") +@ +\caption{True underlying DAG (left) and estimated CPDAG (right) fitted on the + simulated Gaussian data set \code{gmG}.} +\label{fig:pcFit1} +\end{figure} + +\subsection{ges} \label{sec:ges} + +The PC algorithm presented in the previous section is based on conditional +independence tests. To apply it, we first had to calculate a sufficient +statistic and to specify a conditional independence test function. For the +score-based GES algorithm, we have to define a score object before applying +the inference algorithm. + +A score object is an instance of a class derived from the base class +\code{Score}. This base class is implemented as a virtual reference class. +At the moment, the \pkg{pcalg} package only contains classes derived from +\code{Score} for Gaussian data: \code{GaussL0penObsScore} for purely +observational data, and \code{GaussL0penIntScore} for a mixture of +observational and interventional data; for the GES algorithm, we only need +the first one here, but we will encounter the second one in Section +\ref{sec:gies} again. The implementation of score classes for discrete +data is planned for future versions of the \pkg{pcalg} package. However, +the flexible implementation using class inheritance allows the user to +implement own score classes for different scores. + +The predefined score-class \code{GaussL0penObsScore} implements a an +$\ell_0$-penalized maximum-likelihood estimator for observational data from +a Gaussian causal model. A instance is generated as follows: +<>= +score <- new("GaussL0penObsScore", data = matrix(1, 1, 1), + lambda = 0.5*log(nrow(data)), intercept = FALSE, use.cpp = TRUE, ...) +@ +The data matrix is provided by the argument \code{data}. The penalization +constant is specified by \code{lambda}. The default value of \code{lambda} +corresponds to the BIC score; the AIC score is realized by setting +\code{lambda} to $1$. The argument \code{intercept} indicates whether the +model should allow for intercepts in the linear structural equations, or +for a non-zero mean of the multivariate normal distribution, which is +equivalent. The last argument \code{use.cpp} indicates whether the +internal C++ library should be used for calculation, which is in most cases +the best choice due to velocity issues. + +Once a score object is defined, the GES algorithm is called as follows: +<>= +showF(ges) +@ +The argument \code{score} is a score object defined before. The +argument \code{turning} indicates whether the novel turning phase +(see Section \ref{sec:gm}) not +present in the original implementation of \cite{Chickering2002} should be +used, and \code{maxdegree} can be used to bound the vertex degree of the +estimated graph. More details can be found in the help file of +\code{ges()}. + +In Fig.~\ref{fig:gesFit}, we re-analyze the data set used in the example of +Fig.~\ref{fig:pcFit1} with the GES algorithm. The estimated graph is +exactly the same in this case. + +\begin{figure} + \centering +<>= +score <- new("GaussL0penObsScore", gmG8$x) +ges.fit <- ges(score) +par(mfrow=1:2); plot(gmG8$g, main = ""); plot(ges.fit$essgraph, main = "") +@ +\caption{True underlying DAG (left) and essential graph (right) estimated + with the GES algorithm fitted on the simulated Gaussian data set \code{gmG}.} +\label{fig:gesFit} +\end{figure} + +\subsection{fci}\label{sec:fci} + +The FCI algorithm is a generalization of the PC algorithm, in the sense +that it allows arbitrarily many latent and selection variables. Under the +assumption that the data are faithful to a DAG that includes all latent and +selection variables, the FCI algorithm estimates the equivalence class of +MAGs that describe the conditional independence relationships between the +observed variables given the selection variables. + +The first part of the FCI algorithm is analogous to the PC algorithm. It +starts with a complete undirected graph and estimates an initial skeleton +using the function \code{skeleton()}, which produces an initial +order-independent skeleton. All edges of this skeleton are of the +form $\gredge{o-o}$. However, due to the presence of hidden variables, it +is no longer sufficient to consider only subsets of the adjacency sets of +nodes $x$ and $y$ to decide whether the edge $x \gredge{-} y$ should be +removed. Therefore, the initial skeleton may contain some superfluous +edges. These edges are removed in the next step of the algorithm which +requires some orientations. Therefore, the v-structures are determined +using the conservative method (see discussion on \code{conservative} +below). All potential v-structures $a \gredge{-} b \gredge{-} c$ are +checked in the following way. We test whether $V_a$ and $V_c$ are +independent conditioning on any subset of the neighbors of $a$ or any +subset of the neighbors of $c$. If $b$ is in no such conditioning set or in +all such conditioning sets, no further action is taken. If, however, $b$ is +in only some conditioning sets, the triple $a \gredge{-} b \gredge{-} c$ is +marked as \emph{ambiguous}. If $V_a$ is independent of $V_c$ given some $S$ +in the skeleton (i.e., the edge $a \gredge{-} c$ dropped out), but $V_a$ +and $V_c$ remain dependent given all subsets of neighbors of either $a$ or +$c$, we will call all such triples $a \gredge{-} b \gredge{-} c$ +\emph{unambiguous}. This is because in the FCI, the true separating set +might be outside the neighborhood of either $a$ or $c$. An ambiguous triple +is not oriented as a v-structure. After the v-structures have been +oriented, Possible-D-SEP sets for each node in the graph are computed at +once. To decide whether edge $x \gredge{o-o} y$ should be removed, one performs +conditional independence tests of $V_x$ and $V_y$ given all subsets of +Possible-D-SEP($x$) and of Possible-D-SEP($y$) (see help file of function +\code{pdsep()}). The edge is removed if a conditional independence is +found. This will produce a fully order-independent final skeleton as +explained in \cite{CoMa2013-arc}. Subsequently, all edges are transformed into +$\gredge{o-o}$ again and the v-structures are newly determined (using +information in sepset). Finally, as many undetermined edge marks (o) as +possible are determined using (a subset of) the 10 orientation rules given +by \cite{Zhang08-orientation-rules}. + +The function can be called with the following arguments: +\par\vspace*{-1.2ex} +<>= +showF(fci, width=75) +@ +\par\vspace*{-1ex} +where the arguments \code{suffStat}, \code{indepTest}, \code{p}, +\code{alpha}, \code{fixedGaps}, \code{fixedEdges}, \code{NAdelete} and +\code{m.max} are identical to those in % function +\code{skeleton()}. + +The argument \code{pdsep.max} indicates the maximum size of Possible-D-SEP +for which subsets are considered as conditioning sets in the conditional +independence tests. If the nodes \code{x} and \code{y} are adjacent in the +graph and the size of Possible-D-SEP(\code{x})$\setminus +\{$\code{x},\code{y}$\}$ is bigger than \code{pdsep.max} the edge is simply +left in the graph. Note that if \code{pdsep.max} is less than Inf, the +final PAG may be a supergraph than the one computed with \code{pdsep.max = + Inf}, because less tests may have been performed in the former. + +The option \code{rules} contains a logical vector of +length 10 indicating which rules should be used when directing edges, where +the order of the rules is taken from \cite{Zhang08-orientation-rules}. + +The option \code{doPdsep} indicates whether Possible-D-SEP should be +computed for all nodes, and all +subsets of Possible-D-SEP are considered as conditioning sets in the +conditional independence tests, if not defined otherwise in +\code{pdsep.max}. If FALSE, Possible-D-SEP is not computed, so that the +algorithm simplifies to the Modified PC algorithm of \cite{SpirtesEtAl00}. + +By setting the argument \code{biCC = TRUE}, Possible-D-SEP($a$, $c$) is +defined as the intersection of the original Possible-D-SEP($a$, $c$) and +the set of nodes that lie on a path between $a$ and $c$. This method uses +biconnected components to find all nodes on a path between nodes $a$ and +$c$. The smaller Possible-D-SEP sets lead to faster computing times, while +\cite{rfci} showed that the algorithm is identical to the original FCI +algorithm given oracle information on the conditional independence +relationships. + +Conservative versions of FCI, Anytime FCI, and Adaptive Anytime FCI (see +below) are computed if the argument of \code{conservative} is +\code{TRUE}. After the final skeleton is computed, all potential +v-structures $a \gredge{-} b \gredge{-} c$ are checked in the following +way. We test whether $V_a$ and $V_c$ are independent conditioning on any +subset of the neighbors of $a$ or any subset of the neighbors of $c$. When +a subset makes $V_a$ and $V_c$ conditionally independent, we call it a +separating set. If $b$ is in no such separating set or in all such +separating sets, no further action is taken and the normal version of the +FCI, Anytime FCI, or Adaptive Anytime FCI algorithm is continued. If, +however, $b$ is in only some separating sets, the triple $a \gredge{-} b +\gredge{-} c$ is marked \emph{ambiguous}. If $V_a$ is independent of $V_c$ +given some $S$ in the skeleton (i.e., the edge $a \gredge{-} c$ dropped +out), but $V_a$ and $V_c$ remain dependent given all subsets of neighbors +of either $a$ or $c$, we will call all triples $a \gredge{-} b \gredge{-} +c$ \emph{unambiguous}. This is because in the FCI algorithm, the true +separating set might be outside the neighborhood of either $a$ or $c$. An +ambiguous triple is not oriented as a v-structure. Furthermore, no further +orientation rule that needs to know whether $a \gredge{-} b \gredge{-} c$ +is a v-structure or not is applied. Instead of using the conservative +version, which is quite strict towards the v-structures, \cite{CoMa2013-arc} +introduced a less strict version for the v-structures called majority +rule. This adaptation can be called using \code{maj.rule = TRUE}. In this +case, the triple $a \gredge{-} b \gredge{-} c$ is marked as +\emph{ambiguous} if and only if $b$ is in exactly 50 percent of such +separating sets or no separating set was found. If $b$ is in less than 50 +percent of the separating sets it is set as a v-structure, and if in more +than 50 percent it is set as a non v-structure, for more details see +\cite{CoMa2013-arc}. \cite{CoMa2013-arc} showed that with both these +modifications, the final skeleton and the decisions about the v-structures +of the FCI algorithm are fully order-independent. + +Using the argument \code{labels}, one can pass names for the vertices of +the estimated graph. By default, this argument is set to \code{NA}, in +which case the node names \code{as.character(1:p)} are used. + +The argument \code{type} specifies the version of the FCI that has to be +used. Per default it is \code{normal} and so the normal FCI algorithm is +called. If set as \code{anytime}, the Anytime FCI \cite{Spirtes01-anytime} +is called and in this case \code{m.max} must be specified by the +user. The Anytime FCI algorithm can be viewed as a modification of the FCI +algorithm that only performs conditional independence tests up to and +including order m.max when finding the initial skeleton, using the function +\code{skeleton}, and the final skeleton, using the function +\code{pdsep}. Thus, Anytime FCI performs fewer conditional independence +tests than FCI. If set as \code{adaptive}, the Adaptive Anytime FCI +\cite{rfci} is called and in this case m.max is not used. The first part of +the algorithm is identical to the normal FCI described above. But in the +second part when the final skeleton is estimated using the function +\code{pdsep}, the Adaptive Anytime FCI algorithm only performs conditional +independence tests up to and including order m.max, where m.max is the +maximum size of the conditioning sets that were considered to determine the +initial skeleton using the function \code{skeleton}. + +As an example, we estimate the PAG of a graph with five nodes using the +function \code{fci()} and the predefined function \code{gaussCItest()} as +conditional independence test. In Fig.~\ref{fig:fci} the true DAG and the +PAG estimated with \code{fci()} are shown. Random variable $V_1$ is +latent. We can read off that both $V_4$ and $V_5$ cannot be a cause of +$V_2$ and $V_3$, which can be confirmed in the true DAG. + +\begin{figure} + \centering +<>= +data("gmL") +suffStat1 <- list(C = cor(gmL$x), n = nrow(gmL$x)) +pag.est <- fci(suffStat1, indepTest = gaussCItest, + p = ncol(gmL$x), alpha = 0.01, labels = as.character(2:5)) +par(mfrow = 1:2); plot(gmL$g, main = ""); plot(pag.est) +@ +\caption{True underlying DAG (left) and estimated PAG + (right), when applying the FCI and RFCI algorithms to the data set + \code{gmL}. The output of FCI and RFCI is identical. Variable $V_1$ of the + true underlying DAG is latent.} +\label{fig:fci} +\end{figure} + +%% <>= +%% showClass("pcAlgo") +%% @ + +\subsection{rfci}\label{sec:rfci} +The function \code{rfci()} is rather similar to \code{fci()}. However, it +does not compute any Possible-D-SEP sets and thus does not make tests +conditioning on them. This makes \code{rfci()} much faster than +\code{fci()}. The orientation rule for v-structures and the orientation +rule for so-called discriminating paths (rule 4) were modified in order to +produce a PAG which, in the oracle version, is guaranteed to have correct +ancestral relationships. + +The function can be called in the following way: +\par\vspace*{-1.2ex} +<>= +showF(rfci) +@ +\par\vspace*{-1ex} +where the arguments \code{suffStat}, \code{indepTest}, \code{p}, +\code{alpha}, \code{fixedGaps}, \code{fixedEdges}, \code{NAdelete} and +\code{m.max} are identical to those in \code{skeleton()}. + +The argument \code{rules} is similar to the one in +\code{fci} but modified to produce a PAG with correct ancestral +relationships, in the oracle version. + +The first part of the RFCI algorithm is analogous to the PC and FCI +algorithm. It starts with a complete undirected graph and estimates an +initial skeleton using the function \code{skeleton}, which produces +an initial order-independent skeleton, see \code{skeleton} for more +details. All edges of this skeleton are of the form $\gredge{o-o} $. Due to +the presence of hidden variables, it is no longer sufficient to consider +only subsets of the neighborhoods of nodes \code{x} and \code{y} to decide +whether the edge \code{x o-o y} should be removed. The FCI algorithm +performs independence tests conditioning on subsets of Possible-D-SEP to +remove those edges. Since this procedure is computationally infeasible, the +RFCI algorithm uses a different approach to remove some of those +superfluous edges before orienting the v-structures and the discriminating +paths in orientation rule 4. + +Before orienting the v-structures, we perform the following additional +conditional independence tests. For each unshielded triple $a \gredge{-} b +\gredge{-} c$ in the initial skeleton, we check if both $V_a$ and $V_b$ and +$V_b$ and $V_c$ are conditionally dependent given the separating of $a$ and +$c$ (sepset$(a,c)$). These conditional dependencies may not have been +checked while estimating the initial skeleton, since sepset$(a,c)$ does not +need to be a subset of the neighbors of $a$ nor of the neighbors of $c$. If +both conditional dependencies hold and $b$ is not in the sepset$(a,c)$, the +triple is oriented as a v-structure $a \gredge{->} b \gredge{<-} c$. On the +other hand, if an additional conditional independence relationship may be +detected, say $V_a$ is independent from $V_b$ given the sepset$(a,c)$, the +edge between $a$ and $c$ is removed from the graph and the set responsible +for that is saved in sepset$(a,b)$. The removal of an edge can destroy or +create new unshielded triples in the graph. To solve this problem we work +with lists \citep[for details see][]{rfci}. + +Before orienting discriminating paths, we perform the following additional +conditional independence tests. For each triple $a \gredge{<-*} b +\gredge{o-*} c$ with $a \gredge{->} c$, the algorithm searches for a +discriminating path $p = \left$ for $b$ of minimal +length, and checks that the vertices in every consecutive pair $(V_f,V_g)$ +on $p$ are conditionally dependent given all subsets of sepset$(d,c) +\setminus {V_f,V_g}$. If we do not find any conditional independence +relationship, the path is oriented as in rule (R4). If one or more +conditional independence relationships are found, the corresponding edges +are removed, their minimal separating sets are stored. + +Conservative RFCI can be computed if the argument of \code{conservative} is +\code{TRUE}. After the final skeleton is computed and the additional local +tests on all unshielded triples, as described above, have been done, all +potential v-structures $a \gredge{-} b \gredge{-} c$ are checked in the +following way. We test whether $V_a$ and $V_c$ are independent conditioning +on any subset of the neighbors of $a$ or any subset of the neighbors of +$c$. When a subset makes $V_a$ and $V_c$ conditionally independent, we call +it a separating set. If $b$ is in no such separating set or in all such +separating sets, no further action is taken and the normal version of the +RFCI algorithm is continued. If, however, $b$ is in only some separating +sets, the triple $a \gredge{-} b \gredge{-} c$ is marked +\emph{ambiguous}. If $V_a$ is independent of $V_c$ given some $S$ in the +skeleton (i.e., the edge $a \gredge{-} c$ dropped out), but $V_a$ and $V_c$ +remain dependent given all subsets of neighbors of either $a$ or $c$, we +will call all triples $a \gredge{-} b \gredge{-} c$ +\emph{unambiguous}. This is because in the RFCI algorithm, the true +separating set might be outside the neighborhood of either $a$ or $c$. An +ambiguous triple is not oriented as a v-structure. Furthermore, no further +orientation rule that needs to know whether $a \gredge{-} b \gredge{-} c$ +is a v-structure or not is applied. Instead of using the conservative +version, which is quite strict towards the v-structures, \cite{CoMa2013-arc} +introduced a less strict version for the v-structures called majority +rule. This adaptation can be called using \code{maj.rule = TRUE}. In this +case, the triple $a \gredge{-} b \gredge{-} c$ is marked as +\emph{ambiguous} if and only if $b$ is in exactly 50 percent of such +separating sets or no separating set was found. If $b$ is in less than 50 +percent of the separating sets it is set as a v-structure, and if in more +than 50 percent it is set as a non v-structure, for more details see +\cite{CoMa2013-arc}. + +The implementation uses the stabilized skeleton \code{skeleton()}, +which produces an initial order-independent skeleton. The final skeleton +and edge orientations can still be order-dependent, see \cite{CoMa2013-arc}. + +As an example, we re-run the example from Section~\ref{sec:fci} and show +the PAG estimated with \code{rfci()} in Figure~\ref{fig:fci}. The PAG +estimated with \code{fci()} and the PAG estimated with \code{rfci()} are +the same. + +<>= +data("gmL") +suffStat1 <- list(C = cor(gmL$x), n = nrow(gmL$x)) +pag.est <- rfci(suffStat1, indepTest = gaussCItest, + p = ncol(gmL$x), alpha = 0.01, labels = as.character(2:5)) +@ + +A note on implementation: As \code{pc()}, \code{fci()} and \code{rfci()} +are similar in the result they produce, their resulting values are of (S4) +class \code{pcAlgo} and \code{fciAlgo} (for both \code{fci()} and +\code{rfci()}), respectively. Both classes extend +the class (of their ``communalities'') \code{gAlgo}. + +\subsection{gies and simy} \label{sec:gies} + +As we noted in Section \ref{sec:gm}, the GIES algorithm is a generalization +of the GES algorithm to a mix of interventional and observational data. +Hence the usage of \code{gies()} is similar to that of \code{ges()} (see +Section~\ref{sec:ges}). Actually, the function \code{ges()} is only an +internal wrapper for \code{gies()}. + +A data set with jointly interventional and observational data points is +\emph{not} i.i.d. In order to use it for causal inference, we must specify +the intervention target each data point belongs to. This is done by +specifying the arguments \code{target} and \code{target.index} when +generating an instance of \code{GaussL0penIntScore} (see Section +\ref{sec:ges}): +<>= +score <- new("GaussL0penIntScore", data = matrix(1, 1, 1), + targets = list(integer(0)), target.index = rep(as.integer(1), nrow(data)), + lambda = 0.5*log(nrow(data)), intercept = FALSE, use.cpp = TRUE, ...) +@ +The argument \code{targets} is a list of all (mutually different) targets +that have been intervened in the experiments generating the data set. The +allocation of sample indices to intervention targets is specified by the +argument \code{target.index}. This is an integer vector whose first entry +specifies the index of the intervention target in the list \code{targets} +of the first data point, whose second entry specifies the target index of +the second data point, and so on. An example is given in Figure~\ref{fig:giesFit}. + +Once a score object for interventional data is defined, the GIES algorithm +is called as follows: +<>= +showF(gies) +@ +Most arguments coincide with those of \code{ges()} (see Section +\ref{sec:ges}). The only additional argument is \code{targets}: it takes +the same list of (unique) intervention targets as the constructor of the +class \code{GaussL0penIntScore} (see above). This list of targets +specifies the space of corresponding interventional Markov equivalence +classes or essential graphs (see Section \ref{sec:gm}). + +<>= +## Used to generate the 'gmInt' Gaussian data originally: +set.seed(40) +p <- 8 +n <- 5000 +gGtrue <- randomDAG(p, prob = 0.3) +nodes(gGtrue) <- c("Author", "Bar", "Ctrl", "Goal", "V5", "V6", "V7", "V8") +pardag <- as(gGtrue, "GaussParDAG") +pardag$set.err.var(rep(1, p)) +targets <- list(integer(0), 3, 5) +target.index <- c(rep(1, 0.6*n), rep(2, n/5), rep(3, n/5)) + +x1 <- rmvnorm.ivent(0.6*n, pardag) +x2 <- rmvnorm.ivent(n/5, pardag, targets[[2]], + matrix(rnorm(n/5, mean = 4, sd = 0.02), ncol = 1)) +x3 <- rmvnorm.ivent(n/5, pardag, targets[[3]], + matrix(rnorm(n/5, mean = 4, sd = 0.02), ncol = 1)) +gmInt <- list(x = rbind(x1, x2, x3), + targets = targets, + target.index = target.index, + g = gGtrue) +@ +<>= +data(gmInt) +n.tot <- length(gmInt$target.index) +n.obs <- sum(gmInt$target.index == 1) +n3 <- sum(gmInt$target.index == 2) +n5 <- sum(gmInt$target.index == 3) +@ + +The data set \code{gmInt} consists of \Sexpr{n.tot} data points sampled +from the DAG in Figure~\ref{fig:skelExpl}, among them \Sexpr{n.obs} +observational ones, \Sexpr{n3} originating from an intervention at vertex +$3$ and \Sexpr{n5} originating from an intervention at vertex $5$. It can +be loaded by calling +<>= +data(gmInt) +@ +The underlying causal model (or its interventional essential graph, +respectively) is estimated in Figure~\ref{fig:giesFit}. + +\begin{figure} + \centering +<>= +score <- new("GaussL0penIntScore", gmInt$x, targets = gmInt$targets, + target.index = gmInt$target.index) +gies.fit <- gies(score) +simy.fit <- simy(score) +par(mfrow = c(1, 3)) ; plot(gmInt$g, main = "") +plot(gies.fit$essgraph, main = "") +plot(simy.fit$essgraph, main = "") +@ + \caption{The underlying DAG (left) and the essential graph estimated with + the GIES algorithm (middle) and the dynamic programming approach of + \cite{Silander2006} (right) applied on the simulated interventional + Gaussian data set \code{gmInt}. This data set contains data from + interventions at vertices $3$ and $5$; accordingly, the orientation of + all arrows incident to these two vertices becomes identifiable (see + also Figure~\ref{fig:gesFit} for comparison with the observational + case.} + \label{fig:giesFit} +\end{figure} + +As an alternative to GIES, we can also use the dynamic programming approach +of \cite{Silander2006} to estimate the interventional essential graph from +this interventional data set. This algorithm is implemented in the +function \code{simy()} which has the same arguments as \code{gies()}. As +noted in Section \ref{sec:gm}, this approach yields the \emph{exact} +optimum of the BIC score at the price of a computational complexity which +is exponential in the number of variables. On the small example based on +$8$ variables, using this algorithm is feasible; however, it is not +feasible for more than approximately $20$ variables, depending on the +processor and memory of the machine. In this example, we get exactly the +same result as with \code{gies()} (see Figure~\ref{fig:giesFit}). + +\subsection{ida} \label{sec:ida} + +To illustrate the function \code{ida()}, consider the following example. We +simulated 10000 samples from seven multivariate Gaussian random variables +with a causal structure given on the left of Fig.~\ref{fig:ida}. We assume +that the causal structure is unknown and want to infer the causal effect of +$V_2$ on $V_5$. First, we estimate the equivalence class of DAGs that +describe the conditional independence relationships in the data, using the +function \code{pc()} (see Section~\ref{sec:pc}). + +%% Used to generate "gmI" IDA data +<>= +set.seed(123) +p <- 7 +n <- 10000 +myDAG <- randomDAG(p, prob = 0.2) +datI <- rmvDAG(n, myDAG) +gmI <- list(x = datI, g = myDAG) +@ + +<>= +data("gmI") +suffStat <- list(C = cor(gmI$x), n = nrow(gmI$x)) +pc.gmI <- pc(suffStat, indepTest=gaussCItest, + p = ncol(gmI$x), alpha = 0.01) +@ +Comparing the true DAG with the CPDAG in Fig.~\ref{fig:ida}, we see that +the CPDAG and the true DAG have the same skeleton. Moreover, the directed +edges in the CPDAG are also directed in that way in the true DAG. Three +edges in the CPDAG are bidirected. Recall that undirected and bidirected +edges bear the same meaning in a CPDAG, so they can be used interchangeably. +\begin{figure} + \centering +<>= +par(mfrow = c(1,2)) +plot(gmI$g, main = "") +plot(pc.gmI, main = "") +@ +\caption{True DAG (left) and estimated CPDAG (right).} +\label{fig:ida} +\end{figure} + +Since there are three undirected edges in the CPDAG, there might be up to +$2^3 = 8$ DAGs in the corresponding equivalence class. However, the +undirected edges $2 \gredge{-} 3 \gredge{-} 5$ can be oriented as a +new v-structure. As +mentioned in Section~\ref{sec:gm}, DAGs in the equivalence class must have +exactly the same v-structures as the corresponding CPDAG. Thus, +$2 \gredge{-} 3 \gredge{-} 5$ can only be oriented as +$2 \gredge{->} 3 \gredge{->} 5$, $2 \gredge{<-} 3 \gredge{<-} 5$ +or $2 \gredge{<-} 3 +\gredge{->} 5$, and not as $2 \gredge{->} 3 \gredge{<-} 5$. There is +only one remaining undirected edge ($1 \gredge{-} 6$), which can be oriented in +two ways. Thus, there are six valid DAGs (i.e., they have no new v-structures +and no directed cycles) and these form the equivalence class represented by +the CPDAG. In Fig.~\ref{fig:allDags}, all DAGs in the equivalence class are +shown. DAG 6 is the true DAG. + +<>= +am.pdag <- wgtMatrix(pc.gmI@graph) +ad <- allDags(am.pdag, am.pdag, NULL) +gDag <- vector("list", nrow(ad)) +for (i in 1:nrow(ad)) gDag[[i]] <- as(matrix(ad[i, ], 7, 7), "graphNEL") +par(mfrow = c(3,2)) +for (i in 1:6) plot(gDag[[i]], main = paste("DAG",i)) +@ +\begin{figure} + \centering % height ~= 3 x {default height} +%% FIXME (R): DAG 2 and 5 below have a larger font than the others: +<>= +sfsmisc::mult.fig(6) +for (i in 1:6) plot(gDag[[i]], main = paste("DAG",i)) +@ +\caption{All DAGs belonging to the same equivalence class as the true + DAG shown in Fig.~\ref{fig:fci}.} + %%~\ref{fig:ida.}} +\label{fig:allDags} +\end{figure} + +For each DAG G in the equivalence class, we apply Pearl's do-calculus to +estimate the total causal effect of $V_x$ on $V_y$. Since we assume +Gaussianity, this can be done via a +simple linear regression: If $y$ is not a parent of $x$, we take the +regression coefficient of $V_x$ in the regression \code{lm(Vy ~ Vx + + pa(Vx))}, where \code{pa(Vx)} denotes the parents of $x$ in the DAG G ($z$ is +called a parent of $x$ if G if G contains the edge $z \gredge{->} x$); if +$y$ is a parent of $x$ in G, we set the estimated causal effect to zero. + +If the equivalence class contains $k$ DAGs, this yields $k$ estimated +total causal effects. Since we do not know which DAG is the true causal +DAG, we do not know which estimated total causal effect of $V_x$ on $V_y$ is +the correct one. Therefore, we return the entire multiset of $k$ estimated +effects. + +In our example, there are six DAGs in the equivalence class. Therefore, the +function \code{ida()} (with \code{method = "global"}) produces six possible +values of causal effects, one for each DAG. +<>= +ida(2, 5, cov(gmI$x), pc.gmI@graph, method = "global", verbose = FALSE) +@ + +Among these six values, there are only two unique values: $-0.0049$ and +$0.5421$. This is because we compute \code{lm(V5 ~ V2 + pa(V2))} +for each +DAG and report the regression coefficient of $V_2$. Note that there are +only two possible parent sets of node $2$ in all six DAGs: In DAGs 3 and 6, +there are no parents of node $2$. In DAGs 1, 2, 4 and 5, however, the parent +of node $2$ is node $3$. Thus, exactly the same regressions are computed for +DAGs 3 and 6, and the same regressions are computed for DAGs 1, 2, 4 and +5. Therefore, we end up with two unique values, one of which occurs twice, +while the other occurs four times. + +Since the data was simulated from a model, we know that the true value of the +causal effect of $V_2$ on $V_5$ is $0.5529$. Thus, one of the two unique values is +indeed very close to the true causal effect (the slight discrepancy is due +to sampling error). + +The function \code{ida()} can be called as % with the following arguments. +% \code{ida(x.pos, y.pos, mcov, graphEst, method = "local", y.notparent = FALSE,\\ +% verbose = FALSE, all.dags = NA)}, +\par\vspace*{-1.2ex} +<>= +showF(ida) +@ +\par\vspace*{-1ex} +where \code{x.pos} denotes the column position of the cause variable, +\code{y.pos} denotes the column position of the effect +variable, \code{mcov} is the covariance matrix of the original +data, and \code{graphEst} is a graph object describing the causal structure +(this could be given by experts or estimated by \code{pc()}). + +If \code{method="global"}, the method is carried out as described above, +where all DAGs in the equivalence class of the estimated CPDAG are +computed. This method is suitable for small graphs (say, up to 10 +nodes). The DAGs can (but need not) be precomputed using the function +\code{allDags()} and passed via argument \code{all.dags}. + +If \code{method="local"}, we do not determine all DAGs in the equivalence +class of the CPDAG. Instead, we only consider the local neighborhood of $x$ +in the CPDAG. In particular, we consider all possible directions of +undirected edges that have $x$ as endpoint, such that no new v-structure is +created. For each such configuration, we estimate the total causal effect +of $V_x$ on $V_y$ as above, using linear regression. + +At first sight, it is not clear that such a local configuration corresponds +to a DAG in the equivalence class of the CPDAG, since it may be impossible +to direct the remaining undirected edges without creating a directed cycle +or a v-structure. However, \cite{MaKaBu09} showed +that there is at least one DAG in the equivalence class for each such local +configuration. As a result, it follows that the multisets of total causal +effects of the \code{global} and the \code{local} method have the same unique +values. They may, however, have different multiplicities. + +Recall, that in the example using the global method, we obtained two unique +values with multiplicities two and four yielding six numbers in total. +Applying the local method, we obtain the same unique values, but the +multiplicities are 1 for both values. +<>= +ida(2,5, cov(gmI$x), pc.gmI@graph, method = "local") +@ + +One can take summary measures of the multiset. For example, the minimum +absolute value provides a lower bound on the size of the true causal +effect: If the minimum absolute value of all values in the multiset is +larger than one, then we know that the size of the true causal +effect (up to sampling error) must be larger than one. The fact that the +unique values of the multisets of the \code{global} and \code{local} +method are identical implies that summary measures of the multiset that +only depend on the unique values (such as the minimum absolute value) can +be found using the local method. + +In some applications, it is clear that some variable is definitively a cause +of other variables. Consider for example a bacterium producing +a certain substance, taking the amount of produced substance as response +variable. Knocking out genes in the bacterium might change the ability to +produce the substance. By measuring the expression levels of genes, we want +to know which genes have a causal effect on the product. In this setting, +it is clear that the amount of substance is the effect and the activity of +the genes is the cause. Thus in the causal structure, the response variable +cannot be a parent node of any variable describing the expression level of +genes. This background knowledge can be easily incorporated: By setting the +option \code{y.notparent = TRUE}, all edges in the CPDAG that have the +response variable as endpoint (no matter whether directed or undirected) +are overwritten so that they are oriented towards the response variable. + +\subsection{idaFast} +In some applications it is desirable to estimate the causal effect of one +variable on a set of response variables. In these situations, the function +\code{idaFast()} should be used. Imagine for example, that we have data +on several variables, that we have no background knowledge about the causal +effects among the variables and that we want to estimate the causal effect of +each variable onto each other variable. To this end, we could consider for +each variable the problem: What is the causal effect of this variable on +all other variables. Of course, one could solve the problem by using \code{ida()} on +each pair of variables. However, there is a more efficient way which uses +the fact that a linear regression of a fixed set of explanatory variables +on several different response variables can be computed very efficiently. + +The function \code{idaFast()} can be called with the following arguments +%\code{idaFast(x.pos, y.pos.set, mcov, graphEst)}. +\par\vspace*{-1.2ex} +<>= +showF(idaFast) +@ +\par\vspace*{-1ex} +The arguments +\code{x.pos}, \code{mcov}, \code{graphEst} have the same meaning as +the corresponding arguments in \code{ida()}. The argument \code{y.pos.set} +is a vector containing the column positions of all response variables of +interest. + +This call performs \code{ida(x.pos, y.pos, mcov, graphEst, method="local", + y.notparent= FALSE, verbose=FALSE)} for all values of \code{y.pos} in +\code{y.pos.set} at the same time and in an efficient way. Note that the +option \code{y.notparent = TRUE} is not implemented. +%%- , since it is not +%%- clear how to do that efficiently without orienting all edges away from +%%- \code{y.pos.set} at the same time, which seems not to be desirable. + +Consider the example from Section~\ref{sec:ida}, where we computed the +causal effect of $V_2$ on $V_5$. Now, we want to compute the effect of $V_2$ +on $V_5$, $V_6$ and $V_7$ using \code{idaFast()} and compare the results with +the output of \code{ida()}. As expected, both methods lead to the same results. +<>= +(eff.est1 <- ida(2,5, cov(gmI$x), pc.gmI@graph, method="local")) +(eff.est2 <- ida(2,6, cov(gmI$x), pc.gmI@graph, method="local")) +(eff.est3 <- ida(2,7, cov(gmI$x), pc.gmI@graph, method="local")) + +(eff.estF <- idaFast(2, c(5,6,7), cov(gmI$x), pc.gmI@graph)) +@ + +\subsection{backdoor} \label{sec:backdoor} + +This function is a generalization of Pearl's backdoor criterion, see +\cite{Pearl93}, defined for directed acyclic graphs (DAGs), for single +interventions and single outcome variable to more general +types of graphs (CPDAGs, MAGs, and PAGs) that describe Markov equivalence +classes of DAGs with and without latent variables but without selection +variables, for more details see \cite{MaCo2013-arc}. + +The motivation to find a set $W$ that satisfies the generalized backdoor +criterion with respect to $X$ and $Y$ in the given graph relies on the +result of the generalized backdoor adjustment that says: ``If a set of +variables $W$ satisfies the generalized backdoor criterion relative to $X$ +and $Y$ in the given graph, then the causal effect of $X$ on $Y$ is +identifiable and is given by:" $P(Y|\text{do}(X = x)) = \sum_W +P(Y|X,W).P(W)$. This result allows to write post-intervention densities +(the one written using Pearl's do-calculus) using only observational +densities estimated from the data. + +This function can be called in the following way: +\par\vspace*{-1.2ex} +<>= +showF(backdoor) +@ +\par\vspace*{-1ex} + +where \code{amat} is the adjacency matrix of the given graph, \code{x} +denotes the column position of the cause variable, \code{y} denotes the +column position of the effect variable, and \code{mcov} is the covariance +matrix of the original data. + +The argument \code{type} specifies the type of graph of the given adjacency +matrix in \code{amat}. If the input graph is a DAG (\code{type="dag"}), +this function reduces to Pearl's backdoor criterion for single +interventions and single outcome variable, and the parents of $X$ in the +DAG satisfies the backdoor criterion unless $Y$ is a parent of +$X$. Therefore, if $Y$ is a parent of $X$, there is no set $W$ that +satisfies the generalized backdoor criterion relative to $X$ and $Y$ in the +DAG and NA is output. Otherwise, the causal effect is identifiable and a +set $W$ that satisfies the generalized backdoor criterion relative to $X$ +and $Y$ in the DAG is given. If the input graph is a CPDAG $C$ +(\code{type="cpdag"}), a MAG $M$, or a PAG $P$ (with both $M$ and $P$ not +allowing selection variables), this function first checks if the total +causal effect of $X$ on $Y$ is identifiable via the generalized backdoor +criterion (see \cite{MaCo2013-arc}, Theorem 4.1). If the effect is not +identifiable, the output is NA. Otherwise, an explicit set $W$ that +satisfies the generalized backdoor criterion relative to $X$ and $Y$ in the +given graph is found. + +Note that if the set $W$ is equal to the empty set, the output is NULL. + +At this moment this function is not able to work with PAGs estimated using +the \code{rfci} Algorithm. + +It is important to note that there can be pair of nodes \code{x} and +\code{y} for which there is no set $W$ that satisfies the generalized +backdoor criterion, but the total causal effect might be identifiable via +some other technique. + +To illustrate this function, we use as example the CPDAG displayed in +Figure 4, page 15 of \cite{MaCo2013-arc}. The R-code below is used to generate +a DAG \code{g} that belongs to the required equivalence class which is +uniquely represented by the estimated CPDAG \code{myCPDAG}. + +<>= +p <- 6 +amat <- t(matrix(c(0,0,1,1,0,1, 0,0,1,1,0,1, 0,0,0,0,1,0, + 0,0,0,0,1,1, 0,0,0,0,0,0, 0,0,0,0,0,0), 6,6)) +V <- as.character(1:6) +colnames(amat) <- rownames(amat) <- V +edL <- vector("list",length=6) +names(edL) <- V +edL[[1]] <- list(edges=c(3,4,6),weights=c(1,1,1)) +edL[[2]] <- list(edges=c(3,4,6),weights=c(1,1,1)) +edL[[3]] <- list(edges=5,weights=c(1)) +edL[[4]] <- list(edges=c(5,6),weights=c(1,1)) +g <- new("graphNEL", nodes=V, edgeL=edL, edgemode="directed") + +cov.mat <- trueCov(g) + +myCPDAG <- dag2cpdag(g) +true.amat <- as(myCPDAG, "matrix") +## true.amat[true.amat != 0] <- 1 +@ + +The DAG \code{g} and the CPDAG \code{myCPDAG} are shown in Figure~\ref{fig:backdoor}. +\begin{figure} + \centering +<>= +par(mfrow = c(1,2)) +plot(g, main = "") +plot(myCPDAG, main = "") +@ +\caption{True DAG (left) and estimated CPDAG (right).} +\label{fig:backdoor} +\end{figure} + +Now, we want to check if the effect of $V_6$ on $V_3$ in the given CPDAG is +identifiable using \code{backdoor()} and if this is the case know which set +$W$ satisfies the generalized backdoor criterion. As explained in Example 4 in +\cite{MaCo2013-arc}, the causal effect of $V_6$ on $V_3$ in the CPDAG +\code{myCPDAG} is identifiable via the generalized backdoor criterion and +there is a set $W$ that satisfies the generalized criterion: + +<>= +backdoor(true.amat, 6, 3, type="cpdag") +@ + +\subsection{Using a user specific conditional independence test} + +In some cases it might be desirable to use a user specific conditional +independence test instead of the provided ones. The \pkg{pcalg} +package allows the use of any conditional independence test defined by +the user. In this section, we illustrate this feature by using a +conditional independence test for Gaussian data that is not predefined +in the package. + +The functions \code{skeleton()}, \code{pc()} and \code{fci()} all need the +argument \code{indepTest}, a function of the form +\code{indepTest(x, y, S, suffStat)} to test +conditional independence relationships. This function must return +the p-value of the conditional independence test of $V_x$ and $V_y$ given +$V_S$ and some information on the data in the form of a sufficient +statistic (this might be simply the data frame with the original +data), where $x$, $y$, $S$ indicate column positions of the original data +matrix. We will show an example that illustrates how to construct such a +function. + +A simple way to compute the partial correlation of $V_x$ and $V_y$ given $V_S$ +for some data is to solve the two associated linear regression problems +\code{lm}($V_x \sim V_S$) and \code{lm}($V_y \sim V_S$), get the residuals, and +calculate the correlation between the residuals. Finally, a correlation +test between the residuals yields a p-value that can be returned. The +argument \code{suffStat} is an arbitrary object containing several pieces +of information that are all used within the function to produce the +p-value. In the predefined function \code{gaussCItest()} for example, a +list containing the correlation matrix and the number of observations is +passed. This has the advantage that any favorite (e.g., robust) method of +computing the correlation matrix can be used before partial correlations +are computed. Oftentimes, however, it suffices to just pass the +complete data set in \code{suffStat}. We choose this simple method in +our example. An implementation of the function \code{myCItest()} could look +like this. +<>= +options(continue = " ") # MM: so we don't get the "+ " continuation lines +@ +<>= +myCItest <- function(x,y,S, suffStat) { + if (length(S) == 0) { + x. <- suffStat[,x] + y. <- suffStat[,y] + } else { + rxy <- resid(lm.fit(y= suffStat[,c(x,y)], x= cbind(1, suffStat[,S]))) + x. <- rxy[,1]; y. <- rxy[,2] + } + cor.test(x., y.)$p.value +} +@ +We can now use this function together with \code{pc()}. +<>= +suffStat <- list(C = cor(gmG8$x), n = 5000) +pc.gmG <- pc(suffStat, indepTest=gaussCItest, p = 8, alpha = 0.01) +@ +<>= +pc.myfit <- pc(suffStat = gmG8$x, indepTest = myCItest, + p = 8, alpha = 0.01) +par(mfrow = c(1,2)); plot(pc.gmG, main = ""); plot(pc.myfit, main = "") +@ +\begin{figure}[htb] + \centering +<>= +<> +@ +\caption{The estimated CPDAGs using the predefined conditional independence + test \code{gaussCItest()} (left) and the user + specified conditional independence test \code{myCItest()} (right) + are identical for the \code{gmG} data.} +\label{fig:userSpec} +\end{figure} +As expected, the resulting CPDAG (see Fig.~\ref{fig:userSpec}) is the same +as in Section~\ref{sec:pc} where we used the function \code{gaussCItest()} as +conditional independence test. Note however that using +\code{gaussCItest()} is considerably faster than using \code{myCItest()} (on +our computer +% 2010-09-24 : -- R 2.12.0 alpha +% lynne : x86_64 Linux 2.6.34.6-47.fc13.x86_64 : 129.132.58.30 +% model name : AMD Phenom(tm) II X4 925 Processor +% cpu MHz : 1600.000 +% bogomips : 5600.57 +$0.059$ seconds using \code{gaussCItest()} versus $1.05$ +seconds using \code{myCItest()}). +%% MM: Nach Verbesserung [lm.fit()] ist's immer noch deutlich langsame +%% ----- myCItest() noch wesentlich schneller geschrieben werden muss ! +<>= +system.time(for(i in 1:10) + pc.fit <- pc(suffStat, indepTest=gaussCItest, p = 8, alpha = 0.01)) + ## User System verstrichen + ## 0.593 0.000 0.594 +system.time(for(i in 1:10) + pc.myfit <- pc(gmG8$x, indepTest = myCItest, p = 8, alpha = 0.01)) +## Using resid(lm(..)) twice: + ## User System verstrichen + ## 44.864 0.007 44.937 +## Using resid(lm.fit(..)): + ## 10.550 0.067 10.632 +@ + +\section{Applications} +The \pkg{pcalg} package has been used for applications in epidemiology +\citep[see][]{ICF}, biology \citep[see][]{NatMethods10, nagarajan} and the +social sciences \citep[see][]{danenberg}. We will discuss two applications in +more detail below. + +\subsection{Graphical Models and Causal Effects in Human Functioning} +In \cite{ICF}, the development of WHO's International Classification of +Functioning, Disability and Health (ICF) on the one hand and recent +developments in graphical modeling on the other hand were combined to +deepen the understanding of human functioning. The objective of the paper +was to explore how graphical models can be +used in the study of ICF data. It was found that graphical models could be used +successfully for visualization of the dependence structure of the data set, +dimension reduction, and the comparison of subpopulations. Moreover, +estimations of bounds on causal effects using the IDA method yielded +plausible results. All analyses were done with the \pkg{pcalg} package. + +\subsection{Causal effects among genes} +In \cite{NatMethods10}, the authors aim at quantifying the effects of +single gene interventions on the expression of other genes in yeast, +allowing for better insights into causal relations between genes. With $n = +63$ samples of observational data measuring the expression of $p = 5361$ +genes \citep[see][]{HughesEtAl00}, the goal was to identify the largest +intervention effects between all pairs of genes. For the analysis, the +\pkg{pcalg} package with version 1.1-5 was used. + +\cite{HughesEtAl00} also provide gene expression measurements from 234 +interventional experiments, namely from 234 single-gene deletion mutant +strains. Using this data, we know the true causal effect of the knock-out +genes on the remaining genes in good approximation. We can then quantify +how well we can find the true intervention effects in the following way: We +encode the largest 10\% of the intervention effects computed from the +interventional data as the target set of effects that we want to +identify. We then check in an ROC curve, how well the ranking of the causal +effects estimated by applying \code{ida()} to the observational data is +able to identify effects in the target set. For comparison, the authors +also used the (conceptually wrong) Lasso and Elastic Net to obtain +rankings. In Figure~\ref{fig:yeast} one can see that \code{ida()}, using +the function \code{skeleton()} with version 1.1-5, is +clearly superior to the alternative methods (and random guessing) in terms +of identifying effects in the target set. In Figure~\ref{fig:yeast.new} one +can see that \code{ida()} using the stable function \code{skeleton()} +produces even better results than with the old version. + +We note that the yeast data set is very high-dimensional ($n=63$, +$p=5361$). Thus, unlike the toy examples used to illustrate the package in +this manuscript, where $n$ was much bigger than $p$ and the causal +structure was recovered exactly up to its equivalence class, the estimated +causal structure for the yeast data is likely to contain many sampling +errors. However, Figure~\ref{fig:yeast} shows that it is still possible to +extract useful information about causal effects. + +\begin{figure}[htb] + \centering + \includegraphics{Figure1FAT.pdf} + \caption{The largest 10\% of the causal effects found in experiments + among yeast genes are identified much better from observational data + with IDA than with Lasso, Elastic Net or random guessing. The figure is + essentially taken from \cite{NatMethods10}.} +\label{fig:yeast} +\end{figure} + +\begin{figure}[htb] + \centering + \includegraphics{Figure2FAT.pdf} + \caption{The largest 10\% of the causal effects found in experiments + among yeast genes are identified much better from observational data + with IDA than with Lasso, Elastic Net or random guessing. The figure is + essentially taken from \cite{CoMa2013-arc}.} +\label{fig:yeast.new} +\end{figure} + + +\section{Discussion} + +Causal structure learning and the estimation of causal effects from +observational data has large potential. However, we emphasize that we do +not propose causal inference methods based on observational data as a +replacement for experiments. Rather, IDA should be used as a guide for +prioritizing experiments, especially in situations where no clear +preferences based on the context can be given. + +Data from cell biology is usually interventional data: different +measurements could originate from different mutants or different cell +stems, or from experiments with gene knockout or knockdown experiments. +The GIES algorithm is designed for causal inference from data of this +kind. + +Since many assumptions of the proposed methods are uncheckable, it is +important to further validate the methods in a range of applications. We +hope that the \pkg{pcalg} package contributes to this important +issue by providing well-documented and easy to use software. + +\section{Session information} + +<>= +toLatex(sessionInfo(), locale=FALSE) +<>= +options(op.orig) +@ +\newpage +\bibliography{Mybib} + +\end{document} diff --git a/inst/doc/pcalgDoc.pdf b/inst/doc/pcalgDoc.pdf index be77474..bd08592 100644 Binary files a/inst/doc/pcalgDoc.pdf and b/inst/doc/pcalgDoc.pdf differ diff --git a/inst/external/gac-pags.rds b/inst/external/gac-pags.rds new file mode 100644 index 0000000..5c43751 Binary files /dev/null and b/inst/external/gac-pags.rds differ diff --git a/inst/include/pcalg/gies_debug.hpp b/inst/include/pcalg/gies_debug.hpp index 65d629f..df65b17 100644 --- a/inst/include/pcalg/gies_debug.hpp +++ b/inst/include/pcalg/gies_debug.hpp @@ -2,13 +2,13 @@ * Debugging functions for GIES * * @author Alain Hauser - * $Id: gies_debug.hpp 248 2014-03-03 11:27:22Z alhauser $ + * $Id: gies_debug.hpp 249 2014-03-03 12:09:18Z alhauser $ */ #ifndef GIES_DEBUG_HPP_ #define GIES_DEBUG_HPP_ -#include +#include #include // Define default debug level diff --git a/inst/include/pcalg/greedy.hpp b/inst/include/pcalg/greedy.hpp index 10b97c8..d610262 100644 --- a/inst/include/pcalg/greedy.hpp +++ b/inst/include/pcalg/greedy.hpp @@ -2,7 +2,7 @@ * Classes for greedy estimation of causal structures * * @author Alain Hauser - * $Id: greedy.hpp 256 2014-04-09 11:54:39Z alhauser $ + * $Id: greedy.hpp 393 2016-08-20 09:43:47Z alhauser $ */ #ifndef GREEDY_HPP_ @@ -20,6 +20,9 @@ enum edge_flag { NOT_PROTECTED, UNDECIDABLE, PROTECTED }; +// Types of adaptiveness (cf. "ARGES") +enum ForwardAdaptiveFlag { NONE, VSTRUCTURES, TRIPLES }; + /** * Help functions for easier handling of set operations */ @@ -84,7 +87,7 @@ struct EdgeCmp : public std::binary_function }; /** - * Helper class used as a stack for candidate cliques C \subset N + * Auxiliary class used as a stack for candidate cliques C \subset N */ class CliqueStack : public std::deque > { @@ -110,7 +113,7 @@ class CliqueStack : public std::deque > }; /** - * Helper classes for storing cached values + * Auxiliary classes for storing cached values */ struct ArrowChange { @@ -129,6 +132,112 @@ struct ArrowChangeCmp : public std::binary_function enum step_dir { SD_NONE, SD_FORWARD, SD_BACKWARD, SD_TURNING }; +/** + * Graph operations that can be logged + */ +enum graph_op { GO_ADD_EDGE, GO_REMOVE_EDGE, GO_LOCAL_SCORE }; + +/** + * Auxiliary class for logging graph operations. + * + * This is a virtual base class that does not actually log operations; + * derived classes have to do that. + */ +class GraphOperationLogger +{ +public: + /** + * Constructor. Does nothing for base class. + */ + GraphOperationLogger() {}; + + /** + * Destructor. Needs to be virtual because of different storage + * of data in derived classes. + */ + virtual ~GraphOperationLogger() {}; + + /** + * Reset logger + */ + virtual void reset() {}; + + /** + * Log graph operation. If a single vertex is involved, it is specified + * as "first vertex". If an edge is involved, source and target are specified + * as first and second vertex, resp. + */ + virtual void log(graph_op operation, uint first, uint second = 0) {}; +}; + +class EdgeOperationLogger : public GraphOperationLogger +{ +protected: + /** + * Sets of added and removed edges + */ + std::set _addedEdges; + std::set _removedEdges; + +public: + /** + * Constructor + */ + EdgeOperationLogger() : + GraphOperationLogger(), + _addedEdges(), + _removedEdges() {}; + + /** + * Destructor + */ + virtual ~EdgeOperationLogger() {}; + + /** + * Reference to added or removed edges + */ + const std::set& addedEdges() { return _addedEdges; } + const std::set& removedEdges() { return _removedEdges; } + + /** + * Reset logger + */ + virtual void reset() + { + _addedEdges.clear(); + _removedEdges.clear(); + } + + /** + * Log edge additions or removals + */ + virtual void log(graph_op operation, uint first, uint second = 0) + { + Edge edge(first, second); + switch (operation) { + case GO_ADD_EDGE : + // If edge was already removed before, clear removal entry; + // otherwise add addition entry. + if (_removedEdges.erase(edge) == 0) { + _addedEdges.insert(edge); + } + break; + + case GO_REMOVE_EDGE : + // If edge was already added before, clear addition entry; + // otherwise add removal entry. + if (_addedEdges.erase(edge) == 0) { + _removedEdges.insert(edge); + } + break; + + default : + break; + } + } +}; + + // Forward declaration for testing class EssentialGraphTest; class BICScoreTest; @@ -208,11 +317,21 @@ class EssentialGraph */ boost::dynamic_bitset<> _childrenOnly; + /** + * Loggers for graph operations + */ + std::set _loggers; + /** * Checks whether there is a fixed gap between two vertices. */ bool gapFixed(const uint a, const uint b) const; + /** + * Marks a gap as fixed or not fixed + */ + void setFixedGap(const uint a, const uint b, const bool fixed); + /** * Checks whether there is a path from a to b in the graph that does not * go through the vertices of C. The edge (a, b) is not considered, if it @@ -506,6 +625,12 @@ class EssentialGraph */ std::set getChainComponent(const uint v) const; + /** + * Adds and removes loggers. Functions return true on success. + */ + bool addLogger(GraphOperationLogger* logger); + bool removeLogger(GraphOperationLogger* logger); + /** * Sets and gets score object */ @@ -577,8 +702,11 @@ class EssentialGraph /** * Does one forward step of the greedy interventional equivalence search. + * + * @param adaptive: indicates whether set of allowed edges should be + * adaptively enlarged according to AGES */ - bool greedyForward(); + bool greedyForward(const ForwardAdaptiveFlag adaptive = NONE); /** * Does one backward step of the greedy interventional equivalence search @@ -590,6 +718,12 @@ class EssentialGraph */ bool greedyTurn(); + /** + * Wrapper function to the greedy... functions; first argument indicates requested + * direction + */ + bool greedyStepDir(const step_dir direction, const ForwardAdaptiveFlag adaptive = NONE); + /** * Does one greedy step, either forward, backward, or turning, the one that * yields the highest score gain. @@ -614,6 +748,11 @@ class EssentialGraph */ bool greedyDAGTurn(); + /** + * Wrapper function for any of the three preceding functions + */ + bool greedyDAGStepDir(const step_dir direction); + /** * Maximizes the BIC score by dynamic programming, as proposed by * Silander and Myllymäki (2006). Only works for small graphs @@ -633,4 +772,15 @@ class EssentialGraph std::set getOptimalTarget(uint maxSize); }; +/** + * Reads in a graph from a list of in-edges passed as a SEXP to + * an EssentialGraph object + */ +EssentialGraph castGraph(const SEXP argInEdges); + +/** + * Wrap a graph structure to an R list of in-edges + */ +Rcpp::List wrapGraph(const EssentialGraph& graph); + #endif /* GREEDY_HPP_ */ diff --git a/inst/include/pcalg/score.hpp b/inst/include/pcalg/score.hpp index 9a420d2..23f1f5b 100644 --- a/inst/include/pcalg/score.hpp +++ b/inst/include/pcalg/score.hpp @@ -3,7 +3,7 @@ * given some data * * @author Alain Hauser - * $Id: score.hpp 248 2014-03-03 11:27:22Z alhauser $ + * $Id: score.hpp 393 2016-08-20 09:43:47Z alhauser $ */ #ifndef SCORE_HPP_ @@ -147,7 +147,7 @@ class Score * library * @param data preprocessed data */ -Score* createScore(std::string name, TargetFamily* targets, Rcpp::List data); +Score* createScore(std::string name, TargetFamily* targets, Rcpp::List& data); /** * Macros for ScoreRFunction: constants for finding the different R functions @@ -182,6 +182,8 @@ class ScoreRFunction : public Score ScoreRFunction(uint vertexCount, TargetFamily* targets) : Score(vertexCount, targets) {} + virtual ~ScoreRFunction() {} + virtual uint getTotalDataCount() const { return _totalDataCount; } virtual void setData(Rcpp::List& data); @@ -242,7 +244,67 @@ class ScoreGaussL0PenScatter : public Score ScoreGaussL0PenScatter(uint vertexCount, TargetFamily* targets) : Score(vertexCount, targets), _dataCount(vertexCount), - _scatterMatrices(vertexCount) {}; + _scatterMatrices(vertexCount) {} + + virtual ~ScoreGaussL0PenScatter() {} + + virtual uint getTotalDataCount() const { return _totalDataCount; } + + virtual uint getDataCount(const uint vertex) const { return _dataCount[vertex]; } + + virtual void setData(Rcpp::List& data); + + virtual double local(const uint vertex, const std::set& parents) const; + + virtual double global(const EssentialGraph& dag) const; + + virtual std::vector localMLE(const uint vertex, const std::set& parents) const; + + virtual std::vector< std::vector > globalMLE(const EssentialGraph& dag) const; +}; + +/** + * Scoring class calculating a penalized l0-log-likelihood of Gaussian data, + * based on the raw data matrix. + * + * Special case: BIC score + */ +class ScoreGaussL0PenRaw : public Score +{ +protected: + /** + * Numbers of data points. + * + * For each vertex, the number of all data points coming from intervention NOT + * including this vertex are stored (n^{(i)}, 1 \leq i \leq p, in the usual + * notation). + */ + std::vector _dataCount; + uint _totalDataCount; + + /** + * Penalty constant + */ + double _lambda; + + /** + * Indicates whether an intercept should be calculated. + */ + bool _allowIntercept; + + /** + * Raw data matrix and list of "non-interventions" + */ + arma::mat _dataMat; + std::vector _nonInt; + +public: + ScoreGaussL0PenRaw(uint vertexCount, TargetFamily* targets) : + Score(vertexCount, targets), + _dataCount(vertexCount), + _nonInt(vertexCount) {} + + virtual ~ScoreGaussL0PenRaw() {} virtual uint getTotalDataCount() const { return _totalDataCount; } diff --git a/man/LINGAM.Rd b/man/LINGAM.Rd index 2a060a3..0aded23 100644 --- a/man/LINGAM.Rd +++ b/man/LINGAM.Rd @@ -1,13 +1,17 @@ \name{LINGAM} -\title{Linear non-Gaussian Additive Models (LiNGAM)} +\title{Linear non-Gaussian Acyclic Models (LiNGAM)} +\alias{lingam} \alias{LINGAM} \description{ - Fits a Linear non-Gaussian Additive Model (LiNGAM) to the data and + Fits a Linear non-Gaussian Acyclic Model (LiNGAM) to the data and returns the corresponding DAG. For details, see the reference below. } \usage{ +lingam(X, verbose = FALSE) + +## For back-compatibility; this is *deprecated* LINGAM(X, verbose = FALSE) } \arguments{ @@ -18,7 +22,22 @@ LINGAM(X, verbose = FALSE) %% \details{ %% } \value{ - list with components + \code{lingam()} returns an \R object of (S3) class \code{"LINGAM"}, + basically a \code{\link{list}} with components + \item{Bpruned}{a \eqn{p \times p}{p x p} matrix \eqn{B} of linear + coefficients, where \eqn{B_{i,j}} corresponds to a directed edge + from \eqn{j} to \eqn{i}. + %% Note it corresponds to the \emph{transpose} of + %% \code{Adj}, i.e., \code{identical( Adj, t(B) != 0 )} is true.} + } + \item{stde}{a vector of length \eqn{p} with the standard deviations of + the estimated residuals} + \item{ci}{a vector of length \eqn{p} with the intercepts of each + equation + \cr \dots\dots\dots\dots\dots\dots% most ugly, but otherwise \value{} cannot be used + \cr } + + \code{LINGAM()} --- \emph{deprecated now} --- returns a \code{\link{list}} with components \item{Adj}{a \eqn{p \times p}{p x p} 0/1 adjacency matrix \eqn{A}. \code{A[i,j] == 1} corresponds to a directed edge from i to j.} \item{B}{\eqn{p \times p}{p x p} matrix of corresponding linear @@ -31,9 +50,11 @@ LINGAM(X, verbose = FALSE) \emph{Journal of Machine Learning Research} \bold{7}, 2003--2030. } \author{ + Of \code{LINGAM()} and the underlying functionality, +%% MM: use \email{} or drop the e-mail addresses: They are harvested by spammers Patrik Hoyer , Doris Entner , Antti Hyttinen - and Jonas Peters + and Jonas Peters . } \seealso{ \code{\link{fastICA}} from package \pkg{fastICA} is used. @@ -42,29 +63,36 @@ LINGAM(X, verbose = FALSE) ################################################## ## Exp 1 ################################################## -set.seed(123) +set.seed(1234) n <- 500 eps1 <- sign(rnorm(n)) * sqrt(abs(rnorm(n))) eps2 <- runif(n) - 0.5 -x2 <- eps2 -x1 <- 0.9*x2 + eps1 - -X <- cbind(x1,x2) +x2 <- 3 + eps2 +x1 <- 0.9*x2 + 7 + eps1 +#truth: x1 <- x2 trueDAG <- cbind(c(0,1),c(0,0)) -## x1 <- x2 -## adjacency matrix: -## 0 0 -## 1 0 -estDAG <- LINGAM(X) +X <- cbind(x1,x2) +res <- lingam(X) cat("true DAG:\n") show(trueDAG) cat("estimated DAG:\n") -show(estDAG$Adj) +as(res, "amat") + +cat("\n true constants:\n") +show(c(7,3)) +cat("estimated constants:\n") +show(res$ci) + +cat("\n true (sample) noise standard deviations:\n") +show(c(sd(eps1), sd(eps2))) +cat("estimated noise standard deviations:\n") +show(res$stde) + ################################################## ## Exp 2 @@ -83,7 +111,6 @@ x4 <- -x1 -0.9*x3 + eps4 X <- cbind(x1,x2,x3,x4) - trueDAG <- cbind(x1 = c(0,1,0,0), x2 = c(0,0,0,0), x3 = c(0,1,0,0), @@ -95,15 +122,15 @@ trueDAG <- cbind(x1 = c(0,1,0,0), ## 0 0 0 1 ## 0 0 0 0 -estDAG1 <- LINGAM(X, verbose = TRUE)# details on LINGAM -estDAG2 <- LINGAM(X, verbose = 2) # details on LINGAM and fastICA +res1 <- lingam(X, verbose = TRUE)# details on LINGAM +res2 <- lingam(X, verbose = 2) # details on LINGAM and fastICA ## results are the same, of course: -stopifnot(identical(estDAG1, estDAG2)) +stopifnot(identical(res1, res2)) cat("true DAG:\n") show(trueDAG) cat("estimated DAG:\n") -show(estDAG1$Adj) +as(res1, "amat") } \keyword{multivariate} \keyword{models} diff --git a/man/Score-class.Rd b/man/Score-class.Rd index a6df9ba..010d73e 100755 --- a/man/Score-class.Rd +++ b/man/Score-class.Rd @@ -13,6 +13,8 @@ deriving an own class from this virtual base class, i.e., implementing an own score function. \describe{ + \item{\code{.nodes}:}{Node labels. They are passed to causal inference + methods by default to label the nodes of the resulting graph.} \item{\code{decomp}:}{Indicates whether the represented score is decomposable (cf. details). At the moment, only decomposable scores are supported by the implementation of the causal inference algorithms; @@ -33,6 +35,7 @@ new("Score", data = matrix(1, 1, 1), targets = list(integer(0)), target.index = rep(as.integer(1), nrow(data)), + nodes = colnames(data), ...) } \describe{ @@ -45,6 +48,7 @@ new("Score", specifies the index of the intervention target in \code{targets} under which the \eqn{i}-th row of \code{data} was measured.} + \item{\code{nodes}}{Node labels} \item{\code{...}}{Additional parameters used by derived (and non-virtual) classes.} } @@ -62,14 +66,19 @@ new("Score", this list contains a vector of parents.} \item{\code{global.score(dag, ...)}}{Calculates the global score of a DAG, represented as object of a class derived from \code{ParDAG}.} - \item{\code{local.mle(vertex, parents, ...)}}{Calculates the local MLE of - a vertex and its parents. The result is a vector of parameters whose + \item{\code{local.fit(vertex, parents, ...)}}{Calculates a local model fit + of a vertex and its parents, e.g. by MLE. + The result is a vector of parameters whose meaning depends on the model class; it matches the convention used in the - corresponding causal model (cf. \code{.pardag.class}).} - \item{\code{global.mle(dag, ...)}}{Calculates the global MLE of a DAG, + corresponding causal model (cf. \code{.pardag.class}). + % TODO: adjust this!! + } + \item{\code{global.fit(dag, ...)}}{Calculates the global MLE of a DAG, represented by an object of the class specified by \code{.pardag.class}. The result is a list of vectors, one per vertex, each in the same format - as the result vector of \code{local.mle}.} + as the result vector of \code{local.mle}. + % TODO: adjust this!! + } } } \details{ diff --git a/man/amatType.Rd b/man/amatType.Rd new file mode 100644 index 0000000..d4bd793 --- /dev/null +++ b/man/amatType.Rd @@ -0,0 +1,162 @@ +\name{amatType} +\title{Types and Display of Adjacency Matrices in Package 'pcalg'} +\alias{amatType} +\alias{amat.cpdag} +\alias{amat.pag} +\alias{coerce,LINGAM,amat-method}% as(, "amat") +\alias{coerce,pcAlgo,amat-method}% as(, "amat") +\alias{coerce,fciAlgo,amat-method}% as(, "amat") +%% the as(*, "matrix") methods where introduced even earlier. +\alias{coerce,pcAlgo,matrix-method} +\alias{coerce,fciAlgo,matrix-method} +%% hidden, but for us: +\alias{show.pc.amat} +\alias{show.fci.amat} +\description{ + Two types of adjacency matrices are used in package \pkg{pcalg}: Type + \code{amat.cpdag} for DAGs and CPDAGs and type \code{amat.pag} for + MAGs and PAGs. The required type of adjacency matrix is documented + in the help files of the respective functions or classes. If in some + functions more detailed information on the graph type is needed + (i.e. DAG or CPDAG; MAG or PAG) this information will be passed in a + separate argument (see e.g. \code{\link{gac}} and the examples below). + + Note that you get (\sQuote{extract}) such adjacency matrices as (S3) + objects of \code{\link{class}} \code{"amat"} via the usual + \code{\link{as}(., "")} coercion, \preformatted{ as(from, "amat") +}%pre +} +\arguments{ + \item{from}{an \R object of + + class \code{\linkS4class{pcAlgo}}, as returned from + \code{\link{skeleton}()} or \code{\link{pc}()} or an object of + + class \code{\linkS4class{fciAlgo}}, as from \code{\link{fci}()} + (or \code{\link{rfci}}, \code{\link{fciPlus}}, and + \code{\link{dag2pag}}), or an object of + + class \code{"LINGAM"} as returned from \code{\link{lingam}()}.} +} +\details{ + Adjacency matrices are integer valued square matrices with zeros on the + diagonal. They can have row- and columnnames; however, most functions + will work on the (integer) column positions in the adjacency matrix. + + \bold{Coding for type \code{amat.cpdag}:} + \describe{ + \item{\code{0}:}{No edge or tail} + \item{\code{1}:}{Arrowhead} + } + Note that the edgemark-code refers to the \emph{row} index (as opposed + adjacency matrices of type mag or pag). E.g.:\preformatted{% + amat[a,b] = 0 and amat[b,a] = 1 implies a --> b. + amat[a,b] = 1 and amat[b,a] = 0 implies a <-- b. + amat[a,b] = 0 and amat[b,a] = 0 implies a b. + amat[a,b] = 1 and amat[b,a] = 1 implies a --- b.} + + \bold{Coding for type \code{amat.pag}:} + \describe{ + \item{\code{0}:}{No edge} + \item{\code{1}:}{Circle} + \item{\code{2}:}{Arrowhead} + \item{\code{3}:}{Tail} + } + Note that the edgemark-code refers to the \emph{column} index (as + opposed adjacency matrices of type dag or cpdag). E.g.:\preformatted{% + amat[a,b] = 2 and amat[b,a] = 3 implies a --> b. + amat[a,b] = 3 and amat[b,a] = 2 implies a <-- b. + amat[a,b] = 2 and amat[b,a] = 2 implies a <-> b. + amat[a,b] = 1 and amat[b,a] = 3 implies a --o b. + amat[a,b] = 0 and amat[b,a] = 0 implies a b.} +} +\seealso{E.g. \code{\link{gac}} for a function which takes an + adjacency matrix as input; \code{\linkS4class{fciAlgo}} for a class + which has an adjacency matrix in one slot. + + \code{\link{getGraph}(x)} extracts the \code{\linkS4class{graph}} + object from \code{x}, whereas \code{as(*, "amat")} gets the + corresponding adjacency matrix. +} +\examples{ +################################################## +## Function gac() takes an adjecency matrix of +## any kind as input. In addition to that, the +## precise type of graph (DAG/CPDAG/MAG/PAG) needs +## to be passed as a different argument +################################################## +## Adjacency matrix of type 'amat.cpdag' +m1 <- matrix(c(0,1,0,1,0,0, 0,0,1,0,1,0, 0,0,0,0,0,1, + 0,0,0,0,0,0, 0,0,0,0,0,0, 0,0,0,0,0,0), 6,6) +## more detailed information on the graph type needed by gac() +gac(m1, x=1,y=3, z=NULL, type = "dag") + +## Adjacency matrix of type 'amat.cpdag' +m2 <- matrix(c(0,1,1,0,0,0, 1,0,1,1,1,0, 0,0,0,0,0,1, + 0,1,1,0,1,1, 0,1,0,1,0,1, 0,0,0,0,0,0), 6,6) +## more detailed information on the graph type needed by gac() +gac(m2, x=3, y=6, z=c(2,4), type = "cpdag") + +## Adjacency matrix of type 'amat.pag' +m3 <- matrix(c(0,2,0,0, 3,0,3,3, 0,2,0,3, 0,2,2,0), 4,4) +## more detailed information on the graph type needed by gac() +mg3 <- gac(m3, x=2, y=4, z=NULL, type = "mag") +pg3 <- gac(m3, x=2, y=4, z=NULL, type = "pag") +%% FIXME: mg3 is identical to pg3! -- need an example where 'type' matters! + +############################################################ +## as(*, "amat") returns an adjacency matrix incl. its type +############################################################ +## Load predefined data +data(gmG) +n <- nrow (gmG8$x) +V <- colnames(gmG8$x) + +## define sufficient statistics +suffStat <- list(C = cor(gmG8$x), n = n) +## estimate CPDAG +skel.fit <- skeleton(suffStat, indepTest = gaussCItest, + alpha = 0.01, labels = V) +## Extract the "amat" [and show nicely via 'print()' method]: +as(skel.fit, "amat") + +################################################## +## Function fci() returns an adjacency matrix +## of type amat.pag as one slot. +################################################## +set.seed(42) +p <- 7 +## generate and draw random DAG : +myDAG <- randomDAG(p, prob = 0.4) + +## find skeleton and PAG using the FCI algorithm +suffStat <- list(C = cov2cor(trueCov(myDAG)), n = 10^9) +res <- fci(suffStat, indepTest=gaussCItest, + alpha = 0.9999, p=p, doPdsep = FALSE) +str(res) +## get the a(djacency) mat(rix) and nicely print() it: +as(res, "amat") + +################################################## +## pcAlgo object +################################################## +## Load predefined data +data(gmG) +n <- nrow (gmG8$x) +V <- colnames(gmG8$x) + +## define sufficient statistics +suffStat <- list(C = cor(gmG8$x), n = n) +## estimate CPDAG +skel.fit <- skeleton(suffStat, indepTest = gaussCItest, + alpha = 0.01, labels = V) +## Extract Adjacency Matrix - and print (via method 'print.amat'): +as(skel.fit, "amat") + +pc.fit <- pc(suffStat, indepTest = gaussCItest, + alpha = 0.01, labels = V) +pc.fit # (using its own print() method 'print.pcAlgo') + +as(pc.fit, "amat") +} +\keyword{graphs} diff --git a/man/backdoor.Rd b/man/backdoor.Rd index 0abb609..a54b458 100644 --- a/man/backdoor.Rd +++ b/man/backdoor.Rd @@ -1,25 +1,28 @@ \name{backdoor} \alias{backdoor} -\title{Find Set Satisfying the Generalized Backdoor Criterion} +\title{Find Set Satisfying the Generalized Backdoor Criterion (GBC)} \description{ This function first checks if the total causal effect of one variable (\code{x}) onto another variable (\code{y}) is - identifiable via the generalized backdoor criterion, and if this is + identifiable via the GBC, and if this is the case it explicitly gives a set of variables that satisfies the - generalized backdoor criterion with respect to \code{x} and \code{y} + GBC with respect to \code{x} and \code{y} in the given graph. } \usage{ backdoor(amat, x, y, type = "pag", max.chordal = 10, verbose=FALSE) } \arguments{ - \item{amat}{adjacency matrix (see Details for coding) of the given - graph specified in \code{type}.} - \item{x,y}{(integer) position of variable \code{x} or \code{y} in the - adjacency matrix.} + \item{amat}{adjacency matrix of type \code{\link{amat.cpdag}} or + \code{\link{amat.pag}}.} + \item{x,y}{(integer) position of variable \eqn{X} and \eqn{Y}, + respectively, in the adjacency matrix.} \item{type}{string specifying the type of graph of the adjacency matrix - \code{amat}. It can be a DAG (type="dag"), a CPDAG (type="cpdag"), a - MAG (type="mag"), or a PAG (type="pag").} + \code{amat}. It can be a DAG (type="dag"), a CPDAG (type="cpdag"); + then the type of the adjacency matrix is assumed to be + \link{amat.cpdag}. It can also be a MAG (type="mag"), or a PAG + (type="pag"); then the type of the adjacency matrix is assumed to be + \link{amat.pag}.} \item{max.chordal}{only if \code{type = "mag"}, is used in \code{\link{pag2magAM}} to determine paths too large to be checked for chordality.} @@ -32,14 +35,14 @@ backdoor(amat, x, y, type = "pag", max.chordal = 10, verbose=FALSE) interventions and single outcome variable to more general types of graphs (CPDAGs, MAGs, and PAGs) that describe Markov equivalence classes of DAGs with and without latent variables but without - selection variables. For more details see Maathuis and Colombo (2013). + selection variables. For more details see Maathuis and Colombo (2015). - The motivation to find a set W that satisfies the generalized backdoor - criterion with respect to \code{x} and \code{y} + The motivation to find a set W that satisfies the GBC with respect to + \code{x} and \code{y} in the given graph relies on the result of the generalized backdoor adjustment: - \emph{If a set of variables W satisfies the generalized backdoor - criterion relative to \code{x} and \code{y} in the given graph, then + \emph{If a set of variables W satisfies the GBC relative to \code{x} + and \code{y} in the given graph, then the causal effect of \code{x} on \code{y} is identifiable and is given by} \deqn{% P(Y|do(X = x)) = \sum_W P(Y|X,W) \cdot P(W).}{% @@ -58,41 +61,36 @@ backdoor(amat, x, y, type = "pag", max.chordal = 10, verbose=FALSE) (\code{type="mag"}), or a PAG P (\code{type="pag"}) (with both M and P not allowing selection variables), this function first checks if the total causal effect of \code{x} on \code{y} is identifiable via the - generalized backdoor criterion (see Maathuis and Colombo, 2013). If + GBC (see Maathuis and Colombo, 2015). If the effect is not identifiable in this way, the output is - NA. Otherwise, an explicit set W that satisfies the generalized - backdoor criterion with respect to \code{x} and \code{y} in the given - graph is found. + NA. Otherwise, an explicit set W that satisfies the GBC with respect + to \code{x} and \code{y} in the given graph is found. At this moment this function is not able to work with an RFCI-PAG. It is important to note that there can be pair of nodes \code{x} and - \code{y} for which there is no set W that satisfies the generalized - backdoor criterion, but the total causal effect might be identifiable - via some other technique. - - Coding of adjacency matrix: - If \code{type = dag} or \code{type = cpdag}: coding 0/1 for no edge - or tail / arrowhead; e.g. \code{amat[a,b] = 0} and \code{amat[b,a] = - 1} implies a -> b. - Else: coding 0,1,2,3 for no edge, circle, arrowhead, tail; e.g., - \code{amat[a,b] = 2} and \code{amat[b,a] = 3} implies a -> b. + \code{y} for which there is no set W that satisfies the GBC, but the + total causal effect might be identifiable via some other technique. + + For the coding of the adjacency matrix see \link{amatType}. } \value{ Either NA if the total causal effect is not identifiable via the - generalized backdoor criterion, or a set if the effect is identifiable - via the generalized backdoor criterion. Note that if the set W is + GBC, or a set if the effect is identifiable + via the GBC. Note that if the set W is equal to the empty set, the output is NULL. } \references{ - M.H. Maathuis and D. Colombo (2013). A generalized backdoor + M.H. Maathuis and D. Colombo (2015). A generalized backdoor criterion. Annals of Statistics 43 1060-1088. J. Pearl (1993). Comment: Graphical models, causality and intervention. \emph{Statistical Science} \bold{8}, 266--269. } \author{Diego Colombo and Markus Kalisch (\email{kalisch@stat.math.ethz.ch})} -\seealso{\code{\link{pc}} for estimating a CPDAG, \code{\link{dag2pag}} +\seealso{\code{\link{gac}} for the Generalized Adjustment Criterion + (GAC), which is a generalization of GBC; \code{\link{pc}} for + estimating a CPDAG, \code{\link{dag2pag}} and \code{\link{fci}} for estimating a PAG, and \code{\link{pag2magAM}} for estimating a MAG. } @@ -109,7 +107,7 @@ myDAG <- randomDAG(p, prob = 0.2) ## true DAG true.amat <- (amat <- as(myDAG, "matrix")) != 0 # TRUE/FALSE <==> 1/0 print.table(1*true.amat, zero.=".") # "visualization" -## Compute the effect using the generalized backdoor criterion +## Compute set satisfying the GBC: backdoor(true.amat, 5, 7, type="dag") \dontshow{stopifnot(backdoor(true.amat, 5, 7, type="dag") == 3)} ##################################################################### @@ -117,9 +115,8 @@ backdoor(true.amat, 5, 7, type="dag") ##################################################################### ################################################## ## Example not identifiable -## Maathuis and Colombo (2013), Fig. 3, p.14 +## Maathuis and Colombo (2015), Fig. 3a, p.1072 ################################################## - ## create the graph p <- 5 . <- 0 @@ -149,7 +146,7 @@ backdoor(true.amat, 3, 5, type="cpdag") ################################################## ## Example identifiable -## Maathuis and Colombo (2013), Fig. 4, p.15 +## Maathuis and Colombo (2015), Fig. 3b, p.1072 ################################################## ## create the graph @@ -169,9 +166,9 @@ g <- new("graphNEL", nodes=V, edgeL=edL, edgemode="directed") ## estimate the true CPDAG myCPDAG <- dag2cpdag(g) ## Extract the adjacency matrix of the true CPDAG -true.amat <- as(myCPDAG, "matrix") != 0 # 1/0 +true.amat <- as(myCPDAG, "matrix") != 0 -## The effect is identifiable and +## The effect is identifiable and the set satisfying GBC is: backdoor(true.amat, 6, 3, type="cpdag") \dontshow{stopifnot(backdoor(true.amat, 6, 3, type="cpdag") == 1:2)} @@ -180,7 +177,7 @@ backdoor(true.amat, 6, 3, type="cpdag") ################################################################## ################################################## ## Example identifiable -## Maathuis and Colombo (2013), Fig. 7, p.17 +## Maathuis and Colombo (2015), Fig. 5a, p.1075 ################################################## ## create the graph @@ -209,10 +206,11 @@ suffStat <- list(C=true.corr, n=10^9) indepTest <- gaussCItest ## estimate the true PAG -true.pag <- dag2pag(suffStat, indepTest, g, L, alpha = 0.9999) +true.pag <- dag2pag(suffStat, indepTest, g, L, alpha = 0.9999)@amat -## The effect is identifiable and the backdoor is {1,2}: -stopifnot(backdoor(true.amat, 6, 3, type="cpdag") == 1:2) +## The effect is identifiable and the backdoor set is: +backdoor(true.pag, 3, 5, type="pag") +\dontshow{stopifnot(backdoor(true.pag, 3, 5, type="pag") == 1:2)} } \keyword{multivariate} \keyword{models} diff --git a/man/checkTriple.Rd b/man/checkTriple.Rd index 905b142..989216c 100644 --- a/man/checkTriple.Rd +++ b/man/checkTriple.Rd @@ -15,7 +15,8 @@ checkTriple(a, b, c, nbrsA, nbrsC, \arguments{ \item{a, b, c}{(integer) positions in adjacency matrix for nodes \eqn{a}, \eqn{b}, and \eqn{c}, respectively.} - \item{nbrsA, nbrsC}{neighbors of \eqn{a} and \eqn{c}, respectively.} + \item{nbrsA, nbrsC}{(integer) position in adjacency matrix for + neighbors of \eqn{a} and \eqn{c}, respectively.} \item{sepsetA}{vector containing \eqn{Sepset(a,c)}.} \item{sepsetC}{vector containing \eqn{Sepset(c,a)}.} \item{suffStat}{a \code{\link{list}} of sufficient statistics for @@ -63,9 +64,9 @@ checkTriple(a, b, c, nbrsA, nbrsC, \item{sepsetC}{Updated version of \code{sepsetC}} } \references{ - D. Colombo and M.H. Maathuis (2013). - Order-independent constraint-based causal structure learning, - (arXiv:1211.3295v2). + D. Colombo and M.H. Maathuis (2014).Order-independent constraint-based + causal structure learning. \emph{Journal of Machine Learning Research} + \bold{15} 3741-3782. } \author{ Markus Kalisch (\email{kalisch@stat.math.ethz.ch}) and Diego Colombo. diff --git a/man/condIndFisherZ.Rd b/man/condIndFisherZ.Rd index fbe283c..4fe961b 100644 --- a/man/condIndFisherZ.Rd +++ b/man/condIndFisherZ.Rd @@ -19,10 +19,10 @@ zStat (x, y, S, C, n) gaussCItest (x, y, S, suffStat) } \arguments{ - \item{x,y,S}{It is tested, whether \code{x} and \code{y} are conditionally - independent given the subset \code{S} of the remaining nodes. - \code{x, y, S} all are integers, corresponding to variable or node - numbers.} + \item{x,y,S}{(integer) position of variable \eqn{X}, \eqn{Y} and set + of variables \eqn{S}, respectively, in the adjacency matrix. It is + tested, whether \code{X} and \code{Y} are conditionally + independent given the subset \code{S} of the remaining nodes.} \item{C}{Correlation matrix of nodes} \item{n}{Integer specifying the number of observations (\dQuote{samples}) used to estimate the correlation matrix \code{C}.} diff --git a/man/corGraph.Rd b/man/corGraph.Rd index 7512833..3b1376f 100644 --- a/man/corGraph.Rd +++ b/man/corGraph.Rd @@ -2,7 +2,7 @@ \alias{corGraph} \title{Computing the correlation graph} \description{ - Computes the correlation graph. This is the graph in which an edge is + Computes the correlation graph. This is the graph in which an edge is drawn between node i and node j, if the null hypothesis \dQuote{\emph{Correlation between \eqn{X_i} and \eqn{X_j} is zero}} can be rejected at the given significance level \eqn{\alpha (alpha)}{alpha}. @@ -11,16 +11,18 @@ corGraph(dm, alpha=0.05, Cmethod="pearson") } \arguments{ - \item{dm}{Numeric matrix with rows as samples and columns as variables.} - \item{alpha}{Significance level for correlation test (numeric)} - \item{Cmethod}{A character string indicating which correlation coefficient - is to be used for the test. One of "pearson","kendall", or - "spearman", can be abbreviated. (string)} + \item{dm}{numeric matrix with rows as samples and columns as variables.} + \item{alpha}{significance level for correlation test (numeric)} + \item{Cmethod}{a \code{\link{character}} string indicating which + correlation coefficient is to be used for the test. One of + \code{"pearson"}, \code{"kendall"}, or \code{"spearman"}, can be + abbreviated.} } \value{ - Undirected correlation graph (graph object) + Undirected correlation graph, a \code{\linkS4class{graph}} object + (package \pkg{graph}); \code{\link{getGraph}} for the \dQuote{fitted} + graph. } - \author{ Markus Kalisch (\email{kalisch@stat.math.ethz.ch}) and Martin Maechler } diff --git a/man/dag2cpdag.Rd b/man/dag2cpdag.Rd index 33d2fba..5bd8eb1 100644 --- a/man/dag2cpdag.Rd +++ b/man/dag2cpdag.Rd @@ -20,6 +20,10 @@ dag2cpdag(g) v-structures of the given DAG \code{g}. Afterwards it simply uses the 3 orientation rules of the PC algorithm (see references) to orient as many of the remaining undirected edges as possible. + + The function is a simple wrapper function for \code{\link{dag2essgraph}} + which is more powerfull since it also allows the calculation of the + Markov equivalence class in the presence of interventional data. The output of this function is exactly the same as the one using \preformatted{pc(suffStat, indepTest, alpha, labels)} @@ -39,8 +43,9 @@ dag2cpdag(g) P. Spirtes, C. Glymour and R. Scheines (2000) \emph{Causation, Prediction, and Search}, 2nd edition, The MIT Press. } -\author{Markus Kalisch (\email{kalisch@stat.math.ethz.ch}) and Diego Colombo} -\seealso{\code{\link{randomDAG}}, \code{\link{pc}}} +\author{Markus Kalisch (\email{kalisch@stat.math.ethz.ch}) and + Alain Hauser(\email{alain.hauser@bfh.ch})} +\seealso{\code{\link{dag2essgraph}}, \code{\link{randomDAG}}, \code{\link{pc}}} \examples{ p <- 10 ## number of random variables s <- 0.4 ## sparseness of the graph diff --git a/man/dag2essgraph.Rd b/man/dag2essgraph.Rd index 7212f0b..019390f 100644 --- a/man/dag2essgraph.Rd +++ b/man/dag2essgraph.Rd @@ -12,8 +12,10 @@ Convert a DAG to an (interventional or observational) essential graph. dag2essgraph(dag, targets = list(integer(0))) } \arguments{ - \item{dag}{The DAG whose essential graph has to be calculated, represented as - an instance of a class derived from \code{\linkS4class{Score}}.} + \item{dag}{The DAG whose essential graph has to be calculated. Different + representations are possible: \code{dag} can be an adjacency matrix, an + object of \code{\linkS4class{graphNEL}} (package \pkg{graph}), or + an instance of a class derived from \code{\linkS4class{ParDAG}}.} \item{targets}{List of intervention targets with respect to which the essential graph has to be calculated. An observational setting is @@ -35,11 +37,18 @@ dag2essgraph(dag, targets = list(integer(0))) 2000). In a purely observational setting (\emph{i.e.}, if \code{targets = - list(integer(0))}), the function yields the same graph as \link{dag2cpdag}, - although it uses different classes for parameters and return value. + list(integer(0))}), the function yields the same graph as + \code{\link{dag2cpdag}}. } \value{ - An instance of \code{\linkS4class{EssGraph}} representing the essential graph. + Depending on the class of \code{dag}, the essential graph is returned as + \itemize{ + \item{an adjacency matrix, if \code{dag} is an adjacency matrix} + \item{an instance of \code{\linkS4class{graphNEL}}, if \code{dag} is an + instance of \code{graphNEL},} + \item{an instance of \code{\linkS4class{EssGraph}}, if \code{dag} is + an instance of a class derived from \code{\linkS4class{ParDAG}}.} + } } \references{ A. Hauser and P. Bühlmann (2012). Characterization and greedy learning of @@ -61,11 +70,19 @@ s <- 0.4 # Sparseness of the DAG ## Generate a random DAG set.seed(42) -dag <- as(randomDAG(p, s), "GaussParDAG") +require(graph) +dag <- randomDAG(p, s) +nodes(dag) <- sprintf("V\%d", 1:p) ## Calculate observational essential graph res.obs <- dag2essgraph(dag) +## Different argument classes +res2 <- dag2essgraph(as(dag, "GaussParDAG")) +str(res2) +res3 <- dag2essgraph(as(dag, "matrix")) +str(res3) + ## Calculate interventional essential graph for intervention targets ## {1} and {3} res.int <- dag2essgraph(dag, as.list(c(1, 3))) diff --git a/man/dreach.Rd b/man/dreach.Rd index 86c56f5..9cf39cf 100644 --- a/man/dreach.Rd +++ b/man/dreach.Rd @@ -10,7 +10,7 @@ ancestor of x or y in G. See p.136 of Sprirtes et al (2000) or Definition 4.1 of Maathuis and - Colombo (2013). + Colombo (2015). } \usage{ dreach(x, y, amat, verbose = FALSE) @@ -20,10 +20,7 @@ node in the adjacency matrix.} \item{y}{Second argument of D-SEP, given as the column number of the node in the adjacency matrix (\code{y} must be different from \code{x}).} - \item{amat}{Adjacency matrix (coding 0,1,2,3 for no edge, circle, - arrowhead, tail; e.g., \code{amat[a,b] = 2} and \code{amat[b,a] = 3} - implies a -> b) - } + \item{amat}{Adjacency matrix of type \link{amat.pag}.} \item{verbose}{Logical specifying details should be on output} } \value{ @@ -33,7 +30,8 @@ P. Spirtes, C. Glymour and R. Scheines (2000) \emph{Causation, Prediction, and Search}, 2nd edition, The MIT Press. - M.H. Maathuis and D. Colombo (2013). A generalized backdoor criterion. arXiv:1307.5636. + M.H. Maathuis and D. Colombo (2015). A generalized back-door + criterion. \emph{Annals of Statistics} \bold{43} 1060-1088. } \author{Diego Colombo and Markus Kalisch (\email{kalisch@stat.math.ethz.ch})} \seealso{\code{\link{backdoor}} uses this function; diff --git a/man/dsepTest.Rd b/man/dsepTest.Rd index 4afc034..2d57144 100644 --- a/man/dsepTest.Rd +++ b/man/dsepTest.Rd @@ -10,9 +10,10 @@ dsepTest(x, y, S=NULL, suffStat) } \arguments{ - \item{x,y}{integer position of variable x and y in the adjacency matrix.} - \item{S}{integer positions of conditioning variables in the adjacency matrix, - possibly empty.} + \item{x,y}{(integer) position of variable \eqn{X} and \eqn{Y}, + respectively, in the adjacency matrix.} + \item{S}{(integer) positions of zero or more conditioning variables in the + adjacency matrix.} \item{suffStat}{a \code{\link{list}} with two elements, \describe{ \item{\code{"g"}}{Containing the Directed Acyclic Graph (object of diff --git a/man/fci.Rd b/man/fci.Rd index e0c1eec..4c735b6 100644 --- a/man/fci.Rd +++ b/man/fci.Rd @@ -14,7 +14,7 @@ fci(suffStat, indepTest, alpha, labels, p, NAdelete = TRUE, m.max = Inf, pdsep.max = Inf, rules = rep(TRUE, 10), doPdsep = TRUE, biCC = FALSE, conservative = FALSE, maj.rule = FALSE, - verbose = FALSE) + numCores = 1, verbose = FALSE) } \arguments{ @@ -89,6 +89,8 @@ fci(suffStat, indepTest, alpha, labels, p, be checked for ambiguity the second time when v-structures are determined using a majority rule idea, which is less strict than the standard conservative. For more information, see details.} + \item{numCores}{Specifies the number of cores to be used for parallel + estimation of \code{\link{skeleton}}.} \item{verbose}{If true, more detailed output is provided.} } \value{An object of \code{\link{class}} \code{fciAlgo} (see @@ -148,7 +150,7 @@ fci(suffStat, indepTest, alpha, labels, p, tests of x and y given all possible subsets of Possible-D-SEP(x) and of Possible-D-SEP(y). The edge is removed if a conditional independence is found. This produces a fully order-independent final - skeleton as explained in Colombo and Maathuis (2013). Subsequently, + skeleton as explained in Colombo and Maathuis (2014). Subsequently, the v-structures are newly determined on the final skeleton (using information in sepset). Finally, as many as possible undetermined edge marks (o) are determined using (a subset of) the 10 orientation rules @@ -192,7 +194,7 @@ fci(suffStat, indepTest, alpha, labels, p, triple is not oriented as a v-structure. Furthermore, no further orientation rule that needs to know whether a-b-c is a v-structure or not is applied. Instead of using the conservative version, which is - quite strict towards the v-structures, Colombo and Maathuis (2013) + quite strict towards the v-structures, Colombo and Maathuis (2014) introduced a less strict version for the v-structures called majority rule. This adaptation can be called using \code{maj.rule = TRUE}. In this case, the triple a-b-c is marked as \sQuote{ambiguous} if and only if b @@ -200,17 +202,17 @@ fci(suffStat, indepTest, alpha, labels, p, was found. If b is in less than 50 percent of the separating sets it is set as a v-structure, and if in more than 50 percent it is set as a non v-structure (for more details see Colombo and Maathuis, - 2013). Colombo and Maathuis (2013) showed that with both these + 2014). Colombo and Maathuis (2014) showed that with both these modifications, the final skeleton and the decisions about the v-structures of the FCI algorithm are fully order-independent. Note that the order-dependence issues on the 10 orientation rules are - still present, see Colombo and Maathuis (2013) for more details. + still present, see Colombo and Maathuis (2014) for more details. } \references{ - D. Colombo and M.H. Maathuis (2013). Order-independent - constraint-based causal structure learning. arXiv preprint - arXiv:1211.3295v2. + D. Colombo and M.H. Maathuis (2014). Order-independent + constraint-based causal structure learning. Journal of Machine + Learning Research 15 3741-3782. D. Colombo, M. H. Maathuis, M. Kalisch, T. S. Richardson (2012). Learning high-dimensional directed acyclic graphs with latent @@ -241,7 +243,8 @@ fci(suffStat, indepTest, alpha, labels, p, causal discovery in the presence of latent confounders and selection bias. \emph{Artificial Intelligence} \bold{172} 1873-1896. } -\seealso{\code{\link{skeleton}} for estimating a skeleton +\seealso{\code{\link{fciPlus}} for a more efficient variation of FCI; + \code{\link{skeleton}} for estimating a skeleton using the PC algorithm; \code{\link{pc}} for estimating a CPDAG using the PC algorithm; \code{\link{pdsep}} for computing Possible-D-SEP for each node and testing and adapting the graph diff --git a/man/fciAlgo-class.Rd b/man/fciAlgo-class.Rd index 8eca752..a341b24 100644 --- a/man/fciAlgo-class.Rd +++ b/man/fciAlgo-class.Rd @@ -6,15 +6,18 @@ \alias{show,fciAlgo-method} \alias{summary,fciAlgo-method} \alias{print.fciAlgo} -\description{This class of objects is returned by the function - \code{\link{fci}} to represent the estimated PAG. +\description{This class of objects is returned by functions + \code{\link{fci}()}, \code{\link{rfci}()}, \code{\link{fciPlus}}, and + \code{\link{dag2pag}} and represent the estimated PAG (and sometimes + properties of the algorithm). Objects of this class have methods for the functions \code{\link{plot}}, \code{\link{show}} and \code{\link{summary}}. } -\section{Creation of objects}{ - Objects can be created by calls of the form \code{new("fciAlgo", - ...)}, but are typically the result of \code{\link{fci}(..)}. -} +%% Not interesting: +%% \section{Creation of objects}{ +%% Objects can be created by calls of the form \code{new("fciAlgo", +%% ...)}, but are typically the result of \code{\link{fci}(..)}. +%% } \section{Slots}{ The slots \code{call}, \code{n}, \code{max.ord}, \code{n.edgetests}, \code{sepset}, and \code{pMax} are inherited from class @@ -22,12 +25,8 @@ In addition, \code{"fciAlgo"} has slots \describe{ - \item{\code{amat}:}{a \code{\link{matrix}}: The - the estimated graph, represented by its adjacency matrix. - The edge marks are encoded - by numbers: 0 = no edge, 1 = circle, 2 = arrowhead, 3 = - tail. If \code{amat[i,j] = 1} and \code{amat[j,i] = 2}, - this represents the edge \code{i <-o j}.} + \item{\code{amat}:}{adjacency matrix; for the coding of the + adjacency matrix see \link{amatType}} \item{\code{allPdsep}}{a \code{\link{list}}: the ith entry of this list contains Possible D-SEP of node number \code{i}.} \item{\code{n.edgetestsPDSEP}}{the number of new conditional @@ -44,16 +43,19 @@ } \usage{% usage ..for methods with "surprising arguments": \S4method{show}{fciAlgo}(object) -\S3method{print}{fciAlgo}(x, zero.print = ".", \dots) +\S3method{print}{fciAlgo}(x, amat = FALSE, zero.print = ".", \dots) +\S4method{summary}{fciAlgo}(object, amat = TRUE, zero.print = ".", \dots) \S4method{plot}{fciAlgo,ANY}(x, y, main = NULL, \dots) } \arguments{ \item{x, object}{a \code{"fciAlgo"} object.} + \item{amat}{\code{\link{logical}} indicating if the adjacency matrix + should be shown (printed) as well.} \item{zero.print}{string for printing \code{0} (\sQuote{zero}) entries in the adjacency matrix.} \item{y}{(generic \code{plot()} argument; unused).} - \item{main}{main title, not yet supported.} + \item{main}{main title, not yet supported.}% <-> Rgraphviz support \item{\dots}{optional further arguments (passed from and to methods).} } \section{Methods}{ @@ -68,12 +70,16 @@ \author{Markus Kalisch and Martin Maechler} \seealso{ - \code{\link{fci}}, \code{\linkS4class{pcAlgo}} + \code{\link{fci}}, \code{\link{fciPlus}}, etc (see above); + \code{\linkS4class{pcAlgo}} } \examples{ ## look at slots of the class showClass("fciAlgo") + +## Also look at the extensive examples in ?fci , ?fciPlus, etc ! + \dontrun{ ## Suppose, fciObj is an object of class fciAlgo ## access slots by using the @ symbol @@ -81,11 +87,10 @@ fciObj@amat ## adjacency matrix fciObj@sepset ## separation sets ## use show, summary and plot method +fciObj ## same as show(fciObj) show(fciObj) summary(fciObj) plot(fciObj) -} - -## Also look at the extensive examples in ?fci ! +}%dont } \keyword{classes} diff --git a/man/fciPlus.Rd b/man/fciPlus.Rd index a4140bd..b5c68fd 100644 --- a/man/fciPlus.Rd +++ b/man/fciPlus.Rd @@ -59,18 +59,22 @@ fciPlus(suffStat, indepTest, alpha, labels, p, verbose=TRUE) ## Example without latent variables ################################################## +## generate a random DAG ( p = 7 ) set.seed(42) p <- 7 -## generate and draw random DAG : myDAG <- randomDAG(p, prob = 0.4) -## find skeleton and PAG using the FCI algorithm +## find PAG using the FCI+ algorithm on "Oracle" suffStat <- list(C = cov2cor(trueCov(myDAG)), n = 10^9) -res <- fciPlus(suffStat, indepTest=gaussCItest, - alpha = 0.9999, p=p) +m.fci <- fciPlus(suffStat, indepTest=gaussCItest, + alpha = 0.9999, p=p) +summary(m.fci) + +## require("Rgraphviz") +sfsmisc::mult.fig(2, main="True DAG // fciPlus(.) \"oracle\" estimate") +plot(myDAG) +plot(m.fci) } -% Add one or more standard keywords, see file 'KEYWORDS' in the -% R documentation directory. \keyword{multivariate} \keyword{models} \keyword{graphs} diff --git a/man/find.unsh.triple.Rd b/man/find.unsh.triple.Rd index 5ccb15b..0f47e60 100644 --- a/man/find.unsh.triple.Rd +++ b/man/find.unsh.triple.Rd @@ -10,9 +10,9 @@ find.unsh.triple(g, check=TRUE) } \arguments{ - \item{g}{adjacency matrix (\eqn{p \times p}{p * p}) of (the skeleton - of) the graph. \code{g} must be symmetric, with 0/1 entries for - presence of edges.} + \item{g}{adjacency matrix of type \link{amat.cpdag} representing the + skeleton; since a skeleton consists only of undirected edges, + \code{g} must be symmetric.} \item{check}{logical indicating that the symmetry of \code{g} should be checked.} } diff --git a/man/gac.Rd b/man/gac.Rd index b140b7c..3012ea3 100644 --- a/man/gac.Rd +++ b/man/gac.Rd @@ -12,14 +12,16 @@ gac(amat, x, y, z, type = "pag") } \arguments{ - \item{amat}{adjacency matrix (see Details for coding) of the given - graph specified in \code{type}.} + \item{amat}{adjacency matrix of type \link{amat.cpdag} or \link{amat.pag}} \item{x,y,z}{(integer) positions of variables in \code{x}, \code{y} or \code{z} in the adjacency matrix. \code{x}, \code{y} and \code{z} can be vectors representing several nodes.} \item{type}{string specifying the type of graph of the adjacency matrix - \code{amat}. It can be a DAG (type="dag"), a CPDAG (type="cpdag"), a - MAG (type="mag"), or a PAG (type="pag").} + \code{amat}. It can be a DAG (type="dag"), a CPDAG (type="cpdag"); + then the type of the adjacency matrix is assumed to be + \link{amat.cpdag}. It can also be a MAG (type="mag"), or a PAG + (type="pag"); then the type of the adjacency matrix is assumed to be + \link{amat.pag}.} } \details{ This work is a generalization of the work of Shpitser et al. (2012) @@ -29,7 +31,7 @@ gac(amat, x, y, z, type = "pag") Generalized Backdoor Criterion (GBC) of Maathuis and Colombo (2013): While GBC is sufficient but not necessary, GAC is both sufficient and necessary for DAGs, CPDAGs, MAGs and PAGs. For more details see - Perkovic et al. (2015). + Perkovic et al. (2015). The motivation to find a set \code{z} that satisfies the GAC with respect to \code{(x,y)} is the following: @@ -37,23 +39,23 @@ gac(amat, x, y, z, type = "pag") \emph{A set of variables \code{z} satisfies the GAC relative to \code{(x,y)} in the given graph, if and only if the causal effect of \code{x} on \code{y} is identifiable by - covariate adjustment and is given - by} \deqn{% - P(Y|do(X = x)) = \sum_Z P(Y|X,Z) \cdot P(Z).}{% - P(Y|do(X = x)) = sum_Z P(Y|X,Z) * P(Z).} - (for any joint distribution "compatible" with the graph; the formula + covariate adjustment and is given by} + \deqn{% + P(Y|do(X = x)) = \sum_Z P(Y|X,Z) \cdot P(Z),}{% + P(Y|do(X = x)) = sum_Z P(Y|X,Z) * P(Z),} + (for any joint distribution \dQuote{compatible} with the graph; the formula is for discrete variables with straightforward modifications for - continuous variables) + continuous variables). This result allows to write post-intervention densities (the one written using Pearl's do-calculus) using only observational densities estimated from the data. For \code{z} to satisfy the GAC relative to \code{(x,y)} and the graph, the - following three conditions must hold: + following three conditions must hold: \describe{ \item{(0)}{ The graph is adjustment amenable relative to \code{(x,y)}.} \item{(1)}{ The intersection of \code{z} and the forbidden set - (explained in Perkovic et al. (2015)) is empty.} + (explained in Perkovic et al. (2015)) is empty.} \item{(2)}{ All proper definite status non-causal paths in the graph from \code{x} to \code{y} are blocked by \code{z}.} } @@ -63,27 +65,22 @@ gac(amat, x, y, z, type = "pag") total causal effect might be identifiable via some technique other than covariate adjustment. - Coding of adjacency matrix: - If \code{type = dag} or \code{type = cpdag}: coding 0/1 for no edge - or tail / arrowhead; e.g. \code{amat[a,b] = 0} and \code{amat[b,a] = - 1} implies a -> b. - Else: coding 0,1,2,3 for no edge, circle, arrowhead, tail; e.g., - \code{amat[a,b] = 2} and \code{amat[b,a] = 3} implies a -> b. + For the coding of the adjacency matrix see \link{amatType}. } \value{ A \code{\link{list}} with three components: - \describe{ - \item{gac}{logical; TRUE if \code{z} satisfies the GAC relative to - \code{(x,y)} in the graph represented by \code{amat} and \code{type}} - \item{res}{logical vector of length three indicating if each of the three - conditions (0), (1) and (2) are true} - \item{f}{node positions of nodes in the forbidden set (see Perkovic - et al. (2015))} - } + \item{gac}{logical; TRUE if \code{z} satisfies the GAC relative to + \code{(x,y)} in the graph represented by \code{amat} and \code{type}} + \item{res}{logical vector of length three indicating if each of the three + conditions (0), (1) and (2) are true} + \item{f}{node positions of nodes in the forbidden set (see Perkovic + et al. (2015))} } \references{ E. Perkovic, J. Textor, M. Kalisch and M.H. Maathuis (2015). A - Complete Generalized Adjustment Criterion. In \emph{Proceedings of UAI 2015.} + Complete Generalized Adjustment Criterion. In \emph{Proceedings of UAI + 2015.} + \url{http://arxiv.org/abs/1507.01524}. I. Shpitser, T. VanderWeele and J.M. Robins (2012). On the validity of covariate adjustment for estimating causal effects. In @@ -92,7 +89,7 @@ gac(amat, x, y, z, type = "pag") B. van der Zander, M. Liskiewicz and J. Textor (2014). Constructing separators and adjustment sets in ancestral graphs. In \emph{Proceedings of UAI 2014.} - + M.H. Maathuis and D. Colombo (2013). A generalized backdoor criterion. \emph{Annals of Statistics} 43 1060-1088. } @@ -108,19 +105,19 @@ gac(amat, x, y, z, type = "pag") ## Example 4.1 ############################## mFig1 <- matrix(c(0,1,1,0,0,0, 1,0,1,1,1,0, 0,0,0,0,0,1, -0,1,1,0,1,1, 0,1,0,1,0,1, 0,0,0,0,0,0), 6,6) + 0,1,1,0,1,1, 0,1,0,1,0,1, 0,0,0,0,0,0), 6,6) type <- "cpdag" x <- 3; y <- 6 -## Z satisfies GAC -z <- c(2,4); gac(mFig1,x,y,z,type) -z <- c(4,5); gac(mFig1,x,y,z,type) -z <- c(4,2,1); gac(mFig1,x,y,z,type) -z <- c(4,5,1); gac(mFig1,x,y,z,type) -z <- c(4,2,5); gac(mFig1,x,y,z,type) -z <- c(4,2,5,1); gac(mFig1,x,y,z,type) -## Z does not satisfy GAC -z <- 2; gac(mFig1,x,y,z,type) -z <- NULL; gac(mFig1,x,y,z,type) +## Z satisfies GAC : +gac(mFig1, x,y, z=c(2,4), type) +gac(mFig1, x,y, z=c(4,5), type) +gac(mFig1, x,y, z=c(4,2,1), type) +gac(mFig1, x,y, z=c(4,5,1), type) +gac(mFig1, x,y, z=c(4,2,5), type) +gac(mFig1, x,y, z=c(4,2,5,1),type) +## Z does not satisfy GAC : +gac(mFig1,x,y, z=2, type) +gac(mFig1,x,y, z=NULL, type) ############################## ## Example 4.2 @@ -131,30 +128,30 @@ mFig3c <- matrix(c(0,3,0,0, 2,0,3,3, 0,2,0,3, 0,2,2,0), 4,4) type <- "pag" x <- 2; y <- 4 ## Z does not satisfy GAC -z<-NULL; gac(mFig3a,x,y,z,type) ## not amenable rel. to (X,Y) -z<-NULL; gac(mFig3b,x,y,z,type) ## not amenable rel. to (X,Y) +gac(mFig3a,x,y, z=NULL, type) ## not amenable rel. to (X,Y) +gac(mFig3b,x,y, z=NULL, type) ## not amenable rel. to (X,Y) ## Z satisfies GAC -z<-NULL; gac(mFig3c,x,y,z,type) ## amenable rel. to (X,Y) +gac(mFig3c,x,y, z=NULL, type) ## amenable rel. to (X,Y) ############################## ## Example 4.3 ############################## mFig4a <- matrix(c(0,0,1,0,0,0, 0,0,1,0,0,0, 2,2,0,3,3,2, -0,0,2,0,2,2, 0,0,2,1,0,2, 0,0,1,3,3,0), 6,6) + 0,0,2,0,2,2, 0,0,2,1,0,2, 0,0,1,3,3,0), 6,6) mFig4b <- matrix(c(0,0,1,0,0,0, 0,0,1,0,0,0, 2,2,0,0,3,2, -0,0,0,0,2,2, 0,0,2,3,0,2, 0,0,2,3,2,0), 6,6) + 0,0,0,0,2,2, 0,0,2,3,0,2, 0,0,2,3,2,0), 6,6) type <- "pag" x <- 3; y <- 4 ## both PAGs are amenable rel. to (X,Y) ## Z satisfies GAC in Fig. 4a -z<-6; gac(mFig4a,x,y,z,type) -z<-c(1,6); gac(mFig4a,x,y,z,type) -z<-c(2,6); gac(mFig4a,x,y,z,type) -z<-c(1,2,6); gac(mFig4a,x,y,z,type) +gac(mFig4a,x,y, z=6, type) +gac(mFig4a,x,y, z=c(1,6), type) +gac(mFig4a,x,y, z=c(2,6), type) +gac(mFig4a,x,y, z=c(1,2,6), type) ## no Z satisfies GAC in Fig. 4b -z<-NULL; gac(mFig4b,x,y,z,type) -z<-6; gac(mFig4b,x,y,z,type) -z<-c(5,6); gac(mFig4b,x,y,z,type) +gac(mFig4b,x,y, z=NULL, type) +gac(mFig4b,x,y, z=6, type) +gac(mFig4b,x,y, z=c(5,6), type) ############################## ## Example 4.4 @@ -163,21 +160,21 @@ mFig5a <- matrix(c(0,1,0,0,0, 1,0,1,0,0, 0,0,0,0,1, 0,0,1,0,0, 0,0,0,0,0), 5,5) type <- "cpdag" x <- c(1,5); y <- 4 ## Z satisfies GAC -z <- c(2,3);gac(mFig5a,x,y,z,type) +gac(mFig5a,x,y, z=c(2,3), type) ## Z does not satisfy GAC -z <- 2;gac(mFig5a,x,y,z,type) +gac(mFig5a,x,y, z=2, type) mFig5b <- matrix(c(0,1,0,0,0,0,0, 2,0,2,3,0,3,0, 0,1,0,0,0,0,0, 0,2,0,0,3,0,0, 0,0,0,2,0,2,3, 0,2,0,0,2,0,0, 0,0,0,0,2,0,0), 7,7) type <- "pag" x<-c(2,7); y<-6 ## Z satisfies GAC -z<-c(4,5); gac(mFig5b,x,y,z,type) -z<-c(4,5,1); gac(mFig5b,x,y,z,type) -z<-c(4,5,3); gac(mFig5b,x,y,z,type) -z<-c(1,3,4,5); gac(mFig5b,x,y,z,type) +gac(mFig5b,x,y, z=c(4,5), type) +gac(mFig5b,x,y, z=c(4,5,1), type) +gac(mFig5b,x,y, z=c(4,5,3), type) +gac(mFig5b,x,y, z=c(1,3,4,5), type) ## Z does not satisfy GAC -z<-NULL; gac(mFig5b,x,y,z,type) +gac(mFig5b,x,y, z=NULL, type) } \keyword{multivariate} \keyword{models} diff --git a/man/gds.Rd b/man/gds.Rd index 6950673..e0ab39c 100644 --- a/man/gds.Rd +++ b/man/gds.Rd @@ -12,14 +12,42 @@ \code{\link{gies}} or \code{\link{ges}} the preference over \code{gds}. } \usage{ -gds(p, targets, score, verbose = FALSE, ...) +gds(score, labels = score$getNodes(), targets = score$getTargets(), + fixedGaps = NULL, phase = c("forward", "backward", "turning"), + iterate = length(phase) > 1, turning = TRUE, maxDegree = integer(0), + verbose = FALSE, ...) } \arguments{ - \item{p}{number of variables.} - \item{targets}{a \code{\link{list}} of intervention targets + \item{score}{An instance of a class derived from \code{\linkS4class{Score}}.} + \item{labels}{Node labels; by default, they are determined from the scoring + object.} + \item{targets}{A \code{\link{list}} of intervention targets (cf. details). A list of vectors, each vector listing the vertices of one intervention target.} - \item{score}{an instance of a class derived from \code{\linkS4class{Score}}.} + \item{fixedGaps}{Logical \emph{symmetric} matrix of dimension p*p. If entry + \code{[i, j]} is \code{TRUE}, the result is guaranteed to have no edge + between nodes \eqn{i} and \eqn{j}.} + \item{phase}{Character vector listing the phases that should be used; possible + values: \code{forward}, \code{backward}, and \code{turning} (cf. details).} + \item{iterate}{Logical indicating whether the phases listed in the argument + \code{phase} should be iterated more than once (\code{iterate = TRUE}) or + not.} + \item{turning}{Setting \code{turning = TRUE} is equivalent to setting + \code{phases = c("forward", "backward")} and \code{iterate = FALSE}; the + use of the argument \code{turning} is deprecated.} + \item{maxDegree}{Parameter used to limit the vertex degree of the estimated + graph. Valid arguments: + \enumerate{ + \item Vector of length 0 (default): vertex degree is not limited. + \item Real number \eqn{r}, \eqn{0 < r < 1}: degree of vertex \eqn{v} is + limited to \eqn{r \cdot n_v}, where \eqn{n_v} denotes the number of + data points where \eqn{v} was not intervened. + \item Single integer: uniform bound of vertex degree for all vertices + of the graph. + \item Integer vector of length \code{p}: vector of individual bounds + for the vertex degrees. + } + } \item{verbose}{if \code{TRUE}, detailed output is provided.} \item{\dots}{additional arguments for debugging purposes and fine tuning.} %% those in getClass("EssGraph")@refMethods$causal.inf.options @@ -62,9 +90,11 @@ gds(p, targets, score, verbose = FALSE, ...) \item{Turning phase}{In the turning phase, the algorithm reverts arrows of the DAG as long as this augments the score.} } - GIES cycles through these three phases until no augmentation of the score is - possible any more. In the end, \code{gds} returns the (interventional or - observational) essential graph of the last visited DAG. + The phases that are actually run are specified with the argument + \code{phase}. GDS cycles through the specified phases until no augmentation + of the score is possible any more if \code{iterate = TRUE}. In the end, + \code{gds} returns the (interventional or observational) essential graph of + the last visited DAG. It is well-known that a greedy search in the space of DAGs instead of essential graphs is more prone to be stuck in local optima of the score @@ -105,7 +135,7 @@ data(gmInt) score <- new("GaussL0penIntScore", gmInt$x, gmInt$targets, gmInt$target.index) ## Estimate the essential graph -gds.fit <- gds(ncol(gmInt$x), gmInt$targets, score) +gds.fit <- gds(score) ## Plot the estimated essential graph and the true DAG if (require(Rgraphviz)) { diff --git a/man/ges.Rd b/man/ges.Rd index 444a15a..fd7fb7b 100644 --- a/man/ges.Rd +++ b/man/ges.Rd @@ -11,18 +11,29 @@ algorithm of Chickering (2002). } \usage{ -ges(p, score, fixedGaps = NULL, +ges(score, labels = score$getNodes(), + fixedGaps = NULL, adaptive = c("none", "vstructures", "triples"), + phase = c("forward", "backward", "turning"), iterate = length(phase) > 1, turning = TRUE, maxDegree = integer(0), verbose = FALSE, ...) } \arguments{ - \item{p}{Number of variables.} \item{score}{An instance of a class derived from \code{\linkS4class{Score}} which only accounts for observational data.} + \item{labels}{Node labels; by default, they are determined from the scoring + object.} \item{fixedGaps}{logical \emph{symmetric} matrix of dimension p*p. If entry \code{[i, j]} is \code{TRUE}, the result is guaranteed to have no edge between nodes \eqn{i} and \eqn{j}.} - \item{turning}{Logical indicating whether the function should try to augment - the score by turning edges (cf. details).} + \item{adaptive}{indicating whether constraints should be adapted to + newly detected v-structures or unshielded triples (cf. details).} + \item{phase}{Character vector listing the phases that should be used; possible + values: \code{forward}, \code{backward}, and \code{turning} (cf. details).} + \item{iterate}{Logical indicating whether the phases listed in the argument + \code{phase} should be iterated more than once (\code{iterate = TRUE}) or + not.} + \item{turning}{Setting \code{turning = TRUE} is equivalent to setting + \code{phases = c("forward", "backward")} and \code{iterate = FALSE}; the + use of the argument \code{turning} is deprecated.} \item{maxDegree}{Parameter used to limit the vertex degree of the estimated graph. Valid arguments: \enumerate{ @@ -36,7 +47,7 @@ ges(p, score, fixedGaps = NULL, for the vertex degrees. } } - \item{verbose}{if \code{TRUE}, detailed output is provided.} + \item{verbose}{If \code{TRUE}, detailed output is provided.} \item{\dots}{Additional arguments for debugging purposes and fine tuning.} } \details{ @@ -86,10 +97,12 @@ ges(p, score, fixedGaps = NULL, until the score cannot be augmented any more.} } GES cycles through these three phases until no augmentation of the score is - possible any more. Note that the turning phase (activated with - \code{turning = TRUE}, the default behaviour) was not part of the original - implementation of Chickering (2002), but was introduced by Hauser and - Bühlmann (2012) and shown to improve the overall estimation performance. + possible any more if \code{iterate = TRUE}. Note that the turning phase + was not part of the original implementation of Chickering (2002), but was + introduced by Hauser and Bühlmann (2012) and shown to improve the overall + estimation performance. The original algorithm of Chickering (2002) is + reproduced with \code{phase = c("forward", "backward")} and + \code{iterate = FALSE}. GES has the same purpose as the PC algorithm (see \code{\link{pc}}). While the PC algorithm is based on conditional independence tests (requiring the @@ -98,6 +111,37 @@ ges(p, score, fixedGaps = NULL, choice of a score function) and does not depend on conditional independence tests. Since GES always operates in the space of essential graphs, it returns a valid essential graph (or CPDAG) in any case. + + Using the argument \code{fixedGaps}, one can make sure that certain edges + will \emph{not} be present in the resulting essential graph: if the entry + \code{[i, j]} of the matrix passed to \code{fixedGaps} is \code{TRUE}, there + will be no edge between nodes \eqn{i} and \eqn{j}. Using this argument + can speed up the execution of GIES and allows the user to account for + previous knowledge or other constraints. The argument \code{adaptive} can be + used to relax the constraints encoded by \code{fixedGaps} according to a + modification of GES called ARGES (adaptively restricted greedy + equivalence search) which has been presented in Nandy, Hauser and Maathuis + (2015): + \itemize{ + \item When \code{adaptive = "vstructures"} and the algorithm introduces a + new v-structure \eqn{a \longrightarrow b \longleftarrow c}{a → b ← c} in the + forward phase, then the edge \eqn{a - c} is removed from the list of fixed + gaps, meaning that the insertion of an edge between \eqn{a} and \eqn{c} + becomes possible even if it was forbidden by the initial matrix passed to + \code{fixedGaps}. + + \item When \code{adaptive = "triples"} and the algorithm introduces a new + unshielded triple in the forward phase (i.e., a subgraph of three nodes + \eqn{a}, \eqn{b} and \eqn{c} where \eqn{a} and \eqn{b} as well as \eqn{b} + and \eqn{c} are adjacent, but \eqn{a} and \eqn{c} are not), then the edge + \eqn{a - c} is removed from the list of fixed gaps. + } + With one of the adaptive modifications, the successive application of a + skeleton estimation method and GES restricted to an estimated skeleton still + gives a \emph{consistent} estimator of the DAG, which is not the case without + the adaptive modification. + % TODO: Adjust this last paragraph and write a note about the difference + % between ARGES and ARGES-skeleton. } \value{ \code{ges} returns a list with the following two components: @@ -114,6 +158,9 @@ ges(p, score, fixedGaps = NULL, interventional Markov equivalence classes of directed acyclic graphs. \emph{Journal of Machine Learning Research} \bold{13}, 2409--2464. + P. Nandy, A. Hauser and M. Maathuis (2015). Understanding consistency in + hybrid causal structure learning. \emph{arXiv preprint} 1507.02608 + P. Spirtes, C.N. Glymour, and R. Scheines (2000). \emph{Causation, Prediction, and Search}, MIT Press, Cambridge (MA). } @@ -131,7 +178,7 @@ data(gmG) score <- new("GaussL0penObsScore", gmG8$x) ## Estimate the essential graph -ges.fit <- ges(ncol(gmG8$x), score) +ges.fit <- ges(score) ## Plot the estimated essential graph and the true DAG if (require(Rgraphviz)) { diff --git a/man/gies.Rd b/man/gies.Rd index 29c1c21..e8a0ee9 100644 --- a/man/gies.Rd +++ b/man/gies.Rd @@ -10,24 +10,35 @@ (GIES) algorithm of Hauser and Bühlmann (2012). } \usage{ -gies(p, targets, score, fixedGaps = NULL, +gies(score, labels = score$getNodes(), targets = score$getTargets(), + fixedGaps = NULL, adaptive = c("none", "vstructures", "triples"), + phase = c("forward", "backward", "turning"), iterate = length(phase) > 1, turning = TRUE, maxDegree = integer(0), verbose = FALSE, ...) } \arguments{ - \item{p}{Number of variables.} + \item{score}{An \R object inheriting from \code{\linkS4class{Score}}.} + \item{labels}{Node labels; by default, they are determined from the scoring + object.} \item{targets}{A list of intervention targets (cf. details). A list of vectors, each vector listing the vertices of one intervention target.} - \item{score}{An instance of a class derived from \code{\linkS4class{Score}}.} - \item{fixedGaps}{logical \emph{symmetric} matrix of dimension p*p. If entry + \item{fixedGaps}{Logical \emph{symmetric} matrix of dimension p*p. If entry \code{[i, j]} is \code{TRUE}, the result is guaranteed to have no edge between nodes \eqn{i} and \eqn{j}.} - \item{turning}{Logical indicating whether the function should try to augment - the score by turning edges (cf. details).} + \item{adaptive}{indicating whether constraints should be adapted to + newly detected v-structures or unshielded triples (cf. details).} + \item{phase}{Character vector listing the phases that should be used; possible + values: \code{forward}, \code{backward}, and \code{turning} (cf. details).} + \item{iterate}{Logical indicating whether the phases listed in the argument + \code{phase} should be iterated more than once (\code{iterate = TRUE}) or + not.} + \item{turning}{Setting \code{turning = TRUE} is equivalent to setting + \code{phases = c("forward", "backward")} and \code{iterate = FALSE}; the + use of the argument \code{turning} is deprecated.} \item{maxDegree}{Parameter used to limit the vertex degree of the estimated graph. Possible values: \enumerate{ \item Vector of length 0 (default): vertex degree is not limited. - \item Real number \eqn{r}, \eqn{0 < r < 1}: degree of vertex \eqn{v} is + \item Real number \eqn{r}, \eqn{0 < r < 1}: degree of vertex \eqn{v} is limited to \eqn{r \cdot n_v}{r . n_v}, where \eqn{n_v} denotes the number of data points where \eqn{v} was not intervened. \item Single integer: uniform bound of vertex degree for all vertices @@ -36,7 +47,7 @@ gies(p, targets, score, fixedGaps = NULL, for the vertex degrees. } } - \item{verbose}{if \code{TRUE}, detailed output is provided.} + \item{verbose}{If \code{TRUE}, detailed output is provided.} \item{\dots}{Additional arguments for debugging purposes and fine tuning.} } \details{ @@ -48,48 +59,77 @@ gies(p, targets, score, fixedGaps = NULL, data is specified by an empty set, i.e. a vector of the form \code{integer(0)}. As an example, if data contains observational samples as well as samples originating from an intervention at vertices 1 and 4, - the intervention targets must be specified as \code{list(integer(0), - as.integer(1), as.integer(c(1, 4)))}. - + the intervention targets must be specified as \code{list(integer(0), + as.integer(1), as.integer(c(1, 4)))}. + An interventional Markov equivalence class of DAGs can be uniquely - represented by a partially directed graph called interventional essential + represented by a partially directed graph called interventional essential graph. Its edges have the following interpretation: \enumerate{ \item a directed edge \eqn{a \longrightarrow b}{a → b} stands for an arrow - that has the same orientation in all representatives of the + that has the same orientation in all representatives of the interventional Markov equivalence class; - \item an undirected edge \eqn{a} -- \eqn{b} stands for an arrow that is - oriented in one way in some representatives of the equivalence class and + \item an undirected edge \eqn{a} -- \eqn{b} stands for an arrow that is + oriented in one way in some representatives of the equivalence class and in the other way in other representatives of the equivalence class. } - Note that when plotting the object, undirected and bidirected edges are + Note that when plotting the object, undirected and bidirected edges are equivalent. - - GIES (greedy interventional equivalence search) is a score-based algorithm - that greedily maximizes a score function (typically the BIC, passed to the - function via the argument \code{score}) in the space of interventional + + GIES (greedy interventional equivalence search) is a score-based algorithm + that greedily maximizes a score function (typically the BIC, passed to the + function via the argument \code{score}) in the space of interventional essential graphs in three phases, starting from the empty graph: \describe{ \item{Forward phase}{In the forward phase, GIES moves through the space of - interventional essential graphs in steps that correspond to the addition - of a single edge in the space of DAGs; the phase is aborted as soon as + interventional essential graphs in steps that correspond to the addition + of a single edge in the space of DAGs; the phase is aborted as soon as the score cannot be augmented any more.} \item{Backward phase}{In the backward phase, the algorithm performs moves - that correspond to the removal of a single edge in the space of DAGs + that correspond to the removal of a single edge in the space of DAGs until the score cannot be augmented any more.} - \item{Turning phase}{In the turning phase, the algorithm performs moves - that correspond to the reversal of a single arrow in the space of DAGs + \item{Turning phase}{In the turning phase, the algorithm performs moves + that correspond to the reversal of a single arrow in the space of DAGs until the score cannot be augmented any more.} } - GIES cycles through these three phases until no augmentation of the score is - possible any more. GIES is an interventional extension of the GES (greedy - equivalence search) algorithm of Chickering (2002) which is limited to - observational data and hence operates on the space of observational instead - of interventional Markov equivalence classes. + The phases that are actually run are specified with the argument + \code{phase}. GIES cycles through the specified phases until no augmentation + of the score is possible any more if \code{iterate = TRUE}. GIES is an + interventional extension of the GES (greedy equivalence search) algorithm of + Chickering (2002) which is limited to observational data and hence operates + on the space of observational instead of interventional Markov equivalence + classes. + + Using the argument \code{fixedGaps}, one can make sure that certain edges + will \emph{not} be present in the resulting essential graph: if the entry + \code{[i, j]} of the matrix passed to \code{fixedGaps} is \code{TRUE}, there + will be no edge between nodes \eqn{i} and \eqn{j}. Using this argument + can speed up the execution of GIES and allows the user to account for + previous knowledge or other constraints. The argument \code{adaptive} can be + used to relax the constraints encoded by \code{fixedGaps} as follows: + \itemize{ + \item When \code{adaptive = "vstructures"} and the algorithm introduces a + new v-structure \eqn{a \longrightarrow b \longleftarrow c}{a → b ← c} in the + forward phase, then the edge \eqn{a - c} is removed from the list of fixed + gaps, meaning that the insertion of an edge between \eqn{a} and \eqn{c} + becomes possible even if it was forbidden by the initial matrix passed to + \code{fixedGaps}. + + \item When \code{adaptive = "triples"} and the algorithm introduces a new + unshielded triple in the forward phase (i.e., a subgraph of three nodes + \eqn{a}, \eqn{b} and \eqn{c} where \eqn{a} and \eqn{b} as well as \eqn{b} + and \eqn{c} are adjacent, but \eqn{a} and \eqn{c} are not), then the edge + \eqn{a - c} is removed from the list of fixed gaps. + } + This modifications of the forward phase of GIES are inspired by the + analog modifications in the forward phase of GES, which makes the successive + application of a skeleton estimation method and GES restricted to an + estimated skeleton a \emph{consistent} estimator of the DAG (cf. Nandy, + Hauser and Maathuis, 2015). } \value{ \code{gies} returns a list with the following two components: - \item{essgraph}{An object of class \code{\linkS4class{EssGraph}} containing an + \item{essgraph}{An object of class \code{\linkS4class{EssGraph}} containing an estimate of the equivalence class of the underlying DAG.} \item{repr}{An object of a class derived from \code{\linkS4class{ParDAG}} containing a (random) representative of the estimated equivalence class.} @@ -97,10 +137,13 @@ gies(p, targets, score, fixedGaps = NULL, \references{ D.M. Chickering (2002). Optimal structure identification with greedy search. \emph{Journal of Machine Learning Research} \bold{3}, 507--554 - - A. Hauser and P. Bühlmann (2012). Characterization and greedy learning of + + A. Hauser and P. Bühlmann (2012). Characterization and greedy learning of interventional Markov equivalence classes of directed acyclic graphs. \emph{Journal of Machine Learning Research} \bold{13}, 2409--2464. + + P. Nandy, A. Hauser and M. Maathuis (2015). Understanding consistency in + hybrid causal structure learning. \emph{arXiv preprint} 1507.02608 } \author{ Alain Hauser (\email{alain.hauser@bfh.ch}) @@ -113,10 +156,10 @@ gies(p, targets, score, fixedGaps = NULL, data(gmInt) ## Define the score (BIC) -score <- new("GaussL0penIntScore", gmInt$x, gmInt$targets, gmInt$target.index) +score <- new("GaussL0penIntScore", gmInt$x, gmInt$targets, gmInt$target.index) ## Estimate the essential graph -gies.fit <- gies(ncol(gmInt$x), gmInt$targets, score) +gies.fit <- gies(score) ## Plot the estimated essential graph and the true DAG if (require(Rgraphviz)) { diff --git a/man/ida.Rd b/man/ida.Rd index 147043c..09b9263 100644 --- a/man/ida.Rd +++ b/man/ida.Rd @@ -35,8 +35,8 @@ causalEffect(g, y, x) \code{y} is assumed to be of the form \code{x->y}.} \item{verbose}{If TRUE, details on the regressions are printed.} \item{all.dags}{All DAGs in the equivalence class of the - CPDAG can be precomputed by \code{\link{allDags}()} and passed via - this argument. In that case, \code{\link{allDags}(..)} is not called + CPDAG can be precomputed by \code{\link{pdag2allDags}()} and passed via + this argument. In that case, \code{\link{pdag2allDags}(..)} is not called internally. This option is only relevant when using \code{method="global"}.} \item{g}{Graph in which the causal effect is sought.} @@ -82,7 +82,7 @@ causalEffect(g, y, x) If \code{method="global"}, the method as described above is carried out, where all DAGs in the equivalene class of the estimated CPDAG - \code{graphEst} are computed using the function \code{\link{allDags}}. + \code{graphEst} are computed using the function \code{\link{pdag2allDags}}. This method is suitable for small graphs (say, up to 10 nodes). If \code{method="local"}, we do not determine all DAGs in the @@ -140,8 +140,10 @@ causalEffect(g, y, x) } \author{Markus Kalisch (\email{kalisch@stat.math.ethz.ch})} \seealso{ - \code{\link{idaFast}} for estimating the multiset of possible total - causal effects for several target variables simultaneously. + \code{\link{jointIda}} for estimating the multiset of possible total + \emph{joint} effects; \code{\link{idaFast}} for estimating the multiset of + possible total causal effects for several target variables + simultaneously. \code{\link{pc}} for estimating a CPDAG. } diff --git a/man/idaFast.Rd b/man/idaFast.Rd index 7636036..517bc91 100644 --- a/man/idaFast.Rd +++ b/man/idaFast.Rd @@ -14,7 +14,7 @@ idaFast(x.pos, y.pos.set, mcov, graphEst) } \arguments{ -\item{x.pos}{integer position of variable \code{x} in the covariance matrix.} +\item{x.pos}{(integer) position of variable \code{x} in the covariance matrix.} \item{y.pos.set}{integer vector of positions of the target variables \code{y} in the covariance matrix.} \item{mcov}{covariance matrix that was used to estimate \code{graphEst}} @@ -81,7 +81,7 @@ if(require(Rgraphviz)) { ## by using idaFast : (eff.estF <- idaFast(2, c(5,6,7), cov.d, pc.fit@graph)) \dontshow{ -stopifnot(all.equal(eff.estF, tol = 1e-15, +stopifnot(all.equal(eff.estF, tolerance = 1e-15, rbind("5"= eff.est1, "6"= eff.est2, "7"= eff.est3)) , all.equal(idaFast(2, c(7,5), covTrue, myCPDAG), rbind("7"= ida(2, 7, covTrue, myCPDAG), diff --git a/man/jointIda.Rd b/man/jointIda.Rd index 88e4c04..58af9ee 100644 --- a/man/jointIda.Rd +++ b/man/jointIda.Rd @@ -76,7 +76,7 @@ jointIda(x.pos, y.pos, mcov, graphEst = NULL, all.pasets = NULL, vector of possible joint causal effects. } \references{ - [1] P. Nandy, M.H. Maathuis and T.S. Richardson (2014, 2015). + P. Nandy, M.H. Maathuis and T.S. Richardson (2014, 2015). Estimating the effect of joint interventions from observational data in sparse high-dimensional settings. \url{http://arxiv.org/abs/1407.2451}. diff --git a/man/legal.path.Rd b/man/legal.path.Rd index f10eed5..525207c 100644 --- a/man/legal.path.Rd +++ b/man/legal.path.Rd @@ -11,7 +11,7 @@ legal.path(a, b, c, amat) } \arguments{ - \item{a,b,c}{Integer positions in adjacency matrix of nodes \eqn{a}, + \item{a,b,c}{(integer) positions in adjacency matrix of nodes \eqn{a}, \eqn{b}, and \eqn{c}, respectively.} \item{amat}{Adjacency matrix (coding 0,1,2,3 for no edge, circle, arrowhead, tail; e.g., \code{amat[a,b] = 2} and \code{amat[b,a] = 3} diff --git a/man/mat2targets.Rd b/man/mat2targets.Rd index 2c9a8dd..4a81af9 100644 --- a/man/mat2targets.Rd +++ b/man/mat2targets.Rd @@ -1,25 +1,44 @@ \name{mat2targets} \alias{mat2targets} +\alias{targets2mat} \encoding{UTF-8} \concept{intervention} \concept{interventional data} -\title{Construct a list of intervention targets and a target index vector} +\title{Conversion between an intervention matrix and a list of intervention + targets} \description{ - This function constructs a list of intervention targets and a corresponding - vector of target indices from a matrix specifying intervened vertices. The - input matrix has the same dimensions as the usual data matrix; the output - can be used to create scoring objects (see \code{\linkS4class{Score}}) and - to run causal inference methods based on interventional data such as - \code{\link{gies}} or \code{\link{simy}}. + In a data set with \eqn{n} measurements of \eqn{p} variables, intervened + variables can be specified in two ways: + \itemize{ + \item with a \code{\link{logical}} intervention matrix of dimension + \eqn{n \times p}{n × p}, where the entry \code{[i, j]} indicates whether + variable \eqn{j} has been intervened in measurement \eqn{i}; or + + \item with a list of (unique) intervention targets and a + \eqn{p}-dimensional vector indicating the indices of the intervention + targets of the \eqn{p} measurements. + } + + The function \code{mat2targets} converts the first representation to the + second one, the function \code{targets2mat} does the reverse conversion. The + second representation can be used to create scoring objects (see + \code{\linkS4class{Score}}) and to run causal inference methods based on + interventional data such as \code{\link{gies}} or \code{\link{simy}}. } \usage{ mat2targets(A) +targets2mat(p, targets, target.index) } \arguments{ \item{A}{Logical matrix with \eqn{n} rows and \eqn{p} columns, where \eqn{n} is the sample size of a data set with jointly interventional and observational data, and \eqn{p} is the number of variables. \code{A[i, j]} is \code{TRUE} iff variable \code{j} is intervened in data point \code{i}.} + \item{p}{Number of variables} + \item{targets}{List of unique intervention targets} + \item{target.index}{Vector of intervention target indices. The intervention + target of data point \code{i} is encoded as + \code{targets[[target.index[i]]]}.} } \value{ \code{mat2targets} returns a list with two components: @@ -47,6 +66,9 @@ target.list <- mat2targets(A) for (i in 1:length(target.list$target.index)) sprintf("Intervention target of \%d-th data point: \%d", i, target.list$targets[[target.list$target.index[i]]]) + +## Convert back to matrix representation +all(A == targets2mat(p, target.list$targets, target.list$target.index)) } \keyword{manip} \keyword{list} diff --git a/man/pag2mag.Rd b/man/pag2mag.Rd index 5c9bf57..1ffe880 100644 --- a/man/pag2mag.Rd +++ b/man/pag2mag.Rd @@ -10,10 +10,8 @@ pag2magAM(amat.pag, x, max.chordal = 10, verbose = FALSE) } \arguments{ - \item{amat.pag}{Adjacency matrix (coding 0,1,2,3 for no edge, circle, - arrowhead, tail; e.g., \code{amat[a,b] = 2} and \code{amat[b,a] = 3} - implies a -> b)} - \item{x}{Node in the PAG into which no additional edges are oriented.} + \item{amat.pag}{Adjacency matrix of type \link{amat.pag}} + \item{x}{(integer) position in adjacency matrix of node in the PAG into which no additional edges are oriented.} \item{max.chordal}{Positive integer: graph paths larger than \code{max.chordal} are considered to be too large to be checked for chordality.} @@ -32,16 +30,16 @@ pag2magAM(amat.pag, x, max.chordal = 10, verbose = FALSE) This function is used in the Generalized Backdoor Criterion \code{\link{backdoor}} with \code{type="pag"}, see Maathuis and Colombo - (2013) for details. + (2015) for details. } \value{ - The output is an adjacency matrix M of a valid MAG with edge - marks. The edge marks are coded in the following way: M[i,j]=M[j,i]=0: - no edge; M[i,j]=2, M[j,i]=3: i -> j; M[i,j]=2, M[j,i]=2: i <-> j. + The output is an adjacency matrix of type \link{amat.pag} representing + a valid MAG that belongs to the Markov equivalence class + represented by the given PAG. } \references{ - M.H. Maathuis and D. Colombo (2013). A generalized backdoor - criterion. arXiv preprint arXiv:1307.5636. + M.H. Maathuis and D. Colombo (2015). A generalized back-door + criterion. \emph{Annals of Statistics} \bold{43} 1060-1088. Zhang, J. (2006). Causal Inference and Reasoning in Causally Insufficient Systems. Ph. D. thesis, Carnegie Mellon University. diff --git a/man/pc.Rd b/man/pc.Rd index d228734..4e97475 100644 --- a/man/pc.Rd +++ b/man/pc.Rd @@ -10,7 +10,8 @@ pc(suffStat, indepTest, alpha, labels, p, fixedGaps = NULL, fixedEdges = NULL, NAdelete = TRUE, m.max = Inf, u2pd = c("relaxed", "rand", "retry"), skel.method = c("stable", "original", "stable.fast"), - conservative = FALSE, maj.rule = FALSE, solve.confl = FALSE, verbose = FALSE) + conservative = FALSE, maj.rule = FALSE, solve.confl = FALSE, + numCores = 1, verbose = FALSE) } \arguments{ \item{suffStat}{A \code{\link{list}} of sufficient statistics, @@ -21,7 +22,7 @@ pc(suffStat, indepTest, alpha, labels, p, \code{indepTest(x,y,S,suffStat)}, and tests conditional independence of \code{x} and \code{y} given \code{S}. Here, \code{x} and \code{y} are variables, and \code{S} is a (possibly empty) vector of - variables (all variables are denoted by their column numbers + variables (all variables are denoted by their (integer) column positions in the adjacency matrix). \code{suffStat} is a list, see the argument above. The return value of \code{indepTest} is the p-value of the test for conditional independence.} @@ -32,6 +33,8 @@ pc(suffStat, indepTest, alpha, labels, p, \item{p}{(optional) number of variables (or nodes). May be specified if \code{labels} are not, in which case \code{labels} is set to \code{1:p}.} + \item{numCores}{Specifies the number of cores to be used for parallel + estimation of \code{\link{skeleton}}.} \item{verbose}{If \code{TRUE}, detailed output is provided.} \item{fixedGaps}{A logical matrix of dimension p*p. If entry \code{[i,j]} or \code{[j,i]} (or both) are TRUE, the edge i-j is @@ -94,18 +97,20 @@ pc(suffStat, indepTest, alpha, labels, p, interpretation: (i) there is a (directed or undirected) edge between i and j if and only if variables i and j are conditionally dependent given S for all possible subsets S of the remaining nodes; (ii) a directed - edge i->j means that this directed edge is present in all DAGs in the - Markov equivalence class; (iii) an undirected edge i-j means that - there is at least one DAG in the Markov equivalence class with edge i->j and - there is at least one DAG in the Markov equivalence class with edge i<-j. + edge \eqn{i \longrightarrow j}{i → j} means that this directed edge is + present in all DAGs in the Markov equivalence class; (iii) an undirected + edge \eqn{i - j} means that there is at least one DAG in the Markov + equivalence class with edge \eqn{i \longrightarrow j}{i → j} and + there is at least one DAG in the Markov equivalence class with edge + \eqn{i \longleftarrow j}{i ← j}. The CPDAG is estimated using the PC algorithm (named after its inventors \bold{P}eter Spirtes and \bold{C}lark Glymour). The skeleton is estimated by the function \code{\link{skeleton}} which uses a modified - version of the original PC algorithm (see Colombo and Maathuis (2013) for + version of the original PC algorithm (see Colombo and Maathuis (2014) for details). The original PC algorithm is known to be order-dependent, in the sense that the output depends on the order in - which the variables are given. Therefore, Colombo and Maathuis (2013) + which the variables are given. Therefore, Colombo and Maathuis (2014) proposed a simple modification, called PC-stable, that yields order-independent adjacencies in the skeleton (see the help file of this function for details). Subsequently, as many edges as possible @@ -114,13 +119,15 @@ pc(suffStat, indepTest, alpha, labels, p, remain order-dependent. The edges are oriented as follows. First, the algorithm considers all - triples \code{(a,b,c)}, where \code{a} and - \code{b} are adjacent, \code{b} and \code{c} are adjacent, but - \code{a} and \code{c} are not adjacent. For all such triples, - we direct both edges towards b (a->b<-c) if and only if \code{b} was - not part of the conditioning set that made the edge between \code{a} - and \code{c} drop out. These conditioning sets were saved in - \code{sepset}. The structure a->b<-c is called a v-structure. + triples \code{(a,b,c)}, where \eqn{a} and \eqn{b} are adjacent, \eqn{b} and + \eqn{c} are adjacent, but \eqn{a} and \eqn{c} are not adjacent. For all such + triples, we direct both edges towards \eqn{b} + (\eqn{a \longrightarrow b \longleftarrow c}{a → b ← c}) if and only if + \eqn{b} was not part of the conditioning set that made the edge between + \eqn{a} and \eqn{c} drop out. These conditioning sets were saved in + \code{sepset}. The structure + \eqn{a \longrightarrow b \longleftarrow c}{a → b ← c} is called a + v-structure. After determining all v-structures, there may still be undirected edges. It may be possible to direct some of these edges, since @@ -128,73 +135,78 @@ pc(suffStat, indepTest, alpha, labels, p, invalid because it introduces a new v-structure or a directed cycle. Such edges are found by repeatedly applying rules R1-R3 of the PC algorithm as given in - Algorithm 2 of Kalisch and B\"uhlmann (2007). The algorithm stops if + Algorithm 2 of Kalisch and Bühlmann (2007). The algorithm stops if none of the rules is applicable to the graph. The conservative PC algorithm (\code{conservative = TRUE}) is a slight variation of the PC algorithm (see Ramsey et al. 2006). After - the skeleton is computed, all potential v-structures a-b-c are checked - in the following way. We test whether a and c are independent - conditioning on all subsets of the neighbors of a and all subsets of the - neighbors of c. When a subset makes a and c conditionally independent, - we call it a separating set. If b is in no such separating set or in all such - separating sets, no further action is taken and the usual PC is - continued. If, however, b is in only some separating sets, the - triple a-b-c is marked as 'ambiguous'. Moreover, if no separating set is - found among the neighbors, the triple is also marked as - 'ambiguous'. An ambiguous triple is not oriented as a + the skeleton is computed, all potential v-structures \eqn{a - b - c} are + checked in the following way. We test whether a and c are independent + conditioning on all subsets of the neighbors of \eqn{a} and all subsets of + the neighbors of \eqn{c}. When a subset makes \eqn{a} and \eqn{c} + conditionally independent, we call it a separating set. If \eqn{b} is in no + such separating set or in all such separating sets, no further action is + taken and the usual PC is continued. If, however, \eqn{b} is in only some + separating sets, the triple \eqn{a - b - c} is marked as 'ambiguous'. + Moreover, if no separating set is found among the neighbors, the triple is + also marked as 'ambiguous'. An ambiguous triple is not oriented as a v-structure. Furthermore, no further orientation rule that needs to - know whether a-b-c is a v-structure or not is applied. Instead of + know whether \eqn{a - b - c} is a v-structure or not is applied. Instead of using the conservative version, which is quite strict towards the - v-structures, Colombo and Maathuis (2013) introduced a less strict + v-structures, Colombo and Maathuis (2014) introduced a less strict version for the v-structures called majority rule. This adaptation can - be called using \code{maj.rule = TRUE}. In this case, the triple a-b-c - is marked as 'ambiguous' if and only if b is in exactly 50 percent of - such separating sets or no separating set was found. If b is in less - than 50 percent of the separating sets it is set as a v-structure, and - if in more than 50 percent it is set as a non v-structure (for more - details see Colombo and Maathuis, 2013). The useage of both the + be called using \code{maj.rule = TRUE}. In this case, the triple + \eqn{a - b - c} is marked as 'ambiguous' if and only if \eqn{b} is in + exactly 50 percent of such separating sets or no separating set was found. + If \eqn{b} is in less than 50 percent of the separating sets it is set as a + v-structure, and if in more than 50 percent it is set as a non v-structure + (for more details see Colombo and Maathuis, 2014). The usage of both the conservative and the majority rule versions resolve the order-dependence issues of the determination of the v-structures. Sampling errors (or hidden variables) can lead to conflicting information about edge directions. For example, one may find that - a-b-c and b-c-d should both be directed as v-structures. This gives - conflicting information about the edge b-c, since it should be - directed as b<-c in v-structure a->b<-c, while it should be directed - as b->c in v-structure b->c<-d. With the option \code{solve.confl = - FALSE}, in such cases, we simply overwrite the + \eqn{a - b - c} and \eqn{b - c - d} should both be directed as v-structures. + This gives conflicting information about the edge \eqn{b - c}, since it should + be directed as \eqn{b \longleftarrow c}{b ← c} in v-structure + \eqn{a \longrightarrow b \longleftarrow c}{a → b ← c}, while it should be + directed as \eqn{b \longrightarrow c}{b → c} in v-structure + \eqn{b \longrightarrow c \longleftarrow d}{b → c ← d}. With the option + \code{solve.confl = FALSE}, in such cases, we simply overwrite the directions of the conflicting edge. In the example above this means - that we obtain a->b->c<-d if a-b-c was visited first, and a->b<-c<-d - if b-c-d was visited first, meaning that the final orientation on the - edge depends on the ordering in which the v-structures were + that we obtain + \eqn{a \longrightarrow b \longrightarrow c \longleftarrow d}{a → b → c ← d} + if \eqn{a - b - c} was visited first, and + \eqn{a \longrightarrow b \longleftarrow c \longleftarrow d}{a → b ← c ← d} + if \eqn{b - c - d} was visited first, meaning that the final orientation on + the edge depends on the ordering in which the v-structures were considered. With the option \code{solve.confl = TRUE} (which is only supported with option \code{u2pd = "relaxed"}), we first generate a list - of all (unambiguous) v-structures (in the example above a-b-c and - b-c-d), and then we simply orient them allowing both directions on the - edge b-c, namely we allow the bi-directed edge b <-> c resolving the - order-dependence issues on the edge orientations. We denote - bi-directed edges in the adjacency matrix M of the graph as M[b,c]=2 - and M[c,b]=2. In a similar way, using lists for the candidate edges for - each orientation rule and allowing bi-directed edges, the - order-dependence issues in the orientation rules can be resolved. Note - that bi-directed edges merely represent a conflicting orientation and - they should not to be interpreted causally. The useage of these lists - for the candidate edges and allowing bi-directed edges resolves the - order-dependence issues on the orientation of the v-structures and on - the orientation rules, see Colombo and Maathuis (2013) for + of all (unambiguous) v-structures (in the example above \eqn{a - b - c} and + \eqn{b - c - d}), and then we simply orient them allowing both directions on + the edge \eqn{b - c}, namely we allow the bi-directed edge + \eqn{b \leftrightarrow c}{b ↔ c} resolving the order-dependence issues on the + edge orientations. We denote bi-directed edges in the adjacency matrix + \eqn{M} of the graph as \code{M[b,c] = 2} and \code{M[c,b] = 2}. In a similar + way, using lists for the candidate edges for each orientation rule and + allowing bi-directed edges, the order-dependence issues in the orientation + rules can be resolved. Note that bi-directed edges merely represent a + conflicting orientation and they should not to be interpreted causally. The + useage of these lists for the candidate edges and allowing bi-directed edges + resolves the order-dependence issues on the orientation of the v-structures + and on the orientation rules, see Colombo and Maathuis (2014) for more details. Note that calling (\code{conservative = TRUE}), or \code{maj.rule = TRUE}, together with \code{solve.confl = TRUE} produces a fully - order-independent output, see Colombo and Maathuis (2013). + order-independent output, see Colombo and Maathuis (2014). Sampling errors, non faithfulness, or hidden variables can also lead to non-extendable CPDAGs, meaning that there does not exist a DAG that has the same skeleton and v-structures as the graph found by the algorithm. An example of this is an undirected cycle consisting of the - edges a-b-c-d and d-a. In this case it is impossible to direct the - edges without creating a cycle or a new v-structure. The option + edges \eqn{a - b - c - d} and \eqn{d - a}. In this case it is impossible to + direct the edges without creating a cycle or a new v-structure. The option \code{u2pd} specifies what should be done in such a situation. If the option is set to \code{"relaxed"}, the algorithm simply outputs the invalid CPDAG. If the option is set to \code{"rand"}, all direction @@ -206,8 +218,9 @@ pc(suffStat, indepTest, alpha, labels, p, arbitrary DAG is generated on the skeleton as in the option "rand", and then converted into its CPDAG. Note that the output can also be an invalid CPDAG, in the sense that it cannot arise from the oracle PC - algorithm, but be extendible to a DAG, for example a->b<-c<-d. In this - case, \code{u2pd} is not used. + algorithm, but be extendible to a DAG, for example + \eqn{a \longrightarrow b \longleftarrow c \longleftarrow d}{a → b ← c ← d}. + In this case, \code{u2pd} is not used. Notes: (1) Throughout, the algorithm works with the column positions of the variables in the adjacency matrix, and not with the names of @@ -215,9 +228,9 @@ pc(suffStat, indepTest, alpha, labels, p, edges are equivalent.} \references{ - D. Colombo and M.H. Maathuis (2013). - Order-independent constraint-based causal structure learning, - (arXiv:1211.3295v2). + D. Colombo and M.H. Maathuis (2014).Order-independent constraint-based + causal structure learning. \emph{Journal of Machine Learning Research} + \bold{15} 3741-3782. M. Kalisch, M. Maechler, D. Colombo, M.H. Maathuis and P. Buehlmann (2012). Causal Inference Using Graphical Models with the R Package diff --git a/man/pc.cons.intern.Rd b/man/pc.cons.intern.Rd index 6ee3b6e..dad3544 100644 --- a/man/pc.cons.intern.Rd +++ b/man/pc.cons.intern.Rd @@ -61,7 +61,7 @@ pc.cons.intern(sk, suffStat, indepTest, alpha, version.unf = c(NA, NA), (Ramsey et al., 2006): If B is in some but not all separating sets, the triple is marked as ambiguous. Otherwise it is treated as in the standard PC algorithm. If \code{maj.rule=TRUE}, the majority rule is - applied (Colombo and Maathuis, 2013): The triple is marked as + applied (Colombo and Maathuis, 2014): The triple is marked as \sQuote{ambiguous} if B is in exactly 50 percent of the separating sets. If it is in less than 50 percent it is marked as a v-structure, and if it is in more than 50 percent it is marked as a non v-structure. @@ -84,8 +84,9 @@ pc.cons.intern(sk, suffStat, indepTest, alpha, version.unf = c(NA, NA), \item{sk}{The updated skeleton-object (separating sets might have been updated).} } \references{ - D. Colombo and M.H. Maathuis (2013). Order-independent - constraint-based causal structure learning. arXiv:1211.3295v1. + D. Colombo and M.H. Maathuis (2014).Order-independent constraint-based + causal structure learning. \emph{Journal of Machine Learning Research} + \bold{15} 3741-3782. J. Ramsey, J. Zhang and P. Spirtes (2006). Adjacency-faithfulness and conservative causal inference. In diff --git a/man/pcAlgo-class.Rd b/man/pcAlgo-class.Rd index 7c0684d..1aa83fc 100644 --- a/man/pcAlgo-class.Rd +++ b/man/pcAlgo-class.Rd @@ -1,10 +1,11 @@ \name{pcAlgo-class} -\title{Class "pcAlgo" of PC Algorithm Results} +\title{Class "pcAlgo" of PC Algorithm Results, incl. Skeleton} \docType{class} \alias{pcAlgo-class} \alias{plot,pcAlgo,ANY-method} \alias{show,pcAlgo-method} \alias{summary,pcAlgo-method} +\alias{print.pcAlgo} \description{This class of objects is returned by the functions \code{\link{skeleton}} and \code{\link{pc}} to represent the (skeleton) of an estimated CPDAG. @@ -14,7 +15,9 @@ \usage{% usage ..for methods with "surprising arguments": \S4method{plot}{pcAlgo,ANY}(x, y, main = NULL, zvalue.lwd = FALSE, lwd.max = 7, labels = NULL, \dots) +\S3method{print}{pcAlgo}(x, amat = FALSE, zero.print = ".", \dots) +\S4method{summary}{pcAlgo}(object, amat = TRUE, zero.print = ".", \dots) \S4method{show}{pcAlgo}(object) } \arguments{ @@ -28,6 +31,10 @@ \item{labels}{if non-\code{NULL}, these are used to define node attributes \code{nodeAttrs} and \code{attrs}, passed to \code{\link[Rgraphviz]{agopen}()} from package \pkg{Rgraphviz}.} + \item{amat}{\code{\link{logical}} indicating if the adjacency matrix + should be shown (printed) as well.} + \item{zero.print}{string for printing \code{0} (\sQuote{zero}) entries + in the adjacency matrix.} \item{\dots}{optional further arguments (passed from and to methods).} } \section{Creation of objects}{ diff --git a/man/pcorOrder.Rd b/man/pcorOrder.Rd index 645bb18..d18c095 100644 --- a/man/pcorOrder.Rd +++ b/man/pcorOrder.Rd @@ -9,8 +9,10 @@ pcorOrder(i,j, k, C, cut.at = 0.9999999) } \arguments{ - \item{i,j}{Integer variable numbers to compute partial correlations of.} - \item{k}{Conditioning set for partial correlations (vector of integers).} + \item{i,j}{(integer) position of variable \eqn{i} and \eqn{j}, + respectively, in correlation matrix.} + \item{k}{(integer) positions of zero or more conditioning variables in the + correlation matrix.} \item{C}{Correlation matrix (matrix)} \item{cut.at}{Number slightly smaller than one; if \eqn{c} is \code{cut.at}, values outside of \eqn{[-c,c]} are set to \eqn{-c} or diff --git a/man/pdag2allDags.Rd b/man/pdag2allDags.Rd new file mode 100644 index 0000000..dcd62f1 --- /dev/null +++ b/man/pdag2allDags.Rd @@ -0,0 +1,85 @@ +\name{pdag2allDags} +\alias{pdag2allDags} +\title{Enumerate All DAGs in a Markov Equivalence Class} +\description{ + \code{pdag2allDags} computes all DAGs in the Markov Equivalence Class + Represented by a Given Partially Directed Acyclic Graph (PDAG). +} +\usage{ +pdag2allDags(gm, verbose = FALSE) +} +\arguments{ + \item{gm}{adjacency matrix of type \link{amat.cpdag}} + \item{verbose}{logical; if true, some output is produced during + computation} +} +\details{ + All DAGs extending the given PDAG are computing while avoiding new + v-structures and cycles. If no DAG is found, the function returns \code{NULL}. +} +\value{ + List with two elements: +\item{dags:}{Matrix; every row corresponds to a DAG; every column + corresponds to an entry in the adjacency matrix of this DAG. Thus, the +adjacency matrix (of type \link{amat.cpdag}) contained in the i-th row +of matrix \code{dags} can be obtained by calling +\code{matrix(dags[i,],p,p, byrow = TRUE)} (assuming the input PDAG has +\code{p} nodes).} +\item{nodeNms}{Node labels of the input PDAG.} +} +\author{Markus Kalisch (\email{kalisch@stat.math.ethz.ch})} +\examples{ +## Example 1 +gm <- rbind(c(0,1), + c(1,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:2] +res1 <- pdag2allDags(gm) +## adjacency matrix of first DAG in output +amat1 <- matrix(res1$dags[1,],2,2, byrow = TRUE) +colnames(amat1) <- rownames(amat1) <- res1$nodeNms +amat1 ## A --> B + +## Example 2 +gm <- rbind(c(0,1,1), + c(1,0,1), + c(1,1,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:ncol(gm)] +res2 <- pdag2allDags(gm) +## adjacency matrix of first DAG in output +amat2 <- matrix(res2$dags[1,],3,3, byrow = TRUE) +colnames(amat2) <- rownames(amat2) <- res2$nodeNms +amat2 + +## Example 3 +gm <- rbind(c(0,1,1,0,0), + c(1,0,0,0,0), + c(1,0,0,0,0), + c(0,1,1,0,1), + c(0,0,0,1,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:ncol(gm)] +res3 <- pdag2allDags(gm) +## adjacency matrix of first DAG in output +amat3 <- matrix(res3$dags[1,],5,5, byrow = TRUE) +colnames(amat3) <- rownames(amat3) <- res3$nodeNms +amat3 + +## for convenience a simple plotting function +## for the function output +plotAllDags <- function(res) { + require(graph) + p <- sqrt(ncol(res$dags)) + nDags <- ceiling(sqrt(nrow(res$dags))) + par(mfrow = c(nDags, nDags)) + for (i in 1:nrow(res$dags)) { + tmp <- matrix(res$dags[i,],p,p) + colnames(tmp) <- rownames(tmp) <- res$nodeNms + plot(as(tmp, "graphNEL")) + } +} +plotAllDags(res1) +amat1 ## adj.matrix corresponding to the first plot for expl 1 +plotAllDags(res2) +amat2 ## adj.matrix corresponding to the first plot for expl 2 +plotAllDags(res3) +amat3 ## adj.matrix corresponding to the first plot for expl 3 +} diff --git a/man/pdsep.Rd b/man/pdsep.Rd index be29d2e..b259e13 100644 --- a/man/pdsep.Rd +++ b/man/pdsep.Rd @@ -87,7 +87,7 @@ pdsep(skel, suffStat, indepTest, p, sepset, alpha, pMax, m.max = Inf, To make the code more efficient, we only perform tests that were not performed in the estimation of the initial skeleton. - Note that the Possible-D-SEP sets are computed once in the beginning. They are not updated after edge deletions, in order to make sure that the output of the algorithm does not depend on the ordering of the variables (see also Colombo and Maathuis (2013)). + Note that the Possible-D-SEP sets are computed once in the beginning. They are not updated after edge deletions, in order to make sure that the output of the algorithm does not depend on the ordering of the variables (see also Colombo and Maathuis (2014)). } \references{ P. Spirtes, C. Glymour and R. Scheines (2000). @@ -98,8 +98,9 @@ pdsep(skel, suffStat, indepTest, p, sepset, alpha, pMax, m.max = Inf, selection variables. \emph{Annals of Statistics} \bold{40}, 294--321. - D. Colombo and M.H. Maathuis (2013). - Order-independent constraint-based causal structure learning. arXiv:1211.3295v2. + D. Colombo and M.H. Maathuis (2014).Order-independent constraint-based + causal structure learning. \emph{Journal of Machine Learning Research} + \bold{15} 3741-3782. } \seealso{\code{\link{qreach}} to find Possible-D-SEP(x,G); \code{\link{fci}}. diff --git a/man/plotSG.Rd b/man/plotSG.Rd index 7765ee0..4a5486a 100644 --- a/man/plotSG.Rd +++ b/man/plotSG.Rd @@ -11,9 +11,9 @@ plotSG(graphObj, y, dist, amat = NA, directed = TRUE, main = ) } \arguments{ \item{graphObj}{An \R object of class \code{\link[graph:graph-class]{graph}}.} - \item{y}{Starting node.} + \item{y}{(integer) position of the starting node in the adjacency matrix.} \item{dist}{Distance of nodes included in subgraph from starting node \code{y}.} - \item{amat}{Adjacency matrix of skeleton graph (optional).} + \item{amat}{Precomputed adjacency matrix of type \link{amat.cpdag} (optional)} \item{directed}{\code{\link{logical}} indicating if the subgraph should be directed.} \item{main}{Title to be used, with a sensible default; see \code{\link{title}}.} diff --git a/man/possibleDe.Rd b/man/possibleDe.Rd index f881801..c7209e6 100644 --- a/man/possibleDe.Rd +++ b/man/possibleDe.Rd @@ -11,19 +11,16 @@ of x on definite status paths. possibleDe(amat, x) } \arguments{ - \item{amat}{ - Adjacency matrix of the DAG, CPDAG, MAG or PAG. -} - \item{x}{ - Node of interest. -} -} + \item{amat}{adjacency matrix of type \link{amat.pag}} + \item{x}{(integer) position of node \eqn{x} (node of interest) in the + adjacency matrix.} + } \details{ A non-endpoint vertex \code{X} on a path \code{p} in a partial mixed graph is said to be of a \emph{definite status} if it is either a collider or a definite non-collider on \code{p}. The path \code{p} is said to be of a \emph{definite status} if all non-endpoint vertices on the path are of a -definite status (see e.g. Maathuis and Colombo (2013), Def. 3.4). +definite status (see e.g. Maathuis and Colombo (2015), Def. 3.4). A possible descendent of x can be reached moving to adjacent nodes of x but never going against an arrowhead. @@ -32,13 +29,14 @@ but never going against an arrowhead. Vector with possible descendents. } \references{ -M.H. Maathuis and D. Colombo. A generalized backdoor criterion. (\href{http://arxiv.org/abs/1307.5636}{arXiv:1307.5636v2}) + M.H. Maathuis and D. Colombo (2015). A generalized back-door + criterion. \emph{Annals of Statistics} \bold{43} 1060-1088. } \author{ Diego Colombo } \seealso{ -\code{\link{backdoor}} +\code{\link{backdoor}}, \link{amatType} } \examples{ amat <- matrix( c(0,3,0,0,0,0, 2,0,2,0,0,0, 0,3,0,0,0,0, 0,0,0,0,1,0, diff --git a/man/qreach.Rd b/man/qreach.Rd index fcf3321..93e2ea7 100644 --- a/man/qreach.Rd +++ b/man/qreach.Rd @@ -16,11 +16,9 @@ qreach(x, amat, verbose = FALSE) } \arguments{ - \item{x}{Integer: column position of node in adjacency matrix, of + \item{x}{(integer) position of vertex \eqn{x} in the adjacency matrix of which Possible-D-SEP set is to be computed.} - \item{amat}{Adjacency matrix (coding 0,1,2,3 for no edge, circle, - arrowhead, tail; e.g., \code{amat[a,b] = 2} and \code{amat[b,a] = 3} - implies a -> b) + \item{amat}{Adjacency matrix of type \link{amat.pag}. } \item{verbose}{Logical, asking for details on output} } diff --git a/man/randDAG.Rd b/man/randDAG.Rd index 93b5efc..73a8895 100644 --- a/man/randDAG.Rd +++ b/man/randDAG.Rd @@ -14,9 +14,11 @@ randDAG(n, d, method ="er", par1=NULL, par2=NULL, DAG = TRUE, weighted = TRUE, wFUN = list(runif, min=0.1, max=1)) } \arguments{ - \item{n}{integer larger than \code{2}, indicating the number of nodes in the DAG.} + \item{n}{integer, at least \code{2}, indicating the number of nodes in + the DAG.} \item{d}{a positive number, corresponding to the expected number of - neighbours per node, more precisely the expected sum of the in- and out-degree.} + neighbours per node, more precisely the expected sum of the in- and + out-degree.} \item{method}{a string, specifying the method used for generating the random graph. See details below.} \item{par1, par2}{optional additional arguments, dependent on the @@ -40,35 +42,41 @@ randDAG(n, d, method ="er", par1=NULL, par2=NULL, \code{par1} and \code{par2}, with \code{method}, a string, taking one of the following values: \describe{ - \item{\code{regular}:}{Graph where every node has exactly \code{d} incident edges.} + \item{\code{regular}:}{Graph where every node has exactly \code{d} + incident edges. \code{par1} and \code{par2} are not used.} \item{\code{watts}:}{Watts-Strogatz graph that interpolates between the regular (\code{par1->0}) and Erdoes-Renyi graph (\code{par1->1}). The parameter \code{par1} is per default - \code{0.5} and has to be in \code{(0,1)}.} + \code{0.5} and has to be in \code{(0,1)}. \code{par2} is not used.} - \item{\code{er}:}{Erdoes-Renyi graph where every edge is present independently.} + \item{\code{er}:}{Erdoes-Renyi graph where every edge is present + independently. \code{par1} and \code{par2} are not used.} - \item{\code{power}:}{A graph with power-law degree distribution with expectation \code{d}.} + \item{\code{power}:}{A graph with power-law degree distribution with + expectation \code{d}.\code{par1} and \code{par2} are not used.} \item{\code{bipartite}:}{Bipartite graph with at least \code{par1*n} nodes in group 1 and at most \code{(1-par1)*n} nodes in group 2. The argument \code{par1} has to be in \code{[0,1]} and is per - default \code{0.5}.} + default \code{0.5}. \code{par2} is not used.} \item{\code{barabasi}:}{A graph with power-law degree distribution and preferential attachement according to parameter \code{par1}. It - must hold that \code{par1 >= 1} and the default is \code{par1=1}.} + must hold that \code{par1 >= 1} and the default is + \code{par1=1}. \code{par2} is not used.} \item{\code{geometric}:}{A geometric random graph in dimension \code{par1}, where \code{par1} can take values from \code{{2,3,4,5}} and is per default \code{2}. If \code{par2="geo"} and \code{weighted=TRUE}, then the weights are computed according to - the Euclidean distance.} + the Euclidean distance. There are currently no other option for + \code{par2} implemented.} \item{\code{interEr}:}{A graph with \code{par1} islands of Erdoes-Renyi graphs, every pair of those connected by a certain - number of edges proportional to \code{par2}. It is required that + number of edges proportional to \code{par2} (fraction of + inter-connectivity). It is required that \eqn{n/s} be integer and \code{par2} in \eqn{(0,1)}. Defaults are \code{par1=2} and \code{par2=0.25}, respectively.} } diff --git a/man/rfci.Rd b/man/rfci.Rd index 6ff2c11..8ce7e60 100644 --- a/man/rfci.Rd +++ b/man/rfci.Rd @@ -9,7 +9,8 @@ rfci(suffStat, indepTest, alpha, labels, p, skel.method = c("stable", "original", "stable.fast"), fixedGaps = NULL, fixedEdges = NULL, NAdelete = TRUE, m.max = Inf, rules = rep(TRUE, 10), - conservative = FALSE, maj.rule = FALSE, verbose = FALSE) + conservative = FALSE, maj.rule = FALSE, + numCores = 1, verbose = FALSE) } \arguments{ @@ -58,6 +59,8 @@ rfci(suffStat, indepTest, alpha, labels, p, \item{maj.rule}{Logical indicating if the unshielded triples should be checked for ambiguity after the skeleton has been found using a majority rule idea, which is less strict than the conservative.} + \item{numCores}{Specifies the number of cores to be used for parallel + estimation of \code{\link{skeleton}}.} \item{verbose}{If true, more detailed output is provided.} } \value{An object of \code{\link{class}} \code{fciAlgo} (see @@ -136,7 +139,7 @@ rfci(suffStat, indepTest, alpha, labels, p, ambiguous triple is not oriented as a v-structure. Furthermore, no further orientation rule that needs to know whether a-b-c is a v-structure or not is applied. Instead of using the conservative version, which is - quite strict towards the v-structures, Colombo and Maathuis (2013) + quite strict towards the v-structures, Colombo and Maathuis (2014) introduced a less strict version for the v-structures called majority rule. This adaptation can be called using \code{maj.rule = TRUE}. In this case, the triple a-b-c is marked as 'ambiguous' if and only if b @@ -144,24 +147,25 @@ rfci(suffStat, indepTest, alpha, labels, p, was found. If b is in less than 50 percent of the separating sets it is set as a v-structure, and if in more than 50 percent it is set as a non v-structure (for more details see Colombo and Maathuis, - 2013). + 2014). The implementation uses the stabilized skeleton \code{\link{skeleton}}, which produces an initial order-independent skeleton. The final skeleton and edge orientations can still be - order-dependent, see Colombo and Maathuis (2013). + order-dependent, see Colombo and Maathuis (2014). } \references{ - D. Colombo and M.H. Maathuis (2013). - Order-independent constraint-based causal structure learning. arXiv - preprint arXiv:1211.3295v2. + D. Colombo and M.H. Maathuis (2014).Order-independent constraint-based + causal structure learning. \emph{Journal of Machine Learning Research} + \bold{15} 3741-3782. D. Colombo, M. H. Maathuis, M. Kalisch, T. S. Richardson (2012). Learning high-dimensional directed acyclic graphs with latent and selection variables. \emph{Ann. Statist.} \bold{40}, 294-321. } -\seealso{\code{\link{fci}} for estimating a PAG using the FCI algorithm; +\seealso{\code{\link{fci}} and \code{\link{fciPlus}} for estimating a + PAG using the FCI algorithm; \code{\link{skeleton}} for estimating an initial skeleton using the RFCI algorithm; \code{\link{pc}} for estimating a CPDAG using the PC algorithm; \code{\link{gaussCItest}}, diff --git a/man/showAmat.Rd b/man/showAmat.Rd index f14089d..3a1467f 100644 --- a/man/showAmat.Rd +++ b/man/showAmat.Rd @@ -2,6 +2,8 @@ \alias{showAmat} \title{Show Adjacency Matrix of pcAlgo object} \description{ + \bold{This function is deprecated - Use \code{as(*, "amat")} instead !} + Show the adjacency matrix of a \code{"pcAlgo"} object; this is intended to be an alternative if the \pkg{Rgraphviz} package does not work. } diff --git a/man/simy.Rd b/man/simy.Rd index 6168411..e340a4f 100644 --- a/man/simy.Rd +++ b/man/simy.Rd @@ -11,13 +11,15 @@ scoring criterion in exponential runtime. } \usage{ -simy(p, targets, score, verbose = FALSE, ...) +simy(score, labels = score$getNodes(), targets = score$getTargets(), + verbose = FALSE, ...) } \arguments{ - \item{p}{Number of variables.} + \item{score}{An instance of a class derived from \code{\linkS4class{Score}}.} + \item{labels}{Node labels; by default, they are determined from the scoring + object.} \item{targets}{A list of intervention targets (cf. details). A list of vectors, each vector listing the vertices of one intervention target.} - \item{score}{An instance of a class derived from \code{\linkS4class{Score}}.} \item{verbose}{if \code{TRUE}, detailed output is provided.} \item{\dots}{Additional arguments for debugging purposes and fine tuning.} } @@ -83,7 +85,7 @@ data(gmInt) score <- new("GaussL0penIntScore", gmInt$x, gmInt$targets, gmInt$target.index) ## Estimate the essential graph -simy.fit <- simy(ncol(gmInt$x), gmInt$targets, score) +simy.fit <- simy(score) eDAG <- simy.fit$essgraph as(eDAG, "graph") diff --git a/man/skeleton.Rd b/man/skeleton.Rd index 3bc0ed9..43cd254 100644 --- a/man/skeleton.Rd +++ b/man/skeleton.Rd @@ -22,7 +22,7 @@ skeleton(suffStat, indepTest, alpha, labels, p, method = c("stable", "original", "stable.fast"), m.max = Inf, fixedGaps = NULL, fixedEdges = NULL, NAdelete = TRUE, - verbose = FALSE) + numCores = 1, verbose = FALSE) } \arguments{ \item{suffStat}{Sufficient statistics: List containing all necessary @@ -61,6 +61,8 @@ skeleton(suffStat, indepTest, alpha, labels, p, \item{NAdelete}{logical needed for the case \code{indepTest(*)} returns \code{NA}. If it is true, the corresponding edge is deleted, otherwise not.} + \item{numCores}{number of processor cores to use for parallel computation. + Only available for \code{method = "stable.fast"}.} \item{verbose}{if \code{TRUE}, detailed output is provided.} } \value{An object of \code{\link{class}} \code{"pcAlgo"} (see @@ -103,12 +105,12 @@ skeleton(suffStat, indepTest, alpha, labels, p, The PC algorithm (Spirtes, Glymour and Scheines, 2000) (\code{method = "original"}) is known to be order-dependent, in the sense that the output may depend on the order in which the variables - are given. Therefore, Colombo and Maathuis (2013) proposed a simple + are given. Therefore, Colombo and Maathuis (2014) proposed a simple modification, called \dQuote{PC-stable}, which yields order-independent adjacencies in the skeleton, provided by \code{pc()} with the new default \code{method = "stable"}. This stable variant of the algorithm is also available with the \code{method = "stable.fast"}: - it runs the algorithm of Colombo and Maathuis (2013) faster than + it runs the algorithm of Colombo and Maathuis (2014) faster than \code{method = "stable"} in general, but should be regarded as an experimental option at the moment. @@ -140,10 +142,10 @@ skeleton(suffStat, indepTest, alpha, labels, p, et al., 2012) algorithms are built up from the PC algorithm, they are also order-dependent in the skeleton. To resolve their order-dependence issues in the skeleton is more involved, see Colombo and Maathuis - (2013). However now, with \code{method = "stable"}, this function + (2014). However now, with \code{method = "stable"}, this function estimates an initial order-independent skeleton in these algorithms (for additional details on how to make the final skeleton of FCI fully - order-independent see \code{\link{fci}} and Colombo and Maathuis (2013)). + order-independent see \code{\link{fci}} and Colombo and Maathuis (2014)). The information in \code{fixedGaps} and \code{fixedEdges} is used as follows. The gaps given in \code{fixedGaps} are introduced in the very beginning of @@ -158,9 +160,9 @@ skeleton(suffStat, indepTest, alpha, labels, p, the variables. } \references{ - D. Colombo and M.H. Maathuis (2013). - \emph{Order-independent constraint-based causal structure learning}, - (arXiv:1211.3295v2) + D. Colombo and M.H. Maathuis (2014).Order-independent constraint-based + causal structure learning. \emph{Journal of Machine Learning Research} + \bold{15} 3741-3782. D. Colombo, M. H. Maathuis, M. Kalisch, T. S. Richardson (2012). Learning high-dimensional directed acyclic graphs with latent @@ -187,7 +189,7 @@ skeleton(suffStat, indepTest, alpha, labels, p, } \author{ Markus Kalisch (\email{kalisch@stat.math.ethz.ch}), Martin Maechler, - and Diego Colombo. + Alain Hauser, and Diego Colombo. } \examples{ ################################################## diff --git a/man/udag2apag.Rd b/man/udag2apag.Rd index 1d09d92..3f49daf 100644 --- a/man/udag2apag.Rd +++ b/man/udag2apag.Rd @@ -19,10 +19,7 @@ udag2apag(apag, suffStat, indepTest, alpha, sepset, rules = rep(TRUE, 10), unfVect = NULL, verbose = FALSE) } \arguments{ - \item{apag}{Adjacency matrix of the pcAlgo-object of size p*p where - the v-structures have already been oriented (coding 0,1,2,3 for no - edge, circle, arrowhead, tail; e.g., \code{amat[a,b] = 2} and - \code{amat[b,a] = 3} implies a -> b).} + \item{apag}{Adjacency matrix of type \link{amat.pag}} \item{suffStat}{Sufficient statistics: A \code{\link{list}} containing all necessary elements for the conditional independence decisions in the function \code{indepTest}.} @@ -41,7 +38,9 @@ udag2apag(apag, suffStat, indepTest, alpha, sepset, \item{sepset}{List of length p; each element of the list contains another list of length p. The element \code{sepset[[x]][[y]]} contains the separation set that made the edge - between \code{x} and \code{y} drop out. This object is thought to be + between \code{x} and \code{y} drop out. Each separation set is a + vector with (integer) positions of variables in the adjacency + matrix. This object is thought to be obtained from a \code{pcAlgo}-object.} \item{rules}{Logical vector of length 10 with \code{TRUE} or \code{FALSE} for each rule, where \code{TRUE} in position i means that rule i (Ri) will be @@ -82,20 +81,17 @@ udag2apag(apag, suffStat, indepTest, alpha, sepset, matrix and not with the names of the variables. Note that this function does not resolve possible order-dependence in - the application of the orientation rules, see Colombo and Maathuis (2013). + the application of the orientation rules, see Colombo and Maathuis (2014). } \value{ - \item{apag}{Final adjacency matrix (coding 0,1,2,3 for no edge, - circle, arrowhead, tail; e.g., \code{amat[a,b] = 2} and - \code{amat[b,a] = 3} implies a -> b)} - + \item{apag}{Final adjacency matrix of type \link{amat.pag}} \item{sepset}{Updated list of separating sets} } \references{ - D. Colombo and M.H. Maathuis (2013). - Order-independent constraint-based causal structure learning. - arXiv:1211.3295v2. - + D. Colombo and M.H. Maathuis (2014).Order-independent constraint-based + causal structure learning. \emph{Journal of Machine Learning Research} + \bold{15} 3741-3782. + D. Colombo, M. H. Maathuis, M. Kalisch, T. S. Richardson (2012). Learning high-dimensional directed acyclic graphs with latent and selection variables. \emph{Ann. Statist.} \bold{40}, 294--321. diff --git a/man/udag2pag.Rd b/man/udag2pag.Rd index be6183f..81423b0 100644 --- a/man/udag2pag.Rd +++ b/man/udag2pag.Rd @@ -13,13 +13,13 @@ udag2pag(pag, sepset, rules = rep(TRUE, 10), unfVect = NULL, verbose = FALSE, orientCollider = TRUE) } \arguments{ - \item{pag}{Adjacency matrix of the final skeleton of size p*p (coding - 0,1,2,3 for no edge, circle, arrowhead, tail; e.g., \code{amat[a,b] - = 2} and \code{amat[b,a] = 3} implies a -> b).} + \item{pag}{Adjacency matrix of type \link{amat.pag}} \item{sepset}{List of length p; each element of the list contains another list of length p. The element \code{sepset[[x]][[y]]} contains the separation set that made the edge - between \code{x} and \code{y} drop out. This object is thought to be + between \code{x} and \code{y} drop out. Each separation set is a + vector with (integer) positions of variables in the adjacency + matrix. This object is thought to be obtained from a \code{pcAlgo}-object.} \item{rules}{Array of length 10 containing \code{TRUE} or \code{FALSE} for each rule. \code{TRUE} in position i means that rule i (Ri) will @@ -51,16 +51,15 @@ udag2pag(pag, sepset, rules = rep(TRUE, 10), unfVect = NULL, matrix and not with the names of the variables. Note that this function does not resolve possible order-dependence in - the application of the orientation rules, see Colombo and Maathuis (2013). + the application of the orientation rules, see Colombo and Maathuis (2014). } \value{ - Adjacency matrix M with edge marks. The edge marks are - coded in the following way: M[i,j]=M[j,i]=0: no edge; M[i,j]=1, M[j,i] - != 0: i *-o j; M[i,j]=2, M[j,i]!=0: i*->j; M[i,j]=3, M[j,i]!=0: i*-j. + Adjacency matrix of type \link{amat.pag}. } \references{ - D. Colombo and M.H. Maathuis (2013). Order-independent constraint-based - causal structure learning. arXiv:1211.3295v2 + D. Colombo and M.H. Maathuis (2014).Order-independent constraint-based + causal structure learning. \emph{Journal of Machine Learning Research} + \bold{15} 3741-3782. D. Colombo, M. H. Maathuis, M. Kalisch, T. S. Richardson (2012). Learning high-dimensional directed acyclic graphs with latent diff --git a/man/udag2pdag.Rd b/man/udag2pdag.Rd index 134c067..ef997ed 100644 --- a/man/udag2pdag.Rd +++ b/man/udag2pdag.Rd @@ -127,7 +127,7 @@ udag2pdagSpecial(gInput, verbose, n.max=100) example, two v-structures a -> b <- c and b -> c <- d then yield a -> b <-> c <-d. This option can be used to get an order-independent version of the PC algorithm (see Colombo and - Maathuis (2013)). + Maathuis (2014)). We denote bi-directed edges, for example between two variables i and j, in the adjacency matrix M of the graph as M[i,j]=2 and @@ -153,12 +153,10 @@ udag2pdagSpecial(gInput, verbose, n.max=100) \item{xtbl}{Logical indicating whether the final graph with v-structures is extendable} \item{amat0}{Adjacency matrix of original graph with - v-structures (coding 0/1 for no edge or tail / arrowhead; - e.g. \code{amat[a,b] = 0} and \code{amat[b,a] = 1} implies a -> b) .} + v-structures (type \link{amat.cpdag}) .} \item{amat1}{Adjacency matrix of final graph with v-structures after changing the ordering in which the v-structures are - considered (coding 0/1 for no edge or tail / arrowhead; - e.g. \code{amat[a,b] = 0} and \code{amat[b,a] = 1} implies a -> b) .} + considered (type \link{amat.cpdag}) .} \item{status}{Integer code with values \describe{ \item{0:}{Original try is extendable;} \item{1:}{Reorienting double edge visits helps;} @@ -183,9 +181,9 @@ udag2pdagSpecial(gInput, verbose, n.max=100) J. Pearl (2000), \emph{Causality}, Cambridge University Press. - D. Colombo and M.H. Maathuis (2013). - Order-independent constraint-based causal structure learning. - arXiv:1211.3295v2. + D. Colombo and M.H. Maathuis (2014).Order-independent constraint-based + causal structure learning. \emph{Journal of Machine Learning Research} + \bold{15} 3741-3782. } \author{Markus Kalisch (\email{kalisch@stat.math.ethz.ch})} \seealso{\code{\link{pc}}, \code{\link{pdag2dag}}, diff --git a/man/unifDAG.Rd b/man/unifDAG.Rd index fd63db6..107b295 100644 --- a/man/unifDAG.Rd +++ b/man/unifDAG.Rd @@ -55,9 +55,8 @@ unifDAG.approx(n, n.exact=20, weighted=FALSE, wFUN=list(runif,min=0.1,max=1)) \references{ Jack Kuipers and Guisi Moffa (2015) Uniform random generation of large acyclic digraphs. - \emph{Statistics and Computing} \bold{25}, 227--242, Springer; - \url{http://dx.doi.org/10.1007/s11222-013-9428-y}; - Prepublication 2013: \url{http://arxiv.org/pdf/1202.6590.pdf}. + \emph{Statistics and Computing} \bold{25(2)}, 227--242, Springer; + \url{http://dx.doi.org/10.1007/s11222-013-9428-y} } \author{Markus Kalisch (\email{kalisch@stat.math.ethz.ch}) and Manuel Schuerch.} diff --git a/man/visibleEdge.Rd b/man/visibleEdge.Rd index 6bd033f..1475910 100644 --- a/man/visibleEdge.Rd +++ b/man/visibleEdge.Rd @@ -10,14 +10,9 @@ Check if the directed edge from x to z in a MAG or in a PAG is visible or not. visibleEdge(amat, x, z) } \arguments{ - \item{amat}{Adjacency matrix (coding 0,1,2,3 for no edge, circle, - arrowhead, tail; e.g., \code{amat[a,b] = 2} and \code{amat[b,a] = 3} - implies a -> b). -} - \item{x}{Node x. -} - \item{z}{Node z. -} + \item{amat}{Adjacency matrix of type \link{amat.pag}} + \item{x,z}{(integer) position of variable \eqn{x} and \eqn{z}, + respectively, in the adjacency matrix.} } \details{ All directed edges in DAGs and CPDAGs are said to be visible. Given a @@ -25,14 +20,14 @@ MAG M / PAG P, a directed edge A -> B in M / P is visible if there is a vertex C not adjacent to B, such that there is an edge between C and A that is into A, or there is a collider path between C and A that is into A and every non-endpoint vertex on the path is a parent of B. Otherwise -A -> B is said to be invisible. (see Maathuis and Colombo (2013), Def. 3.1) +A -> B is said to be invisible. (see Maathuis and Colombo (2015), Def. 3.1) } \value{ \code{TRUE} if edge is visible, otherwise \code{FALSE}. } \references{ - M.H. Maathuis and D. Colombo (2013). A generalized backdoor - criterion. arXiv preprint arXiv:1307.5636. + M.H. Maathuis and D. Colombo (2015). A generalized backdoor + criterion. Annals of Statistics 43 1060-1088. } \author{ Diego Colombo diff --git a/src/Makevars.win b/src/Makevars.win index 970d52e..7ad2fb0 100644 --- a/src/Makevars.win +++ b/src/Makevars.win @@ -1,6 +1,6 @@ ## Use the R_HOME indirection to support installations of multiple R version # PKG_CXXFLAGS = -I"$(BOOSTLIB)" # provided by package "BH" now -PKG_CXXFLAGS=-I"../inst/include" -PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) +PKG_CXXFLAGS=-I"../inst/include" $(SHLIB_OPENMP_CFLAGS) +PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) $(SHLIB_OPENMP_CFLAGS) diff --git a/src/constraint.cpp b/src/constraint.cpp index cf0a41f..3170446 100644 --- a/src/constraint.cpp +++ b/src/constraint.cpp @@ -15,6 +15,7 @@ #include #include #include +#include double IndepTestRFunction::test(uint u, uint v, std::vector S) const { @@ -141,28 +142,36 @@ void Skeleton::fitCondInd( // edgeTests lists the number of edge tests that have already been done; its size // corresponds to the size of conditioning sets that have already been checked - for (uint condSize = edgeTests.size(); found && (int)condSize <= maxCondSize; ++condSize) { + // TODO: improve handling of check_interrupt, see e.g. + // https://github.com/jjallaire/Rcpp/blob/master/inst/examples/OpenMP/piWithInterrupts.cpp + for (uint condSize = edgeTests.size(); + !check_interrupt() && found && (int)condSize <= maxCondSize; + ++condSize) { dout.level(1) << "Order = " << condSize << "; remaining edges: " << getEdgeCount() << std::endl; - std::set< std::pair > deleteEdges; - found = false; - edgeTests.push_back(0); - - // Iterate over all edges in the graph + // Make a list of edges in the graph; this is needed for OpenMP + std::vector u, v; + u.reserve(getEdgeCount()); + v.reserve(getEdgeCount()); for (boost::tie(ei, eiLast) = boost::edges(_graph); ei != eiLast && !check_interrupt(); ei++) { - // Get endpoints u, v of edge; make sure that deg(u) >= deg(v) - uint u = boost::source(*ei, _graph); - uint v = boost::target(*ei, _graph); - uint u_min = std::min(u, v); - uint u_max = std::max(u, v); - if (getDegree(u) < getDegree(v)) - std::swap(u, v); - - // There is a conditioning set of size "condSize" if deg(u) > condSize - if (getDegree(u) > condSize) { - dout.level(2) << "Found a conditioning set of size " << condSize << std::endl; - found = true; + uint node1 = boost::source(*ei, _graph); + uint node2 = boost::target(*ei, _graph); + if (node1 > node2) + std::swap(node1, node2); + if (std::max(getDegree(node1), getDegree(node2)) > condSize && !isFixed(node1, node2)) { + u.push_back(node1); + v.push_back(node2); } + } + boost::dynamic_bitset<> deleteEdges(u.size()); + arma::ivec localEdgeTests(u.size(), arma::fill::zeros); + + // There is a conditioning set of size "condSize" if u is not empty + found = u.size() > 0; + + // Iterate over all edges in the graph + #pragma omp parallel for + for (std::size_t l = 0; l < u.size(); l++) { bool edgeDone = false; int k; @@ -170,13 +179,13 @@ void Skeleton::fitCondInd( std::vector condSet(condSize); std::vector::iterator> si(condSize); - // Check neighborhood of u, if edge is not fixed - if (!isFixed(u, v) && getDegree(u) > condSize) { + // Check neighborhood of u + if (getDegree(u[l]) > condSize) { // Get neighbors of u (except v) std::vector neighbors(0); - neighbors.reserve(getDegree(u) - 1); - for (boost::tie(outIter, outLast) = boost::out_edges(u, _graph); outIter != outLast; outIter++) - if (boost::target(*outIter, _graph) != v) + neighbors.reserve(getDegree(u[l]) - 1); + for (boost::tie(outIter, outLast) = boost::out_edges(u[l], _graph); outIter != outLast; outIter++) + if (boost::target(*outIter, _graph) != v[l]) neighbors.push_back(boost::target(*outIter, _graph)); // Initialize first conditioning set @@ -189,20 +198,20 @@ void Skeleton::fitCondInd( condSet[i] = *(si[i]); // Test of u and v are conditionally independent given condSet - double pval = _indepTest->test(u, v, condSet); - edgeTests.back()++; - dout.level(1) << " x = " << u << ", y = " << v << ", S = " << + double pval = _indepTest->test(u[l], v[l], condSet); + localEdgeTests(l)++; + dout.level(1) << " x = " << u[l] << ", y = " << v[l] << ", S = " << condSet << " : pval = " << pval << std::endl; if ((boost::math::isnan)(pval)) pval = (NAdelete ? 1. : 0.); - if (pval > pMax(u_min, u_max)) - pMax(u_min, u_max) = pval; + if (pval > pMax(u[l], v[l])) + pMax(u[l], v[l]) = pval; if (pval >= alpha) { - deleteEdges.insert(std::make_pair(u, v)); - arma::ivec condSetR(condSet.size()); + deleteEdges.set(l); + // arma::ivec condSetR(condSet.size()); + sepSet[v[l]][u[l]].set_size(condSet.size()); for (std::size_t j = 0; j < condSet.size(); ++j) - condSetR[j] = condSet[j] + 1; - sepSet[u_max][u_min] = condSetR; + sepSet[v[l]][u[l]][j] = condSet[j] + 1; edgeDone = true; break; // Leave do-while-loop } @@ -217,20 +226,21 @@ void Skeleton::fitCondInd( si[k] = si[k - 1] + 1; } } while(k >= 0); - } + } // IF getDegree(u[l]) - // Check neighborhood of v, if edge is not fixed - if (!edgeDone && !isFixed(u, v) && getDegree(v) > condSize) { + // Check neighborhood of v + if (!edgeDone && getDegree(v[l]) > condSize) { // Get neighbors of u (except v); common neighbors of u and v are listed in the end std::vector neighbors(0); std::vector commNeighbors(0); - neighbors.reserve(getDegree(v) - 1); - commNeighbors.reserve(getDegree(v) - 1); + neighbors.reserve(getDegree(v[l]) - 1); + commNeighbors.reserve(getDegree(v[l]) - 1); uint a; - for (boost::tie(outIter, outLast) = boost::out_edges(v, _graph); outIter != outLast; outIter++) { + for (boost::tie(outIter, outLast) = boost::out_edges(v[l], _graph); + outIter != outLast; outIter++) { a = boost::target(*outIter, _graph); - if (a != u) { - if (hasEdge(u, a)) + if (a != u[l]) { + if (hasEdge(u[l], a)) commNeighbors.push_back(a); else neighbors.push_back(a); @@ -254,20 +264,20 @@ void Skeleton::fitCondInd( condSet[i] = *(si[i]); // Test of u and v are conditionally independent given condSet - double pval = _indepTest->test(v, u, condSet); - edgeTests.back()++; - dout.level(1) << " x = " << v << ", y = " << u << ", S = " << + double pval = _indepTest->test(v[l], u[l], condSet); + localEdgeTests(l)++; + dout.level(1) << " x = " << v[l] << ", y = " << u[l] << ", S = " << condSet << " : pval = " << pval << std::endl; if ((boost::math::isnan)(pval)) pval = (NAdelete ? 1. : 0.); - if (pval > pMax(u_min, u_max)) - pMax(u_min, u_max) = pval; + if (pval > pMax(u[l], v[l])) + pMax(u[l], v[l]) = pval; if (pval >= alpha) { - deleteEdges.insert(std::make_pair(u, v)); - arma::ivec condSetR(condSet.size()); + deleteEdges.set(l); + // arma::ivec condSetR(condSet.size()); + sepSet[v[l]][u[l]].set_size(condSet.size()); for (std::size_t j = 0; j < condSet.size(); ++j) - condSetR[j] = condSet[j] + 1; - sepSet[u_max][u_min] = condSetR; + sepSet[v[l]][u[l]][j] = condSet[j] + 1; edgeDone = true; break; // Leave do-while-loop } @@ -286,19 +296,18 @@ void Skeleton::fitCondInd( si[k] = si[k - 1] + 1; } } while(k >= 0); - } - } - } + } // IF m + } // IF getDegree(v[l]) + } // FOR l // Delete edges marked for deletion - for (std::set< std::pair >::iterator di = deleteEdges.begin(); - di != deleteEdges.end(); ++di) - removeEdge(di->first, di->second); - } // FOR condSize + for (std::size_t l = deleteEdges.find_first(); l < deleteEdges.size(); l = deleteEdges.find_next(l)) + removeEdge(u[l], v[l]); - // Adjust vector of edge test numbers - if (edgeTests.back() == 0) - edgeTests.pop_back(); + // Calculate total number of edge tests + if (found) + edgeTests.push_back(arma::accu(localEdgeTests)); + } // FOR condSize } #endif /* CONSTRAINT_HPP_ */ diff --git a/src/gies.cpp b/src/gies.cpp index 7a90b79..f2cae50 100644 --- a/src/gies.cpp +++ b/src/gies.cpp @@ -2,14 +2,18 @@ * Main file of the Greedy Interventional Equivalence Search library for R * * @author Alain Hauser - * $Id: gies.cpp 266 2014-06-30 14:16:49Z alhauser $ + * $Id: gies.cpp 393 2016-08-20 09:43:47Z alhauser $ */ #include #include #include -#include +// #include #include +// Experimental support for OpenMP; aim: parallelize more and more functions... +#ifdef _OPENMP +#include +#endif // Define BGL class for undirected graph typedef boost::adjacency_list UndirectedGraph; @@ -20,50 +24,9 @@ typedef boost::adjacency_list Undi #define DEFINE_GLOBAL_DEBUG_STREAM #include "pcalg/gies_debug.hpp" -using namespace boost::lambda; +// using namespace boost::lambda; -/** - * Reads in a graph from a list of in-edges passed as a SEXP to - * an EssentialGraph object - */ -EssentialGraph castGraph(SEXP argInEdges) -{ - int i; - Rcpp::List listInEdges(argInEdges); - EssentialGraph result(listInEdges.size()); - - for (i = 0; i < listInEdges.size(); ++i) { - Rcpp::IntegerVector vecParents((SEXP)(listInEdges[i])); - // Adapt indices to C++ convention - for (Rcpp::IntegerVector::iterator vi = vecParents.begin(); vi != vecParents.end(); ++vi) - result.addEdge(*vi - 1, i); - } - - return result; -} - -/** - * Wrap a graph structure to an R list of in-edges - */ -Rcpp::List wrapGraph(EssentialGraph graph) -{ - Rcpp::List result; - Rcpp::IntegerVector vecEdges; - std::set edges; - std::set::iterator si; - - for (uint i = 0; i < graph.getVertexCount(); ++i) { - edges = graph.getInEdges(i); - vecEdges = Rcpp::IntegerVector(); - for (si = edges.begin(); si != edges.end(); ++si) - vecEdges.push_back(*si + 1); - result.push_back(vecEdges); - } - - return result; -} - /** * Yields the local score of a vertex given its parents. * @@ -134,6 +97,7 @@ RcppExport SEXP globalScore( // Calculate local score double result = score->global(castGraph(argInEdges)); + // TODO: check why this leads to a segfault!!!! delete score; return Rcpp::wrap(result); @@ -206,7 +170,7 @@ RcppExport SEXP globalMLE( TargetFamily targets = castTargets(data["targets"]); Score* score = createScore(Rcpp::as(argScore), &targets, data); - // Calculate local score + // Calculate global score std::vector > result = score->globalMLE(castGraph(argInEdges)); delete score; return Rcpp::wrap(result); @@ -247,27 +211,28 @@ RcppExport SEXP causalInference( uint p = graph.getVertexCount(); // Cast list of targets - dout.level(1) << "Casting list of targets...\n"; + dout.level(1) << "Casting options...\n"; + dout.level(2) << " Casting list of targets...\n"; Rcpp::List data(argPreprocData); TargetFamily targets = castTargets(data["targets"]); // Cast algorithm string - dout.level(1) << "Casting algorithm and options...\n"; + dout.level(2) << " Casting algorithm and options...\n"; std::string algName = Rcpp::as(argAlgorithm); - // TODO: cast score type, allow for C++ scoring objects - // Up to now, only R functions are allowed for scoring... - dout.level(1) << "Casting score...\n"; + // Cast score + dout.level(2) << " Casting score...\n"; Score* score = createScore(Rcpp::as(argScore), &targets, data); graph.setScore(score); graph.setTargets(&targets); std::vector steps; - uint i, j; + std::vector stepNames; + std::stringstream ss; // Cast option for limits in vertex degree - dout.level(1) << "Casting maximum vertex degree...\n"; + dout.level(2) << " Casting maximum vertex degree...\n"; Rcpp::NumericVector maxDegree((SEXP)(options["maxDegree"])); if (maxDegree.size() > 0) { if (maxDegree.size() == 1) { @@ -286,6 +251,21 @@ RcppExport SEXP causalInference( } } + // Cast option for required phases + dout.level(2) << " Casting phases...\n"; + std::vector< std::string > optPhases = Rcpp::as< std::vector >(options["phase"]); + std::vector< step_dir > phases(optPhases.size(), SD_FORWARD); + for (uint i = 0; i < optPhases.size(); ++i) { + if (optPhases[i] == "backward") { + phases[i] = SD_BACKWARD; + } + else if (optPhases[i] == "turning") { + phases[i] = SD_TURNING; + } + } + dout.level(2) << " Casting iterative...\n"; + bool doIterate = Rcpp::as(options["iterate"]); + // Cast option for vertices which are not allowed to have parents // TODO: activate function in R, and check for conversion from R to C indexing convention std::vector childrenOnly = Rcpp::as< std::vector >(options["childrenOnly"]); @@ -294,23 +274,36 @@ RcppExport SEXP causalInference( int stepLimit; // Cast option for fixed gaps: logical matrix, assumed to be symmetric by now + dout.level(2) << " Casting fixed gaps...\n"; if (!Rf_isNull(options["fixedGaps"])) { Rcpp::LogicalMatrix gapsMatrix((SEXP)(options["fixedGaps"])); uint n_gaps = 0; - for (i = 0; i < p; ++i) - for (j = i + 1; j < p; ++j) + for (int i = 0; i < p; ++i) + for (int j = i + 1; j < p; ++j) if (gapsMatrix(i, j)) n_gaps++; // Invert gaps if more than half of the possible edges are fixed gaps bool gapsInverted = 4*n_gaps > p*(p - 1); EssentialGraph fixedGaps(p); - for (i = 0; i < p; ++i) - for (j = i + 1; j < p; ++j) + for (int i = 0; i < p; ++i) + for (int j = i + 1; j < p; ++j) if (gapsMatrix(i, j) ^ gapsInverted) fixedGaps.addEdge(i, j, true); graph.setFixedGaps(fixedGaps, gapsInverted); } + // Cast option for adaptive handling of fixed gaps (cf. "ARGES") + dout.level(2) << " Casting adaptive flag...\n"; + ForwardAdaptiveFlag adaptive(NONE); + std::string optAdaptive = options["adaptive"]; + dout.level(2) << "Option 'adaptive': " << optAdaptive << std::endl; + if (optAdaptive == "vstructures") { + adaptive = VSTRUCTURES; + } + if (optAdaptive == "triples") { + adaptive = TRIPLES; + } + // Perform inference algorithm: // GIES if (algName == "GIES") { @@ -320,24 +313,24 @@ RcppExport SEXP causalInference( if (Rcpp::as(options["caching"])) graph.enableCaching(); - // Perform a greedy search, with or without turning phase - // TODO: evtl. zusätzlichen Parameter einfügen, der wiederholtes Suchen - // auch ohne Drehphase erlaubt... - if (Rcpp::as(options["turning"])) { - bool cont; - do { - cont = false; - for (steps.push_back(0); graph.greedyForward(); steps.back()++); - for (steps.push_back(0); graph.greedyBackward(); steps.back()++) - cont = true; - for (steps.push_back(0); graph.greedyTurn(); steps.back()++) + // Perform a greedy search with the requested phases, either iteratively or only once + bool cont; + int phaseCount(1); + do { + cont = false; + for (int i = 0; i < phases.size(); ++i) { + for (steps.push_back(0); + graph.greedyStepDir(phases[i], adaptive); + steps.back()++) { cont = true; - } while (cont); - } - else { - for (steps.push_back(0); graph.greedyForward(); steps.back()++); - for (steps.push_back(0); graph.greedyBackward(); steps.back()++); - } + } + ss.str(std::string()); + ss << optPhases[i] << phaseCount; + stepNames.push_back(ss.str()); + } + cont &= doIterate; + phaseCount++; + } while (cont); } // Single phase or step of GIES @@ -354,12 +347,18 @@ RcppExport SEXP causalInference( graph.enableCaching(); steps.push_back(0); - if (algName == "GIES-F") - for (; steps.back() < stepLimit && graph.greedyForward(); steps.back()++); - else if (algName == "GIES-B") + if (algName == "GIES-F") { + for (; steps.back() < stepLimit && graph.greedyForward(adaptive); steps.back()++); + stepNames.push_back("forward1"); + } + else if (algName == "GIES-B") { for (; steps.back() < stepLimit && graph.greedyBackward(); steps.back()++); - else if (algName == "GIES-T") + stepNames.push_back("backward1"); + } + else if (algName == "GIES-T") { for (; steps.back() < stepLimit && graph.greedyTurn(); steps.back()++); + stepNames.push_back("turning1"); + } } // Single one or several steps of GIES into either direction @@ -371,46 +370,65 @@ RcppExport SEXP causalInference( if (stepLimit == 0) stepLimit = graph.getVertexCount()*graph.getVertexCount(); - // TODO: evtl. steps so ändern, dass man daraus ablesen kann, in welcher - // Reihenfolge die einzelnen Phasen ausgeführt wurden // Steps: 3 entries, storing number of forward, backward, and turning steps - steps.resize(3, 0); - step_dir dir = SD_NONE; + step_dir dir(SD_NONE), lastDir(SD_NONE); + std::vector stepCount(4); do { dir = graph.greedyStep(); - if (dir != SD_NONE) - steps[dir - 1]++; - } while (steps[0] + steps[1] + steps[2] < stepLimit && dir != SD_NONE); + if (dir != SD_NONE) { + if (dir != lastDir) { + steps.push_back(1); + stepCount[0]++; + ss.str(std::string()); + switch(dir) { + case SD_FORWARD: + ss << "forward"; + break; + + case SD_BACKWARD: + ss << "backward"; + break; + + case SD_TURNING: + ss << "turning"; + break; + } + ss << stepCount[dir]++; + stepNames.push_back(ss.str()); + } // IF dir + else { + steps.back()++; + } + } // IF dir + } while (stepCount[0] < stepLimit && dir != SD_NONE); } - // GDS + // GDS; yields a DAG, not an equivalence class! else if (algName == "GDS") { - // TODO: evtl. caching für GDS implementieren... - // Perform a greedy search, with or without turning phase - if (Rcpp::as(options["turning"])) { - bool cont; - do { - cont = false; - for (steps.push_back(0); graph.greedyDAGForward(); steps.back()++); - for (steps.push_back(0); graph.greedyDAGBackward(); steps.back()++) - cont = true; - for (steps.push_back(0); graph.greedyDAGTurn(); steps.back()++) + // Perform a greedy search with the requested phases, either iteratively or only once + bool cont; + int phaseCount(1); + do { + cont = false; + for (int i = 0; i < phases.size(); ++i) { + for (steps.push_back(0); + graph.greedyDAGStepDir(phases[i]); + steps.back()++) { cont = true; - } while (cont); - } - else { - for (steps.push_back(0); graph.greedyDAGForward(); steps.back()++); - for (steps.push_back(0); graph.greedyDAGBackward(); steps.back()++); - } - - // Construct equivalence class - graph.replaceUnprotected(); + } + ss.str(std::string()); + ss << optPhases[i] << phaseCount; + stepNames.push_back(ss.str()); + } + cont &= doIterate; + phaseCount++; + } while (cont); } - // DP + // DP; yields a DAG, not an equivalence class! else if (algName == "SiMy") { graph.siMySearch(); - graph.replaceUnprotected(); + // graph.replaceUnprotected(); } // Other algorithm: throw an error @@ -418,11 +436,14 @@ RcppExport SEXP causalInference( // Return new list of in-edges and steps delete score; + Rcpp::IntegerVector namedSteps(steps.begin(), steps.end()); + namedSteps.names() = stepNames; + // TODO "interrupt" zurückgeben, falls Ausführung unterbrochen wurde. Problem: // check_interrupt() scheint nur einmal true zurückzugeben... return Rcpp::List::create( Rcpp::Named("in.edges") = wrapGraph(graph), - Rcpp::Named("steps") = steps); + Rcpp::Named("steps") = namedSteps); END_RCPP } @@ -460,6 +481,7 @@ RcppExport SEXP dagToEssentialGraph(SEXP argGraph, SEXP argTargets) END_RCPP } + RcppExport SEXP optimalTarget(SEXP argGraph, SEXP argMaxSize) { // Initialize automatic exception handling; manual one does not work any more... @@ -474,7 +496,8 @@ RcppExport SEXP optimalTarget(SEXP argGraph, SEXP argMaxSize) // Adapt numbering convention... std::vector result(target.begin(), target.end()); - std::for_each(result.begin(), result.end(), _1++); + for (std::vector::iterator vi = result.begin(); vi != result.end(); ++vi) + (*vi)--; return Rcpp::wrap(result); END_RCPP @@ -509,7 +532,6 @@ RcppExport SEXP condIndTestGauss( END_RCPP } - /** * Perform undirected version of PC algorithm, i.e., estimate skeleton of DAG * given data @@ -531,8 +553,6 @@ RcppExport SEXP estimateSkeleton( Rcpp::List options(argOptions); dout.setLevel(Rcpp::as(options["verbose"])); - int i, j; - dout.level(1) << "Casting arguments...\n"; // Cast sufficient statistic and significance level @@ -553,14 +573,22 @@ RcppExport SEXP estimateSkeleton( // Invalid independence test name: throw error else throw std::runtime_error(indepTestName + ": Invalid independence test name"); + // Initialize OpenMP + #ifdef _OPENMP + int threads = Rcpp::as(options["numCores"]); + if (threads < 0) + threads = omp_get_num_procs(); + omp_set_num_threads(threads); + #endif + // Create list of lists for separation sets Rcpp::LogicalMatrix adjMatrix(argAdjMatrix); int p = adjMatrix.nrow(); SepSets sepSet(p, std::vector(p, arma::ivec(1))); - for (i = 0; i < p; ++i) - for (j = 0; j < p; ++j) + for (int i = 0; i < p; ++i) + for (int j = 0; j < p; ++j) sepSet[i][j].fill(-1); - // TODO to save space, only create a triangular list only + // TODO to save space, create a triangular list only // Cast graph and fixed edges dout.level(2) << "Casting graph and fixed edges...\n"; @@ -570,20 +598,29 @@ RcppExport SEXP estimateSkeleton( pMax.fill(-1.); std::vector emptySet; std::vector edgeTests(1); - for (i = 0; i < p; i++) - for (j = i + 1; j < p; j++) { + for (int i = 0; i < p; i++) { + #pragma omp parallel for + for (int j = i + 1; j < p; j++) { + if (adjMatrix(i, j) && !fixedMatrix(i, j)) { + pMax(i, j) = indepTest->test(i, j, emptySet); + if (pMax(i, j) >= alpha) + sepSet[j][i].set_size(0); + dout.level(1) << " x = " << i << ", y = " << j << ", S = () : pval = " + << pMax(i, j) << std::endl; + } + } + } + for (int i = 0; i < p; i++) { + for (int j = i + 1; j < p; j++) { if (fixedMatrix(i, j)) graph.addFixedEdge(i, j); else if (adjMatrix(i, j)) { - pMax(i, j) = indepTest->test(i, j, emptySet); edgeTests[0]++; - dout.level(1) << " x = " << i << ", y = " << j << ", S = () : pval = " << pMax(i, j) << std::endl; if (pMax(i, j) < alpha) graph.addEdge(i, j); - else - sepSet[j][i].set_size(0); } } + } // Estimate skeleton graph.setIndepTest(indepTest); diff --git a/src/greedy.cpp b/src/greedy.cpp index 1ea7f22..7da6867 100644 --- a/src/greedy.cpp +++ b/src/greedy.cpp @@ -2,7 +2,7 @@ * greedy.cpp * * @author Alain Hauser - * $Id: greedy.cpp 282 2015-02-27 19:06:37Z alhauser $ + * $Id: greedy.cpp 397 2016-09-21 06:08:24Z alhauser $ */ #include "pcalg/greedy.hpp" @@ -19,7 +19,8 @@ EssentialGraph::EssentialGraph(const uint vertexCount) : _fixedGaps(vertexCount), _gapsInverted(false), _maxVertexDegree(vertexCount, vertexCount), - _childrenOnly(vertexCount) + _childrenOnly(vertexCount), + _loggers() { disableCaching(); } @@ -28,6 +29,7 @@ double EssentialGraph::_minScoreDiff = sqrt(std::numeric_limits::epsilon void EssentialGraph::clear() { + // Clear graph boost::graph_traits::edge_iterator ei, ei_end, next; boost::tie(ei, ei_end) = boost::edges(_graph); for (next = ei; ei != ei_end; ei = next) { @@ -38,16 +40,44 @@ void EssentialGraph::clear() void EssentialGraph::addEdge(const uint a, const uint b, bool undirected) { - boost::add_edge(a, b, _graph); - if (undirected) + if (!hasEdge(a, b)) { + // Add edge and log it + boost::add_edge(a, b, _graph); + for (std::set::iterator logger = _loggers.begin(); + logger != _loggers.end(); ++logger) { + (*logger)->log(GO_ADD_EDGE, a, b); + } + } + + if (undirected && !hasEdge(b, a)) { + // Add edge and log it boost::add_edge(b, a, _graph); + for (std::set::iterator logger = _loggers.begin(); + logger != _loggers.end(); ++logger) { + (*logger)->log(GO_ADD_EDGE, b, a); + } + } } void EssentialGraph::removeEdge(const uint a, const uint b, bool bothDirections) { - boost::remove_edge(a, b, _graph); - if (bothDirections) + if (hasEdge(a, b)) { + // Remove edge and log it + boost::remove_edge(a, b, _graph); + for (std::set::iterator logger = _loggers.begin(); + logger != _loggers.end(); ++logger) { + (*logger)->log(GO_REMOVE_EDGE, a, b); + } + } + + if (bothDirections && hasEdge(b, a)) { + // Remove edge and log it boost::remove_edge(b, a, _graph); + for (std::set::iterator logger = _loggers.begin(); + logger != _loggers.end(); ++logger) { + (*logger)->log(GO_REMOVE_EDGE, b, a); + } + } } bool EssentialGraph::gapFixed(const uint a, const uint b) const @@ -57,6 +87,15 @@ bool EssentialGraph::gapFixed(const uint a, const uint b) const return result ^ _gapsInverted; } +void EssentialGraph::setFixedGap(const uint a, const uint b, const bool fixed) +{ + if (fixed ^ _gapsInverted) { + boost::add_edge(a, b, _fixedGaps); + } else { + boost::remove_edge(a, b, _fixedGaps); + } +} + bool EssentialGraph::existsPath(const uint a, const uint b, const std::set& C, const bool undirected) { // Mark "forbidden" vertices as visited @@ -288,6 +327,7 @@ void EssentialGraph::setFixedGaps(const EssentialGraph& fixedGaps, const bool in _gapsInverted = inverted; } + void EssentialGraph::limitVertexDegree(const std::vector& maxVertexDegree) { if (maxVertexDegree.size() != getVertexCount()) @@ -444,6 +484,18 @@ std::set EssentialGraph::getChainComponent(const uint v) const return chainComp; } +bool EssentialGraph::addLogger(GraphOperationLogger* logger) +{ + bool result; + boost::tie(boost::tuples::ignore, result) = _loggers.insert(logger); + return result; +} + +bool EssentialGraph::removeLogger(GraphOperationLogger* logger) +{ + return _loggers.erase(logger) == 0; +} + ArrowChange EssentialGraph::getOptimalArrowInsertion(const uint v) { // For DEBUGGING purposes: print vertex being processed @@ -459,53 +511,47 @@ ArrowChange EssentialGraph::getOptimalArrowInsertion(const uint v) else result.score = _minScoreDiff; - std::set C, C_par, C_sub, N; - std::set neighbors, parents, adjacent; - std::vector > maxCliques; - std::set::iterator si; - uint u; double diffScore; - CliqueStack cliqueStack; - boost::dynamic_bitset<> posterior, forbidden; boost::unordered_map, double > localScore; boost::unordered_map, double >::iterator hmi; // Find maximal cliques in the neighborhood of v - neighbors = getNeighbors(v); - maxCliques = getMaxCliques(neighbors.begin(), neighbors.end()); + std::set neighbors = getNeighbors(v); + std::vector > maxCliques = getMaxCliques(neighbors.begin(), neighbors.end()); // Get parents of v (used for calculation of partial scores later on) - parents = getParents(v); + std::set parents = getParents(v); // Exclude forbidden sources: // - vertices reachable from children of v - forbidden = getPosteriorSet(getChildren(v)); + boost::dynamic_bitset<> forbidden = getPosteriorSet(getChildren(v)); // - vertices adjacent to v - adjacent = getAdjacent(v); - for (si = adjacent.begin(); si != adjacent.end(); ++si) + std::set tempSet = getAdjacent(v); + for (std::set::iterator si = tempSet.begin(); si != tempSet.end(); ++si) forbidden.set(*si); // - v itself :-) forbidden.set(v); // - vertices which have reached the maximum degree, or which have a fixed // gap to v - for (u = 0; u < getVertexCount(); ++u) + for (uint u = 0; u < getVertexCount(); ++u) if (getDegree(u) >= _maxVertexDegree[u] || gapFixed(u, v)) forbidden.set(u); // Calculate vertices not reachable from v: for those, the "path condition" // for the clique C does not have to be checked later - C.insert(v); - posterior = getPosteriorSet(C); + tempSet = std::set(); + tempSet.insert(v); + boost::dynamic_bitset<> posterior = getPosteriorSet(tempSet); - for (u = 0; u < getVertexCount(); ++u) + for (uint u = 0; u < getVertexCount(); ++u) if (!forbidden[u]) { // Calculate ne(v) \cap ad(u) - N = set_intersection(neighbors, getAdjacent(u)); + std::set N = set_intersection(neighbors, getAdjacent(u)); // Add N as a set to check, and at the same time as a stop set. // Actually, N will be checked _only_ if it is a clique, i.e. subset // of a maximal clique - cliqueStack.clear_all(); + CliqueStack cliqueStack; cliqueStack.push_back(N); cliqueStack.stop_sets.insert(N); @@ -515,7 +561,7 @@ ArrowChange EssentialGraph::getOptimalArrowInsertion(const uint v) // Check all subsets of the actual maximal clique cliqueStack.append(maxCliques[i]); while(!cliqueStack.empty()) { - C = cliqueStack.back(); + std::set C = cliqueStack.back(); cliqueStack.pop_back(); // Check whether there is a v-u-path that does not go through C @@ -525,7 +571,7 @@ ArrowChange EssentialGraph::getOptimalArrowInsertion(const uint v) // submatrices), local should return NaN; then the // test below fails // Use "localScore" as (additional) cache - C_par = set_union(C, parents); + std::set C_par = set_union(C, parents); hmi = localScore.find(C_par); if (hmi == localScore.end()) { dout.level(3) << "calculating partial score for vertex " << v << ", parents " << C_par << "...\n"; @@ -549,8 +595,8 @@ ArrowChange EssentialGraph::getOptimalArrowInsertion(const uint v) } // Add all subsets of C that differ from C in only one vertex to the stack - for (si = C.begin(); si != C.end(); ++si) { - C_sub = C; + for (std::set::iterator si = C.begin(); si != C.end(); ++si) { + std::set C_sub = C; C_sub.erase(*si); cliqueStack.append(C_sub); } @@ -942,6 +988,8 @@ std::set EssentialGraph::replaceUnprotected() // of an unprotected arrow std::set result; + dout.level(2) << " replacing unprotected arrows...\n"; + Edge edge; // Find all arrows in the graph. Mark them as "protected", if they are @@ -977,7 +1025,14 @@ std::set EssentialGraph::replaceUnprotected() // Successively check all undecidable arrows, until no one remains std::set::iterator undIter; edge_flag flag; - while (!undecidableArrows.empty()) { + // If the graph is in a valid state in the beginning, the following loop + // finally flags all undecidable arrows as protected or unprotected. In + // case the graph is in an invalid state in the beginning, it might happen + // that the loop does not terminate; to avoid this, we also check that the + // loop indeed labels undecidable arrows (as PROTECTED or NOT_PROTECTED) in + // every run, and throw an error otherwise. + int labeledArrows = 1; + while (!undecidableArrows.empty() && labeledArrows > 0) { // Find unprotected and protected arrows for (undIter = undecidableArrows.begin(); undIter != undecidableArrows.end(); undIter++) { edge = *undIter; @@ -1014,35 +1069,33 @@ std::set EssentialGraph::replaceUnprotected() } // Replace unprotected arrows by lines; store affected edges in result set + labeledArrows = undecidableArrows.size(); for (arrIter1 = arrowFlags.begin(); arrIter1 != arrowFlags.end(); ) { arrIter2 = arrIter1; arrIter1++; - if (arrIter2->second != UNDECIDABLE) + if (arrIter2->second != UNDECIDABLE) { undecidableArrows.erase(arrIter2->first); + } if (arrIter2->second == NOT_PROTECTED) { addEdge((arrIter2->first).target, (arrIter2->first).source); result.insert(arrIter2->first); arrowFlags.erase(arrIter2); } } + labeledArrows = labeledArrows - undecidableArrows.size(); + dout.level(3) << " Labeled " << labeledArrows << " undecidable arrows\n"; + } + + if (labeledArrows == 0 && !undecidableArrows.empty()) { + throw std::runtime_error("Invalid graph passed to replaceUnprotected()."); } + dout.level(2) << " Done.\n"; return result; } void EssentialGraph::insert(const uint u, const uint v, const std::set C) { - // Temporary variables for caching - std::set directed, undirected, diffSet; - std::set::iterator ei; - uint a; - std::set recalc, recalcAnt; - std::set::iterator si; - boost::dynamic_bitset<> refreshCache(getVertexCount()); - EssentialGraph oldGraph; - if (_doCaching) - oldGraph = *this; - // Get a LexBFS-ordering on the chain component of v, in which all edges of C // point toward v, and all other edges point away from v, and orient the edges // of the chain component accordingly @@ -1051,13 +1104,15 @@ void EssentialGraph::insert(const uint u, const uint v, const std::set C) startOrder.push_back(v); chainComp.erase(v); std::set_difference(chainComp.begin(), chainComp.end(), C.begin(), C.end(), std::inserter(startOrder, startOrder.end())); - lexBFS(startOrder.begin(), startOrder.end(), true, &directed); + lexBFS(startOrder.begin(), startOrder.end(), true); // Add new arrow addEdge(u, v); // Successively replace unprotected arrows by lines - undirected = replaceUnprotected(); + replaceUnprotected(); + + /* MOVED TO greedyForward() // If caching is enabled, recalculate the optimal arrow insertions where // necessary @@ -1110,6 +1165,7 @@ void EssentialGraph::insert(const uint u, const uint v, const std::set C) for (a = refreshCache.find_first(); a < getVertexCount(); a = refreshCache.find_next(a)) _scoreCache[a] = getOptimalArrowInsertion(a); } + */ } void EssentialGraph::remove(const uint u, const uint v, const std::set C) @@ -1171,15 +1227,15 @@ void EssentialGraph::turn(const uint u, const uint v, const std::set C) replaceUnprotected(); } -bool EssentialGraph::greedyForward() +bool EssentialGraph::greedyForward(const ForwardAdaptiveFlag adaptive) { uint v_opt = 0; - std::vector::iterator si; ArrowChangeCmp comp; ArrowChange insertion, optInsertion; // For DEBUGGING purposes: print phase - dout.level(1) << "== starting forward phase...\n"; + dout.level(1) << "== starting forward phase (" + << (adaptive ? "" : "not ") << "adaptive)...\n"; // Initialize optimal score gain optInsertion.score = _minScoreDiff; @@ -1207,7 +1263,7 @@ bool EssentialGraph::greedyForward() _scoreCache[v] = getOptimalArrowInsertion(v); // Find optimal arrow insertion from cache - si = std::max_element(_scoreCache.begin(), _scoreCache.end(), comp); + std::vector::iterator si = std::max_element(_scoreCache.begin(), _scoreCache.end(), comp); v_opt = std::distance(_scoreCache.begin(), si); optInsertion = *si; _actualPhase = SD_FORWARD; @@ -1218,10 +1274,109 @@ bool EssentialGraph::greedyForward() // For DEBUGGING purposes: print inserted arrow dout.level(1) << " inserting edge (" << optInsertion.source << ", " << v_opt << ") with C = " << optInsertion.clique << ", S = " << optInsertion.score << "\n"; - insert(optInsertion.source, v_opt, optInsertion.clique); -// #if DEBUG_OUTPUT_LEVEL >= 2 -// getAdjacencyMatrix().print("A = "); -// #endif + + uint u_opt = optInsertion.source; + EdgeOperationLogger edgeLogger; + if (_doCaching) { + addLogger(&edgeLogger); + } + insert(u_opt, v_opt, optInsertion.clique); + + // Adapt fixed gaps if requested (cf. "ARGES") + if (adaptive == VSTRUCTURES && !hasEdge(v_opt, u_opt)) { + std::set sources = set_difference(getParents(v_opt), getAdjacent(u_opt)); + sources.erase(u_opt); + for (std::set::iterator si = sources.begin(); si != sources.end(); ++si) { + setFixedGap(*si, u_opt, false); + setFixedGap(u_opt, *si, false); + } + } // IF VSTRUCTURES + else if (adaptive == TRIPLES) { + // Adjacent sets of u_opt and v_opt + std::vector< std::set > adjacentSets(2); + adjacentSets[0] = getAdjacent(u_opt); + adjacentSets[1] = getAdjacent(v_opt); + std::vector edgeVertices(2); + edgeVertices[0] = u_opt; + edgeVertices[1] = v_opt; + + // Vertices adjacent to u, but not to v (without v itself) (and vice versa) + // build new unshielded triples + std::set triples; + for (uint j = 0; j <= 1; j++) { + triples = set_difference(adjacentSets[j % 2], adjacentSets[(j + 1) % 2]); + triples.erase(edgeVertices[(j + 1) % 2]); + for (std::set::iterator si = triples.begin(); si != triples.end(); ++si) { + setFixedGap(*si, edgeVertices[(j + 1) % 2], false); + setFixedGap(edgeVertices[(j + 1) % 2], *si, false); + } // FOR si + } // FOR j + } // IF TRIPLES + + // If caching is enabled, recalculate the optimal arrow insertions where + // necessary + if (_doCaching) { + std::set recalc, recalcAnt; + + // Genereate set of vertices whose anterior set is the set of vertices + // whose cache has to be refreshed: + // u, if there was no path from u to v before + // TODO check conditions!!! + // if (!oldGraph.existsPath(u, v)) + recalcAnt.insert(u_opt); + recalc.insert(u_opt); + // v, if the arrow was undirected and there was no path from v to u before + // TODO check conditions!! + // if (hasEdge(v, u) && !oldGraph.existsPath(v, u)) + if (hasEdge(v_opt, u_opt)) + recalcAnt.insert(v_opt); + recalc.insert(v_opt); + // the target of any newly directed edge + for (std::set::iterator ei = edgeLogger.removedEdges().begin(); + ei != edgeLogger.removedEdges().end(); ++ei) { + dout.level(3) << "New directed edge: (" << ei-> source << ", " << ei->target << ")\n"; + recalcAnt.insert(ei->source); + recalc.insert(ei->target); + } + // the source of any newly undirected edge + for (std::set::iterator ei = edgeLogger.addedEdges().begin(); + ei != edgeLogger.addedEdges().end(); ++ei) { + // The newly inserted arrow is not a newly undirected one + // Thanks to Marco Eigenmann for reported a bug here. + if (ei->source != u_opt || ei->target != v_opt) { + dout.level(3) << "New undirected edge: (" << ei-> source << ", " << ei->target << ")\n"; + recalcAnt.insert(ei->target); + recalc.insert(ei->source); + } + } + + // Calculate anterior set of that candidate set, and add vertices that + // have to be recalculated without the complete anterior set + boost::dynamic_bitset<> refreshCache(getVertexCount()); + refreshCache = getAnteriorSet(recalcAnt); + for (std::set::iterator si = recalc.begin(); si != recalc.end(); ++si) + refreshCache.set(*si); + + // If v or u have reached the maximum degree, recalculate the optimal + // arrow insertion for all vertices for which an insertion with new + // parent u or v is proposed by the cache + if (getDegree(u_opt) >= _maxVertexDegree[u_opt]) + for (int a = 0; a < getVertexCount(); ++a) + if (_scoreCache[a].source == u_opt) + refreshCache.set(a); + if (getDegree(v_opt) >= _maxVertexDegree[v_opt]) + for (int a = 0; a < getVertexCount(); ++a) + if (_scoreCache[a].source == v_opt) + refreshCache.set(a); + + // Refresh cache: recalculate arrow insertions + for (int a = refreshCache.find_first(); a < getVertexCount(); a = refreshCache.find_next(a)) + _scoreCache[a] = getOptimalArrowInsertion(a); + + // Unregister logger + removeLogger(&edgeLogger); + } + return true; } else @@ -1311,6 +1466,23 @@ bool EssentialGraph::greedyTurn() return false; } +bool EssentialGraph::greedyStepDir(const step_dir direction, const ForwardAdaptiveFlag adaptive) +{ + switch (direction) { + case SD_FORWARD: + return greedyForward(adaptive); + + case SD_BACKWARD: + return greedyBackward(); + + case SD_TURNING: + return greedyTurn(); + + default: + return false; + } // SWITCH direction +} + step_dir EssentialGraph::greedyStep() { uint v_opt = 0; @@ -1526,6 +1698,24 @@ bool EssentialGraph::greedyDAGTurn() return false; } +bool EssentialGraph::greedyDAGStepDir(const step_dir direction) +{ + switch (direction) { + case SD_FORWARD: + return greedyDAGForward(); + + case SD_BACKWARD: + return greedyDAGBackward(); + + case SD_TURNING: + return greedyDAGTurn(); + + default: + return false; + } // SWITCH direction + +} + void EssentialGraph::siMySearch() { // Check whether DAG is not too large (practically, the algorithm will @@ -1631,3 +1821,38 @@ std::set EssentialGraph::getOptimalTarget(uint maxSize) else throw std::runtime_error("Optimal targets with size other than 1 or p are not supported."); } + +EssentialGraph castGraph(const SEXP argInEdges) +{ + Rcpp::List listInEdges(argInEdges); + EssentialGraph result(listInEdges.size()); + + for (R_len_t i = 0; i < listInEdges.size(); ++i) { + Rcpp::IntegerVector vecParents((SEXP)(listInEdges[i])); + // Adapt indices to C++ convention + for (Rcpp::IntegerVector::iterator vi = vecParents.begin(); vi != vecParents.end(); ++vi) + result.addEdge(*vi - 1, i); + } + + return result; +} + +Rcpp::List wrapGraph(const EssentialGraph& graph) +{ + Rcpp::List result; + Rcpp::IntegerVector vecEdges; + std::set edges; + + for (uint i = 0; i < graph.getVertexCount(); ++i) { + edges = graph.getInEdges(i); + Rcpp::IntegerVector vecEdges(edges.begin(), edges.end()); + // Adapt indices to R convention + for (R_len_t i = 0; i < vecEdges.size(); ++i) + vecEdges[i]++; + result.push_back(vecEdges); + } + + return result; +} + + diff --git a/src/score.cpp b/src/score.cpp index 3a83a71..e9b6a82 100644 --- a/src/score.cpp +++ b/src/score.cpp @@ -1,6 +1,6 @@ /* * @author Alain Hauser - * $Id: score.cpp 248 2014-03-03 11:27:22Z alhauser $ + * $Id: score.cpp 372 2015-11-13 15:59:58Z alhauser $ */ #include "pcalg/score.hpp" @@ -62,7 +62,7 @@ double Score::global(const EssentialGraph& dag) const return result; } -Score* createScore(std::string name, TargetFamily* targets, Rcpp::List data) +Score* createScore(std::string name, TargetFamily* targets, Rcpp::List& data) { Score* result; @@ -70,6 +70,8 @@ Score* createScore(std::string name, TargetFamily* targets, Rcpp::List data) if (name == "gauss.l0pen.scatter") result = new ScoreGaussL0PenScatter(Rcpp::as(data["vertex.count"]), targets); + else if (name == "gauss.l0pen.raw") + result = new ScoreGaussL0PenRaw(Rcpp::as(data["vertex.count"]), targets); else if (name == "none") result = new ScoreRFunction(Rcpp::as(data["vertex.count"]), targets); // Invalid score name: throw error @@ -90,8 +92,8 @@ void ScoreRFunction::setData(Rcpp::List& data) dout.level(2) << "Casting R functions to calculate the score...\n"; _rfunction.push_back(Rcpp::as(data["local.score"])); _rfunction.push_back(Rcpp::as(data["global.score"])); - _rfunction.push_back(Rcpp::as(data["local.mle"])); - _rfunction.push_back(Rcpp::as(data["global.mle"])); + _rfunction.push_back(Rcpp::as(data["local.fit"])); + _rfunction.push_back(Rcpp::as(data["global.fit"])); } double ScoreRFunction::local(const uint vertex, const std::set& parents) const @@ -298,3 +300,148 @@ std::vector< std::vector > ScoreGaussL0PenScatter::globalMLE(const Essen return result; } + +void ScoreGaussL0PenRaw::setData(Rcpp::List& data) +{ + // Cast preprocessed data from R list + dout.level(2) << "Casting preprocessed data...\n"; + _dataCount = Rcpp::as >(data["data.count"]); + dout.level(3) << "# samples per vertex: " << _dataCount << "\n"; + _totalDataCount = Rcpp::as(data["total.data.count"]); + dout.level(3) << "Total # samples: " << _totalDataCount << "\n"; + + // Cast raw data matrix + Rcpp::NumericMatrix dataMat((SEXP)(data["data"])); + _dataMat = arma::mat(dataMat.begin(), dataMat.nrow(), dataMat.ncol(), false); + + // Cast vectors of non-interventions, adjust R indexing convention to C++ + _nonInt = Rcpp::as >(data["non.int"]); + for (std::vector::iterator ni = _nonInt.begin(); ni != _nonInt.end(); ++ni) + for (std::size_t j = 0; j < ni->n_elem; ++j) + (*ni)(j)--; + + // Cast lambda: penalty constant + _lambda = Rcpp::as(data["lambda"]); + dout.level(3) << "Penalty parameter lambda: " << _lambda << "\n"; + + // Check whether an intercept should be calculated + _allowIntercept = Rcpp::as(data["intercept"]); + dout.level(3) << "Include intercept: " << _allowIntercept << "\n"; +} + +double ScoreGaussL0PenRaw::local(const uint vertex, const std::set& parents) const +{ + dout.level(3) << "Calculating local score...\n"; + + // Cast parents set to Armadillo uvec + arma::uvec parVec(_allowIntercept ? parents.size() + 1 : parents.size()); + std::copy(parents.begin(), parents.end(), parVec.begin()); + arma::uvec vVec(1); + vVec[0] = vertex; + + // If intercept is allowed, add "fake parent" taking care of intercept + if (_allowIntercept) + parVec[parents.size()] = 0; + dout.level(3) << "Vertex: " << vertex << "; parents (adjusted acc. to interc.): " << parVec << "\n"; + + // Response vector for linear regression + arma::colvec Y(_dataMat.submat(_nonInt[vertex], vVec)); + double a = arma::accu(Y % Y); + + // Calculate value in the logarithm of maximum likelihood + if (parVec.size()) { + arma::mat Q, R, Z; + + // Matrix for linear regression + Z = _dataMat.submat(_nonInt[vertex], parVec); + if (_allowIntercept) + Z.col(Z.n_cols - 1).fill(1.); + + // QR decomposition + if (!arma::qr_econ(Q, R, Z)) + return std::numeric_limits::quiet_NaN(); + + // Adjust scaled covariance + a -= pow(arma::norm(Y.t() * Q, 2), 2); + } + + // Finish calculation of partial BIC score + return -0.5*(1. + log(a/_dataCount[vertex]))*_dataCount[vertex] - _lambda*(1. + parents.size()); +} + +double ScoreGaussL0PenRaw::global(const EssentialGraph& dag) const +{ + double result = 0.; + uint v; + + // L0-penalized score is decomposable => calculate sum of local scores + for (v = 0; v < dag.getVertexCount(); ++v) + result += local(v, dag.getParents(v)); + + return result; +} + +std::vector ScoreGaussL0PenRaw::localMLE(const uint vertex, const std::set& parents) const +{ + dout.level(3) << "Calculating local MLE...\n"; + + // Get parents, copy them to Armadillo vector + arma::uvec parVec(_allowIntercept ? parents.size() + 1 : parents.size()); + std::copy(parents.begin(), parents.end(), parVec.begin() + (int)_allowIntercept); + if (_allowIntercept) + parVec[0] = 0; + arma::uvec vVec(1); + vVec[0] = vertex; + dout.level(3) << "Vertex: " << vertex << "; parents (adjusted acc. to interc.): " << parVec << "\n"; + + // Response vector for linear regression + arma::colvec Y(_dataMat.submat(_nonInt[vertex], vVec)); + + // Initialize parameter for variance + std::vector result(parents.size() + 2); + result[0] = arma::accu(Y % Y) / _dataCount[vertex]; + + // Calculate regression coefficients + if (parVec.size()) { + arma::mat Q, R, Z; + arma::colvec b, c; + + // Matrix for linear regression + Z = _dataMat.submat(_nonInt[vertex], parVec); + if (_allowIntercept) + Z.col(0).fill(1.); + + // Calculate QR decomposition and regression coefficients + if (!arma::qr_econ(Q, R, Z) || + !arma::solve(c, arma::trimatl(R.t()), Z.t() * Y) || + !arma::solve(b, arma::trimatu(R), c)) { + std::fill(result.begin(), result.end(), std::numeric_limits::quiet_NaN()); + return result; + } + + // Correct error variance + result[0] -= pow(arma::norm(Y.t() * Q, 2), 2) / _dataCount[vertex]; + + // If no intercept was calculated, store intercept 0 + if (_allowIntercept) + result[1] = 0.; + + // Copy coefficients to result vector + std::copy(b.begin(), b.end(), result.begin() + 2 - (int)_allowIntercept); + } + + dout.level(3) << "Local MLE: " << result << "\n"; + + return result; +} + +std::vector< std::vector > ScoreGaussL0PenRaw::globalMLE(const EssentialGraph& dag) const +{ + // Calculate local MLE for all vertices + std::vector< std::vector > result(_vertexCount); + uint v; + for (v = 0; v < dag.getVertexCount(); ++v) + result[v] = localMLE(v, dag.getParents(v)); + + return result; +} diff --git a/tests/gacData.rda b/tests/gacData.rda deleted file mode 100644 index d138c0e..0000000 Binary files a/tests/gacData.rda and /dev/null differ diff --git a/tests/test_LINGAM.R b/tests/test_LINGAM.R index c9a7e5a..5656a9c 100644 --- a/tests/test_LINGAM.R +++ b/tests/test_LINGAM.R @@ -29,7 +29,8 @@ X <- cbind(A = eps1 + 0.9*eps2, estDAG <- LINGAM(X, verbose = TRUE) -stopifnot(as.integer(estDAG$ Adj) == trueDAG, +stopifnot(identical(estDAG, LINGAM(X)), + as.integer(estDAG$ Adj) == trueDAG, all.equal (estDAG$ B, cbind(0, c(0.878188262685122, 0)))) if(doExtras) { @@ -152,7 +153,7 @@ estB.3 <- rbind( c(., ., ., ., 0.774490692, -0.886143314, ., .), c(., ., ., ., ., ., 0.900617843, .)) -eDAG3 <- LINGAM(X, verbose = TRUE) +eDAG3 <- LINGAM(X, verbose = 2) stopifnot(trDAG3 == eDAG3$Adj, with(eDAG3, all(t(B != 0) == Adj)), diff --git a/tests/test_arges.R b/tests/test_arges.R new file mode 100644 index 0000000..4ae337e --- /dev/null +++ b/tests/test_arges.R @@ -0,0 +1,90 @@ +####' Tests adaptive versions of GES (ARGES and ARGES-skeleton) +####' +####' @author Alain Hauser +####' $Id: test_arges.R 393 2016-08-20 09:43:47Z alhauser $ + +cat("Testing adaptive versions of GES:\n") + +library(pcalg) +library(graph) + +## Test with DAG of 3 vertices + +# Create DAG with 3 vertices a shielded v-structure (A --> B <-- C, A --> C). +# The edge weight of A --> C should be smaller than the others. +# Only allowing edges between A and B and B and C at the beginning, +# we can check whether ARGES also allows an edge between A and C in the +# end. +dag <- new("GaussParDAG", + nodes = as.character(1:3), + in.edges = list(integer(0), c(1, 3), 1), + params = list(c(0.8, 0), c(0.2, 0, 0.7, 1.2), c(0.6, 0, 0.1))) +cpdag <- dag2cpdag(dag) +adjMat <- as(cpdag, "matrix") + +# Simulate data +n <- 5000 +set.seed(307) +X <- rmvnorm.ivent(n, dag) + +# Create a score object +score <- new("GaussL0penObsScore", X) + +# Estimate DAG without restriction +ges.fit <- ges(score) +stopifnot(all.equal(adjMat, as(ges.fit$essgraph, "matrix"))) + +# Test old calling convention of GES +warningIssued <- FALSE +tryCatch(ges.fit <- ges(3, score), + warning = function(w) warningIssued <<- TRUE) +stopifnot(warningIssued) + +# Force a gap between vertices 1 and 3 +fixedGaps <- matrix(FALSE, 3, 3) +fixedGaps[1, 3] <- fixedGaps[3, 1] <- TRUE +ges.fit <- ges(score, fixedGaps = fixedGaps) +adjMat <- matrix(FALSE, 3, 3) +adjMat[1, 2] <- adjMat[3, 2] <- TRUE +stopifnot(all.equal(adjMat, as(ges.fit$essgraph, "matrix"))) + +# Test ARGES (adaptive = 'vstructures') +arges.fit <- ges(score, fixedGaps = fixedGaps, adaptive = "vstructures") +adjMat <- as(cpdag, "matrix") +stopifnot(all.equal(adjMat, as(arges.fit$essgraph, "matrix"))) + +# Checking ARGES-skeleton (adaptive = 'triples') +# Create a new DAG of the form A --> B --> C, A --> C, where the edge weight +# of A --> C is weaker than the other edge weights +dag <- new("GaussParDAG", + nodes = as.character(1:3), + in.edges = list(integer(0), 1, 1:2), + params = list(c(0.8, 0), c(0.4, 0, 0.7), c(0.4, 0, 0.1, 0.6))) +cpdag <- dag2cpdag(dag) +adjMat <- as(cpdag, "matrix") + +# Simulate data +set.seed(307) +X <- rmvnorm.ivent(n, dag) + +# Make score object +score <- new("GaussL0penObsScore", X) + +# Fitting with a restriction (forbid edge A -- C) +fixedGaps <- matrix(FALSE, 3, 3) +fixedGaps[1, 3] <- fixedGaps[3, 1] <- TRUE + +ges.fit <- ges(score, fixedGaps = fixedGaps) +adjMat[1, 3] <- adjMat[3, 1] <- FALSE +stopifnot(all.equal(adjMat, as(ges.fit$essgraph, "matrix"))) + +# Test ARGES +arges.fit <- ges(score, fixedGaps = fixedGaps, adaptive = "vstructures") +stopifnot(all.equal(adjMat, as(arges.fit$essgraph, "matrix"))) + +# Test ARGES-skeleton: should reproduce perfect fit +arges.fit <- ges(score, fixedGaps = fixedGaps, adaptive = "triples") +adjMat <- as(cpdag, "matrix") +stopifnot(all.equal(adjMat, as(arges.fit$essgraph, "matrix"))) + +cat("Done.\n") diff --git a/tests/test_bicscore.R b/tests/test_bicscore.R index f04e86e..86f99f8 100644 --- a/tests/test_bicscore.R +++ b/tests/test_bicscore.R @@ -1,9 +1,10 @@ -#' Tests the calculation of BIC and MLE +#' Tests the calculation of BIC and MLE, as well as basic functions +#' the corresponding score class #' #' @author Alain Hauser -#' $Id: test_bicscore.R 224 2014-02-06 14:23:53Z alhauser $ +#' $Id: test_bicscore.R 393 2016-08-20 09:43:47Z alhauser $ -cat("Testing the calculation of the BIC score... ") +cat("Testing the calculation of the BIC score...\n") library(pcalg) @@ -12,42 +13,154 @@ load("test_bicscore.rda") # in directory tests/ i.e., typically *not* installed ## Tolerance for numerical comparison tol <- sqrt(.Machine$double.eps) -for (cpp in c(FALSE, TRUE)) { - score <- new("GaussL0penIntScore", - targets = gauss.targets, - target.index = gauss.target.index, - data = gauss.data, - use.cpp = cpp) - - # print(score$pp.dat) - - if (any(score$pp.dat$data.count != 1000)) - stop("The number of non-interventions are not calculated correctly.") - - if (any(score$pp.dat$scatter.index != 1:5)) - stop("The indices of the scatter matrices are not calculated correctly.") +## Define all test settings +settings <- expand.grid( + format = c("scatter", "raw"), + cpp = c(FALSE, TRUE), + stringsAsFactors = FALSE) +nreps <- 5 - for (i in 1:5) - if (!isTRUE(all.equal(score$pp.dat$scatter[[score$pp.dat$scatter.index[i]]][1:5, 1:5], - gauss.scatter[[i]], - tolerance = tol))) - stop("The scatter matrices are not calculated correctly.") - - for (i in 1:5) - if (!isTRUE(all.equal(gauss.loc.score[[i]], - score$local.score(i, gauss.parents[[i]]), - tolerance = tol))) - stop("The local score is not calculated correctly.") +## Check data storage and calculation of scores +for (m in 1:nrow(settings)) { + cat(sprintf("Setting: storage format = %s, C++ library = %s\n", + settings$format[m], settings$cpp[m])) + + for (i in 1:nreps) { + perm <- 1:nrow(gauss.data) + + ## Randomly permute data + if (i > 1) { + set.seed(i) + perm <- sample(perm) + } + + ## Create the score object with valid data + score <- new("GaussL0penIntScore", + targets = gauss.targets, + target.index = gauss.target.index[perm], + data = gauss.data[perm, ], + format = settings$format[m], + use.cpp = settings$cpp[m], + intercept = FALSE) + + # print(score$pp.dat) - # print(lapply(1:5, function(i) score$local.mle(i, gauss.parents[[i]], DEBUG.LEVEL = 3))) + if (any(score$pp.dat$data.count != 1000)) { + stop("The number of non-interventions are not calculated correctly.") + } - for (i in 1:5) { - local.mle <- score$local.mle(i, gauss.parents[[i]]) - if (length(local.mle) != length(gauss.mle[[i]]) || - !isTRUE(all.equal(gauss.mle[[i]], local.mle, - tolerance = tol))) - stop("The local MLE is not calculated correctly.") + if (settings$format[m] == "scatter") { + if (any(score$pp.dat$scatter.index != 1:5)) { + stop("The indices of the scatter matrices are not calculated correctly.") + } + + for (j in 1:5) { + if (!isTRUE(all.equal(score$pp.dat$scatter[[score$pp.dat$scatter.index[j]]][1:5, 1:5], + gauss.scatter[[j]], + tolerance = tol))) { + stop("The scatter matrices are not calculated correctly.") + } + } + } # IF "scatter" + + for (j in 1:5) { + if (!isTRUE(all.equal(gauss.loc.score[[j]], + score$local.score(j, gauss.parents[[j]]), + tolerance = tol))) { + stop("The local score is not calculated correctly.") + } + } + + # print(lapply(1:5, function(i) score$local.fit(i, gauss.parents[[i]]))) + + for (j in 1:5) { + local.mle <- score$local.fit(j, gauss.parents[[j]]) + if (length(local.mle) != length(gauss.mle[[j]]) || + !isTRUE(all.equal(gauss.mle[[j]], local.mle, + tolerance = tol))) { + stop("The local MLE is not calculated correctly.") + } + } } } -cat("Done.") +## List targets in a non-unique way, check if representation is corrected for +## internal storage +temp.targets <- gauss.targets +temp.targets[[2]] <- rep(temp.targets[[2]], 4) +score <- new("GaussL0penIntScore", + targets = temp.targets, + target.index = gauss.target.index, + data = gauss.data, + format = "scatter", + use.cpp = FALSE, + intercept = FALSE) +stopifnot(isTRUE(all.equal(score$pp.dat$targets, gauss.targets))) +stopifnot(isTRUE(all.equal(score$pp.dat$target.index, gauss.target.index))) + +## Try to create the score object with non-valid data, +## check if error is thrown +stopifnot(isTRUE( + tryCatch( + score <- new("GaussL0penIntScore", + targets = gauss.targets, + target.index = gauss.target.index), + error = function(e) { + cat(paste(" Error caught:", e$message, "\n", sep = " ")) + TRUE + } + ))) + +set.seed(307) +temp.targets <- gauss.targets +temp.targets <- c(temp.targets, temp.targets[[6]]) +temp.target.index <- gauss.target.index +temp.target.index[sample(which(gauss.target.index == 6), size = 20)] <- length(temp.targets) +stopifnot(isTRUE( + tryCatch( + score <- new("GaussL0penIntScore", + targets = temp.targets, + target.index = temp.target.index, + data = gauss.data), + error = function(e) { + cat(paste(" Error caught:", e$message, "\n", sep = " ")) + TRUE + } + ))) + +temp.targets <- gauss.targets +temp.targets[[2]] <- c(temp.targets[[2]], 9) +stopifnot(isTRUE( + tryCatch( + score <- new("GaussL0penIntScore", + targets = temp.targets, + target.index = gauss.target.index, + data = gauss.data), + error = function(e) { + cat(paste(" Error caught:", e$message, "\n", sep = " ")) + TRUE + } + ))) + +temp.target.index <- gauss.target.index +temp.target.index[1] <- length(gauss.targets) + 1 +stopifnot(isTRUE( + tryCatch(score <- new("GaussL0penIntScore", + targets = gauss.targets, + target.index = temp.target.index, + data = gauss.data), + error = function(e) { + cat(paste(" Error caught:", e$message, "\n", sep = " ")) + TRUE + } + ))) + +## Test calculation of BIC score for discrete data +# TODO use more sophisticated data set... +discr.data <- cbind(c(3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,4), + c(5,5,5,5,7,7,7,7,7,7,5,5,5,5,5,7,7,7,7,7), + c(1,1,9,8,1,1,8,8,9,9,1,1,9,9,9,1,1,1,9,9)) +score <- new("DiscrL0penIntScore", data = discr.data) +# score$local.score(1, integer(0)) + +cat("Done.\n") diff --git a/tests/test_dag2essgraph.R b/tests/test_dag2essgraph.R new file mode 100644 index 0000000..3ec9caf --- /dev/null +++ b/tests/test_dag2essgraph.R @@ -0,0 +1,63 @@ +library(pcalg) + +n.perm <- 5 + +set.seed(123) + +# A: adjacency matrix of DAG; +# B: adjacency matrix of CPDAG +# Setting 3 by courtesy of Jonas Peters: in pcalg <= 2.0.8, +# setting i = 3, k = 3 failed +A <- list( + matrix(c(0,0,0,0,1, 0,0,1,0,1, 0,0,0,1,0, 0,0,0,0,0, 0,0,0,0,0), 5, 5, byrow = TRUE), + matrix(c(0,1,0,0,0, 0,0,0,1,0, 0,0,0,1,0, 0,0,0,0,1, 0,0,0,0,0), 5, 5, byrow = TRUE), + matrix(c(0,0,0,0, 1,0,0,0, 1,1,0,0, 1,1,1,0), 4, 4), + matrix(c(0,0,0,0, 1,0,0,0, 1,1,0,0, 1,1,1,0), 4, 4), + matrix(c(0,0,0,0, 1,0,0,0, 1,1,0,0, 1,1,1,0), 4, 4)) +B <- list( + matrix(c(0,0,0,0,1, 0,0,1,0,1, 0,1,0,1,0, 0,0,1,0,0, 0,0,0,0,0), 5, 5, byrow = TRUE), + matrix(c(0,1,0,0,0, 1,0,0,1,0, 0,0,0,1,0, 0,0,0,0,1, 0,0,0,0,0), 5, 5, byrow = TRUE), + matrix(c(0,1,1,1, 1,0,1,1, 1,1,0,1, 1,1,1,0), 4, 4), + matrix(c(0,1,1,0, 1,0,1,0, 1,1,0,0, 1,1,1,0), 4, 4), + matrix(c(0,0,0,0, 1,0,0,0, 1,1,0,1, 1,1,1,0), 4, 4)) +targets <- list( + list(integer(0)), + list(integer(0)), + list(integer(0)), + list(integer(0), 4), + list(integer(0), 2)) + +for (i in 1:length(A)) { + for (k in 1:n.perm) { + p <- nrow(A[[i]]) + + ind <- if(k == 1) 1:p else sample.int(p) + permTargets <- lapply(targets[[i]], function(v) match(v, ind)) + + # Test functionality with a matrix + B.hat <- dag2essgraph(A[[i]][ind, ind], targets = permTargets) + if (!all(B.hat == B[[i]][ind, ind])) { + stop(sprintf("True CPDAG not found! (setting: matrix, i = %d, k = %d)", i, k)) + } + + # Test functionality with grephNEL objects + g <- as(A[[i]][ind, ind], "graphNEL") + pdag <- dag2essgraph(g, targets = permTargets) + B.hat <- as(pdag, "matrix") + if (!all(B.hat == B[[i]][ind, ind])) { + stop(sprintf("True CPDAG not found! (setting: graphNEL, i = %d, k = %d)", i, k)) + } + + # Test functionality with ParDAG/EssGraph objects + g <- as(A[[i]][ind, ind], "GaussParDAG") + pdag <- dag2essgraph(g, targets = permTargets) + B.hat <- as(pdag, "matrix") + if (!all(B.hat == B[[i]][ind, ind])) { + stop(sprintf("True CPDAG not found! (setting: ParDAG, graphNEL, i = %d, k = %d)", i, k)) + } + + # par(mfrow = c(1, 2)) + # plot(g) + # plot(pdag) + } +} diff --git a/tests/test_displayAmat.R b/tests/test_displayAmat.R new file mode 100644 index 0000000..720d400 --- /dev/null +++ b/tests/test_displayAmat.R @@ -0,0 +1,49 @@ +library(pcalg) +################################################## +## pcAlgo object +################################################## +## Load predefined data +data(gmG) +n <- nrow (gmG8$x) +V <- colnames(gmG8$x) + +## define sufficient statistics +suffStat <- list(C = cor(gmG8$x), n = n) +## estimate CPDAG +skel.fit <- skeleton(suffStat, indepTest = gaussCItest, + alpha = 0.01, labels = V) +(amSkel <- as(skel.fit, "amat")) +str(amSkel) +stopifnot(attr(amSkel, "type") == "cpdag", + amSkel["Author", "Bar"] == 1, + amSkel["Bar", "Author"] == 1, + amSkel["Ctrl","Author"] == 0) + +pc.fit <- pc(suffStat, indepTest = gaussCItest, + alpha = 0.01, labels = V) +(amPC <- as(pc.fit, "amat")) +stopifnot(attr(amPC, "type") == "cpdag", + amPC["V5", "V8"] == 0, + amPC["V8", "V5"] == 1, + amPC["Goal","Author"] == 0) + +################################################## +## fciAlgo object +################################################## +set.seed(42) +p <- 7 +## generate and draw random DAG : +myDAG <- randomDAG(p, prob = 0.4) + +## find PAG using the FCI algorithm +myC <- cov2cor(trueCov(myDAG)) +suffStat <- list(C = myC, n = 10^9) +V <- LETTERS[1:p] ## labels of nodes + +fmFCI <- fci(suffStat, indepTest=gaussCItest, labels = V, + alpha = 0.9999, doPdsep = FALSE) +(amFCI <- as(fmFCI, "amat")) +stopifnot(attr(amFCI, "type") == "pag", + amFCI["B","E"] == 2, + amFCI["C","D"] == 1, + amFCI["G","A"] == 3) diff --git a/tests/test_gac.R b/tests/test_gac.R index 6e3e0aa..6ea5cc2 100644 --- a/tests/test_gac.R +++ b/tests/test_gac.R @@ -5,47 +5,54 @@ xx <- TRUE ## DAG / CPDAG ################################################## ## CPDAG 1: Paper Fig 1 -mFig1 <- matrix(c(0,1,1,0,0,0, 1,0,1,1,1,0, 0,0,0,0,0,1, 0,1,1,0,1,1, 0,1,0,1,0,1, 0,0,0,0,0,0), 6,6) +mFig1 <- matrix(c(0,1,1,0,0,0, 1,0,1,1,1,0, 0,0,0,0,0,1, + 0,1,1,0,1,1, 0,1,0,1,0,1, 0,0,0,0,0,0), 6,6) type <- "cpdag" x <- 3; y <- 6 -z <- c(2,4); xx <- xx & gac(mFig1,x,y,z,type)$gac -z <- c(4,5); xx <- xx & gac(mFig1,x,y,z,type)$gac -z <- c(4,2,1); xx <- xx & gac(mFig1,x,y,z,type)$gac -z <- c(4,5,1); xx <- xx & gac(mFig1,x,y,z,type)$gac -z <- c(4,2,5); xx <- xx & gac(mFig1,x,y,z,type)$gac -z <- c(4,2,5,1); xx <- xx & gac(mFig1,x,y,z,type)$gac -z <- 2; xx <- xx & !gac(mFig1,x,y,z,type)$gac -z <- NULL; xx <- xx & !gac(mFig1,x,y,z,type)$gac +## FIXME: test more than just $gac +## Ver.1: Let gac() return an S3 class, say "GACfit" or "gacFit", with a print() method +## and (auto)print(.) everywhere below, save *.Rout.save -> output compared: Is ok, as all "discrete" + +xx <- xx & gac(mFig1,x,y, z=c(2,4), type)$gac +xx <- xx & gac(mFig1,x,y, z=c(4,5), type)$gac +xx <- xx & gac(mFig1,x,y, z=c(4,2,1), type)$gac +xx <- xx & gac(mFig1,x,y, z=c(4,5,1), type)$gac +xx <- xx & gac(mFig1,x,y, z=c(4,2,5), type)$gac +xx <- xx & gac(mFig1,x,y, z=c(4,2,5,1), type)$gac +xx <- xx & !gac(mFig1,x,y, z= 2, type)$gac +xx <- xx & !gac(mFig1,x,y, z= NULL, type)$gac ## CPDAG 2: Paper Fig 5a mFig5a <- matrix(c(0,1,0,0,0, 1,0,1,0,0, 0,0,0,0,1, 0,0,1,0,0, 0,0,0,0,0), 5,5) type <- "cpdag" x <- c(1,5); y <- 4 -z <- c(2,3);xx <- xx & gac(mFig5a,x,y,z,type)$gac -z <- 2;xx <- xx & !gac(mFig5a,x,y,z,type)$gac +xx <- xx & gac(mFig5a, x,y, z=c(2,3), type)$gac +xx <- xx & !gac(mFig5a, x,y, z= 2, type)$gac ## DAG 1 from Marloes' Talk -m <- matrix(c(0,1,0,1,0,0, 0,0,1,0,1,0, 0,0,0,0,0,1, 0,0,0,0,0,0, 0,0,0,0,0,0, 0,0,0,0,0,0),6,6) +mMMd1 <- matrix(c(0,1,0,1,0,0, 0,0,1,0,1,0, 0,0,0,0,0,1, + 0,0,0,0,0,0, 0,0,0,0,0,0, 0,0,0,0,0,0),6,6) type <- "dag" x <- 1; y <- 3 -z <- NULL;xx <- xx & gac(m,x,y,z,type)$gac -z <- 2;xx <- xx & !gac(m,x,y,z,type)$gac -z <- 4;xx <- xx & gac(m,x,y,z,type)$gac -z <- 5;xx <- xx & !gac(m,x,y,z,type)$gac -z <- 6;xx <- xx & !gac(m,x,y,z,type)$gac -z <- c(4,5);xx <- xx & !gac(m,x,y,z,type)$gac +xx <- xx & gac(mMMd1, x,y, z=NULL, type)$gac +xx <- xx & !gac(mMMd1, x,y, z= 2, type)$gac +xx <- xx & gac(mMMd1, x,y, z= 4, type)$gac +xx <- xx & !gac(mMMd1, x,y, z= 5, type)$gac +xx <- xx & !gac(mMMd1, x,y, z= 6, type)$gac +xx <- xx & !gac(mMMd1, x,y, z=c(4,5), type)$gac ## DAG 2 from Marloes' Talk -m <- matrix(c(0,1,0,1,0,0, 0,0,0,0,0,0, 0,1,0,0,1,0, 0,0,0,0,1,0, 0,0,0,0,0,1, 0,0,0,0,0,0), 6,6) +mMMd2 <- matrix(c(0,1,0,1,0,0, 0,0,0,0,0,0, 0,1,0,0,1,0, + 0,0,0,0,1,0, 0,0,0,0,0,1, 0,0,0,0,0,0), 6,6) type <- "dag" x <- 4; y <- 6 -z <- 1;xx <- xx & gac(m,x,y,z,type)$gac -z <- 3;xx <- xx & gac(m,x,y,z,type)$gac -z <- 5;xx <- xx & !gac(m,x,y,z,type)$gac -z <- c(1,5);xx <- xx & !gac(m,x,y,z,type)$gac -z <- c(1,2);xx <- xx & gac(m,x,y,z,type)$gac -z <- c(1,3);xx <- xx & gac(m,x,y,z,type)$gac -z <- 2;xx <- xx & !gac(m,x,y,z,type)$gac +xx <- xx & gac(mMMd2, x,y, z= 1, type)$gac +xx <- xx & gac(mMMd2, x,y, z= 3, type)$gac +xx <- xx & !gac(mMMd2, x,y, z= 5, type)$gac +xx <- xx & !gac(mMMd2, x,y, z=c(1,5), type)$gac +xx <- xx & gac(mMMd2, x,y, z=c(1,2), type)$gac +xx <- xx & gac(mMMd2, x,y, z=c(1,3), type)$gac +xx <- xx & !gac(mMMd2, x,y, z= 2, type)$gac ################################################## ## PAG @@ -53,123 +60,127 @@ z <- 2;xx <- xx & !gac(m,x,y,z,type)$gac mFig3a <- matrix(c(0,1,0,0, 1,0,1,1, 0,1,0,1, 0,1,1,0), 4,4) mFig3b <- matrix(c(0,2,0,0, 3,0,3,3, 0,2,0,3, 0,2,2,0), 4,4) mFig3c <- matrix(c(0,3,0,0, 2,0,3,3, 0,2,0,3, 0,2,2,0), 4,4) -mFig4a <- matrix(c(0,0,1,0,0,0, 0,0,1,0,0,0, 2,2,0,3,3,2, 0,0,2,0,2,2, 0,0,2,1,0,2, 0,0,1,3,3,0), 6,6) -mFig4b <- matrix(c(0,0,1,0,0,0, 0,0,1,0,0,0, 2,2,0,0,3,2, 0,0,0,0,2,2, 0,0,2,3,0,2, 0,0,2,3,2,0), 6,6) -mFig5b <- matrix(c(0,1,0,0,0,0,0, 2,0,2,3,0,3,0, 0,1,0,0,0,0,0, 0,2,0,0,3,0,0, 0,0,0,2,0,2,3, 0,2,0,0,2,0,0, 0,0,0,0,2,0,0), 7,7) +mFig4a <- matrix(c(0,0,1,0,0,0, 0,0,1,0,0,0, 2,2,0,3,3,2, + 0,0,2,0,2,2, 0,0,2,1,0,2, 0,0,1,3,3,0), 6,6) +mFig4b <- matrix(c(0,0,1,0,0,0, 0,0,1,0,0,0, 2,2,0,0,3,2, + 0,0,0,0,2,2, 0,0,2,3,0,2, 0,0,2,3,2,0), 6,6) +mFig5b <- matrix(c(0,1,0,0,0,0,0, 2,0,2,3,0,3,0, 0,1,0,0,0,0,0, 0,2,0,0,3,0,0, + 0,0,0,2,0,2,3, 0,2,0,0,2,0,0, 0,0,0,0,2,0,0), 7,7) type <- "pag" -x<-2; y<-4; z<-NULL; xx <- xx & !gac(mFig3a,x,y,z,type)$gac -x<-2; y<-4; z<-NULL; xx <- xx & !gac(mFig3b,x,y,z,type)$gac -x<-2; y<-4; z<-NULL; xx <- xx & gac(mFig3c,x,y,z,type)$gac -x<-3; y<-4; z<-NULL; xx <- xx & !gac(mFig4a,x,y,z,type)$gac -x<-3; y<-4; z<-6; xx <- xx & gac(mFig4a,x,y,z,type)$gac -x<-3; y<-4; z<-c(1,6); xx <- xx & gac(mFig4a,x,y,z,type)$gac -x<-3; y<-4; z<-c(2,6); xx <- xx & gac(mFig4a,x,y,z,type)$gac -x<-3; y<-4; z<-c(1,2,6); xx <- xx & gac(mFig4a,x,y,z,type)$gac -x<-3; y<-4; z<-NULL; xx <- xx & !gac(mFig4b,x,y,z,type)$gac -x<-3; y<-4; z<-6; xx <- xx & !gac(mFig4b,x,y,z,type)$gac -x<-3; y<-4; z<-c(5,6); xx <- xx & !gac(mFig4b,x,y,z,type)$gac -x<-c(2,7); y<-6; z<-NULL; xx <- xx & !gac(mFig5b,x,y,z,type)$gac -x<-c(2,7); y<-6; z<-c(4,5); xx <- xx & gac(mFig5b,x,y,z,type)$gac -x<-c(2,7); y<-6; z<-c(4,5,1); xx <- xx & gac(mFig5b,x,y,z,type)$gac -x<-c(2,7); y<-6; z<-c(4,5,3); xx <- xx & gac(mFig5b,x,y,z,type)$gac -x<-c(2,7); y<-6; z<-c(1,3,4,5); xx <- xx & gac(mFig5b,x,y,z,type)$gac +xx <- xx & !gac(mFig3a, x=2, y=4, z=NULL, type)$gac +xx <- xx & !gac(mFig3b, x=2, y=4, z=NULL, type)$gac +xx <- xx & gac(mFig3c, x=2, y=4, z=NULL, type)$gac +xx <- xx & !gac(mFig4a, x=3, y=4, z=NULL, type)$gac +xx <- xx & gac(mFig4a, x=3, y=4, z= 6, type)$gac +xx <- xx & gac(mFig4a, x=3, y=4, z=c(1,6), type)$gac +xx <- xx & gac(mFig4a, x=3, y=4, z=c(2,6), type)$gac +xx <- xx & gac(mFig4a, x=3, y=4, z=c(1,2,6), type)$gac +xx <- xx & !gac(mFig4b, x=3, y=4, z=NULL, type)$gac +xx <- xx & !gac(mFig4b, x=3, y=4, z= 6, type)$gac +xx <- xx & !gac(mFig4b, x=3, y=4, z=c(5,6), type)$gac +xx <- xx & !gac(mFig5b, x=c(2,7), y=6, z=NULL, type)$gac +xx <- xx & gac(mFig5b, x=c(2,7), y=6, z=c(4,5), type)$gac +xx <- xx & gac(mFig5b, x=c(2,7), y=6, z=c(4,5,1), type)$gac +xx <- xx & gac(mFig5b, x=c(2,7), y=6, z=c(4,5,3), type)$gac +xx <- xx & gac(mFig5b, x=c(2,7), y=6, z=c(1,3,4,5), type)$gac ## PAG in Marloes' talk -m <- matrix(c(0,0,0,3,2,0,0, 0,0,0,0,1,0,0, 0,0,0,0,1,0,0, 2,0,0,0,0,3,2, 3,2,2,0,0,0,3, 0,0,0,2,0,0,0, 0,0,0,2,2,0,0),7,7) +mMMp <- matrix(c(0,0,0,3,2,0,0, 0,0,0,0,1,0,0, 0,0,0,0,1,0,0, 2,0,0,0,0,3,2, + 3,2,2,0,0,0,3, 0,0,0,2,0,0,0, 0,0,0,2,2,0,0), 7,7) x <- c(5,6); y <- 7 -z<-NULL; xx <- xx & !gac(m,x,y,z,type)$gac -z<-1; xx <- xx & !gac(m,x,y,z,type)$gac -z<-4; xx <- xx & !gac(m,x,y,z,type)$gac -z<-2; xx <- xx & !gac(m,x,y,z,type)$gac -z<-3; xx <- xx & !gac(m,x,y,z,type)$gac -z<-c(2,3); xx <- xx & !gac(m,x,y,z,type)$gac -z<-c(1,4); xx <- xx & gac(m,x,y,z,type)$gac -z<-c(1,4,2); xx <- xx & gac(m,x,y,z,type)$gac -z<-c(1,4,3); xx <- xx & gac(m,x,y,z,type)$gac -z<-c(1,4,2,3); xx <- xx & gac(m,x,y,z,type)$gac +xx <- xx & !gac(mMMp, x,y, z=NULL, type)$gac +xx <- xx & !gac(mMMp, x,y, z= 1, type)$gac +xx <- xx & !gac(mMMp, x,y, z= 4, type)$gac +xx <- xx & !gac(mMMp, x,y, z= 2, type)$gac +xx <- xx & !gac(mMMp, x,y, z= 3, type)$gac +xx <- xx & !gac(mMMp, x,y, z=c(2,3), type)$gac +xx <- xx & gac(mMMp, x,y, z=c(1,4), type)$gac +xx <- xx & gac(mMMp, x,y, z=c(1,4,2), type)$gac +xx <- xx & gac(mMMp, x,y, z=c(1,4,3), type)$gac +xx <- xx & gac(mMMp, x,y, z=c(1,4,2,3), type)$gac ################################################## -## Tests from Ema +## type = "pag" -- Tests from Ema ################################################## -load("gacData.rda") type <- "pag" -m1 <-matrices[[1]] +pag.m <- readRDS(system.file("external/gac-pags.rds", package="pcalg")) +m1 <- pag.m[["m1"]] x <- 6; y <- 9 -z<-NULL; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-1; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-2; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-3; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-4; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-c(2,3); xx <- xx & !gac(m1,x,y,z,type)$gac -z<-c(2,3,8); xx <- xx & gac(m1,x,y,z,type)$gac -z<-c(2,3,7,8); xx <- xx & gac(m1,x,y,z,type)$gac -z<-c(2,3,5,8); xx <- xx & !gac(m1,x,y,z,type)$gac -z<-c(2,3,5,7,8); xx <- xx & !gac(m1,x,y,z,type)$gac +xx <- xx & !gac(m1,x,y, z=NULL, type)$gac +xx <- xx & !gac(m1,x,y, z=1, type)$gac +xx <- xx & !gac(m1,x,y, z=2, type)$gac +xx <- xx & !gac(m1,x,y, z=3, type)$gac +xx <- xx & !gac(m1,x,y, z=4, type)$gac +xx <- xx & !gac(m1,x,y, z=c(2,3), type)$gac +xx <- xx & gac(m1,x,y, z=c(2,3,8), type)$gac +xx <- xx & gac(m1,x,y, z=c(2,3,7,8), type)$gac +xx <- xx & !gac(m1,x,y, z=c(2,3,5,8), type)$gac +xx <- xx & !gac(m1,x,y, z=c(2,3,5,7,8), type)$gac x <- c(6,8); y <- 9 -z<-NULL; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-1; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-2; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-3; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-4; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-c(2,3); xx <- xx & gac(m1,x,y,z,type)$gac -z<-c(2,3,4); xx <- xx & gac(m1,x,y,z,type)$gac -z<-c(2,3,7); xx <- xx & gac(m1,x,y,z,type)$gac -z<-c(2,3,5); xx <- xx & !gac(m1,x,y,z,type)$gac -z<-c(2,3,5,7); xx <- xx & !gac(m1,x,y,z,type)$gac +xx <- xx & !gac(m1,x,y, z=NULL, type)$gac +xx <- xx & !gac(m1,x,y, z=1, type)$gac +xx <- xx & !gac(m1,x,y, z=2, type)$gac +xx <- xx & !gac(m1,x,y, z=3, type)$gac +xx <- xx & !gac(m1,x,y, z=4, type)$gac +xx <- xx & gac(m1,x,y, z=c(2,3), type)$gac +xx <- xx & gac(m1,x,y, z=c(2,3,4), type)$gac +xx <- xx & gac(m1,x,y, z=c(2,3,7), type)$gac +xx <- xx & !gac(m1,x,y, z=c(2,3,5), type)$gac +xx <- xx & !gac(m1,x,y, z=c(2,3,5,7), type)$gac x <- 3; y <- 1 -z<-NULL; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-2; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-4; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-5; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-6; xx <- xx & !gac(m1,x,y,z,type)$gac -z<-c(2,6); xx <- xx & !gac(m1,x,y,z,type)$gac -z<-c(2,8); xx <- xx & !gac(m1,x,y,z,type)$gac -z<-c(2,7,8); xx <- xx & !gac(m1,x,y,z,type)$gac -z<-c(2,5,8); xx <- xx & !gac(m1,x,y,z,type)$gac -z<-c(2,5,7,8); xx <- xx & !gac(m1,x,y,z,type)$gac +xx <- xx & !gac(m1,x,y, z=NULL, type)$gac +xx <- xx & !gac(m1,x,y, z=2, type)$gac +xx <- xx & !gac(m1,x,y, z=4, type)$gac +xx <- xx & !gac(m1,x,y, z=5, type)$gac +xx <- xx & !gac(m1,x,y, z=6, type)$gac +xx <- xx & !gac(m1,x,y, z=c(2,6), type)$gac +xx <- xx & !gac(m1,x,y, z=c(2,8), type)$gac +xx <- xx & !gac(m1,x,y, z=c(2,7,8), type)$gac +xx <- xx & !gac(m1,x,y, z=c(2,5,8), type)$gac +xx <- xx & !gac(m1,x,y, z=c(2,5,7,8), type)$gac -m2 <- matrices[[2]] +m2 <- pag.m[["m2"]] x <- 3; y <-1 -z<-NULL; xx <- xx & !gac(m2,x,y,z,type)$gac -z<-2; xx <- xx & gac(m2,x,y,z,type)$gac -z<-4; xx <- xx & !gac(m2,x,y,z,type)$gac -z<-c(2,8); xx <- xx & !gac(m2,x,y,z,type)$gac -z<-8; xx <- xx & !gac(m2,x,y,z,type)$gac -z<-9; xx <- xx & !gac(m2,x,y,z,type)$gac -z<-c(2,8,9); xx <- xx & !gac(m2,x,y,z,type)$gac -z<-c(2,5); xx <- xx & gac(m2,x,y,z,type)$gac +xx <- xx & !gac(m2,x,y, z=NULL, type)$gac +xx <- xx & gac(m2,x,y, z=2, type)$gac +xx <- xx & !gac(m2,x,y, z=4, type)$gac +xx <- xx & !gac(m2,x,y, z=c(2,8), type)$gac +xx <- xx & !gac(m2,x,y, z=8, type)$gac +xx <- xx & !gac(m2,x,y, z=9, type)$gac +xx <- xx & !gac(m2,x,y, z=c(2,8,9), type)$gac +xx <- xx & gac(m2,x,y, z=c(2,5), type)$gac x <- c(3,9); y <- 1 -z<-NULL; xx <- xx & !gac(m2,x,y,z,type)$gac -z<-2; xx <- xx & !gac(m2,x,y,z,type)$gac -z<-4; xx <- xx & !gac(m2,x,y,z,type)$gac -z<-c(2,8); xx <- xx & !gac(m2,x,y,z,type)$gac -z<-8; xx <- xx & !gac(m2,x,y,z,type)$gac -z<-9; xx <- xx & !gac(m2,x,y,z,type)$gac -z<-c(2,8,9); xx <- xx & !gac(m2,x,y,z,type)$gac -z<-c(2,5); xx <- xx & !gac(m2,x,y,z,type)$gac +xx <- xx & !gac(m2,x,y, z=NULL, type)$gac +xx <- xx & !gac(m2,x,y, z=2, type)$gac +xx <- xx & !gac(m2,x,y, z=4, type)$gac +xx <- xx & !gac(m2,x,y, z=c(2,8), type)$gac +xx <- xx & !gac(m2,x,y, z=8, type)$gac +xx <- xx & !gac(m2,x,y, z=9, type)$gac +xx <- xx & !gac(m2,x,y, z=c(2,8,9), type)$gac +xx <- xx & !gac(m2,x,y, z=c(2,5), type)$gac -m3 <- matrices[[3]] +m3 <- pag.m[["m3"]] x <- 1; y <- 9 -z<-NULL; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-2; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-3; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-5; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-7; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-8; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-c(2,3); xx <- xx & gac(m3,x,y,z,type)$gac -z<-c(5,7); xx <- xx & gac(m3,x,y,z,type)$gac +xx <- xx & !gac(m3,x,y, z=NULL, type)$gac +xx <- xx & !gac(m3,x,y, z=2, type)$gac +xx <- xx & !gac(m3,x,y, z=3, type)$gac +xx <- xx & !gac(m3,x,y, z=5, type)$gac +xx <- xx & !gac(m3,x,y, z=7, type)$gac +xx <- xx & !gac(m3,x,y, z=8, type)$gac +xx <- xx & gac(m3,x,y, z=c(2,3), type)$gac +xx <- xx & gac(m3,x,y, z=c(5,7), type)$gac x <- 1; y <- 8 -z<-NULL; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-2; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-3; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-5; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-7; xx <- xx & gac(m3,x,y,z,type)$gac -z<-9; xx <- xx & !gac(m3,x,y,z,type)$gac -z<-c(2,3); xx <- xx & gac(m3,x,y,z,type)$gac -z<-c(5,9); xx <- xx & !gac(m3,x,y,z,type)$gac +xx <- xx & !gac(m3,x,y, z=NULL, type)$gac +xx <- xx & !gac(m3,x,y, z=2, type)$gac +xx <- xx & !gac(m3,x,y, z=3, type)$gac +xx <- xx & !gac(m3,x,y, z=5, type)$gac +xx <- xx & gac(m3,x,y, z=7, type)$gac +xx <- xx & !gac(m3,x,y, z=9, type)$gac +xx <- xx & gac(m3,x,y, z=c(2,3), type)$gac +xx <- xx & !gac(m3,x,y, z=c(5,9), type)$gac if (!xx) stop("Problem when testing function gac.") diff --git a/tests/test_getNextSet.R b/tests/test_getNextSet.R index eec5923..23c28aa 100644 --- a/tests/test_getNextSet.R +++ b/tests/test_getNextSet.R @@ -14,7 +14,15 @@ while(!my.stop) { } } -resTrue <- rbind(c(1,2,4),c(1,2,5),c(1,3,4),c(1,3,5),c(1,4,5),c(2,3,4),c(2,3,5),c(2,4,5),c(3,4,5)) +resTrue <- rbind(c(1,2,4), + c(1,2,5), + c(1,3,4), + c(1,3,5), + c(1,4,5), + c(2,3,4), + c(2,3,5), + c(2,4,5), + c(3,4,5)) if(any(resTrue!=res)) { stop("Test of getNextSet: Theoretical values not reproduced!") diff --git a/tests/test_gies.R b/tests/test_gies.R index ffa90af..4c61d2a 100644 --- a/tests/test_gies.R +++ b/tests/test_gies.R @@ -2,7 +2,7 @@ ####' GIES, GES, DP ####' ####' @author Alain Hauser -####' $Id: test_gies.R 331 2015-07-15 16:15:37Z mmaechler $ +####' $Id: test_gies.R 393 2016-08-20 09:43:47Z alhauser $ cat("Testing the causal inference algorithms for interventional data:\n") @@ -12,7 +12,7 @@ source(system.file(package="Matrix", "test-tools-1.R", mustWork=TRUE)) ##--> showProc.time(), assertError(), relErrV(), ... load("test_bicscore.rda") # in directory tests/ i.e., typically *not* installed -str(gauss.data) +# str(gauss.data) p <- ncol(gauss.data) (doExtras <- pcalg:::doExtras()) @@ -20,39 +20,73 @@ DBG <- if(doExtras) TRUE else FALSE # no debugging by default ## Tolerance for numerical comparison tol <- sqrt(.Machine$double.eps) # = default for all.equal() -fcns <- c(GIES = gies, GDS = gds) -nreps <- 10 +## Define all test settings +settings <- expand.grid( + fcn = c("gies", "gds"), + cpp = c(FALSE, TRUE), + format = c("scatter", "raw"), + stringsAsFactors = FALSE) +nreps <- 5 -for (nf in names(fcns)) { - cat(if(doExtras)"\n\n", nf, if(doExtras)":\n" else ": ... ", - if(doExtras) paste0(paste(rep("=", nchar(nf)), collapse=""), "\n"), - sep = "") - for (cpp in c(FALSE, TRUE)) { +for (m in seq_along(settings)) { + cat(sprintf("Algorithm: %s, C++: %s, storage format: %s\n", + settings$fcn[m], settings$cpp[m], settings$format[m])) + + for (i in 1:nreps) { + perm <- 1:nrow(gauss.data) + ## Randomly permute data - for (i in 1:nreps) { - perm <- 1:nrow(gauss.data) - if (i > 1) { - set.seed(i) - perm <- sample(perm) - } - score <- new("GaussL0penIntScore", - targets = gauss.targets, - target.index = gauss.target.index[perm], - data = gauss.data[perm, ], - use.cpp = cpp) - est.graph <- fcns[[nf]](p, gauss.targets, score, verbose = DBG) - for (i in 1:p) { - if(doExtras) cat(" use.cpp = ", cpp,"; i = ", i, "\n", sep="") - if (!isTRUE(all.equal(est.graph$essgraph$.in.edges[[i]], - gauss.parents[[i]], tolerance = tol))) - stop("Parents are not estimated correctly.") - } - showProc.time() + if (i > 1) { + set.seed(i) + perm <- sample(perm) + } + + score <- new("GaussL0penIntScore", + targets = gauss.targets, + target.index = gauss.target.index[perm], + data = gauss.data[perm, ], + format = settings$format[m], + use.cpp = settings$cpp[m]) + f <- get(settings$fcn[m]) + est.graph <- f(score, verbose = DBG) + for (j in 1:p) { + if (!isTRUE(all.equal(est.graph$essgraph$.in.edges[[j]], + gauss.parents[[j]], tolerance = tol))) + stop("Parents are not estimated correctly.") } + showProc.time() } cat("[Ok]\n") } +## Test compatibility with deprecated calling conventions +cat("Compatibility with deprecated calling conventions... ") +score <- new("GaussL0penIntScore", + targets = gauss.targets, + target.index = gauss.target.index, + data = gauss.data) + +warningIssued <- FALSE +tryCatch(est.graph <- gies(p, gauss.targets, score), + warning = function(w) warningIssued <<- TRUE) +if (!warningIssued) { + stop("No warning issued for old calling conventions.") +} else { + for (j in 1:p) { + if (!isTRUE(all.equal(est.graph$essgraph$.in.edges[[j]], + gauss.parents[[j]], tolerance = tol))) + stop("Parents are not estimated correctly.") + } +} +warningIssued <- FALSE +tryCatch(est.graph <- gies(p = p, targets = gauss.targets, score = score), + warning = function(w) warningIssued <<- TRUE) +if (!warningIssued) { + stop("No warning issued for old calling conventions.") +} +cat("[OK]\n") + + ## Test stepwise execution of GIES cat(if(doExtras)"\n\n", "GIES stepwise", if(doExtras)":\n" else ": ... ", if(doExtras) paste0(paste(rep("=", 14), collapse=""), "\n"), @@ -90,4 +124,12 @@ for (cpp in c(FALSE, TRUE)) { } } +## Test G(I)ES with discrete data +# TODO: replace by a better example data set!! +discr.data <- cbind(c(3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,4), + c(5,5,5,5,7,7,7,7,7,7,5,5,5,5,5,7,7,7,7,7), + c(1,1,9,8,1,1,8,8,9,9,1,1,9,9,9,1,1,1,9,9)) +score <- new("DiscrL0penIntScore", data = discr.data) +ges.fit <- ges(score) + cat(if(doExtras) "\n", "Done.\n") diff --git a/tests/test_mat2targets.R b/tests/test_mat2targets.R index cf5556d..1c07c35 100644 --- a/tests/test_mat2targets.R +++ b/tests/test_mat2targets.R @@ -1,7 +1,7 @@ library(pcalg) ## Tests whether "intervention matrices" can correctly be mapped to a -## targets/target index pair +## targets/target index pair, and vice versa nreps <- 30 p <- 20 @@ -11,6 +11,7 @@ for (i in 1:nreps) { set.seed(i) A <- matrix(as.logical(rbinom(n*p, 1, 0.01)), nrow = n, ncol = p) + ## Testing conversion of matrix to list of targets target.list <- mat2targets(A) if (any(duplicated(target.list$targets))) stop("Targets are not unique!") @@ -18,5 +19,10 @@ for (i in 1:nreps) { if (!all.equal(which(A[j, ]), target.list$targets[[target.list$target.index[j]]])) stop("Targets not correctly represented!") + + ## Test back-conversion + B <- targets2mat(p, target.list$targets, target.list$target.index) + if (!identical(A, B)) + stop("Intervention matrix not correctly represented!") } diff --git a/tests/test_pcSelect.R b/tests/test_pcSelect.R index fabf02f..a07d2eb 100644 --- a/tests/test_pcSelect.R +++ b/tests/test_pcSelect.R @@ -28,7 +28,7 @@ cMeths <- corMeths[-1] C. <- zMin. <- setNames(as.list(cMeths), cMeths) Cstats <- function(C) { ## numeric symmetric matrix - stopifnot(is.matrix(C), is.numeric(C), isSymmetric(C)) + stopifnot(is.matrix(C), is.numeric(C), isSymmetric(C))# , tol = 3e-14 cbind(diag = diag(C), colSums = colSums(C), e.values = eigen(C, only.values=TRUE)$values) diff --git a/tests/test_pdag2allDags.R b/tests/test_pdag2allDags.R new file mode 100644 index 0000000..7461e39 --- /dev/null +++ b/tests/test_pdag2allDags.R @@ -0,0 +1,111 @@ +library(pcalg) + +val <- rep(FALSE, 9) +## Test 1 +gm <- rbind(c(0,1), + c(1,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:2] +res <- pdag2allDags(gm, verbose = FALSE) +## plotAllDags(res) +## for (i in 1:2) {cat(paste("c(",paste(res$dags[i,], collapse = ","),"),",sep=""),"\n")} +res.truth <- rbind(c(0,1,0,0), + c(0,0,1,0)) +val[1] <- identical(res.truth, res$dags) + +## Test 2 +gm <- rbind(c(0,0), + c(0,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:2] +res <- pdag2allDags(gm, verbose = FALSE) +res.truth <- rbind(c(0,0,0,0)) +val[2] <- identical(res.truth, res$dags) + +## Test 3, non-collider +gm <- rbind(c(0,1,0), + c(1,0,1), + c(0,1,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:ncol(gm)] +res <- pdag2allDags(gm, verbose = FALSE) +res.truth <- rbind(c(0,1,0,0,0,1,0,0,0), + c(0,1,0,0,0,0,0,1,0), + c(0,0,0,1,0,0,0,1,0)) +val[3] <- identical(res.truth, res$dags) +## for (i in 1:3) {cat(paste("c(",paste(res$dags[i,], collapse = ","),"),",sep=""),"\n")} +## plotAllDags(res) + +## Test 4, collider +gm <- rbind(c(0,0,0), + c(1,0,1), + c(0,0,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:ncol(gm)] +res <- pdag2allDags(gm, verbose = FALSE) +res.truth <- rbind(c(0,0,0,1,0,1,0,0,0)) +val[4] <- identical(res.truth, res$dags) +## plotAllDags(res) + +## Test 5, trick question +gm <- rbind(c(0,0,0), + c(1,0,1), + c(0,1,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:ncol(gm)] +res <- pdag2allDags(gm, verbose = FALSE) +res.truth <- rbind(c(0,0,0,1,0,0,0,1,0)) +val[5] <- identical(res.truth, res$dags) +## plotAllDags(res) + +## Test 6,complete +gm <- rbind(c(0,1,1), + c(1,0,1), + c(1,1,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:ncol(gm)] +res <- pdag2allDags(gm, verbose = FALSE) +## for (i in 1:6) {cat(paste("c(",paste(res$dags[i,], collapse = ","),"),",sep=""),"\n")} +res.truth <- rbind(c(0,1,1,0,0,1,0,0,0), + c(0,1,1,0,0,0,0,1,0), + c(0,0,1,1,0,1,0,0,0), + c(0,0,0,1,0,1,1,0,0), + c(0,1,0,0,0,0,1,1,0), + c(0,0,0,1,0,0,1,1,0)) +val[6] <- identical(res.truth, res$dags) +## plotAllDags(res) + +## Test 7, 4 nodes: being really mean +## No DAG possible +gm <- rbind(c(0,1,1,0), + c(1,0,0,1), + c(1,0,0,1), + c(0,1,1,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:ncol(gm)] +res <- pdag2allDags(gm, verbose = FALSE) +val[7] <- is.null(res$dags) +## plotAllDags(res) + +## Test 8, 4 nodes +gm <- rbind(c(0,1,1,0), + c(1,0,0,0), + c(1,0,0,0), + c(0,1,1,0)) +colnames(gm) <- rownames(gm) <- LETTERS[1:ncol(gm)] +res <- pdag2allDags(gm, verbose = FALSE) +res.truth <- rbind(c(0,0,1,0,1,0,0,0,0,0,0,0,0,1,1,0), + c(0,0,0,0,1,0,0,0,1,0,0,0,0,1,1,0), + c(0,1,0,0,0,0,0,0,1,0,0,0,0,1,1,0)) +val[8] <- identical(res.truth, res$dags) +## plotAllDags(res) + +## Test 9, 5 nodes; D -> E must always be there +gm <- rbind(c(0,1,1,0,0), + c(1,0,0,0,0), + c(1,0,0,0,0), + c(0,1,1,0,1), + c(0,0,0,1,0)) + +colnames(gm) <- rownames(gm) <- LETTERS[1:ncol(gm)] +res <- pdag2allDags(gm, verbose = FALSE) + +res.truth <- rbind(c(0,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,1,0), + c(0,0,0,0,0,1,0,0,0,0,1,0,0,0,0,0,1,1,0,0,0,0,0,1,0), + c(0,1,0,0,0,0,0,0,0,0,1,0,0,0,0,0,1,1,0,0,0,0,0,1,0)) +val[9] <- identical(res.truth, res$dags) + +if (!all(val)) stop("Error in testing pdag2allDags!\n") diff --git a/tests/test_randDAG.R b/tests/test_randDAG.R index c7ed98a..1cf6ef9 100644 --- a/tests/test_randDAG.R +++ b/tests/test_randDAG.R @@ -19,7 +19,10 @@ rD.10.4 <- rDAGall(10, 4) ## with a low-level warning rD.10.4 # looks ok -require(graph) +ok <- suppressPackageStartupMessages( + require("graph")) +stopifnot(ok) + stopifnot(vapply(rD.10.4, isDirected, NA)) stopifnot(identical( @@ -71,10 +74,8 @@ stopifnot(all.equal(chisq.test(as.numeric(table(ct)), p = rep(0.1,10))$p.value, 0.3101796548)) ## check generation of negative weights (fixed Bug) -set.seed(123) -tmp1 <- randDAG(3,2,wFUN = list(runif, min = 2, max = 2)) -all( unlist(tmp1@edgeData@data) == 2 ) -set.seed(123) -tmp2 <- randDAG(3,2,wFUN = list(runif, min = -2, max = -2)) -all( unlist(tmp2@edgeData@data) == -2 ) +set.seed(123) ; tmp1 <- randDAG(3,2, wFUN = list(runif, min = 2, max = 2)) +set.seed(123) ; tmp2 <- randDAG(3,2, wFUN = list(runif, min = -2, max = -2)) +stopifnot(unlist(tmp1@edgeData@data) == 2, + unlist(tmp2@edgeData@data) == -2 ) diff --git a/tests/test_randDAG.Rout.save b/tests/test_randDAG.Rout.save index e61b460..de1320e 100644 --- a/tests/test_randDAG.Rout.save +++ b/tests/test_randDAG.Rout.save @@ -1,7 +1,7 @@ -R Under development (unstable) (2015-07-12 r68650) -- "Unsuffered Consequences" -Copyright (C) 2015 The R Foundation for Statistical Computing -Platform: x86_64-unknown-linux-gnu (64-bit) +R version 3.3.1 Patched (2016-07-22 r70961) -- "Bug in Your Hair" +Copyright (C) 2016 The R Foundation for Statistical Computing +Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. @@ -81,8 +81,10 @@ Number of Nodes = 10 Number of Edges = 19 > -> require(graph) -Loading required package: graph +> ok <- suppressPackageStartupMessages( ++ require("graph")) +> stopifnot(ok) +> > stopifnot(vapply(rD.10.4, isDirected, NA)) > > stopifnot(identical( @@ -394,16 +396,12 @@ Number of Edges = 137 + 0.3101796548)) > > ## check generation of negative weights (fixed Bug) -> set.seed(123) -> tmp1 <- randDAG(3,2,wFUN = list(runif, min = 2, max = 2)) -> all( unlist(tmp1@edgeData@data) == 2 ) -[1] TRUE -> set.seed(123) -> tmp2 <- randDAG(3,2,wFUN = list(runif, min = -2, max = -2)) -> all( unlist(tmp2@edgeData@data) == -2 ) -[1] TRUE +> set.seed(123) ; tmp1 <- randDAG(3,2, wFUN = list(runif, min = 2, max = 2)) +> set.seed(123) ; tmp2 <- randDAG(3,2, wFUN = list(runif, min = -2, max = -2)) +> stopifnot(unlist(tmp1@edgeData@data) == 2, ++ unlist(tmp2@edgeData@data) == -2 ) > > > proc.time() user system elapsed - 1.885 0.410 2.628 + 1.022 0.135 1.149 diff --git a/vignettes/pcalgDoc.Rnw b/vignettes/pcalgDoc.Rnw index a1b6fba..88fc9db 100644 --- a/vignettes/pcalgDoc.Rnw +++ b/vignettes/pcalgDoc.Rnw @@ -223,13 +223,13 @@ result. <>= stopifnot(require(Rgraphviz))# needed for all our graph plots par(mfrow = c(1,2)) -plot(gmG$g, main = "") ; plot(pc.gmG, main = "") +plot(gmG8$g, main = "") ; plot(pc.gmG, main = "") @% two plots side by sid <>= -suffStat <- list(C = cor(gmG$x), n = nrow(gmG$x)) +suffStat <- list(C = cor(gmG8$x), n = nrow(gmG8$x)) pc.gmG <- pc(suffStat, indepTest = gaussCItest, - p = ncol(gmG$x), alpha = 0.01) + p = ncol(gmG8$x), alpha = 0.01) <> @ \begin{figure}[htb] @@ -277,11 +277,11 @@ function \code{ida()}. To provide full quantitative information, we need to pass the covariance matrix in addition to the estimated causal structure. <>= -ida(1, 6, cov(gmG$x), pc.gmG@graph) +ida(1, 6, cov(gmG8$x), pc.gmG@graph) @ Since we simulated the data, we know that the true value of the causal -effect is \Sexpr{gGtrue <- gmG$g; round(causalEffect(gGtrue, 6, 1), 2)}. %$ +effect is \Sexpr{gGtrue <- gmG8$g; round(causalEffect(gGtrue, 6, 1), 2)}. %$ Thus, one of the two estimates is indeed close to the true value. Since both values are larger than zero, we can conclude that variable $V_1$ has a positive causal effect @@ -295,7 +295,7 @@ times. However, a faster way is to call the function \code{idaFast()}, which was tailored for such situations. <>= -idaFast(1, c(4,5,6), cov(gmG$x), pc.gmG@graph) +idaFast(1, c(4,5,6), cov(gmG8$x), pc.gmG@graph) @ Each row in the output shows the estimated set of possible causal effects @@ -893,11 +893,11 @@ underlying DAG are shown in Fig.~\ref{fig:skelExpl}. \centering <>= ## using data("gmG", package="pcalg") -suffStat <- list(C = cor(gmG$x), n = nrow(gmG$x)) +suffStat <- list(C = cor(gmG8$x), n = nrow(gmG8$x)) skel.gmG <- skeleton(suffStat, indepTest = gaussCItest, - p = ncol(gmG$x), alpha = 0.01) + p = ncol(gmG8$x), alpha = 0.01) par(mfrow = c(1,2)) -plot(gmG$g, main = ""); plot(skel.gmG, main = "") +plot(gmG8$g, main = ""); plot(skel.gmG, main = "") @ \caption{True underlying DAG (left) and estimated skeleton (right) fitted on the simulated Gaussian data set \texttt{gmG}.} @@ -1075,9 +1075,9 @@ Fig.~\ref{fig:pcFit1}. \begin{figure} \centering <>= -suffStat <- list(C = cor(gmG$x), n = nrow(gmG$x)) -pc.fit <- pc(suffStat, indepTest=gaussCItest, p = ncol(gmG$x), alpha = 0.01) -par(mfrow= c(1,2)); plot(gmG$g, main = ""); plot(pc.fit, main = "") +suffStat <- list(C = cor(gmG8$x), n = nrow(gmG8$x)) +pc.fit <- pc(suffStat, indepTest=gaussCItest, p = ncol(gmG8$x), alpha = 0.01) +par(mfrow= c(1,2)); plot(gmG8$g, main = ""); plot(pc.fit, main = "") @ \caption{True underlying DAG (left) and estimated CPDAG (right) fitted on the simulated Gaussian data set \code{gmG}.} @@ -1125,9 +1125,9 @@ Once a score object is defined, the GES algorithm is called as follows: <>= showF(ges) @ -The argument \code{p} specifies the number of variables in the model, -\code{score} is a score object defined before. The argument \code{turning} -indicates whether the novel turning phase (see Section \ref{sec:gm}) not +The argument \code{score} is a score object defined before. The +argument \code{turning} indicates whether the novel turning phase +(see Section \ref{sec:gm}) not present in the original implementation of \cite{Chickering2002} should be used, and \code{maxdegree} can be used to bound the vertex degree of the estimated graph. More details can be found in the help file of @@ -1140,9 +1140,9 @@ exactly the same in this case. \begin{figure} \centering <>= -score <- new("GaussL0penObsScore", gmG$x) -ges.fit <- ges(ncol(gmG$x), score) -par(mfrow=1:2); plot(gmG$g, main = ""); plot(ges.fit$essgraph, main = "") +score <- new("GaussL0penObsScore", gmG8$x) +ges.fit <- ges(score) +par(mfrow=1:2); plot(gmG8$g, main = ""); plot(ges.fit$essgraph, main = "") @ \caption{True underlying DAG (left) and essential graph (right) estimated with the GES algorithm fitted on the simulated Gaussian data set \code{gmG}.} @@ -1476,6 +1476,7 @@ set.seed(40) p <- 8 n <- 5000 gGtrue <- randomDAG(p, prob = 0.3) +nodes(gGtrue) <- c("Author", "Bar", "Ctrl", "Goal", "V5", "V6", "V7", "V8") pardag <- as(gGtrue, "GaussParDAG") pardag$set.err.var(rep(1, p)) targets <- list(integer(0), 3, 5) @@ -1515,8 +1516,8 @@ respectively) is estimated in Figure~\ref{fig:giesFit}. <>= score <- new("GaussL0penIntScore", gmInt$x, targets = gmInt$targets, target.index = gmInt$target.index) -gies.fit <- gies(ncol(gmInt$x), gmInt$targets, score) -simy.fit <- simy(ncol(gmInt$x), gmInt$targets, score) +gies.fit <- gies(score) +simy.fit <- simy(score) par(mfrow = c(1, 3)) ; plot(gmInt$g, main = "") plot(gies.fit$essgraph, main = "") plot(simy.fit$essgraph, main = "") @@ -1935,11 +1936,11 @@ myCItest <- function(x,y,S, suffStat) { @ We can now use this function together with \code{pc()}. <>= -suffStat <- list(C = cor(gmG$x), n = 5000) +suffStat <- list(C = cor(gmG8$x), n = 5000) pc.gmG <- pc(suffStat, indepTest=gaussCItest, p = 8, alpha = 0.01) @ <>= -pc.myfit <- pc(suffStat = gmG$x, indepTest = myCItest, +pc.myfit <- pc(suffStat = gmG8$x, indepTest = myCItest, p = 8, alpha = 0.01) par(mfrow = c(1,2)); plot(pc.gmG, main = ""); plot(pc.myfit, main = "") @ @@ -1974,7 +1975,7 @@ system.time(for(i in 1:10) ## User System verstrichen ## 0.593 0.000 0.594 system.time(for(i in 1:10) - pc.myfit <- pc(gmG$x, indepTest = myCItest, p = 8, alpha = 0.01)) + pc.myfit <- pc(gmG8$x, indepTest = myCItest, p = 8, alpha = 0.01)) ## Using resid(lm(..)) twice: ## User System verstrichen ## 44.864 0.007 44.937