diff --git a/.Rbuildignore b/.Rbuildignore index b4b32132..4e5e76cc 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -21,3 +21,4 @@ ^dev$ ^\.posit$ ^temp$ +^vignettes/\.quarto$ diff --git a/.gitignore b/.gitignore index 6c4a6a4d..da1811a5 100755 --- a/.gitignore +++ b/.gitignore @@ -49,7 +49,15 @@ inst/rust/template/* # Example runs data-raw/Runs/ inst/Examples/ - +tests/testthat/Runs/ +Examples +inst/Examples/ +Experimental +other/ +1 +2 +3 +errors.xlsx # Misc project outputs *_test.R @@ -62,3 +70,4 @@ src/rust/vendor # Old files Archived + diff --git a/Cargo.lock b/Cargo.lock index 53b6c2a0..6ac78a0e 100644 --- a/Cargo.lock +++ b/Cargo.lock @@ -17,9 +17,9 @@ dependencies = [ [[package]] name = "aho-corasick" -version = "1.1.4" +version = "1.1.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ddd31a130427c27518df266943a5308ed92d4b226cc639f5a8f1002816174301" +checksum = "c982642fa9e8606056828ee9a8505737230110bb1099153c79efe865c59d12ba" dependencies = [ "memchr", ] @@ -32,9 +32,9 @@ checksum = "683d7910e743518b0e34f1186f92494becacb047c7b6bf616c96772180fef923" [[package]] name = "anyhow" -version = "1.0.103" +version = "1.0.104" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2a4385e2e34eb35d6b3efe798b9eb88096925d87726c0798709bf56d9ed84af3" +checksum = "330a5ed07fa54e4702c9d6c4174f74427fc0ef6e214bbd677ae50a5099946470" [[package]] name = "approx" @@ -61,9 +61,9 @@ dependencies = [ "argmin-math", "num-traits", "paste", - "rand 0.9.4", + "rand 0.9.5", "rand_xoshiro", - "thiserror 2.0.18", + "thiserror 2.0.20", "web-time", ] @@ -78,8 +78,8 @@ dependencies = [ "num-complex", "num-integer", "num-traits", - "rand 0.9.4", - "thiserror 2.0.18", + "rand 0.9.5", + "thiserror 2.0.20", ] [[package]] @@ -94,9 +94,9 @@ dependencies = [ [[package]] name = "autocfg" -version = "1.5.0" +version = "1.5.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c08606f8c3cbf4ce6ec8e28fb0014a2c086708fe954eaa885384a6165172e7e8" +checksum = "f2032f911046de80f0a198e0901378627c33f59ea0ac00e363d481118bd70a53" [[package]] name = "bitflags" @@ -106,46 +106,37 @@ checksum = "bef38d45163c2f1dde094a7dfd33ccf595c92905c8f8f4fdc18d06fb1037718a" [[package]] name = "bitflags" -version = "2.11.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c4512299f36f043ab09a583e57bceb5a5aab7a73db1805848e8fef3c9e8c78b3" - -[[package]] -name = "block-buffer" -version = "0.10.4" +version = "2.13.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "3078c7629b62d3f0439517fa394996acacc5cbc91c5a20d8c658e77abd503a71" -dependencies = [ - "generic-array", -] +checksum = "b588b76d00fde79687d7646a9b5bdf3cc0f655e0bbd080335a95d7e96f3587da" [[package]] name = "bumpalo" -version = "3.20.2" +version = "3.20.3" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5d20789868f4b01b2f2caec9f5c4e0213b41e3e5702a50157d699ae31ced2fcb" +checksum = "72f5acc6cb2ba439de613abc23857ec3d78374d8ed5ac84e9d11336e87da8649" dependencies = [ "allocator-api2", ] [[package]] name = "bytemuck" -version = "1.25.0" +version = "1.25.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c8efb64bd706a16a1bdde310ae86b351e4d21550d98d056f22f8a7f7a2183fec" +checksum = "95832e849adfb21180ccb6826a99da14e5d266ae5c2e668e1602cf234f153797" dependencies = [ "bytemuck_derive", ] [[package]] name = "bytemuck_derive" -version = "1.10.2" +version = "1.12.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f9abbd1bc6865053c427f7198e6af43bfdedc55ab791faed4fbd361d789575ff" +checksum = "fc0e56a716f1e132ff6bf4bdac1c944a3fcdc1cae65f70a4a2a1ac3b401d2d1f" dependencies = [ "proc-macro2", "quote", - "syn 2.0.117", + "syn 3.0.3", ] [[package]] @@ -156,9 +147,9 @@ checksum = "1fd0f2584146f6f2ef48085050886acf353beff7305ebd1ae69500e27c67f64b" [[package]] name = "cc" -version = "1.2.60" +version = "1.4.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "43c5703da9466b66a946814e1adf53ea2c90f10063b86290cc9eb67ce3478a20" +checksum = "5d262e149917187838d5b42777c8253bcb64500067342904e7d429499a6f277e" dependencies = [ "find-msvc-tools", "shlex", @@ -172,24 +163,15 @@ checksum = "9330f8b2ff13f34540b44e946ef35111825727b38d33286ef986142615121801" [[package]] name = "chacha20" -version = "0.10.0" +version = "0.10.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "6f8d983286843e49675a4b7a2d174efe136dc93a18d69130dd18198a6c167601" +checksum = "d524456ba66e72eb8b115ff89e01e497f8e6d11d78b70b1aa13c0fbd97540a81" dependencies = [ "cfg-if", - "cpufeatures 0.3.0", + "cpufeatures", "rand_core 0.10.1", ] -[[package]] -name = "cpufeatures" -version = "0.2.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "59ed5838eebb26a2bb2e58f6d5b5316989ae9d08bab10e0e6d103e656d1b0280" -dependencies = [ - "libc", -] - [[package]] name = "cpufeatures" version = "0.3.0" @@ -263,7 +245,7 @@ dependencies = [ "cranelift-entity", "cranelift-isle", "gimli", - "hashbrown 0.17.0", + "hashbrown 0.17.1", "libm", "log", "regalloc2", @@ -318,7 +300,7 @@ source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "a87e0aaa39dbf70693b348a221e45904111704ee8f9fef140498471005f9842d" dependencies = [ "cranelift-codegen", - "hashbrown 0.17.0", + "hashbrown 0.17.1", "log", "smallvec", "target-lexicon", @@ -394,18 +376,18 @@ dependencies = [ [[package]] name = "crossbeam-channel" -version = "0.5.15" +version = "0.5.16" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "82b8f8f868b36967f9606790d1903570de9ceaf870a7bf9fbbd3016d636a2cb2" +checksum = "d85363c37faeca707aef026efa9f3b34d077bce547e48f770770625c6013679e" dependencies = [ "crossbeam-utils", ] [[package]] name = "crossbeam-deque" -version = "0.8.6" +version = "0.8.7" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9dd111b7b7f7d55b72c0a6ae361660ee5853c9af73f70c3c2ef6858b950e2e51" +checksum = "5181e0de7b61eb03a81e347d6dd8797bae9da5146707b51077e2d71a54ec0ceb" dependencies = [ "crossbeam-epoch", "crossbeam-utils", @@ -413,27 +395,27 @@ dependencies = [ [[package]] name = "crossbeam-epoch" -version = "0.9.18" +version = "0.9.20" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5b82ac4a3c2ca9c3460964f020e1402edd5753411d7737aa39c3714ad1b5420e" +checksum = "2d6914041f254d6e9176c01941b21115dcfb7089e55135a35411081bd106ef3f" dependencies = [ "crossbeam-utils", ] [[package]] name = "crossbeam-queue" -version = "0.3.12" +version = "0.3.13" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0f58bbc28f91df819d0aa2a2c00cd19754769c2fad90579b3592b1c9ba7a3115" +checksum = "803d13fb3b09d88be9f4dbc29062c66b19bf7170867ceb746d2a8689bf6c7a26" dependencies = [ "crossbeam-utils", ] [[package]] name = "crossbeam-utils" -version = "0.8.21" +version = "0.8.22" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d0a5c400df2834b80a4c3327b3aad3a4c4cd4de0629063962b03235697506a28" +checksum = "61803da095bee82a81bb1a452ecc25d3b2f1416d1897eb86430c6159ef717c17" [[package]] name = "crunchy" @@ -441,16 +423,6 @@ version = "0.2.4" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "460fbee9c2c2f33933d720630a6a0bac33ba7053db5344fac858d4b8952d77d5" -[[package]] -name = "crypto-common" -version = "0.1.7" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "78c8292055d1c1df0cce5d180393dc8cce0abec0a7102adb6c7b1eef6016d60a" -dependencies = [ - "generic-array", - "typenum", -] - [[package]] name = "csv" version = "1.4.0" @@ -483,9 +455,6 @@ name = "deranged" version = "0.5.8" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "7cd812cc2bc1d69d4764bd80df88b4317eaef9e773c75226407d9bc0876b211c" -dependencies = [ - "powerfmt", -] [[package]] name = "diffsol" @@ -500,7 +469,7 @@ dependencies = [ "petgraph", "serde", "serde_json", - "thiserror 2.0.18", + "thiserror 2.0.20", ] [[package]] @@ -513,7 +482,7 @@ dependencies = [ "faer-traits", "nalgebra", "num-traits", - "thiserror 2.0.18", + "thiserror 2.0.20", ] [[package]] @@ -525,17 +494,7 @@ dependencies = [ "diffsol-la", "log", "num-traits", - "thiserror 2.0.18", -] - -[[package]] -name = "digest" -version = "0.10.7" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9ed9a281f7bc9b7576e61468ba615a66a5c8cfdff42420a70aa82701a3b1e292" -dependencies = [ - "block-buffer", - "crypto-common", + "thiserror 2.0.20", ] [[package]] @@ -556,9 +515,9 @@ checksum = "e1d926b4d407d372f141f93bb444696142c29d32962ccbd3531117cf3aa0bfa9" [[package]] name = "either" -version = "1.15.0" +version = "1.17.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "48c757948c5ede0e46177b7add2e67155f70e33c07fea8284df6576da70b3719" +checksum = "9e5e8f6c15a24b9a3ee5efec809ccd006d3b30e8b3bb63c39af737c7f87daa1d" [[package]] name = "enum-as-inner" @@ -569,7 +528,7 @@ dependencies = [ "heck", "proc-macro2", "quote", - "syn 2.0.117", + "syn 2.0.119", ] [[package]] @@ -607,7 +566,7 @@ checksum = "3bf679796c0322556351f287a51b49e48f7c4986e727b5dd78c972d30e2e16cc" dependencies = [ "proc-macro2", "quote", - "syn 2.0.117", + "syn 2.0.119", ] [[package]] @@ -618,7 +577,7 @@ checksum = "44f23cf4b44bfce11a86ace86f8a73ffdec849c9fd00a386a53d278bd9e81fb3" dependencies = [ "proc-macro2", "quote", - "syn 2.0.117", + "syn 2.0.119", ] [[package]] @@ -661,14 +620,14 @@ dependencies = [ "lazy_static", "proc-macro2", "quote", - "syn 2.0.117", + "syn 2.0.119", ] [[package]] name = "faer" -version = "0.24.0" +version = "0.24.4" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "02d2ecfb80b6f8b0c569e36988a052e64b14d8def9d372390b014e8bf79f299a" +checksum = "5ab6df3dd147fe8d702a288b95bcd8fcc499ab572fc80da6828f60cd4d524d67" dependencies = [ "bytemuck", "dyn-stack", @@ -683,7 +642,7 @@ dependencies = [ "num-traits", "private-gemm-x86", "pulp", - "rand 0.9.4", + "rand 0.9.5", "rand_distr 0.5.1", "rayon", "reborrow", @@ -709,9 +668,9 @@ dependencies = [ [[package]] name = "find-msvc-tools" -version = "0.1.9" +version = "0.1.10" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5baebc0774151f905a1a2cc41989300b1e6fbb29aff0ceffa1064fdd3088d582" +checksum = "26b73573e6edcd2af0cdf47bd6cb58f0b3839491263c314eaad1ccf24430e1de" [[package]] name = "fixedbitset" @@ -737,6 +696,30 @@ version = "0.2.0" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "77ce24cb58228fbb8aa041425bb1050850ac19177686ea6e0f41a70416f56fdb" +[[package]] +name = "futures-core" +version = "0.3.34" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "92d699e522242e69e3003b94ecc1f960f3a5e015aa7c5d7486e65ad01dd94f5e" + +[[package]] +name = "futures-task" +version = "0.3.34" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "cd417de3d1d015fc3bfd2b1ea46dfc7bab72ef86f1cc7cc9c78e728b34a6d1fd" + +[[package]] +name = "futures-util" +version = "0.3.34" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "0d50a92467f8ba5dd6e3ee5d4bd04d73ab2e4e1c44474a0674821dfce14b79bc" +dependencies = [ + "futures-core", + "futures-task", + "pin-project-lite", + "slab", +] + [[package]] name = "gemm" version = "0.19.0" @@ -858,15 +841,15 @@ dependencies = [ [[package]] name = "generativity" -version = "1.1.0" +version = "1.2.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5881e4c3c2433fe4905bb19cfd2b5d49d4248274862b68c27c33d9ba4e13f9ec" +checksum = "d2c81fb5260e37854d09d5c87183309fd8c555b75289427884b25660bc87a85e" [[package]] name = "generator" -version = "0.8.8" +version = "0.8.9" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "52f04ae4152da20c76fe800fa48659201d5cf627c5149ca0b707b69d7eef6cf9" +checksum = "b3b854b0e584ead1a33f18b2fcad7cf7be18b3875c78816b753639aa501513ae" dependencies = [ "cc", "cfg-if", @@ -877,16 +860,6 @@ dependencies = [ "windows-result", ] -[[package]] -name = "generic-array" -version = "0.14.7" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "85649ca51fd72272d7821adaf274ad91c288277713d9c18820d8499a7ff69e9a" -dependencies = [ - "typenum", - "version_check", -] - [[package]] name = "getrandom" version = "0.3.4" @@ -901,16 +874,14 @@ dependencies = [ [[package]] name = "getrandom" -version = "0.4.2" +version = "0.4.3" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0de51e6874e94e7bf76d726fc5d13ba782deca734ff60d5bb2fb2607c7406555" +checksum = "300e883d756b2e4ec94e02791f39b04b522276138852cfc41d9fb7e904106099" dependencies = [ "cfg-if", "libc", "r-efi 6.0.0", "rand_core 0.10.1", - "wasip2", - "wasip3", ] [[package]] @@ -945,9 +916,9 @@ checksum = "f70749695b063ecbf6b62949ccccde2e733ec3ecbbd71d467dca4e5c6c97cca0" [[package]] name = "glam" -version = "0.33.2" +version = "0.33.3" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7f22fb22f065b308be0d8724e3706c7fa3fc2a6c7d6899df4cad7860e7a75436" +checksum = "7360bd2cd76e0cd9032d42cf2922155cecea2685b0cfa4630c3246df030bcfd6" [[package]] name = "half" @@ -979,9 +950,9 @@ checksum = "841d1cc9bed7f9236f321df977030373f4a4163ae1a7dbfe1a51a2c1a51d9100" [[package]] name = "hashbrown" -version = "0.17.0" +version = "0.17.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4f467dd6dccf739c208452f8014c75c18bb8301b050ad1cfb27153803edb0f51" +checksum = "ed5909b6e89a2db4456e54cd5f673791d7eca6732202bbf2a9cc504fe2f9b84a" dependencies = [ "foldhash 0.2.0", ] @@ -998,12 +969,6 @@ version = "0.5.2" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "fc0fef456e4baa96da950455cd02c081ca953b141298e41db3fc7e36b1da849c" -[[package]] -name = "id-arena" -version = "2.3.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "3d3067d79b975e8844ca9eb072e16b31c3c1c36928edf9c6789548c524d0d954" - [[package]] name = "indexmap" version = "2.14.0" @@ -1011,9 +976,7 @@ source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "d466e9454f08e4a911e14806c24e16fba1b4c121d1ea474396f396069cf949d9" dependencies = [ "equivalent", - "hashbrown 0.17.0", - "serde", - "serde_core", + "hashbrown 0.17.1", ] [[package]] @@ -1035,11 +998,12 @@ checksum = "8f42a60cbdf9a97f5d2305f08a87dc4e09308d1276d28c869c684d7777685682" [[package]] name = "js-sys" -version = "0.3.95" +version = "0.3.104" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2964e92d1d9dc3364cae4d718d93f227e3abb088e747d92e0395bfdedf1c12ca" +checksum = "0e0c1080212aad755ea003d18543e8768dd432c48819efd73a7bf1e39b7a5a3a" dependencies = [ - "once_cell", + "cfg-if", + "futures-util", "wasm-bindgen", ] @@ -1049,17 +1013,11 @@ version = "1.5.0" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "bbd2bcb4c963f2ddae06a2efc7e9f3591312473c50c6685e1f298068316e66fe" -[[package]] -name = "leb128fmt" -version = "0.1.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "09edd9e8b54e49e587e4f6295a7d29c3ea94d469cb40ab8ca70b288248a81db2" - [[package]] name = "libc" -version = "0.2.185" +version = "0.2.189" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "52ff2c0fe9bc6cb6b14a0592c2ff4fa9ceb83eea9db979b0487cd054946a2b8f" +checksum = "3eaf3ede3fee6db1a4c2ee091bf8a8b4dccdc6d17f656fb07896ee72867612f2" [[package]] name = "libm" @@ -1087,9 +1045,9 @@ dependencies = [ [[package]] name = "log" -version = "0.4.29" +version = "0.4.33" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5e5032e24019045c762d3c0f28f5b6b8bbf38563a65908389bf7978758920897" +checksum = "0ceec5bc11778974d1bcb055b18002eba7f4b3518b6a0081b3af5f21666da9ad" [[package]] name = "loom" @@ -1124,9 +1082,9 @@ dependencies = [ [[package]] name = "matrixmultiply" -version = "0.3.10" +version = "0.3.11" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a06de3016e9fae57a36fd14dba131fccf49f74b40b7fbdb472f96e361ec71a08" +checksum = "3f607c237553f086e7043417a51df26b2eb899d3caff94e6a67592ff992fedc7" dependencies = [ "autocfg", "rawpointer", @@ -1134,9 +1092,9 @@ dependencies = [ [[package]] name = "memchr" -version = "2.8.0" +version = "2.8.3" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f8ca58f447f06ed17d5fc4043ce1b10dd205e060fb3ce5b979b8ed8e59ff3f79" +checksum = "cf8baf1c55e62ffcace7a9f06f4bd9cd3f0c4beb022d3b367256b91b87513d98" [[package]] name = "memmap2" @@ -1166,13 +1124,13 @@ dependencies = [ "glam 0.30.10", "glam 0.31.1", "glam 0.32.1", - "glam 0.33.2", + "glam 0.33.3", "matrixmultiply", "nalgebra-macros", "num-complex", "num-rational", "num-traits", - "rand 0.10.1", + "rand 0.10.2", "simba", "typenum", ] @@ -1185,7 +1143,7 @@ checksum = "973e7178a678cfd059ccec50887658d482ce16b0aa9da3888ddeab5cd5eb4889" dependencies = [ "proc-macro2", "quote", - "syn 2.0.117", + "syn 2.0.119", ] [[package]] @@ -1296,9 +1254,9 @@ dependencies = [ [[package]] name = "num-bigint" -version = "0.4.6" +version = "0.4.8" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a5e44f723f1133c9deac646763579fdb3ac745e418f2a7af9cd0c431da1f20b9" +checksum = "c89e69e7e0f03bea5ef08013795c25018e101932225a656383bd384495ecc367" dependencies = [ "num-integer", "num-traits", @@ -1312,20 +1270,20 @@ checksum = "73f88a1307638156682bada9d7604135552957b7818057dcef22705b4d509495" dependencies = [ "bytemuck", "num-traits", - "rand 0.8.6", + "rand 0.8.7", ] [[package]] name = "num-conv" -version = "0.2.1" +version = "0.2.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c6673768db2d862beb9b39a78fdcb1a69439615d5794a1be50caa9bc92c81967" +checksum = "521739c6d2bac4aa25192232afe6841231376b2b26d4d9fae5ecf8ca5772e441" [[package]] name = "num-integer" -version = "0.1.46" +version = "0.1.47" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7969661fd2958a5cb096e56c8e1ad0444ac2bbcd0061bd28660485a44879858f" +checksum = "7ce2d95d4b3734dc35aa2f45e1aa22cd416814592a4f9d9205e11affd5b8e10b" dependencies = [ "num-traits", ] @@ -1398,9 +1356,9 @@ checksum = "57c0d7b74b563b49d38dae00a0c37d4d6de9b432382b2892f0574ddcae73fd0a" [[package]] name = "pest" -version = "2.8.6" +version = "2.9.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e0848c601009d37dfa3430c4666e147e49cdcf1b92ecd3e63657d8a5f19da662" +checksum = "5a07a60cc7a4d00c91f95c685609d1d2f79050e6804b70ebedd7650f0b839bcf" dependencies = [ "memchr", "ucd-trie", @@ -1408,9 +1366,9 @@ dependencies = [ [[package]] name = "pest_derive" -version = "2.8.6" +version = "2.9.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "11f486f1ea21e6c10ed15d5a7c77165d0ee443402f0780849d1768e7d9d6fe77" +checksum = "b3a83744a5c8455b8b3e0dc5031362780a347c878bdd11584d1a8984228cc88d" dependencies = [ "pest", "pest_generator", @@ -1418,25 +1376,24 @@ dependencies = [ [[package]] name = "pest_generator" -version = "2.8.6" +version = "2.9.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8040c4647b13b210a963c1ed407c1ff4fdfa01c31d6d2a098218702e6664f94f" +checksum = "e0cd3451aa3de60d4b9a1e736885e4dea6b31617598026f12256ad566d63304a" dependencies = [ "pest", "pest_meta", "proc-macro2", "quote", - "syn 2.0.117", + "syn 2.0.119", ] [[package]] name = "pest_meta" -version = "2.8.6" +version = "2.9.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "89815c69d36021a140146f26659a81d6c2afa33d216d736dd4be5381a7362220" +checksum = "e04d3a0849e241d7dfce834c83b1c5edc8622009e8dd51a12ba1927c32f05496" dependencies = [ "pest", - "sha2", ] [[package]] @@ -1472,38 +1429,38 @@ dependencies = [ "pharmsol-dsl", "pharmsol-macros", "quick_cache", - "rand 0.10.1", + "rand 0.10.2", "rand_distr 0.6.0", "rayon", "serde", "serde_json", "statrs", - "thiserror 2.0.18", + "thiserror 2.0.20", "tracing", ] [[package]] name = "pharmsol-dsl" -version = "0.28.6" +version = "0.28.7" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0d4c0775432277262cc292a595e57226f0ebcb8607ffd4aaacfcc74b0bbe4d89" +checksum = "dda2763e82902a031378f2141f5a35244caacdba1c7c291092acd04a7bb423d1" dependencies = [ "serde", "serde_json", - "thiserror 2.0.18", + "thiserror 2.0.20", ] [[package]] name = "pharmsol-macros" -version = "0.28.6" +version = "0.28.7" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7aee09410f8d55ddeed7350796e086f45b9f508b34d9e85e3e5927e728dca757" +checksum = "a94ca47f20c72586a9093face0f325a19c41d5949ca5ee12e2d28c061c6c2c01" dependencies = [ "pharmsol-dsl", "proc-macro-crate", "proc-macro2", "quote", - "syn 3.0.2", + "syn 3.0.3", ] [[package]] @@ -1537,7 +1494,7 @@ dependencies = [ "faer", "ndarray", "pharmsol", - "rand 0.10.1", + "rand 0.10.2", "rayon", "serde", "serde_json", @@ -1548,9 +1505,9 @@ dependencies = [ [[package]] name = "portable-atomic" -version = "1.13.1" +version = "1.15.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c33a9471896f1c69cecef8d20cbe2f7accd12527ce60845ff44c153bb2a21b49" +checksum = "05c8b63e8d9609db387f0324918f81d68fe27748f084ef092fb35954d0539a85" [[package]] name = "portable-atomic-util" @@ -1576,16 +1533,6 @@ dependencies = [ "zerocopy", ] -[[package]] -name = "prettyplease" -version = "0.2.37" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "479ca8adacdd7ce8f1fb39ce9ecccbfe93a3f1344b3d0d97f20bc0196208f62b" -dependencies = [ - "proc-macro2", - "syn 2.0.117", -] - [[package]] name = "private-gemm-x86" version = "0.1.20" @@ -1613,18 +1560,18 @@ dependencies = [ [[package]] name = "proc-macro2" -version = "1.0.106" +version = "1.0.107" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8fd00f0bb2e90d81d1044c2b32617f68fcb9fa3bb7640c23e9c748e53fb30934" +checksum = "985e7ec9bb745e6ce6535b544d84d6cd6f7ad8bd711c398938ae983b91a766d9" dependencies = [ "unicode-ident", ] [[package]] name = "pulp" -version = "0.22.2" +version = "0.22.3" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2e205bb30d5b916c55e584c22201771bcf2bad9aabd5d4127f38387140c38632" +checksum = "046aa45b989642ec2e4717c8e72d677b13edd831a4d3b6cf37d9a3e54912496a" dependencies = [ "bytemuck", "cfg-if", @@ -1639,9 +1586,9 @@ dependencies = [ [[package]] name = "pulp-wasm-simd-flag" -version = "0.1.0" +version = "0.1.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "40e24eee682d89fb193496edf918a7f407d30175b2e785fe057e4392dfd182e0" +checksum = "1d8f70e07b9c3962945a74e59ca1c511bba65b6419468acc217c457d93f3c740" [[package]] name = "py_literal" @@ -1676,15 +1623,15 @@ checksum = "403c1a912fec895cafb223201e368234842acb9220aaf08ab042ae89ba5f135c" dependencies = [ "equivalent", "foldhash 0.2.0", - "hashbrown 0.17.0", + "hashbrown 0.17.1", "parking_lot", ] [[package]] name = "quote" -version = "1.0.45" +version = "1.0.47" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "41f2619966050689382d2b44f664f4bc593e129785a36d6ee376ddf37259b924" +checksum = "1fbf4db142a473a8d80c26bbf18454ed458bf8d26c8219c331daecfdbd079001" dependencies = [ "proc-macro2", ] @@ -1703,18 +1650,18 @@ checksum = "f8dcc9c7d52a811697d2151c701e0d08956f92b0e24136cf4cf27b57a6a0d9bf" [[package]] name = "rand" -version = "0.8.6" +version = "0.8.7" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5ca0ecfa931c29007047d1bc58e623ab12e5590e8c7cc53200d5202b69266d8a" +checksum = "22f6172bdec972074665ed81ed53b71da00bfc44b65a753cfde883ec4c702a1a" dependencies = [ "rand_core 0.6.4", ] [[package]] name = "rand" -version = "0.9.4" +version = "0.9.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "44c5af06bb1b7d3216d91932aed5265164bf384dc89cd6ba05cf59a35f5f76ea" +checksum = "b9ef1d0d795eb7d84685bca4f72f3649f064e6641543d3a8c415898726a57b41" dependencies = [ "rand_chacha", "rand_core 0.9.5", @@ -1722,12 +1669,12 @@ dependencies = [ [[package]] name = "rand" -version = "0.10.1" +version = "0.10.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d2e8e8bcc7961af1fdac401278c6a831614941f6164ee3bf4ce61b7edb162207" +checksum = "c7f5fa3a058cd35567ef9bfa5e75732bee0f9e4c55fa90477bef2dfcdbc4be80" dependencies = [ "chacha20", - "getrandom 0.4.2", + "getrandom 0.4.3", "rand_core 0.10.1", ] @@ -1769,7 +1716,7 @@ source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "6a8615d50dcf34fa31f7ab52692afec947c4dd0ab803cc87cb3b0b4570ff7463" dependencies = [ "num-traits", - "rand 0.9.4", + "rand 0.9.5", ] [[package]] @@ -1779,7 +1726,7 @@ source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "4d431c2703ccf129de4d45253c03f49ebb22b97d6ad79ee3ecfc7e3f4862c1d8" dependencies = [ "num-traits", - "rand 0.10.1", + "rand 0.10.2", ] [[package]] @@ -1797,7 +1744,7 @@ version = "11.6.0" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "498cd0dc59d73224351ee52a95fee0f1a617a2eae0e7d9d720cc622c73a54186" dependencies = [ - "bitflags 2.11.1", + "bitflags 2.13.1", ] [[package]] @@ -1828,13 +1775,13 @@ dependencies = [ [[package]] name = "readonly" -version = "0.2.13" +version = "0.2.14" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f2a62d85ed81ca5305dc544bd42c8804c5060b78ffa5ad3c64b0fb6a8c13d062" +checksum = "67a77cd6f1a55ff3cb1969c2618f73107efaa6de1daf796ad60ce8f737ae97c1" dependencies = [ "proc-macro2", "quote", - "syn 2.0.117", + "syn 3.0.3", ] [[package]] @@ -1849,18 +1796,18 @@ version = "0.5.18" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "ed2bf2547551a7053d6fdfafda3f938979645c44812fbfcda098faae3f1a362d" dependencies = [ - "bitflags 2.11.1", + "bitflags 2.13.1", ] [[package]] name = "regalloc2" -version = "0.15.1" +version = "0.15.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "de2c52737737f8609e94f975dee22854a2d5c125772d4b1cf292120f4d45c186" +checksum = "757712e8e61590d6d4f5d563483755538b5aa13467837a3b41cd9832509a7f85" dependencies = [ "allocator-api2", "bumpalo", - "hashbrown 0.17.0", + "hashbrown 0.17.1", "log", "rustc-hash", "smallvec", @@ -1868,9 +1815,9 @@ dependencies = [ [[package]] name = "regex-automata" -version = "0.4.14" +version = "0.4.18" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "6e1dd4122fc1595e8162618945476892eefca7b88c52820e74af6262213cae8f" +checksum = "ad8553b9b26413251cbf30e620595c7a41b3887f03da04579c0e6b0d6a06b4b2" dependencies = [ "aho-corasick", "memchr", @@ -1879,9 +1826,9 @@ dependencies = [ [[package]] name = "regex-syntax" -version = "0.8.10" +version = "0.8.11" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "dc897dd8d9e8bd1ed8cdad82b5966c3e0ecae09fb1907d58efaa013543185d0a" +checksum = "d6f6ff9a378485b298a5286656da665ba74413d36db0979633275d2e708145d4" [[package]] name = "region" @@ -1903,9 +1850,9 @@ checksum = "6b1e7f9a428571be2dc5bc0505c13fb6bf936822b894ec87abf8a08a4e51742d" [[package]] name = "rustversion" -version = "1.0.22" +version = "1.0.23" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b39cdef0fa800fc44525c84ccb54a029961a8215f9619753635a9c0d2538d46d" +checksum = "cf54715a573b99ac80df0bc206da022bcd442c974952c7b9720069370852e21f" [[package]] name = "ryu" @@ -1943,12 +1890,6 @@ version = "1.2.0" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "94143f37725109f92c262ed2cf5e59bce7498c01bcc1502d7b9afe439a4e9f49" -[[package]] -name = "semver" -version = "1.0.28" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8a7852d02fc848982e0c167ef163aaff9cd91dc640ba85e263cb1ce46fae51cd" - [[package]] name = "seq-macro" version = "0.3.6" @@ -1957,9 +1898,9 @@ checksum = "1bc711410fbe7399f390ca1c3b60ad0f53f80e95c5eb935e52268a0e2cd49acc" [[package]] name = "serde" -version = "1.0.228" +version = "1.0.229" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9a8e94ea7f378bd32cbbd37198a4a91436180c5bb472411e48b5ec2e2124ae9e" +checksum = "4148590afebada386688f18773da617792bf2ef03ffc1e4cbd2b1d45b023e0ba" dependencies = [ "serde_core", "serde_derive", @@ -1967,29 +1908,29 @@ dependencies = [ [[package]] name = "serde_core" -version = "1.0.228" +version = "1.0.229" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "41d385c7d4ca58e59fc732af25c3983b67ac852c1a25000afe1175de458b67ad" +checksum = "67dca2c9c51e58a4791a4b1ed58308b39c64224d349a935ab5039aa360942a48" dependencies = [ "serde_derive", ] [[package]] name = "serde_derive" -version = "1.0.228" +version = "1.0.229" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d540f220d3187173da220f885ab66608367b6574e925011a9353e4badda91d79" +checksum = "e7a5d71263a5a7d47b41f6b3f06ba276f10cc18b0931f1799f710578e2309348" dependencies = [ "proc-macro2", "quote", - "syn 2.0.117", + "syn 3.0.3", ] [[package]] name = "serde_json" -version = "1.0.149" +version = "1.0.151" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "83fc039473c5595ace860d8c4fafa220ff474b3fc6bfdb4293327f1a37e94d86" +checksum = "c841b55ecdae098c80dcae9cf767f6f8a0c2cdb3416bbef72181df4d0fe73f14" dependencies = [ "itoa", "memchr", @@ -1998,17 +1939,6 @@ dependencies = [ "zmij", ] -[[package]] -name = "sha2" -version = "0.10.9" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a7507d819769d01a365ab707794a4084392c824f54a7a6a7862f8c3d0892b283" -dependencies = [ - "cfg-if", - "cpufeatures 0.2.17", - "digest", -] - [[package]] name = "sharded-slab" version = "0.1.7" @@ -2020,15 +1950,15 @@ dependencies = [ [[package]] name = "shlex" -version = "1.3.0" +version = "2.0.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0fda2ff0d084019ba4d7c6f371c95d8fd75ce3524c3cb8fb653a3023f6323e64" +checksum = "f8fadd59c855ef2080decdef8ff161eb6661b86933c9d82e5ba29dc602a55aba" [[package]] name = "simba" -version = "0.10.0" +version = "0.10.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8f45c644a9f3a386f9288625d9f0c1e999e1acf07a37df35d0516c7f199d9cb2" +checksum = "f1a7200d82ff1c7b4235efd12f11e2537a402c91cf83a5cb97ce80eef787fde7" dependencies = [ "approx", "num-complex", @@ -2036,11 +1966,17 @@ dependencies = [ "wide", ] +[[package]] +name = "slab" +version = "0.4.12" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "0c790de23124f9ab44544d7ac05d60440adc586479ce501c1d6d7da3cd8c9cf5" + [[package]] name = "smallvec" -version = "1.15.1" +version = "1.15.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "67b1b7a3b5fe4f1376887184045fcf45c69e92af734b7aaddc05fb777b6fbd03" +checksum = "8ed6a63f02c8539c91a8685a86f4099661ba3da017932f6ebbea6de3f0fa7c90" [[package]] name = "sobol_burley" @@ -2069,15 +2005,15 @@ checksum = "6ce2be8dc25455e1f91df71bfa12ad37d7af1092ae736f3a6cd0e37bc7810596" [[package]] name = "statrs" -version = "0.19.0" +version = "0.19.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c78553aa710187998fc7c7945c18889c59ef199ff7d2146ab90998b431b29eea" +checksum = "c1837f9a1bd13dabbdbb04489c39451482d3cdd35a6e1a0d0f3570dea2b8c8be" dependencies = [ "approx", "nalgebra", "num-traits", - "rand 0.10.1", - "thiserror 2.0.18", + "rand 0.10.2", + "thiserror 2.0.20", ] [[package]] @@ -2093,9 +2029,9 @@ dependencies = [ [[package]] name = "syn" -version = "2.0.117" +version = "2.0.119" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e665b8803e7b1d2a727f4023456bbbbe74da67099c585258af0ad9c5013b9b99" +checksum = "872831b642d1a07999a962a351ed35b955ea2cfc8f3862091e2a240a84f17297" dependencies = [ "proc-macro2", "quote", @@ -2104,9 +2040,9 @@ dependencies = [ [[package]] name = "syn" -version = "3.0.2" +version = "3.0.3" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a207d6d6a2b7fc470b80443726053f18a2481b7e1eee970597051596567987a3" +checksum = "53e9bae58849f64dfa4f5d5ae372c8341f7305f82a3868709269343628b659a3" dependencies = [ "proc-macro2", "quote", @@ -2119,7 +2055,7 @@ version = "0.6.0" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "01198a2debb237c62b6826ec7081082d951f46dbb64b0e8c7649a452230d1dfc" dependencies = [ - "bitflags 2.11.1", + "bitflags 2.13.1", "byteorder", "enum-as-inner", "libc", @@ -2144,11 +2080,11 @@ dependencies = [ [[package]] name = "thiserror" -version = "2.0.18" +version = "2.0.20" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4288b5bcbc7920c07a1149a35cf9590a2aa808e0bc1eafaade0b80947865fbc4" +checksum = "ec86235f5fcc2a73650310756d2ac5b138a5780bbbdfae3eeccec992c435ba4f" dependencies = [ - "thiserror-impl 2.0.18", + "thiserror-impl 2.0.20", ] [[package]] @@ -2159,37 +2095,36 @@ checksum = "4fee6c4efc90059e10f81e6d42c60a18f76588c3d74cb83a0b242a2b6c7504c1" dependencies = [ "proc-macro2", "quote", - "syn 2.0.117", + "syn 2.0.119", ] [[package]] name = "thiserror-impl" -version = "2.0.18" +version = "2.0.20" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ebc4ee7f67670e9b64d05fa4253e753e016c6c95ff35b89b7941d6b856dec1d5" +checksum = "bc04cd3e1236dd4a98afca4569f2deb3f120e5422a4023be2cb683f8486292af" dependencies = [ "proc-macro2", "quote", - "syn 2.0.117", + "syn 3.0.3", ] [[package]] name = "thread_local" -version = "1.1.9" +version = "1.1.10" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f60246a4944f24f6e018aa17cdeffb7818b76356965d03b07d6a9886e8962185" +checksum = "1ad99c4c6d32803332c548b1af0540b357b3f5fc0be8f6c6bfe8b2e6ae784070" dependencies = [ "cfg-if", ] [[package]] name = "time" -version = "0.3.47" +version = "0.3.55" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "743bd48c283afc0388f9b8827b976905fb217ad9e647fae3a379a9283c4def2c" +checksum = "cdb87b95ec50ddfa440816d227a17b2ccbdda963a316a727fda0fc4334f7d134" dependencies = [ "deranged", - "itoa", "num-conv", "powerfmt", "serde_core", @@ -2199,15 +2134,15 @@ dependencies = [ [[package]] name = "time-core" -version = "0.1.8" +version = "0.1.9" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7694e1cfe791f8d31026952abf09c69ca6f6fa4e1a1229e18988f06a04a12dca" +checksum = "9e1c906769ad99c88eaa54e728060edef082f8e358ff32030cb7c7d315e81109" [[package]] name = "time-macros" -version = "0.2.27" +version = "0.2.32" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2e70e4c5a0e0a8a4823ad65dfe1a6930e4f4d756dcd9dd7939022b5e8c501215" +checksum = "7e689342a48d2ea927c87ea50cabf8594854bf940e9310208848d680d668ed85" dependencies = [ "num-conv", "time-core", @@ -2262,7 +2197,7 @@ checksum = "7490cfa5ec963746568740651ac6781f701c9c5ea257c58e057f3ba8cf69e8da" dependencies = [ "proc-macro2", "quote", - "syn 2.0.117", + "syn 2.0.119", ] [[package]] @@ -2307,9 +2242,9 @@ dependencies = [ [[package]] name = "typenum" -version = "1.20.0" +version = "1.20.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "40ce102ab67701b8526c123c1bab5cbe42d7040ccfd0f64af1a385808d2f43de" +checksum = "b6f5e870be6c3b371b77fe0ee0bafb859fa4964b4404c27de1d380043c4dda20" [[package]] name = "ucd-trie" @@ -2323,12 +2258,6 @@ version = "1.0.24" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "e6e4313cd5fcd3dad5cafa179702e2b244f760991f45397d14d4ebf38247da75" -[[package]] -name = "unicode-xid" -version = "0.2.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ebc1c04c71510c7f702b52b7c350734c9ff1295c464a03335b00bb84fc54f853" - [[package]] name = "valuable" version = "0.1.1" @@ -2353,27 +2282,18 @@ dependencies = [ [[package]] name = "wasip2" -version = "1.0.3+wasi-0.2.9" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "20064672db26d7cdc89c7798c48a0fdfac8213434a1186e5ef29fd560ae223d6" -dependencies = [ - "wit-bindgen 0.57.1", -] - -[[package]] -name = "wasip3" -version = "0.4.0+wasi-0.3.0-rc-2026-01-06" +version = "1.0.4+wasi-0.2.12" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5428f8bf88ea5ddc08faddef2ac4a67e390b88186c703ce6dbd955e1c145aca5" +checksum = "b67efb37e106e55ce722a510d6b5f9c17f083e5fc79afc2badeb12cc313d9487" dependencies = [ - "wit-bindgen 0.51.0", + "wit-bindgen", ] [[package]] name = "wasm-bindgen" -version = "0.2.118" +version = "0.2.127" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0bf938a0bacb0469e83c1e148908bd7d5a6010354cf4fb73279b7447422e3a89" +checksum = "1b70935747edd64d89de3efa29d73789b806c15798f8e7dca4d8ac356b50ce70" dependencies = [ "cfg-if", "once_cell", @@ -2384,9 +2304,9 @@ dependencies = [ [[package]] name = "wasm-bindgen-macro" -version = "0.2.118" +version = "0.2.127" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "eeff24f84126c0ec2db7a449f0c2ec963c6a49efe0698c4242929da037ca28ed" +checksum = "77775f8f3f7217702089053b94958f8f54061a3f663417df76e19cbdcca29bc1" dependencies = [ "quote", "wasm-bindgen-macro-support", @@ -2394,67 +2314,33 @@ dependencies = [ [[package]] name = "wasm-bindgen-macro-support" -version = "0.2.118" +version = "0.2.127" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9d08065faf983b2b80a79fd87d8254c409281cf7de75fc4b773019824196c904" +checksum = "e11d33f857dc2fb11b8bc75aee111aa9cbeb12cd9f25efd3d4c2a3dd4e235284" dependencies = [ "bumpalo", "proc-macro2", "quote", - "syn 2.0.117", + "syn 2.0.119", "wasm-bindgen-shared", ] [[package]] name = "wasm-bindgen-shared" -version = "0.2.118" +version = "0.2.127" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5fd04d9e306f1907bd13c6361b5c6bfc7b3b3c095ed3f8a9246390f8dbdee129" +checksum = "7ef64dbcc55df09c7e5a46182d181c2cfa3e925f3da937ea764728b4bbb9dcbf" dependencies = [ "unicode-ident", ] -[[package]] -name = "wasm-encoder" -version = "0.244.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "990065f2fe63003fe337b932cfb5e3b80e0b4d0f5ff650e6985b1048f62c8319" -dependencies = [ - "leb128fmt", - "wasmparser", -] - -[[package]] -name = "wasm-metadata" -version = "0.244.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "bb0e353e6a2fbdc176932bbaab493762eb1255a7900fe0fea1a2f96c296cc909" -dependencies = [ - "anyhow", - "indexmap", - "wasm-encoder", - "wasmparser", -] - -[[package]] -name = "wasmparser" -version = "0.244.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "47b807c72e1bac69382b3a6fb3dbe8ea4c0ed87ff5629b8685ae6b9a611028fe" -dependencies = [ - "bitflags 2.11.1", - "hashbrown 0.15.5", - "indexmap", - "semver", -] - [[package]] name = "wasmtime-internal-core" version = "47.0.3" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "8a0092c4b9d070ac5e278b6d0db10f5e71214190f0347ca57502b4692f796321" dependencies = [ - "hashbrown 0.17.0", + "hashbrown 0.17.1", "libm", ] @@ -2482,9 +2368,9 @@ dependencies = [ [[package]] name = "wide" -version = "1.5.0" +version = "1.6.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "dfdfe6a32973f2d1b268b8895845a8a96cac2f0191e72c27cc929036060dbf89" +checksum = "de2aaf408e58689c2096682331b1f42bb2d9f2ed6b11560407d023cd0a6c634e" dependencies = [ "bytemuck", "safe_arch", @@ -2662,122 +2548,34 @@ dependencies = [ "memchr", ] -[[package]] -name = "wit-bindgen" -version = "0.51.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d7249219f66ced02969388cf2bb044a09756a083d0fab1e566056b04d9fbcaa5" -dependencies = [ - "wit-bindgen-rust-macro", -] - [[package]] name = "wit-bindgen" version = "0.57.1" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "1ebf944e87a7c253233ad6766e082e3cd714b5d03812acc24c318f549614536e" -[[package]] -name = "wit-bindgen-core" -version = "0.51.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ea61de684c3ea68cb082b7a88508a8b27fcc8b797d738bfc99a82facf1d752dc" -dependencies = [ - "anyhow", - "heck", - "wit-parser", -] - -[[package]] -name = "wit-bindgen-rust" -version = "0.51.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b7c566e0f4b284dd6561c786d9cb0142da491f46a9fbed79ea69cdad5db17f21" -dependencies = [ - "anyhow", - "heck", - "indexmap", - "prettyplease", - "syn 2.0.117", - "wasm-metadata", - "wit-bindgen-core", - "wit-component", -] - -[[package]] -name = "wit-bindgen-rust-macro" -version = "0.51.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0c0f9bfd77e6a48eccf51359e3ae77140a7f50b1e2ebfe62422d8afdaffab17a" -dependencies = [ - "anyhow", - "prettyplease", - "proc-macro2", - "quote", - "syn 2.0.117", - "wit-bindgen-core", - "wit-bindgen-rust", -] - -[[package]] -name = "wit-component" -version = "0.244.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9d66ea20e9553b30172b5e831994e35fbde2d165325bec84fc43dbf6f4eb9cb2" -dependencies = [ - "anyhow", - "bitflags 2.11.1", - "indexmap", - "log", - "serde", - "serde_derive", - "serde_json", - "wasm-encoder", - "wasm-metadata", - "wasmparser", - "wit-parser", -] - -[[package]] -name = "wit-parser" -version = "0.244.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ecc8ac4bc1dc3381b7f59c34f00b67e18f910c2c0f50015669dde7def656a736" -dependencies = [ - "anyhow", - "id-arena", - "indexmap", - "log", - "semver", - "serde", - "serde_derive", - "serde_json", - "unicode-xid", - "wasmparser", -] - [[package]] name = "zerocopy" -version = "0.8.48" +version = "0.8.56" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "eed437bf9d6692032087e337407a86f04cd8d6a16a37199ed57949d415bd68e9" +checksum = "556764e583adb45a9f8d413c2a147fa7e8d821e48e12b14fd560b607998b75eb" dependencies = [ "zerocopy-derive", ] [[package]] name = "zerocopy-derive" -version = "0.8.48" +version = "0.8.56" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "70e3cd084b1788766f53af483dd21f93881ff30d7320490ec3ef7526d203bad4" +checksum = "f2ab42fc20575779bd240faa45f94a74256f755c0fa9e89f0ede20d91d0cdfc1" dependencies = [ "proc-macro2", "quote", - "syn 2.0.117", + "syn 2.0.119", ] [[package]] name = "zmij" -version = "1.0.21" +version = "1.0.23" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b8848ee67ecc8aedbaf3e4122217aff892639231befc6a1b58d29fff4c2cabaa" +checksum = "29666d0abbfad1e3dc4dcf6144730dd3a3ab225bbbdac83319345b1b44ccfc1b" diff --git a/DESCRIPTION b/DESCRIPTION index ef0693da..e237dad0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,6 +2,8 @@ Type: Package Package: Pmetrics Title: Pmetrics for Population Modeling and Simulation Version: 3.2.3 +Author: Michael Neely [aut, cre], Julián Otálvaro [aut], Markus Hovd [aut], Walter Yamada [ctb], Alan Schumitzky [ctb], Rong Chen [ctb], Michael van Guilder [ctb], David Bayard [ctb], Robert Leary [ctb] +Maintainer: Michael Neely Authors@R: c( person("Michael", "Neely", , "mneely@usc.edu", role = c("aut", "cre")), person("Julián", "Otálvaro", , "juliandavid347@gmail.com", role = "aut"), diff --git a/NAMESPACE b/NAMESPACE index 922fc117..4dd39d95 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,7 +4,6 @@ S3method(plot,PM_cov) S3method(plot,PM_cycle) S3method(plot,PM_cycle_data) S3method(plot,PM_data) -S3method(plot,PM_data_data) S3method(plot,PM_final) S3method(plot,PM_final_data) S3method(plot,PM_model) @@ -17,6 +16,7 @@ S3method(plot,PM_pta) S3method(plot,PM_sim) S3method(plot,PM_valid) S3method(plot,PMvalid) +S3method(plot,bd) S3method(print,PM_compare) S3method(print,PMerr) S3method(print,PMnpc) @@ -97,6 +97,8 @@ export(add_smooth) export(additive) export(all_is_numeric) export(apps) +export(bd) +export(bd_post) export(check_updates) export(clear_build) export(cli_ask) @@ -181,6 +183,7 @@ importFrom(dplyr, group_map, if_else, inner_join, + left_join, mutate, n, nest_by, @@ -194,6 +197,7 @@ importFrom(dplyr, select, slice, slice_head, + slice_max, slice_tail, starts_with, summarize, diff --git a/R/PM_bestdose.R b/R/PM_bestdose.R new file mode 100644 index 00000000..6b16b9e8 --- /dev/null +++ b/R/PM_bestdose.R @@ -0,0 +1,1243 @@ +#' @title +#' Object to contain BestDose optimization results +#' +#' @description +#' `r lifecycle::badge("experimental")` +#' +#' This object is created after a successful BestDose optimization run. +#' BestDose finds optimal dosing regimens to achieve target drug concentrations +#' or AUC values using Bayesian optimization. +#' +#' @importFrom dplyr filter left_join group_by slice_max select ungroup bind_rows arrange pull group_map mutate +#' @importFrom plotly plot_ly add_lines add_markers layout +#' @importFrom purrr list_rbind +#' @export +bd <- R6::R6Class( + "bd", + public = list( + #' @field past PM_data object containing past patient data used in the optimization (if applicable) + past = NULL, + #' @field past_pred PM_sim object containing model predictions for the past data + past_pred = NULL, + #' @field future PM_data object containing future data used in the optimization + future = NULL, + #' @field future_pred PM_sim object containing model predictions for the future data + future_pred = NULL, + #' @field result List containing optimization results, including optimal doses, predictions, and objective function value + result = NULL, + #' @field posterior The `bd_post` object used to compute the posterior distribution (if applicable) + posterior = NULL, + #' @field prior_weight The prior weight (lambda) used in the optimization (if applicable) + prior_weight = NULL, + #' @field start Start specification provided by user (numeric hours or datetime string) + start = NULL, + #' @field start_offset Resolved numeric offset (hours) used internally; NULL means use target times as-is + start_offset = 0, + #' @field future_requested_doses Numeric vector of originally requested future doses (0 = optimize, non-zero = fixed) + future_requested_doses = NULL, + #' @field future_target_info List with target_type, target, and target_time from the original future specification + future_target_info = NULL, + #' @description + #' Initialize a `bd` object by running a one-shot BestDose optimization. + #' Creates the posterior internally, then optimizes. For reusing the posterior + #' across multiple optimizations, use `bd_post$new()` followed by `$optimize()`. + #' @param model PM_model object or path to compiled model + #' @param prior Prior parameter value distributions for the model, can be a [PM_result], [PM_final], or path to `theta.csv` file. + #' @param past_data PM_data object or path to CSV file with past patient data (optional). Omitting this will plan a new regimen for the patient + #' based on the population prior without any individualization other than inclusion of any covariates which are in the model. + #' @param future The future regimen to optimize. It can be one of three things: + #' * A list describing future dosing/target setup with elements: + #' - `dose` The amount to administer (required). Use `0` to optimize that dose to achieve the target; any other value is treated as fixed. + #' Can be a scalar or a numeric vector. If a vector is provided, each element corresponds to each dose event in order. + #' - `frequency` How often to administer dose(s) (default 24 hours). Can be a scalar or numeric vector; when vectorized, + #' element `i` is the interval after dose `i` and before dose `i+1`. + #' - `route` Either 0 for oral/bolus, or a value >0 indicating infusion duration. Can be a scalar or numeric vector; + #' when vectorized, element `i` applies to dose `i`. + #' - `number` The total number of doses to administer in the future (default 1). + #' If `number` is smaller than `max(length(dose), length(frequency), length(route))`, it is increased to that maximum and an informational message is shown. + #' If any of `dose`, `frequency`, or `route` are shorter than `number`, their last value is recycled to length `number`. + #' - `target` The target value to achieve after every dose (required). + #' - `target_type` The target type (default `"concentration"`). Must be one of `"concentration"`, `"auc"`, or `"time"`. + #' `"concentration"` targets a concentration at `target_time`; `"auc"` targets an AUC from dose time to `target_time`; + #' `"time"` uses `target_time` as a proportion between 0 and 1 of each dose interval. + #' - `target_time` For `target_type = "concentration"` or `"auc"`, the time after each dose at which to evaluate the target, + #' default 24 hours if unspecified. For `target_type = "time"`, this must be a single numeric proportion between 0 and 1, + #' and each target observation time is set to `round(frequency[i] * target_time)` hours after dose `i`. + #' - `covariates` Named list of covariates in the model with values to use. If there are no covariates in the model, this can be omitted. + #' * A `PM_data` object containing the future regimen and target observations. Dose events should be included with `evid=1` and target observations should be included with `evid=0` and `out` equal to the target value. + #' When `future` is supplied this way, concentration targets are assumed. + #' * A path to a CSV file containing the future regimen and target observations in the same format as described for the `PM_data` object above. + #' When `future` is supplied this way, concentration targets are assumed. + #' @param dose_range List with 'min' and 'max' elements defining the dose search range (default: 0 to 1000) + #' @param prior_weight Numeric between 0 and 1 indicating the balance between the prior and the posterior in the optimization (default: 0.5). + #' If 1, the model prior parameter + #' value distribution will be used as the sole basis for optimization. If 0, only the Bayesian posterior parameter distribution will be used, + #' which incorporates the patient history. Values between 0 and 1 will weight the contribution of the prior vs posterior parameter distributions in the optimization. + #' Choose values closer to 1 when the patient history is sparse or not believed to be very informative, and values closer to 0 when the patient history is rich and believed to be highly informative. + #' @param start Start time for the future regimen. Can be either: + #' * `NULL`: use the supplied future/target times as-is, without appending them after past data. + #' * Numeric hours (default `0`): relative to the last event date/time in past data, or if no past data, + #' relative to the next local clock hour. + #' * Date-time character string: interpreted as an absolute start date/time and converted to an internal hour offset. + #' Ambiguous formats (e.g. `01/02/26`) are resolved using the `date_format` Pmetrics option + #' (set via [setPMoptions]), which defaults to `%m/%d/%y` for US locales and `%d/%m/%y` otherwise. + #' Accepted formats include: + #' - `YYYY-mm-dd HH:MM[:SS]` + #' - `mm/dd/[YY]YY HH:MM[:SS]` or `mm-dd-[YY]YY HH:MM[:SS]` + #' - `dd/mm/[YY]YY HH:MM[:SS]` or `dd-mm-[YY]YY HH:MM[:SS]` + #' @param max_cycles Maximum number of optimization cycles for computing the posterior (default: 500) + #' @param settings List of additional settings for posterior computation (optional) + #' @param posterior `bd_post` object to use instead of computing a new one (optional). + #' When provided, `prior`, `model`, `past_data`, `max_cycles`, and `settings` are ignored, as they are already included in the `posterior` object. + #' @param quiet Logical indicating whether to suppress verbose simulation output (default: FALSE) + #' @return A `bd` object containing the optimization results and associated information + + initialize = function(model = NULL, + prior = NULL, + past_data = NULL, + future = NULL, + dose_range = list(min = 0, max = 1000), + prior_weight = 0.5, + start = 0, + max_cycles = 500, + settings = NULL, + posterior = NULL, + quiet = FALSE) { + if (!is.null(future)) { + if (is.list(future)) { + future_spec <- private$.build_future_data(future) + future_data <- future_spec$data + target_type <- future_spec$target_type + self$future_target_info <- list( + target_type = tolower(as.character(future$target_type %||% "concentration")), + target = future$target, + target_time = future$target_time + ) + } else if (inherits(future, "PM_data") || is.character(future)) { + future_data <- PM_data$new(future, quiet = TRUE) + target_type <- "concentration" + self$future_target_info <- list(target_type = "concentration", target = NA, target_time = NA) + } else { + cli::cli_abort("{.arg future} must be either a list describing the future setup, a PM_data object, or a path to a CSV file.") + } + } else { + cli::cli_abort("A {.arg future} plan must be supplied.") + } + + # Capture originally requested doses before optimization may mutate the PM_data object + if (!is.null(future_data$standard_data)) { + orig_evid1 <- future_data$standard_data |> dplyr::filter(evid == 1) + self$future_requested_doses <- if (nrow(orig_evid1) > 0) orig_evid1$dose else numeric(0) + } + + if (is.null(posterior)) { + if (is.null(prior) || is.null(model)) { + cli::cli_abort("Both {.arg prior} and {.arg model} are required when {.arg posterior} is not provided.") + } + posterior <- bd_post$new( + prior = prior, + model = model, + past_data = past_data, + max_cycles = max_cycles, + settings = settings, + quiet = quiet + ) + } + + start_info <- private$.resolve_start(start, posterior$past) + + raw <- private$.optimize(posterior, future_data, dose_range, prior_weight, target_type, start_info$start_offset, quiet) + + private$.set_result(future_data, raw, posterior, prior_weight) + self$past <- posterior$past + self$start <- start_info$start + self$start_offset <- start_info$start_offset + + if (!is.null(self$past) && !is.null(self$start_offset) && self$start_offset > 0) { + private$.extend_past_to_start(self$start_offset) + } + + private$.sim_past() + private$.sim_future() + + invisible(self) + }, + + #' @description + #' Print summary of BestDose results + print = function() { + cat("BestDose Optimization Results\n") + cat("==============================\n\n") + dose_str <- paste(sprintf("%.2f", self$doses), collapse = ", ") + cat(sprintf("Optimal doses: [%s] mg\n", dose_str)) + cat(sprintf("Objective function: %.10f\n", self$objf)) + cat(sprintf("ln(Objective): %.4f\n", log(self$objf))) + cat(sprintf("Method: %s\n", self$method)) + cat(sprintf("Status: %s\n", self$status)) + if (!is.null(self$prior_weight)) { + cat(sprintf("Prior weight: %.2f\n", self$prior_weight)) + } + if (!is.null(self$start)) { + if (is.character(self$start)) { + cat(sprintf("Start: %s\n", self$start)) + } else { + cat(sprintf("Start offset (h): %.2f\n", self$start_offset)) + } + } + cat(sprintf("\nNumber of predictions: %d\n", nrow(self$result$predictions))) + if (!is.null(self$result$auc_predictions)) { + cat(sprintf("Number of AUC predictions: %d\n", nrow(self$result$auc_predictions))) + } + invisible(self) + }, + #' @description + #' Save results to RDS file + #' @param filename Path to save file. Default: "bestdose_result.rds" + save = function(filename = "bestdose_result.rds") { + saveRDS(self, filename) + cli::cli_alert_success("Results saved to {filename}") + invisible(self) + }, + #' @description + #' Plot observed and predicted concentrations over time for both past and future data + #' @param ... Additional arguments passed to plot.bd function + plot = function(...) { + plot.bd(self, ...) + }, + #' @description + #' Generate an HTML report for a BestDose result + #' @param ... Parameters passed to the internal BestDose report generator. + report = function(...) { + bd_report(self, ...) + } + ), + private = list( + .build_future_data = function(future) { + if (is.null(future$dose) || is.null(future$target)) { + cli::cli_abort(c( + "x" = "Future setup must include both {.code dose} and {.code target}.", + "i" = "Provide {.code future = list(dose = ..., target = ...)}." + )) + } + + # Apply defaults + future$target_type <- future$target_type %||% "concentration" + future$frequency <- future$frequency %||% 24 + future$route <- future$route %||% 0 + future$number <- future$number %||% 1 + + # Determine effective number from vector lengths of dose, frequency, route + n_from_vectors <- max( + length(future$dose), + length(future$frequency), + length(future$route) + ) + if (future$number < n_from_vectors) { + cli::cli_inform(c( + "!" = "{.arg number} ({future$number}) is less than the maximum length of + {.code dose}, {.code frequency}, or {.code route} ({n_from_vectors}).", + ">" = "Setting {.arg number} to {n_from_vectors}." + )) + future$number <- n_from_vectors + } + n <- as.integer(future$number) + + # Recycle the last element of x to reach length n + recycle_last <- function(x, n) { + len <- length(x) + if (len >= n) { + return(x[seq_len(n)]) + } + c(x, rep(x[len], n - len)) + } + doses <- recycle_last(future$dose, n) + freqs <- recycle_last(future$frequency, n) + routes <- recycle_last(future$route, n) + target_type <- tolower(as.character(future$target_type[[1]])) + + if (!target_type %in% c("concentration", "auc", "time")) { + cli::cli_abort("{.arg future$target_type} must be one of: concentration, auc, time") + } + + if (target_type == "time") { + if (is.null(future$target_time) || + length(future$target_time) != 1 || + !is.numeric(future$target_time) || + is.na(future$target_time) || + future$target_time < 0 || + future$target_time > 1) { + cli::cli_abort("For {.code future$target_type = 'time'}, {.arg future$target_time} must be a single numeric value between 0 and 1.") + } + target_offsets <- round(freqs * future$target_time) + rust_target_type <- "concentration" + } else { + future$target_time <- future$target_time %||% 24 + if (length(future$target_time) != 1 || + !is.numeric(future$target_time) || + is.na(future$target_time) || + future$target_time < 0) { + cli::cli_abort("{.arg future$target_time} must be a single non-negative numeric value.") + } + target_offsets <- rep(as.numeric(future$target_time), n) + rust_target_type <- if (target_type == "auc") "auc_from_zero" else "concentration" + } + + # Cumulative dose times: dose 1 at t=0, dose i at sum of preceding frequencies + dose_times <- c(0, cumsum(head(freqs, n - 1))) + + future_data <- PM_data$new() + + # Add each dose event individually + for (i in seq_len(n)) { + dose_args <- list( + id = 1, time = dose_times[i], evid = 1, + dose = doses[i], out = NA, + dur = routes[i], + validate = FALSE + ) + do.call(future_data$addEvent, dose_args) + } + + # Add covariates if specified + if (!is.null(future$covariates) && length(future$covariates) > 0) { + cov_args <- c(list(id = 1, validate = FALSE), future$covariates) + do.call(future_data$addEvent, cov_args) + } + + # Add observation events at target_time after each dose + for (i in seq_len(n)) { + obs_time <- dose_times[i] + target_offsets[i] + obs_args <- list( + id = 1, time = obs_time, evid = 0, + dose = NA, out = future$target, + validate = (i == n) + ) + do.call(future_data$addEvent, obs_args) + } + list(data = future_data, target_type = rust_target_type) + }, + .optimize = function(posterior, future_data, dose_range, prior_weight, target_type, start_offset, quiet = FALSE) { + if (is.null(posterior$handle)) { + cli::cli_abort(c( + "x" = "bd_post object is not properly initialized.", + "i" = "Create a new {.cls bd_post} with {.code bd_post$new()}." + )) + } + + if (!target_type %in% c("concentration", "auc_from_zero")) { + cli::cli_abort("Internal {.arg target_type} must be one of: concentration, auc_from_zero") + } + + if (prior_weight < 0 || prior_weight > 1) { + cli::cli_abort("{.arg prior_weight} must be between 0 and 1") + } + + if (is.null(dose_range$min) || is.null(dose_range$max)) { + cli::cli_abort("{.arg dose_range} must have both 'min' and 'max' elements") + } + + if (dose_range$min >= dose_range$max) { + cli::cli_abort("{.arg dose_range$min} must be less than {.arg dose_range$max}") + } + + future_data_path <- bestdose_parse_data(future_data) + + res <- bestdose_optimize( + posterior$handle, + future_data_path, + start_offset, + dose_range$min, + dose_range$max, + bias_weight = prior_weight, + target_type + ) + + if (is.character(res)) { + cli::cli_abort(res) + } + + res + }, + .set_result = function(future, result, posterior, prior_weight) { + if (!is.null(future)) { + self$future <- if (inherits(future, "PM_data")) future else PM_data$new(future, quiet = TRUE) + } + self$result <- result + self$posterior <- posterior + self$prior_weight <- prior_weight + invisible(self) + }, + .resolve_start = function(start, past) { + if (is.null(start)) { + start_offset <- NULL + } else if (is.numeric(start) && length(start) == 1 && !is.na(start)) { + start_offset <- as.numeric(start) + } else if (is.character(start) && length(start) == 1 && nzchar(start)) { + start_datetime <- private$.parse_datetime(start) + if (is.na(start_datetime)) { + cli::cli_abort(c( + "x" = "Unable to parse {.arg start} datetime string.", + "i" = "Use an ISO-like value such as {.code '2026-02-01 14:00:00'}." + )) + } + + has_past <- !is.null(past) && !is.null(past$data) && nrow(past$data) > 0 + if (has_past) { + ref_datetime <- private$.reference_datetime(past) + start_offset <- as.numeric(difftime(start_datetime, ref_datetime, units = "hours")) + } else { + # Without past data, a datetime string defines the plotting origin itself. + # Keep optimization on the future timeline by using a zero internal offset. + start_offset <- 0 + } + } else { + cli::cli_abort("{.arg start} must be NULL, a single numeric value, or a date-time character string.") + } + + if (!is.null(start_offset) && (!is.finite(start_offset) || start_offset < 0)) { + cli::cli_abort("{.arg start} resolves to a negative or invalid offset relative to the reference time.") + } + + list(start = start, start_offset = start_offset) + }, + .reference_datetime = function(past) { + if (!is.null(past) && !is.null(past$data) && nrow(past$data) > 0 && + all(c("date", "time") %in% names(past$data))) { + dt_raw <- paste(as.character(past$data$date), as.character(past$data$time)) + dt_vals <- vapply( + dt_raw, + function(x) private$.parse_datetime(x), + FUN.VALUE = as.POSIXct(NA_real_, origin = "1970-01-01", tz = Sys.timezone()) + ) + + if (!all(is.na(dt_vals))) { + if (!is.null(past$standard_data) && "time" %in% names(past$standard_data) && + nrow(past$standard_data) == length(dt_vals)) { + idx <- which.max(past$standard_data$time) + if (length(idx) == 1 && !is.na(dt_vals[idx])) { + return(dt_vals[idx]) + } + } + return(max(dt_vals, na.rm = TRUE)) + } + } + + now <- Sys.time() + ceiling_hour <- as.POSIXct( + format(now, "%Y-%m-%d %H:00:00"), + format = "%Y-%m-%d %H:%M:%S", + tz = Sys.timezone() + ) + if (ceiling_hour <= now) ceiling_hour <- ceiling_hour + 3600 + ceiling_hour + }, + .parse_datetime = function(x) { + # Get user-preferred date format from Pmetrics options; fall back to locale + user_date_fmt <- getPMoptions("date_format", warn = FALSE, quiet = TRUE) + if (!is.character(user_date_fmt) || !nzchar(user_date_fmt)) { + user_date_fmt <- if (grepl("en_US", Sys.getlocale("LC_TIME"), fixed = TRUE)) "%m/%d/%y" else "%d/%m/%y" + } + user_4yr <- sub("%y", "%Y", user_date_fmt, fixed = TRUE) + formats <- unique(c( + paste(user_4yr, "%H:%M:%S"), + paste(user_4yr, "%H:%M"), + paste(user_date_fmt, "%H:%M:%S"), + paste(user_date_fmt, "%H:%M"), + "%Y-%m-%d %H:%M:%S", + "%Y-%m-%d %H:%M", + "%m/%d/%Y %H:%M:%S", + "%m/%d/%Y %H:%M", + "%m/%d/%y %H:%M:%S", + "%m/%d/%y %H:%M", + "%m-%d-%Y %H:%M", + "%m-%d-%Y %H:%M:%S", + "%m-%d-%y %H:%M", + "%m-%d-%y %H:%M:%S", + "%d/%m/%Y %H:%M:%S", + "%d/%m/%Y %H:%M", + "%d/%m/%y %H:%M:%S", + "%d/%m/%y %H:%M", + "%d-%m-%Y %H:%M:%S", + "%d-%m-%Y %H:%M", + "%d-%m-%y %H:%M:%S", + "%d-%m-%y %H:%M" + )) + for (fmt in formats) { + dt <- suppressWarnings(as.POSIXct(x, format = fmt, tz = Sys.timezone())) + if (!is.na(dt)) { + return(dt) + } + } + suppressWarnings(as.POSIXct(x, tz = Sys.timezone())) + }, + .extend_past_to_start = function(start_offset) { + if (is.null(self$past) || is.null(self$past$standard_data) || nrow(self$past$standard_data) == 0) { + return(invisible(NULL)) + } + + past_std <- self$past$standard_data + last_rows <- past_std |> + dplyr::group_by(id) |> + dplyr::slice_max(time, n = 1, with_ties = FALSE) |> + dplyr::ungroup() + + new_rows <- last_rows + new_rows$time <- new_rows$time + start_offset + if ("evid" %in% names(new_rows)) new_rows$evid <- 0 + if ("dose" %in% names(new_rows)) new_rows$dose <- NA_real_ + if ("dur" %in% names(new_rows)) new_rows$dur <- NA_real_ + if ("addl" %in% names(new_rows)) new_rows$addl <- NA_real_ + if ("ii" %in% names(new_rows)) new_rows$ii <- NA_real_ + if ("out" %in% names(new_rows)) new_rows$out <- NA_real_ + + self$past$standard_data <- dplyr::bind_rows(past_std, new_rows) |> + dplyr::arrange(id, time) + + invisible(self) + }, + .sim_past = function() { + if (is.null(self$past)) { + return(invisible(NULL)) + } + sim1 <- PM_sim$new( + poppar = as.data.frame(self$posterior$theta), + model = self$posterior$model_info$model, + data = self$past, + predInt = 1, + limits = NA, + quiet = TRUE + ) + self$past_pred <- sim1 + invisible(self) + }, + .sim_future = function() { + if (is.null(self$future)) { + return(invisible(NULL)) + } + # Replace placeholder doses with optimized values (use tail to skip past fixed doses) + future_sim_data <- self$future$standard_data + n_future_doses <- sum(future_sim_data$evid != 0) + future_sim_data$dose[future_sim_data$evid != 0] <- tail(self$result$doses, n_future_doses) + self$future$standard_data <- future_sim_data + + sim2 <- PM_sim$new( + poppar = as.data.frame(self$posterior$theta), + model = self$posterior$model_info$model, + data = self$future, + predInt = 1, + limits = NA, + quiet = TRUE + ) + self$future_pred <- sim2 + invisible(self) + } + ), + active = list( + #' @field doses Optimal doses found by BestDose optimization + doses = function() { + self$result$doses + }, + #' @field objf Objective function value at the optimal doses + objf = function() { + self$result$objf + }, + #' @field method Optimization method used + method = function() { + self$result$method + }, + #' @field status Status of the optimization run + status = function() { + self$result$status + } + ) +) + +#' @title +#' Compute a reusable BestDose posterior +#' +#' @description +#' `r lifecycle::badge("experimental")` +#' +#' Use `bd_post` to compute the Bayesian posterior once from +#' prior population data and patient history, then call `$optimize()` multiple +#' times with different targets, dose ranges, or bias weights. +#' +#' @export +bd_post <- R6::R6Class( + "bd_post", + public = list( + #' @field handle Memory pointer to the computed posterior (opaque to users) + handle = NULL, + #' @field theta Matrix of support points in the posterior distribution + theta = NULL, + #' @field theta_dim Dimensions of the theta matrix + theta_dim = NULL, + #' @field param_names Names of the parameters in the posterior + param_names = NULL, + #' @field posterior_weights Weights of the posterior support points + posterior_weights = NULL, + #' @field population_weights Weights of the population support points + population_weights = NULL, + #' @field past PM_data object containing past patient data used in the posterior computation (if applicable) + past = NULL, + #' @field model_info Information about the model used + model_info = NULL, + #' @field settings Settings used for the posterior computation + settings = NULL, + #' @description + #' Initialize the `bd_post` object by computing the posterior distribution from the given prior, model, and past data + #' @param prior Prior information for the model, can be a PM_result, PM_final, or path to theta.csv + #' @param model PM_model object or path to compiled model + #' @param past_data PM_data object or path to CSV file with past patient data (optional) + #' @param max_cycles Maximum number of optimization cycles for computing the posterior (default: 500) + #' @param settings List of additional settings for posterior computation (optional) + #' @param quiet Logical indicating whether to suppress verbose simulation output (default: FALSE) + #' @return A `bd_post` object containing the computed posterior distribution and associated information + + initialize = function(prior, + model, + past_data = NULL, + max_cycles = 500, + settings = NULL, + quiet = FALSE) { + prior_path <- bestdose_parse_prior(prior) + model_info <- bestdose_parse_model(model) + past_data_path <- if (!is.null(past_data)) bestdose_parse_data(past_data) else NULL + + if (is.null(settings)) { + model_for_settings <- if (!is.null(model_info$model)) model_info$model else model + settings <- bestdose_default_settings(prior, model_for_settings, max_cycles = max_cycles) + } + + prep <- bestdose_prepare( + model_path = model_info$path, + prior_path = prior_path, + past_data_path = past_data_path, + params = settings, + kind = model_info$kind + ) + + if (is.character(prep)) { + cli::cli_abort(prep) + } + + dim <- as.integer(prep$theta_dim) + theta_matrix <- matrix(prep$theta_values, nrow = dim[1], ncol = dim[2]) + colnames(theta_matrix) <- prep$param_names + + self$handle <- prep$handle + self$theta <- theta_matrix + self$theta_dim <- dim + self$param_names <- prep$param_names + self$posterior_weights <- prep$posterior_weights + self$population_weights <- prep$population_weights + self$past <- if (!is.null(past_data)) PM_data$new(past_data, quiet = TRUE) else NULL + self$model_info <- model_info + self$settings <- settings + private$.quiet <- quiet + + cli::cli_alert_success("BestDose posterior computed with {dim[1]} support points") + }, + #' @description + #' Run optimization and return a `bd` result object + #' @param target Future regimen/target specification. Accepts the same forms as the `future` argument to `bd$new()`: + #' a list with elements such as `dose`, `frequency`, `route`, `number`, `target`, `target_type`, and `target_time`; + #' a `PM_data` object; or a path to a CSV file. + #' @param dose_range List with 'min' and 'max' elements defining the dose search range (default: 0 to 1000) + #' @param prior_weight Numeric between 0 and 1 indicating the weight of bias in the optimization (default: 0.5) + #' @param start Start time for future regimen. Can be either `NULL`, numeric hours (default: `0`), or a date-time + #' character string. Ambiguous formats are resolved using the `date_format` Pmetrics option + #' (see [setPMoptions]). Accepted string formats: + #' - `YYYY-mm-dd HH:MM[:SS]` + #' - `mm/dd/[YY]YY HH:MM[:SS]` or `mm-dd-[YY]YY HH:MM[:SS]` + #' - `dd/mm/[YY]YY HH:MM[:SS]` or `dd-mm-[YY]YY HH:MM[:SS]` + #' @param quiet Logical indicating whether to suppress verbose simulation output. If NULL, uses the quiet setting from posterior computation (default: NULL) + #' @return A `bd` object containing the optimization results + optimize = function(target, + dose_range = list(min = 0, max = 1000), + prior_weight = 0.5, + start = 0, + quiet = NULL) { + if (is.null(quiet)) quiet <- private$.quiet + bd$new( + future = target, + dose_range = dose_range, + prior_weight = prior_weight, + start = start, + posterior = self, + quiet = quiet + ) + } + ), + private = list( + .quiet = FALSE, + finalize = function() { + self$handle <- NULL + } + ) +) + +#' @export +bd$load <- function(filename = "bestdose_result.rds") { + if (!file.exists(filename)) { + cli::cli_abort("File not found: {filename}") + } + readRDS(filename) +} + + +############ HELPER FUNCTIONS ############ + +bestdose_parse_prior <- function(prior) { + if (inherits(prior, "PM_result")) { + theta_path <- file.path(prior$rundir, "outputs", "theta.csv") + if (!file.exists(theta_path)) { + cli::cli_abort("theta.csv not found in PM_result outputs") + } + theta_path + } else if (inherits(prior, "PM_final")) { + temp_path <- tempfile(fileext = ".csv") + bestdose_write_prior_csv(prior, temp_path) + temp_path + } else if (is.character(prior)) { + if (!file.exists(prior)) { + cli::cli_abort("Prior file not found: {prior}") + } + prior + } else { + cli::cli_abort("prior must be PM_result, PM_final, or path to theta.csv") + } +} + +bestdose_write_prior_csv <- function(prior, path) { + df <- as.data.frame(prior$popPoints) + df$prob <- prior$popProb + write.csv(df, path, row.names = FALSE, quote = FALSE) +} + +bestdose_parse_model <- function(model) { + if (inherits(model, "PM_model")) { + compiled_path <- model$binary_path + if (is.null(compiled_path) || !file.exists(compiled_path)) { + cli::cli_abort("Model must be compiled first. Use model$compile()") + } + + kind <- if (!is.null(model$model_list$analytical) && model$model_list$analytical) { + "analytical" + } else { + "ode" + } + + list(path = compiled_path, kind = kind, model = model) + } else if (is.character(model)) { + if (!file.exists(model)) { + cli::cli_abort("Model file not found: {model}") + } + kind <- if (grepl("analytical", model, ignore.case = TRUE)) { + "analytical" + } else { + "ode" + } + list(path = model, kind = kind, model = NULL) + } else { + cli::cli_abort("model must be PM_model or path to compiled model") + } +} + +bestdose_parse_data <- function(data) { + if (inherits(data, "PM_data")) { + temp_path <- tempfile(fileext = ".csv") + write.csv(data$standard_data, temp_path, row.names = FALSE, quote = FALSE) + temp_path + } else if (is.character(data)) { + if (!file.exists(data)) { + cli::cli_abort("Data file not found: {data}") + } + data + } else { + cli::cli_abort("data must be PM_data or path to CSV file") + } +} + +bestdose_default_settings <- function(prior, model, max_cycles = 500) { + param_ranges <- lapply(model$model_list$pri, function(x) { + c(x$min, x$max) + }) + names(param_ranges) <- tolower(names(param_ranges)) + + list( + algorithm = "NPAG", + ranges = param_ranges, + error_models = lapply(model$model_list$err, function(x) x$flatten()), + max_cycles = max_cycles, + points = 2028, + seed = 22, + prior = "prior.csv", + idelta = 0.25, + tad = 0.0 + ) +} + + +#' Plot BestDose predictions +#' +#' @description +#' Plot observed and predicted concentrations over time for both past and future data, +#' with options to apply a multiplier to the concentrations, and customize the plot appearance. The top 5 posterior support +#' points are highlighted with distinct colors. +#' +#' @param x A `bd` object containing the best dose predictions. +#' @param mult Numeric multiplier to apply to the concentrations (default: 1, no scaling). +#' @param outeq Numeric value of outeq to filter observations for plotting (default: 1). +#' @param quiet Logical indicating whether to suppress messages (default: FALSE). +#' @param legend Logical indicating whether to display a legend (default: TRUE). +#' @param log Logical indicating whether to use a logarithmic scale for the y-axis (default: FALSE). +#' @param grid Logical indicating whether to display a grid (default: FALSE). +#' @param future_region Logical indicating whether to display the divider line and shaded region for future data (default: FALSE). +#' @param xlab Label for the x-axis. +#' @param ylab Label for the y-axis. +#' @param title Title of the plot. +#' @param xlim Limits for the x-axis. +#' @param ylim Limits for the y-axis. +#' @param print Logical indicating whether to print the plot (default: TRUE). +#' @param ... Additional arguments passed to the plotting function. +#' +#' @return Invisibly returns a plotly object. +#' +#' @export +#' @method plot bd +plot.bd <- function(x, mult = 1, outeq = 1, + quiet = FALSE, legend = TRUE, log = FALSE, + grid = FALSE, future_region = FALSE, + xlab = "Time", ylab = "Concentration", + title = NULL, xlim = NULL, ylim = NULL, print = TRUE, ...) { + if (!inherits(x, "bd")) { + stop("Object must be of class 'bd'") + } + + # Print target/future data for debugging + if (!quiet) { + cli::cli_h3("Target/Future data (for debugging)") + if (!is.null(x$future) && !is.null(x$future$standard_data)) { + print(x$future$standard_data) + } else { + cli::cli_alert_info("No future data available.") + } + } + + # Check if we have future predictions (past is optional) + if (is.null(x$future_pred)) { + cli::cli_abort(c( + "x" = "Future predictions are required for plotting.", + "i" = "BestDose object must have {.code future_pred}." + )) + } + + # Get starting date/time for x-axis datetime conversion + start_datetime <- bd_plot_start_datetime(x) + + # Compute a single, consistent future_time_offset (in hours) for plotting. + # This mirrors the Rust optimization logic: + # with past: future starts at max past time (past is optionally extended to start) + # without past: future starts at start_offset hours from plot origin + future_time_offset <- bd_future_time_offset(x) + has_past <- !is.null(x$past) && !is.null(x$past$standard_data) && nrow(x$past$standard_data) > 0 + + if (!quiet) { + cli::cli_alert_info("start = {deparse(x$start)}, start_offset = {x$start_offset %||% 0}, future_time_offset = {future_time_offset} h") + } + + # Extract observation data from both simulations + past_obs <- NULL + if (!is.null(x$past_pred)) { + past_obs <- x$past_pred$data$obs |> + dplyr::filter(outeq == !!outeq) + } + + future_obs <- x$future_pred$data$obs |> + dplyr::filter(outeq == !!outeq) + + + # Adjust future simulation prediction times using the unified offset + future_obs_adjusted <- future_obs |> + dplyr::mutate(time = time + future_time_offset) + + # Combine past and future observations + if (!is.null(past_obs) && nrow(past_obs) > 0) { + combined_obs <- dplyr::bind_rows( + past_obs |> dplyr::mutate(source = "past"), + future_obs_adjusted |> dplyr::mutate(source = "future") + ) |> + dplyr::arrange(id, nsim, time) |> + dplyr::mutate(datetime = start_datetime + time * 3600) + } else { + combined_obs <- future_obs_adjusted |> + dplyr::mutate(source = "future") |> + dplyr::arrange(id, nsim, time) |> + dplyr::mutate(datetime = start_datetime + time * 3600) + } + + # Apply multiplier + combined_obs$out <- combined_obs$out * mult + + # Handle log scale + if (log) { + if (any(combined_obs$out <= 0, na.rm = TRUE)) { + if (!quiet) { + cat("Values <= 0 omitted from log plot.\n") + } + combined_obs$out[combined_obs$out <= 0] <- NA + } + } + + # Remove NA values (but keep intentional break rows for gap rendering) + combined_obs <- combined_obs |> dplyr::filter(!is.na(out) | source == "break") + + # Extract actual observations from past and future data + past_data_obs <- NULL + future_data_obs <- NULL + past_doses <- NULL + future_doses <- NULL + + if (!is.null(x$past)) { + past_data_obs <- x$past$standard_data |> + dplyr::filter(evid == 0, outeq == !!outeq) |> + dplyr::select(id, time, out) + + past_data_obs$out <- past_data_obs$out * mult + + if (log && any(past_data_obs$out <= 0, na.rm = TRUE)) { + past_data_obs$out[past_data_obs$out <= 0] <- NA + } + + past_data_obs <- past_data_obs |> dplyr::filter(!is.na(out)) + + past_doses <- x$past$standard_data |> + dplyr::filter(evid == 1) |> + dplyr::select(id, time, dur, dose) + } + + if (!is.null(x$future)) { + future_data_obs <- x$future$standard_data |> + dplyr::filter(evid == 0, outeq == !!outeq) |> + dplyr::select(id, time, out) + + # Use the same unified future_time_offset for consistency + future_data_obs <- future_data_obs |> + dplyr::mutate(time = time + future_time_offset) + + future_data_obs$out <- future_data_obs$out * mult + + if (log && any(future_data_obs$out <= 0, na.rm = TRUE)) { + future_data_obs$out[future_data_obs$out <= 0] <- NA + } + + future_data_obs <- future_data_obs |> dplyr::filter(!is.na(out)) + + future_doses <- bd_future_dose_events(x) + if (!is.null(future_doses) && nrow(future_doses) > 0) { + future_doses <- future_doses |> + dplyr::select(id, time, dur, dose) + } + } + + # Initialize plot + p <- plotly::plot_ly() + + # Get posterior weights and robustly map them to nsim values + posterior_weights <- as.numeric(x$posterior$posterior_weights) + top5_colors <- c("#FF0000", "#0000FF", "#008000", "#800080", "#FFA500") + + unique_nsim <- sort(unique(combined_obs$nsim)) + nsim_keys <- as.character(unique_nsim) + + sim_index_by_nsim <- setNames(seq_along(unique_nsim), nsim_keys) + + weight_by_nsim <- setNames(rep(NA_real_, length(nsim_keys)), nsim_keys) + for (k in nsim_keys) { + idx <- sim_index_by_nsim[[k]] + if (!is.na(idx) && idx >= 1 && idx <= length(posterior_weights)) { + weight_by_nsim[[k]] <- posterior_weights[idx] + } + } + + # Identify top 5 nsim keys by weight (largest to smallest) + ranked_keys <- names(sort(weight_by_nsim, decreasing = TRUE, na.last = NA)) + top_keys <- ranked_keys[seq_len(min(5, length(ranked_keys)))] + + color_by_nsim <- setNames(rep("#cccccc", length(nsim_keys)), nsim_keys) + legend_name_by_nsim <- setNames(rep(NA_character_, length(nsim_keys)), nsim_keys) + for (i in seq_along(top_keys)) { + k <- top_keys[i] + color_by_nsim[[k]] <- top5_colors[i] + legend_name_by_nsim[[k]] <- sprintf("%.4e", weight_by_nsim[[k]]) + } + + legend_added <- setNames(rep(FALSE, length(nsim_keys)), nsim_keys) + id_values <- unique(combined_obs$id) + non_top_keys <- setdiff(nsim_keys, top_keys) + + # 1) Plot non-top lines first (light grey, no legend) + for (nsim_key in non_top_keys) { + weight_val <- weight_by_nsim[[nsim_key]] + for (id_val in id_values) { + this_sim <- combined_obs |> + dplyr::filter(id == id_val, as.character(nsim) == nsim_key) |> + dplyr::arrange(datetime) + + if (nrow(this_sim) > 0) { + p <- p |> + plotly::add_lines( + x = ~datetime, y = ~out, data = this_sim, + line = list(color = "#cccccc", width = 0.8), + opacity = 0.6, + name = NULL, + legendgroup = NULL, + hovertemplate = sprintf( + "Time: %%{x}
Out: %%{y}
Weight: %s", + ifelse(is.na(weight_val), "NA", sprintf("%.4e", weight_val)) + ), + showlegend = FALSE + ) + } + } + } + + # 2) Plot top lines second (colored, legend in descending weight order) + for (nsim_key in top_keys) { + line_color <- color_by_nsim[[nsim_key]] + legend_name <- legend_name_by_nsim[[nsim_key]] + weight_val <- weight_by_nsim[[nsim_key]] + + for (id_val in id_values) { + this_sim <- combined_obs |> + dplyr::filter(id == id_val, as.character(nsim) == nsim_key) |> + dplyr::arrange(datetime) + + if (nrow(this_sim) > 0) { + show_in_legend <- !legend_added[[nsim_key]] && legend + if (show_in_legend) { + legend_added[[nsim_key]] <- TRUE + } + legend_rank <- match(nsim_key, top_keys) + + p <- p |> + plotly::add_lines( + x = ~datetime, y = ~out, data = this_sim, + opacity = 0.6, + line = list(color = line_color, width = 2), + name = legend_name, + legendgroup = legend_name, + legendrank = legend_rank, + hovertemplate = sprintf( + "Time: %%{x}
Out: %%{y}
Weight: %s", + ifelse(is.na(weight_val), "NA", sprintf("%.4e", weight_val)) + ), + showlegend = show_in_legend + ) + } + } + } + + # Add past data observations as markers + if (!is.null(past_data_obs) && nrow(past_data_obs) > 0) { + past_data_obs$datetime <- start_datetime + past_data_obs$time * 3600 + p <- p |> + plotly::add_markers( + x = ~datetime, y = ~out, data = past_data_obs, + marker = list(color = "black", size = 8, symbol = "circle"), + name = "Past Observations", + hovertemplate = "Time: %{x}
Out: %{y}", + showlegend = FALSE + ) + } + + # Add future data observations as markers + if (!is.null(future_data_obs) && nrow(future_data_obs) > 0) { + future_data_obs$datetime <- start_datetime + future_data_obs$time * 3600 + p <- p |> + plotly::add_markers( + x = ~datetime, y = ~out, data = future_data_obs, + marker = list(color = "red", size = 8, symbol = "circle"), + name = "Future Observations", + hovertemplate = "Time: %{x}
Out: %{y}", + showlegend = FALSE + ) + } + + # Add dose indicators as markers/segments directly on the plot + # Past doses (black triangles) + if (!is.null(past_doses) && nrow(past_doses) > 0) { + y_min <- min(combined_obs$out, na.rm = TRUE) + + for (i in 1:nrow(past_doses)) { + dose_time <- past_doses$time[i] + dose_datetime <- start_datetime + dose_time * 3600 + dose_dur <- past_doses$dur[i] + dose_amt <- past_doses$dose[i] + + dur_text <- if (is.na(dose_dur) || dose_dur == 0) "Bolus" else sprintf("Duration: %.1f", dose_dur) + p <- p |> + plotly::add_markers( + x = dose_datetime, + y = y_min, + marker = list( + symbol = "triangle-up-open", + size = 10, + color = "black", + line = list(color = "black", width = 1) + ), + customdata = list(list(dose_amt, dur_text)), + hovertemplate = "Time: %{x}
Dose: %{customdata[0]}
%{customdata[1]}", + showlegend = FALSE + ) + + # If infusion, add marker at end time too + if (!is.na(dose_dur) && dose_dur > 0) { + p <- p |> + plotly::add_markers( + x = dose_datetime + dose_dur * 3600, + y = y_min, + marker = list( + symbol = "triangle-down-open", + size = 10, + color = "black", + line = list(color = "black", width = 1) + ), + text = "End infusion", + hovertemplate = "Time: %{x}
%{text}", + showlegend = FALSE + ) + } + } + } + + # Future doses (red triangles) + if (!is.null(future_doses) && nrow(future_doses) > 0) { + y_min <- min(combined_obs$out, na.rm = TRUE) + + for (i in 1:nrow(future_doses)) { + dose_time <- future_doses$time[i] + dose_datetime <- start_datetime + dose_time * 3600 + dose_dur <- future_doses$dur[i] + dose_amt <- future_doses$dose[i] + + dur_text <- if (is.na(dose_dur) || dose_dur == 0) "Bolus" else sprintf("Duration: %.1f", dose_dur) + p <- p |> + plotly::add_markers( + x = dose_datetime, + y = y_min, + marker = list( + symbol = "triangle-up-open", + size = 10, + color = "red", + line = list(color = "red", width = 1) + ), + customdata = list(list(dose_amt, dur_text)), + hovertemplate = "Time: %{x}
Dose: %{customdata[0]}
%{customdata[1]}", + showlegend = FALSE + ) + + if (!is.na(dose_dur) && dose_dur > 0) { + p <- p |> + plotly::add_markers( + x = dose_datetime + dose_dur * 3600, + y = y_min, + marker = list( + symbol = "triangle-down-open", + size = 10, + color = "red", + line = list(color = "red", width = 1) + ), + text = "End infusion", + hovertemplate = "Time: %{x}
%{text}", + showlegend = FALSE + ) + } + } + } + + # Add vertical dashed line and background shading for the future region + future_boundary_datetime <- NULL + if (future_region && has_past && any(combined_obs$source == "future")) { + # Use future_time_offset directly for exact alignment with doses/obs + future_boundary_datetime <- start_datetime + future_time_offset * 3600 + x_max <- max(combined_obs$datetime) + y_range <- range(combined_obs$out, na.rm = TRUE) + + # Add light background rectangle for the future region + p <- p |> + plotly::layout( + shapes = list( + list( + type = "rect", + x0 = future_boundary_datetime, + x1 = x_max, + y0 = 0, + y1 = 1, + xref = "x", + yref = "paper", + fillcolor = "rgba(255, 200, 200, 0.15)", + line = list(width = 0), + layer = "below" + ), + list( + type = "line", + x0 = future_boundary_datetime, + x1 = future_boundary_datetime, + y0 = 0, + y1 = 1, + xref = "x", + yref = "paper", + line = list( + color = "rgba(180, 0, 0, 0.6)", + width = 2, + dash = "dash" + ) + ) + ), + annotations = list( + list( + x = future_boundary_datetime, + y = 1.02, + xref = "x", + yref = "paper", + text = "Future starts", + showarrow = FALSE, + font = list(color = "rgba(180, 0, 0, 0.8)", size = 11) + ) + ) + ) + } + + # Set axis labels and layout + xlab_val <- if (missing(xlab)) "Time" else xlab + ylab_val <- if (missing(ylab)) "Concentration" else ylab + title_val <- if (missing(title)) "BestDose Predictions: Past and Future" else title + + p$x$layout$title <- title_val + p$x$layout$xaxis <- list( + title = xlab_val, + zeroline = FALSE, + showgrid = grid + ) + p$x$layout$yaxis <- list( + title = ylab_val, + type = if (log) "log" else "linear", + zeroline = FALSE, + showgrid = grid + ) + p$x$layout$hovermode <- "closest" + p$x$layout$showlegend <- legend + p$x$layout$legend <- list(traceorder = "normal") + + if (!missing(xlim)) { + p$x$layout$xaxis$range <- xlim + } + if (!missing(ylim)) { + p$x$layout$yaxis$range <- ylim + } + + if (print) print(p) + return(invisible(p)) +} diff --git a/R/PM_bestdose_report.R b/R/PM_bestdose_report.R new file mode 100644 index 00000000..ff319ff2 --- /dev/null +++ b/R/PM_bestdose_report.R @@ -0,0 +1,1286 @@ +bd_parse_datetime <- function(x) { + user_date_fmt <- getPMoptions("date_format", warn = FALSE, quiet = TRUE) + if (!is.character(user_date_fmt) || length(user_date_fmt) != 1 || !nzchar(user_date_fmt)) { + user_date_fmt <- if (grepl("en_US", Sys.getlocale("LC_TIME"), fixed = TRUE)) "%m/%d/%y" else "%d/%m/%y" + } + + user_4yr <- sub("%y", "%Y", user_date_fmt, fixed = TRUE) + formats <- unique(c( + paste(user_4yr, "%H:%M:%S"), + paste(user_4yr, "%H:%M"), + paste(user_date_fmt, "%H:%M:%S"), + paste(user_date_fmt, "%H:%M"), + "%Y-%m-%d %H:%M:%S", + "%Y-%m-%d %H:%M", + "%m/%d/%Y %H:%M:%S", + "%m/%d/%Y %H:%M", + "%m/%d/%y %H:%M:%S", + "%m/%d/%y %H:%M", + "%m-%d-%Y %H:%M:%S", + "%m-%d-%Y %H:%M", + "%m-%d-%y %H:%M:%S", + "%m-%d-%y %H:%M", + "%d/%m/%Y %H:%M:%S", + "%d/%m/%Y %H:%M", + "%d/%m/%y %H:%M:%S", + "%d/%m/%y %H:%M", + "%d-%m-%Y %H:%M:%S", + "%d-%m-%Y %H:%M", + "%d-%m-%y %H:%M:%S", + "%d-%m-%y %H:%M" + )) + + for (fmt in formats) { + dt <- suppressWarnings(as.POSIXct(x, format = fmt, tz = Sys.timezone())) + if (!is.na(dt)) { + return(dt) + } + } + + suppressWarnings(as.POSIXct(x, tz = Sys.timezone())) +} + +bd_plot_start_datetime <- function(x) { + if (!is.null(x$past) && !is.null(x$past$data) && nrow(x$past$data) > 0 && + all(c("date", "time") %in% names(x$past$data))) { + dt <- bd_parse_datetime(paste(as.character(x$past$data$date[1]), as.character(x$past$data$time[1]))) + if (!is.na(dt)) { + return(dt) + } + } + + if (is.character(x$start) && length(x$start) == 1 && nzchar(x$start)) { + dt <- bd_parse_datetime(x$start) + if (!is.na(dt)) { + return(dt) + } + } + + now <- Sys.time() + ceiling_hour <- as.POSIXct( + format(now, "%Y-%m-%d %H:00:00"), + format = "%Y-%m-%d %H:%M:%S", + tz = Sys.timezone() + ) + if (ceiling_hour <= now) ceiling_hour <- ceiling_hour + 3600 + ceiling_hour +} + +bd_future_time_offset <- function(x) { + has_past <- !is.null(x$past) && !is.null(x$past$standard_data) && nrow(x$past$standard_data) > 0 + if (has_past) { + if (is.null(x$start_offset)) { + 0 + } else { + max(x$past$standard_data$time, na.rm = TRUE) + } + } else { + x$start_offset %||% 0 + } +} + +bd_expand_dose_events <- function(data) { + if (is.null(data) || nrow(data) == 0) { + return(data.frame()) + } + + rows <- lapply(seq_len(nrow(data)), function(i) { + row <- data[i, , drop = FALSE] + addl <- if ("addl" %in% names(row) && !is.na(row$addl[1])) as.integer(row$addl[1]) else 0L + n_doses <- addl + 1L + ii <- if ("ii" %in% names(row) && !is.na(row$ii[1])) row$ii[1] else 0 + times <- row$time[1] + seq.int(0, n_doses - 1L) * ii + expanded <- row[rep(1, n_doses), , drop = FALSE] + expanded$time <- times + expanded$addl <- NA + expanded$ii <- NA + expanded + }) + + do.call(rbind, rows) +} + +bd_future_dose_events <- function(x) { + if (is.null(x$future) || is.null(x$future$standard_data)) { + return(NULL) + } + + dose_rows <- x$future$standard_data |> + dplyr::filter(evid == 1) + + if (nrow(dose_rows) == 0) { + return(NULL) + } + + dose_rows <- bd_expand_dose_events(dose_rows) + if (nrow(dose_rows) == 0) { + return(NULL) + } + + result_doses <- x$result$doses %||% numeric() + if (length(result_doses) == nrow(dose_rows)) { + dose_rows$dose <- as.numeric(result_doses) + } else if (length(result_doses) > 0 && all(is.na(dose_rows$dose) | dose_rows$dose == 0)) { + dose_rows$dose[seq_len(min(length(result_doses), nrow(dose_rows)))] <- as.numeric(result_doses[seq_len(min(length(result_doses), nrow(dose_rows)))]) + } + + dose_rows |> + dplyr::mutate(time = time + bd_future_time_offset(x)) +} + +bd_weight_table <- function(x, nsim_values) { + nsim_values <- sort(unique(nsim_values)) + tibble::tibble( + nsim = nsim_values, + weight = as.numeric(x$posterior$posterior_weights)[seq_along(nsim_values)] + ) +} + +bd_weighted_pred_summary <- function(x, sim_data) { + if (is.null(sim_data) || nrow(sim_data) == 0) { + return(NULL) + } + + sim_data <- sim_data |> + dplyr::mutate(id = as.character(id)) + + weights <- bd_weight_table(x, sim_data$nsim) + + sim_data |> + dplyr::left_join(weights, by = dplyr::join_by(nsim)) |> + dplyr::group_by(id, time, outeq) |> + dplyr::summarise( + pred = stats::weighted.mean(out, w = weight, na.rm = TRUE), + .groups = "drop" + ) +} + +bd_fit_data <- function(x, source = c("past", "future"), outeq = 1) { + source <- match.arg(source) + + if (source == "past") { + if (is.null(x$past) || is.null(x$past$standard_data) || is.null(x$past_pred)) { + return(NULL) + } + + actual <- x$past$standard_data |> + dplyr::filter(evid == 0, outeq == !!outeq) |> + dplyr::transmute(id = as.character(id), time, outeq, obs = out, c0, c1, c2, c3) + + sim <- x$past_pred$data$obs |> + dplyr::filter(outeq == !!outeq) + + label <- "Measured" + } else { + if (is.null(x$future) || is.null(x$future$standard_data) || is.null(x$future_pred)) { + return(NULL) + } + + offset <- bd_future_time_offset(x) + actual <- x$future$standard_data |> + dplyr::filter(evid == 0, outeq == !!outeq) |> + dplyr::transmute(id = as.character(id), time = time + offset, outeq, obs = out, c0, c1, c2, c3) + + sim <- x$future_pred$data$obs |> + dplyr::filter(outeq == !!outeq) |> + dplyr::mutate(time = time + offset) + + label <- "Target" + } + + if (nrow(actual) == 0 || nrow(sim) == 0) { + return(NULL) + } + + pred <- bd_weighted_pred_summary(x, sim) + if (is.null(pred) || nrow(pred) == 0) { + return(NULL) + } + + fit <- actual |> + dplyr::left_join(pred, by = dplyr::join_by(id, time, outeq)) |> + dplyr::mutate( + obsSD = dplyr::coalesce(c0, 0) + dplyr::coalesce(c1, 0) * obs + dplyr::coalesce(c2, 0) * obs^2 + dplyr::coalesce(c3, 0) * obs^3, + obsSD = dplyr::if_else(!is.finite(obsSD) | obsSD <= 0, 1, obsSD), + d = pred - obs, + ds = d * d, + wd = d / obsSD, + wds = wd * wd, + kind = label + ) |> + dplyr::filter(!is.na(obs), !is.na(pred)) + + if (nrow(fit) == 0) { + return(NULL) + } + + fit +} + +bd_fit_metrics <- function(data) { + if (is.null(data) || nrow(data) == 0) { + pe <- data.frame(type = rep(NA_character_, 8), absolute = rep(NA_real_, 8), percent = rep(NA_real_, 8)) + return(list(pe = pe, metric_info = get_metric_info(pe))) + } + + N <- nrow(data) + mae <- sum(data$d, na.rm = TRUE) / N + percent_mae <- mean(data$d / data$obs, na.rm = TRUE) * 100 + + mwe <- sum(data$wd, na.rm = TRUE) / N + percent_mwe <- sum(data$wd, na.rm = TRUE) / sum(data$obs / data$obsSD, na.rm = TRUE) * 100 + + mean_obs <- mean(data$obs, na.rm = TRUE) + wmean_obs <- sum(data$obs / data$obsSD, na.rm = TRUE) / N + + mse <- sum(data$ds, na.rm = TRUE) / N + percent_mse <- mean(data$ds, na.rm = TRUE) / (mean_obs^2) * 100 + + mwse <- sum(data$wds, na.rm = TRUE) / N + percent_mwse <- mwse / (wmean_obs^2) * 100 + + rmse <- sqrt(mse) + percent_rmse <- rmse / mean_obs * 100 + + mbase <- mse - mae^2 + percent_mbase <- mbase / (mean_obs^2) * 100 + + mbawse <- mwse - mwe^2 + percent_mbawse <- mbawse / (wmean_obs^2) * 100 + + rmbawse <- sqrt(mbawse) + percent_rmbawse <- rmbawse * 100 / wmean_obs + + pe <- data.frame( + type = c("mae", "mwe", "mse", "mwse", "rmse", "mbase", "mbawse", "rmbawse"), + absolute = c(mae, mwe, mse, mwse, rmse, mbase, mbawse, rmbawse), + percent = c(percent_mae, percent_mwe, percent_mse, percent_mwse, percent_rmse, percent_mbase, percent_mbawse, percent_rmbawse) + ) + + list(pe = pe, metric_info = get_metric_info(pe)) +} + +bd_fit_plot <- function(data, title) { + if (is.null(data) || nrow(data) == 0) { + return(NULL) + } + + lims <- range(c(data$pred, data$obs), na.rm = TRUE) + fit <- if (nrow(data) >= 2) stats::lm(obs ~ pred, data = data) else NULL + ann_text <- NULL + if (!is.null(fit) && !anyNA(stats::coef(fit))) { + ann_text <- sprintf( + "R² = %.3f
Intercept = %.3f
Slope = %.3f", + summary(fit)$r.squared, + stats::coef(fit)[1], + stats::coef(fit)[2] + ) + } + + p <- plotly::plot_ly( + data = data, x = ~pred, y = ~obs, type = "scatter", mode = "markers", + marker = list(size = 9, color = "rgba(214, 86, 69, 0.75)", line = list(color = "rgba(120, 40, 30, 0.9)", width = 1)), + hovertemplate = "Predicted: %{x}
Observed: %{y}" + ) |> + plotly::layout( + title = title, + xaxis = list(title = "Predicted", range = lims), + yaxis = list(title = "Observed", range = lims), + shapes = list(list( + type = "line", + x0 = lims[1], x1 = lims[2], + y0 = lims[1], y1 = lims[2], + line = list(color = "rgba(80, 80, 80, 0.8)", dash = "dash") + )), + hovermode = "closest" + ) + + if (!is.null(fit) && !anyNA(stats::coef(fit))) { + reg_line <- data.frame(x = lims, y = stats::coef(fit)[1] + stats::coef(fit)[2] * lims) + p <- p |> + plotly::add_lines( + data = reg_line, x = ~x, y = ~y, inherit = FALSE, + line = list(color = "#2c3e50", width = 2), + hoverinfo = "skip", showlegend = FALSE + ) |> + plotly::layout(annotations = list(list( + x = 0.02, y = 0.98, xref = "paper", yref = "paper", + text = ann_text, align = "left", + showarrow = FALSE, + bgcolor = "rgba(255,255,255,0.85)", + bordercolor = "rgba(44,62,80,0.4)", + font = list(size = 11) + ))) + } + + p +} + +bd_percent_metric <- function(pe, method) { + if (is.null(pe) || !all(c("type", "percent") %in% names(pe))) { + return(NA_real_) + } + + method0 <- gsub("^percent_", "", method) + idx <- which(pe$type == method0) + if (length(idx) == 0) { + return(NA_real_) + } + + as.numeric(pe$percent[idx[1]]) +} + +bd_fit_rainbow_plot <- function(past_metrics, future_metrics) { + bias_method <- getPMoptions("bias_method") + imp_method <- getPMoptions("imp_method") + + past_bias <- bd_percent_metric(past_metrics$pe, bias_method) + past_imp <- bd_percent_metric(past_metrics$pe, imp_method) + future_bias <- bd_percent_metric(future_metrics$pe, bias_method) + future_imp <- bd_percent_metric(future_metrics$pe, imp_method) + + x_vals <- c(-100, 100, past_bias, future_bias) + y_vals <- c(0, 100, past_imp, future_imp) + x_vals <- x_vals[is.finite(x_vals)] + y_vals <- y_vals[is.finite(y_vals)] + + if (length(x_vals) == 0 || length(y_vals) == 0) { + return(NULL) + } + + xlim <- c(min(x_vals), max(x_vals)) + ylim <- c(0, max(y_vals)) + + if (diff(xlim) < 40) xlim <- c(xlim[1] - 20, xlim[2] + 20) + if (ylim[2] < 20) ylim[2] <- 20 + + b <- seq(100, 0, -20) + a <- seq(50, 0, -10) + cols <- c( + "rgba(255,0,0,0.7)", + "rgba(255,165,0,0.7)", + "rgba(255,255,0,0.7)", + "rgba(154,205,50,0.7)", + "rgba(0,128,0,0.7)" + ) + + p <- plotly::plot_ly() + + for (i in 1:5) { + a1 <- a[i] + a2 <- a[i + 1] + b1 <- b[i] + b2 <- b[i + 1] + + x1 <- seq(-a1, a1, by = 1) + x2 <- seq(-a2, a2, by = 1) + y1 <- sqrt(pmax(0, b1^2 * (1 - x1^2 / a1^2))) + y2 <- sqrt(pmax(0, b2^2 * (1 - x2^2 / a2^2))) + + poly_x <- c(x1, rev(x2)) + poly_y <- c(y1, rev(y2)) + + p <- p |> + plotly::add_trace( + x = poly_x, + y = poly_y, + type = "scatter", + mode = "lines", + fill = "toself", + fillcolor = cols[i], + line = list(color = "rgba(0,0,0,0)", width = 0), + hoverinfo = "skip", + showlegend = FALSE + ) + } + + if (is.finite(past_bias) && is.finite(past_imp)) { + p <- p |> + plotly::add_markers( + x = past_bias, + y = past_imp, + marker = list(color = "black", size = 11, line = list(color = "white", width = 2)), + name = "Past (% bias, % imprecision)", + hoverlabel = list(bgcolor = bd_rainbow_region_color(past_bias, past_imp, alpha = 1)), + hovertemplate = "Past
%Bias: %{x:.2f}
%Imprecision: %{y:.2f}", + showlegend = TRUE + ) + } + + if (is.finite(future_bias) && is.finite(future_imp)) { + p <- p |> + plotly::add_markers( + x = future_bias, + y = future_imp, + marker = list(color = "red", size = 11, line = list(color = "white", width = 2)), + name = "Future (% bias, % imprecision)", + hoverlabel = list(bgcolor = bd_rainbow_region_color(future_bias, future_imp, alpha = 1)), + hovertemplate = "Future
%Bias: %{x:.2f}
%Imprecision: %{y:.2f}", + showlegend = TRUE + ) + } + + p |> + plotly::layout( + title = "Fit quality rainbow", + xaxis = list(title = "% Bias", range = xlim, zeroline = FALSE), + yaxis = list(title = "% Imprecision", range = ylim, zeroline = FALSE), + shapes = list( + list( + type = "rect", + x0 = xlim[1], + x1 = xlim[2], + y0 = 0, + y1 = ylim[2], + xref = "x", + yref = "y", + fillcolor = "#808080", + line = list(width = 0), + layer = "below" + ), + list( + type = "line", + x0 = 0, + x1 = 0, + y0 = 0, + y1 = ylim[2], + line = list(color = "rgba(128,128,128,0.9)", dash = "dash"), + layer = "below" + ) + ), + legend = list(orientation = "h", y = -0.2) + ) +} + +bd_rainbow_region_color <- function(bias, imp, alpha = 1) { + if (!is.finite(bias) || !is.finite(imp)) { + return(if (alpha >= 1) "#808080" else "rgba(128,128,128,0.7)") + } + + a <- seq(50, 0, -10) + b <- seq(100, 0, -20) + + inside_ellipse <- function(x, y, ax, by) { + if (!is.finite(ax) || !is.finite(by) || ax <= 0 || by <= 0) { + return(FALSE) + } + ((x^2) / (ax^2) + (y^2) / (by^2)) <= 1 + } + + base_cols <- c("#FF0000", "#FFA500", "#FFFF00", "#9ACD32", "#008000") + rgba_cols <- c( + "rgba(255,0,0,0.7)", + "rgba(255,165,0,0.7)", + "rgba(255,255,0,0.7)", + "rgba(154,205,50,0.7)", + "rgba(0,128,0,0.7)" + ) + + # smallest enclosing ellipse determines visible region color + for (i in 5:1) { + if (inside_ellipse(bias, imp, a[i], b[i])) { + return(if (alpha >= 1) base_cols[i] else rgba_cols[i]) + } + } + + if (alpha >= 1) "#808080" else "rgba(128,128,128,0.7)" +} + +bd_fit_rainbow_plot_single <- function(metrics, color = "black", name = "Point", title = "Fit quality") { + bias_method <- getPMoptions("bias_method") + imp_method <- getPMoptions("imp_method") + + bias_val <- bd_percent_metric(metrics$pe, bias_method) + imp_val <- bd_percent_metric(metrics$pe, imp_method) + + x_vals <- c(-100, 100) + y_vals <- c(0, 100) + if (is.finite(bias_val)) x_vals <- c(x_vals, bias_val) + if (is.finite(imp_val)) y_vals <- c(y_vals, imp_val) + + xlim <- c(min(x_vals), max(x_vals)) + ylim <- c(0, max(y_vals)) + + if (diff(xlim) < 40) xlim <- c(xlim[1] - 20, xlim[2] + 20) + if (ylim[2] < 20) ylim[2] <- 20 + + b <- seq(100, 0, -20) + a <- seq(50, 0, -10) + cols <- c( + "rgba(255,0,0,0.7)", + "rgba(255,165,0,0.7)", + "rgba(255,255,0,0.7)", + "rgba(154,205,50,0.7)", + "rgba(0,128,0,0.7)" + ) + + p <- plotly::plot_ly() + + for (i in 1:5) { + a1 <- a[i] + a2 <- a[i + 1] + b1 <- b[i] + b2 <- b[i + 1] + x1 <- seq(-a1, a1, by = 1) + x2 <- seq(-a2, a2, by = 1) + y1 <- sqrt(pmax(0, b1^2 * (1 - x1^2 / a1^2))) + y2 <- sqrt(pmax(0, b2^2 * (1 - x2^2 / a2^2))) + poly_x <- c(x1, rev(x2)) + poly_y <- c(y1, rev(y2)) + p <- p |> plotly::add_trace( + x = poly_x, y = poly_y, + type = "scatter", mode = "lines", + fill = "toself", fillcolor = cols[i], + line = list(color = "rgba(0,0,0,0)", width = 0), + hoverinfo = "skip", showlegend = FALSE + ) + } + + if (is.finite(bias_val) && is.finite(imp_val)) { + p <- p |> plotly::add_markers( + x = bias_val, y = imp_val, + marker = list(color = color, size = 11, line = list(color = "white", width = 2)), + name = name, + hoverlabel = list(bgcolor = bd_rainbow_region_color(bias_val, imp_val, alpha = 1)), + hovertemplate = paste0(name, "
%Bias: %{x:.2f}
%Imprecision: %{y:.2f}"), + showlegend = TRUE + ) + } + + p |> plotly::layout( + title = list(text = ""), + xaxis = list(title = "% Bias", range = xlim, zeroline = FALSE), + yaxis = list(title = "% Imprecision", range = ylim, zeroline = FALSE), + shapes = list( + list( + type = "rect", + x0 = xlim[1], x1 = xlim[2], + y0 = 0, y1 = ylim[2], + xref = "x", yref = "y", + fillcolor = "#808080", + line = list(width = 0), + layer = "below" + ), + list( + type = "line", + x0 = 0, x1 = 0, + y0 = 0, y1 = ylim[2], + line = list(color = "rgba(128,128,128,0.9)", dash = "dash"), + layer = "below" + ) + ), + legend = list(orientation = "h", y = -0.2) + ) +} + +bd_sim_weighted_conc <- function(x, sim_obj, outeq = 1, time_offset = 0) { + if (is.null(sim_obj) || is.null(sim_obj$data) || is.null(sim_obj$data$obs)) { + return(NULL) + } + + sim <- sim_obj$data$obs |> + dplyr::filter(outeq == !!outeq) |> + dplyr::mutate(time = time + time_offset) + + pred <- bd_weighted_pred_summary(x, sim) + if (is.null(pred) || nrow(pred) == 0) { + return(NULL) + } + + pred |> + dplyr::group_by(time) |> + dplyr::summarise(conc = mean(pred, na.rm = TRUE), .groups = "drop") |> + dplyr::arrange(time) +} + +bd_past_dose_events <- function(x) { + if (is.null(x$past) || is.null(x$past$standard_data)) { + return(NULL) + } + + doses <- x$past$standard_data |> + dplyr::filter(evid == 1) + + if (nrow(doses) == 0) { + return(NULL) + } + + doses <- bd_expand_dose_events(doses) + if (nrow(doses) == 0) { + return(NULL) + } + + doses |> + dplyr::mutate(source = "Past") +} + +bd_auc_interval <- function(conc_data, t0, t1) { + seg <- conc_data |> + dplyr::filter(time >= t0, time <= t1) |> + dplyr::arrange(time) + + if (nrow(seg) < 2) { + return(0) + } + + dt <- diff(seg$time) + y0 <- seg$conc[-nrow(seg)] + y1 <- seg$conc[-1] + sum((y0 + y1) / 2 * dt, na.rm = TRUE) +} + +bd_auc_table <- function(x, outeq = 1, start_datetime = NULL) { + offset <- bd_future_time_offset(x) + + past_conc <- bd_sim_weighted_conc(x, x$past_pred, outeq = outeq, time_offset = 0) + future_conc <- bd_sim_weighted_conc(x, x$future_pred, outeq = outeq, time_offset = offset) + conc <- dplyr::bind_rows(past_conc, future_conc) + + if (is.null(conc) || nrow(conc) == 0) { + return(NULL) + } + + conc <- conc |> + dplyr::group_by(time) |> + dplyr::summarise(conc = mean(conc, na.rm = TRUE), .groups = "drop") |> + dplyr::arrange(time) + + past_doses <- bd_past_dose_events(x) + future_doses <- bd_future_dose_events(x) + if (!is.null(future_doses) && nrow(future_doses) > 0) { + future_doses <- future_doses |> + dplyr::mutate(source = "Future") + } + + doses <- dplyr::bind_rows(past_doses, future_doses) + if (is.null(doses) || nrow(doses) == 0) { + return(NULL) + } + + doses <- doses |> + dplyr::arrange(time) + + n <- nrow(doses) + postdose <- numeric(n) + final_time <- max(conc$time, na.rm = TRUE) + + for (i in seq_len(n)) { + t0 <- doses$time[i] + t1 <- if (i < n) doses$time[i + 1] else final_time + if (is.finite(t0) && is.finite(t1) && t1 > t0) { + postdose[i] <- bd_auc_interval(conc, t0, t1) + } else { + postdose[i] <- 0 + } + } + + out <- doses |> + dplyr::transmute( + time = time, + dose = dose, + source = source, + postdose_auc = postdose, + cumulative_auc = cumsum(postdose) + ) + + bd_add_datetime_column(out, start_datetime) +} + +bd_auc_plot <- function(auc_tbl) { + if (is.null(auc_tbl) || nrow(auc_tbl) == 0) { + return(NULL) + } + + date_fmt <- getPMoptions("date_format", warn = FALSE, quiet = TRUE) + if (!is.character(date_fmt) || length(date_fmt) != 1 || !nzchar(date_fmt)) { + date_fmt <- if (grepl("en_US", Sys.getlocale("LC_TIME"), fixed = TRUE)) "%m/%d/%y" else "%d/%m/%y" + } + + df <- auc_tbl |> dplyr::mutate( + datetime = suppressWarnings(as.POSIXct(datetime, tz = Sys.timezone())), + dose_idx = seq_len(dplyr::n()), + dose_amt = ifelse(is.na(dose), NA_character_, formatC(as.numeric(dose), format = "f", digits = 2)), + date_label = format(datetime, date_fmt), + time_label = format(datetime, "%H:%M:%S") + ) + + # colors per source + cols <- ifelse(df$source == "Past", "black", "red") + + p <- plotly::plot_ly() + + # bars for post-dose AUC + p <- p |> plotly::add_bars( + x = ~ df$datetime, y = ~ df$postdose_auc, + marker = list(color = cols), + opacity = 0.5, + name = "Post-dose AUC", + showlegend = FALSE, + text = paste0( + "Dose: ", df$dose_idx, + "
Amount: ", df$dose_amt, + "
Date: ", df$date_label, + "
Time: ", df$time_label, + "
Post-dose AUC: ", sprintf("%.2f", df$postdose_auc) + ), + hoverinfo = "text", + textposition = "none" + ) + + # cumulative line split into past / future to change color + past_idx <- which(df$source == "Past") + future_idx <- which(df$source != "Past") + + if (length(past_idx) > 0) { + p <- p |> plotly::add_trace( + x = df$datetime[past_idx], y = df$cumulative_auc[past_idx], + type = "scatter", mode = "lines+markers", name = "Cumulative (Past)", + line = list(color = "black"), marker = list(color = "black"), yaxis = "y2", showlegend = FALSE, + text = paste0( + "Dose: ", df$dose_idx[past_idx], + "
Amount: ", df$dose_amt[past_idx], + "
Date: ", df$date_label[past_idx], + "
Time: ", df$time_label[past_idx], + "
Cumulative AUC: ", sprintf("%.2f", df$cumulative_auc[past_idx]) + ), + hoverinfo = "text" + ) + } + + if (length(future_idx) > 0) { + p <- p |> plotly::add_trace( + x = df$datetime[future_idx], y = df$cumulative_auc[future_idx], + type = "scatter", mode = "lines+markers", name = "Cumulative (Future)", + line = list(color = "red"), marker = list(color = "red"), yaxis = "y2", showlegend = FALSE, + text = paste0( + "Dose: ", df$dose_idx[future_idx], + "
Amount: ", df$dose_amt[future_idx], + "
Date: ", df$date_label[future_idx], + "
Time: ", df$time_label[future_idx], + "
Cumulative AUC: ", sprintf("%.2f", df$cumulative_auc[future_idx]) + ), + hoverinfo = "text" + ) + } + + # bridge segment from last past to first future cumulative point + if (length(past_idx) > 0 && length(future_idx) > 0) { + i_last_past <- max(past_idx) + i_first_future <- min(future_idx) + p <- p |> plotly::add_trace( + x = c(df$datetime[i_last_past], df$datetime[i_first_future]), + y = c(df$cumulative_auc[i_last_past], df$cumulative_auc[i_first_future]), + type = "scatter", mode = "lines", yaxis = "y2", + line = list(color = "black", width = 2), + showlegend = FALSE, + hoverinfo = "skip" + ) + } + + # x-axis tick text: dose number only + ticktext <- paste0("Dose ", df$dose_idx) + + p |> plotly::layout( + xaxis = list(title = "", tickvals = df$datetime, ticktext = ticktext), + yaxis = list(title = "Post-dose AUC", zeroline = FALSE), + yaxis2 = list( + overlaying = "y", side = "right", + title = list(text = "Cumulative AUC", standoff = 40), + automargin = TRUE, + zeroline = FALSE + ), + margin = list(t = 90), + bargap = 0.2, + showlegend = FALSE + ) +} + +bd_pd_table <- function(x, outeq = 1, start_datetime = NULL) { + if (is.null(x$future) || is.null(x$future$standard_data)) { + return(NULL) + } + + target_rows <- x$future$standard_data |> + dplyr::filter(evid == 0, outeq == !!outeq) + if (nrow(target_rows) == 0) { + return(NULL) + } + + target_time <- as.numeric(target_rows$time[1]) + target_value <- as.numeric(target_rows$out[1]) + if (!is.finite(target_time) || !is.finite(target_value)) { + return(NULL) + } + + past_doses <- bd_past_dose_events(x) + future_doses <- bd_future_dose_events(x) + if (!is.null(future_doses) && nrow(future_doses) > 0) { + future_doses <- future_doses |> + dplyr::mutate(source = "Future") + } + + doses <- dplyr::bind_rows(past_doses, future_doses) + if (is.null(doses) || nrow(doses) == 0) { + return(NULL) + } + + doses <- doses |> + dplyr::arrange(time) |> + dplyr::mutate(eval_time = time + target_time) + + offset <- bd_future_time_offset(x) + past_sim <- NULL + future_sim <- NULL + + if (!is.null(x$past_pred) && !is.null(x$past_pred$data) && !is.null(x$past_pred$data$obs)) { + past_sim <- x$past_pred$data$obs |> + dplyr::filter(outeq == !!outeq) + } + if (!is.null(x$future_pred) && !is.null(x$future_pred$data) && !is.null(x$future_pred$data$obs)) { + future_sim <- x$future_pred$data$obs |> + dplyr::filter(outeq == !!outeq) |> + dplyr::mutate(time = time + offset) + } + + sim <- dplyr::bind_rows(past_sim, future_sim) + if (is.null(sim) || nrow(sim) == 0) { + return(NULL) + } + + sim <- sim |> + dplyr::mutate(nsim = as.character(nsim)) + + weights <- bd_weight_table(x, sim$nsim) |> + dplyr::mutate(nsim = as.character(nsim)) + + sim_split <- split(sim, sim$nsim) + nsim_keys <- intersect(names(sim_split), weights$nsim) + if (length(nsim_keys) == 0) { + return(NULL) + } + + eval_times <- doses$eval_time + success_mat <- matrix(FALSE, nrow = length(nsim_keys), ncol = length(eval_times)) + w <- numeric(length(nsim_keys)) + + for (j in seq_along(nsim_keys)) { + key <- nsim_keys[j] + d <- sim_split[[key]] |> + dplyr::arrange(time) + d <- d[!is.na(d$time) & !is.na(d$out), , drop = FALSE] + if (nrow(d) < 2) next + + pred_at <- stats::approx( + x = d$time, + y = d$out, + xout = eval_times, + rule = 2, + ties = mean + )$y + + success <- pred_at >= target_value + success_mat[j, ] <- as.logical(success) + + w_row <- weights$weight[weights$nsim == key] + w[j] <- if (length(w_row) == 0 || !is.finite(w_row[1])) 0 else as.numeric(w_row[1]) + } + + if (sum(w, na.rm = TRUE) <= 0) { + return(NULL) + } + + cum_prob <- vapply(seq_along(eval_times), function(i) { + stats::weighted.mean(as.numeric(success_mat[, i]), w = w, na.rm = TRUE) + }, numeric(1)) + + out <- doses |> + dplyr::transmute( + dose_number = dplyr::row_number(), + time = time, + source = source, + cumulative_probability = cum_prob + ) + + bd_add_datetime_column(out, start_datetime) +} + +bd_add_datetime_column <- function(data, start_datetime) { + if (is.null(data) || nrow(data) == 0 || is.null(start_datetime) || is.na(start_datetime) || !"time" %in% names(data)) { + return(data) + } + + data |> + dplyr::mutate(datetime = format(start_datetime + time * 3600, "%Y-%m-%d %H:%M:%S")) |> + dplyr::relocate(datetime, .after = time) +} + +bd_normalize_weights <- function(w) { + w <- as.numeric(w) + w[!is.finite(w)] <- 0 + s <- sum(w, na.rm = TRUE) + if (!is.finite(s) || s <= 0) { + return(rep(0, length(w))) + } + w / s +} + +bd_parameter_shift_data <- function(x, bins = 25) { + if (is.null(x$posterior) || is.null(x$posterior$theta)) { + return(NULL) + } + + theta <- as.data.frame(x$posterior$theta) + if (nrow(theta) == 0 || ncol(theta) == 0) { + return(NULL) + } + + param_names <- colnames(theta) + if (is.null(param_names) || !length(param_names)) { + param_names <- x$posterior$param_names + colnames(theta) <- param_names + } + + prior_w <- bd_normalize_weights(x$posterior$population_weights) + post_w <- bd_normalize_weights(x$posterior$posterior_weights) + + n_points <- nrow(theta) + if (length(prior_w) != n_points) prior_w <- rep(1 / n_points, n_points) + if (length(post_w) != n_points) post_w <- rep(1 / n_points, n_points) + + bins <- max(5L, as.integer(bins)) + + long <- lapply(seq_along(param_names), function(i) { + p <- param_names[i] + vals <- as.numeric(theta[[p]]) + + ok <- is.finite(vals) + if (!any(ok)) { + return(NULL) + } + + vals_ok <- vals[ok] + prior_ok <- bd_normalize_weights(prior_w[ok]) + post_ok <- bd_normalize_weights(post_w[ok]) + + if (length(vals_ok) == 1 || diff(range(vals_ok, na.rm = TRUE)) == 0) { + bin_idx <- rep(1L, length(vals_ok)) + breaks <- range(vals_ok, na.rm = TRUE) + if (length(breaks) < 2 || !is.finite(diff(breaks)) || diff(breaks) == 0) { + breaks <- c(vals_ok[1] - 0.5, vals_ok[1] + 0.5) + } + bins_use <- 1L + } else { + breaks <- seq(min(vals_ok, na.rm = TRUE), max(vals_ok, na.rm = TRUE), length.out = bins + 1L) + bin_idx <- cut(vals_ok, breaks = breaks, include.lowest = TRUE, labels = FALSE) + bins_use <- bins + } + + bin_tbl <- tibble::tibble( + parameter = p, + bin = as.integer(bin_idx), + value = vals_ok, + prior_weight = prior_ok, + post_weight = post_ok + ) |> + dplyr::group_by(parameter, bin) |> + dplyr::summarise( + value_low = min(value, na.rm = TRUE), + value_high = max(value, na.rm = TRUE), + value_mid = stats::weighted.mean(value, w = post_weight, na.rm = TRUE), + prior_prob = sum(prior_weight, na.rm = TRUE), + post_prob = sum(post_weight, na.rm = TRUE), + .groups = "drop" + ) + + all_bins <- tibble::tibble(bin = seq_len(bins_use)) + out <- all_bins |> + dplyr::left_join(bin_tbl, by = dplyr::join_by(bin)) |> + dplyr::mutate( + parameter = p, + prior_prob = dplyr::coalesce(prior_prob, 0), + post_prob = dplyr::coalesce(post_prob, 0), + delta_prob = post_prob - prior_prob, + bin_pct = (bin - 0.5) / bins_use * 100, + q_label = sprintf("Q%02d", bin) + ) + + out + }) |> + dplyr::bind_rows() + + if (is.null(long) || nrow(long) == 0) { + return(NULL) + } + + summary_tbl <- long |> + dplyr::group_by(parameter) |> + dplyr::summarise( + total_variation = 0.5 * sum(abs(delta_prob), na.rm = TRUE), + max_shift = max(abs(delta_prob), na.rm = TRUE), + .groups = "drop" + ) |> + dplyr::arrange(dplyr::desc(total_variation), dplyr::desc(max_shift)) + + means_tbl <- tibble::tibble( + parameter = param_names, + prior_mean = vapply(seq_along(param_names), function(i) { + stats::weighted.mean(as.numeric(theta[[i]]), w = prior_w, na.rm = TRUE) + }, numeric(1)), + posterior_mean = vapply(seq_along(param_names), function(i) { + stats::weighted.mean(as.numeric(theta[[i]]), w = post_w, na.rm = TRUE) + }, numeric(1)) + ) |> + dplyr::mutate(mean_shift = posterior_mean - prior_mean) + + summary_tbl <- summary_tbl |> + dplyr::left_join(means_tbl, by = dplyr::join_by(parameter)) + + long <- long |> + dplyr::mutate( + parameter = factor(parameter, levels = summary_tbl$parameter) + ) + + list(long = long, summary = summary_tbl, bins = bins) +} + +bd_parameter_shift_heatmap <- function(shift_data) { + if (is.null(shift_data) || is.null(shift_data$long) || nrow(shift_data$long) == 0) { + return(NULL) + } + + df <- shift_data$long |> + dplyr::arrange(parameter, bin) + + df <- df |> + dplyr::mutate( + x_value = dplyr::coalesce(value_mid, (value_low + value_high) / 2) + ) + + df_prior <- df |> + dplyr::filter(is.finite(x_value), is.finite(prior_prob), prior_prob > 0) + + df_post <- df |> + dplyr::filter(is.finite(x_value), is.finite(post_prob), post_prob > 0) + + gg <- ggplot2::ggplot() + + ggplot2::geom_point( + data = df_prior, + ggplot2::aes(x = x_value, y = prior_prob), + color = "grey55", + size = 2.3, + shape = 16 + ) + + ggplot2::geom_point( + data = df_post, + ggplot2::aes(x = x_value, y = post_prob), + color = "red", + alpha = 0.5, + size = 2.3, + shape = 16 + ) + + ggplot2::facet_wrap(~parameter, scales = "free") + + ggplot2::scale_x_continuous(breaks = scales::pretty_breaks(n = 6)) + + ggplot2::scale_y_continuous(breaks = scales::pretty_breaks(n = 5)) + + ggplot2::labs( + title = "Marginal parameter distributions: prior (gray) vs posterior (red)", + x = "Parameter value", + y = "Probability" + ) + + ggplot2::theme_minimal(base_size = 12) + + ggplot2::theme( + legend.position = "none", + panel.grid.minor = ggplot2::element_blank() + ) + + plotly::ggplotly(gg) +} + +bd_report_build <- function(x, outeq = 1) { + start_datetime <- bd_plot_start_datetime(x) + future_offset <- bd_future_time_offset(x) + + overview <- tibble::tibble( + item = c("Status", "Method", "Objective", "log(Objective)", "Prior weight", "Start", "Start offset (h)", "Future starts at (h)"), + value = c( + x$status %||% NA_character_, + x$method %||% NA_character_, + signif(x$objf %||% NA_real_, 6), + if (is.null(x$objf) || is.na(x$objf) || x$objf <= 0) NA_real_ else signif(log(x$objf), 6), + x$prior_weight %||% NA_real_, + paste(x$start %||% NA_character_, collapse = ", "), + x$start_offset %||% NA_real_, + future_offset + ) + ) + + past_last_dose <- NULL + past_last_obs <- NULL + if (!is.null(x$past) && !is.null(x$past$standard_data) && nrow(x$past$standard_data) > 0) { + past_last_dose <- x$past$standard_data |> + dplyr::filter(evid == 1) |> + dplyr::arrange(dplyr::desc(time)) |> + dplyr::slice(1) |> + dplyr::select(time, dose, dur, input) + + past_last_obs <- x$past$standard_data |> + dplyr::filter(evid == 0, outeq == !!outeq) |> + dplyr::arrange(dplyr::desc(time)) |> + dplyr::slice(1) |> + dplyr::select(time, out, outeq) + } + + # Original requested doses (0 = Optimized, non-zero = Fixed), captured before optimization + original_requested_doses <- x$future_requested_doses + + future_doses <- bd_future_dose_events(x) + if (!is.null(future_doses) && nrow(future_doses) > 0) { + n_fd <- nrow(future_doses) + status_vec <- rep("Fixed", n_fd) + if (!is.null(original_requested_doses) && length(original_requested_doses) >= n_fd) { + status_vec <- dplyr::if_else( + as.numeric(original_requested_doses[seq_len(n_fd)]) == 0, + "Optimized", "Fixed" + ) + } + future_doses <- future_doses |> + dplyr::select(time, dose, dur, input) |> + dplyr::mutate(status = status_vec) |> + bd_add_datetime_column(start_datetime) + } + + future_targets <- NULL + if (!is.null(x$future) && !is.null(x$future$standard_data)) { + future_targets <- x$future$standard_data |> + dplyr::filter(evid == 0, outeq == !!outeq) |> + dplyr::mutate(time = time + future_offset) |> + dplyr::select(time, out, outeq) |> + bd_add_datetime_column(start_datetime) + } + + future_predictions <- x$result$predictions + if (!is.null(future_predictions) && nrow(future_predictions) > 0) { + future_predictions <- future_predictions |> + dplyr::filter(outeq == !!(outeq - 1)) |> + bd_add_datetime_column(start_datetime) + } + + auc_table <- bd_auc_table(x, outeq = outeq, start_datetime = start_datetime) + auc_plot <- bd_auc_plot(auc_table) + pd_table <- bd_pd_table(x, outeq = outeq, start_datetime = start_datetime) + + pd_target_summary <- NULL + if (!is.null(x$future_target_info)) { + ti <- x$future_target_info + tt <- ti$target_type %||% "concentration" + tgt <- ti$target + ttm <- ti$target_time + if (!is.null(tt) && tt == "time") { + pct <- if (!is.null(ttm) && is.numeric(ttm) && !is.na(ttm)) round(ttm * 100) else NA + pd_target_summary <- paste0( + "Therapeutic target: Time above ", tgt, + " for ", pct, "% of each dosing interval." + ) + } else { + type_label <- if (!is.null(tt) && tt == "auc") "AUC" else "Concentration" + ttm_display <- if (!is.null(ttm) && length(ttm) == 1 && is.numeric(ttm) && !is.na(ttm)) ttm else 24 + pd_target_summary <- paste0( + "Therapeutic target: ", type_label, " of ", tgt, + ", ", ttm_display, " hours after each dose." + ) + } + } + + past_fit <- bd_fit_data(x, source = "past", outeq = outeq) + future_fit <- bd_fit_data(x, source = "future", outeq = outeq) + + past_fit <- bd_add_datetime_column(past_fit, start_datetime) + future_fit <- bd_add_datetime_column(future_fit, start_datetime) + + past_fit_metrics <- bd_fit_metrics(past_fit) + future_fit_metrics <- bd_fit_metrics(future_fit) + + posterior_table <- as.data.frame(x$posterior$theta) + posterior_table$weight <- as.numeric(x$posterior$posterior_weights) + posterior_table$population_weight <- as.numeric(x$posterior$population_weights) + + posterior_summary <- tibble::tibble( + parameter = x$posterior$param_names, + weighted_mean = vapply(seq_along(x$posterior$param_names), function(i) { + stats::weighted.mean(x$posterior$theta[, i], x$posterior$posterior_weights, na.rm = TRUE) + }, numeric(1)), + weighted_median = vapply(seq_along(x$posterior$param_names), function(i) { + vals <- x$posterior$theta[, i] + wts <- x$posterior$posterior_weights + ord <- order(vals) + vals <- vals[ord] + wts <- wts[ord] / sum(wts) + vals[which.max(cumsum(wts) >= 0.5)] + }, numeric(1)), + weighted_sd = vapply(seq_along(x$posterior$param_names), function(i) { + vals <- x$posterior$theta[, i] + mu <- stats::weighted.mean(vals, x$posterior$posterior_weights, na.rm = TRUE) + sqrt(stats::weighted.mean((vals - mu)^2, x$posterior$posterior_weights, na.rm = TRUE)) + }, numeric(1)) + ) + + shift_data <- bd_parameter_shift_data(x, bins = 25) + + list( + overview = overview, + plot = plot.bd(x, quiet = TRUE, print = FALSE, future_region = FALSE), + past_rainbow_plot = bd_fit_rainbow_plot_single(past_fit_metrics, color = "black", name = "Past"), + future_rainbow_plot = bd_fit_rainbow_plot_single(future_fit_metrics, color = "red", name = "Future"), + past_last_dose = bd_add_datetime_column(past_last_dose, start_datetime), + past_last_obs = bd_add_datetime_column(past_last_obs, start_datetime), + future_doses = future_doses, + future_targets = future_targets, + future_predictions = future_predictions, + auc_plot = auc_plot, + auc_table = auc_table, + pd_table = pd_table, + pd_target_summary = pd_target_summary, + past_fit = past_fit, + future_fit = future_fit, + past_fit_metrics = past_fit_metrics, + future_fit_metrics = future_fit_metrics, + past_fit_plot = bd_fit_plot(past_fit, "Past observations vs predictions"), + future_fit_plot = bd_fit_plot(future_fit, "Future targets vs predictions"), + posterior_summary = posterior_summary, + posterior_table = posterior_table, + parameter_shift_plot = bd_parameter_shift_heatmap(shift_data), + parameter_shift_summary = if (!is.null(shift_data)) shift_data$summary else NULL, + model_summary = paste(capture.output(print(x$posterior$model_info$model)), collapse = "\n") + ) +} + +bd_report <- function(x, path, show = TRUE, quiet = TRUE, title = "BestDose Report") { + if (!inherits(x, "bd")) { + cli::cli_abort(c("x" = "This function expects a {.cls bd} object.")) + } + + template_file <- system.file("report/templates/bestdose.Rmd", package = "Pmetrics") + if (!nzchar(template_file) || !file.exists(template_file)) { + cli::cli_abort(c("x" = "BestDose report template was not found in the package.")) + } + + out_path <- if (missing(path)) tempdir() else normalizePath(path, winslash = "/", mustWork = FALSE) + fs::dir_create(out_path) + + rmarkdown::render( + input = template_file, + output_file = file.path(out_path, "bestdose_report.html"), + params = list(bd = x, title = title), + clean = TRUE, + quiet = quiet + ) + + out_file <- file.path(out_path, "bestdose_report.html") + if (file.exists(out_file)) { + if (show) { + pander::openFileInOS(out_file) + } + return(invisible(1)) + } + + invisible(-1) +} diff --git a/R/PM_data.R b/R/PM_data.R index 651a7000..42f1b0e9 100755 --- a/R/PM_data.R +++ b/R/PM_data.R @@ -12,7 +12,7 @@ #' to process the data #' #' @details -#' *PM_data* objects are passed to the `$fit` method of compiled [PM_model] objects to initiate a +#' *PM_data* objects are passed to [PM_fit] objects to initiate a #' population analysis. The object is created by reading a delimited file in #' the current working directory. The data will be transformed into the standard #' format which is the same for all engines, with a report of any assumptions @@ -31,430 +31,414 @@ #' defined for a PM_data object, including to write the standard data back #' to a file for future use, to summarize and to plot the object, to #' conduct a non-compartmental analysis on the raw data using -#' [make_NCA], to calculate an AUC using [make_AUC], and to add event rows, which +#' [makeNCA], to calculate an AUC using [makeAUC], and to add event rows, which #' is particularly useful for making simulation templates on the fly. #' #' @export PM_data <- R6::R6Class("PM_data", - public <- list( - #' @field data Data frame containing the data to be modeled +public <- list( + #' @field data Data frame containing the data to be modeled + data = NULL, + #' @field standard_data Data frame containing standardized version of the data + standard_data = NULL, + #' @field pop The `$data` field from a [PM_pop] object. This makes it easy to add population predictions to a raw data plot. This field will be `NULL` until the [PM_data] object is added to the [PM_result] after a run. As examples: + #' * `dat <- PM_data$new("data.csv")`. Here, `dat$pop` will be `NULL`. + #' * `run1 <- PM_load(1)`. Here, `run1$data$pop` will be the same as `run1$pop$data`. + pop = NULL, + #' @field post The `$data` field from a [PM_post] object. See details in the `pop` argument above. + post = NULL, + #' @description + #' Create new data object + #' @details + #' Creation of a new [PM_data] objects from a file or + #' a data frame. Data will be standardized and checked + #' automatically to a fully specified, valid data object. + #' @param data A quoted name of a file with full path if not + #' in the working directory, an unquoted name of a data frame + #' in the current R environment, or a [PM_data] object, which will rebuild it. + #' @param dt Pmetrics will try a variety of date/time formats. If all 16 of + #' them fail, use this parameter to specify the correct format as a + #' character vector whose + #' first element is date format and second is time. Use the following abbreviations: + #' * Y = 4 digit year + #' * y = 2 digit year + #' * m = decimal month (1, 2, ..., 12) + #' * d = decimal day (1, 2, ..., 31) + #' * H = hours (0-23) + #' * M = minutes (0-59) + #' Example: `format = c("myd", "mh")`. Not one of the tried combinations! + #' Always check to make sure that dates/times were parsed correctly and the + #' relative times in the `PM_data$standard_data` field look correct. + #' Other date/time formats are possible. See [lubridate::parse_date_time()] for these. + #' @param quiet Quietly validate. Default is `FALSE`. + #' @param validate Check for errors. Default is `TRUE`. Strongly recommended. + #' @param ... Other arguments (not currently used). + initialize = function( data = NULL, - #' @field standard_data Data frame containing standardized version of the data - standard_data = NULL, - #' @field pop The `$data` field from a [PM_pop] object. This makes it easy to add population predictions to a raw data plot. This field will be `NULL` until the [PM_data] object is added to the [PM_result] after a run. As examples: - #' * `dat <- PM_data$new("data.csv")`. Here, `dat$pop` will be `NULL`. - #' * `run1 <- PM_load(1)`. Here, `run1$data$pop` will be the same as `run1$pop$data`. - pop = NULL, - #' @field post The `$data` field from a [PM_post] object. See details in the `pop` argument above. - post = NULL, - #' @description - #' Create new data object - #' @details - #' Creation of a new [PM_data] objects from a file or - #' a data frame. Data will be standardized and checked - #' automatically to a fully specified, valid data object. - #' @param data A quoted name of a file with full path if not - #' in the working directory, an unquoted name of a data frame - #' in the current R environment, or a [PM_data] object, which will rebuild it. - #' @param dt Pmetrics will try a variety of date/time formats. If all 16 of - #' them fail, use this parameter to specify the correct format as a - #' character vector whose - #' first element is date format and second is time. Use the following abbreviations: - #' * Y = 4 digit year - #' * y = 2 digit year - #' * m = decimal month (1, 2, ..., 12) - #' * d = decimal day (1, 2, ..., 31) - #' * H = hours (0-23) - #' * M = minutes (0-59) - #' Example: `format = c("myd", "mh")`. Not one of the tried combinations! - #' Always check to make sure that dates/times were parsed correctly and the - #' relative times in the `PM_data$standard_data` field look correct. - #' Other date/time formats are possible. See [lubridate::parse_date_time()] for these. - #' @param quiet Quietly validate. Default is `FALSE`. - #' @param validate Check for errors. Default is `TRUE`. Strongly recommended. - #' @param ... Other arguments (not currently used). - initialize = function( - data = NULL, - dt = NULL, - quiet = FALSE, - validate = TRUE, - ... - ) { + dt = NULL, + quiet = FALSE, + validate = TRUE, + ...) { if (is.character(data)) { # filename self$data <- rlang::try_fetch(PMreadMatrix(data, quiet = TRUE), - error = function(e) { - cli::cli_abort("Unable to create {.cls PM_data} object", parent = e) - return(NULL) - } - ) - path <- dirname(data) - } else if (inherits(data, "PM_data")) { # R6 - self$data <- data$data - path <- getwd() - } else { # something else - self$data <- data - path <- getwd() - } - - if (!is.null(self$data) && validate) { - self$standard_data <- private$validate(self$data, path = path, quiet = quiet, dt = dt) - } - }, - #' @description - #' Save data to file - #' @details - #' Saves a delimited file (e.g. comma-separated) - #' from the `standard_data` field - #' @param file_name A quoted name of the file to create - #' with full path if not - #' in the working directory. - #' @param ... Arguments passed to [PMwriteMatrix] - save = function(file_name, ...) { - if (!is.null(self$standard_data)) { - PMwriteMatrix(self$standard_data, file_name, ...) - } else { - cli::cli_warn("Create a validated {.cls PM_data} object before writing.") - } - }, - #' @description - #' Calculate AUC - #' @details - #' See [make_AUC]. - #' @param ... Arguments passed to [make_AUC]. - auc = function(...) { - if (!is.null(self$data)) { - rlang::try_fetch(make_AUC(self, ...), - error = function(e) { - cli::cli_warn("Unable to generate AUC.", parent = e) - return(NULL) - } - ) - } else { - cli::cli_warn("Data have not been defined.") - } - }, - #' @description - #' Perform non-compartmental analysis - #' @details - #' See [make_NCA]. - #' @param ... Arguments passed to [make_NCA]. - nca = function(...) { - if (!is.null(self$data)) { - make_NCA(self, ...) - } else { - cli::cli_warn("Data have not been defined.") - } - }, - #' @description - #' Plot method - #' @details - #' See [plot.PM_data]. - #' @param ... Arguments passed to [plot.PM_data] - plot = function(...) { - if (!is.null(self$data)) { - plot.PM_data(self, ...) - } else { - cli::cli_warn("Data have not been defined.") - } - }, - #' @description - #' Print method - #' @details - #' Displays the PM_data object in a variety of ways. - #' @param standard Display the standardized data if `TRUE`. - #' Default is `FALSE`. - #' @param viewer Display the Viewer if `TRUE`. - #' Default is \code{TRUE}. - #' @param ... Other arguments to [print.data.frame]. Only - #' passed if `viewer = FALSE`. - print = function(standard = F, viewer = T, ...) { - if (is.null(self$data)) { - cat("NULL data") - return(invisible(self)) - } - if (standard) { - what <- self$standard_data - title <- "Standardized Data" - } else { - what <- self$data - title <- "Data" - } - if (viewer) { - View(what, title = title) - } else { - print(what, ...) - } - return(invisible(self)) - }, - #' @description - #' Summary method - #' @details - #' See [summary.PM_data]. - #' @param ... Arguments passed to [summary.PM_data]. - summary = function(...) { - if (!is.null(self$standard_data)) { - summary.PM_data(self$standard_data, ...) - } else { - cli::cli_warn("Create a validated PM_data object before summarizing.") - } - }, - #' @description - #' Add events to PM_data object - #' @details - #' Add lines to a PM_data object by supplying named columns and values. - #' `ID` is always required. `Time` is handled differently depending on - #' the sequence of `addEvent` calls (see **Chaining** below). - #' * It is required for the first call to `addEvent` and should be 0. - #' For example: For example: `dat <- PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 5, ii = 24)` - #' * For subsequent calls to `addEvent` with specific times it should be included. - #' For example: `dat <- PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 5, ii = 24)$addEvent(id = 1, time = 144, out = -1)` - #' Here, because `out` wasn't in the original call *and* the next call contains a value for - #' `time`, an `out` value of -1 will be added at time 144 and `out` will be set to `NA` for all the - #' previous rows. - #' * In contrast, the behavior is different if you omit `time` when your - #' data object already has rows. In this case - #' the arguments in the call to `addEvent` (without a value for `time`) - #' will add those arguments as columns in the prior data with the specified value - #' or *replace* values in those columns if they - #' already exist. Be sure this is what you want. - #' For example, building on the prior example: `dat$addEvent(id = 1, dur = 0.5)`. - #' Note that we can chain to the previously created `dat` object. Here, a duration of 0.5 hours - #' will be added to every previous row in `dat` to create the new `dat` object, but no new - #' row is added since there is no `time` associated with it. - #' - #' Adding covariates is supported, but since valid subject records in Pmetrics - #' with covariates must contain non-missing values at time 0, covariates should - #' be included with the first call to `$addEvent()`. - #' - #' As we have seen in the examples above, `ADDL` and `II` are supported. - #' - #' **Chaining** Multiple `$addEvent()` calls can be chained with `PM_data$new()` - #' to create a blank data object and then add rows. - #' This can be particularly useful for creating simulation templates. - #' See the example. - #' @param ... Column names and values. - #' @param dt Pmetrics will try a variety of date/time formats. If all 16 of - #' them fail, use this parameter to specify the correct format as a - #' character vector whose - #' first element is date format and second is time. Use the following abbreviations: - #' * Y = 4 digit year - #' * y = 2 digit year - #' * m = decimal month (1, 2, ..., 12) - #' * d = decimal day (1, 2, ..., 31) - #' * H = hours (0-23) - #' * M = minutes (0-59) - #' Example: `format = c("myd", "mh")`. Not one of the tried combinations! - #' Always check to make sure that dates/times were parsed correctly and the - #' relative times in the `PM_data$standard_data` field look correct. - #' Other date/time formats are possible. See [lubridate::parse_date_time()] for these. - #' @param quiet Quietly validate. Default is `FALSE`. - #' @param validate Validate the new row or not. Default is `FALSE` as a new row - #' added to a blank will result in a one-row data object, which is invalid. Also, - #' only one event type (dose or observation) should be added at a time, so if the - #' new object contains only doses while building, this would cause an error. You - #' should set `validate = TRUE` for the final addition. - #' @examples - #' \dontrun{ - #' PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 4, ii = 12, - #' out = NA, wt = 75)$addEvent(id = 1, time = 60, out = -1) - #' } - - addEvent = function(..., dt = NULL, quiet = FALSE, validate = FALSE) { - args <- list(...) - arg_names <- tolower(names(args)) - - if (!"id" %in% arg_names) { - cli::cli_abort(c("x" = "ID is required to add an event.")) - } - to_add <- data.frame(args) - - if (!is.null(self$data)) { # existing data - old_names <- names(self$data) - missing_args <- arg_names[!arg_names %in% old_names] - if (length(missing_args) > 0) { - self$data[missing_args] <- NA - } - if (!"time" %in% arg_names) { - to_add <- to_add |> dplyr::slice(rep(1, each = nrow(self$data))) - self$data[arg_names] <- to_add - if (validate) { - self$data <- self$data |> dplyr::select(where(~ !all(is.na(.x)))) # clean up - self$standard_data <- private$validate(self$data, path = getwd(), dt = dt, quiet = quiet) - } else { - self$standard_data <- NULL - } - return(invisible(self)) - } - } else { - if (!"time" %in% arg_names) { - cli::cli_abort(c("x" = "Time is required to add the first event.")) + error = function(e) { + cli::cli_abort("Unable to create {.cls PM_data} object", parent = e) + return(NULL) } + ) + path <- dirname(data) + } else if (inherits(data, "PM_data")) { # R6 + self$data <- data$data + path <- getwd() + } else { # something else + self$data <- data + path <- getwd() + } + + if (!is.null(self$data) && validate) { + self$standard_data <- private$validate(self$data, path = path, quiet = quiet, dt = dt) + } + }, + #' @description + #' Save data to file + #' @details + #' Saves a delimited file (e.g. comma-separated) + #' from the `standard_data` field + #' @param file_name A quoted name of the file to create + #' with full path if not + #' in the working directory. + #' @param ... Arguments passed to [PMwriteMatrix] + save = function(file_name, ...) { + if (!is.null(self$standard_data)) { + PMwriteMatrix(self$standard_data, file_name, ...) + } else { + cli::cli_warn("Create a validated {.cls PM_data} object before writing.") + } + }, + #' @description + #' Calculate AUC + #' @details + #' See [makeAUC]. + #' @param ... Arguments passed to [makeAUC]. + auc = function(...) { + if (!is.null(self$data)) { + rlang::try_fetch(makeAUC(self, ...), + error = function(e) { + cli::cli_warn("Unable to generate AUC.", parent = e) + return(NULL) } - # addl will be expanded in validate - - # Ensure input is set to 1 for all dose events (EVID=1) - if (!"input" %in% names(to_add) && "dose" %in% names(to_add)) { - to_add$input <- ifelse(!is.na(to_add$dose), 1, NA) - } - new_data <- dplyr::bind_rows(self$data, to_add) |> dplyr::arrange(id, time) - + ) + } else { + cli::cli_warn("Data have not been defined.") + } +}, +#' @description +#' Perform non-compartmental analysis +#' @details +#' See [makeNCA]. +#' @param ... Arguments passed to [makeNCA]. +nca = function(...) { + if (!is.null(self$data)) { + makeNCA(self, ...) + } else { + cli::cli_warn("Data have not been defined.") + } +}, +#' @description +#' Plot method +#' @details +#' See [plot.PM_data]. +#' @param ... Arguments passed to [plot.PM_data] +plot = function(...) { + if (!is.null(self$data)) { + plot.PM_data(self, ...) + } else { + cli::cli_warn("Data have not been defined.") + } +}, +#' @description +#' Print method +#' @details +#' Displays the PM_data object in a variety of ways. +#' @param standard Display the standardized data if `TRUE`. +#' Default is `FALSE`. +#' @param viewer Display the Viewer if `TRUE`. +#' Default is \code{TRUE}. +#' @param ... Other arguments to [print.data.frame]. Only +#' passed if `viewer = FALSE`. +print = function(standard = F, viewer = T, ...) { + if (is.null(self$data)) { + cat("NULL data") + return(invisible(self)) + } + if (standard) { + what <- self$standard_data + title <- "Standardized Data" + } else { + what <- self$data + title <- "Data" + } + if (viewer) { + View(what, title = title) + } else { + print(what, ...) + } + return(invisible(self)) +}, +#' @description +#' Summary method +#' @details +#' See [summary.PM_data]. +#' @param ... Arguments passed to [summary.PM_data]. +summary = function(...) { + if (!is.null(self$standard_data)) { + summary.PM_data(self$standard_data, ...) + } else { + cli::cli_warn("Create a validated PM_data object before summarizing.") + } +}, +#' @description +#' Add events to PM_data object +#' @details +#' Add lines to a PM_data object by supplying named columns and values. +#' `ID` is always required. `Time` is handled differently depending on +#' the sequence of `addEvent` calls (see **Chaining** below). +#' * It is required for the first call to `addEvent` and should be 0. +#' For example: For example: `dat <- PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 5, ii = 24)` +#' * For subsequent calls to `addEvent` with specific times it should be included. +#' For example: `dat <- PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 5, ii = 24)$addEvent(id = 1, time = 144, out = -1)` +#' Here, because `out` wasn't in the original call *and* the next call contains a value for +#' `time`, an `out` value of -1 will be added at time 144 and `out` will be set to `NA` for all the +#' previous rows. +#' * In contrast, the behavior is different if you omit `time` when your +#' data object already has rows. In this case +#' the arguments in the call to `addEvent` (without a value for `time`) +#' will add those arguments as columns in the prior data with the specified value +#' or *replace* values in those columns if they +#' already exist. Be sure this is what you want. +#' For example, building on the prior example: `dat$addEvent(id = 1, dur = 0.5)`. +#' Note that we can chain to the previously created `dat` object. Here, a duration of 0.5 hours +#' will be added to every previous row in `dat` to create the new `dat` object, but no new +#' row is added since there is no `time` associated with it. +#' +#' Adding covariates is supported, but since valid subject records in Pmetrics +#' with covariates must contain non-missing values at time 0, covariates should +#' be included with the first call to `$addEvent()`. +#' +#' As we have seen in the examples above, `ADDL` and `II` are supported. +#' +#' **Chaining** Multiple `$addEvent()` calls can be chained with `PM_data$new()` +#' to create a blank data object and then add rows. +#' This can be particularly useful for creating simulation templates. +#' See the example. +#' @param ... Column names and values. +#' @param dt Pmetrics will try a variety of date/time formats. If all 16 of +#' them fail, use this parameter to specify the correct format as a +#' character vector whose +#' first element is date format and second is time. Use the following abbreviations: +#' * Y = 4 digit year +#' * y = 2 digit year +#' * m = decimal month (1, 2, ..., 12) +#' * d = decimal day (1, 2, ..., 31) +#' * H = hours (0-23) +#' * M = minutes (0-59) +#' Example: `format = c("myd", "mh")`. Not one of the tried combinations! +#' Always check to make sure that dates/times were parsed correctly and the +#' relative times in the `PM_data$standard_data` field look correct. +#' Other date/time formats are possible. See [lubridate::parse_date_time()] for these. +#' @param quiet Quietly validate. Default is `FALSE`. +#' @param validate Validate the new row or not. Default is `FALSE` as a new row +#' added to a blank will result in a one-row data object, which is invalid. Also, +#' only one event type (dose or observation) should be added at a time, so if the +#' new object contains only doses while building, this would cause an error. You +#' should set `validate = TRUE` for the final addition. +#' @examples +#' \dontrun{ +#' PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 4, ii = 12, +#' out = NA, wt = 75)$addEvent(id = 1, time = 60, out = -1) +#' } - self$data <- new_data +addEvent = function(..., dt = NULL, quiet = FALSE, validate = FALSE) { + args <- list(...) + arg_names <- tolower(names(args)) + + if (!"id" %in% arg_names) { + cli::cli_abort(c("x" = "ID is required to add an event.")) + } + to_add <- data.frame(args) + + if (!is.null(self$data)) { # existing data + old_names <- names(self$data) + missing_args <- arg_names[!arg_names %in% old_names] + if (length(missing_args) > 0) { + self$data[missing_args] <- NA + } + if (!"time" %in% arg_names) { + to_add <- to_add %>% dplyr::slice(rep(1, each = nrow(self$data))) + self$data[arg_names] <- to_add if (validate) { - self$data <- self$data |> - dplyr::select(where(~ !all(is.na(.x)))) |> - arrange(id, time, out) + self$data <- self$data %>% dplyr::select(where(~ !all(is.na(.x)))) # clean up self$standard_data <- private$validate(self$data, path = getwd(), dt = dt, quiet = quiet) } else { self$standard_data <- NULL } return(invisible(self)) - } # end addEvent - ), # end public - private = list( - validate = function(dataObj, path, quiet, dt) { - dataObj_orig <- dataObj # keep the original to pass to PMcheck - dataNames <- names(dataObj) - standardNames <- getFixedColNames() - - covNames <- dataNames[!dataNames %in% standardNames] - if ("date" %in% covNames) { - covNames <- covNames[-which(covNames == "date")] - } - - mandatory <- c("id", "time", "dose", "out") - missingMandatory <- sapply(mandatory, function(x) !x %in% dataNames) - if (any(missingMandatory)) { - cli::cli_abort(c("x" = "Your data are missing these mandatory columns: {mandatory[missingMandatory]}")) - } - - msg <- "Data are in full format already.\n" - - if (!"evid" %in% dataNames) { - dataObj$evid <- ifelse(is.na(dataObj$dose), 0, 1) - msg <- c(msg, "EVID inferred as 0 for observations, 1 for doses.\n") - } - - if ("date" %in% dataNames) { - relTime <- PMmatrixRelTime(dataObj, format = dt) - dataObj$time <- relTime$relTime - dataObj <- dataObj |> select(-date) - msg <- c(msg, paste0("Dates and clock times converted to relative decimal times using ", attr(relTime, "dt_format"), ".\n")) - } - - if (!"dur" %in% dataNames) { - dataObj$dur <- ifelse(is.na(dataObj$dose), NA, 0) - msg <- c(msg, "All doses assumed to be oral (DUR = 0).\n") - } - - if (!"addl" %in% dataNames) { - dataObj$addl <- NA - msg <- c(msg, "ADDL set to missing for all records.\n") - } else { - # ADDL present in raw data - addl_present <- any(!is.na(dataObj$addl)) - if (addl_present && ("ii" %in% dataNames) && any(!is.na(dataObj$ii))) { - msg <- c(msg, "ADDL doses were expanded at II intervals.\n") - } - } - - if (!"ii" %in% dataNames) { - dataObj$ii <- NA - msg <- c(msg, "II set to missing for all records.\n") - } - - if (!"input" %in% dataNames) { - dataObj$input <- ifelse(is.na(dataObj$dose), NA, 1) - msg <- c(msg, "All doses assumed to be INPUT = 1.\n") - } - - if (!"outeq" %in% dataNames) { - dataObj$outeq <- ifelse(is.na(dataObj$out), NA, 1) - msg <- c(msg, "All observations assumed to be OUTEQ = 1.\n") - } - - if (!"cens" %in% dataNames) { - dataObj$cens <- ifelse(is.na(dataObj$out), NA, "none") - msg <- c(msg, "All observations assumed to be uncensored.\n") - } - - if (is.numeric(dataObj$cens)) { - dataObj$cens <- ifelse(is.na(dataObj$out), NA, - dplyr::case_when( - dataObj$cens == 0 ~ "none", - dataObj$cens == 1 ~ "bloq", - dataObj$cens == -1 ~ "aloq", - TRUE ~ "none" - ) - ) - } - - errorCoef <- c("c0", "c1", "c2", "c3") - missingError <- sapply(errorCoef, function(x) !x %in% dataNames) - if (any(missingError)) { - dataObj$c0 <- dataObj$c1 <- dataObj$c2 <- dataObj$c3 <- NA - msg <- c(msg, "One or more error coefficients not specified. Error in model object will be used.\n") - } - - # expand any ADDL > 0 - # preserve original order (necessary for EVID=4) - dataObj$row <- 1:nrow(dataObj) - addl_lines <- dataObj |> filter(!is.na(addl) & addl > 0) - if (nrow(addl_lines) > 0) { - new_lines <- addl_lines |> - tidyr::uncount(addl, .remove = FALSE) |> - group_by(id, time, input) |> - mutate(time = ii * row_number() + time) |> - ungroup() - - dataObj <- bind_rows(dataObj, new_lines) |> - dplyr::arrange(id, time) |> - dplyr::mutate( - addl = ifelse(addl == -1, -1, NA), - ii = ifelse(addl == -1, ii, NA) - ) |> - select(!row) - - msg <- c(msg, "ADDL > 0 rows expanded.\n") - } - dataObj <- dataObj |> select(dplyr::all_of(standardNames), dplyr::all_of(covNames)) - # dataObj <- dataObj |> dplyr::arrange(id, time) - - if (length(msg) > 1) { - msg <- msg[-1] - } # data were not in standard format, so remove that message - - if (!quiet) { - cli::cli_h1("DATA STANDARDIZATION") - cat(msg) - } - - # Assign a block number for each id, incremented at each evid == 4 - dataObj <- dataObj |> - group_by(id) |> - mutate(block = cumsum(evid == 4)) |> - group_by(id, block) |> - arrange(time, desc(evid), .by_group = TRUE) |> - ungroup() |> - select(-block) - - if ("evid" %in% names(dataObj_orig)) { - dataObj_orig <- dataObj_orig |> - group_by(id) |> - mutate(block = cumsum(evid == 4)) |> - group_by(id, block) |> - arrange(time, desc(evid), .by_group = TRUE) |> - ungroup() |> - select(-block) - } else { - dataObj_orig <- dataObj_orig |> arrange(id, time, out) - } - - - validData <- PMcheck(data = list(standard = dataObj, original = dataObj_orig), path = path, fix = TRUE, quiet = quiet) - return(validData) - } # end validate function - ) # end private + } + } else { + if (!"time" %in% arg_names) { + cli::cli_abort(c("x" = "Time is required to add the first event.")) + } + } + # check for addl and if present, expand + if ("addl" %in% arg_names) { + addl_lines <- to_add %>% dplyr::filter(!is.na(addl) & addl > 0) + if (nrow(addl_lines) > 0) { + new_lines <- addl_lines %>% + tidyr::uncount(addl, .remove = F) %>% + dplyr::group_by(id) %>% + dplyr::mutate(time = ii * dplyr::row_number() + time) + + to_add <- dplyr::bind_rows(to_add, new_lines) %>% + dplyr::arrange(id, time) %>% + dplyr::mutate( + addl = ifelse(addl == -1, -1, NA), + ii = ifelse(addl == -1, ii, NA) + ) + } + } + new_data <- dplyr::bind_rows(self$data, to_add) %>% dplyr::arrange(id, time) + + + self$data <- new_data + if (validate) { + self$data <- self$data %>% dplyr::select(where(~ !all(is.na(.x)))) %>% arrange(id, time, out) + self$standard_data <- private$validate(self$data, path = getwd(), dt = dt, quiet = quiet) + } else { + self$standard_data <- NULL + } + return(invisible(self)) +} # end addEvent +), # end public +private = list( + validate = function(dataObj, path, quiet, dt) { + dataObj_orig <- dataObj # keep the original to pass to PMcheck + dataNames <- names(dataObj) + standardNames <- getFixedColNames() + + covNames <- dataNames[!dataNames %in% standardNames] + if ("date" %in% covNames) { + covNames <- covNames[-which(covNames == "date")] + } + + mandatory <- c("id", "time", "dose", "out") + missingMandatory <- sapply(mandatory, function(x) !x %in% dataNames) + if (any(missingMandatory)) { + cli::cli_abort(c("x" = "Your data are missing these mandatory columns: {mandatory[missingMandatory]}")) + } + + msg <- "Data are in full format already.\n" + + if (!"evid" %in% dataNames) { + dataObj$evid <- ifelse(is.na(dataObj$dose), 0, 1) + msg <- c(msg, "EVID inferred as 0 for observations, 1 for doses.\n") + } + + if ("date" %in% dataNames) { + relTime <- PMmatrixRelTime(dataObj, format = dt) + dataObj$time <- relTime$relTime + dataObj <- dataObj %>% select(-date) + msg <- c(msg, paste0("Dates and clock times converted to relative decimal times using ", attr(relTime, "dt_format"), ".\n")) + } + + if (!"dur" %in% dataNames) { + dataObj$dur <- ifelse(is.na(dataObj$dose), NA, 0) + msg <- c(msg, "All doses assumed to be oral (DUR = 0).\n") + } + + if (!"addl" %in% dataNames) { + dataObj$addl <- NA + msg <- c(msg, "ADDL set to missing for all records.\n") + } + + if (!"ii" %in% dataNames) { + dataObj$ii <- NA + msg <- c(msg, "II set to missing for all records.\n") + } + + if (!"input" %in% dataNames) { + dataObj$input <- ifelse(is.na(dataObj$dose), NA, 1) + msg <- c(msg, "All doses assumed to be INPUT = 1.\n") + } + + if (!"outeq" %in% dataNames) { + dataObj$outeq <- ifelse(is.na(dataObj$out), NA, 1) + msg <- c(msg, "All observations assumed to be OUTEQ = 1.\n") + } + + if (!"cens" %in% dataNames) { + dataObj$cens <- ifelse(is.na(dataObj$out), NA, "none") + msg <- c(msg, "All observations assumed to be uncensored.\n") + } + + if (is.numeric(dataObj$cens)) { + dataObj$cens <- ifelse(is.na(dataObj$out), NA, + dplyr::case_when( + dataObj$cens == 0 ~ "none", + dataObj$cens == 1 ~ "bloq", + dataObj$cens == -1 ~ "aloq", + TRUE ~ "none" + ) + ) + } + + errorCoef <- c("c0", "c1", "c2", "c3") + missingError <- sapply(errorCoef, function(x) !x %in% dataNames) + if (any(missingError)) { + dataObj$c0 <- dataObj$c1 <- dataObj$c2 <- dataObj$c3 <- NA + msg <- c(msg, "One or more error coefficients not specified. Error in model object will be used.\n") + } + + # expand any ADDL > 0 + # preserve original order (necessary for EVID=4) + dataObj$row <- 1:nrow(dataObj) + addl_lines <- dataObj %>% filter(!is.na(addl) & addl > 0) + if (nrow(addl_lines) > 0) { + new_lines <- addl_lines %>% + tidyr::uncount(addl, .remove = FALSE) %>% + group_by(id, time) %>% + mutate(time = ii * row_number() + time) %>% + ungroup() + + dataObj <- bind_rows(dataObj, new_lines) %>% + dplyr::arrange(id, time) %>% + dplyr::mutate( + addl = ifelse(addl == -1, -1, NA), + ii = ifelse(addl == -1, ii, NA) + ) %>% + select(!row) + + msg <- c(msg, "ADDL > 0 rows expanded.\n") + } + dataObj <- dataObj %>% select(dplyr::all_of(standardNames), dplyr::all_of(covNames)) + # dataObj <- dataObj %>% dplyr::arrange(id, time) + + if (length(msg) > 1) { + msg <- msg[-1] + } # data were not in standard format, so remove that message + + if (!quiet) { + cli::cli_h1("DATA STANDARDIZATION") + cat(msg) + } + + # sort by id, time, dose + dataObj_orig <- dataObj_orig %>% arrange(id, time, out) # for any out at same time as dose, out will come first + dataObj <- dataObj %>% arrange(id, time, out) + + validData <- PMcheck(data = list(standard = dataObj, original = dataObj_orig), path = path, fix = TRUE, quiet = quiet) + return(validData) + } # end validate function +) # end private ) # end PM_data # MAKE (PMreadMatrix, PMmatrixRelTime, PMcheck) --------------------------- @@ -501,62 +485,61 @@ PMreadMatrix <- function( file, sep = getPMoptions("sep"), dec = getPMoptions("dec"), - quiet = FALSE, ... -) { - # get data - if (missing(file)) { - cli::cli_abort(c("x" = "Please provide filename of Pmetrics data file.")) - } - - file <- normalizePath(file, mustWork = FALSE) - - if (!file.exists(file)) { - cli::cli_abort(c("x" = "The file {.code {basename(file)}} was not found in {.path {dirname(file)}}.")) - } - - # read the first line to understand the format - headers <- scan(file, - what = "character", quiet = TRUE, nlines = 1, - sep = sep, dec = dec, strip.white = T - ) - if (grepl(",", headers)[1]) { - cli::cli_abort(c("x" = "Your .csv delimiter is not a comma. Use {.code setPMoptions(sep = \";\")}, for example.")) - } - headers <- headers[headers != ""] - skip <- ifelse(grepl("POPDATA .*", headers[1]), 1, 0) # 0 if current, 1 if legacy - - args1 <- list( - file = file, delim = sep, col_names = TRUE, na = c(".", "NA", ""), - locale = readr::locale(decimal_mark = dec), - skip = skip, show_col_types = FALSE, progress = FALSE, num_threads = 1 - ) - args2 <- list(...) - - args <- modifyList(args1, args2) - - if (quiet) { - data <- suppressWarnings(purrr::exec(readr::read_delim, !!!args)) - } else { - data <- purrr::exec(readr::read_delim, !!!args) - } - - # remove commented headers and lines - if (grepl("#", names(data)[1])) { + quiet = FALSE, ...) { + # get data + if (missing(file)) { + cli::cli_abort(c("x" = "Please provide filename of Pmetrics data file.")) + } + + file <- normalizePath(file, mustWork = FALSE) + + if (!file.exists(file)) { + cli::cli_abort(c("x" = "The file {.code {basename(file)}} was not found in {.path {dirname(file)}}.")) + } + + # read the first line to understand the format + headers <- scan(file, + what = "character", quiet = TRUE, nlines = 1, + sep = sep, dec = dec, strip.white = T + ) + if (grepl(",", headers)[1]) { + cli::cli_abort(c("x" = "Your .csv delimiter is not a comma. Use {.code setPMoptions(sep = \";\")}, for example.")) + } + headers <- headers[headers != ""] + skip <- ifelse(grepl("POPDATA .*", headers[1]), 1, 0) # 0 if current, 1 if legacy + + args1 <- list( + file = file, delim = sep, col_names = TRUE, na = c(".", "NA", ""), + locale = readr::locale(decimal_mark = dec), + skip = skip, show_col_types = FALSE, progress = FALSE, num_threads = 1 + ) + args2 <- list(...) + + args <- modifyList(args1, args2) + + if (quiet) { + data <- suppressWarnings(purrr::exec(readr::read_delim, !!!args)) + } else { + data <- purrr::exec(readr::read_delim, !!!args) + } + + # remove commented headers and lines + if (grepl("#", names(data)[1])) { names(data)[1] <- sub("#", "", names(data)[1]) } comments <- grep("#", t(data[, 1])) if (length(comments) > 0) { data <- data[-comments, ] } - + names(data) <- tolower(names(data)) - + if (!quiet) { cat(paste("The file", sQuote(file), "contains these columns:\n", sep = " ")) cat(paste(names(data), collapse = ", ")) cat("\n") } - + attr(data, "legacy") <- ifelse(skip == 1, TRUE, FALSE) # if skip = 1, set attribute to TRUE class(data) <- c("PM_data_data", "data.frame") return(data) @@ -605,132 +588,131 @@ PMreadMatrix <- function( PMmatrixRelTime <- function( data, idCol = "id", dateCol = "date", timeCol = "time", evidCol = "evid", - format, split = F -) { - dataCols <- names(data) - # convert numeric if necessary - if (is.numeric(idCol)) idCol <- dataCols[idCol] - if (is.numeric(dateCol)) dateCol <- dataCols[dateCol] - if (is.numeric(timeCol)) timeCol <- dataCols[timeCol] - if (is.numeric(evidCol)) evidCol <- dataCols[evidCol] - - # Get preferred date format from PMoptions; derive lubridate order string (e.g. "%m/%d/%y" -> "mdy") - opt_date_fmt <- getPMoptions("date_format", warn = FALSE, quiet = TRUE) - if (!is.character(opt_date_fmt) || !nzchar(opt_date_fmt)) { - opt_date_fmt <- if (grepl("en_US", Sys.getlocale("LC_TIME"), fixed = TRUE)) "%m/%d/%y" else "%d/%m/%y" - } - opt_date_order <- paste( - tolower(gsub("Y", "y", regmatches(opt_date_fmt, gregexpr("(?<=%)[a-zA-Z]", opt_date_fmt, perl = TRUE))[[1]])), - collapse = "" - ) - opt_formats <- paste(opt_date_order, c("HM", "HMS", "IMOp", "IMSOp")) - - # all reasonable combinations (fallback) - dt_df <- tidyr::crossing(date = c("dmy", "mdy", "ymd", "ydm"), time = c("HM", "HMS", "IMOp", "IMSOp")) - dt_formats <- paste(dt_df$date, dt_df$time) - - if (!all(c(idCol, dateCol, timeCol, evidCol) %in% dataCols)) { - cli::cli_abort(c("x" = "Please provide column names for id, date, time and evid.")) - } - temp <- data.frame(id = data[, idCol], date = data[, dateCol], time = data[, timeCol], evid = data[, evidCol]) - temp$date <- as.character(temp$date) - temp$time <- as.character(temp$time) - temp$time <- unlist(lapply(temp$time, function(x) ifelse(length(gregexpr(":", x)[[1]]) == 1, paste(x, ":00", sep = ""), x))) - - get_dt_format <- function(test) { - found_formats <- table(suppressWarnings(lubridate::guess_formats(paste(temp$date, temp$time), test))) - format_str <- names(found_formats)[which(found_formats == max(found_formats))] - O_str <- grep("O", format_str) - if (length(O_str) > 0) { - format_str <- format_str[-O_str] + format, split = F) { + dataCols <- names(data) + # convert numeric if necessary + if (is.numeric(idCol)) idCol <- dataCols[idCol] + if (is.numeric(dateCol)) dateCol <- dataCols[dateCol] + if (is.numeric(timeCol)) timeCol <- dataCols[timeCol] + if (is.numeric(evidCol)) evidCol <- dataCols[evidCol] + + # Get preferred date format from PMoptions; derive lubridate order string (e.g. "%m/%d/%y" -> "mdy") + opt_date_fmt <- getPMoptions("date_format", warn = FALSE, quiet = TRUE) + if (!is.character(opt_date_fmt) || !nzchar(opt_date_fmt)) { + opt_date_fmt <- if (grepl("en_US", Sys.getlocale("LC_TIME"), fixed = TRUE)) "%m/%d/%y" else "%d/%m/%y" } - the_format <- gsub("%", "", format_str) - return(the_format) - } - - dt <- NA - found_format <- character(0) - - # Step 1: explicit format argument takes priority - if (!missing(format) && !is.null(format)) { - if (format[2] == "HM") format[2] <- "HMS" - format <- paste(format, collapse = " ") - dt <- tryCatch( - suppressWarnings(lubridate::parse_date_time(paste(temp$date, temp$time), quiet = TRUE, format)), - error = function(e) NA + opt_date_order <- paste( + tolower(gsub("Y", "y", regmatches(opt_date_fmt, gregexpr("(?<=%)[a-zA-Z]", opt_date_fmt, perl = TRUE))[[1]])), + collapse = "" ) - found_format <- get_dt_format(format) - } - - # Step 2: try PMoptions date_format - if (all(is.na(dt))) { - dt <- tryCatch( - suppressWarnings(lubridate::parse_date_time(paste(temp$date, temp$time), quiet = TRUE, opt_formats)), - error = function(e) NA - ) - if (!all(is.na(dt))) { - found_format <- get_dt_format(opt_formats) + opt_formats <- paste(opt_date_order, c("HM", "HMS", "IMOp", "IMSOp")) + + # all reasonable combinations (fallback) + dt_df <- tidyr::crossing(date = c("dmy", "mdy", "ymd", "ydm"), time = c("HM", "HMS", "IMOp", "IMSOp")) + dt_formats <- paste(dt_df$date, dt_df$time) + + if (!all(c(idCol, dateCol, timeCol, evidCol) %in% dataCols)) { + cli::cli_abort(c("x" = "Please provide column names for id, date, time and evid.")) } - } - - # Step 3: fall back to automatic detection across all reasonable formats - if (all(is.na(dt))) { - dt <- tryCatch( - suppressWarnings(lubridate::parse_date_time(paste(temp$date, temp$time), quiet = TRUE, dt_formats)), - error = function(e) NA - ) - found_format <- get_dt_format(dt_formats) - # Report if the detected format differs from the configured PMoptions format - if (!all(is.na(dt)) && length(found_format) > 0) { - found_date_orders <- unique( - tolower(gsub("Y", "y", gsub("[^a-zA-Z]", "", sub(" .*", "", found_format)))) + temp <- data.frame(id = data[, idCol], date = data[, dateCol], time = data[, timeCol], evid = data[, evidCol]) + temp$date <- as.character(temp$date) + temp$time <- as.character(temp$time) + temp$time <- unlist(lapply(temp$time, function(x) ifelse(length(gregexpr(":", x)[[1]]) == 1, paste(x, ":00", sep = ""), x))) + + get_dt_format <- function(test) { + found_formats <- table(suppressWarnings(lubridate::guess_formats(paste(temp$date, temp$time), test))) + format_str <- names(found_formats)[which(found_formats == max(found_formats))] + O_str <- grep("O", format_str) + if (length(O_str) > 0) { + format_str <- format_str[-O_str] + } + the_format <- gsub("%", "", format_str) + return(the_format) + } + + dt <- NA + found_format <- character(0) + + # Step 1: explicit format argument takes priority + if (!missing(format) && !is.null(format)) { + if (format[2] == "HM") format[2] <- "HMS" + format <- paste(format, collapse = " ") + dt <- tryCatch( + suppressWarnings(lubridate::parse_date_time(paste(temp$date, temp$time), quiet = TRUE, format)), + error = function(e) NA ) - if (!any(grepl(opt_date_order, found_date_orders, fixed = TRUE))) { - cli::cli_warn(c( - "!" = "Date format in data does not match the configured Pmetrics date format.", - "i" = "Configured: {.val {opt_date_fmt}}", - "i" = "Detected: {.val {paste(found_format, collapse = ', ')}}", - "i" = "Update your preference with {.fn setPMoptions}." - )) + found_format <- get_dt_format(format) + } + + # Step 2: try PMoptions date_format + if (all(is.na(dt))) { + dt <- tryCatch( + suppressWarnings(lubridate::parse_date_time(paste(temp$date, temp$time), quiet = TRUE, opt_formats)), + error = function(e) NA + ) + if (!all(is.na(dt))) { + found_format <- get_dt_format(opt_formats) + } + } + + # Step 3: fall back to automatic detection across all reasonable formats + if (all(is.na(dt))) { + dt <- tryCatch( + suppressWarnings(lubridate::parse_date_time(paste(temp$date, temp$time), quiet = TRUE, dt_formats)), + error = function(e) NA + ) + found_format <- get_dt_format(dt_formats) + # Report if the detected format differs from the configured PMoptions format + if (!all(is.na(dt)) && length(found_format) > 0) { + found_date_orders <- unique( + tolower(gsub("Y", "y", gsub("[^a-zA-Z]", "", sub(" .*", "", found_format)))) + ) + if (!any(grepl(opt_date_order, found_date_orders, fixed = TRUE))) { + cli::cli_warn(c( + "!" = "Date format in data does not match the configured Pmetrics date format.", + "i" = "Configured: {.val {opt_date_fmt}}", + "i" = "Detected: {.val {paste(found_format, collapse = ', ')}}", + "i" = "Update your preference with {.fn setPMoptions}." + )) + } } } - } - if (all(is.na(dt))) { - cli::cli_abort(c("x" = "All dates/times failed to parse. Please specify correct format. ")) - } +if (all(is.na(dt))) { + cli::cli_abort(c("x" = "All dates/times failed to parse. Please specify correct format. ")) +} - temp$dt <- dt # didn't have to stop, so at least some parsed +temp$dt <- dt # didn't have to stop, so at least some parsed - if (split) { - # calculate PK event numbers for each patient - for (i in unique(temp$id)) { - pk.no <- 1 - temp2 <- subset(temp, temp$id == i) - for (j in 1:nrow(temp2)) { - if (temp2$evid[j] == 4) { - pk.no <- pk.no + 1 - } - temp2$pk.no[j] <- pk.no +if (split) { + # calculate PK event numbers for each patient + for (i in unique(temp$id)) { + pk.no <- 1 + temp2 <- subset(temp, temp$id == i) + for (j in 1:nrow(temp2)) { + if (temp2$evid[j] == 4) { + pk.no <- pk.no + 1 } - temp$pk.no[temp$id == i] <- temp2$pk.no + temp2$pk.no[j] <- pk.no } - # make new ID of form xxxxx.x for each PK event per patient - temp$id <- temp$id + temp$pk.no / 10 - temp$evid[temp$evid == 4] <- 1 + temp$pk.no[temp$id == i] <- temp2$pk.no } + # make new ID of form xxxxx.x for each PK event per patient + temp$id <- temp$id + temp$pk.no / 10 + temp$evid[temp$evid == 4] <- 1 +} - # calculate relative times - temp <- makePMmatrixBlock(temp) |> - dplyr::group_by(id, block) |> - dplyr::mutate(relTime = (dt - dt[1]) / lubridate::dhours(1)) +# calculate relative times +temp <- makePMmatrixBlock(temp) %>% +dplyr::group_by(id, block) %>% +dplyr::mutate(relTime = (dt - dt[1]) / lubridate::dhours(1)) - temp$relTime <- round(temp$relTime, 2) - temp <- temp[, c("id", "evid", "relTime")] - attr(temp, "dt_format") <- found_format +temp$relTime <- round(temp$relTime, 2) +temp <- temp[, c("id", "evid", "relTime")] +attr(temp, "dt_format") <- found_format - return(temp) +return(temp) } #' @title Check Pmetrics Inputs for Errors #' @description @@ -880,14 +862,14 @@ PMcheck <- function(data, path = ".", fix = FALSE, quiet = FALSE) { if (is.null(legacy)) { legacy <- F } - - + + # check for errors err <- errcheck(data2, quiet = quiet, source = source) if (length(err) == 1) { cli::cli_abort(c("x" = "You must at least have id, evid, and time columns to proceed with the check.")) } - + # report errors in errors.xlsx if (attr(err, "error") != 0) { # Initialize an Excel Workbook @@ -901,7 +883,7 @@ PMcheck <- function(data, path = ".", fix = FALSE, quiet = FALSE) { openxlsx::saveWorkbook(wb, file = file.path(path, "errors.xlsx"), overwrite = TRUE) } } - + # Provide warning on console about maximum time maxTime <- tryCatch(max(data2$time, na.rm = T), error = function(e) NA) if (!is.na(maxTime) && !is.character(maxTime) && maxTime > 24 * 48 & !quiet) { @@ -913,8 +895,8 @@ PMcheck <- function(data, path = ".", fix = FALSE, quiet = FALSE) { ) ) } - - + + # try to fix errors if asked if (fix) { if (attr(err, "error") == 0) { @@ -935,7 +917,7 @@ PMcheck <- function(data, path = ".", fix = FALSE, quiet = FALSE) { wb <- createInstructions(wb) openxlsx::saveWorkbook(wb, file = file.path(path, "errors.xlsx"), overwrite = TRUE) } - + return(invisible(newdata)) } } else { @@ -945,6 +927,7 @@ PMcheck <- function(data, path = ".", fix = FALSE, quiet = FALSE) { } + ########### ERROR CHECKING, REPORTING AND FIXING FUNCTIONS # errcheck ---------------------------------------------------------------- @@ -974,18 +957,18 @@ errcheck <- function(data2, quiet, source) { ) # set initial attribute to 0 for no error attr(err, "error") <- 0 - + # define fixed column names fixedColNames <- getFixedColNames() - + # define number of columns and number of covariates numcol <- ncol(data2) numfix <- getFixedColNum() numcov <- getCov(data2)$ncov - + # ensure lowercase t <- tolower(names(data2)) - + # check to make sure first 14 columns are correct if (any(!c("id", "time", "evid") %in% t)) { # must at least have id, evid, and time columns to proceed with the check @@ -1000,8 +983,8 @@ errcheck <- function(data2, quiet, source) { attr(err, "error") <- -1 } } - - + + # check that all records have an EVID value t <- which(is.na(data2$evid)) if (length(t) > 0) { @@ -1009,7 +992,7 @@ errcheck <- function(data2, quiet, source) { err$missEVID$results <- t attr(err, "error") <- -1 } - + # check that all records have a TIME value t <- which(is.na(data2$time)) if (length(t) > 0) { @@ -1017,7 +1000,7 @@ errcheck <- function(data2, quiet, source) { err$missTIME$results <- t attr(err, "error") <- -1 } - + # check for dur on dose records t <- which(data2$evid != 0 & is.na(data2$dur)) if (length(t) > 0) { @@ -1025,7 +1008,7 @@ errcheck <- function(data2, quiet, source) { err$doseDur$results <- t attr(err, "error") <- -1 } - + # check for dose on dose records t <- which(data2$evid != 0 & is.na(data2$dose)) if (length(t) > 0) { @@ -1033,7 +1016,7 @@ errcheck <- function(data2, quiet, source) { err$doseDose$results <- t attr(err, "error") <- -1 } - + # check for input on dose records t <- which(data2$evid != 0 & is.na(data2$input)) if (length(t) > 0) { @@ -1041,7 +1024,7 @@ errcheck <- function(data2, quiet, source) { err$doseInput$results <- t attr(err, "error") <- -1 } - + # check for out on observation records t <- which(data2$evid == 0 & is.na(data2$out)) if (length(t) > 0) { @@ -1049,7 +1032,7 @@ errcheck <- function(data2, quiet, source) { err$obsOut$results <- t attr(err, "error") <- -1 } - + # check for outeq on observation records t <- which(data2$evid == 0 & is.na(data2$outeq)) if (length(t) > 0) { @@ -1057,7 +1040,7 @@ errcheck <- function(data2, quiet, source) { err$obsOuteq$results <- t attr(err, "error") <- -1 } - + # check for time=0 for each subject as first record t <- which(tapply(data2$time, data2$id, function(x) x[1]) != 0) t2 <- match(names(t), data2$id) @@ -1066,11 +1049,11 @@ errcheck <- function(data2, quiet, source) { err$T0$results <- t2 attr(err, "error") <- -1 } - + # covariate checks if (numcov > 0) { covinfo <- getCov(data2) - # check for missing covariates at time 0 + # check for missing covariates at time 0 time0 <- which(data2$time == 0 & data2$evid == 1) if (length(time0) > 1) { t <- apply(as.matrix(data2[time0, covinfo$covstart:covinfo$covend], ncol = numcov), 1, function(x) any(is.na(x))) @@ -1085,7 +1068,7 @@ errcheck <- function(data2, quiet, source) { err$covT0$msg <- "OK - All subjects have covariate data at time 0." } } - + # check that all times within a given ID block are monotonically increasing misorder <- NA for (i in 2:nrow(data2)) { @@ -1098,7 +1081,7 @@ errcheck <- function(data2, quiet, source) { err$timeOrder$results <- misorder[-1] attr(err, "error") <- -1 } - + # check that all records for a given subject ID are grouped temp <- data.frame(row = 1:nrow(data2), id = data2$id) t <- tapply(temp$row, temp$id, function(x) any(diff(x) > 1)) @@ -1112,20 +1095,20 @@ errcheck <- function(data2, quiet, source) { err$contigID$results <- t2 attr(err, "error") <- -1 } - + # check that all non-missing columns other than ID and cens are numeric - + allMiss <- names(data2)[which(apply(data2, 2, function(x) all(is.na(x))))] nonNumeric <- names(data2)[which(sapply(data2, function(x) !is.numeric(x)))] if (length(nonNumeric) > 0) { - nonNumeric <- nonNumeric[!nonNumeric %in% allMiss] |> purrr::discard(~ .x %in% (c("id", "cens"))) + nonNumeric <- nonNumeric[!nonNumeric %in% allMiss] %>% purrr::discard(~.x %in% (c("id", "cens"))) } - if (length(nonNumeric) > 0) { # exclude id, cens columns + if (length(nonNumeric) > 0 ) { # exclude id, cens columns err$nonNum$msg <- "FAIL - The following columns must be all numeric." err$nonNum$results <- nonNumeric attr(err, "error") <- -1 } - + # check that all subjects have at least one observation subjObs <- tapply(data2$evid, data2$id, function(x) sum(x == 0, na.rm = T)) if (any(subjObs == 0)) { @@ -1134,18 +1117,18 @@ errcheck <- function(data2, quiet, source) { err$noObs$results <- which(data2$id %in% subjMissObs) attr(err, "error") <- -1 } - + # check for columns with malformed NA values - mal_NA <- purrr::map(as.list(data2), ~ stringr::str_count(.x, "(? - map(~ which(.x == 1)) |> - purrr::map_vec(~ length(.x) > 0) |> - which() + mal_NA <- purrr::map(as.list(data2), ~ stringr::str_count(.x, "(?% + map(~ which(.x == 1)) %>% + purrr::map_vec(~ length(.x) > 0) %>% + which() if (length(mal_NA) > 0) { err$mal_NA$msg <- "FAIL - The following columns contain malformed NA values." err$mal_NA$results <- mal_NA attr(err, "error") <- -1 } - + # check that doses and observations are separated doseOut <- which(!is.na(data2$dose) & !is.na(data2$out)) if (length(doseOut) > 0) { @@ -1153,16 +1136,17 @@ errcheck <- function(data2, quiet, source) { err$doseOut$results <- doseOut attr(err, "error") <- -1 } - - + + + class(err) <- c("PMerr", "list") if (!quiet) { cli::cli_h1("DATA VALIDATION") print(err) flush.console() } - - + + if (!quiet) flush.console() return(err) } @@ -1189,7 +1173,7 @@ errfix <- function(data2, err, quiet) { report <- c(report, paste("Columns are now ordered appropriately.")) } } - + # Check for NA observations (should be -99) if (length(grep("FAIL", err$obsMiss$msg)) > 0) { data2 <- data2[err$obsMiss$results, "out"] < -99 @@ -1216,7 +1200,7 @@ errfix <- function(data2, err, quiet) { if (length(grep("FAIL", err$obsOuteq$msg)) > 0) { report <- c(report, paste("Observation records (evid=0) must have OUTEQ. See errors.xlsx and fix manually.")) } - + # Insert dummy doses of 0 for those missing time=0 first events if (length(grep("FAIL", err$T0$msg)) > 0) { T0 <- data2[err$T0$results, ] @@ -1232,20 +1216,20 @@ errfix <- function(data2, err, quiet) { report <- c(report, paste("Subjects with first time > 0 have had a dummy dose of 0 inserted at time 0.")) err <- errcheck(data2 = data2, quiet = T) } - + # Alert for missing covariate data if (length(grep("FAIL", err$covT0$msg)) > 0) { report <- c(report, paste("All covariates must have values for each subject's first event. See errors.xlsx and fix manually.")) } - + # Reorder times - assume times are in correct block if (length(grep("FAIL", err$timeOrder$msg)) > 0) { - data2 <- makePMmatrixBlock(data2) |> - dplyr::group_by(id, block) |> - dplyr::arrange(time, .by_group = T) |> - ungroup() |> - select(-block) - + data2 <- makePMmatrixBlock(data2) %>% + dplyr::group_by(id, block) %>% + dplyr::arrange(time, .by_group = T) %>% + ungroup() %>% + select(-block) + if (any(data2$evid == 4)) { report <- c(report, paste("Your dataset has EVID=4 events. Times ordered within each event block.")) } else { @@ -1266,37 +1250,37 @@ errfix <- function(data2, err, quiet) { data2$evid[err$missEVID$results] <- ifelse(is.na(data2$dose[err$missEVID$results]), 0, 1) report <- c(report, paste("EVID for events with doses changed to 1, otherwise 0.")) } - + # Fix doses and observations separated if (length(grep("FAIL", err$doseOut$msg)) > 0) { report <- c(report, paste("Rows with both dose and observation values must be fixed manually. See errors.xlsx.")) } - + # Fix malformed NA if (length(grep("FAIL", err$mal_NA$msg)) > 0) { # convert to "." then NA - data2 <- data2 |> - mutate(across(everything(), ~ str_replace_all(.x, "(? - mutate(across(everything(), ~ dplyr::na_if(.x, "."))) + data2 <- data2 %>% + mutate(across(everything(), ~ str_replace_all(.x, "(?% + mutate(across(everything(), ~ dplyr::na_if(.x, "."))) report <- c(report, paste("Malformed NAs corrected.")) } - - + + # Report missing TIME if (length(grep("FAIL", err$missTIME$msg)) > 0) { report <- c(report, paste("Your dataset has missing times. See errors.xlsx and fix manually.")) } - + # Report non-numeric columns if (length(grep("FAIL", err$nonNum$msg)) > 0) { report <- c(report, paste("Your dataset has non-numeric columns. See errors.xlsx and fix manually.")) } - + # Report subjects with no observations if (length(grep("FAIL", err$noObs$msg)) > 0) { report <- c(report, paste("Your dataset has subjects with no observations. See errors.xlsx and fix manually.")) } - + if (!quiet) { cli::cli_h1("FIX DATA REPORT:") report <- report[-1] @@ -1328,188 +1312,187 @@ writeErrorFile <- function(dat, err, legacy, wb, sheet) { "Non-numeric entry", "Subject with no observations", "Malformed NA value", - "Rows with both dose and observation values" - ), - stringsAsFactors = F - ) - numError <- nrow(errorsTable) - errorsTable$code <- 1:numError - - # assign errors with row, column, and code - errList <- lapply(err[3:length(err)], function(x) (lapply(x$results, function(y) c(y, x$col, x$code)))) - errDF <- data.frame(t(data.frame(errList))) - row.names(errDF) <- 1:nrow(errDF) - names(errDF) <- c("row", "column", "code") - errors <- errDF[!is.na(errDF$row), ] - formattedCols <- names(dat) - - if (legacy) { - pmVersion <- "POPDATA DEC_11" - formattedCols <- toupper(formattedCols) - formattedCols[1] <- "#ID" - legacy_offset <- 1 - } else { - legacy_offset <- 0 - } - - # set colors for errors - errColor <- "#FFFF00" # yellow, column specific - errColor2 <- "#00FF00" # green, across columns - errColor3 <- "#00AAFF" # blue, NA - errColor4 <- "#FFAA00" # orange, summary - - # create styles for error formatting - errStyle1 <- openxlsx::createStyle(fgFill = errColor) - errStyle2 <- openxlsx::createStyle(fgFill = errColor2) - errStyle3 <- openxlsx::createStyle(fgFill = errColor3) - errStyle4 <- openxlsx::createStyle(fgFill = errColor4) - - - # function to detect things that can't be coerced to numbers - is.char.num <- function(x) { - if (!is.na(x) && suppressWarnings(is.na(as.numeric(x)))) { - return(T) + "Rows with both dose and observation values"), + stringsAsFactors = F + ) + numError <- nrow(errorsTable) + errorsTable$code <- 1:numError + + # assign errors with row, column, and code + errList <- lapply(err[3:length(err)], function(x) (lapply(x$results, function(y) c(y, x$col, x$code)))) + errDF <- data.frame(t(data.frame(errList))) + row.names(errDF) <- 1:nrow(errDF) + names(errDF) <- c("row", "column", "code") + errors <- errDF[!is.na(errDF$row), ] + formattedCols <- names(dat) + + if (legacy) { + pmVersion <- "POPDATA DEC_11" + formattedCols <- toupper(formattedCols) + formattedCols[1] <- "#ID" + legacy_offset <- 1 } else { - return(F) + legacy_offset <- 0 } - } - - # make second table to summarize errors - error_summary <- errors |> filter(!code %in% c(10, 13, 15)) # we will add these back - - # Highlight the cells with errors - for (i in 1:nrow(errors)) { - thisErr <- errors[i, ] - colIndex <- thisErr$column - rowIndex <- thisErr$row - # special highlighting - overwrite some values - if (thisErr$code == 10) { - # if covariate error - covData <- getCov(dat) - colIndex <- covData$covstart + + + # set colors for errors + errColor <- "#FFFF00" # yellow, column specific + errColor2 <- "#00FF00" # green, across columns + errColor3 <- "#00AAFF" # blue, NA + errColor4 <- "#FFAA00" # orange, summary + + # create styles for error formatting + errStyle1 <- openxlsx::createStyle(fgFill = errColor) + errStyle2 <- openxlsx::createStyle(fgFill = errColor2) + errStyle3 <- openxlsx::createStyle(fgFill = errColor3) + errStyle4 <- openxlsx::createStyle(fgFill = errColor4) + + + # function to detect things that can't be coerced to numbers + is.char.num <- function(x) { + if (!is.na(x) && suppressWarnings(is.na(as.numeric(x)))) { + return(T) + } else { + return(F) + } + } + + # make second table to summarize errors + error_summary <- errors %>% filter(!code %in% c(10, 13, 15)) # we will add these back + + # Highlight the cells with errors + for (i in 1:nrow(errors)) { + thisErr <- errors[i, ] + colIndex <- thisErr$column + rowIndex <- thisErr$row + # special highlighting - overwrite some values + if (thisErr$code == 10) { + # if covariate error + covData <- getCov(dat) + colIndex <- covData$covstart + which(is.na(dat[rowIndex, covData$covstart:covData$covend])) - 1 - rowIndex <- rowIndex + 1 + legacy_offset - error_summary <- dplyr::bind_rows( - error_summary, - data.frame( - row = rep(rowIndex, length(colIndex)), - column = colIndex, - code = 10 + rowIndex <- rowIndex + 1 + legacy_offset + error_summary <- dplyr::bind_rows( + error_summary, + data.frame( + row = rep(rowIndex, length(colIndex)), + column = colIndex, + code = 10 + ) ) - ) - openxlsx::addStyle(wb, sheet, errStyle2, rows = rowIndex, cols = colIndex) - purrr::walk2(colIndex, rowIndex, ~ openxlsx::removeComment(wb, sheet, col = .x, row = .y)) # Excel throws a fit if two comments written - purrr::walk2(colIndex, rowIndex, ~ openxlsx::writeComment(wb, sheet, - col = .x, row = .y, - comment = openxlsx::createComment(errorsTable$comment[10], author = "Pmetrics", visible = F) - )) - } else if (thisErr$code == 12) { - # special for non-numeric columns - colIndex <- thisErr$row # because of the way the error is detected - # find the non-numeric cells in a column - rowIndex2 <- which(sapply(dplyr::pull(dat, colIndex), is.char.num)) + 1 + legacy_offset - # find the malformed NAs as a special case and remove them (separate error below) - # because openxlsx can't overwrite comments - mal_NA <- stringr::str_count(dplyr::pull(dat, colIndex), "(? - map(~ which(.x == 1)) |> - purrr::map_vec(~ length(.x) > 0) |> + openxlsx::addStyle(wb, sheet, errStyle2, rows = rowIndex, cols = colIndex) + purrr::walk2(colIndex, rowIndex, ~ openxlsx::removeComment(wb, sheet, col = .x, row = .y)) # Excel throws a fit if two comments written + purrr::walk2(colIndex, rowIndex, ~ openxlsx::writeComment(wb, sheet, + col = .x, row = .y, + comment = openxlsx::createComment(errorsTable$comment[10], author = "Pmetrics", visible = F) + )) + } else if (thisErr$code == 12) { + # special for non-numeric columns + colIndex <- thisErr$row # because of the way the error is detected + # find the non-numeric cells in a column + rowIndex2 <- which(sapply(dplyr::pull(dat, colIndex), is.char.num)) + 1 + legacy_offset + # find the malformed NAs as a special case and remove them (separate error below) + # because openxlsx can't overwrite comments + mal_NA <- stringr::str_count(dplyr::pull(dat, colIndex), "(?% + map(~ which(.x == 1)) %>% + purrr::map_vec(~ length(.x) > 0) %>% + which() + 1 + legacy_offset + # remove any mal_NA from non-numeric + rowIndex2 <- rowIndex2[!rowIndex2 %in% mal_NA] + # highlight them if any left + if (length(rowIndex2) > 0) { + openxlsx::addStyle(wb, sheet, errStyle2, rows = rowIndex2, cols = colIndex) + purrr::walk2(colIndex, rowIndex2, ~ openxlsx::removeComment(wb, sheet, col = .x, row = .y)) # Excel throws a fit if two comments written + purrr::walk2(colIndex, rowIndex2, ~ openxlsx::writeComment(wb, sheet, + col = .x, row = .y, + comment = openxlsx::createComment(errorsTable$comment[13], author = "Pmetrics", visible = F) + )) + error_summary <- dplyr::bind_rows( + error_summary, + data.frame( + row = rowIndex2, + column = rep(colIndex, length(rowIndex2)), + code = 13 + ) + ) + } + } else if (thisErr$code == 14) { + # malformed NA + colIndex <- thisErr$row # because of the way the error is detected + rowIndex3 <- stringr::str_count(dplyr::pull(dat, colIndex), "(?% + map(~ which(.x == 1)) %>% + purrr::map_vec(~ length(.x) > 0) %>% which() + 1 + legacy_offset - # remove any mal_NA from non-numeric - rowIndex2 <- rowIndex2[!rowIndex2 %in% mal_NA] - # highlight them if any left - if (length(rowIndex2) > 0) { - openxlsx::addStyle(wb, sheet, errStyle2, rows = rowIndex2, cols = colIndex) - purrr::walk2(colIndex, rowIndex2, ~ openxlsx::removeComment(wb, sheet, col = .x, row = .y)) # Excel throws a fit if two comments written - purrr::walk2(colIndex, rowIndex2, ~ openxlsx::writeComment(wb, sheet, + # highlight them + openxlsx::addStyle(wb, sheet, errStyle3, rows = rowIndex3, cols = colIndex) + purrr::walk2(colIndex, rowIndex3, ~ openxlsx::writeComment(wb, sheet, col = .x, row = .y, - comment = openxlsx::createComment(errorsTable$comment[13], author = "Pmetrics", visible = F) + comment = openxlsx::createComment(errorsTable$comment[15], author = "Pmetrics", visible = F) )) error_summary <- dplyr::bind_rows( error_summary, data.frame( - row = rowIndex2, - column = rep(colIndex, length(rowIndex2)), - code = 13 + row = rowIndex3, + column = rep(colIndex, length(rowIndex3)), + code = 15 ) ) + } else { + # add the highlighting and comments for other errors + rowIndex <- rowIndex + 1 + legacy_offset + comment <- openxlsx::createComment(errorsTable$comment[thisErr$code], author = "Pmetrics", visible = F) + openxlsx::addStyle(wb, sheet, errStyle1, rowIndex, colIndex) + openxlsx::writeComment(wb, sheet, xy = c(colIndex, rowIndex), comment = comment) } - } else if (thisErr$code == 14) { - # malformed NA - colIndex <- thisErr$row # because of the way the error is detected - rowIndex3 <- stringr::str_count(dplyr::pull(dat, colIndex), "(? - map(~ which(.x == 1)) |> - purrr::map_vec(~ length(.x) > 0) |> - which() + 1 + legacy_offset - # highlight them - openxlsx::addStyle(wb, sheet, errStyle3, rows = rowIndex3, cols = colIndex) - purrr::walk2(colIndex, rowIndex3, ~ openxlsx::writeComment(wb, sheet, - col = .x, row = .y, - comment = openxlsx::createComment(errorsTable$comment[15], author = "Pmetrics", visible = F) - )) - error_summary <- dplyr::bind_rows( - error_summary, - data.frame( - row = rowIndex3, - column = rep(colIndex, length(rowIndex3)), - code = 15 - ) - ) - } else { - # add the highlighting and comments for other errors - rowIndex <- rowIndex + 1 + legacy_offset - comment <- openxlsx::createComment(errorsTable$comment[thisErr$code], author = "Pmetrics", visible = F) - openxlsx::addStyle(wb, sheet, errStyle1, rowIndex, colIndex) - openxlsx::writeComment(wb, sheet, xy = c(colIndex, rowIndex), comment = comment) - } - } # end errors for loop - - # Add summaries to each column with errors - sum_errors <- dplyr::as_tibble(table(error_summary$column, error_summary$code, dnn = c("column", "code"))) |> - group_by(column) |> + } # end errors for loop + + # Add summaries to each column with errors + sum_errors <- dplyr::as_tibble(table(error_summary$column, error_summary$code, dnn = c("column", "code"))) %>% + group_by(column) %>% summarize(n_err = sum(n)) - - openxlsx::addStyle(wb, sheet, errStyle4, rows = 1 + legacy_offset, cols = as.numeric(sum_errors$column)) - comments <- purrr::map(1:nrow(sum_errors), ~ openxlsx::createComment(paste( - sum_errors$n_err[.x], - ifelse(sum_errors$n_err[.x] > 1, "errors", "error") - ), author = "Pmetrics", visible = F)) - purrr::walk(1:nrow(sum_errors), ~ openxlsx::writeComment(wb, sheet, col = as.numeric(sum_errors$column[.x]), row = 1 + legacy_offset, comment = comments[[.x]])) - - # Writing out the header of the Pmetrics data file : version line.... - if (legacy) { - openxlsx::writeData(wb, sheet, pmVersion, xy = c(1, 1)) - } # POPDATA... - - # ...and data frame column names - openxlsx::writeData(wb, sheet, t(formattedCols), xy = c(1, 1 + legacy_offset), colNames = F) - - # Add the data - openxlsx::writeData(wb, sheet, dat, - rowNames = F, colNames = F, xy = c(1, 2 + legacy_offset), - keepNA = T, na.string = "." - ) - - return(wb) -} - -createInstructions <- function(wb) { - # set colors for errors - errColor <- "#FFFF00" # yellow, column header - errColor2 <- "#00FF00" # green, cell - errColor3 <- "#00AAFF" # blue, NA - errColor4 <- "#FFAA00" # orange, summary - - # create styles for error formatting - errStyle1 <- openxlsx::createStyle(fgFill = errColor) - errStyle2 <- openxlsx::createStyle(fgFill = errColor2) - errStyle3 <- openxlsx::createStyle(fgFill = errColor3) - errStyle4 <- openxlsx::createStyle(fgFill = errColor4) - textStyle <- openxlsx::createStyle(fontSize = 16) - - openxlsx::addWorksheet(wb, "Instructions", tabColour = "grey80") - openxlsx::addStyle(wb, "Instructions", textStyle, rows = 1:8, cols = 1) - openxlsx::addStyle(wb, "Instructions", textStyle, rows = 10:13, cols = 2) - openxlsx::writeData(wb, "Instructions", + + openxlsx::addStyle(wb, sheet, errStyle4, rows = 1 + legacy_offset, cols = as.numeric(sum_errors$column)) + comments <- purrr::map(1:nrow(sum_errors), ~ openxlsx::createComment(paste( + sum_errors$n_err[.x], + ifelse(sum_errors$n_err[.x] > 1, "errors", "error") + ), author = "Pmetrics", visible = F)) + purrr::walk(1:nrow(sum_errors), ~ openxlsx::writeComment(wb, sheet, col = as.numeric(sum_errors$column[.x]), row = 1 + legacy_offset, comment = comments[[.x]])) + + # Writing out the header of the Pmetrics data file : version line.... + if (legacy) { + openxlsx::writeData(wb, sheet, pmVersion, xy = c(1, 1)) + } # POPDATA... + + # ...and data frame column names + openxlsx::writeData(wb, sheet, t(formattedCols), xy = c(1, 1 + legacy_offset), colNames = F) + + # Add the data + openxlsx::writeData(wb, sheet, dat, + rowNames = F, colNames = F, xy = c(1, 2 + legacy_offset), + keepNA = T, na.string = "." + ) + + return(wb) + } + + createInstructions <- function(wb) { + # set colors for errors + errColor <- "#FFFF00" # yellow, column header + errColor2 <- "#00FF00" # green, cell + errColor3 <- "#00AAFF" # blue, NA + errColor4 <- "#FFAA00" # orange, summary + + # create styles for error formatting + errStyle1 <- openxlsx::createStyle(fgFill = errColor) + errStyle2 <- openxlsx::createStyle(fgFill = errColor2) + errStyle3 <- openxlsx::createStyle(fgFill = errColor3) + errStyle4 <- openxlsx::createStyle(fgFill = errColor4) + textStyle <- openxlsx::createStyle(fontSize = 16) + + openxlsx::addWorksheet(wb, "Instructions", tabColour = "grey80") + openxlsx::addStyle(wb, "Instructions", textStyle, rows = 1:8, cols = 1) + openxlsx::addStyle(wb, "Instructions", textStyle, rows = 10:13, cols = 2) + openxlsx::writeData(wb, "Instructions", c( "'Errors' tab contains your data which has been standardized if read using PM_data$new().", "Cells with errors are color coded according to table below.", @@ -1522,25 +1505,26 @@ createInstructions <- function(wb) { ), startCol = 1, startRow = 1 ) - + openxlsx::addStyle(wb, "Instructions", errStyle1, rows = 10, cols = 1) openxlsx::addStyle(wb, "Instructions", errStyle2, rows = 11, cols = 1) openxlsx::addStyle(wb, "Instructions", errStyle3, rows = 12, cols = 1) openxlsx::addStyle(wb, "Instructions", errStyle4, rows = 13, cols = 1) - + openxlsx::writeData(wb, "Instructions", - c( - "Errors specific to a particular column", - "Errors not specific to a defined column, i.e. non-numeric entries or missing covariates at time 0.", - "Malformed NA values, which should only be '.'", - "Used for column headers to report the total number of errors in that column." - ), - startCol = 2, startRow = 10 - ) - return(wb) + c( + "Errors specific to a particular column", + "Errors not specific to a defined column, i.e. non-numeric entries or missing covariates at time 0.", + "Malformed NA values, which should only be '.'", + "Used for column headers to report the total number of errors in that column." + ), + startCol = 2, startRow = 10 +) +return(wb) } + # PLOT -------------------------------------------------------------------- #' @title Plot PM_data Time-Output Data @@ -1567,11 +1551,9 @@ createInstructions <- function(wb) { #' * `join` Can either be a boolean or a list. If set to `TRUE` or #' a list of plotly line attributes, it #' will generate line segments joining observations. If set to -#' `FALSE`, no segments will be generated. -#' -#' **Note:**The color of the joining line +#' `FALSE`, no segments will be generated. The color of the joining line #' is the same as the marker color for that line. To avoid confusion, the line -#' color cannot be changed. Change the `marker` color instead. The default +#' color cannot be changed. The default #' values for the other elements of the `join` list, both of which can be #' overriden are: #' - `width `Width of the segments, default 1. @@ -1583,8 +1565,8 @@ createInstructions <- function(wb) { #' * If plotting data contained in a [PM_result], use "pop" or "post" to include population or posterior predictions. #' ** Example 1: `run1 <- PM_load(1); run1$data$plot(line = list(pred = "post"))` #' * If plotting data not contained in a [PM_result], you may add the -#' name of a population [PM_pop] or posterior [PM_post] prediction object in a [PM_result] object. -#' This might be useful if you want to see how the predictions from one population match +#' name of a population [PM_pop] or posterior [PM_post] prediction object in a [PM_result] object. +#' This might be useful if you want to see how the predictions from one population match #' the raw data from another. #' ** Example 2: `dat <- PM_data$new("new.csv"); dat$plot(line = list(pred = run1$post))`. #' @@ -1614,7 +1596,7 @@ createInstructions <- function(wb) { #' @param group_names A character vector of names to label the **groups** if `legend = TRUE`. #' This vector must be the same length as the number of groups within `group`. If missing, #' the vector will be generated from the unique values in `group`. -#' Example: `c("Male", "Female")` if `group = "gender"` and "gender" is a covariate +#' Example: `c("Male", "Female")` if `color = "gender"` and "gender" is a covariate #' in the data. #' @param mult `r template("mult")` #' @param outeq `r template("outeq")` Default is 1, but can be multiple if present in the data, e.g. `1:2` or `c(1, 3)`. @@ -1687,864 +1669,749 @@ plot.PM_data <- function( ylab = "Output", title = "", xlim, ylim, - print = TRUE, ... -) { - # Plot parameters --------------------------------------------------------- - - if (is.list(marker) && !is.null(marker$shape) && is.null(marker$symbol)) { - marker$symbol <- marker$shape - marker$shape <- NULL - } - - # capture user-supplied overrides before defaults are filled in by amendMarker - user_color <- if (is.list(marker) && !is.null(marker$color)) marker$color else NULL - user_symbol <- if (is.list(marker) && !is.null(marker$symbol)) marker$symbol else NULL - - # process marker - marker <- amendMarker(marker) - - if (!is.null(marker$color)) { - marker$color <- as.character(marker$color) - has_hex <- stringr::str_detect(marker$color, "#") - if (any(has_hex, na.rm = TRUE)) { - alpha_val <- if (is.null(marker$opacity)) 1 else marker$opacity[[1]] - marker$color[has_hex] <- vapply( - marker$color[has_hex], - rgba_to_rgb, - FUN.VALUE = character(1), - alpha = alpha_val - ) + print = TRUE, ...) { + # Plot parameters --------------------------------------------------------- + + # process marker + marker <- amendMarker(marker) + if (stringr::str_detect(marker$color, "#")){ # color is hex + marker$color <- map_chr(marker$color, \(x) substr(x, 1, 7)) # remove alpha if present, controlled by opacity } - } - - # if (stringr::str_detect(marker$color, "#")){ # color is hex - # marker$color <- map_chr(marker$color, \(x) substr(x, 1, 7)) # remove alpha if present, controlled by opacity - # } - - - highlight_base_color <- marker$color[[1]] - if (length(marker$color) == 1 && requireNamespace("RColorBrewer", quietly = TRUE) && - marker$color[[1]] %in% rownames(RColorBrewer::brewer.pal.info)) { - max_c <- RColorBrewer::brewer.pal.info[marker$color[[1]], "maxcolors"] - highlight_base_color <- RColorBrewer::brewer.pal(max_c, marker$color[[1]])[[1]] - } - - highlight_color <- tryCatch( - opposite_color(highlight_base_color), - error = function(e) opposite_color("dodgerblue") - ) # in plotly_Utils.R - - - # process line - if (any(!base::names(line) %in% c("join", "pred"))) { - cli::cli_warn(c("!" = "{.code line} should be a list with at most two named elements: {.code join}, {.code loess}, and/or {.code pred}.", "i" = "See {.fn Pmetrics::plot.PM_data}.")) - } - if (is.null(line$join)) { - line$join <- FALSE - } - if (is.null(line$pred)) { - line$pred <- FALSE - } - - join_color_specified <- is.list(line$join) && "color" %in% names(line$join) - pred_color_specified <- is.list(line$pred) && "color" %in% names(line$pred) - - join <- amendLine(line$join) - if (join_color_specified) { - cli::cli_warn(c( - "!" = "Join line colors are fixed to match the group marker colors.", - "i" = "Use {.code marker$color} to control PM_data group colors. BLOQ/ALOQ symbols are shown in the opposite color only for the markers." - )) - } - if (is.logical(line$pred) && !line$pred) { # if line$pred is FALSE - line$pred <- NULL - } - pred <- line$pred # process further later - - # get the rest of the dots - layout <- amendDots(list(...)) - - # legend - if (missing(legend)) { - if (is.null(group)) { - legend <- FALSE + highlight_color <- opposite_color(marker$color[1]) # in plotly_Utils.R + + + # process line + if (any(!base::names(line) %in% c("join", "pred"))) { + cli::cli_warn(c("!" = "{.code line} should be a list with at most two named elements: {.code join}, {.code loess}, and/or {.code pred}.", "i" = "See {.fn Pmetrics::plot.PM_data}.")) + } + if (is.null(line$join)) { + line$join <- FALSE + } + if (is.null(line$pred)) { + line$pred <- FALSE + } + + join <- amendLine(line$join) + if (is.logical(line$pred) && !line$pred) { # if line$pred is FALSE + line$pred <- NULL + } + pred <- line$pred # process further later + + + # get the rest of the dots + layout <- amendDots(list(...)) + + # legend + if (missing(legend)) { + if (is.null(group)) { + legend <- FALSE + } else { + legend <- TRUE + } + } + + legendList <- amendLegend(legend) + layout <- modifyList(layout, list(showlegend = legendList$showlegend)) + if (length(legendList) > 1) { + layout <- modifyList(layout, list(legend = within(legendList, rm(showlegend)))) + } + + + # grid + layout$xaxis <- setGrid(layout$xaxis, grid) + layout$yaxis <- setGrid(layout$yaxis, grid) + + # axis labels if needed + layout$xaxis$title <- amendTitle(xlab) + if (is.character(ylab)) { + layout$yaxis$title <- amendTitle(ylab, layout$xaxis$title$font) } else { - legend <- TRUE + layout$yaxis$title <- amendTitle(ylab) } - } - - legendList <- amendLegend(legend) - layout <- modifyList(layout, list(showlegend = legendList$showlegend)) - if (length(legendList) > 1) { - layout <- modifyList(layout, list(legend = within(legendList, rm(showlegend)))) - } - - - # grid - layout$xaxis <- setGrid(layout$xaxis, grid) - layout$yaxis <- setGrid(layout$yaxis, grid) - - # axis labels if needed - layout$xaxis$title <- amendTitle(xlab) - if (is.character(ylab)) { - layout$yaxis$title <- amendTitle(ylab, layout$xaxis$title$font) - } else { - layout$yaxis$title <- amendTitle(ylab) - } - - - # axis ranges - if (!missing(xlim)) { - layout$xaxis <- modifyList(layout$xaxis, list(range = xlim)) - } - if (!missing(ylim)) { - layout$yaxis <- modifyList(layout$yaxis, list(range = ylim)) - } - - # log y axis - if (log) { - layout$yaxis <- modifyList(layout$yaxis, list(type = "log")) - } - - # title - layout$title <- amendTitle(title, default = list(size = 20)) - - # overlay - if (is.logical(overlay)) { # T/F - if (!overlay) { # F,default - nrows <- 1 - ncols <- 1 - } # if T, no need to set nrows or ncols - } else { # specified as c(rows, cols) - nrows <- overlay[1] - ncols <- overlay[2] - overlay <- FALSE - } - - # Data processing --------------------------------------------------------- - dat <- x$clone() # make copy of x to work with - - # make blocks - dat$standard_data <- makePMmatrixBlock(dat$standard_data) - - # time after dose - if (tad) { - dat$standard_data$time <- calcTAD(dat$standard_data) - dat$standard_data <- dat$standard_data |> arrange(id, time) - } - - # filter - presub <- dat$standard_data |> - filter(outeq %in% !!outeq, block %in% !!block, evid == 0) |> + + + # axis ranges + if (!missing(xlim)) { + layout$xaxis <- modifyList(layout$xaxis, list(range = xlim)) + } + if (!missing(ylim)) { + layout$yaxis <- modifyList(layout$yaxis, list(range = ylim)) + } + + # log y axis + if (log) { + layout$yaxis <- modifyList(layout$yaxis, list(type = "log")) + } + + # title + layout$title <- amendTitle(title, default = list(size = 20)) + + # overlay + if (is.logical(overlay)) { # T/F + if (!overlay) { # F,default + nrows <- 1 + ncols <- 1 + } # if T, no need to set nrows or ncols + } else { # specified as c(rows, cols) + nrows <- overlay[1] + ncols <- overlay[2] + overlay <- FALSE + } + + # Data processing --------------------------------------------------------- + dat <- x$clone() #make copy of x to work with + + # make blocks + dat$standard_data <- makePMmatrixBlock(dat$standard_data) + + # time after dose + if (tad) { + dat$standard_data$time <- calcTAD(dat$standard_data) + dat$standard_data <- dat$standard_data %>% arrange(id, time) + } + + # filter + presub <- dat$standard_data %>% + filter(outeq %in% !!outeq, block %in% !!block, evid == 0) %>% includeExclude(include, exclude) - - show_block_label <- dplyr::n_distinct(presub$block) > 1 - - - # ---- covariate group (drives COLOR) ------------------------------------ - if (!is.null(group)) { - if (!group %in% base::names(dat$standard_data)) { - cli::cli_abort(c("x" = "{group} is not a column in the data.")) - } - cov_group_factor <- factor(presub[[group]]) - cov_group_levels <- levels(cov_group_factor) - if (!is.null(group_names)) { - group_names <- stringr::str_trim(as.character(group_names)) - group_names <- group_names[nzchar(group_names)] - if (length(group_names) == 0) { - group_names <- NULL + + + + # make group column for groups + if (!is.null(group)) { + if (!group %in% base::names(dat$standard_data)) { + cli::cli_abort(c("x" = "{group} is not a column in the data.")) } + if (is.null(group_names)) { + presub$group <- presub[[group]] + } else if (length(group_names) < length(unique(presub[[group]]))) { + cli::cli_abort(c("x" = "The number of names in {.var group_names} must be at least as long as the number of unique values in {.var group}.")) + } else { + presub$group <- factor(presub[[group]], labels = group_names) + } + } else { # group was NULL + presub <- presub %>% mutate(group = "") } - if (is.null(group_names)) { - presub$cov_group <- as.character(cov_group_factor) - } else { - n_levels <- length(cov_group_levels) - n_user <- min(length(group_names), n_levels) - merged_group_names <- cov_group_levels - merged_group_names[seq_len(n_user)] <- group_names[seq_len(n_user)] - presub$cov_group <- as.character(factor(presub[[group]], levels = cov_group_levels, labels = merged_group_names)) + + + # make outeq labels if more than one output being plotted + if (length(outeq) > 1) { + if (is.null(out_names)) { + out_names <- paste0("Output ", 1:max(outeq)) + } else if (length(out_names) < max(outeq)) { + cli::cli_abort(c("x" = "The number of names in {.var out_names} must be at least as long as the maximum number of outputs in {.var outeq}.")) + } + # add outeq to group + presub <- presub %>% + rowwise() %>% + mutate(group = paste0(group, ", ", out_names[outeq])) } - } else { - presub$cov_group <- "" - } - - # ---- outeq group (drives SHAPE) ----------------------------------------- - if (length(outeq) > 1) { - if (is.null(out_names)) { - out_names <- paste0("Output ", 1:max(outeq)) - } else if (length(out_names) < max(outeq)) { - cli::cli_abort(c("x" = "The number of names in {.var out_names} must be at least as long as the maximum number of outputs in {.var outeq}.")) - } - presub$outeq_group <- out_names[presub$outeq] - } else { - presub$outeq_group <- "" - } - - # ---- combined display label (legend / hover) ---------------------------- - presub <- presub |> - mutate(group = { - mapply( - function(cv, oq, blk) { - parts <- c(cv, oq, blk) - parts <- parts[nchar(trimws(parts)) > 0] - paste(parts, collapse = ", ") - }, cov_group, outeq_group, - if (show_block_label) paste0("Block ", presub$block) else "" - ) - }) |> - ungroup() - - # add cens column if missing - if (!"cens" %in% names(presub)) { - presub$cens <- "none" - } - - # select relevant columns - sub <- presub |> - select(id, time, out, cens, outeq, group, cov_group, outeq_group) |> - mutate(id = as.character(id)) |> + + # add blocks if more than one being plotted + if (length(block) > 1) { + presub <- presub %>% + rowwise() %>% + mutate(group = paste0(group, ", Block ", block)) + } + + # there will always be an Obs group + presub <- presub %>% + rowwise() %>% + mutate(group = paste0(group, ", Obs ")) + + presub$group <- stringr::str_replace(presub$group, "^\\s*,*\\s*", "") + + # add cens column if missing + if (!"cens" %in% names(presub)) { + presub$cens <- "none" + } + + # select relevant columns + sub <- presub %>% + select(id, time, out, cens, outeq, group) %>% + mutate(id = as.character(id)) %>% ungroup() - sub$group <- factor(sub$group) - - # add identifier - sub$src <- "obs" - - # remove missing - sub <- sub |> filter(out != -99) - - - # now process pred data if there - if (!is.null(pred)) { - if (inherits(pred, c("PM_post", "PM_pop"))) { # only PM_post/pop was supplied, make into a list of 1 - pred <- list(pred$data) - } else if (inherits(pred, c("PM_post_data", "PM_pop_data"))) { # only PM_post_data/PM_pop_data was supplied, make into a list of 1 - pred <- list(pred) - } else if (inherits(pred[[1]], c("PM_post", "PM_pop"))) { # PM_post/pop as first argument of list - pred[[1]] <- pred[[1]]$data - } else if (inherits(pred[[1]], c("PM_post_data", "PM_pop_data"))) { # PM_post_data/PM_pop_data as first argument of list - pred[[1]] <- pred[[1]] # nothing to do, in right format already - } else if (pred[[1]] %in% c("pop", "post")) { # pred[[1]] was "pop" or "post" - thisPred <- pred[[1]] - if (is.null(x[[thisPred]])) { # post/pop missing because x was data did not come from a PM_result + sub$group <- factor(sub$group) + + # add identifier + sub$src <- "obs" + + # remove missing + sub <- sub %>% filter(out != -99) + + + # now process pred data if there + if (!is.null(pred)) { + if (inherits(pred, c("PM_post", "PM_pop"))) { # only PM_post/pop was supplied, make into a list of 1 + pred <- list(pred$data) + } else if (inherits(pred, c("PM_post_data", "PM_pop_data"))) { # only PM_post_data/PM_pop_data was supplied, make into a list of 1 + pred <- list(pred) + } else if (inherits(pred[[1]], c("PM_post", "PM_pop"))) { # PM_post/pop as first argument of list + pred[[1]] <- pred[[1]]$data + } else if (inherits(pred[[1]], c("PM_post_data", "PM_pop_data"))){ # PM_post_data/PM_pop_data as first argument of list + pred[[1]] <- pred[[1]] # nothing to do, in right format already + } else if (pred[[1]] %in% c("pop", "post")) { # pred[[1]] was "pop" or "post" + thisPred <- pred[[1]] + if (is.null(x[[thisPred]])) { # post/pop missing because x was data did not come from a PM_result + cli::cli_warn(c( + "!" = "{.code pred = {thisPred}} can only be used as a shortcut when plotting {.cls PM_data} from a {.cls PM_result}.", + "i" = "Supply a {.cls PM_result} object, e.g. {.code line = list(pred = run2$post)}, if you wish to add predictions otherwise." + )) + pred <- NULL + } else { # post/pop present + if (length(pred) == 1){ # pred is either "pop" or "post" + pred <- list(x[[thisPred]]) + } else { + pred[[1]] <- x[[thisPred]] + } + } + } else { # pred[[1]] was none of the above cli::cli_warn(c( - "!" = "{.code pred = {thisPred}} can only be used as a shortcut when plotting {.cls PM_data} from a {.cls PM_result}.", - "i" = "Supply a {.cls PM_result} object, e.g. {.code line = list(pred = run2$post)}, if you wish to add predictions otherwise." + "!" = "The {.var pred} argument is mis-specified.", + "i" = "See the help for {.code plot.PM_data}." )) pred <- NULL - } else { # post/pop present - if (length(pred) == 1) { # pred is either "pop" or "post" - pred <- list(x[[thisPred]]) - } else { - pred[[1]] <- x[[thisPred]] - } } - } else { # pred[[1]] was none of the above - cli::cli_warn(c( - "!" = "The {.var pred} argument is mis-specified.", - "i" = "See the help for {.code plot.PM_data}." - )) - pred <- NULL - } - - - # process pred list to determine formatting - if (length(pred) == 1) { # default formatting and prediction - predArgs <- TRUE - icen <- "median" - } else { # not default, but need to extract icen if present - icen <- purrr::pluck(pred, "icen") # check if icen is in list - if (is.null(icen)) { # not in list so set default + + + # process pred list to determine formatting + if (length(pred) == 1) { # default formatting and prediction + predArgs <- TRUE icen <- "median" - } else { - purrr::pluck(pred, "icen") <- NULL - } # was in list, so remove after extraction - predArgs <- pred[-1] # get args beyond data to plot for pred - } - - predArgs <- amendLine(predArgs) # color will be set by obs later - if (pred_color_specified) { - cli::cli_warn(c( - "!" = "Prediction line colors are fixed to match the group marker colors.", - "i" = "Use {.code marker$color} to control PM_data group colors. BLOQ/ALOQ opposite colors apply only to markers." - )) - } - - - # filter and group by id - if (!is.null(pred[[1]])) { # if pred not reset to null b/c of invalid pred[[1]] - predsub <- pred[[1]] |> - filter(outeq %in% !!outeq, block %in% !!block, icen == !!icen) |> - mutate(cens = "none") |> # always none for predictions - includeExclude(include, exclude) |> - group_by(id) - - # time after dose - if (tad) { - predsub$time <- calcTAD(predsub) + } else { # not default, but need to extract icen if present + icen <- purrr::pluck(pred, "icen") # check if icen is in list + if (is.null(icen)) { # not in list so set default + icen <- "median" + } else { + purrr::pluck(pred, "icen") <- NULL + } # was in list, so remove after extraction + predArgs <- pred[-1] # get args beyond data to plot for pred } - - # select relevant columns and filter missing - predsub <- predsub |> - select(id, time, out = pred, cens, outeq) |> - mutate(id = as.character(id)) |> + + predArgs <- amendLine(predArgs) # color will be set by obs later + + + + # filter and group by id + if (!is.null(pred[[1]])) { # if pred not reset to null b/c of invalid pred[[1]] + predsub <- pred[[1]] %>% + filter(outeq %in% !!outeq, block %in% !!block, icen == !!icen) %>% + mutate(cens = "none") %>% # always none for predictions + includeExclude(include, exclude) %>% + group_by(id) + + # time after dose + if (tad) { + predsub$time <- calcTAD(predsub) + } + + # select relevant columns and filter missing + predsub <- predsub %>% + select(id, time, out = pred, cens, outeq) %>% + mutate(id = as.character(id)) %>% filter(out != -99 & (cens == "none" | cens == 0)) - - - # add group, cov_group, outeq_group from obs lookup - lookup <- dplyr::distinct(sub, id, outeq, group, cov_group, outeq_group) - predsub <- predsub |> - dplyr::left_join(lookup, by = c("id", "outeq")) |> + + + # add group + lookup <- dplyr::distinct(sub, id, outeq, group) + predsub <- predsub %>% dplyr::left_join(lookup, by = c("id", "outeq")) %>% mutate(group = factor(stringr::str_replace_all(group, "Obs", "Pred"))) - - # add identifier - predsub$src <- "pred" - } else { # pred was reset to NULL b/c of invalid pred[[1]] + + # add identifier + predsub$src <- "pred" + } else { # pred was reset to NULL b/c of invalid pred[[1]] + predsub <- NULL + } + } else { # pred was NULL from beginning predsub <- NULL - } - } else { # pred was NULL from beginning - predsub <- NULL - } # end pred processing - - - # Plot function ---------------------------------------------------------- - - dataPlot <- function(allsub, overlay, includePred) { - # ---- Color palette: driven by combined display groups -------------------- - obs_only <- allsub |> filter(src == "obs") - group_levels <- unique(as.character(obs_only$group)) - if (length(group_levels) == 0) { - group_levels <- "" - } - n_groups <- length(group_levels) - - if (!is.null(user_color)) { - if (length(user_color) == 1 && requireNamespace("RColorBrewer", quietly = TRUE) && - user_color %in% rownames(RColorBrewer::brewer.pal.info)) { - max_c <- RColorBrewer::brewer.pal.info[user_color, "maxcolors"] - color_palette <- colorRampPalette(RColorBrewer::brewer.pal(max_c, user_color))(n_groups) - } else { - color_palette <- rep(as.character(user_color), length.out = n_groups) + } # end pred processing + + + + # Plot function ---------------------------------------------------------- + + dataPlot <- function(allsub, overlay, includePred) { + + group_colors <- marker$color + group_symbols <- marker$symbol + if (!is.null(group) | length(outeq)>1 | length(block)>1) { # there was grouping beyond obs/pred + + n_colors <- length(unique(allsub$group)) + + if (length(group_colors) < n_colors) { # fewer colors than groups, need to interpolate + if (checkRequiredPackages("RColorBrewer")) { + palettes <- RColorBrewer::brewer.pal.info %>% mutate(name = rownames(.)) + if (length(group_colors) == 1) { # only one color specified + if (group_colors %in% palettes$name){# colors specified as a palette name + max_colors <- palettes$maxcolors[match(group_colors, palettes$name)] + group_colors <- colorRampPalette(RColorBrewer::brewer.pal(max_colors, group_colors))(n_colors) + } else { + group_colors <- c(group_colors, getDefaultColors(n_colors)[-1]) # in plotly_Utils, add default colors to specified color + } + } else { # length of group_colors > 1 but fewer than groups, so interpolate + group_colors <- tryCatch(colorRampPalette(group_colors)(n_colors), + error = function(e) { + cli::cli_warn(c("!" = "Unable to interpolate colors, using default colors.")) + getDefaultColors(n_colors) # in plotly_Utils + } + ) + } + } else { + cli::cli_inform(c("i" = "Group colors are better with the {.pkg RColorBrewer} package installed.")) + colors <- getDefaultColors(n_colors) # in plotly_Utils + } } - } else if (n_groups == 1) { - color_palette <- rep(marker$color[[1]], n_groups) - } else if (requireNamespace("RColorBrewer", quietly = TRUE)) { - n_pal <- min(max(n_groups, 3L), 9L) # brewer.pal: min 3, max 9 for Set1 - color_palette <- rep(RColorBrewer::brewer.pal(n_pal, "Set1"), length.out = n_groups) - } else { - color_palette <- getDefaultColors(n_groups) - } - - # ---- Shape list: driven by combined display groups ----------------------- - default_shapes <- c( - "circle", "square", "diamond", "cross", "x", - "pentagon", "hexagon", "star", "hexagram" - ) - if (!is.null(user_symbol)) { - shape_list <- rep(as.character(user_symbol), length.out = n_groups) - } else { - shape_list <- rep(default_shapes, length.out = n_groups) + + if (length(group_symbols) < n_colors) { # fewer symbols than groups, need to interpolate + if (length(group_symbols) == 1) { # only one symbol specified + group_symbols <- rep(group_symbols, n_colors) + } else { # multiple symbols specified, but fewer than groups + group_symbols <- rep(group_symbols, length.out = n_colors) + } + } + + } else { # no grouping other than possibly pred + if (includePred | join$width > 0) { # need colors for both obs and join or pred + group_colors <- rep(group_colors, 2) # observed and predicted should be the same + } } - - # ---- Assign per-row color and symbol ------------------------------------ + + + # assign colors and symbols to each group, editing for censoring IDstring <- ifelse(overlay, "ID: {id}\n", "") - allsub <- allsub |> - mutate( - base_color = color_palette[match(as.character(group), group_levels)], - base_symbol = shape_list[match(as.character(group), group_levels)] - ) |> - mutate( - base_color = dplyr::coalesce(base_color, color_palette[[1]]), - base_symbol = dplyr::coalesce(base_symbol, shape_list[[1]]) - ) |> - mutate( - color = dplyr::case_when( - src == "obs" & (cens == "bloq" | cens == "1") ~ opposite_color(base_color, degrees = 90), - src == "obs" & (cens == "aloq" | cens == "-1") ~ opposite_color(base_color, degrees = 90), - .default = base_color - ), - symbol = dplyr::case_when( - src == "obs" & (cens == "bloq" | cens == "1") ~ "triangle-down", - src == "obs" & (cens == "aloq" | cens == "-1") ~ "triangle-up", - .default = as.character(base_symbol) - ), + allsub <- allsub %>% + #rowwise() %>% + mutate( + color = group_colors[as.integer(group)], + symbol = group_symbols[as.integer(group)] + ) %>% + mutate( + color = dplyr::case_when( + cens == "bloq" | cens == "1" | color == "aloq" | color == "-1" ~ opposite_color(color, degrees = 90), + .default = color + ), + #color = ifelse(cens != "none" & cens != "0", opposite_color(color, degrees = 90), color), + symbol = dplyr::case_when( + cens == "bloq" | cens == "1" ~ "triangle-down", + cens == "none" | cens == "0" ~ as.character(symbol), + cens == "aloq" | cens == "-1" ~ "triangle-up", + .default = symbol), text_label = dplyr::case_when( - cens == "bloq" | cens == "1" ~ glue::glue(IDstring, "Time: {round2(time)}\nBLLQ: {round2(out)}\n{group}"), - cens == "none" | cens == "0" ~ glue::glue(IDstring, "Time: {round2(time)}\nOut: {round2(out)}\n{group}"), - cens == "aloq" | cens == "-1" ~ glue::glue(IDstring, "Time: {round2(time)}\nAULQ: {round2(out)}\n{group}"), - .default = glue::glue(IDstring, "Time: {round2(time)}\nPred: {round2(out)}\n{group}") + cens == "bloq" | cens == "1" ~ glue::glue(IDstring,"Time: {round2(time)}\nBLLQ: {round2(out)}\n{group}"), + cens == "none" | cens == "0" ~ glue::glue(IDstring,"Time: {round2(time)}\nOut: {round2(out)}\n{group}"), + cens == "aloq" | cens == "-1" ~ glue::glue(IDstring,"Time: {round2(time)}\nAULQ: {round2(out)}\n{group}"), + .default = glue::glue(IDstring,"Time: {round2(time)}\nPred: {round2(out)}\n{group}") ) - ) |> + ) %>% ungroup() - - # if ID is numeric, arrange by numeric ID - if (overlay && !any(is.na(suppressWarnings(as.numeric(allsub$id))))) { - allsub <- allsub |> - mutate(id = as.numeric(id)) |> - arrange(id, time) - } - - - seen_groups <- NULL - traces <- if (overlay) { - allsub |> dplyr::group_split(id) - } else { - list(allsub) - } - - # Build plot - p <- plot_ly() - for (i in seq_along(traces)) { - trace_data <- traces[[i]] - this_id <- ifelse(overlay, trace_data$id[1], 1) - - obs_split <- trace_data |> - filter(src == "obs") |> - arrange( - group, - dplyr::case_when( - cens == "none" | cens == "0" ~ 0L, - .default = 1L - ), - time - ) |> - dplyr::group_split(group) - - for (j in seq_along(obs_split)) { - obs_group <- obs_split[[j]] - group_name <- as.character(obs_group$group[1]) - legendShow <- !group_name %in% seen_groups - if (legendShow) { - seen_groups <- c(seen_groups, group_name) + + # if ID is numeric, arrange by numeric ID + if(overlay && !any(is.na(suppressWarnings(as.numeric(allsub$id))))) { + allsub <- allsub %>% + mutate(id = as.numeric(id)) %>% arrange(id, time) + } + + + seen_groups <- NULL + traces <- if(overlay) {allsub %>% dplyr::group_split(id)} else {list(allsub)} + + # Build plot + p <- plot_ly() + for (i in seq_along(traces)) { + trace_data <- traces[[i]] + if (any(!unique(trace_data$group) %in% seen_groups)) { + seen_groups <- c(seen_groups, as.character(unique(trace_data$group))) + legendShow <- TRUE + } else { + legendShow <- FALSE } - + this_id <- ifelse(overlay, trace_data$id[1], 1) + p <- add_trace( p, - data = obs_group, + data = trace_data %>% plotly::filter(src == "obs") %>% arrange(group, time), x = ~time, y = ~ out * mult, type = "scatter", mode = "markers", - name = group_name, + split = ~group, + name = ~group, uid = as.character(this_id), meta = list(id = this_id), - marker = list( - color = I(obs_group$color), - symbol = I(obs_group$symbol), - size = marker$size, - opacity = marker$opacity, - line = list(color = marker$line$color, width = marker$line$width) - ), + marker = list(color = ~I(color), symbol = ~I(symbol), size = marker$size, opacity = marker$opacity, + line = list(color = marker$line$color, width = marker$line$width)), text = ~text_label, hoverinfo = "text", - legendgroup = group_name, + legendgroup = ~group, showlegend = legendShow ) - } - - # add joining lines if needed - if (join$width > 0) { - trace_split <- trace_data |> - filter(src == "obs") |> - arrange(group, time) |> - dplyr::group_split(group) - for (j in seq_along(trace_split)) { - this_color <- trace_split[[j]]$base_color[1] - group_name <- as.character(trace_split[[j]]$group[1]) - p <- add_trace( - p, - data = trace_split[[j]], - x = ~time, y = ~ (out * mult), - type = "scatter", mode = "lines", - name = group_name, - uid = as.character(this_id), - meta = list(id = this_id), - line = list(color = this_color, width = join$width, dash = join$dash), - text = ~text_label, - hoverinfo = "text", - legendgroup = group_name, - showlegend = FALSE - ) + + # add joining lines if needed + if (join$width > 0){ + trace_split <- trace_data %>% filter(src == "obs") %>% dplyr::group_split(color) + for(j in seq_along(trace_split)){ + this_color <- trace_split[[j]]$color[1] + p <- add_trace( + p, + data = trace_split[[j]], + x = ~time, y = ~(out * mult), + type = "scatter", mode = "lines", + name = ~group, + uid = as.character(this_id), + meta = list(id = this_id), + line = list(color = this_color, width = join$width, dash = join$dash), + text = ~text_label, + hoverinfo = "text", + legendgroup = ~group, + showlegend = FALSE + ) + } } - } - - if (includePred) { - trace_split <- trace_data |> - filter(src == "pred") |> - arrange(group, time) |> - dplyr::group_split(group) - for (j in seq_along(trace_split)) { - this_color <- trace_split[[j]]$base_color[1] - group_name <- as.character(trace_split[[j]]$group[1]) - legendShow <- !group_name %in% seen_groups - if (legendShow) { - seen_groups <- c(seen_groups, group_name) + + if (includePred) { + trace_split <- trace_data %>% filter(src == "pred") %>% dplyr::group_split(color) + for(j in seq_along(trace_split)){ + this_color <- trace_split[[j]]$color[1] + p <- add_trace( + p, + data = trace_split[[j]], + x = ~time, y = ~(out * mult), + type = "scatter", mode = "lines", + name = ~group, + uid = as.character(this_id), + meta = list(id = this_id), + line = list(color = this_color, width = predArgs$width, dash = predArgs$dash), + text = ~text_label, + hoverinfo = "text", + legendgroup = ~group, + showlegend = legendShow + ) } - p <- add_trace( - p, - data = trace_split[[j]], - x = ~time, y = ~ (out * mult), - type = "scatter", mode = "lines", - name = group_name, - uid = as.character(this_id), - meta = list(id = this_id), - line = list(color = this_color, width = predArgs$width, dash = predArgs$dash), - text = ~text_label, - hoverinfo = "text", - legendgroup = group_name, - showlegend = legendShow - ) } } + + p <- p %>% plotly::layout( + xaxis = layout$xaxis, + yaxis = layout$yaxis, + title = layout$title, + showlegend = layout$showlegend, + legend = layout$legend + ) + return(invisible(p)) + } # end dataPlot + + + # Call plot --------------------------------------------------------------- + + + # if pred present, need to combine data and pred for proper display + + if (!is.null(predsub)) { + allsub <- dplyr::bind_rows(sub, predsub) %>% dplyr::arrange(id, time) + includePred <- TRUE + } else { + allsub <- sub + includePred <- FALSE } - - p <- p |> plotly::layout( - xaxis = layout$xaxis, - yaxis = layout$yaxis, - title = layout$title, - showlegend = layout$showlegend, - legend = layout$legend - ) - return(invisible(p)) - } # end dataPlot - - - # Call plot --------------------------------------------------------------- - - - # if pred present, need to combine data and pred for proper display - - if (!is.null(predsub)) { - allsub <- dplyr::bind_rows(sub, predsub) |> dplyr::arrange(id, time) - includePred <- TRUE - } else { - allsub <- sub - includePred <- FALSE - } - - - # call the plot function and display appropriately - if (overlay) { - allsub <- allsub |> dplyr::group_by(id) - p <- dataPlot(allsub, overlay = TRUE, includePred) - - if (print) print(click_plot(p, highlight_color = highlight_color)) - return(invisible(p)) - } else { # overlay = FALSE, ie. split them - - if (!requireNamespace("trelliscopejs", quietly = TRUE)) { - cli::cli_abort(c("x" = "Package {.pkg trelliscopejs} required to plot when {.code overlay = FALSE}.")) - } - - sub_split <- allsub |> - nest(data = -id) |> + + + # call the plot function and display appropriately + if (overlay) { + allsub <- allsub %>% dplyr::group_by(id) + p <- dataPlot(allsub, overlay = TRUE, includePred) + + if (print) print(click_plot(p, highlight_color = highlight_color)) + return(invisible(p)) + } else { # overlay = FALSE, ie. split them + + if (!checkRequiredPackages("trelliscopejs")) { + cli::cli_abort(c("x" = "Package {.pkg trelliscopejs} required to plot when {.code overlay = FALSE}.")) + } + + sub_split <- allsub %>% + nest(data = -id) %>% mutate(panel = trelliscopejs::map_plot(data, \(x) dataPlot(x, overlay = FALSE, includePred = includePred))) - p <- sub_split |> - ungroup() |> + p <- sub_split %>% + ungroup() %>% trelliscopejs::trelliscope(name = "Data", nrow = nrows, ncol = ncols) - if (print) print(p) - } - - return(invisible(p)) -} - -#' @title Plot method for PM_data data frames -#' @description -#' `r lifecycle::badge("stable")` -#' Allows plotting of altered [PM_data] objects. -#' @details -#' This is useful if you want to modify the data in a [PM_data] object, e.g. to filter the data, but still want to use the plotting capabilities of [plot.PM_data]. -#' See [plot.PM_data] for details on how to format the plot. -#' @method plot PM_data_data -#' @param x A data frame in the format of the `standard_data` field of a [PM_data] object -#' @param ... Additional arguments passed to [plot.PM_data] -#' @return A plot of the data. -#' @author Michael Neely -#' @seealso [PM_data], [plot.PM_data] -#' @export -#' @examples -#' \dontrun{ -#' # filter then plot the standard_data data frame from a PM_data object -#' dataEx$standard_data |> -#' filter(gender == 0) |> -#' plot() -#' } -#' -plot.PM_data_data <- function(x, ...) { - dat_new <- PM_data$new(x, quiet = TRUE) - plot.PM_data(dat_new, ...) -} - -# SUMMARY ----------------------------------------------------------------- - -#' @title Summarize PM_data objects -#' @description -#' `r lifecycle::badge("stable")` -#' -#' Summarize the raw data used for a Pmetrics run. -#' -#' @method summary PM_data -#' @param object A [PM_data] object. -#' @param formula Optional formula for specifying custom summaries. See [aggregate] -#' and [formula] for details on how to specify formulae in R. If, for example, the data contain -#' a covariate for weight named 'wt', then to summarize the mean dose in mg/kg per subject specify -#' `formula = dose/wt ~ id` and `FUN = mean`. -#' @param FUN The summary function to apply to [formula], if specified. This is not -#' quoted, and usual choices will be [mean], [median], [max], or [min]. -#' @param include A vector of subject IDs to include in the summary, e.g. `c(1:3,5,15)` -#' @param exclude A vector of subject IDs to exclude in the summary, e.g. `c(4,6:14,16:20)` -#' @param ... Additional arguments to `FUN`, e.g. `na.rm = TRUE` -#' @return A list of class *summary.PM_data* with the following items: -#' * **nsub** Number of subjects -#' * **ndrug** Number of drug inputs -#' * **numeqt** Number of outputs -#' * **nobsXouteq** Number of observations by outeq -#' * **missObsXouteq** Number of missing observations by outeq -#' * **loqObsXouteq** Number of observations coded as below the limit of quantification by outeq -#' * **ncov** Number of covariates -#' * **covnames** Covariate names -#' * **ndoseXid** Number of doses per input per subject -#' * **nobsXid** Number of observations per outeq per subject -#' * **doseXid** Doses per input per subject -#' * **obsXid** Observations per outeq per subject -#' * **formula** Results of including [formula] -#' @author Michael Neely -#' @seealso [aggregate] -#' @export - -summary.PM_data <- function(object, formula, FUN, include, exclude, ...) { - if (inherits(object, "PM_data")) { - object <- object$standard_data - } - - # filter data if needed - if (!missing(include)) { - object <- subset(object, sub("[[:space:]]+", "", as.character(object$id)) %in% as.character(include)) - } - if (!missing(exclude)) { - object <- subset(object, !sub("[[:space:]]+", "", as.character(object$id)) %in% as.character(exclude)) - } - - # make results list - results <- list() - idOrder <- rank(unique(object$id)) - - results$nsub <- length(unique(object$id)) - results$ndrug <- max(object$input, na.rm = T) - results$numeqt <- max(object$outeq, na.rm = T) - results$nobsXouteq <- tapply(object$evid, object$outeq, function(x) length(x == 0)) - results$missObsXouteq <- by(object, object$outeq, function(x) length(x$out[x$evid == 0 & x$out == -99])) - - # censored - - results$bloqObsXouteq <- purrr::map_int(1:max(object$outeq, na.rm = TRUE), \(x) sum(object$cens[object$outeq == x] == "1", object$cens[object$outeq == x] == "bloq", na.rm = TRUE)) - results$aloqObsXouteq <- purrr::map_int(1:max(object$outeq, na.rm = TRUE), \(x) sum(object$cens[object$outeq == x] == "-1", object$cens[object$outeq == x] == "aloq", na.rm = TRUE)) - - covinfo <- getCov(object) - ncov <- covinfo$ncov - results$ncov <- ncov - results$covnames <- covinfo$covnames - results$ndoseXid <- as.matrix(tapply(object$evid, list(object$id, object$input), function(x) length(x != 0))[idOrder, ]) - results$nobsXid <- as.matrix(tapply(object$evid, list(object$id, object$outeq), function(x) length(x == 0))[idOrder, ]) - results$doseXid <- as.matrix(tapply(object$dose, list(object$id, object$input), function(x) x[!is.na(x)])[idOrder, ]) - results$obsXid <- as.matrix(tapply(object$out, list(object$id, object$outeq), function(x) x[!is.na(x)])[idOrder, ]) - if (ncov > 0) { - # get each subject's covariate values - results$cov <- lapply(1:ncov, function(y) { - tapply( - object[[covinfo$covstart + y - 1]], object$id, - function(z) z[!is.na(z)] - )[idOrder] - }) - names(results$cov) <- covinfo$covnames - } - if (!missing(formula)) { - results$formula <- aggregate(formula, object, FUN, ...) - } - - class(results) <- c("summary.PM_data", "list") - return(results) -} # end function -# PRINT SUMMARY ----------------------------------------------------------------- - -#' @title Print Summary of Pmetrics Data -#' @description -#' `r lifecycle::badge("stable")` -#' -#' @details -#' Print the summary of [PM_data] object. -#' -#' Summarize the raw data used for a Pmetrics run. -#' -#' @method print summary.PM_data -#' @param x An object made by [summary.PM_data]. -#' @return A printed object -#' @author Michael Neely -#' @param ... Not used. -#' @seealso [summary.PM_data] -#' @examples -#' \dontrun{ -#' dataEx$summary() -#' } - -#' @export - -print.summary.PM_data <- function(x, ...) { - # order of objects - # nsub - # ndrug - # numeqt - # nobsXouteq - # missObsXouteq - # bloqObsXouteq - # aloqObsXouteq - # ncov - # ndoseXid - # nobsXid - # doseXid - # obsXid - # cov - # formula - - cli::cli_div(theme = list( - span.blue = list(color = navy()) - )) - cli::cli_h1("Data Summary") - - cli::cli_text("Number of subjects: {.blue {x$nsub}}") - cli::cli_text("Number of inputs: {.blue {x$ndrug}}") - cli::cli_text("Number of outputs: {.blue {x$numeqt}}") - if (x$ncov > 0) { - cli::cli_text(" Covariates: {.blue {x$covnames}}") - } - cli::cli_h2("Inputs: Mean (SD), Min to Max") - for (i in 1:x$ndrug) { - if (x$ndrug > 1) { - cli::cli_h3("Input {i}") - } - cli::cli_text("Number of doses per subject: {.blue {sprintf('%.3f', mean(x$ndoseXid[, i], na.rm = T))}} ({.blue {sprintf('%.3f', sd(x$ndoseXid[, i], na.rm = T))}}), {.blue {sprintf('%.3f', min(x$ndoseXid[, i], na.rm = T))}} to {.blue {sprintf('%.3f', max(x$ndoseXid[, i], na.rm = T))}} ") - cli::cli_text("Dose amount per subject: {.blue {sprintf('%.3f', mean(unlist(x$doseXid[, i]), na.rm = T))}} ({.blue {sprintf('%.3f', sd(unlist(x$doseXid[, i]), na.rm = T))}}), {.blue {sprintf('%.3f', min(unlist(x$doseXid[, i]), na.rm = T))}} to {.blue {sprintf('%.3f', max(unlist(x$doseXid[, i]), na.rm = T))}} ") - } - cli::cli_h2("Outputs: Mean (SD), Min to Max") - for (i in 1:x$numeqt) { - if (x$numeqt > 1) { - cli::cli_h3("Output {i}") - } - nobs <- unlist(x$nobsXid[, i]) - mean_nobs <- mean(nobs, na.rm = T) - sd_nobs <- sd(nobs, na.rm = T) - min_nobs <- min(nobs, na.rm = T) - max_nobs <- max(nobs, na.rm = T) - - obs <- unlist(x$obsXid[, i]) - obs <- obs[obs != -99] - mean_obs <- mean(obs, na.rm = T) - sd_obs <- sd(obs, na.rm = T) - min_obs <- min(obs, na.rm = T) - max_obs <- max(obs, na.rm = T) - - if (x$bloqObsXouteq[i] > 0) { - extra_text <- ", and {.blue {x$bloqObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$bloqObsXouteq[i] / x$nobsXouteq[i])}%}) censored as below a lower LOQ" - } else { - extra_text <- "" + if (print) print(p) } - - if (x$aloqObsXouteq[i] > 0) { - extra_text <- paste0(extra_text, ", and {.blue {x$aloqObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$aloqObsXouteq[i] / x$nobsXouteq[i])}%}) censored as above an upper LOQ") + + return(invisible(p)) } - cli::cli_text("Total across all subjects: {.blue {x$nobsXouteq[i]}}, with {.blue {x$missObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$missObsXouteq[i] / x$nobsXouteq[i])}%}) missing", extra_text, ".") - cli::cli_text("Number per subject: {.blue {sprintf('%.3f', mean_nobs)}} ({.blue {sprintf('%.3f', sd_nobs)}}), {.blue {sprintf('%i', min_nobs)}} to {.blue {sprintf('%i', max_nobs)}} ") - cli::cli_text("Value per subject: {.blue {sprintf('%.3f', mean_obs)}} ({.blue {sprintf('%.3f', sd_obs)}}), {.blue {sprintf('%.3f', min_obs)}} to {.blue {sprintf('%.3f', max_obs)}} ") - } - if (x$ncov > 0) { - cli::cli_h2("Population level covariates: Mean (SD), Min to Max") - for (i in 1:x$ncov) { - cli::cli_text("{x$covnames[i]}: {.blue {sprintf('%.3f', mean(unlist(x$cov[[i]]), na.rm = T))}} ({.blue {sprintf('%.3f', sd(unlist(x$cov[[i]]), na.rm = T))}}), {.blue {sprintf('%.3f', min(unlist(x$cov[[i]]), na.rm = T))}} to {.blue {sprintf('%.3f', max(unlist(x$cov[[i]]), na.rm = T))}}") + # SUMMARY ----------------------------------------------------------------- + + #' @title Summarize PM_data objects + #' @description + #' `r lifecycle::badge("stable")` + #' + #' Summarize the raw data used for a Pmetrics run. + #' + #' @method summary PM_data + #' @param object A [PM_data] object. + #' @param formula Optional formula for specifying custom summaries. See [aggregate] + #' and [formula] for details on how to specify formulae in R. If, for example, the data contain + #' a covariate for weight named 'wt', then to summarize the mean dose in mg/kg per subject specify + #' `formula = dose/wt ~ id` and `FUN = mean`. + #' @param FUN The summary function to apply to [formula], if specified. This is not + #' quoted, and usual choices will be [mean], [median], [max], or [min]. + #' @param include A vector of subject IDs to include in the summary, e.g. `c(1:3,5,15)` + #' @param exclude A vector of subject IDs to exclude in the summary, e.g. `c(4,6:14,16:20)` + #' @param ... Additional arguments to `FUN`, e.g. `na.rm = TRUE` + #' @return A list of class *summary.PM_data* with the following items: + #' * **nsub** Number of subjects + #' * **ndrug** Number of drug inputs + #' * **numeqt** Number of outputs + #' * **nobsXouteq** Number of observations by outeq + #' * **missObsXouteq** Number of missing observations by outeq + #' * **loqObsXouteq** Number of observations coded as below the limit of quantification by outeq + #' * **ncov** Number of covariates + #' * **covnames** Covariate names + #' * **ndoseXid** Number of doses per input per subject + #' * **nobsXid** Number of observations per outeq per subject + #' * **doseXid** Doses per input per subject + #' * **obsXid** Observations per outeq per subject + #' * **formula** Results of including [formula] + #' @author Michael Neely + #' @seealso [aggregate] + #' @export + + summary.PM_data <- function(object, formula, FUN, include, exclude, ...) { + + if(inherits(object, "PM_data")) { + object <- object$standard_data + } + + # filter data if needed + if (!missing(include)) { + object <- subset(object, sub("[[:space:]]+", "", as.character(object$id)) %in% as.character(include)) } - } - - if (!is.null(x$formula)) { - cli::cli_h2("Formula Results") - print(x$formula) - } - cli::cli_text("") - cli::cli_text("{.strong Note:} See {.help summary.PM_data} for more summary options using {.arg formula}.") -} # end function -# WRITE ------------------------------------------------------------------- - -#' @title Write a Pmetrics .csv Matrix File -#' @description -#' `r lifecycle::badge("superseded")` -#' -#' This function is largely superseded as the function is accessed with -#' the `$save()` method for [PM_data] objects. There is rarely a need to call -#' it directly. It is the companion function to [PMreadMatrix]. -#' It will write an appropriate R data object to a formatted .csv file. -#' @details -#' *PMwriteMatrix* will first run [PMcheck] to determine -#' if there are any errors in the structure of `data`. If the error check -#' fails, the file will not be written and a message will be printed on the console. -#' -#' @param data Must be a data.frame with appropriate structure (see [PMcheck]). -#' @param filename Name of file to create. -#' @param override Boolean operator to write even if errors are detected. Default is `FALSE`. -#' @param version Which matrix data format version to write. Default is the current version. -#' @param header Is there a header row? Default is `FALSE` as this was the legacy format. -#' @return Returns the error report (see [PMcheck] for details). -#' @author Michael Neely -#' @seealso [PM_data], [PMcheck], [PMreadMatrix] -#' @export -#' @examples -#' \dontrun{ -#' # write to the current directory -#' NPex$data$save("data.csv") -#' } -PMwriteMatrix <- function( - data, filename, override = FALSE, - version = "DEC_11", header = FALSE -) { - if (!override) { - err <- PMcheck(data, quiet = TRUE) - if (length(grep("FAIL", err)) > 0) { - cli::cli_warn(c("!" = "Write failed; returning errors.")) - return(invisible(err)) + if (!missing(exclude)) { + object <- subset(object, !sub("[[:space:]]+", "", as.character(object$id)) %in% as.character(exclude)) } - } else { - err <- NULL - } - # remove the block column if added during run - if ("block" %in% names(data)) { - data <- data |> dplyr::select(-block) + + # make results list + results <- list() + idOrder <- rank(unique(object$id)) + + results$nsub <- length(unique(object$id)) + results$ndrug <- max(object$input, na.rm = T) + results$numeqt <- max(object$outeq, na.rm = T) + results$nobsXouteq <- tapply(object$evid, object$outeq, function(x) length(x == 0)) + results$missObsXouteq <- by(object, object$outeq, function(x) length(x$out[x$evid == 0 & x$out == -99])) + + # censored + + results$bloqObsXouteq <- purrr::map_int(1:max(object$outeq, na.rm = TRUE), \(x) sum(object$cens[object$outeq == x] == "1", object$cens[object$outeq == x] == "bloq", na.rm = TRUE)) + results$aloqObsXouteq <- purrr::map_int(1:max(object$outeq, na.rm = TRUE), \(x) sum(object$cens[object$outeq == x] == "-1", object$cens[object$outeq == x] == "aloq", na.rm = TRUE)) + + covinfo <- getCov(object) + ncov <- covinfo$ncov + results$ncov <- ncov + results$covnames <- covinfo$covnames + results$ndoseXid <- as.matrix(tapply(object$evid, list(object$id, object$input), function(x) length(x != 0))[idOrder, ]) + results$nobsXid <- as.matrix(tapply(object$evid, list(object$id, object$outeq), function(x) length(x == 0))[idOrder, ]) + results$doseXid <- as.matrix(tapply(object$dose, list(object$id, object$input), function(x) x[!is.na(x)])[idOrder, ]) + results$obsXid <- as.matrix(tapply(object$out, list(object$id, object$outeq), function(x) x[!is.na(x)])[idOrder, ]) + if (ncov > 0) { + # get each subject's covariate values + results$cov <- lapply(1:ncov, function(y) { + tapply( + object[[covinfo$covstart + y - 1]], object$id, + function(z) z[!is.na(z)] + )[idOrder] + }) + names(results$cov) <- covinfo$covnames + } + if (!missing(formula)) { + results$formula <- aggregate(formula, object, FUN, ...) + } + + class(results) <- c("summary.PM_data", "list") + return(results) + } # end function + # PRINT SUMMARY ----------------------------------------------------------------- + + #' @title Print Summary of Pmetrics Data + #' @description + #' `r lifecycle::badge("stable")` + #' + #' @details + #' Print the summary of [PM_data] object. + #' + #' Summarize the raw data used for a Pmetrics run. + #' + #' @method print summary.PM_data + #' @param x An object made by [summary.PM_data]. + #' @return A printed object + #' @author Michael Neely + #' @param ... Not used. + #' @seealso [summary.PM_data] + #' @examples + #' \dontrun{ + #' dataEx$summary() + #' } + + #' @export + + print.summary.PM_data <- function(x, ...) { + # order of objects + # nsub + # ndrug + # numeqt + # nobsXouteq + # missObsXouteq + # bloqObsXouteq + # aloqObsXouteq + # ncov + # ndoseXid + # nobsXid + # doseXid + # obsXid + # cov + # formula + + cli::cli_div(theme = list( + span.blue = list(color = navy()) + )) + cli::cli_h1("Data Summary") + + cli::cli_text("Number of subjects: {.blue {x$nsub}}") + cli::cli_text("Number of inputs: {.blue {x$ndrug}}") + cli::cli_text("Number of outputs: {.blue {x$numeqt}}") + if (x$ncov > 0) { + cli::cli_text(" Covariates: {.blue {x$covnames}}") + } + cli::cli_h2("Inputs: Mean (SD), Min to Max") + for (i in 1:x$ndrug) { + if (x$ndrug > 1) { + cli::cli_h3("Input {i}") + } + cli::cli_text("Number of doses per subject: {.blue {sprintf('%.3f', mean(x$ndoseXid[, i], na.rm = T))}} ({.blue {sprintf('%.3f', sd(x$ndoseXid[, i], na.rm = T))}}), {.blue {sprintf('%.3f', min(x$ndoseXid[, i], na.rm = T))}} to {.blue {sprintf('%.3f', max(x$ndoseXid[, i], na.rm = T))}} ") + cli::cli_text("Dose amount per subject: {.blue {sprintf('%.3f', mean(unlist(x$doseXid[, i]), na.rm = T))}} ({.blue {sprintf('%.3f', sd(unlist(x$doseXid[, i]), na.rm = T))}}), {.blue {sprintf('%.3f', min(unlist(x$doseXid[, i]), na.rm = T))}} to {.blue {sprintf('%.3f', max(unlist(x$doseXid[, i]), na.rm = T))}} ") + + } + cli::cli_h2("Outputs: Mean (SD), Min to Max") + for (i in 1:x$numeqt) { + if (x$numeqt > 1) { + cli::cli_h3("Output {i}") + } + nobs <- unlist(x$nobsXid[, i]) + mean_nobs <- mean(nobs, na.rm = T) + sd_nobs <- sd(nobs, na.rm = T) + min_nobs <- min(nobs, na.rm = T) + max_nobs <- max(nobs, na.rm = T) + + obs <- unlist(x$obsXid[, i]) + obs <- obs[obs != -99] + mean_obs <- mean(obs, na.rm = T) + sd_obs <- sd(obs, na.rm = T) + min_obs <- min(obs, na.rm = T) + max_obs <- max(obs, na.rm = T) + + if (x$bloqObsXouteq[i] > 0) { + extra_text <- ", and {.blue {x$bloqObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$bloqObsXouteq[i] / x$nobsXouteq[i])}%}) censored as below a lower LOQ" + } else { + extra_text <- "" + } + + if (x$aloqObsXouteq[i] > 0) { + extra_text <- paste0(extra_text, ", and {.blue {x$aloqObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$aloqObsXouteq[i] / x$nobsXouteq[i])}%}) censored as above an upper LOQ") + } + cli::cli_text("Total across all subjects: {.blue {x$nobsXouteq[i]}}, with {.blue {x$missObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$missObsXouteq[i] / x$nobsXouteq[i])}%}) missing", extra_text, ".") + cli::cli_text("Number per subject: {.blue {sprintf('%.3f', mean_nobs)}} ({.blue {sprintf('%.3f', sd_nobs)}}), {.blue {sprintf('%i', min_nobs)}} to {.blue {sprintf('%i', max_nobs)}} ") + cli::cli_text("Value per subject: {.blue {sprintf('%.3f', mean_obs)}} ({.blue {sprintf('%.3f', sd_obs)}}), {.blue {sprintf('%.3f', min_obs)}} to {.blue {sprintf('%.3f', max_obs)}} ") + } + if (x$ncov > 0) { + cli::cli_h2("Population level covariates: Mean (SD), Min to Max") + for (i in 1:x$ncov) { + cli::cli_text("{x$covnames[i]}: {.blue {sprintf('%.3f', mean(unlist(x$cov[[i]]), na.rm = T))}} ({.blue {sprintf('%.3f', sd(unlist(x$cov[[i]]), na.rm = T))}}), {.blue {sprintf('%.3f', min(unlist(x$cov[[i]]), na.rm = T))}} to {.blue {sprintf('%.3f', max(unlist(x$cov[[i]]), na.rm = T))}}") + } + } + + if (!is.null(x$formula)) { + cli::cli_h2("Formula Results") + print(x$formula) + } + cli::cli_text("") + cli::cli_text("{.strong Note:} See {.help summary.PM_data} for more summary options using {.arg formula}.") + } # end function + # WRITE ------------------------------------------------------------------- + + #' @title Write a Pmetrics .csv Matrix File + #' @description + #' `r lifecycle::badge("superseded")` + #' + #' This function is largely superseded as the function is accessed with + #' the `$save()` method for [PM_data] objects. There is rarely a need to call + #' it directly. It is the companion function to [PMreadMatrix]. + #' It will write an appropriate R data object to a formatted .csv file. + #' @details + #' *PMwriteMatrix* will first run [PMcheck] to determine + #' if there are any errors in the structure of `data`. If the error check + #' fails, the file will not be written and a message will be printed on the console. + #' + #' @param data Must be a data.frame with appropriate structure (see [PMcheck]). + #' @param filename Name of file to create. + #' @param override Boolean operator to write even if errors are detected. Default is `FALSE`. + #' @param version Which matrix data format version to write. Default is the current version. + #' @param header Is there a header row? Default is `FALSE` as this was the legacy format. + #' @return Returns the error report (see [PMcheck] for details). + #' @author Michael Neely + #' @seealso [PM_data], [PMcheck], [PMreadMatrix] + #' @export + #' @examples + #' \dontrun{ + #' # write to the current directory + #' NPex$data$save("data.csv") + #' } + PMwriteMatrix <- function( + data, filename, override = FALSE, + version = "DEC_11", header = FALSE) { + if (!override) { + err <- PMcheck(data, quiet = TRUE) + if (length(grep("FAIL", err)) > 0) { + cli::cli_warn(c("!" = "Write failed; returning errors.")) + return(invisible(err)) + } + } else { + err <- NULL + } + # remove the block column if added during run + if ("block" %in% names(data)) { + data <- data %>% dplyr::select(-block) + } + + versionNum <- as.numeric(substr(version, 5, 7)) + switch(substr(version, 1, 3), + JAN = 1, + FEB = 2, + MAR = 3, + APR = 4, + MAY = 5, + JUN = 6, + JUL = 7, + AUG = 8, + SEP = 9, + OCT = 10, + NOV = 11, + DEC = 12 + ) / 100 + if (versionNum < 11.12) { + if (tolower(names(data)[6]) == "addl") data <- data[, c(-6, -7)] + } + OS <- getOS() + eol <- c("\r\n", "\n", "\r\n")[OS] + f <- file(filename, "w") + if (header) { + writeLines(paste("POPDATA ", version, "\n#", sep = ""), f, sep = "") + } + writeLines(toupper(names(data)[-ncol(data)]), sep = getPMoptions("sep"), f) + writeLines(toupper(names(data)[ncol(data)]), f) + write.table(data, f, + row.names = FALSE, na = ".", quote = F, sep = getPMoptions("sep"), + dec = getPMoptions("dec"), col.names = F, eol = eol + ) + close(f) + return(invisible(err)) } - - versionNum <- as.numeric(substr(version, 5, 7)) + switch(substr(version, 1, 3), - JAN = 1, - FEB = 2, - MAR = 3, - APR = 4, - MAY = 5, - JUN = 6, - JUL = 7, - AUG = 8, - SEP = 9, - OCT = 10, - NOV = 11, - DEC = 12 - ) / 100 - if (versionNum < 11.12) { - if (tolower(names(data)[6]) == "addl") data <- data[, c(-6, -7)] - } - OS <- getOS() - eol <- c("\r\n", "\n", "\r\n")[OS] - f <- file(filename, "w") - if (header) { - writeLines(paste("POPDATA ", version, "\n#", sep = ""), f, sep = "") - } - writeLines(toupper(names(data)[-ncol(data)]), sep = getPMoptions("sep"), f) - writeLines(toupper(names(data)[ncol(data)]), f) - write.table(data, f, - row.names = FALSE, na = ".", quote = F, sep = getPMoptions("sep"), - dec = getPMoptions("dec"), col.names = F, eol = eol - ) - close(f) - return(invisible(err)) -} + \ No newline at end of file diff --git a/R/PM_sim.R b/R/PM_sim.R index 7c55fe4d..5548d8aa 100755 --- a/R/PM_sim.R +++ b/R/PM_sim.R @@ -83,9 +83,9 @@ PM_sim <- R6::R6Class( #' [PM_result] or [PM_final] objects can easily be used as #' the prior distributions for sampling. Prior distributions #' may also be manually - #' specified, useful when simulating from literature values. + #' specified, useful when simulating from literature values. #' Prior distributions may be unimodal-multivariate (parametric - #' sampling), or multimodal-multivariate (semi-parametric sampling). For + #' sampling), or multimodal-multivariate (semi-parametric sampling). For #' [PM_result] or [PM_final] priors, this can be accomplished with the `split` argument. #' For manual priors, the `weights` argument in the `poppar` list #' specifies the weights for each distribution. @@ -119,34 +119,34 @@ PM_sim <- R6::R6Class( #' Output may also be directed to a new Pmetrics .csv data file #' using the `makecsv` argument. #' - #' @param poppar One of five things: - #' + #' @param poppar One of four things: + #' #' 1. A [PM_result] object containing the final population parameter - #' distribution from a model run, a model object, and a data object. + #' distribution from a model run, a model object, and a data object. #' The model object may be replaced by a different [PM_model], as #' long as the primary parameters are the same as the original model. #' The data object may also be replaced (and often is) by a different [PM_data] #' object compatible with the model. - #' + #' #' ``` #' run1 <- PM_load(1) # load the PM_result object - #' sim1 <- run1$sim(...) # replace model and data in run1 if desired; + #' sim1 <- run1$sim(...) # replace model and data in run1 if desired; #' #must be compatible with model and data in run1 - #' + #' #' mod <- PM_model$new("model.txt") # or use a model object - #' sim2 <- mod$sim(poppar = run1, data = "newdata.csv", ...) + #' sim2 <- mod$sim(poppar = run1, data = "newdata.csv", ...) #' # poppar and data necessary, model obtained from mod #' ``` #' 2. Population prior parameters as a [PM_final] object found in - #' `PM_result$final`. - #' + #' `PM_result$final`. + #' #' ``` #' run1 <- PM_load(1) # load the PM_result object - #' sim1 <- PM_sim$new(poppar = run1$final, model = newmodel, data = newdata, ...) + #' sim1 <- PM_sim$new(poppar = run1$final, model = newmodel, data = newdata, ...) #' # model and data necessary - #' + #' #' mod <- PM_model$new("model.txt") # or use a model object - #' sim2 <- mod$sim(poppar = run1$final, data = "newdata.csv", ...) + #' sim2 <- mod$sim(poppar = run1$final, data = "newdata.csv", ...) #' # poppar and data necessary, model obtained from mod #' ``` #' 3. The name of a previously saved simulation via the `$save` method. The @@ -154,58 +154,46 @@ PM_sim <- R6::R6Class( #' #' 4. A manually specified prior as a list containing the following named items: #' * **wt** vector of weights (probabilities) of sampling from each distribution. If missing, assumed to be 1. - #' * **mean** a list of mean parameter values. Each element of the list should be named with the parameter name and be a + #' * **mean** a list of mean parameter values. Each element of the list should be named with the parameter name and be a #' vector of length equal to the number of distributions. See details below. #' * **sd** an optional named list of overall standard deviations for each parameter, considering parameters as unimodally distributed, - #' i.e. there should only be one value for each parameter, regardless of the number of distributions. - #' `sd` is only needed if a correlation matrix is specified, which will be converted to a covariance matrix. + #' i.e. there should only be one value for each parameter, regardless of the number of distributions. + #' `sd` is only needed if a correlation matrix is specified, which will be converted to a covariance matrix. #' * **ONE** of the following matrices: - #' 1. **cor** A square matrix of the overall correlations between parameters, again + #' 1. **cor** A square matrix of the overall correlations between parameters, again #' considered as unimodally distributed, i.e. there should only be one correlation matrix regardless of the number of distributions. #' If a correlation matrix is specified, the `sd` element is required to calculate the covariance matrix. #' 2. **cov** A square matrix of the overall covariances between parameters, again #' considered as unimodally distributed, i.e. there should only be one covariance matrix regardless of the number of distributions. #' If a covariance matrix is specified, the `sd` element is unnecessary, since the diagonals of the covariance matrix are the variances #' or squared standard deviations. - #' - #' + #' + #' #' If only one distribution is to be specified the #' `wt` vector can be ommitted or should be `wt = 1`. If multiple #' distributions are to be sampled, the `wt` vector should be of #' length equal to the number of distributions in `mean` and the values of `wt` should sum to 1, #' e.g. `wt = c(0.25, 0.05, 0.7)`. The `mean` element should be a list - #' of elements, named for the parameters, with vectors of values equal to the number of terms in `wt`. + #' of elements, named for the parameters, with vectors of values equal to the number of terms in `wt`. #' If `cor` is used, #' Pmetrics will use the `sd` element to calculate the covariance matrix. The #' covariance matrix will be divided by the number of distributions, i.e. `length(wt)`, #' and applied to each distribution. - #' + #' #' Examples: - #' * Single distribution: + #' * Single distribution: #' ``` - #' poppar = list(wt = 1, - #' mean = list(ke = 0.5, v = 100), - #' cov = matrix(c(0.04, 2.4, 2.8, 400), nrow = 2)) # sd not required because cov specified + #' poppar = list(wt = 1, + #' mean = list(ke = 0.5, v = 100), + #' cov = matrix(c(0.04, 2.4, 2.8, 400), nrow = 2)) # sd not required because cov specified #' ``` - #' * Multiple distributions: + #' * Multiple distributions: #' ``` #' poppar = list(wt = c(0.1, 0.15, 0.75), # 3 distributions that sum to 1 #' mean = list(ke = c(2, 0.5, 1), v = c(50, 100, 200)), # 3 values for each parameter #' sd = list(ke = 0.2, v = 20), # overall sd, ignoring multiple distributions #' cor = matrix(c(1, 0.6, 0.7, 1), nrow = 2)) # sd required because cor specified #' ``` - #' 5. A data frame with one column for each parameter and one row for each parameter set - #' to simulate. This is useful when you already have fixed parameter values, such as - #' `NPex$final$popPoints`. Each row will generate one simulated profile, so `nsim` is - #' ignored and the number of simulated profiles will equal the number of rows in the - #' data frame. If a `$prob` column is present, it will be ignored, since each row is - #' treated as the parameters to be used for one simulation. - #' - #' ``` - #' poppar <- as.data.frame(run1$final$popPoints) |> - #' dplyr::select(ke, v) - #' sim1 <- PM_sim$new(poppar = poppar, model = run1$model, data = run1$data) - #' ``` #' #' @param model Name of a suitable [PM_model] object or a model file template #' in the working directory. If missing, and `poppar` is a [PM_result], @@ -251,7 +239,7 @@ PM_sim <- R6::R6Class( #' Each of these specifies custom limits for 3 parameters named Ka, Ke, and V, #' with limits of (0.1, 5), (0.1, 5) and (10, 200), respectively. The last example uses tibbles, the #' tidyverse equivalent of data frames. - #' + #' #' Means and covariances of the total number of simulated sets will be returned to #' verify the simulation, but only those sets within the specified limits will #' be used to generate output(s) and the means and covariances of the retained @@ -276,9 +264,7 @@ PM_sim <- R6::R6Class( #' #' @param nsim The number of simulated profiles to create, per subject. Default #' is 1000. Entering 0 will result in one profile being simulated from each - #' point in the non-parametric prior (for NPAG final objects only). If `poppar` - #' is supplied as a data frame of parameter values, `nsim` is ignored and the - #' number of simulated profiles will equal the number of rows in that data frame. + #' point in the non-parametric prior (for NPAG final objects only). #' #' @param predInt The interval in fractional hours for simulated predicted #' outputs at times other than those specified in the template `data`. @@ -301,9 +287,9 @@ PM_sim <- R6::R6Class( #' predictions will be truncated. #' #' @param covariate Pmetrics can simulate values for some/all covariates - #' declared in the `cov` block of the [PM_model]. + #' declared in the `cov` block of the [PM_model]. #' This argument is a list with the following named elements. - #' + #' #' * **cov** Optional if `poppar` is a [PM_result] object, but required if #' `poppar` is a [PM_final] object or a manually specified prior, e.g., with values #' obtained from the literature. @@ -311,78 +297,78 @@ PM_sim <- R6::R6Class( #' * **sd** Required only if `poppar` is a manually specified prior, optional otherwise. #' * **limits** Optional in all cases. #' * **fix** Optional in all cases. - #' - #' The simplest example is when simulating covariates from a [PM_result]: + #' + #' The simplest example is when simulating covariates from a [PM_result]: #' ``` #' run1 <- PM_load(1) #' run1$sim(..., covariate = list())` #' ``` - #' + #' #' Details on each element are below. - #' - #' `cov` - #' - #' This element specifies the source of the correlation matrix for + #' + #' `cov` + #' + #' This element specifies the source of the correlation matrix for #' covariate values and if possible model primary parameters, i.e., those - #' in the `pri` block of the model. - #' In the first two cases below, Pmetrics will use this `covariate$cov` + #' in the `pri` block of the model. + #' In the first two cases below, Pmetrics will use this `covariate$cov` #' object to calculate the correlation #' matrix between all covariates and Bayesian posterior parameter values. #' In the third case, there is no way to calculate the correlations #' between parameters and covariates, so Pmetrics only calculates the covariate correlations. - #' + #' #' * **Case 1**. If `poppar` is a [PM_result], Pmetrics will use the `$cov` field - #' within that object to obtain covariate means, standard deviations (sd), and + #' within that object to obtain covariate means, standard deviations (sd), and #' correlations among covariates and parameter values. In this case, you can omit this #' element of the `covariate` list. See the example above. #' * **Case 2**. If `poppar` is a [PM_final], you will need to supply the name of a [PM_result] #' or [PM_cov] object as the value for this element so that Pmetrics can calculate covariate #' means, sd, and correlations. - #' + #' #' ``` #' run1 <- PM_load(1) #' sim1 <- PM_sim$new(poppar = run1$final, covariate = list(cov = run1$cov), model = run1$model, data = "newdata.csv") #' ``` - #' + #' #' * **Case 3**. If `poppar` is a manually specified prior, or you wish to simulate covariates #' not in the original model, you must provide a - #' covariance or correlation matrix between the covariates. In this case, it is only possible to + #' covariance or correlation matrix between the covariates. In this case, it is only possible to #' calculate correlations between covariates from the matrix and not between parameters and correlations, - #' since they are unknown. The `$mean` and optionally the + #' since they are unknown. The `$mean` and optionally the #' `$sd` elements of the `covariate` list specified below are also required to complete the necessary #' information for simulation. Similar to `poppar`, if `$sd` is missing, the the `cov` object is treated as a covariance matrix, #' otherwise it is treated as a correlation matrix. #' ``` #' corMat <- matrix(c(1, .98, .98, 1), nrow = 2) # correlation matrix for age and wt, for example #' covariate <- list(cov = corMat, mean = list(age = 9, wt = 32), sd = list(age = 5.5, wt = 18.8)) # note the named lists for mean and sd, and cov is treated as a correlation matrix - #' + #' #' covMat <- matrix(c(30.25, 101.33, 101.33, 353.44), nrow = 2) #' covariate <- list(cov = covMat, mean = list(age = 9, wt = 32)) # equivalent covariance matrix, and sd is not required #' ``` - #' - #' - #' `mean` - #' + #' + #' + #' `mean` + #' #' A named list that specifies the mean #' for one or more of the covariates in your model. If you are simulating in Case 1 or 2 #' above, `mean` is optional and allows you to use a different mean value than was in your - #' model-building population. For example, the population may have had a mean weight of + #' model-building population. For example, the population may have had a mean weight of #' 30 kg, but `covariate = list(..., mean = list(wt = 70))` allows you to simulate #' weight with a mean of 70. If this #' argument is missing then the mean covariate values in the population will #' be used for simulation. The same applies to any covariates that are not - #' named in this list. - #' + #' named in this list. + #' #' In Case 3, `mean` is required and must be a named list with the names #' of the covariates in the correlation matrix, and the values as the mean values for #' those covariates. See the example in `cov` above under Case 3. - #' + #' #' Examples: #' * Using a [PM_result] as poppar: `PM_sim$new(poppar = run1, covariate = list())`. - #' Here we don't need to specify `cov` because it is already in the [PM_result] `run1`. We are + #' Here we don't need to specify `cov` because it is already in the [PM_result] `run1`. We are #' not re-centering or otherwise modifying the covariates, so `covariate` can be an empty list. #' * Using a [PM_final] as poppar: `PM_sim$new(poppar = run1$final, covariate = list(cov = run1$cov, mean = list(wt = 50))`. - #' Here we need to specify `cov` because it is not in the [PM_final] object. Futhermore, we want to recenter the + #' Here we need to specify `cov` because it is not in the [PM_final] object. Futhermore, we want to recenter the #' mean values, so we add the `$mean` element. #' * Using a manually specified covariate correlation matrix: #' ``` @@ -390,13 +376,13 @@ PM_sim <- R6::R6Class( #' covariate <- list(cov = corMat, mean = list(age = 9, wt = 32), sd = list(age = 5.5, wt = 18.8)) # mean and sd are required #' PM_sim$new(poppar = poppar , covariate = covariate) # covariates will be added to poppar for simulation regardless of the source of poppar #' ``` - #' - #' - #' `sd` - #' + #' + #' + #' `sd` + #' #' This functions just as the `$mean`` argument does, but for standard deviations. - #' - #' + #' + #' #' `limits` This is a bit different than the limits for population #' parameters above. Here, #' `limits` is similar to `mean` and `sd` for covariates in @@ -410,18 +396,18 @@ PM_sim <- R6::R6Class( #' age and wt are being simulated. #' * `covariate = list(..., limits = list( wt = c(10, 70)))` will limit wt to between 10 and 70 kg. #' Since age is also being simulated, it will have the same limits as in the population - #' under Cases 1 and 2 above. Under Case 3, there is no population value for wt or age, so + #' under Cases 1 and 2 above. Under Case 3, there is no population value for wt or age, so #' wt will be limited and age will be unlimited. #' * `covariate = list(..., limits = list( wt = c(10, 70), age = c(0, 200)))` will limit wt to between 10 and 70 kg - #' and age to between 0 and 200 years, which is effectively no limit. This would only be necessary under + #' and age to between 0 and 200 years, which is effectively no limit. This would only be necessary under #' Cases 1 or 2 when age was a covariate in the data and model. - #' - #' - #' `fix` - #' - #' A character vector (not a list) of model covariates to fix and not simulate. + #' + #' + #' `fix` + #' + #' A character vector (not a list) of model covariates to fix and not simulate. #' Values in the template data will be used and not simulated. - #' Example: `covariate = list(..., fix = c("wt", "age"))`. + #' Example: `covariate = list(..., fix = c("wt", "age"))`. #' #' @param usePost Boolean, default `FALSE`. Only applicable when `poppar` contains an #' NPAG [PM_final] object. If `TRUE`, the mean @@ -484,7 +470,7 @@ PM_sim <- R6::R6Class( #' exDat$makeNoise(list(dose = list(coeff = c(0.1, 0.1), filter = "dose > 100 & time < 200", mode = "add"), #' out = list(c(0.1, 0.001), mode = "exp"))) #' ``` - #' + #' #' #' @param makecsv A character vector for the name of the single .csv file to be #' made for all simulated "subjects". If no file extension is included, ".csv" @@ -539,18 +525,18 @@ PM_sim <- R6::R6Class( #' nsim = 15, model = "model.txt", include = 1:4, limits = NA, #' noise = list(out = list(coeff = c(0.02, 0.1, 0, 0))) #' ) - #' + #' #' # alternatively, load the model first - #' + #' #' mod <- PM_model$new("model.txt") - #' + #' #' # and then simulate - #' + #' #' sim2 <- mod$sim(poppar = poppar, data = "temp1.csv", #' nsim = 15, include = 1:4, limits = NA, #' noise = list(out = list(coeff = c(0.02, 0.1, 0, 0))) #' ) - #' + #' #' } initialize = function(poppar, model, data, limits = NULL, @@ -577,22 +563,19 @@ PM_sim <- R6::R6Class( "i" = "Instead, use {.arg noise}. See {.help PM_sim}." )) } - + # check to make sure any arguments in ... are not misspelled or otherwise unrecognized - allArgs <- formals(PM_sim$public_methods$initialize) |> names() - # exclude the variadic placeholder from validation - allArgs <- setdiff(allArgs, "...") + allArgs <- formals(PM_sim$public_methods$initialize) %>% names() dotArgs <- names(dots) - # only validate truly named arguments (non-NA, non-empty names) - dotArgs <- dotArgs[!is.null(dotArgs) & !is.na(dotArgs) & nzchar(dotArgs)] unrecog <- setdiff(dotArgs, allArgs) if (length(unrecog) > 0) { cli::cli_abort(c( "x" = "The following argument{?s} {?is/are} not recognized: {.val {unrecog}}.", - "i" = "Check for case errors or misspellings. Refer to {.help PM_sim} for a list of valid arguments." + "i" = "Check for case erorrs or misspellings. Refer to {.help PM_sim} for a list of valid arguments." )) } - + + if (missing(poppar)) { cli::cli_abort(c( @@ -610,15 +593,11 @@ PM_sim <- R6::R6Class( final <- poppar$final$data # PM_final_data msg <- c(msg, "Prior obtained from {.arg PM_result}.") if (missing(model)) { - # Reconstruct the model from its definition so it uses the current - # class methods. Models stored inside saved `PM_result` objects may - # carry outdated methods (R6 serializes method closures), so using - # them directly can invoke removed functions. - model <- PM_model$new(poppar$model, compile = FALSE) + model <- poppar$model msg <- c(msg, "Model obtained from {.arg PM_result}.") } else { model <- PM_model$new(model, compile = FALSE) # compile later - } + } if (missing(data)) { data <- poppar$data @@ -664,7 +643,7 @@ PM_sim <- R6::R6Class( case <- 7 # parse poppar list - poppar_elements <- names(poppar) |> purrr::discard(~ .x == "wt") + poppar_elements <- names(poppar) %>% purrr::discard(~ .x == "wt") if (length(poppar_elements) == 2 && all(c("mean", "sd") %in% poppar_elements)) { # mean and SD only poppar$cov <- diag(poppar$sd^2) # make covariance matrix @@ -682,7 +661,7 @@ PM_sim <- R6::R6Class( # add missing wt if needed if (!"wt" %in% names(poppar)) { poppar$wt <- 1 # default weight - } + } # check to ensure wt and mean are aligned if (!all(map_lgl(poppar$mean, \(x) length(x) == length(poppar$wt)))) { @@ -697,13 +676,13 @@ PM_sim <- R6::R6Class( popWeight = poppar$wt, popMean = tibble::as_tibble(do.call(cbind, poppar$mean)), popCov = data.frame(poppar$cov) - ) + ) # not returning because going on to simulate below ### This is for loading a saved simulation from file - } else if (inherits(poppar, "data.frame")) { # poppar is in the form of theta.csv - poppar$prob <- 1 / nrow(poppar) + } else if (inherits(poppar, "data.frame")){ # poppar is in the form of theta.csv + poppar$prob <- 1/nrow(poppar) final <- list(popPoints = poppar) useTheta <- TRUE case <- 8 @@ -738,28 +717,19 @@ PM_sim <- R6::R6Class( # If we reach this point, we are creating a new simulation # check model and data - if (case %in% c(2, 3, 7, 8)) { # need model and data if not from PM_result - if (missing(model)) { - model <- "model.txt" - } # try the default - # Always reconstruct through PM_model$new so the model uses the current - # class methods. Models supplied from saved objects may carry outdated - # methods (R6 serializes method closures). - model <- PM_model$new(model, compile = FALSE) # compile later + if(case %in% c(2, 3, 7, 8)) { # need model and data if not from PM_result + if (missing(model)) { model <- "model.txt" } # try the default + if (!inherits(model, "PM_model")) {model <- PM_model$new(model, compile = FALSE)} # compile later - if (missing(data)) { - data <- "data.csv" - } # try the default - if (!inherits(data, "PM_data")) { - data <- PM_data$new(data, quiet = quiet) - } # will abort if can't make PM_data + if (missing(data)) { data <- "data.csv" } # try the default + if (!inherits(data, "PM_data")) {data <- PM_data$new(data, quiet = quiet)} # will abort if can't make PM_data } # set default values if (is.null(split)) { - if (inherits(final, "NPAG") || inherits(poppar, "NPAG")) { + if (inherits(poppar, "NPAG")) { split <- TRUE } else { split <- FALSE @@ -777,9 +747,9 @@ PM_sim <- R6::R6Class( # check to ensure first element is correct if (length(covariate) == 0 || !"cov" %in% names(covariate)) { - if (inherits(poppar, "PM_result")) { - covariate$cov <- poppar$cov - msg <- c(msg, "Covariate statistics obtained from {.code PM_result$cov}.") + if (inherits(poppar, "PM_result")) { + covariate$cov <- poppar$cov + msg <- c(msg, "Covariate statistics obtained from {deparse(substitute(poppar))}}$cov}.") } else { cli::cli_abort(c( "x" = "The {.arg covariate$cov} argument must be supplied if `poppar` is not a {.fn PM_result} object.", @@ -800,6 +770,7 @@ PM_sim <- R6::R6Class( } + # check if user specified covariate with posterior simulation? if (usePost) { cli::cli_abort(c( @@ -821,10 +792,12 @@ PM_sim <- R6::R6Class( covariate$cov <- cor2cov(covariate$cov, covariate$sd) # convert correlation matrix to covariance matrix msg <- c(msg, "Covariate correlation matrix converted to covariance matrix.") } - } + + } # OK, all checks passed, so we can proceed with covariates + } # end if !is.null(covariate) # finally, call the simulator, which updates self$data @@ -835,15 +808,15 @@ PM_sim <- R6::R6Class( include = include, exclude = exclude, nsim = nsim, predInt = predInt, covariate = covariate, usePost = usePost, - seed = seed, + seed = seed, ode = ode, noise = noise, - makecsv = makecsv, + makecsv = makecsv, outname = outname, clean = clean, quiet = quiet, useTheta = useTheta, - msg = msg + nocheck = nocheck, overwrite = overwrite, msg = msg ) return(self) - }, # end initialize + }, # end initialize #' #' @description #' `r lifecycle::badge("stable")` @@ -863,14 +836,6 @@ PM_sim <- R6::R6Class( plot.PM_sim(self$data, ...) }, - #' @description - #' `r lifecycle::badge("stable")` - #' Calculate optimal sampling times - #' @param ... Additional parameters, refer to [PM_opt] - opt = function(...) { - PM_opt$new(self, ...) - }, - #' @description #' `r lifecycle::badge("stable")` #' Estimates the Probability of Target Attaintment (PTA), based on the results @@ -883,9 +848,9 @@ PM_sim <- R6::R6Class( #' @description #' `r lifecycle::badge("stable")` #' Calculates the AUC of the specified simulation - #' @param ... Arguments passed to [make_AUC]. + #' @param ... Arguments passed to [makeAUC]. auc = function(...) { - rlang::try_fetch(make_AUC(self$data, ...), + rlang::try_fetch(makeAUC(self$data, ...), error = function(e) { cli::cli_warn("Unable to generate AUC.", parent = e) return(NULL) @@ -952,21 +917,18 @@ PM_sim <- R6::R6Class( SIMrun = function(poppar, limits, model, data, split, include, exclude, nsim, predInt, covariate, usePost, - seed, + seed, ode, noise, - makecsv, quiet, useTheta, - msg) { + makecsv, outname, clean, quiet, useTheta, + nocheck, overwrite, msg) { # DATA PROCESSING AND VALIDATION ------------------------------------------ ###### POPPAR + + npar <- if (useTheta) {ncol(poppar$popPoints) - 1} else {length(poppar$popMean)} - npar <- if (useTheta) { - ncol(poppar$popPoints) - 1 - } else { - length(poppar$popMean) - } ###### MODEL @@ -975,8 +937,8 @@ PM_sim <- R6::R6Class( arg_list <- model$arg_list mod_list <- model$model_list mod_npar <- length(mod_list$parameters) # number of random parameters - # mod_nfix <- sum(map(mod_list$pri, \(x) x$mode == "constant") |> unlist()) # number of constant parameters - # mod_nranfix <- sum(map(mod_list$pri, \(x) x$mode == "fixed") |> unlist()) # number of random but fixed parameters + # mod_nfix <- sum(map(mod_list$pri, \(x) x$mode == "constant") %>% unlist()) # number of constant parameters + # mod_nranfix <- sum(map(mod_list$pri, \(x) x$mode == "fixed") %>% unlist()) # number of random but fixed parameters mod_numeqt <- mod_list$n_out mod_asserr <- map(mod_list$err, \(x) x$coeff) @@ -1001,9 +963,9 @@ PM_sim <- R6::R6Class( cli::cli_abort(c("x" = "No subjects to simulate.")) } - # if (template_numeqt != mod_numeqt) { - # cli::cli_abort(c("x" = "Number of output equations in model and data do not match.")) - # } + if (template_numeqt != mod_numeqt) { + cli::cli_abort(c("x" = "Number of output equations in model and data do not match.")) + } # if (!identical(sort(template_covnames), sort(mod_list$cov))) { # cli::cli_abort(c("x" = "Covariate names in model and data do not match.")) @@ -1043,14 +1005,7 @@ PM_sim <- R6::R6Class( # PARAMETER LIMITS -------------------------------------------------------- if (all(is.null(limits))) { # limits are omitted altogether - # use the parameter names (not positional indices) so that limits can - # be matched to parameters by name in generate_multimodal_samples() - par_names <- if (useTheta) { - setdiff(names(poppar$popPoints), "prob") - } else { - names(poppar$popMean) - } - parLimits <- tibble::tibble(par = par_names, min = rep(-Inf, npar), max = rep(Inf, npar)) + parLimits <- tibble::tibble(par = 1:npar , min = rep(-Inf, npar), max = rep(Inf, npar)) } else if (!any(is.na(limits)) & is.vector(limits)) { # no limit is NA and specified as vector of length 1 or 2 # so first check to make sure poppar is a PM_final_data object if (!inherits(poppar, "PM_final_data")) { @@ -1063,7 +1018,7 @@ PM_sim <- R6::R6Class( if (length(limits) == 1) { # e.g. limits = 3, multiply upper... limits <- c(1, limits) # ...and set lower multiplier to 1 } - parLimits <- orig_lim |> mutate( + parLimits <- orig_lim %>% mutate( min = min * limits[1], max = max * limits[2] ) @@ -1071,10 +1026,9 @@ PM_sim <- R6::R6Class( if (inherits(poppar, "PM_final_data")) { parLimits <- poppar$ab } else { - parLimits <- tibble::tibble( - par = model$model_list$parameters, - min = purrr::map_dbl(model$model_list$pri, ~ .x$min), - max = purrr::map_dbl(model$model_list$pri, ~ .x$max) + parLimits <- tibble::tibble(par = model$model_list$parameters, + min = purrr::map_dbl(model$model_list$pri, ~.x$min), + max = purrr::map_dbl(model$model_list$pri, ~.x$max) ) } } else if (any(is.na(limits))) { # some NAs, causes error @@ -1094,6 +1048,8 @@ PM_sim <- R6::R6Class( } + + # COVARIATES ---------------------------------------------------- # if covariate is not null and simulating more than 1 new subject, @@ -1101,25 +1057,23 @@ PM_sim <- R6::R6Class( simWithCov <- FALSE # default is no covariates - if (!is.null(covariate)) { + if(!is.null(covariate)) { simWithCov <- TRUE # get mean of each covariate and Bayesian posterior parameter - if (is.matrix(covariate$cov)) { # simulating covariates not in the data - if (inherits(poppar, "PM_final_data")) { + if(is.matrix(covariate$cov)){ # simulating covariates not in the data + if(inherits(poppar, "PM_final_data")) { pars <- poppar$postMean # get the parameter values } else { # manual poppar prior, so simulate arbitrary number of parameters - poppar <- poppar |> - purrr::set_names(c("wt", "popMean", "popCov")) |> - c(list(popCor = cov2cor(.$popCov))) # keeps it consistent with PM_final_data + poppar <- poppar %>% purrr::set_names(c("wt", "popMean", "popCov")) %>% c(list(popCor = cov2cor(.$popCov))) # keeps it consistent with PM_final_data weights <- poppar$wt means <- bind_rows(poppar$popMean) cov_matrix <- pos_def(poppar$popCov) # ensure covariance matrix is positive definite, function in PMutilities - if (length(cov_matrix) == 1 && cov_matrix == 1) { - return(invisible(NULL)) # quietly abort simulation - } else if (length(cov_matrix) == 1 && cov_matrix == -1) { + if (length(cov_matrix) == 1 && cov_matrix == 1){ + return(invisible(NULL)) #quietly abort simulation + } else if (length(cov_matrix) == 1 && cov_matrix == -1){ cli::cli_abort(c( "x" = "Population parameter covariance matrix cannot be made positive definite.", "i" = "Please check your covariance matrix." @@ -1128,915 +1082,872 @@ PM_sim <- R6::R6Class( samples_per_mode <- stats::rmultinom(1, size = 50, prob = weights) # Generate samples for each mode - pars <- map(1:length(weights), \(i) { - tryCatch(suppressWarnings( - PM_rtmvnorm( # in PMutilities - n = samples_per_mode[i], - mean = means[i, ], - sigma = cov_matrix, - lb = rep(0, ncol(means[i, ]))) - ), - error = function(e) NULL - ) |> as.data.frame() - }) |> - list_rbind() |> - rlang::set_names(names(means)) - } - # Generate samples for each covariate - means <- covariate$mean - cov_matrix <- pos_def(covariate$cov) # ensure covariance matrix is positive definite, function in PMutilities - if (length(cov_matrix) == 1 && cov_matrix == 1) { - return(invisible(NULL)) # quietly abort simulation - } else if (length(cov_matrix) == 1 && cov_matrix == -1) { - cli::cli_abort(c( - "x" = "Covariate parameter covariance matrix cannot be made positive definite.", - "i" = "Please check your covariance matrix." - )) - } - - samples <- tryCatch( - PM_rtmvnorm( # in PMutilities - n = nrow(pars), - mean = means, - sigma = cov_matrix, - lb = rep(0, length(means)) - ), - error = function(e) NULL - ) |> - tibble::as_tibble(.name_repair = "minimal") |> - rlang::set_names(names(means)) - - # in either case, combine the pars and covariates and proceed - CVsum <- bind_cols(pars, samples, .name_repair = "minimal") |> mutate(icen = "mean") - } else { # we had a PM_final_data as covariate$cov - CVsum <- covariate$cov$summary(icen = "mean") - } - - # take out fixed covariates not to be simulated - if (length(covariate$fix) > 0) { - CVsum <- CVsum |> select(.cols = -!!covariate$fix) - } - # remove covariates that are missing because they have all the same value - # this also drops id and icen columns - CVsum <- CVsum |> - select(where(~ dplyr::n_distinct(.) > 1)) |> - select(-id) - - # get correlation matrix - corCV <- suppressWarnings(cor(CVsum)) - - nsimcov <- ncol(corCV) - npar - - # augment poppar correlation matrix - bind_bottom_right <- function(A, B, n) { - m <- nrow(A) - if (nrow(B) != m + n || ncol(B) != m + n) { - stop("B must be of size (m + n) x (m + n)") - } + tryCatch(suppressWarnings(TruncatedNormal::rtmvnorm(n = samples_per_mode[i], mean = means[i,], sigma = cov_matrix, lb = rep(0, ncol(means[i,])))), + error = function(e) NULL + ) %>% as.data.frame() + }) %>% + list_rbind() %>% + rlang::set_names(names(means)) - # Extract blocks from B - B_right <- B[1:m, (m + 1):(m + n), drop = FALSE] # top-right block - B_bottom <- B[(m + 1):(m + n), 1:m, drop = FALSE] # bottom-left block - B_corner <- B[(m + 1):(m + n), (m + 1):(m + n), drop = FALSE] # bottom-right block - - # Assemble full matrix - top <- cbind(A, B_right) - bottom <- cbind(B_bottom, B_corner) - rbind(top, bottom) } - - corMat <- bind_bottom_right( - as.matrix(poppar$popCor), - as.matrix(corCV), - n = nsimcov - ) - - - # get SD of covariates - covSD <- CVsum |> summarize(across(last_col(offset = nsimcov - 1):last_col(), \(x) sd(x, na.rm = TRUE))) - - # grab their names - covs2sim <- names(covSD) - - # set SDs of named variables, and use population values for others - if (length(covariate$sd) > 0) { - badNames <- which(!names(covariate$sd) %in% names(covSD)) - if (length(badNames) > 0) { - cli::cli_abort(c( - "x" = "The {.arg sd} element of {.arg covariate} must be a list with parameter names.", - "i" = "See {.fn PM_sim} for help." - )) - } - covSD[which(names(covSD) %in% names(covariate$sd))] <- covariate$sd - covSD <- unlist(covSD) + # Generate samples for each covariate + means <- covariate$mean + cov_matrix <- pos_def(covariate$cov) # ensure covariance matrix is positive definite, function in PMutilities + if (length(cov_matrix) == 1 && cov_matrix == 1){ + return(invisible(NULL)) #quietly abort simulation + } else if (length(cov_matrix) == 1 && cov_matrix == -1){ + cli::cli_abort(c( + "x" = "Covariate parameter covariance matrix cannot be made positive definite.", + "i" = "Please check your covariance matrix." + )) } - # augmented correlation matrix to covariance - covMat <- cor2cov(corMat, unlist(c(poppar$popSD, covSD[1:nsimcov]))) - dimnames(covMat) <- dimnames(corMat) + samples <- tryCatch(TruncatedNormal::rtmvnorm(n = nrow(pars), mean = means, sigma = cov_matrix, lb = rep(0, length(means))), error = function(e) NULL) %>% + tibble::as_tibble(.name_repair = "minimal") %>% + rlang::set_names(names(means)) - # get means of covariates - covMean <- CVsum |> summarize(across(covs2sim, \(x) mean(x, na.rm = TRUE))) + # in either case, combine the pars and covariates and proceed + CVsum <- bind_cols(pars, samples, .name_repair = "minimal") %>% mutate(icen = "mean") - # set means of named variables, and use population values for others - if (length(covariate$mean) > 0) { - badNames <- which(!names(covariate$mean) %in% names(covMean)) - if (length(badNames) > 0) { - cli::cli_abort(c( - "x" = "The {.arg mean} element of {.arg covariate} must be a list with parameter names.", - "i" = "See {.fn PM_sim} for help." - )) - } - covMean[which(names(covMean) %in% names(covariate$mean))] <- covariate$mean - covMean <- unlist(covMean) + } else { # we had a PM_final_data as covariate$cov + CVsum <- covariate$cov$summary(icen = "mean") + } + + # take out fixed covariates not to be simulated + if (length(covariate$fix) > 0) { + CVsum <- CVsum %>% select(.cols = -!!covariate$fix) + } + # remove covariates that are missing because they have all the same value + # this also drops id and icen columns + CVsum <- CVsum %>% + select(where(~ dplyr::n_distinct(.) > 1)) %>% + select(-id) + + # get correlation matrix + corCV <- suppressWarnings(cor(CVsum)) + + nsimcov <- ncol(corCV) - npar + + # augment poppar correlation matrix + bind_bottom_right <- function(A, B, n) { + m <- nrow(A) + if (nrow(B) != m + n || ncol(B) != m + n) + stop("B must be of size (m + n) x (m + n)") + + # Extract blocks from B + B_right <- B[1:m, (m+1):(m+n), drop = FALSE] # top-right block + B_bottom <- B[(m+1):(m+n), 1:m, drop = FALSE] # bottom-left block + B_corner <- B[(m+1):(m+n), (m+1):(m+n), drop = FALSE] # bottom-right block + + # Assemble full matrix + top <- cbind(A, B_right) + bottom <- cbind(B_bottom, B_corner) + rbind(top, bottom) + } + + corMat <- bind_bottom_right( + as.matrix(poppar$popCor), + as.matrix(corCV), + n = nsimcov + ) + + + # get SD of covariates + covSD <- CVsum %>% summarize(across(last_col(offset = nsimcov - 1):last_col(), sd, na.rm = TRUE)) + + # grab their names + covs2sim <- names(covSD) + + # set SDs of named variables, and use population values for others + if (length(covariate$sd) > 0) { + badNames <- which(!names(covariate$sd) %in% names(covSD)) + if (length(badNames) > 0) { + cli::cli_abort(c( + "x" = "The {.arg sd} element of {.arg covariate} must be a list with parameter names.", + "i" = "See {.fn PM_sim} for help." + )) } - - - meanVector <- poppar$popMean |> tibble::add_column(!!!as.list(covMean)) - # get the covariate limits - # get min of original population covariates - covMin <- CVsum |> summarize(across(covs2sim, \(x) min(x, na.rm = TRUE))) - # and get max of original population covariates - covMax <- CVsum |> summarize(across(covs2sim, \(x) max(x, na.rm = TRUE))) - - orig_covlim <- tibble::tibble(par = covs2sim, min = unlist(covMin), max = unlist(covMax)) - covLimits <- orig_covlim - if (length(covariate$limits) > 0) { - # covariate limits are supplied as named list - badNames <- which(!names(covariate$limits) %in% names(covMean)) - if (length(badNames) > 0) { - cli::cli_abort(c( - "x" = "The {.arg limit} element of {.arg covariate} must be a list with parameter names.", - "i" = "E.g. {.code limits = list(wt = c(40, 80), age = c(10, 50))}. See {.fn PM_sim} for help." - )) - } - - # figure out which covariates have different limits and change them - - covUpdates <- tibble::enframe(covariate$limits, name = "par", value = "rng") |> - tidyr::unnest_wider(rng, names_sep = "") |> - dplyr::rename(min = rng1, max = rng2) - - covLimits <- dplyr::rows_update(covLimits, covUpdates, by = "par") - - # goodNames <- which(names(covMean) %in% names(covariate$limits)) - # if (length(goodNames) > 0) { - # covLimits[goodNames, ] <- t(sapply(1:length(goodNames), function(x) { - # covariate$limits[[x]] - # })) - # } + covSD[which(names(covSD) %in% names(covariate$sd))] <- covariate$sd + covSD <- unlist(covSD) + } + # augmented correlation matrix to covariance + covMat <- cor2cov(corMat, unlist(c(poppar$popSD, covSD[1:nsimcov]))) + dimnames(covMat) <- dimnames(corMat) + + # get means of covariates + covMean <- CVsum %>% summarize(across(covs2sim, mean, na.rm = TRUE)) + + # set means of named variables, and use population values for others + if (length(covariate$mean) > 0) { + badNames <- which(!names(covariate$mean) %in% names(covMean)) + if (length(badNames) > 0) { + cli::cli_abort(c( + "x" = "The {.arg mean} element of {.arg covariate} must be a list with parameter names.", + "i" = "See {.fn PM_sim} for help." + )) } - # dimnames(covLimits) <- list(covs2sim, c("lower", "upper")) - # covLimits <- data.frame(covLimits) - - - limits <- rbind(parLimits, covLimits) - - # add simulated covariates to primary block of model object - new_pri <- map(1:nsimcov, \(x) ab(covLimits$min[x], covLimits$max[x])) - names(new_pri) <- covs2sim - arg_list$pri <- c(arg_list$pri, new_pri) - - # remove them from the covariate block of model object + covMean[which(names(covMean) %in% names(covariate$mean))] <- covariate$mean + covMean <- unlist(covMean) + } + + + meanVector <- poppar$popMean %>% tibble::add_column(!!!as.list(covMean)) + # get the covariate limits + # get min of original population covariates + covMin <- CVsum %>% summarize(across(covs2sim, min, na.rm = TRUE)) + # and get max of original population covariates + covMax <- CVsum %>% summarize(across(covs2sim, max, na.rm = TRUE)) + + orig_covlim <- tibble::tibble(par = covs2sim, min = unlist(covMin), max = unlist(covMax)) + covLimits <- orig_covlim + if (length(covariate$limits) > 0) { - model_covs <- mod_list$covariates - covs_to_remove <- which(model_covs %in% covs2sim) - arg_list$cov <- arg_list$cov[-covs_to_remove] - if (length(arg_list$cov) == 0) { - arg_list$cov <- NULL # remove covariates if none left + # covariate limits are supplied as named list + badNames <- which(!names(covariate$limits) %in% names(covMean)) + if (length(badNames) > 0) { + cli::cli_abort(c( + "x" = "The {.arg limit} element of {.arg covariate} must be a list with parameter names.", + "i" = "E.g. {.code limits = list(wt = c(40, 80), age = c(10, 50))}. See {.fn PM_sim} for help." + )) } - # also remove them from data template - template <- template[, -which(names(template) %in% covs2sim)] - - - # remake both objects + # figure out which covariates have different limits and change them - arg_list <- PM_model$new(arg_list, compile = FALSE)$arg_list # compile later - template <- PM_data$new(template, quiet = TRUE)$standard_data + covUpdates <- tibble::enframe(covariate$limits, name = "par", value = "rng") %>% + tidyr::unnest_wider(rng, names_sep = "") %>% + dplyr::rename(min = rng1, max = rng2) + covLimits <- dplyr::rows_update(covLimits, covUpdates, by = "par") - # remake poppar - poppar$popMean <- meanVector - poppar$popCov <- covMat - - - # if split is true, augment popPoints with one covariate draw per support - # point sampled from the covariate distribution. Using a constant mean - # for every point makes the covariate columns have zero variance, - # producing a singular covariance matrix and a very high rejection rate. - if (split) { - ndist_split <- nrow(poppar$popPoints) - cov_cov_mat <- covMat[(npar + 1):(npar + nsimcov), (npar + 1):(npar + nsimcov), drop = FALSE] - cov_mean_vec <- covMean[1:nsimcov] - cov_lower <- covLimits$min - cov_upper <- covLimits$max - - # draw one covariate set per support point, rejecting out-of-bounds draws - cov_point_samples <- matrix(NA_real_, nrow = ndist_split, ncol = nsimcov, - dimnames = list(NULL, names(cov_mean_vec))) - for (.sp in seq_len(ndist_split)) { - for (.attempt in seq_len(100)) { - draw <- tryCatch( - suppressWarnings(MASS::mvrnorm(1, mu = cov_mean_vec, Sigma = cov_cov_mat)), - error = function(e) cov_mean_vec - ) - if (!any(draw < cov_lower) && !any(draw > cov_upper)) { - cov_point_samples[.sp, ] <- draw - break - } - if (.attempt == 100) cov_point_samples[.sp, ] <- cov_mean_vec # fallback to mean - } - } - - poppar$popPoints <- dplyr::bind_cols( - poppar$popPoints |> dplyr::select(-prob), - tibble::as_tibble(cov_point_samples), - poppar$popPoints |> dplyr::select(prob) - ) - } - } else { - simWithCov <- FALSE - limits <- parLimits - } # end if (covariate) block + # goodNames <- which(names(covMean) %in% names(covariate$limits)) + # if (length(goodNames) > 0) { + # covLimits[goodNames, ] <- t(sapply(1:length(goodNames), function(x) { + # covariate$limits[[x]] + # })) + # } + } + # dimnames(covLimits) <- list(covs2sim, c("lower", "upper")) + # covLimits <- data.frame(covLimits) - # regardless of covariates or not, 'limits' is the final variable for - # limits on parameters + limits <- rbind(parLimits, covLimits) + # add simulated covariates to primary block of model object + new_pri <- map(1:nsimcov, \(x) ab(covLimits$min[x], covLimits$max[x])) + names(new_pri) <- covs2sim + arg_list$pri <- c(arg_list$pri, new_pri) - # NOISE ------------------------------------------------------------------- + # remove them from the covariate block of model object - if (!all(is.null(noise))) { - # will ignore obs noise for now but add after simulation - if ("out" %in% names(noise)) { - noise1 <- noise |> purrr::list_assign(out = rlang::zap()) - noise2 <- noise["out"] - } else { - noise1 <- noise - noise2 <- NULL - } - - if (length(noise1) > 0) { - template <- private$makeNoise(template, noise1) - } - } else { - noise1 <- noise2 <- NULL + model_covs <- mod_list$covariates + covs_to_remove <- which(model_covs %in% covs2sim) + arg_list$cov <- arg_list$cov[-covs_to_remove] + if (length(arg_list$cov) == 0) { + arg_list$cov <- NULL # remove covariates if none left } + # also remove them from data template + template <- template[, -which(names(template) %in% covs2sim)] - # PRED INT ---------------------------------------------------------------- - template <- if (!all(is.null(predInt))) { - private$makePredInt(template, predInt) - } + # remake both objects - # CALL SIMULATOR ---------------------------------------------------------------- + arg_list <- PM_model$new(arg_list, compile = FALSE)$arg_list # compile later + template <- PM_data$new(template, quiet = TRUE)$standard_data - template <- PM_data$new(template, quiet = TRUE) - if (simWithCov) { # if simulating with covariates, we need to recompile the model with the new covariates - if (!quiet) cli::cli_inform("Recompiling model to include covariates...") - mod <- PM_model$new(arg_list, quiet = TRUE) # - } else { - mod <- model - } + # remake poppar + poppar$popMean <- meanVector + poppar$popCov <- covMat - if (length(postToUse) > 0) { - # simulating from posteriors, each posterior matched to a subject - # need to set theta as the posterior mean or median for each subject - ans <- NULL - data_list <- list() - for (i in 1:nsub) { - # get the prior for this subject - thisPrior <- private$getSimPrior( - i = i, - poppar = poppar, - split = split, - postToUse = postToUse[i], - limits = limits, - seed = seed[1], - nsim = nsim, - toInclude = toInclude, msg = msg - ) - # get the template for this subject - sub_template <- PM_data$new(template$standard_data |> filter(id == toInclude[i]), quiet = TRUE) - - # add the simulated values to the list - data_list <- append(data_list, list(private$getSim(thisPrior, sub_template, mod, noise2, msg = msg))) - ans <- thisPrior$ans - } + + + + # if split is true, then remake (augment) popPoints by adding mean covariate prior to each point + if (split) { - # combine the output - obs <- purrr::list_rbind(map(data_list, \(x) x$obs)) - amt <- purrr::list_rbind(map(data_list, \(x) x$amt)) + add_vector_columns <- function(df, v) { + v_df <- as_tibble(as.list(v)) # convert named vector to one-row tibble + df %>% bind_cols(v_df[rep(1, nrow(df)), ]) # replicate the row to match df + } - parValues <- purrr::list_rbind(map(data_list, \(x) x$parValues)) |> - mutate(id = rep(toInclude, each = !!nsim), nsim = rep(1:!!nsim, nsub)) |> - relocate(id, nsim) - total_means <- dplyr::bind_rows(map(data_list, \(x) x$totalMeans)) |> - mutate(id = toInclude) |> - relocate(id) - total_cov <- dplyr::bind_rows(map(data_list, \(x) data.frame(x$totalCov, row.names = NULL))) |> - mutate( - id = rep(toInclude, each = npar), - par = rep(names(poppar$popMean), !!nsub) - ) |> - relocate(id, par) - total_nsim <- tibble::tibble(id = toInclude, n = purrr::map_dbl(data_list, \(x) x$totalSets)) + poppar$popPoints <- poppar$popPoints %>% add_vector_columns(covMean) %>% select(-prob, everything(), prob) - ret <- list( - obs = obs, - amt = amt, - parValues = parValues, - totalSets = total_nsim, - totalMeans = total_means, - totalCov = total_cov, - template = template, - model = mod + } + } else { + simWithCov <- FALSE + limits <- parLimits + } # end if (covariate) block + + + # regardless of covariates or not, 'limits' is the final variable for + # limits on parameters + + + + # NOISE ------------------------------------------------------------------- + + if (!all(is.null(noise))) { + # will ignore obs noise for now but add after simulation + if ("out" %in% names(noise)) { + noise1 <- noise %>% purrr::list_assign(out = rlang::zap()) + noise2 <- noise["out"] + } else { + noise1 <- noise + noise2 <- NULL + } + + if (length(noise1) > 0) { + template <- private$makeNoise(template, noise1) + } + } else { + noise1 <- noise2 <- NULL + } + + + # PRED INT ---------------------------------------------------------------- + + template <- if (!all(is.null(predInt))) { + private$makePredInt(template, predInt) + } + + # CALL SIMULATOR ---------------------------------------------------------------- + + + template <- PM_data$new(template, quiet = TRUE) + if (simWithCov) { # if simulating with covariates, we need to recompile the model with the new covariates + if (!quiet) cli::cli_inform("Recompiling model to include covariates...") + mod <- PM_model$new(arg_list, quiet = TRUE) # + } else { + mod <- model + } + + if (length(postToUse) > 0) { + # simulating from posteriors, each posterior matched to a subject + # need to set theta as the posterior mean or median for each subject + ans <- NULL + data_list <- list() + for(i in 1:nsub){ + # get the prior for this subject + thisPrior <- private$getSimPrior( + i = i, + poppar = poppar, + split = split, + postToUse = postToUse[i], + limits = limits, + seed = seed[1], + nsim = nsim, + toInclude = toInclude, msg = msg ) + # get the template for this subject + sub_template <- PM_data$new(template$standard_data %>% filter(id == toInclude[i]), quiet = TRUE) - - class(ret) <- c("PM_sim_data", "list") - self$data <- ret - } else { # postToUse is false - - # set theta as nsim rows drawn from prior - if (!useTheta) { - thisPrior <- private$getSimPrior( - i = 1, - poppar = poppar, - split = split, - postToUse = NULL, - limits = limits, - seed = seed[1], - nsim = nsim, - toInclude = toInclude, - msg = msg - ) - } else { - thisPrior <- list(thetas = poppar$popPoints) - } - - self$data <- private$getSim(thisPrior, template, mod, noise2, msg = msg) + # add the simulated values to the list + data_list <- append(data_list, list(private$getSim(thisPrior, sub_template, mod, noise2, msg = msg))) + ans <- thisPrior$ans } + # combine the output + obs <- purrr::list_rbind(map(data_list, \(x) x$obs)) + amt <- purrr::list_rbind(map(data_list, \(x) x$amt)) + + parValues <- purrr::list_rbind(map(data_list, \(x) x$parValues)) %>% + mutate(id = rep(toInclude, each = !!nsim), nsim = rep(1:!!nsim, nsub)) %>% + relocate(id, nsim) + total_means <- dplyr::bind_rows(map(data_list, \(x) x$totalMeans)) %>% + mutate(id = toInclude) %>% + relocate(id) + total_cov <- dplyr::bind_rows(map(data_list, \(x) data.frame(x$totalCov, row.names = NULL))) %>% + mutate( + id = rep(toInclude, each = npar), + par = rep(names(poppar$popMean), !!nsub) + ) %>% + relocate(id, par) + total_nsim <- tibble::tibble(id = toInclude, n = purrr::map_dbl(data_list, \(x) x$totalSets)) + + ret <- list( + obs = obs, + amt = amt, + parValues = parValues, + totalSets = total_nsim, + totalMeans = total_means, + totalCov = total_cov, + template = template, + model = mod + ) + - # MAKE CSV ---------------------------------------------------------------- + class(ret) <- c("PM_sim_data", "list") + self$data <- ret - if (!is.null(makecsv)) { - if (nsub * nsim > 100) { - # cli_ask is in PMutilities - ans <- cli_ask("Creating a csv file with {nsub} templates * {nsim} simulations/template = {nsub * nsim} subjects can take a very long time. Do you wish to proceed (y/n)?") - if (tolower(ans) == "n") { - cat("\nAborting simulation...\n") - return() - } - } - - if (file.exists(makecsv)) { - file.remove(makecsv) + } else { # postToUse is false + + # set theta as nsim rows drawn from prior + if(!useTheta){ + thisPrior <- private$getSimPrior( + i = 1, + poppar = poppar, + split = split, + postToUse = NULL, + limits = limits, + seed = seed[1], + nsim = nsim, + toInclude = toInclude, + msg = msg + ) + } else { + thisPrior <- list(thetas = poppar$popPoints) + } + + self$data <- private$getSim(thisPrior, template, mod, noise2, msg = msg) + } + + + # MAKE CSV ---------------------------------------------------------------- + + if (!is.null(makecsv)) { + if (nsub * nsim > 100) { + # cli_ask is in PMutilities + ans <- cli_ask("Creating a csv file with {nsub} templates * {nsim} simulations/template = {nsub * nsim} subjects can take a very long time. Do you wish to proceed (y/n)?") + if (tolower(ans) == "n") { + cat("\nAborting simulation...\n") + return() } - - # cycle through template and nsims - - csv <- list() - for (i in unique(template$standard_data$id)) { - this_template <- template$standard_data |> filter(id == i) - for (j in 1:nsim) { - this_sim <- self$obs |> filter(id == i, nsim == j) - this_template$out[this_template$evid == 0] <- this_sim$out - this_template$id <- paste(i, j, sep = "_") - if (simWithCov) { # add back simulated covariate values - - this_template <- this_template |> - mutate(!!!set_names(self$parValues |> select(!!covs2sim) |> slice(j), covs2sim)) - } - csv <- append(csv, list(this_template)) + } + + if (file.exists(makecsv)) { + file.remove(makecsv) + } + + # cycle through template and nsims + + csv <- list() + for (i in unique(template$standard_data$id)) { + this_template <- template$standard_data %>% filter(id == i) + for (j in 1:nsim) { + this_sim <- self$obs %>% filter(id == i, nsim == j) + this_template$out[this_template$evid == 0] <- this_sim$out + this_template$id <- paste(i, j, sep = "_") + if(simWithCov){ #add back simulated covariate values + + this_template <- this_template %>% + mutate(!!!set_names(self$parValues %>% select(!!covs2sim) %>% slice(j), covs2sim)) } + csv <- append(csv, list(this_template)) } - - csv <- PM_data$new(list_rbind(csv), quiet = TRUE) - - if (!stringr::str_detect(makecsv, "\\..{3}$")) { - makecsv <- paste0(makecsv, ".csv") - } - csv$save(makecsv) - - cli::cli_inform("The file {.file {makecsv}} was saved in {getwd()}.") } + csv <- PM_data$new(list_rbind(csv), quiet = TRUE) - # FINAL RETURN ------------------------------------------------------------ - if (!quiet && length(msg) > 0) { - cli::cli_alert_info("Simulation messages:") - purrr::walk(msg, \(m) cli::cli_bullets(c("*" = m))) - return(invisible(NULL)) + if (!stringr::str_detect(makecsv, "\\..{3}$")) { + makecsv <- paste0(makecsv, ".csv") } - return(self) - }, # end of SIMrun + csv$save(makecsv) + + cli::cli_inform("The file {.file {makecsv}} was saved in {getwd()}.") + } + + # FINAL RETURN ------------------------------------------------------------ + if (length(msg) > 0) { + cli::cli_alert_info("Simulation messages:") + purrr::walk(msg, \(m) cli::cli_bullets(c("*" = m))) + return(invisible(NULL)) + } + return(self) + + }, # end of SIMrun + + # get prior density + getSimPrior = function(i, poppar, split, postToUse, limits, seed, nsim, toInclude, msg = NULL) { # get prior density - getSimPrior = function(i, poppar, split, postToUse, limits, seed, nsim, toInclude, msg = NULL) { - # get prior density - + + + + + if (inherits(poppar, "NPAG")) { - if (inherits(poppar, "NPAG")) { - if (nsim == 0) { # simulate each support point once - thetas <- poppar$popPoints |> mutate(prob = 1 / n()) - total_means <- poppar$popMean - total_cov <- poppar$popCov - total_nsim <- 0 - - - return(list( - thetas = thetas, total_means = total_means, - total_cov = total_cov, - total_nsim = total_nsim - )) - } + if(nsim == 0){ # simulate each support point once + thetas <- poppar$popPoints %>% mutate(prob = 1/n()) + total_means <- poppar$popMean + total_cov <- poppar$popCov + total_nsim <- 0 - if (nsim < 2 * nrow(poppar$popPoints)) { - split <- FALSE - msg <- c(msg, " {.arg split} set to {.code FALSE} for {.code nsim} less than 2 * number of support points.") - } - if (split) { - popPoints <- poppar$popPoints - pop_weight <- popPoints$prob - pop_mean <- popPoints |> select(-prob) - ndist <- nrow(popPoints) - pop_cov <- poppar$popCov / ndist - } else { # not split - if (is.null(postToUse)) { # not simulating from posteriors - pop_weight <- 1 - pop_mean <- poppar$popMean - pop_cov <- poppar$popCov - ndist <- 1 - } else { # simulating from posteriors - pop_weight <- 1 - pop_mean <- poppar$postMean[postToUse, ] |> select(-id) - pop_cov <- poppar$postCov[[postToUse]] - ndist <- 1 - } - } - } else { # manually specified prior - pop_weight <- poppar$popWeight - ndist <- length(pop_weight) - if (nsim < 2 * ndist) { - cli::cli_abort(c("x" = "The {.arg nsim} argument must be at least twice the number of modes in the prior.")) - } - pop_mean <- poppar$popMean - pop_cov <- poppar$popCov / ndist + return(list( + thetas = thetas, total_means = total_means, + total_cov = total_cov, + total_nsim = total_nsim + )) + } - # override covariance matrix to zero if nsim = 1 - if (nsim == 1) { - pop_cov <- diag(0, nrow(pop_cov)) + if (nsim < 2*nrow(poppar$popPoints)){ + split <- FALSE + msg <- c(msg, " {.arg split} set to {.code FALSE} for {.code nsim} less than 2 * number of support points.") } - pop_cov <- pos_def(pop_cov) # pos_def is in PMutilities - if (length(pop_cov) == 1 && pop_cov == 1) { - return(invisible(NULL)) # quietly abort simulation - } else if (length(pop_cov) == 1 && pop_cov == -1) { - msg <- if (!is.null(postToUse)) { - glue::glue("Unable to fix covariance for template {.code id = {toInclude[i]}}.") - } else { - "Unable to make population covariance positive definite." + if (split) { + popPoints <- poppar$popPoints + pop_weight <- popPoints$prob + pop_mean <- popPoints %>% select(-prob) + ndist <- nrow(popPoints) + pop_cov <- poppar$popCov / ndist + } else { # not split + if (is.null(postToUse)) { # not simulating from posteriors + pop_weight <- 1 + pop_mean <- poppar$popMean + pop_cov <- poppar$popCov + ndist <- 1 + } else { # simulating from posteriors + pop_weight <- 1 + pop_mean <- poppar$postMean[postToUse, ] %>% select(-id) + pop_cov <- poppar$postCov[[postToUse]] + ndist <- 1 } + } + } else { # manually specified prior + pop_weight <- poppar$popWeight + ndist <- length(pop_weight) + if (nsim < 2 * ndist) { + cli::cli_abort(c("x" = "The {.arg nsim} argument must be at least twice the number of modes in the prior.")) + } + pop_mean <- poppar$popMean + pop_cov <- poppar$popCov / ndist + } + + # override covariance matrix to zero if nsim = 1 + if (nsim == 1) { + pop_cov <- diag(0, nrow(pop_cov)) + } + + pop_cov <- pos_def(pop_cov) # pos_def is in PMutilities + if (length(pop_cov)==1 && pop_cov == 1){ + return(invisible(NULL)) #quietly abort simulation + } else if (length(pop_cov)==1 && pop_cov == -1){ + msg <- if (!is.null(postToUse)) {glue::glue("Unable to fix covariance for template {.code id = {toInclude[i]}}.")} else {"Unable to make population covariance positive definite."} + cli::cli_abort(c( + "x" = msg, + "i" = "Please check your data and covariance matrix." + )) + } + + # generate samples for theta + set.seed(seed) + thetas <- generate_multimodal_samples(nsim, pop_weight, pop_mean, pop_cov, toInclude[i], limits) + + + return(thetas) + + }, # end getSimPrior function' + + # call simulator and process results + getSim = function(thisPrior, template, mod, noise2, msg = NULL) { + thetas <- thisPrior$thetas %>% + select(-prob) %>% + as.matrix() + mod$compile() # check if compiled and if not, do so + sim_res <- mod$sim(template, thetas) + sim_res$.id <- template$standard_data$id[match(sim_res$id, template$standard_data$id)] + sim_res <- sim_res %>% + rename(comp = state_index, nsim = spp_index, amt = state) %>% + mutate(across(c(outeq, comp, nsim), \(x) x <- x + 1)) %>% + arrange(.id, comp, nsim, time, outeq) %>% + select(-.id) + + obs <- sim_res %>% filter(comp == 1) %>% # obs are duplicated in every compartment + select(id, nsim, time, out, outeq) + + amt <- sim_res %>% + select(id, nsim, time, out = amt, comp) + + # add output noise if specified + if (!all(is.null(noise2))) { + obs <- private$makeNoise(obs, noise2) + } + + ret <- list( + obs = obs, + amt = amt, + parValues = thisPrior$thetas %>% select(-prob) %>% + mutate(nsim = 1:n()) %>% relocate(nsim), + totalSets = thisPrior$total_nsim, + totalMeans = thisPrior$total_means, + totalCov = thisPrior$total_cov, + template = template, + model = mod + ) + + + class(ret) <- c("PM_sim_data", "list") # add PM_sim_data class to data + return(ret) + }, # end .sim function + + # Create new simulation objects with results of simulation + populate = function(simout, type) { + if (type == "sim") { + # self$obs <- simout$obs + # self$amt <- simout$amt + # self$parValues <- simout$parValues + # self$totalMeans <- simout$totalMeans + # self$totalCov <- simout$totalCov + self$data <- simout + class(self$data) <- c("PM_sim_data", "list") + } else if (type == "simlist") { + N <- length(simout) # number of templates + nsim <- max(simout[[1]]$obs$id) + obs <- purrr::list_rbind(map(1:N, \(x) pluck(simout, x, 1)), names_to = "id2") %>% rename(nsim = id, id = id2) + amt <- purrr::list_rbind(map(1:N, \(x) pluck(simout, x, 2)), names_to = "id2") %>% rename(nsim = id, id = id2) + parValues <- purrr::list_rbind(map(1:N, \(x) pluck(simout, x, 3)), names_to = "id2") %>% rename(nsim = id, id = id2) + totalSets <- map(1:N, \(x) simout[[x]]$totalSets) + totalMeans <- map(1:N, \(x) pluck(simout, x, 5)) + totalCov <- map(1:N, \(x) data.frame(pluck(simout, x, 6))) + self$data <- list( + obs = obs, + amt = amt, + parValues = parValues, + totalSets = totalSets, + totalMeans = totalMeans, + totalCov = totalCov + ) + } else if (type == "R6sim") { + # self$obs <- simout$data$obs + # self$amt <- simout$data$amt + # self$parValues <- simout$data$parValues + # self$totalMeans <- simout$data$totalMeans + # self$totalCov <- simout$data$totalCov + if (inherits(simout$data, "PM_simlist")) { + purrr::map(1:length(simout$data), \(x){ + class(simout$data[[x]]) <- c("PM_sim_data", "list") # ensure class is correct + }) + } else { + class(simout$data) <- c("PM_sim_data", "list") # ensure class is correct + } + self$data <- simout$data + } + return(self) + }, # end populate + + makeNoise = function(template, noise) { + if (!is.list(noise)) { + cli::cli_warn(c( + "!" = "Noise arguments should be a list.", + "i" = "See ?PM_data for details on how to add noise." + )) + return(invisible(template)) + } + + for (i in 1:length(noise)) { + this <- noise[[i]] + this$.col <- names(noise)[i] + if (this$.col %in% c("id", "evid", "addl", "ii", "input", "outeq", "c0", "c1", "c2", "c3")) { cli::cli_abort(c( - "x" = msg, - "i" = "Please check your data and covariance matrix." + "x" = "{.arg {this$.col}} is a reserved column name.", + "i" = "Please choose another column to add noise." )) } + this$coeff <- this[[1]] + if (is.null(this$mode)) { + this$mode <- "add" + } - # generate samples for theta - set.seed(seed) - thetas <- generate_multimodal_samples(nsim, pop_weight, pop_mean, pop_cov, toInclude[i], limits) - - - return(thetas) - }, # end getSimPrior function' - - # call simulator and process results - getSim = function(thisPrior, template, mod, noise2, msg = NULL) { - thetas <- thisPrior$thetas |> - select(-prob) |> - as.matrix() - mod$compile() # check if compiled and if not, do so - sim_res <- mod$sim(template, thetas) - sim_res$.id <- template$standard_data$id[match(sim_res$id, template$standard_data$id)] - sim_res <- sim_res |> - rename(comp = state_index, nsim = spp_index, amt = state) |> - mutate(nsim = nsim + 1) - - # The simulation engine reports 0-based output and compartment indices; - # normalize both to the 1-based convention used throughout Pmetrics. - sim_res <- sim_res |> - mutate( - outeq = normalize_engine_index(outeq), - comp = normalize_engine_index(comp) - ) - - sim_res <- sim_res |> - arrange(.id, comp, nsim, time, outeq) |> - select(-.id) + # add zeros to coefficients if needed to make up to length 4 + if (length(this$coeff) < 4) { + this$coeff <- c(this$coeff, rep(0, 4 - length(this$coeff))) + } - obs <- sim_res |> filter(comp == min(comp, na.rm = TRUE)) |> # obs are duplicated in every compartment - select(id, nsim, time, out, outeq) + # Ensure target is a column in standard_data + if (!this$.col %in% names(template)) { + cli::cli_abort(c( + "x" = "{.arg {this$.col}} is not a column in your data.", + "i" = "Example: {.code noise = list(dose = list(coeff = c(0.1, 0.1)))}" + )) + } - amt <- sim_res |> - select(id, nsim, time, out = amt, comp) + # make temporary row index to preserve order later + template$index_ <- 1:nrow(template) + + # Dynamically apply the filter + if (!is.null(this$filter)) { + filter_status <- "filtered" + filter_exprs <- rlang::parse_expr(this$filter) + filtered_data <- template %>% + filter(!!filter_exprs) + # Keep the rest + remaining_data <- template %>% + filter(magrittr::not(!!filter_exprs)) + } else { + filter_status <- "" + filtered_data <- template + remaining_data <- NULL + } - # add output noise if specified - if (!all(is.null(noise2))) { - obs <- private$makeNoise(obs, noise2) + # Get the target + target_col <- filtered_data %>% select(id, raw = all_of(this$.col)) + + + # Remove temp row index + template <- template %>% select(-index_) + + # Add noise + new_target <- data.frame(1:nrow(target_col)) + names(new_target) <- this$.col + if (this$mode == "add") { + target_col <- target_col %>% + rowwise() %>% + mutate(noisy = raw + suppressWarnings(rnorm(1, + mean = 0, + sd = this$coeff[[1]] + + this$coeff[[2]] * raw + + this$coeff[[3]] * raw^2 + + this$coeff[[4]] * raw^3 + ))) %>% + ungroup() + } else if (this$mode == "exp") { + target_col <- target_col %>% + rowwise() %>% + mutate(noisy = raw * exp(suppressWarnings(rnorm(1, + mean = 0, + sd = this$coeff[[1]] + + this$coeff[[2]] * raw + + this$coeff[[3]] * raw^2 + + this$coeff[[4]] * raw^3 + )))) %>% + ungroup() + } else { + cli::cli_abort("x" = "Mode must be 'add' or 'exp'.") } - ret <- list( - obs = obs, - amt = amt, - parValues = thisPrior$thetas |> select(-prob) |> - mutate(nsim = 1:n()) |> relocate(nsim), - totalSets = thisPrior$total_nsim, - totalMeans = thisPrior$total_means, - totalCov = thisPrior$total_cov, - template = template, - model = mod - ) + # put back the new noisy column + filtered_data[[this$.col]] <- target_col$noisy + combined <- bind_rows(filtered_data, remaining_data) %>% + arrange(index_) %>% + select(-index_) + # Fix initial times to be 0 in case they were mutated + combined[!duplicated(combined$id), "time"] <- 0 - class(ret) <- c("PM_sim_data", "list") # add PM_sim_data class to data - return(ret) - }, # end .sim function - - # Create new simulation objects with results of simulation - populate = function(simout, type) { - if (type == "sim") { - # self$obs <- simout$obs - # self$amt <- simout$amt - # self$parValues <- simout$parValues - # self$totalMeans <- simout$totalMeans - # self$totalCov <- simout$totalCov - self$data <- simout - class(self$data) <- c("PM_sim_data", "list") - } else if (type == "simlist") { - N <- length(simout) # number of templates - nsim <- max(simout[[1]]$obs$id) - obs <- purrr::list_rbind(map(1:N, \(x) pluck(simout, x, 1)), names_to = "id2") |> rename(nsim = id, id = id2) - amt <- purrr::list_rbind(map(1:N, \(x) pluck(simout, x, 2)), names_to = "id2") |> rename(nsim = id, id = id2) - parValues <- purrr::list_rbind(map(1:N, \(x) pluck(simout, x, 3)), names_to = "id2") |> rename(nsim = id, id = id2) - totalSets <- map(1:N, \(x) simout[[x]]$totalSets) - totalMeans <- map(1:N, \(x) pluck(simout, x, 5)) - totalCov <- map(1:N, \(x) data.frame(pluck(simout, x, 6))) - self$data <- list( - obs = obs, - amt = amt, - parValues = parValues, - totalSets = totalSets, - totalMeans = totalMeans, - totalCov = totalCov - ) - } else if (type == "R6sim") { - # self$obs <- simout$data$obs - # self$amt <- simout$data$amt - # self$parValues <- simout$data$parValues - # self$totalMeans <- simout$data$totalMeans - # self$totalCov <- simout$data$totalCov - if (inherits(simout$data, "PM_simlist")) { - purrr::map(1:length(simout$data), \(x){ - class(simout$data[[x]]) <- c("PM_sim_data", "list") # ensure class is correct - }) - } else { - class(simout$data) <- c("PM_sim_data", "list") # ensure class is correct - } - self$data <- simout$data - } - return(self) - }, # end populate + template <- combined + } # end for loop for each noise element - makeNoise = function(template, noise) { - if (!is.list(noise)) { - cli::cli_warn(c( - "!" = "Noise arguments should be a list.", - "i" = "See ?PM_data for details on how to add noise." - )) - return(invisible(template)) + return(template) + }, # end makeNoise function + + makePredInt = function(template, predInt) { + predTimes <- NA + numeqt <- max(template$outeq, na.rm = TRUE) + if (is.list(predInt)) { + # predInt is a list of (start,end,interval) + if (any(sapply(predInt, length) != 3)) { + cli::cli_abort(c("x" = "If a list, each element of predInt must be of the form {.code c(start, end, interval)}.")) } - - for (i in 1:length(noise)) { - this <- noise[[i]] - this$.col <- names(noise)[i] - if (this$.col %in% c("id", "evid", "addl", "ii", "input", "outeq", "c0", "c1", "c2", "c3")) { - cli::cli_abort(c( - "x" = "{.arg {this$.col}} is a reserved column name.", - "i" = "Please choose another column to add noise." - )) - } - this$coeff <- this[[1]] - if (is.null(this$mode)) { - this$mode <- "add" - } - - # add zeros to coefficients if needed to make up to length 4 - if (length(this$coeff) < 4) { - this$coeff <- c(this$coeff, rep(0, 4 - length(this$coeff))) - } - - # Ensure target is a column in standard_data - if (!this$.col %in% names(template)) { - cli::cli_abort(c( - "x" = "{.arg {this$.col}} is not a column in your data.", - "i" = "Example: {.code noise = list(dose = list(coeff = c(0.1, 0.1)))}" - )) - } - - # make temporary row index to preserve order later - template$index_ <- 1:nrow(template) - - # Dynamically apply the filter - if (!is.null(this$filter)) { - filter_status <- "filtered" - filter_exprs <- rlang::parse_expr(this$filter) - filtered_data <- template |> - filter(!!filter_exprs) - # Keep the rest - remaining_data <- template |> - filter(magrittr::not(!!filter_exprs)) - } else { - filter_status <- "" - filtered_data <- template - remaining_data <- NULL - } - - # Get the target - target_col <- filtered_data |> select(id, raw = all_of(this$.col)) - - - # Remove temp row index - template <- template |> select(-index_) - - # Add noise - new_target <- data.frame(1:nrow(target_col)) - names(new_target) <- this$.col - if (this$mode == "add") { - target_col <- target_col |> - rowwise() |> - mutate(noisy = raw + suppressWarnings(rnorm(1, - mean = 0, - sd = this$coeff[[1]] + - this$coeff[[2]] * raw + - this$coeff[[3]] * raw^2 + - this$coeff[[4]] * raw^3 - ))) |> - ungroup() - } else if (this$mode == "exp") { - target_col <- target_col |> - rowwise() |> - mutate(noisy = raw * exp(suppressWarnings(rnorm(1, - mean = 0, - sd = this$coeff[[1]] + - this$coeff[[2]] * raw + - this$coeff[[3]] * raw^2 + - this$coeff[[4]] * raw^3 - )))) |> - ungroup() - } else { - cli::cli_abort("x" = "Mode must be 'add' or 'exp'.") - } - - # put back the new noisy column - filtered_data[[this$.col]] <- target_col$noisy - - combined <- bind_rows(filtered_data, remaining_data) |> - arrange(index_) |> - select(-index_) - # Fix initial times to be 0 in case they were mutated - combined[!duplicated(combined$id), "time"] <- 0 - - template <- combined - } # end for loop for each noise element - - return(template) - }, # end makeNoise function - - makePredInt = function(template, predInt) { - predTimes <- NA - numeqt <- max(template$outeq, na.rm = TRUE) - if (is.list(predInt)) { - # predInt is a list of (start,end,interval) - if (any(sapply(predInt, length) != 3)) { - cli::cli_abort(c("x" = "If a list, each element of predInt must be of the form {.code c(start, end, interval)}.")) + predTimes <- sapply(predInt, function(x) rep(seq(x[1], x[2], x[3]), each = numeqt)) + # catenate columns into single vector + predTimes <- unlist(predTimes) + } else { + # predTimes is not a list + if (length(predInt) == 1) { + # predInt is a single value + if (predInt != 0) { + # it is not zero + predTimes <- rep(seq(0, ceiling(max(template$time, na.rm = T)), predInt)[-1], each = numeqt) } - predTimes <- sapply(predInt, function(x) rep(seq(x[1], x[2], x[3]), each = numeqt)) - # catenate columns into single vector - predTimes <- unlist(predTimes) + # it was 0 so do nothing } else { - # predTimes is not a list - if (length(predInt) == 1) { - # predInt is a single value - if (predInt != 0) { - # it is not zero - predTimes <- rep(seq(0, ceiling(max(template$time, na.rm = T)), predInt)[-1], each = numeqt) - } - # it was 0 so do nothing + # predInt is a single vector of c(start,stop,interval) + if (length(predInt) == 3) { + predTimes <- rep(seq(predInt[1], predInt[2], predInt[3]), each = numeqt) } else { - # predInt is a single vector of c(start,stop,interval) - if (length(predInt) == 3) { - predTimes <- rep(seq(predInt[1], predInt[2], predInt[3]), each = numeqt) - } else { - cli::cli_abort(c( - "x" = "{.var predInt} is misspecified.", - "i" = "See help for {.fn PM_sim}." - )) - } + cli::cli_abort(c( + "x" = "{.var predInt} is misspecified.", + "i" = "See help for {.fn PM_sim}." + )) } } - - # first, add temporary index to ensure id order remains the same - dat2 <- template |> - mutate(.id = dplyr::dense_rank(id)) - - # second, add predInt if necessary - if (!is.na(predTimes[1])) { - predTimes <- predTimes[predTimes > 0] # remove predictions at time 0 - dat3 <- dat2 |> - group_by(.id) |> - group_map(~ { - theseTimes <- predTimes[!predTimes %in% .x$time[.x$evid == 0]] # remove prediction times at times that are specified in template - numPred <- length(theseTimes) - newPred <- data.frame(matrix(NA, nrow = numPred, ncol = 1 + ncol(.x))) - names(newPred) <- c(".id", names(.x)) - newPred[, 1] <- .y # .id - newPred[, 2] <- .x$id[1] # original id - newPred[, 3] <- 0 # evid - newPred[, 4] <- theseTimes # time - newPred[, 10] <- 1 # out - newPred[, 11] <- rep(1:numeqt, numPred / numeqt) # outeq - newPred - }) |> - bind_rows() - new_dat <- bind_rows(dat2, dat3) |> - arrange(.id, time, outeq) |> - select(-.id) - } else { # predInt was not specified - new_dat <- template # the original data without .id - } - new_dat <- new_dat |> mutate(out = ifelse(evid == 0, -1, NA)) # replace all obs with -1 since simulating - return(new_dat) - } # end makePredInt function - ) # end private - ) # end PM_sim - - - #' @keywords internal - #' @name PM_sim - #' @export - PM_sim$run <- function(...) { - lifecycle::deprecate_warn("2.1.0", "PM_sim$run()", details = "Please use PM_sim$new() instead. ?PM_sim for details.") - } - - #' @keywords internal - #' @name PM_sim - #' @export - PM_sim$load <- function(...) { - lifecycle::deprecate_warn("2.1.0", "PM_sim$load()", details = "Please use PM_sim$new() instead. ?PM_sim for details.") - } - - # PLOT -------------------------------------------------------------------- - #' @title Plot Pmetrics Simulation Objects - #' @description - #' `r lifecycle::badge('stable')` - #' - #' Plots *PM_sim* objects with the option to perform a visual and numerical predictive check - #' @details - #' Simulated observations are plotted as quantiles on the y-axis vs. time on the x.axis. If measured - #' observations are included, a visual and numerical predictive check will be performed. - #' The default plot is to omit markers, but if the marker argument is set to `TRUE`, - #' the resulting marker will have the following plotly properties: - #' `list(symbol = "circle-open", color = "black", size = 8)`. By default a grid is - #' omitted. The legend is also omitted by default, but if included, - #' clicking on a quantile item in the legend will hide it in the plot, - #' and double clicking will hide all other quantiles. - #' - #' @method plot PM_sim - #' @param x The name of an *PM_sim* data object generated by [PM_sim] - #' @param include `r template("include")`. - #' @param exclude `r template("exclude")`. - #' @param mult `r template("mult")` - #' @param ci Width of confidence interval bands around simulated quantiles, - #' from 0 to 1. If 0, or *nsim*<100, will not plot. - #' Default is 0.95, i.e. 95th percentile with tails of 2.5 percent above and below excluded. - #' @param binSize Width of binning interval for simulated concentrations, in time units, e.g. hours. - #' A `binSize` of 0.5 will pull all simulated concentrations +/- 0.5 hours into - #' the same time. This is useful - #' for plotting PMsim objects made during [make_valid]. The default is 0, i.e. no binning. - #' If an `obs` object is provided, it will be binned similarly. - #' @param outeq `r template("outeq")` - #' @param line Controls the appearance of lines. It can be specified in several ways. - #' * Default is `TRUE` which results in simulated profiles summarized - #' as quantiles, with default values of 0.05, 0.25, 0.5, 0.75, and 0.95. The default - #' format will be applied, which is solid black lines of width 1. - #' Numerical predictive checking will be calculated if observations are also included - #' (see *obs* below). - #' * `FALSE` results in no lines plotted and the plot will be blank. - #' * `NA` Quantile summaries will be suppressed, but lines joining simulated outputs - #' will be plotted in default format as above. In other words, all profiles will be plotted, - #' not just the quantiles. Numerical predictive checking will be suppressed. - #' * List of quantiles and formats to plot with the following elements: - #' - `probs` Vector of quantiles to include. If missing, will be set to - #' defaults above, i.e., `c(0.05, 0.5, and 0.95)` - #' Example: `line = list(probs = c(0.25, 0.5, 0.75))`. - #' - `color` Vector of color names whose order corresponds to `probs`. - #' If shorter than `probs`, will be recycled. Default is "dodgerblue", but if - #' median is present (`prob = 0.5`), that line will be "red". - #' Examples: `line = list(color = "red")` or `line = list(color = c("red", "blue"))`. - #' - `fill` Fill color between quantile lines. Can be specified in several ways: - #' * `FALSE` (the default) will not fill between lines. - #' * `TRUE` will fill between lines with a default color of "dodgerblue", opacity 0.2. - #' * A list with the following elements: - #' - `color` Fill color name. Default is "dodgerblue", e.g., `fill = list(color = "red")`. - #' - `opacity` Fill opacity. Default is 0.2 e.g., `fill = list(opacity = 0.3)`. - #' - `probs` Vector of paired quantiles to fill between. Default is the minimum and maximum - #' quantile specified in `probs`, or `fill = list(probs = c(0.05, 0.95))` if not specified. - #' Including `probs` in fill which are not in `probs` above will result in an error. - #' - `width` Vector of widths in pixels, as for `color`. Default is 1. - #' Example: `line = list(width = 2)`. - #' - `dash` Vector of dash types, as for color. Default is "solid". - #' See `plotly::schema()`, traces > scatter > attributes > line > dash > values. - #' Example: `line = list(dash = "dashdot")`. - #' @param marker `r template("marker")` Formatting will only be applied to observations - #' if included via the `obs` argument. - #' @param obs The name of a [PM_result] data object or the PM_op field in the - #' PM_result object, all generated by [PM_load]. For example, if - #' `run1 <- PM_load(1)` and `sim1` is a PM_sim object, then - #' `sim1$plot(obs = run1)` or `sim1$plot(obs = run1$op)`. - #' If specified, - #' the observations will be overlaid upon the simulation plot - #' enabling a visual predictive check. In this case, - #' a list object will be returned with two items: $npc containing the quantiles - #' and probability that the observations - #' are below each quantile (binomial test); and $simsum, the times of each - #' observation and the - #' value of the simulated quantile with upper and lower confidence intervals at that time. - #' Additionally, the number of observations beyond the 5th and 95th percentiles will be reported - #' and the binomial test P-value if this number is different than the expected 10% value. - #' @param quiet If `TRUE`, suppresses the message about simulation report generation, defaults to `FALSE`. - #' @param legend `r template("legend")` Default is `FALSE` - #' @param log `r template("log")` Default is `TRUE`. - #' @param grid `r template("grid")` Default is `FALSE` - #' @param xlab `r template("xlab")` Default is "Time". - #' @param ylab `r template("ylab")` Default is "Output". - #' @param title `r template("title")` Default is to have no title. - #' @param xlim `r template("xlim")` - #' @param ylim `r template("ylim")` - #' @param print If `TRUE`, will print the plotly object and return it. If `FALSE`, will only return the plotly object. - #' @param ... `r template("dotsPlotly")` - #' @return Plots the simulation object. If `obs` is included, a list will be returned with - #' the folowing items: - #' * *npc* A dataframe with three columns: quantile, prop_less, pval. - #' ** *quantile* are those specified by the `probs` argument to the plot call - #' ** *prop_less* are the proportion of simulated - #' observations at all times less than the quantile - #' ** *pval* is the P-value of the difference in the - #' prop.less and quantile by the beta-binomial test. - #' * *simsum* A dataframe with the quantile concentration at each simulated time, - #' with lower and upper confidence intervals - #' * *obs* A data frame similar to a the `$data` field of a [PM_op] object - #' with the addition of the quantile for each observation - #' @author Michael Neely - #' @seealso [PM_sim], [plot_ly], [schema] - #' @importFrom tidyr unnest_longer - #' @importFrom dplyr summarize - #' @export - #' @examples - #' \dontrun{ - #' simEx$plot() - #' simEx$plot(log = FALSE, line = list(color = "orange")) - #' } - - #' @family PMplots - - plot.PM_sim <- function( - x, - include, - exclude, - mult = 1, - ci = 0.95, - binSize = 0, - outeq = 1, - line = TRUE, - marker = FALSE, - obs, - quiet = FALSE, - legend = FALSE, - log = TRUE, - grid = FALSE, - xlab, ylab, - title, - xlim, ylim, - print = TRUE, ... - ) { + } + + # first, add temporary index to ensure id order remains the same + dat2 <- template %>% + mutate(.id = dplyr::dense_rank(id)) + + # second, add predInt if necessary + if (!is.na(predTimes[1])) { + predTimes <- predTimes[predTimes > 0] # remove predictions at time 0 + dat3 <- dat2 %>% + group_by(.id) %>% + group_map(~ { + theseTimes <- predTimes[!predTimes %in% .x$time[.x$evid == 0]] # remove prediction times at times that are specified in template + numPred <- length(theseTimes) + newPred <- data.frame(matrix(NA, nrow = numPred, ncol = 1 + ncol(.x))) + names(newPred) <- c(".id", names(.x)) + newPred[, 1] <- .y # .id + newPred[, 2] <- .x$id[1] # original id + newPred[, 3] <- 0 # evid + newPred[, 4] <- theseTimes # time + newPred[, 10] <- 1 # out + newPred[, 11] <- rep(1:numeqt, numPred / numeqt) # outeq + newPred + }) %>% + bind_rows() + new_dat <- bind_rows(dat2, dat3) %>% + arrange(.id, time, outeq) %>% + select(-.id) + } else { # predInt was not specified + new_dat <- template # the original data without .id + } + new_dat <- new_dat %>% mutate(out = ifelse(evid == 0, -1, NA)) # replace all obs with -1 since simulating + return(new_dat) + } # end makePredInt function + ) # end private +) # end PM_sim + + +#' @keywords internal +#' @name PM_sim +#' @export +PM_sim$run <- function(...) { + lifecycle::deprecate_warn("2.1.0", "PM_sim$run()", details = "Please use PM_sim$new() instead. ?PM_sim for details.") +} + +#' @keywords internal +#' @name PM_sim +#' @export +PM_sim$load <- function(...) { + lifecycle::deprecate_warn("2.1.0", "PM_sim$load()", details = "Please use PM_sim$new() instead. ?PM_sim for details.") +} + +# PLOT -------------------------------------------------------------------- +#' @title Plot Pmetrics Simulation Objects +#' @description +#' `r lifecycle::badge('stable')` +#' +#' Plots *PM_sim* objects with the option to perform a visual and numerical predictive check +#' @details +#' Simulated observations are plotted as quantiles on the y-axis vs. time on the x.axis. If measured +#' observations are included, a visual and numerical predictive check will be performed. +#' The default plot is to omit markers, but if the marker argument is set to `TRUE`, +#' the resulting marker will have the following plotly properties: +#' `list(symbol = "circle-open", color = "black", size = 8)`. By default a grid is +#' omitted. The legend is also omitted by default, but if included, +#' clicking on a quantile item in the legend will hide it in the plot, +#' and double clicking will hide all other quantiles. +#' +#' @method plot PM_sim +#' @param x The name of an *PM_sim* data object generated by [PM_sim] +#' @param include `r template("include")`. +#' @param exclude `r template("exclude")`. +#' @param mult `r template("mult")` +#' @param ci Width of confidence interval bands around simulated quantiles, +#' from 0 to 1. If 0, or *nsim*<100, will not plot. +#' Default is 0.95, i.e. 95th percentile with tails of 2.5 percent above and below excluded. +#' @param binSize Width of binning interval for simulated concentrations, in time units, e.g. hours. +#' A `binSize` of 0.5 will pull all simulated concentrations +/- 0.5 hours into +#' the same time. This is useful +#' for plotting PMsim objects made during [make_valid]. The default is 0, i.e. no binning. +#' If an `obs` object is provided, it will be binned similarly. +#' @param outeq `r template("outeq")` +#' @param line Controls the appearance of lines. It can be specified in several ways. +#' * Default is `TRUE` which results in simulated profiles summarized +#' as quantiles, with default values of 0.05, 0.25, 0.5, 0.75, and 0.95. The default +#' format will be applied, which is solid black lines of width 1. +#' Numerical predictive checking will be calculated if observations are also included +#' (see *obs* below). +#' * `FALSE` results in no lines plotted and the plot will be blank. +#' * `NA` Quantile summaries will be suppressed, but lines joining simulated outputs +#' will be plotted in default format as above. In other words, all profiles will be plotted, +#' not just the quantiles. Numerical predictive checking will be suppressed. +#' * List of quantiles and formats to plot with the following elements: +#' - `probs` Vector of quantiles to include. If missing, will be set to +#' defaults above, i.e., `c(0.05, 0.5, and 0.95)` +#' Example: `line = list(probs = c(0.25, 0.5, 0.75))`. +#' - `color` Vector of color names whose order corresponds to `probs`. +#' If shorter than `probs`, will be recycled. Default is "dodgerblue", but if +#' median is present (`prob = 0.5`), that line will be "red". +#' Examples: `line = list(color = "red")` or `line = list(color = c("red", "blue"))`. +#' - `fill` Fill color between quantile lines. Can be specified in several ways: +#' * `FALSE` (the default) will not fill between lines. +#' * `TRUE` will fill between lines with a default color of "dodgerblue", opacity 0.2. +#' * A list with the following elements: +#' - `color` Fill color name. Default is "dodgerblue", e.g., `fill = list(color = "red")`. +#' - `opacity` Fill opacity. Default is 0.2 e.g., `fill = list(opacity = 0.3)`. +#' - `probs` Vector of paired quantiles to fill between. Default is the minimum and maximum +#' quantile specified in `probs`, or `fill = list(probs = c(0.05, 0.95))` if not specified. +#' Including `probs` in fill which are not in `probs` above will result in an error. +#' - `width` Vector of widths in pixels, as for `color`. Default is 1. +#' Example: `line = list(width = 2)`. +#' - `dash` Vector of dash types, as for color. Default is "solid". +#' See `plotly::schema()`, traces > scatter > attributes > line > dash > values. +#' Example: `line = list(dash = "dashdot")`. +#' @param marker `r template("marker")` Formatting will only be applied to observations +#' if included via the `obs` argument. +#' @param obs The name of a [PM_result] data object or the PM_op field in the +#' PM_result object, all generated by [PM_load]. For example, if +#' `run1 <- PM_load(1)` and `sim1` is a PM_sim object, then +#' `sim1$plot(obs = run1)` or `sim1$plot(obs = run1$op)`. +#' If specified, +#' the observations will be overlaid upon the simulation plot +#' enabling a visual predictive check. In this case, +#' a list object will be returned with two items: $npc containing the quantiles +#' and probability that the observations +#' are below each quantile (binomial test); and $simsum, the times of each +#' observation and the +#' value of the simulated quantile with upper and lower confidence intervals at that time. +#' Additionally, the number of observations beyond the 5th and 95th percentiles will be reported +#' and the binomial test P-value if this number is different than the expected 10% value. +#' @param quiet If `TRUE`, suppresses the message about simulation report generation, defaults to `FALSE`. +#' @param legend `r template("legend")` Default is `FALSE` +#' @param log `r template("log")` Default is `TRUE`. +#' @param grid `r template("grid")` Default is `FALSE` +#' @param xlab `r template("xlab")` Default is "Time". +#' @param ylab `r template("ylab")` Default is "Output". +#' @param title `r template("title")` Default is to have no title. +#' @param xlim `r template("xlim")` +#' @param ylim `r template("ylim")` +#' @param print If `TRUE`, will print the plotly object and return it. If `FALSE`, will only return the plotly object. +#' @param ... `r template("dotsPlotly")` +#' @return Plots the simulation object. If `obs` is included, a list will be returned with +#' the folowing items: +#' * *npc* A dataframe with three columns: quantile, prop_less, pval. +#' ** *quantile* are those specified by the `probs` argument to the plot call +#' ** *prop_less* are the proportion of simulated +#' observations at all times less than the quantile +#' ** *pval* is the P-value of the difference in the +#' prop.less and quantile by the beta-binomial test. +#' * *simsum* A dataframe with the quantile concentration at each simulated time, +#' with lower and upper confidence intervals +#' * *obs* A data frame similar to a the `$data` field of a [PM_op] object +#' with the addition of the quantile for each observation +#' @author Michael Neely +#' @seealso [PM_sim], [plot_ly], [schema] +#' @importFrom tidyr unnest_longer +#' @importFrom dplyr summarize +#' @export +#' @examples +#' \dontrun{ +#' simEx$plot() +#' simEx$plot(log = FALSE, line = list(color = "orange")) +#' } + +#' @family PMplots + +plot.PM_sim <- function(x, + include, + exclude, + mult = 1, + ci = 0.95, + binSize = 0, + outeq = 1, + line = TRUE, + marker = FALSE, + obs, + quiet = FALSE, + legend = FALSE, + log = TRUE, + grid = FALSE, + xlab, ylab, + title, + xlim, ylim, + print = TRUE, ...) { if (all(is.na(line))) { line <- list(probs = NA) } # standardize @@ -2070,7 +1981,7 @@ PM_sim <- R6::R6Class( lineList$color <- rep(line$color, nprobs)[1:nprobs] } else { lineList$color <- rep("dodgerblue", nprobs) - # color median red if present + #color median red if present medProb <- which(lineList$probs == 0.5) if (length(medProb) == 0) { lineList$color[medProb] <- "red" @@ -2092,15 +2003,17 @@ PM_sim <- R6::R6Class( line$fill$probs <- range(lineList$probs) } lineList$fill <- line$fill + } else { cli::cli_abort(c( "x" = "{.arg fill} is misspecified.", "i" = "If you want to specify fill between quantiles, use {.code line = list(fill = list(...), ...)}." )) + } - } + } - if (!is.null(lineList$fill$probs) && !all(lineList$fill$probs %in% lineList$probs)) { + if(!is.null(lineList$fill$probs) && !all(lineList$fill$probs %in% lineList$probs)) { cli::cli_abort(c( "x" = "{.arg fill} quantiles must be a subset of {.arg probs}.", "i" = "Please check your {.code line} argument." @@ -2122,8 +2035,8 @@ PM_sim <- R6::R6Class( probValues <- lineList$probs - probFormats <- lineList[-1] |> - purrr::transpose() |> + probFormats <- lineList[-1] %>% + purrr::transpose() %>% purrr::simplify_all() join <- amendLine(probFormats[[1]]) @@ -2225,10 +2138,11 @@ PM_sim <- R6::R6Class( )) } + # include/exclude template ids if (missing(include)) include <- unique(simout$obs$id) if (missing(exclude)) exclude <- NA - simout$obs <- simout$obs |> includeExclude(include, exclude) + simout$obs <- simout$obs %>% includeExclude(include, exclude) if (!missing(obs)) { if (!inherits(obs, c("PM_result", "PM_op"))) { @@ -2240,11 +2154,11 @@ PM_sim <- R6::R6Class( if (inherits(obs, "PM_op")) { obs <- obs$data } - obs <- obs |> + obs <- obs %>% filter( outeq == !!outeq, icen == "median", pred.type == "post" - ) |> + ) %>% select(id, time, obs) # just need obs; median and post are arbitrary } else { obs <- data.frame(time = NA, obs = NA) @@ -2281,14 +2195,14 @@ PM_sim <- R6::R6Class( if (binSize > 0) { binned_sim_times <- seq(floor(min(sim_out$time, na.rm = TRUE)), ceiling(max(sim_out$time, na.rm = TRUE)), binSize) sim_out$time <- binned_sim_times[.bincode(sim_out$time, binned_sim_times, include.lowest = TRUE)] - sim_out <- sim_out |> - group_by(id, time, outeq) |> + sim_out <- sim_out %>% + group_by(id, time, outeq) %>% summarize(out = mean(out), .groups = "drop") if (!all(is.na(obs$obs))) { binned_obs_times <- seq(floor(min(obs$time, na.rm = TRUE)), ceiling(max(obs$time, na.rm = TRUE)), binSize) obs$time <- binned_obs_times[.bincode(obs$time, binned_obs_times, include.lowest = TRUE)] - obs <- obs |> - group_by(id, time) |> + obs <- obs %>% + group_by(id, time) %>% summarize(obs = mean(obs), .groups = "drop") } } @@ -2297,21 +2211,21 @@ PM_sim <- R6::R6Class( nsim <- nrow(simout$parValues) - sim <- sim_out |> filter(outeq == !!outeq) + sim <- sim_out %>% filter(outeq == !!outeq) times <- sort(unique(sim$time)) nobs <- length(times) if (!all(is.na(probValues)) & nsim >= 10) { # make DF of time, quantile and value - sim_quant_df <- sim |> - dplyr::group_by(time) |> - group_map(~ quantile(.x$out, probs = probValues, na.rm = TRUE)) |> - dplyr::tibble() |> - tidyr::unnest_longer(1, indices_to = "quantile", values_to = "value") |> + sim_quant_df <- sim %>% + dplyr::group_by(time) %>% + group_map(~ quantile(.x$out, probs = probValues, na.rm = TRUE)) %>% + dplyr::tibble() %>% + tidyr::unnest_longer(1, indices_to = "quantile", values_to = "value") %>% dplyr::mutate( time = rep(times, each = length(probValues)), quantile = readr::parse_number(quantile) / 100 - ) |> + ) %>% dplyr::select(time, quantile, value) lower_confint <- function(n) { @@ -2328,12 +2242,12 @@ PM_sim <- R6::R6Class( lconfint <- tapply(sim$out, sim$time, function(x) sort(x)[lower_confint(length(x))]) uconfint <- tapply(sim$out, sim$time, function(x) sort(x)[upper_confint(length(x))]) - sim_quant_df$lowerCI <- as.numeric(unlist(lconfint)) - sim_quant_df$upperCI <- as.numeric(unlist(uconfint)) + sim_quant_df$lowerCI <- unlist(lconfint) + sim_quant_df$upperCI <- unlist(uconfint) # plot main data - p <- sim_quant_df |> - group_by(quantile) |> + p <- sim_quant_df %>% + group_by(quantile) %>% plotly::plot_ly(x = ~time, y = ~value) # add confidence intervals @@ -2342,7 +2256,7 @@ PM_sim <- R6::R6Class( cat("\nNote: Confidence intervals for simulation quantiles omitted when nsim < 100\n") } } else { - p <- p |> + p <- p %>% plotly::add_ribbons( ymin = ~lowerCI, ymax = ~upperCI, name = "CI", @@ -2355,8 +2269,8 @@ PM_sim <- R6::R6Class( # add quantile lines, allowing for the independent formats for (i in 1:length(probValues)) { - thisQ <- sim_quant_df |> filter(quantile == probValues[i]) - p <- p |> plotly::add_lines( + thisQ <- sim_quant_df %>% filter(quantile == probValues[i]) + p <- p %>% plotly::add_lines( x = ~time, y = ~value, data = thisQ, line = probFormats[[i]], hovertemplate = "Time: %{x}
Out: %{y}
Quantile: %{text}", text = ~quantile, @@ -2365,111 +2279,106 @@ PM_sim <- R6::R6Class( } # add fill if specified - if (!is.null(lineList$fill)) { - if (ci > 0) { + if(!is.null(lineList$fill)) { + if(ci > 0){ cli::cli_inform(c( "i" = "Consider {.code ci = 0} for cleaner plot.", " " = "See {.help PM_sim$plot()} for details." )) } - fill_area <- sim_quant_df |> - filter(quantile %in% lineList$fill$probs) |> - select(time, quantile, value) |> - tidyr::pivot_wider(names_from = quantile, values_from = value) |> + fill_area <- sim_quant_df %>% filter(quantile %in% lineList$fill$probs) %>% select(time, quantile, value) %>% + tidyr::pivot_wider(names_from = quantile, values_from = value) %>% rename(lower = 2, upper = 3) - p <- p |> - plotly::add_ribbons( - data = fill_area, x = ~time, ymin = ~lower, ymax = ~upper, + p <- p %>% + plotly::add_ribbons(data = fill_area, x = ~time, ymin = ~lower, ymax = ~upper, name = "CI", line = NULL, inherit = FALSE, fillcolor = lineList$fill$color, - opacity = lineList$fill$opacity + opacity = lineList$fill$opacity) + } + + + retValue <- list() + + # add observations if supplied, and calculate NPC + if (!all(is.na(obs))) { + p <- p %>% add_markers(x = ~time, y = ~obs, data = obs, marker = marker) + obs$sim_quant <- NA + + for (i in 1:nrow(obs)) { + obs$sim_quant[i] <- ifelse(is.na(obs$obs[i]), NA, + NPsimInterp(obs$time[i], obs$obs[i], sim_quant_df, probs = probValues) + ) + } + not.miss <- sum(!is.na(obs$sim_quant)) + npc <- data.frame( + quantile = probValues, + prop_less = rep(NA, length(probValues)), + pval = rep(NA, length(probValues)) ) - } - - - retValue <- list() - - # add observations if supplied, and calculate NPC - if (!all(is.na(obs))) { - p <- p |> add_markers(x = ~time, y = ~obs, data = obs, marker = marker) - obs$sim_quant <- NA + for (i in 1:nrow(npc)) { + success <- sum(as.numeric(obs$sim_quant < probValues[i]), na.rm = TRUE) + + pval <- tryCatch( + binom.test(success, not.miss, probValues[i], + alternative = "two" + )$p.value, + error = function(e) NA + ) + npc$prop_less[i] <- round(success / not.miss, 3) + npc$pval[i] <- pval + } + # calculate proportion between 0.05 and 0.95 + between <- rep(NA, nrow(obs)) for (i in 1:nrow(obs)) { - obs$sim_quant[i] <- ifelse(is.na(obs$obs[i]), NA, - NPsimInterp(obs$time[i], obs$obs[i], sim_quant_df, probs = probValues) + between[i] <- ifelse(is.na(obs$obs[i]), NA, + NPsimInterp(obs$time[i], obs$obs[i], sim_quant_df, probs = c(0.05, 0.95)) ) } - not.miss <- sum(!is.na(obs$sim_quant)) - npc <- data.frame( - quantile = probValues, - prop_less = rep(NA, length(probValues)), - pval = rep(NA, length(probValues)) - ) - for (i in 1:nrow(npc)) { - success <- sum(as.numeric(obs$sim_quant < probValues[i]), na.rm = TRUE) - - pval <- tryCatch( - binom.test(success, not.miss, probValues[i], - alternative = "two" - )$p.value, - error = function(e) NA - ) - npc$prop_less[i] <- round(success / not.miss, 3) - npc$pval[i] <- pval + success90 <- sum(as.numeric(between >= 0.05 & between < 0.95), na.rm = TRUE) + attr(npc, "05-95") <- success90 / not.miss + attr(npc, "P-90") <- binom.test(success90, not.miss, 0.9, "two")$p.value + + if (not.miss < nrow(obs)) { + cat(paste("\n", nrow(obs) - not.miss, " observed values were obtained beyond the \nsimulated time range of ", min(sim_quant_df$time), " to ", max(sim_quant_df$time), " and were excluded.", sep = "")) } - # calculate proportion between 0.05 and 0.95 - between <- rep(NA, nrow(obs)) - for (i in 1:nrow(obs)) { - between[i] <- ifelse(is.na(obs$obs[i]), NA, - NPsimInterp(obs$time[i], obs$obs[i], sim_quant_df, probs = c(0.05, 0.95)) - ) - } - success90 <- sum(as.numeric(between >= 0.05 & between < 0.95), na.rm = TRUE) - attr(npc, "05-95") <- success90 / not.miss - attr(npc, "P-90") <- binom.test(success90, not.miss, 0.9, "two")$p.value - - if (not.miss < nrow(obs)) { - cat(paste("\n", nrow(obs) - not.miss, " observed values were obtained beyond the \nsimulated time range of ", min(sim_quant_df$time), " to ", max(sim_quant_df$time), " and were excluded.", sep = "")) + + retValue <- modifyList(retValue, list(npc = npc, simsum = sim_quant_df, obs = obs)) + class(retValue) <- c("PMnpc", "list") } + } else { # probs was set to NA or nsim < 10 - retValue <- modifyList(retValue, list(npc = npc, simsum = sim_quant_df, obs = obs)) - class(retValue) <- c("PMnpc", "list") + # plot all simulated profiles + p <- sim %>% mutate(id2 = paste(id, nsim, sep = "_")) %>% + group_by(id2) %>% + plotly::plot_ly(x = ~time, y = ~out) %>% + plotly::add_lines(line = join) + # plot observations if available + if (!all(is.na(obs))) { + p <- p %>% add_markers(x = ~time, y = ~obs, data = obs, marker = marker) + } + retValue <- list() } -} else { # probs was set to NA or nsim < 10 - # plot all simulated profiles - p <- sim |> - mutate(id2 = paste(id, nsim, sep = "_")) |> - group_by(id2) |> - plotly::plot_ly(x = ~time, y = ~out) |> - plotly::add_lines(line = join) - # plot observations if available - if (!all(is.na(obs))) { - p <- p |> add_markers(x = ~time, y = ~obs, data = obs, marker = marker) - } - retValue <- list() -} - - -# common to all plots -p <- p |> plotly::layout( - xaxis = layout$xaxis, - yaxis = layout$yaxis, - showlegend = layout$showlegend, - legend = layout$legend, - title = layout$title -) - - -if (print) print(p) -retValue <- modifyList(retValue, list(p = p)) -return(invisible(retValue)) + # common to all plots + p <- p %>% plotly::layout( + xaxis = layout$xaxis, + yaxis = layout$yaxis, + showlegend = layout$showlegend, + legend = layout$legend, + title = layout$title + ) + + + if (print) print(p) + retValue <- modifyList(retValue, list(p = p)) + return(invisible(retValue)) } # SUMMARY ----------------------------------------------------------------- @@ -2515,22 +2424,21 @@ return(invisible(retValue)) #' @seealso [PM_sim] #' @export -summary.PM_sim <- function( - object, include, exclude, field = "obs", group = NULL, - statistics = c("mean", "sd", "median", "min", "max"), - digits = getPMoptions("digits"), ... -) { +summary.PM_sim <- function(object, include, exclude, field = "obs", group = NULL, +statistics = c("mean", "sd", "median", "min", "max"), +digits = getPMoptions("digits"), ...) { # get the right data if (inherits(object, "PM_sim")) { dat <- object$data[[field]] } else if (inherits(object, "PM_sim_data")) { dat <- object[[field]] - if ("id" %in% names(dat)) { + if ("id" %in% names(dat)){ # include/exclude template ids if (missing(include)) include <- unique(dat$id) if (missing(exclude)) exclude <- NA - dat <- dat |> includeExclude(include, exclude) + dat <- dat %>% includeExclude(include, exclude) } + } else { cli::cli_abort(c("x" = "Object does not appear to be a simulation.")) } @@ -2562,8 +2470,8 @@ summary.PM_sim <- function( x }) } - summ <- summ |> - list_rbind(names_to = "stat") |> + summ <- summ %>% + list_rbind(names_to = "stat") %>% mutate(across(where(is.numeric), \(x) round(x, digits))) if (length(group) > 0) { attr(summ, "group") <- group @@ -2610,8 +2518,13 @@ print.summary.PM_sim <- function(x, ...) { } + + + # generate random samples from multivariate, multimodal normal distribution generate_multimodal_samples <- function(num_samples, weights, means, cov_matrix, i, limits) { + + # turn means into a list of vectors if needed means <- split(means, 1:nrow(means)) if (length(weights) != length(means)) { @@ -2633,83 +2546,70 @@ generate_multimodal_samples <- function(num_samples, weights, means, cov_matrix, samples_per_mode <- stats::rmultinom(1, size = num_samples, prob = weights) # function used later to check if any parameters are outside their limits - outside_check <- function(x, lower, upper) { - x <- unlist(x, use.names = TRUE) - any(x < lower[names(x)]) || any(x > upper[names(x)]) + outside_check <- function(x) { + any(x - limits$min < 0) | # any parameter < lower limit + any(x - limits$max > 0) # any parameter > upper limit } - lower_bounds <- stats::setNames(limits$min, limits$par) - upper_bounds <- stats::setNames(limits$max, limits$par) - - # Generate samples bounded by limits for each mode + #Generate samples bounded by limits for each mode all_samples <- map(1:length(weights), function(j) { - mu_j <- unlist(means[[j]], use.names = TRUE) - par_names <- names(mu_j) - lower_j <- lower_bounds[par_names] - upper_j <- upper_bounds[par_names] - n_j <- as.integer(samples_per_mode[j, ]) - - keep_list <- vector("list", n_j) - discard_list <- list() + samples <- tryCatch(suppressWarnings(MASS::mvrnorm(n = samples_per_mode[j,], mu = as.matrix(means[[j]], nrow = 1), Sigma = cov_matrix)), error = function(e) NULL) - for (k in seq_len(n_j)) { - cycle_num <- 0 - repeat { - draw <- tryCatch( - suppressWarnings(MASS::mvrnorm( - n = 1, - mu = as.numeric(mu_j), - Sigma = cov_matrix - )), - error = function(e) NULL - ) - cycle_num <- cycle_num + 1 - if (!is.null(draw)) { - names(draw) <- par_names - if (!outside_check(draw, lower_j, upper_j)) { - keep_list[[k]] <- as.data.frame(as.list(unname(draw))) - names(keep_list[[k]]) <- par_names - break + # replace any outside their limits + if(!is.null(samples)){ + if(!is.matrix(samples)){ + samples <- as.data.frame(as.list(samples)) + names(samples) <- names(means[[j]]) + } + + discarded <- NULL + if (!all(is.null(limits))) { + for (k in 1:nrow(samples)) { + cycle_num <- 0 + outside <- outside_check(samples[k, ]) + while (outside && cycle_num < 20) { + new_sample <- tryCatch(suppressWarnings(MASS::mvrnorm(n = 1, mu = as.matrix(means[[j]], nrow = 1), Sigma = cov_matrix)), error = function(e) NULL) + cycle_num <- cycle_num + 1 + outside <- outside_check(new_sample) } - discard_list[[length(discard_list) + 1]] <- as.data.frame(as.list(unname(draw))) - names(discard_list[[length(discard_list)]]) <- par_names - } - if (cycle_num >= 500) { - cli::cli_abort(c( - "x" = "Unable to generate simulated parameters within limits after repeated attempts.", - "i" = "The constrained draw failed for mode {.val {j}} and row {.val {k}}." - )) - } + if (outside) { + cli::cli_abort(c("x" = "Unable to generate simulated parameters within limits after 20 attempts per row.")) + } + if (cycle_num > 0) { + discarded <- rbind(discarded, samples[k, ]) + samples[k, ] <- new_sample + } + + } # end loop to fix thetas out of range } + + + list(keep = samples, discard = discarded) # the final set of samples for this mode + } - samples <- dplyr::bind_rows(keep_list) - discarded <- if (length(discard_list) > 0) dplyr::bind_rows(discard_list) else NULL - list(keep = samples, discard = discarded) - }) - - - retained <- all_samples |> - map(\(x) x$keep) |> - (\(x) do.call(rbind, x))() |> - tibble::as_tibble(.name_repair = "minimal") |> - mutate(prob = 1 / dplyr::n()) - - discarded <- all_samples |> - map(\(x) x$discard) |> - (\(x) do.call(rbind, x))() |> - tibble::as_tibble(.name_repair = "minimal") |> - mutate(prob = 1 / dplyr::n()) - - total_means <- apply(rbind(retained, discarded), 2, mean)[1:ncol(cov_matrix)] - total_cov <- bind_rows(retained, discarded) |> - select(-prob) |> - cov() - total_nsim <- sum(nrow(retained), nrow(discarded)) # sum will ignore NULL values - + + } +) + + +retained <- all_samples %>% map( \(x) x$keep) %>% do.call(rbind, .) %>% +tibble::as_tibble(.name_repair = "minimal") %>% +mutate(prob = 1 / dplyr::n()) + +discarded <- all_samples %>% map( \(x) x$discard) %>% do.call(rbind, .) %>% +tibble::as_tibble(.name_repair = "minimal") %>% +mutate(prob = 1 / dplyr::n()) + +total_means <- apply(rbind(retained, discarded), 2, mean)[1:ncol(cov_matrix)] +total_cov <- bind_rows(retained, discarded) %>% +select(-prob) %>% cov() +total_nsim <- sum(nrow(retained), nrow(discarded)) # sum will ignore NULL values + return(list( - thetas = retained, total_means = total_means, - total_cov = total_cov, - total_nsim = total_nsim - )) -} + thetas = retained, total_means = total_means, + total_cov = total_cov, + total_nsim = total_nsim +)) + +} \ No newline at end of file diff --git a/R/PMoptions.R b/R/PMoptions.R index 52400b2a..e969e1b0 100755 --- a/R/PMoptions.R +++ b/R/PMoptions.R @@ -245,7 +245,7 @@ setPMoptions <- function(launch.app = TRUE) { "date_format", bslib::tooltip( shiny::tags$span("Date format", shiny::icon("circle-question", class = "ms-1 text-muted")), - "Format used to parse date strings" + "Date format used to parse date-time strings" ), choices = c( "MM/DD/YY (United States)" = "%m/%d/%y", diff --git a/R/PMutilities.R b/R/PMutilities.R index 12458ded..cb443001 100755 --- a/R/PMutilities.R +++ b/R/PMutilities.R @@ -1240,3 +1240,54 @@ PM_rtmvnorm <- function(n, mean, sigma, lb, max_draws = 5000000L) { out } + + +#' @title Get latest platform-specific R release metadata +#' @description +#' `r lifecycle::badge("stable")` +#' Retrieves metadata for the latest R release available for the current +#' platform from the r-hub rversions API. +#' @return A list containing all fields returned by the API response. +#' @export +latestR <- function() { + sysname <- tolower(Sys.info()[["sysname"]]) + r_arch <- tolower(R.version$arch) + r_release_endpoint <- switch( + sysname, + windows = "r-release-win", + darwin = if (grepl("arm64|aarch64", r_arch)) "r-release-macos-arm64" else "r-release-macos", + linux = "r-release-tarball", + "r-release" + ) + + jsonlite::fromJSON(sprintf("https://api.r-hub.io/rversions/%s", r_release_endpoint)) +} + + +#' @title Download the latest platform-specific R installer +#' @description +#' `r lifecycle::badge("stable")` +#' Downloads the latest R installer (or source tarball on Linux) for the current +#' platform to the user's Downloads folder. +#' @param r_info Optional API response list. Defaults to [latestR()]. +#' @param destdir Destination directory. Defaults to the user's Downloads folder. +#' @return The file path of the downloaded installer/tarball. +#' @export +downloadR <- function(r_info = latestR(), destdir = path.expand("~/Downloads")) { + download_url <- r_info$URL + if (is.null(download_url) || length(download_url) == 0 || is.na(download_url)) { + download_url <- r_info$url + } + + if (is.null(download_url) || length(download_url) == 0 || is.na(download_url)) { + cli::cli_abort("No downloadable URL was returned by the rversions API for this platform.") + } + + if (!dir.exists(destdir)) { + dir.create(destdir, recursive = TRUE) + } + + destfile <- file.path(destdir, basename(download_url)) + utils::download.file(download_url, destfile = destfile, mode = "wb") + destfile +} diff --git a/R/extendr-wrappers.R b/R/extendr-wrappers.R index 2f9a9105..9ecf164f 100644 --- a/R/extendr-wrappers.R +++ b/R/extendr-wrappers.R @@ -55,5 +55,9 @@ model_metadata <- function(model_source, solver = NULL) .Call(wrap__model_metada #' @export setup_logs <- function() .Call(wrap__setup_logs) +bestdose_prepare <- function(model_path, prior_path, past_data_path, params, kind) .Call(wrap__bestdose_prepare, model_path, prior_path, past_data_path, params, kind) + +bestdose_optimize <- function(handle, target_data_path, time_offset, dose_min, dose_max, bias_weight, target_type) .Call(wrap__bestdose_optimize, handle, target_data_path, time_offset, dose_min, dose_max, bias_weight, target_type) + # nolint end diff --git a/_pkgdown.yml b/_pkgdown.yml index b3a9865d..3e4e1d66 100755 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -55,6 +55,11 @@ reference: desc: Functions for project management and workflow - contents: - PM_tree +- title: BestDose + desc: BestDose optimization objects +- contents: + - bd + - bd_post - title: Helpers desc: Helper functions when creating R6 objects - contents: @@ -141,6 +146,13 @@ reference: - check_updates - latestR - downloadR +- title: Internal + desc: Internal and low-level functions +- contents: + - simulate_all + - simulate_one + - fit + - model_parameters - title: Reference desc: Reference functions - contents: diff --git a/data/NPex.rda b/data/NPex.rda index 4b9abdf8..414d864b 100755 Binary files a/data/NPex.rda and b/data/NPex.rda differ diff --git a/data/dataEx.rda b/data/dataEx.rda index 7be86c7b..0efff8f0 100755 Binary files a/data/dataEx.rda and b/data/dataEx.rda differ diff --git a/data/modEx.rda b/data/modEx.rda index ec1e0015..8054b4cc 100755 Binary files a/data/modEx.rda and b/data/modEx.rda differ diff --git a/data/simEx.rda b/data/simEx.rda index 0cef986e..d1e2ae01 100755 Binary files a/data/simEx.rda and b/data/simEx.rda differ diff --git a/inst/Examples/Rscript/bestdose_simple_test.R b/inst/Examples/Rscript/bestdose_simple_test.R new file mode 100644 index 00000000..58cd4cce --- /dev/null +++ b/inst/Examples/Rscript/bestdose_simple_test.R @@ -0,0 +1,148 @@ +devtools::load_all() + +mod_onecomp <- PM_model$new( + pri = list( + ke = ab(0.001, 3.0), + v = ab(25.0, 250.0) + ), + eqn = function() { + dx[1] <- -ke * X[1] + B[1] + }, + out = function() { + Y[1] <- X[1] / v + }, + err = list( + additive(0, c(0, 0.20, 0, 0)) + ) +) + +past_file <- "inst/Examples/src/bestdose_past.csv" +target_file <- "inst/Examples/src/bestdose_target.csv" +prior_file <- "inst/Examples/src/bestdose_prior.csv" + +cat("Using PMcore prior file\n") + +posterior <- bd_post$new( + prior = prior_file, + model = mod_onecomp, + past_data = PM_data$new(past_file, quiet = TRUE), + max_cycles = 500, + quiet = TRUE +) + +cat("\nPosterior theta (first 5 rows):\n") +print(head(posterior$theta, 5)) +cat("\nPosterior weights (first 10):\n") +print(head(posterior$posterior_weights, 10)) + +prior_weights <- seq(0, 1, by = 0.1) +for (lambda in prior_weights) { + r <- posterior$optimize( + target = target_file, + dose_range = list(min = 0, max = 300), + prior_weight = lambda, # ought to be called "prior_weight" + start = NULL + ) + cat(sprintf( + "Prior weight: %.2f\t\tOptimal dose: [%s]\t\tCost: %.6f\t\tln Cost: %.4f\t\tMethod: %s\n", + lambda, + paste(r$doses, collapse = ", "), + r$objf, + log(r$objf), + r$method + )) +} + +# # Last result predictions +# r <- posterior$optimize( +# target = target_file, +# dose_range = list(min = 0, max = 300), +# prior_weight = 0.0 +# ) +# cat("\nConcentration-time predictions for prior_weight=0.0:\n") +# preds <- r$result$predictions +# for (j in seq_len(nrow(preds))) { +# p <- preds[j, ] +# cat(sprintf( +# "Time: %.2f h, Observed: %.2f, (Pop Mean: %.4f, Pop Median: %.4f, Post Mean: %.4f, Post Median: %.4f)\n", +# p$time, p$obs, p$pop_mean, p$pop_median, p$post_mean, p$post_median +# )) +# } + + +# # ===== One-shot API ===== +# bd1 <- bd$new( +# prior = prior_file, +# model = mod_onecomp, +# past_data = PM_data$new(past_file, quiet = TRUE), +# max_cycles = 500, +# future = PM_data$new(target_file, quiet = TRUE), +# dose_range = list(min = 0, max = 5000), +# prior_weight = 0, +# start = 0 +# ) + +# bd1 + +# bd1$plot() + +# bd2 <- bd$new( +# prior = prior_file, +# model = mod_onecomp, +# max_cycles = 500, +# future = target_file, +# dose_range = list(min = 0, max = 300), +# prior_weight = 0.0 +# ) + +# bd2 + + + +# bd2$plot() + +# plot(bd1) + + +# ## adding ability to specify future as argument to bd$new() instead of target file. +# ## This will allow for more flexible future specifications and avoid the need for a separate target file. + +# future_list <- list(dose = c(120,0), +# frequency = 12, +# route = 0, +# number = 3, +# target_time = 11.5, +# target = 0.3, +# target_type = "concentration") + +# future_list <- list(dose = 320, +# frequency = 12, +# route = 0, +# number = 3, +# target_time = 0.6, +# target = 0.3, +# target_type = "time") + +# #AUC target - crashing as of 3/13/26 +# future_list <- list(dose = 320, +# frequency = 12, +# route = 0, +# number = 3, +# target_time = 11.5, +# target = 10, +# target_type = "auc") + + +# bd_new <- bd$new( +# prior = prior_file, +# model = mod_onecomp, +# past_data = PM_data$new(past_file, quiet = TRUE), +# max_cycles = 50, +# future = future_list, +# dose_range = list(min = 0, max = 5000), +# prior_weight = 0, +# start = "02/02/26 00:00", +# ) + +# # bd_new$plot() +# bd_new$report() diff --git a/inst/Examples/Rscript/run_bestdose_comparison.R b/inst/Examples/Rscript/run_bestdose_comparison.R new file mode 100644 index 00000000..f6888324 --- /dev/null +++ b/inst/Examples/Rscript/run_bestdose_comparison.R @@ -0,0 +1,71 @@ +devtools::load_all() + +mod_onecomp <- PM_model$new( + pri = list( + ke = ab(0.001, 3.0), + v = ab(25.0, 250.0) + ), + eqn = function() { + dx[1] <- -ke * X[1] + B[1] + }, + out = function() { + Y[1] <- X[1] / v + }, + err = list( + additive(0, c(0, 0.20, 0, 0)) + ) +) + +past_file <- "inst/Examples/src/bestdose_past.csv" +target_file <- "inst/Examples/src/bestdose_target.csv" +prior_file <- "inst/Examples/src/bestdose_prior.csv" + +cat("Using PMcore prior file\n") + +posterior <- bd_post$new( + prior = prior_file, + model = mod_onecomp, + past_data = PM_data$new(past_file, quiet = TRUE), + max_cycles = 500, + quiet = TRUE +) + +cat("\nPosterior theta (first 5 rows):\n") +print(head(posterior$theta, 5)) +cat("\nPosterior weights (first 10):\n") +print(head(posterior$posterior_weights, 10)) + +prior_weights <- seq(0, 1, by = 0.1) +for (lambda in prior_weights) { + r <- posterior$optimize( + target = target_file, + dose_range = list(min = 0, max = 300), + prior_weight = lambda, + start = NULL + ) + cat(sprintf( + "Prior weight: %.2f\t\tOptimal dose: [%.4f, %.4f]\t\tCost: %.6f\t\tln Cost: %.4f\t\tMethod: %s\n", + lambda, + r$doses[1], r$doses[2], + r$objf, + log(r$objf), + r$method + )) +} + +# Last result predictions +r <- posterior$optimize( + target = target_file, + dose_range = list(min = 0, max = 300), + prior_weight = 1.0, + start = NULL +) +cat("\nConcentration-time predictions for prior_weight=1.0:\n") +preds <- r$result$predictions +for (j in seq_len(nrow(preds))) { + p <- preds[j, ] + cat(sprintf( + "Time: %.2f h, Observed: %.2f, (Pop Mean: %.4f, Pop Median: %.4f, Post Mean: %.4f, Post Median: %.4f)\n", + p$time, p$obs, p$pop_mean, p$pop_median, p$post_mean, p$post_median + )) +} diff --git a/inst/Examples/Rscript/test_future_vectors.R b/inst/Examples/Rscript/test_future_vectors.R new file mode 100644 index 00000000..ecb2cdd8 --- /dev/null +++ b/inst/Examples/Rscript/test_future_vectors.R @@ -0,0 +1,91 @@ +devtools::load_all(quiet = TRUE) + +mod_onecomp <- PM_model$new( + pri = list(ke = ab(0.001, 3.0), v = ab(25.0, 250.0)), + eqn = function() { dx[1] <- -ke * X[1] + B[1] }, + out = function() { Y[1] <- X[1] / v }, + err = list(additive(0, c(0, 0.20, 0, 0))) +) + +# Test 1: scalar (legacy behavior) +cat("--- Test 1: scalar dose/freq/route, number=3 ---\n") +bd1 <- bd$new( + prior = "inst/Examples/src/bestdose_prior.csv", + model = mod_onecomp, + past_data = PM_data$new("inst/Examples/src/bestdose_past.csv", quiet = TRUE), + max_cycles = 5, + future = list(dose = 1000, frequency = 12, route = 0, number = 3, target_time = 11.5, target = 0.3, target_type = "concentration"), + dose_range = list(min = 0, max = 5000), prior_weight = 0, start = "02/02/26 00:00", + quiet = TRUE +) +cat("doses:", paste(bd1$future$data$dose[!is.na(bd1$future$data$dose)], collapse = ","), "\n") +cat("times:", paste(bd1$future$data$time[!is.na(bd1$future$data$dose)], collapse = ","), "\n\n") + +# Test 2: vector dose (3 elements, number=3) +cat("--- Test 2: vector dose c(500,750,1000), number=3 ---\n") +bd2 <- bd$new( + prior = "inst/Examples/src/bestdose_prior.csv", + model = mod_onecomp, + past_data = PM_data$new("inst/Examples/src/bestdose_past.csv", quiet = TRUE), + max_cycles = 5, + future = list(dose = c(500, 750, 1000), frequency = 12, route = 0, number = 3, target_time = 11.5, target = 0.3, target_type = "concentration"), + dose_range = list(min = 0, max = 5000), prior_weight = 0, start = "02/02/26 00:00", + quiet = TRUE +) +cat("doses:", paste(bd2$future$data$dose[!is.na(bd2$future$data$dose)], collapse = ","), "\n") +cat("times:", paste(bd2$future$data$time[!is.na(bd2$future$data$dose)], collapse = ","), "\n\n") + +# Test 3: number < vector length - should inform and set number=3 +cat("--- Test 3: number=2 < dose length 3 (should inform, expand to 3) ---\n") +bd3 <- bd$new( + prior = "inst/Examples/src/bestdose_prior.csv", + model = mod_onecomp, + past_data = PM_data$new("inst/Examples/src/bestdose_past.csv", quiet = TRUE), + max_cycles = 5, + future = list(dose = c(500, 750, 1000), frequency = 12, route = 0, number = 2, target_time = 11.5, target = 0.3, target_type = "concentration"), + dose_range = list(min = 0, max = 5000), prior_weight = 0, start = "02/02/26 00:00", + quiet = TRUE +) +cat("doses:", paste(bd3$future$data$dose[!is.na(bd3$future$data$dose)], collapse = ","), "\n\n") + +# Test 4: short dose vector recycled (dose length 2, number=4 -> last value 1000 recycled) +cat("--- Test 4: dose c(500,1000), number=4 (recycle last -> 500,1000,1000,1000) ---\n") +bd4 <- bd$new( + prior = "inst/Examples/src/bestdose_prior.csv", + model = mod_onecomp, + past_data = PM_data$new("inst/Examples/src/bestdose_past.csv", quiet = TRUE), + max_cycles = 5, + future = list(dose = c(500, 1000), frequency = 12, route = 0, number = 4, target_time = 11.5, target = 0.3, target_type = "concentration"), + dose_range = list(min = 0, max = 5000), prior_weight = 0, start = "02/02/26 00:00", + quiet = TRUE +) +cat("doses:", paste(bd4$future$data$dose[!is.na(bd4$future$data$dose)], collapse = ","), "\n\n") + +# Test 5: vector frequency (variable intervals) +cat("--- Test 5: dose=1000, freq=c(8,12,24), number=3 ---\n") +bd5 <- bd$new( + prior = "inst/Examples/src/bestdose_prior.csv", + model = mod_onecomp, + past_data = PM_data$new("inst/Examples/src/bestdose_past.csv", quiet = TRUE), + max_cycles = 5, + future = list(dose = 1000, frequency = c(8, 12, 24), route = 0, number = 3, target_time = 7.5, target = 0.3, target_type = "concentration"), + dose_range = list(min = 0, max = 5000), prior_weight = 0, start = "02/02/26 00:00", + quiet = TRUE +) +cat("doses:", paste(bd5$future$data$dose[!is.na(bd5$future$data$dose)], collapse = ","), "\n") +cat("times:", paste(bd5$future$data$time[!is.na(bd5$future$data$dose)], collapse = ","), "\n\n") + +# Test 6: target_type = time (proportional target_time per interval) +cat("--- Test 6: target_type='time', freq=c(8,12,24), target_time=0.5 ---\n") +bd6 <- bd$new( + prior = "inst/Examples/src/bestdose_prior.csv", + model = mod_onecomp, + past_data = PM_data$new("inst/Examples/src/bestdose_past.csv", quiet = TRUE), + max_cycles = 5, + future = list(dose = 1000, frequency = c(8, 12, 24), route = 0, number = 3, target_time = 0.5, target = 0.3, target_type = "time"), + dose_range = list(min = 0, max = 5000), prior_weight = 0, start = "02/02/26 00:00", + quiet = TRUE +) +cat("obs times:", paste(bd6$future$data$time[is.na(bd6$future$data$dose)], collapse = ","), "\n\n") + +cat("All tests completed.\n") diff --git a/inst/Examples/Rscript/test_status_column.R b/inst/Examples/Rscript/test_status_column.R new file mode 100644 index 00000000..079c8c70 --- /dev/null +++ b/inst/Examples/Rscript/test_status_column.R @@ -0,0 +1,35 @@ +devtools::load_all(quiet = TRUE) + +mod_onecomp <- PM_model$new( + pri = list(ke = ab(0.001, 3.0), v = ab(25.0, 250.0)), + eqn = function() { dx[1] <- -ke * X[1] + B[1] }, + out = function() { Y[1] <- X[1] / v }, + err = list(additive(0, c(0, 0.20, 0, 0))) +) + +# Mixed: dose 1 = fixed (1000), dose 2 = optimize (0), dose 3 = fixed (1500) +bd_obj <- bd$new( + prior = "inst/Examples/src/bestdose_prior.csv", + model = mod_onecomp, + past_data = PM_data$new("inst/Examples/src/bestdose_past.csv", quiet = TRUE), + max_cycles = 5, + future = list(dose = c(1000, 0, 1500), frequency = 12, route = 0, number = 3, + target_time = 11.5, target = 0.3, target_type = "concentration"), + dose_range = list(min = 0, max = 5000), prior_weight = 0, start = "02/02/26 00:00", + quiet = TRUE +) + +# Debug: check what standard_data looks like for future evid==1 rows +cat("x$future$standard_data evid==1 rows:\n") +sd <- bd_obj$future$standard_data +print(sd[sd$evid == 1, ]) + +report <- Pmetrics:::bd_report_build(bd_obj) +cat("future_doses status column:\n") +print(report$future_doses[, c("dose", "status")]) + +out <- file.path(tempdir(), "bd-report-status-test") +dir.create(out, showWarnings = FALSE, recursive = TRUE) +status <- bd_obj$report(path = out, show = FALSE, quiet = TRUE) +cat("\nReport status:", status, "\n") +cat("HTML exists:", file.exists(file.path(out, "bestdose_report.html")), "\n") diff --git a/inst/Examples/src/bestdose_past.csv b/inst/Examples/src/bestdose_past.csv new file mode 100644 index 00000000..3383f096 --- /dev/null +++ b/inst/Examples/src/bestdose_past.csv @@ -0,0 +1,9 @@ +id,evid,date,time,dur,dose,addl,ii,input,out,outeq,c0,c1,c2,c3 +1,1,2/1/26,00:00:00,0,150,0,0,1,.,.,.,.,.,. +1,0,2/1/26,02:00:00,.,.,.,.,.,0.759050698,1,.,.,.,. +1,0,2/1/26,04:00:00,.,.,.,.,.,0.38408517,1,.,.,.,. +1,0,2/1/26,06:00:00,.,.,.,.,.,0.194349887,1,.,.,.,. +1,1,2/1/26,12:00:00,0,75,0,0,1,.,.,.,.,.,. +1,0,2/1/26,14:00:00,.,.,.,.,.,0.392266578,1,.,.,.,. +1,0,2/1/26,16:00:00,.,.,.,.,.,0.198489739,1,.,.,.,. +1,0,2/1/26,18:00:00,.,.,.,.,.,0.100437251,1,.,.,.,. \ No newline at end of file diff --git a/inst/Examples/src/bestdose_prior.csv b/inst/Examples/src/bestdose_prior.csv new file mode 100644 index 00000000..bead3957 --- /dev/null +++ b/inst/Examples/src/bestdose_prior.csv @@ -0,0 +1,50 @@ +ke,v,prob +0.08736658442020416,103.9818823337555,0.06405457820397967 +1.0041342623233795,188.76309752464294,0.019607843140974805 +0.10507606186866761,140.8398061990738,0.019607843150332413 +0.3220049516916275,68.28039824962616,0.019607843051963586 +0.3493796042442322,75.56532084941864,0.01960746473012483 +0.04363290762901306,85.5460512638092,0.019607220383661656 +0.3312444769859314,92.81326055526733,0.019607147791086518 +0.09591740503311158,70.4040265083313,0.019606957258885387 +0.3085237291574478,92.42967247962952,0.019739312212632944 +0.3319534166574478,118.09373497962952,0.01963231510029087 +0.06250557525157929,107.03847944736481,0.019671831895535216 +0.06885235497951508,76.48277580738068,0.019704372081019293 +0.104416601395607,91.46958649158478,0.0196439196378291 +0.11730292952060699,78.46177399158478,0.019596592693258374 +0.06250557525157929,95.56875288486481,0.019558583620767178 +0.013994081234931946,178.73696267604828,0.01973719361931262 +0.07190197534561157,66.9762921333313,0.01951179533204779 +0.3406021231412888,99.86292123794556,0.0195017935173522 +0.02050767450332642,140.53142726421356,0.019496909863886087 +0.28171865940093993,140.80943822860718,0.02006966089395463 +0.08736658442020416,127.7562963962555,0.019975556860205728 +0.283145404958725,125.71949124336243,0.021760196860831894 +0.2902425238609314,94.35134649276733,0.020471376913953784 +0.3010685295820236,128.3288460969925,0.019431925066036485 +0.044804392004013066,99.5206606388092,0.021064943923371642 +0.09146677973270416,92.7318823337555,0.01938595576577497 +0.2925854926109314,128.32107305526733,0.018981650341481797 +0.28490263152122497,92.49683499336243,0.018729335263653696 +0.09826037378311157,111.1413311958313,0.022513324580852458 +0.08170614981651307,97.3233950138092,0.022071606402980712 +0.2925854926109314,105.42556524276733,0.02188055586035111 +0.036757444095611574,109.3395733833313,0.01813223949068482 +0.09240295190811158,113.7780499458313,0.01634642552944466 +0.1311608946800232,96.91233038902283,0.020745654510324375 +0.3540655417442322,86.77137553691864,0.03911312316643254 +0.3132096666574478,115.76463341712952,0.030954606713449555 +0.07658791284561157,113.1188702583313,0.00868552053488122 +0.2908282660484314,112.85232305526733,0.014634851770971591 +0.05615650746822358,130.38859486579895,0.0012110863756026463 +0.08678084223270416,87.3705542087555,0.00043536953019302594 +0.057327991843223576,130.87199330329895,0.004552363447102815 +0.08736658442020416,87.4144995212555,0.0002790654992634474 +0.07658791284561157,113.1628155708313,0.026588971195136306 +0.3540655417442322,86.81532084941864,0.0001850932799277153 +0.3132096666574478,115.80857872962952,0.008825717688183198 +0.2908282660484314,112.80837774276733,0.03942289250196689 +0.1311608946800232,96.86838507652283,0.018470031787835278 +0.05615650746822357,130.43254017829895,0.05302517206894798 +0.08678084223270416,87.4144995212555,0.0349542088912624 diff --git a/inst/Examples/src/bestdose_prior_pmcore.csv b/inst/Examples/src/bestdose_prior_pmcore.csv new file mode 100644 index 00000000..bead3957 --- /dev/null +++ b/inst/Examples/src/bestdose_prior_pmcore.csv @@ -0,0 +1,50 @@ +ke,v,prob +0.08736658442020416,103.9818823337555,0.06405457820397967 +1.0041342623233795,188.76309752464294,0.019607843140974805 +0.10507606186866761,140.8398061990738,0.019607843150332413 +0.3220049516916275,68.28039824962616,0.019607843051963586 +0.3493796042442322,75.56532084941864,0.01960746473012483 +0.04363290762901306,85.5460512638092,0.019607220383661656 +0.3312444769859314,92.81326055526733,0.019607147791086518 +0.09591740503311158,70.4040265083313,0.019606957258885387 +0.3085237291574478,92.42967247962952,0.019739312212632944 +0.3319534166574478,118.09373497962952,0.01963231510029087 +0.06250557525157929,107.03847944736481,0.019671831895535216 +0.06885235497951508,76.48277580738068,0.019704372081019293 +0.104416601395607,91.46958649158478,0.0196439196378291 +0.11730292952060699,78.46177399158478,0.019596592693258374 +0.06250557525157929,95.56875288486481,0.019558583620767178 +0.013994081234931946,178.73696267604828,0.01973719361931262 +0.07190197534561157,66.9762921333313,0.01951179533204779 +0.3406021231412888,99.86292123794556,0.0195017935173522 +0.02050767450332642,140.53142726421356,0.019496909863886087 +0.28171865940093993,140.80943822860718,0.02006966089395463 +0.08736658442020416,127.7562963962555,0.019975556860205728 +0.283145404958725,125.71949124336243,0.021760196860831894 +0.2902425238609314,94.35134649276733,0.020471376913953784 +0.3010685295820236,128.3288460969925,0.019431925066036485 +0.044804392004013066,99.5206606388092,0.021064943923371642 +0.09146677973270416,92.7318823337555,0.01938595576577497 +0.2925854926109314,128.32107305526733,0.018981650341481797 +0.28490263152122497,92.49683499336243,0.018729335263653696 +0.09826037378311157,111.1413311958313,0.022513324580852458 +0.08170614981651307,97.3233950138092,0.022071606402980712 +0.2925854926109314,105.42556524276733,0.02188055586035111 +0.036757444095611574,109.3395733833313,0.01813223949068482 +0.09240295190811158,113.7780499458313,0.01634642552944466 +0.1311608946800232,96.91233038902283,0.020745654510324375 +0.3540655417442322,86.77137553691864,0.03911312316643254 +0.3132096666574478,115.76463341712952,0.030954606713449555 +0.07658791284561157,113.1188702583313,0.00868552053488122 +0.2908282660484314,112.85232305526733,0.014634851770971591 +0.05615650746822358,130.38859486579895,0.0012110863756026463 +0.08678084223270416,87.3705542087555,0.00043536953019302594 +0.057327991843223576,130.87199330329895,0.004552363447102815 +0.08736658442020416,87.4144995212555,0.0002790654992634474 +0.07658791284561157,113.1628155708313,0.026588971195136306 +0.3540655417442322,86.81532084941864,0.0001850932799277153 +0.3132096666574478,115.80857872962952,0.008825717688183198 +0.2908282660484314,112.80837774276733,0.03942289250196689 +0.1311608946800232,96.86838507652283,0.018470031787835278 +0.05615650746822357,130.43254017829895,0.05302517206894798 +0.08678084223270416,87.4144995212555,0.0349542088912624 diff --git a/inst/Examples/src/bestdose_target.csv b/inst/Examples/src/bestdose_target.csv new file mode 100644 index 00000000..79883dbe --- /dev/null +++ b/inst/Examples/src/bestdose_target.csv @@ -0,0 +1,9 @@ +id,evid,time,dur,dose,addl,ii,input,out,outeq,c0,c1,c2,c3 +1,1,0,0,0,0,0,1,.,.,.,.,.,. +1,0,2,.,.,.,.,.,0.759050697604428,1,.,.,.,. +1,0,4,.,.,.,.,.,0.384085169721793,1,.,.,.,. +1,0,6,.,.,.,.,.,0.194349887386702,1,.,.,.,. +1,1,12,0,0,0,0,1,.,.,.,.,.,. +1,0,14,.,.,.,.,.,0.392266577540038,1,.,.,.,. +1,0,16,.,.,.,.,.,0.198489739204705,1,.,.,.,. +1,0,18,.,.,.,.,.,0.100437250648841,1,.,.,.,. diff --git a/inst/Examples/src/bestdose_target_pmcore.csv b/inst/Examples/src/bestdose_target_pmcore.csv new file mode 100644 index 00000000..79883dbe --- /dev/null +++ b/inst/Examples/src/bestdose_target_pmcore.csv @@ -0,0 +1,9 @@ +id,evid,time,dur,dose,addl,ii,input,out,outeq,c0,c1,c2,c3 +1,1,0,0,0,0,0,1,.,.,.,.,.,. +1,0,2,.,.,.,.,.,0.759050697604428,1,.,.,.,. +1,0,4,.,.,.,.,.,0.384085169721793,1,.,.,.,. +1,0,6,.,.,.,.,.,0.194349887386702,1,.,.,.,. +1,1,12,0,0,0,0,1,.,.,.,.,.,. +1,0,14,.,.,.,.,.,0.392266577540038,1,.,.,.,. +1,0,16,.,.,.,.,.,0.198489739204705,1,.,.,.,. +1,0,18,.,.,.,.,.,0.100437250648841,1,.,.,.,. diff --git a/inst/options/PMoptions.json b/inst/options/PMoptions.json index 7b47fe49..023db1a5 100755 --- a/inst/options/PMoptions.json +++ b/inst/options/PMoptions.json @@ -9,5 +9,7 @@ "report_template": "app", "date_format": "%m/%d/%y", "update_check": "weekly", - "update_timeout": 1 + "update_timeout": 1, + "backend": "rust", + "model_template_path": "" } diff --git a/man/PM_data.Rd b/man/PM_data.Rd index 7d21fc9b..72048a16 100755 --- a/man/PM_data.Rd +++ b/man/PM_data.Rd @@ -10,7 +10,7 @@ PM_data R6 objects containing raw, standardized and valid data, and methods to process the data } \details{ -\emph{PM_data} objects are passed to the \verb{$fit} method of compiled \link{PM_model} objects to initiate a +\emph{PM_data} objects are passed to \link{PM_fit} objects to initiate a population analysis. The object is created by reading a delimited file in the current working directory. The data will be transformed into the standard format which is the same for all engines, with a report of any assumptions @@ -29,7 +29,7 @@ There are a number of methods defined for a PM_data object, including to write the standard data back to a file for future use, to summarize and to plot the object, to conduct a non-compartmental analysis on the raw data using -\link{make_NCA}, to calculate an AUC using \link{make_AUC}, and to add event rows, which +\link{makeNCA}, to calculate an AUC using \link{makeAUC}, and to add event rows, which is particularly useful for making simulation templates on the fly. } \examples{ @@ -158,12 +158,12 @@ from the \code{standard_data} field \subsection{Arguments}{ \if{html}{\out{
}} \describe{ - \item{\code{...}}{Arguments passed to \link{make_AUC}.} + \item{\code{...}}{Arguments passed to \link{makeAUC}.} } \if{html}{\out{
}} } \subsection{Details}{ - See \link{make_AUC}. + See \link{makeAUC}. } } @@ -180,12 +180,12 @@ from the \code{standard_data} field \subsection{Arguments}{ \if{html}{\out{
}} \describe{ - \item{\code{...}}{Arguments passed to \link{make_NCA}.} + \item{\code{...}}{Arguments passed to \link{makeNCA}.} } \if{html}{\out{
}} } \subsection{Details}{ - See \link{make_NCA}. + See \link{makeNCA}. } } diff --git a/man/PM_sim.Rd b/man/PM_sim.Rd index 9c557eb0..a06b51da 100755 --- a/man/PM_sim.Rd +++ b/man/PM_sim.Rd @@ -152,7 +152,6 @@ Again, this can be useful as a check against the original covariance in \code{po \item \href{#method-PM_sim-initialize}{\code{PM_sim$new()}} \item \href{#method-PM_sim-save}{\code{PM_sim$save()}} \item \href{#method-PM_sim-plot}{\code{PM_sim$plot()}} - \item \href{#method-PM_sim-opt}{\code{PM_sim$opt()}} \item \href{#method-PM_sim-pta}{\code{PM_sim$pta()}} \item \href{#method-PM_sim-auc}{\code{PM_sim$auc()}} \item \href{#method-PM_sim-summary}{\code{PM_sim$summary()}} @@ -193,7 +192,7 @@ or via the \verb{$sim} method for \link{PM_result} objects. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ - \item{\code{poppar}}{One of five things: + \item{\code{poppar}}{One of four things: \enumerate{ \item A \link{PM_result} object containing the final population parameter distribution from a model run, a model object, and a data object. @@ -203,22 +202,22 @@ The data object may also be replaced (and often is) by a different \link{PM_data object compatible with the model. \if{html}{\out{
}}\preformatted{run1 <- PM_load(1) # load the PM_result object -sim1 <- run1$sim(...) # replace model and data in run1 if desired; +sim1 <- run1$sim(...) # replace model and data in run1 if desired; #must be compatible with model and data in run1 mod <- PM_model$new("model.txt") # or use a model object -sim2 <- mod$sim(poppar = run1, data = "newdata.csv", ...) +sim2 <- mod$sim(poppar = run1, data = "newdata.csv", ...) # poppar and data necessary, model obtained from mod }\if{html}{\out{
}} \item Population prior parameters as a \link{PM_final} object found in \code{PM_result$final}. \if{html}{\out{
}}\preformatted{run1 <- PM_load(1) # load the PM_result object -sim1 <- PM_sim$new(poppar = run1$final, model = newmodel, data = newdata, ...) +sim1 <- PM_sim$new(poppar = run1$final, model = newmodel, data = newdata, ...) # model and data necessary mod <- PM_model$new("model.txt") # or use a model object -sim2 <- mod$sim(poppar = run1$final, data = "newdata.csv", ...) +sim2 <- mod$sim(poppar = run1$final, data = "newdata.csv", ...) # poppar and data necessary, model obtained from mod }\if{html}{\out{
}} \item The name of a previously saved simulation via the \verb{$save} method. The @@ -259,9 +258,9 @@ Examples: \item Single distribution: } -\if{html}{\out{
}}\preformatted{poppar = list(wt = 1, - mean = list(ke = 0.5, v = 100), - cov = matrix(c(0.04, 2.4, 2.8, 400), nrow = 2)) # sd not required because cov specified +\if{html}{\out{
}}\preformatted{poppar = list(wt = 1, + mean = list(ke = 0.5, v = 100), + cov = matrix(c(0.04, 2.4, 2.8, 400), nrow = 2)) # sd not required because cov specified }\if{html}{\out{
}} \itemize{ \item Multiple distributions: @@ -272,17 +271,6 @@ Examples: sd = list(ke = 0.2, v = 20), # overall sd, ignoring multiple distributions cor = matrix(c(1, 0.6, 0.7, 1), nrow = 2)) # sd required because cor specified }\if{html}{\out{
}} -\item A data frame with one column for each parameter and one row for each parameter set -to simulate. This is useful when you already have fixed parameter values, such as -\code{NPex$final$popPoints}. Each row will generate one simulated profile, so \code{nsim} is -ignored and the number of simulated profiles will equal the number of rows in the -data frame. If a \verb{$prob} column is present, it will be ignored, since each row is -treated as the parameters to be used for one simulation. - -\if{html}{\out{
}}\preformatted{poppar <- as.data.frame(run1$final$popPoints) |> - dplyr::select(ke, v) -sim1 <- PM_sim$new(poppar = poppar, model = run1$model, data = run1$data) -}\if{html}{\out{
}} }} \item{\code{model}}{Name of a suitable \link{PM_model} object or a model file template in the working directory. If missing, and \code{poppar} is a \link{PM_result}, @@ -348,9 +336,7 @@ all subjects in the data file will be used, i.e. none excluded. Using both \code{include} and \code{exclude} criteria may result in conflicts.} \item{\code{nsim}}{The number of simulated profiles to create, per subject. Default is 1000. Entering 0 will result in one profile being simulated from each -point in the non-parametric prior (for NPAG final objects only). If \code{poppar} -is supplied as a data frame of parameter values, \code{nsim} is ignored and the -number of simulated profiles will equal the number of rows in that data frame.} +point in the non-parametric prior (for NPAG final objects only).} \item{\code{predInt}}{The interval in fractional hours for simulated predicted outputs at times other than those specified in the template \code{data}. The default is 0, which means there will be simulated outputs only at times @@ -715,26 +701,6 @@ result.} } } -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-PM_sim-opt}{}}} -\subsection{\code{PM_sim$opt()}}{ - \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} -Calculate optimal sampling times - \subsection{Usage}{ - \if{html}{\out{
}} - \preformatted{PM_sim$opt(...)} - \if{html}{\out{
}} - } - \subsection{Arguments}{ - \if{html}{\out{
}} - \describe{ - \item{\code{...}}{Additional parameters, refer to \link{PM_opt}} - } - \if{html}{\out{
}} - } -} - \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-PM_sim-pta}{}}} @@ -770,7 +736,7 @@ Calculates the AUC of the specified simulation \subsection{Arguments}{ \if{html}{\out{
}} \describe{ - \item{\code{...}}{Arguments passed to \link{make_AUC}.} + \item{\code{...}}{Arguments passed to \link{makeAUC}.} } \if{html}{\out{
}} } diff --git a/man/bd.Rd b/man/bd.Rd new file mode 100644 index 00000000..4a650f1d --- /dev/null +++ b/man/bd.Rd @@ -0,0 +1,244 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PM_bestdose.R +\name{bd} +\alias{bd} +\title{Object to contain BestDose optimization results} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +This object is created after a successful BestDose optimization run. +BestDose finds optimal dosing regimens to achieve target drug concentrations +or AUC values using Bayesian optimization. +} +\section{Public fields}{ + \if{html}{\out{
}} + \describe{ + \item{\code{past}}{PM_data object containing past patient data used in the optimization (if applicable)} + + \item{\code{past_pred}}{PM_sim object containing model predictions for the past data} + + \item{\code{future}}{PM_data object containing future data used in the optimization} + + \item{\code{future_pred}}{PM_sim object containing model predictions for the future data} + + \item{\code{result}}{List containing optimization results, including optimal doses, predictions, and objective function value} + + \item{\code{posterior}}{The \code{bd_post} object used to compute the posterior distribution (if applicable)} + + \item{\code{prior_weight}}{The prior weight (lambda) used in the optimization (if applicable)} + + \item{\code{start}}{Start specification provided by user (numeric hours or datetime string)} + + \item{\code{start_offset}}{Resolved numeric offset (hours) used internally; NULL means use target times as-is} + + \item{\code{future_requested_doses}}{Numeric vector of originally requested future doses (0 = optimize, non-zero = fixed)} + + \item{\code{future_target_info}}{List with target_type, target, and target_time from the original future specification} + } + \if{html}{\out{
}} +} +\section{Active bindings}{ + \if{html}{\out{
}} + \describe{ + \item{\code{doses}}{Optimal doses found by BestDose optimization} + + \item{\code{objf}}{Objective function value at the optimal doses} + + \item{\code{method}}{Optimization method used} + + \item{\code{status}}{Status of the optimization run} + } + \if{html}{\out{
}} +} +\section{Methods}{ +\subsection{Public methods}{ + \itemize{ + \item \href{#method-bd-initialize}{\code{bd$new()}} + \item \href{#method-bd-print}{\code{bd$print()}} + \item \href{#method-bd-save}{\code{bd$save()}} + \item \href{#method-bd-plot}{\code{bd$plot()}} + \item \href{#method-bd-report}{\code{bd$report()}} + \item \href{#method-bd-clone}{\code{bd$clone()}} + } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-bd-initialize}{}}} +\subsection{\code{bd$new()}}{ + Initialize a \code{bd} object by running a one-shot BestDose optimization. +Creates the posterior internally, then optimizes. For reusing the posterior +across multiple optimizations, use \code{bd_post$new()} followed by \verb{$optimize()}. + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{bd$new( + model = NULL, + prior = NULL, + past_data = NULL, + future = NULL, + dose_range = list(min = 0, max = 1000), + prior_weight = 0.5, + start = 0, + max_cycles = 500, + settings = NULL, + posterior = NULL, + quiet = FALSE +)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{model}}{PM_model object or path to compiled model} + \item{\code{prior}}{Prior parameter value distributions for the model, can be a \link{PM_result}, \link{PM_final}, or path to \code{theta.csv} file.} + \item{\code{past_data}}{PM_data object or path to CSV file with past patient data (optional). Omitting this will plan a new regimen for the patient +based on the population prior without any individualization other than inclusion of any covariates which are in the model.} + \item{\code{future}}{The future regimen to optimize. It can be one of three things: +\itemize{ +\item A list describing future dosing/target setup with elements: +\itemize{ +\item \code{dose} The amount to administer (required). Use \code{0} to optimize that dose to achieve the target; any other value is treated as fixed. +Can be a scalar or a numeric vector. If a vector is provided, each element corresponds to each dose event in order. +\item \code{frequency} How often to administer dose(s) (default 24 hours). Can be a scalar or numeric vector; when vectorized, +element \code{i} is the interval after dose \code{i} and before dose \code{i+1}. +\item \code{route} Either 0 for oral/bolus, or a value >0 indicating infusion duration. Can be a scalar or numeric vector; +when vectorized, element \code{i} applies to dose \code{i}. +\item \code{number} The total number of doses to administer in the future (default 1). +If \code{number} is smaller than \code{max(length(dose), length(frequency), length(route))}, it is increased to that maximum and an informational message is shown. +If any of \code{dose}, \code{frequency}, or \code{route} are shorter than \code{number}, their last value is recycled to length \code{number}. +\item \code{target} The target value to achieve after every dose (required). +\item \code{target_type} The target type (default \code{"concentration"}). Must be one of \code{"concentration"}, \code{"auc"}, or \code{"time"}. +\code{"concentration"} targets a concentration at \code{target_time}; \code{"auc"} targets an AUC from dose time to \code{target_time}; +\code{"time"} uses \code{target_time} as a proportion between 0 and 1 of each dose interval. +\item \code{target_time} For \code{target_type = "concentration"} or \code{"auc"}, the time after each dose at which to evaluate the target, +default 24 hours if unspecified. For \code{target_type = "time"}, this must be a single numeric proportion between 0 and 1, +and each target observation time is set to \code{round(frequency[i] * target_time)} hours after dose \code{i}. +\item \code{covariates} Named list of covariates in the model with values to use. If there are no covariates in the model, this can be omitted. +} +\item A \code{PM_data} object containing the future regimen and target observations. Dose events should be included with \code{evid=1} and target observations should be included with \code{evid=0} and \code{out} equal to the target value. +When \code{future} is supplied this way, concentration targets are assumed. +\item A path to a CSV file containing the future regimen and target observations in the same format as described for the \code{PM_data} object above. +When \code{future} is supplied this way, concentration targets are assumed. +}} + \item{\code{dose_range}}{List with 'min' and 'max' elements defining the dose search range (default: 0 to 1000)} + \item{\code{prior_weight}}{Numeric between 0 and 1 indicating the balance between the prior and the posterior in the optimization (default: 0.5). +If 1, the model prior parameter +value distribution will be used as the sole basis for optimization. If 0, only the Bayesian posterior parameter distribution will be used, +which incorporates the patient history. Values between 0 and 1 will weight the contribution of the prior vs posterior parameter distributions in the optimization. +Choose values closer to 1 when the patient history is sparse or not believed to be very informative, and values closer to 0 when the patient history is rich and believed to be highly informative.} + \item{\code{start}}{Start time for the future regimen. Can be either: +\itemize{ +\item \code{NULL}: use the supplied future/target times as-is, without appending them after past data. +\item Numeric hours (default \code{0}): relative to the last event date/time in past data, or if no past data, +relative to the next local clock hour. +\item Date-time character string: interpreted as an absolute start date/time and converted to an internal hour offset. +Ambiguous formats (e.g. \code{01/02/26}) are resolved using the \code{date_format} Pmetrics option +(set via \link{setPMoptions}), which defaults to \verb{\%m/\%d/\%y} for US locales and \verb{\%d/\%m/\%y} otherwise. +Accepted formats include: +\itemize{ +\item \verb{YYYY-mm-dd HH:MM[:SS]} +\item \verb{mm/dd/[YY]YY HH:MM[:SS]} or \verb{mm-dd-[YY]YY HH:MM[:SS]} +\item \verb{dd/mm/[YY]YY HH:MM[:SS]} or \verb{dd-mm-[YY]YY HH:MM[:SS]} +} +}} + \item{\code{max_cycles}}{Maximum number of optimization cycles for computing the posterior (default: 500)} + \item{\code{settings}}{List of additional settings for posterior computation (optional)} + \item{\code{posterior}}{\code{bd_post} object to use instead of computing a new one (optional). +When provided, \code{prior}, \code{model}, \code{past_data}, \code{max_cycles}, and \code{settings} are ignored, as they are already included in the \code{posterior} object.} + \item{\code{quiet}}{Logical indicating whether to suppress verbose simulation output (default: FALSE)} + } + \if{html}{\out{
}} + } + \subsection{Returns}{ + A \code{bd} object containing the optimization results and associated information + } +} + +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-bd-print}{}}} +\subsection{\code{bd$print()}}{ + Print summary of BestDose results + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{bd$print()} + \if{html}{\out{
}} + } +} + +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-bd-save}{}}} +\subsection{\code{bd$save()}}{ + Save results to RDS file + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{bd$save(filename = "bestdose_result.rds")} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{filename}}{Path to save file. Default: "bestdose_result.rds"} + } + \if{html}{\out{
}} + } +} + +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-bd-plot}{}}} +\subsection{\code{bd$plot()}}{ + Plot observed and predicted concentrations over time for both past and future data + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{bd$plot(...)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{...}}{Additional arguments passed to plot.bd function} + } + \if{html}{\out{
}} + } +} + +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-bd-report}{}}} +\subsection{\code{bd$report()}}{ + Generate an HTML report for a BestDose result + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{bd$report(...)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{...}}{Parameters passed to the internal BestDose report generator.} + } + \if{html}{\out{
}} + } +} + +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-bd-clone}{}}} +\subsection{\code{bd$clone()}}{ + The objects of this class are cloneable with this method. + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{bd$clone(deep = FALSE)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{deep}}{Whether to make a deep clone.} + } + \if{html}{\out{
}} + } +} + +} diff --git a/man/bd_post.Rd b/man/bd_post.Rd new file mode 100644 index 00000000..e75058e8 --- /dev/null +++ b/man/bd_post.Rd @@ -0,0 +1,138 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PM_bestdose.R +\name{bd_post} +\alias{bd_post} +\title{Compute a reusable BestDose posterior} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Use \code{bd_post} to compute the Bayesian posterior once from +prior population data and patient history, then call \verb{$optimize()} multiple +times with different targets, dose ranges, or bias weights. +} +\section{Public fields}{ + \if{html}{\out{
}} + \describe{ + \item{\code{handle}}{Memory pointer to the computed posterior (opaque to users)} + + \item{\code{theta}}{Matrix of support points in the posterior distribution} + + \item{\code{theta_dim}}{Dimensions of the theta matrix} + + \item{\code{param_names}}{Names of the parameters in the posterior} + + \item{\code{posterior_weights}}{Weights of the posterior support points} + + \item{\code{population_weights}}{Weights of the population support points} + + \item{\code{past}}{PM_data object containing past patient data used in the posterior computation (if applicable)} + + \item{\code{model_info}}{Information about the model used} + + \item{\code{settings}}{Settings used for the posterior computation} + } + \if{html}{\out{
}} +} +\section{Methods}{ +\subsection{Public methods}{ + \itemize{ + \item \href{#method-bd_post-initialize}{\code{bd_post$new()}} + \item \href{#method-bd_post-optimize}{\code{bd_post$optimize()}} + \item \href{#method-bd_post-clone}{\code{bd_post$clone()}} + } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-bd_post-initialize}{}}} +\subsection{\code{bd_post$new()}}{ + Initialize the \code{bd_post} object by computing the posterior distribution from the given prior, model, and past data + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{bd_post$new( + prior, + model, + past_data = NULL, + max_cycles = 500, + settings = NULL, + quiet = FALSE +)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{prior}}{Prior information for the model, can be a PM_result, PM_final, or path to theta.csv} + \item{\code{model}}{PM_model object or path to compiled model} + \item{\code{past_data}}{PM_data object or path to CSV file with past patient data (optional)} + \item{\code{max_cycles}}{Maximum number of optimization cycles for computing the posterior (default: 500)} + \item{\code{settings}}{List of additional settings for posterior computation (optional)} + \item{\code{quiet}}{Logical indicating whether to suppress verbose simulation output (default: FALSE)} + } + \if{html}{\out{
}} + } + \subsection{Returns}{ + A \code{bd_post} object containing the computed posterior distribution and associated information + } +} + +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-bd_post-optimize}{}}} +\subsection{\code{bd_post$optimize()}}{ + Run optimization and return a \code{bd} result object + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{bd_post$optimize( + target, + dose_range = list(min = 0, max = 1000), + prior_weight = 0.5, + start = 0, + quiet = NULL +)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{target}}{Future regimen/target specification. Accepts the same forms as the \code{future} argument to \code{bd$new()}: +a list with elements such as \code{dose}, \code{frequency}, \code{route}, \code{number}, \code{target}, \code{target_type}, and \code{target_time}; +a \code{PM_data} object; or a path to a CSV file.} + \item{\code{dose_range}}{List with 'min' and 'max' elements defining the dose search range (default: 0 to 1000)} + \item{\code{prior_weight}}{Numeric between 0 and 1 indicating the weight of bias in the optimization (default: 0.5)} + \item{\code{start}}{Start time for future regimen. Can be either \code{NULL}, numeric hours (default: \code{0}), or a date-time +character string. Ambiguous formats are resolved using the \code{date_format} Pmetrics option +(see \link{setPMoptions}). Accepted string formats: +\itemize{ +\item \verb{YYYY-mm-dd HH:MM[:SS]} +\item \verb{mm/dd/[YY]YY HH:MM[:SS]} or \verb{mm-dd-[YY]YY HH:MM[:SS]} +\item \verb{dd/mm/[YY]YY HH:MM[:SS]} or \verb{dd-mm-[YY]YY HH:MM[:SS]} +}} + \item{\code{quiet}}{Logical indicating whether to suppress verbose simulation output. If NULL, uses the quiet setting from posterior computation (default: NULL)} + } + \if{html}{\out{
}} + } + \subsection{Returns}{ + A \code{bd} object containing the optimization results + } +} + +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-bd_post-clone}{}}} +\subsection{\code{bd_post$clone()}}{ + The objects of this class are cloneable with this method. + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{bd_post$clone(deep = FALSE)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{deep}}{Whether to make a deep clone.} + } + \if{html}{\out{
}} + } +} + +} diff --git a/man/downloadR.Rd b/man/downloadR.Rd index 78e8dd24..c2de7714 100644 --- a/man/downloadR.Rd +++ b/man/downloadR.Rd @@ -4,6 +4,8 @@ \alias{downloadR} \title{Download the latest platform-specific R installer} \usage{ +downloadR(r_info = latestR(), destdir = path.expand("~/Downloads")) + downloadR(r_info = latestR(), destdir = path.expand("~/Downloads")) } \arguments{ @@ -12,9 +14,15 @@ downloadR(r_info = latestR(), destdir = path.expand("~/Downloads")) \item{destdir}{Destination directory. Defaults to the user's Downloads folder.} } \value{ +The file path of the downloaded installer/tarball. + The file path of the downloaded installer/tarball. } \description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} +Downloads the latest R installer (or source tarball on Linux) for the current +platform to the user's Downloads folder. + \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} Downloads the latest R installer (or source tarball on Linux) for the current platform to the user's Downloads folder. diff --git a/man/latestR.Rd b/man/latestR.Rd index fc7d4bb0..334f08d3 100644 --- a/man/latestR.Rd +++ b/man/latestR.Rd @@ -4,12 +4,20 @@ \alias{latestR} \title{Get latest platform-specific R release metadata} \usage{ +latestR() + latestR() } \value{ +A list containing all fields returned by the API response. + A list containing all fields returned by the API response. } \description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} +Retrieves metadata for the latest R release available for the current +platform from the r-hub rversions API. + \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} Retrieves metadata for the latest R release available for the current platform from the r-hub rversions API. diff --git a/man/makeAUC.Rd b/man/makeAUC.Rd old mode 100644 new mode 100755 diff --git a/man/plot.PM_data.Rd b/man/plot.PM_data.Rd index 30c4dc42..f3d85f69 100755 --- a/man/plot.PM_data.Rd +++ b/man/plot.PM_data.Rd @@ -44,19 +44,17 @@ Here \code{line} is a list of two elements: \item \code{join} Can either be a boolean or a list. If set to \code{TRUE} or a list of plotly line attributes, it will generate line segments joining observations. If set to -\code{FALSE}, no segments will be generated. -} - -**Note:**The color of the joining line +\code{FALSE}, no segments will be generated. The color of the joining line is the same as the marker color for that line. To avoid confusion, the line -color cannot be changed. Change the \code{marker} color instead. The default +color cannot be changed. The default values for the other elements of the \code{join} list, both of which can be overriden are: -- \code{width }Width of the segments, default 1. -- \code{dash} See \code{plotly::schema()}, traces > scatter > attributes > +\itemize{ +\item \code{width }Width of the segments, default 1. +\item \code{dash} See \code{plotly::schema()}, traces > scatter > attributes > line > dash > values. Default is "solid". Example: \code{line = list(join = list(dash = "longdash", width = 2))} -\itemize{ +} \item \code{pred} Default is \code{FALSE}, which means that predictions will not be included in the plot. To include predictions, supply one of the following: \item If plotting data contained in a \link{PM_result}, use "pop" or "post" to include population or posterior predictions. @@ -102,7 +100,7 @@ a covariate like "gender"} \item{group_names}{A character vector of names to label the \strong{groups} if \code{legend = TRUE}. This vector must be the same length as the number of groups within \code{group}. If missing, the vector will be generated from the unique values in \code{group}. -Example: \code{c("Male", "Female")} if \code{group = "gender"} and "gender" is a covariate +Example: \code{c("Male", "Female")} if \code{color = "gender"} and "gender" is a covariate in the data.} \item{mult}{Multiplication factor for y axis, e.g. to convert mg/L to ng/mL} diff --git a/man/plot.PM_data_data.Rd b/man/plot.PM_data_data.Rd deleted file mode 100644 index c06f033c..00000000 --- a/man/plot.PM_data_data.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/PM_data.R -\name{plot.PM_data_data} -\alias{plot.PM_data_data} -\title{Plot method for PM_data data frames} -\usage{ -\method{plot}{PM_data_data}(x, ...) -} -\arguments{ -\item{x}{A data frame in the format of the \code{standard_data} field of a \link{PM_data} object} - -\item{...}{Additional arguments passed to \link{plot.PM_data}} -} -\value{ -A plot of the data. -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} -Allows plotting of altered \link{PM_data} objects. -} -\details{ -This is useful if you want to modify the data in a \link{PM_data} object, e.g. to filter the data, but still want to use the plotting capabilities of \link{plot.PM_data}. -See \link{plot.PM_data} for details on how to format the plot. -} -\examples{ -\dontrun{ -# filter then plot the standard_data data frame from a PM_data object -dataEx$standard_data |> - filter(gender == 0) |> - plot() -} - -} -\seealso{ -\link{PM_data}, \link{plot.PM_data} -} -\author{ -Michael Neely -} diff --git a/man/plot.bd.Rd b/man/plot.bd.Rd new file mode 100644 index 00000000..56cfb65a --- /dev/null +++ b/man/plot.bd.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PM_bestdose.R +\name{plot.bd} +\alias{plot.bd} +\title{Plot BestDose predictions} +\usage{ +\method{plot}{bd}( + x, + mult = 1, + outeq = 1, + quiet = FALSE, + legend = TRUE, + log = FALSE, + grid = FALSE, + future_region = FALSE, + xlab = "Time", + ylab = "Concentration", + title = NULL, + xlim = NULL, + ylim = NULL, + print = TRUE, + ... +) +} +\arguments{ +\item{x}{A \code{bd} object containing the best dose predictions.} + +\item{mult}{Numeric multiplier to apply to the concentrations (default: 1, no scaling).} + +\item{outeq}{Numeric value of outeq to filter observations for plotting (default: 1).} + +\item{quiet}{Logical indicating whether to suppress messages (default: FALSE).} + +\item{legend}{Logical indicating whether to display a legend (default: TRUE).} + +\item{log}{Logical indicating whether to use a logarithmic scale for the y-axis (default: FALSE).} + +\item{grid}{Logical indicating whether to display a grid (default: FALSE).} + +\item{future_region}{Logical indicating whether to display the divider line and shaded region for future data (default: FALSE).} + +\item{xlab}{Label for the x-axis.} + +\item{ylab}{Label for the y-axis.} + +\item{title}{Title of the plot.} + +\item{xlim}{Limits for the x-axis.} + +\item{ylim}{Limits for the y-axis.} + +\item{print}{Logical indicating whether to print the plot (default: TRUE).} + +\item{...}{Additional arguments passed to the plotting function.} +} +\value{ +Invisibly returns a plotly object. +} +\description{ +Plot observed and predicted concentrations over time for both past and future data, +with options to apply a multiplier to the concentrations, and customize the plot appearance. The top 5 posterior support +points are highlighted with distinct colors. +} diff --git a/src/rust/src/bestdose_executor.rs b/src/rust/src/bestdose_executor.rs new file mode 100644 index 00000000..e4fe8ddc --- /dev/null +++ b/src/rust/src/bestdose_executor.rs @@ -0,0 +1,353 @@ +use crate::{logs::RFormatLayer, settings::settings}; +use extendr_api::prelude::*; +use pmcore::bestdose::{BestDosePosterior, BestDoseResult, DoseRange, Target}; +use pmcore::prelude::{data, ODE}; +use pmcore::routines::initialization::parse_prior; +use std::path::PathBuf; + +/// Helper to parse target type from string +pub(crate) fn parse_target_type(target_str: &str) -> std::result::Result { + match target_str.to_lowercase().as_str() { + "concentration" => Ok(Target::Concentration), + "auc_from_zero" | "auc" => Ok(Target::AUCFromZero), + "auc_from_last_dose" | "auc_interval" => Ok(Target::AUCFromLastDose), + _ => Err(format!( + "Invalid target type: {}. Must be 'concentration', 'auc_from_zero', or 'auc_from_last_dose'", + target_str + )), + } +} + +/// R-compatible prediction row for BestDose output +#[derive(Debug, IntoDataFrameRow)] +pub struct BestDosePredictionRow { + id: String, + time: f64, + observed: f64, + pop_mean: f64, + pop_median: f64, + post_mean: f64, + post_median: f64, + outeq: usize, +} + +impl BestDosePredictionRow { + pub fn from_np_prediction( + pred: &pmcore::routines::output::predictions::NPPredictionRow, + id: &str, + ) -> Self { + Self { + id: id.to_string(), + time: pred.time(), + observed: pred.obs().unwrap_or(0.0), + pop_mean: pred.pop_mean(), + pop_median: pred.pop_median(), + post_mean: pred.post_mean(), + post_median: pred.post_median(), + outeq: pred.outeq(), + } + } +} + +/// R-compatible AUC prediction row +#[derive(Debug, IntoDataFrameRow)] +pub struct BestDoseAucRow { + time: f64, + auc: f64, +} + +/// Convert BestDoseResult to R-compatible list structure +pub(crate) fn convert_bestdose_result_to_r( + result: BestDoseResult, +) -> std::result::Result { + // Extract doses + let doses: Vec = result.doses(); + + // Objective function + let objf = result.objf(); + + // Status + let status_str = format!("{:?}", result.status()); + + // Predictions as data frame + let pred_rows: Vec = result + .predictions() + .predictions() + .iter() + .map(|p| BestDosePredictionRow::from_np_prediction(p, "subject_1")) + .collect(); + let pred_df = pred_rows + .into_dataframe() + .map_err(|e| format!("Failed to create predictions dataframe: {:?}", e))?; + + // AUC predictions (if available) + let auc_val = if let Some(auc_preds) = result.auc_predictions() { + let auc_rows: Vec = auc_preds + .iter() + .map(|(time, auc)| BestDoseAucRow { + time: *time, + auc: *auc, + }) + .collect(); + let auc_df = auc_rows + .into_dataframe() + .map_err(|e| format!("Failed to create AUC dataframe: {:?}", e))?; + Robj::from(auc_df) + } else { + Robj::from(()) // NULL for no AUC + }; + + // Optimization method + let method_str = format!("{}", result.optimization_method()); + + // Build the list using list! macro + let output = list!( + doses = doses, + objf = objf, + status = status_str, + predictions = pred_df, + auc_predictions = auc_val, + method = method_str + ); + + Ok(output.into()) +} +/// Opaque handle that keeps the dynamic model library alive while reusing the +/// prepared `BestDosePosterior` for multiple optimization runs. +pub struct BestDosePosteriorHandle { + posterior: BestDosePosterior, + #[allow(dead_code)] + library: libloading::Library, +} + +impl BestDosePosteriorHandle { + pub fn new( + model_path: PathBuf, + prior_path: PathBuf, + past_data_path: Option, + params: List, + ) -> std::result::Result { + let (library, (eq, meta)) = + unsafe { pmcore::prelude::pharmsol::exa::load::load::(model_path) }; + + let settings = settings(params, meta.get_params(), "/tmp/bestdose") + .map_err(|e| format!("Failed to parse settings: {}", e))?; + + let (population_theta, prior_weights) = + parse_prior(&prior_path.to_str().unwrap().to_string(), &settings) + .map_err(|e| format!("Failed to parse prior: {}", e))?; + + let population_weights = prior_weights + .ok_or_else(|| "Prior file must contain a 'prob' column with weights".to_string())?; + + let past_data = if let Some(path) = past_data_path { + let data = data::read_pmetrics(path.to_str().unwrap()) + .map_err(|e| format!("Failed to read past data: {}", e))?; + let subjects = data.subjects(); + if subjects.is_empty() { + return Err("Past data file contains no subjects".to_string()); + } + Some(subjects[0].clone()) + } else { + None + }; + + let posterior = BestDosePosterior::compute( + &population_theta, + &population_weights, + past_data, + eq, + settings, + ) + .map_err(|e| format!("Failed to compute BestDose posterior: {}", e))?; + + Ok(Self { posterior, library }) + } + + #[allow(clippy::too_many_arguments)] + pub fn optimize( + &self, + target_data_path: PathBuf, + time_offset: Option, + dose_min: f64, + dose_max: f64, + bias_weight: f64, + target_type: &str, + ) -> std::result::Result { + let target_data = { + let data = data::read_pmetrics(target_data_path.to_str().unwrap()) + .map_err(|e| format!("Failed to read target data: {}", e))?; + let subjects = data.subjects(); + if subjects.is_empty() { + return Err("Target data file contains no subjects".to_string()); + } + subjects[0].clone() + }; + + let target_enum = parse_target_type(target_type)?; + let dose_range = DoseRange::new(dose_min, dose_max); + + self.posterior + .optimize( + target_data, + time_offset, + dose_range, + bias_weight, + target_enum, + ) + .map_err(|e| format!("Optimization failed: {}", e)) + } + + pub fn posterior(&self) -> &BestDosePosterior { + &self.posterior + } +} + +pub(crate) struct PosteriorSummary { + theta_values: Vec, + theta_dim: (i32, i32), + param_names: Vec, + posterior_weights: Vec, + population_weights: Vec, +} + +fn summarize_handle(handle: &BestDosePosteriorHandle) -> PosteriorSummary { + let theta = handle.posterior().theta(); + let matrix = theta.matrix(); + let nrows = matrix.nrows() as i32; + let ncols = matrix.ncols() as i32; + let mut theta_values = vec![0.0; (nrows * ncols) as usize]; + + for col in 0..ncols as usize { + for row in 0..nrows as usize { + theta_values[row + col * nrows as usize] = *matrix.get(row, col); + } + } + + PosteriorSummary { + theta_values, + theta_dim: (nrows, ncols), + param_names: theta.param_names(), + posterior_weights: handle.posterior().posterior_weights().to_vec(), + population_weights: handle.posterior().population_weights().to_vec(), + } +} + +fn vec_to_doubles(values: Vec, label: &str) -> std::result::Result { + Doubles::try_from(values) + .map_err(|e| format!("Failed to convert {} to doubles: {:?}", label, e)) +} + +fn dims_to_integers(dim: (i32, i32)) -> std::result::Result { + Integers::try_from(vec![dim.0, dim.1]) + .map_err(|e| format!("Failed to convert dims to integers: {:?}", e)) +} + +fn names_to_strings(names: &[String]) -> Strings { + Strings::from_values(names.iter().map(|s| s.as_str())) +} + +pub(crate) fn prepare_bestdose_posterior( + model_path: PathBuf, + prior_path: PathBuf, + past_data_path: Option, + params: List, +) -> std::result::Result<(BestDosePosteriorHandle, PosteriorSummary), String> { + let handle = BestDosePosteriorHandle::new(model_path, prior_path, past_data_path, params)?; + + let summary = summarize_handle(&handle); + Ok((handle, summary)) +} + +pub(crate) fn bestdose_prepare_internal( + model_path: &str, + prior_path: &str, + past_data_path: Nullable, + params: List, + kind: &str, +) -> Robj { + RFormatLayer::reset_global_timer(); + let _ = crate::setup_logs(); + + let past_path = past_data_path.into_option().map(PathBuf::from); + + let preparation = match kind { + "ode" => prepare_bestdose_posterior( + PathBuf::from(model_path), + PathBuf::from(prior_path), + past_path, + params.clone(), + ), + "analytical" => Err("BestDose for analytical models is not yet supported".to_string()), + other => Err(format!("{} is not a supported model type", other)), + }; + + match preparation { + Ok((handle, summary)) => { + let theta_values = match vec_to_doubles(summary.theta_values, "theta_values") { + Ok(values) => values, + Err(e) => return Robj::from(e), + }; + let theta_dim = match dims_to_integers(summary.theta_dim) { + Ok(dim) => dim, + Err(e) => return Robj::from(e), + }; + let posterior_weights = + match vec_to_doubles(summary.posterior_weights, "posterior_weights") { + Ok(values) => values, + Err(e) => return Robj::from(e), + }; + let population_weights = + match vec_to_doubles(summary.population_weights, "population_weights") { + Ok(values) => values, + Err(e) => return Robj::from(e), + }; + let param_names = names_to_strings(&summary.param_names); + let handle_ptr = ExternalPtr::new(handle); + + let output = list!( + handle = handle_ptr, + theta_values = theta_values, + theta_dim = theta_dim, + param_names = param_names, + posterior_weights = posterior_weights, + population_weights = population_weights, + nspp = summary.theta_dim.0, + n_parameters = summary.theta_dim.1 + ); + + output.into() + } + Err(e) => Robj::from(format!("BestDose prepare failed: {}", e)), + } +} + +pub(crate) fn bestdose_optimize_internal( + handle: ExternalPtr, + target_data_path: &str, + time_offset: Nullable, + dose_min: f64, + dose_max: f64, + bias_weight: f64, + target_type: &str, +) -> Robj { + let time_offset = time_offset.into_option(); + + match handle.try_addr() { + Ok(inner) => match inner.optimize( + PathBuf::from(target_data_path), + time_offset, + dose_min, + dose_max, + bias_weight, + target_type, + ) { + Ok(result) => match convert_bestdose_result_to_r(result) { + Ok(robj) => robj, + Err(e) => Robj::from(format!("Failed to convert result: {}", e)), + }, + Err(e) => Robj::from(format!("BestDose optimization failed: {}", e)), + }, + Err(e) => Robj::from(format!("Invalid BestDose handle: {}", e)), + } +} diff --git a/src/rust/src/lib.rs b/src/rust/src/lib.rs index 89e99f4f..39d813a8 100644 --- a/src/rust/src/lib.rs +++ b/src/rust/src/lib.rs @@ -1,3 +1,4 @@ +// mod build; mod executor; mod logs; mod settings; @@ -230,10 +231,10 @@ fn setup_logs() -> anyhow::Result<()> { use tracing_subscriber::filter::LevelFilter; // Create a subscriber with our custom layer using the global timer - // Filter to show INFO and above (INFO, WARN, ERROR) so cycle logs are visible + // Filter to show only WARN and above (WARN, ERROR) by default let subscriber = tracing_subscriber::registry() .with(RFormatLayer::new()) - .with(LevelFilter::from_level(Level::INFO)); + .with(LevelFilter::from_level(Level::WARN)); // Set as global default - this will fail if already set, which is fine // We just ignore the error @@ -242,6 +243,9 @@ fn setup_logs() -> anyhow::Result<()> { Ok(()) } +// Macro to generate exports. +// This ensures exported functions are registered with R. +// See corresponding C code in `entrypoint.c`. extendr_module! { mod Pmetrics; fn simulate_one; diff --git a/tests/testthat/helper-models.R b/tests/testthat/helper-models.R index 545a4a07..c4e1bf14 100644 --- a/tests/testthat/helper-models.R +++ b/tests/testthat/helper-models.R @@ -5,18 +5,6 @@ test_that <- function(desc, code) { } cleanup_exa_tmp <- function() { - exa_tmp <- tryCatch(temporary_path(), error = function(...) NA_character_) - - if ( - is.character(exa_tmp) && - length(exa_tmp) == 1 && - !is.na(exa_tmp) && - nzchar(exa_tmp) && - dir.exists(exa_tmp) - ) { - unlink(exa_tmp, recursive = TRUE, force = TRUE) - } - invisible(NULL) }