[ { "path": ".Rbuildignore", "content": "^__dev$\n^__validation$\n^_pkgdown\\.yml$\n^.*\\.code-workspace$\n^.*\\.Rcheck$\n^.*\\.tar.gz$\n^[.]?air[.]toml$\n^\\.claude$\n^\\.DS_Store$\n^\\.gemini$\n^\\.github$\n^\\.lintr$\n^\\.rtms-instructions\\.md$\n^\\.vscode$\n^cran-comments\\.md$\n^LICENSE\\.md$\n^data-raw$\n^dev$\n^docs$\n^specs$\n^AGENTS\\.md$\n^NEWS\\.md$\n^pkgdown$\n^Makefile$\n^SKILL\\.md$\n" }, { "path": ".github/.gitignore", "content": "*.html\n\n" }, { "path": ".github/CONTRIBUTING.md", "content": "# Contributing to rtemis\n\nThank you for your interest in contributing to **rtemis**! This guide will help you report issues effectively.\n\n## Before Opening an Issue\n\n### Update to Latest Version\n\nEnsure you're using the latest version of rtemis (v0.99+). Many issues may already be fixed in recent updates.\n\n```r\n# Install from CRAN\ninstall.packages(\"rtemis\")\n\n# Install from GitHub\npak::pak(\"rtemis-org/rtemis\")\n\n# Install from r-universe\ninstall.packages('rtemis', repos = 'https://rtemis-org.r-universe.dev')\n\n# Check your version\npackageVersion(\"rtemis\")\n```\n\n### Check Existing Issues\n\nPlease search [existing issues](https://github.com/rtemis-org/rtemis/issues) to see if your problem or suggestion has already been reported. If you find a related issue, add a comment with any additional information.\n\n### Review Documentation\n\n- **API Documentation**: https://docs.rtemis.org/r/ml-api/\n- **General Documentation**: https://docs.rtemis.org/r/ml\n\n## Opening an Issue\n\n### Issue Types\n\nWe welcome the following types of issues:\n\n1. **🐛 Bug Reports**: Unexpected behavior, errors, or crashes. (Use `[BUG]` in the title)\n2. **✨ Feature Requests**: Ideas for new functionality. (Use `[FEATURE]` in the title)\n3. **📚 Documentation**: Improvements to docs or examples. (Use `[DOC]` in the title)\n4. **❓ Questions**: Use [Discussions](https://github.com/rtemis-org/rtemis/discussions) for usage questions\n\n### Bug Reports\n\nA good bug report should include:\n\n#### Required Information\n\n1. **rtemis version**: Output of `packageVersion(\"rtemis\")`\n2. **R version**: Output of `R.version.string`\n3. **Operating System**: e.g., macOS 14.5, Ubuntu 22.04, Windows 11\n4. **Clear description**: What did you expect vs. what actually happened?\n\n#### Reproducible Example\n\n**Critical**: Provide a minimal reproducible example. Use the template below:\n\n```r\n# Load required packages\nlibrary(rtemis)\nlibrary(data.table) # if needed\n\n# Create minimal data\nset.seed(2025)\nn <- 100\nx <- rnormmat(n, 3)\ny <- x[, 1] + x[, 2] + rnorm(n)\ndat <- data.frame(x, y)\n\n# Demonstrate the issue\nmod <- train(\n x = dat,\n algorithm = \"glm\"\n)\n\n# Expected: Model trains successfully\n# Actual: Error message...\n```\n\n#### Error Messages\n\nInclude **complete error messages** with full stack traces. If the error is verbose, use a code block:\n\n```\nError in train(...):\n! You must define either `hyperparameters` or `algorithm`.\n```\n\n#### Session Info (for complex issues)\n\nFor crashes or environment-specific issues, include:\n\n```r\nsessionInfo()\n```\n\n### Feature Requests\n\nFor feature requests, please describe:\n\n1. **Use case**: What problem would this solve?\n2. **Proposed solution**: How should it work?\n3. **Alternatives considered**: What workarounds exist currently?\n4. **Impact**: Who would benefit from this feature?\n\n**Example:**\n\n> **Use case**: I frequently need to train models with time-series cross-validation but the current resampling methods don't preserve temporal order.\n>\n> **Proposed solution**: Add `setup_TimeSeriesCV()` that creates train/test splits respecting time ordering.\n>\n> **Alternatives**: Currently using custom resampling with `outer_resampling` parameter, but it's verbose and error-prone.\n\n### Documentation Issues\n\nFor documentation improvements:\n\n1. **Location**: Specify which page or function (e.g., `?train`, `?setup_GLMNET`)\n2. **Problem**: What's unclear, incorrect, or missing?\n3. **Suggestion**: How could it be improved?\n\n## Version-Specific Notes\n\n### rtemis 0.99+ vs. rtemisalpha (Legacy)\n\n**Important**: This repository contains **rtemis 0.99+**, a complete rewrite using S7 classes. If you're using the legacy version (`rtemisalpha`), please note:\n\n- Legacy issues should reference [rtemis-legacy](https://github.com/rtemis-org/rtemis-legacy) (unmaintained)\n- Migration questions are welcome here\n- API differences are expected (see README.md for major changes)\n\n### Active Development\n\nrtemis 0.99+ is under active development. Features may change between releases. When reporting issues:\n\n- Specify your branch if not using `main` (check with `git branch`)\n- Note if the issue appears in a specific algorithm (some are being ported from the legacy version)\n\n## What Happens Next?\n\n1. **Triage**: Maintainers will review and label your issue\n2. **Discussion**: We may ask for clarification or additional details\n3. **Resolution**: \n - **Bugs**: Fixed in upcoming releases, referenced in commit messages\n - **Features**: Evaluated for inclusion in roadmap\n - **Questions**: Answered or redirected to appropriate resources\n\n## Code of Conduct\n\nBe respectful and constructive. We're all here to improve rtemis together.\n\n## Pull Requests\n\nWhile this guide focuses on issues, pull requests are welcome! Key points:\n\n- Discuss major changes in an issue first\n- Follow existing code style (S7 classes, roxygen2 documentation)\n- All `@param` must follow format: `Class: Description ending with period.`\n- Include tests for new functionality\n- Update documentation as needed\n\n## Questions?\n\n- **General usage**: [GitHub Discussions](https://github.com/rtemis-org/rtemis/discussions)\n- **Bug reports/features**: [GitHub Issues](https://github.com/rtemis-org/rtemis/issues)\n- **Security issues**: Contact maintainers directly (see DESCRIPTION file)\n\n---\n\nThank you for contributing to rtemis.\n" }, { "path": ".github/workflows/R-CMD-check.yaml", "content": "# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples\n# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help\n\non:\n pull_request:\n push:\n branches: [main]\n workflow_dispatch:\n\nname: R-CMD-check\n\npermissions: read-all\n\nconcurrency:\n group: R-CMD-check-${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }}\n cancel-in-progress: true\n\njobs:\n R-CMD-check:\n runs-on: ubuntu-latest\n\n env:\n GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}\n R_KEEP_PKG_SOURCE: yes\n\n steps:\n - uses: actions/checkout@v4\n - uses: r-lib/actions/setup-pandoc@v2\n - uses: r-lib/actions/setup-r@v2\n with:\n use-public-rspm: true\n - uses: r-lib/actions/setup-r-dependencies@v2\n with:\n extra-packages: any::rcmdcheck\n needs: check\n - uses: r-lib/actions/check-r-package@v2\n with:\n upload-snapshots: true\n build_args: 'c(\"--no-manual\", \"--compact-vignettes=gs+qpdf\")'\n error-on: '\"note\"'\n" }, { "path": ".gitignore", "content": "# Dev\n__dev/\n__validation/\ndev/\n__out/\nspecs/\n\n# Mac OS\n.DS_Store\n\n# VS Code\n.vscode\n*.code-workspace\n\n# R History files\n.Rhistory\n.Rapp.history\n\n# Output files from R CMD build\n/*.tar.gz\n\n# Output files from R CMD check\n/*.Rcheck/\n\n# pkgdown\n_pkgdown.yml\npkgdown/\n\n# Air\nair.toml\n\n# produced vignettes\nvignettes/*.html\nvignettes/*.pdf\n\n# Temporary files created by R markdown\n*.utf8.md\n*.knit.md\n\n# lintr\n.lintr\n\n# CRAN\ncran-comments.md\n\n# Manual\n*.pdf\n\n# Assistants\nAGENTS.md\n.claude/\nSKILL.md" }, { "path": "DESCRIPTION", "content": "Package: rtemis\nVersion: 1.2.0\nTitle: Machine Learning and Visualization\nDate: 2026-05-12\nAuthors@R: person(given = \"E.D.\", family = \"Gennatas\", role = c(\"aut\", \"cre\", \"cph\"), \n email = \"gennatas@gmail.com\", comment = c(ORCID = \"0000-0001-9280-3609\"))\nDescription: Machine learning and visualization package with an 'S7' backend \n featuring comprehensive type checking and validation, paired with an efficient functional\n user-facing API. train(), cluster(), and decomp() provide one-call access to supervised and \n unsupervised learning. All configuration steps are performed using setup functions and \n validated. A single call to train() handles preprocessing, hyperparameter tuning, and testing \n with nested resampling. Supports 'data.frame', 'data.table', and 'tibble' inputs, parallel \n execution, and interactive visualizations. The package first appeared in E.D. Gennatas (2017)\n .\nLicense: GPL (>= 3)\nURL: https://www.rtemis.org, https://docs.rtemis.org/r/ml, https://docs.rtemis.org/r/ml-api/\nBugReports: https://github.com/rtemis-org/rtemis/issues\nByteCompile: yes\nDepends:\n R (>= 4.1.0)\nImports:\n grDevices,\n graphics,\n stats,\n methods,\n utils,\n S7,\n data.table,\n future,\n htmltools,\n cli\nSuggests:\n arrow,\n bit64,\n car,\n colorspace,\n DBI,\n dbscan,\n dendextend (>= 0.18.0),\n duckdb,\n e1071,\n farff,\n fastICA,\n flexclust,\n future.apply,\n future.mirai,\n futurize,\n geosphere,\n ggplot2,\n glmnet,\n geojsonio,\n glue,\n grid,\n gsubfn,\n haven,\n heatmaply,\n htmlwidgets,\n igraph,\n jsonlite,\n later,\n leaflet,\n leaps,\n lightAUC,\n lightgbm,\n matrixStats,\n mgcv,\n mice,\n mirai,\n missRanger,\n nanonext,\n networkD3,\n NMF,\n openxlsx,\n parallelly,\n partykit,\n plotly,\n plumber,\n pROC,\n progressr,\n psych,\n pvclust,\n ranger,\n reactable,\n readxl,\n reticulate,\n ROCR,\n rpart,\n Rtsne,\n seqinr,\n sf,\n shapr,\n survival,\n tabnet,\n threejs,\n testthat (>= 3.0.0),\n tibble,\n timeDate,\n toml,\n torch,\n uwot,\n vegan,\n vroom,\n withr\nEncoding: UTF-8\nConfig/testthat/edition: 3\nRoxygen: list(markdown = TRUE)\nLazyData: true\nConfig/roxygen2/version: 8.0.0\n" }, { "path": "LICENSE.md", "content": " GNU GENERAL PUBLIC LICENSE\n Version 3, 29 June 2007\n\n Copyright (C) 2007 Free Software Foundation, Inc. \n Everyone is permitted to copy and distribute verbatim copies\n of this license document, but changing it is not allowed.\n\n Preamble\n\n The GNU General Public License is a free, copyleft license for\nsoftware and other kinds of works.\n\n The licenses for most software and other practical works are designed\nto take away your freedom to share and change the works. By contrast,\nthe GNU General Public License is intended to guarantee your freedom to\nshare and change all versions of a program--to make sure it remains free\nsoftware for all its users. We, the Free Software Foundation, use the\nGNU General Public License for most of our software; it applies also to\nany other work released this way by its authors. You can apply it to\nyour programs, too.\n\n When we speak of free software, we are referring to freedom, not\nprice. Our General Public Licenses are designed to make sure that you\nhave the freedom to distribute copies of free software (and charge for\nthem if you wish), that you receive source code or can get it if you\nwant it, that you can change the software or use pieces of it in new\nfree programs, and that you know you can do these things.\n\n To protect your rights, we need to prevent others from denying you\nthese rights or asking you to surrender the rights. Therefore, you have\ncertain responsibilities if you distribute copies of the software, or if\nyou modify it: responsibilities to respect the freedom of others.\n\n For example, if you distribute copies of such a program, whether\ngratis or for a fee, you must pass on to the recipients the same\nfreedoms that you received. You must make sure that they, too, receive\nor can get the source code. And you must show them these terms so they\nknow their rights.\n\n Developers that use the GNU GPL protect your rights with two steps:\n(1) assert copyright on the software, and (2) offer you this License\ngiving you legal permission to copy, distribute and/or modify it.\n\n For the developers' and authors' protection, the GPL clearly explains\nthat there is no warranty for this free software. For both users' and\nauthors' sake, the GPL requires that modified versions be marked as\nchanged, so that their problems will not be attributed erroneously to\nauthors of previous versions.\n\n Some devices are designed to deny users access to install or run\nmodified versions of the software inside them, although the manufacturer\ncan do so. This is fundamentally incompatible with the aim of\nprotecting users' freedom to change the software. The systematic\npattern of such abuse occurs in the area of products for individuals to\nuse, which is precisely where it is most unacceptable. Therefore, we\nhave designed this version of the GPL to prohibit the practice for those\nproducts. If such problems arise substantially in other domains, we\nstand ready to extend this provision to those domains in future versions\nof the GPL, as needed to protect the freedom of users.\n\n Finally, every program is threatened constantly by software patents.\nStates should not allow patents to restrict development and use of\nsoftware on general-purpose computers, but in those that do, we wish to\navoid the special danger that patents applied to a free program could\nmake it effectively proprietary. To prevent this, the GPL assures that\npatents cannot be used to render the program non-free.\n\n The precise terms and conditions for copying, distribution and\nmodification follow.\n\n TERMS AND CONDITIONS\n\n 0. Definitions.\n\n \"This License\" refers to version 3 of the GNU General Public License.\n\n \"Copyright\" also means copyright-like laws that apply to other kinds of\nworks, such as semiconductor masks.\n\n \"The Program\" refers to any copyrightable work licensed under this\nLicense. Each licensee is addressed as \"you\". \"Licensees\" and\n\"recipients\" may be individuals or organizations.\n\n To \"modify\" a work means to copy from or adapt all or part of the work\nin a fashion requiring copyright permission, other than the making of an\nexact copy. The resulting work is called a \"modified version\" of the\nearlier work or a work \"based on\" the earlier work.\n\n A \"covered work\" means either the unmodified Program or a work based\non the Program.\n\n To \"propagate\" a work means to do anything with it that, without\npermission, would make you directly or secondarily liable for\ninfringement under applicable copyright law, except executing it on a\ncomputer or modifying a private copy. Propagation includes copying,\ndistribution (with or without modification), making available to the\npublic, and in some countries other activities as well.\n\n To \"convey\" a work means any kind of propagation that enables other\nparties to make or receive copies. Mere interaction with a user through\na computer network, with no transfer of a copy, is not conveying.\n\n An interactive user interface displays \"Appropriate Legal Notices\"\nto the extent that it includes a convenient and prominently visible\nfeature that (1) displays an appropriate copyright notice, and (2)\ntells the user that there is no warranty for the work (except to the\nextent that warranties are provided), that licensees may convey the\nwork under this License, and how to view a copy of this License. If\nthe interface presents a list of user commands or options, such as a\nmenu, a prominent item in the list meets this criterion.\n\n 1. Source Code.\n\n The \"source code\" for a work means the preferred form of the work\nfor making modifications to it. \"Object code\" means any non-source\nform of a work.\n\n A \"Standard Interface\" means an interface that either is an official\nstandard defined by a recognized standards body, or, in the case of\ninterfaces specified for a particular programming language, one that\nis widely used among developers working in that language.\n\n The \"System Libraries\" of an executable work include anything, other\nthan the work as a whole, that (a) is included in the normal form of\npackaging a Major Component, but which is not part of that Major\nComponent, and (b) serves only to enable use of the work with that\nMajor Component, or to implement a Standard Interface for which an\nimplementation is available to the public in source code form. A\n\"Major Component\", in this context, means a major essential component\n(kernel, window system, and so on) of the specific operating system\n(if any) on which the executable work runs, or a compiler used to\nproduce the work, or an object code interpreter used to run it.\n\n The \"Corresponding Source\" for a work in object code form means all\nthe source code needed to generate, install, and (for an executable\nwork) run the object code and to modify the work, including scripts to\ncontrol those activities. However, it does not include the work's\nSystem Libraries, or general-purpose tools or generally available free\nprograms which are used unmodified in performing those activities but\nwhich are not part of the work. For example, Corresponding Source\nincludes interface definition files associated with source files for\nthe work, and the source code for shared libraries and dynamically\nlinked subprograms that the work is specifically designed to require,\nsuch as by intimate data communication or control flow between those\nsubprograms and other parts of the work.\n\n The Corresponding Source need not include anything that users\ncan regenerate automatically from other parts of the Corresponding\nSource.\n\n The Corresponding Source for a work in source code form is that\nsame work.\n\n 2. Basic Permissions.\n\n All rights granted under this License are granted for the term of\ncopyright on the Program, and are irrevocable provided the stated\nconditions are met. This License explicitly affirms your unlimited\npermission to run the unmodified Program. The output from running a\ncovered work is covered by this License only if the output, given its\ncontent, constitutes a covered work. This License acknowledges your\nrights of fair use or other equivalent, as provided by copyright law.\n\n You may make, run and propagate covered works that you do not\nconvey, without conditions so long as your license otherwise remains\nin force. You may convey covered works to others for the sole purpose\nof having them make modifications exclusively for you, or provide you\nwith facilities for running those works, provided that you comply with\nthe terms of this License in conveying all material for which you do\nnot control copyright. Those thus making or running the covered works\nfor you must do so exclusively on your behalf, under your direction\nand control, on terms that prohibit them from making any copies of\nyour copyrighted material outside their relationship with you.\n\n Conveying under any other circumstances is permitted solely under\nthe conditions stated below. Sublicensing is not allowed; section 10\nmakes it unnecessary.\n\n 3. Protecting Users' Legal Rights From Anti-Circumvention Law.\n\n No covered work shall be deemed part of an effective technological\nmeasure under any applicable law fulfilling obligations under article\n11 of the WIPO copyright treaty adopted on 20 December 1996, or\nsimilar laws prohibiting or restricting circumvention of such\nmeasures.\n\n When you convey a covered work, you waive any legal power to forbid\ncircumvention of technological measures to the extent such circumvention\nis effected by exercising rights under this License with respect to\nthe covered work, and you disclaim any intention to limit operation or\nmodification of the work as a means of enforcing, against the work's\nusers, your or third parties' legal rights to forbid circumvention of\ntechnological measures.\n\n 4. Conveying Verbatim Copies.\n\n You may convey verbatim copies of the Program's source code as you\nreceive it, in any medium, provided that you conspicuously and\nappropriately publish on each copy an appropriate copyright notice;\nkeep intact all notices stating that this License and any\nnon-permissive terms added in accord with section 7 apply to the code;\nkeep intact all notices of the absence of any warranty; and give all\nrecipients a copy of this License along with the Program.\n\n You may charge any price or no price for each copy that you convey,\nand you may offer support or warranty protection for a fee.\n\n 5. Conveying Modified Source Versions.\n\n You may convey a work based on the Program, or the modifications to\nproduce it from the Program, in the form of source code under the\nterms of section 4, provided that you also meet all of these conditions:\n\n a) The work must carry prominent notices stating that you modified\n it, and giving a relevant date.\n\n b) The work must carry prominent notices stating that it is\n released under this License and any conditions added under section\n 7. This requirement modifies the requirement in section 4 to\n \"keep intact all notices\".\n\n c) You must license the entire work, as a whole, under this\n License to anyone who comes into possession of a copy. This\n License will therefore apply, along with any applicable section 7\n additional terms, to the whole of the work, and all its parts,\n regardless of how they are packaged. This License gives no\n permission to license the work in any other way, but it does not\n invalidate such permission if you have separately received it.\n\n d) If the work has interactive user interfaces, each must display\n Appropriate Legal Notices; however, if the Program has interactive\n interfaces that do not display Appropriate Legal Notices, your\n work need not make them do so.\n\n A compilation of a covered work with other separate and independent\nworks, which are not by their nature extensions of the covered work,\nand which are not combined with it such as to form a larger program,\nin or on a volume of a storage or distribution medium, is called an\n\"aggregate\" if the compilation and its resulting copyright are not\nused to limit the access or legal rights of the compilation's users\nbeyond what the individual works permit. Inclusion of a covered work\nin an aggregate does not cause this License to apply to the other\nparts of the aggregate.\n\n 6. Conveying Non-Source Forms.\n\n You may convey a covered work in object code form under the terms\nof sections 4 and 5, provided that you also convey the\nmachine-readable Corresponding Source under the terms of this License,\nin one of these ways:\n\n a) Convey the object code in, or embodied in, a physical product\n (including a physical distribution medium), accompanied by the\n Corresponding Source fixed on a durable physical medium\n customarily used for software interchange.\n\n b) Convey the object code in, or embodied in, a physical product\n (including a physical distribution medium), accompanied by a\n written offer, valid for at least three years and valid for as\n long as you offer spare parts or customer support for that product\n model, to give anyone who possesses the object code either (1) a\n copy of the Corresponding Source for all the software in the\n product that is covered by this License, on a durable physical\n medium customarily used for software interchange, for a price no\n more than your reasonable cost of physically performing this\n conveying of source, or (2) access to copy the\n Corresponding Source from a network server at no charge.\n\n c) Convey individual copies of the object code with a copy of the\n written offer to provide the Corresponding Source. This\n alternative is allowed only occasionally and noncommercially, and\n only if you received the object code with such an offer, in accord\n with subsection 6b.\n\n d) Convey the object code by offering access from a designated\n place (gratis or for a charge), and offer equivalent access to the\n Corresponding Source in the same way through the same place at no\n further charge. You need not require recipients to copy the\n Corresponding Source along with the object code. If the place to\n copy the object code is a network server, the Corresponding Source\n may be on a different server (operated by you or a third party)\n that supports equivalent copying facilities, provided you maintain\n clear directions next to the object code saying where to find the\n Corresponding Source. Regardless of what server hosts the\n Corresponding Source, you remain obligated to ensure that it is\n available for as long as needed to satisfy these requirements.\n\n e) Convey the object code using peer-to-peer transmission, provided\n you inform other peers where the object code and Corresponding\n Source of the work are being offered to the general public at no\n charge under subsection 6d.\n\n A separable portion of the object code, whose source code is excluded\nfrom the Corresponding Source as a System Library, need not be\nincluded in conveying the object code work.\n\n A \"User Product\" is either (1) a \"consumer product\", which means any\ntangible personal property which is normally used for personal, family,\nor household purposes, or (2) anything designed or sold for incorporation\ninto a dwelling. In determining whether a product is a consumer product,\ndoubtful cases shall be resolved in favor of coverage. For a particular\nproduct received by a particular user, \"normally used\" refers to a\ntypical or common use of that class of product, regardless of the status\nof the particular user or of the way in which the particular user\nactually uses, or expects or is expected to use, the product. A product\nis a consumer product regardless of whether the product has substantial\ncommercial, industrial or non-consumer uses, unless such uses represent\nthe only significant mode of use of the product.\n\n \"Installation Information\" for a User Product means any methods,\nprocedures, authorization keys, or other information required to install\nand execute modified versions of a covered work in that User Product from\na modified version of its Corresponding Source. The information must\nsuffice to ensure that the continued functioning of the modified object\ncode is in no case prevented or interfered with solely because\nmodification has been made.\n\n If you convey an object code work under this section in, or with, or\nspecifically for use in, a User Product, and the conveying occurs as\npart of a transaction in which the right of possession and use of the\nUser Product is transferred to the recipient in perpetuity or for a\nfixed term (regardless of how the transaction is characterized), the\nCorresponding Source conveyed under this section must be accompanied\nby the Installation Information. But this requirement does not apply\nif neither you nor any third party retains the ability to install\nmodified object code on the User Product (for example, the work has\nbeen installed in ROM).\n\n The requirement to provide Installation Information does not include a\nrequirement to continue to provide support service, warranty, or updates\nfor a work that has been modified or installed by the recipient, or for\nthe User Product in which it has been modified or installed. Access to a\nnetwork may be denied when the modification itself materially and\nadversely affects the operation of the network or violates the rules and\nprotocols for communication across the network.\n\n Corresponding Source conveyed, and Installation Information provided,\nin accord with this section must be in a format that is publicly\ndocumented (and with an implementation available to the public in\nsource code form), and must require no special password or key for\nunpacking, reading or copying.\n\n 7. Additional Terms.\n\n \"Additional permissions\" are terms that supplement the terms of this\nLicense by making exceptions from one or more of its conditions.\nAdditional permissions that are applicable to the entire Program shall\nbe treated as though they were included in this License, to the extent\nthat they are valid under applicable law. If additional permissions\napply only to part of the Program, that part may be used separately\nunder those permissions, but the entire Program remains governed by\nthis License without regard to the additional permissions.\n\n When you convey a copy of a covered work, you may at your option\nremove any additional permissions from that copy, or from any part of\nit. (Additional permissions may be written to require their own\nremoval in certain cases when you modify the work.) You may place\nadditional permissions on material, added by you to a covered work,\nfor which you have or can give appropriate copyright permission.\n\n Notwithstanding any other provision of this License, for material you\nadd to a covered work, you may (if authorized by the copyright holders of\nthat material) supplement the terms of this License with terms:\n\n a) Disclaiming warranty or limiting liability differently from the\n terms of sections 15 and 16 of this License; or\n\n b) Requiring preservation of specified reasonable legal notices or\n author attributions in that material or in the Appropriate Legal\n Notices displayed by works containing it; or\n\n c) Prohibiting misrepresentation of the origin of that material, or\n requiring that modified versions of such material be marked in\n reasonable ways as different from the original version; or\n\n d) Limiting the use for publicity purposes of names of licensors or\n authors of the material; or\n\n e) Declining to grant rights under trademark law for use of some\n trade names, trademarks, or service marks; or\n\n f) Requiring indemnification of licensors and authors of that\n material by anyone who conveys the material (or modified versions of\n it) with contractual assumptions of liability to the recipient, for\n any liability that these contractual assumptions directly impose on\n those licensors and authors.\n\n All other non-permissive additional terms are considered \"further\nrestrictions\" within the meaning of section 10. If the Program as you\nreceived it, or any part of it, contains a notice stating that it is\ngoverned by this License along with a term that is a further\nrestriction, you may remove that term. If a license document contains\na further restriction but permits relicensing or conveying under this\nLicense, you may add to a covered work material governed by the terms\nof that license document, provided that the further restriction does\nnot survive such relicensing or conveying.\n\n If you add terms to a covered work in accord with this section, you\nmust place, in the relevant source files, a statement of the\nadditional terms that apply to those files, or a notice indicating\nwhere to find the applicable terms.\n\n Additional terms, permissive or non-permissive, may be stated in the\nform of a separately written license, or stated as exceptions;\nthe above requirements apply either way.\n\n 8. Termination.\n\n You may not propagate or modify a covered work except as expressly\nprovided under this License. Any attempt otherwise to propagate or\nmodify it is void, and will automatically terminate your rights under\nthis License (including any patent licenses granted under the third\nparagraph of section 11).\n\n However, if you cease all violation of this License, then your\nlicense from a particular copyright holder is reinstated (a)\nprovisionally, unless and until the copyright holder explicitly and\nfinally terminates your license, and (b) permanently, if the copyright\nholder fails to notify you of the violation by some reasonable means\nprior to 60 days after the cessation.\n\n Moreover, your license from a particular copyright holder is\nreinstated permanently if the copyright holder notifies you of the\nviolation by some reasonable means, this is the first time you have\nreceived notice of violation of this License (for any work) from that\ncopyright holder, and you cure the violation prior to 30 days after\nyour receipt of the notice.\n\n Termination of your rights under this section does not terminate the\nlicenses of parties who have received copies or rights from you under\nthis License. If your rights have been terminated and not permanently\nreinstated, you do not qualify to receive new licenses for the same\nmaterial under section 10.\n\n 9. Acceptance Not Required for Having Copies.\n\n You are not required to accept this License in order to receive or\nrun a copy of the Program. Ancillary propagation of a covered work\noccurring solely as a consequence of using peer-to-peer transmission\nto receive a copy likewise does not require acceptance. However,\nnothing other than this License grants you permission to propagate or\nmodify any covered work. These actions infringe copyright if you do\nnot accept this License. Therefore, by modifying or propagating a\ncovered work, you indicate your acceptance of this License to do so.\n\n 10. Automatic Licensing of Downstream Recipients.\n\n Each time you convey a covered work, the recipient automatically\nreceives a license from the original licensors, to run, modify and\npropagate that work, subject to this License. You are not responsible\nfor enforcing compliance by third parties with this License.\n\n An \"entity transaction\" is a transaction transferring control of an\norganization, or substantially all assets of one, or subdividing an\norganization, or merging organizations. If propagation of a covered\nwork results from an entity transaction, each party to that\ntransaction who receives a copy of the work also receives whatever\nlicenses to the work the party's predecessor in interest had or could\ngive under the previous paragraph, plus a right to possession of the\nCorresponding Source of the work from the predecessor in interest, if\nthe predecessor has it or can get it with reasonable efforts.\n\n You may not impose any further restrictions on the exercise of the\nrights granted or affirmed under this License. For example, you may\nnot impose a license fee, royalty, or other charge for exercise of\nrights granted under this License, and you may not initiate litigation\n(including a cross-claim or counterclaim in a lawsuit) alleging that\nany patent claim is infringed by making, using, selling, offering for\nsale, or importing the Program or any portion of it.\n\n 11. Patents.\n\n A \"contributor\" is a copyright holder who authorizes use under this\nLicense of the Program or a work on which the Program is based. The\nwork thus licensed is called the contributor's \"contributor version\".\n\n A contributor's \"essential patent claims\" are all patent claims\nowned or controlled by the contributor, whether already acquired or\nhereafter acquired, that would be infringed by some manner, permitted\nby this License, of making, using, or selling its contributor version,\nbut do not include claims that would be infringed only as a\nconsequence of further modification of the contributor version. For\npurposes of this definition, \"control\" includes the right to grant\npatent sublicenses in a manner consistent with the requirements of\nthis License.\n\n Each contributor grants you a non-exclusive, worldwide, royalty-free\npatent license under the contributor's essential patent claims, to\nmake, use, sell, offer for sale, import and otherwise run, modify and\npropagate the contents of its contributor version.\n\n In the following three paragraphs, a \"patent license\" is any express\nagreement or commitment, however denominated, not to enforce a patent\n(such as an express permission to practice a patent or covenant not to\nsue for patent infringement). To \"grant\" such a patent license to a\nparty means to make such an agreement or commitment not to enforce a\npatent against the party.\n\n If you convey a covered work, knowingly relying on a patent license,\nand the Corresponding Source of the work is not available for anyone\nto copy, free of charge and under the terms of this License, through a\npublicly available network server or other readily accessible means,\nthen you must either (1) cause the Corresponding Source to be so\navailable, or (2) arrange to deprive yourself of the benefit of the\npatent license for this particular work, or (3) arrange, in a manner\nconsistent with the requirements of this License, to extend the patent\nlicense to downstream recipients. \"Knowingly relying\" means you have\nactual knowledge that, but for the patent license, your conveying the\ncovered work in a country, or your recipient's use of the covered work\nin a country, would infringe one or more identifiable patents in that\ncountry that you have reason to believe are valid.\n\n If, pursuant to or in connection with a single transaction or\narrangement, you convey, or propagate by procuring conveyance of, a\ncovered work, and grant a patent license to some of the parties\nreceiving the covered work authorizing them to use, propagate, modify\nor convey a specific copy of the covered work, then the patent license\nyou grant is automatically extended to all recipients of the covered\nwork and works based on it.\n\n A patent license is \"discriminatory\" if it does not include within\nthe scope of its coverage, prohibits the exercise of, or is\nconditioned on the non-exercise of one or more of the rights that are\nspecifically granted under this License. You may not convey a covered\nwork if you are a party to an arrangement with a third party that is\nin the business of distributing software, under which you make payment\nto the third party based on the extent of your activity of conveying\nthe work, and under which the third party grants, to any of the\nparties who would receive the covered work from you, a discriminatory\npatent license (a) in connection with copies of the covered work\nconveyed by you (or copies made from those copies), or (b) primarily\nfor and in connection with specific products or compilations that\ncontain the covered work, unless you entered into that arrangement,\nor that patent license was granted, prior to 28 March 2007.\n\n Nothing in this License shall be construed as excluding or limiting\nany implied license or other defenses to infringement that may\notherwise be available to you under applicable patent law.\n\n 12. No Surrender of Others' Freedom.\n\n If conditions are imposed on you (whether by court order, agreement or\notherwise) that contradict the conditions of this License, they do not\nexcuse you from the conditions of this License. If you cannot convey a\ncovered work so as to satisfy simultaneously your obligations under this\nLicense and any other pertinent obligations, then as a consequence you may\nnot convey it at all. For example, if you agree to terms that obligate you\nto collect a royalty for further conveying from those to whom you convey\nthe Program, the only way you could satisfy both those terms and this\nLicense would be to refrain entirely from conveying the Program.\n\n 13. Use with the GNU Affero General Public License.\n\n Notwithstanding any other provision of this License, you have\npermission to link or combine any covered work with a work licensed\nunder version 3 of the GNU Affero General Public License into a single\ncombined work, and to convey the resulting work. The terms of this\nLicense will continue to apply to the part which is the covered work,\nbut the special requirements of the GNU Affero General Public License,\nsection 13, concerning interaction through a network will apply to the\ncombination as such.\n\n 14. Revised Versions of this License.\n\n The Free Software Foundation may publish revised and/or new versions of\nthe GNU General Public License from time to time. Such new versions will\nbe similar in spirit to the present version, but may differ in detail to\naddress new problems or concerns.\n\n Each version is given a distinguishing version number. If the\nProgram specifies that a certain numbered version of the GNU General\nPublic License \"or any later version\" applies to it, you have the\noption of following the terms and conditions either of that numbered\nversion or of any later version published by the Free Software\nFoundation. If the Program does not specify a version number of the\nGNU General Public License, you may choose any version ever published\nby the Free Software Foundation.\n\n If the Program specifies that a proxy can decide which future\nversions of the GNU General Public License can be used, that proxy's\npublic statement of acceptance of a version permanently authorizes you\nto choose that version for the Program.\n\n Later license versions may give you additional or different\npermissions. However, no additional obligations are imposed on any\nauthor or copyright holder as a result of your choosing to follow a\nlater version.\n\n 15. Disclaimer of Warranty.\n\n THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY\nAPPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT\nHOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY\nOF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,\nTHE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR\nPURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM\nIS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF\nALL NECESSARY SERVICING, REPAIR OR CORRECTION.\n\n 16. Limitation of Liability.\n\n IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\nWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS\nTHE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY\nGENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE\nUSE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF\nDATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD\nPARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),\nEVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF\nSUCH DAMAGES.\n\n 17. Interpretation of Sections 15 and 16.\n\n If the disclaimer of warranty and limitation of liability provided\nabove cannot be given local legal effect according to their terms,\nreviewing courts shall apply local law that most closely approximates\nan absolute waiver of all civil liability in connection with the\nProgram, unless a warranty or assumption of liability accompanies a\ncopy of the Program in return for a fee.\n\n END OF TERMS AND CONDITIONS\n\n How to Apply These Terms to Your New Programs\n\n If you develop a new program, and you want it to be of the greatest\npossible use to the public, the best way to achieve this is to make it\nfree software which everyone can redistribute and change under these terms.\n\n To do so, attach the following notices to the program. It is safest\nto attach them to the start of each source file to most effectively\nstate the exclusion of warranty; and each file should have at least\nthe \"copyright\" line and a pointer to where the full notice is found.\n\n \n Copyright (C) \n\n This program is free software: you can redistribute it and/or modify\n it under the terms of the GNU General Public License as published by\n the Free Software Foundation, either version 3 of the License, or\n (at your option) any later version.\n\n This program is distributed in the hope that it will be useful,\n but WITHOUT ANY WARRANTY; without even the implied warranty of\n MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n GNU General Public License for more details.\n\n You should have received a copy of the GNU General Public License\n along with this program. If not, see .\n\nAlso add information on how to contact you by electronic and paper mail.\n\n If the program does terminal interaction, make it output a short\nnotice like this when it starts in an interactive mode:\n\n Copyright (C) \n This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.\n This is free software, and you are welcome to redistribute it\n under certain conditions; type `show c' for details.\n\nThe hypothetical commands `show w' and `show c' should show the appropriate\nparts of the General Public License. Of course, your program's commands\nmight be different; for a GUI interface, you would use an \"about box\".\n\n You should also get your employer (if you work as a programmer) or school,\nif any, to sign a \"copyright disclaimer\" for the program, if necessary.\nFor more information on this, and how to apply and follow the GNU GPL, see\n.\n\n The GNU General Public License does not permit incorporating your program\ninto proprietary programs. If your program is a subroutine library, you\nmay consider it more useful to permit linking proprietary applications with\nthe library. If this is what you want to do, use the GNU Lesser General\nPublic License instead of this License. But first, please read\n.\n" }, { "path": "Makefile", "content": "PKG := $(shell awk '/^Package:/{print $$2; exit}' DESCRIPTION)\nR ?= R\nRSCRIPT ?= Rscript\nCHECK_DIR := $(PKG).Rcheck\nTARBALL_GLOB := $(PKG)_*.tar.gz\n\nmsg = @printf '\\033[38;2;108;163;160m[%s] %s\\033[0m\\n' \"$$(date -u '+%Y-%m-%d %H:%M:%SZ')\" \"$(1)\"\n\n.DEFAULT_GOAL := help\n\n.PHONY: help format document install test build check check-cran check-cran-no-tests site clean\n\nhelp:\n\t$(call msg,Available targets:)\n\t@printf '%s\\n' \\\n\t\t' format Format R code with air CLI (if available)' \\\n\t\t' document Generate roxygen2 documentation' \\\n\t\t' install Document and install the package locally with pak' \\\n\t\t' test Run testthat::test_local(stop_on_failure = TRUE)' \\\n\t\t' build Build the source tarball' \\\n\t\t' check Run R CMD check on the built tarball' \\\n\t\t' check-cran Run R CMD check --as-cran' \\\n\t\t' check-cran-no-tests Run R CMD check --as-cran --no-tests' \\\n\t\t' manual Build package manual' \\\n\t\t' site Build pkgdown site' \\\n\t\t' clean Remove tarballs and .Rcheck output'\n\nformat:\n\t$(call msg,─── Formatting $(PKG) package... ───)\n\t@if command -v air >/dev/null 2>&1; then \\\n\t\tair format .; \\\n\telse \\\n\t\techo \" Note: 'air' CLI not found — skipping R code formatting.\"; \\\n\tfi\n\t$(call msg,Done)\n\ndocument: format\n\t$(call msg,─── Documenting $(PKG) package... ───)\n\t$(RSCRIPT) -e \"roxygen2::roxygenize()\"\n\t$(call msg,Done)\n\ninstall: document\n\t$(call msg,─── Installing $(PKG) package... ───)\n\t$(RSCRIPT) -e \"pak::local_install(upgrade = TRUE)\"\n\t$(call msg,Done)\n\ntest:\n\t$(call msg,─── Running testthat tests for $(PKG)... ───)\n\t$(RSCRIPT) -e \"testthat::test_local(stop_on_failure = TRUE)\"\n\t$(call msg,Done)\n\nbuild: clean\n\t$(call msg,─── Building $(PKG) package... ───)\n\t$(R) CMD build .\n\t$(call msg,Done)\n\ncheck: build\n\t$(call msg,─── Running R CMD check on $(PKG)... ───)\n\t$(R) CMD check $(TARBALL_GLOB)\n\trm -f $(TARBALL_GLOB)\n\t$(call msg,Done)\n\ncheck-cran: build\n\t$(call msg,─── Running R CMD check --as-cran on $(PKG)... ───)\n\t$(R) CMD check $(TARBALL_GLOB) --as-cran\n\trm -f $(TARBALL_GLOB)\n\t$(call msg,Done)\n\ncheck-cran-no-tests: build\n\t$(call msg,─── Running R CMD check --as-cran on $(PKG)... ───)\n\t$(R) CMD check $(TARBALL_GLOB) --as-cran --no-tests\n\trm -f $(TARBALL_GLOB)\n\t$(call msg,Done)\n\nmanual:\n\t$(call msg,─── Building manual for $(PKG)... ───)\n\t$(R) CMD Rd2pdf . --output=$(PKG).pdf\n\t$(call msg,Done)\n\nsite:\n\t$(call msg,─── Building pkgdown site for $(PKG)... ───)\n\t$(RSCRIPT) -e \"pkgdown::build_site()\"\n\t$(call msg,Done)\n\nclean:\n\t$(call msg,─── Cleaning build artifacts... ───)\n\trm -rf $(CHECK_DIR)\n\trm -f $(TARBALL_GLOB)\n\t$(call msg,Done)\n" }, { "path": "NAMESPACE", "content": "# Generated by roxygen2: do not edit by hand\n\nS3method(plot,MassGLM)\nexport(\"%BC%\")\nexport(.list_to_Hyperparameters)\nexport(.list_to_ResamplerConfig)\nexport(.list_to_TunerConfig)\nexport(available_clustering)\nexport(available_decomposition)\nexport(available_draw)\nexport(available_supervised)\nexport(available_themes)\nexport(calibrate)\nexport(check_data)\nexport(choose_theme)\nexport(class_imbalance)\nexport(classification_metrics)\nexport(clean_colnames)\nexport(clean_names)\nexport(cluster)\nexport(col2grayscale)\nexport(color_adjust)\nexport(ddSci)\nexport(ddb_collect)\nexport(ddb_data)\nexport(decomp)\nexport(describe)\nexport(df_movecolumn)\nexport(df_nunique_perfeat)\nexport(draw_3Dscatter)\nexport(draw_bar)\nexport(draw_box)\nexport(draw_calibration)\nexport(draw_confusion)\nexport(draw_dist)\nexport(draw_fit)\nexport(draw_graphD3)\nexport(draw_graphjs)\nexport(draw_heatmap)\nexport(draw_leaflet)\nexport(draw_pie)\nexport(draw_protein)\nexport(draw_pvals)\nexport(draw_roc)\nexport(draw_scatter)\nexport(draw_spectrogram)\nexport(draw_survfit)\nexport(draw_table)\nexport(draw_ts)\nexport(draw_varimp)\nexport(draw_volcano)\nexport(draw_xt)\nexport(dt_describe)\nexport(dt_inspect_types)\nexport(dt_keybin_reshape)\nexport(dt_merge)\nexport(dt_names_by_attr)\nexport(dt_nunique_perfeat)\nexport(dt_pctmatch)\nexport(dt_pctmissing)\nexport(dt_set_autotypes)\nexport(dt_set_clean_all)\nexport(dt_set_cleanfactorlevels)\nexport(dt_set_logical2factor)\nexport(dt_set_one_hot)\nexport(exc)\nexport(feature_matrix)\nexport(feature_names)\nexport(features)\nexport(get_factor_names)\nexport(get_mode)\nexport(get_msg_sink)\nexport(get_palette)\nexport(getcharacternames)\nexport(getdatenames)\nexport(getfactornames)\nexport(getlogicalnames)\nexport(getnames)\nexport(getnamesandtypes)\nexport(getnumericnames)\nexport(inc)\nexport(index_col_by_attr)\nexport(init_project_dir)\nexport(inspect)\nexport(inspect_type)\nexport(is_constant)\nexport(labelify)\nexport(massGLM)\nexport(matchcases)\nexport(mgetnames)\nexport(names_by_class)\nexport(one_hot2factor)\nexport(outcome)\nexport(outcome_name)\nexport(plot_manhattan)\nexport(plot_manhattan.MassGLM)\nexport(plot_roc)\nexport(plot_true_pred)\nexport(plot_varimp)\nexport(preprocess)\nexport(preprocess.class_tabular.Preprocessor)\nexport(preprocess.class_tabular.PreprocessorConfig)\nexport(preprocessed)\nexport(present)\nexport(previewcolor)\nexport(read)\nexport(read_config)\nexport(regression_metrics)\nexport(resample)\nexport(rnormmat)\nexport(rtemis_colors)\nexport(rtversion)\nexport(runifmat)\nexport(set_msg_sink)\nexport(set_outcome)\nexport(setdiffsym)\nexport(setup_CART)\nexport(setup_CMeans)\nexport(setup_DBSCAN)\nexport(setup_ExecutionConfig)\nexport(setup_GAM)\nexport(setup_GLM)\nexport(setup_GLMNET)\nexport(setup_GridSearch)\nexport(setup_HardCL)\nexport(setup_ICA)\nexport(setup_Isomap)\nexport(setup_Isotonic)\nexport(setup_KMeans)\nexport(setup_LightCART)\nexport(setup_LightGBM)\nexport(setup_LightRF)\nexport(setup_LightRuleFit)\nexport(setup_LinearSVM)\nexport(setup_NMF)\nexport(setup_NeuralGas)\nexport(setup_PCA)\nexport(setup_Preprocessor)\nexport(setup_RadialSVM)\nexport(setup_Ranger)\nexport(setup_Resampler)\nexport(setup_SuperConfig)\nexport(setup_SuperConfigLive)\nexport(setup_TabNet)\nexport(setup_UMAP)\nexport(setup_tSNE)\nexport(size)\nexport(table_column_attr)\nexport(theme_black)\nexport(theme_blackgrid)\nexport(theme_blackigrid)\nexport(theme_darkgray)\nexport(theme_darkgraygrid)\nexport(theme_darkgrayigrid)\nexport(theme_lightgraygrid)\nexport(theme_mediumgraygrid)\nexport(theme_white)\nexport(theme_whitegrid)\nexport(theme_whiteigrid)\nexport(to_json)\nexport(train)\nexport(uniprot_get)\nexport(with_msg_sink)\nexport(write_toml)\nexport(xtdescribe)\nimport(S7)\nimport(data.table)\nimport(grDevices)\nimport(graphics)\nimport(htmltools)\nimport(methods)\nimport(stats)\nimportFrom(utils,getFromNamespace)\nimportFrom(utils,head)\nimportFrom(utils,packageVersion)\nimportFrom(utils,sessionInfo)\nimportFrom(utils,tail)\n" }, { "path": "NEWS.md", "content": "# rtemis news\n\n## 1.0.0 First CRAN release\n\n## 1.0.1\n\n- Introduce `VariableImportance` S7 class to represent variable importance data, allowing for more than one measure of importance per model and update all relevant classes and methods.\n- Calculate Partial_Effect_Variance as variable importance measure for GAM models\n- Add `execution_config` argument to internal `train_` method and use it in LightRuleFit to propagate to LightGBM and GLMNET calls." }, { "path": "R/00_S7init.R", "content": "# S7_init.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# References\n# S7 generics: https://rconsortium.github.io/S7/articles/generics-methods.html\n\n# %% --- S3 Classes for S7 ----------------------------------------------------------------------------\nclass_data.table <- new_S3_class(\"data.table\")\nclass_lgb.Booster <- new_S3_class(\"lgb.Booster\")\n# All internal methods should support data.frame, data.table, tbl_df\nclass_tabular <- new_union(class_data.frame, class_data.table)\n# Supervised learning model classes\nclass_glm <- new_S3_class(\"glm\")\nclass_gam <- new_S3_class(\"gam\")\nclass_glmnet <- new_S3_class(\"glmnet\")\nclass_cv.glmnet <- new_S3_class(\"cv.glmnet\")\nclass_stepfun <- new_S3_class(\"stepfun\") # Isotonic regression\nclass_rpart <- new_S3_class(\"rpart\")\nclass_ranger <- new_S3_class(\"ranger\")\nclass_svm <- new_S3_class(\"svm\")\nclass_tabnet_fit <- new_S3_class(\"tabnet_fit\")\n\n\n# %% --- Generics -------------------------------------------------------------------------------------\n# %% repr ----\n#' String representation\n#'\n#' @param x rtemis object.\n#'\n#' @return Character string representation of the object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nrepr <- new_generic(\"repr\", \"x\")\n\n\n# %% inspect ----\n#' Inspect rtemis object\n#'\n#' @param x R object to inspect.\n#'\n#' @return Called for side effect of printing information to console; returns character string\n#' invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' inspect(iris)\ninspect <- new_generic(\"inspect\", \"x\", function(x) {\n S7_dispatch()\n}) # /rtemis::inspect\n\n\n# %% preprocess ----\n#' @name\n#' preprocess\n#'\n#' @title\n#' Preprocess Data\n#'\n#' @description\n#' Preprocess data for analysis and visualization.\n#'\n#' @details\n#' Methods are provided for preprocessing training set data, which accepts a `PreprocessorConfig`\n#' object, and for preprocessing validation and test set data, which accept a `Preprocessor`\n#' object.\n#'\n#' @return `Preprocessor` object.\n#'\n#' @author EDG\n#' @rdname preprocess\n#' @export\n#'\n#' @examples\n#' # Setup a `Preprocessor`: this outputs a `PreprocessorConfig` object.\n#' prp <- setup_Preprocessor(remove_duplicates = TRUE, scale = TRUE, center = TRUE)\n#'\n#' # Includes a long list of parameters\n#' prp\n#'\n#' # Resample iris to get train and test data\n#' res <- resample(iris, setup_Resampler(seed = 2026))\n#' iris_train <- iris[res[[1]], ]\n#' iris_test <- iris[-res[[1]], ]\n#'\n#' # Preprocess training data\n#' iris_pre <- preprocess(iris_train, prp)\n#'\n#' # Access preprocessd training data with `preprocessed()`\n#' preprocessed(iris_pre)\n#'\n#' # Apply the same preprocessing to test data\n#' # In this case, the scale and center values from training data will be used.\n#' # Note how `preprocess()` accepts either a `PreprocessorConfig` or `Preprocessor` object for\n#' # this reason.\n#' iris_test_pre <- preprocess(iris_test, iris_pre)\n#'\n#' # Access preprocessed test data\n#' preprocessed(iris_test_pre)\npreprocess <- new_generic(\"preprocess\", c(\"x\", \"config\"))\n\n\n# %% train_ ----\n#' Generic for training supervised learning models\n#'\n#' @description\n#' Internal S7 generic that dispatches algorithm-specific training based on\n#' `Hyperparameters` class. Called by `train()`.\n#'\n#' @param hyperparameters `Hyperparameters` object: Algorithm-specific hyperparameters.\n#' @param x tabular data: Training set.\n#' @param weights Optional Numeric vector: Case weights.\n#' @param dat_validation Optional tabular data: Validation set for algorithms that support early stopping.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Algorithm-specific fitted model object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ntrain_ <- new_generic(\n \"train_\",\n \"hyperparameters\",\n function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n ) {\n S7_dispatch()\n }\n) # /rtemis::train_\n\n\n# %% predict_super ----\n#' Predict from supervised learning model (internal)\n#'\n#' @description\n#' Internal S7 generic that dispatches algorithm-specific prediction based on\n#' model class.\n#'\n#' @param model Fitted model object.\n#' @param newdata tabular data: New data for prediction.\n#' @param type Character: Type of supervised learning (\"Classification\" or \"Regression\").\n#' @param ... Additional arguments (not currently used).\n#'\n#' @return Predictions (class probabilities for classification, numeric for regression).\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\npredict_super <- new_generic(\n \"predict_super\",\n \"model\",\n function(model, newdata, type = NULL, verbosity = 0L) {\n S7_dispatch()\n }\n) # /rtemis::predict_super\n\n\n# %% varimp_super ----\n#' Get variable importance (internal)\n#'\n#' @description\n#' Internal S7 generic that dispatches algorithm-specific variable importance\n#' extraction based on model class.\n#'\n#' @param object Fitted model object.\n#'\n#' @return Numeric vector of variable importance scores (named by feature).\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nvarimp_super <- new_generic(\n \"varimp_super\",\n \"model\",\n function(model, ...) {\n S7_dispatch()\n }\n) # /rtemis::varimp_super\n\n\n# %% se_super ----\n#' Get standard errors of predictions (internal)\n#'\n#' @description\n#' Internal S7 generic for extracting standard errors from regression models.\n#'\n#' @param object Fitted model object.\n#' @param newdata tabular data: New data for prediction.\n#'\n#' @return Numeric vector of standard errors.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nse_super <- new_generic(\n \"se_super\",\n \"model\",\n function(model, newdata) {\n S7_dispatch()\n }\n)\n\n\n# %% se ----\n# Standard error of the fit.\nse <- new_generic(\"se\", \"x\")\n\n\n# %% decomp_ ----\n#' Generic for decomposition\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ndecomp_ <- new_generic(\n \"decomp_\",\n \"config\",\n function(config, x, verbosity = 1L) {\n S7_dispatch()\n }\n) # /rtemis::decomp_\n\n\n# %% cluster_ ----\n#' Generic for clustering\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncluster_ <- new_generic(\n \"cluster_\",\n \"config\",\n function(config, x, verbosity = 1L) {\n S7_dispatch()\n }\n) # /rtemis::cluster_\n\n\n# %% desc ----\n#' Short description for inline printing.\n#' This is like `repr` for single-line descriptions.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ndesc <- new_generic(\"desc\", \"x\")\n\n\n# %% get_metric ----\n#' Get metric\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nget_metric <- new_generic(\"get_metric\", \"x\")\n\n\n# %% validate_hyperparameters ----\n#' Check hyperparameters given training data\n#'\n#' @param x tabular data: Training data.\n#' @param hyperparameters `Hyperparameters` to check.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nvalidate_hyperparameters <- new_generic(\n \"validate_hyperparameters\",\n \"x\",\n function(x, hyperparameters) {\n S7_dispatch()\n }\n) # /rtemis::validate_hyperparameters\n\n\n# %% plot_metric ----\n#' Plot Metric\n#'\n#' @description\n#' Plot metric for `SupervisedRes` objects.\n#'\n#' @param x `SupervisedRes` object.\n#' @param ... Additional arguments passed to the plotting function.\n#'\n#' @return plotly object\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nplot_metric <- new_generic(\"plot_metric\", \"x\")\n\n\n# %% plot_roc ----\n#' Plot ROC curve\n#'\n#' @description\n#' This generic is used to plot the ROC curve for a model.\n#'\n#' @param x `Classification` or `ClassificationRes` object.\n#' @param ... Additional arguments passed to the plotting function.\n#'\n#' @return A plotly object containing the ROC curve.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' ir <- iris[51:150, ]\n#' ir[[\"Species\"]] <- factor(ir[[\"Species\"]])\n#' species_glm <- train(ir, algorithm = \"GLM\")\n#' plot_roc(species_glm)\nplot_roc <- new_generic(\"plot_roc\", \"x\")\n\n\n# %% plot_varimp ----\n#' Plot Variable Importance\n#'\n#' @description\n#' Plot Variable Importance for Supervised objects.\n#'\n#' @param x `Supervised` or `SupervisedRes` object.\n#' @param ... Additional arguments passed to methods.\n#'\n#' @details\n#' This method calls [draw_varimp] internally.\n#' If you pass an integer to the `plot_top` argument, the method will plot this many top features.\n#' If you pass a number between 0 and 1 to the `plot_top` argument, the method will plot this\n#' fraction of top features.\n#'\n#' @return plotly object or invisible NULL if no variable importance is available.\n#'\n#' @author EDG\n#' @export\n#'\n#' @seealso [draw_varimp], which is called by this method\n#'\n#' @examplesIf interactive()\n#' ir <- set_outcome(iris, \"Sepal.Length\")\n#' seplen_cart <- train(ir, algorithm = \"CART\")\n#' plot_varimp(seplen_cart)\n#' # Plot horizontally\n#' plot_varimp(seplen_cart, orientation = \"h\")\n#' plot_varimp(seplen_cart, orientation = \"h\", plot_top = 3L)\n#' plot_varimp(seplen_cart, orientation = \"h\", plot_top = 0.5)\nplot_varimp <- new_generic(\"plot_varimp\", \"x\")\n\n\n# %% plot_true_pred ----\n#' Plot True vs. Predicted Values\n#'\n#' @description\n#' Plot True vs. Predicted Values for Supervised objects.\n#' For classification, it plots a confusion matrix.\n#' For regression, it plots a scatter plot of true vs. predicted values.\n#'\n#' @param x `Supervised` or `SupervisedRes` object.\n#' @param ... Additional arguments passed to methods.\n#'\n#' @return plotly object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- set_outcome(iris, \"Sepal.Length\")\n#' sepallength_glm <- train(x, algorithm = \"GLM\")\n#' plot_true_pred(sepallength_glm)\nplot_true_pred <- new_generic(\"plot_true_pred\", \"x\")\n\n\n# %% plot_manhattan ----\n#' Manhattan plot\n#'\n#' @description\n#' Draw a Manhattan plot for `MassGLM` objects created with [massGLM].\n#'\n#' @param x `MassGLM` object.\n#' @param ... Additional arguments passed to methods.\n#'\n#' @return plotly object.\n#'\n#' @author EDG\n#' @export\n# example included in `plot_manhattan.MassGLM` method.\nplot_manhattan <- new_generic(\"plot_manhattan\", \"x\")\n\n\n# %% describe ----\n#' Describe object\n#'\n#' @param x R object to describe. See method documentation for supported classes.\n#' @param ... Additional arguments passed to methods. See details.\n#'\n#' @details\n#' Extra arguments for `factor` method:\n#' - `max_n`: Integer: Return counts for up to this many levels.\n#' - `return_ordered`: Logical: If TRUE, return levels ordered by count, otherwise return in level order.\n#' - `verbosity`: Integer: Verbosity level.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' # --- For `Supervised` objects ---\n#' species_lightrf <- train(iris, algorithm = \"lightrf\")\n#' describe(species_lightrf)\n#'\n#' # --- For `SupervisedRes` objects ---\n#' mod <- train(iris, algorithm = \"CART\", outer_resampling_config = setup_Resampler())\n#' describe(mod)\n#'\n#' # --- For factors ---\n#' # Small number of levels\n#' describe(iris[[\"Species\"]])\n#'\n#' # Large number of levels: show top n by count\n#' x <- factor(sample(letters, 1000, TRUE))\n#' describe(x)\n#' describe(x, 3)\n#' describe(x, 3, return_ordered = FALSE)\ndescribe <- new_generic(\"describe\", \"x\")\n\n\n# %% present ----\n#' Present rtemis object\n#'\n#' @description\n#' This generic is used to present an rtemis object by printing to console and drawing plots.\n#'\n#' @param x `Supervised` or `SupervisedRes` object or list of such objects.\n#' @param ... Additional arguments passed to the plotting function.\n#'\n#' @return A plotly object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' ir <- set_outcome(iris, \"Sepal.Length\")\n#' seplen_lightrf <- train(ir, algorithm = \"lightrf\")\n#' present(seplen_lightrf)\npresent <- new_generic(\"present\", \"x\")\n\n\n# %% get_hyperparams_need_tuning ----\n#' Get hyperparameters that need tuning.\n#'\n#' @return Character vector of hyperparameter names that need tuning.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nget_hyperparams_need_tuning <- new_generic(\"get_hyperparams_need_tuning\", \"x\")\n\n\n# %% get_hyperparams ----\n#' Get hyperparameters.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nget_hyperparams <- new_generic(\"get_hyperparams\", c(\"x\", \"param_names\"))\n\n\n# %% extract_rules ----\n#' Extract rules from a model.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nextract_rules <- new_generic(\"extract_rules\", \"x\")\n\n\n# %% get_factor_levels ----\n#' @name get_factor_levels\n#'\n#' @title\n#' Get factor levels from data.frame or similar\n#'\n#' @usage\n#' get_factor_levels(x)\n#'\n#' @param x tabular data.\n#'\n#' @return Named list of factor levels. Names correspond to column names.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nget_factor_levels <- new_generic(\n \"get_factor_levels\",\n \"x\",\n function(x) S7_dispatch()\n)\n\nmethod(get_factor_levels, class_data.frame) <- function(x) {\n factor_index <- which(sapply(x, is.factor))\n lapply(x[, factor_index, drop = FALSE], levels)\n}\n\nmethod(get_factor_levels, class_data.table) <- function(x) {\n factor_index <- which(sapply(x, is.factor))\n lapply(x[, factor_index, with = FALSE], levels)\n}\n\n\n# %% to_html ----\n#' Convert to HTML\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nto_html <- new_generic(\"to_html\", \"x\")\n\n\n# %% to_toml ----\n#' Convert to TOML\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nto_toml <- new_generic(\"to_toml\", \"x\")\n\n\n# %% to_yaml ----\n#' Convert to YAML\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nto_yaml <- new_generic(\"to_yaml\", \"x\")\n\n\n# %% to_json ----\n#' Convert to JSON-serializable list\n#'\n#' Convert an rtemis S7 object to a named list suitable for\n#' `jsonlite::toJSON(auto_unbox = TRUE)`. Used by the rtemislive backend\n#' to send structured results to the browser frontend without scraping\n#' R console output.\n#'\n#' Each output list includes a `.class` field equal to the most specific\n#' S7 class name, allowing the frontend to dispatch to a class-specific\n#' renderer.\n#'\n#' The default method walks `props(x)`, recursing into S7-typed properties\n#' and passing through primitive properties as-is. Per-class methods\n#' override where the default isn't appropriate (e.g. classes whose props\n#' include a `data.table`, an opaque model fit, or where some props should\n#' be excluded for size or relevance reasons).\n#'\n#' @param x rtemis S7 object.\n#' @param ... Additional arguments passed to method.\n#'\n#' @return Named list. Pass through `jsonlite::toJSON(auto_unbox = TRUE)`\n#' for serialization.\n#'\n#' @author EDG\n#' @keywords internal\n#' @export\nto_json <- new_generic(\"to_json\", \"x\")\n\n\n# %% to_json default ----\n#' @name to_json\n#' @keywords internal\n#' @noRd\nmethod(to_json, S7_object) <- function(x, ...) {\n ps <- props(x)\n body <- lapply(ps, .to_json_value)\n c(list(.class = S7_class(x)@name), body)\n} # /rtemis::to_json.S7_object\n\n\n#' Recursively convert a value to a JSON-serializable form\n#'\n#' Handles the common composite shapes encountered when walking S7 props:\n#' nested S7 objects (recurse via the generic), lists that may *contain*\n#' S7 objects (recurse element-wise), and primitives / data.frames\n#' (pass through — jsonlite supports them natively).\n#'\n#' @param v Value from an S7 property.\n#'\n#' @return JSON-serializable value.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n.to_json_value <- function(v) {\n if (is.null(v)) {\n return(NULL)\n }\n if (S7_inherits(v)) {\n return(to_json(v))\n }\n # data.frame / data.table are list-like but jsonlite handles them natively.\n if (is.list(v) && !is.data.frame(v)) {\n return(lapply(v, .to_json_value))\n }\n v\n} # /rtemis::.to_json_value\n\n\n# %% write_toml ----\n#' @name\n#' write_toml\n#'\n#' @title\n#' Write to TOML file\n#'\n#' @author EDG\n#' @export\n# examples include in method documentation\nwrite_toml <- new_generic(\n \"write_toml\",\n \"x\",\n function(x, file, overwrite = FALSE, verbosity = 1L) {\n S7_dispatch()\n }\n) # /rtemis::write_toml\n\n\n# %% inc ----\n#' Select (include) columns by character or numeric vector.\n#'\n#' @param x tabular data.\n#' @param idx Character or numeric vector: Column names or indices to include.\n#'\n#' @return data.frame, tibble, or data.table.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' inc(iris, c(3, 4)) |> head()\n#' inc(iris, c(\"Sepal.Length\", \"Species\")) |> head()\ninc <- new_generic(\"inc\", \"x\", function(x, idx) {\n S7_dispatch()\n})\n\n\n# %% exc ----\n#' Exclude columns by character or numeric vector.\n#'\n#' @param x tabular data.\n#' @param idx Character or numeric vector: Column names or indices to exclude.\n#'\n#' @return data.frame, tibble, or data.table.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' exc(iris, \"Species\") |> head()\n#' exc(iris, c(1, 3)) |> head()\nexc <- new_generic(\"exc\", c(\"x\", \"idx\"), function(x, idx) {\n S7_dispatch()\n})\n\nmethod(inc, class_data.frame) <- function(x, idx) {\n x[, idx, drop = FALSE]\n}\n\nmethod(inc, class_data.table) <- function(x, idx) {\n x[, .SD, .SDcols = idx]\n}\n\nmethod(exc, list(class_data.frame, class_character)) <- function(x, idx) {\n x[, -which(names(x) %in% idx), drop = FALSE]\n}\n\nmethod(exc, list(class_data.frame, class_integer)) <- function(x, idx) {\n x[, -idx, drop = FALSE]\n}\n\nmethod(exc, list(class_data.frame, class_double)) <- function(x, idx) {\n idx <- clean_int(idx)\n x[, -idx, drop = FALSE]\n}\n\nmethod(\n exc,\n list(class_data.table, class_character | class_integer)\n) <- function(x, idx) {\n x[, .SD, .SDcols = -idx]\n}\n\nmethod(exc, list(class_data.table, class_double)) <- function(x, idx) {\n idx <- clean_int(idx)\n x[, .SD, .SDcols = -idx]\n}\n\n\n# %% outcome_name ----\n#' Get the name of the last column\n#'\n#' @details\n#' This applied to tabular datasets used for supervised learning in rtemis,\n#' where, by convention, the last column is the outcome variable and all other columns\n#' are features.\n#'\n#' @param x tabular data.\n#'\n#' @return Name of the last column.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' outcome_name(iris)\noutcome_name <- new_generic(\"outcome_name\", \"x\", function(x) {\n S7_dispatch()\n})\n\nmethod(outcome_name, class_data.frame) <- function(x) {\n names(x)[NCOL(x)]\n} # /rtemis::outcome_name\n\n\n# %% outcome ----\n#' Get the outcome as a vector\n#'\n#' Returns the last column of `x`, which is by convention the outcome variable.\n#'\n#' @details\n#' This applied to tabular datasets used for supervised learning in rtemis,\n#' where, by convention, the last column is the outcome variable and all other columns\n#' are features.\n#'\n#' @param x tabular data.\n#'\n#' @return Vector containing the last column of `x`.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' outcome(iris)\noutcome <- new_generic(\"outcome\", \"x\", function(x) {\n S7_dispatch()\n}) # /rtemis::outcome\n\nmethod(outcome, class_data.frame) <- function(x) {\n x[[NCOL(x)]]\n}\n\n\n# %% features ----\n#' Get features from tabular data\n#'\n#' Returns all columns except the last one.\n#'\n#' @details\n#' This can be applied to tabular datasets used for supervised learning in \\pkg{rtemis},\n#' where, by convention, the last column is the outcome variable and all other columns\n#' are features.\n#'\n#' @param x tabular data: Input data to get features from.\n#'\n#' @return Object of the same class as the input, after removing the last column.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' features(iris) |> head()\nfeatures <- new_generic(\"features\", \"x\", function(x) {\n S7_dispatch()\n}) # /rtemis::features\n\nmethod(features, class_data.frame) <- function(x) {\n if (NCOL(x) < 2) {\n cli::cli_abort(\"Input must have at least 2 columns.\")\n }\n x[, -NCOL(x), drop = FALSE]\n}\n\nmethod(features, class_data.table) <- function(x) {\n if (NCOL(x) < 2) {\n cli::cli_abort(\"Input must have at least 2 columns.\")\n }\n x[, -NCOL(x), with = FALSE]\n} # /rtemis::features.class_data.table\n\n\n# %% feature_names ----\n#' Get feature names\n#'\n#' Returns all column names except the last one\n#'\n#' @details\n#' This applied to tabular datasets used for supervised learning in rtemis,\n#' where, by convention, the last column is the outcome variable and all other columns\n#' are features.\n#'\n#' @param x tabular data.\n#'\n#' @return Character vector of feature names.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' feature_names(iris)\nfeature_names <- new_generic(\"feature_names\", \"x\", function(x) {\n S7_dispatch()\n}) # /rtemis::feature_names\n\nmethod(feature_names, class_data.frame) <- function(x) {\n if (NCOL(x) < 2) {\n cli::cli_abort(\"Input must have at least 2 columns.\")\n }\n names(x)[-NCOL(x)]\n} # /rtemis::feature_names.class_data.frame\n\n\n# %% check_factor_levels ----\n#' Check factor levels\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncheck_factor_levels <- new_generic(\"check_factor_levels\", c(\"x\"))\n\n\n# %% get_factor_names ----\n#' Get factor names\n#'\n#' @details\n#' This applied to tabular datasets used for supervised learning in rtemis,\n#' where, by convention, the last column is the outcome variable and all other columns\n#' are features.\n#'\n#' @param x tabular data.\n#'\n#' @return Character vector of factor names.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' get_factor_names(iris)\nget_factor_names <- new_generic(\"get_factor_names\", \"x\", function(x) {\n S7_dispatch()\n}) # /rtemis::get_factor_names\n\nmethod(get_factor_names, class_data.frame) <- function(x) {\n names(x)[sapply(x, is.factor)]\n}\n\n\n# %% calibrate ----\n#' Calibrate `Classification` & `ClassificationRes` Models\n#'\n#' @description\n#' Generic function to calibrate binary classification models.\n#'\n#' @param x `Classification` or `ClassificationRes` object to calibrate.\n#' @param algorithm Character: Algorithm to use to train calibration model.\n#' @param hyperparameters `Hyperparameters` object: Setup using one of `setup_*` functions.\n#' @param verbosity Integer: Verbosity level.\n#' @param ... Additional arguments passed to specific methods.\n#'\n#' @section Method-specific parameters:\n#'\n#' **For `Classification` objects:**\n#' * `predicted_probabilities`: Numeric vector of predicted probabilities\n#' * `true_labels`: Factor of true class labels\n#'\n#' **For `ClassificationRes` objects:**\n#' * `resampler_config`: `ResamplerConfig` object for calibration training\n#' * `train_verbosity`: Integer controlling calibration model training output\n#'\n#' @details\n#' The goal of calibration is to adjust the predicted probabilities of a binary classification\n#' model so that they better reflect the true probabilities (i.e. empirical risk) of the positive\n#' class.\n#'\n#' @return Calibrated model object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' # --- Calibrate Classification ---\n#' dat <- iris[51:150, ]\n#' res <- resample(dat)\n#' dat$Species <- factor(dat$Species)\n#' dat_train <- dat[res[[1]], ]\n#' dat_test <- dat[-res[[1]], ]\n#'\n#' # Train GLM on a training/test split\n#' mod_c_glm <- train(\n#' x = dat_train,\n#' dat_test = dat_test,\n#' algorithm = \"glm\"\n#' )\n#'\n#' # Calibrate the `Classification` by defining `predicted_probabilities` and `true_labels`,\n#' # in this case using the training data, but it could be a separate calibration dataset.\n#' mod_c_glm_cal <- calibrate(\n#' mod_c_glm,\n#' predicted_probabilities = mod_c_glm$predicted_prob_training,\n#' true_labels = mod_c_glm$y_training\n#' )\n#' mod_c_glm_cal\n#'\n#' # --- Calibrate ClassificationRes ---\n#'\n#' # Train GLM with cross-validation\n#' resmod_c_glm <- train(\n#' x = dat,\n#' algorithm = \"glm\",\n#' outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\")\n#' )\n#'\n#' # Calibrate the `ClassificationRes` using the same resampling configuration as used for training.\n#' resmod_c_glm_cal <- calibrate(resmod_c_glm)\n#' resmod_c_glm_cal\ncalibrate <- new_generic(\n \"calibrate\",\n (\"x\"),\n function(\n x,\n algorithm = \"isotonic\",\n hyperparameters = NULL,\n verbosity = 1L,\n ...\n ) {\n S7_dispatch()\n }\n) # /rtemis::calibrate\n\n\n# %% freeze ----\n#' Freeze Hyperparameters\n#'\n#' @param x `Hyperparameters` object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nfreeze <- new_generic(\"freeze\", \"x\")\n\n\n# %% lock ----\n#' Lock Hyperparameters\n#'\n#' @param x `Hyperparameters` object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nlock <- new_generic(\"lock\", \"x\")\n\n\n# %% needs_tuning ----\n#' needs_tuning\n#'\n#' @keywords internal\n#' @noRd\nneeds_tuning <- new_generic(\"needs_tuning\", \"x\")\n\n\n# %% get_factor_levels ----\n#' @name get_factor_levels\n#'\n#' @title\n#' Get factor levels from data.frame or similar\n#'\n#' @usage\n#' get_factor_levels(x)\n#'\n#' @param x tabular data.\n#'\n#' @return Named list of factor levels. Names correspond to column names.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nget_factor_levels <- new_generic(\n \"get_factor_levels\",\n \"x\",\n function(x) S7_dispatch()\n)\n\nmethod(get_factor_levels, class_data.frame) <- function(x) {\n factor_index <- which(sapply(x, is.factor))\n lapply(x[, factor_index, drop = FALSE], levels)\n}\n\nmethod(get_factor_levels, class_data.table) <- function(x) {\n factor_index <- which(sapply(x, is.factor))\n # with = FALSE slightly more performance than using .SD\n lapply(x[, factor_index, with = FALSE], levels)\n}\n\n\n# %% is_tuned ----\nis_tuned <- new_generic(\"is_tuned\", \"x\")\n\n\n# %% get_tuned_status ----\nget_tuned_status <- new_generic(\"get_tuned_status\", \"x\")\n\n\n# %% one_hot ----\none_hot <- new_generic(\"one_hot\", \"x\")\n\n\n# --- Custom S7 validators -------------------------------------------------------------------------\n# %% scalar_dbl ----\n#' Scalar double\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nscalar_dbl <- S7::new_property(\n class = S7::class_double | NULL,\n validator = function(value) {\n if (!is.null(value)) {\n if (length(value) != 1) {\n \"must be a scalar double.\"\n } else if (!is.double(value)) {\n \"must be double.\"\n }\n }\n }\n) # /rtemis::scalar_dbl\n\n\n# %% scalar_dbl_01excl ----\n#' Scalar double between 0 and 1, exclusive\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nscalar_dbl_01excl <- S7::new_property(\n class = S7::class_double | NULL,\n validator = function(value) {\n if (!is.null(value)) {\n if (length(value) != 1) {\n \"must be a scalar double.\"\n } else if (value <= 0 || value >= 1) {\n \"must be between > 0 and < 1.\"\n }\n }\n }\n) # /rtemis::scalar_dbl_01excl\n\n\n# %% scalar_dbl_01incl ----\n#' Scalar double between 0 and 1, inclusive\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nscalar_dbl_01incl <- S7::new_property(\n class = S7::class_double | NULL,\n validator = function(value) {\n if (!is.null(value)) {\n if (length(value) != 1) {\n \"must be a scalar double.\"\n } else if (value < 0 || value > 1) {\n \"must be between >= 0 and <= 1.\"\n }\n }\n }\n) # /rtemis::scalar_dbl_01incl\n\n\n# %% scalar_int ----\n#' Scalar integer\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nscalar_int <- S7::new_property(\n class = S7::class_integer | NULL,\n validator = function(value) {\n if (!is.null(value)) {\n if (length(value) != 1) {\n \"must be a scalar integer.\"\n }\n }\n }\n) # /rtemis::scalar_int\n\n\n# %% scalar_int_pos ----\n#' Scalar positive integer\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nscalar_int_pos <- S7::new_property(\n class = S7::class_integer | NULL,\n validator = function(value) {\n if (!is.null(value)) {\n if (length(value) != 1) {\n \"must be a positive integer scalar.\"\n } else if (value < 0) {\n \"must be >= 0.\"\n }\n }\n }\n) # /rtemis::scalar_int_pos\n\n\n# %% preprocessed ----\n#' Get preprocessed data from `Preprocessor`.\n#'\n#' Returns the preprocessed data from a `Preprocessor` object.\n#'\n#' @param x `Preprocessor`: A `Preprocessor` object.\n#'\n#' @return data.frame: The preprocessed data.\n#'\n#' @export\n#'\n#' @examples\n#' prp <- preprocess(iris, setup_Preprocessor(scale = TRUE, center = TRUE))\n#' preprocessed(prp)\npreprocessed <- new_generic(\"preprocessed\", \"x\", function(x) {\n S7_dispatch()\n}) # /rtemis::preprocessed\n\n\n# --- Internal functions ---------------------------------------------------------------------------\n#' Get output type\n#'\n#' Get output type for printing text.\n#'\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#' @param filename Character: Filename for output.\n#'\n#' @return Character with selected output type.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nget_output_type <- function(\n output_type = c(\"ansi\", \"html\", \"plain\"),\n filename = NULL\n) {\n if (!is.null(filename)) {\n return(\"plain\")\n }\n\n if (is.null(output_type)) {\n if (interactive()) {\n return(\"ansi\")\n } else {\n return(\"plain\")\n }\n }\n\n match.arg(output_type)\n} # /rtemis::get_output_type\n\n\n# %% S7_to_list ----\nS7_to_list <- function(x) {\n if (S7_inherits(x)) {\n x <- props(x)\n }\n if (is.list(x)) {\n x <- lapply(x, S7_to_list)\n }\n x\n} # /rtemis::S7_to_list\n\n\n# %% toml_empty_to_null ----\ntoml_empty_to_null <- function(x) {\n if (!is.list(x)) {\n return(x)\n }\n if (length(x) == 0L) {\n return(NULL)\n }\n if (is.null(names(x))) {\n scalar_types <- vapply(\n x,\n function(el) {\n is.atomic(el) && length(el) == 1L && !is.null(el)\n },\n logical(1)\n )\n if (all(scalar_types)) {\n return(unlist(x, use.names = FALSE))\n }\n }\n lapply(x, toml_empty_to_null)\n} # /rtemis::toml_empty_to_null\n\n\n# %% write_lines ----\n#' Write lines to file\n#'\n#' Normalizes path, check if directory exists, creates it if necessary,\n#' writes lines to file, and checks if file was created successfully.\n#'\n#' @param x Character: Text to write to file.\n#' @param file Character: Path to output file.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Invisible NULL. Called for side effect of writing to file.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nwrite_lines <- function(x, file, overwrite = FALSE, verbosity = 1L) {\n # Normalize path\n file <- normalizePath(file, mustWork = FALSE)\n # Check if file exists\n if (file.exists(file)) {\n if (overwrite) {\n if (verbosity >= 1L) {\n msg(fmt(\n paste(\"Overwriting existing file:\", file),\n col = rtemis_colors[[\"orange\"]]\n ))\n }\n } else {\n cli::cli_abort(\n \"File already exists: {file}. Set `overwrite = TRUE` to overwrite.\"\n )\n }\n }\n # Get directory name\n dir <- dirname(file)\n # Check if directory exists, create it if not\n if (!dir.exists(dir)) {\n dir.create(dir, recursive = TRUE)\n if (!dir.exists(dir)) {\n cli::cli_abort(\"Failed to create directory: {dir}\")\n } else {\n if (verbosity >= 1L) {\n msg(checkmark(), \"Created directory:\", dir)\n }\n }\n }\n # Write lines to file\n writeLines(x, con = file)\n # Check if file was created successfully\n if (!file.exists(file)) {\n cli::cli_abort(\"Failed to create file: {file}\")\n } else {\n if (verbosity >= 1L) {\n msg(checkmark(), \"Created file:\", file)\n }\n }\n invisible(NULL)\n} # /rtemis::write_lines\n\n\n# %% toml_meta ----\n#' @name\n#' toml_meta\n#'\n#' @title\n#' Write TOML metadata\n#'\n#' @description\n#' Creates named list which will become first TOML table in the following format:\n#'\n#' ```toml\n#' [_meta]\n#' package = \"rtemis\"\n#' package_version = \"0.4.2\"\n#' schema_version = \"1.0\"\n#' object_type = \"SuperConfig\"\n#' created_at = 2026-2-11T22:45:00Z\n#' ```\n#' @param x Object to create metadata for. Class name will be included in metadata.\n#' @param schema_version Character: Version of the schema to include in metadata.\n#'\n#' @return Named list containing metadata.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ntoml_meta <- function(x, schema_version = \"1.0\") {\n list(\n `_meta` = list(\n package = \"rtemis\",\n package_version = as.character(packageVersion(\"rtemis\")),\n schema_version = schema_version,\n object_type = S7_class(x)@name,\n created_at = format(\n Sys.time(),\n \"%Y-%m-%dT%H:%M:%SZ\",\n tz = \"UTC\"\n )\n )\n )\n} # /rtemis::toml_meta\n\n\n# %% toml_with_meta ----\n#' Create TOML string with metadata\n#'\n#' Creates a TOML string with an inline metadata table followed by the TOML representation of the\n#' object.\n#'\n#' @param x Object to convert to TOML. Class name will be included in metadata.\n#'\n#'\n#' @return Character string containing TOML representation of the object, with metadata included as\n#' an inline table at the top.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ntoml_with_meta <- function(x, payload, schema_version = \"1.0\") {\n meta_block <- toml::write_toml(\n toml_meta(x, schema_version = schema_version)\n )\n meta_lines <- strsplit(meta_block, \"\\n\", fixed = TRUE)[[1]]\n meta_lines <- meta_lines[meta_lines != \"\" & meta_lines != \"[_meta]\"]\n meta_inline <- paste0(\n \"_meta = { \",\n paste(meta_lines, collapse = \", \"),\n \" }\"\n )\n payload_str <- toml::write_toml(payload)\n paste(meta_inline, payload_str, sep = \"\\n\\n\")\n} # /rtemis::toml_with_meta\n" }, { "path": "R/01_ExecutionConfig.R", "content": "# ExecutionConfig.R\n# ::rtemis::\n# 2026- EDG rtemis.org\n\n# %% ExecutionConfig ----\n#' ExecutionConfig Class\n#'\n#' @description\n#' Execution Configuration Class, defining sequential/parallel/distributed execution settings.\n#'\n#' @author EDG\n#' @noRd\nExecutionConfig <- new_class(\n name = \"ExecutionConfig\",\n properties = list(\n backend = class_character,\n n_workers = class_integer,\n future_plan = class_character | NULL\n ),\n constructor = function(backend, n_workers, future_plan) {\n n_workers <- clean_int(n_workers)\n check_character(backend, allow_null = FALSE)\n check_character(future_plan, allow_null = TRUE)\n new_object(\n S7::S7_object(),\n backend = backend,\n n_workers = n_workers,\n future_plan = future_plan\n )\n },\n validator = function(self) {\n if (self@backend == \"future\" && is.null(self@future_plan)) {\n \"@future_plan must be set when backend is 'future'.\"\n } else if (self@backend == \"none\" && self@n_workers != 1L) {\n \"n_workers must be 1 when backend is 'none'.\"\n } else if (self@backend == \"mirai\" && self@n_workers < 1L) {\n \"n_workers must be at least 1 when backend is 'mirai'.\"\n } else if (self@backend == \"future\" && self@n_workers < 1L) {\n \"n_workers must be at least 1 when backend is 'future'.\"\n }\n }\n) # /rtemis::ExecutionConfig\n\n\n# %% repr.ExecutionConfig ----\nmethod(repr, ExecutionConfig) <- function(x, pad = 0L, output_type = NULL) {\n out <- repr_S7name(\"ExecutionConfig\", pad = pad, output_type = output_type)\n .props <- props(x)\n if (.props[[\"backend\"]] != \"future\") {\n .props[[\"future_plan\"]] <- NULL\n }\n out <- paste0(\n out,\n repr_ls(.props, pad = pad, output_type = output_type)\n )\n} # /rtemis::repr.ExecutionConfig\n\n\n# %% print.ExecutionConfig ----\nmethod(print, ExecutionConfig) <- function(x, output_type = NULL, ...) {\n cat(repr(x, output_type = output_type), \"\\n\")\n invisible(x)\n} # /rtemis::print.ExecutionConfig\n\n\n# %% --- User API ----\n\n# %% setup_ExecutionConfig ----\n#' Setup Execution Configuration\n#'\n#' @param backend Character: Execution backend: \"future\", \"mirai\", or \"none\".\n#' @param n_workers Integer: Number of workers for parallel execution. Only used if `backend is\n#' \"future\"` or \"mirai\". Do not rely on the default value, set to an appropriate number depending\n#' on your system.\n#' @param future_plan Character: Future plan to use if `backend` is \"future\".\n#'\n#' @return `ExecutionConfig` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' setup_ExecutionConfig(backend = \"future\", n_workers = 4L, future_plan = \"multisession\")\nsetup_ExecutionConfig <- function(\n backend = c(\"future\", \"mirai\", \"none\"),\n n_workers = NULL,\n future_plan = NULL\n) {\n backend <- match.arg(backend)\n if (backend == \"future\") {\n check_dependencies(\"futurize\")\n check_character(future_plan, allow_null = TRUE)\n if (is.null(future_plan)) {\n future_plan <- getOption(\"future.plan\", \"mirai_multisession\")\n }\n if (!future_plan %in% ALLOWED_PLANS) {\n cli::cli_abort(\n \"{.val {future_plan}} is not an allowed future plan. Allowed plans: {.val {ALLOWED_PLANS}}.\"\n )\n }\n if (is.null(n_workers)) {\n n_workers <- parallelly::availableCores(omit = 3L)\n }\n } else if (backend == \"mirai\") {\n check_dependencies(\"mirai\")\n if (is.null(n_workers)) {\n n_workers <- parallelly::availableCores(omit = 3L)\n }\n } else if (backend == \"none\") {\n if (is.null(n_workers)) {\n n_workers <- 1L\n } else if (n_workers != 1L) {\n cli::cli_abort(\"n_workers must be 1 when backend is 'none'.\")\n }\n }\n n_workers <- clean_int(n_workers)\n if (n_workers < 1L) {\n cli::cli_abort(\"n_workers must be at least 1.\")\n }\n ExecutionConfig(\n backend = backend,\n n_workers = n_workers,\n future_plan = if (backend == \"future\") future_plan else NULL\n )\n} # /rtemis::setup_ExecutionConfig\n" }, { "path": "R/02_Hyperparameters.R", "content": "# S7_Hyperparameters.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# References ----\n# S7\n# - https://github.com/RConsortium/S7\n# - https://rconsortium.github.io/S7/\n# LightGBM parameters\n# - https://lightgbm.readthedocs.io/en/latest/Parameters.html\n\n# %% Constants ----\n# `tuned` values ----\n# -9: Set by Tuner: Actively being tuned (Values fixed by Tuner).\n# -2: Set by constructor: Not tunable (No tunable_hyperparameters).\n# -1: Set by constructor: Not tunable (tunable_hyperparameters exist, but none of them have more than one value).\n# 0: Set by constructor: Untuned but tunable (at least one of tunable_hyperparameters has more than one value).\n# 1: Set by Tuner: Tuned (Started as 0, set to 1 when tuned).\nTUNED_STATUS_TUNING <- -9L\nTUNED_STATUS_NOT_TUNABLE <- -2L\nTUNED_STATUS_NO_SEARCH_VALUES <- -1L\nTUNED_STATUS_UNTUNED <- 0L\nTUNED_STATUS_TUNED <- 1L\n\n# `resampled` values ----\n# 0: Running on single training set.\n# 1: Running on resampled training sets.\n\n# %% Hyperparameters ----\n#' @title Hyperparameters\n#'\n#' @description\n#' Superclass for hyperparameters.\n#'\n#' @field algorithm Character: Algorithm name.\n#' @field hyperparameters Named list of algorithm hyperparameter values.\n#' @field tunable_hyperparameters Character: Names of tunable hyperparameters.\n#' @field fixed_hyperparameters Character: Names of fixed hyperparameters.\n#' @field tuned Integer: Tuning status.\n#' @field resampled Integer: Outer resampling status.\n#' @field n_workers Integer: Number of workers to use for tuning.\n#'\n#' @author EDG\n#' @noRd\nHyperparameters <- new_class(\n name = \"Hyperparameters\",\n properties = list(\n algorithm = class_character,\n hyperparameters = class_list,\n tunable_hyperparameters = class_character,\n fixed_hyperparameters = class_character,\n tuned = class_integer,\n resampled = class_integer,\n n_workers = class_integer\n ),\n constructor = function(\n algorithm,\n hyperparameters,\n tunable_hyperparameters,\n fixed_hyperparameters,\n n_workers = 1L\n ) {\n # Test if any tunable_hyperparameters have more than one value\n if (length(tunable_hyperparameters) > 0) {\n if (any(sapply(hyperparameters[tunable_hyperparameters], length) > 1)) {\n tuned <- 0L # Search values defined for tunable hyperparameters.\n } else {\n tuned <- -1L # No search values defined for tunable hyperparameters.\n }\n } else {\n tuned <- -2L # No tunable hyperparameters\n }\n # GLMNET\n if (algorithm == \"GLMNET\") {\n if (is.null(hyperparameters[[\"lambda\"]])) {\n tuned <- 0L\n }\n }\n # LightGBM\n if (algorithm == \"LightGBM\") {\n if (is.null(hyperparameters[[\"nrounds\"]])) {\n tuned <- 0L\n }\n }\n # SVM\n # Check kernel-specific hyperparameters\n if (algorithm == \"SVM\") {\n # linear => cost\n if (hyperparameters[[\"kernel\"]] == \"linear\") {\n if (length(hyperparameters[[\"cost\"]]) > 1) {\n tuned <- 0L\n }\n } else if (hyperparameters[[\"kernel\"]] == \"polynomial\") {\n if (length(hyperparameters[[\"degree\"]]) > 1) {\n tuned <- 0L\n }\n } else if (hyperparameters[[\"kernel\"]] == \"radial\") {\n if (length(hyperparameters[[\"sigma\"]]) > 1) {\n tuned <- 0L\n }\n }\n }\n n_workers <- clean_posint(n_workers)\n new_object(\n S7_object(),\n algorithm = algorithm,\n hyperparameters = hyperparameters,\n tunable_hyperparameters = tunable_hyperparameters,\n fixed_hyperparameters = fixed_hyperparameters,\n tuned = tuned,\n resampled = 0L,\n n_workers = n_workers\n )\n }\n) # /rtemis::Hyperparameters\n\n\n# %% repr.Hyperparameters ----\n#' Repr Hyperparameters\n#'\n#' repr method for Hyperparameters object.\n#'\n#' @param x `Hyperparameters` object.\n#' @param pad Integer: Left padding for printed output.\n#' @param maxlength Integer: Maximum length of items to show using `headdot()` before truncating with ellipsis. `-1` means no limit.\n#' @param limit Integer: Limit number of items to show. `-1` means no limit.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @author EDG\n#' @noRd\nmethod(repr, Hyperparameters) <- function(\n x,\n pad = 0L,\n maxlength = -1L,\n limit = -1L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n out <- repr_S7name(\n paste0(x@algorithm, \"Hyperparameters\"),\n pad = pad,\n output_type = output_type\n )\n out <- paste0(\n out,\n repr_ls(\n props(x)[-1],\n pad = pad,\n maxlength = maxlength,\n limit = limit,\n output_type = output_type\n )\n )\n if (x@tuned == TUNED_STATUS_TUNING) {\n out <- paste0(\n out,\n fmt(\n \"\\n Hyperparameters are being tuned.\\n\",\n col = col_tuner,\n bold = TRUE,\n output_type = output_type\n )\n )\n } else if (x@tuned == TUNED_STATUS_NOT_TUNABLE) {\n out <- paste0(\n out,\n fmt(\n \"\\n No hyperparameters are tunable.\\n\",\n col = col_tuner,\n bold = TRUE,\n output_type = output_type\n )\n )\n } else if (x@tuned == TUNED_STATUS_UNTUNED) {\n need_tuning <- names(get_hyperparams_need_tuning(x))\n out <- paste0(\n out,\n fmt(\n paste0(\n \"\\n \",\n ngettext(length(need_tuning), \"Hyperparameter \", \"Hyperparameters \"),\n oxfordcomma(\n need_tuning\n ),\n ngettext(length(need_tuning), \" needs \", \" need \"),\n \"tuning.\\n\"\n ),\n col = col_tuner,\n bold = TRUE,\n output_type = output_type\n )\n )\n } else if (x@tuned == TUNED_STATUS_NO_SEARCH_VALUES) {\n out <- paste0(\n out,\n fmt(\n \"\\n No search values defined for tunable hyperparameters.\\n\",\n col = col_tuner,\n bold = TRUE,\n output_type = output_type\n )\n )\n } else if (x@tuned == TUNED_STATUS_TUNED) {\n out <- paste0(\n out,\n fmt(\n \"\\n Hyperparameters are tuned.\\n\",\n col = col_tuner,\n bold = TRUE,\n output_type = output_type\n )\n )\n }\n out\n} # /rtemis::repr.Hyperparameters\n\n\n# %% print.Hyperparameters ----\nmethod(print, Hyperparameters) <- function(x, output_type = NULL, ...) {\n cat(repr(x, output_type = output_type))\n invisible(x)\n} # /rtemis::print.Hyperparameters\n\n\n# %% is_tuned.Hyperparameters ----\nmethod(is_tuned, Hyperparameters) <- function(x) {\n x@tuned == 1L\n} # /is_tuned.Hyperparameters\n\n\n# %% get_tuned_status.Hyperparameters ----\nmethod(get_tuned_status, Hyperparameters) <- function(x) {\n if (length(x@tunable_hyperparameters) > 0) {\n if (any(sapply(x@hyperparameters[x@tunable_hyperparameters], length) > 1)) {\n 0L\n } else {\n -1L\n }\n } else {\n -2L\n }\n} # /rtemis::get_tuned_status.Hyperparameters\n\n\n# %% update.Hyperparameters ----\n#' Update Hyperparameters\n#'\n#' @param x `Hyperparameters` object.\n#' @param hyperparameters Named list of algorithm hyperparameter values.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(update, Hyperparameters) <- function(\n object,\n hyperparameters,\n tuned = NULL,\n ...\n) {\n for (hp in names(hyperparameters)) {\n object@hyperparameters[[hp]] <- hyperparameters[[hp]]\n }\n # Update tuned status\n if (is.null(tuned)) {\n object@tuned <- get_tuned_status(object)\n } else {\n object@tuned <- tuned\n }\n object\n} # /rtemis::update.Hyperparameters\n\n\n# %% freeze.Hyperparameters ----\nmethod(freeze, Hyperparameters) <- function(x) {\n x@tuned <- -1L\n} # /rtemis::freeze.Hyperparameters\n\n\n# %% lock.Hyperparameters ----\nmethod(lock, Hyperparameters) <- function(x) {\n x@tuned <- 1L\n}\n\n\n# %% `$`.Hyperparameters ----\n# Make Hyperparameters@hyperparameters@name `$`-accessible\nmethod(`$`, Hyperparameters) <- function(x, name) {\n x@hyperparameters[[name]]\n}\n\n\n# %% `.DollarNames`.Hyperparameters ----\n# `$`-autocomplete Hyperparameters@hyperparameters\nmethod(`.DollarNames`, Hyperparameters) <- function(x, pattern = \"\") {\n all_names <- names(x@hyperparameters)\n grep(pattern, all_names, value = TRUE)\n}\n\n\n# %% `[[`.Hyperparameters ----\n# Make Hyperparameters@hyperparameters@name `[[`-accessible\nmethod(`[[`, Hyperparameters) <- function(x, name) {\n x@hyperparameters[[name]]\n}\n\n\n# %% needs_tuning.Hyperparameters ----\nmethod(needs_tuning, Hyperparameters) <- function(x) {\n x@tuned == 0\n} # /rtemis::needs_tuning.Hyperparameters\n\n\n# %% get_hyperparams_need_tuning.Hyperparameters ----\n#' Get hyperparameters that need tuning in an algorithm-specific way.\n#'\n#' @keywords internal\n#' @noRd\nmethod(get_hyperparams_need_tuning, Hyperparameters) <- function(x) {\n # -> list\n # Get tunable hyperparameters with more than one value\n x@hyperparameters[x@tunable_hyperparameters[\n sapply(x@hyperparameters[x@tunable_hyperparameters], length) > 1\n ]]\n} # /get_hyperparams_need_tuning.Hyperparameters\n\n\n# %% get_hyperparams.(Hyperparameters, class_character) ----\nmethod(get_hyperparams, list(Hyperparameters, class_character)) <- function(\n x,\n param_names\n) {\n sapply(param_names, function(p) x@hyperparameters[p], USE.NAMES = FALSE)\n} # /rtemis::get_hyperparams_need_tuning.Hyperparameters\n\n\n# %% GLMHyperparameters ----\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nGLMHyperparameters <- new_class(\n name = \"GLMHyperparameters\",\n parent = Hyperparameters,\n constructor = function(ifw) {\n new_object(\n Hyperparameters(\n algorithm = \"GLM\",\n hyperparameters = list(\n ifw = ifw\n ),\n tunable_hyperparameters = \"ifw\",\n fixed_hyperparameters = character()\n )\n )\n } # /constructor\n) # /rtemis::GLMHyperparameters\n\n\n# %% setup_GLM ----\n#' Setup GLM Hyperparameters\n#'\n#' Setup hyperparameters for GLM training.\n#'\n#' @param ifw (Tunable) Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#'\n#' @return GLMHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' glm_hyperparams <- setup_GLM(ifw = TRUE)\n#' glm_hyperparams\nsetup_GLM <- function(ifw = FALSE) {\n GLMHyperparameters(ifw = ifw)\n}\n\n\n# %% GAMHyperparameters ----\nGAM_tunable <- c(\"k\", \"ifw\")\nGAM_fixed <- character()\n\n#' @author EDG\n#' @keywords internal\n#' @noRd\nGAMHyperparameters <- new_class(\n name = \"GAMHyperparameters\",\n parent = Hyperparameters,\n constructor = function(k, ifw) {\n new_object(\n Hyperparameters(\n algorithm = \"GAM\",\n hyperparameters = list(\n k = k,\n ifw = ifw\n ),\n tunable_hyperparameters = GAM_tunable,\n fixed_hyperparameters = GAM_fixed\n )\n )\n } # /constructor\n) # /rtemis::GAMHyperparameters\n\n\n# %% setup_GAM ----\n#' Setup GAM Hyperparameters\n#'\n#' Setup hyperparameters for GAM training.\n#'\n#' Get more information from [mgcv::gam].\n#'\n#' @param k (Tunable) Integer: Number of knots.\n#' @param ifw (Tunable) Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#'\n#' @return GAMHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' gam_hyperparams <- setup_GAM(k = 5L, ifw = FALSE)\n#' gam_hyperparams\nsetup_GAM <- function(k = 5L, ifw = FALSE) {\n k <- clean_posint(k)\n GAMHyperparameters(k = k, ifw = ifw)\n}\n\n\n# %% CARTHyperparameters ----\nCART_tunable <- c(\"cp\", \"maxdepth\", \"minsplit\", \"minbucket\", \"prune_cp\", \"ifw\")\nCART_fixed <- c(\n \"method\",\n \"model\",\n \"maxcompete\",\n \"maxsurrogate\",\n \"usesurrogate\",\n \"surrogatestyle\",\n \"xval\",\n \"cost\"\n)\n\n\n#' @title CARTHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for CART.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nCARTHyperparameters <- new_class(\n name = \"CARTHyperparameters\",\n parent = Hyperparameters,\n constructor = function(\n cp,\n maxdepth,\n minsplit,\n minbucket,\n prune_cp,\n method,\n model,\n maxcompete,\n maxsurrogate,\n usesurrogate,\n surrogatestyle,\n xval,\n cost,\n ifw\n ) {\n new_object(\n Hyperparameters(\n algorithm = \"CART\",\n hyperparameters = list(\n cp = cp,\n maxdepth = maxdepth,\n minsplit = minsplit,\n minbucket = minbucket,\n prune_cp = prune_cp,\n method = method,\n model = model,\n maxcompete = maxcompete,\n maxsurrogate = maxsurrogate,\n usesurrogate = usesurrogate,\n surrogatestyle = surrogatestyle,\n xval = xval,\n cost = cost,\n ifw = ifw\n ),\n tunable_hyperparameters = CART_tunable,\n fixed_hyperparameters = CART_fixed\n )\n )\n } # /constructor\n) # /rtemis::CARTHyperparameters\n\n\n# %% setup_CART ----\n#' Setup CART Hyperparameters\n#'\n#' Setup hyperparameters for CART training.\n#'\n#' Get more information from [rpart::rpart] and [rpart::rpart.control].\n#'\n#' @param cp (Tunable) Numeric: Complexity parameter.\n#' @param maxdepth (Tunable) Integer: Maximum depth of tree.\n#' @param minsplit (Tunable) Integer: Minimum number of observations in a node to split.\n#' @param minbucket (Tunable) Integer: Minimum number of observations in a terminal node.\n#' @param prune_cp (Tunable) Numeric: Complexity for cost-complexity pruning after tree is built\n#' @param method String: Splitting method.\n#' @param model Logical: If TRUE, return a model.\n#' @param maxcompete Integer: Maximum number of competitive splits.\n#' @param maxsurrogate Integer: Maximum number of surrogate splits.\n#' @param usesurrogate Integer: Number of surrogate splits to use.\n#' @param surrogatestyle Integer: Type of surrogate splits.\n#' @param xval Integer: Number of cross-validation folds.\n#' @param cost Numeric (>=0): One for each feature.\n#' @param ifw Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#'\n#' @return CARTHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' cart_hyperparams <- setup_CART(cp = 0.01, maxdepth = 10L, ifw = TRUE)\n#' cart_hyperparams\nsetup_CART <- function(\n # tunable\n cp = 0.01,\n maxdepth = 20L,\n minsplit = 2L,\n minbucket = 1L, # round(minsplit / 3),\n prune_cp = NULL,\n # fixed\n method = \"auto\",\n model = TRUE,\n maxcompete = 4L,\n maxsurrogate = 5L,\n usesurrogate = 2L,\n surrogatestyle = 0L,\n xval = 0L,\n cost = NULL,\n ifw = FALSE\n) {\n check_inherits(cp, \"numeric\")\n maxdepth <- clean_int(maxdepth)\n minsplit <- clean_int(minsplit)\n minbucket <- clean_int(minbucket)\n check_inherits(prune_cp, \"numeric\")\n check_inherits(method, \"character\")\n check_inherits(model, \"logical\")\n maxcompete <- clean_int(maxcompete)\n maxsurrogate <- clean_int(maxsurrogate)\n usesurrogate <- clean_int(usesurrogate)\n surrogatestyle <- clean_int(surrogatestyle)\n xval <- clean_int(xval)\n check_inherits(cost, \"numeric\")\n CARTHyperparameters(\n cp = cp,\n maxdepth = maxdepth,\n minsplit = minsplit,\n minbucket = minbucket,\n prune_cp = prune_cp,\n method = method,\n model = model,\n maxcompete = maxcompete,\n maxsurrogate = maxsurrogate,\n usesurrogate = usesurrogate,\n surrogatestyle = surrogatestyle,\n xval = xval,\n cost = cost,\n ifw = ifw\n )\n} # /rtemis::setup_CART\n\n# Test that all CART hyperparameters are set by setup_CART\nstopifnot(all(c(CART_tunable, CART_fixed) %in% names(formals(setup_CART))))\n\n\n# %% GLMNETHyperparameters ----\nGLMNET_tunable <- c(\"alpha\", \"ifw\")\nGLMNET_fixed <- c(\n \"family\",\n \"offset\",\n \"which_lambda_cv\",\n \"nlambda\",\n \"penalty_factor\",\n \"standardize\",\n \"intercept\"\n)\n\n#' @title GLMNETHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for GLMNET.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nGLMNETHyperparameters <- new_class(\n name = \"GLMNETHyperparameters\",\n parent = Hyperparameters,\n constructor = function(\n alpha,\n family,\n offset,\n which_lambda_cv,\n nlambda,\n lambda,\n penalty_factor,\n standardize,\n intercept,\n ifw\n ) {\n check_float01inc(alpha)\n check_inherits(which_lambda_cv, \"character\")\n nlambda <- clean_posint(nlambda)\n check_inherits(penalty_factor, \"numeric\")\n check_inherits(standardize, \"logical\")\n new_object(\n Hyperparameters(\n algorithm = \"GLMNET\",\n hyperparameters = list(\n alpha = alpha,\n family = family,\n offset = offset,\n which_lambda_cv = which_lambda_cv,\n nlambda = nlambda,\n lambda = lambda,\n penalty_factor = penalty_factor,\n standardize = standardize,\n intercept = intercept,\n ifw = ifw\n ),\n tunable_hyperparameters = GLMNET_tunable,\n fixed_hyperparameters = GLMNET_fixed\n )\n )\n } # /constructor\n) # /rtemis::GLMNETHyperparameters\n\n#' Setup GLMNET Hyperparameters\n#'\n#' Setup hyperparameters for GLMNET training.\n#'\n#' Get more information from [glmnet::glmnet].\n#'\n#' @param alpha (Tunable) Numeric: Mixing parameter.\n#' @param family Character: Family for GLMNET.\n#' @param offset Numeric: Offset for GLMNET.\n#' @param which_lambda_cv Character: Which lambda to use for prediction:\n#' \"lambda.1se\" or \"lambda.min\"\n#' @param nlambda Positive integer: Number of lambda values.\n#' @param lambda Numeric: Lambda values.\n#' @param penalty_factor Numeric: Penalty factor for each feature.\n#' @param standardize Logical: If TRUE, standardize features.\n#' @param intercept Logical: If TRUE, include intercept.\n#' @param ifw Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#'\n#' @return GLMNETHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' glm_hyperparams <- setup_GLMNET(alpha = 1, ifw = TRUE)\n#' glm_hyperparams\nsetup_GLMNET <- function(\n # tunable\n alpha = 1,\n # fixed\n family = NULL,\n offset = NULL,\n which_lambda_cv = \"lambda.1se\",\n nlambda = 100L,\n lambda = NULL,\n penalty_factor = NULL,\n standardize = TRUE,\n intercept = TRUE,\n ifw = TRUE\n) {\n check_float01inc(alpha)\n check_inherits(which_lambda_cv, \"character\")\n nlambda <- clean_posint(nlambda)\n check_inherits(penalty_factor, \"numeric\")\n check_logical(standardize)\n check_logical(ifw)\n GLMNETHyperparameters(\n family = family,\n offset = offset,\n alpha = alpha,\n which_lambda_cv = which_lambda_cv,\n nlambda = nlambda,\n lambda = lambda,\n penalty_factor = penalty_factor,\n standardize = standardize,\n intercept = intercept,\n ifw = ifw\n )\n} # /rtemis::setup_GLMNET\n\n# Test that all GLMNET hyperparameters are set by setup_GLMNET\nstopifnot(all(\n c(GLMNET_tunable, GLMNET_fixed) %in% names(formals(setup_GLMNET))\n))\n\nmethod(get_hyperparams_need_tuning, GLMNETHyperparameters) <- function(x) {\n # Get tunable hyperparameters with more than one value\n out <- x@hyperparameters[x@tunable_hyperparameters[\n sapply(x@hyperparameters[x@tunable_hyperparameters], length) > 1\n ]]\n if (is.null(x[[\"lambda\"]])) {\n out <- c(out, list(lambda = NULL))\n }\n out\n} # /rtemis::get_hyperparams_need_tuning.GLMNETHyperparameters\n\n\n# %% LightCARTHyperparameters ----\nLightCART_tunable <- c(\n \"num_leaves\",\n \"max_depth\",\n \"lambda_l1\",\n \"lambda_l2\",\n \"min_data_in_leaf\",\n \"max_cat_threshold\",\n \"min_data_per_group\",\n \"linear_tree\",\n \"ifw\"\n)\nLightCART_fixed <- c(\"objective\")\n\n#' @title LightCARTHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for LightCART\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nLightCARTHyperparameters <- new_class(\n name = \"LightCARTHyperparameters\",\n parent = Hyperparameters,\n constructor = function(\n num_leaves,\n max_depth,\n lambda_l1,\n lambda_l2,\n min_data_in_leaf,\n max_cat_threshold,\n min_data_per_group,\n linear_tree,\n objective,\n ifw\n ) {\n new_object(\n Hyperparameters(\n algorithm = \"LightCART\",\n hyperparameters = list(\n num_leaves = num_leaves,\n max_depth = max_depth,\n lambda_l1 = lambda_l1,\n lambda_l2 = lambda_l2,\n min_data_in_leaf = min_data_in_leaf,\n max_cat_threshold = max_cat_threshold,\n min_data_per_group = min_data_per_group,\n linear_tree = linear_tree,\n objective = objective,\n ifw = ifw\n ),\n tunable_hyperparameters = LightCART_tunable,\n fixed_hyperparameters = LightCART_fixed\n )\n )\n } # /constructor\n) # /rtemis::LightCARTHyperparameters\n\n\n# %% setup_LightCART ----\n#' Setup LightCART Hyperparameters\n#'\n#' Setup hyperparameters for LightCART training.\n#'\n#' Get more information from [lightgbm::lgb.train].\n#'\n#' @param num_leaves (Tunable) Positive integer: Maximum number of leaves in one tree.\n#' @param max_depth (Tunable) Integer: Maximum depth of trees.\n#' @param lambda_l1 (Tunable) Numeric: L1 regularization.\n#' @param lambda_l2 (Tunable) Numeric: L2 regularization.\n#' @param min_data_in_leaf (Tunable) Positive integer: Minimum number of data in a leaf.\n#' @param max_cat_threshold (Tunable) Positive integer: Maximum number of categories for categorical features.\n#' @param min_data_per_group (Tunable) Positive integer: Minimum number of observations per categorical group.\n#' @param linear_tree (Tunable) Logical: If TRUE, use linear trees.\n#' @param objective Character: Objective function.\n#' @param ifw Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#'\n#' @return LightCARTHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' lightcart_hyperparams <- setup_LightCART(num_leaves = 32L, ifw = FALSE)\n#' lightcart_hyperparams\nsetup_LightCART <- function(\n num_leaves = 32L,\n max_depth = -1L,\n lambda_l1 = 0,\n lambda_l2 = 0,\n min_data_in_leaf = 20L,\n max_cat_threshold = 32L,\n min_data_per_group = 100L,\n linear_tree = FALSE,\n objective = NULL,\n ifw = FALSE\n) {\n num_leaves <- clean_posint(num_leaves)\n max_depth <- clean_int(max_depth)\n check_float0pos(lambda_l1)\n check_float0pos(lambda_l2)\n min_data_in_leaf <- clean_posint(min_data_in_leaf)\n max_cat_threshold <- clean_posint(max_cat_threshold)\n min_data_per_group <- clean_posint(min_data_per_group)\n check_logical(linear_tree)\n LightCARTHyperparameters(\n num_leaves = num_leaves,\n max_depth = max_depth,\n lambda_l1 = lambda_l1,\n lambda_l2 = lambda_l2,\n min_data_in_leaf = min_data_in_leaf,\n max_cat_threshold = max_cat_threshold,\n min_data_per_group = min_data_per_group,\n linear_tree = linear_tree,\n objective = objective,\n ifw = ifw\n )\n} # /rtemis::setup_LightCART\n\n\n# %% LightRFHyperparameters ----\nLightRF_tunable <- c(\n \"nrounds\",\n \"num_leaves\",\n \"max_depth\",\n \"feature_fraction\",\n \"subsample\",\n \"lambda_l1\",\n \"lambda_l2\",\n \"max_cat_threshold\",\n \"min_data_per_group\",\n \"ifw\"\n)\nLightRF_fixed <- c(\n \"objective\",\n \"device_type\",\n \"tree_learner\",\n \"boosting_type\",\n \"learning_rate\",\n \"subsample_freq\",\n \"early_stopping_rounds\",\n \"force_col_wise\"\n)\n\n#' @title LightRFHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for LightRF\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nLightRFHyperparameters <- new_class(\n name = \"LightRFHyperparameters\",\n parent = Hyperparameters,\n constructor = function(\n nrounds,\n num_leaves,\n max_depth,\n feature_fraction,\n subsample,\n lambda_l1,\n lambda_l2,\n max_cat_threshold,\n min_data_per_group,\n linear_tree,\n ifw,\n # fixed\n objective,\n device_type,\n tree_learner,\n force_col_wise\n ) {\n new_object(\n Hyperparameters(\n algorithm = \"LightRF\",\n hyperparameters = list(\n nrounds = nrounds,\n num_leaves = num_leaves,\n max_depth = max_depth,\n feature_fraction = feature_fraction,\n subsample = subsample,\n lambda_l1 = lambda_l1,\n lambda_l2 = lambda_l2,\n max_cat_threshold = max_cat_threshold,\n min_data_per_group = min_data_per_group,\n linear_tree = linear_tree,\n ifw = ifw,\n # fixed\n objective = objective,\n device_type = device_type,\n tree_learner = tree_learner,\n force_col_wise = force_col_wise,\n # unsettable: LightGBM params for RF\n boosting_type = \"rf\",\n learning_rate = 1, # no effect? in boosting_type 'rf', but set for clarity\n subsample_freq = 1L, # a.k.a. bagging_freq\n early_stopping_rounds = -1L\n ),\n tunable_hyperparameters = LightRF_tunable,\n fixed_hyperparameters = LightRF_fixed\n )\n )\n }\n) # /rtemis::LightRFHyperparameters\n\n\n# %% setup_LightRF ----\n#' Setup LightRF Hyperparameters\n#'\n#' Setup hyperparameters for LightRF training.\n#'\n#' Get more information from [lightgbm::lgb.train].\n#' Note that hyperparameters subsample_freq and early_stopping_rounds are fixed,\n#' and cannot be set because they are what makes `lightgbm` train a random forest.\n#' These can all be set when training gradient boosting with LightGBM.\n#'\n#' @param nrounds (Tunable) Positive integer: Number of boosting rounds.\n#' @param num_leaves (Tunable) Positive integer: Maximum number of leaves in one tree.\n#' @param max_depth (Tunable) Integer: Maximum depth of trees.\n#' @param feature_fraction (Tunable) Numeric: Fraction of features to use.\n#' @param subsample (Tunable) Numeric: Fraction of data to use.\n#' @param lambda_l1 (Tunable) Numeric: L1 regularization.\n#' @param lambda_l2 (Tunable) Numeric: L2 regularization.\n#' @param max_cat_threshold (Tunable) Positive integer: Maximum number of categories for categorical features.\n#' @param min_data_per_group (Tunable) Positive integer: Minimum number of observations per categorical group.\n#' @param linear_tree Logical: If TRUE, use linear trees.\n#' @param objective Character: Objective function.\n#' @param ifw Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#' @param device_type Character: \"cpu\" or \"gpu\".\n#' @param tree_learner Character: \"serial\", \"feature\", \"data\", or \"voting\".\n#' @param force_col_wise Logical: Use only with CPU - If TRUE, force col-wise histogram building.\n#'\n#' @return LightRFHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' lightrf_hyperparams <- setup_LightRF(nrounds = 1000L, ifw = FALSE)\n#' lightrf_hyperparams\nsetup_LightRF <- function(\n nrounds = 500L,\n num_leaves = 4096L,\n max_depth = -1L,\n feature_fraction = 0.7,\n subsample = .623, # a.k.a. bagging_fraction\n lambda_l1 = 0,\n lambda_l2 = 0,\n max_cat_threshold = 32L,\n min_data_per_group = 32L,\n linear_tree = FALSE,\n ifw = FALSE,\n # fixed\n objective = NULL,\n device_type = \"cpu\",\n tree_learner = \"serial\",\n force_col_wise = TRUE\n) {\n nrounds <- clean_posint(nrounds)\n num_leaves <- clean_posint(num_leaves)\n max_depth <- clean_int(max_depth)\n check_float01inc(feature_fraction)\n check_float01inc(subsample)\n check_float0pos(lambda_l1)\n check_float0pos(lambda_l2)\n max_cat_threshold <- clean_posint(max_cat_threshold)\n min_data_per_group <- clean_posint(min_data_per_group)\n check_logical(linear_tree)\n LightRFHyperparameters(\n nrounds = nrounds,\n num_leaves = num_leaves,\n max_depth = max_depth,\n feature_fraction = feature_fraction,\n subsample = subsample,\n lambda_l1 = lambda_l1,\n lambda_l2 = lambda_l2,\n max_cat_threshold = max_cat_threshold,\n min_data_per_group = min_data_per_group,\n linear_tree = linear_tree,\n ifw = ifw,\n objective = objective,\n device_type = device_type,\n tree_learner = tree_learner,\n force_col_wise = force_col_wise\n )\n} # /rtemis::setupLightRF\n\n# Test that all LightRF hyperparameters are set by setup_LightRF\n# LightRF fixed hyperparameters are not editable.\nstopifnot(all(LightRF_tunable %in% names(formals(setup_LightRF))))\n\n\n# %% LightGBMHyperparameters ----\nLightGBM_tunable <- c(\n \"num_leaves\",\n \"max_depth\",\n \"learning_rate\",\n \"feature_fraction\",\n \"subsample\",\n \"subsample_freq\",\n \"lambda_l1\",\n \"lambda_l2\",\n \"max_cat_threshold\",\n \"min_data_per_group\",\n \"linear_tree\",\n \"ifw\"\n)\nLightGBM_fixed <- c(\n \"max_nrounds\",\n \"force_nrounds\",\n \"early_stopping_rounds\",\n \"objective\",\n \"device_type\",\n \"tree_learner\",\n \"force_col_wise\"\n)\n\n\n#' @title LightGBMHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for LightGBM\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nLightGBMHyperparameters <- new_class(\n name = \"LightGBMHyperparameters\",\n parent = Hyperparameters,\n constructor = function(\n max_nrounds,\n force_nrounds,\n early_stopping_rounds,\n # tunable\n num_leaves,\n max_depth,\n learning_rate,\n feature_fraction,\n subsample,\n subsample_freq,\n lambda_l1,\n lambda_l2,\n max_cat_threshold,\n min_data_per_group,\n linear_tree,\n ifw,\n objective,\n device_type,\n tree_learner,\n force_col_wise\n ) {\n nrounds <- if (!is.null(force_nrounds)) {\n force_nrounds\n } else {\n NULL\n }\n new_object(\n Hyperparameters(\n algorithm = \"LightGBM\",\n hyperparameters = list(\n nrounds = nrounds,\n max_nrounds = max_nrounds,\n force_nrounds = force_nrounds,\n early_stopping_rounds = early_stopping_rounds,\n num_leaves = num_leaves,\n max_depth = max_depth,\n learning_rate = learning_rate,\n feature_fraction = feature_fraction,\n subsample = subsample,\n subsample_freq = subsample_freq,\n lambda_l1 = lambda_l1,\n lambda_l2 = lambda_l2,\n max_cat_threshold = max_cat_threshold,\n min_data_per_group = min_data_per_group,\n linear_tree = linear_tree,\n ifw = ifw,\n objective = objective,\n device_type = device_type,\n tree_learner = tree_learner,\n force_col_wise = force_col_wise\n ),\n tunable_hyperparameters = LightGBM_tunable,\n fixed_hyperparameters = LightGBM_fixed\n )\n )\n }\n) # /rtemis::LightGBMHyperparameters\n\nmethod(update, LightGBMHyperparameters) <- function(\n object,\n hyperparameters,\n tuned = NULL,\n ...\n) {\n for (hp in names(hyperparameters)) {\n object@hyperparameters[[hp]] <- hyperparameters[[hp]]\n }\n # Update tuned status\n if (is.null(tuned)) {\n object@tuned <- get_tuned_status(object)\n } else {\n object@tuned <- tuned\n }\n # Update nrounds (e.g. in LightRuleFit)\n if (\n is.null(object@hyperparameters[[\"nrounds\"]]) &&\n !is.null(object@hyperparameters[[\"force_nrounds\"]])\n ) {\n object@hyperparameters[[\"nrounds\"]] <- object@hyperparameters[[\n \"force_nrounds\"\n ]]\n }\n object\n} # /update.LightGBMHyperparameters\n\n\n# %% setup_LightGBM ----\n# References:\n# LightGBM parameters: https://lightgbm.readthedocs.io/en/latest/Parameters.html\n\n#' Setup LightGBM Hyperparameters\n#'\n#' Setup hyperparameters for LightGBM training.\n#'\n#' Get more information from [lightgbm::lgb.train].\n#'\n#' @param max_nrounds Positive integer: Maximum number of boosting rounds.\n#' @param force_nrounds Positive integer: Use this many boosting rounds. Disable search for nrounds.\n#' @param early_stopping_rounds Positive integer: Number of rounds without improvement to stop training.\n#' @param num_leaves (Tunable) Positive integer: Maximum number of leaves in one tree.\n#' @param max_depth (Tunable) Integer: Maximum depth of trees.\n#' @param learning_rate (Tunable) Numeric: Learning rate.\n#' @param feature_fraction (Tunable) Numeric: Fraction of features to use.\n#' @param subsample (Tunable) Numeric: Fraction of data to use.\n#' @param subsample_freq (Tunable) Positive integer: Frequency of subsample.\n#' @param lambda_l1 (Tunable) Numeric: L1 regularization.\n#' @param lambda_l2 (Tunable) Numeric: L2 regularization.\n#' @param max_cat_threshold (Tunable) Positive integer: Maximum number of categories for categorical features.\n#' @param min_data_per_group (Tunable) Positive integer: Minimum number of observations per categorical group.\n#' @param linear_tree Logical: If TRUE, use linear trees.\n#' @param objective Character: Objective function.\n#' @param ifw Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#' @param device_type Character: \"cpu\" or \"gpu\".\n#' @param tree_learner Character: \"serial\", \"feature\", \"data\", or \"voting\".\n#' @param force_col_wise Logical: Use only with CPU - If TRUE, force col-wise histogram building.\n#'\n#' @return LightGBMHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' lightgbm_hyperparams <- setup_LightGBM(\n#' max_nrounds = 500L,\n#' learning_rate = c(0.001, 0.01, 0.05), ifw = TRUE\n#' )\n#' lightgbm_hyperparams\nsetup_LightGBM <- function(\n # nrounds will be auto-tuned if force_nrounds is NULL with a value up to max_nrounds and\n # using early_stopping_rounds.\n max_nrounds = 1000L,\n force_nrounds = NULL,\n early_stopping_rounds = 10L,\n # tunable\n num_leaves = 8L,\n max_depth = -1L,\n learning_rate = 0.01,\n feature_fraction = 1.0,\n subsample = 1.0, # a.k.a. bagging_fraction {check:hyper}\n subsample_freq = 1L,\n lambda_l1 = 0,\n lambda_l2 = 0,\n max_cat_threshold = 32L,\n min_data_per_group = 32L,\n linear_tree = FALSE,\n ifw = FALSE,\n objective = NULL,\n device_type = \"cpu\",\n tree_learner = \"serial\",\n force_col_wise = TRUE\n) {\n max_nrounds <- clean_posint(max_nrounds)\n force_nrounds <- clean_posint(force_nrounds)\n early_stopping_rounds <- clean_posint(early_stopping_rounds)\n num_leaves <- clean_posint(num_leaves)\n max_depth <- clean_int(max_depth)\n check_floatpos1(learning_rate)\n check_floatpos1(feature_fraction)\n check_floatpos1(subsample)\n subsample_freq <- clean_posint(subsample_freq)\n check_float0pos(lambda_l1)\n check_float0pos(lambda_l2)\n max_cat_threshold <- clean_posint(max_cat_threshold)\n min_data_per_group <- clean_posint(min_data_per_group)\n check_logical(linear_tree)\n LightGBMHyperparameters(\n max_nrounds = max_nrounds,\n force_nrounds = force_nrounds,\n early_stopping_rounds = early_stopping_rounds,\n num_leaves = num_leaves,\n max_depth = max_depth,\n learning_rate = learning_rate,\n feature_fraction = feature_fraction,\n subsample = subsample,\n subsample_freq = subsample_freq,\n lambda_l1 = lambda_l1,\n lambda_l2 = lambda_l2,\n max_cat_threshold = max_cat_threshold,\n min_data_per_group = min_data_per_group,\n linear_tree = linear_tree,\n ifw = ifw,\n objective = objective,\n device_type = device_type,\n tree_learner = tree_learner,\n force_col_wise = force_col_wise\n )\n} # /rtemis::setupLightGBM\n\n# Test that all LightGBM hyperparameters are set by setup_LightGBM\nstopifnot(all(\n c(LightGBM_tunable, LightGBM_fixed) %in% names(formals(setup_LightGBM))\n))\n\nmethod(get_hyperparams_need_tuning, LightGBMHyperparameters) <- function(x) {\n # Get tunable hyperparameters with more than one value\n out <- x@hyperparameters[x@tunable_hyperparameters[\n sapply(x@hyperparameters[x@tunable_hyperparameters], length) > 1\n ]]\n if (is.null(x[[\"nrounds\"]])) {\n out <- c(out, list(nrounds = NULL))\n }\n out\n} # /get_hyperparams_need_tuning.LightGBMHyperparameters\n\n\n# %% LightRuleFitHyperparameters ----\nLightRuleFit_tunable <- c(\n \"nrounds\",\n \"num_leaves\",\n \"max_depth\",\n \"learning_rate\",\n \"subsample\",\n \"subsample_freq\",\n \"lambda_l1\",\n \"lambda_l2\",\n \"alpha\",\n \"ifw_lightgbm\",\n \"ifw_glmnet\"\n)\nLightRuleFit_fixed <- c(\"lambda\", \"objective\")\nLightRuleFit_lightgbm_params <- c(\n \"nrounds\",\n \"num_leaves\",\n \"max_depth\",\n \"learning_rate\",\n \"subsample\",\n \"subsample_freq\",\n \"lambda_l1\",\n \"lambda_l2\",\n \"objective\"\n)\nLightRuleFit_glmnet_params <- c(\"alpha\", \"lambda\")\n\n\n#' @title LightRuleFitHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for LightRuleFit.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nLightRuleFitHyperparameters <- new_class(\n name = \"LightRuleFitHyperparameters\",\n parent = Hyperparameters,\n constructor = function(\n nrounds,\n num_leaves,\n max_depth,\n learning_rate,\n subsample,\n subsample_freq,\n lambda_l1,\n lambda_l2,\n objective,\n ifw_lightgbm,\n # GLMNET\n alpha,\n lambda,\n ifw_glmnet,\n # IFW\n ifw\n ) {\n new_object(\n Hyperparameters(\n algorithm = \"LightRuleFit\",\n hyperparameters = list(\n nrounds = nrounds,\n num_leaves = num_leaves,\n max_depth = max_depth,\n learning_rate = learning_rate,\n subsample = subsample,\n subsample_freq = subsample_freq,\n lambda_l1 = lambda_l1,\n lambda_l2 = lambda_l2,\n objective = objective,\n ifw_lightgbm = ifw_lightgbm,\n # GLMNET\n alpha = alpha,\n lambda = lambda,\n ifw_glmnet = ifw_glmnet,\n # IFW\n ifw = ifw\n ),\n tunable_hyperparameters = LightRuleFit_tunable,\n fixed_hyperparameters = LightRuleFit_fixed\n )\n )\n }\n) # /rtemis::LightRuleFitHyperparameters\n\n\n# %% setup_LightRuleFit ----\n#' Setup LightRuleFit Hyperparameters\n#'\n#' Setup hyperparameters for LightRuleFit training.\n#'\n#' Get more information from [lightgbm::lgb.train].\n#'\n#' @param nrounds (Tunable) Positive integer: Number of boosting rounds.\n#' @param num_leaves (Tunable) Positive integer: Maximum number of leaves in one tree.\n#' @param max_depth (Tunable) Integer: Maximum depth of trees.\n#' @param learning_rate (Tunable) Numeric: Learning rate.\n#' @param subsample (Tunable) Numeric: Fraction of data to use.\n#' @param subsample_freq (Tunable) Positive integer: Frequency of subsample.\n#' @param lambda_l1 (Tunable) Numeric: L1 regularization.\n#' @param lambda_l2 (Tunable) Numeric: L2 regularization.\n#' @param objective Character: Objective function.\n#' @param ifw_lightgbm (Tunable) Logical: If TRUE, use Inverse Frequency Weighting in the LightGBM\n#' step.\n#' @param objective Character: Objective function.\n#' @param alpha (Tunable) Numeric: Alpha for GLMNET.\n#' @param lambda Numeric: Lambda for GLMNET.\n#' @param ifw_glmnet (Tunable) Logical: If TRUE, use Inverse Frequency Weighting in the GLMNET step.\n#' @param ifw Logical: If TRUE, use Inverse Frequency Weighting in classification. This applies IFW\n#' to both LightGBM and GLMNET.\n#'\n#' @return LightRuleFitHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' lightrulefit_hyperparams <- setup_LightRuleFit(nrounds = 300L, max_depth = 3L)\n#' lightrulefit_hyperparams\nsetup_LightRuleFit <- function(\n nrounds = 200L,\n num_leaves = 32L,\n max_depth = 4L,\n learning_rate = 0.1,\n subsample = 0.666,\n subsample_freq = 1L,\n lambda_l1 = 0,\n lambda_l2 = 0,\n objective = NULL,\n ifw_lightgbm = FALSE,\n alpha = 1,\n lambda = NULL,\n ifw_glmnet = FALSE,\n ifw = FALSE\n) {\n nrounds <- clean_posint(nrounds)\n num_leaves <- clean_posint(num_leaves)\n max_depth <- clean_int(max_depth)\n check_floatpos1(learning_rate)\n check_floatpos1(subsample)\n subsample_freq <- clean_posint(subsample_freq)\n check_inherits(lambda_l1, \"numeric\")\n check_inherits(lambda_l2, \"numeric\")\n check_float01inc(alpha)\n check_inherits(lambda, \"numeric\")\n check_logical(ifw_lightgbm)\n check_logical(ifw_glmnet)\n check_logical(ifw)\n # If ifw, cannot have ifw_lightgbm or ifw_glmnet\n if (ifw) {\n if (ifw_lightgbm) {\n cli::cli_abort(\"Cannot set ifw and ifw_lightgbm at the same time.\")\n }\n if (ifw_glmnet) {\n cli::cli_abort(\"Cannot set ifw and ifw_glmnet at the same time.\")\n }\n }\n LightRuleFitHyperparameters(\n nrounds = nrounds,\n num_leaves = num_leaves,\n max_depth = max_depth,\n learning_rate = learning_rate,\n subsample = subsample,\n subsample_freq = subsample_freq,\n lambda_l1 = lambda_l1,\n lambda_l2 = lambda_l2,\n objective = objective,\n ifw_lightgbm = ifw_lightgbm,\n alpha = alpha,\n lambda = lambda,\n ifw_glmnet = ifw_glmnet,\n ifw = ifw\n )\n} # /rtemis::setup_LightRuleFit\n\n\n# %% IsotonicHyperparameters ----\nIsotonic_tunable <- character()\nIsotonic_fixed <- character()\n\n#' @title IsotonicHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for Isotonic Regression.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nIsotonicHyperparameters <- new_class(\n name = \"IsotonicHyperparameters\",\n parent = Hyperparameters,\n constructor = function(ifw) {\n new_object(\n Hyperparameters(\n algorithm = \"Isotonic\",\n hyperparameters = list(\n ifw = ifw\n ),\n tunable_hyperparameters = \"ifw\",\n fixed_hyperparameters = Isotonic_fixed\n )\n )\n }\n) # /rtemis::IsotonicHyperparameters\n\n\n# %% setup_Isotonic ----\n#' Setup Isotonic Hyperparameters\n#'\n#' Setup hyperparameters for Isotonic Regression.\n#'\n#' There are not hyperparameters for this algorithm at this moment.\n#'\n#' @param ifw Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#'\n#' @return IsotonicHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' isotonic_hyperparams <- setup_Isotonic(ifw = TRUE)\n#' isotonic_hyperparams\nsetup_Isotonic <- function(ifw = FALSE) {\n IsotonicHyperparameters(ifw = ifw)\n} # /rtemis::setup_Isotonic\n\n\n# %% SVMHyperparameters ----\n#' @title SVMHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for SVM.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nSVMHyperparameters <- new_class(\n name = \"SVMHyperparameters\",\n parent = Hyperparameters,\n constructor = function(\n hyperparameters,\n tunable_hyperparameters,\n fixed_hyperparameters\n ) {\n new_object(\n Hyperparameters(\n algorithm = \"SVM\",\n hyperparameters = hyperparameters,\n tunable_hyperparameters = tunable_hyperparameters,\n fixed_hyperparameters = fixed_hyperparameters\n )\n )\n } # /constructor\n) # /rtemis::SVMHyperparameters\n\n# %% LinearSVMHyperparameters ----\nLinearSVM_tunable <- c(\"cost\", \"ifw\")\nLinearSVM_fixed <- character()\n\n#' @title LinearSVMHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for SVM with linear kernel.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nLinearSVMHyperparameters <- new_class(\n name = \"LinearSVMHyperparameters\",\n parent = Hyperparameters,\n constructor = function(cost, ifw) {\n new_object(\n Hyperparameters(\n algorithm = \"LinearSVM\",\n hyperparameters = list(\n kernel = \"linear\",\n cost = cost,\n ifw = ifw\n ),\n tunable_hyperparameters = c(\"cost\", \"ifw\"),\n fixed_hyperparameters = character()\n )\n )\n } # /constructor\n) # /rtemis::LinearSVMHyperparameters\n\n\n# %% setup_LinearSVM ----\n#' Setup LinearSVM Hyperparameters\n#'\n#' Setup hyperparameters for LinearSVM training.\n#'\n#' Get more information from [e1071::svm].\n#' @param cost (Tunable) Numeric: Cost of constraints violation.\n#' @param ifw Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#'\n#' @return LinearSVMHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' linear_svm_hyperparams <- setup_LinearSVM(cost = 0.5, ifw = TRUE)\n#' linear_svm_hyperparams\nsetup_LinearSVM <- function(\n cost = 1,\n ifw = FALSE\n) {\n check_inherits(cost, \"numeric\")\n check_logical(ifw)\n LinearSVMHyperparameters(\n cost = cost,\n ifw = ifw\n )\n} # /setup_LinearSVM\n\n# Test that all SVM hyperparameters are set by setup_SVM\nstopifnot(all(\n c(LinearSVM_tunable, LinearSVM_fixed) %in% names(formals(setup_LinearSVM))\n))\n\n\n# %% RadialSVMHyperparameters ----\nRadialSVM_tunable <- c(\"cost\", \"gamma\", \"ifw\")\nRadialSVM_fixed <- character()\n\n#' @title RadialSVMHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for SVM with radial kernel.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nRadialSVMHyperparameters <- new_class(\n name = \"RadialSVMHyperparameters\",\n parent = Hyperparameters,\n constructor = function(cost, gamma, ifw) {\n new_object(\n Hyperparameters(\n algorithm = \"RadialSVM\",\n hyperparameters = list(\n kernel = \"radial\",\n cost = cost,\n gamma = gamma,\n ifw = ifw\n ),\n tunable_hyperparameters = c(\"cost\", \"gamma\", \"ifw\"),\n fixed_hyperparameters = character()\n )\n )\n } # /constructor\n) # /rtemis::RadialSVMHyperparameters\n\n\n# %% setup_RadialSVM ----\n#' Setup RadialSVM Hyperparameters\n#'\n#' Setup hyperparameters for RadialSVM training.\n#'\n#' Get more information from [e1071::svm].\n#'\n#' @param cost (Tunable) Numeric: Cost of constraints violation.\n#' @param gamma (Tunable) Numeric: Kernel coefficient.\n#' @param ifw Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#'\n#' @return RadialSVMHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' radial_svm_hyperparams <- setup_RadialSVM(cost = 10, gamma = 0.1, ifw = TRUE)\n#' radial_svm_hyperparams\nsetup_RadialSVM <- function(\n cost = 1,\n gamma = 0.01,\n ifw = FALSE\n) {\n check_inherits(cost, \"numeric\")\n check_inherits(gamma, \"numeric\")\n check_logical(ifw)\n RadialSVMHyperparameters(\n cost = cost,\n gamma = gamma,\n ifw = ifw\n )\n} # /setup_RadialSVM\n\n\n# Test that all SVM hyperparameters are set by setup_SVM\nstopifnot(all(\n c(RadialSVM_tunable, RadialSVM_fixed) %in% names(formals(setup_RadialSVM))\n))\n\n\n# %% TabNetHyperparameters ----\ntabnet_tunable <- c(\n \"batch_size\",\n \"penalty\",\n \"clip_value\",\n \"loss\",\n \"epochs\",\n \"drop_last\",\n \"decision_width\",\n \"attention_width\",\n \"num_steps\",\n \"feature_reusage\",\n \"mask_type\",\n \"virtual_batch_size\",\n \"valid_split\",\n \"learn_rate\",\n \"optimizer\",\n \"lr_scheduler\",\n \"lr_decay\",\n \"step_size\",\n \"checkpoint_epochs\",\n \"cat_emb_dim\",\n \"num_independent\",\n \"num_shared\",\n \"num_independent_decoder\",\n \"num_shared_decoder\",\n \"momentum\",\n \"pretraining_ratio\",\n \"importance_sample_size\",\n \"early_stopping_monitor\",\n \"early_stopping_tolerance\",\n \"early_stopping_patience\",\n \"ifw\"\n)\n\ntabnet_fixed <- c(\"device\", \"num_workers\", \"skip_importance\")\n\n\n#' @title TabNetHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for TabNet.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nTabNetHyperparameters <- new_class(\n name = \"TabNetHyperparameters\",\n parent = Hyperparameters,\n constructor = function(\n batch_size,\n penalty,\n clip_value,\n loss,\n epochs,\n drop_last,\n decision_width,\n attention_width,\n num_steps,\n feature_reusage,\n mask_type,\n virtual_batch_size,\n valid_split,\n learn_rate,\n optimizer,\n lr_scheduler,\n lr_decay,\n step_size,\n checkpoint_epochs,\n cat_emb_dim,\n num_independent,\n num_shared,\n num_independent_decoder,\n num_shared_decoder,\n momentum,\n pretraining_ratio,\n device,\n importance_sample_size,\n early_stopping_monitor,\n early_stopping_tolerance,\n early_stopping_patience,\n num_workers,\n skip_importance,\n ifw\n ) {\n new_object(\n Hyperparameters(\n algorithm = \"TabNet\",\n hyperparameters = list(\n batch_size = batch_size,\n penalty = penalty,\n clip_value = clip_value,\n loss = loss,\n epochs = epochs,\n drop_last = drop_last,\n decision_width = decision_width,\n attention_width = attention_width,\n num_steps = num_steps,\n feature_reusage = feature_reusage,\n mask_type = mask_type,\n virtual_batch_size = virtual_batch_size,\n valid_split = valid_split,\n learn_rate = learn_rate,\n optimizer = optimizer,\n lr_scheduler = lr_scheduler,\n lr_decay = lr_decay,\n step_size = step_size,\n checkpoint_epochs = checkpoint_epochs,\n cat_emb_dim = cat_emb_dim,\n num_independent = num_independent,\n num_shared = num_shared,\n num_independent_decoder = num_independent_decoder,\n num_shared_decoder = num_shared_decoder,\n momentum = momentum,\n pretraining_ratio = pretraining_ratio,\n device = device,\n importance_sample_size = importance_sample_size,\n early_stopping_monitor = early_stopping_monitor,\n early_stopping_tolerance = early_stopping_tolerance,\n early_stopping_patience = early_stopping_patience,\n num_workers = num_workers,\n skip_importance = skip_importance,\n ifw = ifw\n ),\n tunable_hyperparameters = tabnet_tunable,\n fixed_hyperparameters = tabnet_fixed\n )\n )\n } # /constructor\n) # /rtemis::TabNetHyperparameters\n\n\n# %% setup_TabNet ----\n#' Setup TabNet Hyperparameters\n#'\n#' Setup hyperparameters for TabNet training.\n#'\n# Get more information from [tabnet::tabnet_config]\n#'\n#' @param batch_size (Tunable) Positive integer: Batch size.\n#' @param penalty (Tunable) Numeric: Regularization penalty.\n#' @param clip_value Numeric: Clip value.\n#' @param loss Character: Loss function.\n#' @param epochs (Tunable) Positive integer: Number of epochs.\n#' @param drop_last Logical: If TRUE, drop last batch.\n#' @param decision_width (Tunable) Positive integer: Decision width.\n#' @param attention_width (Tunable) Positive integer: Attention width.\n#' @param num_steps (Tunable) Positive integer: Number of steps.\n#' @param feature_reusage (Tunable) Numeric: Feature reusage.\n#' @param mask_type Character: Mask type.\n#' @param virtual_batch_size (Tunable) Positive integer: Virtual batch size.\n#' @param valid_split Numeric: Validation split.\n#' @param learn_rate (Tunable) Numeric: Learning rate.\n#' @param optimizer Character or torch function: Optimizer.\n#' @param lr_scheduler Character or torch function: \"step\", \"reduce_on_plateau\".\n#' @param lr_decay Numeric: Learning rate decay.\n#' @param step_size Positive integer: Step size.\n#' @param checkpoint_epochs (Tunable) Positive integer: Checkpoint epochs.\n#' @param cat_emb_dim (Tunable) Positive integer: Categorical embedding dimension.\n#' @param num_independent (Tunable) Positive integer: Number of independent Gated Linear Units (GLU)\n#' at each step of the encoder.\n#' @param num_shared (Tunable) Positive integer: Number of shared Gated Linear Units (GLU) at each\n#' step of the encoder.\n#' @param num_independent_decoder (Tunable) Positive integer: Number of independent GLU layers for\n#' pretraining.\n#' @param num_shared_decoder (Tunable) Positive integer: Number of shared GLU layers for\n#' pretraining.\n#' @param momentum (Tunable) Numeric: Momentum.\n#' @param pretraining_ratio (Tunable) Numeric: Pretraining ratio.\n#' @param device Character: Device \"cpu\" or \"cuda\".\n#' @param importance_sample_size Positive integer: Importance sample size.\n#' @param early_stopping_monitor Character: Early stopping monitor. \"valid_loss\", \"train_loss\",\n#' \"auto\".\n#' @param early_stopping_tolerance Numeric: Minimum relative improvement to reset the patience\n#' counter.\n#' @param early_stopping_patience Positive integer: Number of epochs without improving before\n#' stopping.\n#' @param num_workers Positive integer: Number of subprocesses for data loacding.\n#' @param skip_importance Logical: If TRUE, skip importance calculation.\n#' @param ifw Logical: If TRUE, use Inverse Frequency Weighting in classification.\n#'\n#' @return TabNetHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' tabnet_hyperparams <- setup_TabNet(epochs = 100L, learn_rate = 0.01)\n#' tabnet_hyperparams\nsetup_TabNet <- function(\n batch_size = 1024^2,\n penalty = 0.001,\n clip_value = NULL,\n loss = \"auto\",\n epochs = 50L,\n drop_last = FALSE,\n decision_width = NULL,\n attention_width = NULL,\n num_steps = 3L,\n feature_reusage = 1.3,\n mask_type = \"sparsemax\",\n virtual_batch_size = 256^2,\n valid_split = 0,\n learn_rate = 0.02,\n optimizer = \"adam\",\n lr_scheduler = NULL,\n lr_decay = 0.1,\n step_size = 30,\n checkpoint_epochs = 10L,\n cat_emb_dim = 1L,\n num_independent = 2L,\n num_shared = 2L,\n num_independent_decoder = 1L,\n num_shared_decoder = 1L,\n momentum = 0.02,\n pretraining_ratio = 0.5,\n device = \"auto\",\n importance_sample_size = NULL,\n early_stopping_monitor = \"auto\",\n early_stopping_tolerance = 0,\n early_stopping_patience = 0,\n num_workers = 0L,\n skip_importance = FALSE,\n ifw = FALSE\n) {\n TabNetHyperparameters(\n batch_size = batch_size,\n penalty = penalty,\n clip_value = clip_value,\n loss = loss,\n epochs = epochs,\n drop_last = drop_last,\n decision_width = decision_width,\n attention_width = attention_width,\n num_steps = num_steps,\n feature_reusage = feature_reusage,\n mask_type = mask_type,\n virtual_batch_size = virtual_batch_size,\n valid_split = valid_split,\n learn_rate = learn_rate,\n optimizer = optimizer,\n lr_scheduler = lr_scheduler,\n lr_decay = lr_decay,\n step_size = step_size,\n checkpoint_epochs = checkpoint_epochs,\n cat_emb_dim = cat_emb_dim,\n num_independent = num_independent,\n num_shared = num_shared,\n num_independent_decoder = num_independent_decoder,\n num_shared_decoder = num_shared_decoder,\n momentum = momentum,\n pretraining_ratio = pretraining_ratio,\n device = device,\n importance_sample_size = importance_sample_size,\n early_stopping_monitor = early_stopping_monitor,\n early_stopping_tolerance = early_stopping_tolerance,\n early_stopping_patience = early_stopping_patience,\n num_workers = num_workers,\n skip_importance = skip_importance,\n ifw = ifw\n )\n} # /setup_TabNet\n\n# Test that all TabNet hyperparameters are set by setup_TabNet\nstopifnot(all(\n c(tabnet_tunable, tabnet_fixed) %in% names(formals(setup_TabNet))\n))\n\nget_tabnet_config <- function(hyperparameters) {\n check_is_S7(hyperparameters, TabNetHyperparameters)\n hpr <- hyperparameters@hyperparameters\n hpr[[\"ifw\"]] <- NULL\n do.call(tabnet::tabnet_config, hpr)\n} # /get_tabnet_config\n\n\n# %% RangerHyperparameters ----\nranger_tunable <- c(\n \"num_trees\",\n \"mtry\",\n \"min_node_size\",\n \"max_depth\",\n \"sample_fraction\",\n \"replace\",\n \"splitrule\",\n \"num_random_splits\",\n \"alpha\",\n \"minprop\",\n \"regularization_factor\",\n \"ifw\"\n)\n\nranger_fixed <- c(\n \"importance\",\n \"write_forest\",\n \"probability\",\n \"min_bucket\",\n \"case_weights\", # set by train\n \"class_weights\", # set by train\n \"poisson_tau\",\n \"split_select_weights\",\n \"always_split_variables\",\n \"respect_unordered_factors\",\n \"scale_permutation_importance\",\n \"local_importance\",\n \"regularization_usedepth\",\n \"keep_inbag\",\n \"inbag\",\n \"holdout\",\n \"quantreg\",\n \"time_interest\",\n \"oob_error\",\n \"save_memory\",\n \"verbose\",\n \"node_stats\",\n \"seed\",\n \"na_action\"\n)\n\n\n#' @title RangerHyperparameters\n#'\n#' @description\n#' Hyperparameters subclass for Ranger Random Forest.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nRangerHyperparameters <- new_class(\n name = \"RangerHyperparameters\",\n parent = Hyperparameters,\n constructor = function(\n num_trees,\n mtry,\n importance,\n write_forest,\n probability,\n min_node_size,\n min_bucket,\n max_depth,\n replace,\n sample_fraction,\n case_weights,\n class_weights,\n splitrule,\n num_random_splits,\n alpha,\n minprop,\n poisson_tau,\n split_select_weights,\n always_split_variables,\n respect_unordered_factors,\n scale_permutation_importance,\n local_importance,\n regularization_factor,\n regularization_usedepth,\n keep_inbag,\n inbag,\n holdout,\n quantreg,\n time_interest,\n oob_error,\n save_memory,\n verbose,\n node_stats,\n seed,\n na_action,\n ifw\n ) {\n new_object(\n Hyperparameters(\n algorithm = \"Ranger\",\n hyperparameters = list(\n num_trees = num_trees,\n mtry = mtry,\n importance = importance,\n write_forest = write_forest,\n probability = probability,\n min_node_size = min_node_size,\n min_bucket = min_bucket,\n max_depth = max_depth,\n replace = replace,\n sample_fraction = sample_fraction,\n case_weights = case_weights,\n class_weights = class_weights,\n splitrule = splitrule,\n num_random_splits = num_random_splits,\n alpha = alpha,\n minprop = minprop,\n poisson_tau = poisson_tau,\n split_select_weights = split_select_weights,\n always_split_variables = always_split_variables,\n respect_unordered_factors = respect_unordered_factors,\n scale_permutation_importance = scale_permutation_importance,\n local_importance = local_importance,\n regularization_factor = regularization_factor,\n regularization_usedepth = regularization_usedepth,\n keep_inbag = keep_inbag,\n inbag = inbag,\n holdout = holdout,\n quantreg = quantreg,\n time_interest = time_interest,\n oob_error = oob_error,\n save_memory = save_memory,\n verbose = verbose,\n node_stats = node_stats,\n seed = seed,\n na_action = na_action,\n ifw = ifw\n ),\n tunable_hyperparameters = ranger_tunable,\n fixed_hyperparameters = ranger_fixed\n )\n )\n } # /constructor\n) # /rtemis::RangerHyperparameters\n\n\n# %% setup_Ranger ----\n#' Setup Ranger Hyperparameters\n#'\n#' Setup hyperparameters for Ranger Random Forest training.\n#'\n#' Get more information from [ranger::ranger].\n#'\n#' @param num_trees (Tunable) Positive integer: Number of trees.\n#' @param mtry (Tunable) Positive integer: Number of features to consider at each split.\n#' @param importance Character: Variable importance mode. \"none\", \"impurity\", \"impurity_corrected\", \"permutation\".\n#' The \"impurity\" measure is the Gini index for classification, the variance of the responses for regression.\n#' @param write_forest Logical: Save ranger.forest object, required for prediction. Set to FALSE to reduce memory usage if no prediction intended.\n#' @param probability Logical: Grow a probability forest as in Malley et al. (2012). For classification only.\n#' @param min_node_size (Tunable) Positive integer: Minimal node size. Default 1 for classification, 5 for regression, 3 for survival, and 10 for probability.\n#' @param min_bucket Positive integer: Minimal number of samples in a terminal node. Only for survival. Deprecated in favor of min_node_size.\n#' @param max_depth (Tunable) Positive integer: Maximal tree depth. A value of NULL or 0 (the default) corresponds to unlimited depth, 1 to tree stumps (1 split per tree).\n#' @param replace Logical: Sample with replacement.\n#' @param sample_fraction (Tunable) Numeric: Fraction of observations to sample. Default is 1 for sampling with replacement and 0.632 for sampling without replacement.\n#' @param case_weights Numeric vector: Weights for sampling of training observations. Observations with larger weights will be selected with higher probability in the bootstrap (or subsampled) samples for the trees.\n#' @param class_weights Numeric vector: Weights for the outcome classes for classification. Vector of the same length as the number of classes, with names corresponding to the class labels.\n#' @param splitrule (Tunable) Character: Splitting rule. For classification: \"gini\", \"extratrees\", \"hellinger\". For regression: \"variance\", \"extratrees\", \"maxstat\", \"beta\". For survival: \"logrank\", \"extratrees\", \"C\", \"maxstat\".\n#' @param num_random_splits (Tunable) Positive integer: For \"extratrees\" splitrule: Number of random splits to consider for each candidate splitting variable.\n#' @param alpha (Tunable) Numeric: For \"maxstat\" splitrule: significance threshold to allow splitting.\n#' @param minprop (Tunable) Numeric: For \"maxstat\" splitrule: lower quantile of covariate distribution to be considered for splitting.\n#' @param poisson_tau Numeric: For \"poisson\" regression splitrule: tau parameter for Poisson regression.\n#' @param split_select_weights Numeric vector: Numeric vector with weights between 0 and 1, representing the probability to select variables for splitting. Alternatively, a list of size num_trees, with one weight vector per tree.\n#' @param always_split_variables Character vector: Character vector with variable names to be always selected in addition to the mtry variables tried for splitting.\n#' @param respect_unordered_factors Character or logical: Handling of unordered factor covariates. For \"partition\" all 2^(k-1)-1 possible partitions are considered for splitting, where k is the number of factor levels. For \"ignore\", all factor levels are ordered by their first occurrence in the data. For \"order\", all factor levels are ordered by their average response. TRUE corresponds to \"partition\" for the randomForest package compatibility.\n#' @param scale_permutation_importance Logical: Scale permutation importance by standard error as in (Breiman 2001). Only applicable if permutation variable importance mode selected.\n#' @param local_importance Logical: For permutation variable importance, use local importance as in Breiman (2001) and Liaw & Wiener (2002).\n#' @param regularization_factor (Tunable) Numeric: Regularization factor. Penalize variables with many split points. Requires splitrule = \"variance\".\n#' @param regularization_usedepth Logical: Use regularization factor with node depth. Requires regularization_factor.\n#' @param keep_inbag Logical: Save how often observations are in-bag in each tree. These will be used for (local) variable importance if inbag.counts in predict() is NULL.\n#' @param inbag List: Manually set observations per tree. List of size num_trees, containing inbag counts for each observation. Can be used for stratified sampling.\n#' @param holdout Logical: Hold-out mode. Hold-out all samples with case weight 0 and use these for variable importance and prediction error.\n#' @param quantreg Logical: Prepare quantile prediction as in quantile regression forests (Meinshausen 2006). For regression only. Set keep_inbag = TRUE to prepare out-of-bag quantile prediction.\n#' @param time_interest Numeric: For GWAS data: SNP with this number will be used as time variable. Only for survival. Deprecated, use time.var in formula instead.\n#' @param oob_error Logical: Compute OOB prediction error. Set to FALSE to save computation time if only the forest is needed.\n#' @param save_memory Logical: Use memory saving (but slower) splitting mode. No effect for survival and GWAS data. Warning: This option slows down the tree growing, use only if you encounter memory problems.\n#' @param verbose Logical: Show computation status and estimated runtime.\n#' @param node_stats Logical: Save additional node statistics. Only terminal nodes for now.\n#' @param seed Positive integer: Random seed. Default is NULL, which generates the seed from R. Set to 0 to ignore the R seed.\n#' @param na_action Character: Action to take if the data contains missing values. \"na.learn\" uses observations with missing values in splitting, treating missing values as a separate category.\n#' @param ifw Logical: Inverse Frequency Weighting for classification. If TRUE, class weights are set inversely proportional to the class frequencies.\n#'\n#' @return RangerHyperparameters object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' ranger_hyperparams <- setup_Ranger(num_trees = 1000L, ifw = FALSE)\n#' ranger_hyperparams\nsetup_Ranger <- function(\n num_trees = 500,\n mtry = NULL,\n importance = \"impurity\",\n write_forest = TRUE,\n probability = FALSE,\n min_node_size = NULL,\n min_bucket = NULL,\n max_depth = NULL,\n replace = TRUE,\n sample_fraction = ifelse(replace, 1, 0.632),\n case_weights = NULL,\n class_weights = NULL,\n splitrule = NULL,\n num_random_splits = 1,\n alpha = 0.5,\n minprop = 0.1,\n poisson_tau = 1,\n split_select_weights = NULL,\n always_split_variables = NULL,\n respect_unordered_factors = NULL,\n scale_permutation_importance = FALSE,\n local_importance = FALSE,\n regularization_factor = 1,\n regularization_usedepth = FALSE,\n keep_inbag = FALSE,\n inbag = NULL,\n holdout = FALSE,\n quantreg = FALSE,\n time_interest = NULL,\n oob_error = TRUE,\n save_memory = FALSE,\n verbose = TRUE,\n node_stats = FALSE,\n seed = NULL,\n na_action = \"na.learn\",\n ifw = FALSE\n) {\n num_trees <- clean_posint(num_trees)\n mtry <- clean_posint(mtry)\n check_inherits(importance, \"character\")\n check_inherits(write_forest, \"logical\")\n check_inherits(probability, \"logical\")\n min_node_size <- clean_posint(min_node_size)\n min_bucket <- clean_posint(min_bucket)\n max_depth <- clean_posint(max_depth)\n check_inherits(replace, \"logical\")\n check_float01inc(sample_fraction)\n check_inherits(case_weights, \"numeric\")\n check_inherits(class_weights, \"numeric\")\n check_inherits(splitrule, \"character\")\n num_random_splits <- clean_posint(num_random_splits)\n check_float01inc(alpha)\n check_float01inc(minprop)\n check_inherits(poisson_tau, \"numeric\")\n check_inherits(split_select_weights, \"numeric\")\n check_inherits(always_split_variables, \"character\")\n check_inherits(respect_unordered_factors, \"logical\")\n check_inherits(scale_permutation_importance, \"logical\")\n check_inherits(local_importance, \"logical\")\n check_inherits(regularization_factor, \"numeric\")\n check_inherits(regularization_usedepth, \"logical\")\n check_inherits(keep_inbag, \"logical\")\n check_inherits(inbag, \"list\")\n check_inherits(holdout, \"logical\")\n check_inherits(quantreg, \"logical\")\n check_inherits(time_interest, \"numeric\")\n check_inherits(oob_error, \"logical\")\n check_inherits(save_memory, \"logical\")\n check_inherits(verbose, \"logical\")\n check_inherits(node_stats, \"logical\")\n check_inherits(seed, \"numeric\")\n check_inherits(na_action, \"character\")\n check_logical(ifw)\n RangerHyperparameters(\n num_trees = num_trees,\n mtry = mtry,\n importance = importance,\n write_forest = write_forest,\n probability = probability,\n min_node_size = min_node_size,\n min_bucket = min_bucket,\n max_depth = max_depth,\n replace = replace,\n sample_fraction = sample_fraction,\n case_weights = case_weights,\n class_weights = class_weights,\n splitrule = splitrule,\n num_random_splits = num_random_splits,\n alpha = alpha,\n minprop = minprop,\n poisson_tau = poisson_tau,\n split_select_weights = split_select_weights,\n always_split_variables = always_split_variables,\n respect_unordered_factors = respect_unordered_factors,\n scale_permutation_importance = scale_permutation_importance,\n local_importance = local_importance,\n regularization_factor = regularization_factor,\n regularization_usedepth = regularization_usedepth,\n keep_inbag = keep_inbag,\n inbag = inbag,\n holdout = holdout,\n quantreg = quantreg,\n time_interest = time_interest,\n oob_error = oob_error,\n save_memory = save_memory,\n verbose = verbose,\n node_stats = node_stats,\n seed = seed,\n na_action = na_action,\n ifw = ifw\n )\n} # /setup_Ranger\n\n# Test that all Ranger hyperparameters are set by setup_Ranger\nstopifnot(all(\n c(ranger_tunable, ranger_fixed) %in% names(formals(setup_Ranger))\n))\n\n\n# %% .list_to_Hyperparameters ----\n#' Convert a list to a Hyperparameters object\n#'\n#' Internal function used by `rtemis.server` to reconstruct a `Hyperparameters`\n#' object from a wire-format list. Not intended for direct use by end users.\n#'\n#' @param x Named list with two elements:\n#' \\describe{\n#' \\item{`algorithm`}{Character: algorithm name, e.g. `\"GLM\"`, `\"RF\"`.}\n#' \\item{`hyperparameters`}{Named list of hyperparameter name-value pairs\n#' passed to the corresponding `setup_()` function.}\n#' }\n#'\n#' @return A `Hyperparameters` object as returned by `setup_()`.\n#'\n#' @author EDG\n#' @keywords internal\n#' @export\n.list_to_Hyperparameters <- function(x) {\n fn <- paste0(\"setup_\", x[[\"algorithm\"]])\n if (!exists(fn, mode = \"function\")) {\n cli::cli_abort(\".val Invalid algorithm: {x[['algorithm']]}.\")\n }\n args <- x[[\"hyperparameters\"]]\n # Keep only arguments that are in the setup function\n setup_formals <- names(formals(get(fn)))\n args <- args[names(args) %in% setup_formals]\n do.call(fn, args)\n}\n" }, { "path": "R/03_Metrics.R", "content": "# S7_Metrics.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% Metrics ----\n#' @title Metrics\n#'\n#' @description\n#' Superclass for Metrics metrics.\n#'\n#' @field sample Character: Sample name.\n#' @field metrics List or data.frame: Metrics.\n#'\n#' @author EDG\n#' @noRd\nMetrics <- new_class(\n name = \"Metrics\",\n properties = list(\n sample = class_character | NULL,\n metrics = class_list | class_data.frame\n )\n) # /rtemis::Metrics\n\n\n# %% `$`.Metrics ----\n# Make Metrics@metrics `$`-accessible\nmethod(`$`, Metrics) <- function(x, name) {\n x@metrics[[name]]\n}\n\n\n# %% `.DollarNames`.Metrics ----\n# `$`-autocomplete Metrics@metrics\nmethod(`.DollarNames`, Metrics) <- function(x, pattern = \"\") {\n all_names <- names(x@metrics)\n grep(pattern, all_names, value = TRUE)\n}\n\n\n# %% `[[`.Metrics ----\n# Make Metrics@metrics `[[`-accessible\nmethod(`[[`, Metrics) <- function(x, name) {\n x@metrics[[name]]\n}\n\n\n# %% RegressionMetrics ----\n#' @title RegressionMetrics\n#'\n#' @description\n#' Metrics subclass for regression models.\n#'\n#' @author EDG\n#' @noRd\nRegressionMetrics <- new_class(\n name = \"RegressionMetrics\",\n parent = Metrics,\n # properties = list(\n # MAE = class_numeric,\n # MSE = class_numeric,\n # RMSE = class_numeric,\n # Rsq = class_numeric\n # ),\n constructor = function(MAE, MSE, RMSE, Rsq, sample = NULL) {\n new_object(\n Metrics(\n sample = sample,\n metrics = data.frame(\n MAE = MAE,\n MSE = MSE,\n RMSE = RMSE,\n Rsq = Rsq\n )\n )\n )\n }\n) # /rtemis::RegressionMetrics\n\n\n# %% repr.RegressionMetrics ----\n# Show RegressionMetrics ----\nmethod(repr, RegressionMetrics) <- function(\n x,\n pad = 0L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n out <- if (!is.null(x@sample)) {\n repr_S7name(\n paste(x@sample, \"Regression Metrics\"),\n pad = pad,\n output_type = output_type\n )\n } else {\n repr_S7name(\"Regression Metrics\", pad = pad, output_type = output_type)\n }\n out <- paste0(\n out,\n repr_ls(\n x@metrics,\n print_class = FALSE,\n print_df = TRUE,\n pad = pad + 2L,\n output_type = output_type\n )\n )\n out\n} # /rtemis::repr.RegressionMetrics\n\n\n# %% print.RegressionMetrics ----\nmethod(print, RegressionMetrics) <- function(\n x,\n pad = 0L,\n output_type = c(\"ansi\", \"html\", \"plain\"),\n ...\n) {\n cat(repr(x, pad = pad, output_type = output_type))\n invisible(x)\n} # /rtemis::print.RegressionMetrics\n\n\n# %% ClassificationMetrics ----\n#' @title ClassificationMetrics\n#'\n#' @description\n#' Metrics subclass for classification models.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nClassificationMetrics <- new_class(\n name = \"ClassificationMetrics\",\n parent = Metrics,\n constructor = function(\n Confusion_Matrix,\n Overall,\n Class,\n Positive_Class,\n sample = NULL\n ) {\n new_object(\n Metrics(\n sample = sample,\n metrics = list(\n Confusion_Matrix = Confusion_Matrix,\n Overall = Overall,\n Class = Class,\n Positive_Class = Positive_Class\n )\n )\n )\n }\n) # /rtemis::ClassificationMetrics\n\n\n# %% repr.ClassificationMetrics ----\nmethod(repr, ClassificationMetrics) <- function(\n x,\n decimal_places = 3L,\n pad = 0L,\n output_type = NULL,\n ...\n) {\n output_type <- get_output_type(output_type)\n\n if (!is.null(x@sample)) {\n out <- repr_S7name(\n paste(x@sample, \"Classification Metrics\"),\n pad = pad,\n output_type = output_type\n )\n } else {\n out <- repr_S7name(\n \"Classification Metrics\",\n pad = pad,\n output_type = output_type\n )\n }\n # Confusion Matrix\n # suggestion: document 17 and 9\n tblpad <- 17L -\n max(nchar(colnames(x@metrics[[\"Confusion_Matrix\"]])), 9L) +\n pad\n out <- paste0(\n out,\n show_table(x[[\"Confusion_Matrix\"]], pad = tblpad, output_type = output_type)\n )\n out <- paste0(\n out,\n \"\\n\",\n show_df(\n x@metrics[[\"Overall\"]],\n pad = pad,\n transpose = TRUE,\n ddSci_dp = decimal_places,\n justify = \"left\",\n spacing = 2L,\n output_type = output_type\n )\n )\n\n if (is.na(x@metrics[[\"Positive_Class\"]])) {\n out <- paste0(\n out,\n show_df(\n x@metrics[[\"Class\"]],\n pad = pad,\n transpose = TRUE,\n ddSci_dp = decimal_places,\n justify = \"left\",\n spacing = 2,\n output_type = output_type\n )\n )\n } else {\n out <- paste0(\n out,\n \"\\n Positive Class \",\n fmt(\n x@metrics[[\"Positive_Class\"]],\n col = highlight_col,\n bold = TRUE,\n output_type = output_type\n ),\n \"\\n\"\n )\n }\n out\n} # /rtemis::repr.ClassificationMetrics\n\n\n# %% print.ClassificationMetrics ----\nmethod(print, ClassificationMetrics) <- function(\n x,\n decimal_places = 3,\n pad = 0L,\n output_type = c(\"ansi\", \"html\", \"plain\"),\n ...\n) {\n cat(repr(\n x,\n decimal_places = decimal_places,\n pad = pad,\n output_type = output_type\n ))\n invisible(x)\n} # /rtemis::print.ClassificationMetrics\n\n\n# %% MetricsRes ----\n#' @title MetricsRes\n#'\n#' @description\n#' Superclass for MetricsRes metrics.\n#'\n#' @field sample Character: Sample name.\n#'\n#' @author EDG\n#' @noRd\nMetricsRes <- new_class(\n name = \"MetricsRes\",\n properties = list(\n sample = class_character | NULL,\n res_metrics = class_list,\n mean_metrics = class_data.frame,\n sd_metrics = class_data.frame\n )\n) # /rtemis::MetricsRes\n\n\n# %% repr.MetricsRes ----\nmethod(repr, MetricsRes) <- function(\n x,\n decimal_places = 3L,\n pad = 0L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n type <- if (S7_inherits(x, RegressionMetricsRes)) {\n \"Regression\"\n } else {\n \"Classification\"\n }\n out <- repr_S7name(\n paste(\"Resampled\", type, x@sample, \"Metrics\"),\n pad = pad,\n output_type = output_type\n )\n out <- paste0(out, strrep(\" \", pad))\n out <- paste0(\n out,\n italic(\" Showing mean (sd) across resamples.\\n\", output_type = output_type)\n )\n # Create list with mean_metrics (sd_metrics)\n metricsl <- lapply(seq_along(x@mean_metrics), function(i) {\n paste0(\n ddSci(x@mean_metrics[[i]], decimal_places),\n gray(\n paste0(\" (\", ddSci(x@sd_metrics[[i]], decimal_places), \")\"),\n output_type = output_type\n )\n )\n })\n names(metricsl) <- names(x@mean_metrics)\n out <- paste0(\n out,\n repr_ls(\n metricsl,\n print_class = FALSE,\n print_df = TRUE,\n pad = pad + 2L,\n output_type = output_type\n )\n )\n out\n} # /rtemis::repr.MetricsRes\n\n\n# %% print.MetricsRes ----\nmethod(print, MetricsRes) <- function(\n x,\n decimal_places = 3L,\n pad = 0L,\n output_type = NULL,\n ...\n) {\n cat(repr(x, decimal_places, pad = pad, output_type = output_type))\n invisible(x)\n} # /rtemis::print.MetricsRes\n\n\n# %% RegressionMetricsRes ----\n#' @author EDG\n#' @noRd\nRegressionMetricsRes <- new_class(\n name = \"RegressionMetricsRes\",\n parent = MetricsRes,\n constructor = function(sample, res_metrics) {\n new_object(\n MetricsRes(\n sample = sample,\n res_metrics = res_metrics,\n mean_metrics = vec2df(\n colMeans(do.call(rbind, lapply(res_metrics, function(x) x@metrics)))\n ),\n sd_metrics = vec2df(\n sapply(do.call(rbind, lapply(res_metrics, function(x) x@metrics)), sd)\n )\n )\n )\n }\n) # /rtemis::RegressionMetricsRes\n\n\n#' @author EDG\n#' @noRd\nClassificationMetricsRes <- new_class(\n name = \"ClassificationMetricsRes\",\n parent = MetricsRes,\n constructor = function(sample, res_metrics) {\n new_object(\n MetricsRes(\n sample = sample,\n res_metrics = res_metrics,\n mean_metrics = vec2df(\n colMeans(do.call(\n rbind,\n lapply(res_metrics, function(x) x@metrics[[\"Overall\"]])\n ))\n ),\n sd_metrics = vec2df(\n sapply(\n do.call(\n rbind,\n lapply(res_metrics, function(x) x@metrics[[\"Overall\"]])\n ),\n sd\n )\n )\n )\n )\n }\n) # /rtemis::ClassificationMetricsRes\n\n\n# %% repr.CalibratedClassification ----\n#' @param x `ClassificationMetrics` before calibration.\n#' @param x_cal `ClassificationMetrics` after calibration.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nrepr_CalibratedClassificationMetrics <- function(\n x,\n x_cal,\n decimal_places = 2L,\n pad = 2L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n\n if (!is.null(x@sample)) {\n out <- repr_S7name(\n paste(x@sample, \"Classification Metrics (Pre => Post Calibration)\"),\n pad = pad,\n output_type = output_type\n )\n } else {\n out <- repr_S7name(\n \"Classification Metrics (Pre => Post Calibration)\",\n pad = pad,\n output_type = output_type\n )\n }\n\n # Confusion Matrix: Pre=>Post\n prepost_cm <- paste_tables(\n x@metrics[[\"Confusion_Matrix\"]],\n x_cal@metrics[[\"Confusion_Matrix\"]],\n sep = \" => \"\n )\n tblpad <- 17L -\n max(nchar(colnames(prepost_cm)), 9L) +\n pad\n out <- paste0(\n out,\n show_table(prepost_cm, pad = tblpad, output_type = output_type)\n )\n\n # Overall metrics: Pre=>Post\n # Note: decimal formatting handled by paste_dfs with decimal_places parameter\n out <- paste0(\n out,\n \"\\n\",\n show_df(\n paste_dfs(\n x@metrics[[\"Overall\"]],\n x_cal@metrics[[\"Overall\"]],\n sep = \" => \",\n decimal_places = decimal_places\n ),\n pad = pad,\n transpose = TRUE,\n ddSci_dp = NULL,\n justify = \"left\",\n spacing = 2L,\n output_type = output_type\n )\n )\n\n # Class metrics: Pre=>Post (for multiclass) or Positive Class (for binary)\n if (is.na(x@metrics[[\"Positive_Class\"]])) {\n out <- paste0(\n out,\n show_df(\n paste_dfs(\n x@metrics[[\"Class\"]],\n x_cal@metrics[[\"Class\"]],\n decimal_places = decimal_places\n ),\n pad = pad,\n transpose = TRUE,\n ddSci_dp = NULL,\n justify = \"left\",\n spacing = 2,\n output_type = output_type\n )\n )\n } else {\n out <- paste0(\n out,\n \"\\n Positive Class \",\n fmt(\n x@metrics[[\"Positive_Class\"]],\n col = highlight_col,\n bold = TRUE,\n output_type = output_type\n ),\n \"\\n\"\n )\n }\n out\n} # /rtemis::repr_CalibratedClassification\n\n\n# %% repr.CalibratedClassificationResMetrics ----\n#' @param x `ClassificationMetricsRes` before calibration.\n#' @param x_cal `ClassificationMetricsRes` after calibration.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nrepr_CalibratedClassificationResMetrics <- function(\n x,\n x_cal,\n decimal_places = 2L,\n pad = 2L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n\n out <- repr_S7name(\n paste(\n \"Resampled Classification\",\n x@sample,\n \"Metrics (Pre => Post Calibration)\"\n ),\n pad = pad,\n output_type = output_type\n )\n out <- paste0(out, strrep(\" \", pad))\n out <- paste0(\n out,\n italic(\n \" Showing mean (sd) across resamples, Pre => Post calibration.\\n\",\n output_type = output_type\n )\n )\n\n # Create pre and post formatted strings: mean (sd)\n pre_strings <- lapply(seq_along(x@mean_metrics), function(i) {\n paste0(\n ddSci(x@mean_metrics[[i]], decimal_places),\n gray(\n paste0(\" (\", ddSci(x@sd_metrics[[i]], decimal_places), \")\"),\n output_type = output_type\n )\n )\n })\n names(pre_strings) <- names(x@mean_metrics)\n\n post_strings <- lapply(seq_along(x_cal@mean_metrics), function(i) {\n paste0(\n ddSci(x_cal@mean_metrics[[i]], decimal_places),\n gray(\n paste0(\" (\", ddSci(x_cal@sd_metrics[[i]], decimal_places), \")\"),\n output_type = output_type\n )\n )\n })\n names(post_strings) <- names(x_cal@mean_metrics)\n\n # Combine pre=>post\n prepost_strings <- lapply(seq_along(pre_strings), function(i) {\n paste(pre_strings[[i]], post_strings[[i]], sep = \" => \")\n })\n names(prepost_strings) <- names(pre_strings)\n\n out <- paste0(\n out,\n repr_ls(\n prepost_strings,\n print_class = FALSE,\n print_df = TRUE,\n pad = pad + 2L,\n output_type = output_type\n )\n )\n out\n} # /rtemis::repr_CalibratedClassificationResMetrics\n" }, { "path": "R/04_Preprocessor.R", "content": "# S7_Preprocessor.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# References\n# https://github.com/RConsortium/S7/\n# https://rconsortium.github.io/S7\n\n# %% PreprocessorConfig ----\n#' @title PreprocessorConfig\n#'\n#' @description\n#' PreprocessorConfig class.\n#'\n#' @author EDG\n#' @noRd\nPreprocessorConfig <- new_class(\n name = \"PreprocessorConfig\",\n properties = list(\n complete_cases = class_logical,\n remove_features_thres = class_numeric | NULL,\n remove_cases_thres = class_numeric | NULL,\n missingness = class_logical,\n impute = class_logical,\n impute_type = class_character,\n impute_missRanger_params = class_list,\n impute_discrete = class_character,\n impute_continuous = class_character,\n integer2factor = class_logical,\n integer2numeric = class_logical,\n logical2factor = class_logical,\n logical2numeric = class_logical,\n numeric2factor = class_logical,\n numeric2factor_levels = class_character | NULL,\n numeric_cut_n = class_numeric,\n numeric_cut_labels = class_logical,\n numeric_quant_n = class_numeric,\n numeric_quant_NAonly = class_logical,\n unique_len2factor = class_numeric,\n character2factor = class_logical,\n factorNA2missing = class_logical,\n factorNA2missing_level = class_character,\n factor2integer = class_logical,\n factor2integer_startat0 = class_logical,\n scale = class_logical,\n center = class_logical,\n scale_centers = class_numeric | NULL,\n scale_coefficients = class_numeric | NULL,\n remove_constants = class_logical,\n remove_constants_skip_missing = class_logical,\n remove_duplicates = class_logical,\n remove_features = class_character | NULL,\n one_hot = class_logical,\n one_hot_levels = class_list | NULL,\n add_date_features = class_logical,\n date_features = class_character,\n add_holidays = class_logical,\n exclude = class_character | NULL\n )\n) # /PreprocessorConfig\n\n\n# %% names.PreprocessorConfig ----\n# Names PreprocessorConfig\nmethod(names, PreprocessorConfig) <- function(x) {\n names(props(x))\n}\n\n\n# %% `$`.PreprocessorConfig ----\n# Make props `$`-accessible\nmethod(`$`, PreprocessorConfig) <- function(x, name) {\n props(x)[[name]]\n}\n\n\n# %% `.DollarNames`.PreprocessorConfig ----\n# DollarSign tab-complete property names\nmethod(`.DollarNames`, PreprocessorConfig) <- function(x, pattern = \"\") {\n all_names <- names(props(x))\n grep(pattern, all_names, value = TRUE)\n}\n\n\n# %% `[[`.PreprocessorConfig ----\n# Make proprs `[[`-accessible\nmethod(`[[`, PreprocessorConfig) <- function(x, name) {\n props(x)[[name]]\n}\n\n\n# %% repr.PreprocessorConfig ----\nmethod(repr, PreprocessorConfig) <- function(\n x,\n limit = -1L,\n pad = 0L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n paste0(\n repr_S7name(\"PreprocessorConfig\", pad = pad, output_type = output_type),\n repr_ls(props(x), pad = pad, limit = limit, output_type = output_type)\n )\n} # /rtemis::repr.PreprocessorConfig\n\n\n# %% print.PreprocessorConfig ----\nmethod(print, PreprocessorConfig) <- function(\n x,\n limit = -1L,\n output_type = NULL,\n ...\n) {\n cat(repr(x, limit = limit, output_type = output_type))\n invisible(x)\n} # /rtemis::print.PreprocessorConfig\n\n\n# %% setup_Preprocessor ----\n#' Setup Preprocessor\n#'\n#' @description\n#' Creates a `PreprocessorConfig` object, which can be used in [preprocess].\n#'\n#' @param complete_cases Logical: If TRUE, only retain complete cases (no missing data).\n#' @param remove_cases_thres Float (0, 1): Remove cases with >= to this fraction\n#' of missing features.\n#' @param remove_features_thres Float (0, 1): Remove features with missing\n#' values in >= to this fraction of cases.\n#' @param missingness Logical: If TRUE, generate new boolean columns for each\n#' feature with missing values, indicating which cases were missing data.\n#' @param impute Logical: If TRUE, impute missing cases. See `impute_discrete` and\n#' `impute_continuous`.\n#' @param impute_type Character: Package to use for imputation.\n#' @param impute_missRanger_params Named list with elements \"pmm.k\" and\n#' \"maxiter\", which are passed to `missRanger::missRanger`. `pmm.k`\n#' greater than 0 results in predictive mean matching. Default `pmm.k = 3`\n#' `maxiter = 10` `num.trees = 500`. Reduce `num.trees` for\n#' faster imputation especially in large datasets. Set `pmm.k = 0` to\n#' disable predictive mean matching.\n#' @param impute_discrete Character: Name of function that returns single value: How to impute\n#' discrete variables for `impute_type = \"meanMode\"`.\n#' @param impute_continuous Character: Name of function that returns single value: How to impute\n#' continuous variables for `impute_type = \"meanMode\"`.\n#' @param integer2factor Logical: If TRUE, convert all integers to factors. This includes\n#' `bit64::integer64` columns.\n#' @param integer2numeric Logical: If TRUE, convert all integers to numeric\n#' (will only work if `integer2factor = FALSE`). This includes\n#' `bit64::integer64` columns.\n#' @param logical2factor Logical: If TRUE, convert all logical variables to\n#' factors.\n#' @param logical2numeric Logical: If TRUE, convert all logical variables to\n#' numeric.\n#' @param numeric2factor Logical: If TRUE, convert all numeric variables to\n#' factors.\n#' @param numeric2factor_levels Character vector: Optional - will be passed to\n#' `levels` arg of `factor()` if `numeric2factor = TRUE`. For advanced/\n#' specific use cases; need to know unique values of numeric vector(s) and given all\n#' numeric vars have same unique values.\n#' @param numeric_cut_n Integer: If > 0, convert all numeric variables to factors by\n#' binning using `base::cut` with `breaks` equal to this number.\n#' @param numeric_cut_labels Logical: The `labels` argument of [base::cut].\n#' @param numeric_quant_n Integer: If > 0, convert all numeric variables to factors by\n#' binning using `base::cut` with `breaks` equal to this number of quantiles.\n#' produced using `stats::quantile`.\n#' @param numeric_quant_NAonly Logical: If TRUE, only bin numeric variables with\n#' missing values.\n#' @param unique_len2factor Integer (>=2): Convert all variables with less\n#' than or equal to this number of unique values to factors.\n#' For example, if binary variables are encoded with 1, 2, you could use\n#' `unique_len2factor = 2` to convert them to factors.\n#' @param character2factor Logical: If TRUE, convert all character variables to\n#' factors.\n#' @param factorNA2missing Logical: If TRUE, make NA values in factors be of\n#' level `factorNA2missing_level`. In many cases this is the preferred way\n#' to handle missing data in categorical variables. Note that since this step\n#' is performed before imputation, you can use this option to handle missing\n#' data in categorical variables and impute numeric variables in the same\n#' `preprocess` call.\n#' @param factorNA2missing_level Character: Name of level if\n#' `factorNA2missing = TRUE`.\n#' @param factor2integer Logical: If TRUE, convert all factors to integers.\n#' @param factor2integer_startat0 Logical: If TRUE, start integer coding at 0.\n#' @param scale Logical: If TRUE, scale columns of `x`.\n#' @param center Logical: If TRUE, center columns of `x`. Note that by\n#' default it is the same as `scale`.\n#' @param scale_centers Named vector: Centering values for each feature.\n#' @param scale_coefficients Named vector: Scaling values for each feature.\n#' @param remove_constants Logical: If TRUE, remove constant columns.\n#' @param remove_constants_skip_missing Logical: If TRUE, skip missing values, before\n#' checking if feature is constant.\n#' @param remove_features Character vector: Features to remove.\n#' @param remove_duplicates Logical: If TRUE, remove duplicate cases.\n#' @param one_hot Logical: If TRUE, convert all factors using one-hot encoding.\n#' @param one_hot_levels List: Named list of the form \"feature_name\" = \"levels\". Used when applying\n#' one-hot encoding to validation or test data using `Preprocessor`.\n#' @param add_date_features Logical: If TRUE, extract date features from date columns.\n#' @param date_features Character vector: Features to extract from dates.\n#' @param add_holidays Logical: If TRUE, extract holidays from date columns.\n#' @param exclude Integer, vector: Exclude these columns from preprocessing.\n#'\n#' @section Order of Operations:\n#'\n#' * keep complete cases only\n#' * remove constants\n#' * remove duplicates\n#' * remove cases by missingness threshold\n#' * remove features by missingness threshold\n#' * integer to factor\n#' * integer to numeric\n#' * logical to factor\n#' * logical to numeric\n#' * numeric to factor\n#' * cut numeric to n bins\n#' * cut numeric to n quantiles\n#' * numeric with less than N unique values to factor\n#' * character to factor\n#' * factor NA to named level\n#' * add missingness column\n#' * impute\n#' * scale and/or center\n#' * one-hot encoding\n#'\n#' @return `PreprocessorConfig` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' preproc_config <- setup_Preprocessor(factorNA2missing = TRUE)\n#' preproc_config\nsetup_Preprocessor <- function(\n complete_cases = FALSE,\n remove_features_thres = NULL,\n remove_cases_thres = NULL,\n missingness = FALSE,\n impute = FALSE,\n impute_type = c(\n \"missRanger\",\n \"micePMM\",\n \"meanMode\"\n ),\n impute_missRanger_params = list(\n pmm.k = 3,\n maxiter = 10,\n num.trees = 500\n ),\n impute_discrete = \"get_mode\",\n impute_continuous = \"mean\",\n integer2factor = FALSE,\n integer2numeric = FALSE,\n logical2factor = FALSE,\n logical2numeric = FALSE,\n numeric2factor = FALSE,\n numeric2factor_levels = NULL,\n numeric_cut_n = 0,\n numeric_cut_labels = FALSE,\n numeric_quant_n = 0,\n numeric_quant_NAonly = FALSE,\n unique_len2factor = 0,\n character2factor = FALSE,\n factorNA2missing = FALSE,\n factorNA2missing_level = \"missing\",\n # nonzeroFactors = FALSE,\n factor2integer = FALSE,\n factor2integer_startat0 = TRUE,\n scale = FALSE,\n center = scale,\n scale_centers = NULL,\n scale_coefficients = NULL,\n remove_constants = FALSE,\n remove_constants_skip_missing = TRUE,\n remove_features = NULL,\n remove_duplicates = FALSE,\n one_hot = FALSE,\n one_hot_levels = NULL,\n # cleanfactorlevels = FALSE,\n add_date_features = FALSE,\n date_features = c(\"weekday\", \"month\", \"year\"),\n add_holidays = FALSE,\n exclude = NULL\n) {\n # Match args\n impute_type <- match.arg(impute_type)\n # Checks performed in the `PreprocessorConfig` constructor\n PreprocessorConfig(\n complete_cases = complete_cases,\n remove_features_thres = remove_features_thres,\n remove_cases_thres = remove_cases_thres,\n missingness = missingness,\n impute = impute,\n impute_type = impute_type,\n impute_missRanger_params = impute_missRanger_params,\n impute_discrete = impute_discrete,\n impute_continuous = impute_continuous,\n integer2factor = integer2factor,\n integer2numeric = integer2numeric,\n logical2factor = logical2factor,\n logical2numeric = logical2numeric,\n numeric2factor = numeric2factor,\n numeric2factor_levels = numeric2factor_levels,\n numeric_cut_n = numeric_cut_n,\n numeric_cut_labels = numeric_cut_labels,\n numeric_quant_n = numeric_quant_n,\n numeric_quant_NAonly = numeric_quant_NAonly,\n unique_len2factor = unique_len2factor,\n character2factor = character2factor,\n factorNA2missing = factorNA2missing,\n factorNA2missing_level = factorNA2missing_level,\n factor2integer = factor2integer,\n factor2integer_startat0 = factor2integer_startat0,\n scale = scale,\n center = center,\n scale_centers = scale_centers,\n scale_coefficients = scale_coefficients,\n remove_constants = remove_constants,\n remove_constants_skip_missing = remove_constants_skip_missing,\n remove_features = remove_features,\n remove_duplicates = remove_duplicates,\n one_hot = one_hot,\n one_hot_levels = one_hot_levels,\n add_date_features = add_date_features,\n date_features = date_features,\n add_holidays = add_holidays,\n exclude = exclude\n )\n} # /setup_Preprocessor\n\n# Note:\n# data_dependent_props <- c(\n# \"scale_centers\", # Named vector with feature scaling centers.\n# \"scale_coefficients\", # Named vector with feature scaling coefficients.\n# \"one_hot_levels\", # Named list of the form \"feature_name\" = \"levels\".\n# \"remove_features\" # Character vector of feature names to remove.\n# )\n\n# %% Preprocessor ----\n#' @title Preprocessor\n#'\n#' @description\n#' Class to hold output of preprocessing values after applying `PreprocessorConfig` to\n#' training dataset, so that the same preprocessing can be applied to validation and test\n#' datasets.\n#'\n#' @field config `PreprocessorConfig` object.\n#' @field preprocessed Data frame or list: Preprocessed data. If a single data.frame is passed to\n#' `preprocess`, this will be a data.frame. If additional data sets are passed to the\n#' `dat_validation` and/or `dat_test` arguments, this will be a named list.\n#' @field values List: Data-dependent preprocessing values to be used for validation and test set\n#' preprocessing.\n#'\n#' @author EDG\n#' @noRd\nPreprocessor <- new_class(\n name = \"Preprocessor\",\n properties = list(\n config = PreprocessorConfig,\n preprocessed = class_data.frame | class_list,\n values = class_list\n ),\n constructor = function(\n config,\n preprocessed,\n scale_centers = NULL,\n scale_coefficients = NULL,\n one_hot_levels = NULL,\n remove_features = NULL\n ) {\n new_object(\n S7_object(),\n config = config,\n preprocessed = preprocessed,\n values = list(\n scale_centers = scale_centers,\n scale_coefficients = scale_coefficients,\n one_hot_levels = one_hot_levels,\n remove_features = remove_features\n )\n )\n }\n) # /Preprocessor\n\n\n# %% repr.Preprocessor ----\nmethod(repr, Preprocessor) <- function(\n x,\n pad = 0L,\n print_df = FALSE,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n paste0(\n repr_S7name(\"Preprocessor\", pad = pad, output_type = output_type),\n repr_ls(props(x), pad = pad, print_df = print_df)\n )\n} # /rtemis::repr.Preprocessor\n\n\n# %% print.Preprocessor ----\nmethod(print, Preprocessor) <- function(x, pad = 0L, output_type = NULL, ...) {\n cat(repr(x, output_type = output_type))\n invisible(x)\n} # /rtemis::print.Preprocessor\n\n\n# %% names.Preprocessor ----\nmethod(names, Preprocessor) <- function(x) {\n names(props(x))\n}\n\n\n# %% `$`.Preprocessor ----\n# Make props `$`-accessible\nmethod(`$`, Preprocessor) <- function(x, name) {\n props(x)[[name]]\n}\n\n\n# %% `.DollarNames`.Preprocessor ----\n# DollarSign tab-complete property names\nmethod(`.DollarNames`, Preprocessor) <- function(x, pattern = \"\") {\n all_names <- names(props(x))\n grep(pattern, all_names, value = TRUE)\n}\n\n\n# %% `[`.Preprocessor ----\n# Make props `[`-accessible\nmethod(`[`, Preprocessor) <- function(x, name) {\n props(x)[[name]]\n}\n\n\n# %% `[[`.Preprocessor ----\n# Make props `[[`-accessible\nmethod(`[[`, Preprocessor) <- function(x, name) {\n props(x)[[name]]\n}\n\n\n# %% preprocessed.Preprocessor ----\nmethod(preprocessed, Preprocessor) <- function(x) {\n x@preprocessed\n}\n" }, { "path": "R/05_Resampler.R", "content": "# S7_Resampler.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# References\n# https://github.com/RConsortium/S7/\n# https://rconsortium.github.io/S7\n\n# Description\n# `ResamplerConfig` class and subclasses create objects that store resampling configuration.\n# They are set by `setup_Resampler()` and perform type checking and validation.\n# They are used by `resample()`.\n# `Resampler` class stores resamples and their configuration.\n# `Resampler` objects are created by `resample()`.\n\n# Note: `id_strat` is used by `resample()`, not individual resamplers\n\n# %% ResamplerConfig ----\n#' @title ResamplerConfig\n#'\n#' @description\n#' Superclass for resampler configuration.\n#'\n#' @field type Character: Type of resampler.\n#' @field n Integer: Number of resamples.\n#'\n#' @author EDG\n#' @noRd\nResamplerConfig <- new_class(\n name = \"ResamplerConfig\",\n properties = list(\n type = class_character,\n n = class_integer # scalar_int_pos\n ),\n constructor = function(type, n) {\n # LOOCV does not have a defined number of resamples, so n can be NA_integer_\n n <- clean_posint(n, allow_na = TRUE)\n new_object(\n S7_object(),\n type = type,\n n = n\n )\n }\n) # /rtemis::ResamplerConfig\n\n\n# %% `$`.ResamplerConfig ----\n# Make S7 properties `$`-accessible\nmethod(`$`, ResamplerConfig) <- function(x, name) {\n prop(x, name)\n}\n\n\n# %% `[[`.ResamplerConfig ----\n# Make S7 properties `[[`-accessible\nmethod(`[[`, ResamplerConfig) <- function(x, name) {\n prop(x, name)\n}\n\n\n# %% repr.ResamplerConfig ----\n#' repr ResamplerConfig\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(repr, ResamplerConfig) <- function(x, pad = 0L, output_type = NULL) {\n output_type <- get_output_type(output_type)\n paste0(\n repr_S7name(x, pad = pad, output_type = output_type),\n repr_ls(\n props(x)[-1],\n pad = pad,\n print_class = FALSE,\n output_type = output_type\n )\n )\n} # /rtemis::repr.ResamplerConfig\n\n\n# %% print.ResamplerConfig ----\n#' Print ResamplerConfig\n#'\n#' @description\n#' print ResamplerConfig object\n#'\n#' @param x ResamplerConfig object\n#'\n#' @author EDG\n#' @noRd\nmethod(print, ResamplerConfig) <- function(\n x,\n pad = 0L,\n output_type = c(\"ansi\", \"html\", \"plain\"),\n ...\n) {\n cat(repr(x, pad = pad, output_type = output_type))\n invisible(x)\n} # /rtemis::print.ResamplerConfig\n\n\n# %% desc.ResamplerConfig ----\nmethod(desc, ResamplerConfig) <- function(x) {\n switch(\n x@type,\n KFold = paste0(x@n, \" independent folds\"),\n StratSub = paste0(x@n, \" stratified subsamples\"),\n StratBoot = paste0(x@n, \" stratified bootstraps\"),\n Bootstrap = paste0(x@n, \" bootstrap resamples\"),\n Custom = paste0(x@n, \" custom resamples\"),\n LOOCV = paste0(x@n, \" leave-one-out folds\"),\n paste0(x@n, \" resamples\")\n )\n} # /rtemis::desc.ResamplerConfig\n\n\n# %% KFoldConfig ----\n#' @title KFoldConfig\n#'\n#' @description\n#' ResamplerConfig subclass for k-fold resampling.\n#'\n#' @author EDG\n#' @noRd\nKFoldConfig <- new_class(\n name = \"KFoldConfig\",\n parent = ResamplerConfig,\n properties = list(\n stratify_var = class_character | NULL,\n strat_n_bins = scalar_int_pos,\n id_strat = class_vector | NULL,\n seed = scalar_int_pos\n ),\n constructor = function(n, stratify_var, strat_n_bins, id_strat, seed) {\n new_object(\n ResamplerConfig(\n type = \"KFold\",\n n = n\n ),\n stratify_var = stratify_var,\n strat_n_bins = strat_n_bins,\n id_strat = id_strat,\n seed = seed\n )\n }\n) # /rtemis::KFoldConfig\n\n\n# %% StratSubConfig ----\n#' @title StratSubConfig\n#'\n#' @description\n#' ResamplerConfig subclass for stratified subsampling.\n#'\n#' @author EDG\n#' @noRd\nStratSubConfig <- new_class(\n name = \"StratSubConfig\",\n parent = ResamplerConfig,\n properties = list(\n n = scalar_int_pos,\n train_p = scalar_dbl_01excl,\n stratify_var = class_character | NULL,\n strat_n_bins = scalar_int_pos,\n id_strat = class_vector | NULL,\n seed = scalar_int_pos\n ),\n constructor = function(\n n,\n train_p,\n stratify_var,\n strat_n_bins,\n id_strat,\n seed\n ) {\n new_object(\n ResamplerConfig(\n type = \"StratSub\",\n n = n\n ),\n train_p = train_p,\n stratify_var = stratify_var,\n strat_n_bins = strat_n_bins,\n id_strat = id_strat,\n seed = seed\n )\n }\n) # /rtemis::StratSubConfig\n\n\n# %% StratBootConfig ----\n#' @title StratBootConfig\n#'\n#' @description\n#' ResamplerConfig subclass for stratified bootstrapping.\n#'\n#' @author EDG\n#' @noRd\nStratBootConfig <- new_class(\n name = \"StratBootConfig\",\n parent = ResamplerConfig,\n properties = list(\n stratify_var = class_character | NULL,\n train_p = scalar_dbl_01excl,\n strat_n_bins = scalar_int_pos,\n target_length = scalar_int_pos,\n id_strat = class_vector | NULL,\n seed = scalar_int_pos\n ),\n constructor = function(\n n,\n stratify_var,\n train_p,\n strat_n_bins,\n target_length,\n id_strat,\n seed\n ) {\n new_object(\n ResamplerConfig(\n type = \"StratBoot\",\n n = n\n ),\n stratify_var = stratify_var,\n train_p = train_p,\n strat_n_bins = strat_n_bins,\n target_length = target_length,\n id_strat = id_strat,\n seed = seed\n )\n }\n) # /rtemis::StratBootConfig\n\n\n# %% BootstrapConfig ----\n#' @title BootstrapConfig\n#'\n#' @description\n#' ResamplerConfig subclass for bootstrap resampling.\n#'\n#' @author EDG\n#' @noRd\nBootstrapConfig <- new_class(\n name = \"BootstrapConfig\",\n parent = ResamplerConfig,\n properties = list(\n id_strat = class_vector | NULL,\n seed = scalar_int_pos\n ),\n constructor = function(n, id_strat, seed) {\n new_object(\n ResamplerConfig(\n type = \"Bootstrap\",\n n = n\n ),\n id_strat = id_strat,\n seed = seed\n )\n }\n) # /rtemis::BootstrapConfig\n\n\n# %% LOOCVConfig ----\n#' @title LOOCVConfig\n#'\n#' @description\n#' ResamplerConfig subclass for leave-one-out cross-validation.\n#'\n#' @author EDG\n#' @noRd\nLOOCVConfig <- new_class(\n name = \"LOOCVConfig\",\n parent = ResamplerConfig,\n constructor = function(n) {\n new_object(\n ResamplerConfig(\n type = \"LOOCV\",\n n = n\n )\n )\n }\n) # /rtemis::LOOCVConfig\n\n\n# %% CustomConfig ----\n#' @title CustomConfig\n#'\n#' @description\n#' ResamplerConfig subclass for custom resampling.\n#'\n#' @author EDG\n#' @noRd\nCustomConfig <- new_class(\n name = \"CustomConfig\",\n parent = ResamplerConfig,\n constructor = function(n) {\n new_object(\n ResamplerConfig(\n type = \"Custom\",\n n = n\n )\n )\n }\n) # /rtemis::CustomConfig\n\n\n# %% setup_Resampler ----\n#' Setup Resampler\n#'\n#' @param n_resamples Integer: Number of resamples to make.\n#' @param type Character: Type of resampler: \"KFold\", \"StratSub\", \"StratBoot\", \"Bootstrap\", \"LOOCV\"\n#' @param stratify_var Character: Variable to stratify by.\n#' @param train_p Float: Training set percentage.\n#' @param strat_n_bins Integer: Number of bins to stratify by.\n#' @param target_length Integer: Target length for stratified bootstraps.\n#' @param id_strat Integer: Vector of indices to stratify by. These may be, for example, case IDs\n#' if your dataset contains repeated measurements. By specifying this vector, you can ensure that\n#' each case can only be present in the training or test set, but not both.\n#' @param seed Integer: Random seed.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return ResamplerConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' tenfold_resampler <- setup_Resampler(n_resamples = 10L, type = \"KFold\", seed = 2026L)\n#' tenfold_resampler\nsetup_Resampler <- function(\n n_resamples = 10L,\n type = c(\"KFold\", \"StratSub\", \"StratBoot\", \"Bootstrap\", \"LOOCV\"),\n # index = NULL,\n # group = NULL,\n stratify_var = NULL,\n train_p = .75,\n strat_n_bins = 4L,\n target_length = NULL,\n id_strat = NULL,\n seed = NULL,\n verbosity = 1L\n) {\n # Arguments\n type <- match_arg(\n type,\n c(\"KFold\", \"StratSub\", \"StratBoot\", \"Bootstrap\", \"LOOCV\")\n )\n if (length(type) == 0) {\n cli::cli_abort(\n \"Invalid resampler type. Must be one of: 'StratSub', 'StratBoot', 'KFold', 'Bootstrap', 'LOOCV'\"\n )\n }\n seed <- clean_int(seed)\n\n if (type == \"KFold\") {\n KFoldConfig(\n n = n_resamples,\n stratify_var = stratify_var,\n strat_n_bins = strat_n_bins,\n id_strat = id_strat,\n seed = seed\n )\n } else if (type == \"StratSub\") {\n StratSubConfig(\n n = n_resamples,\n train_p = train_p,\n stratify_var = stratify_var,\n strat_n_bins = strat_n_bins,\n id_strat = id_strat,\n seed = seed\n )\n } else if (type == \"StratBoot\") {\n StratBootConfig(\n n = n_resamples,\n train_p = train_p,\n stratify_var = stratify_var,\n strat_n_bins = strat_n_bins,\n target_length = target_length,\n id_strat = id_strat,\n seed = seed\n )\n } else if (type == \"Bootstrap\") {\n BootstrapConfig(\n n = n_resamples,\n id_strat = id_strat,\n seed = seed\n )\n } else if (type == \"LOOCV\") {\n LOOCVConfig(\n n = NA_integer_\n )\n } else {\n cli::cli_abort(paste(\n \"Resampler'\",\n type,\n \"'is not supported.\",\n \"Supported types are: 'KFold', 'StratSub', 'StratBoot', 'Bootstrap', 'LOOCV'.\"\n ))\n }\n} # /rtemis::setup_Resampler\n\n\n# %% Resampler ----\n#' @title Resampler\n#'\n#' @description\n#' Class for resampling objects.\n#'\n#' @author EDG\n#' @noRd\nResampler <- new_class(\n name = \"Resampler\",\n properties = list(\n type = class_character,\n resamples = class_list,\n config = ResamplerConfig\n )\n) # /rtemis::Resampler\n\n\n# %% repr.Resampler ----\n#' repr Resampler\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(repr, Resampler) <- function(x, pad = 0L, output_type = NULL) {\n output_type <- get_output_type(output_type)\n paste0(\n repr_S7name(x, pad = pad, output_type = output_type),\n repr_ls(\n props(x),\n pad = pad,\n print_class = FALSE,\n output_type = output_type\n )\n )\n} # /rtemis::repr.Resampler\n\n\n# %% print.Resampler ----\nmethod(print, Resampler) <- function(\n x,\n output_type = c(\"ansi\", \"html\", \"plain\"),\n ...\n) {\n cat(repr(x, output_type = output_type))\n invisible(x)\n}\n\n# %% names.Resampler ----\nmethod(names, Resampler) <- function(x) {\n names(x@resamples)\n}\n\n\n# %% `$`.Resampler ----\n# Access Resampler$resamples resamples using `$` ----\nmethod(`$`, Resampler) <- function(x, name) {\n x@resamples[[name]]\n}\n\n\n# %% `.DollarNames`.Resampler ----\n# DollarSign tab-complete Resampler@resamples names\nmethod(`.DollarNames`, Resampler) <- function(x, pattern = \"\") {\n all_names <- names(x@resamples)\n grep(pattern, all_names, value = TRUE)\n}\n\n\n# %% `[[`.Resampler ----\n# Access Resampler$resamples resamples using `[[` ----\nmethod(`[[`, Resampler) <- function(x, index) {\n x@resamples[[index]]\n}\n\n\n# %% desc.Resampler ----\nmethod(desc, Resampler) <- function(x) {\n desc(x@config)\n}\n\n\n# %% --- Internal functions ----\n\n# %% .list_to_ResamplerConfig ----\n#' Convert a list to a ResamplerConfig object\n#'\n#' Internal function used by `rtemis.server` and `SuperConfig` deserialization\n#' to reconstruct a `ResamplerConfig` object from a named list. Not intended\n#' for direct use by end users.\n#'\n#' @param x Named list with the following elements:\n#' \\describe{\n#' \\item{`type`}{Character: resampler type — one of `\"KFold\"`,\n#' `\"StratSub\"`, `\"StratBoot\"`, `\"Bootstrap\"`, `\"LOOCV\"`, `\"Custom\"`.}\n#' \\item{`n`}{Integer: number of resamples (not used for `\"LOOCV\"`).}\n#' \\item{`train_p`}{Numeric: training proportion (used by `\"StratSub\"` and\n#' `\"StratBoot\"`).}\n#' \\item{`stratify_var`}{Character or `NULL`: stratification variable name.}\n#' \\item{`strat_n_bins`}{Integer: number of bins for stratification.}\n#' \\item{`target_length`}{Integer or `NULL`: target resample length\n#' (`\"StratBoot\"` only).}\n#' \\item{`id_strat`}{Character or `NULL`: ID stratification variable.}\n#' \\item{`seed`}{Integer or `NULL`: random seed.}\n#' }\n#'\n#' @return A `ResamplerConfig` object of the appropriate subtype.\n#'\n#' @author EDG\n#' @keywords internal\n#' @export\n.list_to_ResamplerConfig <- function(x) {\n switch(\n x[[\"type\"]],\n KFold = KFoldConfig(\n n = x[[\"n\"]],\n stratify_var = x[[\"stratify_var\"]],\n strat_n_bins = x[[\"strat_n_bins\"]],\n id_strat = x[[\"id_strat\"]],\n seed = x[[\"seed\"]]\n ),\n StratSub = StratSubConfig(\n n = x[[\"n\"]],\n train_p = x[[\"train_p\"]],\n stratify_var = x[[\"stratify_var\"]],\n strat_n_bins = x[[\"strat_n_bins\"]],\n id_strat = x[[\"id_strat\"]],\n seed = x[[\"seed\"]]\n ),\n StratBoot = StratBootConfig(\n n = x[[\"n\"]],\n train_p = x[[\"train_p\"]],\n stratify_var = x[[\"stratify_var\"]],\n strat_n_bins = x[[\"strat_n_bins\"]],\n target_length = x[[\"target_length\"]],\n id_strat = x[[\"id_strat\"]],\n seed = x[[\"seed\"]]\n ),\n Bootstrap = BootstrapConfig(\n n = x[[\"n\"]],\n id_strat = x[[\"id_strat\"]],\n seed = x[[\"seed\"]]\n ),\n LOOCV = LOOCVConfig(\n n = NA_integer_\n ),\n Custom = CustomConfig(\n n = x[[\"n\"]]\n )\n )\n} # /rtemis::.list_to_ResamplerConfig\n" }, { "path": "R/06_Tuner.R", "content": "# S7_Tuner.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# References\n# S7\n# https://github.com/RConsortium/S7/\n# https://rconsortium.github.io/S7\n# future\n# https://www.futureverse.org/backends.html\n\n# Description\n# `TunerConfig` class and subclasses create objects that store tuner config.\n# They are set by `setup_GridSearch()` and perform type checking and validation.\n# They are used by `tune()`.\n# `Tuner` class and subclasses create objects that store tuning results.\n# They are created by `tune()`.\n\n# Dev\n# Should both class constructors (e.g. GridSearch@constructor) and setup functions\n# (e.g. setup_GridSearch) perform type checking and validation?\n\n# %% TunerConfig ----\n#' TunerConfig\n#'\n#' Superclass for tuner config.\n#'\n#' @field type Character: Type of tuner.\n#' @field config Named list of tuner config.\n#'\n#' @author EDG\n#' @noRd\nTunerConfig <- new_class(\n name = \"TunerConfig\",\n properties = list(\n type = class_character,\n config = class_list\n )\n) # /rtemis::TunerConfig\n\n\n# %% repr.TunerConfig ----\nmethod(repr, TunerConfig) <- function(\n x,\n pad = 0L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n paste0(\n repr_S7name(\n paste(x@type, \"TunerConfig\"),\n pad = pad,\n output_type = output_type\n ),\n repr_ls(x@config, pad = pad, output_type = output_type)\n )\n} # /rtemis::repr.TunerConfig\n\n\n# %% print.TunerConfig ----\nmethod(print, TunerConfig) <- function(x, pad = 0L, ...) {\n cat(repr(x, pad = pad), \"\\n\")\n invisible(x)\n}\n\n# %% desc.TunerConfig ----\nmethod(desc, TunerConfig) <- function(x) {\n if (x@type == \"GridSearch\") {\n paste(x@config[[\"search_type\"]], \"grid search\")\n }\n}\n\n\n# %% `$`.TunerConfig ----\n# Make TunerConfig@config `$`-accessible\nmethod(`$`, TunerConfig) <- function(x, name) {\n x@config[[name]]\n}\n\n\n# %% `.DollarNames`.TunerConfig ----\n# `$`-autocomplete TunerConfig@config\nmethod(`.DollarNames`, TunerConfig) <- function(x, pattern = \"\") {\n all_names <- names(x@config)\n grep(pattern, all_names, value = TRUE)\n}\n\n\n# %% `[[`.TunerConfig ----\n# Make TunerConfig@config `[[`-accessible\nmethod(`[[`, TunerConfig) <- function(x, name) {\n x@config[[name]]\n}\n\n\n# %% GridSearchConfig ----\n#' @title GridSearchConfig\n#'\n#' @description\n#' TunerConfig subclass for grid search config.\n#'\n#' @author EDG\n#' @noRd\nGridSearchConfig <- new_class(\n name = \"GridSearchConfig\",\n parent = TunerConfig,\n constructor = function(\n resampler_config = NULL,\n search_type = NULL,\n randomize_p = NULL,\n metrics_aggregate_fn = NULL,\n metric = NULL,\n maximize = NULL\n ) {\n check_is_S7(resampler_config, ResamplerConfig)\n check_inherits(search_type, \"character\")\n check_float01exc(randomize_p)\n check_character(metrics_aggregate_fn)\n check_inherits(metric, \"character\")\n check_inherits(maximize, \"logical\")\n # Only assign randomize_p if search_type is \"randomized\"\n params <- list(\n search_type = search_type,\n resampler_config = resampler_config,\n metrics_aggregate_fn = metrics_aggregate_fn,\n metric = metric,\n maximize = maximize\n )\n if (search_type == \"randomized\") {\n params[[\"randomize_p\"]] <- randomize_p\n }\n new_object(\n TunerConfig(\n type = \"GridSearch\",\n config = params\n )\n )\n }\n) # /rtemis::GridSearchConfig\n\n\n# %% setup_GridSearch ----\n#' Setup Grid Search Config\n#'\n#' Create a `GridSearchConfig` object that can be passed to [train].\n#'\n#' @param resampler_config `ResamplerConfig` set by [setup_Resampler].\n#' @param search_type Character: \"exhaustive\" or \"randomized\". Type of\n#' grid search to use. Exhaustive search will try all combinations of\n#' config. Randomized will try a random sample of size\n#' `randomize_p` * `N of total combinations`\n#' @param randomize_p Float (0, 1): For `search_type == \"randomized\"`,\n#' randomly test this proportion of combinations.\n#' @param metrics_aggregate_fn Character: Name of function to use to aggregate error metrics.\n#' @param metric Character: Metric to minimize or maximize.\n#' @param maximize Logical: If TRUE, maximize `metric`, otherwise minimize it.\n#'\n#' @return A `GridSearchConfig` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' gridsearch_config <- setup_GridSearch(\n#' resampler_config = setup_Resampler(n_resamples = 5L, type = \"KFold\"),\n#' search_type = \"exhaustive\"\n#' )\n#' gridsearch_config\nsetup_GridSearch <- function(\n resampler_config = setup_Resampler(n_resamples = 5L, type = \"KFold\"),\n search_type = \"exhaustive\",\n randomize_p = NULL,\n metrics_aggregate_fn = \"mean\",\n metric = NULL,\n maximize = NULL\n) {\n # Arguments ----\n check_is_S7(resampler_config, ResamplerConfig)\n check_inherits(search_type, \"character\")\n check_float01exc(randomize_p)\n if (search_type == \"exhaustive\" && !is.null(randomize_p)) {\n cli::cli_abort(\"search_type is 'exhaustive': do not set randomize_p.\")\n }\n # check_inherits(metrics_aggregate_fn, \"function\")\n check_character(metrics_aggregate_fn)\n check_inherits(metric, \"character\")\n check_inherits(maximize, \"logical\")\n GridSearchConfig(\n resampler_config = resampler_config,\n search_type = search_type,\n randomize_p = randomize_p,\n metrics_aggregate_fn = metrics_aggregate_fn,\n metric = metric,\n maximize = maximize\n )\n} # /rtemis::setup_GridSearch\n\n\n# %% Tuner ----\n#' Tuner Class\n#'\n#' @field type Character: Type of tuner.\n#' @field hyperparameters Named list of tunable and fixed hyperparameters.\n#' @field tuning_results Data.frame: Tuning results.\n#' @field best_hyperparameters Named list of best hyperparameter values. Includes only\n#' hyperparameters that were tuned.\n#'\n#' @author EDG\n#' @noRd\nTuner <- new_class(\n name = \"Tuner\",\n properties = list(\n type = class_character,\n hyperparameters = Hyperparameters,\n tuner_config = TunerConfig,\n tuning_results = class_list, # with 2 elements: metrics_training, metrics_validation\n best_hyperparameters = class_list\n )\n) # /rtemis::Tuner\n\n\n# %% desc.Tuner ----\nmethod(desc, Tuner) <- function(x) {\n if (x@type == \"GridSearch\") {\n paste(x@tuner_config[[\"search_type\"]], \"grid search\")\n }\n} # /rtemis::describe.Tuner\n\n\n# %% GridSearch ----\n#' GridSearch Class\n#'\n#' Tuner subclass for grid search.\n#'\n#' @author EDG\n#' @noRd\nGridSearch <- new_class(\n name = \"GridSearch\",\n parent = Tuner,\n constructor = function(\n hyperparameters,\n tuner_config,\n tuning_results,\n best_hyperparameters\n ) {\n type <- \"GridSearch\"\n new_object(\n Tuner(\n type = type,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n tuning_results = tuning_results,\n best_hyperparameters = best_hyperparameters\n )\n )\n }\n) # /rtemis::GridSearch\n\n\n# print.GridSearch ----\n#' Print GridSearch\n#'\n#' Print GridSearch object\n#'\n#' @param x GridSearch object.\n#' @param header Logical: If TRUE, print header with type of tuner.\n#' @param ... Not used.\n#'\n#' @author EDG\n#' @noRd\nmethod(print, GridSearch) <- function(x, header = TRUE, ...) {\n if (header) {\n objcat(paste(x@type))\n }\n type <- if (x@tuner_config[[\"search_type\"]] == \"exhaustive\") {\n \"An exhaustive grid search\"\n } else {\n paste0(\n \"A randomized grid search (p = \",\n x@tuner_config[[\"randomize_p\"]],\n \")\"\n )\n }\n n_param_combs <- NROW(x@tuning_results[[\"param_grid\"]])\n cat(\n type,\n \" of \",\n singorplu(n_param_combs, \"parameter combination\"),\n \" was performed using \",\n desc(x@tuner_config[[\"resampler_config\"]]),\n \".\\n\",\n sep = \"\"\n )\n cat(\n x@tuner_config[[\"metric\"]],\n \"was\",\n ifelse(x@tuner_config[[\"maximize\"]], \"maximized\", \"minimized\"),\n \"with the following config:\\n\"\n )\n printls(x@best_hyperparameters)\n invisible(x)\n} # /rtemis::print.GridSearch\n\n\n# %% repr.GridSearch ----\nmethod(repr, GridSearch) <- function(\n x,\n header = TRUE,\n pad = 0L,\n output_type = c(\"ansi\", \"html\", \"plain\"),\n ...\n) {\n output_type <- match.arg(output_type)\n out <- character()\n if (header) {\n out <- paste0(out, repr_S7name(x@type, pad = pad), \"\\n\")\n }\n type <- if (x@tuner_config[[\"search_type\"]] == \"exhaustive\") {\n \"An exhaustive grid search\"\n } else {\n paste0(\n \"A randomized grid search (p = \",\n x@tuner_config[[\"randomize_p\"]],\n \")\"\n )\n }\n n_param_combs <- NROW(x@tuning_results[[\"param_grid\"]])\n out <- paste0(\n out,\n type,\n \" of \",\n singorplu(n_param_combs, \"parameter combination\"),\n \" was performed using \",\n desc(x@tuner_config[[\"resampler_config\"]]),\n \".\\n\"\n )\n out <- paste(\n out,\n x@tuner_config[[\"metric\"]],\n \"was\",\n ifelse(x@tuner_config[[\"maximize\"]], \"maximized\", \"minimized\"),\n \"with the following config:\\n\"\n )\n out <- paste(\n out,\n repr_ls(x@best_hyperparameters, pad = pad, output_type = output_type),\n sep = \"\"\n )\n out\n} # /rtemis::repr.GridSearch\n\n\n# %% .list_to_TunerConfig ----\n#' Convert a list to a TunerConfig object\n#'\n#' Internal function used by `rtemis.server` and `SuperConfig` deserialization\n#' to reconstruct a `TunerConfig` object from a named list. Not intended for\n#' direct use by end users.\n#'\n#' @param x Named list with two elements:\n#' \\describe{\n#' \\item{`type`}{Character: tuner type. Currently only `\"GridSearch\"` is\n#' supported.}\n#' \\item{`config`}{Named list of tuner configuration fields. For\n#' `\"GridSearch\"`: `resampler_config` (a list accepted by\n#' [.list_to_ResamplerConfig()]), `search_type`, `randomize_p`,\n#' `metrics_aggregate_fn`, `metric`, and `maximize`.}\n#' }\n#'\n#' @return A `TunerConfig` object (currently a `GridSearchConfig`).\n#'\n#' @author EDG\n#' @keywords internal\n#' @export\n.list_to_TunerConfig <- function(x) {\n if (x[[\"type\"]] == \"GridSearch\") {\n setup_GridSearch(\n resampler_config = .list_to_ResamplerConfig(x[[\"config\"]][[\n \"resampler_config\"\n ]]),\n search_type = x[[\"config\"]][[\"search_type\"]],\n randomize_p = x[[\"config\"]][[\"randomize_p\"]],\n metrics_aggregate_fn = x[[\"config\"]][[\"metrics_aggregate_fn\"]],\n metric = x[[\"config\"]][[\"metric\"]],\n maximize = x[[\"config\"]][[\"maximize\"]]\n )\n } else {\n cli::cli_abort(\"Unsupported tuner type: {x[['type']]}\")\n }\n} # /rtemis::.list_to_TunerConfig\n" }, { "path": "R/07_Supervised.R", "content": "# S7_Supervised.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# References\n# https://github.com/RConsortium/S7/\n# https://rconsortium.github.io/S7\n# https://rconsortium.github.io/S7/articles/classes-objects.html?q=computed#computed-properties\n# https://utf8-icons.com/\n\n# %% VariableImportance ----\n#' @title VariableImportance\n#'\n#' @description\n#' Class for variable importance objects. Allows for one or more variable importance measures,\n#' stored in a data.table with columns \"variable\", and at least one\n#' more column with a descriptive name.\n#'\n#' @author EDG\n#' @noRd\nVariableImportance <- new_class(\n name = \"VariableImportance\",\n properties = list(\n data = class_data.table\n ),\n validator = function(self) {\n # Must include at least two columns\n if (NCOL(self@data) < 2L) {\n cli::cli_abort(\n \"Variable importance data must include at least two columns: 'variable' and at least one importance measure.\"\n )\n }\n # Must include column \"variable\" of type character\n if (!\"variable\" %in% names(self@data)) {\n cli::cli_abort(\n \"Variable importance data must include a 'variable' column.\"\n )\n }\n if (!is.character(self@data[[\"variable\"]])) {\n cli::cli_abort(\"Column 'variable' must be of type character.\")\n }\n # All other columns must be numeric\n other_cols <- setdiff(names(self@data), \"variable\")\n if (!all(self@data[, sapply(.SD, is.numeric), .SDcols = other_cols])) {\n cli::cli_abort(\n \"All columns other than 'variable' must be numeric.\"\n )\n }\n # Number of rows will be checked by Supervised to be at least as many as\n # the number of predictors.\n }\n) # /rtemis::VariableImportance\n\n\n# %% repr.VariableImportance ----\nmethod(repr, VariableImportance) <- function(x, pad = 0L, output_type = NULL) {\n output_type <- get_output_type(output_type)\n # \"N variable importance measures for M predictors\"\n n_m <- NCOL(x@data) - 1L\n paste0(\n repr_S7name(\"VariableImportance\", pad = pad, output_type = output_type),\n strrep(\" \", pad),\n fmt(n_m, col = highlight_col, bold = TRUE, output_type = output_type),\n ngettext(\n n_m,\n \" variable importance measure for \",\n \" variable importance measures for \"\n ),\n fmt(\n NROW(x@data),\n col = highlight_col,\n bold = TRUE,\n output_type = output_type\n ),\n ngettext(NROW(x@data), \" predictor\", \" predictors\")\n )\n} # /rtemis::repr.VariableImportance\n\n\n# %% print.VariableImportance ----\nmethod(print, VariableImportance) <- function(x, output_type = NULL, ...) {\n cat(repr(x, output_type = output_type), \"\\n\")\n invisible(x)\n} # /rtemis::print.VariableImportance\n\n\n# Plot methods\n# Supervised: plot_varimp\n# SupervisedRes: plot_varimp, plot_metric\n# Regression: plot_true_pred,\n# Classification: plot_true_pred, plot_roc\n# RegressionRes: plot_metric, plot_true_pred,\n# ClassificationRes: plot_metric, plot_true_pred, plot_roc\n\n# %% Supervised ----\n#' @title Supervised\n#'\n#' @description\n#' Superclass for supervised learning models.\n#'\n#' @author EDG\n#' @noRd\nSupervised <- new_class(\n name = \"Supervised\",\n properties = list(\n algorithm = class_character,\n model = class_any,\n type = class_character,\n preprocessor = Preprocessor | NULL,\n preprocessor_internal = Preprocessor | NULL,\n hyperparameters = Hyperparameters | NULL,\n tuner = Tuner | NULL,\n execution_config = ExecutionConfig,\n y_training = class_any,\n y_validation = class_any,\n y_test = class_any,\n predicted_training = class_any,\n predicted_validation = class_any,\n predicted_test = class_any,\n metrics_training = Metrics,\n metrics_validation = Metrics | NULL,\n metrics_test = Metrics | NULL,\n xnames = class_character,\n varimp = VariableImportance | NULL,\n question = class_character | NULL,\n extra = class_any,\n session_info = class_any\n ),\n constructor = function(\n algorithm,\n model,\n type,\n preprocessor,\n preprocessor_internal,\n hyperparameters,\n tuner,\n execution_config,\n y_training,\n y_validation,\n y_test,\n predicted_training,\n predicted_validation,\n predicted_test,\n metrics_training,\n metrics_validation,\n metrics_test,\n xnames,\n varimp,\n question,\n extra\n ) {\n new_object(\n S7_object(),\n algorithm = algorithm,\n model = model,\n type = type,\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner = tuner,\n execution_config = execution_config,\n y_training = y_training,\n y_validation = y_validation,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_validation = predicted_validation,\n predicted_test = predicted_test,\n metrics_training = metrics_training,\n metrics_validation = metrics_validation,\n metrics_test = metrics_test,\n xnames = xnames,\n varimp = varimp,\n question = question,\n extra = extra,\n session_info = sessionInfo()\n )\n }\n) # /rtemis::Supervised\n\n\n# %% predict.Supervised ----\n#' Predict `Supervised`\n#'\n#' Predict Method for `Supervised` objects\n#'\n#' @param object `Supervised` object.\n#' @param newdata data.frame or similar: New data to predict.\n#'\n#' @noRd\nmethod(predict, Supervised) <- function(object, newdata, verbosity = 1L, ...) {\n check_inherits(newdata, \"data.frame\")\n\n # Apply user-specified preprocessor if available\n if (!is.null(object@preprocessor)) {\n newdata <- preprocess(\n newdata,\n object@preprocessor,\n verbosity = verbosity\n ) |>\n preprocessed()\n }\n\n # Apply algorithm-specific preprocessor if available\n if (!is.null(object@preprocessor_internal)) {\n newdata <- preprocess(\n newdata,\n object@preprocessor_internal,\n verbosity = verbosity\n ) |>\n preprocessed()\n }\n\n # After preprocessing, enforce strict predictor names and order\n if (!identical(names(newdata), object@xnames)) {\n extra_cols <- setdiff(names(newdata), object@xnames)\n missing_cols <- setdiff(object@xnames, names(newdata))\n cli::cli_abort(c(\n \"x\" = \"Predictor names and order in newdata must exactly match training data.\",\n \"i\" = \"Expected {length(object@xnames)} columns; got {NCOL(newdata)}.\",\n \"i\" = if (length(extra_cols) > 0L) {\n paste0(\"Unexpected columns: \", paste(extra_cols, collapse = \", \"))\n } else {\n \"Unexpected columns: none.\"\n },\n \"i\" = if (length(missing_cols) > 0L) {\n paste0(\"Missing columns: \", paste(missing_cols, collapse = \", \"))\n } else {\n \"Missing columns: none.\"\n }\n ))\n }\n\n # Call predict_super with fully preprocessed data\n predict_super(\n model = object@model,\n newdata = newdata,\n type = object@type,\n verbosity = verbosity\n )\n} # /rtemis::predict.Supervised\n\n\n# %% fitted.Supervised ----\n#' Fitted `Supervised`\n#'\n#' Fitted Method for `Supervised` objects\n#'\n#' @param object `Supervised` object.\n#'\n#' @keywords internal\n#' @noRd\nmethod(fitted, Supervised) <- function(object, ...) {\n object@predicted_training\n} # /rtemis::fitted.Supervised\n\n\n# %% se.Supervised ----\n#' Standard Error `Supervised`\n#'\n#' Standard Error Method for `Supervised` objects\n#'\n#' @param object `Supervised` object.\n#'\n#' @keywords internal\n#' @noRd\nmethod(se, Supervised) <- function(x, ...) {\n x@se_training\n}\n\n\n# %% `$`.Supervised ----\n# Make Supervised props `$`- accessible\nmethod(`$`, Supervised) <- function(x, name) {\n prop(x, name)\n}\n\n\n# %% `.DollarNames`.Supervised ----\n# `$`-autocomplete Supervised props\nmethod(`.DollarNames`, Supervised) <- function(x, pattern = \"\") {\n all_names <- names(props(x))\n grep(pattern, all_names, value = TRUE)\n}\n\n\n# %% `[[`.Supervised ----\n# Make Supervised props `[[`- accessible ----\nmethod(`[[`, Supervised) <- function(x, name) {\n prop(x, name)\n}\n\n\n# %% repr.Supervised ----\n#' repr `Supervised`\n#'\n#' @param x `Supervised` object.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nmethod(repr, Supervised) <- function(\n x,\n pad = 0L,\n output_type = NULL,\n filename = NULL\n) {\n output_type <- get_output_type(output_type, filename)\n # Class name\n out <- paste0(\n repr_S7name(x@type, pad = pad, output_type = output_type),\n highlight(x@algorithm, output_type = output_type),\n \" (\",\n desc_alg(x@algorithm),\n \")\\n\"\n )\n\n # Tuning, if available\n if (!is.null(x@tuner)) {\n out <- paste0(\n out,\n fmt(\n \"\\U2699\",\n col = col_tuner,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n \" Tuned using \",\n desc(x@tuner),\n \".\\n\"\n )\n }\n\n # Calibration, if available\n if (prop_exists(x, \"calibration_model\")) {\n out <- paste0(\n out,\n fmt(\n \"\\U27CB\",\n col = col_calibrator,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n \" Calibrated using \",\n desc_alg(x@calibration_model@algorithm),\n \".\\n\"\n )\n }\n\n out <- paste0(out, \"\\n\")\n\n # {Regression, Classification} vs. CalibratedClassification\n if (prop_exists(x, \"calibration_model\")) {\n # CalibratedClassification\n # Metrics, training\n out <- paste0(\n out,\n # repr(x@metrics_training, pad = 2L, output_type = output_type)\n repr_CalibratedClassificationMetrics(\n x@metrics_training,\n x@metrics_training_calibrated,\n pad = pad + 2L,\n output_type = output_type\n )\n )\n\n # Metrics, validation\n if (length(x@metrics_validation) > 0) {\n out <- paste0(\n out,\n repr_CalibratedClassificationMetrics(\n x@metrics_validation,\n x@metrics_validation_calibrated,\n pad = pad + 2L,\n output_type = output_type\n )\n )\n }\n\n # Metrics, test\n if (length(x@metrics_test) > 0) {\n out <- paste0(\n out,\n \"\\n\",\n repr_CalibratedClassificationMetrics(\n x@metrics_test,\n x@metrics_test_calibrated,\n pad = pad + 2L,\n output_type = output_type\n )\n )\n }\n } else {\n # {Regression, Classification}\n\n # Metrics, training\n out <- paste0(\n out,\n repr(x@metrics_training, pad = pad + 2L, output_type = output_type)\n )\n\n # Metrics, validation\n if (length(x@metrics_validation) > 0) {\n out <- paste0(\n out,\n repr(x@metrics_validation, pad = pad + 2L, output_type = output_type)\n )\n }\n\n # Metrics, test\n if (length(x@metrics_test) > 0) {\n out <- paste0(\n out,\n \"\\n\",\n repr(x@metrics_test, pad = pad + 2L, output_type = output_type)\n )\n }\n }\n\n out\n} # /rtemis::repr.Supervised\n\n\n# %% to_json.Supervised ----\n#' to_json `Supervised`\n#'\n#' Convert a `Supervised` (or `Regression` / `Classification` /\n#' `CalibratedClassification`) object to a JSON-serializable list. Excludes\n#' the model object, full prediction vectors, full outcome vectors, the\n#' R session_info, and `extra` — all of which are either not JSON-friendly,\n#' too large for the control-plane response, or fetched separately as\n#' Arrow IPC bulk data.\n#'\n#' @param x `Supervised` object.\n#'\n#' @return Named list. Pass to `jsonlite::toJSON(auto_unbox = TRUE)`.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(to_json, Supervised) <- function(x, ...) {\n # Use `.to_json_value()` for every prop — it handles nested S7 objects,\n # nested lists containing S7 objects, and primitive types uniformly.\n # That matters when a prop's *declared* type is S7 but the actual value\n # is a primitive (e.g. `varimp` is sometimes a plain numeric vector\n # rather than a VariableImportance — a rtemis-internal type mismatch\n # that this method must tolerate).\n out <- list(\n .class = S7_class(x)@name,\n algorithm = x@algorithm,\n type = x@type,\n question = x@question,\n xnames = x@xnames,\n n_features = length(x@xnames),\n preprocessor = .to_json_value(x@preprocessor),\n preprocessor_internal = .to_json_value(x@preprocessor_internal),\n hyperparameters = .to_json_value(x@hyperparameters),\n tuner = .to_json_value(x@tuner),\n execution_config = .to_json_value(x@execution_config),\n metrics_training = .to_json_value(x@metrics_training),\n metrics_validation = .to_json_value(x@metrics_validation),\n metrics_test = .to_json_value(x@metrics_test),\n varimp = .to_json_value(x@varimp)\n )\n\n # Subclass-specific extras\n if (prop_exists(x, \"binclasspos\")) {\n out[[\"binclasspos\"]] <- x@binclasspos\n }\n if (prop_exists(x, \"se_training\")) {\n # Regression: don't serialize full SE vectors (large); flag presence only\n out[[\"has_se\"]] <- !is.null(x@se_training)\n }\n if (prop_exists(x, \"calibration_model\")) {\n out[[\"calibration_model\"]] <- .to_json_value(x@calibration_model)\n if (prop_exists(x, \"metrics_training_calibrated\")) {\n out[[\"metrics_training_calibrated\"]] <-\n .to_json_value(x@metrics_training_calibrated)\n }\n if (prop_exists(x, \"metrics_validation_calibrated\")) {\n out[[\"metrics_validation_calibrated\"]] <-\n .to_json_value(x@metrics_validation_calibrated)\n }\n if (prop_exists(x, \"metrics_test_calibrated\")) {\n out[[\"metrics_test_calibrated\"]] <-\n .to_json_value(x@metrics_test_calibrated)\n }\n }\n\n Filter(Negate(is.null), out)\n} # /rtemis::to_json.Supervised\n\n\n# %% print.Supervised ----\nmethod(print, Supervised) <- function(\n x,\n output_type = c(\"ansi\", \"html\", \"plain\"),\n ...\n) {\n cat(repr(x, output_type = output_type))\n invisible(x)\n} # /rtemis::print.Supervised\n\n\n# %% describe.Supervised ----\n#' Describe `Supervised` object\n#'\n#' @param x `Supervised` object.\n#' @param ... Not used.\n#'\n#' @return Character string describing the `Supervised` object, invisibly.\n#'\n#' @author EDG\n#' @noRd\n#'\n#' @examples\n#' species_lightrf <- train(iris, algorithm = \"lightrf\")\n#' describe(species_lightrf)\nmethod(describe, Supervised) <- function(x) {\n type <- x@type\n algorithm <- desc_alg(x@algorithm)\n cat(algorithm, \" was used for \", tolower(type), \".\\n\", sep = \"\")\n desc <- paste0(algorithm, \" was used for \", tolower(type), \".\")\n\n # Tuning ----\n if (length(x@tuner) > 0) {\n describe(x@tuner)\n }\n\n # Metrics ----\n if (type == \"Classification\") {\n cat(\n \"Balanced accuracy was\",\n ddSci(x@metrics_training[[\"Overall\"]][[\"Balanced_Accuracy\"]]),\n \"on the training set\"\n )\n desc <- paste(\n desc,\n \"Balanced accuracy was\",\n ddSci(x@metrics_training[[\"Overall\"]][[\"Balanced_Accuracy\"]]),\n \"in the training set\"\n )\n if (!is.null(x@metrics_test[[\"Overall\"]][[\"Balanced_Accuracy\"]])) {\n cat(\n \" and\",\n ddSci(x@metrics_test[[\"Overall\"]][[\"Balanced_Accuracy\"]]),\n \"in the test set.\"\n )\n desc <- paste(\n desc,\n \"and\",\n ddSci(x@metrics_test[[\"Overall\"]][[\"Balanced_Accuracy\"]]),\n \"in the test set.\"\n )\n } else {\n cat(\".\")\n desc <- paste0(desc, \".\")\n }\n } else if (type == \"Regression\") {\n cat(\n \"R-squared was\",\n ddSci(x@metrics_training[[\"Rsq\"]]),\n \"in the training set\"\n )\n desc <- paste(\n desc,\n \"R-squared was\",\n ddSci(x@metrics_training[[\"Rsq\"]]),\n \"on the training set\"\n )\n if (!is.null(x@metrics_test[[\"Rsq\"]])) {\n cat(\n \" and\",\n ddSci(x@metrics_test[[\"Rsq\"]]),\n \"in the test.\"\n )\n desc <- paste(\n desc,\n \"and\",\n ddSci(x@metrics_test[[\"Rsq\"]]),\n \"on the test set.\"\n )\n } else {\n cat(\".\")\n desc <- paste0(desc, \".\")\n }\n }\n cat(\"\\n\")\n invisible(desc)\n} # /rtemis::describe.Supervised\n\n\n# %% Classification ----\n#' @title Classification\n#'\n#' @description\n#' Supervised subclass for classification models.\n#'\n#' @author EDG\n#' @noRd\nClassification <- new_class(\n name = \"Classification\",\n parent = Supervised,\n properties = list(\n predicted_prob_training = class_double | class_data.frame | NULL,\n predicted_prob_validation = class_double | class_data.frame | NULL,\n predicted_prob_test = class_double | class_data.frame | NULL,\n binclasspos = class_integer\n ),\n constructor = function(\n algorithm = NULL,\n model = NULL,\n preprocessor = NULL, # Preprocessor\n preprocessor_internal = NULL, # Algorithm-specific preprocessor\n hyperparameters = NULL, # Hyperparameters\n tuner = NULL, # Tuner\n execution_config,\n y_training = NULL,\n y_validation = NULL,\n y_test = NULL,\n predicted_training = NULL,\n predicted_validation = NULL,\n predicted_test = NULL,\n xnames = NULL,\n varimp = NULL,\n question = NULL,\n extra = NULL,\n predicted_prob_training = NULL,\n predicted_prob_validation = NULL,\n predicted_prob_test = NULL,\n binclasspos = 2L\n ) {\n metrics_training <- classification_metrics(\n true_labels = y_training,\n predicted_labels = predicted_training,\n predicted_prob = predicted_prob_training,\n sample = \"Training\"\n )\n metrics_validation <- if (!is.null(y_validation)) {\n classification_metrics(\n true_labels = y_validation,\n predicted_labels = predicted_validation,\n predicted_prob = predicted_prob_validation,\n sample = \"Validation\"\n )\n } else {\n NULL\n }\n metrics_test <- if (!is.null(y_test)) {\n classification_metrics(\n true_labels = y_test,\n predicted_labels = predicted_test,\n predicted_prob = predicted_prob_test,\n sample = \"Test\"\n )\n } else {\n NULL\n }\n new_object(\n Supervised(\n algorithm = algorithm,\n model = model,\n type = \"Classification\",\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner = tuner,\n execution_config = execution_config,\n y_training = y_training,\n y_validation = y_validation,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_validation = predicted_validation,\n predicted_test = predicted_test,\n metrics_training = metrics_training,\n metrics_validation = metrics_validation,\n metrics_test = metrics_test,\n xnames = xnames,\n varimp = varimp,\n question = question,\n extra = extra\n ),\n predicted_prob_training = predicted_prob_training,\n predicted_prob_validation = predicted_prob_validation,\n predicted_prob_test = predicted_prob_test,\n binclasspos = binclasspos\n )\n }\n) # /rtemis::Classification\n\n\n# %% CalibratedClassification ----\n#' @title CalibratedClassification\n#'\n#' @description\n#' Classification subclass for calibrated classification models.\n#' The classification_model can be trained on any data, ideally different from any data used by\n#' the classification model.\n#'\n#' @author EDG\n#' @noRd\nCalibratedClassification <- new_class(\n name = \"CalibratedClassification\",\n parent = Classification,\n properties = list(\n calibration_model = Supervised,\n predicted_training_calibrated = class_vector,\n predicted_validation_calibrated = class_vector | NULL,\n predicted_test_calibrated = class_vector | NULL,\n predicted_prob_training_calibrated = class_double,\n predicted_prob_validation_calibrated = class_double | NULL,\n predicted_prob_test_calibrated = class_double | NULL,\n metrics_training_calibrated = Metrics,\n metrics_validation_calibrated = Metrics | NULL,\n metrics_test_calibrated = Metrics | NULL\n ),\n constructor = function(classification_model, calibration_model) {\n # Predict calibrated probabilities of classification model datasets\n predicted_prob_training_calibrated <- predict(\n calibration_model,\n data.frame(\n predicted_probabilities = classification_model@predicted_prob_training\n ),\n )\n predicted_prob_validation_calibrated <- if (\n !is.null(classification_model@predicted_prob_validation)\n ) {\n predict(\n calibration_model,\n data.frame(\n predicted_probabilities = classification_model@predicted_prob_validation\n )\n )\n } else {\n NULL\n }\n predicted_prob_test_calibrated <- if (\n !is.null(classification_model@predicted_prob_test)\n ) {\n predict(\n calibration_model,\n data.frame(\n predicted_probabilities = classification_model@predicted_prob_test\n )\n )\n } else {\n NULL\n }\n # Predict calibrated labels of classification model datasets\n predicted_training_calibrated <- prob2categorical(\n predicted_prob_training_calibrated,\n levels = levels(classification_model@y_training)\n )\n predicted_validation_calibrated <- if (\n !is.null(classification_model@predicted_prob_validation)\n ) {\n prob2categorical(\n predicted_prob_validation_calibrated,\n levels = levels(classification_model@y_validation)\n )\n } else {\n NULL\n }\n predicted_test_calibrated <- if (\n !is.null(classification_model@predicted_prob_test)\n ) {\n prob2categorical(\n predicted_prob_test_calibrated,\n levels = levels(classification_model@y_test)\n )\n } else {\n NULL\n }\n metrics_training_calibrated <- classification_metrics(\n true_labels = classification_model@y_training,\n predicted_labels = predicted_training_calibrated,\n predicted_prob = predicted_prob_training_calibrated,\n sample = \"Calibrated Training\"\n )\n metrics_validation_calibrated <- if (\n !is.null(classification_model@y_validation)\n ) {\n classification_metrics(\n true_labels = classification_model@y_validation,\n predicted_labels = predicted_validation_calibrated,\n predicted_prob = predicted_prob_validation_calibrated,\n sample = \"Calibrated Validation\"\n )\n } else {\n NULL\n }\n metrics_test_calibrated <- if (!is.null(classification_model@y_test)) {\n classification_metrics(\n true_labels = classification_model@y_test,\n predicted_labels = predicted_test_calibrated,\n predicted_prob = predicted_prob_test_calibrated,\n sample = \"Calibrated Test\"\n )\n } else {\n NULL\n }\n new_object(\n classification_model,\n calibration_model = calibration_model,\n predicted_training_calibrated = predicted_training_calibrated,\n predicted_validation_calibrated = predicted_validation_calibrated,\n predicted_test_calibrated = predicted_test_calibrated,\n predicted_prob_training_calibrated = predicted_prob_training_calibrated,\n predicted_prob_validation_calibrated = predicted_prob_validation_calibrated,\n predicted_prob_test_calibrated = predicted_prob_test_calibrated,\n metrics_training_calibrated = metrics_training_calibrated,\n metrics_validation_calibrated = metrics_validation_calibrated,\n metrics_test_calibrated = metrics_test_calibrated\n )\n }\n) # /rtemis::CalibratedClassification\n\n\n# %% predict.CalibratedClassification ----\nmethod(predict, CalibratedClassification) <- function(object, newdata, ...) {\n check_inherits(newdata, \"data.frame\")\n # Get the classification model's predicted probabilities\n raw_prob <- do_call(\n predict_super,\n list(model = object@model, newdata = newdata, type = \"Classification\")\n )\n # Get the calibration model's predicted probabilities\n predict(\n object@calibration_model,\n newdata = data.frame(predicted_probabilities = raw_prob)\n )\n} # /rtemis::predict.CalibratedClassification\n\nse_compat_algorithms <- c(\"GLM\", \"GAM\")\n\n\n# %% Regression ----\n#' @title Regression\n#' @description\n#' Supervised subclass for regression models.\n#'\n#' @author EDG\n#' @noRd\nRegression <- new_class(\n name = \"Regression\",\n parent = Supervised,\n properties = list(\n se_training = class_double | NULL,\n se_validation = class_double | NULL,\n se_test = class_double | NULL\n ),\n constructor = function(\n algorithm = NULL,\n model = NULL,\n preprocessor = NULL, # Preprocessor\n preprocessor_internal = NULL, # Algorithm-specific preprocessor\n hyperparameters = NULL, # Hyperparameters\n tuner = NULL, # Tuner\n execution_config, # ExecutionConfig\n y_training = NULL,\n y_validation = NULL,\n y_test = NULL,\n predicted_training = NULL,\n predicted_validation = NULL,\n predicted_test = NULL,\n se_training = NULL,\n se_validation = NULL,\n se_test = NULL,\n xnames = NULL,\n varimp = NULL,\n question = NULL,\n extra = NULL\n ) {\n # Metrics ----\n metrics_training <- regression_metrics(\n y_training,\n predicted_training,\n sample = \"Training\"\n )\n metrics_validation <- if (!is.null(y_validation)) {\n regression_metrics(\n y_validation,\n predicted_validation,\n sample = \"Validation\"\n )\n } else {\n NULL\n }\n metrics_test <- if (!is.null(y_test)) {\n regression_metrics(\n y_test,\n predicted_test,\n sample = \"Test\"\n )\n } else {\n NULL\n }\n new_object(\n Supervised(\n algorithm = algorithm,\n model = model,\n type = \"Regression\",\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner = tuner,\n execution_config = execution_config,\n y_training = y_training,\n y_validation = y_validation,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_validation = predicted_validation,\n predicted_test = predicted_test,\n metrics_training = metrics_training,\n metrics_validation = metrics_validation,\n metrics_test = metrics_test,\n xnames = xnames,\n varimp = varimp,\n question = question,\n extra = extra\n ),\n se_training = se_training,\n se_validation = se_validation,\n se_test = se_test\n )\n }\n) # /rtemis::Regression\n\n\n# %% plot_true_pred.Regression ----\n#' Plot True vs. Predicted for Regression\n#'\n#' @param x `Regression` object.\n#' @param what Character vector: What to plot. Can include \"training\", \"validation\", \"test\", or\n#' \"all\", which will plot all available.\n#' @param fit Character: Algorithm to use to draw fit line.\n#' @param theme `Theme` object.\n#' @param labelify Logical: If TRUE, labelify the axis labels.\n#' @param ... Additional arguments passed to the plotting function.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(plot_true_pred, Regression) <- function(\n x,\n what = \"all\",\n fit = \"glm\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n labelify = TRUE,\n ...\n) {\n if (length(what) == 1 && what == \"all\") {\n what <- c(\"training\", \"validation\", \"test\")\n }\n true <- paste0(\"y_\", what)\n true_l <- Filter(\n Negate(is.null),\n sapply(true, function(z) prop(x, z))\n )\n predicted <- paste0(\"predicted_\", what)\n predicted_l <- Filter(\n Negate(is.null),\n sapply(predicted, function(z) prop(x, z))\n )\n if (labelify) {\n names(predicted_l) <- labelify(names(predicted_l))\n }\n draw_fit(\n x = true_l,\n y = predicted_l,\n fit = fit,\n theme = theme,\n ...\n )\n} # /rtemis::plot_true_pred.Regression\n\n\n# %% plot_true_pred.Classification ----\n#' Plot True vs. Predicted for Classification\n#'\n#' @param x `Classification` object.\n#' @param what Character vector: What to plot. \"training\", \"validation\", \"test\"\n#' @param xlab Optional Character: x axis label. If NULL, will be generated automatically.\n#' @param theme `Theme` object.\n#' @param ... Additional arguments passed to the plotting function.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(plot_true_pred, Classification) <- function(\n x,\n what = NULL,\n xlab = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n ...\n) {\n if (is.null(what)) {\n if (!is.null(x@metrics_test)) {\n what <- \"test\"\n } else if (!is.null(x@metrics_validation)) {\n what <- \"validation\"\n } else {\n what <- \"training\"\n }\n }\n .confmat <- if (what == \"training\") {\n x@metrics_training\n } else if (what == \"validation\") {\n x@metrics_validation\n } else if (what == \"test\") {\n x@metrics_test\n }\n if (is.null(xlab)) {\n xlab <- labelify(paste(\"Predicted\", what))\n }\n draw_confusion(\n .confmat,\n theme = theme,\n xlab = xlab,\n ...\n )\n} # /rtemis::plot_true_pred.Classification\n\n\n# %% plot_roc.Classification ----\nmethod(plot_roc, Classification) <- function(\n x,\n what = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n filename = NULL,\n ...\n) {\n if (is.null(x@predicted_prob_training)) {\n msg(highlight2(\"No predicted probabilities available.\"))\n return(invisible())\n }\n if (is.null(what)) {\n what <- if (!is.null(x@metrics_test)) {\n c(\"training\", \"test\")\n } else {\n \"training\"\n }\n }\n labelsl <- probl <- list()\n\n if (\"training\" %in% what) {\n labelsl[[\"Training\"]] <- x@y_training\n probl[[\"Training\"]] <- x@predicted_prob_training\n }\n if (\"test\" %in% what && !is.null(x@predicted_prob_test)) {\n labelsl[[\"Test\"]] <- x@y_test\n probl[[\"Test\"]] <- x@predicted_prob_test\n }\n\n draw_roc(\n true_labels = labelsl,\n predicted_prob = probl,\n theme = theme,\n palette = palette,\n legend_title = \"Sample (AUC)\",\n filename = filename,\n ...\n )\n} # /rtemis::plot_ROC.Classification\n\n\n# %% make_Supervised ----\nmake_Supervised <- function(\n algorithm = NULL,\n model = NULL,\n preprocessor = NULL,\n preprocessor_internal = NULL,\n hyperparameters = NULL,\n tuner = NULL,\n execution_config,\n y_training = NULL,\n y_validation = NULL,\n y_test = NULL,\n predicted_training = NULL,\n predicted_validation = NULL,\n predicted_test = NULL,\n predicted_prob_training = NULL,\n predicted_prob_validation = NULL,\n predicted_prob_test = NULL,\n se_training = NULL,\n se_validation = NULL,\n se_test = NULL,\n xnames = character(),\n varimp = NULL,\n question = character(),\n extra = NULL,\n binclasspos = 2L\n) {\n # Supervised ----\n if (is.factor(y_training)) {\n Classification(\n algorithm = algorithm,\n model = model,\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner = tuner,\n execution_config = execution_config,\n y_training = y_training,\n y_validation = y_validation,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_validation = predicted_validation,\n predicted_test = predicted_test,\n predicted_prob_training = predicted_prob_training,\n predicted_prob_validation = predicted_prob_validation,\n predicted_prob_test = predicted_prob_test,\n xnames = xnames,\n varimp = varimp,\n question = question,\n extra = extra,\n binclasspos = binclasspos\n )\n } else {\n Regression(\n algorithm = algorithm,\n model = model,\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner = tuner,\n execution_config = execution_config,\n y_training = y_training,\n y_validation = y_validation,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_validation = predicted_validation,\n predicted_test = predicted_test,\n se_training = se_training,\n se_validation = se_validation,\n se_test = se_test,\n xnames = xnames,\n varimp = varimp,\n question = question,\n extra = extra\n )\n }\n} # /rtemis::make_Supervised\n\n\n# %% write_Supervised ----\nwrite_Supervised <- function(\n object,\n outdir = NULL,\n save_mod = FALSE,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n verbosity = 1L\n) {\n if (verbosity > 0L) {\n print(object)\n }\n\n if (save_mod) {\n rt_save(object, outdir, verbosity = verbosity)\n }\n} # /rtemis::write_Supervised\n\n\n# %% present.Regression ----\n# present method for Regression objects\n# Plot training + test metrics, if available, side by side using `plotly::subplot()`\n# & run `describe()` on the object\nmethod(present, Regression) <- function(\n x,\n what = c(\"training\", \"test\"),\n theme = choose_theme(getOption(\"rtemis_theme\")),\n filename = NULL,\n ...\n) {\n # Describe the model\n describe(x)\n # Plot True vs. Predicted\n plot_true_pred(\n x,\n what = what,\n theme = theme,\n filename = filename,\n ...\n )\n} # /rtemis::present.Regression\n\n\n# %% present.Classification ----\n# present method for Classification objects\n# Plot training + test metrics if available, side by side\nmethod(present, Classification) <- function(\n x,\n what = c(\"training\", \"test\"),\n type = c(\"ROC\", \"confusion\"),\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n filename = NULL,\n ...\n) {\n type <- match.arg(type)\n\n # Describe the model\n describe(x)\n\n if (type == \"ROC\") {\n plot_roc(\n x,\n what = what,\n theme = theme,\n palette = palette,\n filename = filename\n )\n } else if (type == \"confusion\") {\n # Training set plot\n if (\"training\" %in% what) {\n plot_training <- plot_true_pred(\n x,\n what = \"training\",\n theme = theme,\n xlab = \"Predicted Training\"\n )\n } else {\n plot_training <- NULL\n }\n # Test set plot\n if (\"test\" %in% what && !is.null(x@y_test)) {\n plot_test <- plot_true_pred(\n x,\n what = \"test\",\n theme = theme,\n xlab = \"Predicted Test\"\n )\n } else {\n plot_test <- NULL\n }\n\n # Combined plot\n # classification: confusion matrices side by side\n plotly::subplot(\n plot_training,\n plot_test,\n nrows = 1L,\n shareX = FALSE,\n shareY = FALSE,\n titleX = TRUE,\n titleY = TRUE,\n margin = 0.01\n )\n }\n} # /rtemis::present.Classification\n\n\n# %% SupervisedRes ----\n# fields metrics_training/metrics_validation/metrics_test\n# could be active bindings that are collected from @models\n#' SupervisedRes\n#'\n#' @description\n#' Superclass for Resampled supervised learning models.\n#'\n#' @author EDG\n#' @noRd\nSupervisedRes <- new_class(\n name = \"SupervisedRes\",\n properties = list(\n algorithm = class_character,\n models = class_list,\n type = class_character,\n preprocessor = Preprocessor | NULL,\n preprocessor_internal = Preprocessor | NULL,\n hyperparameters = Hyperparameters | NULL,\n tuner_config = TunerConfig | NULL,\n outer_resampler = Resampler,\n execution_config = ExecutionConfig,\n y_training = class_any,\n y_test = class_any,\n predicted_training = class_any,\n predicted_test = class_any,\n metrics_training = MetricsRes,\n metrics_test = MetricsRes,\n xnames = class_character,\n varimp = class_list | NULL,\n question = class_character | NULL,\n extra = class_any,\n session_info = class_any\n ),\n constructor = function(\n algorithm,\n models,\n type,\n preprocessor,\n preprocessor_internal,\n hyperparameters,\n tuner_config,\n outer_resampler,\n execution_config,\n y_training,\n y_test,\n predicted_training,\n predicted_test,\n metrics_training,\n metrics_test,\n metrics_training_mean,\n metrics_test_mean,\n xnames,\n varimp,\n question,\n extra\n ) {\n new_object(\n S7::S7_object(),\n algorithm = algorithm,\n models = models,\n type = models[[1]]@type,\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n outer_resampler = outer_resampler,\n execution_config = execution_config,\n y_training = y_training,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_test = predicted_test,\n metrics_training = metrics_training,\n metrics_test = metrics_test,\n # metrics_training_mean = metrics_training_mean,\n # metrics_test_mean = metrics_test_mean,\n xnames = xnames,\n varimp = varimp,\n question = question,\n extra = extra,\n session_info = sessionInfo()\n )\n }\n) # /rtemis::SupervisedRes\n\n\n# %% repr.SupervisedRes ----\n#' repr `SupervisedRes`\n#'\n#' @param x `SupervisedRes` object.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#' @param filename Character: Filename to save output to (not used).\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nmethod(repr, SupervisedRes) <- function(\n x,\n output_type = NULL,\n filename = NULL\n) {\n output_type <- get_output_type(output_type, filename)\n\n # Class name + Alg name (2 lines)\n out <- paste0(\n repr_S7name(paste(\"Resampled\", x@type, \"Model\"), output_type = output_type),\n highlight(x@algorithm, output_type = output_type),\n \" (\",\n desc_alg(x@algorithm),\n \")\\n\"\n )\n\n # Tuning, if available (1 line)\n if (!is.null(x@tuner_config)) {\n out <- paste0(\n out,\n fmt(\"\\U2699\", col = col_tuner, bold = TRUE, output_type = output_type),\n \" Tuned using \",\n desc(x@tuner_config),\n \".\\n\"\n )\n }\n\n # Outer resampling (1 line)\n out <- paste0(\n out,\n fmt(\"\\U27F3\", col = col_outer, bold = TRUE, output_type = output_type),\n \" Tested using \",\n desc(x@outer_resampler),\n \".\\n\"\n )\n\n # Calibration, if available\n if (prop_exists(x, \"calibration_models\")) {\n out <- paste0(\n out,\n fmt(\n \"\\U27CB\",\n col = col_calibrator,\n bold = TRUE,\n output_type = output_type\n ),\n \" Calibrated using \",\n desc_alg(x@calibration_models[[1]]@algorithm),\n \" with \",\n desc(x@calibration_models[[1]]@outer_resampler@config),\n \".\\n\"\n )\n }\n\n out <- paste0(out, \"\\n\")\n\n # Metrics, training\n if (prop_exists(x, \"calibration_models\")) {\n out <- paste0(\n out,\n repr_CalibratedClassificationResMetrics(\n x@metrics_training,\n x@metrics_training_calibrated,\n pad = 2L,\n output_type = output_type\n )\n )\n } else {\n out <- paste0(\n out,\n repr(x@metrics_training, pad = 2L, output_type = output_type)\n )\n }\n\n # Metrics, test\n if (prop_exists(x, \"calibration_models\")) {\n out <- paste0(\n out,\n \"\\n\",\n repr_CalibratedClassificationResMetrics(\n x@metrics_test,\n x@metrics_test_calibrated,\n pad = 2L,\n output_type = output_type\n )\n )\n } else {\n out <- paste0(\n out,\n \"\\n\",\n repr(x@metrics_test, pad = 2L, output_type = output_type)\n )\n }\n\n out\n} # /rtemis::repr.SupervisedRes\n\n\n# %% to_json.SupervisedRes ----\n#' to_json `SupervisedRes`\n#'\n#' Convert a `SupervisedRes` (or `RegressionRes` / `ClassificationRes`)\n#' object to a JSON-serializable list. The list of per-resample fitted\n#' models (`@models`) is summarised by length only — individual model\n#' details remain available on the server and can be fetched via\n#' separate `job.result` requests if needed.\n#'\n#' @param x `SupervisedRes` object.\n#'\n#' @return Named list. Pass to `jsonlite::toJSON(auto_unbox = TRUE)`.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(to_json, SupervisedRes) <- function(x, ...) {\n out <- list(\n .class = S7_class(x)@name,\n algorithm = x@algorithm,\n type = x@type,\n question = x@question,\n xnames = x@xnames,\n n_features = length(x@xnames),\n n_resamples = length(x@models),\n preprocessor = .to_json_value(x@preprocessor),\n preprocessor_internal = .to_json_value(x@preprocessor_internal),\n hyperparameters = .to_json_value(x@hyperparameters),\n tuner_config = .to_json_value(x@tuner_config),\n outer_resampler = .to_json_value(x@outer_resampler),\n execution_config = .to_json_value(x@execution_config),\n metrics_training = .to_json_value(x@metrics_training),\n metrics_test = .to_json_value(x@metrics_test),\n # varimp is `class_list | NULL` of VariableImportance.\n # `.to_json_value` recurses through lists, dispatching `to_json` on\n # S7 elements and passing through anything else.\n varimp_per_resample = .to_json_value(x@varimp)\n )\n\n Filter(Negate(is.null), out)\n} # /rtemis::to_json.SupervisedRes\n\n\n# %% print.SupervisedRes ----\nmethod(print, SupervisedRes) <- function(\n x,\n output_type = NULL,\n ...\n) {\n cat(repr(x, output_type = output_type))\n invisible(x)\n} # /rtemis::print.SupervisedRes\n\n\n# %% predict.SupervisedRes ----\n#' Predict SupervisedRes\n#'\n#' Predict Method for SupervisedRes objects\n#'\n#' @param object `SupervisedRes` object.\n#' @param newdata data.frame or similar: New data to predict.\n#' @param type Character: Type of prediction to output: \"avg\" applies `avg_fn` (default \"mean\") to\n#' the predictions of individual models, \"all\" returns the predictions of all models in a\n#' data.frame. \"metrics\" returns a list of data.frames with a) predictions from each model, b)\n#' the mean of the predictions, and c) the standard deviation of the predictions.\n#' @param ... Not used.\n#'\n#' @keywords internal\n#' @noRd\nmethod(predict, SupervisedRes) <- function(\n object,\n newdata,\n type = c(\"avg\", \"all\", \"metrics\"),\n avg_fn = \"mean\",\n ...\n) {\n check_inherits(newdata, \"data.frame\")\n type <- match.arg(type)\n\n predicted <- sapply(\n object@models,\n function(mod) {\n predict(mod, newdata = newdata)\n }\n ) # -> data.frame n cases x n resamples\n\n if (type == \"all\") {\n return(predicted)\n } else if (type == \"avg\") {\n return(apply(predicted, 1, avg_fn))\n } else if (type == \"metrics\") {\n mean_predictions <- apply(predicted, 2, mean)\n sd_predictions <- apply(predicted, 2, sd)\n return(list(\n predictions = predicted,\n mean = mean_predictions,\n sd = sd_predictions\n ))\n }\n} # /rtemis::predict.SupervisedRes\n\n\n# %% ClassificationRes ----\n#' @title ClassificationRes\n#'\n#' @description\n#' SupervisedRes subclass for Resampled classification models.\n#'\n#' @author EDG\n#' @noRd\nClassificationRes <- new_class(\n name = \"ClassificationRes\",\n parent = SupervisedRes,\n properties = list(\n predicted_prob_training = class_any,\n predicted_prob_test = class_any\n ),\n constructor = function(\n algorithm,\n models,\n preprocessor,\n preprocessor_internal = NULL,\n hyperparameters,\n tuner_config,\n outer_resampler,\n execution_config,\n y_training,\n y_validation = NULL,\n y_test = NULL,\n predicted_training = NULL,\n predicted_test = NULL,\n predicted_prob_training = NULL,\n predicted_prob_test = NULL,\n xnames = NULL,\n varimp = NULL,\n question = NULL,\n extra = NULL\n ) {\n metrics_training <- ClassificationMetricsRes(\n sample = \"Training\",\n res_metrics = lapply(models, function(mod) mod@metrics_training)\n )\n metrics_test <- ClassificationMetricsRes(\n sample = \"Test\",\n res_metrics = lapply(models, function(mod) mod@metrics_test)\n )\n new_object(\n SupervisedRes(\n algorithm = algorithm,\n models = models,\n type = \"Classification\",\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n outer_resampler = outer_resampler,\n execution_config = execution_config,\n y_training = y_training,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_test = predicted_test,\n metrics_training = metrics_training,\n metrics_test = metrics_test,\n # metrics_training_mean = metrics_training_mean,\n # metrics_test_mean = metrics_test_mean,\n xnames = xnames,\n varimp = varimp,\n question = question,\n extra = extra\n ),\n predicted_prob_training = predicted_prob_training,\n predicted_prob_test = predicted_prob_test\n )\n }\n) # /rtemis::ClassificationRes\n\n\n# %% CalibratedClassificationRes ----\n#' @title CalibratedClassificationRes\n#'\n#' @description\n#' ClassificationRes subclass for calibrated classification models.\n#' The calibration models are trained on resamples of the `ClassificationRes`'s test data.\n#'\n#' @author EDG\n#' @noRd\n# We use getter functions to avoid duplicating data\nCalibratedClassificationRes <- new_class(\n name = \"CalibratedClassificationRes\",\n parent = ClassificationRes,\n properties = list(\n calibration_models = class_list,\n predicted_training_calibrated = new_property(\n getter = function(self) {\n lapply(self@calibration_models, function(mod) {\n mod@predicted_training\n })\n }\n ),\n predicted_test_calibrated = new_property(\n getter = function(self) {\n lapply(self@calibration_models, function(mod) {\n mod@predicted_test\n })\n }\n ),\n predicted_prob_training_calibrated = new_property(\n getter = function(self) {\n lapply(self@calibration_models, function(mod) {\n mod@predicted_prob_training\n })\n }\n ),\n predicted_prob_test_calibrated = new_property(\n getter = function(self) {\n lapply(self@calibration_models, function(mod) {\n mod@predicted_prob_test\n })\n }\n ),\n metrics_training_calibrated = ClassificationMetricsRes,\n metrics_test_calibrated = ClassificationMetricsRes\n ),\n constructor = function(ClassificationRes_model, calibrations_models) {\n # Aggregate calibrated metrics from individual models within each calibration resample\n # calibrations_models is a list of *Res objects, each containing multiple models\n # We need to extract all individual model metrics and aggregate them\n all_training_metrics <- unlist(\n lapply(calibrations_models, function(calmod) {\n calmod@metrics_training@res_metrics\n }),\n recursive = FALSE\n )\n all_test_metrics <- unlist(\n lapply(calibrations_models, function(calmod) {\n calmod@metrics_test@res_metrics\n }),\n recursive = FALSE\n )\n\n metrics_training_calibrated <- ClassificationMetricsRes(\n sample = \"Training\",\n res_metrics = all_training_metrics\n )\n metrics_test_calibrated <- ClassificationMetricsRes(\n sample = \"Test\",\n res_metrics = all_test_metrics\n )\n\n new_object(\n ClassificationRes_model,\n calibration_models = calibrations_models,\n metrics_training_calibrated = metrics_training_calibrated,\n metrics_test_calibrated = metrics_test_calibrated\n )\n }\n) # /rtemis::CalibratedClassificationRes\n\n\n# %% predict.CalibratedClassificationRes ----\nmethod(predict, CalibratedClassificationRes) <- function(\n object,\n newdata,\n what = c(\"avg\", \"all\", \"metrics\"),\n avg_fn = \"mean\",\n ...\n) {\n check_inherits(newdata, \"data.frame\")\n what <- match.arg(what)\n\n # Check lengths match\n if (length(object@models) != length(object@calibration_models)) {\n cli::cli_abort(\"Number of base models and calibration models must match.\")\n }\n\n predicted <- mapply(\n function(base_mod, cal_mod) {\n # 1. Predict with base model\n raw_prob <- predict(\n base_mod,\n newdata = newdata\n )\n\n # 2. Predict with calibration model\n predict(\n cal_mod,\n newdata = data.frame(predicted_probabilities = raw_prob)\n )\n },\n object@models,\n object@calibration_models,\n SIMPLIFY = TRUE\n ) # -> matrix n cases x n resamples\n\n if (what == \"all\") {\n return(predicted)\n } else if (what == \"avg\") {\n return(apply(predicted, 1, avg_fn))\n } else if (what == \"metrics\") {\n mean_predictions <- apply(predicted, 2, mean)\n sd_predictions <- apply(predicted, 2, sd)\n # Return both aggregated prediction metrics (per resample)\n # Keeping consistent with SupervisedRes\n return(list(\n predictions = predicted,\n mean = mean_predictions,\n sd = sd_predictions\n ))\n }\n} # /rtemis::predict.CalibratedClassificationRes\n\n\n# %% RegressionRes ----\n#' @title RegressionRes\n#'\n#' @description\n#' SupervisedRes subclass for Resampled regression models.\n#'\n#' @author EDG\n#' @noRd\nRegressionRes <- new_class(\n name = \"RegressionRes\",\n parent = SupervisedRes,\n properties = list(\n se_training = class_any,\n se_validation = class_any,\n se_test = class_any\n ),\n constructor = function(\n algorithm,\n models,\n preprocessor,\n preprocessor_internal,\n hyperparameters,\n tuner_config,\n outer_resampler,\n execution_config,\n y_training,\n y_validation = NULL,\n y_test = NULL,\n predicted_training = NULL,\n predicted_test = NULL,\n se_training = NULL,\n se_test = NULL,\n xnames = NULL,\n varimp = NULL,\n question = NULL,\n extra = NULL\n ) {\n metrics_training <- lapply(\n models,\n function(mod) mod@metrics_training@metrics\n )\n metrics_test <- lapply(models, function(mod) mod@metrics_test@metrics)\n metrics_training <- RegressionMetricsRes(\n sample = \"Training\",\n res_metrics = lapply(models, function(mod) mod@metrics_training)\n )\n metrics_test <- RegressionMetricsRes(\n sample = \"Test\",\n res_metrics = lapply(models, function(mod) mod@metrics_test)\n )\n new_object(\n SupervisedRes(\n algorithm = algorithm,\n models = models,\n type = \"Regression\",\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n outer_resampler = outer_resampler,\n execution_config = execution_config,\n y_training = y_training,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_test = predicted_test,\n metrics_training = metrics_training,\n metrics_test = metrics_test,\n # metrics_training_mean = metrics_training_mean,\n # metrics_test_mean = metrics_test_mean,\n xnames = xnames,\n varimp = varimp,\n question = question,\n extra = extra\n ),\n se_training = se_training,\n se_test = se_test\n )\n }\n) # /rtemis::RegressionRes\n\n\n# %% desc.SupervisedRes ----\nmethod(desc, SupervisedRes) <- function(x, metric = NULL) {\n type <- x@type\n algorithm <- desc_alg(x@algorithm)\n # cat(algorithm, \" was used for \", tolower(type), \".\\n\", sep = \"\")\n out <- paste0(algorithm, \" was used for \", tolower(type), \".\")\n\n # Tuning ----\n if (length(x@tuner_config) > 0) {\n out <- paste0(\n out,\n \" Hyperparameter tuning was performed using \",\n desc(x@tuner_config),\n \".\"\n )\n }\n\n # Metrics ----\n if (type == \"Classification\") {\n if (is.null(metric)) {\n metric <- \"Balanced_Accuracy\"\n }\n out <- paste(\n out,\n \"Mean\",\n labelify(metric, toLower = TRUE),\n \"was\",\n ddSci(x@metrics_training@mean_metrics[[\"Balanced_Accuracy\"]]),\n \"in the training set and\",\n ddSci(x@metrics_test@mean_metrics[[\"Balanced_Accuracy\"]]),\n \"in the test set across \"\n )\n } else if (type == \"Regression\") {\n out <- paste(\n out,\n \"Mean R-squared was\",\n ddSci(x@metrics_training@mean_metrics[[\"Rsq\"]]),\n \"on the training set and\",\n ddSci(x@metrics_test@mean_metrics[[\"Rsq\"]]),\n \"on the test set across \"\n )\n }\n out <- paste0(out, desc(x@outer_resampler), \".\")\n invisible(out)\n} # /rtemis::desc.SupervisedRes\n\n\n# %% describe.SupervisedRes ----\n#' Describe `SupervisedRes`\n#'\n#' @param x `SupervisedRes` object.\n#' @param ... Not used.\n#'\n#' @return Character string describing the `SupervisedRes` object, invisibly.\n#'\n#' @author EDG\n#' @noRd\n#'\n#' @examples\n#' mod <- train(iris, algorithm = \"CART\", outer_resampling_config = setup_Resampler())\n#' describe(mod)\nmethod(describe, SupervisedRes) <- function(x, ...) {\n cat(desc(x), \"\\n\")\n}\n\n\n# %% present.SupervisedRes ----\nmethod(present, SupervisedRes) <- function(\n x,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n ...\n) {\n # Describe the model\n describe(x)\n # Plot the performance metrics\n plot_metric(x, what = c(\"training\", \"test\"), theme = theme, ...)\n} # /rtemis::present.SupervisedRes\n\n\n# %% plot_true_pred.RegressionRes ----\n# Plot true vs. predicted aggregated across resamples for either training, test, or both.\n#' Plot True vs. Predicted for RegressionRes\n#'\n#' @param x `RegressionRes` object.\n#' @param what Character vector: \"all\", \"training\", \"test\". Which set(s) to plot.\n#' @param fit Character: Algorithm to use to draw fit line.\n#' @param theme `Theme` object.\n#' @param labelify Logical: If TRUE, labelify the axis labels.\n#' @param ... Additional arguments passed to [draw_fit].\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(plot_true_pred, RegressionRes) <- function(\n x,\n what = \"all\",\n fit = \"glm\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n labelify = TRUE,\n ...\n) {\n if (length(what) == 1 && what == \"all\") {\n what <- c(\"training\", \"test\")\n }\n true <- paste0(\"y_\", what)\n true_l <- sapply(true, function(z) {\n unlist(prop(x, z), use.names = FALSE)\n })\n\n predicted <- paste0(\"predicted_\", what)\n predicted_l <- sapply(predicted, function(z) {\n unlist(prop(x, z), use.names = FALSE)\n })\n if (labelify) {\n names(predicted_l) <- labelify(names(predicted_l))\n }\n draw_fit(\n x = true_l,\n y = predicted_l,\n fit = fit,\n theme = theme,\n ...\n )\n} # /rtemis::plot_true_pred.RegressionRes\n\n\n# %% plot_true_pred.ClassificationRes ----\n# Cannot be combined with plot_true_pred.RegressionRes\n# because scatter can overplot train & test, but confusion matrices must be subplots.\n#' Plot True vs. Predicted for ClassificationRes\n#'\n#' @param x `ClassificationRes` object.\n#' @param what Character vector: \"all\", \"training\", \"test\". Which set(s) to plot.\n#' @param theme `Theme` object.\n#' @param ... Additional arguments passed to [draw_confusion].\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(plot_true_pred, ClassificationRes) <- function(\n x,\n what = \"all\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n ...\n) {\n if (length(what) == 1 && what == \"all\") {\n what <- c(\"training\", \"test\")\n }\n true <- paste0(\"y_\", what)\n true_l <- sapply(true, function(z) {\n unlist(prop(x, z), use.names = FALSE)\n })\n\n predicted <- paste0(\"predicted_\", what)\n predicted_l <- sapply(predicted, function(z) {\n unlist(prop(x, z), use.names = FALSE)\n })\n # if (labelify) {\n # names(predicted_l) <- labelify(names(predicted_l))\n # }\n # => Do not pass filename to both training & testing, latter will overwrite; pass to subplot if\n # plotting both\n # Training\n if (\"training\" %in% what) {\n plt_training <- draw_confusion(\n table(true_l[[\"y_training\"]], predicted_l[[\"predicted_training\"]]),\n xlab = \"Predicted Training\",\n theme = theme,\n ...\n )\n }\n if (\"test\" %in% what) {\n plt_test <- draw_confusion(\n table(true_l[[\"y_test\"]], predicted_l[[\"predicted_test\"]]),\n xlab = \"Predicted Test\",\n theme = theme,\n ...\n )\n }\n\n if (length(what) == 1) {\n if (what == \"training\") {\n return(plt_training)\n } else {\n return(plt_test)\n }\n } else {\n return(plotly::subplot(\n plt_training,\n plt_test,\n nrows = 1L,\n shareX = FALSE,\n shareY = FALSE\n ))\n }\n} # /rtemis::plot_true_pred.ClassificationRes\n\n\n# %% plot_roc.ClassificationRes ----\n#' Plot ROC for ClassificationRes\n#'\n#' @param x `ClassificationRes` object.\n#' @param what Character vector: \"all\", \"training\", \"test\". Which set(s) to plot.\n#' @param theme `Theme` object.\n#' @param col Character vector: Colors to use for the ROC curves.\n#' @param filename Character: Filename to save the plot to.\n#' @param ... Additional arguments passed to [draw_roc].\n#'\n#' @return plotly object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(plot_roc, ClassificationRes) <- function(\n x,\n what = \"all\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n filename = NULL,\n ...\n) {\n if (length(what) == 1 && what == \"all\") {\n what <- c(\"training\", \"test\")\n }\n labelsl <- probl <- list()\n\n if (\"training\" %in% what) {\n labelsl[[\"Training\"]] <- unlist(x@y_training, use.names = FALSE)\n probl[[\"Training\"]] <- unlist(x@predicted_prob_training, use.names = FALSE)\n }\n if (\"test\" %in% what && !is.null(x@predicted_prob_test)) {\n labelsl[[\"Test\"]] <- unlist(x@y_test, use.names = FALSE)\n probl[[\"Test\"]] <- unlist(x@predicted_prob_test, use.names = FALSE)\n }\n\n draw_roc(\n true_labels = labelsl,\n predicted_prob = probl,\n theme = theme,\n palette = palette,\n legend_title = \"Sample (AUC)\",\n filename = filename,\n ...\n )\n} # /rtemis::plot_roc.ClassificationRes\n\n\n# %% plot_metric.SupervisedRes ----\n#' Plot Metric SupervisedRes\n#'\n#' Plot boxplot of performance metrics across resamples.\n#'\n#' @param x `SupervisedRes` object.\n#' @param what Character vector: \"training\", \"test\". What to print. Default is to print both.\n#' @param metric Character: Metric to plot.\n#' @param ylab Character: Label for the y-axis.\n#' @param boxpoints Character:\"all\", \"outliers\" - How to display points in the boxplot.\n#' @param theme `Theme` object.\n#' @param ... Additional arguments passed to the plotting function.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(plot_metric, SupervisedRes) <- function(\n x,\n what = c(\"training\", \"test\"),\n metric = NULL,\n ylab = labelify(metric),\n boxpoints = \"all\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n ...\n) {\n what <- match.arg(what, several.ok = TRUE)\n .class <- x@type == \"Classification\"\n\n # Metric\n if (is.null(metric)) {\n if (.class) {\n metric <- \"Balanced_Accuracy\"\n } else {\n metric <- \"Rsq\"\n }\n }\n\n xl <- list()\n if (\"training\" %in% what) {\n if (.class) {\n xl[[\"Training\"]] <- sapply(\n x@metrics_training@res_metrics,\n function(fold) {\n fold[[\"Overall\"]][[metric]]\n }\n )\n } else {\n xl[[\"Training\"]] <- sapply(\n x@metrics_training@res_metrics,\n function(fold) {\n fold[[metric]]\n }\n )\n }\n }\n if (\"test\" %in% what) {\n if (.class) {\n xl[[\"Test\"]] <- sapply(x@metrics_test@res_metrics, function(fold) {\n fold[[\"Overall\"]][[metric]]\n })\n } else {\n xl[[\"Test\"]] <- sapply(x@metrics_test@res_metrics, function(fold) {\n fold[[metric]]\n })\n }\n }\n\n # Boxplot ----\n draw_box(xl, theme = theme, ylab = ylab, boxpoints = boxpoints, ...)\n} # /rtemis::plot_metric.SupervisedRes\n\n\n# %% plot_varimp.Supervised ----\nmethod(plot_varimp, Supervised) <- function(\n x,\n measure = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n filename = NULL,\n ...\n) {\n if (is.null(x@varimp)) {\n msg(highlight2(\"No variable importance available.\"))\n return(invisible())\n }\n if (is.null(measure)) {\n vi <- x@varimp@data[[2L]]\n } else {\n vi <- x@varimp@data[[measure]]\n }\n names(vi) <- x@varimp@data[[\"variable\"]]\n draw_varimp(vi, theme = theme, filename = filename, ...)\n} # /rtemis::plot_varimp.Supervised\n\n\n# %% plot_varimp.SupervisedRes ----\nmethod(plot_varimp, SupervisedRes) <- function(\n x,\n measure = NULL,\n ylab = NULL,\n summarize_fn = \"mean\",\n show_top = 20L,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n filename = NULL,\n ...\n) {\n if (is.null(x@varimp)) {\n msg(highlight2(\"No variable importance available.\"))\n return(invisible())\n }\n check_inherits(summarize_fn, \"character\")\n\n # Extract named numeric vectors from each VariableImportance object.\n # Not every variable gets a score in every resample, so rbindlist with fill.\n varimp_list <- lapply(x@varimp, function(z) {\n vi <- if (is.null(measure)) z@data[[2L]] else z@data[[measure]]\n names(vi) <- z@data[[\"variable\"]]\n as.data.table(as.list(vi))\n })\n\n varimp <- rbindlist(varimp_list, use.names = TRUE, fill = TRUE)\n # Missing scores (variable absent in a resample) treated as 0\n setDF(varimp)\n varimp[is.na(varimp)] <- 0\n # Summarize and sort\n varimp_summary <- apply(varimp, 2, summarize_fn)\n varimp_sorted <- varimp_summary[order(-varimp_summary)]\n if (length(varimp_sorted) > show_top) {\n varimp_sorted <- varimp_sorted[seq_len(show_top)]\n }\n # ylab\n if (is.null(ylab)) {\n measure_name <- if (is.null(measure)) {\n names(x@varimp[[1L]]@data)[2L]\n } else {\n measure\n }\n ylab <- paste0(\n labelify(paste(summarize_fn, measure_name)),\n \"\\n(across \",\n desc(x@outer_resampler),\n \")\"\n )\n }\n draw_varimp(\n varimp_sorted,\n theme = theme,\n ylab = ylab,\n filename = filename,\n ...\n )\n} # /rtemis::plot_varimp.SupervisedRes\n\n\n# %% make_SupervisedRes ----\n#' Make SupervisedRes\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmake_SupervisedRes <- function(\n algorithm,\n type,\n models,\n preprocessor,\n preprocessor_internal,\n hyperparameters,\n tuner_config,\n outer_resampler,\n execution_config,\n y_training,\n y_test,\n predicted_training,\n predicted_test,\n predicted_prob_training,\n predicted_prob_test,\n se_training = NULL,\n se_test = NULL,\n xnames = character(),\n varimp = NULL,\n question = character(),\n extra = NULL\n) {\n if (type == \"Classification\") {\n ClassificationRes(\n algorithm = algorithm,\n models = models,\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n outer_resampler = outer_resampler,\n execution_config = execution_config,\n y_training = y_training,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_test = predicted_test,\n predicted_prob_training = predicted_prob_training,\n predicted_prob_test = predicted_prob_test,\n xnames = xnames,\n varimp = varimp,\n question = question,\n extra = extra\n )\n } else {\n RegressionRes(\n algorithm = algorithm,\n models = models,\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n outer_resampler = outer_resampler,\n execution_config = execution_config,\n y_training = y_training,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_test = predicted_test,\n se_training = se_training,\n se_test = se_test,\n xnames = xnames,\n varimp = varimp,\n question = question,\n extra = extra\n )\n }\n} # /rtemis::make_SupervisedRes\n\nearly_stopping_algs <- c(\"LightGBM\", \"LightRF\", \"LightRuleFit\")\n\n\n# LightRuleFit ----\n#' @title LightRuleFit\n#'\n#' @description\n#' Class for LightRuleFit models.\n#'\n#' @author EDG\n#' @noRd\nLightRuleFit <- new_class(\n name = \"LightRuleFit\",\n properties = list(\n model_lightgbm = Supervised,\n model_glmnet = Supervised,\n rules = class_character,\n rules_coefs = class_data.frame,\n rules_index = class_integer,\n rules_selected = class_character,\n rules_selected_formatted = class_character,\n rules_selected_formatted_coefs = class_data.frame,\n y_levels = class_character | NULL,\n xnames = class_character,\n complexity_metrics = class_data.frame\n )\n) # /rtemis::LightRuleFit\n\n# Print LightRuleFit ----\nmethod(print, LightRuleFit) <- function(x, ...) {\n objcat(\"rtemis LightRuleFit Model\")\n cat(\n \"Trained using \",\n highlight(x@model_lightgbm@algorithm),\n \" and \",\n highlight(x@model_glmnet@algorithm),\n \".\\n\",\n sep = \"\"\n )\n cat(\"Selected\", highlight(length(x@rules_selected)), \"rules.\\n\")\n invisible(x)\n} # /rtemis::print.LightRuleFit\n\n\n# get_metric Regression ----\nmethod(get_metric, Regression) <- function(x, set, metric) {\n prop(prop(x, paste0(\"metrics_\", set)), \"metrics\")[[metric]]\n} # /get_metric.Regression\n\n# get_metric Classification ----\nmethod(get_metric, Classification) <- function(x, set, metric) {\n prop(prop(x, paste0(\"metrics_\", set)), \"metrics\")[[\"Overall\"]][[metric]]\n} # /get_metric.Classification\n\n# get_metric RegressionRes ----\nmethod(get_metric, RegressionRes) <- function(x, set, metric) {\n sapply(\n prop(prop(x, paste0(\"metrics_\", set)), \"res_metrics\"),\n function(r) {\n r[[metric]]\n }\n )\n} # /rtemis::get_metric.RegressionRes\n\n# get_metric ClassificationRes ----\nmethod(get_metric, ClassificationRes) <- function(x, set, metric) {\n sapply(\n prop(prop(x, paste0(\"metrics_\", set)), \"res_metrics\"),\n function(r) {\n r[[\"Overall\"]][[metric]]\n }\n )\n} # /rtemis::get_metric.ClassificationRes\n\n\n# Describe list of Supervised/Res ----\n#' Describe multiple Supervised or SupervisedRes objects\n#'\n#' @param x List of `Supervised` or `SupervisedRes` objects.\n#' @param metric Character: Metric to use for description. Default is NULL, which uses \"Balanced_Accuracy\" for Classification and \"Rsq\" for Regression.\n#' @param decimal_places Integer: Number of decimal places to round metrics to.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nmethod(desc, class_list) <- function(\n x,\n metric = NULL,\n decimal_places = 3L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n # Check all elements are Supervised or all are SupervisedRes objects\n if (\n !all(sapply(x, S7_inherits, Supervised)) &&\n !all(sapply(x, S7_inherits, SupervisedRes))\n ) {\n cli::cli_abort(\n \"All elements must be either Supervised or SupervisedRes objects\"\n )\n }\n type <- if (S7_inherits(x[[1]], SupervisedRes)) {\n \"SupervisedRes\"\n } else {\n \"Supervised\"\n }\n\n # Check that all models are of the same type\n if (!all(sapply(x, function(m) m@type == x[[1]]@type))) {\n cli::cli_abort(\n \"All objects must be of the same supervised learning type (Classification or Regression).\"\n )\n }\n\n # Name list using algorithm names\n if (is.null(names(x))) {\n names(x) <- sapply(x, function(m) m@algorithm)\n }\n suptype <- x[[1]]@type\n\n # SupervisedRes\n if (type == \"SupervisedRes\") {\n # Check that the same resampling method was used - ideally same seed, but do not enforce that, but report it\n # Get resampling config from each\n res_params <- lapply(x, function(m) m@outer_resampler@config)\n # Check all resamplers of same type\n if (!all(sapply(res_params, function(p) p@type == res_params[[1]]@type))) {\n cli::cli_warn(\n \"All SupervisedRes objects must use the same resampling method.\"\n )\n }\n # ?replace with loop that checks all resampler params\n # Check all resamplers use same n\n if (!all(sapply(res_params, function(p) p@n == res_params[[1]]@n))) {\n cli::cli_warn(\n \"All SupervisedRes objects must use the same number of resamples.\"\n )\n }\n\n # Describe SupervisedRes objects\n # 1. Report names of algorithms used.\n out <- paste0(\n oxfordcomma(sapply(x, function(m) desc_abb_alg(m@algorithm))),\n \" were used for \",\n suptype,\n \".\\n\"\n )\n # 2. Get metric\n if (is.null(metric)) {\n metric <- if (suptype == \"Classification\") {\n \"Balanced_Accuracy\"\n } else {\n \"Rsq\"\n }\n }\n metricv <- sapply(x, function(m) m@metrics_test@mean_metrics[[metric]])\n } # /SupervisedRes\n if (type == \"Supervised\") {\n # 1. Report names of algorithms used.\n out <- paste0(\n oxfordcomma(sapply(x, function(m) desc_abb_alg(m@algorithm))),\n \" were used for \",\n suptype,\n \".\\n\"\n )\n # 2. Get metric\n if (is.null(metric)) {\n metric <- if (suptype == \"Classification\") {\n \"Balanced_Accuracy\"\n } else {\n \"Rsq\"\n }\n }\n if (suptype == \"Classification\") {\n # Classification\n metricv <- sapply(x, function(m) {\n m@metrics_test@metrics[[\"Overall\"]][[metric]]\n })\n } else {\n # Regression\n metricv <- sapply(x, function(m) m@metrics_test@metrics[[metric]])\n }\n } # /rtemis::Supervised\n\n # 3. Report mean metric across all models, sorting by performance\n metric_sorted <- sort(metricv, decreasing = TRUE)\n # => Get ties at specified decimal_places\n out <- paste0(\n out,\n \"The top-performing model was \",\n bold(names(metric_sorted)[1], output_type = output_type),\n \" with a test-set \",\n bold(labelify(metric), output_type = output_type),\n \" of \",\n bold(\n ddSci(metric_sorted[1], decimal_places = decimal_places),\n output_type = output_type\n ),\n \", followed by \",\n oxfordcomma(names(metric_sorted[-1])),\n \" with \",\n metric,\n \" of \",\n oxfordcomma(ddSci(metric_sorted[-1], decimal_places = decimal_places)),\n \" respectively.\"\n )\n out\n} # /rtemis::desc.list\n\n\n# %% describe.list(Supervised/Res) ----\n#' Print description of a list of Supervised or SupervisedRes objects\n#'\n#' @param x List of `Supervised` or `SupervisedRes` objects.\n#' @param ... See details.\n#'\n#' @details\n#' Extra arguments:\n#' - `metric`: Character: Metric to use for description. If NULL, defaults to \"Balanced_Accuracy\" for Classification and \"Rsq\" for Regression.\n#' - `decimal_places`: Integer: Number of decimal places to round metrics to.\n#' - `output_type`: Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character of description invisibly. Prints description to output.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nmethod(describe, class_list) <- function(\n x,\n metric = NULL,\n decimal_places = 3L,\n output_type = NULL,\n ...\n) {\n out <- desc(\n x,\n metric = metric,\n decimal_places = decimal_places,\n output_type = output_type\n )\n cat(out, \"\\n\")\n invisible(out)\n} # /rtemis::describe.list(Supervised/Res)\n" }, { "path": "R/08_MassUni.R", "content": "# S7_MassUni.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% MassGLM ----\n#' @title MassGLM\n#'\n#' @description\n#' Superclass for mass-univariate models.\n#'\n#' @author EDG\n#' @noRd\nMassGLM <- new_class(\n name = \"MassGLM\",\n properties = list(\n summary = class_data.table,\n ynames = class_character,\n xnames = class_character,\n coefnames = class_character,\n family = class_character\n )\n) # /rtemis::MassGLM\n\n\n# %% `$`.MassGLM ----\n# Make MassGLM@name `$`-accessible ----\nmethod(`$`, MassGLM) <- function(x, name) {\n prop(x, name)\n}\n\n\n# %% `.DollarNames`.MassGLM ----\n# `$`-autocomplete MassGLM ----\nmethod(`.DollarNames`, MassGLM) <- function(x, pattern = \"\") {\n prop_names <- names(props(x))\n grep(pattern, prop_names, value = TRUE)\n}\n\n\n# %% `[[`.MassGLM ----\n# Make MassGLM@name `[[`-accessible ----\nmethod(`[[`, MassGLM) <- function(x, name) {\n prop(x, name)\n}\n\n\n# %% repr.MassGLM ----\nmethod(repr, MassGLM) <- function(\n x,\n pad = 0L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n paste0(\n repr_S7name(\"MassGLM\", pad = pad),\n highlight(length(x@ynames)),\n \" GLMs of family \",\n bold(x@family),\n \" with \",\n highlight(length(x@xnames)),\n ngettext(length(x@xnames), \" predictor\", \" predictors\"),\n \" each.\",\n \"\\nAvailable coefficients: \",\n paste(highlight(x@coefnames), collapse = \", \"),\n \"\\n\"\n )\n} # /rtemis::repr.MassGLM\n\n\n# %% print.MassGLM ----\n#' Print MassGLM\n#'\n#' @param x MassGLM object.\n#' @param ... Not used.\n#'\n#' @return `x`, invisibly.\n#'\n#' @author EDG\n#' @noRd\nmethod(print, MassGLM) <- function(x, output_type = NULL, ...) {\n cat(repr(x, output_type = output_type))\n invisible(x)\n} # /rtemis::print.MassGLM\n\n\n# %% plot.MassGLM ----\n#' Plot MassGLM using volcano plot\n#'\n#' @param x MassGLM object trained using [massGLM].\n#' @param coefname Character: Name of coefficient to plot. If `NULL`, the first coefficient is used.\n#' @param p_adjust_method Character: \"holm\", \"hochberg\", \"hommel\", \"bonferroni\", \"BH\", \"BY\", \"fdr\", \"none\" -\n#' p-value adjustment method.\n#' @param p_transform Function to transform p-values for plotting. Default is `function(x) -log10(x)`.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param theme `Theme` object. Create using one of the `theme_` functions, e.g.\n#' `theme_whitegrid()`.\n#' @param verbosity Integer: Verbosity level.\n#' @param ... Additional arguments passed to [draw_volcano].\n#'\n#' @return plotly object with volcano plot.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' set.seed(2019)\n#' y <- rnormmat(500, 500, return_df = TRUE)\n#' x <- data.frame(x = y[, 3] + y[, 5] - y[, 9] + y[, 15] + rnorm(500))\n#' mod <- massGLM(x, y)\n#' plot(mod)\nplot.MassGLM <- method(plot, MassGLM) <- function(\n x,\n coefname = NULL,\n p_adjust_method = \"holm\",\n p_transform = function(x) -log10(x),\n xlab = \"Coefficient\",\n ylab = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n verbosity = 1L,\n ...\n) {\n if (is.null(coefname)) {\n coefname <- x@coefnames[1]\n }\n if (!coefname %in% x@coefnames) {\n cli::cli_abort(c(\n \"i\" = \"{.var coefname} must be one of available coefnames: {.strong {x@coefnames}}\",\n \"x\" = \"You asked for: {.strong {coefname}}\"\n ))\n }\n if (verbosity > 0L) {\n msg(\n \"Plotting coefficients for\",\n highlight(coefname),\n \"x\",\n length(x@ynames),\n \"outcomes.\"\n )\n }\n\n # y-axis label ----\n if (is.null(ylab)) {\n ylab <- fn2label(p_transform, \"p-value\")\n ylab <- paste(ylab, \"for\", coefname)\n if (p_adjust_method != \"none\") {\n ylab <- paste0(ylab, \" (\", labelify(p_adjust_method), \"-corrected)\")\n }\n }\n\n # Plot ----\n coefs <- x@summary[[paste0(\"Coefficient_\", coefname)]]\n pvals <- x@summary[[paste0(\"p_value_\", coefname)]]\n draw_volcano(\n x = coefs,\n pvals = pvals,\n xnames = x@ynames,\n p_adjust_method = p_adjust_method,\n p_transform = p_transform,\n theme = theme,\n xlab = xlab,\n ylab = ylab,\n ...\n )\n} # /rtemis::plot.MassGLM\n\n\n# %% plot_manhattan.MassGLM ----\n#' @name\n#' plot_manhattan\n#'\n#' @param x MassGLM object.\n#' @param coefname Character: Name of coefficient to plot. If `NULL`, the first coefficient is used.\n#' @param p_adjust_method Character: \"holm\", \"hochberg\", \"hommel\", \"bonferroni\", \"BH\", \"BY\", \"fdr\", \"none\" -\n#' p-value adjustment method.\n#' @param p_transform Function to transform p-values for plotting. Default is `function(x) -log10(x)`.\n#' @param ylab Character: y-axis label.\n#' @param theme `Theme` object.\n#' @param col_pos Character: Color for positive significant coefficients.\n#' @param col_neg Character: Color for negative significant coefficients.\n#' @param alpha Numeric: Transparency level for the bars.\n#' @param ... Additional arguments passed to [draw_bar].\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' # x: outcome of interest as first column, optional covariates in the other columns\n#' # y: features whose association with x we want to study\n#' set.seed(2022)\n#' y <- data.table(rnormmat(500, 40))\n#' x <- data.table(\n#' x1 = y[[3]] - y[[5]] + y[[14]] + rnorm(500),\n#' x2 = y[[21]] + rnorm(500)\n#' )\n#' massmod <- massGLM(x, y)\n#' plot_manhattan(massmod)\nplot_manhattan.MassGLM <- method(plot_manhattan, MassGLM) <- function(\n x,\n coefname = NULL,\n p_adjust_method = c(\n \"holm\",\n \"hochberg\",\n \"hommel\",\n \"bonferroni\",\n \"BH\",\n \"BY\",\n \"fdr\",\n \"none\"\n ),\n p_transform = function(x) -log10(x),\n ylab = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n col_pos = \"#43A4AC\",\n col_neg = \"#FA9860\",\n alpha = 0.8,\n ...\n) {\n p_adjust_method <- match.arg(p_adjust_method)\n if (is.null(coefname)) {\n coefname <- x@coefnames[1]\n }\n if (!coefname %in% x@coefnames) {\n stop(\n \"coefname must be one of the coefnames available in the MassGLM object.\"\n )\n }\n\n # y-axis label ----\n if (is.null(ylab)) {\n ylab <- fn2label(p_transform, \"p-value\")\n ylab <- paste(ylab, \"for\", coefname)\n if (p_adjust_method != \"none\") {\n ylab <- paste0(ylab, \" (\", labelify(p_adjust_method), \"-corrected)\")\n }\n }\n\n # Plot ----\n coefs <- x@summary[[paste0(\"Coefficient_\", coefname)]]\n pvals <- x@summary[[paste0(\"p_value_\", coefname)]]\n pvals <- p.adjust(pvals, method = p_adjust_method)\n signif_pos_idi <- pvals < 0.05 & coefs > 0\n signif_neg_idi <- pvals < 0.05 & coefs < 0\n col <- rep(\n adjustcolor(theme[[\"fg\"]], alpha.f = alpha),\n length(pvals)\n )\n col[signif_pos_idi] <- adjustcolor(col_pos, alpha.f = alpha)\n col[signif_neg_idi] <- adjustcolor(col_neg, alpha.f = alpha)\n\n draw_bar(\n x = p_transform(pvals),\n theme = theme,\n palette = col,\n group_names = x@ynames,\n ylab = ylab,\n ...\n )\n} # /rtemis::plot_manhattan.MassGLM\n\n\n# %% summary.MassGLM ----\nmethod(summary, MassGLM) <- function(object, ...) {\n object@summary\n} # /rtemis::summary.MassGLM\n" }, { "path": "R/09_ClusteringConfig.R", "content": "# S7_ClusteringConfig.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% ClusteringConfig ----\n#' @title ClusteringConfig\n#'\n#' @description\n#' Clustering config class.\n#'\n#' @field algorithm Character: Algorithm name.\n#' @field config List: Algorithm-specific config.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nClusteringConfig <- new_class(\n name = \"ClusteringConfig\",\n properties = list(\n algorithm = class_character,\n config = class_list\n )\n) # /rtemis::ClusteringConfig\n\n\n# %% `$`.ClusteringConfig ----\n# Make ClusteringConfig@config `$`-accessible\nmethod(`$`, ClusteringConfig) <- function(x, name) {\n x@config[[name]]\n}\n\n\n# %% `.DollarNames`.ClusteringConfig ----\n# `$`-autocomplete ClusteringConfig@config ----\nmethod(`.DollarNames`, ClusteringConfig) <- function(x, pattern = \"\") {\n all_names <- names(x@config)\n grep(pattern, all_names, value = TRUE)\n}\n\n\n# %% `[[`.ClusteringConfig ----\n# Make ClusteringConfig@config `[[`-accessible\nmethod(`[[`, ClusteringConfig) <- function(x, index) {\n x@config[[index]]\n}\n\n\n# %% repr.ClusteringConfig ----\nmethod(repr, ClusteringConfig) <- function(\n x,\n pad = 0L,\n output_type = NULL,\n ...\n) {\n output_type <- get_output_type(output_type)\n out <- repr_S7name(\n paste(x@algorithm, \"ClusteringConfig\"),\n pad = pad,\n output_type = output_type\n )\n paste0(\n out,\n repr_ls(props(x)[[\"config\"]], pad = pad, output_type = output_type)\n )\n} # /rtemis::repr.ClusteringConfig\n\n\n# %% print.ClusteringConfig ----\n#' Print Method for ClusteringConfig\n#'\n#' @param x ClusteringConfig object.\n#' @param pad Integer: Left side padding.\n#'\n#' @return ClusteringConfig object, invisibly.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(print, ClusteringConfig) <- function(\n x,\n pad = 0L,\n output_type = NULL,\n ...\n) {\n cat(repr(x, pad = pad, output_type = output_type))\n invisible(x)\n} # /rtemis::print.ClusteringConfig\n\n\n# %% KMeansConfig ----\n#' @title KMeansConfig\n#'\n#' @description\n#' ClusteringConfig subclass for K-means Clustering.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nKMeansConfig <- new_class(\n name = \"KMeansConfig\",\n parent = ClusteringConfig,\n constructor = function(k, dist) {\n k <- clean_posint(k)\n check_inherits(dist, \"character\")\n new_object(\n ClusteringConfig(\n algorithm = \"KMeans\",\n config = list(\n k = k,\n dist = dist\n )\n )\n )\n }\n) # /rtemis::KMeansConfig\n\n\n# %% setup_KMeans ----\n#' Setup KMeansConfig\n#'\n#' @param k Number of clusters.\n#' @param dist Character: Distance measure to use: 'euclidean' or 'manhattan'.\n#'\n#' @return KMeansConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' kmeans_config <- setup_KMeans(k = 4L, dist = \"euclidean\")\n#' kmeans_config\nsetup_KMeans <- function(k = 3L, dist = c(\"euclidean\", \"manhattan\")) {\n k <- clean_posint(k)\n dist <- match.arg(dist)\n KMeansConfig(k, dist)\n} # /rtemis::setup_KMeans\n\n\n# %% HardCLConfig ----\n#' @title HardCLConfig\n#'\n#' @description\n#' ClusteringConfig subclass for HardCL Clustering.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nHardCLConfig <- new_class(\n name = \"HardCLConfig\",\n parent = ClusteringConfig,\n constructor = function(k, dist) {\n k <- clean_posint(k)\n check_inherits(dist, \"character\")\n new_object(\n ClusteringConfig(\n algorithm = \"HardCL\",\n config = list(\n k = k,\n dist = dist\n )\n )\n )\n }\n) # /rtemis::HardCLConfig\n\n\n# %% setup_HardCL ----\n#' Setup HardCLConfig\n#'\n#' @param k Number of clusters.\n#' @param dist Character: Distance measure to use: 'euclidean' or 'manhattan'.\n#'\n#' @return HardCLConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' hardcl_config <- setup_HardCL(k = 4L, dist = \"euclidean\")\n#' hardcl_config\nsetup_HardCL <- function(k = 3L, dist = c(\"euclidean\", \"manhattan\")) {\n k <- clean_posint(k)\n dist <- match.arg(dist)\n HardCLConfig(k, dist)\n} # /rtemis::setup_HardCL\n\n\n# %% NeuralGasConfig ----\n#' @title NeuralGasConfig\n#'\n#' @description\n#' ClusteringConfig subclass for Neural Gas Clustering.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nNeuralGasConfig <- new_class(\n name = \"NeuralGasConfig\",\n parent = ClusteringConfig,\n constructor = function(k, dist) {\n k <- clean_posint(k)\n check_inherits(dist, \"character\")\n new_object(\n ClusteringConfig(\n algorithm = \"NeuralGas\",\n config = list(\n k = k,\n dist = dist\n )\n )\n )\n }\n) # /rtemis::NeuralGasConfig\n\n\n# %% setup_NeuralGas ----\n#' Setup NeuralGasConfig\n#'\n#' @param k Number of clusters.\n#' @param dist Character: Distance measure to use: 'euclidean' or 'manhattan'.\n#'\n#' @return NeuralGasConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' neuralgas_config <- setup_NeuralGas(k = 4L, dist = \"euclidean\")\n#' neuralgas_config\nsetup_NeuralGas <- function(k = 3L, dist = c(\"euclidean\", \"manhattan\")) {\n k <- clean_posint(k)\n dist <- match.arg(dist)\n NeuralGasConfig(k, dist)\n} # /rtemis::setup_NeuralGas\n\n\n# %% CMeansConfig ----\n#' @title CMeansConfig\n#'\n#' @description\n#' ClusteringConfig subclass for CMeans Clustering.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nCMeansConfig <- new_class(\n name = \"CMeansConfig\",\n parent = ClusteringConfig,\n constructor = function(\n k,\n max_iter,\n dist,\n method,\n m,\n rate_par,\n weights,\n control\n ) {\n k <- clean_posint(k)\n max_iter <- clean_posint(max_iter)\n check_character(dist)\n check_character(method)\n check_floatpos(m)\n check_float01inc(rate_par)\n check_inherits(weights, \"numeric\")\n check_inherits(control, \"list\")\n new_object(\n ClusteringConfig(\n algorithm = \"CMeans\",\n config = list(\n k = k,\n max_iter = max_iter,\n dist = dist,\n method = method,\n m = m,\n rate_par = rate_par,\n weights = weights,\n control = control\n )\n )\n )\n }\n) # /rtemis::CMeansConfig\n\n\n# %% setup_CMeans ----\n#' Setup CMeansConfig\n#'\n#' @param k Integer: Number of clusters.\n#' @param max_iter Integer: Maximum number of iterations.\n#' @param dist Character: Distance measure to use: 'euclidean' or 'manhattan'.\n#' @param method Character: \"cmeans\" - fuzzy c-means clustering; \"ufcl\": on-line update.\n#' @param m Float (>1): Degree of fuzzification.\n#' @param rate_par Float (0, 1): Learning rate for the online variant.\n#' @param weights Float (>0): Case weights.\n#' @param control List: Control config for clustering algorithm.\n#'\n#' @return CMeansConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' cmeans_config <- setup_CMeans(k = 4L, dist = \"euclidean\")\n#' cmeans_config\nsetup_CMeans <- function(\n k = 2L,\n max_iter = 100L,\n dist = c(\"euclidean\", \"manhattan\"),\n method = c(\"cmeans\", \"ufcl\"),\n m = 2.0,\n rate_par = NULL,\n weights = 1.0,\n control = list()\n) {\n k <- clean_posint(k)\n max_iter <- clean_posint(max_iter)\n dist <- match.arg(dist)\n method <- match.arg(method)\n check_floatpos(m)\n stopifnot(m > 1)\n check_float01inc(rate_par)\n check_inherits(weights, \"numeric\")\n CMeansConfig(\n k = k,\n max_iter = max_iter,\n dist = dist,\n method = method,\n m = m,\n rate_par = rate_par,\n weights = weights,\n control = control\n )\n} # /rtemis::setup_CMeans\n\n\n# %% DBSCANConfig ----\n#' @title DBSCANConfig\n#'\n#' @description\n#' ClusteringConfig subclass for DBSCAN Clustering.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nDBSCANConfig <- new_class(\n name = \"DBSCANConfig\",\n parent = ClusteringConfig,\n constructor = function(\n eps,\n min_points,\n weights,\n border_points,\n search,\n bucket_size,\n split_rule,\n approx\n ) {\n check_floatpos(eps)\n min_points <- clean_posint(min_points)\n check_inherits(weights, \"numeric\")\n check_inherits(border_points, \"logical\")\n check_inherits(search, \"character\")\n check_inherits(bucket_size, \"integer\")\n check_inherits(split_rule, \"character\")\n check_inherits(approx, \"logical\")\n new_object(\n ClusteringConfig(\n algorithm = \"DBSCAN\",\n config = list(\n eps = eps,\n min_points = min_points,\n weights = weights,\n border_points = border_points,\n search = search,\n bucket_size = bucket_size,\n split_rule = split_rule,\n approx = approx\n )\n )\n )\n }\n) # /rtemis::DBSCANConfig\n\n\n# %% setup_DBSCAN ----\n#' Setup DBSCANConfig\n#'\n#' @param eps Float: Radius of neighborhood.\n#' @param min_points Integer: Minimum number of points in a neighborhood to form a cluster.\n#' @param weights Numeric vector: Weights for data points.\n#' @param border_points Logical: If TRUE, assign border points to clusters.\n#' @param search Character: Nearest neighbor search strategy: \"kdtree\", \"linear\", or \"dist\".\n#' @param bucket_size Integer: Size of buckets for k-dtree search.\n#' @param split_rule Character: Rule for splitting clusters: \"SUGGEST\", \"STD\", \"MIDPT\", \"FAIR\", \"SL_MIDPT\", \"SL_FAIR\".\n#' @param approx Logical: If TRUE, use approximate nearest neighbor search.\n#' @return DBSCANConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' dbscan_config <- setup_DBSCAN(eps = 0.5, min_points = 5L)\n#' dbscan_config\nsetup_DBSCAN <- function(\n eps = 0.5,\n min_points = 5L,\n weights = NULL,\n border_points = TRUE,\n search = c(\"kdtree\", \"linear\", \"dist\"),\n bucket_size = 100L,\n split_rule = c(\"SUGGEST\", \"STD\", \"MIDPT\", \"FAIR\", \"SL_MIDPT\", \"SL_FAIR\"),\n approx = FALSE\n) {\n check_floatpos(eps)\n min_points <- clean_posint(min_points)\n check_inherits(weights, \"numeric\")\n check_inherits(border_points, \"logical\")\n search <- match.arg(search)\n check_inherits(bucket_size, \"integer\")\n split_rule <- match.arg(split_rule)\n check_inherits(approx, \"logical\")\n DBSCANConfig(\n eps = eps,\n min_points = min_points,\n weights = weights,\n border_points = border_points,\n search = search,\n bucket_size = bucket_size,\n split_rule = split_rule,\n approx = approx\n )\n} # /rtemis::setup_DBSCAN\n" }, { "path": "R/10_Clustering.R", "content": "# S7_Clustering.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% Clustering ----\n#' @title Clustering\n#'\n#' @description\n#' Clustering class.\n#'\n#' @field algorithm Character: Algorithm name.\n#' @field clust Any: Clustering object.\n#' @field k Integer: Number of clusters.\n#' @field clusters List: Cluster assignment.\n#' @field config ClusteringConfig: Algorithm-specific config.\n#'\n#' @author EDG\n#' @noRd\nClustering <- new_class(\n name = \"Clustering\",\n properties = list(\n algorithm = class_character,\n clust = class_any,\n k = class_integer,\n clusters = class_integer | class_list,\n config = ClusteringConfig\n )\n) # /Clustering\n\n\n# %% `$`.Clustering ----\n# Make Clustering props `$`-accessible\nmethod(`$`, Clustering) <- function(x, name) {\n prop(x, name)\n}\n\n\n# %% `.DollarNames`.Clustering ----\n# `$`-autocomplete Clustering props\nmethod(`.DollarNames`, Clustering) <- function(x, pattern = \"\") {\n prop_names <- names(props(x))\n grep(pattern, prop_names, value = TRUE)\n}\n\n\n# %% `[[`.Clustering ----\n# Make Clustering props `[[`-accessible\nmethod(`[[`, Clustering) <- function(x, index) {\n prop(x, index)\n}\n\n\n# %% repr.Clustering ----\nmethod(repr, Clustering) <- function(\n x,\n pad = 0L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n paste0(\n repr_S7name(paste(x@algorithm, \"Clustering\")),\n repr_ls(props(x)[-1], pad = pad, output_type = output_type)\n )\n} # /rtemis::repr.Clustering\n\n\n# %% print.Clustering ----\nmethod(print, Clustering) <- function(\n x,\n pad = 0L,\n output_type = NULL,\n ...\n) {\n cat(repr(x, pad = pad, output_type = output_type))\n invisible(x)\n} # /rtemis::print.Clustering\n" }, { "path": "R/11_DecompositionConfig.R", "content": "# S7_DecompositionConfig.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% DecompositionConfig ----\n#' @title DecompositionConfig\n#'\n#' @description\n#' Decomposition config class.\n#'\n#' @field algorithm Character: Algorithm name.\n#' @field config List: Algorithm-specific config.\n#'\n#' @author EDG\n#' @noRd\nDecompositionConfig <- new_class(\n name = \"DecompositionConfig\",\n properties = list(\n algorithm = class_character,\n config = class_list\n )\n) # /DecompositionConfig\n\n\n# %% `$`.DecompositionConfig ----\n# Make DecompositionConfig@config `$`-accessible ----\nmethod(`$`, DecompositionConfig) <- function(x, name) {\n x@config[[name]]\n}\n\n\n# %% `.DollarNames`.DecompositionConfig ----\n# `$`-autocomplete DecompositionConfig@config ----\nmethod(`.DollarNames`, DecompositionConfig) <- function(x, pattern = \"\") {\n all_names <- names(x@config)\n grep(pattern, all_names, value = TRUE)\n}\n\n\n# %% `[`.DecompositionConfig ----\n# Make props `[`-accessible ----\nmethod(`[`, DecompositionConfig) <- function(x, name) {\n props(x)[[name]]\n}\n\n\n# %% `[[`.DecompositionConfig ----\n# Make DecompositionConfig@config `[[`-accessible ----\nmethod(`[[`, DecompositionConfig) <- function(x, name) {\n x@config[[name]]\n}\n\n\n# %% repr.DecompositionConfig ----\n#' Show Method for DecompositionConfig\n#'\n#' @param object DecompositionConfig object.\n#' @param pad Integer: Left side padding.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return character\n#'\n#' @author EDG\n#' @noRd\nmethod(repr, DecompositionConfig) <- function(\n x,\n pad = 0L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n paste0(\n repr_S7name(\n paste(x[\"algorithm\"], \"DecompositionConfig\"),\n pad = pad,\n output_type = output_type\n ),\n repr_ls(x[\"config\"], pad = pad, limit = -1L, output_type = output_type)\n )\n} # /rtemis::repr.DecompositionConfig\n\n\n# %% print.DecompositionConfig ----\n#' Print Method for DecompositionConfig\n#'\n#' @param x DecompositionConfig object.\n#' @param pad Integer: Left side padding.\n#' @param ... Not used.\n#'\n#' @return DecompositionConfig object, invisibly.\n#'\n#' @author EDG\n#' @noRd\nmethod(print, DecompositionConfig) <- function(\n x,\n pad = 0L,\n output_type = NULL,\n ...\n) {\n cat(repr(x, pad = pad, output_type = output_type))\n invisible(x)\n}\n\n\n# %% PCAConfig ----\n#' @title PCAConfig\n#'\n#' @description\n#' DecompositionConfig subclass for Principal Component Analysis.\n#' Internal use only.\n#'\n#' @author EDG\n#' @noRd\nPCAConfig <- new_class(\n name = \"PCAConfig\",\n parent = DecompositionConfig,\n constructor = function(k, center, scale, tol) {\n k <- clean_posint(k)\n check_logical(center)\n check_logical(scale)\n check_float0pos(tol)\n new_object(\n DecompositionConfig(\n algorithm = \"PCA\",\n config = list(\n k = k,\n center = center,\n scale = scale,\n tol = tol\n )\n )\n )\n }\n) # /rtemis::PCAConfig\n\n\n# %% setup_PCA ----\n#' Setup PCA config.\n#'\n#' @param k Integer: Number of components. (passed to `prcomp` `rank.`)\n#' @param center Logical: If TRUE, center the data.\n#' @param scale Logical: If TRUE, scale the data.\n#' @param tol Numeric: Tolerance.\n#'\n#' @return PCAConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' pca_config <- setup_PCA(k = 3L)\n#' pca_config\nsetup_PCA <- function(k = 3L, center = TRUE, scale = TRUE, tol = NULL) {\n k <- clean_posint(k)\n check_logical(center)\n check_logical(scale)\n check_float0pos(tol)\n PCAConfig(k, center, scale, tol)\n} # /rtemis::setup_PCA\n\n\n# %% ICAConfig ----\n#' @title ICAConfig\n#'\n#' @description\n#' DecompositionConfig subclass for Independent Component Analysis.\n#' Internal use only.\n#'\n#' @author EDG\n#' @noRd\nICAConfig <- new_class(\n name = \"ICAConfig\",\n parent = DecompositionConfig,\n constructor = function(k, type, fun, alpha, row_norm, maxit, tol) {\n new_object(\n DecompositionConfig(\n algorithm = \"ICA\",\n config = list(\n k = k,\n type = type,\n fun = fun,\n alpha = alpha,\n row_norm = row_norm,\n maxit = maxit,\n tol = tol\n )\n )\n )\n }\n) # /rtemis::ICAConfig\n\n\n# %% setup_ICA ----\n#' @title setup_ICA\n#'\n#' @description\n#' Setup ICA config.\n#'\n#' @param k Integer: Number of components.\n#' @param type Character: Type of ICA: \"parallel\" or \"deflation\".\n#' @param fun Character: ICA function: \"logcosh\", \"exp\".\n#' @param alpha Numeric \\[1, 2\\]: Used in approximation to neg-entropy with `fun = \"logcosh\"`.\n#' @param row_norm Logical: If TRUE, normalize rows of `x` before ICA.\n#' @param maxit Integer: Maximum number of iterations.\n#' @param tol Numeric: Tolerance.\n#'\n#' @return ICAConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' ica_config <- setup_ICA(k = 3L)\n#' ica_config\nsetup_ICA <- function(\n k = 3L,\n type = c(\"parallel\", \"deflation\"),\n fun = c(\"logcosh\", \"exp\"),\n alpha = 1.0,\n row_norm = TRUE,\n maxit = 100L,\n tol = 1e-04\n) {\n k <- clean_posint(k)\n type <- match.arg(type)\n fun <- match.arg(fun)\n stopifnot(alpha >= 1, alpha <= 2)\n check_inherits(row_norm, \"logical\")\n maxit <- clean_posint(maxit)\n check_inherits(tol, \"numeric\")\n ICAConfig(\n k = k,\n type = type,\n fun = fun,\n alpha = alpha,\n row_norm = row_norm,\n maxit = maxit,\n tol = tol\n )\n} # /rtemis::setup_ICA\n\n\n# %% NMFConfig ----\n#' @title NMFConfig\n#'\n#' @description\n#' DecompositionConfig subclass for Non-negative Matrix Factorization.\n#' Internal use only.\n#'\n#' @author EDG\n#' @noRd\nNMFConfig <- new_class(\n name = \"NMFConfig\",\n parent = DecompositionConfig,\n constructor = function(k, method, nrun) {\n k <- clean_posint(k)\n check_inherits(method, \"character\")\n nrun <- clean_posint(nrun)\n new_object(\n DecompositionConfig(\n algorithm = \"NMF\",\n config = list(\n k = k,\n method = method,\n nrun = nrun\n )\n )\n )\n }\n) # /rtemis::NMFConfig\n\n\n# %% setup_NMF ----\n#' Setup NMF config.\n#'\n#' @param k Integer: Number of components.\n#' @param method Character: NMF method. See `NMF::nmf`.\n#' @param nrun Integer: Number of runs to perform.\n#'\n#' @return NMFConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' nmf_config <- setup_NMF(k = 3L)\n#' nmf_config\nsetup_NMF <- function(\n k = 2L,\n method = \"brunet\",\n nrun = if (length(k) > 1L) 30L else 1L\n) {\n k <- clean_posint(k)\n check_inherits(method, \"character\")\n nrun <- clean_posint(nrun)\n NMFConfig(k, method, nrun)\n} # /rtemis::setup_NMF\n\n\n# %% UMAPConfig ----\n#' @title UMAPConfig\n#'\n#' @description\n#' DecompositionConfig subclass for Uniform Manifold Approximation and Projection.\n#' Internal use only.\n#'\n#' @author EDG\n#' @noRd\nUMAPConfig <- new_class(\n name = \"UMAPConfig\",\n parent = DecompositionConfig,\n constructor = function(\n k,\n n_neighbors,\n init,\n metric,\n n_epochs,\n learning_rate,\n scale\n ) {\n k <- clean_posint(k)\n n_neighbors <- clean_posint(n_neighbors)\n check_inherits(init, \"character\")\n check_inherits(metric, \"character\")\n n_epochs <- clean_posint(n_epochs)\n check_float0pos(learning_rate)\n check_inherits(scale, \"logical\")\n new_object(\n DecompositionConfig(\n algorithm = \"UMAP\",\n config = list(\n k = k,\n n_neighbors = n_neighbors,\n init = init,\n metric = metric,\n n_epochs = n_epochs,\n learning_rate = learning_rate,\n scale = scale\n )\n )\n )\n }\n) # /rtemis::UMAPConfig\n\n\n# %% setup_UMAP ----\n#' Setup UMAP config.\n#'\n#' @details\n#' A high `n_neighbors` value may give error in some systems:\n#' \"Error in irlba::irlba(L, nv = n, nu = 0, maxit = iters) :\n#' function 'as_cholmod_sparse' not provided by package 'Matrix'\"\n#'\n#' @param k Integer: Number of components.\n#' @param n_neighbors Integer: Number of keighbors.\n#' @param init Character: Initialization type. See `uwot::umap \"init\"`.\n#' @param metric Character: Distance metric to use: \"euclidean\", \"cosine\",\n#' \"manhattan\", \"hamming\", \"categorical\".\n#' @param n_epochs Integer: Number of epochs.\n#' @param learning_rate Float: Learning rate.\n#' @param scale Logical: If TRUE, scale input data before doing UMAP.\n#'\n#' @return UMAPConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' umap_config <- setup_UMAP(k = 3L)\n#' umap_config\nsetup_UMAP <- function(\n k = 2L,\n n_neighbors = 15L,\n init = \"spectral\",\n metric = c(\"euclidean\", \"cosine\", \"manhattan\", \"hamming\", \"categorical\"),\n n_epochs = NULL,\n learning_rate = 1.0,\n scale = TRUE\n) {\n k <- clean_posint(k)\n n_neighbors <- clean_posint(n_neighbors)\n init <- match.arg(init)\n metric <- match.arg(metric)\n check_inherits(n_epochs, \"integer\")\n check_float0pos(learning_rate)\n check_inherits(scale, \"logical\")\n UMAPConfig(\n k = k,\n n_neighbors = n_neighbors,\n init = init,\n metric = metric,\n n_epochs = n_epochs,\n learning_rate = learning_rate,\n scale = scale\n )\n} # /rtemis::setup_UMAP\n\n\n# %% tSNEConfig ----\n#' @title tSNEConfig\n#'\n#' @description\n#' DecompositionConfig subclass for t-Distributed Stochastic Neighbor Embedding.\n#'\n#' @author EDG\n#' @noRd\ntSNEConfig <- new_class(\n name = \"tSNEConfig\",\n parent = DecompositionConfig,\n constructor = function(\n k = NULL,\n initial_dims = NULL,\n perplexity = NULL,\n theta = NULL,\n check_duplicates = NULL,\n pca = NULL,\n partial_pca = NULL,\n max_iter = NULL,\n verbose = NULL,\n is_distance = NULL,\n Y_init = NULL,\n pca_center = NULL,\n pca_scale = NULL,\n normalize = NULL,\n stop_lying_iter = NULL,\n mom_switch_iter = NULL,\n momentum = NULL,\n final_momentum = NULL,\n eta = NULL,\n exaggeration_factor = NULL,\n num_threads = NULL\n ) {\n k <- clean_posint(k)\n initial_dims <- clean_posint(initial_dims)\n check_logical(check_duplicates)\n check_logical(pca)\n check_logical(partial_pca)\n max_iter <- clean_posint(max_iter)\n check_logical(verbose)\n check_logical(is_distance)\n check_inherits(Y_init, \"matrix\")\n check_logical(pca_center)\n check_logical(pca_scale)\n check_logical(normalize)\n stop_lying_iter <- clean_posint(stop_lying_iter)\n mom_switch_iter <- clean_posint(mom_switch_iter)\n num_threads <- clean_posint(num_threads)\n new_object(\n DecompositionConfig(\n algorithm = \"tSNE\",\n config = list(\n k = k,\n initial_dims = initial_dims,\n perplexity = perplexity,\n theta = theta,\n check_duplicates = check_duplicates,\n pca = pca,\n partial_pca = partial_pca,\n max_iter = max_iter,\n verbose = verbose,\n is_distance = is_distance,\n Y_init = Y_init,\n pca_center = pca_center,\n pca_scale = pca_scale,\n normalize = normalize,\n stop_lying_iter = stop_lying_iter,\n mom_switch_iter = mom_switch_iter,\n momentum = momentum,\n final_momentum = final_momentum,\n eta = eta,\n exaggeration_factor = exaggeration_factor,\n num_threads = num_threads\n )\n )\n )\n }\n) # /rtemis::tSNEConfig\n\n\n# %% setup_tSNE ----\n#' Setup tSNE config.\n#'\n#' @details\n#' Get more information on the config by running `?Rtsne::Rtsne`.\n#'\n#' @param k Integer: Number of components.\n#' @param initial_dims Integer: Initial dimensions.\n#' @param perplexity Integer: Perplexity.\n#' @param theta Float: Theta.\n#' @param check_duplicates Logical: If TRUE, check for duplicates.\n#' @param pca Logical: If TRUE, perform PCA.\n#' @param partial_pca Logical: If TRUE, perform partial PCA.\n#' @param max_iter Integer: Maximum number of iterations.\n#' @param verbose Logical: If TRUE, print messages.\n#' @param is_distance Logical: If TRUE, `x` is a distance matrix.\n#' @param Y_init Matrix: Initial Y matrix.\n#' @param pca_center Logical: If TRUE, center PCA.\n#' @param pca_scale Logical: If TRUE, scale PCA.\n#' @param normalize Logical: If TRUE, normalize.\n#' @param stop_lying_iter Integer: Stop lying iterations.\n#' @param mom_switch_iter Integer: Momentum switch iterations.\n#' @param momentum Float: Momentum.\n#' @param final_momentum Float: Final momentum.\n#' @param eta Float: Eta.\n#' @param exaggeration_factor Float: Exaggeration factor.\n#' @param num_threads Integer: Number of threads.\n#'\n#' @return tSNEConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' tSNE_config <- setup_tSNE(k = 3L)\n#' tSNE_config\nsetup_tSNE <- function(\n k = 2L,\n initial_dims = 50L,\n perplexity = 30,\n theta = 0.5,\n check_duplicates = TRUE,\n pca = TRUE,\n partial_pca = FALSE,\n max_iter = 1000L,\n verbose = getOption(\"verbose\", FALSE),\n is_distance = FALSE,\n Y_init = NULL,\n pca_center = TRUE,\n pca_scale = FALSE,\n normalize = TRUE,\n stop_lying_iter = ifelse(is.null(Y_init), 250L, 0L),\n mom_switch_iter = ifelse(is.null(Y_init), 250L, 0L),\n momentum = 0.5,\n final_momentum = 0.8,\n eta = 200,\n exaggeration_factor = 12,\n num_threads = 1L\n) {\n tSNEConfig(\n k = k,\n initial_dims = initial_dims,\n perplexity = perplexity,\n theta = theta,\n check_duplicates = check_duplicates,\n pca = pca,\n partial_pca = partial_pca,\n max_iter = max_iter,\n verbose = verbose,\n is_distance = is_distance,\n Y_init = Y_init,\n pca_center = pca_center,\n pca_scale = pca_scale,\n normalize = normalize,\n stop_lying_iter = stop_lying_iter,\n mom_switch_iter = mom_switch_iter,\n momentum = momentum,\n final_momentum = final_momentum,\n eta = eta,\n exaggeration_factor = exaggeration_factor,\n num_threads = num_threads\n )\n} # /rtemis::setup_tSNE\n\n\n# %% IsomapConfig ----\n#' @title IsomapConfig\n#'\n#' @description\n#' DecompositionConfig subclass for Isomap.\n#'\n#' @author EDG\n#' @noRd\nIsomapConfig <- new_class(\n name = \"IsomapConfig\",\n parent = DecompositionConfig,\n constructor = function(\n k,\n dist_method = NULL,\n nsd = NULL,\n path = NULL\n ) {\n k <- clean_posint(k)\n check_inherits(dist_method, \"character\")\n nsd <- clean_int(nsd)\n check_inherits(path, \"character\")\n new_object(\n DecompositionConfig(\n algorithm = \"Isomap\",\n config = list(\n k = k,\n dist_method = dist_method,\n nsd = nsd,\n path = path\n )\n )\n )\n }\n) # /rtemis::IsomapConfig\n\n\n# %% setup_Isomap ----\n#' Setup Isomap config.\n#'\n#' @param k Integer: Number of components.\n#' @param dist_method Character: Distance method.\n#' @param nsd Integer: Number of shortest dissimilarities retained.\n#' @param path Character: Path argument for `vegan::isomap`.\n#'\n#' @return IsomapConfig object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' isomap_config <- setup_Isomap(k = 3L)\n#' isomap_config\nsetup_Isomap <- function(\n k = 2L,\n dist_method = c(\"euclidean\", \"manhattan\"),\n nsd = 0L,\n path = c(\"shortest\", \"extended\")\n) {\n k <- clean_posint(k)\n dist_method <- match.arg(dist_method)\n nsd <- clean_int(nsd)\n path <- match.arg(path)\n IsomapConfig(k, dist_method, nsd, path)\n} # /rtemis::setup_Isomap\n" }, { "path": "R/12_Decomposition.R", "content": "# S7_Decomposition.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% Decomposition ----\n#' @title Decomposition\n#'\n#' @description\n#' Decomposition class.\n#'\n#' @field algorithm Character: Algorithm name.\n#' @field decom Any: Decomposition object.\n#' @field config List: Algorithm-specific config.\n#' @field decom: Decomposition model.\n#' @field transformed: transformedransformed data, i.e. either a projection or an embedding of the input data.\n#'\n#' @author EDG\n#' @noRd\nDecomposition <- new_class(\n name = \"Decomposition\",\n properties = list(\n algorithm = class_character,\n config = DecompositionConfig,\n decom = class_any,\n transformed = class_any\n )\n) # /rtemis::Decomposition\n\n\n# %% `$`.Decomposition ----\n# Make Decomposition properties `$`-accessible\nmethod(`$`, Decomposition) <- function(x, name) {\n prop_names <- names(props(x))\n if (name %in% prop_names) {\n prop(x, name)\n } else {\n cli::cli_abort(paste0(\n \"No property named '\",\n name,\n \"' in Decomposition object.\"\n ))\n }\n}\n\n\n# %% `.DollarNames`.Decomposition ----\nmethod(`.DollarNames`, Decomposition) <- function(x, pattern = \"\") {\n prop_names <- names(props(x))\n grep(pattern, prop_names, value = TRUE)\n}\n\n\n# %% `[[`.Decomposition ----\n# Make Decomposition@transformed `[[`-accessible\nmethod(`[[`, Decomposition) <- function(x, index) {\n props(x, \"transformed\")[[index]]\n}\n\n\n# %% repr.Decomposition ----\nmethod(repr, Decomposition) <- function(\n x,\n pad = 0L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n paste0(\n repr_S7name(\n paste(x@algorithm, \"Decomposition\"),\n pad = pad,\n output_type = output_type\n ),\n repr_ls(props(x)[-1], pad = pad, output_type = output_type)\n )\n} # /rtemis::repr.Decomposition\n\n\n# %% print.Decomposition ----\nmethod(print, Decomposition) <- function(\n x,\n pad = 0L,\n output_type = NULL,\n ...\n) {\n cat(repr(x, pad = pad, output_type = output_type))\n invisible(x)\n} # /rtemis::print.Decomposition\n" }, { "path": "R/13_Themes.R", "content": "# S7_Themes.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% Theme ----\n#' Theme\n#'\n#' @field name Character: Name of theme.\n#' @field config Named list of theme config.\n#'\n#' @author EDG\n#' @noRd\nTheme <- new_class(\n name = \"Theme\",\n properties = list(\n name = class_character,\n config = class_list\n )\n) # /Theme\n\n\n# %% print.Theme ----\n#' Print Theme\n#'\n#' Print Theme object\n#'\n#' @param x `Theme` object.\n#' @param ... Not used.\n#'\n#' @author EDG\n#' @noRd\nmethod(print, Theme) <- function(x, ...) {\n objcat(paste(x@name, \"Theme\"))\n printls(props(x)[[\"config\"]])\n invisible(x)\n}\n\n\n# %% `$`.Theme ----\n# Make Theme@config `$`-accessible with autocomplete ----\nmethod(`$`, Theme) <- function(x, name) {\n x@config[[name]]\n} # /rtemis::Theme$\n\n\n# %% `.DollarNames`.Theme ----\nmethod(`.DollarNames`, Theme) <- function(x, pattern = \"\") {\n all_names <- names(x@config)\n grep(pattern, all_names, value = TRUE)\n} # /rtemis::Theme.DollarNames\n\n\n# %% `[[`.Theme ----\n# Make Theme@config `[[`-accessible ----\nmethod(`[[`, Theme) <- function(x, name) {\n x@config[[name]]\n} # /rtemis::Theme[[]]\n\n\n# %% names.Theme ----\n#' Get names of Theme object\n#'\n#' @param x `Theme` object.\n#'\n#' @return Character vector of names of `Theme` object.\n#'\n#' @author EDG\n#' @noRd\nmethod(names, Theme) <- function(x) {\n names(x@config)\n} # /rtemis::names.Theme\n" }, { "path": "R/14_SuperConfig.R", "content": "# S7_SuperConfig.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# References ----\n# https://github.com/RConsortium/S7\n# https://rconsortium.github.io/S7/\n\n# %% SuperConfig ----\n#' SuperConfig Class\n#'\n#' @description\n#' Supervised Learning Configuration Class.\n#'\n#' @author EDG\n#' @noRd\nSuperConfig <- new_class(\n name = \"SuperConfig\",\n properties = list(\n dat_training_path = class_character,\n dat_validation_path = class_character | NULL,\n dat_test_path = class_character | NULL,\n weights = class_character | NULL, # column name in dat_training\n preprocessor_config = PreprocessorConfig | NULL,\n algorithm = class_character | NULL,\n hyperparameters = Hyperparameters | NULL,\n tuner_config = TunerConfig | NULL,\n outer_resampling_config = ResamplerConfig | NULL,\n execution_config = ExecutionConfig,\n question = class_character | NULL,\n outdir = class_character,\n verbosity = class_integer\n )\n) # /rtemis::SuperConfig\n\n\n# %% repr.SuperConfig ----\n#' Repr SuperConfig\n#'\n#' @param x `SuperConfig` object.\n#' @param pad Integer: Number of spaces to pad the message with.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted string that can be printed with cat()\n#'\n#' @author EDG\n#' @noRd\nmethod(repr, SuperConfig) <- function(x, pad = 0L, output_type = NULL) {\n out <- repr_S7name(\"SuperConfig\", pad = pad, output_type = output_type)\n out <- paste0(\n out,\n repr_ls(props(x), pad = pad, limit = 20L, output_type = output_type)\n )\n out\n} # /rtemis::repr.SuperConfig\n\n\n# %% print.SuperConfig ----\n#' Print `SuperConfig`\n#'\n#' Print `SuperConfig` object\n#'\n#' @param x `SuperConfig` object.\n#' @param ... Not used.\n#'\n#' @author EDG\n#' @noRd\nmethod(print, SuperConfig) <- function(x, output_type = NULL, ...) {\n cat(repr(x, output_type = output_type))\n invisible(x)\n} # /rtemis::print.SuperConfig\n\n\n# %% setup_SuperConfig ----\n#' Setup SuperConfig\n#'\n#' Setup `SuperConfig` object.\n#'\n#' @param dat_training_path Character: Path to training data file.\n#' @param dat_validation_path Character: Path to validation data file.\n#' @param dat_test_path Character: Path to test data file.\n#' @param weights Optional Character: Column name in training data to use as observation weights.\n#' If NULL, no weights are used.\n#' @param preprocessor_config `PreprocessorConfig` object: Configuration for data preprocessing.\n#' @param algorithm Character: Algorithm to use for training.\n#' @param hyperparameters `Hyperparameters` object: Configuration for model hyperparameters.\n#' @param tuner_config `TunerConfig` object: Configuration for hyperparameter tuning.\n#' @param outer_resampling_config `ResamplerConfig` object: Configuration for outer res\n#' resampling during model training.\n#' @param execution_config `ExecutionConfig` object: Configuration for execution settings. Setup\n#' with [setup_ExecutionConfig].\n#' @param question Character: Question to answer with the supervised learning analysis.\n#' @param outdir Character: Output directory for results.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `SuperConfig` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' sc <- setup_SuperConfig(\n#' dat_training_path = \"train.csv\",\n#' preprocessor_config = setup_Preprocessor(remove_duplicates = TRUE),\n#' algorithm = \"LightRF\",\n#' hyperparameters = setup_LightRF(),\n#' tuner_config = setup_GridSearch(),\n#' outer_resampling_config = setup_Resampler(),\n#' execution_config = setup_ExecutionConfig(),\n#' question = \"Can we tell iris species apart given their measurements?\",\n#' outdir = \"models/\"\n#' )\nsetup_SuperConfig <- function(\n dat_training_path,\n dat_validation_path = NULL,\n dat_test_path = NULL,\n weights = NULL,\n preprocessor_config = NULL,\n algorithm = NULL,\n hyperparameters = NULL,\n tuner_config = NULL,\n outer_resampling_config = NULL,\n execution_config = setup_ExecutionConfig(),\n question = NULL,\n outdir = \"results/\",\n verbosity = 1L\n) {\n # Sanitize paths for security\n dat_training_path <- sanitize_path(dat_training_path, must_exist = FALSE)\n\n if (!is.null(dat_validation_path)) {\n dat_validation_path <- sanitize_path(\n dat_validation_path,\n must_exist = FALSE\n )\n }\n\n if (!is.null(dat_test_path)) {\n dat_test_path <- sanitize_path(dat_test_path, must_exist = FALSE)\n }\n\n outdir <- sanitize_path(outdir, must_exist = FALSE, type = \"any\")\n\n SuperConfig(\n dat_training_path = dat_training_path,\n dat_validation_path = dat_validation_path,\n dat_test_path = dat_test_path,\n weights = weights,\n preprocessor_config = preprocessor_config,\n algorithm = algorithm,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n outer_resampling_config = outer_resampling_config,\n execution_config = execution_config,\n question = question,\n outdir = outdir,\n verbosity = verbosity\n )\n} # /setup_SuperConfig\n\n\n# %% to_toml.SuperConfig ----\n#' Convert `SuperConfig` to TOML\n#'\n#' Convert `SuperConfig` object to TOML format for saving to file that can be read back in with\n#' `read_config()`.\n#'\n#' @param x `SuperConfig` object.\n#'\n#' @return Character: TOML string representation of the `SuperConfig` object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(to_toml, SuperConfig) <- function(x) {\n check_dependencies(\"toml\")\n xl <- S7_to_list(props(x))\n toml_with_meta(x, xl)\n} # /rtemis::to_toml.SuperConfig\n\n\n# %% write_toml.SuperConfig ----\n#' @name\n#' write_toml\n#'\n#' @param x `SuperConfig` object.\n#' @param file Character: Path to output TOML file.\n#' @param overwrite Logical: If TRUE, overwrite existing file.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `SuperConfig` object, invisibly.\n#'\n#' @author EDG\n#' @rdname write_toml\n#'\n#' @examples\n#' x <- setup_SuperConfig(\n#' dat_training_path = \"~/Data/iris.csv\",\n#' dat_validation_path = NULL,\n#' dat_test_path = NULL,\n#' weights = NULL,\n#' preprocessor_config = setup_Preprocessor(remove_duplicates = TRUE),\n#' algorithm = \"LightRF\",\n#' hyperparameters = setup_LightRF(),\n#' tuner_config = setup_GridSearch(),\n#' outer_resampling_config = setup_Resampler(),\n#' execution_config = setup_ExecutionConfig(),\n#' question = \"Can we tell iris species apart given their measurements?\",\n#' outdir = \"models/\",\n#' verbosity = 1L\n#' )\n#' tmpdir <- tempdir()\n#' write_toml(x, file.path(tmpdir, \"rtemis.toml\"))\nmethod(write_toml, SuperConfig) <- function(\n x,\n file,\n overwrite = FALSE,\n verbosity = 1L\n) {\n toml_str <- to_toml(x)\n write_lines(\n toml_str,\n file = file,\n overwrite = overwrite,\n verbosity = verbosity\n )\n invisible(x)\n} # /rtemis::write_toml.SuperConfig\n\n\n# %% read_config ----\n#' Read `SuperConfig` from TOML file\n#'\n#' Read `SuperConfig` object from TOML file that was written with `write_toml()`.\n#'\n#' @param file Character: Path to input TOML file.\n#'\n#' @return `SuperConfig` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' # Create a SuperConfig object\n#' x <- setup_SuperConfig(\n#' dat_training_path = \"~/Data/iris.csv\",\n#' algorithm = \"LightRF\",\n#' hyperparameters = setup_LightRF()\n#' )\n#' # Write TOML file\n#' tmpdir <- tempdir()\n#' tmpfile <- file.path(tmpdir, \"rtemis_test.toml\")\n#' write_toml(x, tmpfile)\n#' # Read config from TOML file\n#' x_read <- read_config(tmpfile)\nread_config <- function(file) {\n check_dependencies(\"toml\")\n file <- sanitize_path(file, must_exist = TRUE, type = \"file\")\n xl <- toml::read_toml(file)\n xl <- toml_empty_to_null(xl)\n # Convert list to SuperConfig object\n\n setup_SuperConfig(\n dat_training_path = xl[[\"dat_training_path\"]],\n dat_validation_path = xl[[\"dat_validation_path\"]],\n dat_test_path = xl[[\"dat_test_path\"]],\n weights = xl[[\"weights\"]],\n preprocessor_config = if (is.null(xl[[\"preprocessor_config\"]])) {\n NULL\n } else {\n do.call(setup_Preprocessor, xl[[\"preprocessor_config\"]])\n },\n algorithm = xl[[\"algorithm\"]],\n hyperparameters = if (is.null(xl[[\"hyperparameters\"]])) {\n NULL\n } else {\n .list_to_Hyperparameters(xl[[\"hyperparameters\"]])\n },\n tuner_config = if (is.null(xl[[\"tuner_config\"]])) {\n NULL\n } else {\n .list_to_TunerConfig(xl[[\"tuner_config\"]])\n },\n outer_resampling_config = if (is.null(xl[[\"outer_resampling_config\"]])) {\n NULL\n } else {\n .list_to_ResamplerConfig(xl[[\"outer_resampling_config\"]])\n },\n execution_config = if (is.null(xl[[\"execution_config\"]])) {\n setup_ExecutionConfig()\n } else {\n do.call(setup_ExecutionConfig, xl[[\"execution_config\"]])\n },\n question = iflengthy(xl[[\"question\"]]),\n outdir = iflengthy(xl[[\"outdir\"]]),\n verbosity = iflengthy(xl[[\"verbosity\"]])\n )\n} # /rtemis::read_config\n\n\n# %% to_yaml.SuperConfig ----\n#' Convert `SuperConfig` to YAML\n#'\n#' Convert `SuperConfig` object to YAML format for saving to file that can be read back in with\n#' `read_config()`.\n#'\n#' @param x `SuperConfig` object.\n#'\n#' @return Character: YAML string representation of the `SuperConfig` object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(to_yaml, SuperConfig) <- function(x) {\n xl <- S7_to_list(props(x))\n yaml::as.yaml(xl)\n} # /rtemis::to_yaml.SuperConfig\n\n\n# %% SuperConfigLive ----\n#' SuperConfigLive Class\n#'\n#' @description\n#' Like `SuperConfig`, but carries in-memory training/validation/test data\n#' instead of file paths. Used by `rtemislive` (uploads arrive over a WS\n#' frame, not as a file) and by future HPC submission paths that hand the\n#' data directly to a worker.\n#'\n#' Not TOML-serialisable — in-memory data does not round-trip cleanly to\n#' a config file. Use `SuperConfig` when you need on-disk reproducibility.\n#'\n#' @author EDG\n#' @noRd\nSuperConfigLive <- new_class(\n name = \"SuperConfigLive\",\n properties = list(\n dat_training = class_tabular,\n dat_validation = class_tabular | NULL,\n dat_test = class_tabular | NULL,\n weights = class_character | NULL, # column name in dat_training\n preprocessor_config = PreprocessorConfig | NULL,\n algorithm = class_character | NULL,\n hyperparameters = Hyperparameters | NULL,\n tuner_config = TunerConfig | NULL,\n outer_resampling_config = ResamplerConfig | NULL,\n execution_config = ExecutionConfig,\n question = class_character | NULL,\n outdir = class_character | NULL,\n verbosity = class_integer\n )\n) # /rtemis::SuperConfigLive\n\n\n# %% repr.SuperConfigLive ----\n#' @author EDG\n#' @noRd\nmethod(repr, SuperConfigLive) <- function(x, pad = 0L, output_type = NULL) {\n out <- repr_S7name(\"SuperConfigLive\", pad = pad, output_type = output_type)\n # Replace heavy data slots with a {rows, cols} summary so the printout\n # stays readable.\n pl <- props(x)\n fmt_dim <- function(d) {\n if (is.null(d)) {\n return(NULL)\n }\n paste0(\"<\", NROW(d), \" x \", NCOL(d), \">\")\n }\n pl[[\"dat_training\"]] <- fmt_dim(pl[[\"dat_training\"]])\n pl[[\"dat_validation\"]] <- fmt_dim(pl[[\"dat_validation\"]])\n pl[[\"dat_test\"]] <- fmt_dim(pl[[\"dat_test\"]])\n out <- paste0(\n out,\n repr_ls(pl, pad = pad, limit = 20L, output_type = output_type)\n )\n out\n} # /rtemis::repr.SuperConfigLive\n\n\n# %% print.SuperConfigLive ----\n#' @author EDG\n#' @noRd\nmethod(print, SuperConfigLive) <- function(x, output_type = NULL, ...) {\n cat(repr(x, output_type = output_type))\n invisible(x)\n} # /rtemis::print.SuperConfigLive\n\n\n# %% setup_SuperConfigLive ----\n#' Setup SuperConfigLive\n#'\n#' Build a `SuperConfigLive` — same shape as [setup_SuperConfig] but with\n#' in-memory tabular data instead of file paths.\n#'\n#' @param dat_training data.frame or data.table. Training data.\n#' @param dat_validation data.frame, data.table, or `NULL`.\n#' @param dat_test data.frame, data.table, or `NULL`.\n#' @param weights Character or `NULL`. Column name in `dat_training` used\n#' as observation weights.\n#' @param preprocessor_config,algorithm,hyperparameters,tuner_config,outer_resampling_config,execution_config,question,verbosity\n#' See [setup_SuperConfig].\n#' @param outdir Character or `NULL`. Output directory; `NULL` (the\n#' default) means \"do not write to disk\" (the rtemislive case).\n#'\n#' @return `SuperConfigLive` object.\n#'\n#' @author EDG\n#' @export\nsetup_SuperConfigLive <- function(\n dat_training,\n dat_validation = NULL,\n dat_test = NULL,\n weights = NULL,\n preprocessor_config = NULL,\n algorithm = NULL,\n hyperparameters = NULL,\n tuner_config = NULL,\n outer_resampling_config = NULL,\n execution_config = setup_ExecutionConfig(),\n question = NULL,\n outdir = NULL,\n verbosity = 1L\n) {\n if (!is.null(outdir)) {\n outdir <- sanitize_path(outdir, must_exist = FALSE, type = \"any\")\n }\n SuperConfigLive(\n dat_training = dat_training,\n dat_validation = dat_validation,\n dat_test = dat_test,\n weights = weights,\n preprocessor_config = preprocessor_config,\n algorithm = algorithm,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n outer_resampling_config = outer_resampling_config,\n execution_config = execution_config,\n question = question,\n outdir = outdir,\n verbosity = as.integer(verbosity)\n )\n} # /rtemis::setup_SuperConfigLive\n" }, { "path": "R/15_CheckData.R", "content": "# CheckData.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% CheckData ----\n#' @author EDG\n#' @noRd\nCheckData <- new_class(\n name = \"CheckData\",\n properties = list(\n object_class = class_character,\n name = class_character,\n n_rows = class_integer,\n n_cols = class_integer,\n n_numeric = class_integer,\n n_integer = class_integer,\n n_character = class_integer,\n n_factor = class_integer,\n n_ordered = class_integer,\n n_date = class_integer,\n n_constant = class_integer,\n n_duplicates = class_integer,\n n_cols_anyna = class_integer,\n n_na = class_integer,\n classes_na = class_any | NULL,\n na_feature_pct = class_data.frame | NULL,\n na_case_pct = class_data.frame | NULL,\n n_na_last_col = class_integer | NULL\n ),\n constructor = function(\n object_class,\n name,\n n_rows,\n n_cols,\n n_numeric,\n n_integer,\n n_character,\n n_factor,\n n_ordered,\n n_date,\n n_constant,\n n_duplicates,\n n_cols_anyna,\n n_na,\n classes_na = NULL,\n na_feature_pct = NULL,\n na_case_pct = NULL,\n n_na_last_col = NULL\n ) {\n n_rows <- clean_int(n_rows)\n n_cols <- clean_int(n_cols)\n n_numeric <- clean_int(n_numeric)\n n_integer <- clean_int(n_integer)\n n_character <- clean_int(n_character)\n n_factor <- clean_int(n_factor)\n n_ordered <- clean_int(n_ordered)\n n_date <- clean_int(n_date)\n n_constant <- clean_int(n_constant)\n n_duplicates <- clean_int(n_duplicates)\n n_cols_anyna <- clean_int(n_cols_anyna)\n n_na <- clean_int(n_na)\n check_inherits(na_feature_pct, \"data.frame\")\n check_inherits(na_case_pct, \"data.frame\")\n n_na_last_col <- clean_int(n_na_last_col)\n new_object(\n S7_object(),\n object_class = object_class,\n name = name,\n n_rows = n_rows,\n n_cols = n_cols,\n n_numeric = n_numeric,\n n_integer = n_integer,\n n_character = n_character,\n n_factor = n_factor,\n n_ordered = n_ordered,\n n_date = n_date,\n n_constant = n_constant,\n n_duplicates = n_duplicates,\n n_cols_anyna = n_cols_anyna,\n n_na = n_na,\n classes_na = classes_na,\n na_feature_pct = na_feature_pct,\n na_case_pct = na_case_pct,\n n_na_last_col = n_na_last_col\n )\n }\n) # /rtemis::CheckData\n\n\n# %% `$`.CheckData ----\n# Make CheckData properties `$`-accessible\nmethod(`$`, CheckData) <- function(x, name) {\n prop(x, name)\n} # /rtemis::`$`.CheckData\n\n\n# %% `.DollarNames`.CheckData ----\n# `$`-autocomplete CheckData properties\nmethod(`.DollarNames`, CheckData) <- function(x, pattern = \"\") {\n all_names <- names(x)\n grep(pattern, all_names, value = TRUE)\n} # /rtemis::`.DollarNames`.CheckData\n\n\n# %% `[[`.CheckData ----\n# Make CheckData properties `[[`-accessible\nmethod(`[[`, CheckData) <- function(x, name) {\n prop(x, name)\n} # /rtemis::`[[`.CheckData\n\n\n# %% repr.CheckData ----\n#' Repr method for CheckData\n#'\n#' @param x CheckData object.\n#'\n#' @return Character: String representation of CheckData object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(repr, CheckData) <- function(\n x,\n name = NULL,\n check_integers = FALSE,\n pad = 0L,\n output_type = NULL\n) {\n out <- repr_S7name(x)\n if (is.null(name)) {\n name <- x[[\"name\"]]\n if (is.null(name)) name <- deparse(substitute(x))\n }\n n_rows <- x[[\"n_rows\"]]\n n_cols <- x[[\"n_cols\"]]\n n_numeric <- x[[\"n_numeric\"]]\n n_integer <- x[[\"n_integer\"]]\n n_character <- x[[\"n_character\"]]\n n_factor <- x[[\"n_factor\"]]\n n_ordered <- x[[\"n_ordered\"]]\n n_date <- x[[\"n_date\"]]\n n_constant <- x[[\"n_constant\"]]\n n_duplicates <- x[[\"n_duplicates\"]]\n n_cols_anyna <- x[[\"n_cols_anyna\"]]\n n_na <- x[[\"n_na\"]]\n n_na_last_col <- x[[\"n_na_last_col\"]]\n\n ## Object class and dimensions ----\n out <- paste0(\n \" \",\n highlight(name, pad = pad, output_type = output_type),\n paste(\n \": A\",\n x[[\"object_class\"]],\n \"with\",\n highlight(\n format(n_rows, trim = TRUE, big.mark = \",\", scientific = FALSE),\n pad = pad,\n output_type = output_type\n ),\n ngettext(n_rows, \"row\", \"rows\"),\n \"and\",\n highlight(\n format(n_cols, trim = TRUE, big.mark = \",\", scientific = FALSE),\n pad = pad,\n output_type = output_type\n ),\n ngettext(n_cols, \"column.\", \"columns.\")\n )\n )\n\n ## Data Types ----\n isOrdered <- if (n_factor == 1) {\n paste(\", which\", ngettext(n_ordered, \"is\", \"is not\"), \"ordered\")\n } else if (n_factor > 1) {\n paste(\n \", of which\",\n fmt(n_ordered, bold = TRUE, pad = pad, output_type = output_type),\n ngettext(n_ordered, \"is\", \"are\"),\n \"ordered\"\n )\n } else {\n \"\"\n }\n out <- paste(\n out,\n fmt(\"\\n Data types\", bold = TRUE, pad = pad, output_type = output_type),\n paste(\n \" *\",\n fmt(n_numeric, bold = TRUE, pad = pad, output_type = output_type),\n \"numeric\",\n ngettext(n_numeric, \"feature\", \"features\")\n ),\n paste(\n \" *\",\n fmt(n_integer, bold = TRUE, pad = pad, output_type = output_type),\n \"integer\",\n ngettext(n_integer, \"feature\", \"features\")\n ),\n paste0(\n \" * \",\n fmt(n_factor, bold = TRUE, pad = pad, output_type = output_type),\n ngettext(n_factor, \" factor\", \" factors\"),\n isOrdered\n ),\n paste(\n \" *\",\n fmt(n_character, bold = TRUE, pad = pad, output_type = output_type),\n \"character\",\n ngettext(n_character, \"feature\", \"features\")\n ),\n paste(\n \" *\",\n fmt(n_date, bold = TRUE, pad = pad, output_type = output_type),\n \"date\",\n ngettext(n_date, \"feature\", \"features\")\n ),\n sep = \"\\n\"\n )\n\n ## Issues ----\n out <- paste(\n out,\n fmt(\"\\n Issues\", bold = TRUE, pad = pad, output_type = output_type),\n sep = \"\\n\"\n )\n out <- paste(\n out,\n paste(\n \" *\",\n fmt(\n n_constant,\n col = if (n_constant > 0) rt_red else NULL,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n \"constant\",\n ngettext(n_constant, \"feature\", \"features\")\n ),\n sep = \"\\n\"\n )\n\n out <- paste(\n out,\n paste(\n \" *\",\n fmt(\n n_duplicates,\n col = if (n_duplicates > 0) rt_orange else NULL,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n \"duplicate\",\n ngettext(n_duplicates, \"case\", \"cases\")\n ),\n sep = \"\\n\"\n )\n\n nas <- if (n_cols_anyna > 0) {\n classes_na <- x[[\"classes_na\"]]\n .col <- if (n_cols_anyna > 0) rt_orange else NULL\n out_nas <- paste(\n fmt(\n n_cols_anyna,\n col = .col,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n ngettext(n_cols_anyna, \"feature includes\", \"features include\"),\n \"'NA' values;\",\n fmt(n_na, col = .col, bold = TRUE, pad = pad, output_type = output_type),\n \"'NA'\",\n ngettext(n_na, \"value\", \"values\"),\n \"total\\n *\",\n paste0(\n mapply(\n function(val, name) {\n paste(\n fmt(\n val,\n col = .col,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n tolower(name)\n )\n },\n classes_na,\n names(classes_na)\n ),\n collapse = \"; \"\n )\n )\n if (n_na_last_col > 0) {\n out_nas <- paste(\n out_nas,\n paste0(\n \"\\n * \",\n fmt(\n n_na_last_col,\n col = .col,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n ngettext(n_na_last_col, \" missing value\", \" missing values\"),\n \" in the last column\"\n )\n )\n }\n out_nas\n } else {\n paste(\n fmt(\"0\", bold = TRUE, pad = pad, output_type = output_type),\n \"missing values\"\n )\n }\n out <- paste0(out, \"\\n * \", nas)\n\n ## Recommendations ----\n out <- paste(\n out,\n fmt(\n \"\\n Recommendations\",\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n sep = \"\\n\"\n )\n\n if (sum(n_character, n_constant, n_duplicates, n_cols_anyna) > 0) {\n if (n_character > 0) {\n out <- paste(\n out,\n fmt(\n \" * Consider converting character features to factors or excluding them.\",\n col = rt_orange,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n sep = \"\\n\"\n )\n }\n if (n_constant > 0) {\n out <- paste(\n out,\n fmt(\n (paste(\n \" * Remove the constant\",\n ngettext(n_constant, \"feature.\", \"features.\")\n )),\n col = rt_red,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n sep = \"\\n\"\n )\n }\n\n if (n_duplicates > 0) {\n out <- paste(\n out,\n fmt(\n paste(\n \" * Consider removing the duplicate\",\n ngettext(n_duplicates, \"case.\", \"cases.\")\n ),\n col = rt_orange,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n sep = \"\\n\"\n )\n }\n\n if (n_cols_anyna > 0) {\n out <- paste(\n out,\n fmt(\n paste(\n \" * Consider using algorithms that can handle missingness or imputing missing values.\"\n ),\n col = rt_blue,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n sep = \"\\n\"\n )\n # Note regarding missing values in last column\n if (n_na_last_col > 0) {\n out <- paste(\n out,\n fmt(\n \"\\n * Filter cases with missing values in the last column if using dataset for supervised learning.\\n\",\n col = rt_orange,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n )\n )\n }\n }\n\n if (check_integers && n_integer > 0) {\n out <- paste(\n out,\n paste0(\n \" * Check the\",\n ifelse(n_integer > 1, paste(\"\", n_integer, \"\"), \" \"),\n \"integer\",\n ngettext(n_integer, \" feature\", \" features\"),\n \" and consider if\",\n ngettext(n_integer, \" it\", \" they\"),\n \" should be converted to \",\n ngettext(n_integer, \"factor\", \"factors\")\n ),\n sep = \"\\n\"\n )\n }\n } else {\n out <- paste(\n out,\n fmt(\n \" * Everything looks good\",\n col = rt_green,\n bold = TRUE,\n pad = pad,\n output_type = output_type\n ),\n sep = \"\\n\"\n )\n }\n paste0(out, \"\\n\")\n} # /rtemis::repr.CheckData\n\n\n# %% print.CheckData ----\nmethod(print, CheckData) <- function(\n x,\n name = NULL,\n check_integers = FALSE,\n output_type = NULL,\n ...\n) {\n cat(repr(\n x,\n name = name,\n check_integers = check_integers,\n output_type = output_type\n ))\n invisible(x)\n} # /rtemis::print.CheckData\n" }, { "path": "R/16_S7utils.R", "content": "# S7_utils\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% SuperWorkers ----\n#' @keywords internal\n#' @noRd\nSuperWorkers <- new_class(\n name = \"SuperWorkers\",\n properties = list(\n algorithm = class_character,\n max_workers = class_integer,\n max_workers_algorithm = class_integer,\n max_workers_tuning = class_integer,\n max_workers_resampling = class_integer\n ),\n constructor = function(\n algorithm,\n max_workers,\n max_workers_algorithm,\n max_workers_tuning,\n max_workers_resampling\n ) {\n max_workers <- clean_posint(max_workers)\n max_workers_algorithm <- clean_posint(max_workers_algorithm)\n max_workers_tuning <- clean_posint(max_workers_tuning)\n max_workers_resampling <- clean_posint(max_workers_resampling)\n # Validate input\n if (\n max_workers_algorithm + max_workers_tuning + max_workers_resampling >\n max_workers\n ) {\n cli::cli_abort(\n \"Total workers for algorithm, tuning, and resampling cannot exceed max_workers.\"\n )\n }\n new_object(\n S7_object(),\n algorithm = algorithm,\n max_workers = max_workers,\n max_workers_algorithm = max_workers_algorithm,\n max_workers_tuning = max_workers_tuning,\n max_workers_resampling = max_workers_resampling\n )\n }\n) # /rtemis::SuperWorkers\n\n\n# %% BiasVariance ----\nBiasVariance <- new_class(\n name = \"BiasVariance\",\n properties = list(\n bias_squared = class_numeric,\n mean_bias_squared = class_numeric,\n sd_bias_squared = class_numeric,\n variance = class_numeric,\n mean_variance = class_numeric,\n sd_variance = class_numeric\n )\n)\n\n# %% `[[`.BiasVariance ----\n# Make BiasVariance props `[[`- accessible ----\nmethod(`[[`, BiasVariance) <- function(x, name) {\n prop(x, name)\n}\n\n\n# %% repr.BiasVariance ----\nmethod(repr, BiasVariance) <- function(\n x,\n pad = 0L,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n paste0(\n repr_S7name(\"BiasVariance\"),\n \"Mean squared bias: \",\n highlight(ddSci(x[[\"mean_bias_squared\"]]), output_type = output_type),\n \" (\",\n ddSci(x[[\"sd_bias_squared\"]]),\n \")\\n\",\n \"Mean variance: \",\n highlight(\n ddSci(x[[\"mean_variance\"]]),\n output_type = output_type\n ),\n \" (\",\n ddSci(x[[\"sd_variance\"]]),\n \")\\n\"\n )\n} # /rtemis::repr.BiasVariance\n\n\n# %% print.BiasVariance ----\n#' Print method for BiasVariance\n#'\n#' @param x BiasVariance object.\n#' @param ... Not used.\n#'\n#' @return `x`, invisibly.\n#'\n#' @author EDG\n#' @noRd\nmethod(print, BiasVariance) <- function(x, ...) {\n cat(repr(x))\n invisible(x)\n} # /rtemis::print.BiasVariance\n" }, { "path": "R/algorithmDB.R", "content": "# algorithmDB.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# Supervised Learning ----\nsupervised_algorithms <- data.frame(rbind(\n c(\"CART\", \"Classification and Regression Trees\", TRUE, TRUE, TRUE),\n c(\"GAM\", \"Generalized Additive Model\", TRUE, TRUE, FALSE),\n c(\"GLM\", \"Generalized Linear Model\", TRUE, TRUE, FALSE),\n c(\"GLMNET\", \"Elastic Net\", TRUE, TRUE, TRUE),\n c(\"Isotonic\", \"Isotonic Regression\", TRUE, TRUE, FALSE),\n c(\"LightCART\", \"Decision Tree\", TRUE, TRUE, FALSE),\n c(\"LightGBM\", \"Gradient Boosting\", TRUE, TRUE, FALSE),\n c(\"LightRF\", \"LightGBM Random Forest\", TRUE, TRUE, FALSE),\n c(\"LightRuleFit\", \"LightGBM RuleFit\", TRUE, TRUE, FALSE),\n c(\"Ranger\", \"Random Forest\", TRUE, TRUE, FALSE),\n c(\n \"LinearSVM\",\n \"Support Vector Machine with Linear Kernel\",\n TRUE,\n TRUE,\n FALSE\n ),\n c(\n \"RadialSVM\",\n \"Support Vector Machine with Radial Kernel\",\n TRUE,\n TRUE,\n FALSE\n ),\n c(\"TabNet\", \"Attentive Interpretable Tabular Learning\", TRUE, TRUE, FALSE)\n))\ncolnames(supervised_algorithms) <- c(\n \"Name\",\n \"Description\",\n \"Class\",\n \"Reg\",\n \"Surv\"\n)\n\nsupervised_multiclass <- c(\n \"GLMNET\",\n \"CART\",\n \"LightCART\",\n \"LightRF\",\n \"LightGBM\",\n \"LinearSVM\",\n \"RadialSVM\",\n \"Ranger\"\n)\n\nget_alg_name <- function(algorithm) {\n algname <- supervised_algorithms[, 1][\n tolower(algorithm) == tolower(supervised_algorithms[, 1])\n ]\n if (length(algname) == 0) {\n cli::cli_abort(algorithm, \"Incorrect algorithm specified\")\n }\n algname\n}\n\nget_alg_setup <- function(algorithm) {\n paste0(\"setup_\", get_alg_name(algorithm))\n}\n\n#' Get algorithm description\n#'\n#' @param algorithm Character: Algorithm name.\n#'\n#' @return Character: Algorithm description.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\ndesc_alg <- function(algorithm) {\n algdesc <- supervised_algorithms[, 2][\n tolower(algorithm) == tolower(supervised_algorithms[, 1])\n ]\n if (length(algdesc) == 0) {\n cli::cli_abort(algorithm, \"Incorrect algorithm specified\")\n }\n algdesc\n} # /rtemis::desc_alg\n\n#' Algorithm description with short name\n#'\n#' @param algorithm Character: Algorithm name.\n#'\n#' @return Character: Algorithm description with short name in parentheses.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\ndesc_abb_alg <- function(algorithm) {\n paste0(\n desc_alg(algorithm),\n \" (\",\n get_alg_name(algorithm),\n \")\"\n )\n} # /rtemis::desc_abb_alg\n\nget_train_fn <- function(algorithm) {\n paste0(\"train_\", get_alg_name(algorithm))\n} # /rtemis::get_train_fn\n\nget_default_hyperparameters <- function(algorithm, type, ncols) {\n alg_name <- get_alg_name(algorithm)\n if (alg_name == \"LightRF\") {\n setup_LightRF(\n feature_fraction = if (type == \"Classification\") {\n sqrt(ncols) / ncols\n } else {\n 0.33\n }\n )\n } else {\n do.call(paste0(\"setup_\", get_alg_name(algorithm)), list())\n }\n} # /rtemis::get_default_hyperparameters\n\n\n# use e.g. in draw_scatter\nsetup_alg <- function(algorithm, ...) {\n alg_name <- get_alg_name(algorithm)\n setup_fn <- get_alg_setup(algorithm)\n do_call(setup_fn, list(...))\n} # /rtemis::setup_alg\n\n# Clustering ----\nclust_algorithms <- data.frame(rbind(\n c(\"CMeans\", \"Fuzzy C-means Clustering\"),\n c(\"DBSCAN\", \"Density-based spatial clustering of applications with noise\"),\n # c(\"EMC\", \"Expectation Maximization Clustering\"),\n c(\"HardCL\", \"Hard Competitive Learning\"),\n # c(\"HOPACH\", \"Hierarchical Ordered Partitioning And Collapsing Hybrid\"),\n # c(\"H2OKMeans\", \"H2O K-Means Clustering\"),\n c(\"KMeans\", \"K-Means Clustering\"),\n # c(\"MeanShift\", \"Mean Shift Clustering\"),\n c(\"NeuralGas\", \"Neural Gas Clustering\")\n # c(\"PAM\", \"Partitioning Around Medoids\"),\n # c(\"PAMK\", \"Partitioning Around Medoids with k estimation\"),\n # c(\"SPEC\", \"Spectral Clustering\")\n))\n\nget_clust_name <- function(algorithm) {\n clustname <- clust_algorithms[, 1][\n tolower(algorithm) == tolower(clust_algorithms[, 1])\n ]\n if (length(clustname) == 0) {\n cli::cli_abort(algorithm, \"Incorrect clustering algorithm specified\")\n }\n clustname\n} # /rtemis::get_clust_name\n\nget_clust_desc <- function(algorithm) {\n clustdesc <- clust_algorithms[, 2][\n tolower(algorithm) == tolower(clust_algorithms[, 1])\n ]\n if (length(clustdesc) == 0) {\n cli::cli_abort(algorithm, \"Incorrect clustering algorithm specified\")\n }\n clustdesc\n} # /rtemis::get_clust_desc\n\nget_clust_fn <- function(algorithm) {\n paste0(\"cluster_\", get_clust_name(algorithm))\n} # /rtemis::get_clust_fn\n\nget_default_clusterparams <- function(algorithm) {\n do.call(paste0(\"setup_\", get_clust_name(algorithm)), list())\n}\n\nget_clustpredict_fn <- function(algorithm) {\n paste0(\"clustpredict_\", get_clust_name(algorithm))\n}\n\nget_clust_setup_fn <- function(algorithm) {\n paste0(\"setup_\", get_clust_name(algorithm))\n} # /rtemis::get_clust_setup_fn\n\n\n# Decomposition ----\ndecom_algorithms <- data.frame(rbind(\n # c(\"H2OAE\", \"H2O Autoencoder\"),\n # c(\"H2OGLRM\", \"H2O Generalized Low-Rank Model\"),\n c(\"ICA\", \"Independent Component Analysis\"),\n c(\"Isomap\", \"Isomap\"),\n # c(\"KPCA\", \"Kernel Principal Component Analysis\"),\n # c(\"LLE\", \"Locally Linear Embedding\"),\n # c(\"MDS\", \"Multidimensional Scaling\"),\n c(\"NMF\", \"Non-negative Matrix Factorization\"),\n c(\"PCA\", \"Principal Component Analysis\"),\n # c(\"SPCA\", \"Sparse Principal Component Analysis\"),\n # c(\"SVD\", \"Singular Value Decomposition\"),\n c(\"tSNE\", \"t-distributed Stochastic Neighbor Embedding\"),\n c(\"UMAP\", \"Uniform Manifold Approximation and Projection\")\n))\n\nget_decom_name <- function(algorithm) {\n decomname <- decom_algorithms[, 1][\n tolower(algorithm) == tolower(decom_algorithms[, 1])\n ]\n if (length(decomname) == 0) {\n cli::cli_abort(algorithm, \"Incorrect decomposition algorithm specified\")\n }\n decomname\n} # /rtemis::get_decom_name\n\nget_decom_desc <- function(algorithm) {\n decomdesc <- decom_algorithms[, 2][\n tolower(algorithm) == tolower(decom_algorithms[, 1])\n ]\n if (length(decomdesc) == 0) {\n cli::cli_abort(algorithm, \"Incorrect decomposition algorithm specified\")\n }\n decomdesc\n} # /rtemis::get_decom_desc\n\nget_decom_fn <- function(algorithm) {\n paste0(\"decom_\", get_decom_name(algorithm))\n} # /rtemis::get_decom_fn\n\nget_default_decomparams <- function(algorithm) {\n do.call(paste0(\"setup_\", get_decom_name(algorithm)), list())\n} # /rtemis::get_default_decomparams\n\nget_decom_setup_fn <- function(algorithm) {\n paste0(\"setup_\", get_decom_name(algorithm))\n} # /rtemis::get_decom_setup_fn\n\nget_decom_predict_fn <- function(algorithm) {\n paste0(\"predict_\", get_decom_name(algorithm))\n} # /rtemis::get_decom_predict_fn\n\n\n#' Available Algorithms\n#'\n#' Print available algorithms for supervised learning, clustering, and decomposition.\n#'\n#' @rdname available_algorithms\n#' @aliases available_algorithms\n#'\n#' @param verbosity Integer: Verbosity level.\n#' @return Named list of algorithm descriptions, invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' available_supervised()\navailable_supervised <- function(verbosity = 1L) {\n algs <- structure(\n supervised_algorithms[, 2],\n names = supervised_algorithms[, 1],\n class = \"list\"\n )\n if (verbosity > 0L) {\n printls(algs, print_class = FALSE, limit = -1L)\n }\n invisible(algs)\n}\n\n#' @rdname available_algorithms\n#' @export\n#'\n#' @examples\n#' available_clustering()\navailable_clustering <- function(verbosity = 1L) {\n algs <- structure(\n clust_algorithms[, 2],\n names = clust_algorithms[, 1],\n class = \"list\"\n )\n if (verbosity > 0L) {\n printls(algs, print_class = FALSE, limit = -1L)\n }\n invisible(algs)\n}\n\n\n#' @rdname available_algorithms\n#' @export\n#'\n#' @examples\n#' available_decomposition()\navailable_decomposition <- function(verbosity = 1L) {\n algs <- structure(\n decom_algorithms[, 2],\n names = decom_algorithms[, 1],\n class = \"list\"\n )\n if (verbosity > 0L) {\n printls(algs, print_class = FALSE, limit = -1L)\n }\n invisible(algs)\n}\n\n# Draw ----\ndraw_fns <- data.frame(\n rbind(\n c(\"draw_3DScatter\", \"3D Scatter Plot\"),\n c(\"draw_bar\", \"Bar Plot\"),\n c(\"draw_box\", \"Box Plot\"),\n c(\"draw_calibration\", \"Calibration Plot\"),\n c(\"draw_confusion\", \"Confusion Matrix\"),\n c(\"draw_dist\", \"Density and Histogram Plots\"),\n c(\"draw_fit\", \"Scatter Plot with Fit Line alias\"),\n c(\"draw_graphD3\", \"Network Graph using networkD3\"),\n c(\"draw_graphjs\", \"Network Graph using graphjs\"),\n c(\"draw_heat\", \"Heatmap using plotly\"),\n c(\"draw_heatmap\", \"Heatmap using heatmaply\"),\n c(\"draw_leafleat\", \"Choropleth Map using leaflet\"),\n c(\"draw_pie\", \"Pie Chart\"),\n c(\"draw_protein\", \"Amino Acid Annotation Plot\"),\n c(\"draw_roc\", \"ROC Curve\"),\n c(\"draw_scatter\", \"Scatter Plot\"),\n c(\"draw_spectrogram\", \"Spectrogram\"),\n c(\"draw_table\", \"Table using plotly\"),\n c(\"draw_ts\", \"Time Series Plot\"),\n c(\"draw_varimp\", \"Barplot for Variable Importance alias\"),\n c(\"draw_volcano\", \"Volcano Plot\"),\n c(\"draw_xt\", \"Time Series Line Plot\")\n )\n)\ncolnames(draw_fns) <- c(\"Function Name\", \"Description\")\n\n\n#' Available Draw Functions\n#'\n#' Print available draw functions for visualization.\n#'\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Named list of draw function descriptions, invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' available_draw()\navailable_draw <- function(verbosity = 1L) {\n fns <- structure(\n draw_fns[, 2],\n names = draw_fns[, 1],\n class = \"list\"\n )\n if (verbosity > 0L) {\n cat(\"Available draw functions:\\n\")\n printls(fns, print_class = FALSE, limit = -1L)\n }\n invisible(fns)\n} # /rtemis::available_draw\n" }, { "path": "R/calibrate.R", "content": "# calibrate.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% calibrate.Classification ----\n#' Calibrate Binary Classification Models\n#'\n#' @description\n#' The goal of calibration is to adjust the predicted probabilities of a binary classification\n#' model so that they better reflect the true probabilities (i.e. empirical risk) of the positive\n#' class.\n#'\n#' @details\n#' Important: The calibration model's training data should be different from the classification\n#' model's training data.\n#'\n#' @param x `Classification` object.\n#' @param predicted_probabilities Numeric vector: Predicted probabilities.\n#' @param true_labels Factor: True class labels.\n#' @param algorithm Character: Algorithm to use to train calibration model.\n#' @param hyperparameters `Hyperparameters` object: Setup using one of `setup_*` functions.\n#' @param verbosity Integer: Verbosity level.\n#' @param ... Not used\n#'\n#' @return `CalibratedClassification` object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' datc2 <- data.frame(\n#' gn = factor(sample(c(\"alpha\", \"beta\", \"gamma\"), 100, replace = TRUE)),\n#' iris[51:150, ]\n#' )\n#' res <- resample(datc2)\n#' datc2$Species <- factor(datc2$Species)\n#' datc2_train <- datc2[res[[1]], ]\n#' datc2_test <- datc2[-res[[1]], ]\n#' mod_c_glm <- train(\n#' x = datc2_train,\n#' dat_test = datc2_test,\n#' algorithm = \"glm\"\n#' )\n#' mod_c_glm_cal <- calibrate(\n#' mod_c_glm,\n#' predicted_probabilities = mod_c_glm$predicted_prob_training,\n#' true_labels = mod_c_glm$y_training\n#' )\n#' mod_c_glm_cal\nmethod(calibrate, Classification) <- function(\n x,\n predicted_probabilities,\n true_labels,\n algorithm = \"isotonic\",\n hyperparameters = NULL,\n verbosity = 1L,\n ...\n) {\n # Check inputs\n check_float01inc(predicted_probabilities)\n check_inherits(true_labels, \"factor\")\n\n # Training data is whatever is passed by user\n dat <- data.table(predicted_probabilities, true_labels)\n # Test data is taken from mod, if available\n if (!is.null(x@y_test) && !is.null(x@predicted_prob_test)) {\n dat_test <- data.table(\n predicted_probabilities = x@predicted_prob_test,\n true_labels = x@y_test\n )\n } else {\n dat_test <- NULL\n }\n # Calibration model\n if (verbosity > 0L) {\n msg(\n fmt(\"<>\", col = col_calibrator, bold = TRUE),\n \"Calibrating\",\n x@algorithm,\n \"classification...\"\n )\n }\n cal_model <- train(\n dat,\n dat_test = dat_test,\n algorithm = algorithm,\n hyperparameters = hyperparameters,\n verbosity = verbosity\n )\n\n mod_cal <- CalibratedClassification(x, cal_model)\n if (verbosity > 0L) {\n message()\n print(mod_cal)\n message()\n }\n if (verbosity > 0L) {\n msg(fmt(\"\", col = col_calibrator, bold = TRUE), \"Calibration done.\")\n }\n mod_cal\n} # /rtemis::calibrate\n\n\n# %% calibrate.ClassificationRes ----\n#' Calibrate Resampled Classification Models\n#'\n#' @param x `ClassificationRes` object.\n#' @param algorithm Character: Algorithm to use to train calibration model.\n#' @param hyperparameters `Hyperparameters` object: Setup using one of `setup_*` functions.\n#' @param resampler_config `ResamplerConfig` object: Configuration for resampling during calibration model training.\n#' @param train_verbosity Integer: Verbosity level for training calibration models.\n#' @param verbosity Integer: Verbosity level.\n#' @param ... Not used\n#'\n#' @return `CalibratedClassificationRes` object.\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(calibrate, ClassificationRes) <- function(\n x,\n algorithm = \"isotonic\",\n hyperparameters = NULL,\n resampler_config = setup_Resampler(\n n_resamples = 5L,\n type = \"KFold\"\n ),\n train_verbosity = 0L,\n verbosity = 1L,\n ...\n) {\n # Check inputs\n check_inherits(algorithm, \"character\")\n check_is_S7(resampler_config, ResamplerConfig)\n verbosity <- clean_int(verbosity)\n\n # Check IFW is FALSE\n if (!is.null(hyperparameters) && hyperparameters[[\"ifw\"]]) {\n cli::cli_abort(\"IFW must be FALSE for proper calibration.\")\n }\n\n # Calibration models\n if (verbosity > 0L) {\n msg(\n fmt(\"<>\", col = col_calibrator, bold = TRUE),\n \"Calibrating\",\n x@algorithm,\n \"resampled classification...\"\n )\n }\n calmods <- lapply(\n x@models,\n function(mod) {\n dat <- data.table(\n predicted_probabilities = mod@predicted_prob_test,\n true_labels = mod@y_test\n )\n train(\n dat,\n algorithm = algorithm,\n hyperparameters = hyperparameters,\n outer_resampling_config = resampler_config,\n verbosity = train_verbosity\n )\n }\n )\n names(calmods) <- names(x@models)\n\n # CalibratedClassificationRes\n modres_cal <- CalibratedClassificationRes(x, calmods)\n\n # Outro ----\n if (verbosity > 0L) {\n message()\n print(modres_cal)\n message()\n }\n if (verbosity > 0L) {\n msg(fmt(\"\", col = col_calibrator, bold = TRUE), \"Calibration done.\")\n }\n modres_cal\n} # /rtemis::calibrate.ClassificationRes\n" }, { "path": "R/check_data.R", "content": "# check_data.R\n# ::rtemis::\n# 2022- EDG rtemis.org\n\n# %% check_data ----\n#' Check Data\n#'\n#' @param x tabular data: Input to be checked.\n#' @param name Character: Name of dataset.\n#' @param get_duplicates Logical: If TRUE, check for duplicate cases.\n#' @param get_na_case_pct Logical: If TRUE, calculate percent of NA values per\n#' case.\n#' @param get_na_feature_pct Logical: If TRUE, calculate percent of NA values\n#' per feature.\n#'\n#' @return `CheckData` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' n <- 1000\n#' x <- rnormmat(n, 50, return_df = TRUE)\n#' x$char1 <- sample(letters, n, TRUE)\n#' x$char2 <- sample(letters, n, TRUE)\n#' x$fct <- factor(sample(letters, n, TRUE))\n#' x <- rbind(x, x[1, ])\n#' x$const <- 99L\n#' x[sample(nrow(x), 20), 3] <- NA\n#' x[sample(nrow(x), 20), 10] <- NA\n#' x$fct[30:35] <- NA\n#' check_data(x)\ncheck_data <- function(\n x,\n name = NULL,\n get_duplicates = TRUE,\n get_na_case_pct = FALSE,\n get_na_feature_pct = FALSE\n) {\n if (is.null(name)) {\n name <- deparse(substitute(x))\n }\n # Check is tabular\n check_tabular(x)\n # Get class of x before converting to data.table\n object_class <- class(x)[1]\n # Convert to data.table\n x <- as.data.table(x)\n n_rows <- NROW(x)\n n_cols <- NCOL(x)\n\n # Data Types ----\n classes <- sapply(x, \\(v) class(v)[1])\n counts <- table(classes)\n\n ## Numeric ----\n n_numeric <- max0(counts[\"numeric\"])\n\n ## Integers ----\n n_integer <- max0(counts[\"integer\"])\n\n ## Characters ----\n n_character <- max0(counts[\"character\"])\n\n ## Factors ----\n index_factor <- which(sapply(x, is.factor))\n n_factor <- length(index_factor)\n index_ordered <- which(sapply(x, is.ordered))\n n_ordered <- length(index_ordered)\n\n ## Dates ----\n n_date <- sum(\n max0(counts[\"Date\"]),\n max0(counts[\"IDate\"]),\n max0(counts[\"POSIXct\"]),\n max0(counts[\"POSIXlt\"])\n )\n\n # Issues ----\n\n ## Constants ----\n index_constant <- which(sapply(x, is_constant))\n n_constant <- length(index_constant)\n\n ## Duplicates ----\n n_duplicates <- if (get_duplicates) {\n n_rows - uniqueN(x)\n } else {\n NA\n }\n\n ## NAs ----\n cols_anyna <- which(sapply(x, anyNA))\n n_cols_anyna <- length(cols_anyna)\n index_na <- which(is.na(x))\n n_na <- length(index_na)\n\n ## Get percent of NA values per feature and per case\n if (n_cols_anyna > 0) {\n na_feature_pct <- if (get_na_feature_pct) {\n data.frame(\n Feature = names(cols_anyna),\n Pct_NA = sapply(seq_len(n_cols_anyna), \\(i) {\n sum(is.na(x[[cols_anyna[i]]])) / n_rows\n })\n )\n } else {\n NULL\n }\n\n index_incomplete <- which(!complete.cases(x))\n n_incomplete <- length(index_incomplete)\n\n na_case_pct <- if (get_na_case_pct) {\n data.frame(\n Case = index_incomplete,\n Pct_NA = sapply(seq_len(n_incomplete), \\(i) {\n sum(is.na(x[index_incomplete[i], ])) / n_cols\n })\n )\n } else {\n NULL\n }\n\n # Get types of features with NA\n classes_na <- table(classes[cols_anyna])\n\n # Get N of NAs in last column\n n_na_last_col <- sum(is.na(x[[n_cols]]))\n } else {\n n_na_last_col <- 0\n classes_na <- NULL\n na_feature_pct <- if (get_na_feature_pct) {\n data.frame(\n Feature = character(0),\n Pct_NA = double(0)\n )\n } else {\n NULL\n }\n na_case_pct <- if (get_na_case_pct) {\n data.frame(\n Case = integer(0),\n Pct_NA = double(0)\n )\n } else {\n NULL\n }\n }\n\n # CheckData ----\n CheckData(\n object_class = object_class,\n name = name,\n n_rows = n_rows,\n n_cols = n_cols,\n n_numeric = n_numeric,\n n_integer = n_integer,\n n_character = n_character,\n n_factor = n_factor,\n n_ordered = n_ordered,\n n_date = n_date,\n n_constant = n_constant,\n n_duplicates = n_duplicates,\n n_cols_anyna = n_cols_anyna,\n n_na = n_na,\n classes_na = classes_na,\n na_feature_pct = na_feature_pct,\n na_case_pct = na_case_pct,\n n_na_last_col = n_na_last_col\n )\n} # /rtemis::check_data\n\n\n# %% max0 ----\n#' Helper function to get max or 0\n#'\n#' @param x Numeric vector\n#'\n#' @return Numeric: max(x, 0)\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmax0 <- function(x) max(x, 0, na.rm = TRUE)\n\n\n# %% to_html.CheckData ----\n#' Generate `CheckData` object description in HTML\n#'\n#' @param x `CheckData` object\n#' @param name Character: Name of the data set\n#' @param css List: CSS styles\n#'\n#' @return `shiny.tag` object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(to_html, CheckData) <- function(\n x,\n name = NULL,\n css = list(\n font_family = \"Helvetica\",\n color = \"#fff\",\n background_color = \"#242424\"\n )\n) {\n n_rows <- x[[\"n_rows\"]]\n n_cols <- x[[\"n_cols\"]]\n n_numeric <- x[[\"n_numeric\"]]\n n_integer <- x[[\"n_integer\"]]\n n_character <- x[[\"n_character\"]]\n n_factor <- x[[\"n_factor\"]]\n n_ordered <- x[[\"n_ordered\"]]\n n_date <- x[[\"n_date\"]]\n n_constant <- x[[\"n_constant\"]]\n n_duplicates <- x[[\"n_duplicates\"]]\n n_cols_anyna <- x[[\"n_cols_anyna\"]]\n n_na <- x[[\"n_na\"]]\n classes_na <- x[[\"classes_na\"]]\n\n ## Data Types ----\n numeric <- HTML(paste(\n strong(n_numeric),\n \"numeric\",\n ngettext(n_numeric, \"feature\", \"features\")\n ))\n integer <- HTML(paste(\n strong(n_integer),\n \"integer\",\n ngettext(n_integer, \"feature\", \"features\")\n ))\n categorical <- HTML(paste0(\n strong(n_factor),\n ngettext(n_factor, \" factor\", \" factors\"),\n if (n_factor == 1) {\n paste(\", which\", ngettext(n_ordered, \"is\", \"is not\"), \"ordered\")\n } else if (n_factor > 1) {\n paste(\n \", of which\",\n strong(n_ordered),\n ngettext(n_ordered, \"is\", \"are\"),\n \"ordered\"\n )\n }\n ))\n # .col <- if (n_character > 0) html_orange else strong\n .col <- strong\n characters <- HTML(paste(\n .col(n_character),\n \"character\",\n ngettext(n_character, \"feature\", \"features\")\n ))\n dates <- HTML(paste(\n strong(n_date),\n \"date\",\n ngettext(n_date, \"feature\", \"features\")\n ))\n\n ## Issues ----\n .col <- if (n_constant > 0) html_red else strong\n constants <- HTML(paste(\n .col(n_constant),\n \"constant\",\n ngettext(n_constant, \"feature\", \"features\")\n ))\n .col <- if (n_duplicates > 0) html_orange else strong\n duplicates <- HTML(paste(\n .col(n_duplicates),\n \"duplicate\",\n ngettext(n_duplicates, \"case\", \"cases\")\n ))\n\n .col <- if (n_cols_anyna > 0) html_orange else strong\n nas <- if (n_cols_anyna > 0) {\n HTML(paste(\n .col(n_cols_anyna),\n ngettext(n_cols_anyna, \"feature includes\", \"features include\"),\n \"'NA' values; \",\n .col(n_na),\n \"'NA'\",\n ngettext(n_na, \"value\", \"values\"),\n \"total\",\n tags[[\"ul\"]](\n lapply(seq_along(classes_na), \\(i) {\n tags[[\"li\"]](HTML(paste(\n .col(classes_na[i]),\n tolower(names(classes_na)[i])\n # ngettext(classes_na[i], \"feature\", \"features\")\n )))\n })\n )\n ))\n } else {\n HTML(paste(strong(\"0\"), \"missing values\"))\n }\n\n ## Recs ----\n rec_constant <- if (n_constant > 0) {\n tags[[\"li\"]](HTML(paste(html_orange(\n \"Remove the constant\",\n ngettext(n_constant, \"feature\", \"features\")\n ))))\n } else {\n NULL\n }\n\n rec_dups <- if (n_duplicates > 0) {\n tags[[\"li\"]](HTML(paste(html_orange(\n \"Consider removing the duplicate\",\n ngettext(n_duplicates, \"case\", \"cases\")\n ))))\n } else {\n NULL\n }\n\n rec_na <- if (n_cols_anyna > 0) {\n list(\n if (isTRUE(classes_na[\"factor\"] > 0)) {\n tags[[\"li\"]](HTML(paste(html_orange(\n \"Consider assigning factor 'NA' values to new 'missing' level\"\n ))))\n },\n tags[[\"li\"]](HTML(paste(html_orange(\n \"Consider imputing missing values or using algorithms that can handle missing values\"\n ))))\n )\n } else {\n NULL\n }\n\n recs <- if (sum(n_constant, n_duplicates, n_cols_anyna) == 0) {\n tags[[\"li\"]](html_success(\"Everything looks good\"))\n } else {\n list(\n rec_constant,\n rec_dups,\n rec_na\n )\n }\n ## out ----\n div(\n p(\n div(\n html_highlight(name),\n \": A\",\n x[[\"class\"]],\n \"with\",\n html_highlight(n_rows),\n ngettext(n_rows, \"row\", \"rows\"),\n \"and\",\n html_highlight(n_cols),\n ngettext(n_cols, \"feature\", \"features\"),\n class = \"checkdata-header\"\n )\n ),\n p(\n span(strong(\"Data types\"), class = \"sidelined\"),\n tags[[\"ul\"]](\n tags[[\"li\"]](numeric),\n tags[[\"li\"]](integer),\n tags[[\"li\"]](categorical),\n tags[[\"li\"]](characters),\n tags[[\"li\"]](dates)\n )\n ), # p Data Types\n p(\n span(strong(\"Issues\"), class = \"sidelined\"),\n tags[[\"ul\"]](\n tags[[\"li\"]](constants),\n tags[[\"li\"]](duplicates),\n tags[[\"li\"]](nas)\n )\n ), # p Issues\n p(\n span(strong(\"Recommendations\"), class = \"sidelined\"),\n tags[[\"ul\"]](\n recs\n )\n ), # p Recommendations\n class = \"checkData\",\n style = paste0(\n \"font-family:\",\n css[[\"font_family\"]],\n \"; color:\",\n css[[\"color\"]],\n \"; background-color:\",\n css[[\"background_color\"]],\n \";\"\n )\n )\n} # /rtemis::to_html.CheckData\n" }, { "path": "R/check_input_data.R", "content": "# check_supervised.R\n# ::rtemis::\n# EDG rtemis.org\n\n# Notes:\n# Some algorithms do not work with variable names containing dots (SparkML)\n\n# %% check_factor_levels.class_data.frame ----\nmethod(check_factor_levels, class_data.frame) <- function(x, y, z) {\n if (!is.null(y) || !is.null(z)) {\n index_factor <- which(sapply(x, is.factor))\n x_levels <- lapply(x[, index_factor, drop = FALSE], levels)\n if (!is.null(y)) {\n y_levels <- lapply(y[, index_factor, drop = FALSE], levels)\n if (\n !all(sapply(seq_along(x_levels), function(i) {\n identical(x_levels[[i]], y_levels[[i]])\n }))\n ) {\n cli::cli_abort(\n \"Training and validation set factor levels do not match.\"\n )\n }\n }\n if (!is.null(z)) {\n z_levels <- lapply(z[, index_factor, drop = FALSE], levels)\n if (\n !all(sapply(seq_along(x_levels), function(i) {\n identical(x_levels[[i]], z_levels[[i]])\n }))\n ) {\n cli::cli_abort(\"Training and test set factor levels do not match.\")\n }\n }\n }\n invisible()\n} # /method(check_factor_levels, class_data.frame)\n\nmethod(check_factor_levels, class_data.table) <- function(x, y, z) {\n if (!is.null(y) || !is.null(z)) {\n index_factor <- which(sapply(x, is.factor))\n x_levels <- lapply(x[, .SD, .SDcols = index_factor], levels)\n if (!is.null(y)) {\n y_levels <- lapply(y[, .SD, .SDcols = index_factor], levels)\n if (\n !all(sapply(seq_along(x_levels), function(i) {\n identical(x_levels[[i]], y_levels[[i]])\n }))\n ) {\n cli::cli_abort(\n \"Training and validation set factor levels do not match.\"\n )\n }\n }\n if (!is.null(z)) {\n z_levels <- lapply(z[, .SD, .SDcols = index_factor], levels)\n if (\n !all(sapply(seq_along(x_levels), function(i) {\n identical(x_levels[[i]], z_levels[[i]])\n }))\n ) {\n cli::cli_abort(\"Training and test set factor levels do not match.\")\n }\n }\n }\n invisible()\n} # /method(check_factor_levels, class_data.table)\n\n#' Check data ahead of supervised learning\n#'\n#' @param x Data frame: Training set features and outcome in the last column.\n#' @param dat_validation Data frame: Validation set features and outcome in the last column.\n#' @param dat_test Data frame: Test set features and outcome in the last column.\n#' @param allow_missing Logical: If TRUE, allow missing values in the data.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return NULL, invisibly. Stops execution if checks fail.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' res <- resample(iris)\n#' iris_train <- iris[res[[1]], ]\n#' iris_test <- iris[-res[[1]], ]\n#' check_supervised(iris_train, dat_test = iris_test)\ncheck_supervised <- function(\n x,\n dat_validation = NULL,\n dat_test = NULL,\n allow_missing = TRUE,\n verbosity = 1L\n) {\n # if (upsample && downsample) cli::cli_abort(\"Only one of upsample and downsample can be TRUE\")\n\n if (verbosity > 0L) {\n msgstart(\"Checking data is ready for training...\")\n }\n\n # Check types ----\n check_inherits(x, \"data.frame\")\n if (!is.null(dat_validation)) {\n check_inherits(dat_validation, \"data.frame\")\n }\n if (!is.null(dat_test)) {\n check_inherits(dat_test, \"data.frame\")\n }\n\n # Check dimensions ----\n ncols <- NCOL(x)\n # Since one column must be outcome, need min of 2 columns\n if (ncols < 2) {\n cli::cli_abort(\"Data must contain at least 1 feature and 1 outcome column.\")\n }\n if (!is.null(dat_validation)) {\n if (NCOL(dat_validation) != ncols) {\n cli::cli_abort(\n \"\\nValidation set must contain same number of columns as training set.\"\n )\n }\n }\n if (!is.null(dat_test)) {\n if (NCOL(dat_test) != ncols) {\n cli::cli_abort(\n \"Test set must contain same number of columns as training set.\"\n )\n }\n }\n\n # Missing values ----\n if (anyNA(outcome(x))) {\n cli::cli_abort(\"Training set outcome cannot contain any missing values.\")\n }\n if (!allow_missing && anyNA(x)) {\n cli::cli_abort(\"Data should not contain missing values.\")\n }\n\n # Outcome class ----\n outcome_class <- class(x[[ncols]])\n if (!outcome_class %in% c(\"integer\", \"numeric\", \"factor\")) {\n cli::cli_abort(\"Outcome must be integer, numeric, or factor.\")\n }\n if (!is.null(dat_validation)) {\n if (class(dat_validation[[ncols]]) != outcome_class) {\n cli::cli_abort(\"Training and validation outcome must be of same class.\")\n }\n }\n if (!is.null(dat_test)) {\n if (class(dat_test[[ncols]]) != outcome_class) {\n cli::cli_abort(\"Training and test outcome must be of same class.\")\n }\n }\n\n # Factor levels ----\n # Check that factors across training, validation, and test contain the same levels.\n check_factor_levels(x = x, y = dat_validation, z = dat_test)\n\n if (verbosity > 0L) {\n msgdone()\n }\n invisible()\n} # /rtemis::check_supervised\n\n\n# %% check_unsupervised_data ----\n#' Check data ahead of unsupervised learning\n#'\n#' @param x Data frame: Features for unsupervised learning.\n#' @param allow_missing Logical: If TRUE, allow missing values in the data. Default is FALSE.\n#'\n#' @return NULL, invisibly. Stops execution if checks fail.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' check_unsupervised_data(iris[, -5])\ncheck_unsupervised_data <- function(x, allow_missing = FALSE, verbosity = 1L) {\n if (verbosity > 0L) {\n msgstart(\"Checking unsupervised data...\")\n }\n if (NCOL(x) < 2) {\n cli::cli_abort(\"Data must contain at least 2 columns.\")\n }\n if (any(sapply(x, function(x) !is.numeric(x)))) {\n cli::cli_abort(\"All columns must be numeric.\")\n }\n if (!allow_missing && anyNA(x)) {\n cli::cli_abort(\"Data should not contain missing values.\")\n }\n if (verbosity > 0L) {\n msgdone()\n }\n invisible()\n} # /rtemis::check_unsupervised_data\n" }, { "path": "R/cluster.R", "content": "# cluster.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% cluster ----\n#' Perform Clustering\n#'\n#' Perform clustering on the rows (usually cases) of a dataset.\n#'\n#' @details\n#' See [docs.rtemis.org/r](https://docs.rtemis.org/r/) for detailed documentation.\n#'\n#' @param x Matrix or data.frame: Data to cluster. Rows are cases to be clustered.\n#' @param algorithm Character: Clustering algorithm.\n#' @param config List: Algorithm-specific config.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `Clustering` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' iris_km <- cluster(exc(iris, \"Species\"), algorithm = \"KMeans\")\ncluster <- function(\n x,\n algorithm = \"KMeans\",\n config = NULL,\n verbosity = 1L\n) {\n # Checks ----\n if (is.null(config)) {\n config <- get_default_clusterparams(algorithm)\n }\n check_is_S7(config, ClusteringConfig)\n\n # Intro ----\n start_time <- intro(verbosity = verbosity)\n\n # Data ----\n if (verbosity > 0L) {\n summarize_unsupervised(x)\n }\n\n # Cluster ----\n algorithm <- get_clust_name(algorithm)\n if (verbosity > 0L) {\n msg0(bold(paste0(\"Clustering with \", algorithm, \"...\")))\n }\n clust <- cluster_(config = config, x = x, verbosity = verbosity)\n\n # Clusters ----\n clusters <- do_call(\n fn = get_clustpredict_fn(algorithm),\n args = list(clust = clust)\n )\n\n if (!is.null(config[[\"k\"]])) {\n # For algorithms where k is specified in config\n k <- config[[\"k\"]]\n } else {\n # For algorithms where k is not prescribed, but determined from the clustering result\n k <- length(unique(clusters))\n if (verbosity > 0L) {\n msg0(paste0(\"Found \", highlight(k), \" clusters.\"))\n }\n }\n\n # Outro ----\n outro(start_time, verbosity = verbosity)\n Clustering(\n algorithm = algorithm,\n clust = clust,\n k = k,\n clusters = clusters,\n config = config\n )\n} # /rtemis::cluster\n" }, { "path": "R/cluster_CMeans.R", "content": "# cluster_CMeans.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% cluster_.CMeansConfig ----\n#' C-means Clustering\n#'\n#' @keywords internal\n#' @noRd\nmethod(cluster_, CMeansConfig) <- function(config, x, verbosity = 1L) {\n # Dependencies ----\n check_dependencies(\"e1071\")\n\n # Data ----\n check_unsupervised_data(x = x, allow_missing = FALSE, verbosity = verbosity)\n\n # Cluster ----\n if (verbosity > 0L) {\n msg(\"Clustering with\", config@algorithm, \"...\")\n }\n clust <- e1071::cmeans(\n x = x,\n centers = config[[\"k\"]],\n iter.max = config[[\"max_iter\"]],\n verbose = verbosity > 0L,\n dist = config[[\"dist\"]],\n method = config[[\"method\"]],\n m = config[[\"m\"]],\n rate.par = config[[\"rate_par\"]],\n weights = config[[\"weights\"]],\n control = config[[\"control\"]]\n )\n check_inherits(clust, \"fclust\")\n clust\n} # /rtemis::cluster_.CMeansConfig\n\n\n# %% clustpredict_CMeans ----\nclustpredict_CMeans <- function(clust) {\n check_inherits(clust, \"fclust\")\n clust[[\"cluster\"]]\n} # /rtemis::clustpredict_CMeans\n" }, { "path": "R/cluster_DBSCAN.R", "content": "# cluster_DBSCAN.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% cluster_.DBSCANConfig ----\n#' Density-based spatial clustering of applications with noise (DBSCAN)\n#'\n#' @keywords internal\n#' @noRd\nmethod(cluster_, DBSCANConfig) <- function(config, x, verbosity = 1L) {\n # Checks ----\n check_is_S7(config, DBSCANConfig)\n\n # Dependencies ----\n check_dependencies(\"dbscan\")\n\n # Data ----\n check_unsupervised_data(x = x, allow_missing = FALSE, verbosity = verbosity)\n\n # Cluster ----\n if (verbosity > 0L) {\n msg(\"Clustering with\", config@algorithm, \"...\")\n }\n clust <- dbscan::dbscan(\n x = x,\n eps = config[[\"eps\"]],\n minPts = config[[\"min_points\"]],\n weights = config[[\"weights\"]],\n borderPoints = config[[\"border_points\"]],\n search = config[[\"search\"]],\n bucketSize = config[[\"bucket_size\"]],\n splitRule = config[[\"split_rule\"]],\n approx = config[[\"approx\"]]\n )\n check_inherits(clust, \"dbscan\")\n clust\n} # /rtemis::cluster_.DBSCANConfig\n\n\n# %% clustpredict_DBSCAN ----\nclustpredict_DBSCAN <- function(clust, dat_train = NULL, newdata = NULL) {\n check_inherits(clust, \"dbscan\")\n if (is.null(newdata)) {\n return(clust[[\"cluster\"]])\n } else {\n predict(clust, newdata = newdata, data = dat_train)\n }\n} # /rtemis::clustpredict_DBSCAN\n" }, { "path": "R/cluster_flexclust.R", "content": "# cluster_KMeans.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% cluster_.KMeansConfig ----\n#' K-means Clustering\n#'\n#' @keywords internal\n#' @noRd\nmethod(cluster_, KMeansConfig) <- function(config, x, verbosity = 1L) {\n # Dependencies ----\n check_dependencies(\"flexclust\")\n\n # Data ----\n check_unsupervised_data(x = x, allow_missing = FALSE, verbosity = verbosity)\n\n # Cluster ----\n if (verbosity > 0L) {\n msg(\"Clustering with\", config@algorithm, \"...\")\n }\n clust <- flexclust::cclust(\n x = x,\n k = config[[\"k\"]],\n dist = config[[\"dist\"]],\n method = \"kmeans\"\n )\n check_inherits(clust, \"kcca\")\n clust\n} # /rtemis::cluster_.KMeansConfig\n\n\n# %% cluster_.HardCLConfig ----\n#' Hard Competitive Learning Clustering\n#'\n#' @keywords internal\n#' @noRd\nmethod(cluster_, HardCLConfig) <- function(config, x, verbosity = 1L) {\n # Checks ----\n check_is_S7(config, HardCLConfig)\n\n # Dependencies ----\n check_dependencies(\"flexclust\")\n\n # Data ----\n check_unsupervised_data(x = x, allow_missing = FALSE, verbosity = verbosity)\n\n # Cluster ----\n if (verbosity > 0L) {\n msg(\"Clustering with\", config@algorithm, \"...\")\n }\n clust <- flexclust::cclust(\n x = x,\n k = config[[\"k\"]],\n dist = config[[\"dist\"]],\n method = \"hardcl\"\n )\n check_inherits(clust, \"kcca\")\n clust\n} # /rtemis::cluster_.HardCLConfig\n\n\n# %% cluster_.NeuralGasConfig ----\n#' Neural Gas Clustering\n#'\n#' @keywords internal\n#' @noRd\nmethod(cluster_, NeuralGasConfig) <- function(config, x, verbosity = 1L) {\n # Dependencies ----\n check_dependencies(\"flexclust\")\n\n # Data ----\n check_unsupervised_data(x = x, allow_missing = FALSE, verbosity = verbosity)\n\n # Cluster ----\n if (verbosity > 0L) {\n msg(\"Clustering with\", config@algorithm, \"...\")\n }\n clust <- flexclust::cclust(\n x = x,\n k = config[[\"k\"]],\n dist = config[[\"dist\"]],\n method = \"neuralgas\"\n )\n check_inherits(clust, \"kcca\")\n clust\n} # /rtemis::cluster_.NeuralGasConfig\n\n\n# %% clustpredict_{KMeans,HardCL,NeuralGas} ----\n#' clustpredict methods for KMeans, HardCL, NeuralGas\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nclustpredict_KMeans <- clustpredict_HardCL <- clustpredict_NeuralGas <- function(\n clust,\n newdata = NULL\n) {\n check_inherits(clust, \"kcca\")\n flexclust::clusters(clust, newdata = newdata)\n} # /rtemis::clustpredict_{KMeans,HardCL,NeuralGas}\n" }, { "path": "R/data_xt_example.R", "content": "#' Example longitudinal dataset\n#'\n#' A small synthetic dataset demonstrating various participation patterns\n#' in longitudinal data, suitable for examples with \\code{\\link{xtdescribe}}.\n#'\n#' @format A data frame with 30 rows and 4 variables:\n#' \\describe{\n#' \\item{patient_id}{Integer: Patient identifier (1-10).}\n#' \\item{year}{Integer: Year of measurement (2020-2024).}\n#' \\item{blood_pressure}{Numeric: Systolic blood pressure measurement.}\n#' \\item{treatment}{Character: Treatment group (\"A\" or \"B\").}\n#' }\n#'\n#' @details\n#' This dataset includes 10 patients measured at up to 5 time points (years 2020-2024).\n#' The dataset demonstrates various participation patterns typical in longitudinal studies:\n#' \\itemize{\n#' \\item Complete participation (all time points)\n#' \\item Early dropout\n#' \\item Late entry\n#' \\item Intermittent participation\n#' \\item Single time point participation\n#' }\n#'\n#' @examples\n#' data(xt_example)\n#' head(xt_example)\n#' summary(xt_example)\n#'\n#' @keywords datasets\n\"xt_example\"\n" }, { "path": "R/ddSci.R", "content": "# ddSci.R\n# ::rtemis::\n# 2015- EDG rtemis.org\n\n#' Format Numbers for Printing\n#'\n#' 2 Decimal places, otherwise scientific notation\n#'\n#' Numbers will be formatted to 2 decimal places, unless this results in 0.00 (e.g. if input was .0032),\n#' in which case they will be converted to scientific notation with 2 significant figures.\n#' `ddSci` will return `0.00` if the input is exactly zero.\n#' This function can be used to format numbers in plots, on the console, in logs, etc.\n#'\n#' @param x Vector of numbers\n#' @param decimal_places Integer: Return this many decimal places.\n#' @param hi Float: Threshold at or above which scientific notation is used.\n#' @param as_numeric Logical: If TRUE, convert to numeric before returning.\n#' This will not force all numbers to print 2 decimal places. For example:\n#' 1.2035 becomes \"1.20\" if `as_numeric = FALSE`, but 1.2 otherwise\n#' This can be helpful if you want to be able to use the output as numbers / not just for printing.\n#' @return Formatted number\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- .34876549\n#' ddSci(x)\n#' # \"0.35\"\n#' x <- .00000000457823\n#' ddSci(x)\n#' # \"4.6e-09\"\nddSci <- function(x, decimal_places = 2, hi = 1e06, as_numeric = FALSE) {\n if (is.null(x)) {\n if (as_numeric) {\n return(NULL)\n } else {\n return(\"NULL\")\n }\n }\n # Do not format factors, characters, or integers.\n if (is.factor(x) || is.character(x)) {\n return(as.character(x))\n }\n if (is.integer(x)) {\n return(x)\n }\n\n x <- as.list(unlist(x))\n\n x <- lapply(x, as.numeric)\n\n xf <- list()\n\n # Check for non-zero decimals\n # decs <- sum(unlist(x) %% 1, na.rm = TRUE) > 0\n\n for (i in seq(x)) {\n if (is.na(x[[i]])) {\n xf[[i]] <- NA\n } else {\n # if (decs & x[[i]] == 0) { # x[[i]] is zero but others have decimals\n if (x[[i]] == 0) {\n # always give requested decimal places\n xf[[i]] <- format(0, nsmall = decimal_places)\n } else {\n if (abs(x[[i]]) >= hi) {\n xf[[i]] <- format(\n round(x[[i]], decimal_places),\n scientific = TRUE,\n digits = decimal_places,\n nsmall = decimal_places\n )\n } else {\n # if (decs) {\n # xf[[i]] <- ifelse(round(x[[i]], 2) != 0,\n # format(round(x[[i]], decimal_places), nsmall = decimal_places),\n # format(x[[i]], scientific = TRUE, digits = 2)\n # )\n # } else {\n # xf[[i]] <- as.character(x[[i]])\n # }\n xf[[i]] <- ifelse(\n round(x[[i]], 2) != 0,\n format(round(x[[i]], decimal_places), nsmall = decimal_places),\n format(x[[i]], scientific = TRUE, digits = 2)\n )\n }\n }\n }\n }\n xf <- as.character(xf)\n if (as_numeric) {\n xf <- as.numeric(xf)\n }\n xf\n} # /rtemis::ddSci\n" }, { "path": "R/ddb.R", "content": "# ddb.R\n# ::rtemis::\n# 2022- EDG rtemis.org\n\n#' Read CSV using DuckDB\n#'\n#' Lazy-read a CSV file, optionally: filter rows, remove duplicates,\n#' clean column names, convert character to factor, collect.\n#'\n#' @param filename Character: file name; either full path or just the file name,\n#' if `datadir` is also provided.\n#' @param datadir Character: Optional path if `filename` is not full path.\n#' @param sep Character: Field delimiter/separator.\n#' @param header Logical: If TRUE, first line will be read as column names.\n#' @param quotechar Character: Quote character.\n#' @param ignore_errors Logical: If TRUE, ignore parsing errors (sometimes it's\n#' either this or no data, so).\n#' @param make_unique Logical: If TRUE, keep only unique rows.\n#' @param select_columns Character vector: Column names to select.\n#' @param filter_column Character: Name of column to filter on, e.g. \"ID\".\n#' @param filter_vals Numeric or Character vector: Values in `filter_column` to keep.\n#' `filter_column` to keep.\n#' @param character2factor Logical: If TRUE, convert character columns to\n#' factors.\n#' @param collect Logical: If TRUE, collect data and return structure class\n#' as defined by `returnobj`.\n#' @param progress Logical: If TRUE, print progress (no indication this works).\n#' @param returnobj Character: \"data.frame\" or \"data.table\" object class to\n#' return. If \"data.table\", data.frame object returned from\n#' `DBI::dbGetQuery` is passed to `data.table::setDT`; will add to\n#' execution time if very large, but then that's when you need a data.table.\n#' @param data.table.key Character: If set, this corresponds to a column name in the\n#' dataset. This column will be set as key in the data.table output.\n#' @param clean_colnames Logical: If TRUE, clean colnames with\n#' [clean_colnames].\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return data.frame or data.table if `collect` is TRUE, otherwise a character with the SQL query\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' \\dontrun{\n#' # Requires local CSV file; replace with your own path\n#' ir <- ddb_data(\"/Data/massive_dataset.csv\",\n#' filter_column = \"ID\",\n#' filter_vals = 8001:9999\n#' )\n#' }\nddb_data <- function(\n filename,\n datadir = NULL,\n sep = \",\",\n header = TRUE,\n quotechar = \"\",\n ignore_errors = TRUE,\n make_unique = TRUE,\n select_columns = NULL,\n filter_column = NULL,\n filter_vals = NULL,\n character2factor = FALSE,\n collect = TRUE,\n progress = TRUE,\n returnobj = c(\"data.table\", \"data.frame\"),\n data.table.key = NULL,\n clean_colnames = TRUE,\n verbosity = 1L\n) {\n # Intro ----\n check_dependencies(\"DBI\", \"duckdb\")\n returnobj <- match.arg(returnobj)\n if (!is.null(data.table.key)) {\n returnobj <- \"data.table\"\n }\n path <- if (is.null(datadir)) {\n normalizePath(filename)\n } else {\n file.path(normalizePath(datadir), filename)\n }\n check_files(path, verbosity = 0L)\n fileext <- tools::file_ext(path)\n\n out <- paste(\n bold(highlight(\"\\u25B6\")),\n ifelse(collect, \"Reading\", \"Lazy-reading\"),\n highlight(basename(path))\n )\n if (!is.null(filter_column)) {\n out <- paste(\n out,\n bold(highlight(\"\\u29e8\")),\n \"filtering on\",\n bold(filter_column)\n )\n }\n start_time <- intro(out, verbosity = verbosity)\n distinct <- ifelse(make_unique, \"DISTINCT \", NULL)\n select <- if (!is.null(select_columns)) {\n ls2sel(select_columns)\n } else {\n \"*\"\n }\n\n # SQL ----\n sql <- if (fileext == \"parquet\") {\n paste0(\n \"SELECT \",\n paste0(distinct, select),\n \" FROM read_parquet('\",\n path,\n \"')\"\n )\n } else {\n paste0(\n \"SELECT \",\n paste0(distinct, select),\n \" FROM read_csv_auto('\",\n path,\n \"',\n sep='\",\n sep,\n \"', quote='\",\n quotechar,\n \"',\n header=\",\n header,\n \", ignore_errors=\",\n ignore_errors,\n \")\"\n )\n }\n\n sql <- if (!is.null(filter_column)) {\n vals <- if (is.numeric(filter_vals)) {\n paste0(filter_vals, collapse = \", \")\n } else {\n paste0(\"'\", paste0(filter_vals, collapse = \"', '\"), \"'\")\n }\n paste(\n sql,\n \"WHERE\",\n filter_column,\n \"in (\",\n vals,\n \");\"\n )\n } else {\n paste0(sql, \";\")\n }\n\n # Collect ----\n if (collect) {\n conn <- DBI::dbConnect(duckdb::duckdb())\n on.exit(DBI::dbDisconnect(conn, shutdown = TRUE))\n # on.exit(\n # tryCatch(DBI::dbRollback(conn), error = function(e) {\n # }))\n if (progress) {\n DBI::dbExecute(conn, \"PRAGMA enable_progress_bar;\")\n }\n out <- DBI::dbGetQuery(conn, sql)\n if (clean_colnames) {\n names(out) <- clean_colnames(out)\n }\n if (returnobj == \"data.table\") {\n data.table::setDT(out)\n if (!is.null(data.table.key)) {\n data.table::setkeyv(out, data.table.key)\n }\n }\n if (character2factor) {\n out <- preprocess(out, setup_Preprocessor(character2factor = TRUE))\n }\n } else {\n out <- sql\n }\n\n # Outro ----\n outro(start_time, verbosity = verbosity)\n out\n} # /rtemis::ddb_data\n\n\n# output: '\"alpha\", \"beta\", \"gamma\"'\nls2sel <- function(x) {\n paste0(\n '\"',\n paste0(x, collapse = '\", \"'),\n '\"'\n )\n}\n\n\n#' Collect a lazy-read duckdb table\n#'\n#' Collect a table read with `ddb_data(x, collect = FALSE)`\n#'\n#' @param sql Character: DuckDB SQL query, usually output of\n#' [ddb_data] with `collect = FALSE`\n#' @param progress Logical: If TRUE, show progress bar\n#' @param returnobj Character: data.frame or data.table: class of object to return\n#'\n#' @return `data.frame` or `data.table`.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' \\dontrun{\n#' # Requires local CSV file; replace with your own path\n#' sql <- ddb_data(\"/Data/iris.csv\", collect = FALSE)\n#' ir <- ddb_collect(sql)\n#' }\nddb_collect <- function(\n sql,\n progress = TRUE,\n returnobj = c(\"data.frame\", \"data.table\")\n) {\n returnobj <- match.arg(returnobj)\n conn <- DBI::dbConnect(duckdb::duckdb())\n on.exit(DBI::dbDisconnect(conn, shutdown = TRUE))\n if (progress) {\n DBI::dbExecute(conn, \"PRAGMA enable_progress_bar;\")\n }\n out <- DBI::dbGetQuery(conn, sql)\n if (returnobj == \"data.table\") {\n setDT(out)\n }\n out\n} # /rtemis::ddb_collect\n" }, { "path": "R/decomp.R", "content": "# decomp.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% decomp ----\n#' Perform Data Decomposition\n#'\n#' Perform linear or non-linear decomposition of numeric data.\n#'\n#' @details\n#' See [docs.rtemis.org/r](https://docs.rtemis.org/r/) for detailed documentation.\n#'\n#' @param x Matrix or data frame: Input data.\n#' @param algorithm Character: Decomposition algorithm.\n#' @param config DecompositionConfig: Algorithm-specific config.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `Decomposition` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' iris_pca <- decomp(exc(iris, \"Species\"), algorithm = \"PCA\")\ndecomp <- function(x, algorithm = \"ICA\", config = NULL, verbosity = 1L) {\n # Checks ----\n if (is.null(config)) {\n config <- get_default_decomparams(algorithm)\n }\n check_is_S7(config, DecompositionConfig)\n\n # Intro ----\n start_time <- intro(verbosity = verbosity)\n\n # Data ----\n if (verbosity > 0L) {\n summarize_unsupervised(x)\n }\n\n # Decompose ----\n algorithm <- get_decom_name(algorithm)\n if (verbosity > 0L) {\n msg0(\"Decomposing with \", algorithm, \"...\")\n }\n\n # decomp_ -> list with elements 'decom' and 'transformed'\n decom <- decomp_(config = config, x = x, verbosity = verbosity)\n\n # Outro ----\n outro(start_time, verbosity = verbosity)\n Decomposition(\n algorithm = algorithm,\n config = config,\n decom = decom[[\"decom\"]],\n transformed = decom[[\"transformed\"]]\n )\n} # /rtemis::decomp\n" }, { "path": "R/decomp_ICA.R", "content": "# decom_ICA.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% decomp_.ICAConfig ----\n#' ICA Decomposition\n#'\n#' @keywords internal\n#' @noRd\nmethod(decomp_, ICAConfig) <- function(config, x, verbosity = 1L) {\n # Checks ----\n check_dependencies(\"fastICA\")\n check_unsupervised_data(x = x, allow_missing = FALSE)\n\n # Decompose ----\n if (verbosity > 0L) {\n msg(\"Decomposing with\", config@algorithm, \"...\")\n }\n decom <- fastICA::fastICA(\n X = as.matrix(x),\n n.comp = config[[\"k\"]],\n alg.typ = config[[\"type\"]],\n fun = config[[\"fun\"]],\n alpha = config[[\"alpha\"]],\n method = \"C\",\n row.norm = config[[\"row_norm\"]],\n maxit = config[[\"maxit\"]],\n tol = config[[\"tol\"]],\n verbose = verbosity > 0L\n )\n check_inherits(decom, \"list\")\n list(decom = decom, transformed = decom[[\"S\"]])\n} # /rtemis::decomp_.ICAConfig\n" }, { "path": "R/decomp_Isomap.R", "content": "# decom_Isomap.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% decomp_.IsomapConfig ----\n#' Isomap Decomposition\n#'\n#' @keywords internal\n#' @noRd\nmethod(decomp_, IsomapConfig) <- function(config, x, verbosity = 1L) {\n # Checks ----\n check_dependencies(\"vegan\")\n check_unsupervised_data(x = x, allow_missing = FALSE)\n\n # Decompose ----\n if (verbosity > 0L) {\n msg(\"Decomposing with\", config@algorithm, \"...\")\n }\n dst <- vegan::vegdist(x = x, method = config[[\"dist_method\"]])\n decom <- vegan::isomap(\n dist = dst,\n ndim = config[[\"k\"]],\n k = config[[\"nsd\"]],\n path = config[[\"path\"]]\n )\n check_inherits(decom, \"isomap\")\n list(decom = decom, transformed = decom[[\"points\"]])\n} # /rtemis::decomp_.IsomapConfig\n" }, { "path": "R/decomp_NMF.R", "content": "# decom_NMF.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% decomp_.NMFConfig ----\n#' Non-negative Matrix Factorization (NMF)\n#'\n#' Decomposes a data matrix into non-negative factors using NMF.\n#'\n#' @param x A numeric matrix or data frame to be decomposed.\n#' @param config `NMFConfig` object.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return A list containing the decomposition and transformed data.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(decomp_, NMFConfig) <- function(config, x, verbosity = 1L) {\n # Checks ----\n check_is_S7(config, NMFConfig)\n check_dependencies(\"NMF\")\n check_unsupervised_data(x = x, allow_missing = FALSE)\n\n # Decompose ----\n if (verbosity > 0L) {\n msg(\"Decomposing with\", config@algorithm, \"...\")\n }\n xm <- as.matrix(x)\n args <- list(x = t(xm), rank = config[[\"k\"]], nrun = config[[\"nrun\"]])\n decom <- do_call(NMF::nmf, args)\n check_inherits(decom, \"NMFfit\")\n basis <- NMF::basis(decom)\n transformed <- xm %*% basis\n colnames(transformed) <- paste0(\"NMF_\", seq_len(NCOL(transformed)))\n list(decom = decom, transformed = transformed)\n} # /rtemis::decomp_.NMFConfig\n" }, { "path": "R/decomp_PCA.R", "content": "# decom_PCA.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% decomp_.PCAConfig ----\n#' PCA Decomposition\n#'\n#' @keywords internal\n#' @noRd\nmethod(decomp_, PCAConfig) <- function(config, x, verbosity = 1L) {\n # Checks ----\n check_is_S7(config, PCAConfig)\n check_unsupervised_data(x = x, allow_missing = FALSE)\n\n # Decompose ----\n if (verbosity > 0L) {\n msg(\"Decomposing with\", config@algorithm, \"...\")\n }\n decom <- prcomp(\n x = x,\n center = config[[\"center\"]],\n scale. = config[[\"scale\"]],\n tol = config[[\"tol\"]],\n rank. = config[[\"k\"]]\n )\n check_inherits(decom, \"prcomp\")\n list(decom = decom, transformed = decom[[\"x\"]])\n} # /rtemis::decomp_.PCAConfig\n" }, { "path": "R/decomp_UMAP.R", "content": "# decom_UMAP.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% decomp_.UMAPConfig ----\n#' UMAP Decomposition\n#'\n#' @param x A numeric matrix or data frame to be decomposed.\n#' @param config `UMAPConfig` object.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return A list containing the decomposition and transformed data.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(decomp_, UMAPConfig) <- function(config, x, verbosity = 1L) {\n # Checks ----\n check_is_S7(config, UMAPConfig)\n check_dependencies(\"uwot\")\n check_unsupervised_data(x = x, allow_missing = FALSE)\n\n # Decompose ----\n if (verbosity > 0L) {\n msg(\"Decomposing with\", config@algorithm, \"...\")\n }\n args <- c(\n list(X = x, n_components = config[[\"k\"]], ret_model = TRUE),\n config@config\n )\n args[[\"k\"]] <- NULL\n decom <- do_call(\n uwot::umap,\n args,\n error_pattern_suggestion = list(\n \"as_cholmod_sparse\" = \"Try installing packages 'Matrix' and 'irlba' from source.\"\n )\n )\n # ret_model = TRUE returns list\n check_inherits(decom, \"list\")\n list(decom = decom, transformed = decom[[\"embedding\"]])\n} # /rtemis::decomp_.UMAPConfig\n" }, { "path": "R/decomp_tSNE.R", "content": "# decom_tSNE.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% decomp_.tSNEConfig ----\n#' tSNE Decomposition\n#'\n#' @keywords internal\n#' @noRd\nmethod(decomp_, tSNEConfig) <- function(config, x, verbosity = 1L) {\n # Checks ----\n check_is_S7(config, tSNEConfig)\n check_dependencies(\"Rtsne\")\n check_unsupervised_data(x = x, allow_missing = FALSE)\n\n # Decompose ----\n if (verbosity > 0L) {\n msg(\"Decomposing with\", config@algorithm, \"...\")\n }\n args <- c(list(X = x, dims = config[[\"k\"]]), config@config)\n args[[\"k\"]] <- NULL\n decom <- do_call(\n Rtsne::Rtsne,\n args,\n error_pattern_suggestion = list(\n \"Remove duplicates\" = \"Remove duplicates using `preprocess()\"\n )\n )\n check_inherits(decom, \"Rtsne\")\n list(decom = decom, transformed = decom[[\"Y\"]])\n} # /rtemis::decomp_.tSNEConfig\n" }, { "path": "R/draw_3Dscatter.R", "content": "# draw_3Dscatter.R\n# ::rtemis::\n# 2019- EDG rtemis.org\n\n#' Interactive 3D Scatter Plots\n#'\n#' Draw interactive 3D scatter plots using `plotly`.\n#'\n#' @details\n#' See [docs.rtemis.org/r](https://docs.rtemis.org/r/) for detailed documentation.\n#'\n#' Note that `draw_3Dscatter` uses the theme's `plot_bg` as `grid_col`.\n#'\n#' @param x Numeric, vector/data.frame/list: x-axis data.\n#' @param y Numeric, vector/data.frame/list: y-axis data.\n#' @param z Numeric, vector/data.frame/list: z-axis data.\n#' @param fit Character: Fit method.\n#' @param cluster Character: Clustering method.\n#' @param cluster_config List: Config for clustering.\n#' @param group Factor: Grouping variable.\n#' @param formula Formula: Formula for non-linear least squares fit.\n#' @param rsq Logical: If TRUE, print R-squared values in legend if `fit` is set.\n#' @param mode Character, vector: \"markers\", \"lines\", \"markers+lines\".\n#' @param order_on_x Logical: If TRUE, order `x` and `y` on `x`.\n#' @param main Character: Main title.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param zlab Character: z-axis label.\n#' @param alpha Numeric: Alpha for markers.\n#' @param bg Background color.\n#' @param plot_bg Plot background color.\n#' @param theme `Theme` object.\n#' @param palette Character vector: Colors to use.\n#' @param axes_square Logical: If TRUE, draw a square plot.\n#' @param group_names Character: Names for groups.\n#' @param font_size Numeric: Font size.\n#' @param marker_col Color for markers.\n#' @param marker_size Numeric: Marker size.\n#' @param fit_col Color for fit line.\n#' @param fit_alpha Numeric: Alpha for fit line.\n#' @param fit_lwd Numeric: Line width for fit line.\n#' @param tick_font_size Numeric: Tick font size.\n#' @param spike_col Spike lines color.\n#' @param legend Logical: If TRUE, draw legend.\n#' @param legend_xy Numeric: Position of legend.\n#' @param legend_xanchor Character: X anchor for legend.\n#' @param legend_yanchor Character: Y anchor for legend.\n#' @param legend_orientation Character: Orientation of legend.\n#' @param legend_col Color for legend text.\n#' @param legend_bg Color for legend background.\n#' @param legend_border_col Color for legend border.\n#' @param legend_borderwidth Numeric: Border width for legend.\n#' @param legend_group_gap Numeric: Gap between legend groups.\n#' @param margin Numeric, named list: Margins for top, bottom, left, right.\n#' @param fit_params `Hyperparameters` for fit.\n#' @param width Numeric: Width of plot.\n#' @param height Numeric: Height of plot.\n#' @param padding Numeric: Graph padding.\n#' @param displayModeBar Logical: If TRUE, display mode bar.\n#' @param modeBar_file_format Character: File format for mode bar.\n#' @param verbosity Integer: Verbosity level.\n#' @param filename Character: Filename to save plot.\n#' @param file_width Numeric: Width of saved file.\n#' @param file_height Numeric: Height of saved file.\n#' @param file_scale Numeric: Scale of saved file.\n#'\n#' @return A `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' draw_3Dscatter(iris, group = iris$Species, theme = theme_darkgraygrid())\ndraw_3Dscatter <- function(\n x,\n y = NULL,\n z = NULL,\n fit = NULL,\n cluster = NULL,\n cluster_config = NULL,\n group = NULL,\n formula = NULL,\n rsq = TRUE,\n mode = \"markers\",\n order_on_x = NULL,\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n zlab = NULL,\n alpha = .8,\n bg = NULL,\n plot_bg = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n axes_square = FALSE,\n group_names = NULL,\n font_size = 16,\n marker_col = NULL,\n marker_size = 8,\n fit_col = NULL,\n fit_alpha = .7,\n fit_lwd = 2.5,\n tick_font_size = 12,\n spike_col = NULL,\n legend = NULL,\n legend_xy = c(0, 1),\n legend_xanchor = \"left\",\n legend_yanchor = \"auto\",\n legend_orientation = \"v\",\n legend_col = NULL,\n legend_bg = \"#FFFFFF00\",\n legend_border_col = \"#FFFFFF00\",\n legend_borderwidth = 0,\n legend_group_gap = 0,\n margin = list(t = 30, b = 0, l = 0, r = 0),\n fit_params = NULL,\n width = NULL,\n height = NULL,\n padding = 0,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n verbosity = 0L,\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1\n) {\n # Dependencies ----\n check_dependencies(\"plotly\")\n\n # Arguments ----\n if (is.null(y) && is.null(z) && NCOL(x) > 2) {\n .colnames <- labelify(colnames(x))\n y <- x[, 2]\n z <- x[, 3]\n x <- x[, 1]\n if (is.null(xlab)) {\n xlab <- .colnames[1]\n }\n if (is.null(ylab)) {\n ylab <- .colnames[2]\n }\n if (is.null(zlab)) zlab <- .colnames[3]\n }\n if (!is.null(main)) {\n main <- paste0(\"\", main, \"\")\n }\n if (!is.null(fit)) {\n if (fit == \"none\") fit <- NULL\n } # easier to work with shiny\n if (!is.null(fit)) {\n fit <- toupper(fit)\n }\n .mode <- mode\n .names <- group_names\n\n # order_on_x ----\n if (is.null(order_on_x)) {\n order_on_x <- if (!is.null(fit) || any(grepl(\"lines\", mode))) {\n TRUE\n } else {\n FALSE\n }\n }\n\n # Cluster ----\n if (!is.null(cluster)) {\n group <- suppressWarnings(\n cluster(\n x = data.frame(x, y),\n algorithm = cluster,\n config = do_call(\n get_clust_setup_fn(cluster),\n cluster_config\n )\n )@clusters\n )\n group <- paste(\"Cluster\", group)\n }\n\n # Data ----\n # xlab, ylab ----\n # The gsubs remove all text up to and including a \"$\" symbol if present\n if (is.null(xlab)) {\n if (is.list(x)) {\n xlab <- \"x\"\n } else {\n xlab <- labelify(gsub(\".*\\\\$\", \"\", deparse(substitute(x))))\n }\n }\n if (!is.null(y) && is.null(ylab)) {\n if (is.list(y)) {\n ylab <- \"y\"\n } else {\n ylab <- labelify(gsub(\".*\\\\$\", \"\", deparse(substitute(y))))\n }\n }\n if (!is.null(z) && is.null(zlab)) {\n if (is.list(z)) {\n zlab <- \"z\"\n } else {\n zlab <- labelify(gsub(\".*\\\\$\", \"\", deparse(substitute(z))))\n }\n }\n\n # '- Group ----\n if (!is.null(group)) {\n group <- as.factor(group)\n x <- split(x, group, drop = TRUE)\n y <- split(y, group, drop = TRUE)\n z <- split(z, group, drop = TRUE)\n if (is.null(group_names)) {\n group_names <- levels(droplevels(group))\n }\n names(x) <- names(y) <- names(z) <- .names <- group_names\n }\n\n # Try to get names from list or data frame inputs\n if (is.list(y) || NCOL(y) > 1) {\n if (is.null(.names) && !is.null(names(y))) .names <- names(y)\n }\n if (is.list(x) || NCOL(x) > 1) {\n if (is.null(.names) && !is.null(names(x))) .names <- names(x)\n }\n if (is.list(z) || NCOL(z) > 1) {\n if (is.null(.names) && !is.null(names(z))) .names <- names(z)\n }\n\n # Convert to lists ----\n x <- if (!is.list(x)) as.list(as.data.frame(x)) else x\n y <- if (!is.null(y) && !is.list(y)) as.list(as.data.frame(y)) else y\n z <- if (!is.null(z) && !is.list(z)) as.list(as.data.frame(z)) else z\n if (length(x) == 1 && length(y) > 1) {\n x <- rep(x, length(y))\n .names <- names(y)\n }\n if (length(y) == 1 && length(x) > 1) {\n y <- rep(y, length(x))\n .names <- names(x)\n }\n if (length(z) == 1 && length(x) > 1) {\n z <- rep(z, length(x))\n .names <- names(x)\n }\n n_groups <- length(x)\n\n # legend <- if (is.null(legend) & n_groups == 1 & is.null(fit)) FALSE else TRUE\n legend <- if (is.null(legend) && n_groups == 1) FALSE else TRUE\n\n if (length(.mode) < n_groups) {\n .mode <- c(.mode, rep(tail(.mode)[1], n_groups - length(.mode)))\n }\n\n # if (is.null(legend)) legend <- n_groups > 1\n if (is.null(.names)) {\n if (n_groups > 1) {\n .names <- paste(\"Group\", seq_len(n_groups))\n } else {\n .names <- if (!is.null(fit)) fit else NULL\n .names <- NULL\n }\n }\n\n # Reorder ----\n if (order_on_x) {\n index <- lapply(x, order)\n x <- lapply(seq(x), function(i) x[[i]][index[[i]]])\n y <- lapply(seq(x), function(i) y[[i]][index[[i]]])\n z <- lapply(seq(x), function(i) z[[i]][index[[i]]])\n }\n\n # s.e. fit ----\n se_fit <- FALSE\n # if (se_fit) {\n # if (!fit %in% c(\"GLM\", \"LM\", \"LOESS\", \"GAM\", \"NW\")) {\n # warning(paste(\"Standard error of the fit not available for\", fit, \"- try LM, LOESS, GAM, or NW\"))\n # se_fit <- FALSE\n # }\n # }\n\n # Colors ----\n col <- recycle(palette, seq_len(n_groups))\n\n # Convert inputs to RGB\n spike_col <- plotly::toRGB(spike_col)\n\n # Theme ----\n axes_visible <- FALSE\n axes_mirrored <- FALSE\n check_is_S7(theme, Theme)\n\n bg <- plotly::toRGB(theme[[\"bg\"]])\n plot_bg <- plotly::toRGB(theme[[\"plot_bg\"]])\n grid_col <- plotly::toRGB(theme[[\"grid_col\"]], theme[[\"grid_alpha\"]])\n tick_col <- plotly::toRGB(theme[[\"tick_col\"]])\n labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n if (!theme[[\"axes_visible\"]]) {\n tick_col <- labs_col <- \"transparent\"\n }\n\n # marker_col, se_col ----\n if (is.null(marker_col)) {\n marker_col <- if (!is.null(fit) && n_groups == 1) {\n as.list(rep(theme[[\"fg\"]], n_groups))\n } else {\n col\n }\n }\n\n if (!is.null(fit)) {\n if (is.null(fit_col)) fit_col <- col\n }\n\n # Derived\n if (is.null(legend_col)) {\n legend_col <- labs_col\n }\n\n # Size ----\n if (axes_square) {\n width <- height <- min(dev.size(\"px\")) - 10\n }\n\n # fitted & se_fit ----\n # If plotting se bands, need to include (fitted +/- se.times * se) in the axis limits\n if (se_fit) {\n se <- list()\n } else {\n se <- NULL\n }\n if (!is.null(fit)) {\n # learner <- get_train_fn(fit)\n fitted <- list()\n fitted_text <- character()\n for (i in seq_len(n_groups)) {\n df1 <- data.frame(x[[i]], y[[i]], z[[i]])\n mod <- train(\n df1,\n algorithm = fit,\n hyperparameters = fit_params,\n verbosity = verbosity\n )\n fitted[[i]] <- fitted(mod)\n if (se_fit) {\n se[[i]] <- se(mod)\n }\n fitted_text[i] <- fit\n if (rsq) {\n fitted_text[i] <- paste0(\n fitted_text[i],\n if (n_groups == 1) \" (\" else \" \",\n \"R2 = \",\n ddSci(mod@metrics_training[[\"Rsq\"]]),\n if (n_groups == 1) \")\"\n )\n }\n }\n }\n\n # plotly ----\n plt <- plotly::plot_ly(\n width = width,\n height = height\n )\n for (i in seq_len(n_groups)) {\n # '- { Scatter } ----\n marker <- if (grepl(\"markers\", .mode[i])) {\n list(\n color = plotly::toRGB(marker_col[[i]], alpha = alpha),\n size = marker_size\n )\n } else {\n NULL\n }\n plt <- plotly::add_trace(\n plt,\n x = x[[i]],\n y = y[[i]],\n z = z[[i]],\n type = \"scatter3d\",\n mode = .mode[i],\n # fillcolor = plotly::toRGB(col[[i]], alpha),\n # name = if (n_groups > 1) .names[i] else \"Raw\",\n name = .names[i],\n # text = .text[[i]],\n # hoverinfo = \"text\",\n # marker = if (grepl(\"markers\", .mode[i])) list(color = plotly::toRGB(marker_col[[i]], alpha = alpha)) else NULL,\n marker = marker,\n line = if (grepl(\"lines\", .mode[i])) {\n list(color = plotly::toRGB(marker_col[[i]], alpha = alpha))\n } else {\n NULL\n },\n legendgroup = if (n_groups > 1) .names[i] else \"Raw\",\n showlegend = legend\n )\n # if (se_fit) {\n # # '- { SE band } ----\n # plt <- plotly::add_trace(plt,\n # x = x[[i]],\n # y = fitted[[i]] + se.times * se[[i]],\n # type = \"scatter\",\n # mode = \"lines\",\n # line = list(color = \"transparent\"),\n # legendgroup = .names[i],\n # showlegend = FALSE,\n # hoverinfo = \"none\",\n # inherit = FALSE)\n # plt <- plotly::add_trace(plt, x = x[[i]],\n # y = fitted[[i]] - se.times * se[[i]],\n # type = \"scatter\",\n # mode = \"lines\",\n # fill = \"tonexty\",\n # fillcolor = plotly::toRGB(se_col[[i]], alpha = se.alpha),\n # line = list(color = \"transparent\"),\n # # name = shade.name,\n # legendgroup = .names[i],\n # showlegend = FALSE,\n # hoverinfo = \"none\",\n # inherit = FALSE)\n # }\n\n if (!is.null(fit)) {\n # '- { Fitted mesh } ----\n plt <- plotly::add_trace(\n plt,\n x = x[[i]],\n y = y[[i]],\n z = fitted[[i]],\n type = \"mesh3d\",\n opacity = fit_alpha,\n name = fitted_text[i],\n # legendgroup = .names[i],\n # showlegend = if (legend & n_groups == 1) TRUE else FALSE,\n inherit = FALSE,\n showscale = FALSE,\n intensity = 1,\n colorscale = list(\n c(0, plotly::toRGB(fit_col[[i]])),\n c(1, plotly::toRGB(fit_col[[i]]))\n )\n )\n }\n }\n # Layout ----\n # '- layout ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = labs_col\n )\n tickfont <- list(\n family = theme[[\"font_family\"]],\n size = tick_font_size,\n color = theme[[\"tick_labels_col\"]]\n )\n .legend <- list(\n x = legend_xy[1],\n xanchor = legend_xanchor,\n y = legend_xy[2],\n yanchor = legend_yanchor,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = legend_col\n ),\n orientation = legend_orientation,\n bgcolor = plotly::toRGB(legend_bg),\n bordercolor = plotly::toRGB(legend_border_col),\n borderwidth = legend_borderwidth,\n tracegroupgap = legend_group_gap\n )\n\n plt <- plotly::layout(\n plt,\n scene = list(\n yaxis = list(\n title = ylab,\n showline = axes_visible,\n mirror = axes_mirrored,\n titlefont = f,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = FALSE,\n spikecolor = spike_col\n ),\n xaxis = list(\n title = xlab,\n showline = axes_visible,\n mirror = axes_mirrored,\n titlefont = f,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = FALSE,\n spikecolor = spike_col\n ),\n zaxis = list(\n title = zlab,\n showline = axes_visible,\n mirror = axes_mirrored,\n titlefont = f,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = FALSE,\n spikecolor = spike_col\n )\n ),\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n )\n ),\n # titlefont = list(),\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg,\n margin = margin,\n showlegend = legend,\n legend = .legend\n )\n\n # Padding\n plt[[\"sizingPolicy\"]][[\"padding\"]] <- padding\n # Config\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n )\n )\n\n # Write to file ----\n if (!is.null(filename)) {\n plotly::save_image(\n plt,\n file = file.path(filename),\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n }\n\n plt\n} # /rtemis::draw_3Dscatter\n" }, { "path": "R/draw_bar.R", "content": "# draw_bar.R\n# ::rtemis::\n# 2019-22 EDG rtemis.org\n\n#' Interactive Barplots\n#'\n#' Draw interactive barplots using `plotly`\n#'\n#' @details\n#' See [docs.rtemis.org/r](https://docs.rtemis.org/r/) for detailed documentation.\n#'\n#' @param x vector (possibly named), matrix, or data.frame: If matrix or\n#' data.frame, rows are groups (can be 1 row), columns are features\n#' @param main Character: Main plot title.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param alpha Float (0, 1]: Transparency for bar colors.\n#' @param theme `Theme` object.\n#' @param palette Character vector: Colors to use.\n#' @param barmode Character: Type of bar plot to make: \"group\", \"relative\",\n#' \"stack\", \"overlay\". Default = \"group\". Use\n#' \"relative\" for stacked bars, wich handles negative values correctly,\n#' unlike \"stack\", as of writing.\n#' @param group_names Character, vector, length = NROW(x): Group names.\n#' Default = NULL, which uses `rownames(x)`\n#' @param order_by_val Logical: If TRUE, order bars by increasing value.\n#' Only use for single group data.\n#' @param ylim Float, vector, length 2: y-axis limits.\n#' @param hovernames Character, vector: Optional character vector to show on\n#' hover over each bar.\n#' @param feature_names Character, vector, length = NCOL(x): Feature names.\n#' Default = NULL, which uses `colnames(x)`\n#' @param font_size Float: Font size for all labels.\n#' @param legend Logical: If TRUE, draw legend. Default = NULL, and will be\n#' turned on if there is more than one feature present\n#' @param legend_col Color: Legend text color. Default = NULL, determined by\n#' theme\n#' @param hline Float: If defined, draw a horizontal line at this y value.\n#' @param hline_col Color for `hline`.\n#' @param hline_width Float: Width for `hline`.\n#' @param hline_dash Character: Type of line to draw: \"solid\", \"dot\", \"dash\",\n#' \"longdash\", \"dashdot\",\n#' or \"longdashdot\"\n#' @param hline_annotate Character: Text of horizontal line annotation if\n#' `hline` is set\n#' @param hline_annotation_x Numeric: x position to place annotation with paper\n#' as reference. 0: to the left of the plot area; 1: to the right of the plot area\n#' @param margin Named list: plot margins.\n#' @param padding Integer: N pixels to pad plot.\n#' @param horizontal Logical: If TRUE, plot bars horizontally\n#' @param annotate Logical: If TRUE, annotate stacked bars\n#' @param annotate_col Color for annotations\n#' @param legend_xy Numeric, vector, length 2: x and y for plotly's legend\n#' @param legend_orientation \"v\" or \"h\" for vertical or horizontal\n#' @param legend_xanchor Character: Legend's x anchor: \"left\", \"center\",\n#' \"right\", \"auto\"\n#' @param legend_yanchor Character: Legend's y anchor: \"top\", \"middle\",\n#' \"bottom\", \"auto\"\n#' @param automargin_x Logical: If TRUE, automatically set x-axis margins\n#' @param automargin_y Logical: If TRUE, automatically set y-axis margins\n#' @param displayModeBar Logical: If TRUE, show plotly's modebar\n#' @param modeBar_file_format Character: \"svg\", \"png\", \"jpeg\", \"pdf\" / any\n#' output file type supported by plotly and your system\n# @param print_plot Logical: If TRUE, print plot, otherwise return it invisibly\n#' @param filename Character: Path to file to save static plot.\n#' @param file_width Integer: File width in pixels for when `filename` is\n#' set.\n#' @param file_height Integer: File height in pixels for when `filename`\n#' is set.\n#' @param file_scale Numeric: If saving to file, scale plot by this number\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' draw_bar(VADeaths, legend_xy = c(0, 1))\n#' draw_bar(VADeaths, legend_xy = c(1, 1), legend_xanchor = \"left\")\n#' # simple individual bars\n#' a <- c(4, 7, 2)\n#' draw_bar(a)\n#' # if input is a data.frame, each row is a group and each column is a feature\n#' b <- data.frame(x = c(3, 5, 7), y = c(2, 1, 8), z = c(4, 5, 2))\n#' rownames(b) <- c(\"Jen\", \"Ben\", \"Ren\")\n#' draw_bar(b)\n#' # stacked\n#' draw_bar(b, barmode = \"stack\")\ndraw_bar <- function(\n x,\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n alpha = 1,\n horizontal = FALSE,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n barmode = c(\"group\", \"relative\", \"stack\", \"overlay\"),\n group_names = NULL,\n order_by_val = FALSE,\n ylim = NULL,\n hovernames = NULL,\n feature_names = NULL,\n font_size = 16,\n annotate = FALSE,\n annotate_col = theme[[\"labs_col\"]],\n legend = NULL,\n legend_col = NULL,\n legend_xy = c(1, 1),\n legend_orientation = \"v\",\n legend_xanchor = \"left\",\n legend_yanchor = \"auto\",\n hline = NULL,\n hline_col = NULL,\n hline_width = 1,\n hline_dash = \"solid\",\n hline_annotate = NULL,\n hline_annotation_x = 1,\n margin = list(b = 65, l = 65, t = 50, r = 10, pad = 0),\n automargin_x = TRUE,\n automargin_y = TRUE,\n padding = 0,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n verbosity = 0L\n) {\n # Dependencies ----\n check_dependencies(\"plotly\")\n\n # Arguments ----\n barmode <- match.arg(barmode)\n if (!is.null(main)) {\n main <- paste0(\"\", main, \"\")\n }\n\n dat <- as.data.frame(x)\n if (NROW(dat) == 1 && barmode != \"stack\") {\n dat <- as.data.frame(t(dat))\n }\n\n # Order by val ----\n if (order_by_val) {\n if (NCOL(dat) > 1) {\n order_ <- order(sapply(dat, mean, na.rm = TRUE))\n dat <- dat[, order_]\n } else {\n order_ <- order(dat[[1]])\n dat <- dat[order_, , drop = FALSE]\n }\n if (!is.null(group_names)) {\n group_names <- group_names[order_]\n }\n if (!is.null(hovernames)) hovernames <- hovernames[order_]\n }\n\n # Group names ----\n group_names_ <- group_names\n if (is.null(group_names)) {\n if (!is.null(rownames(dat))) group_names_ <- rownames(dat)\n }\n\n if (verbosity > 0L) {\n msg(\"group_names_:\", group_names_, \"\\n\")\n }\n\n # Feature names ----\n feature_names_ <- feature_names\n if (is.null(feature_names_)) {\n if (!is.null(colnames(dat))) {\n feature_names_ <- labelify(colnames(dat))\n } else {\n feature_names_ <- paste0(\"Feature\", seq_len(NCOL(dat)))\n }\n }\n\n if (verbosity > 0L) {\n msg(\"feature_names_:\", feature_names_, \"\\n\")\n }\n if (is.null(legend)) {\n legend <- length(feature_names_) > 1\n }\n\n # Colors ----\n p <- NCOL(dat)\n col <- recycle(palette, seq(p))[seq(p)]\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n bg <- plotly::toRGB(theme[[\"bg\"]])\n plot_bg <- plotly::toRGB(theme[[\"plot_bg\"]])\n grid_col <- plotly::toRGB(theme[[\"grid_col\"]])\n tick_col <- plotly::toRGB(theme[[\"tick_col\"]])\n labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n\n # Derived\n if (is.null(legend_col)) {\n legend_col <- labs_col\n }\n\n if (!is.null(hovernames)) {\n hovernames <- matrix(hovernames)\n if (NCOL(hovernames) == 1 && p > 1) {\n hovernames <- matrix(rep(hovernames, p), ncol = p)\n }\n }\n\n # plot_ly ----\n group_names_ <- factor(group_names_, levels = group_names_)\n plt <- plotly::plot_ly(\n x = if (horizontal) dat[[1]] else group_names_,\n y = if (horizontal) group_names_ else dat[[1]],\n type = \"bar\",\n name = feature_names_[1],\n text = hovernames[, 1],\n marker = list(color = plotly::toRGB(if (p > 1) col[1] else col, alpha)),\n showlegend = legend\n )\n if (p > 1) {\n for (i in seq_len(p)[-1]) {\n plt <- plotly::add_trace(\n plt,\n x = if (horizontal) dat[[i]] else group_names_,\n y = if (horizontal) group_names_ else dat[[i]],\n name = feature_names_[i],\n text = hovernames[, i],\n marker = list(color = plotly::toRGB(col[i], alpha))\n )\n }\n }\n\n if (annotate) {\n if (barmode != \"stack\") {\n warning(\"Set barmode to 'stack' to allow annotation\")\n } else {\n if (horizontal) {\n for (i in seq_len(ncol(dat))) {\n plt <- plt |>\n plotly::add_annotations(\n xref = \"x\",\n yref = \"y\",\n x = rowSums(dat[, seq_len(i - 1), drop = FALSE]) + dat[, i] / 2,\n y = seq_len(nrow(dat)) - 1,\n text = paste(dat[, i]),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n }\n } else {\n for (i in seq_len(ncol(dat))) {\n plt <- plt |>\n plotly::add_annotations(\n xref = \"x\",\n yref = \"y\",\n x = seq_len(nrow(dat)) - 1,\n y = rowSums(dat[, seq_len(i - 1), drop = FALSE]) + dat[, i] / 2,\n text = paste(signif(dat[, i], 2)),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n }\n }\n }\n }\n\n # Layout ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = labs_col\n )\n tickfont <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = theme[[\"tick_labels_col\"]]\n )\n legend_ <- list(\n x = legend_xy[1],\n y = legend_xy[2],\n xanchor = legend_xanchor,\n yanchor = legend_yanchor,\n bgcolor = \"#ffffff00\",\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = legend_col\n ),\n orientation = legend_orientation\n )\n\n plt <- plotly::layout(\n plt,\n yaxis = list(\n title = ylab,\n # showline = axes_visible,\n # mirror = axes_mirrored,\n range = ylim,\n titlefont = f,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = FALSE,\n automargin = automargin_y\n ),\n xaxis = list(\n title = xlab,\n # showline = axes_visible,\n # mirror = axes_mirrored,\n titlefont = f,\n showgrid = FALSE,\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n automargin = automargin_x\n ),\n barmode = barmode, # group works without actual groups too\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n ),\n xref = \"paper\",\n x = theme[[\"main_adj\"]]\n ),\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg,\n margin = margin,\n # showlegend = legend,\n legend = legend_\n )\n\n # hline ----\n if (!is.null(hline)) {\n if (is.null(hline_col)) {\n hline_col <- theme[[\"fg\"]]\n }\n hline_col <- recycle(hline_col, hline)\n hline_width <- recycle(hline_width, hline)\n hline_dash <- recycle(hline_dash, hline)\n hlinel <- lapply(seq_along(hline), function(i) {\n list(\n type = \"line\",\n x0 = 0,\n x1 = 1,\n xref = \"paper\",\n y0 = hline[i],\n y1 = hline[i],\n line = list(\n color = hline_col[i],\n width = hline_width[i],\n dash = hline_dash[i]\n )\n )\n })\n plt <- plotly::layout(plt, shapes = hlinel)\n\n # Annotate horizontal lines on the right border of the plot\n if (!is.null(hline_annotate)) {\n plt <- plt |>\n plotly::add_annotations(\n xref = \"paper\",\n yref = \"y\",\n xanchor = \"right\",\n yanchor = \"bottom\",\n x = hline_annotation_x,\n y = hline,\n text = hline_annotate,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n }\n }\n\n # Padding\n plt[[\"sizingPolicy\"]][[\"padding\"]] <- padding\n\n # Config\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n )\n )\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n plt\n} # /rtemis::draw_bar.R\n" }, { "path": "R/draw_box.R", "content": "# draw_box.R\n# ::rtemis::\n# EDG rtemis.org\n\n#' Interactive Boxplots & Violin plots\n#'\n#' Draw interactive boxplots or violin plots using \\pkg{plotly}\n#'\n#' @details\n#' See [docs.rtemis.org/r](https://docs.rtemis.org/r/) for detailed documentation.\n#'\n#' For multiple box plots, the recommendation is:\n#' - `x=dat[, columnindex]` for multiple variables of a data.frame\n#' - `x=list(a=..., b=..., etc.)` for multiple variables of potentially\n#' different length\n#' - `x=split(var, group)` for one variable with multiple groups: group names\n#' appear below boxplots\n#' - `x=dat[, columnindex], group = factor` for grouping multiple variables:\n#' group names appear in legend\n#'\n#' If `orientation == \"h\"`, `xlab` is applied to y-axis and vice versa.\n#' Similarly, `x.axist.type` applies to y-axis - this defaults to\n#' \"category\" and would not normally need changing.\n#'\n#' @param x Vector or List of vectors: Input\n#' @param time Date or date-time vector\n#' @param time_bin Character: \"year\", \"quarter\", \"month\", or \"day\". Period to\n#' bin by\n#' @param type Character: \"box\" or \"violin\"\n#' @param group Factor to group by\n#' @param x_transform Character: \"none\", \"scale\", or \"minmax\" to use raw values,\n#' scaled and centered values or min-max normalized to 0-1, respectively.\n#' Transform is applied to each variable before grouping, so that groups are\n#' comparable\n#' @param main Character: Plot title.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param alpha Float (0, 1]: Transparency for box colors.\n#' @param bg Color: Background color.\n#' @param plot_bg Color: Background color for plot area.\n#' @param theme `Theme` object.\n#' @param palette Character vector: Colors to use.\n#' @param quartilemethod Character: \"linear\", \"exclusive\", \"inclusive\"\n#' @param xlim Numeric vector: x-axis limits\n#' @param ylim Numeric vector: y-axis limits\n#' @param boxpoints Character or FALSE: \"all\", \"suspectedoutliers\", \"outliers\"\n#' See \n#' @param xnames Character, vector, length = NROW(x): x-axis names. Default = NULL, which\n#' tries to set names automatically.\n#' @param group_lines Logical: If TRUE, add separating lines between groups of\n#' boxplots\n#' @param group_lines_dash Character: \"solid\", \"dot\", \"dash\", \"longdash\",\n#' \"dashdot\", or \"longdashdot\"\n#' @param group_lines_col Color for `group_lines`\n#' @param group_lines_alpha Numeric: transparency for `group_lines_col`\n#' @param order_by_fn Function: If defined, order boxes by increasing value of\n#' this function (e.g. median).\n#' @param font_size Float: Font size for all labels.\n#' @param ylab_standoff Numeric: Standoff for y-axis label\n#' @param legend Logical: If TRUE, draw legend.\n#' @param legend_col Color: Legend text color. Default = NULL, determined by\n#' the theme.\n#' @param legend_xy Float, vector, length 2: Relative x, y position for legend.\n#' @param xaxis_type Character: \"linear\", \"log\", \"date\", \"category\",\n#' \"multicategory\"\n#' @param cataxis_tickangle Numeric: Angle for categorical axis tick labels\n#' @param margin Named list: plot margins.\n#' @param violin_box Logical: If TRUE and type is \"violin\" show box within\n#' violin plot\n#' @param orientation Character: \"v\" or \"h\" for vertical, horizontal\n#' @param annotate_n Logical: If TRUE, annotate with N in each box\n#' @param annotate_n_y Numeric: y position for `annotate_n`\n#' @param annotate_mean Logical: If TRUE, annotate with mean of each box\n#' @param annotate_meansd Logical: If TRUE, annotate with mean (SD) of each box\n#' @param annotate_meansd_y Numeric: y position for `annotate_meansd`\n#' @param annotate_col Color for annotations\n#' @param labelify Logical: If TRUE, [labelify] x names\n#' @param legend_orientation \"v\" or \"h\" for vertical, horizontal\n#' @param legend_xanchor Character: Legend's x anchor: \"left\", \"center\",\n#' \"right\", \"auto\"\n#' @param legend_yanchor Character: Legend's y anchor: \"top\", \"middle\",\n#' \"bottom\", \"auto\"\n#' @param automargin_x Logical: If TRUE, automatically set x-axis margins\n#' @param automargin_y Logical: If TRUE, automatically set y-axis margins\n#' @param boxgroupgap Numeric: Sets the gap (in plot fraction) between boxes\n#' of the same location coordinate\n#' @param hovertext Character vector: Text to show on hover for each data point\n#' @param show_n Logical: If TRUE, show N in each box\n#' @param pvals Numeric vector: Precomputed p-values. Should correspond to each box.\n#' Bypasses `htest` and `htest_compare`. Requires `group` to be set\n#' @param htest Character: e.g. \"t.test\", \"wilcox.test\" to compare each box to\n#' the *first* box. If grouped, compare within each group to the first box.\n#' If p-value of test is less than `htest.thresh`, add asterisk above/\n#' to the side of each box\n#' @param htest_compare Integer: 0: Compare all distributions against the first one;\n#' 2: Compare every second box to the one before it. Requires `group` to\n#' be set\n#' @param htest_y Numeric: y coordinate for `htest` annotation\n#' @param htest_annotate Logical: if TRUE, include htest annotation\n#' @param htest_annotate_x Numeric: x-axis paper coordinate for htest annotation\n#' @param htest_annotate_y Numeric: y-axis paper coordinate for htest annotation\n#' @param htest_star_col Color for htest annotation stars\n#' @param htest_bracket_col Color for htest annotation brackets\n#' @param starbracket_pad Numeric: Padding for htest annotation brackets\n#' @param use_plotly_group If TRUE, use plotly's `group` arg to group\n#' boxes.\n#' @param width Numeric: Force plot size to this width. Default = NULL, i.e. fill\n#' available space\n#' @param height Numeric: Force plot size to this height. Default = NULL, i.e. fill\n#' available space\n#' @param displayModeBar Logical: If TRUE, show plotly's modebar\n#' @param filename Character: Path to file to save static plot.\n#' @param modeBar_file_format Character: \"svg\", \"png\", \"jpeg\", \"pdf\"\n#' @param file_width Integer: File width in pixels for when `filename` is\n#' set.\n#' @param file_height Integer: File height in pixels for when `filename`\n#' is set.\n#' @param file_scale Numeric: If saving to file, scale plot by this number\n#' @param mathjax Optional Character \\{\"local\", \"cdn\"\\}: Whether to use local or CDN version of\n#' MathJax for rendering mathematical annotations.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' # A.1 Box plot of 4 variables\n#' draw_box(iris[, 1:4])\n#' # A.2 Grouped Box plot\n#' draw_box(iris[, 1:4], group = iris[[\"Species\"]])\n#' draw_box(iris[, 1:4], group = iris[[\"Species\"]], annotate_n = TRUE)\n#' # B. Boxplot binned by time periods\n#' # Synthetic data with an instantenous shift in distributions\n#' set.seed(2021)\n#' dat1 <- data.frame(alpha = rnorm(200, 0), beta = rnorm(200, 2), gamma = rnorm(200, 3))\n#' dat2 <- data.frame(alpha = rnorm(200, 5), beta = rnorm(200, 8), gamma = rnorm(200, -3))\n#' x <- rbind(dat1, dat2)\n#' startDate <- as.Date(\"2019-12-04\")\n#' endDate <- as.Date(\"2021-03-31\")\n#' time <- seq(startDate, endDate, length.out = 400)\n#' draw_box(x[, 1], time, \"year\", ylab = \"alpha\")\n#' draw_box(x, time, \"year\", legend.xy = c(0, 1))\n#' draw_box(x, time, \"quarter\", legend.xy = c(0, 1))\n#' draw_box(x, time, \"month\",\n#' legend.orientation = \"h\",\n#' legend.xy = c(0, 1),\n#' legend.yanchor = \"bottom\"\n#' )\n#' # (Note how the boxplots widen when the period includes data from both dat1 and dat2)\ndraw_box <- function(\n x,\n time = NULL,\n time_bin = c(\"year\", \"quarter\", \"month\", \"day\"),\n type = c(\"box\", \"violin\"),\n group = NULL,\n x_transform = c(\"none\", \"scale\", \"minmax\"),\n main = NULL,\n xlab = \"\",\n ylab = NULL,\n alpha = .6,\n bg = NULL,\n plot_bg = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n boxpoints = \"outliers\",\n quartilemethod = \"linear\",\n xlim = NULL,\n ylim = NULL,\n violin_box = TRUE,\n orientation = \"v\",\n annotate_n = FALSE,\n annotate_n_y = 1,\n annotate_mean = FALSE, # forr A.2.b.\n annotate_meansd = FALSE,\n annotate_meansd_y = 1,\n annotate_col = theme[[\"labs_col\"]],\n xnames = NULL,\n group_lines = FALSE,\n group_lines_dash = \"dot\",\n group_lines_col = NULL,\n group_lines_alpha = .5,\n labelify = TRUE,\n order_by_fn = NULL,\n font_size = 16,\n # Axes\n ylab_standoff = 18,\n legend = NULL,\n legend_col = NULL,\n legend_xy = NULL,\n legend_orientation = \"v\",\n legend_xanchor = \"auto\",\n legend_yanchor = \"auto\",\n xaxis_type = \"category\",\n cataxis_tickangle = \"auto\",\n # margin = list(t = 35, pad = 0),\n margin = list(b = 65, l = 65, t = 50, r = 12, pad = 0),\n automargin_x = TRUE,\n automargin_y = TRUE,\n # boxgap = 0, #1/nvars, #.12,\n boxgroupgap = NULL,\n hovertext = NULL,\n show_n = FALSE,\n # boxmode = NULL,\n pvals = NULL,\n htest = \"none\",\n htest_compare = 0,\n # htest.thresh = .05,\n htest_y = NULL,\n htest_annotate = TRUE,\n htest_annotate_x = 0,\n htest_annotate_y = -.065,\n htest_star_col = theme[[\"labs_col\"]],\n htest_bracket_col = theme[[\"labs_col\"]],\n starbracket_pad = c(.04, .05, .09),\n use_plotly_group = FALSE,\n width = NULL,\n height = NULL,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n mathjax = NULL\n) {\n # Dependencies ----\n check_dependencies(\"plotly\")\n\n # Arguments ----\n type <- match.arg(type)\n x_transform <- match.arg(x_transform)\n\n # Convert vector or data.frame/data.table/matrix to list\n if (!is.list(x)) {\n # x is vector\n if (is.numeric(x)) {\n .names <- deparse(substitute(x))\n x <- list(x)\n names(x) <- .names\n } else {\n # x is data.frame or matrix\n .names <- colnames(x)\n x <- lapply(seq_len(NCOL(x)), function(i) x[, i])\n names(x) <- .names\n }\n }\n nvars <- length(x)\n if (nvars > 1 && !is.null(group) && !is.null(time)) {\n cli::cli_abort(\"Better use subplot for each variable\")\n }\n horizontal <- orientation == \"h\"\n\n if (x_transform != \"none\") {\n if (x_transform == \"scale\") {\n x <- lapply(x, \\(z) as.numeric(scale(z)))\n } else if (x_transform == \"minmax\") {\n x <- lapply(x, drange)\n } else {\n cli::cli_abort(\"Unsupported x_transform specified\")\n }\n }\n\n # Order by fn ----\n if (!is.null(order_by_fn)) {\n if (is.null(time)) {\n if (is.list(x)) {\n .order <- order(sapply(x, order_by_fn, na.rm = TRUE))\n if (is.data.frame(x)) {\n x <- x[, .order]\n } else {\n x <- x[names(x)[.order]]\n }\n }\n if (!is.null(xnames)) {\n xnames <- xnames[.order]\n }\n } else {\n cli::cli_abort(\"Cannot use `order_by_fn` with `time`\")\n }\n }\n\n # Remove non-numeric vectors\n # which.nonnum <- which(sapply(x, function(i) !is.numeric(i)))\n # if (length(which.nonnum) > 0) x[[which.nonnum]] <- NULL\n\n if (!is.null(group)) {\n group <- factor(group)\n }\n n_groups <- if (is.null(group)) {\n length(x)\n } else {\n nlevels(group)\n }\n if (n_groups == 1) {\n htest <- \"none\"\n }\n .xnames <- xnames\n if (is.null(.xnames)) {\n .xnames <- names(x)\n if (is.null(.xnames)) {\n .xnames <- paste0(\"Feature\", seq(n_groups))\n }\n if (labelify) .xnames <- labelify(.xnames)\n }\n\n # Colors ----\n col <- recycle(palette, seq(n_groups))\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n if (theme[[\"main_font\"]] == 2) {\n main <- paste0(\"\", main, \"\")\n }\n bg <- plotly::toRGB(theme[[\"bg\"]])\n plot_bg <- plotly::toRGB(theme[[\"plot_bg\"]])\n grid_col <- plotly::toRGB(theme[[\"grid_col\"]])\n tick_col <- plotly::toRGB(theme[[\"tick_col\"]])\n labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n\n # Derived\n if (is.null(legend_col)) {\n legend_col <- labs_col\n }\n\n # Plot ----\n if (is.null(time)) {\n if (is.null(group)) {\n # A.1 Single and multiple boxplots ----\n if (is.null(legend)) {\n legend <- FALSE\n }\n # Args for first trace\n .args <- if (horizontal) {\n list(x = x[[1]], y = NULL)\n } else {\n list(x = NULL, y = x[[1]])\n }\n .args <- c(\n .args,\n list(\n type = type,\n # name = .xnames[1],\n name = if (show_n) {\n paste0(.xnames[1], \" (N=\", length(x[[1]]), \")\")\n } else {\n .xnames[1]\n },\n line = list(color = plotly::toRGB(col[1])),\n fillcolor = plotly::toRGB(col[1], alpha),\n marker = list(color = plotly::toRGB(col[1], alpha)),\n showlegend = legend\n # width = width\n )\n )\n if (!is.null(hovertext) && n_groups == 1) {\n hovertext <- list(hovertext)\n }\n if (type == \"box\") {\n .args <- c(\n .args,\n list(\n quartilemethod = quartilemethod,\n boxpoints = boxpoints\n )\n )\n if (!is.null(hovertext)) .args[[\"text\"]] <- hovertext[[1]]\n }\n if (type == \"violin\") {\n .args[[\"box\"]] <- list(visible = violin_box)\n }\n plt <- do.call(plotly::plot_ly, .args)\n if (n_groups > 1) {\n for (i in seq_len(n_groups)[-1]) {\n plt <- plotly::add_trace(\n plt,\n x = if (horizontal) x[[i]] else NULL,\n y = if (horizontal) NULL else x[[i]],\n # name = .xnames[i],\n name = if (show_n) {\n paste0(.xnames[i], \" (N=\", length(x[[i]]), \")\")\n } else {\n .xnames[i]\n },\n line = list(color = plotly::toRGB(col[i])), # box borders\n fillcolor = plotly::toRGB(col[i], alpha), # box fill\n marker = list(color = plotly::toRGB(col[i], alpha)), # points\n text = if (!is.null(hovertext)) hovertext[[i]] else NULL\n )\n }\n }\n\n # '-Annotate N ----\n if (annotate_n) {\n Nperbox <- Filter(\n function(i) i > 0,\n sapply(x, function(j) length(na.exclude(j)))\n )\n plt <- plt |>\n plotly::add_annotations(\n xref = \"paper\",\n yref = \"paper\",\n xanchor = \"right\",\n yanchor = \"bottom\",\n x = 0,\n y = annotate_n_y,\n text = \"N =\",\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n ) |>\n plotly::add_annotations(\n xref = \"x\",\n yref = \"paper\",\n yanchor = \"bottom\",\n # x = seq_len(nvars) - 1,\n x = seq_along(Nperbox) - 1,\n y = 1,\n text = as.character(Nperbox),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n } # /annotate_n\n\n # '-Annotate Mean SD ----\n if (annotate_meansd) {\n Meanperbox <- sapply(x, function(j) mean(na.exclude(j))) |>\n round(digits = 2) |>\n format(nsmall = 2)\n SDperbox <- sapply(x, function(j) sd(na.exclude(j))) |>\n round(digits = 2) |>\n format(nsmall = 2)\n plt <- plt |>\n plotly::add_annotations(\n xref = \"x\",\n yref = \"paper\",\n yanchor = \"bottom\",\n x = seq_along(Meanperbox) - 1,\n y = 1,\n # text = as.character(Nperbox),\n text = paste0(Meanperbox, \" (\", SDperbox, \")\"),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n } # /annotate_meansd\n\n # '-htest ----\n if (htest != \"none\") {\n if (htest_compare == 0) {\n pvals <- sapply(x[-1], \\(v) {\n suppressWarnings(\n do.call(htest, list(x = x[[1]], y = v))[[\"p.value\"]]\n )\n })\n }\n y_sb <- starbracket_y(unlist(x), pad = starbracket_pad)\n if (is.null(htest_y)) {\n htest_y <- y_sb[[\"star\"]]\n }\n plt <- plt |>\n plotly::add_annotations(\n xref = if (horizontal) \"paper\" else \"x\",\n # yref = if (horizontal) \"x\" else \"paper\",\n yref = if (horizontal) \"x\" else \"y\",\n yanchor = if (horizontal) \"auto\" else \"top\",\n xanchor = if (horizontal) \"center\" else \"auto\",\n x = if (horizontal) htest_y else seq_along(pvals), # exclude first\n y = if (horizontal) seq_along(pvals) else htest_y,\n # text = unname(ifelse(pvals < htest.thresh, \"*\", \"\")),\n text = pval_stars(pvals),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n\n if (htest_annotate) {\n test <- switch(\n htest,\n `wilcox.test` = \"Wilcoxon\",\n `t.test` = \"T-test\",\n htest\n )\n plt <- plt |>\n plotly::add_annotations(\n xref = \"paper\",\n yref = \"paper\",\n yanchor = \"top\",\n xanchor = \"left\",\n x = htest_annotate_x,\n y = htest_annotate_y,\n # text = paste0(\"*\", test, \" p-val < \", htest.thresh),\n # text = paste0(\"* \", test, \" p-val < \", htest.thresh),\n # text = paste0(\n # '* ',\n # test, \" p-val < \", htest.thresh),\n text = paste0(\n test,\n \" p-val:\",\n ' * ',\n \"< .05\",\n ' ** ',\n \"< .01\",\n ' *** ',\n \"< .001\"\n ),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n }\n } # / htest!=\"none\"\n } else {\n if (use_plotly_group) {\n # A.2.a Grouped boxplots with [group] ----\n # Best to use this for multiple variables x group.\n # For single variables x group, preferred way it to use\n # split(var, group) => A1\n if (is.null(legend)) {\n legend <- TRUE\n }\n dt <- cbind(data.table::as.data.table(x), group = group)\n dtlong <- data.table::melt(\n dt[, ID := seq_len(nrow(dt))],\n id.vars = c(\"ID\", \"group\")\n )\n if (is.null(ylab)) {\n ylab <- \"\"\n }\n .args <- list(\n data = dtlong,\n type = type,\n x = if (horizontal) ~value else ~variable,\n y = if (horizontal) ~variable else ~value,\n color = ~group,\n colors = col2hex(col),\n showlegend = legend\n )\n if (type == \"box\") {\n .args <- c(\n .args,\n list(\n quartilemethod = quartilemethod,\n boxpoints = boxpoints,\n alpha = alpha\n )\n )\n if (!is.null(hovertext)) {\n dtlong <- merge(dtlong, cbind(dt[, list(ID)], hovertext))\n .args[[\"text\"]] <- dtlong[[\"hovertext\"]]\n }\n }\n if (type == \"violin\") {\n .args[[\"box\"]] <- list(visible = violin_box)\n }\n cataxis <- list(\n tickvals = 0:(NCOL(dt) - 2),\n ticktext = .xnames\n )\n .args <- c(list(width = width, height = height), .args)\n plt <- do.call(plotly::plot_ly, .args) |>\n plotly::layout(\n boxmode = \"group\",\n xaxis = if (horizontal) NULL else cataxis,\n yaxis = if (horizontal) cataxis else NULL\n )\n } else {\n # A.2.b Grouped boxplots with split and loop ----\n # Replaces A.2.a to allow annotation positioning\n if (is.null(legend)) {\n legend <- TRUE\n }\n dts <- split(data.table::as.data.table(x), group, drop = TRUE)\n\n if (is.null(ylab)) {\n ylab <- \"\"\n }\n if (type == \"box\") {\n .args <- list(\n type = \"box\",\n quartilemethod = quartilemethod,\n boxpoints = boxpoints,\n alpha = alpha\n )\n } else {\n .args <- list(\n type = \"violin\",\n box = list(visible = violin_box)\n )\n }\n\n varnames <- names(x)\n nvars <- length(varnames)\n ngroups <- length(dts)\n groupnames <- names(dts)\n xval <- do.call(paste, expand.grid(groupnames, varnames))\n # text = xval[i],\n xval <- factor(xval, levels = xval)\n\n boxindex <- 0\n\n # plt <- plotly::plot_ly(type = type) # box or violin\n .args <- c(list(width = width, height = height), .args)\n plt <- do.call(plotly::plot_ly, .args)\n for (i in seq_along(varnames)) {\n # loop vars\n for (j in seq_along(dts)) {\n # loop groups\n boxindex <- boxindex + 1\n plt <- plt |>\n plotly::add_trace(\n x = if (horizontal) dts[[j]][[i]] else xval[boxindex],\n y = if (horizontal) xval[boxindex] else dts[[j]][[i]],\n name = groupnames[j],\n meta = xval[boxindex],\n line = list(color = plotly::toRGB(col[j])),\n fillcolor = plotly::toRGB(col[j], alpha),\n marker = list(color = plotly::toRGB(col[j], alpha)),\n showlegend = legend & (i == nvars),\n hoverinfo = \"all\",\n legendgroup = groupnames[j]\n )\n }\n }\n\n cataxis <- list(\n type = \"category\",\n tickmode = \"array\",\n tickvals = (mean(seq_len(ngroups)) + 0:(nvars - 1) * ngroups) - 1, # need -1 if type = \"category\"\n ticktext = .xnames,\n tickangle = cataxis_tickangle,\n automargin = TRUE\n )\n\n plt <- plt |>\n plotly::layout(\n xaxis = if (horizontal) NULL else cataxis,\n yaxis = if (horizontal) cataxis else NULL\n )\n\n # '- Group lines ----\n if (nvars > 1 && group_lines) {\n if (is.null(group_lines_col)) {\n group_lines_col <- theme[[\"fg\"]]\n }\n group_lines_col <- adjustcolor(\n group_lines_col,\n group_lines_alpha\n )\n at <- seq((ngroups - .5), (ngroups * (nvars - 1) - .5), by = ngroups)\n if (horizontal) {\n plt <- plt |>\n plotly::layout(\n shapes = plotly_hline(\n at,\n color = group_lines_col,\n dash = group_lines_dash\n )\n )\n } else {\n plt <- plt |>\n plotly::layout(\n shapes = plotly_vline(\n at,\n color = group_lines_col,\n dash = group_lines_dash\n )\n )\n }\n }\n\n # '-Annotate N ----\n if (annotate_n) {\n Nperbox <- Filter(\n function(i) i > 0,\n c(t(sapply(dts, function(i) {\n sapply(i, function(j) length(na.exclude(j)))\n })))\n )\n plt <- plt |>\n plotly::add_annotations(\n xref = \"paper\",\n yref = \"paper\",\n xanchor = \"right\",\n yanchor = \"bottom\",\n x = 0,\n y = annotate_n_y,\n text = \"N =\",\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n ) |>\n plotly::add_annotations(\n xref = \"x\",\n yref = \"paper\",\n yanchor = \"bottom\",\n x = seq_len(nvars * ngroups) - 1,\n y = 1,\n text = as.character(Nperbox),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n } # /annotate_n\n\n # '-Annotate Mean SD ----\n if (annotate_meansd) {\n Meanperbox <- c(t(sapply(dts, function(i) {\n sapply(i, function(j) mean(na.exclude(j)))\n }))) |>\n round(digits = 2) |>\n format(nsmall = 2)\n SDperbox <- c(t(sapply(dts, function(i) {\n sapply(i, function(j) sd(na.exclude(j)))\n }))) |>\n round(digits = 2) |>\n format(nsmall = 2)\n plt <- plt |>\n plotly::add_annotations(\n xref = \"x\",\n yref = \"paper\",\n yanchor = \"bottom\",\n x = seq_len(nvars * ngroups) - 1,\n y = 1,\n text = paste0(Meanperbox, \" (\", SDperbox, \")\"),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n } # /annotate_meansd\n\n # '-Annotate Mean ----\n if (annotate_mean) {\n Meanperbox <- c(t(sapply(dts, function(i) {\n sapply(i, function(j) mean(na.exclude(j)))\n }))) |>\n round(digits = 1) |>\n format(nsmall = 1)\n plt <- plt |>\n plotly::add_annotations(\n xref = \"x\",\n yref = \"paper\",\n yanchor = \"bottom\",\n x = seq_len(nvars * ngroups) - 1,\n y = 1,\n text = Meanperbox,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n } # /annotate_mean\n\n # '- htest ----\n if (htest != \"none\" || !is.null(pvals)) {\n # dts list elements are groups; columns are variables\n # pvals is N groups -1 x N vars\n if (is.null(pvals)) {\n if (htest_compare == 0) {\n pvals <- sapply(seq_len(nvars), \\(cid) {\n sapply(2:ngroups, \\(gid) {\n suppressWarnings(\n do.call(\n htest,\n list(\n x = dts[[1]][[cid]],\n y = dts[[gid]][[cid]]\n )\n )[[\"p.value\"]]\n )\n })\n })\n pvals <- c(rbind(1, pvals))\n } else if (htest_compare == 2) {\n pvals <- rep(1, nvars * ngroups)\n pvals[seq(2, ngroups * nvars, 2)] <- lapply(\n seq_len(nvars),\n \\(cid) {\n lapply(seq(htest_compare, ngroups, htest_compare), \\(gid) {\n suppressWarnings(\n do.call(\n htest,\n list(\n x = dts[[gid - 1]][[cid]],\n y = dts[[gid]][[cid]]\n )\n )[[\"p.value\"]]\n )\n })\n }\n ) |>\n unlist()\n }\n }\n # if brackets are drawn, center stars above them, otherwise\n # center stars above boxes\n axshift <- if (htest_compare == 2) 1.5 else 1\n y_sb <- starbracket_y(unlist(x), pad = starbracket_pad)\n if (is.null(htest_y)) {\n htest_y <- y_sb[[\"star\"]]\n }\n plt <- plt |>\n plotly::add_annotations(\n xref = if (horizontal) \"paper\" else \"x\",\n # yref = if (horizontal) \"x\" else \"paper\",\n yref = if (horizontal) \"x\" else \"y\",\n yanchor = if (horizontal) \"auto\" else \"top\",\n xanchor = if (horizontal) \"center\" else \"auto\",\n x = if (horizontal) {\n htest_y\n } else {\n seq_len(nvars * ngroups) - axshift\n },\n y = if (horizontal) {\n seq_len(nvars * ngroups) - axshift\n } else {\n htest_y\n },\n # text = unname(ifelse(pvals < htest.thresh, \"*\", \"\")),\n text = pval_stars(pvals),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = htest_star_col\n ),\n showarrow = FALSE\n )\n if (htest_annotate) {\n test <- switch(\n htest,\n `wilcox.test` = \"Wilcoxon\",\n `t.test` = \"T-test\",\n htest\n )\n plt <- plt |>\n plotly::add_annotations(\n xref = \"paper\",\n yref = \"paper\",\n yanchor = \"top\",\n xanchor = \"left\",\n x = htest_annotate_x,\n y = htest_annotate_y,\n # text = paste0(\"*\", test, \" p-val < \", htest.thresh),\n # text = paste0(\"* \", test, \" p-val < \", htest.thresh),\n # text = paste0(\n # '* ',\n # test, \" p-val < \", htest.thresh\n # ),\n text = paste0(\n test,\n \" p-val:\",\n ' * ',\n \"< .05\",\n ' ** ',\n \"< .01\",\n ' *** ',\n \"< .001\"\n ),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n } # /htest.annotate\n\n # '- htest brackets for htest.compare == 2 ----\n if (htest_compare == 2) {\n for (i in seq(2, ngroups * nvars, 2)) {\n if (pvals[i] < .05) {\n # y_bracket <- bracket_y(unlist(x))\n plt <- plt |>\n plotly::add_trace(\n x = c(rep(xval[i - 1], 2), rep(xval[i], 2)),\n y = y_sb[[\"bracket\"]],\n type = \"scatter\",\n mode = \"lines\",\n inherit = FALSE,\n line = list(color = htest_bracket_col, width = 1),\n showlegend = FALSE\n )\n }\n }\n }\n } # /htest grouped\n }\n }\n } else {\n # B. Time-binned boxplots ----\n time_bin <- match.arg(time_bin)\n if (is.null(xlab)) {\n xlab <- \"\"\n }\n if (is.null(ylab)) {\n ylab <- \"\"\n }\n if (is.null(legend)) {\n legend <- TRUE\n }\n\n dt <- data.table::as.data.table(x)\n if (!is.null(group)) {\n dt[, group := group]\n }\n if (!is.null(hovertext)) {\n dt[, hovertext := hovertext]\n }\n\n dt[, timeperiod := date2factor(time, time_bin)] |>\n setkey(timeperiod)\n\n Npertimeperiod <- dt[levels(timeperiod)][,\n lapply(.SD, \\(i) length(na.exclude(i))),\n by = timeperiod\n ] |>\n setorder()\n\n ## Long data\n # appease R CMD check\n ID <- timeperiod <- NULL\n dtlong <- data.table::melt(\n dt[, ID := .I],\n id.vars = c(\n \"ID\",\n \"timeperiod\",\n mgetnames(dt, \"group\", \"hovertext\")\n )\n )\n\n if (is.null(group)) {\n .args <- list(\n data = dtlong,\n type = type,\n x = if (horizontal) ~value else ~timeperiod,\n y = if (horizontal) ~timeperiod else ~value,\n color = ~variable,\n colors = col2hex(col),\n showlegend = legend\n )\n } else {\n .args <- list(\n data = dtlong,\n type = type,\n x = if (horizontal) ~value else ~timeperiod,\n y = if (horizontal) ~timeperiod else ~value,\n color = ~group,\n colors = col2hex(col),\n showlegend = legend\n )\n }\n\n if (!is.null(hovertext)) {\n .args[[\"text\"]] <- dtlong[[\"hovertext\"]]\n }\n\n if (type == \"box\") {\n .args <- c(\n .args,\n list(\n quartilemethod = quartilemethod,\n boxpoints = boxpoints\n )\n )\n }\n if (type == \"violin\") {\n .args[[\"box\"]] <- list(visible = violin_box)\n }\n\n .args <- c(list(width = width, height = height), .args)\n plt <- do.call(plotly::plot_ly, .args)\n if (!is.null(group) || nvars > 1) {\n plt <- plt |> plotly::layout(boxmode = \"group\")\n }\n\n # '-Annotate N ----\n if (is.null(group) && annotate_n) {\n Nperbox <- Npertimeperiod[[2]] # include zeros\n plt <- plt |>\n plotly::add_annotations(\n xref = \"paper\",\n yref = \"paper\",\n xanchor = \"right\",\n yanchor = \"bottom\",\n x = 0,\n y = annotate_n_y,\n text = \"N =\",\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n ) |>\n plotly::add_annotations(\n xref = \"x\",\n yref = \"paper\",\n yanchor = \"bottom\",\n x = seq_along(Nperbox) - 1,\n y = 1,\n text = paste(Nperbox),\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n }\n } # /time-binned boxplots\n\n # Layout ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = labs_col\n )\n tickfont <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = theme[[\"tick_labels_col\"]]\n )\n .legend <- list(\n x = legend_xy[1],\n y = legend_xy[2],\n xanchor = legend_xanchor,\n yanchor = legend_yanchor,\n bgcolor = \"#ffffff00\",\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = legend_col\n ),\n orientation = legend_orientation\n )\n\n yaxis_title <- if (horizontal) xlab else ylab\n plt <- plotly::layout(\n plt,\n yaxis = list(\n title = list(text = yaxis_title, standoff = ylab_standoff),\n type = if (horizontal) xaxis_type else NULL,\n titlefont = f,\n showgrid = if (horizontal) FALSE else theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = if (horizontal) NA else tick_col,\n tickfont = tickfont,\n zeroline = FALSE,\n automargin = automargin_y,\n range = ylim\n ),\n xaxis = list(\n title = if (horizontal) ylab else xlab,\n type = if (horizontal) NULL else xaxis_type,\n titlefont = f,\n showgrid = if (horizontal) theme[[\"grid\"]] else FALSE,\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = if (horizontal) tick_col else NA,\n tickfont = tickfont,\n automargin = automargin_x,\n range = xlim\n ),\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n ),\n xref = \"paper\",\n x = theme[[\"main_adj\"]]\n ),\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg,\n margin = margin,\n legend = .legend,\n # boxgap = boxgap,\n boxgroupgap = boxgroupgap\n )\n\n # Config ----\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n ),\n mathjax = mathjax\n )\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n plt\n} # /rtemis::draw_box.R\n" }, { "path": "R/draw_calibration.R", "content": "# draw_calibration.R\n# ::rtemis::\n# 2023 EDG rtemis.org\n\n#' Draw calibration plot\n#'\n#' @param true_labels Factor or list of factors with true class labels\n#' @param predicted_prob Numeric vector or list of numeric vectors with predicted probabilities\n#' @param bin_method Character: \"quantile\" or \"equidistant\": Method to bin the estimated\n#' probabilities.\n#' @param n_bins Integer: Number of windows to split the data into\n#' @param binclasspos Integer: Index of the positive class. The convention used in the package is\n#' the second level is the positive class.\n#' @param main Character: Main title\n#' @param subtitle Character: Subtitle, placed bottom right of plot\n#' @param xlab Character: x-axis label\n#' @param ylab Character: y-axis label\n#' @param show_marginal_x Logical: Add marginal plot of distribution of estimated probabilities\n#' @param marginal_x_y Numeric: y position of marginal plot\n#' @param marginal_col Character: Color of marginal plot\n#' @param marginal_size Numeric: Size of marginal plot\n#' @param mode Character: \"lines\", \"markers\", \"lines+markers\": How to plot.\n#' @param show_brier Logical: If TRUE, add Brier scores to trace names.\n#' @param theme `Theme` object.\n#' @param filename Character: Path to save output.\n#' @param ... Additional arguments passed to [draw_scatter]\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' # Synthetic data with n cases\n#' n <- 500L\n#' true_labels <- factor(sample(c(\"A\", \"B\"), n, replace = TRUE))\n#' # Synthetic probabilities where A has mean 0.25 and B has mean 0.75\n#' predicted_prob <- ifelse(true_labels == \"A\",\n#' rbeta(n, 2, 6),\n#' rbeta(n, 6, 2)\n#' )\n#' draw_calibration(true_labels, predicted_prob)\ndraw_calibration <- function(\n true_labels,\n predicted_prob,\n n_bins = 10L,\n bin_method = c(\"quantile\", \"equidistant\"),\n binclasspos = 2L,\n main = NULL,\n subtitle = NULL,\n xlab = \"Mean predicted probability\",\n ylab = \"Empirical risk\",\n show_marginal_x = TRUE,\n marginal_x_y = -.02,\n marginal_col = NULL,\n marginal_size = 10,\n mode = \"markers+lines\",\n show_brier = TRUE,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n filename = NULL,\n ...\n) {\n # Arguments ----\n bin_method <- match.arg(bin_method)\n if (!is.list(true_labels)) {\n true_labels <- list(true_labels = true_labels)\n }\n if (!is.list(predicted_prob)) {\n predicted_prob <- list(estimated_prob = predicted_prob)\n }\n # Ensure same number of inputs\n stopifnot(length(true_labels) == length(predicted_prob))\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n pos_class <- lapply(true_labels, \\(x) {\n levels(x)[binclasspos]\n })\n\n # Ensure same positive class\n stopifnot(length(unique(unlist(pos_class))) == 1)\n\n # Create windows\n if (bin_method == \"equidistant\") {\n breaks <- lapply(seq_along(predicted_prob), \\(x) {\n seq(0, 1, length.out = n_bins + 1)\n })\n } else if (bin_method == \"quantile\") {\n breaks <- lapply(predicted_prob, \\(x) {\n quantile(x, probs = seq(0, 1, length.out = n_bins + 1))\n })\n }\n\n # Calculate the mean probability in each window\n mean_bin_prob <- lapply(seq_along(predicted_prob), \\(i) {\n sapply(seq_len(n_bins), \\(j) {\n mean(predicted_prob[[i]][\n predicted_prob[[i]] >= breaks[[i]][j] &\n predicted_prob[[i]] < breaks[[i]][j + 1]\n ])\n })\n })\n names(mean_bin_prob) <- names(predicted_prob)\n\n # Calculate the proportion of condition positive cases in each window\n window_empirical_risk <- lapply(seq_along(predicted_prob), \\(i) {\n sapply(seq_len(n_bins), \\(j) {\n idl <- predicted_prob[[i]] >= breaks[[i]][j] &\n predicted_prob[[i]] < breaks[[i]][j + 1]\n sum(true_labels[[i]][idl] == pos_class[[i]]) / sum(idl)\n })\n })\n names(window_empirical_risk) <- names(predicted_prob)\n\n # Add Brier score\n if (show_brier) {\n .brier_score <- sapply(seq_along(predicted_prob), \\(i) {\n brier_score(\n true_int = labels2int(true_labels[[i]], binclasspos),\n predicted_prob = predicted_prob[[i]]\n )\n })\n names(window_empirical_risk) <- paste0(\n names(window_empirical_risk),\n \" (Brier=\",\n round(.brier_score, 3),\n \")\"\n )\n }\n\n # Calculate confidence intervals\n # confint <- sapply(seq_len(n_bins), \\(i) {\n # events <- length(true_labels[true_labels == pos_class & predicted_prob >= breaks[i] & predicted_prob < breaks[i + 1]])\n # total <- length(predicted_prob >= breaks[i] & predicted_prob < breaks[i + 1])\n # suppressWarnings(pt <- prop.test(\n # events, total,\n # conf.level = conf_level\n # ))\n # pt$conf.int\n # })\n\n # Plot\n if (is.null(subtitle)) {\n subtitle <- paste(\n \"using\",\n n_bins,\n if (bin_method == \"quantile\") \"quantiles\" else \"equidistant bins\"\n )\n }\n # if (is.null(subtitle) && !is.na(subtitle)) .subtitle <- paste0(subtitle, \"\\n\", .subtitle)\n plt <- draw_scatter(\n x = mean_bin_prob,\n y = window_empirical_risk,\n main = main,\n # subtitle = paste(\"\", .subtitle, \"\"),\n subtitle = subtitle,\n subtitle_x = 1,\n subtitle_y = 0,\n subtitle_yref = \"y\",\n subtitle_xanchor = \"right\",\n subtitle_yanchor = \"bottom\",\n xlab = xlab,\n ylab = ylab,\n show_marginal_x = show_marginal_x,\n marginal_x = predicted_prob,\n marginal_x_y = marginal_x_y,\n marginal_size = marginal_size,\n axes_square = TRUE,\n diagonal = TRUE,\n xlim = c(0, 1),\n ylim = c(0, 1),\n mode = mode,\n theme = theme,\n filename = filename,\n ...\n )\n\n # Add marginal.x ----\n # Using estimated probabilities\n # if (marginal.x) {\n # if (is.null(marginal.col)) marginal.col <- plotly::toRGB(theme[[\"fg\"]], alpha = .5)\n # for (i in seq_along(mean_bin_prob)) {\n # plt <- plotly::add_trace(\n # plt,\n # x = predicted_prob[[i]],\n # y = rep(-.02, length(predicted_prob[[i]])),\n # type = \"scatter\",\n # mode = \"markers\",\n # marker = list(\n # color = marginal.col,\n # size = marginal.size,\n # symbol = \"line-ns-open\"\n # ),\n # showlegend = FALSE,\n # hoverinfo = \"x\"\n # )\n # }\n # } # /marginal.x\n\n plt\n} # /rtemis::draw_calibration\n" }, { "path": "R/draw_confusion.R", "content": "# draw_confusion.R\n# ::rtemis::\n# 2024- EDG rtemis.org\n\n#' Plot confusion matrix\n#'\n#' @param x `ClassificationMetrics` object produced by [classification_metrics] or confusion matrix\n#' where rows are the reference and columns are the estimated classes. For binary classification,\n#' the first row and column are the positive class.\n#' @param xlab Character: x-axis label. Default is \"Predicted\".\n#' @param ylab Character: y-axis label. Default is \"Reference\".\n#' @param true_col Color for true positives & true negatives.\n#' @param false_col Color for false positives & false negatives.\n#' @param font_size Integer: font size.\n#' @param main Character: plot title.\n#' @param main_y Numeric: y position of the title.\n#' @param main_yanchor Character: y anchor of the title.\n#' @param theme `Theme` object.\n#' @param margin List: Plot margins.\n#' @param filename Character: file name to save the plot. Default is NULL.\n#' @param file_width Numeric: width of the file. Default is 500.\n#' @param file_height Numeric: height of the file. Default is 500.\n#' @param file_scale Numeric: scale of the file. Default is 1.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' # Assume positive class is \"b\"\n#' true_labels <- factor(c(\"a\", \"a\", \"a\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\"))\n#' predicted_labels <- factor(c(\"a\", \"b\", \"a\", \"b\", \"b\", \"a\", \"b\", \"b\", \"b\", \"a\"))\n#' predicted_prob <- c(0.3, 0.55, 0.45, 0.75, 0.57, 0.3, 0.8, 0.63, 0.62, 0.39)\n#' metrics <- classification_metrics(true_labels, predicted_labels, predicted_prob)\n#' draw_confusion(metrics)\ndraw_confusion <- function(\n x,\n xlab = \"Predicted\",\n ylab = \"Reference\",\n true_col = \"#43A4AC\",\n false_col = \"#FA9860\",\n font_size = 18,\n main = NULL,\n main_y = 1,\n main_yanchor = \"bottom\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n margin = list(l = 20, r = 5, b = 5, t = 20),\n # write to file\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1\n) {\n # Input ----\n if (S7_inherits(x, ClassificationMetrics)) {\n x <- x@metrics[[\"Confusion_Matrix\"]]\n }\n\n if (is.null(dim(x)) || ncol(x) != nrow(x)) {\n cli::cli_abort(\"The confusion matrix must be a square matrix.\")\n }\n\n # Metrics ----\n nclasses <- ncol(x)\n total <- sum(x)\n class_totals <- rowSums(x)\n condition_negative <- total - class_totals\n predicted_totals <- colSums(x)\n hits <- diag(x)\n # misses = class_totals - hits\n class_sensitivity <- hits / class_totals\n true_negative <- total - predicted_totals - (class_totals - hits)\n class_specificity <- true_negative / condition_negative\n class_balancedAccuracy <- .5 * (class_sensitivity + class_specificity)\n # PPV = true positive / predicted condition positive\n class_ppv <- hits / predicted_totals\n # NPV = true negative / predicted condition negative\n class_npv <- true_negative / (total - predicted_totals)\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n bg <- plotly::toRGB(theme[[\"bg\"]])\n plot_bg <- plotly::toRGB(theme[[\"plot_bg\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n\n # Colors ----\n pos_color <- colorRamp(colors = c(theme[[\"bg\"]], true_col))\n neg_color <- colorRamp(colors = c(theme[[\"bg\"]], false_col))\n\n # Fonts ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = theme[[\"labs_col\"]]\n )\n\n # Plot ----\n plt <- plotly::plot_ly(\n type = \"scatter\",\n mode = \"lines\"\n )\n\n # Add colored tiles & counts ----\n for (i in seq_len(nclasses)) {\n for (j in seq_len(nclasses)) {\n plt <- make_plotly_conf_tile(\n p = plt,\n x = x,\n i = i,\n j = j,\n pos_color = pos_color,\n neg_color = neg_color,\n font_size = font_size,\n theme = theme\n )\n }\n }\n\n # Layout ----\n plt <- plotly::layout(\n plt,\n xaxis = list(\n side = \"above\",\n showticklabels = FALSE,\n showgrid = FALSE,\n zeroline = FALSE\n ),\n yaxis = list(\n showticklabels = FALSE,\n showgrid = FALSE,\n zeroline = FALSE,\n autorange = \"reversed\",\n scaleanchor = \"x\",\n scaleratio = 1\n ),\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n ),\n xref = \"paper\",\n x = theme[[\"main_adj\"]],\n yref = \"paper\",\n y = main_y,\n yanchor = main_yanchor\n ),\n showlegend = FALSE,\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg,\n margin = margin\n ) # /layout\n\n # Class labels ----\n # Add class labels above and to the left of the plot\n # Left\n plt <- plotly::add_annotations(\n plt,\n x = rep(-0.125, nclasses),\n y = seq_len(nclasses) - 0.5,\n text = colnames(x),\n # textposition = \"middle right\",\n font = f,\n showarrow = FALSE,\n textangle = -90\n )\n # Above\n plt <- plotly::add_annotations(\n plt,\n x = seq_len(nclasses) - 0.5,\n y = rep(-0.125, nclasses),\n text = colnames(x),\n # textposition = \"bottom center\",\n font = f,\n showarrow = FALSE\n )\n\n # x-axis label \"Predicted\"\n plt <- plotly::add_annotations(\n plt,\n x = nclasses / 2,\n y = ifelse(nclasses == 2, -.3, -0.5),\n text = xlab,\n font = f,\n showarrow = FALSE\n )\n\n # y-axis label \"Reference\"\n plt <- plotly::add_annotations(\n plt,\n x = ifelse(nclasses == 2, -.3, -0.5),\n y = nclasses / 2,\n text = ylab,\n font = f,\n showarrow = FALSE,\n textangle = -90\n )\n\n # Metrics ----\n if (nclasses == 2) {\n # Sens./Spec. ----\n # Rect: Sens./Spec. bg\n plt <- plotly::add_trace(\n plt,\n x = c(nclasses, nclasses + 0.3, nclasses + 0.3, nclasses),\n y = c(0, 0, nclasses, nclasses),\n line = list(color = \"transparent\"),\n fill = \"toself\",\n fillcolor = plotly::toRGB(theme[[\"fg\"]], alpha = .075),\n showlegend = FALSE\n )\n\n # Text: Sens. & Spec.\n plt <- plotly::add_annotations(\n plt,\n x = rep(nclasses + 0.15, 2),\n y = c(.5, 1.5),\n text = paste0(\n c(\"Sensitivity\\n\", \"Specificity\\n\"),\n c(ddSci(class_sensitivity[1], 3), ddSci(class_specificity[1], 3))\n ),\n font = f,\n showarrow = FALSE,\n textangle = -90\n )\n\n # PPV/NPV ----\n # Rect: PPV/NPV bg\n plt <- plotly::add_trace(\n plt,\n x = c(0, nclasses, nclasses, 0, 0),\n y = c(nclasses, nclasses, nclasses + .3, nclasses + .3, nclasses),\n line = list(color = \"transparent\"),\n fill = \"toself\",\n fillcolor = plotly::toRGB(theme[[\"fg\"]], alpha = .075),\n showlegend = FALSE\n )\n\n # Text: PPV & NPV\n plt <- plotly::add_annotations(\n plt,\n x = c(.5, 1.5),\n y = rep(nclasses + 0.15, 2),\n text = paste0(\n c(\"PPV\\n\", \"NPV\\n\"),\n c(ddSci(class_ppv[1], 3), ddSci(class_npv[1], 3))\n ),\n font = f,\n showarrow = FALSE\n )\n } else {\n # PPV ----\n # Text: \"PPV\" at bottom left corner\n plt <- plotly::add_annotations(\n plt,\n x = -0.05,\n y = nclasses + .1,\n xanchor = \"right\",\n yanchor = \"middle\",\n text = \"PPV\",\n font = f,\n showarrow = FALSE\n )\n\n # Rect: PPV bg\n plt <- plotly::add_trace(\n plt,\n x = c(0, nclasses, nclasses, 0, 0),\n y = c(nclasses, nclasses, nclasses + 0.2, nclasses + 0.2, nclasses),\n line = list(color = \"transparent\"),\n fill = \"toself\",\n fillcolor = plotly::toRGB(theme[[\"fg\"]], alpha = .075),\n showlegend = FALSE\n )\n\n # Text: Per-class PPV\n for (i in seq_len(nclasses)) {\n plt <- plotly::add_annotations(\n plt,\n x = i - 0.5,\n y = nclasses + .1,\n text = ddSci(class_ppv[i], 3),\n font = f,\n showarrow = FALSE\n )\n }\n\n # NPV ----\n # Label: \"NPV\" at bottom left corner\n plt <- plotly::add_annotations(\n plt,\n x = -0.05,\n y = nclasses + .3,\n xanchor = \"right\",\n yanchor = \"middle\",\n text = \"NPV\",\n font = f,\n showarrow = FALSE\n )\n\n # Rect: NPV bg\n plt <- plotly::add_trace(\n plt,\n x = c(0, nclasses, nclasses, 0, 0),\n y = c(\n nclasses + 0.2,\n nclasses + 0.2,\n nclasses + 0.4,\n nclasses + 0.4,\n nclasses + 0.2\n ),\n line = list(color = \"transparent\"),\n fill = \"toself\",\n fillcolor = plotly::toRGB(theme[[\"fg\"]], alpha = .05),\n showlegend = FALSE\n )\n\n # Text: Per-class NPV\n for (i in seq_len(nclasses)) {\n plt <- plotly::add_annotations(\n plt,\n x = i - 0.5,\n y = nclasses + .3,\n text = ddSci(class_npv[i], 3),\n font = f,\n showarrow = FALSE\n )\n }\n\n # Sensitivity ----\n # Label: \"Sens.\" top right vertically\n plt <- plotly::add_annotations(\n plt,\n x = nclasses + 0.1,\n y = -.05,\n yanchor = \"bottom\",\n text = \"Sens.\",\n font = f,\n showarrow = FALSE,\n textangle = -90\n )\n\n # Rect: Sens. bg\n plt <- plotly::add_trace(\n plt,\n x = c(nclasses, nclasses + 0.2, nclasses + 0.2, nclasses),\n y = c(0, 0, nclasses, nclasses),\n line = list(color = \"transparent\"),\n fill = \"toself\",\n fillcolor = plotly::toRGB(theme[[\"fg\"]], alpha = .075),\n showlegend = FALSE\n )\n\n # Text: Per-class Sens.\n for (i in seq_len(nclasses)) {\n plt <- plotly::add_annotations(\n plt,\n x = nclasses + 0.1,\n y = i - 0.5,\n text = ddSci(class_sensitivity[i], 3),\n font = f,\n showarrow = FALSE,\n textangle = -90\n )\n }\n\n # Specificity ----\n # Label: \"Spec.\" top right vertically\n plt <- plotly::add_annotations(\n plt,\n x = nclasses + 0.3,\n y = -.05,\n yanchor = \"bottom\",\n text = \"Spec.\",\n font = f,\n showarrow = FALSE,\n textangle = -90\n )\n\n # Rect: Spec. bg\n plt <- plotly::add_trace(\n plt,\n x = c(nclasses + 0.2, nclasses + 0.4, nclasses + 0.4, nclasses + 0.2),\n y = c(0, 0, nclasses, nclasses),\n line = list(color = \"transparent\"),\n fill = \"toself\",\n fillcolor = plotly::toRGB(theme[[\"fg\"]], alpha = .05),\n showlegend = FALSE\n )\n\n # Text: Per-class Spec.\n for (i in seq_len(nclasses)) {\n plt <- plotly::add_annotations(\n plt,\n x = nclasses + 0.3,\n y = i - 0.5,\n text = ddSci(class_specificity[i], 3),\n font = f,\n showarrow = FALSE,\n textangle = -90\n )\n }\n }\n\n # Balanced Accuracy ----\n # Rect: BA bg\n ba_pad <- ifelse(nclasses == 2, 0.3, 0.4)\n plt <- plotly::add_trace(\n plt,\n x = c(nclasses, nclasses + ba_pad, nclasses + ba_pad, nclasses),\n y = c(nclasses, nclasses, nclasses + ba_pad, nclasses + ba_pad),\n line = list(color = \"transparent\"),\n fill = \"toself\",\n fillcolor = plotly::toRGB(theme[[\"fg\"]], alpha = .025),\n showlegend = FALSE\n )\n\n # Text: Balanced accuracy\n ba_pad <- ifelse(nclasses == 2, 0.15, 0.2)\n ba <- ifelse(\n nclasses == 2,\n class_balancedAccuracy[1],\n mean(class_balancedAccuracy)\n )\n plt <- plotly::add_annotations(\n plt,\n x = nclasses + ba_pad,\n y = nclasses + ba_pad,\n xanchor = \"center\",\n yanchor = \"middle\",\n text = paste0(\"BA\\n\", ddSci(ba, 3)),\n font = f,\n showarrow = FALSE\n )\n\n # Disable hoverinfo\n plt <- plotly::style(plt, hoverinfo = \"none\")\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n return(plt)\n} # /rtemis::draw_confusion\n\n\n#' Make plotly confusion matrix tile\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmake_plotly_conf_tile <- function(\n p,\n x,\n i,\n j,\n pos_color,\n neg_color,\n font_size,\n theme,\n xref = \"x\",\n yref = \"y\"\n) {\n val <- x[i, j] / sum(x[i, ])\n col <- if (i == j) {\n pos_color(val)\n } else {\n neg_color(val)\n }\n col <- rgb(col[1], col[2], col[3], maxColorValue = 255)\n # Add colored tile\n p <- plotly::add_trace(\n p,\n x = c(j - 1, j - 1, j, j, j - 1),\n y = c(i, i - 1, i - 1, i, i),\n line = list(color = \"transparent\"),\n fill = \"toself\",\n fillcolor = col\n )\n # Add text\n p <- plotly::add_trace(\n p,\n x = j - 0.5,\n y = i - 0.5,\n mode = \"text\",\n text = paste0(\"\", x[i, j], \"\"),\n textposition = \"middle center\",\n textfont = list(\n family = theme[[\"font_family\"]],\n color = ifelse(val > 0.5, theme[[\"bg\"]], theme[[\"fg\"]]),\n size = font_size\n ),\n showlegend = FALSE\n )\n\n return(p)\n} # /rtemis::make_plotly_conf_tile\n" }, { "path": "R/draw_dist.R", "content": "# draw_dist.R\n# ::rtemis::\n# 2019- EDG rtemis.org\n\n# check whether list is reordered with ridge\n\n#' Draw Distributions using Histograms and Density Plots\n#'\n#' Draw Distributions using Histograms and Density Plots using `plotly`.\n#'\n#' @details\n#' See [docs.rtemis.org/r](https://docs.rtemis.org/r/) for detailed documentation.\n#'\n#' If input is data.frame, non-numeric variables will be removed.\n#'\n#' @param x Numeric vector / data.frame / list: Input. If not a vector, each column / each element is drawn.\n#' @param type Character: \"density\" or \"histogram\".\n#' @param mode Character: \"overlap\", \"ridge\". How to plot different groups; on the same axes (\"overlap\"), or on separate plots with the same x-axis (\"ridge\").\n#' @param group Vector: Will be converted to factor; levels define group members.\n#' @param main Character: Main title for the plot.\n#' @param xlab Character: Label for the x-axis.\n#' @param ylab Character: Label for the y-axis.\n#' @param col Color: Colors for the plot.\n#' @param alpha Numeric: Alpha transparency for plot elements.\n#' @param plot_bg Color: Background color for plot area.\n#' @param theme `Theme` object.\n#' @param palette Character: Color palette to use.\n#' @param axes_square Logical: If TRUE, draw a square plot to fill the graphic device. Default = FALSE.\n#' @param group_names Character: Names for the groups.\n#' @param font_size Numeric: Font size for plot text.\n#' @param font_alpha Numeric: Alpha transparency for font.\n#' @param legend Logical: If TRUE, draw legend. Default = NULL, which will be set to TRUE if x is a list of more than 1 element.\n#' @param legend_xy Numeric, vector, length 2: Relative x, y position for legend. Default = c(0, 1).\n#' @param legend_col Color: Color for the legend text.\n#' @param legend_bg Color: Background color for legend.\n#' @param legend_border_col Color: Border color for legend.\n#' @param bargap Numeric: The gap between adjacent histogram bars in plot fraction.\n#' @param vline Numeric, vector: If defined, draw a vertical line at this x value(s).\n#' @param vline_col Color: Color for `vline`.\n#' @param vline_width Numeric: Width for `vline`.\n#' @param vline_dash Character: Type of line to draw: \"solid\", \"dot\", \"dash\", \"longdash\", \"dashdot\", or \"longdashdot\".\n#' @param text Character: If defined, add this text over the plot.\n#' @param text_x Numeric: x-coordinate for `text`.\n#' @param text_xref Character: \"x\": `text_x` refers to plot's x-axis; \"paper\": `text_x` refers to plotting area from 0-1.\n#' @param text_xanchor Character: \"auto\", \"left\", \"center\", \"right\".\n#' @param text_y Numeric: y-coordinate for `text`.\n#' @param text_yref Character: \"y\": `text_y` refers to plot's y-axis; \"paper\": `text_y` refers to plotting area from 0-1.\n#' @param text_yanchor Character: \"auto\", \"top\", \"middle\", \"bottom\".\n#' @param text_col Color: Color for `text`.\n#' @param margin List: Margins for the plot.\n#' @param automargin_x Logical: If TRUE, automatically adjust x-axis margins.\n#' @param automargin_y Logical: If TRUE, automatically adjust y-axis margins.\n#' @param zerolines Logical: If TRUE, draw lines at y = 0.\n#' @param density_kernel Character: Kernel to use for density estimation.\n#' @param density_bw Character: Bandwidth to use for density estimation.\n#' @param histnorm Character: NULL, \"percent\", \"probability\", \"density\", \"probability density\".\n#' @param histfunc Character: \"count\", \"sum\", \"avg\", \"min\", \"max\".\n#' @param hist_n_bins Integer: Number of bins to use if type = \"histogram\".\n#' @param barmode Character: Barmode for histogram. One of \"overlay\", \"stack\", \"relative\", \"group\".\n#' @param ridge_sharex Logical: If TRUE, draw single x-axis when `mode = \"ridge\"`.\n#' @param ridge_y_labs Logical: If TRUE, show individual y labels when `mode = \"ridge\"`.\n#' @param ridge_order_on_mean Logical: If TRUE, order groups by mean value when `mode = \"ridge\"`.\n#' @param displayModeBar Logical: If TRUE, display the mode bar.\n#' @param modeBar_file_format Character: File format for mode bar. Default = \"svg\".\n#' @param width Numeric: Force plot size to this width. Default = NULL, i.e. fill available space.\n#' @param height Numeric: Force plot size to this height. Default = NULL, i.e. fill available space.\n#' @param filename Character: Path to file to save static plot.\n#' @param file_width Integer: File width in pixels for when `filename` is set.\n#' @param file_height Integer: File height in pixels for when `filename` is set.\n#' @param file_scale Numeric: If saving to file, scale plot by this number.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' # Will automatically use only numeric columns\n#' draw_dist(iris)\n#' draw_dist(iris[[\"Sepal.Length\"]], group = iris[[\"Species\"]])\ndraw_dist <- function(\n x,\n type = c(\"density\", \"histogram\"),\n mode = c(\"overlap\", \"ridge\"),\n group = NULL,\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n col = NULL,\n alpha = .75,\n plot_bg = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = getOption(\"rtemis_palette\", \"rtms\"),\n axes_square = FALSE,\n group_names = NULL,\n font_size = 16,\n font_alpha = .8,\n legend = NULL,\n legend_xy = c(0, 1),\n legend_col = NULL,\n legend_bg = \"#FFFFFF00\",\n legend_border_col = \"#FFFFFF00\",\n bargap = .05,\n vline = NULL,\n vline_col = theme[[\"fg\"]],\n vline_width = 1,\n vline_dash = \"dot\",\n text = NULL,\n text_x = 1,\n text_xref = \"paper\",\n text_xanchor = \"left\",\n text_y = 1,\n text_yref = \"paper\",\n text_yanchor = \"top\",\n text_col = theme[[\"fg\"]],\n margin = list(b = 65, l = 65, t = 50, r = 10, pad = 0),\n automargin_x = TRUE,\n automargin_y = TRUE,\n zerolines = FALSE,\n density_kernel = \"gaussian\",\n density_bw = \"SJ\",\n histnorm = c(\n \"\",\n \"density\",\n \"percent\",\n \"probability\",\n \"probability density\"\n ),\n histfunc = c(\"count\", \"sum\", \"avg\", \"min\", \"max\"),\n hist_n_bins = 20,\n barmode = \"overlay\", # ?alternatives\n ridge_sharex = TRUE,\n ridge_y_labs = FALSE,\n ridge_order_on_mean = TRUE,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n width = NULL,\n height = NULL,\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1\n) {\n # Dependencies ----\n check_dependencies(\"plotly\")\n\n # Arguments ----\n type <- match.arg(type)\n mode <- match.arg(mode)\n if (!is.null(main)) {\n main <- paste0(\"\", main, \"\")\n }\n .xname <- labelify(deparse(substitute(x)))\n\n # Data ----\n\n # '- Group ----\n if (!is.null(group)) {\n if (is.factor(group)) {\n group <- droplevels(group)\n } else {\n group <- as.factor(group)\n }\n x <- as.data.frame(x)\n # Can't have multiple vectors in `x` and `group`\n if (length(x) > 1 && !is.null(group)) {\n cli::cli_abort(\n \"Can't have both multiple vectors in `x` and `group` defined.\"\n )\n }\n x <- split(x, group)\n x <- sapply(x, as.vector)\n if (is.null(group_names)) {\n group_names <- levels(group)\n }\n names(x) <- .names <- group_names\n }\n\n if (!is.list(x)) {\n x <- list(x)\n }\n n_groups <- length(x)\n if (n_groups == 1 && is.null(xlab)) {\n xlab <- .xname\n }\n\n # Remove non-numeric vectors\n which_nonnum <- which(sapply(x, function(i) !is.numeric(i)))\n if (length(which_nonnum) > 0) {\n for (i in rev(which_nonnum)) {\n x[[i]] <- NULL\n }\n }\n\n if (is.null(legend)) {\n legend <- length(x) > 1\n }\n if (!is.null(group_names)) {\n .names <- group_names\n } else {\n .names <- labelify(names(x))\n }\n if (is.null(.names)) {\n .names <- paste(\"Feature\", seq_along(x))\n }\n\n # Colors ----\n if (is.character(palette)) {\n palette <- get_palette(palette)\n }\n n_groups <- length(x)\n if (is.null(col)) {\n col <- recycle(palette, seq(n_groups))[seq(n_groups)]\n }\n\n if (length(col) < n_groups) {\n col <- rep(col, n_groups / length(col))\n }\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n bg <- plotly::toRGB(theme[[\"bg\"]])\n plot_bg <- plotly::toRGB(theme[[\"plot_bg\"]])\n grid_col <- plotly::toRGB(theme[[\"grid_col\"]])\n tick_col <- plotly::toRGB(theme[[\"tick_col\"]])\n labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n if (!theme[[\"axes_visible\"]]) {\n tick_col <- labs_col <- \"transparent\"\n }\n\n # '- Axis font ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = labs_col\n )\n\n # '- Tick font ----\n tickfont <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = theme[[\"tick_labels_col\"]]\n )\n\n # Derived\n if (is.null(legend_col)) {\n legend_col <- labs_col\n }\n\n # Size ----\n if (axes_square) {\n width <- height <- min(dev.size(\"px\")) - 10\n }\n\n # Ridge ----\n if (mode == \"ridge\") {\n axis <- list(\n showline = FALSE,\n # mirror = axes_mirrored,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = zerolines\n )\n ridge_groups <- if (ridge_order_on_mean) {\n order(sapply(x, mean), decreasing = TRUE)\n } else {\n seq_len(n_groups)\n }\n }\n\n # plotly ----\n # z <- if (mode == \"overlap\") rep(1, n_groups) else seq_len(n_groups)\n # plt <- vector(\"list\", n_groups)\n\n .text <- lapply(x, function(i) {\n paste(\n \"mean =\",\n ddSci(mean(i, na.rm = TRUE)),\n \"\\nsd =\",\n ddSci(sd(i, na.rm = TRUE))\n )\n })\n\n # '- { Density } ----\n if (type == \"density\") {\n if (is.null(ylab)) {\n ylab <- \"Density\"\n }\n xl_density <- lapply(\n x,\n density,\n na.rm = TRUE,\n kernel = density_kernel,\n bw = density_bw\n )\n\n if (mode == \"overlap\") {\n # '- Density overlap ----\n plt <- plotly::plot_ly(\n width = width,\n height = height\n )\n for (i in seq_len(n_groups)) {\n plt <- plotly::add_trace(\n plt,\n x = xl_density[[i]][[\"x\"]],\n y = xl_density[[i]][[\"y\"]],\n type = \"scatter\",\n mode = \"none\",\n fill = \"tozeroy\",\n fillcolor = plotly::toRGB(col[[i]], alpha),\n name = .names[i],\n hovertext = .text[[i]],\n hoverinfo = \"text\",\n showlegend = legend\n )\n }\n } else {\n # '- Density ridge ----\n plt <- lapply(ridge_groups, function(i) {\n plotly::plot_ly(\n x = xl_density[[i]][[\"x\"]],\n y = xl_density[[i]][[\"y\"]],\n type = \"scatter\",\n mode = \"none\",\n fill = \"tozeroy\",\n fillcolor = plotly::toRGB(col[[i]], alpha),\n name = .names[i],\n hovertext = .text[[i]],\n hoverinfo = \"text\",\n showlegend = legend,\n width = width,\n height = height\n ) |>\n plotly::layout(\n xaxis = axis,\n yaxis = c(\n list(\n title = list(\n text = .names[i],\n font = f\n )\n ),\n axis\n )\n )\n })\n }\n } # End mode == \"density\"\n\n # '- { Histogram } ----\n if (type == \"histogram\") {\n # https://plotly.com/r/reference/#histogram-bingroup\n bingroup <- 1\n histnorm <- match.arg(histnorm)\n histfunc <- match.arg(histfunc)\n # if (is.null(ylab)) ylab <- \"Count\"\n\n if (mode == \"overlap\") {\n # '- Histogram overlap ----\n plt <- plotly::plot_ly(\n width = width,\n height = height\n )\n for (i in seq_len(n_groups)) {\n plt <- plotly::add_trace(\n plt,\n x = x[[i]],\n type = \"histogram\",\n marker = list(color = plotly::toRGB(col[i], alpha)),\n name = .names[i],\n hovertext = .text[[i]],\n hoverinfo = \"text\",\n histnorm = histnorm,\n histfunc = histfunc,\n nbinsx = hist_n_bins,\n showlegend = legend,\n bingroup = bingroup\n )\n }\n plt <- plotly::layout(plt, barmode = barmode, bargap = bargap)\n } else {\n # '- Histogram ridge ----\n plt <- lapply(ridge_groups, function(i) {\n plotly::plot_ly(\n x = x[[i]],\n type = \"histogram\",\n histnorm = histnorm,\n histfunc = histfunc,\n nbinsx = hist_n_bins,\n marker = list(color = plotly::toRGB(col[i], alpha)),\n name = .names[i],\n hovertext = .text[[i]],\n hoverinfo = \"text\",\n showlegend = legend,\n width = width,\n height = height,\n bingroup = bingroup\n ) |>\n plotly::layout(\n xaxis = axis,\n yaxis = c(\n list(\n title = list(\n text = .names[i],\n font = f\n )\n ),\n axis\n ),\n bargap = bargap\n )\n })\n }\n }\n\n if (mode == \"ridge\") {\n plt <- plotly::subplot(\n plt,\n nrows = n_groups,\n shareX = ridge_sharex,\n # shareY = ridge_sharey,\n titleY = ridge_y_labs\n )\n }\n\n # Layout ----\n zerocol <- adjustcolor(theme[[\"zerolines_col\"]], theme[[\"zerolines_alpha\"]])\n # '- layout ----\n .legend <- list(\n x = legend_xy[1],\n y = legend_xy[2],\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = legend_col\n ),\n bgcolor = legend_bg,\n bordercolor = legend_border_col\n )\n\n plt <- plotly::layout(\n plt,\n xaxis = list(\n title = list(\n text = xlab,\n font = f\n ),\n showline = FALSE,\n # mirror = axes_mirrored,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = FALSE,\n automargin = automargin_x\n ),\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n ),\n xref = \"paper\",\n x = theme[[\"main_adj\"]]\n ),\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg,\n margin = margin,\n showlegend = legend,\n legend = .legend\n )\n\n if (mode == \"overlap\") {\n plt <- plotly::layout(\n plt,\n yaxis = list(\n title = list(\n text = ylab,\n font = f\n ),\n showline = FALSE,\n # mirror = axes_mirrored,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = zerolines,\n zerolinecolor = zerocol,\n zerolinewidth = theme[[\"zerolines_lwd\"]],\n automargin = automargin_y\n )\n )\n }\n\n # vline ----\n if (!is.null(vline)) {\n plt <- plotly::layout(\n plt,\n shapes = plotly_vline(\n vline,\n color = vline_col,\n width = vline_width,\n dash = vline_dash\n )\n )\n }\n\n # text ----\n if (!is.null(text)) {\n plt <- plotly::layout(\n plt,\n annotations = list(\n text = text,\n x = text_x,\n xref = text_xref,\n xanchor = text_xanchor,\n y = text_y,\n yref = text_yref,\n yanchor = text_yanchor,\n font = list(\n color = text_col,\n family = theme[[\"font_family\"]],\n size = font_size\n ),\n showarrow = FALSE\n )\n )\n }\n\n # Config\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n )\n )\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n plt\n} # /rtemis::draw_dist\n" }, { "path": "R/draw_graphd3.R", "content": "# draw_graphD3\n# ::rtemis::\n# EDG rtemis.org\n\n#' Plot graph using \\pkg{networkD3}\n#'\n#' @param net \\pkg{igraph} network.\n#' @param groups Vector, length n nodes indicating group/cluster/community membership of nodes in `net`.\n#' @param color_scale D3 colorscale (e.g. `networkD3::JS(\"d3.scaleOrdinal(d3.schemeCategory20b);\")`).\n#' @param edge_col Color for edges.\n#' @param node_col Color for nodes.\n#' @param node_alpha Float \\[0, 1\\]: Node opacity.\n#' @param edge_alpha Float \\[0, 1\\]: Edge opacity.\n#' @param zoom Logical: If TRUE, graph is zoomable.\n#' @param legend Logical: If TRUE, display legend for groups.\n#' @param palette Character vector: Colors to use.\n#' @param theme `Theme` object.\n#' @param ... Additional arguments to pass to `networkD3`.\n#'\n#' @return `forceNetwork` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' library(igraph)\n#' g <- make_ring(10)\n#' draw_graphD3(g)\ndraw_graphD3 <- function(\n net,\n groups = NULL,\n color_scale = NULL,\n edge_col = NULL,\n node_col = NULL,\n node_alpha = .5,\n edge_alpha = .33,\n zoom = TRUE,\n legend = FALSE,\n palette = get_palette(getOption(\"rtemis_palette\")),\n theme = choose_theme(getOption(\"rtemis_theme\")),\n ...\n) {\n # Dependencies ----\n check_dependencies(\"networkD3\")\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n netd3 <- networkD3::igraph_to_networkD3(net)\n if (is.null(groups)) {\n netd3[[\"nodes\"]][[\"group\"]] <- \"A\"\n } else {\n netd3[[\"nodes\"]][[\"group\"]] <- groups\n }\n\n # Colors ----\n if (is.null(node_col) && length(unique(netd3[[\"nodes\"]][[\"group\"]])) == 1) {\n node_col <- theme[[\"fg\"]]\n }\n\n if (is.null(color_scale)) {\n if (length(unique(netd3[[\"nodes\"]][[\"group\"]])) == 1) {\n color_scale <- paste0(\n 'd3.scaleOrdinal().domain([\"A\"]).range([\"',\n adjustcolor(node_col, node_alpha),\n '\"]);'\n )\n } else {\n if (is.character(palette)) {\n palette <- adjustcolor(unlist(get_palette(palette)), node_alpha)\n }\n ngroups <- length(unique(groups))\n .groups <- paste0(sort(unique(groups)), collapse = '\", \"')\n if (ngroups > length(palette)) {\n palette <- rep(palette, ngroups / length(palette))\n }\n .colors <- paste0(palette[seq(ngroups)], collapse = '\", \"')\n color_scale <- paste0(\n 'd3.scaleOrdinal().domain([\"',\n .groups,\n '\"]).range([\"',\n .colors,\n '\"]);'\n )\n }\n }\n\n if (is.null(edge_col)) {\n if (is.null(groups)) {\n edge_col <- adjustcolor(\"#18A3AC\", edge_alpha)\n } else {\n edge_col <- adjustcolor(theme[[\"fg\"]], edge_alpha)\n }\n } else {\n edge_col <- adjustcolor(edge_col, edge_alpha)\n }\n\n # Plot ----\n fn <- networkD3::forceNetwork(\n Links = netd3[[\"links\"]],\n Nodes = netd3[[\"nodes\"]],\n Source = \"source\",\n Target = \"target\",\n NodeID = \"name\",\n Group = \"group\",\n colourScale = color_scale,\n linkColour = edge_col,\n opacity = 1,\n legend = legend,\n zoom = zoom\n )\n\n # fn$x$nodes$border <- border.groups\n fn <- htmlwidgets::onRender(\n fn,\n 'function(el, x) { d3.selectAll(\"circle\").style(\"stroke\", d => \"#ffffff00\"); }'\n )\n\n fn\n} # /rtemis::draw_graphD3\n" }, { "path": "R/draw_graphjs.R", "content": "# draw_graphjs.R\n# ::rtemis::\n# EDG rtemis.org\n\n#' Plot network using \\pkg{threejs::graphjs}\n#'\n#' Interactive plotting of an \\pkg{igraph} net using \\pkg{threejs}.\n#'\n#' @param net \\pkg{igraph} network.\n#' @param vertex_size Numeric: Vertex size.\n#' @param vertex_col Color for vertices.\n#' @param vertex_label_col Color for vertex labels.\n#' @param vertex_label_alpha Numeric: Transparency for `vertex_label_col`.\n#' @param vertex_frame_col Color for vertex border (frame).\n#' @param vertex_label Character vector: Vertex labels. Default = NULL, which will keep existing names in `net` if any. Set to NA to avoid printing vertex labels.\n#' @param vertex_shape Character, vector, length 1 or N nodes: Vertex shape. See `graphjs(\"vertex_shape\")`.\n#' @param edge_col Color for edges.\n#' @param edge_alpha Numeric: Transparency for edges.\n#' @param edge_curved Numeric: Curvature of edges.\n#' @param edge_width Numeric: Edge thickness.\n#' @param layout Character: one of: \"fr\", \"dh\", \"drl\", \"gem\", \"graphopt\", \"kk\", \"lgl\", \"mds\", \"sugiyama\", corresponding to all the available layouts in \\pkg{igraph}.\n#' @param coords Output of precomputed \\pkg{igraph} layout. If provided, `layout` is ignored.\n#' @param layout_args List of arguments to pass to `layout` function.\n#' @param cluster Character: one of: \"edge_betweenness\", \"fast_greedy\", \"infomap\", \"label_prop\", \"leading_eigen\", \"louvain\", \"optimal\", \"spinglass\", \"walktrap\", corresponding to all the available \\pkg{igraph} clustering functions.\n#' @param groups Output of precomputed \\pkg{igraph} clustering. If provided, `cluster` is ignored.\n#' @param cluster_config List of arguments to pass to `cluster` function.\n#' @param cluster_mark_groups Logical: If TRUE, draw polygons to indicate clusters, if `groups` or `cluster` are defined.\n#' @param cluster_color_vertices Logical: If TRUE, color vertices by cluster membership.\n#' @param main Character: Main title.\n#' @param theme `Theme` object.\n#' @param palette Color vector or name of rtemis palette.\n#' @param mar Numeric vector, length 4: `par`'s margin argument.\n#' @param filename Character: If provided, save plot to this filepath.\n#' @param verbosity Integer: Verbosity level.\n#' @param ... Extra arguments to pass to `igraph::plot.igraph()`.\n#'\n#' @return `scatterplotThree` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' library(igraph)\n#' g <- make_ring(10)\n#' draw_graphjs(g)\ndraw_graphjs <- function(\n net,\n vertex_size = 1,\n vertex_col = NULL,\n vertex_label_col = NULL,\n vertex_label_alpha = .66,\n vertex_frame_col = NA,\n vertex_label = NULL,\n vertex_shape = \"circle\",\n edge_col = NULL,\n edge_alpha = .5,\n edge_curved = .35,\n edge_width = 2,\n layout = c(\n \"fr\",\n \"dh\",\n \"drl\",\n \"gem\",\n \"graphopt\",\n \"kk\",\n \"lgl\",\n \"mds\",\n \"sugiyama\"\n ),\n coords = NULL,\n layout_args = list(),\n cluster = NULL,\n groups = NULL,\n cluster_config = list(),\n cluster_mark_groups = TRUE,\n cluster_color_vertices = FALSE,\n main = \"\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = getOption(\"rtemis_palette\", \"rtms\"),\n mar = rep(0, 4),\n filename = NULL,\n verbosity = 1L,\n ...\n) {\n # Dependencies ----\n check_dependencies(\"igraph\", \"threejs\")\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n if (is.character(palette)) {\n palette <- unname(unlist(get_palette(palette)))\n }\n\n # Vertex names ----\n # by default use names in input net.\n if (!is.null(vertex_label)) {\n igraph::igraph.options(net, vertex_label = vertex_label)\n }\n\n # Layout ----\n layout <- match.arg(layout)\n if (is.null(coords) && !is.null(layout)) {\n coords <- do.call(\n getFromNamespace(paste0(\"layout_with_\", layout), \"igraph\"),\n c(list(net, dim = 3), layout_args)\n )\n if (layout == \"sugiyama\") coords <- coords[[\"layout\"]]\n }\n\n # Cluster ----\n if (is.null(groups) && !is.null(cluster)) {\n groups <- do.call(\n getFromNamespace(paste0(\"cluster_\", cluster), \"igraph\"),\n c(list(net), cluster_config)\n )\n }\n\n if (is.null(vertex_col)) {\n vertex_col <- if (!is.null(groups)) {\n palette <- recycle(palette, length(unique(groups[[\"membership\"]])))\n palette[groups[[\"membership\"]]]\n } else {\n theme[[\"fg\"]]\n }\n }\n\n if (is.null(vertex_label_col)) {\n vertex_label_col <- theme[[\"fg\"]]\n }\n vertex_label_col <- adjustcolor(vertex_label_col, vertex_label_alpha)\n\n # Leave edge_col as NULL for auto-coloring with groups\n if (is.null(edge_col) && is.null(groups)) {\n edge_col <- \"#18A3AC\"\n }\n\n # Plot ----\n threejs::graphjs(\n net,\n layout = coords,\n vertex.color = vertex_col,\n vertex.size = vertex_size,\n vertex.shape = vertex_shape,\n vertex.label = vertex_label,\n edge.color = edge_col,\n edge.alpha = edge_alpha,\n edge.width = edge_width,\n main = main,\n bg = theme[[\"bg\"]],\n vertex.label.color = vertex_label_col,\n vertex.frame.color = vertex_frame_col,\n edge.curved = edge_curved,\n vertex.label.family = theme[[\"font_family\"]],\n font.main = theme[[\"font_family\"]],\n stroke = NULL,\n verbosity = verbosity,\n ...\n )\n} # /rtemis::draw_graphjs\n" }, { "path": "R/draw_heatmap.R", "content": "# draw_heatmap.R\n# ::rtemis::\n# 2017 EDG rtemis.org\n\n#' Interactive Heatmaps\n#'\n#' Draw interactive heatmaps using `heatmaply`.\n#'\n#' @details\n#' See [docs.rtemis.org/r](https://docs.rtemis.org/r/) for detailed documentation.\n#' 'heatmaply' unfortunately forces loading of the 'colorspace' namespace.\n#'\n#' @param x Input matrix.\n#' @param Rowv Logical or dendrogram. If Logical: Compute dendrogram and reorder rows. Defaults to FALSE. If dendrogram: use as is, without reordering. See more at `heatmaply::heatmaply(\"Rowv\")`.\n#' @param Colv Logical or dendrogram. If Logical: Compute dendrogram and reorder columns. Defaults to FALSE. If dendrogram: use as is, without reordering. See more at `heatmaply::heatmaply(\"Colv\")`.\n#' @param cluster Logical: If TRUE, set `Rowv` and `Colv` to TRUE.\n#' @param symm Logical: If TRUE, treat `x` symmetrically - `x` must be a square matrix.\n#' @param cellnote Matrix with values to be displayed on hover. Defaults to `ddSci(x)`.\n#' @param colorgrad_n Integer: Number of colors in gradient. Default = 101.\n#' @param colors Character vector: Colors to use in gradient.\n#' @param space Character: Color space to use. Default = \"rgb\".\n#' @param lo Character: Color for low values. Default = \"#18A3AC\".\n#' @param lomid Character: Color for low-mid values.\n#' @param mid Character: Color for mid values.\n#' @param midhi Character: Color for mid-high values.\n#' @param hi Character: Color for high values. Default = \"#F48024\".\n#' @param k_row Integer: Number of desired number of groups by which to color dendrogram branches in the rows. Default = 1.\n#' @param k_col Integer: Number of desired number of groups by which to color dendrogram branches in the columns. Default = 1.\n#' @param grid_gap Integer: Space between cells. Default = 0 (no space).\n#' @param limits Float, length 2: Determine color range. Default = NULL, which automatically centers values around 0.\n#' @param margins Float, length 4: Heatmap margins.\n#' @param main Character: Main title.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param key_title Character: Title for the color key.\n#' @param showticklabels Logical: If TRUE, show tick labels.\n#' @param colorbar_len Numeric: Length of the colorbar.\n#' @param row_side_colors Data frame: Column names will be label names, cells should be label colors. See `heatmaply::heatmaply(\"row_side_colors\")`.\n#' @param row_side_palette Color palette function. See `heatmaply::heatmaply(\"row_side_palette\")`.\n#' @param col_side_colors Data frame: Column names will be label names, cells should be label colors. See `heatmaply::heatmaply(\"col_side_colors\")`.\n#' @param col_side_palette Color palette function. See `heatmaply::heatmaply(\"col_side_palette\")`.\n#' @param font_size Numeric: Font size.\n#' @param padding Numeric: Padding between cells.\n#' @param displayModeBar Logical: If TRUE, display the plotly mode bar.\n#' @param modeBar_file_format Character: File format for image exports from the mode bar.\n#' @param filename Character: File name to save the plot.\n#' @param file_width Numeric: Width of exported image.\n#' @param file_height Numeric: Height of exported image.\n#' @param file_scale Numeric: Scale of exported image.\n#' @param plot_method Character: Plot method to use. Default = \"plotly\".\n#' @param theme `Theme` object.\n#' @param ... Additional arguments to be passed to `heatmaply::heatmaply`.\n#'\n#' @return `plotly` object.`\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' x <- rnormmat(200, 20)\n#' xcor <- cor(x)\n#' draw_heatmap(xcor)\ndraw_heatmap <- function(\n x,\n Rowv = TRUE,\n Colv = TRUE,\n cluster = FALSE,\n symm = FALSE,\n cellnote = NULL,\n colorgrad_n = 101,\n colors = NULL,\n space = \"rgb\",\n lo = \"#18A3AC\",\n lomid = NULL,\n mid = NULL,\n midhi = NULL,\n hi = \"#F48024\",\n k_row = 1,\n k_col = 1,\n grid_gap = 0,\n limits = NULL,\n margins = NULL,\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n key_title = NULL,\n showticklabels = NULL,\n colorbar_len = .7,\n plot_method = \"plotly\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n row_side_colors = NULL,\n row_side_palette = NULL,\n col_side_colors = NULL,\n col_side_palette = NULL,\n font_size = NULL,\n padding = 0,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n ...\n) {\n # Dependencies ----\n check_dependencies(\"heatmaply\")\n\n # Colnames ----\n if (is.null(colnames(x))) {\n colnames(x) <- seq_len(NCOL(x))\n }\n if (is.null(rownames(x))) {\n rownames(x) <- seq_len(NROW(x))\n }\n\n # Margins ----\n # By default, allow 7 px per character\n if (is.null(margins)) {\n bottom <- max(nchar(colnames(x))) * 7 + 15\n left <- max(nchar(rownames(x))) * 7 + 10\n margins <- c(bottom, left, 50, 50)\n }\n\n # Tick Labels ----\n if (is.null(showticklabels)) {\n showticklabels <- c(\n ifelse(NCOL(x) < 50, TRUE, FALSE),\n ifelse(NROW(x) < 50, TRUE, FALSE)\n )\n }\n\n if (is.null(font_size)) {\n font_size <- 17.0769 - 0.2692 * ncol(x)\n }\n\n # Limits ----\n if (is.null(limits)) {\n maxabs <- max(abs(x), na.rm = TRUE)\n if (.2 < maxabs && maxabs < 1) {\n maxabs <- 1\n }\n limits <- c(-maxabs, maxabs)\n }\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n bg <- plotly::toRGB(theme[[\"bg\"]])\n fg <- plotly::toRGB(theme[[\"fg\"]])\n plot_bg <- plotly::toRGB(theme[[\"plot_bg\"]])\n grid_col <- plotly::toRGB(theme[[\"grid_col\"]])\n tick_labels_col <- plotly::toRGB(theme[[\"tick_labels_col\"]])\n labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n\n # Colors ----\n if (is.null(mid)) {\n mid <- theme[[\"bg\"]]\n }\n colors <- colorgrad(\n n = colorgrad_n,\n colors = colors,\n space = space,\n lo = lo,\n lomid = lomid,\n mid = mid,\n midhi = midhi,\n hi = hi\n )\n\n # Cluster ----\n if (cluster) {\n Rowv <- Colv <- TRUE\n }\n\n # Cellnote ----\n if (!is.null(cellnote)) {\n if (cellnote == \"values\") cellnote <- matrix(ddSci(x), NROW(x), NCOL(x))\n }\n\n # heatmaply ----\n ggp2text <- ggplot2::element_text(\n family = theme[[\"font_family\"]],\n color = theme[[\"tick_labels_col\"]]\n )\n ggp2theme <- ggplot2::theme(\n panel.background = ggplot2::element_rect(fill = theme[[\"bg\"]]),\n plot.background = ggplot2::element_rect(fill = theme[[\"bg\"]]),\n legend.text = ggplot2::element_text(color = theme[[\"fg\"]]),\n legend.background = ggplot2::element_rect(fill = theme[[\"bg\"]]),\n text = ggp2text,\n title = ggp2text,\n axis.text = ggp2text,\n axis.text.x = ggp2text,\n axis.text.y = ggp2text,\n axis.title.x = ggp2text,\n axis.title.y = ggp2text,\n plot.subtitle = ggp2text,\n plot.caption = ggp2text\n )\n\n # Dendrogram ----\n if (isTRUE(Rowv)) {\n Rowv <- x |>\n dist() |>\n hclust() |>\n as.dendrogram() |>\n dendextend::set(\"branches_k_color\", k = 1) |>\n dendextend::set(\"branches_lwd\", 1) |>\n dendextend::set(\"branches_col\", fg) |>\n dendextend::ladderize()\n }\n\n if (isTRUE(Colv)) {\n Colv <- x |>\n t() |>\n dist() |>\n hclust() |>\n as.dendrogram() |>\n dendextend::set(\"branches_k_color\", k = 1) |>\n dendextend::set(\"branches_lwd\", 1) |>\n dendextend::set(\"branches_col\", fg) |>\n dendextend::ladderize()\n }\n\n plt <- suppressWarnings(heatmaply::heatmaply(\n x,\n Rowv = Rowv,\n Colv = Colv,\n symm = symm,\n cellnote = cellnote,\n colors = colors,\n grid_gap = grid_gap,\n limits = limits,\n margins = margins,\n key_title = key_title,\n xlab = xlab,\n ylab = ylab,\n # main = main,\n k_row = k_row,\n k_col = k_col,\n plot_method = plot_method,\n colorbar_len = colorbar_len,\n showticklabels = showticklabels,\n heatmap_layers = ggp2theme,\n row_side_colors = row_side_colors,\n row_side_palette = row_side_palette,\n col_side_colors = col_side_colors,\n col_side_palette = col_side_palette\n # side_color_layers = ggp2theme,\n # file = filename\n ))\n\n # Layout ----\n # '- layout ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = labs_col\n )\n tickfont <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = tick_labels_col\n )\n .legend <- list(\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = fg\n )\n )\n\n plt <- plotly::layout(\n plt,\n yaxis2 = list(\n title = list(\n font = f\n ), # gets assigned to dendrogram\n titlefont = f,\n tickcolor = bg,\n showline = FALSE,\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickfont = tickfont\n ),\n xaxis = list(\n title = list(\n font = f\n ),\n titlefont = f,\n tickcolor = bg,\n showline = FALSE,\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickfont = tickfont\n ),\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n ),\n xref = \"paper\",\n x = theme[[\"main_adj\"]]\n ),\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg,\n legend = .legend\n )\n\n # Manual theme colors\n\n ## y axis tick label colors\n # plt[[\"x\"]][[\"layoutAttrs\"]][[2]][[\"yaxis2\"]][[\"tickfont\"]][[\"color\"]]\n ## x axis tick label colors\n # plt[[\"x\"]][[\"layoutAttrs\"]][[2]][[\"xaxis\"]][[\"tickfont\"]][[\"color\"]] <- \"rgba(255, 0, 0, 1)\"\n\n ## edge lines must be invisible\n plt[[\"x\"]][[\"layout\"]][[\"yaxis\"]][[\"linecolor\"]] <- plt[[\"x\"]][[\"layout\"]][[\n \"xaxis2\"\n ]][[\"linecolor\"]] <- theme[[\"bg\"]]\n\n # Manual layout ----\n # Set padding\n plt[[\"sizingPolicy\"]][[\"padding\"]] <- padding\n\n # Config ----\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n )\n )\n\n ## Override colorbar tick font color to theme[[\"fg\"]]\n plt[[\"x\"]][[\"data\"]][[3]][[\"colorbar\"]][[\"tickfont\"]] <- list(\n family = theme[[\"font_family\"]],\n color = tick_labels_col\n )\n plt[[\"x\"]][[\"data\"]][[3]][[\"colorbar\"]][[\"tickcolor\"]] <- theme[[\"tick_col\"]]\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n plt\n} # /rtemis::draw_heatmap\n" }, { "path": "R/draw_leaflet.R", "content": "# draw_leaflet.R\n# ::rtemis::\n# 2020 EDG rtemis.org\n\n#' Plot interactive choropleth map using \\pkg{leaflet}\n#'\n#' @param fips Character vector: FIPS codes. (If numeric, it will be appropriately zero-padded).\n#' @param values Values to map to `fips`.\n#' @param names Character vector: Optional county names to appear on hover along `values`.\n#' @param fillOpacity Float: Opacity for fill colors.\n#' @param color_mapping Character: \"Numeric\" or \"Bin\".\n#' @param col_lo Overlay color mapped to lowest value.\n#' @param col_hi Overlay color mapped to highest value.\n#' @param col_na Color mapped to NA values.\n#' @param col_highlight Hover border color.\n#' @param col_interpolate Character: \"linear\" or \"spline\".\n#' @param col_bins Integer: Number of color bins to create if `color_mapping = \"Bin\"`.\n#' @param domain Limits for mapping colors to values. Default = NULL and set to range.\n#' @param weight Float: Weight of county border lines.\n#' @param color Color of county border lines.\n#' @param alpha Float: Overlay transparency.\n#' @param bg_tile_provider Background tile (below overlay colors), one of `leaflet::providers`.\n#' @param bg_tile_alpha Float: Background tile transparency.\n#' @param fg_tile_provider Foreground tile (above overlay colors), one of `leaflet::providers`.\n#' @param legend_position Character: One of: \"topright\", \"bottomright\", \"bottomleft\", \"topleft\".\n#' @param legend_alpha Float: Legend box transparency.\n#' @param legend_title Character: Defaults to name of `values` variable.\n#' @param init_lng Float: Center map around this longitude (in decimal form). Default = -98.54180833333334 (US geographic center).\n#' @param init_lat Float: Center map around this latitude (in decimal form). Default = 39.207413888888894 (US geographic center).\n#' @param init_zoom Integer: Initial zoom level (depends on device, i.e. window, size).\n#' @param stroke Logical: If TRUE, draw polygon borders.\n#'\n#' @return `leaflet` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' fips <- c(06075, 42101)\n#' population <- c(874961, 1579000)\n#' names <- c(\"SF\", \"Philly\")\n#' draw_leaflet(fips, population, names)\n# NA in legend issue: https://github.com/rstudio/leaflet/issues/615\ndraw_leaflet <- function(\n fips,\n values,\n names = NULL,\n fillOpacity = 1,\n color_mapping = c(\"Numeric\", \"Bin\"),\n col_lo = \"#0290EE\",\n col_hi = \"#FE4AA3\",\n col_na = \"#303030\",\n col_highlight = \"#FE8A4F\",\n col_interpolate = c(\"linear\", \"spline\"),\n col_bins = 21, # for color_mapping Bin\n domain = NULL,\n weight = .5,\n color = \"black\",\n alpha = 1,\n bg_tile_provider = leaflet::providers[[\"CartoDB.Positron\"]],\n bg_tile_alpha = .67,\n fg_tile_provider = leaflet::providers[[\"CartoDB.PositronOnlyLabels\"]],\n legend_position = c(\n \"topright\",\n \"bottomright\",\n \"bottomleft\",\n \"topleft\"\n ),\n legend_alpha = .8,\n legend_title = NULL,\n init_lng = -98.54180833333334,\n init_lat = 39.207413888888894,\n init_zoom = 3,\n stroke = TRUE\n) {\n # Dependencies ----\n check_dependencies(\"leaflet\", \"geojsonio\", \"htmltools\", \"htmlwidgets\", \"sf\")\n\n # Arguments ----\n vals_name <- deparse(substitute(values))\n color_mapping <- match.arg(color_mapping)\n col_interpolate <- match.arg(col_interpolate)\n palette <- colorRamp(\n colors = c(col_lo, col_hi),\n interpolate = col_interpolate\n )\n legend_position <- match.arg(legend_position)\n if (is.null(legend_title)) {\n legend_title <- labelify(vals_name)\n }\n\n # State vs. County data ----\n if (max(nchar(fips)) < 3) {\n geo <- readRDS(\n system.file(\n \"extdata\",\n \"us-states.rds\",\n package = \"rtemis\"\n )\n )\n fips <- if (is.character(fips)) {\n fips\n } else {\n sprintf(\"%02d\", fips)\n }\n } else {\n geo <- readRDS(\n system.file(\n \"extdata\",\n \"us-counties.rds\",\n package = \"rtemis\"\n )\n )\n fips <- if (is.character(fips)) {\n fips\n } else {\n sprintf(\"%05d\", fips)\n }\n }\n\n # Match input county-level data\n index <- match(geo[[\"id\"]], fips)\n geo[[\"val\"]] <- values[index]\n\n # Colorscale ----\n if (color_mapping == \"Numeric\") {\n pal <- leaflet::colorNumeric(\n palette = palette,\n domain = domain,\n na.color = col_na,\n alpha = TRUE\n )\n } else {\n pal <- leaflet::colorBin(\n palette = palette,\n domain = domain,\n na.color = col_na,\n bins = col_bins\n )\n }\n\n # Hover labels ----\n .labs <- values[index]\n if (!is.null(names)) {\n .names <- names[index]\n labels <- lapply(seq_len(NROW(geo)), function(i) {\n if (is.na(.labs[i])) {\n '
N/A
'\n } else {\n sprintf(\"%s
%g\", .names[i], .labs[i])\n }\n }) |>\n lapply(htmltools::HTML)\n } else {\n labels <- lapply(seq_len(NROW(geo)), function(i) {\n if (is.na(.labs[i])) {\n '
N/A
'\n } else {\n sprintf(\"%g\", .labs[i])\n }\n }) |>\n lapply(htmltools::HTML)\n }\n geo[[\"labels\"]] <- labels\n\n # leaflet map ----\n map <- leaflet::leaflet(geo) |>\n leaflet::addProviderTiles(\n provider = bg_tile_provider,\n options = leaflet::providerTileOptions(opacity = bg_tile_alpha)\n ) |>\n leaflet::addMapPane(\"polygons\", zIndex = 410) |>\n leaflet::addMapPane(\"tiles\", zIndex = 420) |>\n leaflet::addPolygons(\n fillColor = ~ pal(val),\n fillOpacity = fillOpacity,\n opacity = alpha,\n weight = weight,\n color = color,\n stroke = stroke,\n group = legend_title,\n options = leaflet::pathOptions(pane = \"polygons\"),\n highlight = leaflet::highlightOptions(\n weight = 2,\n color = col_highlight,\n bringToFront = TRUE\n ),\n label = labels,\n labelOptions = leaflet::labelOptions(\n style = list(\"font-weight\" = \"normal\", padding = \"2px 2px\"),\n textsize = \"15px\",\n direction = \"auto\"\n )\n ) |>\n leaflet::addProviderTiles(\n provider = fg_tile_provider,\n options = leaflet::pathOptions(pane = \"tiles\")\n ) |>\n leaflet::addLegend(\n position = legend_position,\n pal = pal,\n values = geo[[\"val\"]],\n opacity = legend_alpha,\n title = legend_title\n ) |>\n leaflet::addLayersControl(overlayGroups = c(legend_title)) |>\n leaflet::setView(lng = init_lng, lat = init_lat, zoom = init_zoom)\n\n insert <- htmltools::tags[[\"style\"]](\n type = \"text/css\",\n \"div.info.legend.leaflet-control br {clear: both;}\"\n )\n map <- htmlwidgets::prependContent(map, insert)\n map\n} # /rtemis:: draw_leaflet\n" }, { "path": "R/draw_pie.R", "content": "# draw_pie.R\n# ::rtemis::\n# 2019 EDG rtemis.org\n\n#' Interactive Pie Chart\n#'\n#' Draw interactive pie charts using `plotly`.\n#'\n#' @param x data.frame: Input: Either a) 1 numeric column with categories defined by rownames, or\n#' b) two columns, the first is category names, the second numeric or c) a numeric vector with categories defined using\n#' the `category.names` argument.\n#' @param main Character: Plot title. Default = NULL, which results in `colnames(x)[1]`.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param alpha Numeric: Alpha for the pie slices.\n#' @param bg Character: Background color.\n#' @param plot_bg Character: Plot background color.\n#' @param theme `Theme` object.\n#' @param palette Character vector: Colors to use.\n#' @param category_names Character, vector, length = NROW(x): Category names. Default = NULL, which uses\n#' either `rownames(x)`, or the first column of `x` if `ncol(x) = 2`.\n#' @param textinfo Character: Info to show over each slice: \"label\", \"percent\", \"label+percent\".\n#' @param font_size Integer: Font size for labels.\n#' @param labs_col Character: Color of labels.\n#' @param legend Logical: If TRUE, show legend.\n#' @param legend_col Character: Color for legend.\n#' @param sep_col Character: Separator color.\n#' @param margin List: Margin settings.\n#' @param padding Numeric: Padding between cells.\n#' @param displayModeBar Logical: If TRUE, display the plotly mode bar.\n#' @param modeBar_file_format Character: File format for image exports from the mode bar.\n#' @param filename Character: File name to save plot.\n#' @param file_width Integer: Width for saved file.\n#' @param file_height Integer: Height for saved file.\n#' @param file_scale Numeric: Scale for saved file.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' draw_pie(VADeaths[, 1, drop = FALSE])\ndraw_pie <- function(\n x,\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n alpha = .8,\n bg = NULL,\n plot_bg = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n category_names = NULL,\n textinfo = \"label+percent\",\n font_size = 16,\n labs_col = NULL,\n legend = TRUE,\n legend_col = NULL,\n sep_col = NULL,\n margin = list(b = 50, l = 50, t = 50, r = 20),\n padding = 0,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1\n) {\n # Dependencies ----\n check_dependencies(\"plotly\")\n\n # Names ----\n .input_name <- deparse(substitute(x))\n .rownames <- rownames(x)\n .colnames <- colnames(x)\n x <- as.data.frame(x)\n\n .cat_names <- category_names\n\n if (NCOL(x) == 2) {\n .cat_names <- as.character(x[, 1])\n x <- x[, 2, drop = FALSE]\n if (is.null(main)) main <- .colnames[2]\n }\n\n if (is.null(.cat_names)) {\n if (!is.null(.rownames)) {\n .cat_names <- .rownames\n } else {\n .cat_names <- LETTERS[seq_len(NROW(x))]\n }\n }\n\n if (is.null(main)) {\n if (!is.null(.colnames)) {\n main <- labelify(.colnames[1])\n } else {\n main <- labelify(.input_name)\n }\n }\n\n if (!is.null(main)) {\n main <- paste0(\"\", main, \"\")\n }\n\n # Colors ----\n p <- NROW(x)\n col <- recycle(palette, seq_len(p))\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n bg <- plotly::toRGB(theme[[\"bg\"]])\n labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n\n if (is.null(legend_col)) {\n legend_col <- labs_col\n }\n sep_col <- if (is.null(sep_col)) bg else plotly::toRGB(sep_col)\n\n # plotly ----\n plt <- plotly::plot_ly(\n labels = .cat_names,\n values = x[, 1],\n type = \"pie\",\n textinfo = textinfo,\n insidetextfont = list(color = \"#FFFFFF\"),\n outsidetextfont = list(color = labs_col),\n marker = list(\n colors = unlist(col),\n line = list(color = sep_col, width = 1)\n )\n )\n\n ## layout ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = labs_col\n )\n .legend <- list(\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = legend_col\n )\n )\n plt <- plotly::layout(\n plt,\n yaxis = list(\n title = ylab,\n showline = FALSE,\n titlefont = f,\n showgrid = FALSE,\n zeroline = FALSE\n ),\n xaxis = list(\n title = xlab,\n showline = FALSE,\n titlefont = f,\n showgrid = FALSE,\n zeroline = FALSE\n ),\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n )\n ),\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg,\n margin = margin,\n showlegend = legend,\n legend = .legend\n )\n\n # Padding\n plt[[\"sizingPolicy\"]][[\"padding\"]] <- padding\n # Config\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n )\n )\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n plt\n} # /rtemis::draw_pie.R\n" }, { "path": "R/draw_protein.R", "content": "# draw_protein\n# ::rtemis::\n# 2022- EDG rtemis.org\n\n#' Plot an amino acid sequence with annotations\n#'\n#' Plot an amino acid sequence with multiple site and/or region annotations.\n#'\n#' @param x Character vector: amino acid sequence (1-letter abbreviations) OR\n#' `a3` object OR Character: path to JSON file OR Character: UniProt accession number.\n#' @param site Named list of lists with indices of sites. These will be\n#' highlighted by coloring the border of markers.\n#' @param region Named list of lists with indices of regions. These will be\n#' highlighted by coloring the markers and lines of regions using the\n#' `palette` colors.\n#' @param ptm List of post-translational modifications.\n#' @param cleavage_site List of cleavage sites.\n#' @param variant List of variant information.\n#' @param disease_variants List of disease variant information.\n#' @param n_per_row Integer: Number of amino acids to show per row.\n#' @param main Character: Main title.\n#' @param main_xy Numeric vector, length 2: x and y coordinates for title.\n#' e.g. if `main_xref` and `main_yref` are `\"paper\"`:\n#' `c(0.055, .975)` is top left, `c(.5, .975)` is top and\n#' middle.\n#' @param main_xref Character: xref for title.\n#' @param main_yref Character: yref for title.\n#' @param main_xanchor Character: xanchor for title.\n#' @param main_yanchor Character: yanchor for title.\n#' @param layout Character: \"1curve\", \"grid\": type of layout to use.\n#' @param show_markers Logical: If TRUE, show amino acid markers.\n#' @param show_labels Logical: If TRUE, annotate amino acids with elements.\n#' @param font_size Integer: Font size for labels.\n#' @param label_col Color for labels.\n#' @param scatter_mode Character: Mode for scatter plot.\n#' @param marker_size Integer: Size of markers.\n#' @param marker_col Color for markers.\n#' @param marker_alpha Numeric: Alpha for markers.\n#' @param marker_symbol Character: Symbol for markers.\n#' @param line_col Color for lines.\n#' @param line_alpha Numeric: Alpha for lines.\n#' @param line_width Numeric: Width for lines.\n#' @param show_full_names Logical: If TRUE, show full names of amino acids.\n#' @param region_scatter_mode Character: Mode for scatter plot.\n#' @param region_style Integer: Style for regions.\n#' @param region_marker_size Integer: Size of region markers.\n#' @param region_marker_alpha Numeric: Alpha for region markers.\n#' @param region_marker_symbol Character: Symbol for region markers.\n#' @param region_line_dash Character: Dash for region lines.\n#' @param region_line_shape Character: Shape for region lines.\n#' @param region_line_smoothing Numeric: Smoothing for region lines.\n#' @param region_line_width Numeric: Width for region lines.\n#' @param region_line_alpha Numeric: Alpha for region lines.\n#' @param theme `Theme` object.\n#' @param region_palette Named list of colors for regions.\n#' @param region_outline_only Logical: If TRUE, only show outline of regions.\n#' @param region_outline_pad Numeric: Padding for region outline.\n#' @param region_pad Numeric: Padding for region.\n#' @param region_fill_alpha Numeric: Alpha for region fill.\n#' @param region_fill_shape Character: Shape for region fill.\n#' @param region_fill_smoothing Numeric: Smoothing for region fill.\n#' @param bpadcx Numeric: Padding for region border.\n#' @param bpadcy Numeric: Padding for region border.\n#' @param site_marker_size Integer: Size of site markers.\n#' @param site_marker_symbol Character: Symbol for site markers.\n#' @param site_marker_alpha Numeric: Alpha for site markers.\n#' @param site_border_width Numeric: Width for site borders.\n#' @param site_palette Named list of colors for sites.\n#' @param variant_col Color for variants.\n#' @param disease_variant_col Color for disease variants.\n#' @param showlegend_ptm Logical: If TRUE, show legend for PTMs.\n#' @param ptm_col Named list of colors for PTMs.\n#' @param ptm_symbol Character: Symbol for PTMs.\n#' @param ptm_offset Numeric: Offset for PTMs.\n#' @param ptm_pad Numeric: Padding for PTMs.\n#' @param ptm_marker_size Integer: Size of PTM markers.\n#' @param clv_col Color for cleavage site annotations.\n#' @param clv_symbol Character: Symbol for cleavage site annotations.\n#' @param clv_offset Numeric: Offset for cleavage site annotations.\n#' @param clv_pad Numeric: Padding for cleavage site annotations.\n#' @param clv_marker_size Integer: Size of cleavage site annotation markers.\n#' @param annotate_position_every Integer: Annotate every nth position.\n#' @param annotate_position_alpha Numeric: Alpha for position annotations.\n#' @param annotate_position_ay Numeric: Y offset for position annotations.\n#' @param position_font_size Integer: Font size for position annotations.\n#' @param legend_xy Numeric vector, length 2: x and y coordinates for legend.\n#' @param legend_xanchor Character: xanchor for legend.\n#' @param legend_yanchor Character: yanchor for legend.\n#' @param legend_orientation Character: Orientation for legend.\n#' @param legend_col Color for legend.\n#' @param legend_bg Color for legend background.\n#' @param legend_border_col Color for legend border.\n#' @param legend_borderwidth Numeric: Width for legend border.\n#' @param legend_group_gap Numeric: Gap between legend groups.\n#' @param margin List: Margin settings.\n#' @param showgrid_x Logical: If TRUE, show x grid.\n#' @param showgrid_y Logical: If TRUE, show y grid.\n#' @param automargin_x Logical: If TRUE, use automatic margin for x axis.\n#' @param automargin_y Logical: If TRUE, use automatic margin for y axis.\n#' @param xaxis_autorange Logical: If TRUE, use automatic range for x axis.\n#' @param yaxis_autorange Character: If TRUE, use automatic range for y axis.\n#' @param scaleanchor_y Character: Scale anchor for y axis.\n#' @param scaleratio_y Numeric: Scale ratio for y axis.\n#' @param hoverlabel_align Character: Alignment for hover label.\n#' @param displayModeBar Logical: If TRUE, display mode bar.\n#' @param modeBar_file_format Character: File format for mode bar.\n#' @param scrollZoom Logical: If TRUE, enable scroll zoom.\n#' @param filename Character: File name to save plot.\n#' @param file_width Integer: Width for saved file.\n#' @param file_height Integer: Height for saved file.\n#' @param file_scale Numeric: Scale for saved file.\n#' @param width Integer: Width for plot.\n#' @param height Integer: Height for plot.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' \\dontrun{\n#' # Reads sequence from UniProt server\n#' tau <- seqinr::read.fasta(\"https://rest.uniprot.org/uniprotkb/P10636.fasta\",\n#' seqtype = \"AA\"\n#' )\n#' draw_protein(as.character(tau[[1]]))\n#'\n#' # or directly using the UniProt accession number:\n#' draw_protein(\"P10636\")\n#' }\ndraw_protein <- function(\n x,\n site = NULL,\n region = NULL,\n ptm = NULL,\n cleavage_site = NULL,\n variant = NULL,\n disease_variants = NULL,\n # label_group = NULL,\n n_per_row = NULL,\n main = NULL,\n main_xy = c(0.055, .975),\n main_xref = \"paper\",\n main_yref = \"paper\",\n main_xanchor = \"middle\",\n main_yanchor = \"top\",\n layout = c(\"simple\", \"grid\", \"1curve\", \"2curve\"),\n show_markers = TRUE,\n show_labels = TRUE,\n font_size = 18,\n label_col = NULL,\n scatter_mode = \"markers+lines\",\n # AA marker\n marker_size = 28,\n marker_col = NULL, # \"gray18\",\n marker_alpha = 1,\n marker_symbol = \"circle\",\n # AA line\n line_col = NULL, # \"gray18\",\n line_alpha = 1,\n line_width = 2,\n # Hover names\n show_full_names = TRUE,\n # regions\n region_scatter_mode = \"markers+lines\",\n region_style = 3,\n region_marker_size = marker_size,\n region_marker_alpha = .6,\n region_marker_symbol = \"circle\",\n region_line_dash = \"solid\",\n region_line_shape = \"line\",\n region_line_smoothing = 1,\n region_line_width = 1,\n region_line_alpha = .6,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n region_palette = getOption(\"rtemis_palette\", \"rtms\"),\n region_outline_only = FALSE,\n region_outline_pad = 2, # for fake polys\n region_pad = .35, # for real polys\n region_fill_alpha = .1666666,\n region_fill_shape = \"line\",\n region_fill_smoothing = 1,\n bpadcx = .5,\n bpadcy = .5,\n # Sites - colored marker border\n site_marker_size = marker_size,\n site_marker_symbol = marker_symbol,\n site_marker_alpha = 1,\n site_border_width = 1.5,\n site_palette = getOption(\"rtemis_palette\", \"rtms\"),\n # Variants\n variant_col = \"#FA6E1E\",\n # Text groups\n disease_variant_col = \"#E266AE\", # \"#c982d7\"\n # PTMs\n showlegend_ptm = TRUE,\n ptm_col = NULL,\n ptm_symbol = \"circle\",\n ptm_offset = .12,\n ptm_pad = .35,\n ptm_marker_size = marker_size / 4.5,\n # Cleavage sites\n clv_col = NULL,\n clv_symbol = \"triangle-down\",\n clv_offset = .12,\n clv_pad = .35,\n clv_marker_size = marker_size / 4,\n # Position annotations\n annotate_position_every = 10,\n annotate_position_alpha = .5,\n annotate_position_ay = -.4 * marker_size,\n position_font_size = font_size - 6,\n # Legend\n legend_xy = c(.97, .954),\n legend_xanchor = \"left\",\n legend_yanchor = \"top\",\n legend_orientation = \"v\",\n legend_col = NULL,\n legend_bg = \"#FFFFFF00\",\n legend_border_col = \"#FFFFFF00\",\n legend_borderwidth = 0,\n legend_group_gap = 0,\n margin = list(b = 0, l = 0, t = 0, r = 0, pad = 0),\n # Axes\n showgrid_x = FALSE,\n showgrid_y = FALSE,\n automargin_x = TRUE,\n automargin_y = TRUE,\n xaxis_autorange = TRUE,\n yaxis_autorange = \"reversed\",\n scaleanchor_y = \"x\",\n scaleratio_y = 1,\n # Layout\n hoverlabel_align = \"left\",\n # config\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n scrollZoom = TRUE,\n # file out\n filename = NULL,\n file_width = 1320,\n file_height = 990,\n file_scale = 1,\n width = NULL,\n height = NULL,\n verbosity = 1L\n) {\n # Data ----\n if (inherits(x, \"A3\")) {\n dat <- x\n x <- dat[[\"sequence\"]]\n site <- iflengthy(dat[[\"annotations\"]][[\"site\"]])\n region <- iflengthy(dat[[\"annotations\"]][[\"region\"]])\n ptm <- iflengthy(dat[[\"annotations\"]][[\"ptm\"]])\n cleavage_site <- iflengthy(dat[[\"annotations\"]][[\"cleavage_site\"]])\n variant <- iflengthy(dat[[\"annotations\"]][[\"variant\"]])\n disease_variants <- iflengthy(dat[[\"annotations\"]][[\"site\"]][[\n \"disease_associated_variant\"\n ]])\n }\n if (length(x) == 1) {\n if (grepl(\".json$\", x)) {\n dat <- jsonlite::read_json(\n x,\n simplifyVector = TRUE,\n simplifyMatrix = FALSE\n )\n x <- dat[[\"sequence\"]]\n disease_variants <- dat[[\"annotations\"]][[\"site\"]][[\n \"disease_associated_variant\"\n ]]\n site <- dat[[\"annotations\"]][[\"site\"]]\n region <- dat[[\"annotations\"]][[\"region\"]]\n ptm <- dat[[\"annotations\"]][[\"ptm\"]]\n cleavage_site <- dat[[\"annotations\"]][[\"cleavage_site\"]]\n } else {\n dat <- uniprot_get(x, verbosity = verbosity)\n x <- dat[[\"sequence\"]]\n # if (is.null(main)) main <- dat[[\"identifier\"]]\n }\n }\n x <- toupper(x)\n position <- seq_along(x)\n n <- length(x)\n if (is.null(n_per_row)) {\n n_per_row <- ceiling(sqrt(n))\n }\n\n # Arguments ----\n layout <- match.arg(layout)\n\n # Coordinates ----\n if (layout == \"grid\") {\n # '- grid ----\n # 1:n_per_row, n_per_row:1, till n\n xs <- rep(c(1:n_per_row, n_per_row:1), length.out = n)\n nrows <- ceiling(n / n_per_row)\n ys <- rep(1:nrows, each = n_per_row, length = n)\n } else if (layout == \"1curve\") {\n # '- 1curve ----\n xs <- rep(c(1:n_per_row, (n_per_row - 1):2), length.out = n)\n nrows <- ceiling(1 + (n / n_per_row - 1))\n ys <- c(\n 1,\n rep(seq(1, nrows * 4, 3), each = n_per_row - 1, length = n - 1)\n )\n # drop the n_per_row, then n_per_row - 1\n ys[seq(n_per_row, n, n_per_row - 1)] <-\n ys[seq(n_per_row, n, n_per_row - 1)] + 1.5\n } else if (layout == \"simple\") {\n # '- simple ----\n # if each point is 1 unit apart, border points must be sqrt(3)/2 away\n xs <- rep(c(1:n_per_row, (n_per_row - 1):2), length.out = n)\n nrows <- ceiling(1 + (n / n_per_row))\n ys <- c(\n 1,\n rep(seq(1, nrows), each = n_per_row - 1, length = n - 1)\n )\n # every n_per_row, move to .5 up and sqrt(3)/2 right, left from previous\n # Right border\n ys[seq(n_per_row, n, (2 * n_per_row - 2))] <-\n ys[seq(n_per_row, n, (2 * n_per_row - 2))] + .5\n xs[seq(n_per_row, n, (2 * n_per_row - 2))] <-\n xs[seq(n_per_row, n, 2 * n_per_row - 2)] - 1 + sqrt(3) / 2\n # Left border\n ys[seq((2 * n_per_row) - 1, n, (2 * n_per_row - 2))] <-\n ys[seq((2 * n_per_row) - 1, n, (2 * n_per_row - 2))] + .5\n xs[seq((2 * n_per_row) - 1, n, (2 * n_per_row - 2))] <-\n xs[seq((2 * n_per_row) - 1, n, (2 * n_per_row - 2))] + 1 - sqrt(3) / 2\n } else if (layout == \"2curve\") {\n # '- 2curve ----\n xs <- rep(c(1:n_per_row, n_per_row:1), length.out = n)\n nrows <- ceiling(n / n_per_row)\n ys <- rep(1:nrows * 3 - 2, each = n_per_row, length = n)\n ys[seq(n_per_row, n, n_per_row)] <-\n ys[seq(n_per_row, n, n_per_row)] + 1\n ys[seq(n_per_row, n, n_per_row) + 1] <-\n ys[seq(n_per_row, n, n_per_row)] + 1\n }\n # Theme ----\n check_is_S7(theme, Theme)\n\n if (is.null(label_col)) {\n label_col <- theme[[\"fg\"]]\n }\n label_col <- recycle(label_col, x)\n if (is.null(marker_col)) {\n marker_col <- color_fade(theme[[\"fg\"]], theme[[\"bg\"]], .9)\n }\n marker_col <- plotly::toRGB(marker_col, alpha = marker_alpha)\n if (is.null(line_col)) {\n line_col <- color_fade(theme[[\"fg\"]], theme[[\"bg\"]], .9)\n }\n line_col <- plotly::toRGB(line_col, alpha = marker_alpha)\n\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n if (is.null(legend_col)) {\n legend_col <- labs_col\n }\n grid_col <- plotly::toRGB(theme[[\"grid_col\"]], theme[[\"grid_alpha\"]])\n\n # Palette ----\n if (is.character(region_palette)) {\n region_palette <- get_palette(region_palette)\n }\n if (is.character(site_palette)) {\n site_palette <- get_palette(site_palette)\n }\n\n # Match abbreviations to full names ----\n if (show_full_names) {\n input <- switch(max(nchar(x)), \"1\" = \"1\", \"3\" = \"3\", \"full\")\n\n if (input == \"full\") {\n xnames <- x\n } else {\n if (input == \"1\") {\n xnames <- factor(\n x,\n levels = aa[[\"Abbreviation1\"]],\n labels = aa[[\"Name\"]]\n ) |>\n as.character()\n } else {\n xnames <- factor(\n x,\n levels = toupper(aa[[\"Abbreviation3\"]]),\n labels = aa[[\"Name\"]]\n ) |>\n as.character()\n }\n }\n } else {\n xnames <- x\n }\n\n # Variants: overwrite xnames with tooltip info\n if (!is.null(variant)) {\n for (i in seq_along(variant)) {\n varidi <- variant[[i]][[\"position\"]]\n xnames[varidi] <- paste0(\n xnames[varidi],\n \"\\n\\n\",\n list2html(variant[[i]], col = variant_col)\n )\n }\n }\n\n # plotly ----\n plt <- plotly::plot_ly(\n width = width,\n height = height\n )\n\n # AA markers and lines ----\n aaname <- if (is.null(disease_variants)) {\n \"1° structure\"\n } else {\n paste0(\n \"1° structure (\",\n \"Disease variants)\"\n )\n }\n if (show_markers) {\n clvtext <- if (!is.null(cleavage_site)) {\n # Get cleavage sites for each amino acid\n sapply(position, \\(i) {\n if (i %in% unlist(cleavage_site)) {\n paste0(\n \"\\nCleavage site for:\\n\",\n paste0(\n names(cleavage_site)[sapply(cleavage_site, \\(x) i %in% x)],\n collapse = \"\\n\"\n )\n )\n } else {\n \"\"\n }\n })\n } else {\n NULL\n }\n plt <- plt |>\n plotly::add_trace(\n x = xs,\n y = ys,\n type = \"scatter\",\n mode = scatter_mode,\n marker = list(\n color = plotly::toRGB(marker_col, alpha = marker_alpha),\n size = marker_size,\n symbol = marker_symbol\n ),\n line = list(\n color = plotly::toRGB(line_col, alpha = line_alpha),\n width = line_width\n ),\n text = paste0(position, \": \", xnames, clvtext),\n name = aaname,\n # hoverinfo = marker.hoverinfo\n hoverinfo = \"text\"\n )\n }\n # regions ----\n if (!is.null(region)) {\n region_names <- names(region)\n if (is.null(region_names)) {\n region_names <- paste(\"region\", seq_along(region))\n }\n\n if (region_style == 1) {\n # '- region style 1 ----\n # for overlapping sets within each region\n for (i in seq_along(region)) {\n for (j in seq_along(region[[i]])) {\n plt <- plt |>\n plotly::add_trace(\n x = xs[region[[i]][[j]]],\n y = ys[region[[i]][[j]]],\n type = \"scatter\",\n mode = region_scatter_mode,\n marker = list(\n color = plotly::toRGB(\n region_palette[[i]],\n alpha = region_marker_alpha\n ),\n size = region_marker_size,\n symbol = region_marker_symbol\n ),\n line = list(\n color = plotly::toRGB(\n region_palette[[i]],\n alpha = region_line_alpha\n ),\n dash = region_line_dash,\n shape = region_line_shape,\n smoothing = region_line_smoothing,\n width = region_line_width\n ),\n name = region_names[i],\n legendgroup = region_names[i],\n showlegend = j == 1\n )\n if (region_outline_only) {\n # simulate rounded selection around AAs\n # need region_marker_size & line_width > marker_size\n plt <- plt |>\n plotly::add_trace(\n x = xs[region[[i]][[j]]],\n y = ys[region[[i]][[j]]],\n type = \"scatter\",\n mode = region_scatter_mode,\n marker = list(\n color = plotly::toRGB(\n # marker_col,\n theme[[\"bg\"]],\n alpha = marker_alpha\n ),\n size = region_marker_size - region_outline_pad,\n symbol = region_marker_symbol\n ),\n line = list(\n color = plotly::toRGB(\n # line_col,\n theme[[\"bg\"]],\n alpha = line_alpha\n ),\n shape = region_line_shape,\n smoothing = region_line_smoothing,\n width = region_line_width - region_outline_pad\n ),\n name = NULL,\n legendgroup = region_names[i],\n showlegend = FALSE\n )\n plt <- plt |>\n plotly::add_trace(\n x = xs[region[[i]][[j]]],\n y = ys[region[[i]][[j]]],\n type = \"scatter\",\n mode = scatter_mode,\n marker = list(\n color = plotly::toRGB(marker_col, alpha = marker_alpha),\n size = marker_size,\n symbol = marker_symbol\n ),\n line = list(\n color = plotly::toRGB(line_col, alpha = line_alpha),\n width = line_width\n ),\n name = NULL,\n legendgroup = region_names[i],\n showlegend = FALSE\n )\n }\n }\n }\n } else if (region_style == 2) {\n # '- region style 2 ----\n # for non-overlapping sets within each region\n for (i in seq_along(region)) {\n plt <- plt |>\n plotly::add_trace(\n x = xs[unlist(region[[i]])],\n y = ys[unlist(region[[i]])],\n type = \"scatter\",\n mode = \"markers\",\n marker = list(\n color = plotly::toRGB(\n region_palette[[i]],\n alpha = region_marker_alpha\n ),\n size = region_marker_size,\n symbol = region_marker_symbol\n ),\n name = region_names[i]\n )\n }\n } else {\n # '- region style 3 ----\n # for 1curve only\n # region polys: get marker direction and location:\n # left, leftborder, right, rightborder\n dl <- c(\n \"r\",\n rep(c(\"r\", \"l\"), each = n_per_row - 1, length = n - 1)\n )\n dl[seq(n_per_row, n, n_per_row - 1)] <-\n paste0(dl[seq(n_per_row, n, n_per_row - 1)], \"b\")\n # i: IDI of region group\n for (i in seq_along(region)) {\n # each region's directions\n region_dl <- lapply(seq_along(region[[i]]), \\(j) {\n dl[region[[i]][[j]]]\n })\n\n region_poly_xy <- lapply(seq_along(region[[i]]), \\(j) {\n poly_xys(\n xs = xs[region[[i]][[j]]],\n ys = ys[region[[i]][[j]]],\n d = region_dl[[j]],\n pad = region_pad,\n bpadcx = bpadcx,\n bpadcy = bpadcy\n )\n })\n\n for (j in seq_along(region[[i]])) {\n plt <- plt |>\n plotly::add_polygons(\n x = region_poly_xy[[j]][[\"px\"]],\n y = region_poly_xy[[j]][[\"py\"]],\n line = list(\n color = region_palette[[i]],\n width = region_line_width,\n shape = region_fill_shape,\n smoothing = region_fill_smoothing\n ),\n fillcolor = plotly::toRGB(\n region_palette[[i]],\n alpha = region_fill_alpha\n ),\n name = region_names[i],\n legendgroup = region_names[i],\n showlegend = j == 1\n )\n }\n } # each region's individual regions' coords\n }\n } # /regions\n\n # Sites ----\n if (!is.null(site)) {\n site_names <- names(site)\n if (is.null(site_names)) {\n site_names <- paste(\"Site\", seq_along(site))\n }\n # for overlapping sets within each region\n for (i in seq_along(site)) {\n for (j in seq_along(site[[i]])) {\n plt <- plt |>\n plotly::add_trace(\n x = xs[site[[i]][[j]]],\n y = ys[site[[i]][[j]]],\n type = \"scatter\",\n mode = \"markers\",\n marker = list(\n color = plotly::toRGB(\n \"#000000\",\n alpha = 0\n ),\n size = site_marker_size,\n symbol = site_marker_symbol,\n line = list(\n color = plotly::toRGB(\n site_palette[[i]],\n alpha = site_marker_alpha\n ),\n width = site_border_width\n )\n ),\n name = site_names[i],\n legendgroup = site_names[i],\n showlegend = j == 1\n )\n }\n }\n } # /sites\n\n # PTMs ----\n # Note: Do not show both PTMs and cleavage sites using the same padding\n if (!is.null(ptm)) {\n if (verbosity > 1L) {\n msg_info(\"Adding PTM markers...\")\n }\n if (is.null(ptm_col)) {\n ptm_col <- 1 + seq_along(ptm)\n }\n ptm_symbol <- recycle(ptm_symbol, ptm)\n ptm_names <- names(ptm)\n for (i in seq_along(ptm)) {\n polyoffset <- npad(i, n = length(ptm), pad = ptm_pad)\n plt <- plt |>\n plotly::add_trace(\n x = xs[ptm[[i]]] + polyoffset[1],\n y = ys[ptm[[i]]] + polyoffset[2],\n type = \"scatter\",\n mode = \"markers\",\n marker = list(\n color = plotly::toRGB(ptm_col[[i]]),\n size = ptm_marker_size,\n symbol = ptm_symbol[i]\n ),\n name = ptm_names[i],\n showlegend = showlegend_ptm\n )\n }\n }\n # Cleavage sites ----\n # Note: Do not show both PTMs and cleavage sites using the same padding\n if (!is.null(cleavage_site)) {\n if (verbosity > 1L) {\n msg_info(\"Adding cleavage site markers...\")\n }\n if (is.null(clv_col)) {\n clv_col <- c(\n colorspace::qualitative_hcl(\n (length(cleavage_site)),\n h = c(40, 360),\n c = 120,\n l = 50\n )\n )\n }\n clv_symbol <- recycle(clv_symbol, cleavage_site)\n clv_names <- names(cleavage_site)\n for (i in seq_along(cleavage_site)) {\n polyoffset <- npad(i, n = length(cleavage_site), pad = clv_pad)\n plt <- plt |>\n plotly::add_trace(\n x = xs[cleavage_site[[i]]] + polyoffset[1],\n y = ys[cleavage_site[[i]]] + polyoffset[2],\n type = \"scatter\",\n mode = \"markers\",\n marker = list(\n color = plotly::toRGB(clv_col[[i]]),\n size = clv_marker_size,\n symbol = clv_symbol[i]\n ),\n name = clv_names[i],\n showlegend = showlegend_ptm\n )\n }\n }\n\n # AA labels ----\n if (show_labels) {\n # Variants\n if (!is.null(variant)) {\n variant_idi <- sapply(variant, \\(v) v[[\"position\"]])\n label_col[variant_idi] <- variant_col\n }\n # Disease variants\n if (!is.null(disease_variants)) {\n label_col[disease_variants] <- disease_variant_col\n }\n label_group <- factor(label_col)\n label_group_col <- levels(label_group)\n for (i in seq_along(label_group_col)) {\n idx <- label_group == label_group_col[i]\n plt <- plt |>\n plotly::add_annotations(\n xref = \"x\",\n yref = \"y\",\n x = xs[idx],\n y = ys[idx],\n text = x[idx],\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = label_group_col[[i]]\n ),\n showarrow = FALSE\n # name = label_group.levels[[i]],\n # showlegend = nchar(label_group.levels[[i]]) > 0\n )\n }\n # }\n }\n\n # Position annotations ----\n if (\n !is.null(annotate_position_every) && length(x) > annotate_position_every\n ) {\n idxpos <- seq(annotate_position_every, n, annotate_position_every)\n plt <- plt |>\n plotly::add_annotations(\n x = xs[idxpos],\n y = ys[idxpos],\n xref = \"x\",\n yref = \"y\",\n xanchor = \"middle\",\n yanchor = \"bottom\",\n ax = 0,\n ay = annotate_position_ay,\n text = idxpos,\n showarrow = TRUE,\n arrowcolor = \"#ffffff00\",\n font = list(\n size = position_font_size,\n family = theme[[\"font_family\"]],\n color = plotly::toRGB(theme[[\"fg\"]], alpha = annotate_position_alpha)\n )\n )\n }\n\n # Layout ----\n .legend <- list(\n x = legend_xy[1],\n xanchor = legend_xanchor,\n y = legend_xy[2],\n yanchor = legend_yanchor,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = legend_col\n ),\n orientation = legend_orientation,\n bgcolor = plotly::toRGB(legend_bg),\n bordercolor = plotly::toRGB(legend_border_col),\n borderwidth = legend_borderwidth,\n tracegroupgap = legend_group_gap\n )\n\n plt <- plotly::layout(\n plt,\n xaxis = list(\n autorange = xaxis_autorange,\n showgrid = showgrid_x,\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n zeroline = FALSE,\n showticklabels = FALSE,\n automargin = automargin_x\n ),\n yaxis = list(\n autorange = yaxis_autorange,\n showgrid = showgrid_y,\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n zeroline = FALSE,\n showticklabels = FALSE,\n automargin = automargin_y,\n scaleanchor = scaleanchor_y,\n scaleratio = scaleratio_y\n ),\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n ),\n xref = main_xref,\n yref = main_yref,\n xanchor = main_xanchor,\n yanchor = main_yanchor,\n x = main_xy[1],\n y = main_xy[2]\n ),\n paper_bgcolor = theme[[\"bg\"]],\n plot_bgcolor = theme[[\"plot_bg\"]],\n margin = margin,\n legend = .legend,\n hoverlabel = list(\n align = hoverlabel_align\n )\n )\n\n # Config\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n ),\n scrollZoom = TRUE\n )\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n return(plt)\n} # /rtemis::draw_protein\n\naa <- data.frame(\n Abbreviation1 = c(\n \"A\",\n \"R\",\n \"N\",\n \"D\",\n \"C\",\n \"Q\",\n \"E\",\n \"G\",\n \"H\",\n \"I\",\n \"L\",\n \"K\",\n \"M\",\n \"F\",\n \"P\",\n \"S\",\n \"T\",\n \"W\",\n \"Y\",\n \"V\",\n \"B\",\n \"Z\",\n \"X\",\n \"\"\n ),\n Abbreviation3 = c(\n \"Ala\",\n \"Arg\",\n \"Asn\",\n \"Asp\",\n \"Cys\",\n \"Gln\",\n \"Glu\",\n \"Gly\",\n \"His\",\n \"Ile\",\n \"Leu\",\n \"Lys\",\n \"Met\",\n \"Phe\",\n \"Pro\",\n \"Ser\",\n \"Thr\",\n \"Trp\",\n \"Tyr\",\n \"Val\",\n \"Asx\",\n \"Glx\",\n \"Xaa\",\n \"TERM\"\n ),\n Name = c(\n \"Alanine\",\n \"Arginine\",\n \"Asparagine\",\n \"Aspartate\",\n \"Cysteine\",\n \"Glutamine\",\n \"Glutamate\",\n \"Glycine\",\n \"Histidine\",\n \"Isoleucine\",\n \"Leucine\",\n \"Lysine\",\n \"Methionine\",\n \"Phenylalanine\",\n \"Proline\",\n \"Serine\",\n \"Threonine\",\n \"Tryptophan\",\n \"Tyrosine\",\n \"Valine\",\n \"Aspartic acid or Asparagine\",\n \"Glutamine or Glutamic acid\",\n \"(Any)\",\n \"Termination codon\"\n )\n)\n\npoly_xys <- function(xs, ys, d, pad = 1, bpadcx = .5, bpadcy = .5) {\n n <- length(xs)\n dk <- rep(1, n)\n kinks <- which(\"rb\" == d | \"lb\" == d)\n for (i in kinks) {\n if ((i + 1) <= n) {\n dk[(i + 1):n] <- -dk[(i + 1):n]\n }\n }\n\n # première ----\n px_1 <- switch(\n d[1],\n \"r\" = xs[1] - pad,\n \"l\" = xs[1] + pad,\n \"rb\" = c(xs[1] - pad, xs[1]),\n \"lb\" = c(xs[1] + pad, xs[1])\n )\n py_1 <- switch(\n d[1],\n \"rb\" = rep(ys[1] - pad, 2),\n \"lb\" = rep(ys[1] - pad, 2),\n ys[1] - pad\n )\n\n # aller ----\n # k: IDI of individual amino acid within individual region\n px_aller <-\n sapply(seq_along(d), \\(k) {\n if (d[k] == \"rb\") {\n # rep(xs[k] + sqrt(.5 * pad^2), 2)\n rep(xs[k] + pad, 2)\n } else if (d[k] == \"lb\") {\n # rep(xs[k] - sqrt(.5 * pad^2), 2)\n rep(xs[k] - pad, 2)\n } else {\n xs[k]\n }\n }) |>\n unlist()\n\n py_aller <-\n sapply(seq_along(d), \\(k) {\n if (d[[k]] %in% c(\"l\", \"r\")) {\n if (dk[k] == -1) {\n ys[k] + pad\n } else {\n ys[k] - pad\n }\n } else {\n if (k == 1) {\n c(ys[k] - pad, ys[k] + sqrt(.5 * pad^2))\n } else if (k == length(d)) {\n c(ys[k] - sqrt(.5 * pad^2), ys[k] + pad)\n } else {\n c(ys[k] - sqrt(.5 * pad^2), ys[k] + sqrt(.5 * pad^2))\n }\n }\n }) |>\n unlist()\n\n # centre ----\n dr <- rev(d)\n dkr <- rev(dk)\n xsr <- rev(xs)\n ysr <- rev(ys)\n px_centre <-\n switch(\n dr[1],\n \"r\" = rep(xsr[1] + pad, 2),\n \"l\" = rep(xsr[1] - pad, 2),\n # \"rb\" = c(xsr[1], xsr[1] - sqrt(.5 * pad^2)),\n # \"lb\" = c(xsr[1], xsr[1] + sqrt(.5 * pad^2))\n \"rb\" = c(xsr[1], xsr[1] - pad),\n \"lb\" = c(xsr[1], xsr[1] + pad)\n )\n\n py_centre <-\n if (dr[1] %in% c(\"r\", \"l\")) {\n if (length(kinks) > 0) {\n c(ysr[1] + pad, ysr[1] - pad)\n } else {\n c(ysr[1] - pad, ysr[1] + pad)\n }\n } else {\n rep(ysr[1] + pad, 2)\n }\n\n # retour ----\n px_retour <-\n sapply(seq_along(dr), \\(k) {\n if (dr[k] == \"rb\") {\n if (k == 1 | k == length(dr)) {\n rep(xsr[k] - pad, 2)\n } else {\n rep(xsr[k] - 1.5 * sqrt(.5 * pad^2), 2)\n }\n } else if (dr[k] == \"lb\") {\n if (k == 1 | k == length(dr)) {\n rep(xsr[k] + pad, 2)\n } else {\n rep(xsr[k] + 1.5 * sqrt(.5 * pad^2), 2)\n }\n } else {\n xsr[k]\n }\n }) |>\n unlist()\n\n py_retour <-\n sapply(seq_along(dr), \\(k) {\n if (dr[[k]] %in% c(\"l\", \"r\")) {\n if (dkr[k] == -1) {\n ysr[k] - pad\n } else {\n ysr[k] + pad\n }\n } else {\n rep(ysr[k], 2)\n }\n }) |>\n unlist()\n\n # find point before and after rb/lb\n idirb <- which(d == \"rb\")\n if (length(idirb) > 0) {\n if (idirb > 1) {\n px_aller[idirb - 1] <- px_aller[idirb - 1] + sqrt(.5 * pad^2)\n }\n if ((idirb + 1) <= length(d)) {\n px_aller[idirb + 2] <- px_aller[idirb + 2] + sqrt(.5 * pad^2)\n }\n }\n\n idilb <- which(d == \"lb\")\n if (length(idilb) > 0) {\n if (idilb > 1) {\n px_aller[idilb - 1] <- px_aller[idilb - 1] - sqrt(.5 * pad^2)\n }\n if ((idilb + 1) <= length(d)) {\n px_aller[idilb + 2] <- px_aller[idilb + 2] - sqrt(.5 * pad^2)\n }\n }\n\n # pénultième ----\n py_pen <- if (d[1] %in% c(\"rb\", \"lb\")) {\n ys[1] - sqrt(.5 * pad^2)\n } else {\n ys[1] + pad\n }\n\n # out ----\n list(\n px = c(px_1, px_aller, px_centre, px_retour, px_1[1], px_1[1]),\n py = c(py_1, py_aller, py_centre, py_retour, py_pen, py_1[1])\n )\n}\n\n\nqrtpad <- function(i, pad = .3) {\n qrt <- sqrt(.5 * pad^2)\n switch(\n i,\n `1` = c(qrt, -qrt),\n `2` = c(pad, 0),\n `3` = c(qrt, qrt),\n `4` = c(0, pad),\n `5` = c(-qrt, qrt),\n `6` = c(-pad, 0),\n `7` = c(-qrt, -qrt)\n )\n}\n\n# npad: function to calculate circular offset of a point from the center of a region\n# by dividing circle into n equal parts, beginning from the top\nnpad <- function(i, n = 12, pad = .3) {\n angle <- 2 * pi / n\n x <- sin(angle * i) * pad\n y <- cos(angle * i) * pad\n c(x, y)\n}\n" }, { "path": "R/draw_pvals.R", "content": "# draw_pvals.R\n# ::rtemis::\n# 2021 EDG rtemis.org\n\n#' Barplot p-values using [draw_bar]\n#'\n#' Plot 1 - p-values as a barplot\n#'\n#' @param x Float, vector: p-values.\n#' @param xnames Character, vector: feature names.\n#' @param yname Character: outcome name.\n#' @param p_adjust_method Character: method for [p.adjust].\n#' @param pval_hline Float: Significance level at which to plot horizontal line.\n#' @param hline_col Color for `pval_hline`.\n#' @param hline_dash Character: type of line to draw.\n#' @param ... Additional arguments passed to [draw_bar].\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' draw_pvals(c(0.01, 0.02, 0.03), xnames = c(\"Feature1\", \"Feature2\", \"Feature3\"))\ndraw_pvals <- function(\n x,\n xnames = NULL,\n yname = NULL,\n p_adjust_method = \"none\",\n pval_hline = .05,\n hline_col = rt_red,\n hline_dash = \"dash\",\n ...\n) {\n if (is.null(xnames)) {\n xnames <- names(x)\n }\n if (is.null(yname)) {\n yname <- deparse(substitute(x))\n }\n\n draw_bar(\n 1 - p.adjust(x, method = p_adjust_method),\n group_names = xnames,\n legend = FALSE,\n ylab = if (p_adjust_method == \"none\") {\n \"1 - p-value\"\n } else {\n paste0(\"1 - \", p_adjust_method, \"-adjusted p-value\")\n },\n hline = 1 - pval_hline,\n hline_col = hline_col,\n hline_dash = hline_dash,\n ...\n )\n} # /rtemis::draw_pvals\n" }, { "path": "R/draw_roc.R", "content": "# draw_roc.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n#' Draw ROC curve\n#'\n#' @param true_labels Factor: True outcome labels.\n#' @param predicted_prob Numeric vector \\[0, 1\\]: Predicted probabilities for the positive class (i.e. second level of outcome).\n#' Or, for multiclass, a matrix of predicted probabilities with one column per class.\n#' Or, a list of such vectors/matrices to draw multiple ROC curves on the same plot.\n#' @param multiclass_fill_labels Logical: If TRUE, fill in labels for multiclass ROC curves.\n#' If FALSE, column names of `predicted_prob` must match levels of `true_labels`.\n#' @param main Character: Main title for the plot.\n#' @param theme `Theme` object.\n#' @param palette Character vector: Colors to use.\n#' @param legend Logical: If TRUE, draw legend.\n#' @param legend_title Character: Title for the legend.\n#' @param legend_xy Numeric vector: Position of the legend in the form c(x, y).\n#' @param legend_xanchor Character: X anchor for the legend.\n#' @param legend_yanchor Character: Y anchor for the legend.\n#' @param auc_dp Integer: Number of decimal places for AUC values.\n#' @param xlim Numeric vector: Limits for the x-axis.\n#' @param ylim Numeric vector: Limits for the y-axis.\n#' @param diagonal Logical: If TRUE, draw diagonal line.\n#' @param diagonal_col Character: Color for the diagonal line.\n#' @param axes_square Logical: If TRUE, make axes square.\n#' @param filename Character: If provided, save the plot to this file.\n#' @param ... Additional arguments passed to [draw_scatter].\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' # Binary classification\n#' true_labels <- factor(c(\"A\", \"B\", \"A\", \"A\", \"B\", \"A\", \"B\", \"B\", \"A\", \"B\"))\n#' predicted_prob <- c(0.1, 0.4, 0.35, 0.8, 0.65, 0.2, 0.9, 0.55, 0.3, 0.7)\n#' draw_roc(true_labels, predicted_prob)\ndraw_roc <- function(\n true_labels,\n predicted_prob,\n multiclass_fill_labels = TRUE,\n main = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n legend = TRUE,\n legend_title = \"Group (AUC)\",\n legend_xy = c(1, 0),\n legend_xanchor = \"right\",\n legend_yanchor = \"bottom\",\n auc_dp = 3L,\n xlim = c(-0.05, 1.05),\n ylim = c(-0.05, 1.05),\n diagonal = TRUE,\n diagonal_col = NULL,\n axes_square = TRUE,\n filename = NULL,\n ...\n) {\n # List of probabilities\n probl <- if (!is.list(predicted_prob)) {\n list(predicted_prob)\n } else {\n predicted_prob\n }\n labelsl <- if (!is.list(true_labels)) {\n list(true_labels)\n } else {\n true_labels\n }\n # Check N sets\n if (length(probl) != length(labelsl)) {\n cli::cli_abort(\n \"You must have the same N of sets of `predicted_prob` and `true_labels`.\"\n )\n }\n\n # Binary vs. Multiclass\n # Determine number of classes from number of columns in predicted_prob\n # If ncol is NULL, it is binary classification\n n_classes <- unique(sapply(probl, \\(x) {\n if (is.null(ncol(x))) {\n 2L\n } else {\n ncol(x)\n }\n }))\n\n if (length(n_classes) > 1) {\n cli::cli_abort(\n \"You must have the same number of classes in each set of `predicted_prob`.\"\n )\n }\n\n # Check lengths of corresponding sets\n # NROW() works for both vectors and matrices\n for (i in seq_along(probl)) {\n if (NROW(probl[[i]]) != length(labelsl[[i]])) {\n cli::cli_abort(\n \"You must have the same N of `predicted_prob` and `true_labels`.\"\n )\n }\n }\n\n if (n_classes == 2L) {\n .roc <- lapply(seq_along(probl), \\(i) {\n pROC::roc(\n response = labelsl[[i]],\n predictor = probl[[i]],\n levels = levels(labelsl[[i]]),\n direction = \"<\"\n )\n })\n } else {\n .roc <- lapply(seq_along(probl), \\(i) {\n pred <- probl[[i]]\n if (is.null(colnames(pred))) {\n if (multiclass_fill_labels) {\n colnames(pred) <- levels(labelsl[[i]])\n } else {\n cli::cli_abort(\n \"For multiclass, `predicted_prob` must have column names matching levels of `true_labels`.\"\n )\n }\n }\n pROC::multiclass.roc(\n response = labelsl[[i]],\n predictor = pred,\n levels = levels(labelsl[[i]])\n )\n })\n }\n\n .names <- names(probl)\n\n if (n_classes == 2L) {\n TPR <- lapply(.roc, \\(r) r[[\"sensitivities\"]])\n FPR <- lapply(.roc, \\(r) 1 - r[[\"specificities\"]])\n AUC <- lapply(.roc, \\(r) r[[\"auc\"]])\n } else {\n TPR <- lapply(.roc, \\(r) r[[\"rocs\"]][[1]][[\"sensitivities\"]])\n FPR <- lapply(.roc, \\(r) 1 - r[[\"rocs\"]][[1]][[\"specificities\"]])\n AUC <- lapply(.roc, \\(r) r[[\"auc\"]])\n }\n names(TPR) <- names(FPR) <- names(AUC) <- .names\n theme@config[[\"zerolines\"]] <- FALSE\n draw_scatter(\n x = FPR,\n y = TPR,\n xlab = \"False Positive Rate\",\n ylab = \"True Positive Rate\",\n main = main,\n theme = theme,\n palette = palette,\n mode = \"lines\",\n group_names = paste0(.names, \" (\", ddSci(unlist(AUC), auc_dp), \")\"),\n legend = legend,\n legend_title = legend_title,\n legend_xy = legend_xy,\n legend_xanchor = legend_xanchor,\n legend_yanchor = legend_yanchor,\n xlim = xlim,\n ylim = ylim,\n diagonal = diagonal,\n diagonal_col = diagonal_col,\n axes_square = axes_square,\n order_on_x = FALSE,\n filename = filename,\n ...\n )\n} # /rtemis::draw_roc\n" }, { "path": "R/draw_scatter.R", "content": "# draw_scatter.R\n# ::rtemis::\n# 2019- EDG rtemis.org\n\n#' Interactive Scatter Plots\n#'\n#' Draw interactive scatter plots using `plotly`.\n#'\n#' @param x Numeric, vector/data.frame/list: x-axis data. If y is NULL and `NCOL(x) > 1`, first two columns used as `x` and `y`, respectively.\n#' @param y Numeric, vector/data.frame/list: y-axis data.\n#' @param fit Character: Fit method.\n#' @param se_fit Logical: If TRUE, include standard error of the fit.\n#' @param se_times Numeric: Multiplier for standard error.\n#' @param include_fit_name Logical: If TRUE, include fit name in legend.\n#' @param cluster Character: Clustering method.\n#' @param cluster_config List: Config for clustering.\n#' @param group Factor: Grouping variable.\n# @param formula Formula: Formula for non-linear least squares fit.\n#' @param rsq Logical: If TRUE, print R-squared values in legend if `fit` is set.\n#' @param mode Character, vector: \"markers\", \"lines\", \"markers+lines\".\n#' @param order_on_x Logical: If TRUE, order `x` and `y` on `x`.\n#' @param main Character: Main title.\n#' @param subtitle Character: Subtitle.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param alpha Numeric: Alpha for markers.\n#' @param theme `Theme` object.\n#' @param palette Character vector: Colors to use.\n#' @param axes_square Logical: If TRUE, draw a square plot.\n#' @param group_names Character: Names for groups.\n#' @param font_size Numeric: Font size.\n#' @param marker_col Color for markers.\n#' @param marker_size Numeric: Marker size.\n#' @param symbol Character: Marker symbol.\n#' @param fit_col Color for fit line.\n#' @param fit_alpha Numeric: Alpha for fit line.\n#' @param fit_lwd Numeric: Line width for fit line.\n#' @param line_shape Character: Line shape for line plots. Options: \"linear\", \"hv\", \"vh\", \"hvh\", \"vhv\".\n#' @param se_col Color for standard error band.\n#' @param se_alpha Numeric: Alpha for standard error band.\n#' @param scatter_type Character: Scatter plot type.\n#' @param show_marginal_x Logical: If TRUE, add marginal distribution line markers on x-axis.\n#' @param show_marginal_y Logical: If TRUE, add marginal distribution line markers on y-axis.\n#' @param marginal_x Numeric: Data for marginal distribution on x-axis.\n#' @param marginal_y Numeric: Data for marginal distribution on y-axis.\n#' @param marginal_x_y Numeric: Y position of marginal markers on x-axis.\n#' @param marginal_y_x Numeric: X position of marginal markers on y-axis.\n#' @param marginal_col Color for marginal markers.\n#' @param marginal_alpha Numeric: Alpha for marginal markers.\n#' @param marginal_size Numeric: Size of marginal markers.\n#' @param legend Logical: If TRUE, draw legend.\n#' @param legend_title Character: Title for legend.\n#' @param legend_trace Logical: If TRUE, draw legend trace. (For when you have `fit` and don't want a trace for the markers.)\n#' @param legend_xy Numeric: Position of legend.\n#' @param legend_xanchor Character: X anchor for legend.\n#' @param legend_yanchor Character: Y anchor for legend.\n#' @param legend_orientation Character: Orientation of legend.\n#' @param legend_col Color for legend text.\n#' @param legend_bg Color for legend background.\n#' @param legend_border_col Color for legend border.\n#' @param legend_borderwidth Numeric: Border width for legend.\n#' @param legend_group_gap Numeric: Gap between legend groups.\n#' @param x_showspikes Logical: If TRUE, show spikes on x-axis.\n#' @param y_showspikes Logical: If TRUE, show spikes on y-axis.\n#' @param spikedash Character: Dash type for spikes.\n#' @param spikemode Character: Spike mode.\n#' @param spikesnap Character: Spike snap mode.\n#' @param spikecolor Color for spikes.\n#' @param spikethickness Numeric: Thickness of spikes.\n#' @param margin List: Plot margins.\n#' @param main_y Numeric: Y position of main title.\n#' @param main_yanchor Character: Y anchor for main title.\n#' @param subtitle_x Numeric: X position of subtitle.\n#' @param subtitle_y Numeric: Y position of subtitle.\n#' @param subtitle_xref Character: X reference for subtitle.\n#' @param subtitle_yref Character: Y reference for subtitle.\n#' @param subtitle_xanchor Character: X anchor for subtitle.\n#' @param subtitle_yanchor Character: Y anchor for subtitle.\n#' @param automargin_x Logical: If TRUE, automatically adjust x-axis margins.\n#' @param automargin_y Logical: If TRUE, automatically adjust y-axis margins.\n#' @param xlim Numeric: Limits for x-axis.\n#' @param ylim Numeric: Limits for y-axis.\n#' @param axes_equal Logical: If TRUE, set equal scaling for axes.\n#' @param diagonal Logical: If TRUE, add diagonal line.\n#' @param diagonal_col Color for diagonal line.\n#' @param diagonal_dash Character: \"solid\", \"dash\", \"dot\", \"dashdot\", \"longdash\", \"longdashdot\". Dash type for diagonal line.\n#' @param diagonal_alpha Numeric: Alpha for diagonal line.\n#' @param fit_params `Hyperparameters` for fit.\n#' @param vline Numeric: X position for vertical line.\n#' @param vline_col Color for vertical line.\n#' @param vline_width Numeric: Width for vertical line.\n#' @param vline_dash Character: Dash type for vertical line.\n#' @param hline Numeric: Y position for horizontal line.\n#' @param hline_col Color for horizontal line.\n#' @param hline_width Numeric: Width for horizontal line.\n#' @param hline_dash Character: Dash type for horizontal line.\n#' @param hovertext List: Hover text for markers.\n#' @param width Numeric: Width of plot.\n#' @param height Numeric: Height of plot.\n#' @param displayModeBar Logical: If TRUE, display mode bar.\n#' @param modeBar_file_format Character: File format for mode bar.\n#' @param scrollZoom Logical: If TRUE, enable scroll zoom.\n#' @param filename Character: Filename to save plot.\n#' @param file_width Numeric: Width of saved file.\n#' @param file_height Numeric: Height of saved file.\n#' @param file_scale Numeric: Scale of saved file.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' draw_scatter(iris$Sepal.Length, iris$Petal.Length,\n#' fit = \"gam\", se_fit = TRUE, group = iris$Species\n#' )\ndraw_scatter <- function(\n x,\n y = NULL,\n fit = NULL,\n se_fit = FALSE,\n se_times = 1.96,\n include_fit_name = TRUE,\n cluster = NULL,\n cluster_config = list(k = 2),\n group = NULL,\n # formula = NULL,\n rsq = TRUE,\n mode = \"markers\",\n order_on_x = NULL,\n main = NULL,\n subtitle = NULL,\n xlab = NULL,\n ylab = NULL,\n alpha = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n axes_square = FALSE,\n group_names = NULL,\n font_size = 16,\n marker_col = NULL,\n marker_size = 8,\n symbol = \"circle\",\n fit_col = NULL,\n fit_alpha = .8,\n fit_lwd = 2.5,\n line_shape = \"linear\",\n se_col = NULL,\n se_alpha = .4,\n scatter_type = \"scatter\",\n show_marginal_x = FALSE,\n show_marginal_y = FALSE,\n marginal_x = x,\n marginal_y = y,\n marginal_x_y = NULL,\n marginal_y_x = NULL,\n marginal_col = NULL,\n marginal_alpha = .333,\n marginal_size = 10,\n legend = NULL,\n legend_title = NULL,\n legend_trace = TRUE,\n legend_xy = c(0, .98),\n legend_xanchor = \"left\",\n legend_yanchor = \"auto\",\n legend_orientation = \"v\",\n legend_col = NULL,\n legend_bg = \"#FFFFFF00\",\n legend_border_col = \"#FFFFFF00\",\n legend_borderwidth = 0,\n legend_group_gap = 0,\n x_showspikes = FALSE,\n y_showspikes = FALSE,\n spikedash = \"solid\",\n spikemode = \"across\",\n spikesnap = \"hovered data\",\n spikecolor = NULL,\n spikethickness = 1,\n margin = list(b = 65, l = 65, t = 50, r = 10, pad = 0),\n main_y = 1.01,\n main_yanchor = \"bottom\",\n subtitle_x = 0.02,\n subtitle_y = 0.99,\n subtitle_xref = \"paper\",\n subtitle_yref = \"paper\",\n subtitle_xanchor = \"left\",\n subtitle_yanchor = \"top\",\n automargin_x = TRUE,\n automargin_y = TRUE,\n xlim = NULL,\n ylim = NULL,\n axes_equal = FALSE,\n diagonal = FALSE,\n diagonal_col = NULL,\n diagonal_dash = \"dot\",\n diagonal_alpha = .66,\n fit_params = NULL,\n vline = NULL,\n vline_col = theme[[\"fg\"]],\n vline_width = 1,\n vline_dash = \"dot\",\n hline = NULL,\n hline_col = theme[[\"fg\"]],\n hline_width = 1,\n hline_dash = \"dot\",\n hovertext = NULL,\n width = NULL,\n height = NULL,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n scrollZoom = TRUE,\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n verbosity = 0L\n) {\n # Dependencies ----\n check_dependencies(\"plotly\")\n\n # Arguments ----\n xname <- labelify(gsub(\".*\\\\$\", \"\", deparse(substitute(x))))\n yname <- labelify(gsub(\".*\\\\$\", \"\", deparse(substitute(y))))\n if (is.null(y) && NCOL(x) > 1) {\n if (is.null(xlab)) {\n xlab <- labelify(colnames(x)[1])\n }\n if (is.null(ylab)) {\n ylab <- labelify(colnames(x)[2])\n }\n y <- x[, 2]\n x <- x[, 1]\n }\n if (!is.null(fit)) {\n if (fit == \"none\") fit <- NULL\n } # easier to work with shiny\n if (is.logical(fit)) {\n if (fit) fit <- \"GAM\"\n }\n if (is.null(fit)) {\n se_fit <- FALSE\n }\n if (!is.null(fit)) {\n fit <- toupper(fit)\n }\n if (!is.null(main)) {\n main <- paste0(\"\", main, \"\")\n }\n .mode <- mode\n .names <- group_names\n\n check_is_S7(theme, Theme)\n\n if (se_fit) {\n if (!fit %in% c(\"GLM\", \"LM\", \"LOESS\", \"GAM\", \"NW\")) {\n warning(paste(\n \"Standard error of the fit not available for\",\n fit,\n \"- try LM, LOESS, GAM, or NW\"\n ))\n se_fit <- FALSE\n }\n }\n\n # order_on_x ----\n if (is.null(order_on_x)) {\n order_on_x <- if (!is.null(fit) || any(grepl(\"lines\", mode))) {\n TRUE\n } else {\n FALSE\n }\n }\n\n # Cluster ----\n if (!is.null(cluster)) {\n group <- suppressWarnings(\n cluster(\n x = data.frame(x, y),\n algorithm = cluster,\n config = do_call(\n get_clust_setup_fn(cluster),\n cluster_config\n )\n )@clusters\n )\n group <- paste(\"Cluster\", group)\n }\n\n # Data ----\n # xlab, ylab ----\n # The gsubs remove all text up to and including a \"$\" symbol if present\n if (is.null(xlab)) {\n if (is.list(x)) xlab <- \"x\" else xlab <- xname\n }\n if (!is.null(y) && is.null(ylab)) {\n if (is.list(y)) ylab <- \"y\" else ylab <- yname\n }\n\n # Group ----\n if (!is.null(group)) {\n group <- as.factor(group)\n x <- split(x, group, drop = TRUE)\n y <- split(y, group, drop = TRUE)\n if (is.null(group_names)) {\n group_names <- levels(droplevels(group))\n }\n names(x) <- names(y) <- .names <- group_names\n if (!is.null(hovertext)) hovertext <- split(hovertext, group, drop = TRUE)\n }\n\n # Try to get names from list or data frame inputs\n if (is.list(y) || NCOL(y) > 1) {\n if (is.null(.names) && !is.null(names(y))) .names <- names(y)\n }\n if (is.list(x) || NCOL(x) > 1) {\n if (is.null(.names) && !is.null(names(x))) .names <- names(x)\n }\n\n # Data to lists ----\n x <- if (!is.list(x)) as.list(as.data.frame(x)) else x\n y <- if (!is.null(y) && !is.list(y)) as.list(as.data.frame(y)) else y\n hovertext <- if (!is.null(hovertext) && !is.list(hovertext)) {\n as.list(as.data.frame(hovertext))\n } else {\n hovertext\n }\n if (length(x) == 1 && length(y) > 1) {\n x <- rep(x, length(y))\n .names <- names(y)\n }\n if (length(y) == 1 && length(x) > 1) {\n y <- rep(y, length(x))\n .names <- names(x)\n }\n if (!is.null(hovertext) && length(hovertext) == 1 && length(x) > 1) {\n hovertext <- rep(hovertext, length(x))\n }\n n_groups <- length(x)\n\n if (is.null(legend)) {\n legend <- if (n_groups == 1 && is.null(fit)) FALSE else TRUE\n }\n\n if (length(.mode) < n_groups) {\n .mode <- c(.mode, rep(tail(.mode)[1], n_groups - length(.mode)))\n }\n\n # if (is.null(legend)) legend <- n_groups > 1\n if (is.null(.names)) {\n if (n_groups > 1) {\n .names <- paste(\"Group\", seq_len(n_groups))\n } else {\n # .names <- if (!is.null(fit)) fit else NULL\n .names <- xname\n }\n }\n\n # Marginal data ----\n if (show_marginal_x && is.null(marginal_x)) {\n marginal_x <- x\n }\n if (show_marginal_y && is.null(marginal_y)) {\n marginal_y <- y\n }\n\n # Reorder ----\n if (order_on_x) {\n index <- lapply(x, order)\n x <- lapply(seq(x), \\(i) x[[i]][index[[i]]])\n y <- lapply(seq(x), \\(i) y[[i]][index[[i]]])\n if (!is.null(hovertext)) {\n hovertext <- lapply(seq(x), \\(i) hovertext[[i]][index[[i]]])\n }\n }\n\n # Colors ----\n col <- recycle(palette, seq_len(n_groups))\n if (is.null(alpha)) {\n alpha <- if (mode == \"markers\") {\n autoalpha(max(lengths(x)))\n } else {\n 1\n }\n }\n\n # Theme ----\n if (diagonal) {\n if (is.null(diagonal_col)) {\n diagonal_col <- theme[[\"fg\"]]\n }\n diagonal_col <- adjustcolor(diagonal_col, diagonal_alpha)\n }\n\n bg <- plotly::toRGB(theme[[\"bg\"]])\n plot_bg <- plotly::toRGB(theme[[\"plot_bg\"]])\n grid_col <- plotly::toRGB(theme[[\"grid_col\"]], theme[[\"grid_alpha\"]])\n tick_col <- plotly::toRGB(theme[[\"tick_col\"]])\n labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n if (!theme[[\"axes_visible\"]]) {\n tick_col <- labs_col <- \"transparent\"\n }\n\n # marker_col, se_col ===\n if (is.null(marker_col)) {\n marker_col <- if (!is.null(fit) && n_groups == 1) {\n as.list(rep(theme[[\"fg\"]], n_groups))\n } else {\n col\n }\n }\n\n if (!is.null(fit)) {\n if (is.null(fit_col)) fit_col <- col\n }\n\n if (se_fit && is.null(se_col)) {\n se_col <- col\n }\n\n if (is.null(legend_col)) {\n legend_col <- labs_col\n }\n if (is.null(spikecolor)) {\n spikecolor <- theme[[\"fg\"]]\n }\n\n # Size ----\n # fitted & se_fit ----\n # If plotting se bands, need to include (fitted +/- se_times * se) in the axis limits\n if (se_fit) {\n se <- list()\n } else {\n se <- NULL\n }\n if (!is.null(fit)) {\n fitted <- list()\n fitted_text <- character()\n for (i in seq_len(n_groups)) {\n mod <- train(\n x = data.frame(x = x[[i]], y = y[[i]]),\n algorithm = fit,\n hyperparameters = fit_params,\n verbosity = verbosity - 1L\n )\n fitted[[i]] <- fitted(mod)\n if (se_fit) {\n se[[i]] <- se(mod)\n }\n if (include_fit_name) {\n # fitted_text[i] <- switch(fit,\n # NLS = mod$extra$model,\n # NLA = mod$mod$formula,\n # fit\n # )\n fitted_text[i] <- fit\n } else {\n fitted_text[i] <- \"\"\n }\n if (rsq) {\n fitted_text[i] <- paste0(\n fitted_text[i],\n if (n_groups == 1) \" (\" else \" \",\n \"R2 = \",\n ddSci(mod@metrics_training[[\"Rsq\"]]),\n if (n_groups == 1) \")\"\n )\n }\n # if (rsq_pval) {\n # if (fit %in% c(\"LM\", \"GLM\")) {\n # rsqp[[i]] <- paste0(ddSci(mod@metrics_training$Rsq), \" (\",\n # ddSci(summary(mod$mod)$coefficients[2, 4]), \")\")\n # } else if (fit == \"GAM\") {\n # rsqp[[i]] <- paste0(ddSci(mod@metrics_training$Rsq), \" (\",\n # ddSci(summary(mod$mod)$s.pv), \")\")\n # }\n # }\n }\n }\n\n # Axes Limits ----\n if (axes_equal) {\n if (is.null(xlim)) {\n xlim <- getlim(unlist(x), \"r\", .06)\n }\n if (is.null(ylim)) {\n ylim <- getlim(unlist(y), \"r\", .06)\n if (is.list(fitted) && !is.list(se)) {\n ylim_hi <- max(unlist(fitted))\n ylim_lo <- min(unlist(fitted))\n ylim <- range(ylim_lo, ylim_hi, y)\n }\n if (is.list(se)) {\n ylim_hi <- max(unlist(lapply(\n seq_along(fitted),\n function(i) {\n as.data.frame(fitted[[i]]) +\n se_times * as.data.frame(se[[i]])\n }\n )))\n ylim_lo <- min(unlist(lapply(\n seq_along(fitted),\n function(i) {\n as.data.frame(fitted[[i]]) -\n se_times * as.data.frame(se[[i]])\n }\n )))\n ylim <- range(ylim_lo, ylim_hi, y)\n }\n }\n\n xlim <- ylim <- range(xlim, ylim)\n } # /axes_equal\n\n # unlist will coerce Dates to numeric, also don't want padding\n if (is.null(xlim) && !inherits(x[[1]], \"Date\")) {\n xlim <- getlim(unlist(x), \"r\", .06)\n }\n if (is.null(ylim) && !inherits(y[[1]], \"Date\")) {\n ylim <- getlim(unlist(y), \"r\", .06)\n }\n\n # plotly ----\n if (!is.null(fit) && rsq) {\n if (!include_fit_name) {\n fitted_text <- gsub(\"^ \", \"\", fitted_text)\n }\n if (n_groups > 1) {\n .names <- paste0(.names, \" (\", fitted_text, \")\")\n }\n }\n\n plt <- plotly::plot_ly(\n width = width,\n height = height\n )\n\n if (diagonal) {\n lo <- min(xlim[1], ylim[1])\n hi <- max(xlim[2], ylim[2])\n plt <- plotly::layout(\n plt,\n shapes = list(\n type = \"line\",\n x0 = lo,\n x1 = hi,\n y0 = lo,\n y1 = hi,\n line = list(\n color = diagonal_col,\n dash = diagonal_dash\n )\n )\n )\n }\n\n for (i in seq_len(n_groups)) {\n ## { Scatter } ----\n marker <- if (grepl(\"markers\", .mode[i])) {\n list(\n color = plotly::toRGB(marker_col[[i]], alpha = alpha),\n size = marker_size,\n symbol = symbol\n )\n } else {\n NULL\n }\n plt <- plotly::add_trace(\n plt,\n x = x[[i]],\n y = y[[i]],\n type = scatter_type,\n mode = .mode[i],\n # fillcolor = plotly::toRGB(col[[i]], alpha),\n name = .names[i],\n # text = .text[[i]],\n # hoverinfo = \"text\",\n text = hovertext[[i]],\n marker = marker,\n line = if (grepl(\"lines\", .mode[i])) {\n list(\n color = plotly::toRGB(marker_col[[i]], alpha = alpha),\n shape = line_shape\n )\n } else {\n NULL\n },\n legendgroup = if (legend_trace) {\n .names[i]\n } else {\n paste0(.names[i], \"_marker\")\n },\n showlegend = legend && legend_trace\n )\n # Marginal plots ----\n # Add marginal plots by plotting short vertical markers on the x and y axes\n if (show_marginal_x) {\n if (is.null(marginal_col)) {\n marginal_col <- plotly::toRGB(marker_col, alpha = marginal_alpha)\n }\n if (is.null(marginal_x_y)) {\n marginal_x_y <- ylim[1]\n }\n # Extend ylim to include marginal markers\n ylim[1] <- ylim[1] - 0.02 * diff(ylim)\n for (i in seq_len(n_groups)) {\n plt <- plotly::add_trace(\n plt,\n x = marginal_x[[i]],\n y = rep(marginal_x_y, length(marginal_x[[i]])),\n type = \"scatter\",\n mode = \"markers\",\n marker = list(\n color = marginal_col[[i]],\n size = marginal_size,\n symbol = \"line-ns-open\"\n ),\n showlegend = FALSE,\n hoverinfo = \"x\"\n )\n }\n } # /show_marginal_x\n\n if (show_marginal_y) {\n if (is.null(marginal_col)) {\n marginal_col <- plotly::toRGB(marker_col, alpha = marginal_alpha)\n }\n if (is.null(marginal_y_x)) {\n marginal_y_x <- xlim[1]\n }\n # Extend xlim to include marginal markers\n xlim[1] <- xlim[1] - 0.02 * diff(xlim)\n for (i in seq_len(n_groups)) {\n plt <- plotly::add_trace(\n plt,\n x = rep(marginal_y_x, length(marginal_y[[i]])),\n y = marginal_y[[i]],\n type = \"scatter\",\n mode = \"markers\",\n marker = list(\n color = marginal_col[[i]],\n size = marginal_size,\n symbol = \"line-ew-open\"\n ),\n showlegend = FALSE,\n hoverinfo = \"y\"\n # legendgroup = .names[i]\n )\n }\n } # /show_marginal_y\n\n ## { SE band } ----\n if (se_fit) {\n plt <- plotly::add_trace(\n plt,\n x = x[[i]],\n y = fitted[[i]] + se_times * se[[i]],\n type = scatter_type,\n mode = \"lines\",\n line = list(color = \"transparent\"),\n legendgroup = .names[i],\n showlegend = FALSE,\n hoverinfo = \"none\",\n inherit = FALSE\n )\n plt <- plotly::add_trace(\n plt,\n x = x[[i]],\n y = fitted[[i]] - se_times * se[[i]],\n type = scatter_type,\n mode = \"lines\",\n fill = \"tonexty\",\n fillcolor = plotly::toRGB(se_col[[i]], alpha = se_alpha),\n line = list(color = \"transparent\"),\n # name = shade_name,\n legendgroup = .names[i],\n showlegend = FALSE,\n hoverinfo = \"none\",\n inherit = FALSE\n )\n }\n if (!is.null(fit)) {\n ## { Fitted line } ----\n lfit <- list(\n color = plotly::toRGB(fit_col[[i]], alpha = fit_alpha),\n width = fit_lwd\n )\n plt <- plotly::add_trace(\n plt,\n x = x[[i]],\n y = fitted[[i]],\n type = scatter_type,\n mode = \"lines\",\n line = lfit,\n name = fitted_text[i],\n legendgroup = .names[i],\n showlegend = if (legend & n_groups == 1) TRUE else FALSE,\n inherit = FALSE\n )\n }\n }\n\n # Layout ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = labs_col\n )\n tickfont <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = theme[[\"tick_labels_col\"]]\n )\n .legend <- list(\n title = list(\n text = legend_title,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = legend_col\n )\n ),\n x = legend_xy[1],\n xanchor = legend_xanchor,\n y = legend_xy[2],\n yanchor = legend_yanchor,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = legend_col\n ),\n orientation = legend_orientation,\n bgcolor = plotly::toRGB(legend_bg),\n bordercolor = plotly::toRGB(legend_border_col),\n borderwidth = legend_borderwidth,\n tracegroupgap = legend_group_gap\n )\n\n zerocol <- adjustcolor(theme[[\"zerolines_col\"]], theme[[\"zerolines_alpha\"]])\n plt <- plotly::layout(\n plt,\n yaxis = list(\n title = ylab,\n showline = FALSE,\n showspikes = y_showspikes,\n spikecolor = spikecolor,\n spikedash = spikedash,\n spikemode = spikemode,\n spikesnap = spikesnap,\n spikethickness = spikethickness,\n titlefont = f,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = theme[[\"zerolines\"]],\n zerolinecolor = zerocol,\n zerolinewidth = theme[[\"zerolines_lwd\"]],\n range = ylim,\n automargin = automargin_y\n ),\n xaxis = list(\n title = list(text = xlab),\n showline = FALSE,\n showspikes = x_showspikes,\n spikecolor = spikecolor,\n spikedash = spikedash,\n spikemode = spikemode,\n spikesnap = spikesnap,\n spikethickness = spikethickness,\n # mirror = axes_mirrored,\n titlefont = f,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = theme[[\"zerolines\"]],\n zerolinecolor = zerocol,\n zerolinewidth = theme[[\"zerolines_lwd\"]],\n range = xlim,\n automargin = automargin_x\n ),\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n ),\n xref = \"paper\",\n x = theme[[\"main_adj\"]],\n yref = \"paper\",\n y = main_y,\n yanchor = main_yanchor\n ),\n # titlefont = list(),\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg,\n margin = margin,\n showlegend = legend,\n legend = .legend\n ) # /layout\n\n ## vline ----\n if (!is.null(vline)) {\n plt <- plotly::layout(\n plt,\n shapes = plotly_vline(\n vline,\n color = vline_col,\n width = vline_width,\n dash = vline_dash\n )\n )\n }\n\n ## hline ----\n if (!is.null(hline)) {\n plt <- plotly::layout(\n plt,\n shapes = plotly_hline(\n hline,\n color = hline_col,\n width = hline_width,\n dash = hline_dash\n )\n )\n }\n\n ## square ----\n if (axes_square) {\n plt <- plt |>\n plotly::layout(\n yaxis = list(\n scaleanchor = \"x\",\n scaleratio = 1\n )\n )\n }\n\n # Subtitle ----\n # add annotation at top left with same font as main title\n if (!is.null(subtitle)) {\n plt <- plt |>\n plotly::add_annotations(\n x = subtitle_x,\n y = subtitle_y,\n xref = subtitle_xref,\n yref = subtitle_yref,\n xanchor = subtitle_xanchor,\n yanchor = subtitle_yanchor,\n text = subtitle,\n showarrow = FALSE,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n )\n )\n }\n\n # Config\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n ),\n scrollZoom = scrollZoom\n )\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n plt\n} # /rtemis::draw_scatter\n\n\n#' True vs. Predicted Plot\n#'\n#' A `draw_scatter` wrapper for plotting true vs. predicted values\n#'\n#' @inheritParams draw_scatter\n#' @param x Numeric, vector/data.frame/list: True values. If y is NULL and\n#' `NCOL(x) > 1`, first two columns used as `x` and `y`, respectively\n#' @param y Numeric, vector/data.frame/list: Predicted values\n#' @param ... Additional arguments passed to [draw_scatter]\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' x <- rnorm(500)\n#' y <- x + rnorm(500)\n#' draw_fit(x, y)\ndraw_fit <- function(\n x,\n y,\n xlab = \"True\",\n ylab = \"Predicted\",\n fit = \"glm\",\n se_fit = TRUE,\n axes_square = TRUE,\n axes_equal = TRUE,\n diagonal = TRUE,\n ...\n) {\n draw_scatter(\n x,\n y,\n xlab = xlab,\n ylab = ylab,\n fit = fit,\n se_fit = se_fit,\n axes_square = axes_square,\n axes_equal = axes_equal,\n diagonal = diagonal,\n ...\n )\n} # /rtemis::draw_fit\n" }, { "path": "R/draw_spectrogram.R", "content": "# draw_spectrogram.R\n# ::rtemis::\n# 2023 EDG rtemis.org\n# https://plotly.com/r/heatmaps/\n\n#' Interactive Spectrogram\n#'\n#' Draw interactive spectrograms using `plotly`\n#'\n#' To set custom colors, use a minimum of `lo` and `hi`, optionally also\n#' `lomid`, `mid`, `midhi` colors and set `colorscale = NULL`.\n#'\n#' @param x Numeric: Time.\n#' @param y Numeric: Frequency.\n#' @param z Numeric: Power.\n#' @param colorgrad_n Integer: Number of colors in the gradient.\n#' @param colors Character: Custom colors for the gradient.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param zlab Character: z-axis label.\n#' @param hover_xlab Character: x-axis label for hover.\n#' @param hover_ylab Character: y-axis label for hover.\n#' @param hover_zlab Character: z-axis label for hover.\n#' @param zmin Numeric: Minimum value for color scale.\n#' @param zmax Numeric: Maximum value for color scale.\n#' @param zauto Logical: If TRUE, automatically set zmin and zmax.\n#' @param hoverlabel_align Character: Alignment of hover labels.\n#' @param colorscale Character: Color scale.\n#' @param colorbar_y Numeric: Y position of colorbar.\n#' @param colorbar_yanchor Character: Y anchor of colorbar.\n#' @param colorbar_xpad Numeric: X padding of colorbar.\n#' @param colorbar_ypad Numeric: Y padding of colorbar.\n#' @param colorbar_len Numeric: Length of colorbar.\n#' @param colorbar_title_side Character: Side of colorbar title.\n#' @param showgrid Logical: If TRUE, show grid.\n#' @param space Character: Color space for gradient.\n#' @param lo Character: Low color for gradient.\n#' @param lomid Character: Low-mid color for gradient.\n#' @param mid Character: Mid color for gradient.\n#' @param midhi Character: Mid-high color for gradient.\n#' @param hi Character: High color for gradient.\n#' @param grid_gap Integer: Space between cells.\n#' @param limits Numeric, length 2: Determine color range. Default = NULL, which automatically centers values around 0.\n#' @param main Character: Main title.\n#' @param key_title Character: Title of the key.\n#' @param showticklabels Logical: If TRUE, show tick labels.\n#' @param theme `Theme` object.\n#' @param font_size Numeric: Font size.\n#' @param padding Numeric: Padding between cells.\n#' @param displayModeBar Logical: If TRUE, display the plotly mode bar.\n#' @param modeBar_file_format Character: File format for image exports from the mode bar.\n#' @param filename Character: Filename to save the plot. Default is NULL.\n#' @param file_width Numeric: Width of exported image.\n#' @param file_height Numeric: Height of exported image.\n#' @param file_scale Numeric: Scale of exported image.\n#' @param ... Additional arguments to be passed to `heatmaply::heatmaply`.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' # Example data\n#' time <- seq(0, 10, length.out = 100)\n#' freq <- seq(1, 100, length.out = 100)\n#' power <- outer(time, freq, function(t, f) sin(t) * cos(f))\n#'draw_spectrogram(\n#' x = time,\n#' y = freq,\n#' z = power\n#' )\ndraw_spectrogram <- function(\n x,\n y,\n z,\n colorgrad_n = 101,\n colors = NULL,\n xlab = \"Time\",\n ylab = \"Frequency\",\n zlab = \"Power\",\n hover_xlab = xlab,\n hover_ylab = ylab,\n hover_zlab = zlab,\n zmin = NULL,\n zmax = NULL,\n zauto = TRUE,\n hoverlabel_align = \"right\",\n colorscale = \"Jet\",\n colorbar_y = .5,\n colorbar_yanchor = \"middle\",\n colorbar_xpad = 0,\n colorbar_ypad = 0,\n colorbar_len = .75,\n colorbar_title_side = \"bottom\",\n showgrid = FALSE,\n space = \"rgb\",\n lo = \"#18A3AC\",\n lomid = NULL,\n mid = NULL,\n midhi = NULL,\n hi = \"#F48024\",\n grid_gap = 0,\n limits = NULL,\n main = NULL,\n key_title = NULL,\n showticklabels = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n font_size = NULL,\n padding = 0,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n ...\n) {\n # Dependencies ----\n check_dependencies(\"plotly\")\n\n # Tick Labels ----\n if (is.null(showticklabels)) {\n showticklabels <- c(\n ifelse(NCOL(z) < 50, TRUE, FALSE),\n ifelse(NROW(z) < 50, TRUE, FALSE)\n )\n }\n\n if (is.null(font_size)) {\n font_size <- 17.0769 - 0.2692 * ncol(z)\n }\n\n # Limits ----\n if (is.null(limits)) {\n maxabs <- max(abs(z), na.rm = TRUE)\n if (.2 < maxabs && maxabs < 1) {\n maxabs <- 1\n }\n limits <- c(-maxabs, maxabs)\n }\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n bg <- plotly::toRGB(theme[[\"bg\"]])\n fg <- plotly::toRGB(theme[[\"fg\"]])\n plot_bg <- plotly::toRGB(theme[[\"plot_bg\"]])\n grid_col <- plotly::toRGB(theme[[\"grid_col\"]])\n # tick_col <- plotly::toRGB(theme[[\"tick_col\"]])\n tick_labels_col <- plotly::toRGB(theme[[\"tick_labels_col\"]])\n labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n\n # Colors ----\n if (is.null(mid)) {\n mid <- theme[[\"bg\"]]\n }\n colors <- colorgrad(\n n = colorgrad_n,\n colors = colors,\n space = space,\n lo = lo,\n lomid = lomid,\n mid = mid,\n midhi = midhi,\n hi = hi\n )\n\n # Plot ----\n plt <- plotly::plot_ly()\n plt <- plt |>\n plotly::add_trace(\n x = x,\n y = y,\n z = z,\n type = \"heatmap\",\n zauto = zauto,\n zmin = zmin,\n zmax = zmax,\n colorscale = colorscale,\n colors = colors,\n hovertemplate = paste0(\n hover_xlab,\n \": %{x:.3f}
\",\n hover_ylab,\n \": %{y:.3f}
\",\n hover_zlab,\n \": %{z:.3f}\"\n ),\n showlegend = FALSE\n )\n\n # Layout ----\n # '- layout ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = labs_col\n )\n tickfont <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = tick_labels_col\n )\n .legend <- list(\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = fg\n )\n )\n\n plt <- plotly::layout(\n plt,\n yaxis = list(\n title = list(\n text = ylab,\n font = f\n ),\n titlefont = f,\n showgrid = showgrid,\n tickcolor = bg,\n showline = FALSE,\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickfont = tickfont\n ),\n xaxis = list(\n title = list(\n text = xlab,\n font = f\n ),\n titlefont = f,\n showgrid = showgrid,\n tickcolor = bg,\n showline = FALSE,\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickfont = tickfont\n ),\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n ),\n xref = \"paper\",\n x = theme[[\"main_adj\"]]\n ),\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg,\n legend = .legend,\n hoverlabel = list(align = hoverlabel_align)\n )\n\n # Manual theme colors\n\n ## y axis tick label colors\n # plt[[\"x\"]][[\"layoutAttrs\"]][[2]][[\"yaxis2\"]][[\"tickfont\"]][[\"color\"]]\n ## x axis tick label colors\n # plt[[\"x\"]][[\"layoutAttrs\"]][[2]][[\"xaxis\"]][[\"tickfont\"]][[\"color\"]] <- \"rgba(255, 0, 0, 1)\"\n ## edge lines must be invisible\n plt[[\"x\"]][[\"layout\"]][[\"yaxis\"]][[\"linecolor\"]] <- plt[[\"x\"]][[\"layout\"]][[\n \"xaxis2\"\n ]][[\"linecolor\"]] <- theme[[\"bg\"]]\n\n # Manual layout ----\n # Set padding\n plt[[\"sizingPolicy\"]][[\"padding\"]] <- padding\n\n # Colorbar ----\n # https://plotly.com/r/reference/#scatter-marker-colorbar\n plt <- plt |>\n plotly::colorbar(\n y = colorbar_y,\n yanchor = colorbar_yanchor,\n title = list(\n text = zlab,\n font = f,\n side = colorbar_title_side\n ),\n tickfont = tickfont,\n xpad = colorbar_xpad,\n ypad = colorbar_ypad,\n len = colorbar_len\n )\n\n # Config ----\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n )\n )\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n plt\n} # /rtemis::draw_spectrogram\n" }, { "path": "R/draw_survfit.R", "content": "# draw_survfit.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# draw_scatter(time, survival_prob, mode = \"lines\", line_shape = \"hv\")\n# ?median lines, error bands, nrisk_table\n\n#' Draw a survfit object\n#'\n#' Draw a `survfit` object using [draw_scatter].\n#'\n#' @inheritParams draw_scatter\n#'\n#' @param x `survfit` object created by [survival::survfit].\n#' @param mode Character, vector: \"markers\", \"lines\", \"markers+lines\".\n# @param plot_median Logical: If `TRUE`, draw line(s) at 50% survival.\n#' @param xlim Numeric vector of length 2: x-axis limits.\n#' @param ylim Numeric vector of length 2: y-axis limits.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param main Character: Main title.\n#' @param symbol Character: Symbol to use for the points.\n#' @param nrisk_table Logical: If `TRUE`, subplot a table of the number at risk at each time point.\n#' @param ... Additional arguments passed to [draw_scatter].\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' # Get the lung dataset\n#' data(cancer, package = \"survival\")\n#' sf1 <- survival::survfit(survival::Surv(time, status) ~ 1, data = lung)\n#' draw_survfit(sf1)\n#' sf2 <- survival::survfit(survival::Surv(time, status) ~ sex, data = lung)\n#' draw_survfit(sf2)\n#' # with N at risk table\n#' draw_survfit(sf2)\ndraw_survfit <- function(\n x,\n # plot_median = TRUE,\n mode = \"lines\",\n symbol = \"cross\",\n line_shape = \"hv\",\n xlim = NULL,\n ylim = NULL,\n xlab = \"Time\",\n ylab = \"Survival\",\n main = NULL,\n legend_xy = c(1, 1),\n legend_xanchor = \"right\",\n legend_yanchor = \"top\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n nrisk_table = FALSE,\n filename = NULL,\n ...\n) {\n # Checks ----\n check_inherits(x, \"survfit\")\n\n # Data ----\n nstrata <- if (is.null(x[[\"strata\"]])) {\n 1\n } else {\n length(x[[\"strata\"]])\n }\n\n if (nstrata > 1) {\n .group <- unlist(sapply(seq_len(nstrata), function(i) {\n rep(i, x[[\"strata\"]][i])\n }))\n } else {\n .group <- rep(1, length(x[[\"time\"]]))\n }\n\n # Limits ----\n if (is.null(xlim)) {\n xlim <- c(0, max(x[[\"time\"]], na.rm = TRUE))\n }\n if (is.null(ylim)) {\n ylim <- c(0, 1)\n }\n\n # Plot ----\n draw_scatter(\n x = split(x[[\"time\"]], .group),\n y = split(x[[\"surv\"]], .group),\n xlim = xlim,\n ylim = ylim,\n xlab = xlab,\n ylab = ylab,\n main = main,\n theme = theme,\n mode = mode,\n symbol = symbol,\n line_shape = line_shape,\n filename = filename,\n legend_xy = legend_xy,\n legend_xanchor = legend_xanchor,\n legend_yanchor = legend_yanchor,\n ...\n )\n} # /rtemis::draw_survfit\n" }, { "path": "R/draw_table.R", "content": "# draw_table.R\n# ::rtemis::\n# 2019 EDG rtemis.org\n\n#' Simple HTML table\n#'\n#' Draw an html table using `plotly`\n#'\n#' @param x data.frame: Table to draw\n#' @param .ddSci Logical: If TRUE, apply [ddSci] to numeric columns.\n#' @param main Character: Table tile.\n#' @param main_col Color: Title color.\n#' @param main_x Float \\[0, 1\\]: Align title: 0: left, .5: center, 1: right.\n#' @param main_xanchor Character: \"auto\", \"left\", \"right\": plotly's layout xanchor for\n#' title.\n#' @param fill_col Color: Used to fill header with column names and first column with\n#' row names.\n#' @param table_bg Color: Table background.\n#' @param bg Color: Background.\n#' @param line_col Color: Line color.\n#' @param lwd Float: Line width.\n#' @param header_font_col Color: Header font color.\n#' @param table_font_col Color: Table font color.\n#' @param font_size Integer: Font size.\n#' @param font_family Character: Font family.\n#' @param margin List: plotly's margins.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' df <- data.frame(\n#' Name = c(\"Alice\", \"Bob\", \"Charlie\"),\n#' Age = c(25, 30, 35),\n#' Score = c(90.5, 85.0, 88.0)\n#' )\n#' p <- draw_table(\n#' df,\n#' main = \"Sample Table\",\n#' main_col = \"#00b2b2\"\n#' )\ndraw_table <- function(\n x,\n .ddSci = TRUE,\n main = NULL,\n main_col = \"black\",\n main_x = 0,\n main_xanchor = \"auto\",\n fill_col = \"#18A3AC\",\n table_bg = \"white\",\n bg = \"white\",\n line_col = \"white\",\n lwd = 1,\n header_font_col = \"white\",\n table_font_col = \"gray20\",\n font_size = 14,\n font_family = \"Helvetica Neue\",\n margin = list(\n l = 0,\n r = 5,\n t = 30,\n b = 0,\n pad = 0\n )\n) {\n # Dependencies ----\n check_dependencies(\"plotly\")\n\n # Input ----\n x <- as.data.frame(x)\n if (.ddSci) {\n # x <- dplyr::mutate_if(x, is.numeric, ddSci)\n # Lose the dep:\n x <- data.frame(lapply(x, function(x) if (is.numeric(x)) ddSci(x) else x))\n }\n\n # Colnames ----\n if (!is.null(colnames(x))) {\n colnames(x) <- paste0(\"\", colnames(x), \"\")\n }\n\n # Rownames ----\n if (!is.null(rownames(x))) {\n rownames(x) <- paste0(\"\", rownames(x), \"\")\n }\n\n # plotly ----\n\n plt <- plotly::plot_ly(x)\n plt <- plotly::add_table(\n plt,\n header = list(\n line = list(\n width = lwd,\n color = c(\n \"rgba(255,255,255,0)\",\n plotly::toRGB(line_col)\n )\n ),\n fill = list(\n color = c(\n \"rgba(255,255,255,0)\",\n plotly::toRGB(fill_col)\n )\n ),\n align = c(\"right\", \"center\"),\n font = list(\n color = plotly::toRGB(header_font_col),\n family = font_family,\n size = font_size\n )\n ),\n cells = list(\n line = list(\n width = lwd,\n color = c(\n plotly::toRGB(line_col),\n plotly::toRGB(fill_col)\n )\n ),\n fill = list(\n color = c(\n plotly::toRGB(fill_col),\n plotly::toRGB(table_bg)\n )\n ),\n align = c(\"right\", \"center\"),\n font = list(\n color = c(\n plotly::toRGB(header_font_col),\n plotly::toRGB(table_font_col)\n ),\n family = font_family,\n size = font_size\n )\n )\n )\n\n # layout ----\n main <- paste0(\"\", main, \"\")\n plt <- plotly::layout(\n plt,\n title = list(\n text = main,\n font = list(\n family = font_family,\n size = font_size,\n color = main_col\n ),\n x = main_x,\n xanchor = main_xanchor\n ),\n paper_bgcolor = plotly::toRGB(bg),\n margin = margin\n )\n\n plt\n} # /rtemis::draw_table\n" }, { "path": "R/draw_ts.R", "content": "# draw_ts.R\n# ::rtemis::\n# 2022 EDG rtemis.org\n\n# => recalc limits for fn = \"sum\"\n\n#' Interactive Timeseries Plots\n#'\n#' Draw interactive timeseries plots using `plotly`\n#'\n#' @param x Numeric vector of values to plot or list of vectors\n#' @param time Numeric or Date vector of time corresponding to values of `x`\n#' @param window Integer: apply `roll_fn` over this many units of time\n#' @param group Factor defining groups\n#' @param roll_fn Character: \"mean\", \"median\", \"max\", or \"sum\": Function to apply on\n#' rolling windows of `x`\n#' @param roll_col Color for rolling line\n#' @param roll_alpha Numeric: transparency for rolling line\n#' @param roll_lwd Numeric: width of rolling line\n#' @param roll_name Rolling function name (for annotation)\n#' @param alpha Numeric \\[0, 1\\]: Transparency\n#' @param align Character: \"center\", \"right\", or \"left\"\n#' @param group_names Character vector of group names\n#' @param xlab Character: x-axis label\n#' @param n_xticks Integer: number of x-axis ticks to use (approximately)\n# @param tickmode\n#' @param scatter_type Character: \"scatter\" or \"lines\"\n#' @param legend Logical: If TRUE, show legend\n#' @param x_showspikes Logical: If TRUE, show x-axis spikes on hover\n#' @param y_showspikes Logical: If TRUE, show y-axis spikes on hover\n#' @param spikedash Character: dash type string (\"solid\", \"dot\", \"dash\",\n#' \"longdash\", \"dashdot\", or \"longdashdot\") or a dash length list in px\n#' (eg \"5px,10px,2px,2px\")\n#' @param displayModeBar Logical: If TRUE, display plotly's modebar\n#' @param theme `Theme` object.\n#' @param palette Character: palette name, or list of colors\n#' @param filename Character: Path to filename to save plot\n#' @param spikemode Character: If \"toaxis\", spike line is drawn from the data\n#' point to the axis the series is plotted on. If \"across\", the line is drawn\n#' across the entire plot area, and supercedes \"toaxis\". If \"marker\", then a\n#' marker dot is drawn on the axis the series is plotted on\n#' @param spikesnap Character: \"data\", \"cursor\", \"hovered data\". Determines\n#' whether spikelines are stuck to the cursor or to the closest datapoints.\n#' @param spikecolor Color for spike lines\n#' @param spikethickness Numeric: spike line thickness\n#' @param modeBar_file_format Character: modeBar image export file format\n#' @param file_width Numeric: image export width\n#' @param file_height Numeric: image export height\n#' @param file_scale Numeric: image export scale\n#' @param ... Additional arguments to be passed to [draw_scatter]\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' time <- sample(seq(as.Date(\"2020-03-01\"), as.Date(\"2020-09-23\"), length.out = 140))\n#' x1 <- rnorm(140)\n#' x2 <- rnorm(140, 1, 1.2)\n#' # Single timeseries\n#' draw_ts(x1, time)\n#' # Multiple timeseries input as list\n#' draw_ts(list(Alpha = x1, Beta = x2), time)\n#' # Multiple timeseries grouped by group, different lengths\n#' time1 <- sample(seq(as.Date(\"2020-03-01\"), as.Date(\"2020-07-23\"), length.out = 100))\n#' time2 <- sample(seq(as.Date(\"2020-05-01\"), as.Date(\"2020-09-23\"), length.out = 140))\n#' time <- c(time1, time2)\n#' x <- c(rnorm(100), rnorm(140, 1, 1.5))\n#' group <- c(rep(\"Alpha\", 100), rep(\"Beta\", 140))\n#' draw_ts(x, time, 7, group)\ndraw_ts <- function(\n x,\n time,\n window = 7L,\n group = NULL,\n roll_fn = c(\"mean\", \"median\", \"max\", \"none\"),\n roll_col = NULL,\n roll_alpha = 1,\n roll_lwd = 2,\n roll_name = NULL,\n alpha = NULL,\n align = \"center\",\n group_names = NULL,\n xlab = \"Time\",\n n_xticks = 12,\n # tickmode = \"array\",\n scatter_type = \"scatter\",\n legend = TRUE,\n x_showspikes = TRUE,\n y_showspikes = FALSE,\n spikedash = \"solid\",\n spikemode = \"across\",\n spikesnap = \"hovered data\",\n spikecolor = NULL,\n spikethickness = 1,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = getOption(\"rtemis_palette\", \"rtms\"),\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n ...\n) {\n # Arguments ----\n roll_fn <- match.arg(roll_fn)\n if (roll_fn == \"none\") {\n window <- NULL\n }\n\n # Timeseries ----\n if (!is.null(group)) {\n x <- split(x, group)\n time <- split(time, group)\n }\n\n if (is.data.frame(x)) {\n x <- as.list(x)\n }\n\n if (!is.list(x)) {\n x <- list(x)\n }\n\n if (is.data.frame(time)) {\n time <- as.list(time)\n }\n\n if (!is.list(time)) {\n time <- list(time)\n }\n\n if (is.null(group_names)) {\n group_names <- if (!is.null(names(x))) {\n names(x)\n } else {\n paste(\"Group\", seq_along(x))\n }\n }\n\n idx <- lapply(time, order)\n time <- lapply(seq_along(time), \\(i) time[[i]][idx[[i]]])\n if (length(time) < length(x)) {\n time <- rep(time, length(x) / length(time))\n idx <- rep(idx, length(x) / length(idx))\n }\n x <- lapply(seq_along(x), \\(i) x[[i]][idx[[i]]])\n # xtl <- lapply(seq_along(x), \\(i) zoo::zoo(x[[i]], time[[i]]))\n\n if (!is.null(window) && window > 0) {\n avg_line <- switch(\n roll_fn,\n mean = lapply(\n x,\n \\(xt) data.table::frollmean(xt, n = window, align = align)\n ),\n median = lapply(\n x,\n \\(xt) data.table::frollapply(xt, n = window, median, align = align)\n ),\n max = lapply(\n x,\n \\(xt) data.table::frollapply(xt, n = window, max, align = align)\n ),\n sum = lapply(x, \\(xt) data.table::frollsum(xt, n = window, align = align))\n )\n }\n\n # Palette ----\n if (is.character(palette)) {\n palette <- get_palette(palette)\n }\n if (is.null(roll_col)) {\n roll_col <- palette[seq_along(x)]\n }\n\n # draw_scatter ----\n plt <- draw_scatter(\n time,\n x,\n xlab = xlab,\n theme = theme,\n palette = palette,\n alpha = alpha,\n group_names = group_names,\n legend = legend,\n scatter_type = scatter_type,\n x_showspikes = x_showspikes,\n y_showspikes = y_showspikes,\n spikedash = spikedash,\n spikemode = spikemode,\n spikesnap = spikesnap,\n spikecolor = spikecolor,\n spikethickness = spikethickness,\n ...\n )\n\n # Rolling function line ----\n if (is.null(roll_name)) {\n roll_name <- paste0(\"Rolling \", roll_fn, \" (window=\", window, \")\")\n }\n\n if (!is.null(window)) {\n for (i in seq_along(x)) {\n plt <- plt |>\n plotly::add_trace(\n x = time[[i]],\n y = avg_line[[i]],\n type = \"scatter\",\n mode = \"lines\",\n line = list(\n color = plotly::toRGB(roll_col[[i]], alpha = roll_alpha),\n width = roll_lwd\n ),\n name = roll_name\n )\n }\n }\n\n # Config\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n )\n )\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n plt\n} # /rtemis::draw_ts\n" }, { "path": "R/draw_varimp.R", "content": "# draw_varimp.R\n# ::rtemis::\n# 2017 EDG rtemis.org\n\n#' Interactive Variable Importance Plot\n#'\n#' Plot variable importance using `plotly`\n#'\n#' A simple `plotly` wrapper to plot horizontal barplots, sorted by value,\n#' which can be used to visualize variable importance, model coefficients, etc.\n#'\n#' @param x Numeric vector (or coercible to numeric): Input.\n#' @param names Vector, string: Names of features.\n#' @param main Character: Main title.\n#' @param type Character: \"bar\" or \"line\".\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param plot_top Integer: Plot this many top features.\n#' @param orientation Character: \"h\" or \"v\".\n#' @param line_width Numeric: Line width.\n#' @param labelify Logical: If TRUE, labelify feature names.\n#' @param alpha Numeric: Transparency.\n#' @param palette Character vector: Colors to use.\n#' @param mar Vector, numeric, length 4: Plot margins in pixels (NOT inches).\n#' @param font_size Integer: Overall font size to use (essentially for the\n#' title at this point).\n#' @param axis_font_size Integer: Font size to use for axis labels and tick labels.\n#' @param theme `Theme` object.\n#' @param showlegend Logical: If TRUE, show legend.\n#' @param filename Character: Path to save the plot image.\n#' @param file_width Numeric: Width of the saved plot image.\n#' @param file_height Numeric: Height of the saved plot image.\n#' @param file_scale Numeric: Scale of the saved plot image.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' # synthetic data\n#' x <- rnorm(10)\n#' names(x) <- paste0(\"Feature_\", seq(x))\n#' draw_varimp(x)\n#' draw_varimp(x, orientation = \"h\")\ndraw_varimp <- function(\n x,\n names = NULL,\n main = NULL,\n type = c(\"bar\", \"line\"),\n xlab = NULL,\n ylab = NULL,\n plot_top = 1, # 1 or less means plot this percent\n orientation = \"v\",\n line_width = 12,\n labelify = TRUE,\n alpha = 1,\n palette = get_palette(getOption(\"rtemis_palette\")),\n mar = NULL,\n font_size = 16,\n axis_font_size = 14,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n showlegend = TRUE,\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1\n) {\n # Dependencies ----\n check_dependencies(\"plotly\")\n\n # Arguments ----\n type <- match.arg(type)\n if (is.null(mar)) {\n mar <- if (is.null(main)) c(20, 20, 20, 20) else c(20, 20, 40, 20)\n }\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n bg <- plotly::toRGB(theme[[\"bg\"]])\n plot_bg <- plotly::toRGB(theme[[\"plot_bg\"]])\n grid_col <- plotly::toRGB(theme[[\"grid_col\"]])\n tick_col <- plotly::toRGB(theme[[\"tick_col\"]])\n labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n\n ## Axis font ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = labs_col\n )\n\n ## Tick font ----\n tickfont <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = theme[[\"tick_labels_col\"]]\n )\n\n # Data ----\n if (NCOL(x) > 1 && NROW(x) > 1) {\n cli::cli_abort(\"x must be a vector or single row or column\")\n }\n\n ## Names ----\n if (is.null(names)) {\n if (is.null(names(x))) {\n .names <- if (NCOL(x) == 1) {\n labelify(rownames(x))\n } else {\n labelify(colnames(x))\n }\n } else {\n .names <- labelify(names(x))\n }\n } else {\n .names <- labelify(names)\n }\n\n x <- as.numeric(x)\n if (length(.names) == 0) {\n .names <- paste(\"Feature\", seq_along(x))\n }\n\n ## Index ----\n index <- if (plot_top <= 1) {\n order(abs(x))[(length(x) - plot_top * length(x)):length(x)]\n } else {\n if (plot_top > length(x)) {\n plot_top <- length(x)\n }\n order(abs(x))[(length(x) - plot_top + 1):length(x)]\n }\n x <- x[index]\n .names <- .names[index]\n # reorder to arrange negative to positive\n index <- order(x)\n x <- x[index]\n .names <- .names[index]\n y <- factor(.names, levels = .names)\n\n # Colors ----\n col <- palette[[1]]\n col <- color_adjust(col, alpha = alpha)\n\n # plotly ----\n if (type == \"bar\") {\n plt <- plotly::plot_ly(\n x = if (orientation == \"h\") x else y,\n y = if (orientation == \"h\") y else x,\n type = \"bar\",\n marker = list(\n color = col,\n line = list(width = NULL)\n ),\n showlegend = FALSE\n )\n } else {\n # Plot each x[i] value as a line segment from 0 to x[i]\n plt <- plotly::plot_ly()\n for (i in seq_along(x)) {\n plt <- plotly::add_trace(\n plt,\n x = if (orientation == \"h\") c(0, x[i]) else c(y[i], y[i]),\n y = if (orientation == \"h\") c(y[i], y[i]) else c(0, x[i]),\n type = \"scatter\",\n mode = \"lines\",\n line = list(color = col, width = line_width),\n name = .names[i],\n showlegend = FALSE,\n # Show \"_name[i]: value\" on hover\n hoverinfo = \"text\",\n hovertext = paste0(.names[i], \": \", ddSci(x[i]))\n )\n }\n }\n\n # Layout ----\n if (is.null(xlab)) {\n xlab <- if (orientation == \"h\") \"Variable Importance\" else \"\"\n }\n if (is.null(ylab)) {\n ylab <- if (orientation == \"h\") \"\" else \"Variable Importance\"\n }\n plt <- plotly::layout(\n plt,\n margin = list(\n b = mar[1],\n l = mar[2],\n t = mar[3],\n r = mar[4],\n pad = 0\n ), # inner plot area padding\n xaxis = list(\n title = list(\n text = xlab,\n font = f\n ),\n # showline = axes_visible,\n # mirror = axes_mirrored,\n showgrid = FALSE,\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = FALSE\n ),\n yaxis = list(\n title = list(\n text = ylab,\n font = f\n ),\n # showline = axes_visible,\n # mirror = axes_mirrored,\n showgrid = theme[[\"grid\"]],\n # gridcolor = grid_col,\n # gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tickfont,\n zeroline = FALSE\n ),\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n ),\n xref = \"paper\",\n x = theme[[\"main_adj\"]]\n ),\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg\n )\n\n # Remove padding\n plt[[\"sizingPolicy\"]][[\"padding\"]] <- 0\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n plt\n} # draw_varimp\n" }, { "path": "R/draw_volcano.R", "content": "# draw_volcano\n# ::rtemis::\n# 2022 EDG rtemis.org\n# allow custom grouping\n\n# References\n# https://github.com/plotly/plotly.js/blob/master/src/plot_api/plot_config.js\n\n#' Volcano Plot\n#'\n#' @param x Numeric vector: Input values, e.g. log2 fold change, coefficients, etc.\n#' @param pvals Numeric vector: p-values.\n#' @param xnames Character vector: `x` names.\n#' @param group Optional factor: Used to color code points. If NULL, significant points\n#' below `x_thresh`, non-significant points, and significant points\n#' above `x_thresh` will be plotted with the first, second and third\n#' color of `palette`.\n#' @param x_thresh Numeric x-axis threshold separating low from high.\n#' @param p_thresh Numeric: p-value threshold of significance.\n#' @param p_adjust_method Character: p-value adjustment method.\n#' \"holm\", \"hochberg\", \"hommel\", \"bonferroni\", \"BH\", \"BY\", \"fdr\", \"none\".\n#' Default = \"holm\". Use \"none\" for raw p-values.\n#' @param p_transform function.\n#' @param legend Logical: If TRUE, show legend. Will default to FALSE, if\n#' `group = NULL`, otherwise to TRUE.\n#' @param legend_lo Character: Legend to annotate significant points below the\n#' `x_thresh`.\n#' @param legend_hi Character: Legend to annotate significant points above the\n#' `x_thresh`.\n#' @param label_lo Character: label for low values.\n#' @param label_hi Character: label for high values.\n#' @param main Character: Main title.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param margin Named list of plot margins.\n#' Default = `list(b = 65, l = 65, t = 50, r = 10, pad = 0)`.\n#' @param xlim Numeric vector, length 2: x-axis limits.\n#' @param ylim Numeric vector, length 2: y-axis limits.\n#' @param alpha Numeric: point transparency.\n#' @param hline Numeric: If defined, draw a horizontal line at this y value.\n#' @param hline_col Color for `hline`.\n#' @param hline_width Numeric: Width for `hline`.\n#' @param hline_dash Character: Type of line to draw: \"solid\", \"dot\", \"dash\",\n#' \"longdash\", \"dashdot\", or \"longdashdot\".\n#' @param hline_annotate Character: Text of horizontal line annotation if\n#' `hline` is set.\n#' @param hline_annotation_x Numeric: x position to place annotation with paper\n#' as reference. 0: to the left of the plot area; 1: to the right of the plot area.\n#' @param annotate Logical: If TRUE, annotate significant points.\n#' @param annotate_col Color for annotations.\n#' @param theme `Theme` object.\n#' @param font_size Integer: Font size.\n#' @param palette Character vector: Colors to use. If `group` is NULL, the first, second and third\n#' colors will be used for significant points with negative coefficients, non-significant points, and\n#' significant points with positive coefficients, respectively. If `group` is not NULL, colors will\n#' be assigned to groups, in order of appearance.\n#' @param legend_x_lo Numeric: x position of `legend_lo`.\n#' @param legend_x_hi Numeric: x position of `legend_hi`.\n#' @param legend_y Numeric: y position for `legend_lo` and `legend_hi`.\n#' @param annotate_n Integer: Number of significant points to annotate.\n#' @param ax_lo Numeric: Sets the x component of the arrow tail about the arrow head for\n#' significant points below `x_thresh`.\n#' @param ay_lo Numeric: Sets the y component of the arrow tail about the arrow head for\n#' significant points below `x_thresh`.\n#' @param ax_hi Numeric: Sets the x component of the arrow tail about the arrow head for\n#' significant points above `x_thresh`.\n#' @param ay_hi Numeric: Sets the y component of the arrow tail about the arrow head for\n#' significant points above `x_thresh`.\n#' @param annotate_alpha Numeric: Transparency for annotations.\n#' @param hovertext Character vector: Text to display on hover.\n#' @param displayModeBar Logical: If TRUE, display plotly mode bar.\n#' @param filename Character: Path to save the plot image.\n#' @param file_width Numeric: Width of the saved plot image.\n#' @param file_height Numeric: Height of the saved plot image.\n#' @param file_scale Numeric: Scale of the saved plot image.\n#' @param verbosity Integer: Verbosity level.\n#' @param ... Additional arguments passed to [draw_scatter].\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' set.seed(2019)\n#' y <- rnormmat(500, 500, return_df = TRUE)\n#' x <- data.frame(x = y[, 3] + y[, 5] - y[, 9] + y[, 15] + rnorm(500))\n#' mod <- massGLM(x, y)\n#' draw_volcano(summary(mod)[[\"Coefficient_x\"]], summary(mod)[[\"p_value_x\"]])\ndraw_volcano <- function(\n x,\n pvals,\n xnames = NULL,\n group = NULL,\n x_thresh = 0,\n p_thresh = .05,\n p_adjust_method = c(\n \"holm\",\n \"hochberg\",\n \"hommel\",\n \"bonferroni\",\n \"BH\",\n \"BY\",\n \"fdr\",\n \"none\"\n ),\n p_transform = function(x) -log10(x),\n legend = NULL,\n legend_lo = NULL,\n legend_hi = NULL,\n label_lo = \"Low\",\n label_hi = \"High\",\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n margin = list(b = 65, l = 65, t = 50, r = 10, pad = 0),\n xlim = NULL,\n ylim = NULL,\n alpha = NULL,\n hline = NULL,\n hline_col = NULL,\n hline_width = 1,\n hline_dash = \"solid\",\n hline_annotate = NULL,\n hline_annotation_x = 1,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n annotate = TRUE,\n annotate_col = theme[[\"labs_col\"]],\n font_size = 16,\n palette = NULL,\n legend_x_lo = NULL,\n legend_x_hi = NULL,\n legend_y = .97,\n annotate_n = 7L,\n ax_lo = NULL, # 40,\n ay_lo = NULL,\n ax_hi = NULL, # -40,\n ay_hi = NULL,\n annotate_alpha = .7,\n hovertext = NULL,\n displayModeBar = \"hover\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n verbosity = 1L,\n ...\n) {\n xname <- deparse(substitute(x))\n p_adjust_method <- match.arg(p_adjust_method)\n filt <- !is.na(x) & !is.na(pvals)\n if (is.null(xnames)) {\n xnames <- names(x)\n } else {\n xnames <- xnames\n }\n xnames <- xnames[filt]\n if (!is.null(group)) {\n group <- group[filt]\n }\n x <- x[filt]\n pvals <- pvals[filt]\n if (is.null(xnames)) {\n xnames <- paste(\"Feature\", seq_along(x))\n }\n if (is.null(legend)) {\n legend <- !is.null(group)\n }\n\n p_adjusted <- p.adjust(pvals, method = p_adjust_method)\n index_ltpthresh <- p_adjusted < p_thresh\n p_transformed <- p_transform(p_adjusted)\n if (is.null(xlab)) {\n xlab <- labelify(xname)\n }\n\n # Default to lo - ns - hi groups\n if (is.null(group)) {\n group <- rep(\"NS\", length(pvals))\n group[index_ltpthresh & x < x_thresh] <- label_lo\n group[index_ltpthresh & x > x_thresh] <- label_hi\n group <- factor(group, levels = c(label_lo, \"NS\", label_hi))\n if (is.null(palette)) {\n palette <- list(\"#43A4AC\", \"#7f7f7f\", \"#FA9860\")\n }\n }\n\n group.counts <- table(group)\n include <- group.counts > 0\n if (verbosity > 0L) {\n cat(\"Group counts:\\n\")\n print(group.counts)\n }\n\n # Colors for groups\n if (is.null(palette)) {\n palette <- get_palette(getOption(\"rtemis_palette\", \"rtms\"))\n }\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n # y-axis label ----\n if (is.null(ylab)) {\n ylab <- fn2label(p_transform, \"p-value\")\n if (p_adjust_method != \"none\") {\n ylab <- paste0(ylab, \" (\", p_adjust_method, \"-corrected)\")\n }\n }\n\n # Plot ----\n if (is.null(hovertext)) {\n hovertext <- xnames\n }\n plt <- draw_scatter(\n x,\n p_transformed,\n main = main,\n xlab = xlab,\n ylab = ylab,\n xlim = xlim,\n ylim = ylim,\n alpha = alpha,\n theme = theme,\n margin = margin,\n legend = legend,\n group = group,\n palette = palette[include],\n hovertext = hovertext,\n ...\n )\n\n # High - Low legend ----\n autolegend_x_lo <- is.null(legend_x_lo)\n if (autolegend_x_lo) {\n # legend.x.lo <- Filter(\\(x) x < x.thresh, x) |> range() |> diff() * -.2 + x.thresh\n legend_x_lo <- x_thresh - abs(diff(c(x_thresh, min(x, na.rm = TRUE)))) * .2\n }\n\n autolegend_x_hi <- is.null(legend_x_hi)\n if (autolegend_x_hi) {\n # legend.x.hi <- Filter(\\(x) x > x.thresh, x) |> range() |> diff() * .2 + x.thresh\n legend_x_hi <- x_thresh + abs(diff(c(x_thresh, max(x, na.rm = TRUE)))) * .2\n }\n\n legxdiff <- legend_x_hi - legend_x_lo\n\n if (autolegend_x_lo) {\n legend_x_lo <- x_thresh - legxdiff / 2\n }\n if (autolegend_x_hi) {\n legend_x_hi <- x_thresh + legxdiff / 2\n }\n\n if (group.counts[1] > 0 && !is.null(legend_lo)) {\n plt <- plt |>\n plotly::add_annotations(\n x = legend_x_lo,\n y = legend_y,\n text = legend_lo,\n xref = \"x\",\n yref = \"paper\",\n showarrow = FALSE,\n font = list(\n color = palette[[1]],\n family = theme[[\"font_family\"]],\n size = font_size\n )\n )\n }\n\n if (group.counts[3] > 0 && !is.null(legend_hi)) {\n plt <- plt |>\n plotly::add_annotations(\n x = legend_x_hi,\n y = legend_y,\n text = legend_hi,\n xref = \"x\",\n yref = \"paper\",\n showarrow = FALSE,\n font = list(\n color = palette[[3]],\n family = theme[[\"font_family\"]],\n size = font_size\n )\n )\n }\n\n # Annotations ----\n if (annotate) {\n index_ltxthresh <- x < x_thresh\n index_gtxthresh <- x > x_thresh\n\n index_lo <- index_ltpthresh & index_ltxthresh\n index_hi <- index_ltpthresh & index_gtxthresh\n annotate_n_lo <- annotate_n_hi <- annotate_n\n if (sum(index_lo) < annotate_n) {\n annotate_n_lo <- sum(index_lo)\n }\n if (sum(index_hi) < annotate_n) {\n annotate_n_hi <- sum(index_hi)\n }\n\n if (annotate_n_lo > 0) {\n lo_ord <- order(pvals[index_lo])\n lo_x <- x[index_lo][lo_ord[seq_len(annotate_n_lo)]]\n lo_pval <- p_transformed[index_lo][lo_ord[seq_len(annotate_n_lo)]]\n lo_name <- xnames[index_lo][lo_ord[seq_len(annotate_n_lo)]]\n\n if (is.null(ay_lo)) {\n if (is.null(ay_lo)) {\n ay_lo <- drange(order(lo_pval), 30, -30)\n }\n }\n if (is.null(ax_lo)) {\n ax_lo <- 5 + 5 * annotate_n_lo\n }\n plt <- plt |>\n plotly::add_annotations(\n x = lo_x,\n y = lo_pval,\n text = lo_name,\n arrowhead = 4,\n arrowcolor = adjustcolor(theme[[\"fg\"]], .33),\n arrowsize = .5,\n arrowwidth = 1,\n ax = ax_lo,\n ay = ay_lo,\n xanchor = \"left\",\n font = list(\n size = 16,\n family = theme[[\"font_family\"]],\n color = adjustcolor(theme[[\"fg\"]], annotate_alpha)\n )\n )\n }\n\n # Annotate 10 most significant increasing\n if (annotate_n_hi > 0) {\n hi_ord <- order(pvals[index_ltpthresh & index_gtxthresh])\n hi_x <- x[index_ltpthresh & index_gtxthresh][hi_ord[seq_len(\n annotate_n_hi\n )]]\n hi_pval <- p_transformed[\n index_ltpthresh & index_gtxthresh\n ][hi_ord[seq_len(annotate_n_hi)]]\n hi_name <- xnames[index_ltpthresh & index_gtxthresh][hi_ord[seq_len(\n annotate_n_hi\n )]]\n\n if (is.null(ay_hi)) {\n ay_hi <- drange(order(hi_pval), 50, -50)\n }\n if (is.null(ax_hi)) {\n ax_hi <- -5 - 5 * annotate_n_hi\n }\n plt <- plt |>\n plotly::add_annotations(\n x = hi_x,\n y = hi_pval,\n text = hi_name,\n arrowhead = 4,\n arrowcolor = adjustcolor(theme[[\"fg\"]], .33),\n arrowsize = .5,\n arrowwidth = 1,\n ax = ax_hi,\n ay = ay_hi,\n xanchor = \"right\",\n font = list(\n size = 16,\n family = theme[[\"font_family\"]],\n color = adjustcolor(theme[[\"fg\"]], annotate_alpha)\n )\n )\n }\n }\n\n # hline ----\n if (!is.null(hline)) {\n if (is.null(hline_col)) {\n hline_col <- theme[[\"fg\"]]\n }\n hline_col <- recycle(hline_col, hline)\n hline_width <- recycle(hline_width, hline)\n hline_dash <- recycle(hline_dash, hline)\n hlinel <- lapply(seq_along(hline), function(i) {\n list(\n type = \"line\",\n x0 = 0,\n x1 = 1,\n xref = \"paper\",\n y0 = hline[i],\n y1 = hline[i],\n line = list(\n color = hline_col[i],\n width = hline_width[i],\n dash = hline_dash[i]\n )\n )\n })\n plt <- plotly::layout(plt, shapes = hlinel)\n\n # Annotate horizontal lines on the right border of the plot\n if (!is.null(hline_annotate)) {\n plt <- plt |>\n plotly::add_annotations(\n xref = \"paper\",\n yref = \"y\",\n xanchor = \"right\",\n yanchor = \"bottom\",\n x = hline_annotation_x,\n y = hline,\n text = hline_annotate,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = annotate_col\n ),\n showarrow = FALSE\n )\n }\n }\n\n # Config ----\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = \"svg\",\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n )\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n plt\n} # /rtemis::draw_volcano\n" }, { "path": "R/draw_xt.R", "content": "# draw_xt.R\n# ::rtemis::\n# 2024 EDG rtemis.org\n\n# Multiple legends\n# https://plotly.com/python/legend/#adding-multiple-legends\n# https://plotly.com/r/legend/\n\n#' Plot timeseries data\n#'\n#' @param x Datetime vector or list of vectors.\n#' @param y Numeric vector or named list of vectors: y-axis data.\n#' @param x2 Datetime vector or list of vectors, optional: must be provided if `y2` does not\n#' correspond to values in `x`. A single x-axis will be drawn for all values in `x` and `x2`.\n#' @param y2 Numeric vector, optional: If provided, a second y-axis will be added to the right\n#' side of the plot.\n#' @param which_xy Integer vector: Indices of `x` and `y` to plot.\n#' If not provided, will select up to the first two x-y traces.\n#' @param which_xy2 Integer vector: Indices of `x2` and `y2` to plot.\n#' If not provided, will select up to the first two x2-y2 traces.\n#' @param shade_bin Integer vector \\{0, 1\\}: Time points in `x` to shade on the plot. For example,\n#' if there are 10 time points in `x`, and you want to shade time points 3 to 7,\n#' `shade_bin = c(0, 0, 1, 1, 1, 1, 1, 0, 0, 0)`. Only set `shade_bin` or `shade_interval`, not\n#' both.\n#' @param shade_interval List of numeric vectors: Intervals to shade on the plot. Only set\n#' `shade_bin` or `shade_interval`, not both.\n#' @param shade_col Color: Color to shade intervals.\n#' @param shade_x Numeric vector: x-values to use for shading.\n#' @param shade_name Character: Name for shaded intervals.\n#' @param shade_showlegend Logical: If TRUE, show legend for shaded intervals.\n#' @param ynames Character vector, optional: Names for each vector in `y`.\n#' @param y2names Character vector, optional: Names for each vector in `y2`.\n#' @param xlab Character: x-axis label.\n#' @param ylab Character: y-axis label.\n#' @param y2lab Character: y2-axis label.\n#' @param xunits Character: x-axis units.\n#' @param yunits Character: y-axis units.\n#' @param y2units Character: y2-axis units.\n#' @param yunits_col Color for y-axis units.\n#' @param y2units_col Color for y2-axis units.\n#' @param zt Numeric vector: Zeitgeber time. If provided, will be shown on the x-axis instead of\n#' `x`. To be used only with a single `x` vector and no `x2`.\n#' @param show_zt Logical: If TRUE, show zt on x-axis, if zt is provided.\n#' @param show_zt_every Optional integer: Show zt every `show_zt_every` ticks. If NULL, will be\n#' calculated to be `x_nticks` +/- 1 if `x_nticks` is not 0, otherwise 12 +/- 1.\n#' @param zt_nticks Integer: Number of zt ticks to show. Only used if `show_zt_every` is NULL.\n#' The actual number of ticks shown will depend on the periodicity of zt, so that zt = 0 is always\n#' included.\n#' @param main Character: Main title.\n#' @param main_y Numeric: Y position of main title.\n#' @param main_yanchor Character: \"top\", \"middle\", \"bottom\".\n#' @param x_nticks Integer: Number of ticks on x-axis.\n#' @param y_nticks Integer: Number of ticks on y-axis.\n#' @param show_rangeslider Logical: If TRUE, show a range slider.\n#' @param slider_start Numeric: Start of range slider.\n#' @param slider_end Numeric: End of range slider.\n#' @param theme `Theme` object.\n#' @param palette Character vector: Colors to be used to draw each vector in `y` and `y2`, in order.\n#' @param font_size Numeric: Font size for text.\n#' @param yfill Character: Fill type for y-axis: \"none\", \"tozeroy\", \"tonexty\".\n#' @param y2fill Character: Fill type for y2-axis: \"none\", \"tozeroy\", \"tonexty\".\n#' @param fill_alpha Numeric: Fill opacity for y-axis.\n#' @param yline_width Numeric: Line width for y-axis lines.\n#' @param y2line_width Numeric: Line width for y2-axis lines.\n#' @param x_showspikes Logical: If TRUE, show spikes on x-axis.\n#' @param spike_dash Character: Dash type for spikes: \"solid\", \"dot\", \"dash\", \"longdash\",\n#' \"dashdot\", \"longdashdot\".\n#' @param spike_col Color for spikes.\n#' @param x_spike_thickness Numeric: Thickness of spikes. `-2` avoids drawing border around spikes.\n#' @param tickfont_size Numeric: Font size for tick labels.\n#' @param x_tickmode Character: \"auto\", \"linear\", \"array\".\n#' @param x_tickvals Numeric vector: Tick positions.\n#' @param x_ticktext Character vector: Tick labels.\n#' @param x_tickangle Numeric: Angle of tick labels.\n#' @param legend_x Numeric: X position of legend.\n#' @param legend_y Numeric: Y position of legend.\n#' @param legend_xanchor Character: \"left\", \"center\", \"right\".\n#' @param legend_yanchor Character: \"top\", \"middle\", \"bottom\".\n#' @param legend_orientation Character: \"v\" for vertical, \"h\" for horizontal.\n#' @param margin Named list with 4 numeric values: \"l\", \"r\", \"t\", \"b\" for left, right, top, bottom\n#' margins.\n#' @param x_standoff Numeric: Distance from x-axis to x-axis label.\n#' @param y_standoff Numeric: Distance from y-axis to y-axis label.\n#' @param y2_standoff Numeric: Distance from y2-axis to y2-axis label.\n#' @param hovermode Character: \"closest\", \"x\", \"x unified\".\n#' @param displayModeBar Logical: If TRUE, display plotly mode bar.\n#' @param modeBar_file_format Character: \"png\", \"svg\", \"jpeg\", \"webp\", \"pdf\": file format for mode\n#' bar image export.\n#' @param scrollZoom Logical: If TRUE, enable zooming by scrolling.\n#' @param filename Character: Path to save the plot image.\n#' @param file_width Numeric: Width of the saved plot image.\n#' @param file_height Numeric: Height of the saved plot image.\n#' @param file_scale Numeric: Scale of the saved plot image.\n#'\n#' @return `plotly` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examplesIf interactive()\n#' datetime <- seq(\n#' as.POSIXct(\"2020-01-01 00:00\"),\n#' as.POSIXct(\"2020-01-02 00:00\"),\n#' by = \"hour\"\n#' )\n#' df <- data.frame(\n#' datetime = datetime,\n#' value1 = rnorm(length(datetime)),\n#' value2 = rnorm(length(datetime))\n#' )\n#' draw_xt(df, x = df[, 1], y = df[, 2:3])\ndraw_xt <- function(\n x,\n y,\n x2 = NULL,\n y2 = NULL,\n which_xy = NULL,\n which_xy2 = NULL,\n # Shade intervals\n shade_bin = NULL,\n shade_interval = NULL,\n shade_col = NULL,\n shade_x = NULL,\n shade_name = \"\",\n shade_showlegend = FALSE,\n ynames = NULL,\n y2names = NULL,\n xlab = NULL,\n ylab = NULL,\n y2lab = NULL,\n xunits = NULL,\n yunits = NULL,\n y2units = NULL,\n yunits_col = NULL,\n y2units_col = NULL,\n zt = NULL,\n show_zt = TRUE,\n show_zt_every = NULL,\n zt_nticks = 18L,\n main = NULL,\n main_y = 1,\n main_yanchor = \"bottom\",\n x_nticks = 0,\n y_nticks = 0,\n show_rangeslider = NULL,\n slider_start = NULL,\n slider_end = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n font_size = 16,\n yfill = \"none\",\n y2fill = \"none\",\n fill_alpha = .2,\n yline_width = 2,\n y2line_width = 2,\n x_showspikes = TRUE,\n spike_dash = \"solid\",\n spike_col = NULL,\n x_spike_thickness = -2,\n tickfont_size = 16,\n x_tickmode = \"auto\",\n x_tickvals = NULL,\n x_ticktext = NULL,\n x_tickangle = NULL,\n # legend\n legend_x = 0,\n legend_y = 1.1,\n legend_xanchor = \"left\",\n legend_yanchor = \"top\",\n legend_orientation = \"h\",\n margin = list(l = 75, r = 75, b = 75, t = 75),\n # axis labels\n x_standoff = 20L,\n y_standoff = 20L,\n y2_standoff = 20L,\n hovermode = \"x\",\n # config\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n scrollZoom = TRUE,\n filename = NULL,\n file_width = 960,\n file_height = 500,\n file_scale = 1\n) {\n # Names ----\n .xname <- labelify(gsub(\".*\\\\$\", \"\", deparse(substitute(x))))\n .x2name <- labelify(gsub(\".*\\\\$\", \"\", deparse(substitute(x2))))\n if (!is.null(x2) && .xname != .x2name) {\n .xname <- NULL\n }\n .yname <- labelify(gsub(\".*\\\\$\", \"\", deparse(substitute(y))))\n .y2name <- labelify(gsub(\".*\\\\$\", \"\", deparse(substitute(y2))))\n\n # Data ----\n\n # Data to lists\n if (!is.null(y2) && is.null(x2)) {\n x2 <- x\n }\n if (!is.list(x)) {\n x <- list(x)\n }\n if (!is.list(y)) {\n y <- list(y)\n }\n if (!is.null(y2) && !is.list(y2)) {\n y2 <- list(y2)\n }\n if (!is.null(y2) && !is.list(x2)) {\n x2 <- list(x2)\n }\n\n # Recycle x and x2 as needed\n if (length(y) > 1 && length(x) == 1) {\n x <- rep(x, length(y))\n }\n if (!is.null(y2) && length(y2) > 1 && length(x2) == 1) {\n x2 <- rep(x2, length(y2))\n }\n if (length(x) != length(y)) {\n cli::cli_abort(\"{.arg x} and {.arg y} must be the same length\")\n }\n if (!is.null(y2) && length(x2) != length(y2)) {\n cli::cli_abort(\"{.arg x2} and {.arg y2} must be the same length\")\n }\n\n # Which traces to plot ----\n # By default, plot up to two for each y axis\n if (is.null(which_xy)) {\n if (length(x) > 2) {\n x <- x[1:2]\n y <- y[1:2]\n }\n } else {\n x <- x[which_xy]\n y <- y[which_xy]\n }\n\n if (is.null(which_xy2)) {\n if (length(x2) > 2) {\n x2 <- x2[1:2]\n y2 <- y2[1:2]\n }\n } else {\n x2 <- x2[which_xy2]\n y2 <- y2[which_xy2]\n }\n\n # Rangeslider ----\n if (is.null(show_rangeslider)) {\n show_rangeslider <- length(x[[1]]) > 500\n }\n\n # Check args ----\n if (!is.null(shade_bin) && !is.null(shade_interval)) {\n cli::cli_abort(\n \"Only set {.arg shade_bin} or {.arg shade_interval}, not both\"\n )\n }\n\n # Names ----\n if (is.null(ynames)) {\n ynames <- if (is.null(names(y))) {\n if (length(y) > 1) {\n paste(.yname, seq_along(y), sep = \"_\")\n } else {\n .yname\n }\n } else {\n names(y)\n }\n }\n\n if (!is.null(y2) && is.null(y2names)) {\n y2names <- if (is.null(names(y2))) {\n if (length(y2) > 1) {\n paste(.y2name, seq_along(y2), sep = \"_\")\n } else {\n .y2name\n }\n } else {\n names(y2)\n }\n }\n\n # Add units\n if (!is.null(yunits)) {\n if (is.null(yunits_col)) {\n yunits_col <- if (length(y) == 1) {\n palette[[1]]\n } else {\n \"#00ff00\"\n }\n }\n yunits <- paste0(\n \"(\",\n '',\n yunits,\n \"\",\n \")\"\n )\n ynames <- paste(ynames, yunits)\n }\n if (!is.null(y2units)) {\n if (is.null(y2units_col)) {\n y2units_col <- if (length(y2) == 1) {\n palette[[length(x) + 1]]\n } else {\n \"#ff0000\"\n }\n }\n y2units <- paste0(\n \"(\",\n '',\n y2units,\n \"\",\n \")\"\n )\n y2names <- paste(y2names, y2units)\n }\n\n # Theme ----\n check_is_S7(theme, Theme)\n\n bg <- plotly::toRGB(theme[[\"bg\"]])\n plot_bg <- plotly::toRGB(theme[[\"plot_bg\"]])\n grid_col <- plotly::toRGB(theme[[\"grid_col\"]], theme[[\"grid_alpha\"]])\n tick_col <- plotly::toRGB(theme[[\"tick_col\"]])\n legend_col <- labs_col <- plotly::toRGB(theme[[\"labs_col\"]])\n main_col <- plotly::toRGB(theme[[\"main_col\"]])\n if (!theme[[\"axes_visible\"]]) {\n tick_col <- labs_col <- \"transparent\"\n }\n if (is.null(spike_col)) {\n spike_col <- theme[[\"fg\"]]\n }\n zero_col <- adjustcolor(theme[[\"zerolines_col\"]], theme[[\"zerolines_alpha\"]])\n\n # Colors ----\n # if (is.null(line1.fill.col)) line1.fill.col <- plotly::toRGB(line1.col, alpha = 0.4)\n # if (is.null(line2.fill.col) && !is.null(y2)) {\n # line2.fill.col <- plotly::toRGB(line2.col, alpha = 0.4)\n # }\n palette_y <- palette[seq_along(y)]\n palette_y2 <- palette[length(y) + seq_along(y2)]\n\n if (length(y) > 1 && length(yfill) == 1) {\n yfill <- rep(yfill, length(y))\n }\n stopifnot(length(yfill) == length(y))\n\n if (length(y2) > 1 && length(y2fill) == 1) {\n y2fill <- rep(y2fill, length(y2))\n }\n\n if (!is.null(y2)) {\n stopifnot(length(y2fill) == length(y2))\n }\n\n # Fonts ----\n f <- list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = labs_col\n )\n tick_font <- list(\n family = theme[[\"font_family\"]],\n size = tickfont_size,\n color = theme[[\"tick_labels_col\"]]\n )\n\n # Calculate shade_interval from shade_bin ----\n if (!is.null(shade_bin)) {\n shade_bin_p <- c(0, shade_bin, 0)\n shade_bin_starts <- which(diff(shade_bin_p) == 1)\n shade_bin_ends <- which(diff(shade_bin_p) == -1)\n shade_interval <- lapply(\n seq_along(shade_bin_starts),\n \\(i) c(shade_bin_starts[i], shade_bin_ends[i])\n )\n }\n\n # zt ----\n if (show_zt && !is.null(zt)) {\n x_tickmode <- \"array\"\n if (is.null(show_zt_every)) {\n # Get periodicity of ZT\n idi0 <- which(zt == 0)\n # Get differences between 0s\n diff_idi0 <- diff(idi0)[1]\n # Pick show.zt.every to be perfect divisor of diff_idi0 so that total length is closest to zt.nticks\n # a) diff_idi0 %% show.zt.every must be 0\n # b) length(zt) / show.zt.every must be closest to zt.nticks\n sze <- round(length(zt) / zt_nticks)\n i <- 0\n # if diff_idi0 %% sze != 0, search for closest integer above or below sze\n sze_high <- sze_low <- sze\n while (diff_idi0 %% sze_low != 0) {\n sze_low <- sze_low - 1\n }\n while (diff_idi0 %% sze_high != 0) {\n sze_high <- sze_high + 1\n }\n show_zt_every <- c(sze_low, sze_high)[which.min(abs(c(\n sze - sze_low,\n sze - sze_high\n )))]\n }\n idi <- seq(1, length(zt), by = show_zt_every)\n # Make sure 0 is included\n while (!0 %in% zt[idi]) {\n idi <- idi + 1\n }\n idi <- idi[idi <= length(zt)]\n x_tickvals <- x[[1]][idi]\n x_ticktext <- zt[idi]\n if (is.null(xlab)) xlab <- \"ZT\"\n }\n\n # Plot ----\n plt <- plotly::plot_ly(type = \"scatter\", mode = \"lines\")\n\n # Shade intervals ----\n if (!is.null(shade_interval)) {\n if (is.null(shade_x)) {\n shade_x <- x[[1]]\n }\n if (is.null(shade_col)) {\n shade_col <- plotly::toRGB(theme[[\"fg\"]], 0.15)\n }\n ymax <- max(unlist(y), unlist(y2))\n # Draw shaded rectangles\n for (i in seq_along(shade_interval)) {\n plt <- plotly::add_trace(\n plt,\n x = c(\n shade_x[shade_interval[[i]][1]],\n shade_x[shade_interval[[i]][2]],\n shade_x[shade_interval[[i]][2]],\n shade_x[shade_interval[[i]][1]]\n ),\n y = c(0, 0, ymax, ymax),\n fill = \"toself\",\n fillcolor = shade_col,\n line = list(color = \"transparent\"),\n yaxis = \"y\",\n xaxis = \"x\",\n name = shade_name,\n legendgroup = if (shade_showlegend) shade_name else NULL,\n showlegend = shade_showlegend && i == 1\n )\n }\n } # /shade.interval\n\n for (i in seq_along(y)) {\n plt <- plotly::add_trace(\n plt,\n x = x[[i]],\n y = y[[i]],\n line = list(color = palette_y[[i]], width = yline_width),\n fill = yfill[[i]],\n fillcolor = plotly::toRGB(palette_y[[i]], alpha = fill_alpha),\n name = ynames[[i]],\n legendgroup = if (!is.null(y2)) \"legend_y\" else NULL\n )\n } # /y scatter\n\n if (!is.null(y2)) {\n for (i in seq_along(y2)) {\n plt <- plotly::add_trace(\n plt,\n x = x2[[i]],\n y = y2[[i]],\n line = list(color = palette_y2[[i]], width = y2line_width),\n fill = y2fill[[i]],\n fillcolor = plotly::toRGB(palette_y2[[i]], alpha = fill_alpha),\n name = y2names[[i]],\n legendgroup = \"legend_y2\",\n yaxis = \"y2\"\n )\n }\n } # /y2 scatter\n\n # Labels ----\n if (is.null(xlab)) {\n xlab <- .xname\n }\n if (!is.null(xunits)) {\n xlab <- paste0(xlab, \" (\", xunits, \")\")\n }\n\n if (!is.null(yunits)) {\n ylab <- if (is.null(ylab)) {\n if (length(y) == 1) {\n ynames\n } else {\n yunits\n }\n } else {\n paste(ylab, yunits)\n }\n }\n\n if (!is.null(y2units)) {\n y2lab <- if (is.null(y2lab)) {\n if (length(y2) == 1) {\n y2names\n } else {\n y2units\n }\n } else {\n paste(y2lab, y2units)\n }\n }\n\n # Layout ----\n plt <- plotly::layout(\n plt,\n xaxis = list(\n title = list(\n text = xlab,\n standoff = x_standoff,\n font = f\n ),\n nticks = x_nticks,\n showspikes = x_showspikes,\n spikedash = spike_dash,\n spikecolor = spike_col,\n spikethickness = x_spike_thickness,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickmode = x_tickmode,\n tickvals = x_tickvals,\n ticktext = x_ticktext,\n tickangle = x_tickangle,\n tickcolor = tick_col,\n tickfont = tick_font,\n zeroline = theme[[\"zerolines\"]],\n zerolinecolor = zero_col,\n zerolinewidth = theme[[\"zerolines_lwd\"]]\n ), # /layout > xaxis\n yaxis = list(\n title = list(\n text = ylab,\n standoff = y_standoff,\n font = f\n ),\n nticks = y_nticks,\n showgrid = theme[[\"grid\"]],\n gridcolor = grid_col,\n gridwidth = theme[[\"grid_lwd\"]],\n tickcolor = tick_col,\n tickfont = tick_font,\n zeroline = theme[[\"zerolines\"]],\n zerolinecolor = zero_col,\n zerolinewidth = theme[[\"zerolines_lwd\"]],\n standoff = y_standoff\n ), # /layout > yaxis\n title = list(\n text = main,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = main_col\n ),\n xref = \"paper\",\n x = theme[[\"main_adj\"]],\n yref = \"paper\",\n y = main_y,\n yanchor = main_yanchor\n ),\n legend = list(\n x = legend_x,\n y = legend_y,\n xanchor = legend_xanchor,\n yanchor = legend_yanchor,\n font = list(\n family = theme[[\"font_family\"]],\n size = font_size,\n color = legend_col\n ),\n orientation = legend_orientation,\n bgcolor = \"#ffffff00\"\n ), # /layout > legend\n paper_bgcolor = bg,\n plot_bgcolor = plot_bg,\n margin = margin,\n hovermode = hovermode\n ) # /layout\n\n if (!is.null(y2)) {\n plt <- plt |>\n plotly::layout(\n yaxis2 = list(\n overlaying = \"y\",\n side = \"right\",\n title = list(\n text = y2lab,\n standoff = y2_standoff,\n font = f\n ),\n tickfont = tick_font\n )\n )\n } # /yaxis2 layout\n\n # Config ----\n plt <- plotly::config(\n plt,\n displaylogo = FALSE,\n displayModeBar = displayModeBar,\n toImageButtonOptions = list(\n format = modeBar_file_format,\n width = file_width,\n height = file_height\n ),\n scrollZoom = scrollZoom\n ) # /config\n\n # Write to file ----\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n } # /export_plotly\n\n # Rangeslider ----\n if (show_rangeslider) {\n if (is.null(slider_start)) {\n slider_start <- x[[1]][1]\n }\n if (is.null(slider_end)) {\n idi <- min(500, length(x[[1]]))\n slider_end <- x[[1]][idi]\n }\n plt <- plt |>\n plotly::rangeslider(start = slider_start, end = slider_end)\n } # /rangeslider\n\n return(plt)\n} # /rtemis::draw_xt\n\n# tickmode = \"array\", tickvals: placement, ticktext: labels\n" }, { "path": "R/fmt.R", "content": "# fmt.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% fmt ----\n#' Text formatting\n#'\n#' Formats text with specified color, styles, and background using ANSI escape codes or HTML, with support for plain text output.\n#'\n#' @param x Character: Text to format.\n#' @param col Optional Character: Color using hex code or name. If NULL, no color is applied.\n#' @param bold Logical: If TRUE, make text bold.\n#' @param italic Logical: If TRUE, make text italic.\n#' @param underline Logical: If TRUE, underline text.\n#' @param thin Logical: If TRUE, make text thin/light.\n#' @param muted Logical: If TRUE, make text muted/dimmed.\n#' @param bg Optional Character: Background color using hex code or name. If NULL, no background\n#' color is applied.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted text with specified styling.\n#'\n#' @details\n#' This function combines multiple formatting options into a single call,\n#' making it more efficient than nested function calls. It generates\n#' optimized ANSI escape sequences and clean HTML output.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' # Simple color\n#' fmt(\"Hello\", col = \"red\")\n#'\n#' # Bold red text\n#' fmt(\"Error\", col = \"red\", bold = TRUE)\n#'\n#' # Multiple styles\n#' fmt(\"Warning\", col = \"yellow\", bold = TRUE, italic = TRUE)\n#'\n#' # With background\n#' fmt(\"Highlight\", col = \"white\", bg = \"blue\", bold = TRUE)\nfmt <- function(\n x,\n col = NULL,\n bold = FALSE,\n italic = FALSE,\n underline = FALSE,\n thin = FALSE,\n muted = FALSE,\n bg = NULL,\n pad = 0L,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n\n out <- switch(\n output_type,\n \"ansi\" = {\n codes <- character()\n\n # Style codes\n if (bold) {\n codes <- c(codes, \"1\")\n } else {\n # Explicitly set normal weight to override message() bold default\n codes <- c(codes, \"22\")\n }\n if (thin || muted) {\n codes <- c(codes, \"2\")\n } # Both use dim/faint\n if (italic) {\n codes <- c(codes, \"3\")\n }\n if (underline) {\n codes <- c(codes, \"4\")\n }\n\n # Foreground color\n if (!is.null(col)) {\n tryCatch(\n {\n col_rgb <- col2rgb(col)\n codes <- c(\n codes,\n paste0(\"38;2;\", col_rgb[1], \";\", col_rgb[2], \";\", col_rgb[3])\n )\n },\n error = function(e) {\n warning(\"Invalid color '\", col, \"', ignoring color\")\n }\n )\n }\n\n # Background color\n if (!is.null(bg)) {\n tryCatch(\n {\n bg_rgb <- col2rgb(bg)\n codes <- c(\n codes,\n paste0(\"48;2;\", bg_rgb[1], \";\", bg_rgb[2], \";\", bg_rgb[3])\n )\n },\n error = function(e) {\n warning(\"Invalid background color '\", bg, \"', ignoring background\")\n }\n )\n }\n\n # Generate ANSI sequence\n if (length(codes) > 0) {\n paste0(\"\\033[\", paste(codes, collapse = \";\"), \"m\", x, \"\\033[0m\")\n } else {\n x\n }\n },\n \"html\" = {\n styles <- character()\n\n # Colors\n if (!is.null(col)) {\n styles <- c(styles, paste0(\"color: \", col))\n }\n if (!is.null(bg)) {\n styles <- c(styles, paste0(\"background-color: \", bg))\n }\n\n # Styles\n if (bold) {\n styles <- c(styles, \"font-weight: bold\")\n }\n if (thin) {\n styles <- c(styles, \"font-weight: lighter\")\n }\n if (muted) {\n styles <- c(styles, \"color: gray\")\n } # Override color for muted\n if (italic) {\n styles <- c(styles, \"font-style: italic\")\n }\n if (underline) {\n styles <- c(styles, \"text-decoration: underline\")\n }\n\n # Generate HTML span\n if (length(styles) > 0) {\n paste0(\n '',\n x,\n \"\"\n )\n } else {\n x\n }\n },\n \"plain\" = x\n ) # /switch\n if (pad > 0L) {\n out <- paste0(strrep(\" \", pad), out)\n }\n out\n} # /rtemis::fmt\n\n\n# %% highlight ----\n#' Highlight text\n#'\n#' A `fmt()` convenience wrapper for highlighting text.\n#'\n#' @param x Character: Text to highlight.\n#' @param pad Integer: Number of spaces to pad before text.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted text with highlight.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nhighlight <- function(\n x,\n pad = 0L,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n fmt(x, col = highlight_col, bold = TRUE, pad = pad, output_type = output_type)\n} # /rtemis::highlight\n\n\n# %% highlight2 ----\nhighlight2 <- function(\n x,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n fmt(x, col = highlight2_col, bold = FALSE, output_type = output_type)\n} # /rtemis::highlight2\n\n\n# %% bold ----\n#' Make text bold\n#'\n#' A `fmt()` convenience wrapper for making text bold.\n#'\n#' @param text Character: Text to make bold\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted text with bold styling\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nbold <- function(text, output_type = c(\"ansi\", \"html\", \"plain\")) {\n fmt(text, bold = TRUE, output_type = output_type)\n} # /rtemis::bold\n\n\n# %% italic ----\n#' Make text italic\n#'\n#' A `fmt()` convenience wrapper for making text italic.\n#'\n#' @param text Character: Text to make italic\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted text with italic styling\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nitalic <- function(text, output_type = c(\"ansi\", \"html\", \"plain\")) {\n fmt(text, italic = TRUE, output_type = output_type)\n} # /rtemis::italic\n\n\n# %% underline ----\n#' Make text underlined\n#'\n#' A `fmt()` convenience wrapper for making text underlined.\n#'\n#' @param text Character: Text to underline\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted text with underline styling\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nunderline <- function(text, output_type = c(\"ansi\", \"html\", \"plain\")) {\n fmt(text, underline = TRUE, output_type = output_type)\n} # /rtemis::underline\n\n\n# %% thin ----\n#' Make text thin/light\n#'\n#' A `fmt()` convenience wrapper for making text thin/light.\n#'\n#' @param text Character: Text to make thin\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted text with thin/light styling\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nthin <- function(text, output_type = c(\"ansi\", \"html\", \"plain\")) {\n fmt(text, thin = TRUE, output_type = output_type)\n} # /rtemis::thin\n\n\n# %% muted ----\n#' Muted text\n#'\n#' A `fmt()` convenience wrapper for making text muted.\n#'\n#' @param x Character: Text to format\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted text with muted styling\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmuted <- function(x, output_type = c(\"ansi\", \"html\", \"plain\")) {\n fmt(x, muted = TRUE, output_type = output_type)\n} # /rtemis::muted\n\n\n# %% gray ----\n#' Gray text\n#'\n#' A `fmt()` convenience wrapper for making text gray.\n#'\n#' @param x Character: Text to format\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted text with gray styling\n#'\n#' @details\n#' Can be useful in contexts where muted is not supported.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ngray <- function(x, output_type = c(\"ansi\", \"html\", \"plain\")) {\n fmt(x, col = \"#808080\", output_type = output_type)\n} # /rtemis::gray\n\n\n# %% col256 ----\n#' Apply 256-color formatting\n#'\n#' @param text Character: Text to color\n#' @param col Character or numeric: Color (ANSI 256-color code, hex for HTML)\n#' @param bg Logical: If TRUE, apply as background color\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted text with 256-color styling\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncol256 <- function(\n text,\n col = \"79\",\n bg = FALSE,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n\n switch(\n output_type,\n \"ansi\" = {\n if (bg) {\n paste0(\"\\033[48;5;\", col, \"m\", text, \"\\033[0m\")\n } else {\n paste0(\"\\033[38;5;\", col, \"m\", text, \"\\033[0m\")\n }\n },\n \"html\" = {\n # Convert ANSI color codes to hex colors if needed\n hex_col <- if (\n is.numeric(col) || (is.character(col) && !grepl(\"^#\", col))\n ) {\n ansi256_to_hex(col)\n } else {\n col\n }\n if (bg) {\n paste0(\n '',\n text,\n \"\"\n )\n } else {\n paste0('', text, \"\")\n }\n },\n \"plain\" = text\n )\n} # /rtemis::col256\n\n\n# %% ansi256_to_hex ----\n#' Convert ANSI 256 color code to HEX\n#'\n#' @param code Integer: ANSI 256 color code (0-255).\n#'\n#' @return Character: HEX color string.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nansi256_to_hex <- function(code) {\n code <- as.integer(code)\n if (is.na(code) || code < 0 || code > 255) {\n return(\"#000000\") # Return black for invalid codes\n }\n\n # Standard and high-intensity colors (0-15)\n if (code < 16) {\n return(c(\n \"#000000\",\n \"#cd0000\",\n \"#00cd00\",\n \"#cdcd00\",\n \"#0000ee\",\n \"#cd00cd\",\n \"#00cdcd\",\n \"#e5e5e5\",\n \"#7f7f7f\",\n \"#ff0000\",\n \"#00ff00\",\n \"#ffff00\",\n \"#5c5cff\",\n \"#ff00ff\",\n \"#00ffff\",\n \"#ffffff\"\n )[code + 1])\n }\n\n # 6x6x6 color cube (16-231)\n if (code >= 16 && code <= 231) {\n code <- code - 16\n r <- floor(code / 36)\n g <- floor((code %% 36) / 6)\n b <- code %% 6\n levels <- c(0, 95, 135, 175, 215, 255) # xterm levels\n return(grDevices::rgb(\n levels[r + 1],\n levels[g + 1],\n levels[b + 1],\n maxColorValue = 255\n ))\n }\n\n # Grayscale ramp (232-255)\n gray_level <- (code - 232) * 10 + 8\n grDevices::rgb(\n gray_level,\n gray_level,\n gray_level,\n maxColorValue = 255\n )\n} # /rtemis::ansi256_to_hex\n\n\n# %% fmt_gradient ----\n#' Gradient text\n#'\n#' @param x Character: Text to colorize.\n#' @param colors Character vector: Colors to use for the gradient.\n#' @param bold Logical: If TRUE, make text bold.\n#' @param space Character {\"rgb\", \"Lab\"}: Color space for gradient interpolation.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Text with gradient color applied.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nfmt_gradient <- function(\n x,\n colors,\n bold = FALSE,\n space = \"Lab\",\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n\n if (output_type == \"plain\") {\n return(x)\n }\n\n # Split text into individual characters\n chars <- strsplit(x, \"\")[[1]]\n n_chars <- length(chars)\n\n if (n_chars <= 1) {\n # For single character or empty string, use first color\n return(fmt(x, col = colors[1], output_type = output_type))\n }\n\n # Generate gradient colors using colorRampPalette\n tryCatch(\n {\n gradient_colors <- grDevices::colorRampPalette(colors, space = space)(\n n_chars\n )\n },\n error = function(e) {\n warning(\"Invalid gradient colors, using default\")\n x\n }\n )\n\n # Apply gradient colors to each character\n gradient_chars <- character(n_chars)\n for (i in seq_len(n_chars)) {\n gradient_chars[i] <- fmt(\n chars[i],\n col = gradient_colors[i],\n bold = bold,\n output_type = output_type\n )\n }\n\n # Combine all colored characters\n paste(gradient_chars, collapse = \"\")\n} # /rtemis::fmt_gradient\n\n\n# %% map_value_to_color ----\n#' Map numeric value to color\n#'\n#' Maps a numeric value to a color based on a specified range and color palette using `fmt`\n#' for formatting. Useful for visualizing numeric values in text output.\n#'\n#' @param x Numeric: Value to map to a color.\n#' @param range Numeric vector of length 2: Minimum and maximum values for mapping.\n#' @param colors Character vector: Colors to use for the gradient mapping.\n#' @param space Character {\"rgb\", \"Lab\"}: Color space for gradient interpolation.\n#' @param bold Logical: If TRUE, make text bold.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted text with color corresponding to the numeric value.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmap_value_to_color <- function(\n x,\n range = c(0, 1),\n colors = c(\"#ff9f20\", \"#00b2b2\"),\n space = \"Lab\",\n bold = TRUE,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n if (output_type == \"plain\") {\n return(as.character(x))\n }\n if (!is.numeric(x) || length(x) != 1L || is.na(x)) {\n cli::cli_abort(\"`x` must be a single non-missing numeric value.\")\n }\n if (!is.numeric(range) || length(range) != 2L || anyNA(range)) {\n cli::cli_abort(\n \"`range` must be a numeric vector of length 2 with no missing values.\"\n )\n }\n if (range[1] >= range[2]) {\n cli::cli_abort(\"`range[1]` must be strictly less than `range[2]`.\")\n }\n if (!is.character(colors) || length(colors) < 2L || anyNA(colors)) {\n cli::cli_abort(\n \"`colors` must be a character vector of at least 2 non-missing colors.\"\n )\n }\n # Check x is within range\n if (x < range[1] || x > range[2]) {\n cli::cli_abort(\n \"Value {x} is out of range [{range[1]}, {range[2]}]\"\n )\n }\n\n n_colors <- 256L\n gradient <- tryCatch(\n {\n grDevices::colorRampPalette(colors, space = space)(n_colors)\n },\n error = function(e) {\n cli::cli_abort(\"Invalid `colors` specification.\")\n }\n )\n\n p <- (x - range[1]) / (range[2] - range[1])\n idx <- as.integer(round(p * (n_colors - 1L))) + 1L\n idx <- max(1L, min(n_colors, idx))\n\n fmt(\n as.character(x),\n col = gradient[idx],\n bold = bold,\n output_type = output_type\n )\n} # /rtemis::map_value_to_color\n" }, { "path": "R/ifw.R", "content": "# ifw.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n#' Inverse Frequency Weighting\n#'\n#' @param y Vector: Outcome\n#' @param type Character: \"case_weights\" or \"class_weights\". What to return.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Numeric vector of weights.\n#'\n#' @keywords internal\n#' @noRd\n#' @author EDG\n#'\n#' @examples\n#' y <- factor(sample(c(\"A\", \"B\"), size = 100, replace = TRUE, prob = c(.1, .9)))\n#' ifw(y)\n#' ifw(y, type = \"class_weights\")\nifw <- function(y, type = c(\"case_weights\", \"class_weights\"), verbosity = 1L) {\n stopifnot(is.factor(y))\n type <- match.arg(type)\n if (verbosity > 0L) {\n msg(\n \"Calculating\",\n sub(\"_\", \" \", type),\n \"using Inverse Frequency Weighting.\"\n )\n }\n\n # Class weights ----\n inverse_proportions <- 1 / (table(y) / NROW(y))\n class_weights <- structure(\n as.numeric(inverse_proportions / min(inverse_proportions)),\n names = names(inverse_proportions)\n )\n\n if (type == \"class_weights\") {\n out <- class_weights\n stopifnot(length(out) == nlevels(y))\n } else {\n out <- class_weights[as.integer(y)]\n stopifnot(length(out) == length(y))\n }\n out\n} # /rtemis::ifw\n" }, { "path": "R/massGLM.R", "content": "# massGLM.R\n# ::rtemis::\n# 2021- EDG rtemis.org\n\n#' Mass-univariate GLM Analysis\n#'\n#' @param x tabular data: Predictor variables. Usually a small number of covariates.\n#' @param y data.frame or similar: Each column is a different outcome. The function will train one\n#' GLM for each column of `y`. Usually a large number of features.\n#' @param scale_y Logical: If TRUE, scale each column of `y` to have mean 0 and sd 1. If `NULL`,\n#' defaults to TRUE if `y` is numeric, FALSE otherwise.\n#' @param center_y Logical: If TRUE, center each column of `y` to have mean 0. If `NULL`, defaults\n#' to TRUE if `scale_y` is TRUE, FALSE otherwise.\n# @param include_anova Logical: If TRUE, include ANOVA results in the summary.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `MassGLM` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' set.seed(2022)\n#' y <- rnormmat(500, 40, return_df = TRUE)\n#' x <- data.frame(\n#' x1 = y[[3]] - y[[5]] + y[[14]] + rnorm(500),\n#' x2 = y[[21]] + rnorm(500)\n#' )\n#' massmod <- massGLM(x, y)\n#' # Print table of coefficients, p-values, etc. for all models\n#' summary(massmod)\nmassGLM <- function(\n x,\n y,\n scale_y = NULL,\n center_y = NULL,\n # include_anova = TRUE,\n verbosity = 1L\n) {\n # Init ----\n start_time <- intro(verbosity = verbosity)\n\n # Check y ----\n # all y columns must be numeric or all factors with 2 levels\n y_class <- sapply(y, class)\n if (y_class[1] == \"numeric\") {\n # Check all are numeric\n if (!all(y_class == \"numeric\")) {\n cli::cli_abort(\n \"All columns of y must be the same type: either numeric or factors with 2 levels\"\n )\n }\n .family <- \"gaussian\"\n } else if (y_class[1] == \"factor\") {\n n_levels <- sapply(y, nlevels)\n if (!all(n_levels == 2)) {\n cli::cli_abort(\"All factor columns of y must have 2 levels\")\n }\n .family <- \"binomial\"\n } else {\n cli::cli_abort(\n \"All columns of y must be either numeric or factors with 2 levels. Found: {.val {y_class}}\"\n )\n }\n\n # Preprocessing ----\n if (is.null(scale_y)) {\n scale_y <- if (y_class[1] == \"numeric\") {\n TRUE\n } else {\n FALSE\n }\n }\n if (is.null(center_y)) {\n center_y <- if (scale_y) {\n TRUE\n } else {\n FALSE\n }\n }\n if (scale_y || center_y) {\n y <- preprocess(\n y,\n config = setup_Preprocessor(scale = scale_y, center = center_y),\n verbosity = verbosity\n )[[\"preprocessed\"]]\n }\n\n # Data ----\n xnames <- colnames(x)\n ynames <- colnames(y)\n dat <- data.table(x, y)\n\n # fit1: Loop function ----\n fit1 <- function(index, dat, family, ynames) {\n formula1 <- as.formula(paste(\n ynames[index],\n \"~\",\n paste(xnames, collapse = \" + \")\n ))\n mod1 <- glm(formula1, family = family, data = dat)\n glm2table(list(mod1), xnames = ynames[index], include_anova = NA)\n }\n\n # Fit models ----\n if (verbosity > 0L) {\n msg(\n \"Fitting\",\n highlight(length(ynames)),\n \"GLMs of family\",\n bold(.family),\n \"with\",\n highlight(length(xnames)),\n ngettext(length(xnames), \"predictor\", \"predictors\"),\n \"each...\"\n )\n }\n tbls <- lapply(\n cli::cli_progress_along(seq_along(y), name = \"GLMs\", type = \"tasks\"),\n function(i) {\n fit1(index = i, dat = dat, family = .family, ynames = ynames)\n }\n )\n tbl <- rbindlist(tbls)\n\n # MassGLM ----\n # ynames should be the same as tbl[[\"Variable\"]]\n # <> Check in MassGLM constructor\n if (!all(ynames == tbl[[\"Variable\"]])) {\n cli::cli_warn(c(\n \"The names of the outcome variables in y ({.val ynames}) do not match the names in the summary table ({.val summary[['Variable']]})\",\n \"Check the summary table.\"\n ))\n }\n outro(start_time)\n MassGLM(\n summary = tbl,\n ynames = ynames,\n xnames = xnames,\n coefnames = gsub(\"Coefficient_\", \"\", getnames(tbl, \"Coefficient\")),\n family = .family\n )\n} # /rtemis::massGLM\n" }, { "path": "R/metrics.R", "content": "# metrics.R\n# ::rtemis::\n# 2019- EDG rtemis.org\n\n#' Error functions\n#'\n#' Convenience functions for calculating loss.\n#' These can be passed as arguments to learners that support custom loss functions.\n#'\n#' @rdname error\n#' @param x Vector of True values\n#' @param y Vector of predicted values\n#' @param na.rm Logical: If TRUE, remove NA values before computation.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmae <- function(x, y, na.rm = TRUE) {\n error <- x - y\n mean(abs(error), na.rm = na.rm)\n} # /rtemis::mae\n\n#' @rdname error\n#' @keywords internal\n#' @noRd\nmse <- function(x, y, na.rm = TRUE) {\n error <- x - y\n mean(error^2, na.rm = na.rm)\n} # /rtemis::mse\n\n#' Weighted MSE\n#'\n#' @rdname error\n#' @keywords internal\n#' @noRd\nmsew <- function(x, y, weights = rep(1, length(y)), na.rm = TRUE) {\n error <- x - y\n error <- error * weights\n mean(error^2, na.rm = na.rm)\n} # /rtemis::msew\n\n#' @rdname error\n#' @keywords internal\n#' @noRd\nrmse <- function(x, y, na.rm = TRUE) {\n sqrt(mse(x, y, na.rm = na.rm))\n} # /rtemis::rmse\n\n#' R-squared\n#'\n#' @param x Float, vector: True values\n#' @param y Float, vector: predicted values\n#' @author EDG\n#' @keywords internal\n#' @noRd\nrsq <- function(x, y) {\n SSE <- sum((x - y)^2)\n # Sum of Squares due to Regression (SSR) a.k.a. Explained Sum of Squares (ESS)\n # SSR <- sum((mean(x) - y)^2)\n # Total Sum of Squares (TSS or SST)\n SST <- sum((x - mean(x))^2)\n # R-squared a.k.a. Coefficient of Determination i.e. percent variance explained\n 1 - (SSE / SST)\n} # /rtemis::rsq\n\n\n#' Log Loss for a binary classifier\n#'\n#' @param true_int Integer vector, {0, 1}: True labels (1 is the positive class).\n#' @param predicted_prob Float, vector: predicted probabilities.\n#' @param eps Float: Small value to prevent log(0).\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nlogloss <- function(true_int, predicted_prob, eps = 1e-16) {\n predicted_prob <- pmax(pmin(predicted_prob, 1 - eps), eps)\n -mean(\n true_int * log(predicted_prob) + (1 - true_int) * log(1 - predicted_prob)\n )\n} # /rtemis::logloss\n\n\n#' Sensitivity\n#'\n#' The first factor level is considered the positive case.\n#'\n#' @param true Factor: True labels.\n#' @param predicted Factor: Predicted labels.\n#' @param harmonize Logical: If TRUE, run `factor_harmonize` first.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nsensitivity <- function(true, predicted, harmonize = FALSE, verbosity = 1L) {\n if (harmonize) {\n predicted <- factor_harmonize(true, predicted, verbosity = verbosity)\n }\n pos_index <- true == levels(true)[1]\n condition_pos <- sum(pos_index)\n true_pos <- sum(true[pos_index] == predicted[pos_index])\n true_pos / condition_pos\n}\n\n\n#' Specificity\n#'\n#' The first factor level is considered the positive case.\n#'\n#' @param true True labels\n#' @param predicted predicted labels\n#' @param harmonize Logical: If TRUE, run `factor_harmonize` first\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @keywords internal\n#' @noRd\nspecificity <- function(true, predicted, harmonize = FALSE, verbosity = 1L) {\n if (harmonize) {\n predicted <- factor_harmonize(true, predicted, verbosity = verbosity)\n }\n neg_index <- true == levels(true)[2]\n condition_neg <- sum(neg_index)\n true_neg <- sum(true[neg_index] == predicted[neg_index])\n true_neg / condition_neg\n}\n\n#' Balanced Accuracy\n#'\n#' Balanced Accuracy of a binary classifier\n#'\n#' BAcc = .5 * (Sensitivity + Specificity)\n#'\n#' @param true Factor: True labels.\n#' @param predicted Factor: Predicted labels.\n#' @param harmonize Logical: passed to `sensitivity()` and `specificity`, which use `factor_harmonize`.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @keywords internal\n#' @noRd\nbacc <- function(true, predicted, harmonize = FALSE, verbosity = 1L) {\n 0.5 *\n (sensitivity(\n true,\n predicted,\n harmonize = harmonize,\n verbosity = verbosity\n ) +\n specificity(\n true,\n predicted,\n harmonize = harmonize,\n verbosity = verbosity\n ))\n} # /rtemis::bacc\n\n#' Precision (aka PPV)\n#'\n#' The first factor level is considered the positive case.\n#'\n#' @param true Factor: True labels\n#' @param predicted Factor: predicted labels\n#' @param harmonize Logical: If TRUE, run `factor_harmonize` first\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @keywords internal\n#' @noRd\nprecision <- function(true, predicted, harmonize = FALSE, verbosity = 1L) {\n if (harmonize) {\n predicted <- factor_harmonize(true, predicted, verbosity = verbosity)\n }\n tbl <- table(predicted, true)\n predicted_totals <- rowSums(tbl)[1]\n hits <- diag(tbl)[1]\n\n if (hits == 0 && predicted_totals == 0) {\n 1\n } else {\n hits / predicted_totals\n }\n} # /rtemis::precision\n\n#' Factor harmonize\n#'\n#' @param reference Reference factor.\n#' @param x Input factor.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Factor: x with levels in the same order as reference.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nfactor_harmonize <- function(reference, x, verbosity = 1L) {\n if (!is.factor(x) || !is.factor(reference)) {\n cli::cli_abort(\"Inputs must be factors\")\n }\n if (!all(levels(x) == levels(reference))) {\n if (!all(levels(x) %in% levels(reference))) {\n if (verbosity > 0L) {\n msg(\"Levels of x:\")\n }\n levels(x)\n if (verbosity > 0L) {\n msg(\"levels of reference:\")\n }\n levels(reference)\n cli::cli_abort(\"Levels of two inputs do not match\")\n }\n if (verbosity > 0L) {\n msg(\"Input factor levels are not in the same order, correcting\")\n }\n x <- factor(x, levels = levels(reference))\n }\n x\n} # /rtemis::factor_harmonize\n\n\n#' F1 score\n#'\n#' Calculate the F1 score for classification:\n#'\n#' \\deqn{F1 = 2 \\frac{Recall \\cdot Precision}{Recall + Precision}}{F1 = 2 * (Recall * Precision)/(Recall + Precision)}\n#'\n#' @param recall Float \\[0, 1\\]: Recall a.k.a. Sensitivity\n#' @param precision Float \\[0, 1\\]: Precision a.k.a. Positive Predictive Value\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nf1 <- function(precision, recall) {\n 2 * (recall * precision) / (recall + precision)\n} # /rtemis::f1\n\n\n# auc.R\n# ::rtemis::\n# 2019-23 EDG rtemis.org\n\n#' Area under the ROC Curve\n#'\n#' Get the Area under the ROC curve to assess classifier performance.\n#'\n#' @param true_int Integer vector: True labels of outcomes (e.g. c(0, 1, 1))\n#' @param predicted_prob Numeric Vector: Probabilities or model scores\n#' (e.g. c(.32, .75, .63), etc)\n#' @param method Character {\"lightAUC\" \"ROCR\"}: Package to use.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Numeric.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' preds <- c(0.7, 0.55, 0.45, 0.25, 0.6, 0.7, 0.2)\n#' labels <- 2L - as.integer(factor(c(\"a\", \"a\", \"a\", \"b\", \"b\", \"b\", \"b\")))\n#' auc(labels, preds, method = \"lightAUC\")\n#' auc(labels, preds, method = \"ROCR\")\nauc <- function(\n true_int,\n predicted_prob,\n method = c(\"lightAUC\", \"ROCR\"),\n verbosity = 0L\n) {\n # Checks ----\n method <- match.arg(method)\n check_inherits(true_int, \"integer\")\n check_float01inc(predicted_prob)\n # method <- match.arg(method)\n if (length(unique(true_int)) == 1) {\n return(NaN)\n }\n if (method == \"lightAUC\") {\n check_dependencies(\"lightAUC\")\n auc. <- lightAUC::lightAUC(probs = predicted_prob, actuals = true_int)\n } else if (method == \"ROCR\") {\n check_dependencies(\"ROCR\")\n .pred <- try(ROCR::prediction(\n predicted_prob,\n true_int,\n label.ordering = NULL\n ))\n auc. <- try(ROCR::performance(.pred, \"auc\")@y.values[[1]])\n }\n\n if (inherits(auc., \"try-error\")) {\n auc. <- NaN\n }\n\n if (verbosity > 0L) {\n msg(\"AUC =\", auc.)\n }\n auc.\n} # /rtemis::auc\n\n\n#' Area under the Curve by pairwise concordance\n#'\n#' Get the Area under the ROC curve to assess classifier performance using pairwise concordance\n#'\n#' The first level of `true.labels` must be the positive class, and high numbers in\n#' `estimated.score` should correspond to the positive class.\n#'\n#' @param estimated.score Float, Vector: Probabilities or model scores\n#' (e.g. c(.32, .75, .63), etc)\n#' @param true.labels True labels of outcomes (e.g. c(0, 1, 1))\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @examples\n#' true.labels <- factor(c(\"a\", \"a\", \"a\", \"b\", \"b\", \"b\", \"b\"))\n#' estimated.score <- c(0.7, 0.55, 0.45, 0.25, 0.6, 0.7, 0.2)\n#' auc_pairs(estimated.score, true.labels, verbosity = 1L)\n#'\n#' @keywords internal\n#' @noRd\nauc_pairs <- function(estimated.score, true.labels, verbosity = 1L) {\n true.labels <- as.factor(true.labels)\n true.levels <- levels(true.labels)\n n.levels <- length(true.levels)\n if (n.levels == 2) {\n outer.diff <- outer(\n estimated.score[true.labels == true.levels[1]],\n estimated.score[true.labels == true.levels[2]],\n \"-\"\n )\n .auc <- mean((outer.diff > 0) + .5 * (outer.diff == 0))\n } else {\n cli::cli_abort(\n \"Multiclass AUC does not have a unique definition and is not yet implemented\"\n )\n }\n if (verbosity > 0L) {\n msg(\"Positive class:\", true.levels[1])\n msg(\"AUC =\", .auc)\n }\n invisible(.auc)\n} # /rtemis::auc_pairs\n\n\n#' Brier_Score\n#'\n#' Calculate the Brier_Score for classification:\n#'\n#' \\deqn{BS = \\frac{1}{N} \\sum_{i=1}^{N} (y_i - p_i)^2}{BS = 1/N * sum_{i=1}^{N} (y_i - p_i)^2}\n#'\n#' @param true_int Integer vector, {0, 1}: True labels\n#' @param predicted_prob Numeric vector, \\[0, 1\\]: predicted probabilities\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nbrier_score <- function(true_int, predicted_prob) {\n true_int <- clean_int(true_int)\n check_float01inc(predicted_prob)\n mean((true_int - predicted_prob)^2)\n} # /rtemis::brier_score\n\n#' Convert labels to integers\n#'\n#' Convert factor labels to integers where the positive class is 1 and the negative class is 0.\n#'\n#' @param x Factor: True labels.\n#' @param binclasspos Integer: Position of the factor level which is the positive class (binary classification only).\n#'\n#' @return Integer vector: 0, 1 where 1 is the positive class as defined by binclasspos.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nlabels2int <- function(x, binclasspos = 2L) {\n stopifnot(is.factor(x))\n # Convert factor to 0, 1 where 1 is the positive class as defined by binclasspos\n if (binclasspos == 1L) {\n xi <- 2L - as.integer(x)\n } else {\n xi <- as.integer(x) - 1L\n }\n xi\n} # /rtemis::labels2int\n\n# classification_metrics() ----\n#' Classification Metrics\n#'\n#' @details\n#' Note that auc_method = \"pROC\" is the only one that will output an AUC even if\n#' one or more predicted probabilities are NA.\n#'\n#' @param true_labels Factor: True labels.\n#' @param predicted_labels Factor: predicted values.\n#' @param predicted_prob Numeric vector: predicted probabilities.\n#' @param binclasspos Integer: Factor level position of the positive class in binary classification.\n#' @param calc_auc Logical: If TRUE, calculate AUC. May be slow in very large datasets.\n#' @param calc_brier Logical: If TRUE, calculate Brier_Score.\n#' @param auc_method Character: \"lightAUC\", \"pROC\", \"ROCR\".\n#' @param sample Character: Sample name.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `ClassificationMetrics` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' # Assume positive class is \"b\"\n#' true_labels <- factor(c(\"a\", \"a\", \"a\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\"))\n#' predicted_labels <- factor(c(\"a\", \"b\", \"a\", \"b\", \"b\", \"a\", \"b\", \"b\", \"b\", \"a\"))\n#' predicted_prob <- c(0.3, 0.55, 0.45, 0.75, 0.57, 0.3, 0.8, 0.63, 0.62, 0.39)\n#'\n#' classification_metrics(true_labels, predicted_labels, predicted_prob)\n#' classification_metrics(true_labels, predicted_labels, 1 - predicted_prob, binclasspos = 1L)\nclassification_metrics <- function(\n true_labels,\n predicted_labels,\n predicted_prob = NULL,\n binclasspos = 2L,\n calc_auc = TRUE,\n calc_brier = TRUE,\n auc_method = \"lightAUC\",\n sample = character(),\n verbosity = 0L\n) {\n # Checks ----\n # Binary class probabilities only for now\n if (length(predicted_prob) > length(true_labels)) {\n predicted_prob <- NULL\n }\n n_classes <- nlevels(true_labels)\n\n # Check same levels in\n if (!all(levels(true_labels) == levels(predicted_labels))) {\n cli::cli_abort(\n \"True and predicted labels must have the same levels, in the same order.\",\n \"\\n levels(true_labels): \",\n paste(levels(true_labels), collapse = \", \"),\n \"\\nlevels(predicted_labels): \",\n paste(levels(predicted_labels), collapse = \", \")\n )\n }\n\n # Positive class ----\n # For confusion table, make positive class the first factor level\n if (n_classes == 2 && binclasspos == 2L) {\n true_labels <- factor(true_labels, levels = rev(levels(true_labels)))\n predicted_labels <- factor(\n predicted_labels,\n levels = rev(levels(predicted_labels))\n )\n }\n true_levels <- levels(true_labels)\n\n # Levels already set so that the first level is the positive class\n Positive_Class <- if (n_classes == 2) true_levels[1] else NA\n if (verbosity > 0L) {\n if (n_classes == 2) {\n msg(\n \"There are two outcome classes:\",\n highlight(paste(rev(true_levels), collapse = \", \"))\n )\n msg(\" The positive class is:\", highlight(Positive_Class))\n } else {\n msg(\n \"There are\",\n n_classes,\n \"classes:\",\n highlight(paste(rev(true_levels), collapse = \", \"))\n )\n }\n }\n tbl <- table(true_labels, predicted_labels)\n # attr(tbl, \"dimnames\") <- list(Reference = true_levels, Predicted = true_levels)\n names(attributes(tbl)[[\"dimnames\"]]) <- c(\"Reference\", \"Predicted\")\n\n Class <- list()\n Overall <- list()\n Class[[\"Totals\"]] <- rowSums(tbl)\n Class[[\"Predicted_totals\"]] <- colSums(tbl)\n Total <- sum(tbl)\n Class[[\"Hits\"]] <- diag(tbl)\n # Class[[\"Misses\"]] <- Class[[\"Totals\"]] - Class[[\"Hits\"]]\n Class[[\"Sensitivity\"]] <- Class[[\"Hits\"]] / Class[[\"Totals\"]]\n Class[[\"Condition_negative\"]] <- Total - Class[[\"Totals\"]]\n Class[[\"True_negative\"]] <- Total -\n Class[[\"Predicted_totals\"]] -\n (Class[[\"Totals\"]] - Class[[\"Hits\"]])\n Class[[\"Specificity\"]] <- Class[[\"True_negative\"]] /\n Class[[\"Condition_negative\"]]\n Class[[\"Balanced_Accuracy\"]] <- .5 *\n (Class[[\"Sensitivity\"]] + Class[[\"Specificity\"]])\n # PPV = true positive / predicted condition positive\n Class[[\"PPV\"]] <- Class[[\"Hits\"]] / Class[[\"Predicted_totals\"]]\n # NPV = true negative / predicted condition negative\n Class[[\"NPV\"]] <- Class[[\"True_negative\"]] /\n (Total - Class[[\"Predicted_totals\"]])\n Class[[\"F1\"]] <- 2 *\n (Class[[\"PPV\"]] * Class[[\"Sensitivity\"]]) /\n (Class[[\"PPV\"]] + Class[[\"Sensitivity\"]])\n\n # Binary vs Multiclass ----\n if (n_classes == 2) {\n Overall[[\"Sensitivity\"]] <- Class[[\"Sensitivity\"]][1]\n Overall[[\"Specificity\"]] <- Class[[\"Specificity\"]][1]\n Overall[[\"Balanced_Accuracy\"]] <- Class[[\"Balanced_Accuracy\"]][1]\n Overall[[\"PPV\"]] <- Class[[\"PPV\"]][1]\n Overall[[\"NPV\"]] <- Class[[\"NPV\"]][1]\n Overall[[\"F1\"]] <- Class[[\"F1\"]][1]\n } else {\n Overall[[\"Balanced_Accuracy\"]] <- mean(Class[[\"Sensitivity\"]])\n Overall[[\"F1\"]] <- mean(Class[[\"F1\"]])\n }\n Overall[[\"Accuracy\"]] <- sum(Class[[\"Hits\"]]) / Total\n\n # Probability-based metrics ----\n if (!is.null(predicted_prob) && n_classes == 2L) {\n # Positive class has been set to first level\n true_int <- 2L - as.integer(true_labels)\n if (calc_auc) {\n Overall[[\"AUC\"]] <- auc(\n true_int = true_int,\n predicted_prob = predicted_prob,\n method = auc_method\n )\n }\n if (calc_brier) {\n Overall[[\"Brier_Score\"]] <- brier_score(true_int, predicted_prob)\n }\n # Overall[[\"Log loss\"]] <- logloss(true_int, predicted_prob)\n }\n\n # Outro ----\n Overall <- as.data.frame(do.call(cbind, Overall))\n rownames(Overall) <- \"Overall\"\n Class <- (data.frame(\n Sensitivity = Class[[\"Sensitivity\"]],\n Specificity = Class[[\"Specificity\"]],\n Balanced_Accuracy = Class[[\"Balanced_Accuracy\"]],\n PPV = Class[[\"PPV\"]],\n NPV = Class[[\"NPV\"]],\n F1 = Class[[\"F1\"]]\n ))\n\n ClassificationMetrics(\n sample = sample,\n Confusion_Matrix = tbl,\n Overall = Overall,\n Class = Class,\n Positive_Class = Positive_Class\n )\n} # /rtemis::classification_metrics\n\n\n# regression_metrics() ----\n#' Regression Metrics\n#'\n#' @param true Numeric vector: True values.\n#' @param predicted Numeric vector: Predicted values.\n#' @param na.rm Logical: If TRUE, remove NA values before computation.\n#' @param sample Character: Sample name (e.g. \"training\", \"test\").\n#'\n#' @return `RegressionMetrics` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' true <- rnorm(100)\n#' predicted <- true + rnorm(100, sd = 0.5)\n#' regression_metrics(true, predicted)\nregression_metrics <- function(\n true,\n predicted,\n na.rm = TRUE,\n sample = NULL\n) {\n RegressionMetrics(\n MAE = mae(true, predicted, na.rm = na.rm),\n MSE = mse(true, predicted, na.rm = na.rm),\n RMSE = rmse(true, predicted, na.rm = na.rm),\n Rsq = rsq(true, predicted),\n sample = sample\n )\n} # /rtemis::regression_metrics\n" }, { "path": "R/msg.R", "content": "# msg.R\n# ::rtemis::\n# 2016- EDG rtemis.org\n\n#' Get current date and time\n#'\n#' @details\n#' used by msgdatetime, log_to_file\n#'\n#' @param datetime_format Character: Format for the date and time.\n#'\n#' @return Character: Formatted date and time.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' datetime()\ndatetime <- function(datetime_format = \"%Y-%m-%d %H:%M:%S\") {\n format(Sys.time(), datetime_format)\n}\n\n\n#' Message datetime()\n#'\n#' @param datetime_format Character: Format for the date and time.\n#'\n#' @return Character: Formatted date and time.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n# Used by msg(), msg0(), msgstart()\nmsgdatetime <- function(datetime_format = \"%Y-%m-%d %H:%M:%S\") {\n message(gray(paste0(datetime(), \" \")), appendLF = FALSE)\n}\n\n\n#' Info msg\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmsg_info <- function(..., format_fn = highlight2, verbosity = 1L) {\n msg0(..., format_fn = format_fn, caller_id = 2, verbosity = verbosity)\n}\n\n\n#' Dispatch to the registered message sink, if any\n#'\n#' Internal helper used by `msg()`, `msg0()`, `msgstart()`, `msgdone()`.\n#' Returns TRUE if a sink consumed the event (caller should skip the console\n#' output path), FALSE if no sink is registered (caller should write to console\n#' as usual).\n#'\n#' @param text Character: the formatted message text (no datetime prefix).\n#' @param caller Character or NA: calling function name from `format_caller()`.\n#' @param ts Character: formatted timestamp from `datetime()`.\n#' @param level Character: one of `\"info\"`, `\"start\"`, `\"done\"`.\n#'\n#' @return Logical scalar.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n.msg_to_sink <- function(text, caller, ts, level) {\n sink <- live[[\"msg_sink\"]]\n if (is.null(sink)) {\n return(FALSE)\n }\n sink(list(text = text, caller = caller, ts = ts, level = level))\n TRUE\n}\n\n\n#' Format caller\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nformat_caller <- function(call_stack, call_depth, caller_id, max_char = 30L) {\n stack_length <- length(call_stack)\n if (stack_length < 2) {\n caller <- NA\n } else {\n call_depth <- call_depth + caller_id\n if (call_depth > stack_length) {\n call_depth <- stack_length\n }\n caller <- paste(\n lapply(\n rev(seq(call_depth)[-seq(caller_id)]),\n function(i) rev(call_stack)[[i]][[1]]\n ),\n collapse = \">>\"\n )\n }\n # do.call and similar will change the call stack, it will contain the full\n # function definition instead of the name alone\n # Capture S7 method calls\n if (!is.na(caller) && substr(caller, 1, 8) == \"`method(\") {\n caller <- sub(\"`method\\\\(([^,]+),.*\\\\)`\", \"\\\\1\", caller)\n }\n if (is.function(caller)) {\n # Try to get function name from call stack context\n caller <- tryCatch(\n {\n # Get the original call stack element as character\n call_str <- deparse(rev(call_stack)[[rev(seq(call_depth)[\n -seq(caller_id)\n ])[1]]])\n # Extract function name from the call\n fn_match <- regexpr(\"^[a-zA-Z_][a-zA-Z0-9_\\\\.]*\", call_str)\n if (fn_match > 0) {\n regmatches(call_str, fn_match)\n } else {\n \"(fn)\"\n }\n },\n error = function(e) \"(fn)\"\n )\n }\n if (is.character(caller)) {\n if (nchar(caller) > 30) caller <- paste0(substr(caller, 1, 27), \"...\")\n }\n caller\n} # /rtemis::format_caller\n\n\n#' Message with provenance\n#'\n#' Print message to output with a prefix including data and time, and calling function or full\n#' call stack\n#'\n#' If `msg` is called directly from the console, it will print `[interactive>]` in place of\n#' the call stack.\n#' `msg0`, similar to `paste0`, is `msg(..., sep = \"\")`\n#'\n#'\n#' @param ... Message to print\n#' @param caller Character: Name of calling function\n#' @param call_depth Integer: Print the system call path of this depth.\n#' @param caller_id Integer: Which function in the call stack to print\n#' @param newline_pre Logical: If TRUE begin with a new line.\n#' @param newline Logical: If TRUE end with a new line.\n#' @param format_fn Function: Formatting function to use on the message text.\n#' @param sep Character: Use to separate objects in `...`\n#' @param verbosity Integer: Verbosity level of the message. If 0L, does not print anything and\n#' returns NULL, invisibly.\n#'\n#' @return If verbosity > 0L, returns a list with call, message, and date, invisibly, otherwise\n#' returns NULL invisibly.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' msg(\"Hello\")\nmsg <- function(\n ...,\n caller = NULL,\n call_depth = 1L,\n caller_id = 1L,\n newline_pre = FALSE,\n newline = TRUE,\n format_fn = plain,\n sep = \" \",\n verbosity = 1L\n) {\n if (verbosity < 1L) {\n return(invisible(NULL))\n }\n if (is.null(caller)) {\n call_stack <- as.list(sys.calls())\n caller <- format_caller(call_stack, call_depth, caller_id)\n } # / get caller\n\n txt <- Filter(Negate(is.null), list(...))\n text <- paste(txt, collapse = sep)\n\n # Sink path: hand structured event to registered sink, skip console.\n if (.msg_to_sink(text, caller, datetime(), \"info\")) {\n return(invisible(NULL))\n }\n\n if (newline_pre) {\n message(\"\")\n }\n msgdatetime()\n message(\n format_fn(text),\n appendLF = FALSE\n )\n if (!is.null(caller) && !is.na(caller) && nchar(caller) > 0L) {\n message(plain(gray(paste0(\" [\", caller, \"]\"))))\n } else if (newline) {\n message(\"\")\n }\n} # /rtemis::msg\n\n\n#' @rdname msg\n#'\n#' @keywords internal\n#' @noRd\nmsg0 <- function(\n ...,\n caller = NULL,\n call_depth = 1,\n caller_id = 1,\n newline_pre = FALSE,\n newline = TRUE,\n format_fn = plain,\n sep = \"\",\n verbosity = 1L\n) {\n if (verbosity < 1L) {\n return(invisible(NULL))\n }\n if (is.null(caller)) {\n call_stack <- as.list(sys.calls())\n caller <- format_caller(call_stack, call_depth, caller_id)\n }\n\n txt <- Filter(Negate(is.null), list(...))\n text <- paste(txt, collapse = sep)\n\n if (.msg_to_sink(text, caller, datetime(), \"info\")) {\n return(invisible(NULL))\n }\n\n if (newline_pre) {\n message(\"\")\n }\n msgdatetime()\n message(\n format_fn(text),\n appendLF = FALSE\n )\n if (!is.null(caller) && !is.na(caller) && nchar(caller) > 0L) {\n message(plain(gray(paste0(\" [\", caller, \"]\"))))\n } else if (newline) {\n message(\"\")\n }\n} # /rtemis::msg0\n\n\n#' msgstart\n#'\n#' @inheritParams msg\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmsgstart <- function(\n ...,\n newline_pre = FALSE,\n sep = \"\"\n) {\n txt <- Filter(Negate(is.null), list(...))\n text <- paste(txt, collapse = sep)\n\n if (.msg_to_sink(text, NA_character_, datetime(), \"start\")) {\n return(invisible(NULL))\n }\n\n if (newline_pre) {\n message()\n }\n msgdatetime()\n message(plain(text), appendLF = FALSE)\n} # /rtemis::msgstart\n\n\n#' msgdone\n#'\n#' @inheritParams msg\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmsgdone <- function(caller = NULL, call_depth = 1, caller_id = 1, sep = \" \") {\n if (is.null(caller)) {\n call_stack <- as.list(sys.calls())\n caller <- format_caller(call_stack, call_depth, caller_id)\n }\n\n if (.msg_to_sink(\"done\", caller, datetime(), \"done\")) {\n return(invisible(NULL))\n }\n\n message(\" \", appendLF = FALSE)\n yay(end = \" \")\n message(gray(paste0(\"[\", caller, \"]\\n\")), appendLF = FALSE)\n} # /rtemis::msgdone\n\n\n# %% Message sink API ---------------------------------------------------------\n\n#' Set the rtemis message sink\n#'\n#' When set, `msg()`, `msg0()`, `msgstart()`, and `msgdone()` forward their\n#' structured output through `sink` instead of writing to the R console. Used\n#' by `rtemislive` to capture training-time messages and forward them over a\n#' WebSocket connection. Pass `NULL` to restore default console output.\n#'\n#' The sink function is called once per message with a single argument: a list\n#' with fields\n#'\n#' - `text`: character. The formatted message body (no datetime prefix).\n#' - `caller`: character or `NA`. Calling function as identified by\n#' `format_caller()`.\n#' - `ts`: character. Formatted timestamp (`\"%Y-%m-%d %H:%M:%S\"`).\n#' - `level`: character. One of `\"info\"` (`msg`/`msg0`), `\"start\"`\n#' (`msgstart`), or `\"done\"` (`msgdone`).\n#'\n#' When a sink is set, the console output path is **skipped** for affected\n#' calls. Errors thrown by the sink propagate to the caller of `msg()`.\n#'\n#' @param sink Function or `NULL`.\n#'\n#' @return Previous sink (function or `NULL`), invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @seealso [get_msg_sink()], [with_msg_sink()].\n#'\n#' @examples\n#' captured <- list()\n#' set_msg_sink(function(m) captured[[length(captured) + 1L]] <<- m)\n#' # msg(\"hello world\") # would append to `captured`\n#' set_msg_sink(NULL) # restore console output\nset_msg_sink <- function(sink) {\n if (!is.null(sink) && !is.function(sink)) {\n cli::cli_abort(\"`sink` must be a function or NULL.\")\n }\n old <- live[[\"msg_sink\"]]\n live[[\"msg_sink\"]] <- sink\n invisible(old)\n} # /rtemis::set_msg_sink\n\n\n#' Get the current rtemis message sink\n#'\n#' @return The currently registered sink function, or `NULL` if none is set.\n#'\n#' @author EDG\n#' @export\n#'\n#' @seealso [set_msg_sink()], [with_msg_sink()].\nget_msg_sink <- function() {\n live[[\"msg_sink\"]]\n} # /rtemis::get_msg_sink\n\n\n#' Run code with a temporary message sink\n#'\n#' Sets `sink` for the duration of `code`, restoring the previous sink on exit\n#' (including on error). Useful in tests and for short-lived capture.\n#'\n#' @param sink Sink function or `NULL`.\n#' @param code Code to run.\n#'\n#' @return The value returned by `code`.\n#'\n#' @author EDG\n#' @export\n#'\n#' @seealso [set_msg_sink()], [get_msg_sink()].\n#'\n#' @examples\n#' captured <- list()\n#' with_msg_sink(\n#' function(m) captured[[length(captured) + 1L]] <<- m,\n#' {\n#' # any msg() / msg0() / msgstart() / msgdone() calls in here are captured\n#' }\n#' )\nwith_msg_sink <- function(sink, code) {\n old <- set_msg_sink(sink)\n on.exit(set_msg_sink(old), add = TRUE)\n force(code)\n} # /rtemis::with_msg_sink\n" }, { "path": "R/preprocess.R", "content": "# preprocess.R\n# ::rtemis::\n# 2017- EDG rtemis.org\n\n# %% preprocess(x, PreprocessorConfig, ...) ----\n#' @name\n#' preprocess\n#'\n#' @param x data.frame, data.table, tbl_df (tabular data): Data to be preprocessed.\n#' @param config `PreprocessorConfig`: Setup using [setup_Preprocessor] OR `Preprocessor` object:\n#' Output of previous run of `preprocess`. This allows, for example, applying preprocessing to a\n#' validation or test set using the same parameters as were used for the training set. In\n#' particular, the same scale centers and coefficients will be applied to the new data.\n#' @param dat_validation tabular data: Validation set data.\n#' @param dat_test tabular data: Test set data.\n#' @param verbosity Integer: Verbosity level.\n#' @param ... Not used.\n#'\n#' @author EDG\n#' @export\npreprocess.class_tabular.PreprocessorConfig <- method(\n preprocess,\n list(class_tabular, PreprocessorConfig)\n) <- function(\n x,\n config,\n dat_validation = NULL,\n dat_test = NULL,\n verbosity = 1L\n) {\n # -> Preprocessor\n # Intro ----\n start_time <- intro(verbosity = verbosity - 1L)\n # Init values list for Preprocessor output.\n values <- list(\n scale_centers = NULL,\n scale_coefficients = NULL,\n one_hot_levels = NULL,\n remove_features = NULL\n )\n\n # Data\n isdatatable <- data.table::is.data.table(x)\n x <- as.data.frame(x)\n\n # Complete cases ----\n if (config@complete_cases) {\n if (verbosity > 0L) {\n msg(\"Filtering complete cases...\")\n }\n x <- x[complete.cases(x), ]\n }\n\n # Set aside excluded ----\n if (!is.null(config@exclude) && length(config@exclude) > 0) {\n excluded <- x[, config@exclude, drop = FALSE]\n excluded_names <- colnames(x)[config@exclude]\n x <- x[, -config@exclude, drop = FALSE]\n }\n\n # Remove named features ----\n if (!is.null(config@remove_features)) {\n if (verbosity > 0L) {\n msg(\"Removing\", length(config@remove_features), \"features...\")\n }\n values$remove_features <- config@remove_features\n x <- x[, !names(x) %in% config@remove_features, drop = FALSE]\n }\n\n # Remove constants ----\n # Must be ahead of numeric quantile at least\n if (config@remove_constants) {\n constant <- which(sapply(\n x,\n is_constant,\n skip_missing = config@remove_constants_skip_missing\n ))\n if (length(constant) > 0) {\n if (verbosity > 0L) {\n msg0(\n \"Removing \",\n singorplu(length(constant), \"constant feature\"),\n \"...\"\n )\n }\n x <- x[, -constant]\n }\n }\n\n # Remove duplicates ----\n if (config@remove_duplicates) {\n # Ndups <- sum(duplicated(x))\n duplicate_index <- which(duplicated(x))\n Ndups <- length(duplicate_index)\n if (Ndups > 0) {\n if (verbosity > 0L) {\n msg0(\"Removing \", singorplu(Ndups, \"duplicate case\"), \"...\")\n }\n x <- unique(x)\n }\n } else {\n duplicate_index <- NULL\n }\n\n # Remove Cases by missing feature threshold ----\n if (!is.null(config@remove_cases_thres)) {\n if (anyNA(x)) {\n xt <- data.table::as.data.table(x)\n # na_fraction_bycase <- apply(x, 1, function(i) sum(is.na(i))/length(i))\n na_fraction_bycase <- data.table::transpose(xt)[, lapply(\n .SD,\n function(i) {\n sum(is.na(i)) / length(i)\n }\n )]\n index_remove_cases_thres <- which(\n na_fraction_bycase >= config@remove_cases_thres\n )\n if (length(index_remove_cases_thres) > 0) {\n if (verbosity > 0L) {\n msg(\n \"Removing\",\n length(index_remove_cases_thres),\n \"cases with >=\",\n config@remove_cases_thres,\n \"missing data...\"\n )\n }\n xt <- xt[-index_remove_cases_thres, ]\n }\n x <- as.data.frame(xt)\n }\n }\n\n # Remove Features by missing feature threshold ----\n if (!is.null(config@remove_features_thres)) {\n if (anyNA(x)) {\n xt <- data.table::as.data.table(x)\n na.fraction.byfeat <- xt[, lapply(.SD, function(i) {\n sum(is.na(i)) / length(i)\n })]\n removeFeat_thres_index <- which(\n na.fraction.byfeat >= config@remove_features_thres\n )\n if (length(removeFeat_thres_index) > 0) {\n if (verbosity > 0L) {\n msg(\n \"Removing\",\n length(removeFeat_thres_index),\n \"features with >=\",\n config@remove_features_thres,\n \"missing data...\"\n )\n }\n x <- x[, -removeFeat_thres_index]\n }\n }\n }\n\n # Integer to factor ----\n index_integer <- NULL\n if (config@integer2factor) {\n index_integer <- c(\n which(sapply(x, is.integer)),\n which(sapply(x, bit64::is.integer64))\n )\n if (verbosity > 0L) {\n if (length(index_integer) > 0) {\n msg(\n \"Converting\",\n singorplu(length(index_integer), \"integer\"),\n \"to factor...\"\n )\n } else {\n msg(\"No integers to convert to factor...\")\n }\n }\n for (i in index_integer) {\n x[, i] <- as.factor(x[, i])\n }\n }\n\n # Logical to factor ----\n if (config@logical2factor) {\n index_logical <- which(sapply(x, is.logical))\n if (verbosity > 0L) {\n if (length(index_logical) > 0) {\n msg0(\n \"Converting \",\n singorplu(length(index_logical), \"logical feature\"),\n \" to \",\n ngettext(length(index_logical), \"factor\", \"factors\"),\n \"...\"\n )\n } else {\n msg(\"No logicals to convert to factor...\")\n }\n }\n for (i in index_logical) {\n x[, i] <- as.factor(x[, i])\n }\n }\n\n # Numeric to factor ----\n if (config@numeric2factor) {\n index_numeric <- which(sapply(x, is.numeric))\n if (verbosity > 0L) {\n msg(\"Converting numeric to factors...\")\n }\n if (is.null(config@numeric2factor_levels)) {\n for (i in index_numeric) {\n x[, i] <- as.factor(x[, i])\n }\n } else {\n for (i in index_numeric) {\n x[, i] <- factor(x[, i], levels = config@numeric2factor_levels)\n }\n }\n }\n\n # Character to factor ----\n if (config@character2factor) {\n index_char <- which(sapply(x, is.character))\n if (verbosity > 0L) {\n if (length(index_char) > 0) {\n msg0(\n \"Converting \",\n singorplu(length(index_char), \"character feature\"),\n \" to \",\n ngettext(length(index_char), \"a factor\", \"factors\"),\n \"...\"\n )\n } else {\n msg(\"No character features to convert to factors found.\")\n }\n }\n for (i in index_char) {\n x[, i] <- as.factor(x[, i])\n }\n }\n\n # unique_len2factor ----\n if (config@unique_len2factor > 1) {\n index_len <- which(sapply(\n x,\n \\(i) length(unique(i)) <= config@unique_len2factor\n ))\n # Exclude factors\n index_factor <- which(sapply(x, is.factor))\n index_len <- setdiff(index_len, index_factor)\n if (verbosity > 0L) {\n if (length(index_len) > 0) {\n msg(\n \"Converting\",\n singorplu(length(index_len), \"feature\"),\n \"with <=\",\n config@unique_len2factor,\n \"unique values to factors...\"\n )\n } else {\n msg(\n \"No features with <=\",\n config@unique_len2factor,\n \"unique values found.\"\n )\n }\n }\n for (i in index_len) {\n x[, i] <- factor(x[, i])\n }\n }\n\n # Integer to numeric ----\n if (config@integer2numeric) {\n if (is.null(index_integer)) {\n index_integer <- c(\n which(sapply(x, is.integer)),\n which(sapply(x, bit64::is.integer64))\n )\n }\n if (verbosity > 0L) {\n if (length(index_integer) > 0) {\n msg(\n \"Converting\",\n singorplu(length(index_integer), \"integer\"),\n \"to numeric...\"\n )\n } else {\n msg(\"No integers to convert to numeric...\")\n }\n }\n for (i in index_integer) {\n x[, i] <- as.numeric(x[, i])\n }\n }\n\n # Logical to numeric ----\n if (config@logical2numeric) {\n index_logical <- which(sapply(x, is.logical))\n if (verbosity > 0L) {\n msg(\"Converting logicals to numeric...\")\n }\n for (i in index_logical) {\n x[, i] <- as.numeric(x[, i])\n }\n }\n\n # Numeric cut ----\n if (config@numeric_cut_n > 0) {\n index_numeric <- which(sapply(x, is.numeric))\n if (length(index_numeric) > 0) {\n if (verbosity > 0L) {\n msg(\"Cutting numeric features in\", config@numeric_cut_n, \"bins...\")\n }\n for (i in index_numeric) {\n x[, i] <- factor(\n cut(\n x[, i],\n breaks = config@numeric_cut_n,\n labels = config@numeric_cut_labels\n )\n )\n }\n }\n }\n\n # Numeric quantile ----\n if (config@numeric_quant_n > 0) {\n index_numeric2q <- if (config@numeric_quant_nAonly) {\n index_numeric2q <- which(sapply(x, is.numeric) & sapply(x, anyNA))\n } else {\n which(sapply(x, is.numeric))\n }\n if (length(index_numeric2q) > 0) {\n if (verbosity > 0L) {\n msg(\n \"Cutting numeric features in\",\n config@numeric_quant_n,\n \"quantiles...\"\n )\n }\n for (i in index_numeric2q) {\n rng <- abs(diff(range(x[, i], na.rm = TRUE)))\n quantiles <- quantile(\n x[, i],\n probs = seq(0, 1, length.out = config@numeric_quant_n),\n na.rm = TRUE\n )\n quantiles[1] <- quantiles[1] - .02 * rng\n quantiles[config@numeric_quant_n] <- quantiles[\n config@numeric_quant_n\n ] +\n .02 * rng\n quantiles <- unique(quantiles)\n x[, i] <- factor(\n cut(\n x[, i],\n breaks = quantiles\n )\n )\n }\n }\n }\n\n # factor NA to level ----\n if (config@factorNA2missing) {\n index_factor <- which(sapply(x, is.factor))\n if (verbosity > 0L) {\n if (length(index_factor) > 0) {\n msg0(\n \"Converting \",\n length(index_factor),\n ngettext(length(index_factor), \" factor's\", \" factors'\"),\n \" NA values to level '\",\n config@factorNA2missing_level,\n \"'...\"\n )\n } else {\n msg(\"No factors found.\")\n }\n }\n for (i in index_factor) {\n x[, i] <- factor_NA2missing(x[, i], config@factorNA2missing_level)\n }\n }\n\n # Factor to integer ----\n # e.g. for algorithms that do not support factors directly, but can handle integers\n # as categorical (e.g. LightGBM)\n if (config@factor2integer) {\n index_factor <- which(sapply(x, is.factor))\n if (verbosity > 0L) {\n if (length(index_factor) > 0) {\n msg(\n \"Converting\",\n singorplu(length(index_factor), \"factor\"),\n \"to integer...\"\n )\n } else {\n msg(\"No factors found to convert to integer...\")\n }\n }\n if (config@factor2integer_startat0) {\n for (i in index_factor) {\n x[, i] <- as.integer(x[, i]) - 1\n }\n } else {\n for (i in index_factor) {\n x[, i] <- as.integer(x[, i])\n }\n }\n }\n\n # Missingness ----\n if (config@missingness) {\n cols_with_na <- which(apply(x, 2, anyNA))\n .colnames <- colnames(x)\n for (i in cols_with_na) {\n x[, paste0(.colnames[i], \"_missing\")] <- factor(as.numeric(is.na(x[, i])))\n if (verbosity > 0L) {\n msg0(\"Created missingness indicator for \", .colnames[i], \"...\")\n }\n }\n }\n\n # Impute ----\n if (config@impute) {\n if (config@impute_type == \"missRanger\") {\n # '- missRanger ----\n check_dependencies(\"missRanger\")\n if (verbosity > 0L) {\n if (config@impute_missRanger_params[[\"pmm.k\"]] > 0) {\n msg(\n \"Imputing missing values using predictive mean matching with missRanger...\"\n )\n } else {\n msg(\"Imputing missing values using missRanger...\")\n }\n }\n x <- missRanger::missRanger(\n x,\n pmm.k = config@impute_missRanger_params[[\"pmm.k\"]],\n verbose = verbosity\n )\n } else if (config@impute_type == \"micePMM\") {\n check_dependencies(\"mice\")\n if (verbosity > 0L) {\n msg(\n \"Imputing missing values by predictive mean matching using mice...\"\n )\n }\n x <- mice::complete(mice::mice(x, m = 1, method = \"pmm\"))\n } else {\n # '- mean/mode ----\n if (verbosity > 0L) {\n msg(\n \"Imputing missing values using\",\n config@impute_discrete,\n \"(discrete) and\",\n config@impute_continuous,\n \"(continuous)...\"\n )\n }\n\n index_discrete <- which(sapply(x, function(i) is_discrete(i) && anyNA(i)))\n if (length(index_discrete) > 0) {\n for (i in index_discrete) {\n index <- which(is.na(x[, i]))\n imputed <- do_call(\n config@impute_discrete,\n list(x[[i]], na.rm = TRUE)\n )\n x[index, i] <- imputed\n }\n }\n\n index_numeric <- which(sapply(x, function(i) is.numeric(i) && anyNA(i)))\n if (length(index_numeric) > 0) {\n for (i in index_numeric) {\n index <- which(is.na(x[, i]))\n imputed <- do_call(\n config@impute_continuous,\n list(x[[i]], na.rm = TRUE)\n )\n x[index, i] <- imputed\n }\n }\n }\n }\n\n # Scale +/- center ----\n if (config@scale || config@center) {\n # Get index of numeric features\n numeric_index <- which(sapply(x, is.numeric))\n sc <- if (config@scale) \"Scaling\" else NULL\n ce <- if (config@center) \"centering\" else NULL\n if (length(numeric_index) > 0) {\n if (verbosity > 0L) {\n msg(\n paste(c(sc, ce), collapse = \" and \"),\n length(numeric_index),\n \"numeric features...\"\n )\n }\n # Info: scale outputs a matrix.\n scale_ <- if (!is.null(config@scale_coefficients)) {\n # Check names match\n stopifnot(identical(\n names(config@scale_coefficients),\n names(x[, numeric_index])\n ))\n config@scale_coefficients\n } else {\n config@scale\n }\n center_ <- if (!is.null(config@scale_centers)) {\n # Check names match\n stopifnot(identical(\n names(config@scale_centers),\n names(x[, numeric_index])\n ))\n config@scale_centers\n } else {\n config@center\n }\n x_num_scaled <- scale(\n x[, numeric_index, drop = FALSE],\n scale = scale_,\n center = center_\n )\n\n # Collect scale and center values\n values$scale_centers <- attr(x_num_scaled, \"scaled:center\")\n values$scale_coefficients <- attr(x_num_scaled, \"scaled:scale\")\n\n x_num_scaled <- as.data.frame(x_num_scaled)\n\n # Insert into original dataset\n x[, numeric_index] <- x_num_scaled\n # j <- 0\n # for (i in numeric_index) {\n # j <- j + 1\n # x[, i] <- x_num_scaled[, j]\n # }\n } else {\n msg(\n paste(c(sc, ce), collapse = \" and \"),\n \"was requested \\n but no numeric features were found: Please check data.\"\n )\n }\n }\n\n # One Hot Encoding ----\n if (config@one_hot) {\n x <- one_hot(\n x,\n verbosity = verbosity,\n factor_levels = config@one_hot_levels\n )\n }\n\n # Add date features ----\n if (config@add_date_features) {\n if (verbosity > 0L) {\n msg(\"Extracting date features...\")\n }\n # Find date columns\n date_cols <- which(sapply(x, function(col) inherits(col, \"Date\")))\n # For each date column, extract features\n for (i in date_cols) {\n .date_features <- dates2features(\n x[[i]],\n features = config@date_features\n )\n names(.date_features) <- paste0(names(x)[i], \"_\", names(.date_features))\n x <- cbind(x, .date_features)\n }\n }\n\n # Add holidays ----\n if (config@add_holidays) {\n if (verbosity > 0L) {\n msg(\"Extracting holidays...\")\n }\n # Find date columns\n date_cols <- which(sapply(x, \\(col) inherits(col, \"Date\")))\n # For each date column, extract holidays\n for (i in date_cols) {\n .holidays <- get_holidays(x[, i])\n x[[paste0(names(x)[i], \"_holidays\")]] <- .holidays\n }\n }\n\n # Add back excluded ----\n if (!is.null(config@exclude) && length(config@exclude) > 0) {\n # remove any duplicates\n if (!is.null(duplicate_index)) {\n excluded <- excluded[-duplicate_index, , drop = FALSE]\n }\n\n # remove by case thres\n if (\n !is.null(config@remove_cases_thres) &&\n length(index_remove_cases_thres) > 0\n ) {\n n_feat_inc <- NCOL(x)\n x <- cbind(x, excluded[-index_remove_cases_thres, ])\n colnames(x)[-c(seq(n_feat_inc))] <- excluded_names\n } else {\n x <- cbind(x, excluded)\n }\n } # /add back excluded\n\n if (isdatatable) {\n data.table::setDT(x)\n }\n if (verbosity > 0L) {\n msg(\"Preprocessing done.\")\n }\n\n preprocessed <- list(training = x)\n\n if (!is.null(dat_validation)) {\n if (verbosity > 0L) {\n msg(\"Applying preprocessing to validation data...\")\n }\n prp_validation <- preprocess(\n x = dat_validation,\n config = Preprocessor(\n config = config,\n preprocessed = list(),\n scale_centers = values[[\"scale_centers\"]],\n scale_coefficients = values[[\"scale_coefficients\"]],\n one_hot_levels = values[[\"one_hot_levels\"]],\n remove_features = values[[\"remove_features\"]]\n ),\n verbosity = verbosity\n )\n preprocessed$validation <- prp_validation@preprocessed\n }\n if (!is.null(dat_test)) {\n if (verbosity > 0L) {\n msg(\"Applying preprocessing to test data...\")\n }\n prp_test <- preprocess(\n x = dat_test,\n config = Preprocessor(\n config = config,\n preprocessed = list(),\n scale_centers = values[[\"scale_centers\"]],\n scale_coefficients = values[[\"scale_coefficients\"]],\n one_hot_levels = values[[\"one_hot_levels\"]],\n remove_features = values[[\"remove_features\"]]\n ),\n verbosity = verbosity\n )\n preprocessed$test <- prp_test@preprocessed\n }\n outro(start_time, verbosity = verbosity - 1L)\n Preprocessor(\n config = config,\n preprocessed = if (length(preprocessed) == 1) {\n preprocessed[[1]]\n } else {\n preprocessed\n },\n scale_centers = values[[\"scale_centers\"]],\n scale_coefficients = values[[\"scale_coefficients\"]],\n one_hot_levels = values[[\"one_hot_levels\"]],\n remove_features = values[[\"remove_features\"]]\n )\n} # /rtemis::preprocess(PreprocessorConfig, ...)\n\n\n# %% preprocess(x, Preprocessor, ...) ----\n#' @name\n#' preprocess\n#'\n#' @author EDG\n#' @export\npreprocess.class_tabular.Preprocessor <- method(\n preprocess,\n list(class_tabular, Preprocessor)\n) <- function(\n x,\n config,\n verbosity = 1L\n) {\n # -> Preprocessor\n params <- config@config\n # Overwrite scale_centers, scale_coefficients, one_hot_levels, and remove_features\n params@scale_centers <- config@values[[\"scale_centers\"]]\n params@scale_coefficients <- config@values[[\"scale_coefficients\"]]\n params@one_hot_levels <- config@values[[\"one_hot_levels\"]]\n params@remove_features <- config@values[[\"remove_features\"]]\n\n preprocess(x, params, verbosity = verbosity)\n} # /rtemis::preprocess(Preprocessor, ...)\n\n\n# %% one_hot ----\n#' @name one_hot\n#'\n#' @title\n#' One hot encoding\n#'\n#' @description\n#' One hot encode a vector or factors in a data.frame\n#'\n#' @details\n#' A vector input will be one-hot encoded regardless of type by looking at all unique values. With data.frame input,\n#' only column of type factor will be one-hot encoded.\n#' This function is used by [preprocess].\n#' `one_hot.data.table` operates on a copy of its input.\n#' `one_hot_` performs one-hot encoding ***in-place***.\n#'\n#' @param x Vector or data.frame\n#' @param xname Character: Variable name\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return For vector input, a one-hot-encoded matrix, for data.frame frame\n#' input, an expanded data.frame where all factors are one-hot encoded\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' # factor with only one unique value but 2 levels:\n#' vf <- factor(rep(\"alpha\", 20), levels = c(\"alpha\", \"beta\"))\n#' vf_one_hot <- one_hot(vf)\n#' vf_one_hot\nmethod(one_hot, class_any) <- function(x, xname = NULL, verbosity = 1L) {\n if (is.null(xname)) {\n xname <- deparse(substitute(x))\n }\n # ensures if factor without all levels present, gets all columns created\n if (!is.factor(x)) {\n x <- factor(x)\n }\n .levels <- levels(x)\n ncases <- NROW(x)\n index <- as.integer(x)\n oh <- matrix(0, ncases, length(.levels))\n colnames(oh) <- paste(xname, .levels, sep = \"_\")\n for (i in seq(ncases)) {\n oh[i, index[i]] <- 1\n }\n oh\n} # /rtemis::one_hot.default\n\n\n# included for benchmarking mostly\none_hotcm <- function(\n x,\n xname = deparse(substitute(x)),\n return = \"data.frame\"\n) {\n stopifnot(is.factor(x))\n dt <- data.table(\n ID = seq_along(x),\n x = x\n )\n setnames(dt, \"x\", xname)\n out <- dcast(\n melt(dt, id.vars = \"ID\"),\n ID ~ variable + value,\n fun.aggregate = length\n )[, -1]\n if (return == \"data.frame\") {\n setDF(out)\n }\n out\n}\n\n# loop is faster than dcast/melt\n# x <- iris$Species\n# microbenchmark::microbenchmark(loop = one_hot.default(x), dt = one_hotcm(x))\n\n# %% one_hot.data.frame ----\n#' @rdname one_hot\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' one_hot(iris) |> head()\nmethod(one_hot, class_data.frame) <- function(\n x,\n factor_levels = NULL,\n verbosity = 1L\n) {\n ncases <- NROW(x)\n factor_index <- which(sapply(x, is.factor))\n # If factor_levels list is provided, check column names match\n if (!is.null(factor_levels)) {\n stopifnot(identical(names(factor_levels), colnames(x[, factor_index])))\n }\n one.hot <- as.list(x)\n if (verbosity > 0L) {\n .names <- colnames(x)\n }\n for (i in factor_index) {\n if (verbosity > 0L) {\n msgstart(\"One hot encoding \", .names[i], \"...\")\n }\n .levels <- if (!is.null(factor_levels)) {\n factor_levels[[i]]\n } else {\n levels(x[[i]])\n }\n index <- as.integer(x[, i])\n oh <- matrix(0, ncases, length(.levels))\n colnames(oh) <- paste0(names(x)[i], \"_\", .levels)\n for (j in seq(ncases)) {\n oh[j, index[j]] <- 1\n }\n # Replace list element that was a factor with one-hot encoded matrix\n one.hot[[i]] <- oh\n }\n if (verbosity > 0L) {\n msgdone()\n }\n # do.call below creates a matrix, maintaining column names in one.hot matrix.\n # as.data.frame on one.hot would have added {name_of_oh_element}.{column_names}\n as.data.frame(do.call(cbind, one.hot))\n} # /rtemis::one_hot.data.frame\n\n\n# %% one_hot.data.table ----\n#' @rdname one_hot\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' ir <- data.table::as.data.table(iris)\n#' ir_oh <- one_hot(ir)\n#' ir_oh\nmethod(one_hot, class_data.table) <- function(x, verbosity = 1L) {\n x <- copy(x)\n ncases <- NROW(x)\n factor_index <- which(sapply(x, is.factor))\n .names <- colnames(x)\n for (i in factor_index) {\n if (verbosity > 0L) {\n msg_info(\"One hot encoding \", .names[i], \"...\")\n }\n .levels <- levels(x[[i]])\n index <- as.integer(x[[i]])\n oh <- as.data.table(matrix(0, ncases, length(.levels)))\n .colnames <- colnames(oh) <- .levels\n for (k in seq_along(.levels)) {\n oh[index == k, (.colnames[k]) := 1]\n }\n x[, (paste(.names[i], .levels, sep = \"_\")) := oh]\n }\n # remove original factor(s)\n x[, paste(.names[factor_index]) := NULL]\n if (verbosity > 0L) {\n msg(\"Done\")\n }\n invisible(x)\n} # /rtemis::one_hot.data.table\n\n\n#' Convert data.table's factor to one-hot encoding ***in-place***\n#'\n#' @param x data.table: Input data.table. Will be modified ***in-place***.\n#' @param xname Character, optional: Dataset name.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return The input, invisibly, after it has been modified ***in-place***.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' ir <- data.table::as.data.table(iris)\n#' # dt_set_one_hot operates ***in-place***; therefore no assignment is used:\n#' dt_set_one_hot(ir)\n#' ir\ndt_set_one_hot <- function(x, xname = NULL, verbosity = 1L) {\n if (is.null(xname)) {\n xname <- deparse(substitute(x))\n }\n ncases <- NROW(x)\n factor_index <- which(sapply(x, is.factor))\n .names <- colnames(x)\n for (i in factor_index) {\n if (verbosity > 0L) {\n msg_info(\"One hot encoding \", .names[i], \"...\")\n }\n .levels <- levels(x[[i]])\n index <- as.numeric(x[[i]])\n oh <- as.data.table(matrix(0, ncases, length(.levels)))\n .colnames <- colnames(oh) <- paste(xname, .levels, sep = \"_\")\n for (k in seq_along(.levels)) {\n oh[index == k, (.colnames[k]) := 1]\n }\n x[, (paste(.names[i], .levels, sep = \"_\")) := oh]\n }\n # remove original factor(s)\n x[, paste(.names[factor_index]) := NULL]\n if (verbosity > 0L) {\n msg(\"Done\")\n }\n invisible(x)\n} # /rtemis::dt_set_one_hot\n\n\n#' Convert one-hot encoded matrix to factor\n#'\n#' @details If input has a single column, it will be converted to factor and\n#' returned\n#'\n#' @param x one-hot encoded matrix or data.frame.\n#' @param labels Character vector of level names.\n#'\n#' @return A factor.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- data.frame(matrix(FALSE, 10, 3))\n#' colnames(x) <- c(\"Dx1\", \"Dx2\", \"Dx3\")\n#' x$Dx1[1:3] <- x$Dx2[4:6] <- x$Dx3[7:10] <- TRUE\n#' one_hot2factor(x)\none_hot2factor <- function(x, labels = colnames(x)) {\n if (NCOL(x) == 1) {\n return(factor(x))\n }\n if (any(na.exclude(rowSums(x)) > 1)) {\n cli::cli_abort(\"Input must be one-hot encoded.\")\n }\n out <- factor(rep(NA, NROW(x)), levels = labels)\n for (i in seq_along(labels)) {\n out[x[, i] == 1] <- labels[i]\n }\n out\n} # /rtemis::one_hot2factor\n\n\n#' Binary matrix times character vector\n#'\n#' @param x A binary matrix or data.frame\n#' @param labels Character vector length equal to `ncol(x)`\n#'\n#' @return a character vector\n#'\n#' @author EDG\n#' @export\n`%BC%` <- function(x, labels) {\n if (NCOL(x) == 1) {\n return(factor(x))\n }\n dt <- as.data.table(x)\n fn <- \\(r) paste(unique(labels[which(r == 1)]), collapse = \",\")\n out <- dt[, list(fn(.SD)), by = seq_len(NROW(dt))][[2]]\n out[out == \"\"] <- NA\n out\n} # /rtemis::`%BC%`\n\n\n#' Binary matrix to list vector\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nbinmat2lvec <- function(x, labels = colnames(x), return.list = FALSE) {\n if (NCOL(x) == 1) {\n return(factor(x))\n }\n dt <- as.data.table(x)\n if (return.list) {\n fn <- \\(r) list(labels[which(r == 1)])\n out <- dt[, list(fn(.SD)), by = seq_len(NROW(dt))][[2]]\n out[sapply(out, length) == 0] <- NA\n } else {\n fn <- \\(r) paste(unique(labels[which(r == 1)]), collapse = \",\")\n out <- dt[, list(fn(.SD)), by = seq_len(NROW(dt))]\n out[out == \"\"] <- NA\n }\n out\n} # /rtemis::binmat2lvec\n\n\n# %% feature_matrix ----\n#' Convert tabular data to feature matrix\n#'\n#' Convert a tabular dataset to a matrix, one-hot encoding factors, if present.\n#'\n#' @details\n#' This is a convenience function that uses [features()], [preprocess()], `as.matrix()`.\n#'\n#' @param x tabular data: Input data to convert to a feature matrix.\n#'\n#' @return Matrix with features. Factors are one-hot encoded, if present.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' # reorder columns so that we have a categorical feature\n#' x <- set_outcome(iris, \"Sepal.Length\")\n#' feature_matrix(x) |> head()\nfeature_matrix <- function(x) {\n x |>\n features() |>\n preprocess(setup_Preprocessor(one_hot = TRUE)) |>\n preprocessed() |>\n as.matrix()\n} # /rtemis::feature_matrix\n" }, { "path": "R/present.R", "content": "# present.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n#' Present list of Supervised or SupervisedRes objects\n#'\n#' Plot training and testing performance boxplots of multiple `Supervised` or `SupervisedRes` objects\n#'\n#' @param x List of `Supervised` or `SupervisedRes` objects.\n#' @param metric Character: Metric to plot.\n#' @param model_names Character: Names of models being plotted.\n#' @param ylim Numeric vector of length 2: y-axis limits for the boxplots.\n#' @param theme `Theme` object.\n#' @param boxpoints Character: \"all\", \"outliers\", or \"suspectedoutliers\". Determines how points are\n#' displayed in the boxplot.\n#' @param filename Character: Filename to save the plot to.\n#' @param file_width Numeric: Width of the exported image in pixels.\n#' @param file_height Numeric: Height of the exported image in pixels.\n#' @param file_scale Numeric: Scale factor for the exported image.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return plotly object\n#'\n#' @author EDG\n#' @noRd\n#'\n#' @examples\n#' \\dontrun{\n#' iris_lightrf <- train(\n#' iris,\n#' algorithm = \"lightrf\",\n#' outer_resampling_config = setup_Resampler(seed = 2026)\n#' )\n#' iris_rsvm <- train(\n#' iris,\n#' algorithm = \"radialsvm\",\n#' outer_resampling_config = setup_Resampler(seed = 2026)\n#' )\n#' present(list(iris_lightrf, iris_rsvm), metric = \"Balanced_Accuracy\")\n#' }\nmethod(present, class_list) <- function(\n x,\n metric = NULL,\n model_names = NULL,\n ylim = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n boxpoints = \"all\",\n filename = NULL,\n file_width = 800,\n file_height = 600,\n file_scale = 1,\n verbosity = 1L\n) {\n # Check that all elements of x are either Supervised or SupervisedRes objects\n all_supervised <- all(sapply(x, function(m) {\n S7_inherits(m, Supervised)\n }))\n all_supervisedres <- all(sapply(x, function(m) {\n S7_inherits(m, SupervisedRes)\n }))\n\n if (!(all_supervised || all_supervisedres)) {\n cli::cli_abort(\n \"Input must be a list of Supervised or SupervisedRes objects.\"\n )\n }\n\n # Check all models are of the same type\n type <- unique(sapply(x, function(m) m@type))\n if (length(type) > 1) {\n cli::cli_abort(\"All models must be of the same type\")\n }\n\n # Describe\n if (verbosity > 0L) {\n describe(x)\n }\n\n # Get names\n if (is.null(model_names)) {\n model_names <- sapply(x, function(m) {\n m@algorithm\n })\n }\n\n # If any names are duplicated, append a number\n if (any(duplicated(model_names))) {\n model_names <- make.unique(model_names, sep = \"_\")\n }\n\n # Metric\n if (is.null(metric)) {\n metric <- switch(\n type,\n Classification = \"Balanced_Accuracy\",\n Regression = \"Rsq\"\n )\n }\n\n # Data\n xl_training <- lapply(x, function(m) {\n get_metric(m, set = \"training\", metric = metric)\n })\n xl_test <- lapply(x, function(m) {\n get_metric(m, set = \"test\", metric = metric)\n })\n names(xl_training) <- names(xl_test) <- model_names\n\n # Plots\n if (all_supervisedres) {\n # Get ylim\n if (is.null(ylim)) {\n ylim <- range(c(xl_training, xl_test), na.rm = TRUE)\n }\n plot_training <- draw_box(\n xl_training,\n ylab = labelify(paste(\"Training\", metric)),\n ylim = ylim,\n theme = theme,\n boxpoints = boxpoints\n )\n plot_test <- draw_box(\n xl_test,\n ylab = labelify(paste(\"Test\", metric)),\n ylim = ylim,\n theme = theme,\n boxpoints = boxpoints\n )\n plt <- plotly::subplot(\n plot_training,\n plot_test,\n nrows = 2L,\n shareX = TRUE,\n shareY = FALSE,\n titleX = TRUE,\n titleY = TRUE,\n margin = 0.05\n )\n } else {\n # rows are groups, columns are features\n xdf_training <- as.data.frame(xl_training)\n xdf_test <- as.data.frame(xl_test)\n xdf <- t(rbind(xdf_training, xdf_test))\n colnames(xdf) <- c(\"Training\", \"Test\")\n plt <- draw_bar(xdf, ylab = labelify(metric), theme = theme)\n }\n\n if (!is.null(filename)) {\n export_plotly(\n plt,\n filename = filename,\n width = file_width,\n height = file_height,\n scale = file_scale\n )\n }\n plt\n} # /rtemis::present.list\n" }, { "path": "R/read.R", "content": "# read.R\n# ::rtemis::\n# 2022- EDG rtemis.org\n\n# %% read ----\n#' Read tabular data from a variety of formats\n#'\n#' Read data and optionally clean column names, keep unique rows, and convert\n#' characters to factors\n#'\n#' @details\n#' `read` is a convenience function to read:\n#'\n#' - **Delimited** files using `data.table:fread()`, `arrow:read_delim_arrow()`,\n#' `vroom::vroom()`, or `duckdb::duckdb_read_csv()`\n#' - **ARFF** files using `farff::readARFF()`\n#' - **Parquet** files using `arrow::read_parquet()`\n#' - **XLSX** files using `readxl::read_excel()`\n#' - **DTA** files from Stata using `haven::read_dta()`\n#' - **FASTA** files using `seqinr::read.fasta()`\n#' - **RDS** files using `readRDS()`\n#'\n#' @param filename Character: filename or full path if `datadir = NULL`.\n#' @param datadir Character: Optional path to directory where `filename`\n#' is located. If not specified, `filename` must be the full path.\n#' @param make_unique Logical: If TRUE, keep unique rows only.\n#' @param character2factor Logical: If TRUE, convert character variables to\n#' factors.\n#' @param clean_colnames Logical: If TRUE, clean columns names using\n#' [clean_colnames].\n#' @param delim_reader Character: package to use for reading delimited data.\n#' @param xlsx_sheet Integer or character: Name or number of XLSX sheet to read.\n#' @param sep Single character: field separator. If `delim_reader = \"fread\"`\n#' and `sep = NULL`, this defaults to \"auto\", otherwise defaults to \",\".\n#' @param quote Single character: quote character.\n#' @param na_strings Character vector: Strings to be interpreted as NA values.\n#' For `delim_reader = \"duckdb\"`, this must be a single string.\n#' @param output Character: \"default\" or \"data.table\", If default, return the delim_reader's\n#' default data structure, otherwise convert to data.table.\n#' @param attr Character: Attribute to set (Optional).\n#' @param value Character: Value to set (if `attr` is not NULL).\n#' @param verbosity Integer: Verbosity level.\n#' @param fread_verbosity Integer: Verbosity level. Passed to `data.table::fread`\n#' @param timed Logical: If TRUE, time the process and print to console\n#' @param ... Additional arguments to pass to `data.table::fread`,\n#' `arrow::read_delim_arrow()`, `vroom::vroom()`,\n#' or `readxl::read_excel()`.\n#'\n#' @return data.frame, data.table, or tibble.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' \\dontrun{\n#' # Replace with your own data directory and filename\n#' datadir <- \"/Data\"\n#' dat <- read(\"iris.csv\", datadir)\n#' }\nread <- function(\n filename,\n datadir = NULL,\n make_unique = FALSE,\n character2factor = FALSE,\n clean_colnames = TRUE,\n delim_reader = c(\"data.table\", \"vroom\", \"duckdb\", \"arrow\"),\n xlsx_sheet = 1,\n sep = NULL,\n quote = \"\\\"\",\n na_strings = c(\"\"),\n output = c(\"data.table\", \"tibble\", \"data.frame\"),\n attr = NULL,\n value = NULL,\n verbosity = 1L,\n fread_verbosity = 0L,\n timed = verbosity > 0L,\n ...\n) {\n check_dependencies(\"data.table\")\n if (timed) {\n start_time <- intro(verbosity = 0L)\n }\n delim_reader <- match.arg(delim_reader)\n output <- match.arg(output)\n if (output == \"tibble\") {\n check_dependencies(\"tibble\")\n }\n ext <- tools::file_ext(filename)\n path <- if (is.null(datadir)) {\n filename\n } else {\n file.path(datadir, filename)\n }\n path <- path.expand(path)\n # Sanitize path for security\n path <- sanitize_path(path, must_exist = FALSE)\n\n if (ext == \"parquet\") {\n check_dependencies(\"arrow\")\n msg0(\n bold(highlight(\"\\u25B6\")),\n \" Reading \",\n highlight(basename(path)),\n \" using arrow::read_parquet()...\",\n verbosity = verbosity\n )\n .dat <- arrow::read_parquet(path, ...)\n } else if (ext == \"rds\") {\n msg0(\n bold(highlight(\"\\u25B6\")),\n \" Reading \",\n highlight(basename(path)),\n \"...\",\n verbosity = verbosity\n )\n .dat <- readRDS(path)\n } else if (ext == \"xlsx\") {\n check_dependencies(\"readxl\")\n msg0(\n bold(highlight(\"\\u25B6\")),\n \" Reading \",\n highlight(basename(path)),\n \" using readxl::read_excel()...\",\n verbosity = verbosity\n )\n .dat <- readxl::read_excel(\n path,\n sheet = xlsx_sheet,\n na = na_strings,\n ...\n )\n } else if (ext == \"dta\") {\n check_dependencies(\"haven\")\n msg0(\n bold(highlight(\"\\u25B6\")),\n \" Reading \",\n highlight(basename(path)),\n \" using haven::read_dta()...\",\n verbosity = verbosity\n )\n .dat <- haven::read_dta(path, ...)\n } else if (ext == \"fasta\") {\n check_dependencies(\"seqinr\")\n msg0(\n bold(highlight(\"\\u25B6\")),\n \" Reading \",\n highlight(basename(path)),\n \" using seqinr::read.fasta()...\",\n verbosity = verbosity\n )\n .dat <- seqinr::read.fasta(path, ...)\n # if single sequence, return as character\n if (length(.dat) == 1) {\n .dat <- as.character(.dat[[1]])\n }\n return(.dat)\n } else if (ext == \"arff\") {\n check_dependencies(\"farff\")\n msg0(\n bold(highlight(\"\\u25B6\")),\n \" Reading \",\n highlight(basename(path)),\n \" using farff::readARFF()...\",\n verbosity = verbosity\n )\n .dat <- farff::readARFF(path, ...)\n } else {\n msg0(\n bold(highlight(\"\\u25B6\")),\n \" Reading \",\n highlight(basename(path)),\n \" using \",\n delim_reader,\n \"...\",\n verbosity = verbosity\n )\n if (delim_reader == \"data.table\") {\n if (is.null(sep)) {\n sep <- \"auto\"\n }\n .dat <- data.table::fread(\n path,\n sep = sep,\n quote = quote,\n na.strings = na_strings,\n verbose = fread_verbosity > 0L,\n ...\n )\n } else if (delim_reader == \"duckdb\") {\n check_dependencies(\"DBI\", \"duckdb\")\n if (is.null(sep)) {\n sep <- \",\"\n }\n if (length(na_strings) > 1) {\n msg(\n \"Note: 'na_strings' must be a single string for duckdb; setting to '\",\n na_strings[1],\n \"'\"\n )\n na_strings <- na_strings[1]\n }\n con <- DBI::dbConnect(duckdb::duckdb(), dbdir = \":memory:\")\n on.exit(DBI::dbDisconnect(con, shutdown = TRUE), add = TRUE)\n duckdb::duckdb_read_csv(\n con,\n \"data\",\n path,\n header = TRUE,\n na.strings = na_strings,\n nrow.check = 500,\n delim = sep,\n quote = quote,\n ...\n )\n .dat <- DBI::dbReadTable(con, \"data\")\n } else if (delim_reader == \"arrow\") {\n check_dependencies(\"arrow\")\n if (is.null(sep)) {\n sep <- \",\"\n }\n .dat <- arrow::read_delim_arrow(\n path,\n delim = sep,\n quote = quote,\n na = na_strings,\n ...\n )\n } else {\n check_dependencies(\"vroom\")\n .dat <- vroom::vroom(\n path,\n delim = sep,\n quote = quote,\n na = na_strings,\n progress = verbosity > 0L,\n ...\n )\n }\n }\n\n .nrow <- nrow(.dat)\n .ncol <- ncol(.dat)\n msg(\n \"Read in\",\n highlightbig(.nrow),\n \"x\",\n highlightbig(.ncol),\n verbosity = verbosity\n )\n if (make_unique) {\n .dat <- unique(.dat)\n .nrowp <- nrow(.dat)\n .dup <- .nrow - .nrowp\n if (verbosity > 0L && .dup > 0) {\n msg(\n \"Removed\",\n bold(orange(format(.dup, big.mark = \",\"))),\n \"duplicate\",\n paste0(ngettext(.dup, \"row\", \"rows\"), \".\")\n )\n msg(\n \"New dimensions:\",\n highlightbig(.nrowp),\n \"x\",\n highlightbig(.ncol)\n )\n }\n }\n\n if (clean_colnames) {\n setnames(.dat, names(.dat), clean_colnames(.dat))\n }\n\n if (character2factor) {\n .dat <- preprocess(\n .dat,\n setup_Preprocessor(character2factor = TRUE)\n )[[\"preprocessed\"]]\n }\n\n if (!is.null(attr) && !is.null(value)) {\n for (i in seq_len(ncol(.dat))) {\n setattr(.dat[[i]], attr, value)\n }\n }\n\n if (timed) {\n outro(start_time)\n }\n\n # Set output structure\n if (output == \"data.table\") {\n if (!is.data.table(.dat)) setDT(.dat)\n } else if (output == \"tibble\") {\n .dat <- tibble::as_tibble(.dat)\n } else if (output == \"data.frame\") {\n if (!is.data.frame(.dat)) {\n .dat <- as.data.frame(.dat)\n } else {\n setDF(.dat)\n }\n }\n\n .dat\n} # /rtemis::read\n" }, { "path": "R/resample.R", "content": "# resample.R\n# ::rtemis::\n# 2015- EDG rtemis.org\n\n#' Resample data\n#'\n#' Create resamples of your data, e.g. for model building or validation.\n#' \"KFold\" creates stratified folds, , \"StratSub\" creates stratified subsamples,\n#' \"Bootstrap\" gives the standard bootstrap, i.e. random sampling with replacement,\n#' while \"StratBoot\" uses StratSub and then randomly duplicates some of the training cases to\n#' reach original length of input (default) or length defined by `target_length`.\n#'\n#' Note that option 'KFold' may result in resamples of slightly different length. Avoid all\n#' operations which rely on equal-length vectors. For example, you can't place resamples in a\n#' data.frame, but must use a list instead.\n#'\n#' @param x Vector or data.frame: Usually the outcome; `NROW(x)` defines the sample size.\n#' @param config Resampler object created by [setup_Resampler].\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `Resampler` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' y <- rnorm(200)\n#' # 10-fold (stratified)\n#' y_10fold <- resample(y, setup_Resampler(10L, \"kfold\"))\n#' y_10fold\n#' # 25 stratified subsamples\n#' y_25strat <- resample(y, setup_Resampler(25L, \"stratsub\"))\n#' y_25strat\n#' # 100 stratified bootstraps\n#' y_100strat <- resample(y, setup_Resampler(100L, \"stratboot\"))\n#' y_100strat\n#' # LOOCV\n#' y_loocv <- resample(y, setup_Resampler(type = \"LOOCV\"))\n#' y_loocv\nresample <- function(\n x,\n config = setup_Resampler(),\n # index = NULL,\n # group = NULL,\n verbosity = 1L\n) {\n check_is_S7(config, ResamplerConfig)\n # Input ----\n type <- config@type\n if (NCOL(x) > 1) {\n if (survival::is.Surv(x)) {\n msg(\"Survival object will be stratified on time.\", verbosity = verbosity)\n x <- x[, 1]\n } else {\n msg(\n \"Input contains more than one column; stratifying on last.\",\n verbosity = verbosity\n )\n x <- x[[NCOL(x)]]\n }\n }\n\n # Stratify on case IDs ----\n id_strat <- if (type != \"LOOCV\") {\n config@id_strat\n } else {\n NULL\n }\n\n if (!is.null(id_strat)) {\n # Only keep unique IDs\n idl <- !duplicated(id_strat)\n x <- x[idl]\n }\n\n if (type == \"StratBoot\") {\n target_length <- if (is.null(config@target_length)) {\n NROW(x)\n } else {\n config@target_length\n }\n }\n\n # resample ----\n if (!type %in% c(\"Bootstrap\", \"LOOCV\")) {\n .stratify_var <- if (is.null(config@stratify_var)) {\n x\n } else {\n config@stratify_var\n }\n }\n\n n_resamples <- if (type == \"LOOCV\") length(x) else config@n\n\n # Print config ----\n if (verbosity > 1L) {\n print(config)\n }\n\n # Make resamples ----\n if (type == \"StratSub\") {\n ## StratSub ----\n res_part <- strat_sub(\n x = x,\n n_resamples = n_resamples,\n train_p = config@train_p,\n stratify_var = .stratify_var,\n strat_n_bins = config@strat_n_bins,\n seed = config@seed,\n verbosity = verbosity\n )\n } else if (type == \"Bootstrap\") {\n ## Bootstrap ----\n res_part <- bootstrap(\n x = x,\n n_resamples = n_resamples,\n seed = config@seed\n )\n } else if (type == \"KFold\") {\n ## KFold ----\n res_part <- kfold(\n x = x,\n k = n_resamples,\n stratify_var = .stratify_var,\n strat_n_bins = config@strat_n_bins,\n seed = config@seed,\n verbosity = verbosity\n )\n } else if (type == \"LOOCV\") {\n ## LOOCV ----\n res_part <- loocv(x = x)\n # Get number of resamples\n config@n <- length(res_part)\n } else if (type == \"StratBoot\") {\n ## StratBoot ----\n res_part <- strat_boot(\n x = x,\n n_resamples = n_resamples,\n train_p = config@train_p,\n stratify_var = .stratify_var,\n strat_n_bins = config@strat_n_bins,\n target_length = target_length,\n seed = config@seed,\n verbosity = verbosity\n )\n }\n\n # Update strat_n_bins ----\n if (type == \"StratSub\" || type == \"StratBoot\") {\n actual_n_bins <- attr(res_part, \"strat_n_bins\")\n if (actual_n_bins != config@strat_n_bins) {\n if (verbosity > 0L) {\n msg0(\n \"Updated strat_n_bins from \",\n config@strat_n_bins,\n \" to \",\n actual_n_bins,\n \" in ResamplerConfig object.\"\n )\n }\n config@strat_n_bins <- actual_n_bins\n }\n }\n\n if (!is.null(id_strat)) {\n ### Get ID by resample ----\n id_by_res <- lapply(res_part, \\(x) id_strat[idl][x])\n ### Get resamples on original data with replicates ----\n res_part <- lapply(id_by_res, \\(x) which(id_strat %in% x))\n }\n\n # Output ----\n Resampler(type, res_part, config)\n} # /rtemis::resample\n\n\n#' Bootstrap Resampling\n#'\n#' @param x Input vector.\n#' @param n_resamples Integer: Number of resamples to make.\n#' @param seed Integer: If provided, set seed for reproducibility.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nbootstrap <- function(x, n_resamples = 10, seed = NULL) {\n if (!is.null(seed)) {\n set.seed(seed)\n }\n\n ids <- seq_along(x)\n .length <- length(x)\n if (!is.null(seed)) {\n set.seed(seed)\n }\n\n res <- lapply(\n seq(n_resamples),\n function(i) sort(sample(ids, .length, replace = TRUE))\n )\n names(res) <- paste0(\"Bootsrap_\", seq(n_resamples))\n res\n} # /rtemis::bootstrap\n\n\n#' K-fold Resampling\n#'\n#' @inheritParams resample\n#' @param x Input Vector.\n#' @param k Integer: Number of folds.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nkfold <- function(\n x,\n k = 10,\n stratify_var = NULL,\n strat_n_bins = 4,\n seed = NULL,\n verbosity = TRUE\n) {\n if (!is.null(seed)) {\n set.seed(seed)\n }\n\n if (is.null(stratify_var)) {\n stratify_var <- x\n }\n stratify_var <- as.numeric(stratify_var)\n # ->> update\n max.bins <- length(unique(stratify_var))\n if (max.bins < strat_n_bins) {\n if (max.bins == 1) {\n cli::cli_abort(\"Only one unique value present in stratify_var.\")\n }\n if (verbosity > 0L) {\n msg0(\"Using max n bins possible = \", max.bins, \".\")\n }\n strat_n_bins <- max.bins\n }\n\n ids <- seq_along(x)\n # cuts\n cuts <- cut(stratify_var, breaks = strat_n_bins, labels = FALSE)\n cut.bins <- sort(unique(cuts))\n\n # ids by cut\n idl <- lapply(seq_along(cut.bins), function(i) ids[cuts == cut.bins[i]])\n # length of each cut\n # idl.length <- sapply(idl, length)\n idl.length <- as.numeric(table(cuts))\n\n # split each idl into k folds after randomizing them\n idl.k <- vector(\"list\", length(cut.bins))\n for (i in seq_along(cut.bins)) {\n cut1 <- cut(sample(idl.length[i]), breaks = k, labels = FALSE)\n idl.k[[i]] <- lapply(seq(k), function(j) idl[[i]][cut1 == j])\n }\n\n res <- lapply(\n seq(k),\n \\(i) {\n seq(ids)[-sort(unlist(lapply(seq_along(cut.bins), \\(j) idl.k[[j]][[i]])))]\n }\n )\n\n names(res) <- paste0(\"Fold_\", seq(k))\n attr(res, \"strat_n_bins\") <- strat_n_bins\n res\n} # /rtemis::kfold\n\n\n#' Resample using Stratified Subsamples\n#'\n#' @inheritParams resample\n#' @param x Input vector\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nstrat_sub <- function(\n x,\n n_resamples = 10,\n train_p = .75,\n stratify_var = NULL,\n strat_n_bins = 4,\n seed = NULL,\n verbosity = TRUE\n) {\n if (!is.null(seed)) {\n set.seed(seed)\n }\n if (is.null(stratify_var)) {\n stratify_var <- x\n }\n stratify_var <- as.numeric(stratify_var)\n max.bins <- length(unique(stratify_var))\n if (max.bins < strat_n_bins) {\n if (verbosity > 0L) {\n msg(\"Using max n bins possible =\", max.bins)\n }\n strat_n_bins <- max.bins\n }\n ids <- seq_along(x)\n cuts <- cut(stratify_var, breaks = strat_n_bins, labels = FALSE)\n cut.bins <- sort(unique(cuts))\n idl <- lapply(seq_along(cut.bins), function(i) ids[cuts == cut.bins[i]])\n idl.length <- as.numeric(table(cuts))\n res <- lapply(seq(n_resamples), function(i) {\n sort(unlist(sapply(seq_along(cut.bins), function(j) {\n sample(idl[[j]], train_p * idl.length[j])\n })))\n })\n names(res) <- paste0(\"Subsample_\", seq(n_resamples))\n attr(res, \"strat_n_bins\") <- strat_n_bins\n res\n} # /rtemis::strat_sub\n\n\n#' Stratified Bootstrap Resampling\n#'\n#' @inheritParams resample\n#' @param x Input vector\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nstrat_boot <- function(\n x,\n n_resamples = 10,\n train_p = .75,\n stratify_var = NULL,\n strat_n_bins = 4,\n target_length = NULL,\n seed = NULL,\n verbosity = TRUE\n) {\n if (!is.null(seed)) {\n set.seed(seed)\n }\n\n res_part1 <- strat_sub(\n x = x,\n n_resamples = n_resamples,\n train_p = train_p,\n stratify_var = stratify_var,\n strat_n_bins = strat_n_bins,\n verbosity = verbosity\n )\n\n # Make sure target_length was not too short by accident\n res.length <- length(res_part1[[1]])\n if (is.null(target_length)) {\n target_length <- length(x)\n }\n if (target_length < res.length) {\n target_length <- length(x)\n }\n\n # Add back this many cases\n add.length <- target_length - res.length\n doreplace <- ifelse(add.length > res.length, 1, 0)\n res_part2 <- lapply(\n res_part1,\n function(i) sample(i, add.length, replace = doreplace)\n )\n res <- mapply(c, res_part1, res_part2, SIMPLIFY = FALSE)\n res <- lapply(res, sort)\n names(res) <- paste0(\"StratBoot_\", seq(n_resamples))\n attr(res, \"strat_n_bins\") <- strat_n_bins\n res\n} # /rtemis::strat_boot\n\n\n#' Leave-one-out Resampling\n#'\n#' @param x Input vector\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nloocv <- function(x) {\n res <- lapply(seq(x), function(i) (seq(x))[-i])\n names(res) <- paste0(\"Fold_\", seq(res))\n res\n} # /rtemis::loocv\n" }, { "path": "R/rtemis-package.R", "content": "# rtemis-package.R\n# ::rtemis::\n# 2015- EDG rtemis.org\n\n#' \\pkg{rtemis}: Advanced Machine Learning and Visualization\n#'\n#' @description\n#' Advanced Machine Learning & Visualization made efficient, accessible, reproducible\n#'\n#' @section Online Documentation and Vignettes:\n#' \n#'\n#' @section System Setup:\n#' There are some options you can define in your .Rprofile (usually found in your home directory),\n#' so you do not have to define each time you execute a function.\n#' \\describe{\n#' \\item{rtemis_theme}{General plotting theme; set to e.g. \"whiteigrid\" or \"darkgraygrid\"}\n#' \\item{rtemis_font}{Font family to use in plots.}\n#' \\item{rtemis_palette}{Name of default palette to use in plots. See options by running `get_palette()`}\n#' }\n#' @section Visualization:\n#' Graphics are handled using the `draw` family, which produces interactive plots primarily using\n#' `plotly` and other packages.\n#'\n#' @section Supervised Learning:\n#' By convention, the last column of the data is the outcome variable, and all other columns are\n#' predictors. Convenience function [set_outcome] can be used to move a specified column to the\n#' end of the data.\n#' Regression and Classification is performed using `train()`.\n#' This function allows you to preprocess, train, tune, and test models on multiple resamples.\n#' Use [available_supervised] to get a list of available algorithms\n#'\n#' @section Classification:\n#' For training of binary classification models, the outcome should be provided as a factor,\n#' with the *second* level of the factor being the 'positive' class.\n#'\n#' @section Clustering:\n#' Clustering is performed using `cluster()`.\n#' Use [available_clustering] to get a list of available algorithms.\n#'\n#' @section Decomposition:\n#' Decomposition is performed using `decomp()`.\n#' Use [available_decomposition] to get a list of available algorithms.\n#'\n#' @section Type Documentation:\n#' Function documentation includes input type (e.g. \"Character\", \"Integer\",\n#' \"Float\"/\"Numeric\", etc).\n#' When applicable, value ranges are provided in interval notation. For example, Float: [0, 1)\n#' means floats between 0 and 1 including 0, but excluding 1.\n#' Categorical variables may include set of allowed values using curly braces.\n#' For example, Character: \\{\"future\", \"mirai\", \"none\"\\}.\n#'\n#' @section Tabular Data:\n#' \\pkg{rtemis} internally uses methods for efficient handling of tabular data, with support for\n#' `data.frame`, `data.table`, and `tibble`. If a function is documented as accepting\n#' \"tabular data\", it should work with any of these data structures. If a function is documented\n#' as accepting only one of these, then it should only be used with that structure.\n#' For example, some optimized `data.table` operations that perform in-place modifications only\n#' work with `data.table` objects.\n#'\n#' @name rtemis-package\n#' @import stats methods graphics grDevices S7 data.table htmltools\n#' @importFrom utils packageVersion sessionInfo getFromNamespace head tail\n\"_PACKAGE\"\n\nNULL\n" }, { "path": "R/rtemis_color_system.R", "content": "#' rtemis Color System\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nrtemis_light_teal <- \"#00fdfd\"\nrtemis_light_blue <- \"#30cefe\"\nrtemis_teal <- \"#00b2b2\"\nkaimana_red <- \"#ff004c\"\nkaimana_blue <- \"#0067e0\"\nkaimana_light_blue <- \"#479cff\"\ncoastside_orange <- \"#ff9f20\"\nrtemis_orange <- \"#ff4f36\"\nkaimana_green <- \"#00ffb3\"\nkaimana_med_green <- \"#00996b\"\nrtemis_purple <- \"#6125f7\"\nrtemis_magenta <- \"#912ac8\"\nrtemis_magenta_light <- \"#b25bd6\"\nmagenta <- \"#ff00ff\"\nlmd_burgundy <- \"#a92459\"\nrtms_gray <- \"#808080\"\n\nrt_gray <- rtms_gray\nrt_red <- kaimana_red\nrt_blue <- kaimana_light_blue\nrt_green <- kaimana_med_green\nrt_orange <- coastside_orange\nrt_teal <- rtemis_teal\nrt_purple <- rtemis_purple\nrt_magenta <- rtemis_magenta_light\n\n# %% rtemis colors ----\nhighlight_col <- rt_orange\ncol_object <- rt_gray # object name in repr_S7name\ncol_info <- highlight2_col <- lmd_burgundy\ncol_outer <- rt_green\ncol_tuner <- rt_blue\ncol_calibrator <- rt_magenta\n\n\n#' rtemis Color System\n#'\n#' A named list of colors used consistently across all packages\n#' in the rtemis ecosystem.\n#'\n#' Colors are provided as hex strings.\n#'\n#' @format A named list with the following elements:\n#' \\describe{\n#' \\item{red}{\"kaimana red\"}\n#' \\item{blue}{\"kaimana light blue\"}\n#' \\item{green}{\"kaimana medium green\"}\n#' \\item{orange}{\"coastside orange\"}\n#' \\item{teal}{\"rtemis teal\"}\n#' \\item{purple}{\"rtemis purple\"}\n#' \\item{magenta}{\"rtemis magenta\"}\n#' \\item{highlight_col}{\"highlight color\"}\n#' \\item{object}{\"rtemis teal\"}\n#' \\item{info}{\"lmd burgundy\"}\n#' \\item{outer}{\"kaimana red\"}\n#' \\item{tuner}{\"coastside orange\"}\n#' }\n#'\n#' @examples\n#' rtemis_colors[[\"orange\"]]\n#'\n#' @author EDG\n#'\n#' @export\n#'\n#' @examples\n#' rtemis_colors[[\"teal\"]]\nrtemis_colors <- list(\n red = rt_red,\n blue = rt_blue,\n green = rt_green,\n orange = rt_orange,\n teal = rt_teal,\n purple = rt_purple,\n magenta = rt_magenta,\n highlight_col = highlight_col,\n object = col_object,\n info = col_info,\n outer = col_outer,\n tuner = col_tuner\n) # /rtemis.utils::rtemis_colors\n" }, { "path": "R/theme.R", "content": "# theme.R\n# ::rtemis::\n# EDG rtemis.org\n\n# %% Black ----\n#' Themes for `draw_*` functions\n#'\n#' @param bg Color: Figure background.\n#' @param plot_bg Color: Plot region background.\n#' @param fg Color: Foreground color used as default for multiple elements like\n#' axes and labels, which can be defined separately.\n#' @param pch Integer: Point character.\n#' @param cex Float: Character expansion factor.\n#' @param lwd Float: Line width.\n#' @param bty Character: Box type: \"o\", \"l\", \"7\", \"c\", \"u\", or \"]\", or \"n\".\n#' @param box_col Box color if `bty != \"n\"`.\n#' @param box_alpha Float: Box alpha.\n#' @param box_lty Integer: Box line type.\n#' @param box_lwd Float: Box line width.\n#' @param grid Logical: If TRUE, draw grid in plot regions.\n#' @param grid_nx Integer: N of vertical grid lines.\n#' @param grid_ny Integer: N of horizontal grid lines.\n#' @param grid_col Grid color.\n#' @param grid_alpha Float: Grid alpha.\n#' @param grid_lty Integer: Grid line type.\n#' @param grid_lwd Float: Grid line width.\n#' @param axes_visible Logical: If TRUE, draw axes.\n#' @param axes_col Axes colors.\n#' @param tick_col Tick color.\n#' @param tick_alpha Float: Tick alpha.\n#' @param tick_labels_col Tick labels' color.\n#' @param tck `graphics::parr`'s tck argument: Tick length, can be negative.\n#' @param tcl `graphics::parr`'s tcl argument.\n#' @param x_axis_side Integer: Side to place x-axis.\n#' @param y_axis_side Integer: Side to place y-axis.\n#' @param labs_col Labels' color.\n#' @param x_axis_line Numeric: `graphics::axis`'s `line` argument for the x-axis.\n#' @param x_axis_las Numeric: `graphics::axis`'s `las` argument for the x-axis.\n#' @param x_axis_padj Numeric: x-axis' `padj`: Adjustment for the x-axis\n#' tick labels' position.\n#' @param x_axis_hadj Numeric: x-axis' `hadj`.\n#' @param y_axis_line Numeric: `graphics::axis`'s `line` argument for the y-axis.\n#' @param y_axis_las Numeric: `graphics::axis`'s `las` argument for the y-axis.\n#' @param y_axis_padj Numeric: y-axis' `padj`.\n#' @param y_axis_hadj Numeric: y-axis' `hadj`.\n#' @param xlab_line Numeric: Line to place `xlab`.\n#' @param ylab_line Numeric: Line to place `ylab`.\n#' @param zerolines Logical: If TRUE, draw lines on x = 0, y = 0, if within\n#' plot limits.\n#' @param zerolines_col Zerolines color.\n#' @param zerolines_alpha Float: Zerolines alpha.\n#' @param zerolines_lty Integer: Zerolines line type.\n#' @param zerolines_lwd Float: Zerolines line width.\n#' @param main_line Float: How many lines away from the plot region to draw\n#' title.\n#' @param main_adj Float: How to align title.\n#' @param main_font Integer: 1: Regular, 2: Bold.\n#' @param main_col Title color.\n#' @param font_family Character: Font to be used throughout plot.\n#'\n#' @return `Theme` object.\n#'\n#' @rdname theme\n#' @export\n#'\n#' @examples\n#' theme <- theme_black(font_family = \"Geist\")\n#' theme\ntheme_black <- function(\n bg = \"#000000\",\n plot_bg = \"transparent\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = FALSE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = fg,\n grid_alpha = .2,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = fg,\n tick_alpha = .5,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"black\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_black\n\n\n#' @rdname theme\n#' @export\ntheme_blackgrid <- function(\n bg = \"#000000\",\n plot_bg = \"transparent\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = fg,\n grid_alpha = .2,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = fg,\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"blackgrid\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_blackgrid\n\n\n#' @rdname theme\n#' @export\ntheme_blackigrid <- function(\n bg = \"#000000\",\n plot_bg = \"#1A1A1A\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = bg,\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = fg,\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"blackigrid\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_darkgrid\n\n\n#' @rdname theme\n#' @export\ntheme_darkgray <- function(\n bg = \"#121212\",\n plot_bg = \"transparent\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = FALSE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = fg,\n grid_alpha = .2,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = fg,\n tick_alpha = .5,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"darkgray\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_darkgray\n\n\n#' @rdname theme\n#' @export\ntheme_darkgraygrid <- function(\n bg = \"#121212\",\n plot_bg = \"transparent\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = \"#404040\",\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"#00000000\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"darkgraygrid\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_darkgraygrid\n\n\n#' @rdname theme\n#' @export\ntheme_darkgrayigrid <- function(\n bg = \"#121212\",\n plot_bg = \"#202020\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = bg,\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"transparent\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"darkgrayigrid\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_darkgrayigrid\n\n\n# %% White ----\n#' @rdname theme\n#' @export\ntheme_white <- function(\n bg = \"#ffffff\",\n plot_bg = \"transparent\",\n fg = \"#000000\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = FALSE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = fg,\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = fg,\n tick_alpha = .5,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"white\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_white\n\n#' @rdname theme\n#' @export\ntheme_whitegrid <- function(\n bg = \"#ffffff\",\n plot_bg = \"transparent\",\n fg = \"#000000\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = \"#c0c0c0\",\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"#00000000\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"whitegrid\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_whitegrid\n\n#' @rdname theme\n#' @export\ntheme_whiteigrid <- function(\n bg = \"#ffffff\",\n plot_bg = \"#E6E6E6\",\n fg = \"#000000\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = bg,\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"transparent\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"whiteigrid\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_whiteigrid\n\n\n# %% Gray ----\n#' @rdname theme\n#' @export\ntheme_lightgraygrid <- function(\n bg = \"#dfdfdf\",\n plot_bg = \"transparent\",\n fg = \"#000000\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = \"#c0c0c0\",\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"#00000000\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"lightgraygrid\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_lightgray\n\n\n#' @rdname theme\n#' @export\ntheme_mediumgraygrid <- function(\n bg = \"#b3b3b3\",\n plot_bg = \"transparent\",\n fg = \"#000000\",\n pch = 16,\n cex = 1,\n lwd = 2,\n # box --\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = .5,\n # grid --\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = \"#d0d0d0\",\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n # axes --\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"#00000000\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = .5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = .5,\n y_axis_hadj = .5,\n xlab_line = 1.4,\n ylab_line = 2,\n # zerolines --\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = .5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n # title --\n main_line = .25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n) {\n Theme(\n name = \"mediumgraygrid\",\n config = list(\n bg = bg,\n plot_bg = plot_bg,\n fg = fg,\n pch = pch,\n cex = cex,\n lwd = lwd,\n # box --\n bty = bty,\n box_col = box_col,\n box_alpha = box_alpha,\n box_lty = box_lty,\n box_lwd = box_lwd,\n # grid --\n grid = grid,\n grid_nx = grid_nx,\n grid_ny = grid_ny,\n grid_col = grid_col,\n grid_alpha = grid_alpha,\n grid_lty = grid_lty,\n grid_lwd = grid_lwd,\n # axes --\n axes_visible = axes_visible,\n axes_col = axes_col,\n tick_col = tick_col,\n tick_alpha = tick_alpha,\n tick_labels_col = tick_labels_col,\n tck = tck,\n tcl = tcl,\n x_axis_side = x_axis_side,\n y_axis_side = y_axis_side,\n labs_col = labs_col,\n x_axis_line = x_axis_line,\n x_axis_las = x_axis_las,\n x_axis_padj = x_axis_padj,\n x_axis_hadj = x_axis_hadj,\n y_axis_line = y_axis_line,\n y_axis_las = y_axis_las,\n y_axis_padj = y_axis_padj,\n y_axis_hadj = y_axis_hadj,\n xlab_line = xlab_line,\n ylab_line = ylab_line,\n # zerolines --\n zerolines = zerolines,\n zerolines_col = zerolines_col,\n zerolines_alpha = zerolines_alpha,\n zerolines_lty = zerolines_lty,\n zerolines_lwd = zerolines_lwd,\n # title --\n main_line = main_line,\n main_adj = main_adj,\n main_font = main_font,\n main_col = main_col,\n font_family = font_family\n )\n )\n} # /rtemis::theme_mediumdgray\n\n\n#' Print available \\pkg{rtemis} themes\n#'\n#' @return Called for its side effect of printing available themes.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' available_themes()\navailable_themes <- function() {\n cat(highlight(\" Available themes:\\n\"))\n cat(' \"white\", \"whitegrid\", \"whiteigrid,\\n')\n cat(' \"black\", \"blackgrid\", \"blackigrid\",\\n')\n cat(' \"darkgray\", \"darkgraygrid\", \"darkgrayigrid\",\\n')\n cat(' \"lightgraygrid\", \"mediumgraygrid\"\\n')\n invisible()\n}\n\n\n# %% choose_theme ----\n#' Select an rtemis theme\n#'\n#' @details\n#' If `x` is not defined, `choose_theme()` will use `getOption(\"rtemis_theme\", \"whitegrid\")` to\n#' select the theme. This allows users to set a default theme for all rtemis plots by setting\n#' `options(rtemis_theme = \"theme_name\")` at any point.\n#'\n#' @param x Character: Name of theme to select. If not defined, will use `getOption(\"rtemis_theme\", \"whitegrid\")`.\n#' @param override Optional List: Theme parameters to override defaults.\n#'\n#' @return `Theme` object.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' # Get default theme set by options(rtemis_theme = \"theme_name\").\n#' # If not set, defaults to \"whitegrid\":\n#' choose_theme()\n#' # Get darkgraygrid theme. Same as `theme_darkgraygrid()`:\n#' choose_theme(\"darkgraygrid\")\n#' # This will use the default theme, and override the foreground color to red:\n#' choose_theme(override = list(fg = \"#ff0000\"))\nchoose_theme <- function(\n x = c(\n \"white\",\n \"whitegrid\",\n \"whiteigrid\",\n \"black\",\n \"blackgrid\",\n \"blackigrid\",\n \"darkgray\",\n \"darkgraygrid\",\n \"darkgrayigrid\",\n \"lightgraygrid\",\n \"mediumgraygrid\"\n ),\n override = NULL\n) {\n if (length(x) > 1) {\n x <- getOption(\"rtemis_theme\", \"whitegrid\")\n }\n if (is.null(override)) {\n override <- list()\n }\n\n do_call(paste0(\"theme_\", x), override)\n} # /rtemis::theme\n" }, { "path": "R/train.R", "content": "# train.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% train ----\n#' Train Supervised Learning Models\n#'\n#' @description\n#' Preprocess, tune, train, and test supervised learning models using nested resampling in a single\n#' call.\n#'\n#' @param x Tabular data, i.e. data.frame, data.table, or tbl_df (tibble): Training set data.\n#' @param dat_validation Tabular data: Validation set data.\n#' @param dat_test Tabular data: Test set data.\n#' @param weights Optional vector of case weights.\n#' @param algorithm Character: Algorithm to use. Can be left NULL, if `hyperparameters` is defined.\n#' @param preprocessor_config Optional PreprocessorConfig object: Setup using [setup_Preprocessor].\n#' @param hyperparameters `Hyperparameters` object: Setup using one of `setup_*` functions.\n#' @param tuner_config TunerConfig object: Setup using [setup_GridSearch].\n#' @param outer_resampling_config Optional ResamplerConfig object: Setup using [setup_Resampler].\n#' This defines the outer resampling method, i.e. the splitting into training and test sets for the\n#' purpose of assessing model performance. If NULL, no outer resampling is performed, in which case\n#' you might want to use a `dat_test` dataset to assess model performance on a single test set.\n#' @param execution_config `ExecutionConfig` object: Setup using [setup_ExecutionConfig]. This\n#' allows you to set backend (\"future\", \"mirai\", or \"none\"), number of workers, and future plan if\n#' using `backend = \"future\"`.\n#' @param question Optional character string defining the question that the model is trying to\n#' answer.\n#' @param outdir Character, optional: String defining the output directory.\n#' @param verbosity Integer: Verbosity level.\n#' @param ... Not used.\n#'\n#' @details\n#' **Online book & documentation**\n#'\n#' See [docs.rtemis.org/r](https://docs.rtemis.org/r/) for detailed documentation.\n#'\n#' **Preprocessing**\n#'\n#' There are many different stages at which preprocessing could be applied, when running a\n#' supervised learning pipeline with nested resampling. Some operations are best done before\n#' passing data to `train()`:\n#'\n#' - Duplicate rows should be removed before resampling, so that duplicates don't end up in\n#' different resamples, e.g. one in training and one in test.\n#' - Constant columns should be removed before resampling. A column may appear constant in a small\n#' resample, even if it is not constant in the full dataset. Removing it inconsistently will\n#' throw an error during prediction.\n#' - All data-dependent preprocessing steps need to be performed on training data only and applied\n#' on validation and test data, e.g. scaling, centering, imputation.\n#'\n#' User-defined preprocessing through `preprocessor_config` is applied on training set data,\n#' the learned parameters are stored in the returned Supervised or SupervisedRes object, and the\n#' preprocessing is applied on validation and test data.\n#'\n#' **Binary Classification**\n#'\n#' For binary classification, the outcome should be a factor where *the 2nd level\n#' corresponds to the positive class*.\n#'\n#' **Resampling**\n#'\n#' Note that you should not use an outer resampling method with\n#' replacement if you will also be using an inner resampling (for tuning).\n#' The duplicated cases from the outer resampling may appear both in the\n#' training and test sets of the inner resamples, leading to underestimated\n#' test error.\n#'\n#' **Reproducibility**\n#'\n#' If using ***outer resampling***, you can set a seed when defining `outer_resampling_config`, e.g.\n#' ```r\n#' outer_resampling_config = setup_Resampler(n_resamples = 10L, type = \"KFold\", seed = 2026L)\n#' ```\n#' If using ***tuning with inner resampling***, you can set a seed when defining `tuner_config`,\n#' e.g.\n#' ```r\n#' tuner_config = setup_GridSearch(\n#' resampler_config = setup_Resampler(n_resamples = 5L, type = \"KFold\", seed = 2027L)\n#' )\n#' ```\n#'\n#' **Parallelization**\n#'\n#' There are three levels of parallelization that may be used during training:\n#'\n#' 1. Algorithm training (e.g. a parallelized learner like LightGBM)\n#' 2. Tuning (inner resampling, where multiple resamples can be processed in parallel)\n#' 3. Outer resampling (where multiple outer resamples can be processed in parallel)\n#'\n#' The `train()` function will automatically manage parallelization depending\n#' on:\n#' - The number of workers specified by the user using `n_workers`\n#' - Whether the training algorithm supports parallelization itself\n#' - Whether hyperparameter tuning is needed\n#'\n#' @return Object of class `Regression(Supervised)`, `RegressionRes(SupervisedRes)`,\n#' `Classification(Supervised)`, or `ClassificationRes(SupervisedRes)`.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' \\donttest{\n#' iris_c_lightRF <- train(\n#' iris,\n#' algorithm = \"LightRF\",\n#' outer_resampling_config = setup_Resampler(),\n#' )\n#' }\ntrain <- function(\n x,\n dat_validation = NULL,\n dat_test = NULL,\n weights = NULL,\n algorithm = NULL,\n preprocessor_config = NULL, # PreprocessorConfig\n hyperparameters = NULL, # Hyperparameters\n tuner_config = NULL, # TunerConfig\n outer_resampling_config = NULL, # ResamplerConfig\n execution_config = setup_ExecutionConfig(), # ExecutionConfig\n question = NULL,\n outdir = NULL,\n verbosity = 1L,\n ...\n) {\n # SuperConfigLive dispatch ----\n if (S7_inherits(x, SuperConfigLive)) {\n return(train(\n x = x@dat_training,\n dat_validation = x@dat_validation,\n dat_test = x@dat_test,\n weights = x@weights,\n preprocessor_config = x@preprocessor_config,\n algorithm = x@algorithm,\n hyperparameters = x@hyperparameters,\n tuner_config = x@tuner_config,\n outer_resampling_config = x@outer_resampling_config,\n execution_config = x@execution_config,\n question = x@question,\n outdir = x@outdir,\n verbosity = x@verbosity\n ))\n } # / train.SuperConfigLive\n\n # SuperConfig dispatch ----\n if (S7_inherits(x, SuperConfig)) {\n dat_training <- read(x@dat_training_path, character2factor = TRUE)\n dat_validation <- if (!is.null(x@dat_validation_path)) {\n read(x@dat_validation_path)\n } else {\n NULL\n }\n dat_test <- if (!is.null(x@dat_test_path)) {\n read(x@dat_test_path)\n } else {\n NULL\n }\n # Call train() with data and other parameters from config\n return(train(\n x = dat_training,\n dat_validation = dat_validation,\n dat_test = dat_test,\n weights = x@weights,\n preprocessor_config = x@preprocessor_config,\n algorithm = x@algorithm,\n hyperparameters = x@hyperparameters,\n tuner_config = x@tuner_config,\n outer_resampling_config = x@outer_resampling_config,\n execution_config = x@execution_config,\n question = x@question,\n outdir = x@outdir,\n verbosity = x@verbosity\n ))\n } # / train.SuperConfig\n\n # Checks ----\n if (is.null(hyperparameters) && is.null(algorithm)) {\n cli::cli_abort(\n \"You must define either {.arg hyperparameters} or {.arg algorithm}.\"\n )\n }\n\n extra_args <- list(...)\n if (length(extra_args) > 0L) {\n cli::cli_abort(\n \"Unused extra arguments were provided: {.val {names(extra_args)}}. Please check your function call.\"\n )\n }\n\n if (is.null(algorithm) && !is.null(hyperparameters)) {\n algorithm <- hyperparameters@algorithm\n }\n\n type <- supervised_type(x)\n ncols <- ncol(x)\n\n if (is.null(hyperparameters) && !is.null(algorithm)) {\n hyperparameters <- get_default_hyperparameters(\n algorithm,\n type = type,\n ncols = ncols\n )\n }\n\n if (\n !is.null(algorithm) &&\n tolower(algorithm) != tolower(hyperparameters@algorithm)\n ) {\n cli::cli_abort(\n \"You defined algorithm to be '{algorithm}', but defined hyperparameters for {hyperparameters@algorithm}.\"\n )\n }\n\n check_is_S7(hyperparameters, Hyperparameters)\n\n # Set default tuner_config if tuning is needed but none specified\n if (needs_tuning(hyperparameters) && is.null(tuner_config)) {\n tuner_config <- setup_GridSearch()\n }\n\n if (!is.null(tuner_config)) {\n check_is_S7(tuner_config, TunerConfig)\n }\n\n if (!is.null(preprocessor_config)) {\n check_is_S7(preprocessor_config, PreprocessorConfig)\n }\n\n # execution_config must always be set\n check_is_S7(execution_config, ExecutionConfig)\n # Override parallelization parameters with those from execution_config\n backend <- execution_config@backend\n n_workers <- execution_config@n_workers\n future_plan <- execution_config@future_plan\n\n # If outer_resampling_config is set, dat_validation and dat_test must be NULL\n if (!is.null(outer_resampling_config)) {\n if (!is.null(dat_validation) || !is.null(dat_test)) {\n cli::cli_abort(\n \"If outer_resampling_config is set, {.arg dat_validation} and {.arg dat_test} must be NULL.\"\n )\n }\n }\n\n if (backend == \"future\" && future_plan == \"mirai_multisession\") {\n future_plan <- \"future.mirai::mirai_multisession\"\n }\n if (!is.null(outer_resampling_config)) {\n check_is_S7(outer_resampling_config, ResamplerConfig)\n if (!is.null(outer_resampling_config[[\"id_strat\"]])) {\n stopifnot(length(outer_resampling_config[[\"id_strat\"]]) == NROW(x))\n }\n }\n\n algorithm <- get_alg_name(algorithm)\n if (!is.null(outdir)) {\n outdir <- make_path(outdir)\n if (!dir.exists(outdir)) {\n dir.create(outdir, showWarnings = FALSE, recursive = TRUE)\n }\n if (verbosity > 1L) {\n msg_info(\"Output directory set to \", outdir, \".\")\n }\n }\n\n logfile <- if (!is.null(outdir)) {\n paste0(\n outdir,\n \"/\",\n \"train_\",\n algorithm,\n \"_\",\n format(Sys.time(), \"%Y%m%d.%H%M%S\"),\n \".log\"\n )\n } else {\n NULL\n }\n\n # Start timer & logfile ----\n start_time <- intro(verbosity = verbosity, logfile = logfile)\n\n # Data ----\n if (type == \"Classification\") {\n classes <- levels(outcome(x))\n }\n\n ## Print data summary ----\n if (verbosity > 0L) {\n summarize_supervised(\n x = x,\n dat_validation = dat_validation,\n dat_test = dat_test\n )\n }\n\n # Init ----\n workers <- get_n_workers(\n algorithm = algorithm,\n hyperparameters = hyperparameters,\n outer_resampling_config = outer_resampling_config,\n n_workers = n_workers,\n verbosity = verbosity\n )\n hyperparameters@n_workers <- workers[[\"algorithm\"]]\n tuner <- NULL\n\n # Set backend to \"none\" if workers[[\"tuning\"]] == 1L\n backend <- if (workers[[\"tuning\"]] == 1L) {\n \"none\"\n } else {\n backend\n }\n\n # Preprocessors ----\n # `preprocessor`: User-level preprocessing (Preprocessor object created from\n # `setup_Preprocessor`). Handles scaling, imputation, encoding, etc.\n # `preprocessor_internal`: Algorithm-level preprocessing (Preprocessor object\n # returned by each train_*() method). Handles transformations the algorithm\n # requires internally (e.g. factor-to-integer conversion for LightGBM).\n # Both are stored on the trained model so predict() can re-apply them in order:\n # user-level first, then algorithm-level.\n # Initialized to NULL here; set in the single-model path below.\n # In the outer resampling path, each sub-model carries its own pair.\n preprocessor <- preprocessor_internal <- NULL\n\n # === Outer Resampling ===\n # Splits data into multiple training-test folds and calls train() recursively\n # on each. Each recursive call enters the Single Model path below (which may\n # itself tune via inner resampling). After all folds complete, execution falls\n # through to the Outer Aggregation path.\n if (!is.null(outer_resampling_config)) {\n msg0(\n fmt(\"<> \", col = col_outer, bold = TRUE),\n \"Training \",\n highlight(paste(algorithm, type)),\n \" using \",\n desc(outer_resampling_config),\n \"...\",\n verbosity = verbosity\n )\n outer_resampler <- resample(\n x,\n config = outer_resampling_config,\n verbosity = verbosity\n )\n models <- lapply(\n cli::cli_progress_along(\n seq_len(outer_resampler@config@n),\n name = \"Training outer resamples...\",\n type = \"tasks\"\n ),\n function(i) {\n train(\n x = x[outer_resampler[[i]], ],\n dat_test = x[-outer_resampler[[i]], ],\n algorithm = algorithm,\n preprocessor_config = preprocessor_config,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n outer_resampling_config = NULL, # This model is one of the outer resamples.\n execution_config = execution_config,\n weights = if (!is.null(weights)) {\n weights[outer_resampler[[i]]]\n } else {\n NULL\n },\n question = question,\n verbosity = verbosity - 1L\n )\n }\n )\n names(models) <- names(outer_resampler@resamples)\n hyperparameters@resampled <- 1L\n msg(\n fmt(\"\", col = col_outer, bold = TRUE),\n \"Outer resampling done.\",\n verbosity = verbosity\n )\n } # /Outer Resampling\n\n if (hyperparameters@resampled == 0L) {\n # === Inner path ===\n # Trains one model: optionally tune (inner resampling) → preprocess →\n # train algorithm → predict → returns Supervised.\n # Skipped when outer resampling was performed (resampled == 1L).\n\n # Tune ----\n # Inner resampling for hyperparameter optimization.\n if (needs_tuning(hyperparameters)) {\n tuner <- tune(\n x = x,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n preprocessor_config = preprocessor_config,\n weights = weights,\n backend = backend,\n future_plan = future_plan,\n n_workers = workers[[\"tuning\"]],\n verbosity = verbosity\n )\n # Update hyperparameters\n hyperparameters <- update(\n hyperparameters,\n tuner@best_hyperparameters,\n tuned = 1L\n )\n } # /Tune\n\n # User-level preprocessing ----\n if (!is.null(preprocessor_config)) {\n preprocessor <- preprocess(\n x = x,\n config = preprocessor_config,\n dat_validation = dat_validation,\n dat_test = dat_test\n )\n x <- if (is.null(dat_validation) && is.null(dat_test)) {\n preprocessor@preprocessed\n } else {\n preprocessor@preprocessed[[\"training\"]]\n }\n if (!is.null(dat_validation)) {\n dat_validation <- preprocessor@preprocessed[[\"validation\"]]\n }\n if (!is.null(dat_test)) dat_test <- preprocessor@preprocessed[[\"test\"]]\n } else {\n preprocessor <- NULL\n } # /User-level preprocessing\n\n # IFW ----\n # Weight calculation must follow preprocessing since N cases may change.\n if (type == \"Classification\" && hyperparameters[[\"ifw\"]]) {\n if (!is.null(weights)) {\n cli::cli_abort(\"Custom weights are defined, but IFW is set to TRUE.\")\n } else {\n weights <- ifw(x[[ncols]], type = \"case_weights\", verbosity = verbosity)\n }\n } # /IFW\n\n # Train algorithm ----\n if (is_tuned(hyperparameters)) {\n msg(\n \"Training\",\n highlight(paste(algorithm, type)),\n \"with tuned hyperparameters...\",\n verbosity = verbosity\n )\n } else {\n msg0(\n \"Training \",\n highlight(paste(algorithm, type)),\n \"...\",\n verbosity = verbosity\n )\n }\n # Validation data is only passed to learners that use early stopping.\n # For other learners, validation metrics are collected during tuning.\n dat_validation_for_training <- if (algorithm %in% early_stopping_algs) {\n dat_validation\n } else {\n NULL\n }\n\n trained <- train_(\n hyperparameters = hyperparameters,\n x = x,\n weights = weights,\n dat_validation = dat_validation_for_training,\n execution_config = execution_config, # used by LightRuleFit\n verbosity = verbosity\n )\n\n model <- trained[[\"model\"]]\n # Algorithm-level preprocessing (e.g. factor-to-integer for LightGBM),\n # returned by train_*() if needed.\n preprocessor_internal <- trained[[\"preprocessor\"]]\n\n # Predictions ----\n predicted_prob_training <- predicted_prob_validation <- predicted_prob_test <- NULL\n\n # Re-apply algorithm-level preprocessing before predicting on each dataset.\n x_features <- features(x)\n if (!is.null(preprocessor_internal)) {\n x_features <- preprocess(\n x_features,\n preprocessor_internal,\n verbosity = 0L\n ) |>\n preprocessed()\n }\n\n predicted_training <- predict_super(\n model = model,\n newdata = x_features,\n type = type\n )\n\n if (type == \"Classification\") {\n predicted_prob_training <- predicted_training\n predicted_training <- prob2categorical(\n predicted_prob_training,\n levels = classes\n )\n }\n\n predicted_validation <- predicted_test <- NULL\n if (!is.null(dat_validation)) {\n dat_validation_features <- features(dat_validation)\n if (!is.null(preprocessor_internal)) {\n dat_validation_features <- preprocess(\n dat_validation_features,\n preprocessor_internal,\n verbosity = 0L\n ) |>\n preprocessed()\n }\n\n predicted_validation <- predict_super(\n model = model,\n newdata = dat_validation_features,\n type = type\n )\n\n if (type == \"Classification\") {\n predicted_prob_validation <- predicted_validation\n predicted_validation <- prob2categorical(\n predicted_prob_validation,\n levels = classes\n )\n }\n }\n\n if (!is.null(dat_test)) {\n dat_test_features <- features(dat_test)\n if (!is.null(preprocessor_internal)) {\n dat_test_features <- preprocess(\n dat_test_features,\n preprocessor_internal,\n verbosity = 0L\n ) |>\n preprocessed()\n }\n\n predicted_test <- predict_super(\n model = model,\n newdata = dat_test_features,\n type = type\n )\n\n if (type == \"Classification\") {\n predicted_prob_test <- predicted_test\n predicted_test <- prob2categorical(\n predicted_prob_test,\n levels = classes\n )\n }\n }\n\n # Standard Errors ----\n # Use the same (algorithm-level preprocessed) features as predictions.\n se_training <- se_validation <- se_test <- NULL\n if (type == \"Regression\" && algorithm %in% se_compat_algorithms) {\n se_training <- se_super(model = model, newdata = x_features)\n if (!is.null(dat_validation)) {\n se_validation <- se_super(\n model = model,\n newdata = dat_validation_features\n )\n }\n if (!is.null(dat_test)) {\n se_test <- se_super(model = model, newdata = dat_test_features)\n }\n }\n\n # Return Supervised ----\n mod <- make_Supervised(\n algorithm = algorithm,\n model = model,\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner = tuner,\n execution_config = execution_config,\n y_training = x[[ncols]],\n y_validation = if (!is.null(dat_validation)) dat_validation[[ncols]],\n y_test = if (!is.null(dat_test)) dat_test[[ncols]],\n predicted_training = predicted_training,\n predicted_validation = predicted_validation,\n predicted_test = predicted_test,\n predicted_prob_training = predicted_prob_training,\n predicted_prob_validation = predicted_prob_validation,\n predicted_prob_test = predicted_prob_test,\n se_training = se_training,\n se_validation = se_validation,\n se_test = se_test,\n xnames = names(x)[-ncols],\n varimp = varimp_super(model = model),\n question = question\n )\n } else {\n # === Outer Aggregation path ===\n # Reached after outer resampling. Each sub-model (Supervised) in `models`\n # carries its own preprocessor pair. Aggregate results → SupervisedRes.\n y_training <- lapply(models, function(mod) mod@y_training)\n y_test <- lapply(models, function(mod) mod@y_test)\n predicted_training <- lapply(models, function(mod) mod@predicted_training)\n predicted_test <- lapply(models, function(mod) mod@predicted_test)\n if (type == \"Classification\") {\n predicted_prob_training <- lapply(\n models,\n function(mod) mod@predicted_prob_training\n )\n predicted_prob_test <- lapply(\n models,\n function(mod) mod@predicted_prob_test\n )\n } else {\n predicted_prob_training <- predicted_prob_test <- NULL\n }\n # Return SupervisedRes ----\n mod <- make_SupervisedRes(\n algorithm = algorithm,\n type = type,\n models = models,\n preprocessor = preprocessor,\n preprocessor_internal = preprocessor_internal,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n outer_resampler = outer_resampler,\n execution_config = execution_config,\n y_training = y_training,\n y_test = y_test,\n predicted_training = predicted_training,\n predicted_test = predicted_test,\n predicted_prob_training = predicted_prob_training,\n predicted_prob_test = predicted_prob_test,\n xnames = names(x)[-ncols],\n varimp = lapply(models, \\(mod) mod@varimp),\n question = question\n )\n }\n\n # Outro ----\n if (verbosity > 0L) {\n message()\n print(mod)\n message()\n }\n if (!is.null(outdir)) {\n rt_save(mod, outdir = outdir, file_prefix = paste0(\"train_\", algorithm))\n }\n outro(\n start_time,\n logfile = logfile,\n verbosity = verbosity\n )\n # Print object to logfile\n if (!is.null(logfile)) {\n cat(\n \"\\n\",\n repr(mod, output_type = \"plain\"),\n file = logfile,\n append = TRUE,\n sep = \"\"\n )\n }\n mod\n} # /rtemis::train\n\n\n# %% get_n_workers ----\n# Function to assign number of workers to algorithm, tuning, or outer resampling\n# based on whether algorithm is parallelized, tuning is needed, and outer resampling is set.\n\n#' Get Number of Workers\n#'\n#' Distribute workers across different parallelization levels: algorithm training,\n#' tuning (inner resampling), and outer resampling. Assigns workers to the innermost\n#' available parallelization level to avoid over-subscription.\n#'\n#' @param algorithm Character: Algorithm name.\n#' @param hyperparameters `Hyperparameters` object: Setup using one of `setup_*` functions.\n#' @param outer_resampling_config Optional ResamplerConfig object: Setup using [setup_Resampler].\n#' @param n_workers Integer: Total number of workers you want to use.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @details\n#' The function prioritizes parallelization levels as follows:\n#' 1. If algorithm is parallelized (e.g., LightGBM, Ranger): all workers go to algorithm\n#' 2. Else if tuning is needed: all workers go to tuning (inner resampling)\n#' 3. Else if outer resampling is set: all workers go to outer resampling\n#' 4. Else: sequential execution (1 worker each)\n#'\n#' @return Named list with the number of workers for each level:\n#' - `algorithm`: Number of workers for algorithm training.\n#' - `tuning`: Number of workers for tuning (if applicable).\n#' - `outer_resampling_config`: Number of workers for outer resampling (if applicable).\n#'\n#' @keywords internal\n#' @noRd\nget_n_workers <- function(\n algorithm,\n hyperparameters,\n outer_resampling_config,\n n_workers,\n verbosity = 1L\n) {\n # Input validation\n stopifnot(\n is.character(algorithm),\n length(algorithm) == 1L,\n is.numeric(n_workers),\n n_workers >= 1L,\n n_workers == as.integer(n_workers)\n )\n\n # Check parallelization conditions\n is_parallelized <- algorithm %in% live[[\"parallelized_learners\"]]\n requires_tuning <- needs_tuning(hyperparameters)\n requires_resampling <- !is.null(outer_resampling_config)\n\n # Assign workers to innermost parallelization level to avoid over-subscription\n if (is_parallelized) {\n # Parallelized algorithms get all workers, disable other parallelization\n workers_algorithm <- n_workers\n workers_tuning <- 1L\n workers_outer_resampling <- 1L\n if (verbosity > 1L && (requires_tuning || requires_resampling)) {\n msg(\n bold(algorithm),\n \"is parallelized. Disabling tuning parallelization.\"\n )\n }\n } else if (requires_tuning) {\n # Tuning gets all workers if algorithm is not parallelized\n workers_algorithm <- 1L\n workers_tuning <- n_workers\n workers_outer_resampling <- 1L\n if (requires_resampling) {\n msg(\n \"Tuning parallelization enabled.\",\n verbosity = verbosity\n )\n }\n } else if (requires_resampling) {\n # Outer resampling gets all workers if no tuning needed\n workers_algorithm <- 1L\n workers_tuning <- 1L\n workers_outer_resampling <- n_workers\n } else {\n # Sequential execution\n workers_algorithm <- 1L\n workers_tuning <- 1L\n workers_outer_resampling <- 1L\n }\n\n msg0(\n bold(\"//\"),\n \" Max workers: \",\n highlight(n_workers),\n \" => \",\n \"Algorithm: \",\n highlight(workers_algorithm),\n \"; Tuning: \",\n highlight(workers_tuning),\n \"; Outer Resampling: \",\n highlight(workers_outer_resampling),\n verbosity = verbosity\n )\n\n list(\n algorithm = workers_algorithm,\n tuning = workers_tuning,\n outer_resampling = workers_outer_resampling\n )\n} # /rtemis::get_n_workers\n" }, { "path": "R/train_CART.R", "content": "# train_CART.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% train_.CARTHyperparameters ----\n#' Train a CART decision tree\n#'\n#' Train a CART decision tree using `rpart`.\n#'\n#' CART does not need any special preprocessing.\n#' It works with numeric and factor variables and handles missing values.\n#' The \"train_*\" functions train a single model.\n#' Use [train] for tuning and test using nested cross-validation.\n#'\n#' @param hyperparameters `CARTHyperparameters` object: make using [setup_CART].\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation Optional tabular data: Not used for CART.\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, CARTHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"rpart\")\n\n # Arguments ----\n # Hyperparameters must be either untunable or frozen by `train`\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n\n # Data ----\n check_supervised(\n x = x,\n allow_missing = TRUE,\n verbosity = verbosity\n )\n if (is.null(weights)) {\n weights <- rep(1, NROW(x))\n }\n\n # Train ----\n # weights can't be NULL.\n # !If formula is character, the input to weights must be the unquoted column name in the data.frame\n # that contains weights, e.g. by doing cbind(x, weights = weights)\n model <- rpart::rpart(\n as.formula(make_formula(x)),\n data = x,\n weights = weights,\n control = rpart::rpart.control(\n minsplit = hyperparameters[[\"minsplit\"]],\n minbucket = hyperparameters[[\"minbucket\"]],\n cp = hyperparameters[[\"cp\"]],\n maxcompete = hyperparameters[[\"maxcompete\"]],\n maxsurrogate = hyperparameters[[\"maxsurrogate\"]],\n usesurrogate = hyperparameters[[\"usesurrogate\"]],\n surrogatestyle = hyperparameters[[\"surrogatestyle\"]],\n maxdepth = hyperparameters[[\"maxdepth\"]],\n xval = hyperparameters[[\"xval\"]]\n )\n )\n\n # Cost-Complexity Pruning ----\n if (!is.null(hyperparameters[[\"prune_cp\"]])) {\n model <- rpart::prune(model, cp = hyperparameters[[\"prune_cp\"]])\n }\n check_inherits(model, \"rpart\")\n list(model = model, preprocessor = NULL)\n} # /rtemis::train_.CARTHyperparameters\n\n\n# %% predict_super.class_rpart ----\n#' Predict from rpart model\n#'\n#' @param model rpart model.\n#' @param newdata tabular data: Data to predict on.\n#' @param type Character: Type of supervised learning (\"Classification\" or \"Regression\").\n#'\n#' @keywords internal\n#' @noRd\nmethod(predict_super, class_rpart) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n if (type == \"Classification\") {\n # Classification\n # predict.rpart returns a matrix n_cases x n_classes,\n # with classes are ordered the same as factor levels\n predicted_prob <- predict(model, newdata = newdata, type = \"prob\") # binclasspos = 2L\n if (NCOL(predicted_prob) == 2L) {\n # In binary classification, rpart returns matrix with 2 columns\n predicted_prob <- predicted_prob[, 2L]\n }\n predicted_prob\n } else {\n predict(model, newdata = newdata, type = \"vector\")\n }\n} # /rtemis::predict_super.rpart\n\n\n# %% varimp_super.class_rpart ----\n#' Get variable importance from rpart model\n#'\n#' @param model rpart model.\n#'\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, class_rpart) <- function(model) {\n vi <- model[[\"variable.importance\"]]\n VariableImportance(\n data.table(\n variable = names(vi),\n importance = unname(vi)\n )\n )\n} # /rtemis::varimp_super.rpart\n" }, { "path": "R/train_GAM.R", "content": "# train_GAM.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% train_.GAMHyperparameters ----\n#' Train a GAM model\n#'\n#' Train a GAM model using `GAM`.\n#'\n#' GAM does not work in the presence of missing values.\n#'\n#' @param hyperparameters `GAMHyperparameters` object: make using [setup_GAM].\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation Optional tabular data: Not used for GAM.\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, GAMHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"mgcv\")\n\n # Hyperparameters ----\n # Hyperparameters must be either untunable or frozen by `train`.\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n\n # Data ----\n check_supervised(\n x = x,\n allow_missing = FALSE,\n verbosity = verbosity\n )\n\n type <- supervised_type(x)\n n_classes <- if (type == \"Classification\") {\n nlevels(x[, ncol(x)])\n } else {\n NA\n }\n\n # Formula ----\n # use s(x, k = k) for all numeric predictors\n index_numeric <- which(sapply(features(x), is.numeric))\n spline_features <- if (length(index_numeric) > 0) {\n paste0(\n \"s(\",\n colnames(x)[index_numeric],\n \", k = \",\n hyperparameters[[\"k\"]],\n \")\",\n collapse = \" + \"\n )\n } else {\n \"\"\n }\n index_factor <- which(sapply(features(x), is.factor))\n categorical_features <- if (length(index_factor) > 0) {\n paste0(\n colnames(x)[index_factor],\n collapse = \" + \"\n )\n } else {\n \"\"\n }\n formula <- as.formula(\n gsub(\n \" \\\\+ $\",\n \"\",\n paste(\n outcome_name(x),\n \"~\",\n gsub(\n \"^ \\\\+ \",\n \"\",\n paste(spline_features, categorical_features, sep = \" + \")\n )\n )\n )\n )\n\n # Train ----\n family <- if (type == \"Regression\") {\n gaussian()\n } else if (type == \"Classification\") {\n if (n_classes == 2) {\n binomial()\n } else {\n mgcv::multinom()\n }\n }\n\n model <- mgcv::gam(\n formula = formula,\n family = family,\n data = x,\n weights = weights\n )\n check_inherits(model, \"gam\")\n list(model = model, preprocessor = NULL)\n} # /rtemis::train_.GAMHyperparameters\n\n\n# %% predict_super.class_gam ----\n#' Predict from GAM model\n#'\n#' @param model GAM model.\n#' @param newdata tabular data: Data to predict on.\n#' @param type Character: Type of supervised learning (\"Classification\" or \"Regression\").\n#'\n#' @keywords internal\n#' @noRd\nmethod(predict_super, class_gam) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n out <- predict(object = model, newdata = newdata, type = \"response\")\n if (model[[\"family\"]][[\"family\"]] == \"binomial\") {\n # mgvc::predict.gam returns an array of 1 dimension that causes errors during type-checking.\n out <- as.numeric(out)\n }\n out\n} # /rtemis::predict_super.gam\n\n\n# %% varimp_super.class_gam ----\n#' Get variable importance from GAM model\n#'\n#' Variable importance for GAM is estimated as the variance of each predictor's partial effect,\n#' obtained via predict(model, type = \"terms\"). This measures each smooth term's contribution to\n#' the variance of the fitted values. Values are normalized to sum to one, representing each\n#' predictor's proportion of total predicted variance. This approach is computationally efficient\n#' (no refitting required) and analogous to importance measures in tree-based methods. It assumes\n#' approximate uncorrelatedness of partial effects, which penalized smooths tend to satisfy. For\n#' models with high concurvity, consider hierarchical partitioning of R² (e.g. via the gam.hp\n#' package) as an alternative.\n#'\n#' @param model mgcv gam model.\n#'\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, class_gam) <- function(\n model,\n type = c(\"partial_effect\", \"F-test\")\n) {\n peff <- predict(model, type = \"terms\")\n vi <- apply(peff, 2, var)\n npeff <- vi / sum(vi) # normalized importance\n VariableImportance(\n data.table(\n variable = names(npeff),\n Partial_Effect_Variance = unname(npeff)\n )\n )\n} # /rtemis::varimp_super.gam\n\n\n# %% se_super.class_gam ----\n#' Get Standard Errors from GAM model\n#'\n#' @param model mgcv gam model.\n#' @param newdata tabular data: Data to predict on.\n#'\n#' @keywords internal\n#' @noRd\nmethod(se_super, class_gam) <- function(model, newdata) {\n predict(model, newdata = newdata, se.fit = TRUE)[[\"se.fit\"]]\n} # /rtemis::se_super.gam\n" }, { "path": "R/train_GLM.R", "content": "# train_GLM.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% train_.GLMHyperparameters ----\n#' Train a GLM model\n#'\n#' Train a GLM model using `stats::glm`.\n#'\n#' @details\n#' `stats::glm` does not work in the presence of missing values.\n#' This function uses the formula interface to `glm` to train a GLM model.\n#' No preprocessing is needed.\n#'\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param hyperparameters `GLMHyperparameters` object: make using [setup_GLM].\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @return GLM model.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, GLMHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Data ----\n check_supervised(\n x = x,\n allow_missing = FALSE,\n verbosity = verbosity\n )\n\n if (is.null(weights)) {\n weights <- rep(1, NROW(x))\n }\n\n type <- supervised_type(x)\n if (type == \"Classification\") {\n n_classes <- nlevels(outcome(x))\n if (n_classes > 2L) {\n cli::cli_abort(\"GLM does not support multiclass classification\")\n }\n } else {\n n_classes <- NA_integer_\n }\n\n # Formula ----\n formula <- as.formula(\n paste(\n names(x)[ncol(x)],\n \"~ .\"\n )\n )\n\n # Train ----\n family <- if (type == \"Regression\") {\n gaussian()\n } else if (type == \"Classification\") {\n binomial()\n }\n model <- glm(\n formula = formula,\n family = family,\n data = x,\n weights = weights\n )\n check_inherits(model, \"glm\")\n list(model = model, preprocessor = NULL)\n} # /rtemis::train_.GLMHyperparameters\n\n\n# %% predict_super.class_glm ----\n#' Predict from GLM model\n#'\n#' @param model GLM model.\n#' @param newdata data.frame or similar: Data to predict on.\n#'\n#' @keywords internal\n#' @noRd\nmethod(predict_super, class_glm) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n predict(model, newdata = newdata, type = \"response\")\n} # /rtemis::predict_super.glm\n\n\n# %% varimp_super.class_glm ----\n#' Get coefficients from GLM model\n#'\n#' @param model GLM model.\n#'\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, class_glm) <- function(\n model,\n type = c(\"coefficients\", \"p-value\")\n) {\n type <- match.arg(type)\n .coef <- if (type == \"coefficients\") {\n coef(model)\n } else if (type == \"p-value\") {\n summary(model)[[\"coefficients\"]][, 4]\n }\n VariableImportance(\n data.table(\n variable = names(.coef),\n Coefficient = unname(.coef)\n )\n )\n} # /rtemis::varimp_super.glm\n\n\n# %% se_super.class_glm ----\n#' Get Standard Errors from GLM model\n#'\n#' @param model GLM model.\n#' @param newdata data.frame or similar: Data to predict on.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(se_super, class_glm) <- function(model, newdata) {\n predict(model, newdata = newdata, se.fit = TRUE)[[\"se.fit\"]]\n} # /rtemis::se_super.glm\n" }, { "path": "R/train_GLMNET.R", "content": "# train_GLMNET.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% train_.GLMNETHyperparameters ----\n#' Train a GLMNET model\n#'\n#' Train a GLMNET model using `glmnet`.\n#'\n#' GLMNET does not work in the presence of missing values.\n#'\n#' @param hyperparameters `GLMNETHyperparameters` object: make using [setup_GLMNET].\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation tabular data: Validation set (unused).\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, GLMNETHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"glmnet\")\n\n # Hyperparameters ----\n # Hyperparameters must be either untunable or frozen by `train`.\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n\n # Convert \"null\" lambda to NULL\n if (hyperparameters[[\"lambda\"]] == \"null\") {\n hyperparameters@hyperparameters[[\"lambda\"]] <- NULL\n }\n\n # Data ----\n check_supervised(\n x = x,\n allow_missing = FALSE,\n verbosity = verbosity\n )\n\n # weights can't be NULL.\n if (is.null(weights)) {\n weights <- rep(1, NROW(x))\n }\n type <- supervised_type(x)\n n_classes <- if (type == \"Classification\") {\n nlevels(outcome(x))\n } else {\n NA_integer_\n }\n family <- if (is.null(hyperparameters[[\"family\"]])) {\n if (type == \"Regression\") {\n \"gaussian\"\n } else if (type == \"Classification\") {\n if (n_classes == 2L) {\n \"binomial\"\n } else {\n \"multinomial\"\n }\n }\n }\n\n # Train ----\n # Create xm so that the correct NCOL is used for penalty_factor,\n # since factors are converted to dummy variables.\n xm <- as.matrix(\n model.matrix(~., exc(x, NCOL(x)))[, -1]\n )\n # Check data-specific hyperparameter values\n # penalty_factor must be of length = N features.\n if (is.null(hyperparameters[[\"penalty_factor\"]])) {\n hyperparameters@hyperparameters[[\"penalty_factor\"]] <- rep(1, NCOL(xm))\n if (verbosity > 1L) {\n msg_info(\"NCOL(xm): \", NCOL(xm))\n msg_info('Updated hyperparameters[[\"penalty_factor\"]] to all 1s.')\n }\n } else {\n if (length(hyperparameters[[\"penalty_factor\"]]) != NCOL(xm)) {\n cli::cli_abort(\n \"Length of penalty_factor must be equal to the number of predictors.\"\n )\n }\n }\n # if lambda is NULL, use cv.glmnet to find optimal lambda\n if (is.null(hyperparameters[[\"lambda\"]])) {\n model <- glmnet::cv.glmnet(\n x = xm,\n y = outcome(x),\n family = family,\n weights = weights,\n offset = hyperparameters[[\"offset\"]],\n alpha = hyperparameters[[\"alpha\"]],\n nlambda = hyperparameters[[\"nlambda\"]],\n standardize = hyperparameters[[\"standardize\"]],\n intercept = hyperparameters[[\"intercept\"]], # can't be NULL\n penalty.factor = hyperparameters[[\"penalty_factor\"]]\n )\n check_inherits(model, \"cv.glmnet\")\n } else {\n model <- glmnet::glmnet(\n x = xm,\n y = outcome(x),\n family = family,\n weights = weights,\n offset = hyperparameters[[\"offset\"]],\n alpha = hyperparameters[[\"alpha\"]],\n nlambda = hyperparameters[[\"nlambda\"]],\n lambda = hyperparameters[[\"lambda\"]],\n standardize = hyperparameters[[\"standardize\"]],\n intercept = hyperparameters[[\"intercept\"]], # can't be NULL\n penalty.factor = hyperparameters[[\"penalty_factor\"]]\n )\n check_inherits(model, \"glmnet\")\n }\n list(model = model, preprocessor = NULL)\n} # /rtemis::train_.GLMNETHyperparameters\n\n#' Predict from GLMNET model\n#'\n#' @param model glmnet model.\n#' @param newdata data.frame or similar: Data to predict on.\n#' @param type Optional character: \"Regression\" or \"Classification\". Auto-detected if NULL.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(predict_super, class_glmnet) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n # Determine type\n # if model@classnames exists, type is Classification\n if (is.null(type)) {\n type <- if (!is.null(model[[\"classnames\"]])) {\n \"Classification\"\n } else {\n \"Regression\"\n }\n }\n newdata <- as.matrix(\n model.matrix(~., newdata)[, -1, drop = FALSE]\n )\n if (type == \"Regression\") {\n predict(model, newx = newdata, type = \"response\")[, 1]\n } else if (type == \"Classification\") {\n predicted_prob <- predict(model, newx = newdata, type = \"response\")\n if (NCOL(predicted_prob) == 1) {\n # In binary classification, glmnet returns matrix with 1 column\n # with probabilities of second level.\n predicted_prob <- as.numeric(predicted_prob)\n }\n predicted_prob\n }\n} # /rtemis::predict_super.class_glmnet\n\n#' @keywords internal\n#' @noRd\nmethod(predict_super, class_cv.glmnet) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n # Determine type\n # if model@classnames exists, type is Classification\n if (is.null(type)) {\n type <- if (!is.null(model[[\"classnames\"]])) {\n \"Classification\"\n } else {\n \"Regression\"\n }\n }\n newdata <- as.matrix(\n model.matrix(~., newdata)[, -1, drop = FALSE]\n )\n if (type == \"Regression\") {\n predict(model, newx = newdata, type = \"response\")[, 1]\n } else if (type == \"Classification\") {\n predicted_prob <- predict(model, newx = newdata, type = \"response\")\n if (NCOL(predicted_prob) == 1) {\n # In binary classification, glmnet returns matrix with 1 column\n # with probabilities of second level.\n predicted_prob <- as.numeric(predicted_prob)\n }\n predicted_prob\n }\n} # /rtemis::predict_super.class_cv.glmnet\n\n\n# %% varimp_super.class_glmnet ----\n#' Get coefficients from GLMNET model\n#'\n#' @param model glmnet model.\n#'\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, class_glmnet) <- function(model) {\n coefs <- coef(model)\n\n # In multiclass, coef(model) returns a list of coefficient matrices, one per class.\n # Not yet supported as VariableImportance.\n if (is.list(coefs)) {\n return(NULL)\n }\n\n if (NCOL(coefs) > 1) {\n msg(\"GLMNET with multiple sets of coefficients - returning first column.\")\n }\n\n # Exclude intercept\n coefs <- coefs[, 1][-1]\n VariableImportance(\n data.table(\n variable = names(coefs),\n Coefficient = unname(coefs)\n )\n )\n} # /rtemis::varimp_super.class_glmnet\n\n\n# %% varimp_super.class_cv.glmnet ----\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, class_cv.glmnet) <- function(model) {\n coefs <- coef(model)\n\n # In multiclass, coef(model) returns a list of coefficient matrices, one per class.\n # Not yet supported as VariableImportance.\n if (is.list(coefs)) {\n return(NULL)\n }\n\n # Exclude intercept\n coefs <- coefs[, 1][-1]\n VariableImportance(\n data.table(\n variable = names(coefs),\n Coefficient = unname(coefs)\n )\n )\n} # /rtemis::varimp_super.class_cv.glmnet\n" }, { "path": "R/train_Isotonic.R", "content": "# train_Isotonic.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% train_.IsotonicHyperparameters ----\n#' Train an Isotonic model\n#'\n#' @details\n#' This is primarily used for calibration of classification models.\n#' Binary classification will not work if x and y are not monotonic, i.e. higher values in `x` must\n#' correspond to `1`, i.e. positive class in y.\n#' outcome `1`.\n#'\n#' @param hyperparameters `IsotonicHyperparameters` object: make using [setup_Isotonic].\n#' @param x tabular data: Training set. Only a single predictor is allowed.\n#' @param weights Not used.\n#' @param dat_validation Not used.\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @return Object of class `stepfun`.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, IsotonicHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Data ----\n check_supervised(\n x = x,\n allow_missing = FALSE,\n verbosity = verbosity\n )\n if (NCOL(x) > 2) {\n cli::cli_abort(\"Isotonic requires a single predictor.\")\n }\n\n if (!is.null(weights)) {\n cli::cli_abort(\"Isotonic does not support weights.\")\n }\n\n type <- supervised_type(x)\n if (type == \"Classification\") {\n n_classes <- nlevels(outcome(x))\n if (n_classes > 2L) {\n cli::cli_abort(\"Isotonic does not support multiclass classification\")\n }\n # Assuming binclasspos = 2L\n y <- as.numeric(x[[2]]) - 1\n } else {\n y <- x[[2]]\n n_classes <- NA_integer_\n }\n\n # Model ----\n ir <- isoreg(cbind(x[[1]], y))\n model <- as.stepfun(ir)\n check_inherits(model, \"stepfun\")\n list(model = model, preprocessor = NULL)\n} # /rtemis::train_.IsotonicHyperparameters\n\n\n# %% predict_super.class_stepfun ----\n#' Predict from Isotonic model\n#'\n#' @param model Isotonic model.\n#' @param newdata data.frame or similar: Data to predict on.\n#' @param type Not used.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(predict_super, class_stepfun) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n model(newdata[[1]])\n} # /rtemis::predict_super.class_stepfun\n\n\n# %% varimp_super.class_stepfun ----\n#' Get coefficients from Isotonic model\n#'\n#' @param model Isotonic model.\n#'\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, class_stepfun) <- function(model) {\n NULL\n} # /rtemis::varimp_super.class_stepfun\n" }, { "path": "R/train_LightCART.R", "content": "# train_LightCART.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% train_.LightCARTHyperparameters ----\n#' Decision Tree using LightGBM\n#'\n#' @param hyperparameters `LightCARTHyperparameters` object: make using [setup_LightCART].\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation data.frame or similar: Validation set (not used for LightCART).\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, LightCARTHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"lightgbm\")\n\n # Hyperparameters ----\n # Hyperparameters must be either untunable or frozen by `train`.\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n\n # Data ----\n check_supervised(\n x = x,\n allow_missing = TRUE,\n verbosity = verbosity\n )\n type <- supervised_type(x)\n if (type == \"Classification\") {\n nclasses <- nlevels(outcome(x))\n } else {\n nclasses <- 1L\n }\n if (is.null(hyperparameters[[\"objective\"]])) {\n hyperparameters@hyperparameters[[\"objective\"]] <- if (\n type == \"Regression\"\n ) {\n \"regression\"\n } else {\n if (nclasses == 2L) {\n \"binary\"\n } else {\n \"multiclass\"\n }\n }\n }\n ## Preprocess & create lgb.Dataset ----\n lgb_data <- prepare_lgb_data(\n x = x,\n type = type,\n weights = weights,\n verbosity = verbosity\n )\n x <- lgb_data[[\"train_data\"]]\n prp <- lgb_data[[\"preprocessor\"]]\n\n # Train ----\n params <- hyperparameters@hyperparameters\n params[[\"ifw\"]] <- NULL\n # num_class is required for multiclass classification only, must be 1 or unset for regression & binary classification\n if (nclasses > 2L) {\n params[[\"num_class\"]] <- nclasses\n }\n # Set n threads\n params[[\"num_threads\"]] <- 1L\n\n model <- lightgbm::lgb.train(\n params = params,\n data = x,\n nrounds = 1L,\n valids = list(training = x),\n early_stopping_rounds = NULL,\n verbose = verbosity - 2L\n )\n check_inherits(model, \"lgb.Booster\")\n list(model = model, preprocessor = prp)\n} # /rtemis::train_.LightCARTHyperparameters\n" }, { "path": "R/train_LightGBM.R", "content": "# train_LightGBM.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# LightGBM parameters\n# https://lightgbm.readthedocs.io/en/latest/Parameters.html\n\n# %% train_.LightGBMHyperparameters ----\n#' Gradient Boosting with LightGBM\n#'\n#' @param hyperparameters `LightGBMHyperparameters` object: make using [setup_LightGBM].\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation Optional tabular data: Validation set for early stopping.\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, LightGBMHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"lightgbm\")\n\n # Hyperparameters ----\n # Hyperparameters must be either untunable or frozen by `train`.\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n\n # Convert \"null\" nrounds to max_nrounds\n if (hyperparameters[[\"nrounds\"]] == \"null\") {\n hyperparameters@hyperparameters[[\"nrounds\"]] <- hyperparameters[[\n \"max_nrounds\"\n ]]\n }\n\n # Data ----\n check_supervised(\n x = x,\n dat_validation = dat_validation,\n allow_missing = TRUE,\n verbosity = verbosity\n )\n type <- supervised_type(x)\n\n ## Objective ----\n if (type == \"Classification\") {\n nclasses <- nlevels(outcome(x))\n } else {\n nclasses <- 1L\n }\n if (is.null(hyperparameters[[\"objective\"]])) {\n hyperparameters@hyperparameters[[\"objective\"]] <- if (\n type == \"Regression\"\n ) {\n \"regression\"\n } else {\n if (nclasses == 2L) {\n \"binary\"\n } else {\n \"multiclass\"\n }\n }\n }\n\n ## Preprocess & create lgb.Datasets ----\n lgb_data <- prepare_lgb_data(\n x = x,\n dat_validation = dat_validation,\n type = type,\n weights = weights,\n verbosity = verbosity\n )\n x <- lgb_data[[\"train_data\"]]\n dat_validation <- lgb_data[[\"valid_data\"]]\n prp <- lgb_data[[\"preprocessor\"]]\n\n # Train ----\n params <- hyperparameters@hyperparameters\n params[[\"nrounds\"]] <- params[[\"max_nrounds\"]] <- params[[\n \"early_stopping_rounds\"\n ]] <- params[[\"force_nrounds\"]] <- params[[\"ifw\"]] <- NULL\n\n # num_class is required for multiclass classification only, must be 1 or unset for regression & binary classification\n if (nclasses > 2L) {\n params[[\"num_class\"]] <- nclasses\n }\n # Set n threads\n params[[\"num_threads\"]] <- prop(hyperparameters, \"n_workers\")\n\n model <- lightgbm::lgb.train(\n params = params,\n data = x,\n nrounds = hyperparameters[[\"nrounds\"]],\n valids = if (!is.null(dat_validation)) {\n list(training = x, validation = dat_validation)\n } else {\n list(training = x)\n },\n early_stopping_rounds = hyperparameters[[\"early_stopping_rounds\"]],\n verbose = verbosity - 1L\n )\n check_inherits(model, \"lgb.Booster\")\n list(model = model, preprocessor = prp)\n} # /rtemis::train_.LightGBMHyperparameters\n\n\n# %% predict_super.class_lgb.Booster ----\n#' Predict from LightGBM model\n#'\n#' @param model lgb.Booster object.\n#' @param newdata tabular data: Data to predict on. Will have been preprocessed by\n#' `predict.Supervised` before calling this method if algorithm-specific preprocessing was performed during training.\n#' @param type Character: Type of supervised learning.\n#'\n#' @keywords internal\n#' @noRd\nmethod(predict_super, class_lgb.Booster) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n check_inherits(model, \"lgb.Booster\")\n check_inherits(newdata, \"data.frame\")\n\n # Algorithm-specific preprocessing (factor2integer) is applied by\n # predict.Supervised before calling this method. See R/train.R and R/07_Supervised.R\n\n # Predict ----\n predict(model, newdata = as.matrix(newdata))\n} # /rtemis::predict_super.lgb.Booster\n\n\n# %% varimp_super.class_lgb.Booster ----\n#' Get variable importance from LightGBM model\n#'\n#' @param model lgb.Booster object.\n#'\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, class_lgb.Booster) <- function(model) {\n check_inherits(model, \"lgb.Booster\")\n vi <- lightgbm::lgb.importance(model, percentage = TRUE) # -> data.table\n names(vi)[1] <- \"variable\"\n VariableImportance(vi)\n} # /rtemis::varimp_super.lgb.Booster\n" }, { "path": "R/train_LightRF.R", "content": "# train_LightRF.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# References\n# LightGBM parameters: https://lightgbm.readthedocs.io/en/latest/Parameters.html\n\n# %% train_.LightRFHyperparameters ----\n#' Random Forest using LightGBM\n#'\n#' @param hyperparameters `LightRFHyperparameters` object: make using [setup_LightRF].\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation Optional tabular data: Validation set for early stopping.\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, LightRFHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"lightgbm\")\n\n # Hyperparameters ----\n # Hyperparameters must be either untunable or frozen by `train`.\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n\n # Data ----\n check_supervised(\n x = x,\n dat_validation = dat_validation,\n allow_missing = TRUE,\n verbosity = verbosity\n )\n type <- supervised_type(x)\n if (type == \"Classification\") {\n nclasses <- nlevels(outcome(x))\n } else {\n nclasses <- 1L\n }\n if (is.null(hyperparameters[[\"objective\"]])) {\n hyperparameters@hyperparameters[[\"objective\"]] <- if (\n type == \"Regression\"\n ) {\n \"regression\"\n } else {\n if (nclasses == 2L) {\n \"binary\"\n } else {\n \"multiclass\"\n }\n }\n }\n\n ## Preprocess & create lgb.Datasets ----\n lgb_data <- prepare_lgb_data(\n x = x,\n dat_validation = dat_validation,\n type = type,\n weights = weights,\n verbosity = verbosity\n )\n x <- lgb_data[[\"train_data\"]]\n dat_validation <- lgb_data[[\"valid_data\"]]\n prp <- lgb_data[[\"preprocessor\"]]\n\n # Train ----\n params <- hyperparameters@hyperparameters\n # Remove params that are not used by LightGBM\n params[[\"ifw\"]] <- NULL\n params[[\"nrounds\"]] <- params[[\"early_stopping_rounds\"]] <- NULL\n # num_class is required for multiclass classification only, must be 1 or unset for regression & binary classification\n if (nclasses > 2L) {\n params[[\"num_class\"]] <- nclasses\n }\n # Set n threads\n params[[\"num_threads\"]] <- prop(hyperparameters, \"n_workers\")\n\n model <- lightgbm::lgb.train(\n params = params,\n data = x,\n nrounds = hyperparameters[[\"nrounds\"]],\n valids = if (!is.null(dat_validation)) {\n list(training = x, validation = dat_validation)\n } else {\n list(training = x)\n },\n early_stopping_rounds = hyperparameters[[\"early_stopping_rounds\"]],\n verbose = verbosity - 2L\n )\n check_inherits(model, \"lgb.Booster\")\n list(model = model, preprocessor = prp)\n} # /rtemis::train_.LightRFHyperparameters\n" }, { "path": "R/train_LightRuleFit.R", "content": "# train_LightRuleFit.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% train_.LightRuleFitHyperparameters ----\n#' Train a LightRuleFit model\n#'\n#' Train a LightRuleFit model using LightGBM and GLMNET.\n#'\n#' @param hyperparameters `LightRuleFitHyperparameters` object: make using [setup_LightRuleFit].\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation tabular data: Validation set.\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, LightRuleFitHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"lightgbm\", \"glmnet\", \"matrixStats\", \"gsubfn\")\n\n # Hyperparameters ----\n # Hyperparameters must be either untunable or frozen by `train`.\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n\n # Data ----\n check_supervised(\n x = x,\n dat_validation = dat_validation,\n allow_missing = TRUE,\n verbosity = verbosity\n )\n type <- supervised_type(x)\n nclasses <- if (type == \"Classification\") nlevels(x[[ncol(x)]]) else 1L\n\n # IFW for LightGBM ----\n # See setup_LightRuleFit: You can choose to use IFW for both steps with `ifw = TRUE` OR control each steps individually using `ifw_lightgbm` and `ifw_glmnet`.\n lightgbm_weights <- if (hyperparameters[[\"ifw_lightgbm\"]]) {\n ifw(x[[ncol(x)]], verbosity = verbosity)\n } else {\n weights\n }\n\n # Train Gradient Boosting using LightGBM ----\n # LightRuleFit_tunable includes the names of all LightGBM hyperparameters used by LightRuleFit.\n lgbm_parameters <- update(\n setup_LightGBM(),\n get_hyperparams(hyperparameters, LightRuleFit_lightgbm_params)\n )\n lgbm_parameters@hyperparameters[[\"ifw\"]] <- hyperparameters[[\"ifw_lightgbm\"]]\n mod_lgbm <- train(\n x = x,\n dat_validation = dat_validation,\n weights = lightgbm_weights,\n hyperparameters = lgbm_parameters,\n # tuner_config = tuner_config, # ? add tuner_config to LightRuleFitHyperparameters\n outer_resampling_config = NULL,\n execution_config = execution_config,\n verbosity = verbosity\n )\n\n # Extract Rules from Boosted Trees ----\n lgbm_rules <- extract_rules(\n mod_lgbm@model,\n n_iter = NULL,\n xnames = names(x),\n factor_levels = get_factor_levels(x)\n )\n\n # Match cases x rules ----\n cases_by_rules <- match_cases_by_rules(x, lgbm_rules, verbosity = verbosity)\n\n # IFW for LASSO ----\n glmnet_weights <- if (hyperparameters[[\"ifw_glmnet\"]]) {\n ifw(x[[ncol(x)]], verbosity = verbosity)\n } else {\n weights\n }\n\n # LASSO: Select Rules ----\n lasso_hyperparameters <- setup_GLMNET(\n alpha = hyperparameters[[\"alpha\"]],\n lambda = hyperparameters[[\"lambda\"]]\n )\n dat_rules <- data.frame(cases_by_rules, y = x[[ncol(x)]])\n colnames(dat_rules)[ncol(dat_rules)] <- colnames(x)[ncol(x)]\n mod_glmnet <- train(\n dat_rules,\n hyperparameters = lasso_hyperparameters,\n weights = glmnet_weights,\n execution_config = execution_config,\n verbosity = verbosity\n )\n\n # Rule coefficients ----\n rules_coefs <- data.matrix(coef(mod_glmnet@model))\n # Need special handling for multiclass support starting here\n intercept_coef <- rules_coefs[1, , drop = FALSE]\n colnames(intercept_coef) <- \"Coefficient\"\n rules_coefs <- data.frame(Rule = lgbm_rules, Coefficient = rules_coefs[-1, 1])\n nonzero_index <- which(abs(rules_coefs[[\"Coefficient\"]]) > 0)\n rules_selected <- lgbm_rules[nonzero_index]\n cases_by_rules_selected <- cases_by_rules[, nonzero_index]\n Ncases_by_rules <- matrixStats::colSums2(cases_by_rules_selected)\n\n # Empirical risk ----\n if (type == \"Classification\" && nclasses == 2) {\n x <- as.data.table(x)\n empirical_risk <- vector(\"numeric\", length(rules_selected))\n for (i in seq_along(rules_selected)) {\n match <- x[eval(parse(text = rules_selected[i])), ]\n freq <- table(match[[ncol(match)]])\n empirical_risk[i] <- freq[mod_glmnet@binclasspos] / sum(freq)\n }\n } else {\n empirical_risk <- NULL\n }\n\n # Format Rules ----\n # => Check format_LightRuleFit_rules' use of gsubfn::gsubfn\n rules_selected_formatted <- format_LightRuleFit_rules(\n rules_selected,\n decimal_places = 2\n )\n # appease R CMD check\n Coefficient <- NULL\n rules_selected_formatted_coefs <- data.table(\n Rule_ID = seq(rules_selected_formatted),\n Rule = rules_selected_formatted,\n N_Cases = Ncases_by_rules,\n Coefficient = rules_coefs[[\"Coefficient\"]][nonzero_index]\n )\n if (type == \"Classification\" && nclasses == 2) {\n # appease R CMD check\n Empirical_Risk <- NULL\n rules_selected_formatted_coefs[, Empirical_Risk := empirical_risk]\n }\n setorder(rules_selected_formatted_coefs, -Coefficient)\n\n # LightRuleFit ----\n model <- LightRuleFit(\n model_lightgbm = mod_lgbm,\n model_glmnet = mod_glmnet,\n rules = lgbm_rules,\n rules_coefs = rules_coefs,\n rules_index = nonzero_index,\n rules_selected = rules_selected,\n rules_selected_formatted = rules_selected_formatted,\n rules_selected_formatted_coefs = rules_selected_formatted_coefs,\n y_levels = levels(x[[ncol(x)]]),\n xnames = names(x)[-ncol(x)],\n complexity_metrics = data.frame(\n n_rules_total = length(lgbm_rules),\n n_nonzero_rules = length(nonzero_index)\n )\n )\n list(model = model, preprocessor = NULL)\n} # /rtemis::train_.LightRuleFitHyperparameters\n\n\n# %% predict_super.LightRuleFitHyperparameters ----\n#' Predict from LightRuleFit LightGBM model\n#'\n#' @param model LightRuleFit object trained using `train_LightRuleFit`.\n#' @param newdata data.frame or similar: Data to predict on.\n#'\n#' @keywords internal\n#' @noRd\nmethod(predict_super, LightRuleFit) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n check_inherits(newdata, \"data.frame\")\n\n rules <- model@rules\n cases_by_rules <- match_cases_by_rules(newdata, rules, verbosity = verbosity)\n datm <- data.matrix(cases_by_rules)\n if (model@model_lightgbm@type == \"Classification\") {\n predicted <- predict(\n model@model_glmnet@model,\n newx = datm,\n type = \"response\"\n )\n if (length(model@y_levels) == 2) {\n predicted[, 1]\n } else {\n predicted\n }\n } else {\n as.numeric(predict(model@model_glmnet@model, newx = datm))\n }\n} # /rtemis::predict_super.LightRuleFit\n\n\n# %% varimp_super.LightRuleFit ----\n#' Get variable importance from LightRuleFit model\n#'\n#' @param model LightRuleFit object trained using `train_LightRuleFit`.\n#'\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, LightRuleFit) <- function(model) {\n .coef <- coef(model@model_glmnet@model)[-1, , drop = FALSE]\n VariableImportance(\n data.table(\n variable = rownames(.coef),\n Coefficient = unname(.coef[, 1])\n )\n )\n} # /rtemis::varimp_super.LightRuleFit\n" }, { "path": "R/train_Ranger.R", "content": "# train_Ranger.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# References\n# https://imbs-hl.github.io/ranger/reference/ranger.html\n\n# %% train_.RangerHyperparameters ----\n#' Random Forest using Ranger\n#'\n#' @param hyperparameters `RangerHyperparameters`: Hyperparameters for Ranger.\n#' @param x tabular data: Training data.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation tabular data: Validation data (currently unused).\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `ranger` model object.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, RangerHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"ranger\")\n\n # Hyperparameters ----\n # Hyperparameters must be either untunable or frozen by `train`.\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n # mtry cannot be larger than number of features\n if (any(hyperparameters@hyperparameters[[\"mtry\"]] > NCOL(features(x)))) {\n cli::cli_abort(\n \"mtry cannot be greater than number of features: {ncol(features(x))}.\"\n )\n }\n\n # Data ----\n check_supervised(\n x = x,\n allow_missing = TRUE,\n verbosity = verbosity\n )\n type <- supervised_type(x)\n\n # Train ----\n model <- ranger::ranger(\n formula = NULL,\n x = features(x),\n y = outcome(x),\n num.trees = hyperparameters@hyperparameters[[\"num_trees\"]],\n mtry = hyperparameters@hyperparameters[[\"mtry\"]],\n importance = hyperparameters@hyperparameters[[\"importance\"]],\n write.forest = hyperparameters@hyperparameters[[\"write_forest\"]],\n probability = type == \"Classification\",\n min.node.size = hyperparameters@hyperparameters[[\"min_node_size\"]],\n min.bucket = hyperparameters@hyperparameters[[\"min_bucket\"]],\n max.depth = hyperparameters@hyperparameters[[\"max_depth\"]],\n replace = hyperparameters@hyperparameters[[\"replace\"]],\n sample.fraction = hyperparameters@hyperparameters[[\"sample_fraction\"]],\n case.weights = weights,\n splitrule = hyperparameters@hyperparameters[[\"splitrule\"]],\n num.random.splits = hyperparameters@hyperparameters[[\"num_random_splits\"]],\n alpha = hyperparameters@hyperparameters[[\"alpha\"]],\n minprop = hyperparameters@hyperparameters[[\"minprop\"]],\n poisson.tau = hyperparameters@hyperparameters[[\"poisson_tau\"]],\n split.select.weights = hyperparameters@hyperparameters[[\n \"split_select_weights\"\n ]],\n always.split.variables = hyperparameters@hyperparameters[[\n \"always_split_variables\"\n ]],\n respect.unordered.factors = hyperparameters@hyperparameters[[\n \"respect_unordered_factors\"\n ]],\n scale.permutation.importance = hyperparameters@hyperparameters[[\n \"scale_permutation_importance\"\n ]],\n local.importance = hyperparameters@hyperparameters[[\"local_importance\"]],\n regularization.factor = hyperparameters@hyperparameters[[\n \"regularization_factor\"\n ]],\n regularization.usedepth = hyperparameters@hyperparameters[[\n \"regularization_usedepth\"\n ]],\n keep.inbag = hyperparameters@hyperparameters[[\"keep_inbag\"]],\n inbag = hyperparameters@hyperparameters[[\"inbag\"]],\n holdout = hyperparameters@hyperparameters[[\"holdout\"]],\n quantreg = hyperparameters@hyperparameters[[\"quantreg\"]],\n time.interest = hyperparameters@hyperparameters[[\"time_interest\"]],\n oob.error = hyperparameters@hyperparameters[[\"oob_error\"]],\n num.threads = prop(hyperparameters, \"n_workers\"),\n save.memory = hyperparameters@hyperparameters[[\"save_memory\"]],\n verbose = verbosity > 0L,\n node.stats = hyperparameters@hyperparameters[[\"node_stats\"]],\n seed = hyperparameters@hyperparameters[[\"seed\"]],\n na.action = hyperparameters@hyperparameters[[\"na_action\"]]\n )\n check_inherits(model, \"ranger\")\n list(model = model, preprocessor = NULL)\n} # /rtemis::train_.RangerHyperparameters\n\n#' Predict from Ranger model\n#'\n#' @param model `ranger` model object.\n#' @param newdata data.frame or similar: Data to predict on.\n#' @param type Character: Prediction type.\n#' @param verbosity Integer: Verbosity level.\n#' @param ranger_type Character: Ranger prediction type.\n#' @param ... Additional arguments passed to ranger predict.\n#'\n#' @keywords internal\n#' @noRd\nmethod(predict_super, class_ranger) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n check_inherits(model, \"ranger\")\n check_inherits(newdata, \"data.frame\")\n\n # Predict ----\n predicted <- predict(\n model,\n data = newdata,\n type = \"response\",\n verbose = verbosity > 0L\n )[[\"predictions\"]]\n if (type == \"Classification\" && NCOL(predicted) == 2L) {\n # In binary classification, ranger returns matrix with 2 columns\n # with probabilities for each class\n predicted <- predicted[, 2L]\n }\n predicted\n} # /rtemis::predict_super.class_ranger\n\n\n# %% varimp_super.class_ranger ----\n#' Get variable importance from Ranger model\n#'\n#' @param model `ranger` model object.\n#'\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, class_ranger) <- function(model) {\n check_inherits(model, \"ranger\")\n vi <- ranger::importance(model)\n VariableImportance(\n data.table(\n variable = names(vi),\n importance = unname(vi)\n )\n )\n} # /rtemis::varimp_super.class_ranger\n\n\n# %% validate_hyperparameters.RangerHyperparameters ----\n#' Validate Ranger Hyperparameters\n#'\n#' Validate Ranger Hyperparameters given training data.\n#'\n#' @param x tabular data: Training data.\n#' @param hyperparameters `RangerHyperparameters`: Hyperparameters to check.\n#'\n#' @return NULL. Will throw error if hyperparameters are invalid.\n#'\n#' @keywords internal\n#' @noRd\nmethod(validate_hyperparameters, RangerHyperparameters) <- function(\n x,\n hyperparameters\n) {\n check_is_S7(x, class_data.frame)\n check_is_S7(hyperparameters, RangerHyperparameters)\n\n # Check mtry\n if (any(hyperparameters@hyperparameters[[\"mtry\"]] > NCOL(features(x)))) {\n cli::cli_abort(\n \"mtry cannot be greater than number of features: {ncol(features(x))}.\"\n )\n }\n\n hyperparameters\n} # /rtemis::validate_hyperparameters.RangerHyperparameters\n" }, { "path": "R/train_SVM.R", "content": "# train_SVM.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% train_.LinearSVMHyperparameters ----\n#' Train a Linear SVM model\n#'\n#' Train a Linear SVM model using `e1071::svm`.\n#'\n#' SVM does not work in the presence of missing values.\n#'\n#' @param hyperparameters `LinearSVMHyperparameters` object: make using [setup_LinearSVM].\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation Optional tabular data: Not used for Linear SVM.\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @return Object of class `svm`.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, LinearSVMHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"e1071\")\n\n # Checks ----\n if (!is.null(weights)) {\n cli::cli_abort(\n \"Case weights are not supported by e1071::svm. You can enable `ifw` in the hyperparameters to use inverse frequency weighting instead.\"\n )\n }\n\n # Hyperparameters ----\n # Hyperparameters must be either untunable or frozen by `train`.\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n\n # Data ----\n check_supervised(\n x = x,\n allow_missing = FALSE,\n verbosity = verbosity\n )\n\n type <- supervised_type(x)\n n_classes <- if (type == \"Classification\") {\n nlevels(outcome(x))\n } else {\n NA\n }\n\n # Preprocess ----\n # One-hot encode\n y <- outcome(x)\n x <- features(x)\n factor_index <- names(x)[which(sapply(x, is.factor))]\n if (length(factor_index) > 0L) {\n prp <- preprocess(\n x,\n config = setup_Preprocessor(one_hot = TRUE),\n verbosity = verbosity\n )\n x <- preprocessed(prp)\n } else {\n prp <- NULL\n }\n\n # Can use class_weights or set class.weights = \"inverse\" in svm()\n # if (is.null(weights)) {\n # weights <- rep(1, NROW(x))\n # }\n\n # Train ----\n class_weights <-\n if (\n type == \"Classification\" && n_classes == 2 && hyperparameters[[\"ifw\"]]\n ) {\n \"inverse\"\n } else {\n NULL\n }\n # gamma can't be NULL even if not used\n gamma <- hyperparameters[[\"gamma\"]]\n if (is.null(gamma)) {\n gamma <- 1\n }\n model <- e1071::svm(\n x = x,\n y = y, # factor or numeric\n kernel = hyperparameters[[\"kernel\"]],\n cost = hyperparameters[[\"cost\"]],\n gamma = gamma,\n class.weights = class_weights,\n probability = TRUE\n )\n check_inherits(model, \"svm\")\n list(model = model, preprocessor = prp)\n} # /rtemis::train_.LinearSVMHyperparameters\n\n\n# %% train_.RadialSVMHyperparameters ----\n#' Train a Radial SVM model\n#'\n#' Train a Radial SVM model using `e1071::svm`.\n#'\n#' SVM does not work in the presence of missing values.\n#'\n#' @param hyperparameters `RadialSVMHyperparameters` object: make using [setup_RadialSVM].\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation Optional tabular data: Not used for Radial SVM.\n#' @param verbosity Integer: If > 0, print messages.\n#'\n#' @return Object of class `svm`.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, RadialSVMHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"e1071\")\n\n # Checks ----\n if (!is.null(weights)) {\n cli::cli_abort(\n \"Case weights are not supported by e1071::svm. You can enable `ifw` in the hyperparameters to use inverse frequency weighting instead.\"\n )\n }\n\n # Hyperparameters ----\n # Hyperparameters must be either untunable or frozen by `train`.\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n\n # Data ----\n check_supervised(\n x = x,\n allow_missing = FALSE,\n verbosity = verbosity\n )\n\n type <- supervised_type(x)\n n_classes <- if (type == \"Classification\") {\n nlevels(outcome(x))\n } else {\n NA\n }\n\n # Preprocess ----\n # One-hot encode\n y <- outcome(x)\n x <- features(x)\n factor_index <- names(x)[which(sapply(x, is.factor))]\n if (length(factor_index) > 0L) {\n prp <- preprocess(\n x,\n config = setup_Preprocessor(one_hot = TRUE),\n verbosity = verbosity\n )\n x <- preprocessed(prp)\n } else {\n prp <- NULL\n }\n\n # Can use class_weights or set class.weights = \"inverse\" in svm()\n # if (is.null(weights)) {\n # weights <- rep(1, NROW(x))\n # }\n\n # Train ----\n class_weights <-\n if (\n type == \"Classification\" && n_classes == 2 && hyperparameters[[\"ifw\"]]\n ) {\n \"inverse\"\n } else {\n NULL\n }\n # gamma can't be NULL even if not used\n gamma <- hyperparameters[[\"gamma\"]]\n if (is.null(gamma)) {\n gamma <- 1\n }\n model <- e1071::svm(\n x = x,\n y = y, # factor or numeric\n kernel = hyperparameters[[\"kernel\"]],\n cost = hyperparameters[[\"cost\"]],\n gamma = gamma,\n class.weights = class_weights,\n probability = TRUE\n )\n check_inherits(model, \"svm\")\n list(model = model, preprocessor = prp)\n} # /rtemis::train_.RadialSVMHyperparameters\n\n\n# %% predict_super.svm ----\n#' Predict from SVM model\n#'\n#' @param model SVM model.\n#' @param newdata data.frame or similar: Data to predict on.\n#' @param type Character: Type of supervised learning (\"Classification\" or \"Regression\").\n#'\n#' @keywords internal\n#' @noRd\nmethod(predict_super, class_svm) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n if (type == \"Classification\") {\n predicted_prob <- attr(\n predict(model, newdata = newdata, probability = TRUE),\n \"probabilities\"\n )\n if (length(model$levels) == 2) {\n predicted_prob[, 2]\n } else {\n predicted_prob\n }\n } else {\n predict(model, newdata = newdata)\n }\n} # /rtemis::predict_super.svm\n\n\n# %% varimp_super.class_svm ----\n#' Get coefficients from SVM model\n#'\n#' @param model SVM model.\n#'\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, class_svm) <- function(model) {\n # Only for linear kernel with binary classification\n if (model[[\"kernel\"]] == 0L && model[[\"nclasses\"]] == 2) {\n .coefs <- coef(model)\n VariableImportance(\n data.table(\n variable = names(.coefs),\n Coefficient = unname(.coefs)\n )\n )\n } else {\n NULL\n }\n} # /rtemis::varimp_super.svm\n" }, { "path": "R/train_TabNet.R", "content": "# train_TabNet.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% train_.TabNetHyperparameters ----\n#' Train a TabNet model\n#'\n#' Train a TabNet model using `TabNet`.\n#'\n#' TabNet does not work in the presence of missing values.\n#'\n#' @param hyperparameters `TabNetHyperparameters` object: make using [setup_TabNet].\n#' @param x tabular data: Training set.\n#' @param weights Numeric vector: Case weights.\n#' @param dat_validation tabular data: Validation set for early stopping.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Object of class `TabNet`.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmethod(train_, TabNetHyperparameters) <- function(\n hyperparameters,\n x,\n weights = NULL,\n dat_validation = NULL,\n execution_config = setup_ExecutionConfig(),\n verbosity = 1L\n) {\n # Dependencies ----\n check_dependencies(\"torch\", \"tabnet\")\n\n # Hyperparameters ----\n # Hyperparameters must be either untunable or frozen by `train`.\n if (needs_tuning(hyperparameters)) {\n cli::cli_abort(\"Hyperparameters must be fixed - use train() instead.\")\n }\n\n # Data ----\n check_supervised(\n x = x,\n allow_missing = FALSE,\n verbosity = verbosity\n )\n type <- supervised_type(x)\n\n # Scale data ----\n y <- outcome(x)\n prp <- preprocess(\n features(x),\n config = setup_Preprocessor(scale = TRUE, center = TRUE)\n )\n x <- prp@preprocessed\n\n # Train ----\n # The predictor data should be standardized (e.g. centered or scaled). The model treats\n # categorical predictors internally thus, you don't need to make any treatment.\n config <- get_tabnet_config(hyperparameters)\n config[[\"verbose\"]] <- verbosity > 0L\n model <- tabnet::tabnet_fit(\n x = x,\n y = y,\n config = config,\n weights = weights\n )\n check_inherits(model, \"tabnet_fit\")\n list(model = model, preprocessor = prp)\n} # /rtemis::train_.TabNetHyperparameters\n\n\n# %% predict_super.class_tabnet_fit ----\n#' Predict from TabNet model\n#'\n#' @param model TabNet model.\n#' @param newdata data.frame or similar: Data to predict on.\n#' @param type Character: \"Regression\" or \"Classification\".\n#'\n#' @keywords internal\n#' @noRd\nmethod(predict_super, class_tabnet_fit) <- function(\n model,\n newdata,\n type = NULL,\n verbosity = 0L\n) {\n if (type == \"Regression\") {\n predict(model, new_data = newdata)[[1]]\n } else if (type == \"Classification\") {\n predicted <- predict(model, new_data = newdata, type = \"prob\")\n if (NCOL(predicted) == 2) {\n predicted[[2]]\n } else {\n predicted\n }\n }\n} # /rtemis::predict_super.class_tabnet_fit\n\n\n# %% varimp_super.class_tabnet_fit ----\n#' Get variable importance from TabNet model\n#'\n#' @param model TabNet model.\n#'\n#' @keywords internal\n#' @noRd\nmethod(varimp_super, class_tabnet_fit) <- function(model) {\n NULL\n} # /rtemis::varimp_super.class_tabnet_fit\n" }, { "path": "R/tune.R", "content": "# tune.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% get_tuner_fn ----\n#' Get Tuner Function\n#'\n#' @param type Character: Type of tuner.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nget_tuner_fn <- function(type = \"GridSearch\") {\n type <- match_arg(type, c(\"GridSearch\"))\n switch(type, \"GridSearch\" = \"tune_GridSearch\")\n} # /rtemis::get_tuner_fn\n\n\n# %% tune ----\n#' Tune Supervised Learning Model\n#'\n#' @param x tabular data: Training set data.\n#' @param hyperparameters `Hyperparameters` object: make using each learner's `setup_*` function.\n#' @param tuner_config `TunerConfig` object: created with [setup_GridSearch].\n#' @param preprocessor_config Optional `PreprocessorConfig` object: created with\n#' [setup_Preprocessor].\n#' @param weights Numeric vector: Optional case weights.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ntune <- function(\n x,\n hyperparameters,\n tuner_config,\n preprocessor_config = NULL,\n weights = NULL,\n verbosity = 1L,\n backend = \"none\",\n future_plan = \"multicore\",\n n_workers = 1L\n) {\n check_is_S7(hyperparameters, Hyperparameters)\n check_is_S7(tuner_config, TunerConfig)\n stopifnot(needs_tuning(hyperparameters))\n\n if (tuner_config@type == \"GridSearch\") {\n tune_GridSearch(\n x = x,\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n preprocessor_config = preprocessor_config,\n weights = weights,\n verbosity = verbosity,\n backend = backend,\n future_plan = future_plan,\n n_workers = n_workers\n )\n } else {\n cli::cli_abort(\"Unsupported tuner type: {tuner_config@type}\")\n }\n} # /rtemis::tune\n" }, { "path": "R/tune_GridSearch.R", "content": "# tune_GridSearch.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# %% tune_GridSearch ----\n#' \\pkg{rtemis} internal: Grid Search for Hyperparameter Tuning of \\pkg{rtemis} Learners\n#'\n#' Train models using a combination of parameter values for model selection\n#'\n#' @details\n#' Note that weights, if defined (and not NULL), should be passed directly to `grid_search`\n#' as they need to be resampled along `x` and `y`, and should not be passed along with\n#' `grid_params`. `ifw` and `ifw_type` should be passed as part of `grid_params`\n#' and will be passed on to the learner.\n#' Includes a algorithm-specific extraction of config that are determined internally,\n#' such as `lambda` for `GLMNET`, `nrounds` for `LightGBM`, etc.\n#'\n#' The current implementation allows running sequentially either directly using lapply + cli\n#' progress, or using a sequential future plan. The former may give better debugging information.\n#' The latter may be helpful to test that the future parallelization setup works correctly.\n#'\n#' @param x tabular data: Training set.\n#' @param hyperparameters `Hyperparameters` object created with a learner's `setup_*` function.\n#' @param tuner_config `TunerConfig` object created with [setup_GridSearch].\n#' @param preprocessor_config Optional `PreprocessorConfig` object: Applied within each tuning\n#' fold so hyperparameters are evaluated on preprocessed data.\n#' @param weights Vector: Class weights.\n#' @param save_mods Logical: Save models in tuning results.\n#' @param n_workers Integer: Number of workers to use for parallel processing.\n#' @param backend Character: Type of parallelization to use. Options are \"none\", \"future\",\n#' or \"mirai\".\n#' @param future_plan Character: Future plan to use if `backend` is \"future\".\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `GridSearch` object.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\ntune_GridSearch <- function(\n x,\n hyperparameters,\n tuner_config,\n preprocessor_config = NULL,\n weights = NULL,\n save_mods = FALSE,\n n_workers = 1L,\n backend = NULL,\n future_plan = NULL,\n verbosity = 1L\n) {\n check_is_S7(hyperparameters, Hyperparameters)\n check_is_S7(tuner_config, TunerConfig)\n stopifnot(needs_tuning(hyperparameters))\n\n # Dependencies ----\n if (backend == \"future\") {\n check_dependencies(\"futurize\", \"future.apply\")\n if (!is.null(future_plan) && future_plan == \"sequential\") {\n if (n_workers > 1L) {\n cli::cli_abort(\n \"Requested 'sequential' future plan, which supports {.val 1L} worker, but {.val {n_workers}} workers were requested.\"\n )\n }\n }\n } else if (backend == \"mirai\") {\n check_dependencies(\"mirai\")\n }\n\n # Intro ----\n start_time <- intro(\n newline_pre = TRUE,\n caller = \"tune_GridSearch\",\n verbosity = verbosity - 1L\n )\n\n # Arguments ----\n algorithm <- hyperparameters@algorithm\n\n # Parallel Processing Strategy ----\n # If backend is NULL, default to \"none\"\n if (is.null(backend)) {\n backend <- \"none\"\n }\n\n # If backend is \"future\" or \"mirai\" with n_workers = 1, we execute\n # sequentially using the respective backend just to test that the\n # parallelization setup works.\n # If the user wants standard sequential execution, they should use/leave\n # backend = \"none\" (default).\n if (backend != \"none\" && n_workers == 1L) {\n if (verbosity > 0L) {\n msg0(\n \"Using \",\n backend,\n \" with 1 worker\"\n )\n }\n }\n\n # Make Grid ----\n grid_params <- get_hyperparams_need_tuning(hyperparameters)\n n_resamples <- tuner_config[[\"resampler_config\"]][[\"n\"]]\n search_type <- tuner_config[[\"search_type\"]]\n # expand_grid converts NULL to \"null\" for expansion to work.\n param_grid <- expand_grid(grid_params, stringsAsFactors = FALSE)\n param_grid <- cbind(param_combo_id = seq_len(NROW(param_grid)), param_grid)\n n_param_combinations <- NROW(param_grid)\n res_param_grid <- expand_grid(\n c(list(resample_id = seq_len(n_resamples)), grid_params),\n stringsAsFactors = FALSE\n )\n n_res_x_comb <- NROW(res_param_grid)\n if (search_type == \"randomized\") {\n index_per_resample <- sample(\n n_param_combinations,\n round(tuner_config[[\"randomize_p\"]] * n_param_combinations)\n )\n res_param_grid <- res_param_grid[rep(index_per_resample, n_resamples), ]\n }\n\n # Intro pt. 2 ----\n if (verbosity > 0L) {\n msg0(\n fmt(\"<> \", col = col_tuner, bold = TRUE),\n \"Tuning \",\n algorithm,\n \" by \",\n search_type,\n \" grid search with \",\n desc(tuner_config@config[[\"resampler_config\"]]),\n \"...\"\n )\n msg0(\n fmt(n_param_combinations, col = col_tuner, bold = TRUE),\n ngettext(\n n_param_combinations,\n \" parameter combination x \",\n \" parameter combinations x \"\n ),\n fmt(n_resamples, col = col_tuner, bold = TRUE),\n \" resamples: \",\n fmt(n_res_x_comb, col = col_tuner, bold = TRUE),\n \" models total\",\n \" (\",\n Sys.getenv(\"R_PLATFORM\"),\n \").\"\n )\n }\n\n # Resamples ----\n res <- resample(\n x = x,\n config = tuner_config[[\"resampler_config\"]],\n verbosity = verbosity\n )\n\n # learner1 ----\n if (backend == \"future\") {\n ptn <- progressr::progressor(steps = NROW(res_param_grid))\n }\n learner1 <- function(\n index,\n x,\n res,\n res_param_grid,\n hyperparameters,\n preprocessor_config,\n weights,\n verbosity,\n save_mods,\n n_res_x_comb\n ) {\n if (verbosity > 1L) {\n msg_info(\n \"Running grid line #\",\n fmt(index, col = col_tuner, bold = TRUE),\n \"/\",\n NROW(res_param_grid),\n \"...\",\n caller = \"tune_GridSearch\",\n sep = \"\"\n )\n }\n res1 <- res[[res_param_grid[index, \"resample_id\"]]]\n dat_train1 <- x[res1, ]\n weights1 <- weights[res1]\n dat_valid1 <- x[-res1, ]\n hyperparams1 <- hyperparameters\n hyperparams1 <- update(\n hyperparams1,\n as.list(res_param_grid[index, 2:NCOL(res_param_grid), drop = FALSE]),\n tuned = -9L # Hyperparameters are being tuned\n )\n\n mod1 <- do_call(\n \"train\",\n args = list(\n x = dat_train1,\n dat_validation = dat_valid1,\n algorithm = hyperparams1@algorithm,\n preprocessor_config = preprocessor_config,\n hyperparameters = hyperparams1,\n weights = weights1,\n verbosity = verbosity - 1L\n )\n )\n\n out1 <- list(\n id = index,\n resample_id = res_param_grid[index, \"resample_id\"],\n metrics_training = mod1@metrics_training,\n metrics_validation = mod1@metrics_validation,\n type = mod1@type,\n hyperparameters = hyperparams1\n )\n\n # Algorithm-specific params ----\n # => add to hyperparameters\n if (algorithm == \"GLMNET\") {\n out1[[\"hyperparameters\"]]@hyperparameters[[\"lambda.min\"]] <- mod1@model[[\n \"lambda.min\"\n ]]\n out1[[\"hyperparameters\"]]@hyperparameters[[\"lambda.1se\"]] <- mod1@model[[\n \"lambda.1se\"\n ]]\n }\n if (algorithm == \"LightGBM\") {\n # Check best_iter is meaningful, otherwise issue message and set to 100L\n best_iter <- mod1@model[[\"best_iter\"]]\n if (is.null(best_iter) || best_iter == -1 || best_iter == 0) {\n msg_info(\n paste(\n \"best_iter returned from lightgbm:\",\n best_iter,\n \"- setting to 100L\"\n )\n )\n best_iter <- 100L\n }\n out1[[\"hyperparameters\"]]@hyperparameters[[\"best_iter\"]] <- best_iter\n }\n # if (algorithm %in% c(\"LINAD\", \"LINOA\")) {\n # out1$est.n.leaves <- mod1$mod$n.leaves\n # }\n # if (algorithm == \"LIHADBoost\") {\n # out1$sel.n.steps <- mod1$mod$selected.n.steps\n # }\n if (save_mods) {\n out1[[\"mod1\"]] <- mod1\n }\n if (backend == \"future\") {\n ptn(sprintf(\"Tuning resample %i/%i\", index, n_res_x_comb))\n }\n out1\n } # /learner1\n\n # Train Grid ----\n if (backend == \"none\") {\n if (verbosity > 0L) {\n msg(\"Tuning in sequence\")\n }\n # Sequential execution with cli progress.\n grid_run <- lapply(\n cli::cli_progress_along(\n seq_len(n_res_x_comb),\n name = paste0(\"Tuning... (\", n_res_x_comb, \" combinations)\"),\n type = \"tasks\"\n ),\n FUN = learner1,\n x = x,\n res = res,\n hyperparameters = hyperparameters,\n res_param_grid = res_param_grid,\n preprocessor_config = preprocessor_config,\n weights = weights,\n verbosity = verbosity,\n save_mods = save_mods,\n n_res_x_comb = n_res_x_comb\n )\n } else if (backend == \"future\") {\n # Future parallelization\n future_plan <- set_preferred_plan(\n requested_plan = future_plan,\n n_workers = n_workers,\n envir = parent.frame(),\n verbosity = verbosity\n )\n if (verbosity > 0L) {\n msg0(\n \"Tuning using future (\",\n bold(future_plan),\n \"); N workers: \",\n bold(n_workers)\n )\n }\n if (verbosity > 1L) {\n # verify plan set by set_preferred_plan with envir\n msg_info(\"Current future plan:\")\n print(future::plan())\n }\n grid_run <- lapply(\n X = seq_len(n_res_x_comb),\n FUN = learner1,\n x = x,\n res = res,\n hyperparameters = hyperparameters,\n res_param_grid = res_param_grid,\n preprocessor_config = preprocessor_config,\n weights = weights,\n verbosity = verbosity,\n save_mods = save_mods,\n n_res_x_comb = n_res_x_comb\n ) |>\n futurize::futurize(seed = TRUE, globals = FALSE)\n } else if (backend == \"mirai\") {\n if (verbosity > 0L) {\n msg(\"Tuning using mirai; N workers:\", bold(n_workers))\n }\n mirai::daemons(n_workers, dispatcher = TRUE)\n on.exit(mirai::daemons(0L))\n grid_run <- mirai::mirai_map(\n .x = seq_len(n_res_x_comb),\n .f = learner1,\n .args = list(\n x = x,\n res = res,\n hyperparameters = hyperparameters,\n res_param_grid = res_param_grid,\n preprocessor_config = preprocessor_config,\n weights = weights,\n verbosity = verbosity,\n save_mods = save_mods,\n n_res_x_comb = n_res_x_comb\n )\n )\n }\n\n # Metric ----\n type <- supervised_type(x)\n metric <- tuner_config@config[[\"metric\"]]\n maximize <- tuner_config@config[[\"maximize\"]]\n if (is.null(metric)) {\n if (type == \"Classification\") {\n metric <- \"Balanced_Accuracy\"\n } else if (type == \"Regression\") {\n metric <- \"MSE\"\n } else {\n metric <- \"Concordance\"\n }\n tuner_config@config[[\"metric\"]] <- metric\n }\n if (is.null(maximize)) {\n maximize <- metric %in%\n c(\"Accuracy\", \"Balanced_Accuracy\", \"Concordance\", \"Rsq\", \"r\")\n tuner_config@config[[\"maximize\"]] <- maximize\n }\n select_fn <- if (maximize) which.max else which.min\n verb <- if (maximize) \"maximize\" else \"minimize\"\n\n # Aggregate ----\n # Average test errors\n # if using mirai, wait for all to finish\n if (backend == \"mirai\") {\n # Appease R CMD check\n .progress <- NULL\n grid_run <- grid_run[.progress]\n # grid_run <- mirai::collect_mirai(grid_run)\n }\n if (type %in% c(\"Regression\", \"Survival\")) {\n metrics_training_all <- as.data.table(t(sapply(\n grid_run,\n function(r) unlist(r[[\"metrics_training\"]]@metrics)\n )))\n metrics_validation_all <- as.data.table(t(sapply(\n grid_run,\n function(r) unlist(r[[\"metrics_validation\"]]@metrics)\n )))\n } else if (type == \"Classification\") {\n metrics_training_all <- as.data.table(t(sapply(\n grid_run,\n function(r) unlist(r[[\"metrics_training\"]]@metrics[[\"Overall\"]])\n )))\n metrics_validation_all <- as.data.table(t(sapply(\n grid_run,\n function(r) unlist(r[[\"metrics_validation\"]]@metrics[[\"Overall\"]])\n )))\n }\n # appease R CMD check\n param_combo_id <- NULL\n metrics_validation_all[,\n param_combo_id := rep(\n seq_len(n_param_combinations),\n each = n_resamples\n )\n ]\n metrics_training_all[,\n param_combo_id := rep(\n seq_len(n_param_combinations),\n each = n_resamples\n )\n ]\n metrics_training_by_combo_id <- metrics_training_all[,\n lapply(\n .SD,\n get(tuner_config[[\"metrics_aggregate_fn\"]])\n ),\n by = param_combo_id\n ]\n metrics_validation_by_combo_id <- metrics_validation_all[,\n lapply(\n .SD,\n get(tuner_config[[\"metrics_aggregate_fn\"]])\n ),\n by = param_combo_id\n ]\n\n tune_results <- list(\n param_grid = param_grid,\n metrics_training = metrics_training_by_combo_id,\n metrics_validation = metrics_validation_by_combo_id\n )\n\n # Algorithm-specific collection ----\n # N of iterations is the one hyperparameter that may be determined\n # automatically, we therefore need to extract it and average it\n ## GLMNET ----\n if (algorithm == \"GLMNET\") {\n if (is.null(grid_params[[\"lambda\"]])) {\n # if lambda was NULL, cv.glmnet was run and optimal lambda was estimated\n # For each i in grid_run, get grid_run[[i]]$hyperparameters[[grid_run[[i]]$hyperparameters$which_lambda_cv]]\n if (verbosity > 1L) {\n msg_info(\"Extracting best lambda from GLMNET models...\")\n }\n lambda_cv2 <- data.table(\n lambda = sapply(\n grid_run,\n function(x) {\n x[[\"hyperparameters\"]][[x[[\"hyperparameters\"]][[\n \"which_lambda_cv\"\n ]]]]\n }\n )\n )\n lambda_cv2[,\n param_combo_id := rep(\n seq_len(n_param_combinations),\n each = n_resamples\n )\n ]\n lambda_by_param_combo_id <- lambda_cv2[,\n lapply(.SD, get(tuner_config[[\"metrics_aggregate_fn\"]])),\n by = param_combo_id\n ]\n # Replace NULL lambda in tune_results$param_grid with average value of CV-squared lambda\n stopifnot(tune_results[[\"param_grid\"]][[\"lambda\"]] == \"null\")\n param_grid[[\"lambda\"]] <- tune_results[[\"param_grid\"]][[\n \"lambda\"\n ]] <- lambda_by_param_combo_id[[\"lambda\"]]\n }\n } # /GLMNET\n\n ## LightGBM ----\n if (algorithm == \"LightGBM\") {\n if (is.null(grid_params[[\"nrounds\"]])) {\n if (verbosity > 1L) {\n msg_info(\"Extracting best N of iterations from LightGBM models...\")\n }\n nrounds_cv <- data.table(\n nrounds = sapply(grid_run, \\(x) x[[\"hyperparameters\"]][[\"best_iter\"]])\n )\n nrounds_cv[[\"param_combo_id\"]] <- rep(\n seq_len(n_param_combinations),\n each = n_resamples\n )\n nrounds_by_param_combo_id <- nrounds_cv[,\n lapply(.SD, get(tuner_config[[\"metrics_aggregate_fn\"]])),\n by = param_combo_id\n ]\n # Replace NULL nrounds in tune_results$param_grid with average value of Res nrounds\n stopifnot(tune_results[[\"param_grid\"]][[\"nrounds\"]] == \"null\")\n param_grid[[\"nrounds\"]] <- tune_results[[\"param_grid\"]][[\"nrounds\"]] <-\n as.integer(round(nrounds_by_param_combo_id[[\"nrounds\"]]))\n }\n } # /LightGBM\n\n ## GBM, H2OGBM ----\n # if (algorithm %in% c(\"H2OGBM\", \"GBM\", \"GBM3\")) {\n # est.n.trees.all <- data.frame(n.trees = plyr::laply(\n # grid_run,\n # function(x) x$est.n.trees\n # ))\n # est.n.trees.all$param_combo_id <- rep(seq_len(n_param_combinations), each = n_resamples)\n # est.n.trees.by.param_combo_id <- aggregate(\n # n.trees ~ param_combo_id, est.n.trees.all,\n # metrics_aggregate_fn\n # )\n # tune_results <- cbind(\n # n.trees = round(est.n.trees.by.param_combo_id$n.trees),\n # tune_results\n # )\n # n_params <- n_params + 1\n # } # /GBM, H2OGBM\n\n ## XGBoost ----\n # if (algorithm == \"XGBoost\") {\n # if (verbosity > 1L) {\n # msg(highlight(\"Extracting best N of iterations from XGBoost models...\"))\n # }\n # est.nrounds.all <- data.frame(nrounds = plyr::laply(\n # grid_run,\n # \\(m) m$best_iteration\n # ))\n # est.nrounds.all$param_combo_id <- rep(seq_len(n_param_combinations),\n # each = n_resamples\n # )\n # est.nrounds.by.param_combo_id <- aggregate(\n # nrounds ~ param_combo_id, est.nrounds.all,\n # metrics_aggregate_fn\n # )\n # tune_results <- cbind(\n # nrounds = round(est.nrounds.by.param_combo_id$nrounds),\n # tune_results\n # )\n # n_params <- n_params + 1\n # } /XGBoost\n\n ## LINAD ----\n # if (algorithm %in% c(\"LINAD\", \"LINOA\")) {\n # if (verbosity > 1L) {\n # msg_info(\"Extracting best N leaves from LINAD models...\")\n # }\n # est.n.leaves.all <- data.frame(n.leaves = plyr::laply(\n # grid_run,\n # \\(x) ifelse(length(x$est.n.leaves) == 0, 1, x$est.n.leaves)\n # ))\n # est.n.leaves.all$param_combo_id <- rep(seq_len(n_param_combinations),\n # each = n_resamples\n # )\n # est.n.leaves.by.param_combo_id <- aggregate(\n # n.leaves ~ param_combo_id, est.n.leaves.all,\n # metrics_aggregate_fn\n # )\n # tune_results <- cbind(\n # n.leaves =\n # round(est.n.leaves.by.param_combo_id$n.leaves), tune_results\n # )\n # n_params <- n_params + 1\n # } # /LINAD, LINOA\n\n ## LIHADBoost ----\n # if (algorithm == \"LIHADBoost\") {\n # if (verbosity > 1L) {\n # msg(highlight(\"Extracting best N steps from LIHADBoost models...\"))\n # }\n # est.n.steps.all <- data.frame(n.steps = plyr::laply(\n # grid_run,\n # \\(x) x$sel.n.steps\n # ))\n # est.n.steps.all$param_combo_id <- rep(seq_len(n_param_combinations),\n # each = n_resamples\n # )\n # est.n.steps.by.param_combo_id <- aggregate(\n # n.steps ~ param_combo_id, est.n.steps.all,\n # metrics_aggregate_fn\n # )\n # tune_results <- cbind(\n # n.steps = round(est.n.steps.by.param_combo_id$n.steps),\n # tune_results\n # )\n # n_params <- n_params + 1\n # } # /LIHADBoost\n\n # Consider explicitly sorting hyperparam values in increasing order,\n # so that in case of tie, lowest value is chosen -\n # if that makes sense, e.g. n.leaves, etc.\n best_param_combo_id <- as.integer(\n tune_results[[\"metrics_validation\"]][\n select_fn(tune_results[[\"metrics_validation\"]][[metric]]),\n 1\n ]\n )\n best_param_combo <- as.list(param_grid[best_param_combo_id, -1, drop = FALSE])\n if (verbosity > 0L) {\n msg(\n paste0(\"Best config to \", paste(verb, metric), \":\")\n )\n print_tune_finding(grid_params, best_param_combo)\n }\n\n # Outro ----\n # Since this is always called from within `train()`, we don't want to print \"Completed...\"\n outro(start_time, verbosity = verbosity - 1L)\n\n if (verbosity > 0L) {\n msg(\n fmt(\"\", col = col_tuner, bold = TRUE),\n \"Tuning done.\"\n )\n }\n\n # => add optional mods field to GridSearch\n # if (save_mods) mods <- grid_run\n GridSearch(\n hyperparameters = hyperparameters,\n tuner_config = tuner_config,\n tuning_results = list(\n param_grid = param_grid,\n training = metrics_training_by_combo_id,\n validation = metrics_validation_by_combo_id\n ),\n best_hyperparameters = best_param_combo\n )\n} # /rtemis::tune_GridSearch\n\n\n# %% print_tune_finding ----\n#' Print tuning results\n#'\n#' Prints set of search values and best value in the form {1, 3, 5} => 3\n#' for each hyperparameter that was tuned.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nprint_tune_finding <- function(grid_params, best_param_combo, pad = 22L) {\n # Make list of search values and best value\n tfl <- lapply(seq_along(grid_params), function(i) {\n paste0(\n \"{\",\n paste(grid_params[[i]], collapse = \", \"),\n \"}\",\n \" => \",\n bold(best_param_combo[[names(grid_params)[i]]])\n )\n })\n names(tfl) <- names(grid_params)\n # Capture output to sync with msg stream (stderr)\n out <- utils::capture.output(printls(tfl, print_class = FALSE, pad = pad))\n message(paste(out, collapse = \"\\n\"))\n} # /rtemis::print_tune_finding\n" }, { "path": "R/utils.R", "content": "# utils.R\n# ::rtemis::\n# 2016- EDG rtemis.org\n\n#' Print range of continuous variable\n#'\n#' @param x Numeric vector\n#' @param ddSci Logical: If TRUE, use [ddSci] or range.\n#' @param decimal_places Integer: Number of decimal place to use if `ddSci = TRUE`.\n#' @param na.rm Logical: passed to `base::range`\n#'\n#' @return Called for its side effect of printing the range of `x`.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nshow_range <- function(x, ddSci = TRUE, decimal_places = 1, na.rm = TRUE) {\n if (ddSci) {\n paste(\n ddSci(range(x, na.rm = na.rm), decimal_places = decimal_places),\n collapse = \" to \"\n )\n } else {\n paste(range(x, na.rm = na.rm), collapse = \" to \")\n }\n} # /rtemis::show_range\n\n\n#' Set Dynamic Range\n#'\n#' `rtemis preproc`: Adjusts the dynamic range of a vector or matrix input.\n#' By default normalizes to 0-1 range.\n#'\n#' @param x Numeric vector or matrix / data frame: Input\n#' @param lo Target range minimum. Defaults to 0\n#' @param hi Target range maximum. Defaults to 1\n#' @param byCol Logical: If TRUE: if `x` is matrix, `drange` each\n#' column separately\n#'\n#' @return Numeric vector.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' x <- runif(20, -10, 10)\n#' x <- drange(x)\ndrange <- function(x, lo = 0, hi = 1, byCol = TRUE) {\n dr <- function(x, lo, hi) {\n .min <- min(x, na.rm = TRUE)\n (x - .min) / max(x - .min, na.rm = TRUE) * (hi - lo) + lo\n }\n\n if (NCOL(x) > 1) {\n if (byCol) {\n apply(x, 2, function(x) dr(x, lo, hi))\n } else {\n dr(x, lo, hi)\n }\n } else {\n dr(x, lo, hi)\n }\n} # /rtemis::drange\n\n\n#' Factor NA to \"missing\" level\n#'\n#' Set NA values of a factor vector to a new level indicating missingness\n#'\n#' @param x Factor.\n#' @param na_level_name Character: Name of new level to create that will be assigned to all current\n#' NA values in `x`.\n#'\n#' @return factor.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' x <- factor(sample(letters[1:3], 100, TRUE))\n#' x[sample(1:100, 10)] <- NA\n#' xm <- factor_NA2missing(x)\nfactor_NA2missing <- function(x, na_level_name = \"missing\") {\n check_inherits(x, \"factor\")\n if (anyNA(x)) {\n x <- factor(x, levels = c(levels(x), na_level_name))\n x[is.na(x)] <- na_level_name\n x\n } else {\n x\n }\n} # /rtemis::factor_NA2missing\n\n\n#' Filter order\n#'\n#' @param x Input vector\n#' @param idl Logical vector: Index of elements to filter\n#' @param decreasing Logical: If TRUE, sort in descending order\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' x <- rnorm(10)\n#' x\n#' x[filter_order(x, x < 0)]\nfilter_order <- function(x, idl, decreasing = FALSE) {\n idi <- which(idl)\n flt_ord <- order(x[idi], decreasing = decreasing)\n idi[flt_ord]\n}\n\n\n#' Get the mode of a factor or integer\n#'\n#' Returns the mode of a factor or integer\n#'\n#' @param x Vector, factor or integer: Input data.\n#' @param na.rm Logical: If TRUE, exclude NAs (using `na.exclude(x)`).\n#' @param getlast Logical: If TRUE, get the last value in case of ties.\n#' @param retain_class Logical: If TRUE, output is always same class as input.\n#'\n#' @return The mode of `x`\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- c(9, 3, 4, 4, 0, 2, 2, NA)\n#' get_mode(x)\n#' x <- c(9, 3, 2, 2, 0, 4, 4, NA)\n#' get_mode(x)\n#' get_mode(x, getlast = FALSE)\nget_mode <- function(\n x,\n na.rm = TRUE,\n getlast = TRUE,\n retain_class = TRUE\n) {\n if (retain_class) {\n .class <- class(x)\n }\n if (na.rm) {\n x <- na.exclude(x)\n }\n freq <- table(x)\n if (sum(freq) > 0) {\n if (getlast) {\n .vals <- unique(x)\n out <- .vals[rev(which(.vals %in% names(freq)[which(freq == max(freq))]))[\n 1\n ]]\n } else {\n out <- names(freq)[which.max(freq)]\n }\n if (length(out) == 0) out <- NA\n } else {\n out <- NA\n }\n\n if (retain_class) {\n if (is.factor(x)) {\n out <- factor(out, levels = levels(x))\n } else {\n class(out) <- .class\n }\n }\n out\n} # /rtemis::get_mode\n\n\n#' Check if vector is constant\n#'\n#' @param x Vector: Input\n#' @param skip_missing Logical: If TRUE, skip NA values before test\n#'\n#' @return Logical.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- rep(9, 1000000)\n#' is_constant(x)\n#' x[10] <- NA\n#' is_constant(x)\n#' is_constant(x, skip_missing = TRUE)\nis_constant <- function(x, skip_missing = FALSE) {\n # all(duplicated(x)[-1L])\n if (skip_missing) {\n x <- na.exclude(x)\n }\n isTRUE(all(x == x[1]))\n} # /rtemis::is_constant\n\n\n#' Check if variable is discrete (factor or integer)\n#'\n#' @param x Input\n#'\n#' @return Logical.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nis_discrete <- function(x) {\n is.factor(x) || is.integer(x) || is.logical(x) || is.character(x)\n} # /rtemis::is_discrete\n\n\n#' Return object if it has length > 0\n#'\n#' Returns the input object if it has length > 0, else NULL\n#'\n#' @param x Object\n#'\n#' @return `x` if `length(x) > 0`, else `NULL`\n#'\n#' @keywords internal\n#' @noRd\niflengthy <- function(x) {\n if (length(x) > 0) x else NULL\n} # /rtemis::iflengthy\n\n\n#' @keywords internal\n#' @noRd\npval_stars <- function(x) {\n cut(x, breaks = c(0, .001, .01, .05, 1), labels = c(\"***\", \"**\", \"*\", \"\"))\n}\n\n\n#' Format singular/plural noun\n#'\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' singorplu(0, \"cat\")\n#' singorplu(1, \"cat\")\n#' singorplu(2, \"cat\")\nsingorplu <- function(n, x) {\n switch(\n as.character(n),\n `0` = paste0(\"no \", x, \"s\"),\n `1` = paste(\"1\", x),\n paste0(n, \" \", x, \"s\")\n )\n}\n\n\n#' Size of object\n#'\n#' Returns the size of an object\n#'\n#' @details\n#' If `dim(x)` is NULL, returns `length(x)`.\n#' @param x any object with `length()` or `dim()`.\n#' @param verbosity Integer: Verbosity level. If > 0, print size to console\n#'\n#' @return Integer vector with length equal to the number of dimensions of `x`, invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- rnorm(20)\n#' size(x)\n#' # 20\n#' x <- matrix(rnorm(100), 20, 5)\n#' size(x)\n#' # 20 5\nsize <- function(x, verbosity = 1L) {\n z <- if (is.null(dim(x))) {\n length(x)\n } else {\n dim(x)\n }\n if (verbosity > 0L) {\n # Format to add \",\" for thousands\n z_formatted <- format(z, trim = TRUE, big.mark = \",\", scientific = FALSE)\n cat(paste(bold(z_formatted), collapse = gray(\" x \")), \"\\n\")\n }\n invisible(z)\n} # /rtemis::size\n\n\n#' Recycle values of vector to match length of target.\n#'\n#' @details\n#' If `target` is longer than `x`, the values of `x` will be recycled to match the length of\n#' `target`. If `x` is longer than `target`, the values of `x` will be truncated to match the\n#' length of `target`.\n#' Used internally by many functions.\n#'\n#' @param x Vector to be recycled\n#' @param target Object whose length defines target length\n#'\n#' @return Vector.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nrecycle <- function(x, target) {\n lenx <- length(x)\n lent <- length(target)\n rep(x, ceiling(lent / lenx))[seq_len(lent)]\n} # /rtemis::recycle\n\n\n#' Random Normal Matrix\n#'\n#' Create a matrix or data frame of defined dimensions, whose columns are random normal vectors\n#'\n#' @param nrow Integer: Number of rows.\n#' @param ncol Integer: Number of columns.\n#' @param mean Float: Mean.\n#' @param sd Float: Standard deviation.\n#' @param return_df Logical: If TRUE, return data.frame, otherwise matrix.\n#' @param seed Integer: Set seed for `rnorm`.\n#'\n#' @return `matrix` or `data.frame`.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- rnormmat(20, 5, mean = 12, sd = 6, return_df = TRUE, seed = 2026)\n#' x\nrnormmat <- function(\n nrow = 10,\n ncol = 10,\n mean = 0,\n sd = 1,\n return_df = FALSE,\n seed = NULL\n) {\n if (length(mean) != ncol) {\n mean <- rep_len(mean, ncol)\n }\n if (length(sd) != ncol) {\n sd <- rep_len(sd, ncol)\n }\n\n if (!is.null(seed)) {\n set.seed(seed)\n }\n mat <- sapply(seq_len(ncol), function(j) {\n rnorm(nrow, mean = mean[j], sd = sd[j])\n })\n if (return_df) {\n mat <- as.data.frame(mat)\n }\n mat\n} # /rtemis::rnormmat\n\n\n#' Random Uniform Matrix\n#'\n#' Create a matrix or data frame of defined dimensions, whose columns are random uniform vectors\n#'\n#' @param nrow Integer: Number of rows.\n#' @param ncol Integer: Number of columns.\n#' @param min Float: Min.\n#' @param max Float: Max.\n#' @param return_df Logical: If TRUE, return data.frame, otherwise matrix.\n#' @param seed Integer: Set seed for `rnorm`.\n#'\n#' @return `matrix` or `data.frame`.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- runifmat(20, 5, min = 12, max = 18, return_df = TRUE, seed = 2026)\n#' x\nrunifmat <- function(\n nrow = 10,\n ncol = 10,\n min = 0,\n max = 1,\n return_df = FALSE,\n seed = NULL\n) {\n if (length(min) < ncol) {\n min <- rep(min, ncol / length(min))\n }\n if (length(max) < ncol) {\n max <- rep(max, ncol / length(max))\n }\n\n if (!is.null(seed)) {\n set.seed(seed)\n }\n mat <- sapply(seq_len(ncol), function(j) runif(nrow, min = min, max = max))\n if (return_df) {\n mat <- as.data.frame(mat)\n }\n mat\n} # /rtemis::runifmat\n\n\n#' Get rtemis version and system info\n#'\n#' @return List: rtemis version and system info, invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' rtversion()\nrtversion <- function() {\n out <- c(\n list(rtemis_version = as.character(packageVersion(\"rtemis\"))),\n as.list(Sys.info())\n )\n printls(out, print_class = FALSE)\n invisible(out)\n} # /rtemis::rtversion\n\n\n#' Symmetric Set Difference\n#'\n#' @param x vector\n#' @param y vector of same type as `x`\n#'\n#' @return Vector.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' setdiff(1:10, 1:5)\n#' setdiff(1:5, 1:10)\n#' setdiffsym(1:10, 1:5)\n#' setdiffsym(1:5, 1:10)\nsetdiffsym <- function(x, y) {\n union(setdiff(x, y), setdiff(y, x))\n} # /rtemis::setdiffsym\n\n\n#' Initialize Project Directory\n#'\n#' Initializes Directory Structure: \"R\", \"Data\", \"Results\"\n#'\n#' @param path Character: Path to initialize project directory in.\n#' @param output_dir Character: Name of output directory to create.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Character: the path where the project directory was initialized, invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' \\dontrun{\n#' # Will create \"my_project\" directory with\n#' init_project_dir(\"my_project\")\n#' }\ninit_project_dir <- function(path, output_dir = \"Out\", verbosity = 1L) {\n if (verbosity > 0L) {\n msg(\"Initializing project directory...\")\n }\n path <- normalizePath(path, mustWork = FALSE)\n\n # Create project directory if it doesn't exist\n if (!dir.exists(path)) {\n if (verbosity > 0L) {\n cat(\" > Creating \", bold(path), \" folder...\", sep = \"\")\n }\n dir.create(path, recursive = TRUE)\n if (dir.exists(path)) {\n if (verbosity > 0L) {\n yay()\n }\n } else {\n if (verbosity > 0L) {\n nay()\n }\n cli::cli_abort(\n \"Failed to create project directory at {.file {path}}. Check path & permissions.\"\n )\n }\n }\n\n # Log file: rtemis_init.log ----\n logfile_path <- file.path(path, \"rtemis_init.log\")\n sink(file = logfile_path, append = TRUE)\n cat(\"\\n\")\n cat(\"Initialized: \", datetime(), \"\\n\", sep = \"\")\n cat(\"--------------------------------\\n\")\n print(sessionInfo())\n sink()\n\n # Directories: /R /Data /output_dir ----\n dirs <- file.path(path, c(\"R\", \"Data\", output_dir))\n for (i in dirs) {\n if (verbosity > 0L) {\n cat(\" > Creating \", bold(i), \" folder...\", sep = \"\")\n }\n if (!dir.exists(i)) {\n dir.create(i)\n if (dir.exists(i)) {\n if (verbosity > 0L) yay()\n } else {\n if (verbosity > 0L) nay()\n }\n } else {\n if (verbosity > 0L) cat(orange(\" Already present\\n\", bold = TRUE))\n }\n }\n if (verbosity > 0L) {\n msg(\"Done.\")\n }\n invisible(path)\n} # /rtemis::init_project_dir\n" }, { "path": "R/utils_art.R", "content": "# utils_art.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n#' Color columns of text art\n#'\n#' This function accepts text input of 1 or more lines and two colors.\n#' It will:\n#' a) generate a color gradient between the two colors\n#' b) apply the gradient to each column of the text, creating a left to right color gradient.\n#'\n#' @param x Character vector of text to colorize.\n#' @param color_left Color for the left side of the gradient.\n#' @param color_right Color for the right side of the gradient.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character vector with color formatting applied to each column.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncolor_txt_columns <- function(\n x,\n color_left,\n color_right,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n # Count number of columns in input text\n ncols <- max(nchar(x, type = \"width\"))\n\n if (ncols == 0) {\n return(x)\n }\n\n # Create color gradient from color_left to color_right with ncols steps\n gradient <- grDevices::colorRampPalette(c(color_left, color_right))(ncols)\n\n # Apply the colors to each column of the text\n result <- character(length(x))\n\n for (i in seq_along(x)) {\n line <- x[i]\n line_chars <- strsplit(line, \"\")[[1]]\n line_width <- nchar(line, type = \"width\")\n\n if (line_width == 0) {\n result[i] <- line\n next\n }\n\n colored_chars <- character(length(line_chars))\n\n for (j in seq_along(line_chars)) {\n char <- line_chars[j]\n if (char == \" \") {\n colored_chars[j] <- char\n } else {\n # Use column position for gradient color\n col_pos <- min(j, ncols)\n colored_chars[j] <- fmt(\n char,\n col = gradient[col_pos],\n output_type = output_type\n )\n }\n }\n\n result[i] <- paste0(colored_chars, collapse = \"\")\n }\n\n result\n} # /rtemis::color_txt_columns\n\n\n#' Color rows of text art\n#'\n#' This function accepts text input of 1 or more lines and two colors.\n#' It will:\n#' a) generate a color gradient between the two colors\n#' b) apply the gradient to each row of the text, creating a top to bottom color gradient.\n#'\n#' @param x Character vector of text to colorize.\n#' @param color_top Color for the top of the gradient.\n#' @param color_bottom Color for the bottom of the gradient.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character vector with color formatting applied to each row.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncolor_txt_rows <- function(\n x,\n color_top,\n color_bottom,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n\n # Number of rows\n nrows <- length(x)\n\n if (nrows == 0) {\n return(x)\n }\n\n # Create color gradient from color_top to color_bottom with nrows steps\n gradient <- grDevices::colorRampPalette(c(color_top, color_bottom))(nrows)\n\n # Apply the colors to each row of the text\n result <- character(nrows)\n\n for (i in seq_along(x)) {\n line <- x[i]\n line_chars <- strsplit(line, \"\")[[1]]\n line_width <- nchar(line, type = \"width\")\n\n if (line_width == 0) {\n result[i] <- line\n next\n }\n\n colored_chars <- character(length(line_chars))\n\n for (j in seq_along(line_chars)) {\n char <- line_chars[j]\n if (char == \" \") {\n colored_chars[j] <- char\n } else {\n colored_chars[j] <- fmt(\n char,\n col = gradient[i],\n output_type = output_type\n )\n }\n }\n\n result[i] <- paste0(colored_chars, collapse = \"\")\n }\n\n result\n} # /rtemis::color_txt_rows\n\n\n#' pkglogo\n#'\n#' @param pkg Character: Package name.\n#' @param filename Character: Filename of the logo file (without path).\n#' @param fmt_fn Function: \"color_txt_columns\", \"color_text_rows\" Formatting function to apply to\n#' the logo text.\n#' @param args List: Arguments to pass to `fmt_fn`.\n#' @param pad Integer: Left-pad output with this many spaces.\n#'\n#' @return Character: Formatted logo text.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\npkglogo <- function(\n pkg = .packageName,\n filename = paste0(pkg, \".utf8\"),\n fmt_fn = color_txt_columns,\n args = list(\n color_left = kaimana_red,\n color_right = coastside_orange,\n output_type = \"ansi\"\n ),\n pad = 2L\n) {\n logo_file <- system.file(\n package = .packageName,\n \"resources\",\n filename\n )\n logo_txt <- readLines(logo_file)\n paste0(\n strrep(\" \", pad),\n do.call(fmt_fn, c(list(x = logo_txt), args)),\n collapse = \"\\n\"\n )\n} # /rtemis::pkglogo\n\n\n#' Show colors\n#'\n#' Display color previews with ANSI color blocks\n#'\n#' @param x Named vector or list of colors to preview.\n#' @param pad Integer: Pad output with this many spaces.\n#' @param center_title Logical: If TRUE, autopad title for centering, if present.\n#' @param title Character: Optional title to display.\n#' @param title_newline Logical: If TRUE, add newline after title.\n#' @param limit Integer: Maximum number of colors to show. Set to -1L for no limit.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted string that can be printed with cat()\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nshow_col <- function(\n x,\n pad = 2L,\n center_title = TRUE,\n title = NULL,\n title_newline = TRUE,\n limit = 12L,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n\n # Helper function to build padded string equivalent of padcat\n build_padcat <- function(\n text,\n pad = 2L,\n newline_pre = FALSE,\n newline = FALSE\n ) {\n result <- \"\"\n if (newline_pre) {\n result <- paste0(result, \"\\n\")\n }\n result <- paste0(result, strrep(\" \", pad))\n result <- paste0(result, text)\n if (newline) {\n result <- paste0(result, \"\\n\")\n }\n result\n }\n\n # Initialize output string\n result <- \"\"\n\n if (is.null(x)) {\n if (!is.null(title)) {\n result <- paste0(\n result,\n highlight(build_padcat(title, pad = pad, newline = title_newline))\n )\n }\n result <- paste0(result, strrep(\" \", pad), \"NULL\")\n return(result)\n }\n\n if (length(x) == 0) {\n result <- paste0(result, class(x), \" of length 0.\\n\")\n return(result)\n }\n\n # Convert to named list if needed\n if (is.null(names(x)) && !is.list(x)) {\n names(x) <- as.character(x)\n }\n\n x <- as.list(x)\n xnames <- names(x)\n if (is.null(xnames)) {\n xnames <- paste0(\"color_\", seq_along(x))\n }\n\n # Calculate left-hand side width\n lhs <- max(nchar(xnames)) + pad\n\n # Add title if provided\n if (!is.null(title)) {\n title_pad <- if (center_title) {\n max(0, lhs - round((.5 * nchar(title))) - 3)\n } else {\n 0\n }\n result <- paste0(\n result,\n highlight(build_padcat(title, pad = title_pad, newline = title_newline)),\n \"\\n\"\n )\n }\n\n # Show limit message if needed\n counter <- 0L\n if (limit != -1L && length(x) > limit) {\n limit_text <- paste0(\n italic(\n gray(\n paste0(\n \"Showing first \",\n limit,\n \" of \",\n length(x),\n \" colors.\\n\"\n ),\n output_type = output_type\n ),\n output_type = output_type\n )\n )\n result <- paste0(result, build_padcat(limit_text, pad = pad))\n }\n\n # Display each color\n for (i in seq_along(x)) {\n counter <- counter + 1L\n if (limit != -1L && counter > limit) {\n more_text <- paste0(\n italic(\n gray(\n paste0(\n \"...\",\n length(x) - limit,\n \" more colors not shown.\\n\"\n )\n ),\n output_type = output_type\n )\n )\n result <- paste0(result, build_padcat(more_text, pad = pad))\n break\n }\n\n # Get color value\n color_val <- x[[i]]\n\n # Create color blocks: 2 solid, 2 medium, 2 light\n if (output_type == \"ansi\") {\n # Use the color directly\n color_display <- tryCatch(\n {\n # Create blocks with varying intensities\n solid_block <- fmt(\n \"\\u2588\",\n col = color_val,\n output_type = output_type\n )\n medium_block <- fmt(\n \"\\u2593\",\n col = color_val,\n output_type = output_type\n )\n light_block <- fmt(\n \"\\u2591\",\n col = color_val,\n output_type = output_type\n )\n\n paste0(\n solid_block,\n solid_block,\n medium_block,\n medium_block,\n light_block,\n light_block\n )\n },\n error = function(e) {\n # Fallback if color conversion fails\n paste0(\n \"\\u2588\\u2588\\u2593\\u2593\\u2591\\u2591 (\",\n color_val,\n \")\"\n )\n }\n )\n } else {\n # For non-ANSI output, just show the color value\n color_display <- paste0(\n \"\\u2588\\u2588\\u2593\\u2593\\u2591\\u2591 (\",\n color_val,\n \")\"\n )\n }\n\n # Format and add the line\n item_text <- paste0(\n bold(\n format(\n xnames[i],\n width = lhs,\n justify = \"right\"\n ),\n output_type = output_type\n ),\n \": \",\n color_display,\n \"\\n\"\n )\n result <- paste0(result, item_text)\n }\n\n result\n} # /rtemis::show_col\n" }, { "path": "R/utils_async.R", "content": "# utils_async.R\n# ::rtemis::\n# 2026- EDG rtemis.org\n\n# Define allowed future plans\nALLOWED_PLANS <- c(\n \"sequential\",\n \"multicore\",\n \"multisession\",\n \"cluster\",\n \"remote\",\n \"transparent\",\n \"future.mirai::mirai_multisession\", # what user sets\n \"mirai_multisession\" # what future::plan() returns\n)\n\n\n#' Check if system is Windows\n#'\n#' @return Logical: TRUE if Windows, FALSE otherwise\n#' @noRd\nis_windows <- function() {\n tolower(Sys.info()[[\"sysname\"]]) == \"windows\"\n} # /is_windows\n\n\n#' Identify future plan\n#'\n#' @return Character: Name of current plan\n#'\n#' @noRd\nidentify_plan <- function(x = NULL) {\n if (is.null(x)) {\n x <- future::plan()\n }\n for (p in ALLOWED_PLANS) {\n if (inherits(x, p)) {\n return(p)\n }\n }\n cli::cli_abort(\n \"Detected future plan not in allowed plans ({.val {ALLOWED_PLANS}}). Detected plan class: {.val {class(x)}}\"\n )\n} # /rtemis::identify_plan\n\n\n#' Set preferred plan\n#'\n#' Sets the future plan according to system and user preference:\n#' - Check whether a plan has been set by the user\n#' - Check whether there is an option set for future plan\n#' - Check available cores\n#' - Check if Windows\n#'\n#' @param requested_plan Optional character: Requested plan, one of \"multicore\", \"multisession\", \"sequential\".\n#' @param n_workers Optional integer: Number of workers to use.\n#'\n#' @return Character: Name of plan set\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nset_preferred_plan <- function(\n requested_plan = NULL,\n n_workers = NULL,\n envir = parent.frame(),\n verbosity = 1L\n) {\n # If user has requested a specific plan, try to set it\n if (!is.null(requested_plan)) {\n # Security check\n if (!requested_plan %in% ALLOWED_PLANS) {\n cli::cli_abort(\n \"Requested plan {.val {requested_plan}} is not one of allowed plans: {.val {ALLOWED_PLANS}}\"\n )\n }\n # future::plan will determine workers if NULL & will set to sequential if only 1 core available\n # therefore plan set by following call is not always the requested one and needs to be\n # determined.\n\n if (requested_plan == \"sequential\") {\n with(\n future::plan(strategy = requested_plan),\n local = TRUE,\n envir = envir\n )\n } else {\n with(\n future::plan(strategy = requested_plan, workers = n_workers),\n local = TRUE,\n envir = envir\n )\n }\n\n return(identify_plan())\n }\n\n # If user has not requested a specific plan, check if they have set one\n current_plan <- future::plan()\n\n # If the plan is not sequential, we must assume user set it and respect it (though it might\n # have been set by a different package)\n if (!inherits(current_plan, \"sequential\")) {\n return(identify_plan(current_plan))\n }\n # If the plan is sequential, we can't currently tell if it was set by the user or is default\n # -> Ideally, we would know this. <-\n # We therefore proceed to set our preferred plan based on OS, n available cores, and requested\n # n workers.\n # If n_workers was set to 1 and no requested_plan was defined, use sequential\n if (!is.null(n_workers) && n_workers == 1L) {\n with(\n future::plan(strategy = \"sequential\"),\n local = TRUE,\n envir = envir\n )\n return(\"sequential\")\n }\n\n if (is_windows()) {\n # On Windows, multicore is not available\n preferred_plan <- \"multisession\"\n } else {\n preferred_plan <- \"multicore\"\n }\n with(\n future::plan(strategy = preferred_plan, workers = n_workers),\n local = TRUE,\n envir = envir\n )\n # This will still be sequential and not \"preferred_plan\" if n_workers = 1\n identify_plan()\n} # /set_preferred_plan\n" }, { "path": "R/utils_checks.R", "content": "# utils_checks.R\n# ::rtemis::\n# 2024- EDG rtemis.org\n\n# clean_* functions performm checks and return clean inputs.\n# check_* functions perform checks (do not return a value).\n\n# %% test_inherits ----\n#' Check class of object\n#'\n#' @param x Object to check\n#' @param cl Character: class to check against\n#'\n#' @return Logical\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' test_inherits(\"papaya\", \"character\") # TRUE\n#' test_inherits(c(1, 2.5, 3.2), \"integer\")\n#' test_inherits(iris, \"list\") # FALSE, compare to is_check(iris, is.list)\ntest_inherits <- function(x, cl) {\n if (!inherits(x, cl)) {\n input <- deparse(substitute(x))\n message(red(bold(input), \"is not\", bold(cl)))\n return(FALSE)\n }\n TRUE\n} # /rtemis::test_inherits\n\n\n# %% check_inherits ----\n#' Check class of object\n#'\n#' @param x Object to check.\n#' @param cl Character: class to check against.\n#' @param allow_null Logical: If TRUE, NULL values are allowed and return early.\n#'\n#' @return Called for side effects. Throws an error if checks fail.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' check_inherits(\"papaya\", \"character\")\n#' # These will throw errors:\n#' # check_inherits(c(1, 2.5, 3.2), \"integer\")\n#' # check_inherits(iris, \"list\")\ncheck_inherits <- function(\n x,\n cl,\n allow_null = TRUE,\n xname = deparse(substitute(x))\n) {\n if (allow_null && is.null(x)) {\n return(invisible())\n }\n\n if (is.null(x)) {\n cli::cli_abort(\"{.var {xname}} cannot be NULL.\")\n }\n\n if (!inherits(x, cl)) {\n cli::cli_abort(\n \"{.var {xname}} must be of class {.cls {cl}}.\"\n )\n }\n\n invisible()\n} # /rtemis::check_inherits\n\n\n# %% clean_int ----\n#' Clean integer input\n#'\n#' @details\n#' The goal is to return an integer vector.\n#' If the input is integer, it is returned as is.\n#' If the input is numeric, it is coerced to integer only if the numeric values are integers,\n#' otherwise an error is thrown.\n#'\n#' @param x Double or integer vector to check.\n#'\n#' @return Integer vector\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' clean_int(6L)\n#' clean_int(3)\n#' # clean_int(12.1) # Error\n#' clean_int(c(3, 5, 7))\n#' # clean_int(c(3, 5, 7.01)) # Error\nclean_int <- function(x, xname = deparse(substitute(x))) {\n if (is.integer(x)) {\n return(x)\n } else if (is.numeric(x)) {\n if (all(x %% 1 == 0)) {\n return(as.integer(x))\n } else {\n cli::cli_abort(\"{.var {xname}} must be integer.\")\n }\n } else if (is.null(x)) {\n return(NULL)\n }\n cli::cli_abort(\"{.var {xname}} must be integer.\")\n} # /rtemis::clean_int\n\n\n# %% match_arg ----\n#' Match Arguments Ignoring Case\n#'\n#' @param x Character: Argument to match.\n#' @param choices Character vector: Choices to match against.\n#'\n#' @return Character: Matched argument.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' match_arg(\"papaya\", c(\"AppleExtreme\", \"SuperBanana\", \"PapayaMaster\"))\nmatch_arg <- function(x, choices) {\n out <- match.arg(tolower(x), tolower(choices))\n grep(out, choices, value = TRUE, ignore.case = TRUE)\n} # /rtemis::match_arg\n\n\n# %% check_logical ----\n#' Check logical\n#'\n#' @param x Vector to check\n#' @param allow_null Logical: If TRUE, NULL values are allowed and return early.\n#'\n#' @return Called for side effects. Throws an error if checks fail.\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\ncheck_logical <- function(\n x,\n allow_null = TRUE,\n xname = deparse(substitute(x))\n) {\n if (allow_null && is.null(x)) {\n return(invisible())\n }\n\n if (is.null(x)) {\n cli::cli_abort(\"{.var {xname}} cannot be NULL.\")\n }\n\n if (anyNA(x)) {\n cli::cli_abort(\"{.var {xname}} must not contain NAs.\")\n }\n if (!is.logical(x)) {\n cli::cli_abort(\"{.var {xname}} must be logical.\")\n }\n\n invisible()\n} # /rtemis::check_logical\n\n\n# %% check_character ----\n#' Check character\n#'\n#' @param x Vector to check\n#' @param allow_null Logical: If TRUE, NULL values are allowed and return early.\n#'\n#' @return Called for side effects. Throws an error if checks fail.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncheck_character <- function(\n x,\n allow_null = TRUE,\n xname = deparse(substitute(x))\n) {\n if (allow_null && is.null(x)) {\n return(invisible())\n }\n\n if (is.null(x)) {\n cli::cli_abort(\"{.var {xname}} cannot be NULL.\")\n }\n\n if (anyNA(x)) {\n cli::cli_abort(\"{.var {xname}} must not contain NAs.\")\n }\n if (!is.character(x)) {\n cli::cli_abort(\"{.var {xname}} must be character.\")\n }\n\n invisible()\n} # /rtemis::check_character\n\n\n# %% check_floatpos ----\n#' Check positive float\n#'\n#' @details\n#' Checking with `is.numeric()` allows integer inputs as well, which should be ok since it is\n#' unlikely the function that consumes this will enforce double type only, but instead is most\n#' likely to allow implicit coercion from integer to numeric.\n#'\n#' @param x Float vector.\n#' @param allow_null Logical: If TRUE, NULL values are allowed and return early.\n#'\n#' @return Called for side effects. Throws an error if checks fail, otherwise invisible().\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncheck_floatpos <- function(\n x,\n allow_null = TRUE,\n xname = deparse(substitute(x))\n) {\n if (allow_null && is.null(x)) {\n return(invisible())\n }\n\n if (is.null(x)) {\n cli::cli_abort(\"{.var {xname}} cannot be NULL.\")\n }\n\n if (!is.numeric(x)) {\n cli::cli_abort(\"{.var {xname}} must be numeric.\")\n }\n\n if (anyNA(x)) {\n cli::cli_abort(\"{.var {xname}} must not contain NAs.\")\n }\n\n if (any(x <= 0)) {\n cli::cli_abort(\"{.var {xname}} must be greater than 0.\")\n }\n\n invisible()\n} # /rtemis::check_floatpos\n\n\n# %% check_float01exc ----\n#' Check float between 0 and 1, exclusive\n#'\n#' @param x Vector to check\n#' @param allow_null Logical: If TRUE, NULL values are allowed and return early.\n#'\n#' @return Called for side effects. Throws an error if checks fail.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#' @examples\n#' check_float01exc(0.5)\ncheck_float01exc <- function(\n x,\n allow_null = TRUE,\n xname = deparse(substitute(x))\n) {\n if (allow_null && is.null(x)) {\n return(invisible())\n }\n\n if (is.null(x)) {\n cli::cli_abort(\"{.var {xname}} cannot be NULL.\")\n }\n\n if (!is.numeric(x)) {\n cli::cli_abort(\"{.var {xname}} must be numeric.\")\n }\n\n if (anyNA(x)) {\n cli::cli_abort(\"{.var {xname}} must not contain NAs.\")\n }\n\n if (any(x <= 0 | x >= 1)) {\n cli::cli_abort(\n \"{.var {xname}} must be between 0 and 1, exclusive.\"\n )\n }\n\n invisible()\n} # /rtemis::check_float01exc\n\n\n# %% check_float01inc ----\n#' Check float between 0 and 1, inclusive\n#'\n#' @param x Float vector.\n#' @param allow_null Logical: If TRUE, NULL values are allowed and return early.\n#'\n#' @return Called for side effects. Throws an error if checks fail.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#' @examples\n#' check_float01inc(0.5)\ncheck_float01inc <- function(\n x,\n allow_null = TRUE,\n xname = deparse(substitute(x))\n) {\n if (allow_null && is.null(x)) {\n return(invisible())\n }\n\n if (is.null(x)) {\n cli::cli_abort(\"{.var {xname}} cannot be NULL.\")\n }\n\n if (!is.numeric(x)) {\n cli::cli_abort(\n \"{.var {xname}} must be numeric. Received: {.val {x}} of class {class(x)}\",\n call. = FALSE\n )\n }\n\n if (anyNA(x)) {\n cli::cli_abort(\"{.var {xname}} must not contain NAs.\")\n }\n\n if (any(x < 0 | x > 1)) {\n cli::cli_abort(\"{.var {xname}} must be between 0 and 1, inclusive.\")\n }\n\n invisible()\n} # /rtemis::check_float01\n\n\n# %% check_floatpos1 ----\ncheck_floatpos1 <- function(\n x,\n allow_null = TRUE,\n xname = deparse(substitute(x))\n) {\n if (allow_null && is.null(x)) {\n return(invisible())\n }\n\n if (is.null(x)) {\n cli::cli_abort(\"{.var {xname}} cannot be NULL.\")\n }\n\n if (!is.numeric(x)) {\n cli::cli_abort(\"{.var {xname}} must be numeric.\")\n }\n\n if (anyNA(x)) {\n cli::cli_abort(\"{.var {xname}} must not contain NAs.\")\n }\n\n if (any(x <= 0) || any(x > 1)) {\n cli::cli_abort(\n \"{.var {xname}} must be greater than 0 and less or equal to 1.\"\n )\n }\n\n invisible()\n} # /rtemis::check_floatpos1\n\n\n# %% clean_posint ----\n#' Check positive integer\n#'\n#' @param x Integer vector.\n#'\n#' @return x, otherwise error.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' clean_posint(5)\nclean_posint <- function(x, allow_na = FALSE, xname = deparse(substitute(x))) {\n if (is.null(x)) {\n return(NULL)\n }\n\n if (!allow_na && anyNA(x)) {\n cli::cli_abort(\"{.var {xname}} must not contain NAs.\")\n } else {\n x <- na.exclude(x)\n }\n\n if (any(x <= 0)) {\n cli::cli_abort(\"{.var {xname}} must contain only positive integers.\")\n }\n\n clean_int(x, xname = xname)\n} # /rtemis::clean_posint\n\n\n# %% check_float0pos ----\n#' Check float greater than or equal to 0\n#'\n#' Checks if an input is a numeric vector containing non-negative\n#' (>= 0) values and no `NA`s. It is designed to validate function arguments.\n#'\n#' @param x Numeric vector: The input object to check.\n#' @param allow_null Logical: If TRUE, NULL values are allowed and return early.\n#'\n#' @return Called for side effects. Throws an error if checks fail.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\ncheck_float0pos <- function(\n x,\n allow_null = TRUE,\n xname = deparse(substitute(x))\n) {\n if (allow_null && is.null(x)) {\n return(invisible())\n }\n\n if (is.null(x)) {\n cli::cli_abort(\"{.var {xname}} cannot be NULL.\")\n }\n\n if (!is.numeric(x)) {\n cli::cli_abort(\"{.var {xname}} must be numeric.\")\n }\n\n if (anyNA(x)) {\n cli::cli_abort(\"{.var {xname}} must not contain NAs.\")\n }\n\n if (any(x < 0)) {\n cli::cli_abort(\"{.var {xname}} must be zero or greater.\")\n }\n\n invisible()\n} # /rtemis::check_float0pos\n\n\n# %% check_float_neg1_1 ----\n#' Check float -1 <= x <= 1\n#'\n#' @param x Numeric vector: The input object to check.\n#' @param allow_null Logical: If TRUE, NULL values are allowed and return early.\n#'\n#' @return Called for side effects. Throws an error if checks fail.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\ncheck_float_neg1_1 <- function(\n x,\n allow_null = TRUE,\n xname = deparse(substitute(x))\n) {\n if (allow_null && is.null(x)) {\n return(invisible())\n }\n\n if (is.null(x)) {\n cli::cli_abort(\"{.var {xname}} cannot be NULL.\")\n }\n\n if (!is.numeric(x)) {\n cli::cli_abort(\"{.var {xname}} must be numeric.\")\n }\n\n if (anyNA(x)) {\n cli::cli_abort(\"{.var {xname}} must not contain NAs.\")\n }\n\n if (any(x < -1 | x > 1)) {\n cli::cli_abort(\"{.var {xname}} must be between -1 and 1, inclusive.\")\n }\n\n invisible()\n} # /rtemis::check_float_neg1_1\n\n\n# %% abbreviate_class ----\n#' Abbreviate object class name\n#'\n#' @param x Object\n#'\n#' @return Character: Abbreviated class\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nabbreviate_class <- function(x, n = 4L) {\n paste0(\"<\", abbreviate(class(x)[1], minlength = n), \">\")\n} # /rtemis::abbr_class\n\n\n# %% check_dependencies ----\n#' \\pkg{rtemis} internal: Dependencies check\n#'\n#' Checks if dependencies can be loaded; names missing dependencies if not.\n#'\n#' @param ... List or vector of strings defining namespaces to be checked\n#' @param verbosity Integer: Verbosity level.\n#' Note: An error will always printed if dependencies are missing.\n#' Setting this to FALSE stops it from printing\n#' \"Dependencies check passed\".\n#'\n#' @return Called for side effects. Aborts and prints list of missing dependencies, if any.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\ncheck_dependencies <- function(..., verbosity = 0L) {\n ns <- as.list(c(...))\n err <- !sapply(ns, \\(i) requireNamespace(i, quietly = TRUE))\n if (any(err)) {\n cli::cli_abort(\n paste0(\n \"Please install the following \",\n ngettext(sum(err), \"dependency\", \"dependencies\"),\n \":\\n\",\n pastels(ns[err], bullet = \" -\")\n )\n )\n } else {\n if (verbosity > 0L) msg(\"Dependency check passed\")\n }\n invisible()\n} # /rtemis::check_dependencies\n\n\n# %% check_data.table ----\n#' Check data.table\n#'\n#' @param x Object to check.\n#'\n#' @return Called for side effects. Throws an error if input is not a data.table, returns x\n#' invisibly otherwise.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncheck_data.table <- function(x, xname = deparse(substitute(x))) {\n if (!data.table::is.data.table(x)) {\n cli::cli_abort(\"{.var {xname}} must be a data.table.\")\n }\n invisible(x)\n} # /rtemis::check_data.table\n\n\n# %% check_tabular ----\n#' Check object is tabular\n#'\n#' Checks if object is of class `data.frame`, `data.table`, or `tbl_df`.\n#'\n#' @param x Object to check.\n#'\n#' @return Called for side effects. Throws an error if input is not tabular, returns x invisibly\n#' otherwise.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncheck_tabular <- function(x) {\n if (!inherits(x, c(\"data.frame\", \"data.table\", \"tbl_df\"))) {\n cli::cli_abort(\n \"{.var {deparse(substitute(x))}} must be a data.frame, data.table, or tbl_df.\"\n )\n }\n invisible(x)\n} # /rtemis::check_tabular\n" }, { "path": "R/utils_color.R", "content": "# utils_color.R\n# ::rtemis::\n# 2016- EDG rtemis.org\n\n#' Simple Color Operations\n#'\n#' Invert a color or calculate the mean of two colors in HSV or RGB space.\n#' This may be useful in creating colors for plots\n#'\n#' The average of two colors in RGB space will often pass through gray,\n#' which is likely undesirable. Averaging in HSV space, better for most applications.\n#' @param col Input color(s)\n#' @param fn Character: \"invert\", \"mean\": Function to perform\n#' @param space Character: \"HSV\", \"RGB\": Colorspace to operate in - for\n#' averaging only\n#'\n#' @return Color\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncolor_op <- function(col, fn = c(\"invert\", \"mean\"), space = c(\"HSV\", \"RGB\")) {\n # Arguments ----\n fn <- match.arg(fn)\n space <- match.arg(space)\n\n # Colors ----\n col <- as.list(col)\n col.rgb <- col2rgb(col, alpha = TRUE)\n\n if (fn == \"invert\") {\n inverted <- apply(col.rgb, 2, \\(i) 255 - i)\n # maintain alpha\n inverted[4, ] <- col.rgb[4, ]\n invertedl <- lapply(seq_len(NCOL(inverted)), \\(i) {\n rgb(\n inverted[1, i],\n inverted[2, i],\n inverted[3, i],\n inverted[4, i],\n maxColorValue = 255\n )\n })\n if (!is.null(names(col))) {\n names(invertedl) <- paste0(names(col), \".invert\")\n }\n return(invertedl)\n } else if (fn == \"mean\") {\n if (length(col) < 2) {\n cli::cli_abort(\"Need at least two colors to average\")\n }\n if (space == \"RGB\") {\n averaged <- rowMeans(col.rgb)\n averaged <- rgb(\n averaged[1],\n averaged[2],\n averaged[3],\n averaged[4],\n maxColorValue = 255\n )\n return(list(average = averaged))\n } else if (space == \"HSV\") {\n # Convert HSV to RGB\n col.hsv <- rgb2hsv(col.rgb[1:3, ])\n # Get mean HSV values\n averaged <- rowMeans(col.hsv)\n # Get mean alpha from RGB\n alpha <- mean(col.rgb[4, ])\n # Turn to hex\n averaged <- hsv(averaged[1], averaged[2], averaged[3], alpha / 255)\n return(averaged)\n }\n }\n} # /rtemis::color_op\n\n\n#' Color to Grayscale\n#'\n#' Convert a color to grayscale\n#'\n#' Uses the NTSC grayscale conversion:\n#' 0.299 * R + 0.587 * G + 0.114 * B\n#'\n#' @param x Color to convert to grayscale\n#' @param what Character: \"color\" returns a hexadecimal color,\n#' \"decimal\" returns a decimal between 0 and 1\n#'\n#' @return Character: color hex code.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' col2grayscale(\"red\")\n#' col2grayscale(\"red\", \"dec\")\ncol2grayscale <- function(x, what = c(\"color\", \"decimal\")) {\n what <- match.arg(what)\n col <- col2rgb(x)\n gs <- (0.299 * col[1, ] + 0.587 * col[2, ] + 0.114 * col[3, ]) / 255\n if (what == \"color\") {\n grDevices::gray(gs)\n } else {\n gs\n }\n} # /rtemis::col2grayscale\n\n\n#' Invert Color in RGB space\n#'\n#' @param x Color, vector\n#'\n#' @return Inverted colors using hexadecimal notation `#RRGGBBAA`.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' cols <- c(\"red\", \"green\", \"blue\")\n#' previewcolor(cols)\n#' cols |>\n#' color_invertRGB() |>\n#' previewcolor()\ncolor_invertRGB <- function(x) {\n col <- as.list(x)\n col_rgb <- col2rgb(col, alpha = TRUE)\n inverted <- apply(col_rgb, 2, \\(i) 255 - i)\n # maintain alpha\n inverted[4, ] <- col_rgb[4, ]\n invertedl <- sapply(seq_len(NCOL(inverted)), \\(i) {\n rgb(\n inverted[1, i],\n inverted[2, i],\n inverted[3, i],\n inverted[4, i],\n maxColorValue = 255\n )\n })\n if (!is.null(names(col))) {\n names(invertedl) <- paste0(names(col), \".invert\")\n }\n invertedl\n} # /rtemis::color_invertRGB\n\n\n#' Fade color towards target\n#'\n#' @param x Color source\n#' @param to Target color\n#' @param pct Numeric (0, 1) fraction of the distance in RGBA space between\n#' `x` and `to` to move. e.g. .5 gets the mean RGBA value of the two\n#'\n#' @return Color in hex notation\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' previewcolor(c(\"red\", color_fade(\"red\", \"blue\", .5), \"blue\"))\ncolor_fade <- function(x, to = \"#000000\", pct = .5) {\n col <- col2rgb(x, alpha = TRUE)\n col2 <- col2rgb(to, alpha = TRUE)\n d <- (col2 - col) * pct\n colf <- (col + d) / 255\n rgb(colf[1], colf[2], colf[3], colf[4])\n}\n\n\n#' Pastelify a color (make a color more pastel)\n#'\n#' Lower a color's saturation by a given percent in the HSV color system\n#'\n#' @param x Color vector: Color(s) to operate on\n#' @param s Float: Decrease saturation by this fraction. For example, if `s = 0.3` and saturation of\n#' input color is 1, it will become 0.7.\n#'\n#' @return Character vector with hex codes of modified colors.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' cols <- c(\"red\", \"green\", \"blue\")\n#' previewcolor(cols)\n#' cols_d <- desaturate(cols)\n#' previewcolor(cols_d)\ndesaturate <- function(x, s = 0.3) {\n # Infer color names, if available\n if (!is.null(names(x))) {\n .names <- names(x)\n } else if (is.character(x)) {\n .names <- x\n } else {\n .names <- NULL\n }\n\n x <- lapply(x, col2rgb)\n x <- lapply(x, rgb2hsv)\n xp <- lapply(x, function(i) {\n .s <- i[2]\n i[2] <- .s - (.s * s)\n hsv(i[1], i[2], i[3])\n })\n\n names(xp) <- .names\n unlist(xp)\n} # /rtemis::desaturate\n\n\n#' Convert R color to hexadecimal code\n#'\n#' Convert a color that R understands into the corresponding hexadecimal code\n#'\n#' @param color Color(s) that R understands\n#'\n#' @return Character vector of hexadecimal codes.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' col2hex(c(\"gray50\", \"skyblue\"))\ncol2hex <- function(color) {\n .rgb <- col2rgb(color)\n sapply(seq_along(color), function(i) {\n paste0(\n \"#\",\n paste0(\n sprintf(\n \"%02s\",\n c(\n as.character(as.hexmode(.rgb[1, i])),\n as.character(as.hexmode(.rgb[2, i])),\n as.character(as.hexmode(.rgb[3, i]))\n )\n ),\n collapse = \"\"\n )\n )\n })\n} # /rtemis::col2hex\n\n\n#' Adjust HSV Color\n#'\n#' Modify alpha, hue, saturation and value (HSV) of a color\n#'\n#' @param color Input color. Any format that grDevices::col2rgb() recognizes\n#' @param alpha Numeric: Scale alpha by this amount. Future: replace with absolute setting\n#' @param hue Float: How much hue to add to `color`\n#' @param sat Float: How much saturation to add to `color`\n#' @param val Float: How much to increase value of `color` by\n#'\n#' @return Adjusted color\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' previewcolor(c(teal = \"#00ffff\", teal50 = color_adjust(\"#00ffff\", alpha = 0.5)))\ncolor_adjust <- function(color, alpha = NULL, hue = 0, sat = 0, val = 0) {\n ac <- color\n # HSV ----\n ac.hsv <- grDevices::rgb2hsv(grDevices::col2rgb(ac))\n ac <- grDevices::hsv(ac.hsv[1] + hue, ac.hsv[2] + sat, ac.hsv[3] + val)\n # alpha ----\n if (!is.null(alpha)) {\n ac <- adjustcolor(ac, alpha.f = alpha)\n }\n ac\n} # /rtemis::color_adjust\n\n\n#' Preview color\n#'\n#' Preview one or multiple colors using little rhombi with their little labels up top\n#'\n#' @param x Color, vector: One or more colors that R understands\n#' @param main Character: Title. Default = NULL, which results in\n#' `deparse(substitute(x))`\n#' @param bg Background color.\n#' @param main_col Color: Title color\n#' @param main_x Float: x coordinate for `main`.\n#' @param main_y Float: y coordinate for `main`.\n#' @param main_adj Float: `adj` argument to mtext for `main`.\n#' @param main_cex Float: character expansion factor for `main`.\n#' @param main_font Integer, 1 or 2: Weight of `main` 1: regular, 2: bold.\n#' @param width Float: Plot width. Default = NULL, i.e. set automatically\n#' @param xlim Vector, length 2: x-axis limits. Default = NULL, i.e. set automatically\n#' @param ylim Vector, length 2: y-axis limits.\n#' @param asp Float: Plot aspect ratio.\n#' @param labels_y Float: y coord for labels. Default = 1.55 (rhombi are fixed and range y .5 - 1.5)\n#' @param label_cex Float: Character expansion for labels. Default = NULL, and is\n#' calculated automatically based on length of `x`\n#' @param mar Numeric vector, length 4: margin size.\n#' @param filename Character: Path to save plot as PDF.\n#' @param pdf_width Numeric: Width of PDF in inches.\n#' @param pdf_height Numeric: Height of PDF in inches.\n#'\n#' @return Nothing, prints plot.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' previewcolor(get_palette(\"rtms\"))\npreviewcolor <- function(\n x,\n main = NULL,\n bg = \"#333333\",\n main_col = \"#b3b3b3\",\n main_x = .7,\n main_y = 0.2,\n main_adj = 0,\n main_cex = .9,\n main_font = 2,\n width = NULL,\n xlim = NULL,\n ylim = c(0, 2.2),\n asp = 1,\n labels_y = 1.55,\n label_cex = NULL,\n mar = c(0, 0, 0, 1),\n filename = NULL,\n pdf_width = 8,\n pdf_height = 2.5\n) {\n if (is.null(main)) {\n main <- deparse(substitute(x))\n }\n x <- unlist(x)\n\n par_orig <- par(no.readonly = TRUE)\n on.exit(par(par_orig))\n\n if (is.null(width)) {\n width <- max(3, .3 * length(x))\n }\n if (is.null(xlim)) {\n xlim <- c(0.3, width + .7)\n }\n if (!is.null(filename)) {\n grDevices::pdf(filename, pdf_width, pdf_height)\n }\n par(bg = bg, mar = mar, oma = c(0, 0, 0, 0), xaxs = \"i\", yaxs = \"i\")\n\n # Plot ----\n plot(\n NULL,\n NULL,\n asp = asp,\n axes = FALSE,\n xlim = xlim,\n ylim = ylim,\n xlab = NA,\n ylab = NA\n )\n\n if (length(x) >= 3) {\n xmid <- seq(1, width, length.out = length(x))\n } else if (length(x) == 2) {\n xmid <- c(.3333 * width, .6666 * width) + .5\n } else {\n xmid <- .5 * width + .5\n }\n\n for (i in seq(x)) {\n rhombus(xmid[i], 1, col = x[i])\n }\n\n # '- Labels ----\n if (is.null(label_cex)) {\n label_cex <- 1.30 - .02 * length(x)\n label_cex <- 1.314869 - 0.009163 * length(x)\n }\n\n if (is.null(names(x))) {\n labels <- as.character(x)\n } else {\n labels <- names(x)\n }\n text(\n xmid + .1,\n labels_y,\n labels,\n col = x,\n srt = 45,\n adj = 0,\n offset = 0,\n cex = label_cex,\n xpd = TRUE\n )\n\n # '- Title ----\n if (!is.null(main)) {\n text(\n main_x,\n main_y,\n main,\n col = main_col,\n adj = main_adj,\n font = main_font,\n cex = main_cex\n )\n }\n\n if (!is.null(filename)) {\n dev.off()\n }\n} # /rtemis::previewcolor\n\n\nrhombus <- function(\n xmid = 1,\n ymid = 1,\n width = 1,\n height = 1,\n col = \"#80FFFF\"\n) {\n # left, top, right, bottom\n hw <- .5 * width\n hh <- .5 * height\n polygon(\n x = c(xmid - hw, xmid, xmid + hw, xmid),\n y = c(ymid, ymid + hh, ymid, ymid - hh),\n col = col,\n border = NA\n )\n} # /rtemis::rhombus\n\n\n#' Color Gradient\n#'\n#' Create a gradient of colors and optionally a colorbar\n#'\n#' It is best to provide an odd number, so that there is always an equal number of colors on either side\n#' of the midpoint.\n#' For example, if you want a gradient from -1 to 1 or equivalent, an n = 11, will give 5 colors on either\n#' side of 0, each representing a 20\\% change from the next.\n#'\n#' `colors` can be defined as a sequence of 3-letter color abbreviations of 2, 3, 4, or 5 colors\n#' which will correspond to values: \\{\"lo\",\"hi\"\\}; \\{\"lo\", \"mid\", \"hi\"\\}; \\{\"lo\", \"mid\", \"midhi\", \"hi\"\\}, and\n#' \\{\"lo\", \"lomid\", \"mid\", \"midhi\", \"hi\"\\}, respectively.\n#' For example, try `colorgrad(21, \"blugrnblkredyel\", colorbar = TRUE)`\n#' 3-letter color abbreviations:\n#' wht: white; blk: black; red; grn: green; blu: blue; yel: yellow; rng: orange; prl: purple\n#'\n#' @param n Integer: How many distinct colors you want. If not odd, converted to `n + 1`\n#' Defaults to 21\n#' @param colors Character: Acts as a shortcut to defining `lo`, `mid`, etc for a number of defaults:\n#' \"french\", \"penn\", \"grnblkred\",\n#' @param space Character: Which colorspace to use. Option: \"rgb\", or \"Lab\".\n#' Recommendation: If `mid` is \"white\" or \"black\" (default), use \"rgb\", otherwise \"Lab\"\n#' @param lo Color for low end\n#' @param lomid Color for low-mid\n#' @param mid Color for middle of the range or \"mean\", which will result in `color_op(c(lo, hi), \"mean\")`.\n#' If `mid = NA`, then only `lo` and `hi` are used to create the color gradient.\n#' @param midhi Color for middle-high\n#' @param hi Color for high end\n#' @param preview Logical: Plot the colors horizontally\n#' @param cb_n Integer: How many steps you would like in the colorbar\n#' @param bar_min Numeric: Lowest value in colorbar\n#' @param bar_mid Numeric: Middle value in colorbar\n#' @param bar_max Numeric: Max value in colorbar\n#' @param cex Float: Character expansion for axis\n#' @param theme Theme object.\n#' @param bg Color: Background color\n#' @param col_text Color: Colorbar text color\n#' @param plotlycb Logical: Create colorbar using `plotly` (instead of base R graphics)\n#' @param plotly_width Float: Width for plotly colorbar.\n#' @param plotly_height Float: Height for plotly colorbar.\n#' @param return_plotly Logical: If TRUE, return `plotly` object\n#' @param margins Vector: Plotly margins.\n#' @param pad Float: Padding for `plotly`.\n#'\n#' @return Invisible vector of hexadecimal colors / plotly object if `return_plotly = TRUE`\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ncolorgrad <- function(\n n = 21L,\n colors = NULL,\n space = c(\"rgb\", \"Lab\"),\n lo = rt_teal,\n lomid = NULL,\n mid = NULL,\n midhi = NULL,\n hi = rt_orange,\n preview = FALSE,\n cb_n = 21L,\n bar_min = -1,\n bar_mid = 0,\n bar_max = 1,\n cex = 1.2,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n bg = NULL,\n col_text = NULL,\n plotlycb = FALSE,\n plotly_width = 80,\n plotly_height = 500,\n return_plotly = FALSE,\n margins = c(0, 0, 0, 0),\n pad = 0L\n) {\n # Arguments ----\n n <- as.integer(n)\n if (n %% 2 != 1) {\n n <- n + 1\n }\n\n if (return_plotly) {\n plotlycb <- TRUE\n }\n if (is.null(cb_n)) {\n cb_n <- n\n if (cb_n %% 2 != 1) cb_n <- cb_n + 1\n }\n space <- match.arg(space)\n theme <- if (strtrim(theme@name, 4) %in% c(\"dark\", \"blac\")) {\n \"dark\"\n } else {\n \"light\"\n }\n\n # Colors ----\n if (!is.null(colors)) {\n if (colors == \"french\") {\n lo <- \"#01256E\"\n lomid <- NULL\n mid <- \"white\"\n midhi <- NULL\n hi <- \"#95001A\"\n } else if (colors == \"penn\") {\n lo <- \"#02CFFF\"\n lomid <- NULL\n mid <- \"#01256E\"\n midhi <- \"#95001A\"\n hi <- \"#F2C100\"\n } else if (colors == \"blues\") {\n lo <- \"#01256E\"\n mid <- NULL\n hi <- \"#82AFD3\"\n } else if (colors == \"greens\") {\n lo <- \"#005200\"\n mid <- NULL\n hi <- \"#80DF80\"\n } else {\n cols <- colorvec(cols = colors)\n lo <- cols$lo\n lomid <- cols$lomid\n mid <- cols$mid\n midhi <- cols$midhi\n hi <- cols$hi\n }\n }\n\n # Grad ----\n n <- as.integer(n)\n midpoint <- ceiling(n / 2)\n if (is.null(mid)) {\n mid <- ifelse(theme == \"light\", \"white\", \"black\")\n }\n if (!is.na(mid)) {\n if (mid == \"mean\") {\n mid <- color_op(c(lo, hi), \"mean\")\n }\n lo2mid <- colorRampPalette(c(lo, lomid, mid), space = space)\n mid2hi <- colorRampPalette(c(mid, midhi, hi), space = space)\n grad <- c(lo2mid(midpoint), mid2hi(n - midpoint + 1)[-1])\n } else {\n grad <- colorRampPalette(c(lo, hi), space = space)(n)\n }\n\n if (cb_n != n) {\n cb_n <- as.integer(cb_n)\n cb_midpoint <- ceiling(cb_n / 2)\n # if (is.null(mid)) mid <- color_op(c(lo, hi), \"mean\")\n # lo2mid <- grDevices::colorRampPalette(c(lo, lomid, mid), space = space)\n # mid2hi <- grDevices::colorRampPalette(c(mid, midhi, hi), space = space)\n if (!is.na(mid)) {\n cb_grad <- c(lo2mid(cb_midpoint), mid2hi(cb_n - cb_midpoint + 1)[-1])\n } else {\n cb_grad <- colorRampPalette(c(lo, hi), space = space)(cb_n)\n }\n } else {\n cb_grad <- grad\n cb_midpoint <- midpoint\n }\n\n # Preview ----\n if (preview) {\n plot(\n rep(1, n),\n col = grad,\n pch = 19,\n cex = 6,\n xlim = c(0.5, n + .5),\n ylim = c(.8, 1.2),\n ann = FALSE,\n axes = FALSE\n )\n text(\n x = 0.25,\n y = 1.05,\n labels = paste0(\"Color gradient (n = \", n, \")\"),\n adj = 0,\n cex = 1.5\n )\n segments(midpoint, .95, midpoint, 1.05, lwd = 2, lty = 2, col = NA)\n }\n\n # Plotly cb ----\n if (plotlycb) {\n requireNamespace(\"plotly\")\n\n m <- list(\n size = 40,\n color = grad,\n opacity = 1,\n symbol = \"circle\"\n )\n\n x.ax <- list(\n title = \"\",\n zeroline = FALSE,\n showline = FALSE,\n showticklabels = FALSE,\n showgrid = FALSE,\n range = c(0.8, 1.4)\n )\n\n y.ax <- list(\n title = \"\",\n zeroline = FALSE,\n showline = FALSE,\n showticklabels = FALSE,\n showgrid = FALSE\n )\n\n t <- list(\n family = \"Open Sans\",\n size = 22,\n color = plotly::toRGB(\"black\")\n )\n\n a <- list()\n for (i in 1:3) {\n a[[i]] <- list(\n x = 1.3,\n y = c(1, midpoint, n)[i],\n text = as.character(c(bar_min, bar_mid, bar_max))[i],\n xref = \"x\",\n yref = \"y\",\n showarrow = FALSE\n )\n }\n\n hovtext <- ddSci(seq(bar_min, bar_max, (bar_max - bar_min) / (n - 1)))\n\n margin <- list(\n b = margins[1],\n l = margins[2],\n t = margins[3],\n r = margins[4],\n pad = pad\n )\n\n p <- plotly::plot_ly(\n x = rep(1, n),\n y = 1:n,\n type = \"scatter\",\n mode = \"markers\",\n marker = m,\n hoverinfo = \"text\",\n text = hovtext\n ) |>\n plotly::layout(\n xaxis = x.ax,\n yaxis = y.ax,\n width = plotly_width,\n height = plotly_height,\n annotations = a,\n font = t,\n margin = margin\n ) |>\n plotly::config(displayModeBar = FALSE)\n if (plotlycb && !return_plotly) print(p)\n }\n\n # out ----\n if (return_plotly) {\n return(p)\n }\n invisible(grad)\n} # /rtemis::colorgrad\n\n\n# 3-letter Color Name Abbreviations\n# wht white\n# blk black\n# red\n# grn green\n# blu blue\n# yel yellow\n# rng orange\n# prl purple\n\ncolorvec <- function(cols) {\n if (nchar(cols) %% 3 != 0) {\n cli::cli_abort(\n \"All colors must be specified by their 3-letter abbreviations\"\n )\n }\n\n cols <- tolower(cols)\n ncols <- nchar(cols) / 3\n cols <- lapply(seq(ncols), function(i) substr(cols, i * 3 - 2, i * 3))\n\n coldf <- data.frame(\n abbr = c(\"wht\", \"red\", \"grn\", \"blu\", \"blk\", \"yel\", \"rng\", \"prl\"),\n name = c(\n \"white\",\n \"red\",\n \"green\",\n \"blue\",\n \"black\",\n \"yellow\",\n \"orange\",\n \"purple\"\n ),\n stringsAsFactors = FALSE\n )\n\n cols <- sapply(1:ncols, function(i) coldf[coldf[[\"abbr\"]] == cols[i], 2])\n\n lo <- lomid <- mid <- midhi <- hi <- NULL\n collist <- list(\n twocols = c(\"lo\", \"hi\"),\n threecols = c(\"lo\", \"mid\", \"hi\"),\n fourcols = c(\"lo\", \"mid\", \"midhi\", \"hi\"),\n fivecols = c(\"lo\", \"lomid\", \"mid\", \"midhi\", \"hi\")\n )\n\n for (i in seq(ncols)) {\n assign(collist[[ncols - 1]][i], cols[i])\n }\n list(lo = lo, lomid = lomid, mid = mid, midhi = midhi, hi = hi)\n}\n\nautoalpha <- function(x, gamma = .0008, min = .3) {\n max(min, 1 - x * gamma)\n}\n" }, { "path": "R/utils_data.R", "content": "# utils_data.R\n# ::rtemis::\n# EDG rtemis.org\n\n# %% Public ----------------------------------------------------------------------------------------\n\n#' Describe factor\n#'\n#' Outputs a single character with names and counts of each level of the input factor.\n#'\n#' @param x factor.\n#' @param ... See details.\n#'\n#' @details\n#' Extra arguments:\n#' - `max_n`: Integer: Return counts for up to this many levels.\n#' - `return_ordered`: Logical: If TRUE, return levels ordered by count, otherwise return in level order.\n#' - `verbosity`: Integer: Verbosity level.\n#'\n#' @return Character with level counts.\n#'\n#' @author EDG\n#' @noRd\n#'\n#' @examples\n#' # Small number of levels\n#' describe(iris[[\"Species\"]])\n#'\n#' # Large number of levels: show top n by count\n#' x <- factor(sample(letters, 1000, TRUE))\n#' describe(x)\n#' describe(x, 3)\n#' describe(x, 3, return_ordered = FALSE)\nmethod(describe, class_factor) <- function(\n x,\n max_n = 5,\n return_ordered = TRUE,\n verbosity = 1L\n) {\n x <- factor(x)\n x_levels <- levels(x)\n n_unique <- length(x_levels)\n x_freqs <- as.integer(table(x))\n if (return_ordered) {\n idi <- order(x_freqs, decreasing = TRUE)\n }\n\n if (n_unique <= max_n) {\n if (return_ordered) {\n out <- paste(x_levels[idi], x_freqs[idi], sep = \": \", collapse = \"; \")\n } else {\n out <- paste(x_levels, x_freqs, sep = \": \", collapse = \"; \")\n }\n } else {\n idi <- order(x_freqs, decreasing = TRUE)\n if (return_ordered) {\n idi <- idi[seq_len(max_n)]\n out <- paste0(\n \"(Top \",\n max_n,\n \" of \",\n n_unique,\n \") \",\n paste(x_levels[idi], x_freqs[idi], sep = \": \", collapse = \"; \")\n )\n } else {\n idx <- seq_len(max_n)\n out <- paste0(\n \"(First \",\n max_n,\n \" of \",\n n_unique,\n \") \",\n paste(x_levels[idx], x_freqs[idx], sep = \": \", collapse = \"; \")\n )\n }\n }\n if (verbosity > 0L) {\n print(out)\n }\n invisible(out)\n} # /rtemis::describe.factor\n\n\n#' Match cases by covariates\n#'\n#' Find one or more cases from a `pool` data.frame that match cases in a target\n#' data.frame. Match exactly and/or by distance (sum of squared distances).\n#'\n#' @param target data.frame you are matching against.\n#' @param pool data.frame you are looking for matches from.\n#' @param n_matches Integer: Number of matches to return.\n#' @param target_id Character: Column name in `target` that holds unique\n#' cases IDs. Default = NULL, in which case integer case numbers will be used.\n#' @param pool_id Character: Same as `target_id` for `pool`.\n#' @param exactmatch_factors Logical: If TRUE, selected cases will have to\n#' exactly match factors available in `target`.\n#' @param exactmatch_cols Character: Names of columns that should be matched\n#' exactly.\n#' @param distmatch_cols Character: Names of columns that should be\n#' distance-matched.\n#' @param norepeats Logical: If TRUE, cases in `pool` can only be chosen\n#' once.\n#' @param ignore_na Logical: If TRUE, ignore NA values during exact matching.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return data.frame\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' set.seed(2021)\n#' cases <- data.frame(\n#' PID = paste0(\"PID\", seq(4)),\n#' Sex = factor(c(1, 1, 0, 0)),\n#' Handedness = factor(c(1, 1, 0, 1)),\n#' Age = c(21, 27, 39, 24),\n#' Var = c(.7, .8, .9, .6),\n#' Varx = rnorm(4)\n#' )\n#' controls <- data.frame(\n#' CID = paste0(\"CID\", seq(50)),\n#' Sex = factor(sample(c(0, 1), 50, TRUE)),\n#' Handedness = factor(sample(c(0, 1), 50, TRUE, c(.1, .9))),\n#' Age = sample(16:42, 50, TRUE),\n#' Var = rnorm(50),\n#' Vary = rnorm(50)\n#' )\n#'\n#' mc <- matchcases(cases, controls, 2, \"PID\", \"CID\")\nmatchcases <- function(\n target,\n pool,\n n_matches = 1,\n target_id = NULL,\n pool_id = NULL,\n exactmatch_factors = TRUE,\n exactmatch_cols = NULL,\n distmatch_cols = NULL,\n norepeats = TRUE,\n ignore_na = FALSE,\n verbosity = 1L\n) {\n ntarget <- nrow(target)\n npool <- nrow(pool)\n\n # Get IDs\n if (is.null(target_id)) {\n targetID <- seq(ntarget)\n } else {\n targetID <- target[, target_id]\n target[, target_id] <- NULL\n }\n if (is.null(pool_id)) {\n poolID <- seq(npool)\n } else {\n poolID <- pool[, pool_id]\n pool[, pool_id] <- NULL\n }\n\n # exact- & dist-matched column names\n if (is.null(exactmatch_cols) && exactmatch_factors) {\n exactmatch_cols <- colnames(target)[sapply(target, is.factor)]\n }\n # Keep exactmatch_cols present in pool\n exactmatch_cols <- exactmatch_cols[exactmatch_cols %in% colnames(pool)]\n\n if (is.null(distmatch_cols)) {\n distmatch_cols <- colnames(target)[!colnames(target) %in% exactmatch_cols]\n }\n # Keep distmatch_cols present in pool\n distmatch_cols <- distmatch_cols[distmatch_cols %in% colnames(pool)]\n\n # Remove unused columns, if any\n .remove <- colnames(target)[\n !colnames(target) %in% c(exactmatch_cols, distmatch_cols)\n ]\n target[, .remove] <- NULL\n .remove <- colnames(pool)[\n !colnames(pool) %in% c(exactmatch_cols, distmatch_cols)\n ]\n pool[, .remove] <- NULL\n\n # Convert all non-exact-matching to numeric\n tonumeric <- distmatch_cols[!sapply(target[, distmatch_cols], is.numeric)]\n if (length(tonumeric) > 0) {\n target[, tonumeric] <- lapply(target[, tonumeric, drop = FALSE], as.numeric)\n }\n tonumeric <- distmatch_cols[!sapply(pool[, distmatch_cols], is.numeric)]\n if (length(tonumeric) > 0) {\n pool[, tonumeric] <- lapply(pool[, tonumeric, drop = FALSE], as.numeric)\n }\n\n # Normalize all\n vcat <- rbind(target, pool)\n vcat[, distmatch_cols] <- lapply(vcat[, distmatch_cols, drop = FALSE], scale)\n target_s <- cbind(targetID = targetID, vcat[seq(ntarget), ])\n pool_s <- cbind(poolID = poolID, vcat[-seq(ntarget), ])\n rm(vcat)\n\n # For each target, select matches on categoricals,\n # then order pool by distance.\n mc <- data.frame(targetID = targetID, match = matrix(NA, ntarget, n_matches))\n for (i in seq(ntarget)) {\n if (verbosity > 0L) {\n msg(\"Working on case\", i, \"of\", ntarget)\n }\n if (is.null(exactmatch_cols)) {\n subpool <- pool_s\n } else {\n ind <- sapply(seq_len(nrow(pool_s)), function(j) {\n all(\n target_s[i, exactmatch_cols] == pool_s[j, exactmatch_cols],\n na.rm = ignore_na\n )\n })\n subpool <- pool_s[ind, , drop = FALSE]\n }\n distord <- order(sapply(\n seq_len(nrow(subpool)),\n function(j) {\n mse(\n unlist(target_s[i, distmatch_cols]),\n unlist(subpool[j, distmatch_cols]),\n na.rm = ignore_na\n )\n }\n ))\n n_matched <- min(n_matches, nrow(subpool))\n mc[i, 2:(n_matched + 1)] <- subpool[, 1][distord[seq(n_matched)]]\n if (norepeats) {\n pool_s <- pool_s[!pool_s[, 1] %in% mc[i, 2:(n_matches + 1)], ]\n }\n }\n\n mc\n} # /rtemis::matchcases\n\n\n#' Index columns by attribute name & value\n#'\n#' @param x tabular data.\n#' @param name Character: Name of attribute.\n#' @param value Character: Value of attribute.\n#' @param exact Logical: Passed to `attr` when retrieving attribute value. If `TRUE`, attribute\n#' name must match `name` exactly, otherwise, partial match is allowed.\n#'\n#' @return Integer vector.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- data.table(\n#' id = 1:5,\n#' sbp = rnorm(5, 120, 15),\n#' dbp = rnorm(5, 80, 10),\n#' paO2 = rnorm(5, 90, 10),\n#' paCO2 = rnorm(5, 40, 5)\n#' )\n#' setattr(x[[\"sbp\"]], \"source\", \"outpatient\")\n#' setattr(x[[\"dbp\"]], \"source\", \"outpatient\")\n#' setattr(x[[\"paO2\"]], \"source\", \"icu\")\n#' setattr(x[[\"paCO2\"]], \"source\", \"icu\")\n#' index_col_by_attr(x, \"source\", \"icu\")\nindex_col_by_attr <- function(x, name, value, exact = TRUE) {\n colattr <- lapply(x, \\(i) attr(i, name, exact = exact))\n # Convert to character vector maintaining NULL values (where attribute is not set)\n colattr <- sapply(colattr, function(i) {\n if (is.null(i)) NA_character_ else as.character(i)\n })\n which(colattr == value)\n} # /rtemis.utils::index_col_by_attr\n\n\n#' Tabulate column attributes\n#'\n#' @param x tabular data: Input data set.\n#' @param attr Character: Attribute to get\n#' @param useNA Character: Passed to `table`\n#'\n#' @return table.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- data.table(\n#' id = 1:5,\n#' sbp = rnorm(5, 120, 15),\n#' dbp = rnorm(5, 80, 10),\n#' paO2 = rnorm(5, 90, 10),\n#' paCO2 = rnorm(5, 40, 5)\n#' )\n#' setattr(x[[\"sbp\"]], \"source\", \"outpatient\")\n#' setattr(x[[\"dbp\"]], \"source\", \"outpatient\")\n#' setattr(x[[\"paO2\"]], \"source\", \"icu\")\n#' setattr(x[[\"paCO2\"]], \"source\", \"icu\")\n#' table_column_attr(x, \"source\")\ntable_column_attr <- function(x, attr = \"source\", useNA = \"always\") {\n attrs <- sapply(x, \\(i) {\n if (is.null(attr(i, attr, exact = TRUE))) {\n NA_character_\n } else {\n attr(i, attr, exact = TRUE)\n }\n })\n table(attrs, useNA = useNA)\n} # /rtemis::table_column_attr\n\n\n#' List column names by class\n#'\n#' @param x tabular data.\n#' @param sorted Logical: If TRUE, sort the output\n#' @param item_format Function: Function to format each item\n#' @param maxlength Integer: Maximum number of items to print\n#'\n#' @return `NULL`, invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' names_by_class(iris)\nnames_by_class <- function(\n x,\n sorted = TRUE,\n item_format = highlight,\n maxlength = 24\n) {\n classes <- sapply(x, class)\n vals <- unique(classes)\n out <- if (sorted) {\n sapply(vals, \\(i) sort(names(x)[classes == i]))\n } else {\n sapply(vals, \\(i) names(x)[classes == i])\n }\n cat(repr_ls(out, item_format = item_format, maxlength = maxlength))\n invisible()\n} # /rtemis::names_by_class\n\n\n#' Inspect character and factor vector\n#'\n#' Checks character or factor vector to determine whether it might be best to convert to\n#' numeric.\n#'\n#' @details\n#' All data can be represented as a character string. A numeric variable may be read as\n#' a character variable if there are non-numeric characters in the data.\n#' It is important to be able to automatically detect such variables and convert them,\n#' which would mean introducing NA values.\n#'\n#' @param x Character or factor vector.\n#' @param xname Character: Name of input vector `x`.\n#' @param verbosity Integer: Verbosity level.\n#' @param thresh Numeric: Threshold for determining whether to convert to numeric.\n#' @param na.omit Logical: If TRUE, remove NA values before checking.\n#'\n#' @return Character.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- c(\"3\", \"5\", \"undefined\", \"21\", \"4\", NA)\n#' inspect_type(x)\n#' z <- c(\"mango\", \"banana\", \"tangerine\", NA)\n#' inspect_type(z)\ninspect_type <- function(\n x,\n xname = NULL,\n verbosity = 1L,\n thresh = .5,\n na.omit = TRUE\n) {\n if (is.null(xname)) {\n xname <- deparse(substitute(x))\n }\n if (na.omit) {\n x <- na.omit(x)\n }\n xclass <- class(x)[1]\n xlen <- length(x)\n raw_na <- sum(is.na(x))\n n_non_na <- xlen - raw_na\n # char_na <- sum(is.na(as.character(x)))\n suppressWarnings({\n num_na <- if (xclass == \"character\") {\n sum(is.na(as.numeric(x)))\n } else {\n sum(is.na(as.numeric(as.character(x))))\n }\n })\n if (raw_na == xlen) {\n \"NA\"\n } else if (\n xclass %in% c(\"character\", \"factor\") && (num_na / n_non_na) < thresh\n ) {\n if (verbosity > 0L) {\n msg0(\n \"Possible type error: \",\n highlight(xname),\n \" is a \",\n bold(xclass),\n \", but perhaps should be \",\n bold(\"numeric\"),\n \".\"\n )\n }\n \"numeric\"\n } else {\n xclass\n }\n} # /rtemis::inspect_type\n" }, { "path": "R/utils_data.table.R", "content": "# utils_data.table.R\n# ::rtemis::\n# 2022- EDG rtemis.org\n\n#' Number of unique values per feature\n#'\n#' @param x data.table: Input data.table.\n#' @param excludeNA Logical: If TRUE, exclude NA values.\n#' @param limit Integer: Print up to this many features. Set to -1L to print all.\n#' @param verbosity Integer: If > 0, print output to console.\n#'\n#' @return Named integer vector of length `NCOL(x)` with number of unique values per column/feature, invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' ir <- as.data.table(iris)\n#' dt_nunique_perfeat(ir)\ndt_nunique_perfeat <- function(\n x,\n excludeNA = FALSE,\n limit = 20L,\n verbosity = 1L\n) {\n stopifnot(inherits(x, \"data.table\"))\n nupf <- sapply(x, \\(i) data.table::uniqueN(i, na.rm = excludeNA))\n if (verbosity > 0L) {\n printls(nupf, item_format = thin, limit = limit, print_class = FALSE)\n }\n invisible(nupf)\n} # /rtemis::dt_nunique_perfeat\n\n\n#' Long to wide key-value reshaping\n#'\n#' Reshape a long format `data.table` using key-value pairs with\n#' `data.table::dcast`\n#'\n#' @param x `data.table` object.\n#' @param id_name Character: Name of column in `x` that defines the IDs\n#' identifying individual rows.\n#' @param key_name Character: Name of column in `x` that holds the key.\n#' @param positive Numeric or Character: Used to fill id ~ key combination\n#' present in the long format input `x`.\n#' @param negative Numeric or Character: Used to fill id ~ key combination\n#' NOT present in the long format input `x`.\n#' @param xname Character: Name of `x` to be used in messages.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return `data.table` in wide format.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- data.table(\n#' ID = rep(1:3, each = 2),\n#' Dx = c(\"A\", \"C\", \"B\", \"C\", \"D\", \"A\")\n#' )\n#' dt_keybin_reshape(x, id_name = \"ID\", key_name = \"Dx\")\ndt_keybin_reshape <- function(\n x,\n id_name,\n key_name,\n positive = 1,\n negative = 0,\n xname = NULL,\n verbosity = 1L\n) {\n if (is.null(xname)) {\n xname <- deparse(substitute(x))\n }\n stopifnot(inherits(x, \"data.table\"))\n x <- copy(x)\n\n # Assign positive value to all in long form\n value_name <- \"Bin__\"\n x[, (value_name) := positive]\n\n .formula <- as.formula(paste(\n paste(id_name, collapse = \" + \"),\n \"~\",\n key_name\n ))\n if (verbosity > 0L) {\n msg(\"Reshaping\", highlight(xname), \"to wide format...\")\n catsize(x, \"Input size\")\n }\n # Reshape to wide, filling all absent with negative value\n x <- dcast(\n x,\n .formula,\n fun.aggregate = length,\n value.var = value_name,\n drop = FALSE,\n fill = negative\n )\n\n if (verbosity > 0L) {\n catsize(x, \"Output size\")\n }\n x\n} # /rtemis::dt_keybin_reshape\n\n\n#' Merge data.tables\n#'\n#' @param left data.table\n#' @param right data.table\n#' @param on Character: Name of column to join on.\n#' @param left_on Character: Name of column on left table.\n#' @param right_on Character: Name of column on right table.\n#' @param how Character: Type of join: \"inner\", \"left\", \"right\", \"outer\".\n#' @param left_name Character: Name of left table.\n#' @param right_name Character: Name of right table.\n#' @param left_suffix Character: If provided, add this suffix to all left column names,\n#' excluding on/left_on.\n#' @param right_suffix Character: If provided, add this suffix to all right column names,\n#' excluding on/right_on.\n#' @param verbosity Integer: Verbosity level.\n#' @param ... Additional arguments to be passed to `data.table::merge`.\n#'\n#' @return Merged data.table.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' xleft <- data.table(ID = 1:5, Alpha = letters[1:5])\n#' xright <- data.table(ID = c(3, 4, 5, 6), Beta = LETTERS[3:6])\n#' xlr_inner <- dt_merge(xleft, xright, on = \"ID\", how = \"inner\")\ndt_merge <- function(\n left,\n right,\n on = NULL,\n left_on = NULL,\n right_on = NULL,\n how = \"left\",\n left_name = NULL,\n right_name = NULL,\n left_suffix = NULL,\n right_suffix = NULL,\n verbosity = 1L,\n ...\n) {\n if (is.null(left_name)) {\n left_name <- deparse(substitute(left))\n }\n if (is.null(right_name)) {\n right_name <- deparse(substitute(right))\n }\n if (is.null(left_on)) {\n left_on <- on\n }\n if (is.null(right_on)) {\n right_on <- on\n }\n if (verbosity > 0L) {\n icon <- switch(\n how,\n inner = \"\\u2A1D\",\n left = \"\\u27D5\",\n right = \"\\u27D6\",\n \"\\u27D7\"\n )\n if (left_on == right_on) {\n msg0(\n bold(highlight(icon)),\n \" Merging \",\n highlight(left_name),\n \" & \",\n highlight(right_name),\n \" on \",\n highlight(left_on),\n \"...\"\n )\n } else {\n msg0(\n bold(highlight(icon)),\n \" Merging \",\n highlight(left_name),\n \" & \",\n highlight(right_name),\n \" on \",\n highlight(left_on),\n \" & \",\n highlight(right_on),\n \"...\"\n )\n }\n\n catsize(left, left_name)\n catsize(right, right_name)\n }\n\n if (how == \"left\") {\n all.x <- TRUE\n all.y <- FALSE\n } else if (how == \"right\") {\n all.x <- FALSE\n all.y <- TRUE\n } else if (how == \"inner\") {\n all.x <- FALSE\n all.y <- FALSE\n } else {\n all.x <- all.y <- TRUE\n }\n if (!is.null(left_suffix)) {\n left_names <- setdiff(names(left), left_on)\n setnames(left, left_names, paste0(left_names, left_suffix))\n }\n if (!is.null(right_suffix)) {\n right_names <- setdiff(names(right), right_on)\n setnames(right, right_names, paste0(right_names, right_suffix))\n }\n dat <- merge(\n left,\n right,\n by.x = left_on,\n by.y = right_on,\n all.x = all.x,\n all.y = all.y,\n ...\n )\n if (verbosity > 0L) {\n catsize(dat, \"Merged\")\n }\n dat\n} # /rtemis::dt_merge\n\n\n#' Clean factor levels of data.table ***in-place***\n#'\n#' Finds all factors in a data.table and cleans factor levels to include\n#' only underscore symbols\n#'\n#' @param x data.table: Input data.table. Will be modified ***in-place***.\n#' @param prefix_digits Character: If not NA, add this prefix to all factor levels that\n#' are numbers\n#'\n#' @return Nothing, modifies `x` ***in-place***.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- as.data.table(iris)\n#' levels(x[[\"Species\"]]) <- c(\"setosa:iris\", \"versicolor$iris\", \"virginica iris\")\n#' levels(x[[\"Species\"]])\n#' dt_set_cleanfactorlevels(x)\n#' levels(x[[\"Species\"]])\ndt_set_cleanfactorlevels <- function(x, prefix_digits = NA) {\n stopifnot(inherits(x, \"data.table\"))\n idi <- names(x)[sapply(x, is.factor)]\n for (i in idi) {\n x[,\n (i) := factor(\n x[[i]],\n labels = clean_names(levels(x[[i]]), prefix_digits = prefix_digits)\n )\n ]\n }\n} # /rtemis::dt_set_cleanfactorlevels\n\n\n#' Get N and percent match of values between two columns of two data.tables\n#'\n#' @param x data.table: First input data.table.\n#' @param y data.table: Second input data.table.\n#' @param on Integer or character: column to read in `x` and `y`, if it is the\n#' same\n#' @param left_on Integer or character: column to read in `x`\n#' @param right_on Integer or character: column to read in `y`\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return list.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- data.table(ID = 1:5, Alpha = letters[1:5])\n#' y <- data.table(ID = c(3, 4, 5, 6), Beta = LETTERS[3:6])\n#' dt_pctmatch(x, y, on = \"ID\")\ndt_pctmatch <- function(\n x,\n y,\n on = NULL,\n left_on = NULL,\n right_on = NULL,\n verbosity = 1L\n) {\n if (is.null(left_on)) {\n left_on <- on\n }\n if (is.null(right_on)) {\n right_on <- on\n }\n xv <- unique(x[[left_on]])\n n <- length(xv)\n yv <- unique(y[[right_on]])\n nmatch <- sum(xv %in% yv)\n matchpct <- nmatch / n * 100\n if (verbosity > 0L) {\n by_final <- paste(unique(c(left_on, right_on)), collapse = \", \")\n msg0(\n \"Matched \",\n highlight(nmatch),\n \"/\",\n highlight(n),\n \" on \",\n bold(by_final),\n \" (\",\n highlight(ddSci(matchpct)),\n \"%)\"\n )\n }\n invisible(list(nmatch = nmatch, matchpct = matchpct))\n} # /rtemis::dt_pctmatch\n\n\n#' Get percent of missing values from every column\n#'\n#' @param x data.frame or data.table\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return list\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- data.table(a = c(1, 2, NA, 4), b = c(NA, NA, 3, 4), c = c(\"A\", \"B\", \"C\", NA))\n#' dt_pctmissing(x)\ndt_pctmissing <- function(x, verbosity = 1L) {\n nmissing <- sapply(x, \\(i) sum(is.na(i)))\n pctmissing <- nmissing / NROW(x)\n if (verbosity > 0L) {\n cat(\"Percent missing per column:\\n\")\n printls(pctmissing, print_class = FALSE)\n }\n invisible(list(nmissing = nmissing, pctmissing = pctmissing))\n} # /rtemis::dt_pctmissing\n\n\n#' Convert data.table logical columns to factors\n#'\n#' Convert data.table logical columns to factors with custom labels ***in-place***\n#'\n#' @param x data.table: Input data.table. Will be modified ***in-place***.\n#' @param cols Optional Integer or character: columns to convert. If NULL, operates on all\n#' logical columns.\n#' @param labels Character: labels for factor levels.\n#' @param maintain_attributes Logical: If TRUE, maintain column attributes.\n#' @param fillNA Optional Character: If not NULL, fill NA values with this constant.\n#'\n#' @return data.table, invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- data.table(a = 1:5, b = c(TRUE, FALSE, FALSE, FALSE, TRUE))\n#' x\n#' dt_set_logical2factor(x)\n#' x\n#' z <- data.table(\n#' alpha = 1:5,\n#' beta = c(TRUE, FALSE, TRUE, NA, TRUE),\n#' gamma = c(FALSE, FALSE, TRUE, FALSE, NA)\n#' )\n#' # You can usee fillNA to fill NA values with a constant\n#' dt_set_logical2factor(z, cols = \"beta\", labels = c(\"No\", \"Yes\"), fillNA = \"No\")\n#' z\n#' w <- data.table(mango = 1:5, banana = c(FALSE, FALSE, TRUE, TRUE, FALSE))\n#' w\n#' dt_set_logical2factor(w, cols = 2, labels = c(\"Ugh\", \"Huh\"))\n#' w\n#' # Column attributes are maintained by default:\n#' z <- data.table(\n#' alpha = 1:5,\n#' beta = c(TRUE, FALSE, TRUE, NA, TRUE),\n#' gamma = c(FALSE, FALSE, TRUE, FALSE, NA)\n#' )\n#' for (i in seq_along(z)) setattr(z[[i]], \"source\", \"Guava\")\n#' str(z)\n#' dt_set_logical2factor(z, cols = \"beta\", labels = c(\"No\", \"Yes\"))\n#' str(z)\ndt_set_logical2factor <- function(\n x,\n cols = NULL,\n labels = c(\"False\", \"True\"),\n maintain_attributes = TRUE,\n fillNA = NULL\n) {\n if (is.null(cols)) {\n cols <- names(x)[sapply(x, is.logical)]\n }\n for (i in cols) {\n if (maintain_attributes) {\n .attr <- attributes(x[[i]])\n }\n x[, (i) := factor(x[[i]], levels = c(FALSE, TRUE), labels = labels)]\n if (!is.null(fillNA)) {\n x[is.na(x[[i]]), (i) := fillNA]\n }\n if (maintain_attributes) {\n for (j in seq_along(.attr)) {\n setattr(x[[i]], names(.attr)[j], .attr[[j]])\n }\n }\n }\n invisible(x)\n}\n\n\n#' Inspect column types\n#'\n#' Will attempt to identify columns that should be numeric but are either character or\n#' factor by running [inspect_type] on each column.\n#'\n#' @param x data.table: Input data.table.\n#' @param cols Character vector: columns to inspect.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Character vector.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- data.table(\n#' id = 8001:8006,\n#' a = c(\"3\", \"5\", \"undefined\", \"21\", \"4\", NA),\n#' b = c(\"mango\", \"banana\", \"tangerine\", NA, \"apple\", \"kiwi\"),\n#' c = c(1, 2, 3, 4, 5, 6)\n#' )\n#' dt_inspect_types(x)\ndt_inspect_types <- function(x, cols = NULL, verbosity = 1L) {\n if (is.null(cols)) {\n char_factor_idi <- which(sapply(x, is.character) | sapply(x, is.factor))\n cols <- names(x[, .SD, .SDcols = char_factor_idi])\n }\n current_types <- sapply(x[, .SD, .SDcols = cols], class)\n suggested_types <- sapply(\n cols,\n \\(cn) inspect_type(x[[cn]], xname = cn, verbosity = verbosity)\n )\n to_convert <- suggested_types != current_types\n names(to_convert)[to_convert]\n}\n\n\n#' Set column types automatically\n#'\n#' This function inspects a data.table and attempts to identify columns that should be\n#' numeric but have been read in as character, and fixes their type ***in-place***.\n#' This can happen when one or more fields contain non-numeric characters, for example.\n#'\n#' @param x data.table: Input data.table. Will be modified ***in-place***, if needed.\n#' @param cols Character vector: columns to work on. If not defined, will work on all\n#' columns\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return data.table, invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- data.table(\n#' id = 8001:8006,\n#' a = c(\"3\", \"5\", \"undefined\", \"21\", \"4\", NA),\n#' b = c(\"mango\", \"banana\", \"tangerine\", NA, \"apple\", \"kiwi\"),\n#' c = c(1, 2, 3, 4, 5, 6)\n#' )\n#' str(x)\n#' # ***in-place*** operation means no assignment is needed\n#' dt_set_autotypes(x)\n#' str(x)\n#'\n#' # Try excluding column 'a' from autotyping\n#' x <- data.table(\n#' id = 8001:8006,\n#' a = c(\"3\", \"5\", \"undefined\", \"21\", \"4\", NA),\n#' b = c(\"mango\", \"banana\", \"tangerine\", NA, \"apple\", \"kiwi\"),\n#' c = c(1, 2, 3, 4, 5, 6)\n#' )\n#' str(x)\n#' # exclude column 'a' from autotyping\n#' dt_set_autotypes(x, cols = setdiff(names(x), \"a\"))\n#' str(x)\ndt_set_autotypes <- function(x, cols = NULL, verbosity = 1L) {\n if (is.null(cols)) {\n cols <- names(x)\n }\n character_idx <- sapply(x[, .SD, .SDcols = cols], is.character)\n char_cols <- names(character_idx)[character_idx]\n for (i in char_cols) {\n if (inspect_type(x[[i]], i, verbosity = 0L) == \"numeric\") {\n if (verbosity > 0L) {\n msg(\"Converting\", highlight(i), \"to\", bold(\"numeric\"))\n }\n # This will generate warnings if there are non-numeric values\n suppressWarnings({\n x[, (i) := as.numeric(x[[i]])]\n })\n }\n }\n invisible(x)\n} # /rtemis::dt_set_autotypes\n\n\n#' List column names by attribute\n#'\n#' @param x data.table: Input data.table.\n#' @param attribute Character: name of attribute.\n#' @param exact Logical: If TRUE, use exact matching.\n#' @param sorted Logical: If TRUE, sort the output.\n#'\n#' @return Character vector.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- data.table(\n#' id = 1:5,\n#' sbp = rnorm(5, 120, 15),\n#' dbp = rnorm(5, 80, 10),\n#' paO2 = rnorm(5, 90, 10),\n#' paCO2 = rnorm(5, 40, 5)\n#' )\n#' setattr(x[[\"id\"]], \"source\", \"demographics\")\n#' setattr(x[[\"sbp\"]], \"source\", \"outpatient\")\n#' setattr(x[[\"dbp\"]], \"source\", \"outpatient\")\n#' setattr(x[[\"paO2\"]], \"source\", \"icu\")\n#' setattr(x[[\"paCO2\"]], \"source\", \"icu\")\n#'\n#' dt_names_by_attr(x, \"source\", \"outpatient\")\ndt_names_by_attr <- function(x, attribute, exact = TRUE, sorted = TRUE) {\n attrs <- unlist(lapply(x, \\(i) attr(i, attribute)))\n attrs <- sapply(x, \\(i) {\n .attr <- attr(i, attribute, exact = exact)\n if (is.null(.attr)) \"NA\" else .attr\n })\n vals <- unique(attrs)\n if (sorted) {\n sapply(vals, \\(i) sort(names(x)[attrs == i]))\n } else {\n sapply(vals, \\(i) names(x)[attrs == i])\n }\n} # /rtemis::dt_names_by_attr\n\n\n#' Clean column names and factor levels ***in-place***\n#'\n#' @param x data.table: Input data.table. Will be modified ***in-place***, if needed.\n#' @param prefix_digits Character: prefix to add to names beginning with a\n#' digit. Set to NA to skip\n#'\n#' @return Nothing, modifies `x` ***in-place***.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' x <- as.data.table(iris)\n#' levels(x[[\"Species\"]]) <- c(\"setosa:iris\", \"versicolor$iris\", \"virginica iris\")\n#' names(x)\n#' levels(x[[\"Species\"]])\n#' # ***in-place*** operation means no assignment is needed\n#' dt_set_clean_all(x)\n#' names(x)\n#' levels(x[[\"Species\"]])\ndt_set_clean_all <- function(x, prefix_digits = NA) {\n if (!is.data.table(x)) {\n cli::cli_abort(\"{.arg x} must be a data.table\")\n }\n data.table::setnames(x, names(x), clean_colnames(x))\n idi <- names(x)[sapply(x, is.factor)]\n for (i in idi) {\n x[,\n (i) := factor(\n x[[i]],\n labels = clean_names(levels(x[[i]]), prefix_digits = prefix_digits)\n )\n ]\n }\n} # /rtemis::dt_set_clean_all\n\n\n#' Describe data.table\n#'\n#' @param x data.table: Input data.table.\n#' @param verbosity Integer: If > 0, print output to console.\n#'\n#' @return List with three data.tables: Numeric, Categorical, and Date.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' library(data.table)\n#' origin <- as.POSIXct(\"2022-01-01 00:00:00\", tz = \"America/Los_Angeles\")\n#' x <- data.table(\n#' ID = paste0(\"ID\", 1:10),\n#' V1 = rnorm(10),\n#' V2 = rnorm(10, 20, 3),\n#' V1_datetime = as.POSIXct(\n#' seq(\n#' 1, 1e7,\n#' length.out = 10\n#' ),\n#' origin = origin\n#' ),\n#' V2_datetime = as.POSIXct(\n#' seq(\n#' 1, 1e7,\n#' length.out = 10\n#' ),\n#' origin = origin\n#' ),\n#' C1 = sample(c(\"alpha\", \"beta\", \"gamma\"), 10, TRUE),\n#' F1 = factor(sample(c(\"delta\", \"epsilon\", \"zeta\"), 10, TRUE))\n#' )\ndt_describe <- function(x, verbosity = 1L) {\n if (!is.data.table(x)) {\n cli::cli_abort(\"{.arg x} must be a data.table\")\n }\n nrows <- NROW(x)\n\n # appease R CMD check: do not use ..var in DT frame, use with = FALSE instead\n\n # Numeric\n index_nm <- which(sapply(x, is.numeric))\n\n nm_summary <- if (length(index_nm) > 0) {\n data.frame(\n Variable = x[, index_nm, with = FALSE] |> names(),\n Min = sapply(x[, index_nm, with = FALSE], min, na.rm = TRUE),\n Max = sapply(x[, index_nm, with = FALSE], max, na.rm = TRUE),\n Median = sapply(x[, index_nm, with = FALSE], median, na.rm = TRUE),\n Mean = sapply(x[, index_nm, with = FALSE], mean, na.rm = TRUE),\n SD = sapply(x[, index_nm, with = FALSE], sd, na.rm = TRUE),\n Pct_missing = sapply(\n x[, index_nm, with = FALSE],\n \\(col) sum(is.na(col)) / nrows\n )\n )\n } else {\n data.frame(\n Variable = character(),\n Min = numeric(),\n Max = numeric(),\n Median = numeric(),\n Mean = numeric(),\n SD = numeric(),\n Pct_missing = numeric()\n )\n }\n\n # Characters & factors\n index_cf <- c(which(sapply(x, is.character)), which(sapply(x, is.factor)))\n\n cf_summary <- if (length(index_cf) > 0) {\n data.frame(\n Variable = x[, index_cf, with = FALSE] |> names(),\n N_unique = sapply(\n x[, index_cf, with = FALSE],\n \\(col) length(unique(col))\n ),\n Mode = sapply(x[, index_cf, with = FALSE], get_mode),\n Counts = sapply(x[, index_cf, with = FALSE], describe),\n Pct_missing = sapply(\n x[, index_cf, with = FALSE],\n \\(col) sum(is.na(col)) / nrows\n )\n )\n } else {\n data.frame(\n Variable = numeric(),\n N_unique = integer(),\n Mode = character(),\n Counts = character(),\n Pct_missing = numeric()\n )\n }\n\n # Dates\n index_dt <- which(sapply(\n x,\n \\(col) any(class(col) %in% c(\"Date\", \"IDate\", \"POSIXct\", \"POSIXt\"))\n ))\n\n dt_summary <- if (length(index_dt) > 0) {\n data.frame(\n Variable = x[, index_dt, with = FALSE] |> names(),\n Min = do.call(c, lapply(x[, index_dt, with = FALSE], min, na.rm = TRUE)),\n Max = do.call(c, lapply(x[, index_dt, with = FALSE], max, na.rm = TRUE)),\n Median = do.call(\n c,\n lapply(x[, index_dt, with = FALSE], median, na.rm = TRUE)\n ),\n Mean = do.call(\n c,\n lapply(x[, index_dt, with = FALSE], mean, na.rm = TRUE)\n ),\n Pct_missing = sapply(\n x[, index_dt, with = FALSE],\n \\(col) sum(is.na(col)) / nrows\n )\n )\n } else {\n data.frame(\n Variable = character(),\n Min = numeric(),\n Max = numeric(),\n Median = numeric(),\n Mean = numeric(),\n Pct_missing = numeric()\n )\n }\n\n out <- list(\n Numeric = nm_summary,\n Categorical = cf_summary,\n Date = dt_summary\n )\n if (verbosity > 0L) {\n printls(out, print_df = TRUE)\n }\n invisible(out)\n} # /rtemis::dt_describe\n" }, { "path": "R/utils_date.R", "content": "# utils_date.R\n# ::rtemis::\n# 2024- EDG rtemis.org\n\n#' Extract features from dates\n#'\n#' @details weekday and month will be extracted as factors, year as integer\n#'\n#' @param dates Date vector.\n#' @param features Character vector: features to extract.\n#' @param drop_dates Logical: If TRUE, drop original date column.\n#'\n#' @return data.table with extracted features\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ndates2features <- function(\n dates,\n features = c(\"weekday\", \"month\", \"year\"),\n drop_dates = TRUE\n) {\n # appease R CMD check\n weekday <- NULL\n # to factors: dow, month\n dt <- data.table(dates = dates)\n if (\"weekday\" %in% features) {\n dt[, weekday := factor(weekdays(dates))]\n }\n if (\"month\" %in% features) {\n dt[, month := factor(months(dates))]\n }\n if (\"year\" %in% features) {\n dt[, year := year(dates)]\n }\n if (drop_dates) {\n dt[, dates := NULL]\n }\n dt\n} # /rtemis::dates2features\n\n\n#' Get holidays from date vector\n#'\n#' @param dates Date vector\n#' @param holidays Character vector: holidays to extract\n#'\n#' @return Factor of length `length(dates)` with levels \"Not Holiday\", \"Holiday\"\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nget_holidays <- function(\n dates,\n holidays = c(\"LaborDay\", \"NewYearsDay\", \"ChristmasDay\")\n) {\n # Get years from dates\n years <- unique(data.table::year(dates))\n # Get all holidays in all years\n .holidays <- do.call(\n \"c\",\n lapply(years, function(year) {\n do.call(\n \"c\",\n lapply(holidays, function(holiday) {\n timeDate::as.Date.timeDate(timeDate::holiday(\n year = year,\n Holiday = holiday\n ))\n })\n )\n })\n )\n # Return intersection of dates and holidays\n holidays_fct <- factor(\n rep(0, length(dates)),\n levels = c(0, 1),\n labels = c(\"Not Holiday\", \"Holiday\")\n )\n holidays_fct[dates %in% .holidays] <- \"Holiday\"\n holidays_fct\n} # /rtemis::get_holidays\n\n\n#' Date to factor time bin\n#'\n#' Convert Date to time bin factor.\n#'\n#' Order of levels will be chronological (important e.g. for plotting)\n#' Additionally, can output ordered factor with `ordered = TRUE`\n#'\n#' @param x Date vector\n#' @param time_bin Character: \"year\", \"quarter\", \"month\", or \"day\"\n#' @param make_bins Character: \"range\" or \"preseent\". If \"range\" the factor levels will include all\n#' time periods define by `time_bin` within `bin_range`. This means factor levels can be\n#' empty. Otherwise, if \"present\", factor levels only include time periods present in data.\n#' @param bin_range Date, vector, length 2: Range of dates to make levels for. Defaults to range of\n#' input dates `x`.\n#' @param ordered Logical: If TRUE, factor output is ordered.\n#'\n#' @return factor of time periods\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' library(data.table)\n#' startDate <- as.Date(\"2018-01-01\")\n#' endDate <- as.Date(\"2020-12-31\")\n#' time <- sample(seq(startDate, endDate, length.out = 100))\n#' date2factor(time)\n#' date2factor(time, \"quarter\")\n#' date2factor(time, \"month\")\n#' date2factor(time, \"day\")\n#' # range vs. present\n#' x <- sample(seq(as.Date(\"2018-01-01\"), as.Date(\"2021-01-01\"), by = 1), 10)\n#' date2factor(x, time_bin = \"quarter\", make_bins = \"present\")\n#' date2factor(x, time_bin = \"quarter\", make_bins = \"range\")\ndate2factor <- function(\n x,\n time_bin = c(\"year\", \"quarter\", \"month\", \"day\"),\n make_bins = c(\"range\", \"present\"),\n bin_range = range(x, na.rm = TRUE),\n ordered = FALSE\n) {\n time_bin <- match.arg(time_bin)\n make_bins <- match.arg(make_bins)\n\n if (time_bin == \"year\") {\n if (make_bins == \"present\") {\n factor(data.table::year(x), ordered = ordered)\n } else {\n out <- as.character(data.table::year(x))\n factor(\n out,\n levels = as.character(seq(\n data.table::year(bin_range[1]),\n data.table::year(bin_range[2])\n )),\n ordered = ordered\n )\n }\n } else if (time_bin == \"quarter\") {\n if (make_bins == \"present\") {\n factor(\n paste0(data.table::year(x), \" Q\", data.table::quarter(x)),\n ordered = ordered\n )\n } else {\n factor(\n paste0(data.table::year(x), \" Q\", data.table::quarter(x)),\n levels = levels(date2yq(seq(\n bin_range[1],\n bin_range[2],\n by = \"quarter\"\n ))),\n ordered = ordered\n )\n }\n } else if (time_bin == \"month\") {\n ym <- paste(substr(months(x), 1, 3), data.table::year(x))\n if (make_bins == \"present\") {\n .levels <- unique(ym[order(x)])\n factor(ym, levels = .levels, ordered = ordered)\n } else {\n factor(\n ym,\n levels = levels(date2ym(seq(bin_range[1], bin_range[2], by = \"month\"))),\n ordered = ordered\n )\n }\n } else if (time_bin == \"day\") {\n if (make_bins == \"present\") {\n factor(x, levels = as.character(unique(x[order(x)])), ordered = ordered)\n } else {\n factor(\n x,\n levels = as.character(seq(bin_range[1], bin_range[2], by = 1)),\n ordered = ordered\n )\n }\n }\n} # /rtemis::date2factor\n\n\n#' Date to year-quarter factor\n#'\n#' @param x Date vector\n#' @param ordered Logical: If TRUE, return ordered factor.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ndate2yq <- function(x, ordered = FALSE) {\n factor(\n paste0(data.table::year(x), \" Q\", data.table::quarter(x)),\n ordered = ordered\n )\n} # /rtemis::date2yq\n\n\n#' Date to year-month factor\n#'\n#' @param x Date vector\n#' @param ordered Logical: If TRUE, return ordered factor.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ndate2ym <- function(x, ordered = FALSE) {\n ym <- paste(substr(months(x), 1, 3), data.table::year(x))\n .levels <- unique(ym[order(x)])\n factor(ym, levels = .levels, ordered = ordered)\n} # /rtemis::date2ym\n" }, { "path": "R/utils_df.R", "content": "# dataops\n# ::rtemis::\n# 2021 EDG rtemis.org\n\n#' Get names by string matching or class\n#'\n#' @details\n#' For `getnames()` only:\n#' `pattern`, `starts_with`, and `ends_with` are applied sequentially.\n#' If more than one is provided, the result will be the intersection of all matches.\n#'\n#'\n#' @param x object with `names()` method.\n#' @param pattern Character: pattern to match anywhere in names of x.\n#' @param starts_with Character: pattern to match in the beginning of names of x.\n#' @param ends_with Character: pattern to match at the end of names of x.\n#' @param ignore_case Logical: If TRUE, well, ignore case.\n#'\n#' @return Character vector of matched names.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' getnames(iris, starts_with = \"Sepal\")\n#' getnames(iris, ends_with = \"Width\")\n#' getfactornames(iris)\n#' getnumericnames(iris)\ngetnames <- function(\n x,\n pattern = NULL,\n starts_with = NULL,\n ends_with = NULL,\n ignore_case = TRUE\n) {\n .names <- if (is.character(x)) {\n x\n } else {\n names(x)\n }\n # Apply filters sequentially\n if (!is.null(pattern)) {\n .names <- .names[grep(pattern, .names, ignore.case = ignore_case)]\n }\n if (!is.null(starts_with)) {\n .names <- .names[\n grep(paste0(\"^\", starts_with), .names, ignore.case = ignore_case)\n ]\n }\n if (!is.null(ends_with)) {\n .names <- .names[\n grep(paste0(ends_with, \"$\"), .names, ignore.case = ignore_case)\n ]\n }\n .names\n} # /rtemis::getnames\n\n\n#' Get names by string matching multiple patterns\n#'\n#' @details\n#' `pattern`, `starts_with`, and `ends_with` are applied and the union of all matches is returned.\n#' `pattern` can be a character vector of multiple patterns to match.\n#'\n#' @param x Character vector or object with `names()` method.\n#' @param pattern Character vector: pattern(s) to match anywhere in names of x.\n#' @param starts_with Character: pattern to match in the beginning of names of x.\n#' @param ends_with Character: pattern to match at the end of names of x.\n#' @param ignore_case Logical: If TRUE, well, ignore case.\n#' @param return_index Logical: If TRUE, return integer index of matches instead of names.\n#'\n#' @return Character vector of matched names or integer index.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' mgetnames(iris, pattern = c(\"Sepal\", \"Petal\"))\n#' mgetnames(iris, starts_with = \"Sepal\")\n#' mgetnames(iris, ends_with = \"Width\")\nmgetnames <- function(\n x,\n pattern = NULL,\n starts_with = NULL,\n ends_with = NULL,\n ignore_case = TRUE,\n return_index = FALSE\n) {\n .names <- if (is.character(x)) x else names(x)\n idi <- numeric()\n if (!is.null(pattern)) {\n idi <- c(\n idi,\n unlist(lapply(\n pattern,\n function(p) grep(p, .names, ignore.case = ignore_case)\n ))\n )\n }\n if (!is.null(starts_with)) {\n idi <- c(idi, which(startsWith(.names, starts_with)))\n }\n if (!is.null(ends_with)) {\n idi <- c(idi, which(endsWith(.names, ends_with)))\n }\n idi <- unique(idi)\n if (return_index) {\n idi\n } else {\n .names[idi]\n }\n}\n\n# Get factor/numeric/logical/character names from data.frame/data.table ----\n\n# @param x data.frame or data.table (or data.frame-compatible object)\n# @return Character vector of column names of x with the specified class.\n#'\n#' @rdname getnames\n#' @export\ngetfactornames <- function(x) names(x)[sapply(x, is.factor)]\n\n#' @rdname getnames\n#' @export\ngetnumericnames <- function(x) names(x)[sapply(x, is.numeric)]\n\n#' @rdname getnames\n#' @export\ngetlogicalnames <- function(x) names(x)[sapply(x, is.logical)]\n\n#' @rdname getnames\n#' @export\ngetcharacternames <- function(x) names(x)[sapply(x, is.character)]\n\n#' @rdname getnames\n#' @export\ngetdatenames <- function(x) {\n date_id <- sapply(\n x,\n \\(v) class(v)[1] %in% c(\"Date\", \"IDate\", \"POSIXct\", \"POSIXlt\")\n )\n names(x)[date_id]\n}\n\n#' Get data.frame names and types\n#'\n#' @param x data.frame / data.table or similar\n#' @return character vector of column names with attribute \"type\" holding the class of each\n#' column\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' getnamesandtypes(iris)\ngetnamesandtypes <- function(x) {\n xnames <- names(x)\n attr(xnames, \"type\") <- sapply(x, class)\n xnames\n} # /rtemis::namesandtypes\n\n\n#' Unique values per feature\n#'\n#' Get number of unique values per features\n#'\n#' @param x matrix or data frame input\n#' @param excludeNA Logical: If TRUE, exclude NA values from unique count.\n#'\n#' @return Vector, integer of length `NCOL(x)` with number of unique\n#' values per column/feature\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' df_nunique_perfeat(iris)\ndf_nunique_perfeat <- function(x, excludeNA = FALSE) {\n if (excludeNA) {\n apply(x, 2, function(i) length(unique(na.exclude(i))))\n } else {\n apply(x, 2, function(i) length(unique(i)))\n }\n} # /rtemis::df_nunique_perfeat\n\n\n#' Move data frame column\n#'\n#' @param x data.frame.\n#' @param colname Character: Name of column you want to move.\n#' @param to Integer: Which column position to move the vector to.\n#' Default = `ncol(x)` i.e. the last column.\n#'\n#' @return data.frame\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' ir <- df_movecolumn(iris, colname = \"Species\", to = 1L)\ndf_movecolumn <- function(x, colname, to = ncol(x)) {\n if (!is.data.frame(x)) {\n cli::cli_abort(\"Input {.arg x} must be a data frame.\")\n }\n\n check_character(colname, allow_null = FALSE)\n\n to <- clean_int(to)\n\n if (NCOL(x) < 2) {\n cli::cli_abort(\"Input data.frame {.arg x} must have at least 2 columns.\")\n }\n\n if (!(colname %in% names(x))) {\n cli::cli_abort(\"Column {.val {colname}} not found in input data frame.\")\n }\n\n ncols <- ncol(x)\n if (to < 1L || to > ncols) {\n cli::cli_abort(\"{.arg to} must be between 1 and {.val {ncols}}.\")\n }\n\n xnames <- setdiff(names(x), colname)\n x[, append(xnames, colname, after = to - 1L)]\n} # /rtemis::df_movecolumn\n\n\n#' Vector to data.frame\n#'\n#' Convert vector to 1-row data.frame, maintaining names if present\n#'\n#' @param x Vector.\n#' @param col_names Character: Name of the vector.\n#'\n#' @return data.frame.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nvec2df <- function(x, col_names = NULL) {\n if (!is.vector(x)) {\n cli::cli_abort(\"Input must be a vector\")\n }\n if (!is.null(col_names)) {\n names(x) <- col_names\n }\n as.data.frame(t(x))\n} # /rtemis::vec2df\n" }, { "path": "R/utils_exec.R", "content": "# utils_exec.Ranger\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n#' Do call with tryCatch and suggestion\n#'\n#' @param fn Function to call.\n#' @param args List of arguments to pass to function.\n#' @param error_pattern_suggestion Named list of the form pattern = \"suggestion\". If the pattern is\n#' found in the error message, the suggestion is appended to the error message.\n#' @param warning_pattern_suggestion Named list of the form pattern = \"suggestion\". If the pattern is\n#'\n#' @return Result of function call.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ndo_call <- function(\n fn,\n args,\n error_pattern_suggestion = NULL,\n warning_pattern_suggestion = NULL\n) {\n call <- parent.frame(n = 1L)\n common_errors <- list(\n \"object '(.*)' not found\" = \"Check that the object exists and is spelled correctly.\",\n \"object of type 'closure' is not subsettable\" = \"Check that the object is a list or data.frame.\"\n )\n common_warnings <- list(\n \"NAs introduced by coercion\" = \"Check that the input is of the correct type.\",\n # \"glm.fit: algorithm did not converge\" =\n # \"Same reasons as for 'glm.fit: fitted probabilities numerically 0 or 1 occurred'.\",\n \"glm.fit: fitted probabilities numerically 0 or 1 occurred\" = paste(\n bold(\"Reasons for this warning include:\"),\n \"1) Perfect Separation of classes.\",\n \"2) Highly Imbalanced data.\",\n \"3) Extreme values in predictors.\",\n \"4) Too many predictors for the number of observations.\",\n \"5) Multicollinearity.\",\n bold(\"Suggestion:\"),\n \"Try using GLMNET or tree-based algorithms\",\n sep = \"\\n \"\n )\n )\n err_pat_sug <- c(common_errors, error_pattern_suggestion)\n warn_pat_sug <- c(common_warnings, warning_pattern_suggestion)\n tryCatch(\n {\n withCallingHandlers(\n {\n do.call(fn, args)\n },\n warning = function(w) {\n fnwarn <- conditionMessage(w)\n message(\"Warning caught: \", fnwarn)\n idi <- which(sapply(\n names(warn_pat_sug),\n function(i) grepl(i, fnwarn)\n ))\n if (length(idi) > 0) {\n for (i in idi) {\n cat(orange(warn_pat_sug[[i]], \"\\n\"))\n }\n }\n invokeRestart(\"muffleWarning\")\n } # /warning\n ) # /withCallingHandlers\n },\n error = function(e) {\n fnerr <- e[[\"message\"]]\n errmsg <- paste0(highlight(fn), \" failed with error:\\n\", fnerr, \"\\n\")\n idi <- which(sapply(names(err_pat_sug), function(i) grepl(i, fnerr)))\n if (length(idi) > 0) {\n suggestions <- sapply(idi, function(i) err_pat_sug[[i]])\n errmsg <- paste0(\n red(errmsg),\n orange(\n paste0(\n bold(\"\\nSuggestion:\\n \"),\n paste0(suggestions, collapse = \"\\n \")\n )\n )\n )\n }\n cat(\"\\n\")\n cli::cli_abort(errmsg, call = call)\n } # /error\n ) # /tryCatch\n} # /rtemis::do_call\n" }, { "path": "R/utils_files.R", "content": "# utils_files.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n#' Expand, normalize, concatenate, clean path\n#'\n#' @param ... Character: Parts of path to concatenate.\n#' @param expand_path Logical: If TRUE, expand concatenated path using [path.expand].\n#'\n#' @return Character: Path.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nmake_path <- function(..., expand_path = TRUE) {\n path <- list(...)\n # Remove final \"/\"\n path <- lapply(path, \\(x) gsub(\"\\\\/$\", \"\", x))\n # Concat\n path <- do.call(file.path, path)\n # Expand\n if (expand_path) {\n path <- path.expand(path)\n }\n path\n} # /rtemis::make_path\n" }, { "path": "R/utils_html.R", "content": "# html_ops.R\n# ::rtemis::\n# 2023- EDG rtemis.org\n\n#' @keywords internal\n#' @noRd\nhtml_highlight <- function(..., bold = TRUE) {\n if (bold) {\n span(..., style = \"color: #16A0AC; font-weight: 700;\")\n } else {\n span(..., style = \"color: #16A0AC;\")\n }\n}\n\n\n#' @keywords internal\n#' @noRd\nhtml_orange <- function(..., bold = TRUE) {\n if (bold) {\n span(..., style = \"color: #FA6E1E; font-weight: 700;\")\n } else {\n span(..., style = \"color: #FA6E1E;\")\n }\n}\n\n\n#' @keywords internal\n#' @noRd\nhtml_red <- function(..., bold = TRUE) {\n if (bold) {\n span(..., style = \"color: #E61048; font-weight: 700;\")\n } else {\n span(..., style = \"color: #E61048;\")\n }\n}\n\n\n#' @keywords internal\n#' @noRd\nhtml_success <- function(..., bold = TRUE) {\n if (bold) {\n span(..., style = \"color: #32A03E; font-weight: 700;\")\n } else {\n span(..., style = \"color: #32A03E;\")\n }\n}\n" }, { "path": "R/utils_io.R", "content": "# utils_io.R\n# ::rtemis::\n# 2022 EDG rtemis.org\n\n#' Write \\pkg{rtemis} model to RDS file\n#'\n#' @param object `Supervised` object.\n#' @param outdir Path to output directory.\n#' @param file_prefix Character: Prefix for filename.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nrt_save <- function(\n object,\n outdir,\n file_prefix,\n print_load_info = TRUE,\n verbosity = 1L\n) {\n # Message before expanding outdir to preserve privacy when using relative paths.\n if (verbosity > 0L) {\n start_time <- Sys.time()\n msg0(\n \"Writing data to \",\n outdir,\n \"...\",\n caller = NA,\n newline = FALSE\n )\n }\n outdir <- sanitize_path(outdir, must_exist = FALSE, type = \"any\")\n if (!dir.exists(outdir)) {\n dir.create(outdir, recursive = TRUE, showWarnings = FALSE)\n }\n rds_path <- file.path(outdir, paste0(file_prefix, \".rds\"))\n try(saveRDS(object, rds_path))\n if (verbosity > 0L) {\n elapsed <- Sys.time() - start_time\n }\n if (file.exists(rds_path)) {\n if (verbosity > 0L) {\n yay(format(elapsed, digits = 2), gray(\" [rt_save]\"), sep = \"\")\n if (print_load_info) {\n msg0(gray(\n paste0(\n \"Reload with: \",\n \"> obj <- readRDS('\",\n rds_path,\n \"')\"\n )\n ))\n }\n }\n } else {\n if (verbosity > 0L) {\n nay(\n \"Failed after \",\n format(elapsed, digits = 2),\n gray(\" [rt_save]\"),\n sep = \"\"\n )\n }\n cli::cli_abort(\"Error: Saving model to \", outdir, \" failed.\")\n }\n} # /rtemis::rt_save\n\n#' Check file(s) exist\n#'\n#' @param paths Character vector of paths\n#' @param verbosity Integer: Verbosity level.\n#' @param pad Integer: Number of spaces to pad to the left\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\ncheck_files <- function(paths, verbosity = 1L, pad = 0) {\n if (verbosity > 0L) {\n msg0(\"Checking \", singorplu(length(paths), \"file\"), \":\")\n }\n\n for (f in paths) {\n if (file.exists(f)) {\n if (verbosity > 0L) {\n yay(f, pad = pad)\n }\n } else {\n if (verbosity > 0L) {\n nay(paste(f, red(\" not found!\")), pad = pad)\n }\n cli::cli_abort(\"File not found\")\n }\n }\n} # /rtemis::check_files\n\n# %% sanitize_path ----\n#' Sanitize and validate file paths for security\n#'\n#' Validates and normalizes file paths to prevent security vulnerabilities\n#' including command injection, path traversal, and unauthorized file access.\n#'\n#' @param path Character: File or directory path to sanitize.\n#' @param must_exist Logical: If TRUE, abort if path does not exist. Default = FALSE.\n#' @param allowed_base Character: Optional base directory to restrict paths to. If provided,\n#' the normalized path must be within this directory. Default = NULL (no restriction).\n#' @param allow_urls Logical: If TRUE, allow URL schemes (http://, https://, etc.).\n#' Default = FALSE.\n#' @param type Character: Expected path type - \"file\", \"directory\", or \"any\". Only checked\n#' if `must_exist = TRUE`. Default = \"any\".\n#'\n#' @return Character: Sanitized and normalized absolute path.\n#'\n#' @details\n#' Security checks performed:\n#' - Rejects paths starting with pipe character (prevents command injection in R readers)\n#' - Rejects paths containing null bytes\n#' - Rejects URL schemes unless `allow_urls = TRUE`\n#' - Normalizes path to absolute form\n#' - Optionally validates path exists and is correct type\n#' - Optionally validates path is within allowed base directory\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nsanitize_path <- function(\n path,\n must_exist = FALSE,\n allowed_base = NULL,\n allow_urls = FALSE,\n type = c(\"any\", \"file\", \"directory\")\n) {\n type <- match.arg(type)\n\n # Check for NULL or empty\n if (is.null(path) || length(path) == 0L || nchar(path) == 0L) {\n cli::cli_abort(\"Path cannot be NULL or empty.\")\n }\n\n # Check for multiple paths\n if (length(path) > 1L) {\n cli::cli_abort(\"Function accepts a single path. Got {length(path)} paths.\")\n }\n\n # Check for null bytes (check if raw bytes contain 0x00)\n if (any(charToRaw(path) == 0L)) {\n cli::cli_abort(\"Path contains null byte: {.file {path}}\")\n }\n\n # Check for pipe character at start (command injection vector)\n if (grepl(\"^\\\\s*\\\\|\", path)) {\n cli::cli_abort(\"Path cannot start with pipe character: {.file {path}}\")\n }\n\n # Check for URL schemes unless explicitly allowed\n if (!allow_urls && grepl(\"^[a-zA-Z][a-zA-Z0-9+.-]*://\", path)) {\n cli::cli_abort(\"URL schemes not allowed: {.file {path}}\")\n }\n\n # Normalize to absolute path\n # mustWork = FALSE allows non-existent paths, will check separately if needed\n normalized_path <- normalizePath(path, winslash = \"/\", mustWork = FALSE)\n\n # Validate against allowed base directory if specified\n if (!is.null(allowed_base)) {\n allowed_base_norm <- normalizePath(\n allowed_base,\n winslash = \"/\",\n mustWork = TRUE\n )\n # Check if normalized path starts with allowed base\n if (!startsWith(normalized_path, allowed_base_norm)) {\n cli::cli_abort(\n \"Path {.file {path}} is outside allowed directory: {.file {allowed_base}}\"\n )\n }\n }\n\n # Check existence and type if required\n if (must_exist) {\n if (!file.exists(normalized_path)) {\n cli::cli_abort(\"Path does not exist: {.file {normalized_path}}\")\n }\n\n if (type == \"file\" && dir.exists(normalized_path)) {\n cli::cli_abort(\"Path is not a file: {.file {normalized_path}}\")\n }\n\n if (type == \"directory\" && !dir.exists(normalized_path)) {\n cli::cli_abort(\"Path is not a directory: {.file {normalized_path}}\")\n }\n }\n\n normalized_path\n} # /rtemis::sanitize_path\n" }, { "path": "R/utils_lightgbm.R", "content": "# utils_lightgbm.R\n# ::rtemis::\n# 2023- EDG rtemis.org\n\n# %% prepare_lgb_data ----\n#' Prepare data for LightGBM-based learners\n#'\n#' Shared data preparation for LightGBM, LightRF, and LightCART.\n#' Converts factors to 0-based integers, removes the outcome from\n#' `categorical_feature`, and creates `lgb.Dataset` objects.\n#'\n#' @param x tabular data: Training set (features + outcome in last column).\n#' @param dat_validation Optional tabular data: Validation set.\n#' @param type Character: \"Classification\" or \"Regression\".\n#' @param weights Optional numeric vector: Case weights for training data.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Named list with elements:\n#' - `train_data`: `lgb.Dataset` for training.\n#' - `valid_data`: `lgb.Dataset` for validation, or NULL.\n#' - `preprocessor`: `Preprocessor` object if factors were converted, or NULL.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nprepare_lgb_data <- function(\n x,\n dat_validation = NULL,\n type,\n weights = NULL,\n verbosity = 1L\n) {\n # Factor-to-integer preprocessing ----\n factor_index <- names(x)[which(sapply(x, is.factor))]\n if (length(factor_index) > 0L) {\n prp <- preprocess(\n x,\n config = setup_Preprocessor(\n factor2integer = TRUE,\n factor2integer_startat0 = TRUE\n ),\n dat_validation = dat_validation,\n verbosity = verbosity\n )\n if (is.null(dat_validation)) {\n x <- prp@preprocessed\n } else {\n x <- prp@preprocessed[[\"training\"]]\n dat_validation <- prp@preprocessed[[\"validation\"]]\n }\n } else {\n prp <- NULL\n }\n\n # Remove outcome from factor_index (outcome is last column).\n # For Classification, the outcome is a factor that was also converted;\n # it must not be listed as a categorical feature.\n if (type == \"Classification\" && length(factor_index) > 0L) {\n factor_index <- factor_index[seq_len(length(factor_index) - 1L)]\n }\n\n # Create lgb.Datasets ----\n train_data <- lightgbm::lgb.Dataset(\n data = as.matrix(features(x)),\n categorical_feature = factor_index,\n label = outcome(x),\n weight = weights\n )\n\n valid_data <- if (!is.null(dat_validation)) {\n lightgbm::lgb.Dataset(\n data = as.matrix(features(dat_validation)),\n categorical_feature = factor_index,\n label = outcome(dat_validation)\n )\n }\n\n list(\n train_data = train_data,\n valid_data = valid_data,\n preprocessor = prp\n )\n} # /rtemis::prepare_lgb_data\n\n#' Get LightGBM Booster Trees\n#'\n#' @return A list of trees\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nget_lgb_tree <- function(x, n_iter = -1) {\n out <- lapply(\n jsonlite::fromJSON(\n lightgbm::lgb.dump(\n booster = x,\n num_iteration = n_iter\n ),\n simplifyVector = FALSE\n )[[\"tree_info\"]],\n \\(y) y[[\"tree_structure\"]]\n )\n names(out) <- paste0(\"Tree_\", seq_along(out))\n out\n} # /rtemis::get_lgb_tree\n\n\n# preorderlgb ----\n\n#' Preorder Traversal of LightGBM Tree\n#'\n#' Called by `lgbtree2rules` and operates on `tree` environment in place.\n#'\n#' @param tree Environment that will hold the extracted rules.\n#' @param node LightGBM tree.\n#' @param rule Character: current rule.\n#' @param left Character: left child label.\n#' @param right Character: right child label.\n#' @param split_feature Character: split feature label.\n#' @param threshold Character: threshold label.\n#' @param right_cat_type Character: \"in\" or \"notin\": operator for right categorical.\n#' @param xnames Character vector: feature names.\n#' @param factor_levels Named list of factor levels.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Character vector of rules.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\npreorderlgb <- function(\n tree,\n node,\n rule = \"TRUE\",\n left = \"left_child\",\n right = \"right_child\",\n split_feature = \"split_feature\",\n threshold = \"threshold\",\n right_cat_type = \"in\",\n xnames,\n factor_levels,\n verbosity = 0L\n) {\n if (is.null(node[[split_feature]])) {\n names(rule) <- \"leaf\"\n if (verbosity > 0L) {\n message(\"Reached a leaf; rule is \", rule, \".\")\n }\n tree[[\"leafs\"]] <- c(tree[[\"leafs\"]], rule)\n return(rule)\n }\n rule_left <- paste0(\n rule,\n \" & \",\n xnames[node[[split_feature]] + 1],\n decision_left(node[[\"decision_type\"]]),\n fmt_thresh(\n catsplit = node[[\"decision_type\"]] == \"==\",\n feature = xnames[node[[split_feature]] + 1],\n threshold = node[[\"threshold\"]],\n factor_levels = factor_levels\n )\n )\n rule_right <- paste0(\n rule,\n \" & \",\n xnames[node[[split_feature]] + 1],\n decision_right(node[[\"decision_type\"]], right_cat_type),\n fmt_thresh_right(\n catsplit = node[[\"decision_type\"]] == \"==\",\n feature = xnames[node[[split_feature]] + 1],\n threshold = node[[\"threshold\"]],\n factor_levels = factor_levels,\n cat_type = right_cat_type\n )\n )\n rule_left <- preorderlgb(\n tree,\n node[[left]],\n rule_left,\n left,\n right,\n split_feature,\n threshold,\n right_cat_type = right_cat_type,\n xnames = xnames,\n factor_levels = factor_levels,\n verbosity = verbosity\n )\n rule <- c(rule, rule_left)\n rule_right <- preorderlgb(\n tree,\n node[[right]],\n rule_right,\n left,\n right,\n split_feature,\n threshold,\n right_cat_type = right_cat_type,\n xnames = xnames,\n factor_levels = factor_levels,\n verbosity = verbosity\n )\n rule <- c(rule, rule_right)\n} # /rtemis::preorderlgb\n\n\n# lgbtree2rules ----\nlgbtree2rules <- function(x, xnames, factor_levels, right_cat_type = \"in\") {\n tree <- new.env()\n tree[[\"leafs\"]] <- character()\n preorderlgb(\n tree,\n x,\n xnames = xnames,\n right_cat_type = right_cat_type,\n factor_levels = factor_levels\n )\n # remove root node \"TRUE & \"\n substr(tree[[\"leafs\"]], 8, 99999)\n} # /rtemis::lgbtree2rules\n\n\n# lgb2rules ----\n#' Convert LightGBM Booster to set of rules\n#'\n#' @param x LightGBM Booster object\n#' @param n_iter Integer: Number of trees to convert to rules\n#' @param xnames Character vector: Names of features\n#'\n#' @return Character vector of rules\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nlgb2rules <- function(\n Booster,\n n_iter = NULL,\n xnames,\n factor_levels,\n right_cat_type = \"in\",\n return_unique = TRUE,\n verbosity = 1L\n) {\n if (verbosity > 0L) {\n msgstart(\"Extracting LightGBM rules...\")\n }\n if (is.null(n_iter)) {\n n_iter <- length(Booster)\n }\n trees <- get_lgb_tree(Booster, n_iter)\n rules <- lapply(trees, function(x) {\n lgbtree2rules(\n x,\n xnames,\n factor_levels = factor_levels,\n right_cat_type = right_cat_type\n )\n }) |>\n unlist()\n if (verbosity > 0L) {\n msgdone()\n }\n if (return_unique) unique(rules) else rules\n} # /rtemis::lgb2rules\n\n\n# extract_rules.lgb.Booster ----\n#' author EDG\n#' @keywords internal\n#' @noRd\nmethod(extract_rules, class_lgb.Booster) <- function(\n x,\n n_iter = NULL,\n xnames,\n factor_levels,\n right_cat_type = \"in\",\n return_unique = TRUE,\n verbosity = 1L\n) {\n if (verbosity > 0L) {\n msgstart(\"Extracting LightGBM rules...\")\n }\n if (is.null(n_iter)) {\n n_iter <- length(x)\n }\n trees <- get_lgb_tree(x, n_iter)\n rules <- lapply(trees, function(x) {\n lgbtree2rules(\n x,\n xnames,\n factor_levels = factor_levels,\n right_cat_type = right_cat_type\n )\n }) |>\n unlist()\n\n rules <- if (return_unique) {\n unique(rules)\n } else {\n rules\n }\n if (verbosity > 0L) {\n msgdone()\n msg0(\n \"Extracted \",\n highlight(length(rules)),\n ifelse(return_unique, \" unique\", \"\"),\n \" rules.\"\n )\n }\n rules\n} # /rtemis::extract_rules.lgb.Booster\n\n\n# decision_left ----\n#' @author EDG\n#' @keywords internal\n#' @noRd\ndecision_left <- function(decision_type) {\n switch(decision_type, \"<=\" = \" <= \", \"==\" = \" %in% \")\n} # /rtemis::decision_left\n\n\n#' @author EDG\n#' @keywords internal\n#' @noRd\ndecision_right <- function(decision_type, cat_type) {\n switch(\n decision_type,\n \"<=\" = \" > \",\n \"==\" = if (cat_type == \"in\") \" %in% \" else \" %notin% \"\n )\n} # /rtemis::decision_right\n\n\n#' Format rule thresholds\n#'\n#' @param catsplit Logical: If TRUE, feature is categorical\n#' @param feature Character: feature name\n#' @param threshold Character: threshold as reported by lightgbm\n#' @param factor_levels Named list of factor levels. Names should correspond to training\n#' set column names.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nfmt_thresh <- function(catsplit, feature, threshold, factor_levels) {\n if (catsplit) {\n flevels <- as.integer(strsplit(threshold, \"\\\\|\\\\|\")[[1]]) + 1 # 0- to 1-based factor level index\n flevels <- factor_levels[[feature]][flevels]\n paste0(\n \"c(\",\n paste0(\"'\", flevels, \"'\", collapse = \",\"),\n \")\"\n )\n } else {\n threshold\n }\n} # /rtemis::fmt_thresh\n\n\n#' @author EDG\n#' @keywords internal\n#' @noRd\nfmt_thresh_right <- function(\n catsplit,\n feature,\n threshold,\n factor_levels,\n cat_type\n) {\n if (catsplit) {\n flevels <- as.integer(strsplit(threshold, \"\\\\|\\\\|\")[[1]]) + 1 # 0- to 1-based factor level index\n flevels <- factor_levels[[feature]][flevels]\n if (cat_type == \"in\") {\n flevels <- setdiff(factor_levels[[feature]], flevels)\n }\n paste0(\n \"c(\",\n paste0(\"'\", flevels, \"'\", collapse = \",\"),\n \")\"\n )\n } else {\n threshold\n }\n} # /rtemis::fmt_thresh_right\n" }, { "path": "R/utils_palettes.R", "content": "# palettes.R\n# ::rtemis::\n# 2016- EDG rtemis.org\n\n# Colors ----\n#' @keywords internal\n#' @noRd\nucsfCol <- c(\n Navy = \"#052049\",\n A2 = \"#0F388A\",\n A3_CTA_Blue = \"#006BE9\",\n B3_Blue = \"#178CCB\",\n B5 = \"#B8E6FA\",\n B6 = \"#E2F4FC\",\n C1 = \"#0E5258\",\n C2 = \"#14828C\",\n C3_Teal = \"#16A0AC\",\n C4 = \"#60D0DA\",\n C5 = \"#B4E2E8\",\n D1 = \"#00483A\",\n D2 = \"#007242\",\n D3_Green = \"#32A03E\",\n E3_Chartreuse = \"#84C234\",\n E4_Point_Reyes = \"#B4DC55\",\n F1 = \"#2E2872\",\n F2 = \"#443E8C\",\n F3_Purple = \"#6C62D0\",\n F4_Yosemite = \"#8A8CE3\",\n F5 = \"#C0C0EA\",\n G1 = \"#461850\",\n G2 = \"#6C247C\",\n G3_Violet = \"#A238BA\",\n G4 = \"#C45ED8\",\n G5 = \"#EACCF0\",\n H1 = \"#561038\",\n H2 = \"#821A56\",\n H3_Magenta = \"#C42882\",\n H4 = \"#E266AE\",\n H5 = \"#F2C2DE\",\n I3_Blue_Gray = \"#506380\",\n I6 = \"#F2F3F4\",\n J2 = \"#878D96\",\n J3_Cool_Gray = \"#B4B9BF\",\n J5 = \"#E1E3E5\",\n K3_Gray = \"#D1D3D3\",\n L3_Yellow = \"#FEB80A\",\n M3_Orange = \"#FA6E1E\",\n N3_Red = \"#E61048\"\n)\n\n\n# UC Davis ----\n#' UC Davis Colors\n#'\n#' `ucdCol`: UC Davis color palette\n#' (https://marketingtoolbox.ucdavis.edu/visual-identity/color.html)\n#' @keywords internal\n#' @noRd\nucdCol <- c(\n davisBlue = \"#002855\",\n davisGold = \"#DAAA00\",\n unitransRed = \"#BA0C2F\",\n westernRedbud = \"#C6007E\",\n californiaPoppy = \"#ED8B00\",\n goldenLupine = \"#FFCD00\",\n sunnyGrass = \"#78BE20\",\n skyBlue = \"#00B5E2\",\n recPoolBlue = \"#008EAA\",\n wineGrape = \"#642667\",\n muBrick = \"#C26E60\",\n hartHallStucco = \"#E6A65D\",\n sageGreen = \"#9CAF88\",\n evergreen = \"#00573F\",\n winterSkyGray = \"#5B7F95\",\n centennialWalkGray = \"#B1B3B3\",\n corkOak = \"#ACA39A\",\n southHallShingleBrown = \"#4F2C1D\"\n)\n\n\n# Berkeley ----\n#' Berkeley Colors\n#'\n#' `berkeleyCol`: Berkeley color palette\n#' (https://brand.berkeley.edu/colors/)\n#'\n#' @keywords internal\n#' @noRd\nberkeleyCol <- c(\n Berkeley_Blue = \"#003262\",\n Founders_Rock = \"#3B7EA1\",\n California_Gold = \"#FDB515\",\n Medalist = \"#C4820E\",\n Wellman_Tile = \"#D9661F\",\n Rose_Garden = \"#EE1F60\",\n Golden_Gate = \"#ED4E33\",\n South_Hall = \"#6C3302\",\n Bay_Fog = \"#DDD5C7\",\n Lawrence = \"#00B0DA\",\n LapLane = \"#00A598\",\n Pacific = \"#46535E\",\n Sather_Gate = \"#B9D3B6\",\n Ion = \"#CFDD45\",\n Soy_Bean = \"#859438\",\n Stone_Pine = \"#584F29\",\n Grey = \"#EEEEEE\",\n Web_Grey = \"#888888\"\n)\n\n\n# UC Santa Cruz ----\n#' UC Santa Cruz Colors\n#'\n#' `ucscCol`: UC Santa Cruz color palette\n#' (https://communications.ucsc.edu/visual-design/color/)\n#'\n#' @keywords internal\n#' @noRd\nucscCol <- c(\n blue = \"#003c6c\",\n gold = \"#fdc700\",\n mediumBlue = \"#006aad\",\n lightBlue = \"#13a5dc\",\n teal = \"#007988\",\n orange = \"#f29813\",\n yellow = \"#ffbf00\",\n green = \"#93c02d\",\n rubineRed = \"#da216d\"\n)\n\n\n# UC Merced ----\n#' UC Merced Colors\n#'\n#' `ucmercedCol`: UC Merced color palette\n#' (https://publicrelations.ucmerced.edu/color-guidelines)\n#'\n#' @keywords internal\n#' @noRd\nucmercedCol <- c(\n mercedRiverBlue = \"#092f44\",\n foothillsGold = \"#a29061\",\n sierraSkyBlue = \"#5f8498\",\n wildflowerBabyBlueEyes = \"#2980b9\",\n yosemiteSnowWhite = \"#F8F5EC\",\n halfDomeSlate = \"#5B5B5B\",\n mercedRyeGreen = \"#235B16\"\n)\n\n\n# UC Santa Barbara ----\n#' UC Santa Barbara Colors\n#'\n#' `ucsbCol`: UC Santa Barbara color palette\n#' (https://www.ucsb.edu/visual-identity/color)\n#'\n#' @keywords internal\n#' @noRd\nucsbCol <- c(\n navy = \"#003660\",\n gold = \"#FEBC11\",\n aqua = \"#04859B\",\n moss = \"#7A8D39\",\n seaGreen = \"#0BA89A\",\n coral = \"#EF5645\",\n mist = \"#9CBEBE\",\n clay = \"#DCD6CC\",\n sandstone = \"#C9BF9D\",\n lightGray = \"#DCE1E5\"\n)\n\n\n# UCLA ----\n#' UCLA Colors\n#'\n#' `uclaCol`: UCLA color palette (http://brand.ucla.edu/identity/colors)\n#'\n#' @keywords internal\n#' @noRd\nuclaCol <- c(\n Blue = \"#2774AE\",\n Gold = \"#FFD100\",\n Darkest_Blue = \"#003B5C\",\n Darker_Blue = \"#005587\",\n Lighter_Blue = \"#8BB8E8\",\n Lightest_Blue = \"#C3D7EE\",\n Darkest_Gold = \"#FFB81C\",\n Darker_Gold = \"#FFC72C\",\n Yellow = \"#FFFF00\",\n Green = \"#00FF87\",\n Magenta = \"#FF00A5\",\n Cyan = \"#00FFFF\",\n Purple = \"#8237FF\"\n)\n\n\n# UC Riverside ----\n#' UC Riverside Colors\n#'\n#' `ucrCol`: UC Riverside color palette (https://brand.ucr.edu/ucr-colors)\n#'\n#' @keywords internal\n#' @noRd\nucrColor <- c(\n ucrBlue = \"#2d6cc0\",\n ucrGold = \"#f1ab00\",\n ucrGray = \"#393b41\"\n)\n\n\n# UCI ----\n#' UCI Colors\n#'\n#' `uciCol`: UCI color palette (https://communications.uci.edu/campus-resources/graphic-standards/colors.php)\n#'\n#' @keywords internal\n#' @noRd\nuciCol <- c(\n blue = \"#0064a4\",\n yellow = \"#ffd200\",\n teal = \"#6aa2b8\",\n lightGray = \"#c6beb5\",\n navy = \"#1b3d6d\",\n orange = \"#f78d2d\",\n darkGray = \"#555759\",\n lightYellow = \"#f7eb5f\"\n)\n\n\n# UC San Diego ----\n#' UC San Diego Colors\n#'\n#' `ucsdCol`: UC San Diego color palette\n#' (https://ucpa.ucsd.edu/brand/elements/color-palette/)\n#'\n#' @keywords internal\n#' @noRd\nucsdCol <- c(\n blue = \"#182B49\",\n mediumBlue = \"#006A96\",\n gold = \"#C69214\",\n yellow = \"#FFCD00\",\n cyan = \"#00C6D7\",\n green = \"#6E963B\",\n lightYellow = \"#F3E500\",\n orange = \"#FC8900\",\n coolGray = \"#747678\",\n lightGray = \"#B6B1A9\",\n darkGold = \"#84754E\"\n)\n\n\n# University of California ----\n#' University of California Colors\n#'\n#' `californiaCol`: University of California color palette\n#' (http://brand.universityofcalifornia.edu/guidelines/color.html#!primary-colors)\n#'\n#' @keywords internal\n#' @noRd\nucCol <- c(\n ucBlue = \"#1295D8\",\n ucGold = \"#FFB511\",\n blue = \"#005581\",\n lightBlue = \"#72CDF4\",\n gold = \"#FFD200\",\n lightgold = \"#FFE552\",\n orange = \"#FF6E1B\",\n lightOrange = \"#FF8F28\",\n pink = \"#E44C9A\",\n lightPink = \"#FEB2E0\",\n teal = \"#00778B\",\n lightTeal = \"#00A3AD\",\n ucGray = \"#7C7E7F\",\n warmGray8 = \"#8F8884\",\n warmGray3 = \"#BEB6AF\",\n warmGray1 = \"#DBD5CD\",\n metallicGold = \"#B4975A\"\n)\n\n# Stanford ----\n#' Stanford Colors\n#'\n#' `stanfordCol`: Stanford color palette\n#' (https://identity.stanford.edu/color.html#digital-color)\n#'\n#' @keywords internal\n#' @noRd\nstanfordCol <- c(\n Cardinal = \"#8c1515\",\n Cool_Grey = \"#4d4f53\",\n Black = \"#2e2d29\",\n Bright_Red = \"#B1040E\",\n Chocolate = \"#2F2424\",\n Stone = \"#544948\",\n Fog = \"#F4F4F4\",\n Light_Sandstone = \"#F9F6EF\",\n Sandstone = \"#d2c295\",\n Warm_Grey = \"#3f3c30\",\n Beige = \"#9d9573\",\n Light_Sage = \"#c7d1c5\",\n Clay = \"#5f574f\",\n Cloud = \"#dad7cb\",\n Driftwood = \"#b6b1a9\",\n Sandhill = \"#b3995d\",\n Palo_Alto = \"#175e54\",\n Teal = \"#00505c\",\n Purple = \"#53284f\",\n Redwood = \"#8d3c1e\",\n Brown = \"#5e3032\",\n Sky = \"#0098db\",\n Lagunita = \"#007c92\",\n Mint = \"#009b76\",\n Gold = \"#b26f16\",\n Sun = \"#eaab00\",\n Poppy = \"#e98300\"\n)\n\n# California State University ----\n#' California State University Colors\n#'\n#' `csuCol`: California State University color palette\n#' (https://www2.calstate.edu/csu-system/csu-branding-standards/Documents/CSU-Brand-Guidelines-8-2018.pdf)\n#'\n#' @keywords internal\n#' @noRd\ncsuCol <- c(\n red = \"#CC0B2A\",\n coolGray = \"#D9D9D6\",\n black = \"#2F2F2F\"\n)\n\n\n# California Polytechnic State University ----\n#' California Polytechnic State University Colors\n#'\n#' `calpolyCol`: Cal Poly color palette\n#' (https://universitymarketing.calpoly.edu/brand-guidelines/colors/)\n#'\n#' @keywords internal\n#' @noRd\ncalpolyCol <- c(\n calpolygreen = \"#154734\",\n calpolygold = \"#C69214\",\n stadiumgold = \"#F8E08E\",\n polycanyon = \"#F2C75C\",\n dextergreen = \"#A4D65E\",\n farmersmarket = \"#3A913F\",\n skyblue = \"#B5E3D8\",\n surfblue = \"#5CB8B2\",\n serenity = \"#D3E3F4\",\n morroblue = \"#ABCAE9\",\n missionbeige = \"#E4E1D1\",\n pismosand = \"#CAC7A7\",\n coastsage = \"#B6CCC2\",\n sycamore = \"#789F90\",\n kennedygray = \"#8E9089\",\n sealgray = \"#54585A\",\n heritageorange = \"#FF6A39\",\n avodaco = \"#D0DF00\"\n)\n\n# Caltech ----\n#' Caltech Colors\n#'\n#' `caltechCol`: Caltech color palette (http://identity.caltech.edu/colors)\n#'\n#' @keywords internal\n#' @noRd\ncaltechCol <- c(\n orange = \"#FF6C0C\",\n coolGray9 = \"#76777B\",\n coolGray3c = \"#C8C8C8\",\n pms414 = \"#AAA99F\",\n pms5497c = \"#849895\",\n pms7494c = \"#9DAE88\",\n pms451c = \"#C7B784\",\n pms7403c = \"#F1D384\",\n pms548c = \"#003B4C\",\n pms3292c = \"#005851\",\n pms668c = \"#644B78\",\n pms195c = \"#7A303F\",\n pms186c = \"#CF0A2C\",\n pms299c = \"#00A1DF\",\n pms7473c = \"#1E988A\",\n pms7489c = \"#73A950\",\n pms7408c = \"#F9BE00\",\n pms605c = \"#E2CC00\",\n pms1915c = \"#F54D80\"\n)\n\n# Scripps Research ----\n#' Scripps Research Colors\n#'\n#' `scrippsCol`: Scripps Research color palette\n#'\n#' @keywords internal\n#' @noRd\nscrippsCol <- c(\n yellow = \"#edb035\",\n orange = \"#f1624f\",\n maroon = \"#610f37\",\n blue = \"#273d78\",\n teal = \"#116f79\",\n lightblue = \"#59c3d3\"\n)\n\n# Penn ----\n#' rtemis Color Palettes\n#'\n#' `pennCol`: Penn color palette\n#' (http://www.upenn.edu/about/styleguide-color-type)\n#'\n#' @keywords internal\n#' @noRd\npennCol <- c(\n darkestBlue = \"#000f3a\",\n darkerBlue = \"#00144d\",\n blue = \"#01256e\",\n lighterBlue = \"#045ea7\",\n lightestBlue = \"#82afd3\",\n darkestRed = \"#57000a\",\n darkerRed = \"#74000e\",\n red = \"#95001a\",\n lighterRed = \"#c2004d\",\n lightestRed = \"#e180a6\",\n darkestYellow = \"#af7f00\",\n darkerYellow = \"#eaa900\",\n yellow = \"#f2c100\",\n lighterYellow = \"#f8de00\",\n lightestYellow = \"#fcef80\",\n darkestGreen = \"#005200\",\n darkerGreen = \"#006e00\",\n green = \"#008e00\",\n lighterGreen = \"#00be00\",\n lightestGreen = \"#80df80\",\n darkestOrange = \"#812d00\",\n darkerOrange = \"#ac3c00\",\n orange = \"#c35a00\",\n lighterOrange = \"#df9700\",\n lightestOrange = \"#efcb80\",\n darkestPurple = \"#23001f\",\n darkerPurple = \"#2f0029\",\n purple = \"#4a0042\",\n lighterPurple = \"#890082\",\n lightestPurple = \"#c480c1\"\n)\n\n\n#' `pennPalette`: Subset of `pennCol`.\n#'\n#' @keywords internal\n#' @noRd\npennPalette <- pennCol[c(\n \"lighterBlue\",\n \"red\",\n \"green\",\n \"yellow\",\n \"lighterPurple\",\n \"orange\",\n \"lightestBlue\",\n \"lighterRed\",\n \"lighterGreen\",\n \"lightestPurple\",\n \"lighterOrange\"\n)]\n\n#' `pennLightPalette`: Subset of `pennCol`. This is the lighter Penn palette for use with\n#' the dark themes\n#'\n#' @keywords internal\n#' @noRd\npennLightPalette <- pennCol[c(\n \"lightestBlue\",\n \"lightestRed\",\n \"lightestGreen\",\n \"lightestYellow\",\n \"lightestPurple\"\n)]\n\n\n# CMU ----\n#' CMU Colors\n#'\n#' `cmuCol`: Carnegie Mellon color palette\n#' (https://www.cmu.edu/marcom/brand-standards/web-standards.html#colors)\n#'\n#' @keywords internal\n#' @noRd\ncmuCol <- c(\n cmuRed = \"#bb0000\",\n gray = \"#e0e0e0\",\n darkGray = \"#666666\",\n gold = \"#aa6600\",\n teal = \"#006677\",\n blue = \"#224477\",\n green = \"#008855\",\n darkGreen = \"#224433\"\n)\n\n\n# MIT ----\n#' MIT Colors\n#'\n#' `mitCol`: MIT color palette\n#' (http://web.mit.edu/graphicidentity/colors.html)\n#'\n#' @keywords internal\n#' @noRd\nmitCol <- c(\n red = \"#A31F34\",\n gray = \"#8A8B8C\",\n lightGray = \"#C2C0BF\"\n)\n\n\n# Princeton ----\n#' Princeton Colors\n#'\n#' `princetonCol`: Princeton color palette\n#' (https://communications.princeton.edu/guides-tools/logo-graphic-identity)\n#'\n#' @keywords internal\n#' @noRd\nprincetonCol <- c(\n orangeOnWhite = \"#e77500\",\n orangeOnBlack = \"#f58025\"\n)\n\n\n# Columbia ----\n#' Columbia Colors\n#'\n#' `columbiaCol`: Columbia color palette\n#' (https://visualidentity.columbia.edu/content/web-0)\n#'\n#' @keywords internal\n#' @noRd\ncolumbiaCol <- c(\n blue = \"#000d74\",\n blue1 = \"#C4D8E2\",\n blue2 = \"#75AADB\",\n blue3 = \"#6CADDF\",\n blue4 = \"#008EE0\",\n blue5 = \"#2C6BAC\",\n blue6 = \"#0046A6\",\n white = \"#F9F9F9\",\n lightGray = \"#EFEFEF\",\n sandstone = \"#D2D2C0\",\n gray = \"#555555\",\n slate = \"#41516C\",\n tarawera = \"#093552\",\n yellow = \"#FFB400\",\n lightGreen = \"#C0CD3F\",\n lime = \"#90C134\",\n orange = \"#C14D00\",\n red = \"#841C1C\",\n purple = \"#8E0F56\"\n)\n\n\n# Brown ----\n#' Brown Colors\n#'\n#' `brownCol`: Brown color palette\n#' (https://www.brown.edu/university-identity/sites/university-identity/files/Brown_Visual_Identity_Policy_2016-07-22.pdf)\n#'\n#' @keywords internal\n#' @noRd\nbrownCol <- c(\n red = \"#ED1C24\",\n brown = \"#4E3629\",\n gold = \"#FFC72C\",\n gray = \"#98A4AE\",\n skyBlue = \"#59CBE8\",\n emerald = \"#00B398\",\n navy = \"#003C71\",\n taupe = \"#B7B09C\"\n)\n\n\n# Yale ----\n#' Yale Colors\n#'\n#' `yaleCol`: Yale color palette (https://yaleidentity.yale.edu/web)\n#'\n#' @keywords internal\n#' @noRd\nyaleCol <- c(\n yaleBlue = \"#00356b\",\n mediumBlue = \"#286dc0\",\n lightBlue = \"#63aaff\",\n darkestGray = \"#222222\",\n darkGray = \"#4a4a4a\",\n sandstone = \"#978d85\",\n lightGray = \"#dddddd\",\n lightestGray = \"#f9f9f9\",\n green = \"#5f712d\",\n orange = \"#bd5319\"\n)\n\n\n# Cornell ----\n#' Cornell Colors\n#'\n#' `cornellCol`: Yale color palette\n#' (https://brand.cornell.edu/design-center/colors/\n#'\n#' @keywords internal\n#' @noRd\ncornellCol <- c(\n carnellian = \"#B31B1B\",\n darkGrey = \"#222222\",\n lightGrey = \"#F7F7F7\",\n linkBlue = \"#006699\",\n greenGraphics = \"#6EB43F\",\n greenText = \"#4B7B2B\",\n greenLargeText = \"#578E32\",\n orangeGraphics = \"#F8981D\",\n orangeLargeText = \"#D47500\",\n redGraphics = \"#EF4035\",\n redText = \"#DF1E12\",\n navy = \"#073949\",\n darkWarmGrey = \"#A2998B\",\n seaGrey = \"#9FAD9F\"\n)\n\n# Harvard Medical School ----\n#' HMS Colors\n#'\n#' `hmsCol`: Harvard Medical School color palette\n#' (https://identityguide.hms.harvard.edu/color)\n#'\n#' @keywords internal\n#' @noRd\nhmsCol <- c(\n crimson = \"#A51C30\",\n black = \"#1E1E1E\",\n mortar = \"#8C8179\",\n parchment = \"#F3F3F1\",\n slate = \"#8996A0\",\n shade = \"#BAC5C6\",\n indigo = \"#293352\",\n blueBonnet = \"#4E84C4\",\n ivy = \"#52854C\",\n pear = \"#C3D7A4\",\n lemon = \"#FFDB6D\",\n saffron = \"#D16103\",\n gold = \"#C4961A\",\n creme = \"#F4EDCA\"\n)\n\n\n# Dartmouth ----\n#' Dartmouth Colors\n#'\n#' `dartmouthCol`: Dartmouth color palette\n#' (https://communications.dartmouth.edu/visual-identity/design-elements/color-palette#web%20palette)\n#'\n#' @keywords internal\n#' @noRd\ndartmouthCol <- c(\n dartmouthGreen = \"#00693e\",\n forestGreen = \"#12312b\",\n webGray1 = \"#f7f7f7\",\n webGray2 = \"#e2e2e2\",\n graniteGray = \"#424141\",\n autumnBrown = \"#643c20\",\n bonfireRed = \"#9d162e\",\n tuckOrange = \"#e32d1c\",\n summerYellow = \"#f5dc69\",\n springGreen = \"#c4dd88\",\n riverNavy = \"#003c73\",\n riverBlue = \"#267aba\",\n webViolet = \"#8a6996\",\n bonfireOrange = \"#ffa00f\"\n)\n\n# USF ----\n#' USF Colors\n#'\n#' `usfCol`: USF color palette\n#' (https://myusf.usfca.edu/marketing-communications/resources/graphics-resources/brand-standards/color-palette)\n#' Color conversions performed using https://www.pantone.com/color-finder/\n#'\n#' @keywords internal\n#' @noRd\nusfCol <- c(\n green = \"#205C40\",\n yellow = \"#ffb81c\",\n gray = \"#75787B\"\n)\n\n\n# Washington ----\n#' University of Washington Colors\n#'\n#' `uwCol`: University of Washington color palette\n#' (http://www.washington.edu/brand/graphic-elements/primary-color-palette/)\n#'\n#' @keywords internal\n#' @noRd\nuwCol <- c(\n purple = \"#4b2e83\",\n gold = \"#b7a57a\",\n metallicGold = \"#85754d\"\n)\n\n\n# Johns Hopkins ----\n#' Johns Hopkins University Colors\n#'\n#' `jhuCol`: Johns Hopkins University color palette\n#' (https://brand.jhu.edu/color/)\n#'\n#' @keywords internal\n#' @noRd\njhuCol <- c(\n heritageBlue = \"#002d72\",\n spiritBlue = \"#68ace5\",\n orange = \"#cf4520\",\n maroon = \"#76232f\",\n pink = \"#a15a95\",\n green = \"#009b77\",\n blue = \"#0072ce\",\n yellow = \"#f1c400\",\n pms7407c = \"#cba052\",\n pms1375c = \"#ff9e1b\",\n pms1505c = \"#ff6900\",\n pms7586c = \"#9e5330\",\n pms4625c = \"#4f2c1d\",\n pms486c = \"#e8927c\",\n pms187c = \"#a6192e\",\n pms262c = \"#51284f\",\n pms666c = \"#a192b2\",\n pms279c = \"#418fde\",\n pms564c = \"#86c8bc\",\n pms7734c = \"#286140\",\n pms7490c = \"#719949\"\n)\n\n\n# NYU ----\n#' NYU Colors\n#'\n#' `nyuCol`: NYU color palette\n#' (https://www.nyu.edu/employees/resources-and-services/media-and-communications/styleguide/website/graphic-visual-design.html)\n#'\n#' @keywords internal\n#' @noRd\nnyuCol <- c(\n brightPurple = \"#8900e1\",\n nyuPurple = \"#57068c\",\n darkerPurple = \"#330662\",\n darkestPurple = \"#220337\",\n mediumGray = \"#6d6d6d\",\n lightGray = \"#b8b8b8\",\n lighterGray = \"#d6d6d6\",\n lightestGray = \"#f2f2f2\",\n red = \"#cb0200\",\n orange = \"#e86c00\",\n green = \"#489141\",\n blue = \"#28619e\",\n lightBlue = \"#3dbbdb\",\n accentGreen = \"#007c70\",\n brightRed = \"#d71e5e\",\n brightOrange = \"#e86c00\",\n yellow = \"#ffc107\"\n)\n\n# WashU ----\n#' Washington University St Louis Colors\n#'\n#' `washuCol`: WashU color palette\n#' (https://marcomm.wustl.edu/resources/branding-logo-toolkit/color-palettes/)\n#'\n#' @keywords internal\n#' @noRd\nwashuCol <- c(\n red = \"#a51417\",\n gray = \"#6c7373\",\n lightGray = \"#c8c8c8\",\n darkGray = \"#3d3d3d\",\n extraLightGRAY = \"#eeeeee\",\n green = \"#007360\",\n darkGreen = \"#173e3a\",\n lightGreen = \"#789b4a\",\n tan = \"#e1c4ac\",\n darkBlue = \"#172752\",\n blue = \"#005f85\",\n pearl = \"#d8d2c5\",\n yellow = \"#ffcc00\",\n orange = \"#d15f27\",\n darkOrange = \"#b85323\",\n purple = \"#622466\",\n lightTurqoise = \"#67c8c7\",\n turqoise = \"#2b8282\"\n)\n\n\n# Chicago ----\n#' U Chicago Colors\n#'\n#' `chicagoCol`: University of Chicago color palette\n#' (https://news.uchicago.edu/sites/default/files/attachments/_uchicago.identity.guidelines.pdf)\n#'\n#' @keywords internal\n#' @noRd\nchicagoCol <- c(\n maroon = \"#800000\",\n darkGray = \"#767676\",\n lightGray = \"#D6D6CE\",\n yellowTint = \"#FFB547\",\n yellowCore = \"#FFA319\",\n yellowShade = \"#C68220\",\n orangeTint = \"#D49464\",\n orangeCore = \"#C16622\",\n orangeShade = \"#9A5324\",\n redTint = \"#B1746F\",\n redCore = \"#8F3931\",\n redShade = \"#642822\",\n lightGreenTint = \"#ADB17D\",\n lightGreenCore = \"#8A9045\",\n lightGreenShade = \"#616530\",\n darkGreenTint = \"#8A8B79\",\n darkGreenCore = \"#58593F\",\n darkGreenShade = \"#3E3E23\",\n blueTint = \"#5B8FA8\",\n blueCore = \"#155F83\",\n blueShade = \"#0F425C\",\n violetTint = \"#725663\",\n violetCore = \"#350E20\",\n cyan = \"#47B5FF\",\n magenta = \"#FF3399\"\n)\n\n\n# Penn State ----\n#' Penn State Colors\n#'\n#' `texasCol`: Penn State color palette\n#' (https://brand.psu.edu/design-essentials.html#color)\n#'\n#' @keywords internal\n#' @noRd\npennstateCol <- c(\n nittanyNavy = \"#001E44\",\n beaverBlue = \"#1E407C\",\n pennsylvaniaSky = \"#009CDE\",\n limestone = \"#91959C\",\n creek = \"#3EA39E\",\n slate = \"#314D64\",\n pennsForest = \"#4A7729\",\n oldCoaly = \"#54585A\",\n landGrant = \"#6A3028\",\n lionsRoar = \"#BF8226\",\n lionShrine = \"#B88965\",\n statelyAtherton = \"#AC8DCE\",\n pughBlue = \"#96BEE6\",\n original1887 = \"#BC204B\",\n brightkeystone = \"#FFD100\",\n inventOrange = \"#E98300\",\n dawnOfDiscovery = \"#F2665E\",\n perpetualWonder = \"#491D70\",\n greenOpportunity = \"#008755\",\n futuresCalling = \"#99CC00\"\n)\n\n\n# SFSU ----\n#' SF State\n#'\n#' `sfsuCol`: SF State color palette\n#' (https://logo.sfsu.edu/color-system)\n#'\n#' @keywords internal\n#' @noRd\nsfsuCol <- c(\n `2755C` = \"#231161\",\n `2755C_85pc` = \"#463077\",\n `117C` = \"#C99700\",\n `117C_60pc` = \"#E9D597\",\n `3025C` = \"#004F71\",\n `383C` = \"#ABAD00\",\n `7419C` = \"#B04A5A\",\n `484C` = \"#9A3324\",\n coolGray11 = \"#53565A\"\n)\n\n# U Illinois ----\n#' University of Illinois Colors\n#'\n#' `illinoisCol`: University of Illinois color palette\n#' (https://www.uillinois.edu/OUR/brand/color_palettes)\n#'\n#' @keywords internal\n#' @noRd\nillinoisCol <- c(\n uofiblue = \"#13294b\",\n urbanaOrange = \"#E84A27\",\n uicRed = \"#D50032\",\n uisBlue = \"#003366\",\n teal = \"#0d605e\",\n grayBlue = \"#6fafc7\",\n citron = \"#bfd46d\",\n darkYellow = \"#ffd125\",\n salmon = \"#ee5e5e\",\n periwinkle = \"#4f6898\",\n gray = \"#E8E9EA\",\n coolGray6 = \"#A5A8AA\",\n coolGray1 = \"#5E6669\",\n secondaryBlue1 = \"#0455A4\",\n secondaryBlue2 = \"#1F4096\"\n)\n\n# U Maryland ----\n#' University of Maryland Colors\n#'\n#' `umdCol`: University of Maryland color palette\n#' (https://osc.umd.edu/licensing-trademarks/brand-standards/logos/#color)\n#'\n#' @keywords internal\n#' @noRd\numdCol <- c(\n umdRed = \"#E21833\",\n umdYellow = \"#ffd200\",\n umdBrown = \"#AD7C59\"\n)\n\n# MSU ----\n#' Michigan State University Colors\n#'\n#' `msuCol`: MSU color palette\n#' (https://brand.msu.edu/visual/color-palette)\n#'\n#' @keywords internal\n#' @noRd\nmsuCol <- c(\n SpartanGreen = \"#18453B\",\n White = \"#FFFFFF\",\n Black = \"#000000\",\n KellyGreen = \"#008208\",\n LimeGreen = \"#7BBD00\",\n ExcellenceGreen = \"#0B9A6D\"\n)\n\n# Michigan ----\n#' University of Michigan Colors\n#'\n#' `michiganCol`: Michigan color palette\n#' (https://brand.umich.edu/design-resources/colors/)\n#'\n#' @keywords internal\n#' @noRd\nmichiganCol <- c(\n Maize = \"#FFCB05\",\n Blue = \"#00274C\",\n TappanRed = \"#9A3324\",\n RossOrange = \"#D86018\",\n RackhamGreen = \"#75988d\",\n WaveFieldGreen = \"#A5A508\",\n TaubmanTeal = \"#00B2A9\",\n ArboretumBlue = \"#2F65A7\",\n A2Amethyst = \"#702082\",\n MatthaeiViolet = \"#575294\",\n UMMATan = \"#CFC096\",\n BurtonTowerBeige = \"#9B9A6D\",\n AngelHallAsh = \"#989C97\",\n LawQuadStone = \"#655A52\",\n PumaBlack = \"#131516\"\n)\n\n# Iowa ----\n#' Univeristy of Iowa Colors\n#'\n#' `iowaCol`: University of Iowa color palette\n#' (https://brand.uiowa.edu/color)\n#'\n#' @keywords internal\n#' @noRd\niowaCol <- c(\n Gold = \"#FFCD00\",\n Gray = \"#BBBCBC\",\n Blue = \"#00A9E0\",\n Green = \"#00AF66\",\n Orange = \"#FF8200\",\n DarkGray = \"#63666A\",\n DarkBlue = \"#00558C\",\n DarkGreen = \"#00664F\",\n DarkOrange = \"#BD472A\"\n)\n\n# U Texas ----\n#' U Texas Colors\n#'\n#' `texasCol`: University of Texas color palette\n#' (https://brand.utexas.edu/identity/color/)\n#'\n#' @keywords internal\n#' @noRd\ntexasCol <- c(\n burntOrange = \"#bf5700\",\n gray = \"#333f48\",\n brightOrange = \"#f8971f\",\n yellow = \"#ffd600\",\n lightGreen = \"#a6cd57\",\n green = \"#579d42\",\n teal = \"#00a9b7\",\n blue = \"#005f86\",\n lightBlue = \"#9cadb7\",\n stone = \"#d6d2c4\"\n)\n\n\n# Emory ----\n#' Emory Colors\n#'\n#' `emoryCol`: Emory color palette\n#' (https://brand.emory.edu/color.html)\n#'\n#' @keywords internal\n#' @noRd\nemoryCol <- c(\n emoryBlue = \"#012169\",\n darkBlue = \"#0c2340\",\n mediumBlue = \"#0033a0\",\n lightBlue = \"#007dba\",\n yellow = \"#f2a900\",\n gold = \"#b58500\",\n metallicGold = \"#84754e\",\n cyan = \"#00aeef\",\n skyBlue = \"#41b6e6\",\n teal = \"#487f84\",\n kellyGreen = \"#348338\",\n seaGreen = \" #006c5b\",\n olive = \"#5c8118\",\n orange = \"#c35413\",\n red = \"#da291c\",\n magenta = \"#c6007e\",\n purple = \"#6558b1\",\n grape = \"#6d2077\",\n black = \"#101820\",\n coolGray5 = \"#b1b3b3\",\n coolGray2 = \"#d0d0ce\",\n coolGray1 = \"#d9d9d6\"\n)\n\n# Georgia Tech ----\n#' Georgia Tech Colors\n#'\n#' `techCol`: Georgia Tech color palette\n#' (http://www.licensing.gatech.edu/super-block/239)\n#'\n#' @keywords internal\n#' @noRd\ntechCol <- c(\n techGold = \"#B3A369\",\n buzzGold = \"#EAAA00\",\n blue = \"#00263A\"\n)\n\n\n# Vanderbilt ----\n#' Vanderbilt Color\n#'\n#' `vanderbiltCol`: Vanderbilt color palette\n#' (https://www.vanderbilt.edu/communications/brand/color.php)\n#'\n#' @keywords internal\n#' @noRd\nvanderbiltCol <- c(\n gold = \"#D8AB4C\",\n blue = \"#006682\",\n red = \"#993D1B\",\n darkGray = \"#333333\",\n green = \"#464E21\",\n lightBlue = \"#CCE0E6\",\n lightRed = \"#EBD8D1\",\n lightGray = \"#DDDDDD\",\n lightGreen = \"#DADCD3\"\n)\n\n# Jefferson ----\n#' Jefferson University Colors\n#'\n#' `jeffersonCol`: Jefferson color palette (http://creative.jefferson.edu/downloads/Jefferson-Brand-Guidelines.pdf)\n#'\n#' @keywords internal\n#' @noRd\njeffersonCol <- c(\n jeffDeepBlue = \"#152456\",\n jeffBrightBlue = \"#59B7df\",\n legacyMaroon = \"#9f2943\",\n red = \"#e53e30\",\n voltGreen = \"#ece819\",\n silver = \"#dfe1df\",\n darkGray = \"#8e9089\",\n black = \"#231f20\"\n)\n\n# Hawaii ----\n#' University of Hawaii Colors\n#'\n#' `hawaiiCol`: University of Hawaii color palette (https://www.hawaii.edu/offices/eaur/graphicsstandards.pdf)\n#'\n#' @keywords internal\n#' @noRd\nhawaiiCol <- c(\n manoa = \"#024731\",\n hilo = \"#DA291C\",\n westOahu = \"#A71930\",\n hawaiiCC = \"#91004B\",\n honoluluCC = \"#00747A\",\n kapiolaniCC = \"#002395\",\n kauaiCC = \"#716FB3\",\n leeward = \"#3D7EDB\",\n mauiCC = \"#005172\",\n windward = \"#7AB800\",\n system = \"#B3995D\"\n)\n\n# NIH ----\n#' NIH Colors\n#'\n#' `nihCol`: NIH color palette (https://www.nlm.nih.gov/about/nlm_logo_guidelines_030414_508.pdf)\n#'\n#' @keywords internal\n#' @noRd\nnihCol <- c(\n blue = \"#20558a\",\n gray = \"#616265\"\n)\n\n# Imperial ----\n#' Imperial Colours\n#'\n#' `imperialCol`: Imperial College London colour palette\n#' (https://www.imperial.ac.uk/brand-style-guide/visual-identity/brand-colours/)\n#'\n#' @keywords internal\n#' @noRd\nimperialCol <- c(\n navy = \"#002147\",\n imperialBlue = \"#003E74\",\n lightGrey = \"#EBEEEE\",\n coolGrey = \"#9D9D9D\",\n lightBlue = \"#D4EFFC\",\n blue = \"#006EAF\",\n processBlue = \"#0091D4\",\n poolBlue = \"#00ACD7\",\n darkTeal = \"#0F8291\",\n teal = \"#009CBC\",\n seaglass = \"#379f9f\",\n darkGreen = \"#02893B\",\n kermitGreen = \"#66A40A\",\n lime = \"#BBCE00\",\n orange = \"#D24000\",\n tangerine = \"#EC7300\",\n lemonYellow = \"#FFDD00\",\n brick = \"#A51900\",\n red = \"#DD2501\",\n cherry = \"#E40043\",\n raspberry = \"#9F004E\",\n magentaPink = \"#C81E78\",\n iris = \"#751E66\",\n violet = \"#960078\",\n plum = \"#321E6D\",\n purple = \"#653098\"\n)\n\n# UCL ----\n#' UCL Colours\n#'\n#' `uclCol`: UCL colour palette (https://www.ucl.ac.uk/cam/brand/guidelines/colour)\n#'\n#' @keywords internal\n#' @noRd\nuclCol <- c(\n darkGreen = \"#555025\",\n darkRed = \"#651D32\",\n darkPurple = \"#4B384C\",\n darkBlue = \"#003D4C\",\n darkBrown = \"#4E3629\",\n midGreen = \"#8F993E\",\n midRed = \"#93272C\",\n midPurple = \"#500778\",\n midBlue = \"#002855\",\n stone = \"#D6D2C4\",\n brightGreen = \"#B5BD00\",\n brightRed = \"#D50032\",\n brightBlue = \"#0097A9\",\n brightPink = \"#AC145A\",\n lightGreen = \"#BBC592\",\n lightRed = \"#E03C31\",\n lightPurple = \"#C6B0BC\",\n lightBlue = \"#8DB9CA\",\n yellow = \"#F6BE00\",\n orange = \"#EA7600\",\n grey = \"#8C8279\",\n blueCeleste = \"#A4DBE8\",\n IOEblue = \"#24509A\"\n)\n\n# Oxford ----\n#' Oxford Colours\n#'\n#' `oxfordCol`: Oxford University colour palette (https://www.ox.ac.uk/sites/files/oxford/media_wysiwyg/Oxford%20Blue%20LR.pdf)\n#'\n#' @keywords internal\n#' @noRd\noxfordCol <- c(\n oxfordBlue = \"#002147\",\n pantone279 = \"#4891DC\",\n pantone291 = \"#9ECEEB\",\n pantone5405 = \"#44687D\",\n pantone549 = \"#5F9BAF\",\n pantone551 = \"#A1C4D0\",\n pantone562 = \"#007770\",\n pantone624 = \"#7BA296\",\n pantone559 = \"#BCD2C3\",\n pantone576 = \"#69913B\",\n pantone578 = \"#B9CF96\",\n pantone580 = \"#CEDBAF\",\n pantone583 = \"#AAB300\",\n pantone585 = \"#DBDE72\",\n pantone587 = \"#E3E597\",\n pantone7412 = \"#CF7A30\",\n pantone129 = \"#F5CF47\",\n pantone127 = \"#F3DE74\",\n pantone202 = \"#872434\",\n pantone200 = \"#BE0F34\",\n pantone196 = \"#EBC4CB\",\n pantoneWarmGray6 = \"#A79D96\",\n pantoneWarmGray3 = \"#C7C2BC\",\n pantoneWarmGray1 = \"#E0DED9\"\n)\n\n\n# NHS ----\n#' NHS Colours\n#'\n#' `nhsCol`: NHS colour palette (https://www.england.nhs.uk/nhsidentity/identity-guidelines/colours/)\n#'\n#' @keywords internal\n#' @noRd\nnhsCol <- c(\n nhsDarkBlue = \"#003087\",\n nhsBlue = \"#005EB8\",\n nhsBrightBlue = \"#0072CE\",\n nhsLightBlue = \"#41B6E6\",\n nhsAquaBlue = \"#00A9CE\",\n nhsBlack = \"#231f20\",\n nhsDarkGrey = \"#425563\",\n nhsMidGrey = \"#768692\",\n nhsPaleGrey = \"#E8EDEE\",\n nhsDarkGreen = \"#006747\",\n nhsGreen = \"#009639\",\n nhsLightGreen = \"#78BE20\",\n nhsAquaGreen = \"#00A499\",\n nhsPurple = \"#330072\",\n nhsDarkPink = \"#7C2855\",\n nhsPink = \"#AE2573\",\n nhsDarkRed = \"#8A1538\",\n emergencyServicesRed = \"#DA291C\",\n nhsOrange = \"#ED8B00\",\n nhsWarmYellow = \"#FFB81C\",\n nhsYellow = \"#FAE100\"\n)\n\n# UBC ----\n#' UBC Colors\n#'\n#' `ubcCol`: UBC color palette (http://assets.brand.ubc.ca/downloads/ubc_colour_guide.pdf)\n#'\n#' @keywords internal\n#' @noRd\nubcCol <- c(\n ubcBlue = \"#002145\",\n blue2 = \"#0055B7\",\n blue3 = \"#00A7E1\",\n blue4 = \"#40B4E5\",\n blue5 = \"#6EC4E8\",\n blue6 = \"#97D4E9\"\n)\n\n# U Toronto ----\n#' U Toronto Colors\n#'\n#' `torontoCol`: U Toronto color palette (https://trademarks.utoronto.ca/colors-fonts/)\n#'\n#' @keywords internal\n#' @noRd\ntorontoCol <- c(\n blue = \"#002043\",\n red = \"#bb133e\"\n)\n\n# McGill ----\n#' McGill Colors\n#'\n#' `mcgillCol`: McGill color palette (https://www.mcgill.ca/visual-identity/visual-identity-guide)\n#'\n#' @keywords internal\n#' @noRd\nmcgillCol <- c(\n mcgillRed = \"#ED1B2F\",\n grey = \"#5D6770\",\n pastelOrange = \"#FFD794\",\n brightOrange = \"#F7941D\",\n mutedOrange = \"#D3674A\",\n darkOrange = \"#AA4B31\",\n pastelYellow = \"#FFF193\",\n brightYellow = \"#FFD400\",\n mutedYellow = \"#E8B92E\",\n darkYellow = \"#B28C35\",\n pastelTeal = \"#B5E1E1\",\n brightTeal = \"#27BDBE\",\n mutedTeal = \"#087F8C\",\n darkTeal = \"#0A6266\",\n pastelBlue = \"#C8EAF5\",\n brightBlue = \"#44C8F5\",\n mutedBlue = \"#0096C9\",\n darkBlue = \"#024F6D\",\n pastelGreen = \"#D5E6A8\",\n brightGreen = \"#B2D235\",\n mutedGreen = \"#8BA04E\",\n darkGreen = \"#305534\",\n pastelPink = \"#E2A7CC\",\n brightPink = \"#C768A9\",\n mutedPink = \"#9B5678\",\n darkPink = \"#673567\",\n darkRed = \"#9E0918\"\n)\n\n# ETH ----\n#' ETH Colours\n#'\n#' `ethCol`: ETH color palette (https://ethz.ch/services/en/service/communication/corporate-design/colour.html)\n#'\n#' @keywords internal\n#' @noRd\nethCol <- c(\n eth1 = \"#1F407A\",\n eth2 = \"#3C5A0F\",\n eth3 = \"#0069B4\",\n eth4 = \"#72791C\",\n eth5 = \"#91056A\",\n eth6 = \"#6F6F6E\",\n eth7 = \"#A8322D\",\n eth8 = \"#007A92\",\n eth9 = \"#956013\",\n eth10 = \"#82BE1E\"\n)\n\n# RWTH Aachen ----\n#' RWTH Aachen Colours\n#'\n#' `rwthCol`: RWTH Aachen color palette (http://www9.rwth-aachen.de/global/show_document.asp?id=aaaaaaaaaadpbhq)\n#'\n#' @keywords internal\n#' @noRd\nrwthCol <- c(\n blau1 = \"#00549F\",\n blau2 = \"#407FB7\",\n blau3 = \"#8EBAE5\",\n blau4 = \"#C7DDF2\",\n blau5 = \"#E8F1FA\",\n magenta1 = \"#E30066\",\n magenta2 = \"#E96088\",\n magenta3 = \"#F19EB1\",\n magenta4 = \"#F9D2DA\",\n magenta5 = \"#FDEEF0\",\n gelb1 = \"#FFED00\",\n gelb2 = \"#FFF055\",\n gelb3 = \"#FFF59B\",\n gelb4 = \"#FFFAD1\",\n gelb5 = \"#FFFDEE\",\n petrol1 = \"#006165\",\n petrol2 = \"#2D7F83\",\n petrol3 = \"#7DA4A7\",\n petrol4 = \"#BFD0D1\",\n petrol5 = \"#E6ECEC\",\n tuerkis1 = \"#0098A1\",\n tuerkis2 = \"#00B1B7\",\n tuerkis3 = \"#89CCCF\",\n tuerkis4 = \"#CAE7E7\",\n tuerkis5 = \"#EBF6F6\",\n gruen1 = \"#57AB27\",\n gruen2 = \"#8DC060\",\n gruen3 = \"#B8D698\",\n gruen4 = \"#DDEBCE\",\n gruen5 = \"#F2F7EC\",\n maigruen1 = \"#BDCD00\",\n maigruen2 = \"#D0D95C\",\n maigruen3 = \"#E0E69A\",\n maigruen4 = \"#F0F3D0\",\n maigruen5 = \"#F9FAED\",\n orange1 = \"#F6A800\",\n orange2 = \"#FABE50\",\n orange3 = \"#FDD48F\",\n orange4 = \"#FEEAC9\",\n orange5 = \"#FFF7EA\",\n rot1 = \"#CC071E\",\n rot2 = \"#D85C41\",\n rot3 = \"#E69679\",\n rot4 = \"#F3CDBB\",\n rot5 = \"#FAEBE3\",\n bordeaux1 = \"#A11035\",\n bordeaux2 = \"#B65256\",\n bordeaux3 = \"#CD8B87\",\n bordeaux4 = \"#E5C5C0\",\n bordeaux5 = \"#F5E8E5\",\n violett1 = \"#612158\",\n violett2 = \"#834E75\",\n violett3 = \"#A8859E\",\n violett4 = \"#D2C0CD\",\n violett5 = \"#EDE5EA\",\n lila1 = \"#7A6FAC\",\n lila2 = \"#9B91C1\",\n lila3 = \"#BCB5D7\",\n lila4 = \"#DEDAEB\",\n lila5 = \"#F2F0F7\"\n)\n\n# Mozilla ----\n#' Mozilla Colors\n#'\n#' `mozillaCol`: Mozilla design colors\n#' (https://mozilla.design/mozilla/color/)\n#'\n#' @keywords internal\n#' @noRd\nmozillaCol <- c(\n neonBlue = \"#00ffff\",\n lemonYellow = \"#fff44f\",\n warmRed = \"#ff4f5e\",\n neonGreen = \"#54ffbd\",\n darkPurple = \"#6e008b\",\n darkGreen = \"#005e5e\",\n darkBlue = \"#00458b\",\n lightGrey = \"#e7e5e2\"\n)\n\n# Firefox ----\n#' Firefox Colors\n#'\n#' `firefoxCol`: Firefox design colors\n#' (https://mozilla.design/firefox/color/)\n#'\n#' @keywords internal\n#' @noRd\nfirefoxCol <- c(\n Green = \"#53FEBE\",\n Blue = \"#0290EE\",\n Purple = \"#AC71FF\",\n Light_Purple = \"#D64CF1\",\n Magenta = \"#FE4AA3\",\n Salmon = \"#FF6A75\",\n Orange = \"#FE8A4F\",\n Yellow = \"#FFBD4F\"\n)\n\n# Apple ----\n#' Apple Colors\n#'\n#' `appleCol`: Apple Human Interface Guidelines color palette\n#' (https://developer.apple.com/design/human-interface-guidelines/ios/visual-design/color/)\n#'\n#' @keywords internal\n#' @noRd\nappleCol <- c(\n red = \"#FF3B30\",\n orange = \"#FF9500\",\n yellow = \"#FFCC00\",\n green = \"#4CD964\",\n tealBlue = \"#5AC8FA\",\n blue = \"#007AFF\",\n purple = \"#5856D6\",\n pink = \"#FF2D55\"\n)\n\n\n# Google ----\n#' Google Colors\n#'\n#' `googleCol`: Google brand palette (https://brandpalettes.com/google-colors/)\n#'\n#' @keywords internal\n#' @noRd\ngoogleCol <- c(\n blue = \"#4285F4\",\n red = \"#DB4437\",\n yellow = \"#F4B400\",\n green = \"#0F9D58\"\n)\n\n# Amazon ----\n#' Amazon Colors\n#'\n#' `amazonCol`: Amazon brand palette\n#' (https://images-na.ssl-images-amazon.com/images/G/01/AdvertisingSite/pdfs/AmazonBrandUsageGuidelines.pdf)\n#'\n#' @keywords internal\n#' @noRd\namazonCol <- c(\n orange = \"#FF9900\",\n blue = \"#146EB4\"\n)\n\n# Microsoft ----\n#' Microsoft Colors\n#'\n#' `microsoftCol`: Microsoft brand palette\n#' (https://brandcolors.net/b/microsoft)\n#'\n#' @keywords internal\n#' @noRd\nmicrosoftCol <- c(\n orange = \"#f65314\",\n green = \"#7cbb00\",\n blue = \"#00a1f1\",\n yellow = \"#ffbb00\"\n)\n\n# rtemis palettes ----\nrtCol1 <- desaturate(\n c(\n ucsfCol[[\"C3_Teal\"]],\n ucsfCol[[\"M3_Orange\"]],\n pennCol[[\"lighterRed\"]],\n pennCol[[\"lighterBlue\"]],\n pennCol[[\"lighterOrange\"]],\n pennCol[[\"lighterPurple\"]],\n ucsfCol[[\"A3_CTA_Blue\"]],\n pennCol[[\"lightestOrange\"]],\n pennCol[[\"lightestPurple\"]],\n pennCol[[\"blue\"]],\n pennCol[[\"red\"]],\n pennCol[[\"orange\"]],\n pennCol[[\"purple\"]]\n ),\n .3\n)\n\nrtCol1n <- desaturate(\n c(\n ucsfCol[[\"C3_Teal\"]],\n ucsfCol[[\"M3_Orange\"]],\n pennCol[[\"lighterBlue\"]],\n pennCol[[\"lighterRed\"]],\n pennCol[[\"lighterOrange\"]],\n pennCol[[\"lighterPurple\"]],\n pennCol[[\"lightestBlue\"]],\n ucsfCol[[\"G4\"]],\n pennCol[[\"lightestOrange\"]],\n pennCol[[\"lightestPurple\"]],\n pennCol[[\"blue\"]],\n pennCol[[\"red\"]],\n pennCol[[\"orange\"]],\n pennCol[[\"purple\"]]\n ),\n .3\n)\n\nrtCol2 <- c(\n ucsfCol[[\"C3_Teal\"]],\n ucsfCol[[\"M3_Orange\"]],\n ucsfCol[[\"H2\"]],\n ucsfCol[[\"A2\"]],\n ucsfCol[[\"C4\"]],\n ucsfCol[[\"L3_Yellow\"]],\n ucsfCol[[\"H3_Magenta\"]],\n ucsfCol[[\"A3_CTA_Blue\"]]\n)\n\nrtms <- c(\n teal = ucsfCol[[\"C3_Teal\"]],\n orange = ucsfCol[[\"M3_Orange\"]],\n red = pennCol[[\"lighterRed\"]],\n blue = pennCol[[\"lighterBlue\"]],\n lighter_teal = ucsfCol[[\"C4\"]],\n yellow = ucsfCol[[\"L3_Yellow\"]],\n magenta = ucsfCol[[\"H3_Magenta\"]],\n lighter_blue = ucsfCol[[\"A3_CTA_Blue\"]]\n) |>\n desaturate()\n\nrtcoldev <- c(\n rtemisblue = \"#80ffff\",\n rtemisbluetoo = \"#00D6FF\",\n lavender = \"#ff80ffff\",\n orange = \"#ffb200ff\"\n)\n\ngrays <- c(\n Gray10 = \"gray10\",\n Gray30 = \"gray30\",\n Gray50 = \"gray50\",\n Gray70 = \"gray70\",\n Gray90 = \"gray90\"\n)\n\n# Pantone 2022 ----\npantoneBalancingAct <- c(\n Granite_Green = \"#86A293\",\n Muted_Clay = \"#D29381\",\n Very_Peri = \"#6667AB\",\n Hawthorne_Rose = \"#884C5E\",\n Dried_Moss = \"#CCB97E\",\n Elderberry = \"#9D848E\",\n Lotus = \"#E3C1C0\",\n Burnished_Lilac = \"#C4AEB1\"\n)\n\npantoneWellspring <- c(\n Eggshell_Blue = \"#A1CAC9\",\n Celery = \"#CFBF54\",\n Dewberry = \"#8C5896\",\n Chai_tea = \"#B3832F\",\n Greenbrier = \"#48996B\",\n Very_Peri = \"#6667AB\",\n Treetop = \"#436A2F\",\n Foliage = \"#759F51\"\n)\n\npantoneAmusements <- c(\n Tawny_Orange = \"#D77E6F\",\n Very_Peri = \"#6667AB\",\n Iced_Coffee = \"#B38F6A\",\n Pink_Flambe = \"#D75078\",\n Fuchsia_Pink = \"#E288B6\",\n Paradise_Pink = \"#E9445D\",\n Cornsilk = \"#EEC272\",\n Tourmaline = \"#85A0A9\"\n)\n\n# rtemis_palettes ----\nrtemis_palettes <- list(\n ucsfCol = ucsfCol,\n pennCol = pennCol,\n imperialCol = imperialCol,\n stanfordCol = stanfordCol,\n ucdCol = ucdCol,\n berkeleyCol = berkeleyCol,\n ucscCol = ucscCol,\n ucmercedCol = ucmercedCol,\n ucsbCol = ucsbCol,\n uclaCol = uclaCol,\n ucrColor = ucrColor,\n uciCol = uciCol,\n ucsdCol = ucsdCol,\n ucCol = ucCol,\n scrippsCol = scrippsCol,\n caltechCol = caltechCol,\n cmuCol = cmuCol,\n princetonCol = princetonCol,\n columbiaCol = columbiaCol,\n yaleCol = yaleCol,\n brownCol = brownCol,\n cornellCol = cornellCol,\n hmsCol = hmsCol,\n dartmouthCol = dartmouthCol,\n usfCol = usfCol,\n uwCol = uwCol,\n jhuCol = jhuCol,\n nyuCol = nyuCol,\n washuCol = washuCol,\n chicagoCol = chicagoCol,\n pennstateCol = pennstateCol,\n msuCol = msuCol,\n michiganCol = michiganCol,\n iowaCol = iowaCol,\n texasCol = texasCol,\n techCol = techCol,\n jeffersonCol = jeffersonCol,\n hawaiiCol = hawaiiCol,\n nihCol = nihCol,\n torontoCol = torontoCol,\n mcgillCol = mcgillCol,\n uclCol = uclCol,\n oxfordCol = oxfordCol,\n nhsCol = nhsCol,\n ethCol = ethCol,\n rwthCol = rwthCol,\n firefoxCol = firefoxCol,\n mozillaCol = mozillaCol,\n appleCol = appleCol,\n googleCol = googleCol,\n amazonCol = amazonCol,\n microsoftCol = microsoftCol,\n pantoneBalancingAct = pantoneBalancingAct,\n pantoneWellspring = pantoneWellspring,\n pantoneAmusements = pantoneAmusements,\n grays = grays,\n rtCol1 = rtCol1,\n rtms = rtms\n)\n\n#' Get Color Palette\n#'\n#' `get_palette()` returns a color palette (character vector of colors).\n#' Without arguments, prints names of available color palettes.\n#' Each palette is a named list of hexadecimal color definitions which can be used with\n#' any graphics function.\n#'\n#' @param palette Character: Name of palette to return. Default = NULL: available palette\n#' names are printed and no palette is returned.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Character vector of colors for the specified palette, or invisibly returns\n#' list of available palettes if `palette = NULL`.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' # Print available palettes\n#' get_palette()\n#' # Get the Imperial palette\n#' get_palette(\"imperial\")\nget_palette <- function(palette = NULL, verbosity = 1L) {\n if (is.null(palette)) {\n if (verbosity > 0L) {\n msg(highlight(\"The following palettes are available:\"))\n print(names(rtemis_palettes))\n }\n } else {\n palette <- match.arg(\n palette,\n names(rtemis_palettes)\n )\n rtemis_palettes[[palette]]\n }\n} # /rtemis::get_palette\n\n\n# Xterm Colors ----\nXtermCol <- c(\n `Black (SYSTEM)` = \"#000000\",\n `Maroon (SYSTEM)` = \"#800000\",\n `Green (SYSTEM)` = \"#008000\",\n `Olive (SYSTEM)` = \"#808000\",\n `Navy (SYSTEM)` = \"#000080\",\n `Purple (SYSTEM)` = \"#800080\",\n `Teal (SYSTEM)` = \"#008080\",\n `Silver (SYSTEM)` = \"#c0c0c0\",\n `Grey (SYSTEM)` = \"#808080\",\n `Red (SYSTEM)` = \"#ff0000\",\n `Lime (SYSTEM)` = \"#00ff00\",\n `Yellow (SYSTEM)` = \"#ffff00\",\n `Blue (SYSTEM)` = \"#0000ff\",\n `Fuchsia (SYSTEM)` = \"#ff00ff\",\n `Aqua (SYSTEM)` = \"#00ffff\",\n `White (SYSTEM)` = \"#ffffff\",\n Grey0 = \"#000000\",\n NavyBlue = \"#00005f\",\n DarkBlue = \"#000087\",\n Blue3 = \"#0000af\",\n Blue3 = \"#0000d7\",\n Blue1 = \"#0000ff\",\n DarkGreen = \"#005f00\",\n DeepSkyBlue4 = \"#005f5f\",\n DeepSkyBlue4 = \"#005f87\",\n DeepSkyBlue4 = \"#005faf\",\n DodgerBlue3 = \"#005fd7\",\n DodgerBlue2 = \"#005fff\",\n Green4 = \"#008700\",\n SpringGreen4 = \"#00875f\",\n Turquoise4 = \"#008787\",\n DeepSkyBlue3 = \"#0087af\",\n DeepSkyBlue3 = \"#0087d7\",\n DodgerBlue1 = \"#0087ff\",\n Green3 = \"#00af00\",\n SpringGreen3 = \"#00af5f\",\n DarkCyan = \"#00af87\",\n LightSeaGreen = \"#00afaf\",\n DeepSkyBlue2 = \"#00afd7\",\n DeepSkyBlue1 = \"#00afff\",\n Green3 = \"#00d700\",\n SpringGreen3 = \"#00d75f\",\n SpringGreen2 = \"#00d787\",\n Cyan3 = \"#00d7af\",\n DarkTurquoise = \"#00d7d7\",\n Turquoise2 = \"#00d7ff\",\n Green1 = \"#00ff00\",\n SpringGreen2 = \"#00ff5f\",\n SpringGreen1 = \"#00ff87\",\n MediumSpringGreen = \"#00ffaf\",\n Cyan2 = \"#00ffd7\",\n Cyan1 = \"#00ffff\",\n DarkRed = \"#5f0000\",\n DeepPink4 = \"#5f005f\",\n Purple4 = \"#5f0087\",\n Purple4 = \"#5f00af\",\n Purple3 = \"#5f00d7\",\n BlueViolet = \"#5f00ff\",\n Orange4 = \"#5f5f00\",\n Grey37 = \"#5f5f5f\",\n MediumPurple4 = \"#5f5f87\",\n SlateBlue3 = \"#5f5faf\",\n SlateBlue3 = \"#5f5fd7\",\n RoyalBlue1 = \"#5f5fff\",\n Chartreuse4 = \"#5f8700\",\n DarkSeaGreen4 = \"#5f875f\",\n PaleTurquoise4 = \"#5f8787\",\n SteelBlue = \"#5f87af\",\n SteelBlue3 = \"#5f87d7\",\n CornflowerBlue = \"#5f87ff\",\n Chartreuse3 = \"#5faf00\",\n DarkSeaGreen4 = \"#5faf5f\",\n CadetBlue = \"#5faf87\",\n CadetBlue = \"#5fafaf\",\n SkyBlue3 = \"#5fafd7\",\n SteelBlue1 = \"#5fafff\",\n Chartreuse3 = \"#5fd700\",\n PaleGreen3 = \"#5fd75f\",\n SeaGreen3 = \"#5fd787\",\n Aquamarine3 = \"#5fd7af\",\n MediumTurquoise = \"#5fd7d7\",\n SteelBlue1 = \"#5fd7ff\",\n Chartreuse2 = \"#5fff00\",\n SeaGreen2 = \"#5fff5f\",\n SeaGreen1 = \"#5fff87\",\n SeaGreen1 = \"#5fffaf\",\n Aquamarine1 = \"#5fffd7\",\n DarkSlateGray2 = \"#5fffff\",\n DarkRed = \"#870000\",\n DeepPink4 = \"#87005f\",\n DarkMagenta = \"#870087\",\n DarkMagenta = \"#8700af\",\n DarkViolet = \"#8700d7\",\n Purple = \"#8700ff\",\n Orange4 = \"#875f00\",\n LightPink4 = \"#875f5f\",\n Plum4 = \"#875f87\",\n MediumPurple3 = \"#875faf\",\n MediumPurple3 = \"#875fd7\",\n SlateBlue1 = \"#875fff\",\n Yellow4 = \"#878700\",\n Wheat4 = \"#87875f\",\n Grey53 = \"#878787\",\n LightSlateGrey = \"#8787af\",\n MediumPurple = \"#8787d7\",\n LightSlateBlue = \"#8787ff\",\n Yellow4 = \"#87af00\",\n DarkOliveGreen3 = \"#87af5f\",\n DarkSeaGreen = \"#87af87\",\n LightSkyBlue3 = \"#87afaf\",\n LightSkyBlue3 = \"#87afd7\",\n SkyBlue2 = \"#87afff\",\n Chartreuse2 = \"#87d700\",\n DarkOliveGreen3 = \"#87d75f\",\n PaleGreen3 = \"#87d787\",\n DarkSeaGreen3 = \"#87d7af\",\n DarkSlateGray3 = \"#87d7d7\",\n SkyBlue1 = \"#87d7ff\",\n Chartreuse1 = \"#87ff00\",\n LightGreen = \"#87ff5f\",\n LightGreen = \"#87ff87\",\n PaleGreen1 = \"#87ffaf\",\n Aquamarine1 = \"#87ffd7\",\n DarkSlateGray1 = \"#87ffff\",\n Red3 = \"#af0000\",\n DeepPink4 = \"#af005f\",\n MediumVioletRed = \"#af0087\",\n Magenta3 = \"#af00af\",\n DarkViolet = \"#af00d7\",\n Purple = \"#af00ff\",\n DarkOrange3 = \"#af5f00\",\n IndianRed = \"#af5f5f\",\n HotPink3 = \"#af5f87\",\n MediumOrchid3 = \"#af5faf\",\n MediumOrchid = \"#af5fd7\",\n MediumPurple2 = \"#af5fff\",\n DarkGoldenrod = \"#af8700\",\n LightSalmon3 = \"#af875f\",\n RosyBrown = \"#af8787\",\n Grey63 = \"#af87af\",\n MediumPurple2 = \"#af87d7\",\n MediumPurple1 = \"#af87ff\",\n Gold3 = \"#afaf00\",\n DarkKhaki = \"#afaf5f\",\n NavajoWhite3 = \"#afaf87\",\n Grey69 = \"#afafaf\",\n LightSteelBlue3 = \"#afafd7\",\n LightSteelBlue = \"#afafff\",\n Yellow3 = \"#afd700\",\n DarkOliveGreen3 = \"#afd75f\",\n DarkSeaGreen3 = \"#afd787\",\n DarkSeaGreen2 = \"#afd7af\",\n LightCyan3 = \"#afd7d7\",\n LightSkyBlue1 = \"#afd7ff\",\n GreenYellow = \"#afff00\",\n DarkOliveGreen2 = \"#afff5f\",\n PaleGreen1 = \"#afff87\",\n DarkSeaGreen2 = \"#afffaf\",\n DarkSeaGreen1 = \"#afffd7\",\n PaleTurquoise1 = \"#afffff\",\n Red3 = \"#d70000\",\n DeepPink3 = \"#d7005f\",\n DeepPink3 = \"#d70087\",\n Magenta3 = \"#d700af\",\n Magenta3 = \"#d700d7\",\n Magenta2 = \"#d700ff\",\n DarkOrange3 = \"#d75f00\",\n IndianRed = \"#d75f5f\",\n HotPink3 = \"#d75f87\",\n HotPink2 = \"#d75faf\",\n Orchid = \"#d75fd7\",\n MediumOrchid1 = \"#d75fff\",\n Orange3 = \"#d78700\",\n LightSalmon3 = \"#d7875f\",\n LightPink3 = \"#d78787\",\n Pink3 = \"#d787af\",\n Plum3 = \"#d787d7\",\n Violet = \"#d787ff\",\n Gold3 = \"#d7af00\",\n LightGoldenrod3 = \"#d7af5f\",\n Tan = \"#d7af87\",\n MistyRose3 = \"#d7afaf\",\n Thistle3 = \"#d7afd7\",\n Plum2 = \"#d7afff\",\n Yellow3 = \"#d7d700\",\n Khaki3 = \"#d7d75f\",\n LightGoldenrod2 = \"#d7d787\",\n LightYellow3 = \"#d7d7af\",\n Grey84 = \"#d7d7d7\",\n LightSteelBlue1 = \"#d7d7ff\",\n Yellow2 = \"#d7ff00\",\n DarkOliveGreen1 = \"#d7ff5f\",\n DarkOliveGreen1 = \"#d7ff87\",\n DarkSeaGreen1 = \"#d7ffaf\",\n Honeydew2 = \"#d7ffd7\",\n LightCyan1 = \"#d7ffff\",\n Red1 = \"#ff0000\",\n DeepPink2 = \"#ff005f\",\n DeepPink1 = \"#ff0087\",\n DeepPink1 = \"#ff00af\",\n Magenta2 = \"#ff00d7\",\n Magenta1 = \"#ff00ff\",\n OrangeRed1 = \"#ff5f00\",\n IndianRed1 = \"#ff5f5f\",\n IndianRed1 = \"#ff5f87\",\n HotPink = \"#ff5faf\",\n HotPink = \"#ff5fd7\",\n MediumOrchid1 = \"#ff5fff\",\n DarkOrange = \"#ff8700\",\n Salmon1 = \"#ff875f\",\n LightCoral = \"#ff8787\",\n PaleVioletRed1 = \"#ff87af\",\n Orchid2 = \"#ff87d7\",\n Orchid1 = \"#ff87ff\",\n Orange1 = \"#ffaf00\",\n SandyBrown = \"#ffaf5f\",\n LightSalmon1 = \"#ffaf87\",\n LightPink1 = \"#ffafaf\",\n Pink1 = \"#ffafd7\",\n Plum1 = \"#ffafff\",\n Gold1 = \"#ffd700\",\n LightGoldenrod2 = \"#ffd75f\",\n LightGoldenrod2 = \"#ffd787\",\n NavajoWhite1 = \"#ffd7af\",\n MistyRose1 = \"#ffd7d7\",\n Thistle1 = \"#ffd7ff\",\n Yellow1 = \"#ffff00\",\n LightGoldenrod1 = \"#ffff5f\",\n Khaki1 = \"#ffff87\",\n Wheat1 = \"#ffffaf\",\n Cornsilk1 = \"#ffffd7\",\n Grey100 = \"#ffffff\",\n Grey3 = \"#080808\",\n Grey7 = \"#121212\",\n Grey11 = \"#1c1c1c\",\n Grey15 = \"#262626\",\n Grey19 = \"#303030\",\n Grey23 = \"#3a3a3a\",\n Grey27 = \"#444444\",\n Grey30 = \"#4e4e4e\",\n Grey35 = \"#585858\",\n Grey39 = \"#626262\",\n Grey42 = \"#6c6c6c\",\n Grey46 = \"#767676\",\n Grey50 = \"#808080\",\n Grey54 = \"#8a8a8a\",\n Grey58 = \"#949494\",\n Grey62 = \"#9e9e9e\",\n Grey66 = \"#a8a8a8\",\n Grey70 = \"#b2b2b2\",\n Grey74 = \"#bcbcbc\",\n Grey78 = \"#c6c6c6\",\n Grey82 = \"#d0d0d0\",\n Grey85 = \"#dadada\",\n Grey89 = \"#e4e4e4\",\n Grey93 = \"#eeeeee\"\n)\n" }, { "path": "R/utils_plot.R", "content": "# plotops.R\n# ::rtemis::\n# 2020- EDG rtemis.org\n\n#' @keywords internal\n#' @noRd\ngetlim <- function(x, axs = c(\"r\", \"i\"), axs.r.pct = .04) {\n axs <- match.arg(axs)\n\n .x <- na.exclude(x)\n .min <- min(.x)\n .max <- max(.x)\n\n if (axs == \"r\") {\n .diff <- .max - .min\n c(.min - axs.r.pct * .diff, .max + axs.r.pct * .diff)\n } else {\n c(.min, .max)\n }\n} # /rtemis::getlim\n" }, { "path": "R/utils_plotly.R", "content": "# utils_plotly\n# ::rtemis::\n# 2021- EDG rtemis.org\n\n# plotly_vline calls plotly_vline1 to create a list for one or more vertical\n# lines, to be passed to plotly::layout's shapes argument\nplotly_vline1 <- function(x, color = \"#F48024\", width = 1, dash = \"dot\") {\n list(\n type = \"line\",\n x0 = x,\n x1 = x,\n y0 = 0,\n y1 = 1,\n yref = \"paper\",\n line = list(\n color = color,\n width = width,\n dash = dash\n )\n )\n}\n\n# Calls plotly_vline1 for each x value\nplotly_vline <- function(x, color = \"#F48024\", width = 1, dash = \"dot\") {\n color <- recycle(color, x)\n width <- recycle(width, x)\n dash <- recycle(dash, x)\n mapply(\n plotly_vline1,\n x,\n color = color,\n width = width,\n dash = dash,\n SIMPLIFY = FALSE\n )\n}\n\n\n# plotly_hline calls plotly_hline1 to create a list for one or more horizontal\n# lines, to be passed to plotly::layout's shapes argument\nplotly_hline1 <- function(y, color = \"#F48024\", width = 1, dash = \"dot\") {\n list(\n type = \"line\",\n x0 = 0,\n x1 = 1,\n y0 = y,\n y1 = y,\n xref = \"paper\",\n line = list(\n color = color,\n width = width,\n dash = dash\n )\n )\n}\n\n\nplotly_hline <- function(y, color = \"#F48024\", width = 1, dash = \"dot\") {\n color <- recycle(color, y)\n width <- recycle(width, y)\n dash <- recycle(dash, y)\n mapply(\n plotly_hline1,\n y,\n color = color,\n width = width,\n dash = dash,\n SIMPLIFY = FALSE\n )\n}\n\n\n# bracket y values for boxplot htest\nbracket_y <- function(x, pad = c(.04, .05)) {\n l <- max(x) + (diff(range(x)) * pad)\n c(l, rev(l))\n}\n\n\nstarbracket_y <- function(x, pad = c(.04, .05, .09)) {\n l <- max(x) + (diff(range(x)) * pad)\n list(star = l[3], bracket = c(l[1:2], rev(l[1:2])))\n}\n\n\n# plotly shade\nplotly_shade <- function(\n plt,\n x,\n ypos,\n yneg,\n col,\n alpha = 1,\n legendgroup = NA,\n showlegend = FALSE\n) {\n plt <- plotly::add_trace(\n plt,\n x = x,\n y = ypos,\n # type = scatter.type,\n mode = \"lines\",\n line = list(color = \"transparent\"),\n legendgroup = legendgroup,\n showlegend = showlegend,\n hoverinfo = \"none\",\n inherit = FALSE\n )\n plt <- plotly::add_trace(\n plt,\n x = x,\n y = yneg,\n # type = scatter.type,\n mode = \"lines\",\n fill = \"tonexty\",\n fillcolor = plotly::toRGB(col, alpha = alpha),\n line = list(color = \"transparent\"),\n legendgroup = legendgroup,\n showlegend = showlegend,\n hoverinfo = \"none\",\n inherit = FALSE\n )\n}\n\n\n#' Export plotly plot to file\n#'\n#' @param x plotly object.\n#' @param filename Character: Filename to save the plot to.\n#' @param width Numeric: Width of the exported image in pixels.\n#' @param height Numeric: Height of the exported image in pixels.\n#' @param scale Numeric: Scale factor for the exported image.\n#' @param import_kaleido Logical: If TRUE, attempts to import kaleido for exporting plotly plots.\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return NULL\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nexport_plotly <- function(\n x,\n filename,\n width = 600,\n height = 600,\n scale = 1,\n import_kaleido = TRUE,\n verbosity = 1L\n) {\n # Import kaleido\n if (import_kaleido) {\n tryCatch(\n {\n reticulate::py_run_string(\"import kaleido\")\n cat(\"Kaleido is available for plotly exports.\\n\")\n },\n error = function(e) {\n cat(\"Installing kaleido for plotly exports...\\n\")\n reticulate::py_install(\"kaleido\")\n reticulate::py_run_string(\"import kaleido\")\n cat(\"Kaleido installed successfully.\\n\")\n }\n )\n }\n\n # Intro\n if (verbosity > 0L) {\n msgstart(\"Exporting plotly plot to \", filename, \"...\")\n }\n\n # Export to file ----\n filename <- normalizePath(filename, mustWork = FALSE)\n # Create parent directory if it doesn't exist\n parent_dir <- dirname(filename)\n if (!dir.exists(parent_dir)) {\n dir.create(parent_dir, recursive = TRUE)\n if (!dir.exists(parent_dir)) {\n cli::cli_abort(\n \"Failed to create directory {.file {parent_dir}}. Check path & permissions.\"\n )\n }\n }\n plotly::save_image(\n x,\n file = filename,\n width = width,\n height = height,\n scale = scale\n )\n\n # Check if the file was created\n if (!file.exists(filename)) {\n cli::cli_abort(\n \"Failed to save plotly plot to {.file {filename}}. Check if the file path is correct and writable.\"\n )\n } else {\n if (verbosity > 0L) {\n msgdone()\n }\n }\n} # /rtemis::export_plotly\n" }, { "path": "R/utils_print.R", "content": "# print_ops.R\n# ::rtemis::\n# 2016-23 EDG rtemis.org\n\nis_common_struct <- function(x) {\n class(x)[1] %in%\n c(\n \"numeric\",\n \"integer\",\n \"character\",\n \"logical\",\n \"factor\",\n \"Date\",\n \"POSIXct\",\n \"POSIXlt\",\n \"list\",\n \"data.frame\",\n \"matrix\",\n \"array\",\n \"table\",\n \"ts\",\n \"tbl_df\",\n \"data.table\"\n )\n}\n\n#' Pretty print list\n#'\n#' Pretty print a list (or data frame) recursively\n#'\n#' Data frames in R began life as lists\n#'\n#' @param x list or object that will be converted to a list.\n#' @param prefix Character: Optional prefix for names.\n#' @param pad Integer: Pad output with this many spaces.\n#' @param item_format Formatting function for list item names.\n#' @param maxlength Integer: Maximum length of items to show using `headdot()` before truncating with ellipsis.\n#' @param center_title Logical: If TRUE, autopad title for centering, if present.\n#' @param title Character: Optional title to print before list.\n#' @param title_newline Logical: If TRUE, print title on new line.\n#' @param newline_pre Logical: If TRUE, print newline before list.\n#' @param format_fn_rhs Formatting function for right-hand side values.\n#' @param print_class Logical: If TRUE, print abbreviated class of object.\n#' @param abbrev_class_n Integer: Number of characters to abbreviate class names to.\n#' @param print_df Logical: If TRUE, print data frame contents, otherwise print n rows and columns.\n#' @param print_S4 Logical: If TRUE, print S4 object contents, otherwise print class name.\n#' @param limit Integer: Maximum number of items to show. Use -1 for unlimited.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nprintls <- function(\n x,\n prefix = \"\",\n pad = 2L,\n item_format = bold,\n maxlength = 4L,\n center_title = TRUE,\n title = NULL,\n title_newline = TRUE,\n newline_pre = FALSE,\n format_fn_rhs = ddSci,\n print_class = TRUE,\n abbrev_class_n = 3L,\n print_df = FALSE,\n print_S4 = FALSE,\n limit = 12L\n) {\n # Arguments ----\n if (newline_pre) {\n cat(\"\\n\")\n }\n if (is.null(x)) {\n if (!is.null(title)) {\n padcat(title, pad = pad, newline = title_newline, newline_pre = FALSE)\n }\n cat(strrep(\" \", pad), \"NULL\", sep = \"\")\n } else if (length(x) == 0) {\n cat(class(x), \"of length 0.\\n\")\n } else if (is.data.frame(x) && !print_df) {\n cat(\n \"data.frame with\",\n NROW(x),\n \"rows and\",\n NCOL(x),\n \"columns.\\n\"\n )\n } else if (!is_common_struct(x)) {\n cat(\"object of class:\", class(x), \"\\n\")\n } else {\n x <- as.list(x)\n # Get class of each element\n classes_ <- sapply(x, class)\n # Remove closures that will cause error\n is_fn <- which(sapply(x, is.function))\n if (length(is_fn) > 0) {\n for (i in is_fn) {\n x[[i]] <- paste0(as.character(head(deparse(x[[i]]), n = 1L)), \"...\")\n }\n }\n # Remove NULLs\n null_index <- sapply(x, is.null)\n x[null_index] <- \"NULL\"\n xnames <- names(x)\n lhs <- max(nchar(paste0(prefix, xnames))) + pad\n if (!is.null(title)) {\n title_pad <- if (center_title) {\n max(0, lhs - round((.5 * nchar(title))) - 3)\n } else {\n 0\n }\n padcat(\n title,\n pad = title_pad,\n newline = title_newline,\n newline_pre = FALSE\n )\n } # /title\n counter <- 0L\n # Print each item up to limit items\n if (limit != -1L && length(x) > limit) {\n padcat(\n italic(gray(\n paste(\n \"Showing first\",\n limit,\n \"of\",\n length(x),\n \"items.\\n\"\n )\n )),\n pad = pad\n )\n }\n for (i in seq_along(x)) {\n counter <- counter + 1L\n if (limit != -1L && counter > limit) {\n padcat(\n italic(gray(\n paste0(\n \"...\",\n length(x) - limit,\n \" more items not shown.\\n\"\n )\n )),\n pad = pad\n )\n break\n }\n # Print item\n if (is.list(x[[i]])) {\n if (length(x[[i]]) == 0) {\n cat(paste0(\n item_format(format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n )),\n \": \",\n format_fn_rhs(\"(empty list)\"),\n \"\\n\"\n ))\n } else {\n cat(\n paste0(\n item_format(format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n )),\n \": \"\n )\n )\n if (is_common_struct(x[[i]])) {\n printls(\n x[[i]],\n pad = lhs + 2,\n newline_pre = TRUE,\n print_df = print_df\n )\n } else {\n cat(\n italic(\"object of class:\", class(x[[i]])),\n \"\\n\"\n )\n }\n }\n } else if (is.logical(x[[i]])) {\n cat(paste0(\n item_format(format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n )),\n \": \",\n if (print_class) {\n gray(paste0(\"<\", abbreviate(\"logical\", abbrev_class_n), \"> \"))\n },\n ifelse(isTRUE(x[[i]]), \"TRUE\", \"FALSE\"),\n \"\\n\"\n ))\n } else if (S7_inherits(x[[i]])) {\n cat(\n paste0(\n item_format(format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n )),\n \": \"\n ),\n \"\\n\"\n )\n # Print S7 object\n print(x[[i]], pad = lhs + 2)\n } else if (is.data.frame(x[[i]])) {\n cat(paste0(\n item_format(format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n )),\n \": \",\n if (print_class) {\n gray(paste0(\"<\", abbreviate(classes_[[i]], abbrev_class_n), \"> \"))\n },\n headdot(x[[i]], maxlength = maxlength, format_fn = format_fn_rhs),\n \"\\n\"\n ))\n } else if (isS4(x[[i]])) {\n cat(paste0(\n item_format(format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n )),\n \": \"\n ))\n # Print S4 object\n if (print_S4) {\n cat(\"\\n\")\n print(x[[i]])\n } else {\n cat(\"(S4 object of class: '\", class(x[[i]]), \"')\\n\", sep = \"\")\n }\n } else if (!is_common_struct(x[[i]])) {\n cat(paste0(\n item_format(format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n )),\n \": \",\n if (print_class) {\n gray(paste0(\"<\", abbreviate(classes_[[i]], abbrev_class_n), \"> \"))\n },\n italic(\"object of class:\", class(x[[i]])),\n \"\\n\"\n ))\n } else {\n cat(paste0(\n item_format(format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n )),\n \": \",\n if (print_class) {\n gray(paste0(\"<\", abbreviate(classes_[[i]], abbrev_class_n), \"> \"))\n },\n headdot(x[[i]], maxlength = maxlength, format_fn = format_fn_rhs),\n \"\\n\"\n ))\n }\n }\n }\n} # /rtemis::printls\n\n# printdf1\n# ::rtemis::\n# 2016 rtemis.org\n#' Print 1 x N data frame\n#'\n#' Pretty print a data frame containing 1 row of data with named columns as a vertical list\n#' of \" name : value\"\n#' \" other.name : other.value\"\n#'\n#' @param x data frame\n#' @param pad Integer: Pad output with this many spaces.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n\nprintdf1 <- function(x, pad = 2) {\n x <- as.data.frame(x)\n # df <- data.frame(Parameter = c(names(x)), Value = unlist(x), row.names = NULL)\n\n xnames <- colnames(x)\n lhs <- max(nchar(xnames)) + pad\n\n for (i in seq_len(ncol(x))) {\n cat(\n paste(format(xnames[i], width = lhs, justify = \"right\"), \":\", x[1, i]),\n \"\\n\"\n )\n }\n} # /rtemis::printdf1\n\n\n#' Show data.frame\n#'\n#' Create a pretty text representation of a data.frame.\n#'\n#' @param x data frame\n#' @param pad Integer: Pad output with this many spaces.\n#' @param spacing Integer: Number of spaces between columns.\n#' @param ddSci_dp Integer: Number of decimal places to print using [ddSci]. Default = NULL for no\n#' formatting\n#' @param transpose Logical: If TRUE, transpose `x` before printing.\n#' @param justify Character: \"right\", \"left\".\n#' @param colnames Logical: If TRUE, print column names.\n#' @param rownames Logical: If TRUE, print row names.\n#' @param colnames_formatter Format function for printing column names.\n#' @param rownames_formatter Format function for printing row names.\n#' @param newline_pre Logical: If TRUE, print a new line before printing data frame.\n#' @param newline Logical: If TRUE, print a new line after printing data frame.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nshow_df <- function(\n x,\n pad = 0L,\n spacing = 1L,\n ddSci_dp = NULL,\n transpose = FALSE,\n justify = \"right\",\n incl_colnames = TRUE,\n incl_rownames = TRUE,\n colnames_formatter = highlight,\n rownames_formatter = gray,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n\n if (transpose) {\n x <- as.data.frame(t(x))\n }\n xnames <- colnames(x)\n xrownames <- gsub(pattern = \"\\\\.\", replacement = \" \", rownames(x))\n if (!is.null(ddSci_dp)) {\n xf <- as.data.frame(matrix(ddSci(x, decimal_places = ddSci_dp), NROW(x)))\n colnames(xf) <- xnames\n rownames(xf) <- xrownames\n x <- xf\n }\n\n col_char <- sapply(seq_along(xnames), \\(i) {\n max(nchar(as.character(x[, i])), nchar(xnames[i]))\n })\n\n xrownames_spacing <- if (incl_rownames) {\n max(nchar(xrownames)) + pad\n } else {\n pad\n }\n spacer <- strrep(\" \", spacing)\n\n out <- character()\n if (incl_colnames) {\n out <- paste0(\n out,\n strrep(\" \", xrownames_spacing)\n )\n if (justify == \"left\") {\n out <- paste0(out, spacer)\n }\n for (i in seq_len(NCOL(x))) {\n out <- paste0(\n out,\n colnames_formatter(\n format(\n xnames[i],\n width = col_char[i] + spacing,\n justify = justify\n ),\n output_type = output_type\n )\n )\n }\n out <- paste0(out, \"\\n\")\n }\n\n # Row names\n if (incl_rownames) {\n for (i in seq_len(NROW(x))) {\n out <- paste0(\n out,\n rownames_formatter(\n format(\n xrownames[i],\n width = xrownames_spacing,\n justify = \"right\"\n ),\n output_type = output_type\n )\n )\n for (j in seq_len(NCOL(x))) {\n out <- paste0(\n out,\n spacer,\n paste(format(x[i, j], width = col_char[j], justify = justify))\n )\n }\n out <- paste0(out, \"\\n\")\n }\n } else {\n for (i in seq_len(NROW(x))) {\n for (j in seq_len(NCOL(x))) {\n out <- paste0(\n out,\n spacer,\n paste(format(x[i, j], width = col_char[j], justify = justify))\n )\n }\n out <- paste0(out, \"\\n\")\n }\n }\n out\n} # /rtemis::show_df\n\n\n#' Show table\n#'\n#' @param x table.\n#' @param spacing Integer: Number of spaces between columns.\n#' @param pad Integer: Pad output with this many spaces.\n#'\n#' @return Character: formatted string.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nshow_table <- function(\n x,\n spacing = 2L,\n pad = 2L,\n formatter = highlight,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n\n dim_names <- names(attr(x, \"dimnames\"))\n class_names <- attr(x, \"dimnames\")[[\"Reference\"]]\n n_classes <- NCOL(x)\n mat <- matrix(c(x), NROW(x))\n colnames(mat) <- colnames(x)\n rownames(mat) <- rownames(x)\n # Column width without spacing\n col.width <- sapply(seq_along(class_names), \\(i) {\n max(nchar(as.character(x[, i])), nchar(class_names[i]))\n })\n lhspad <- max(nchar(class_names), nchar(dim_names[1])) + spacing + pad\n # Top dimname\n formatted_dimname <- format(\n dim_names[2],\n width = lhspad + nchar(dim_names[2]),\n justify = \"right\"\n )\n out <- paste0(\n bold(formatted_dimname, output_type = output_type),\n \"\\n\"\n )\n # Left dimname\n formatted_dimname1 <- format(\n dim_names[1],\n width = lhspad - spacing,\n justify = \"right\"\n )\n out <- paste0(\n out,\n bold(formatted_dimname1, output_type = output_type),\n strrep(\" \", spacing)\n )\n\n # Column names\n # (Continue on same row as left dimname)\n for (i in seq_len(n_classes)) {\n formatted_classname <- format(\n class_names[i],\n width = col.width[i] + spacing,\n justify = \"left\"\n )\n out <- paste0(\n out,\n formatter(formatted_classname, output_type = output_type)\n )\n }\n # Add Confusion matrix excluding colnames that are already added\n out <- paste0(\n out,\n \"\\n\",\n show_df(\n mat,\n pad = lhspad - max(nchar(class_names)) - spacing,\n incl_colnames = FALSE,\n spacing = spacing,\n colnames_formatter = formatter,\n rownames_formatter = formatter,\n output_type = output_type\n )\n )\n out\n} # /rtemis::show_table\n\n#' @keywords internal\n#' @noRd\npastels <- function(x, bullet = \" -\") {\n paste(paste(bullet, x, collapse = \"\\n\"), \"\\n\")\n} # /rtemis::pastels\n\n\n#' Get first few elements of a vector with ellipsis\n#'\n#' @details\n#' Used, for example, by `repr_ls`\n#'\n#' @return Character.\n#'\n#' @keywords internal\n#' @noRd\nheaddot <- function(x, maxlength = 6L, format_fn = identity) {\n if (maxlength == -1L || length(x) < maxlength) {\n paste(format_fn(x), collapse = \", \")\n } else {\n paste0(\n paste(format_fn(head(as.vector(x), n = maxlength)), collapse = \", \"),\n \"...\"\n )\n }\n} # /rtemis::headdot\n\n\n#' Print Size\n#'\n#' Get `NCOL(x)` and \\code{NROW{x}}\n#'\n#' @param x R object (usually that inherits from matrix or data.frame)\n#' @param name Character: Name of input object\n#' @param verbosity Integer: Verbosity level.\n#' @param newline Logical: If TRUE, end with new line character.\n#'\n#' @return vector of NROW, NCOL invisibly\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' catsize(iris)\ncatsize <- function(x, name = NULL, verbosity = 1L, newline = TRUE) {\n if (inherits(x, c(\"matrix\", \"data.frame\"))) {\n .nrow <- NROW(x)\n .ncol <- NCOL(x)\n nrows <- format(.nrow, big.mark = \",\")\n ncols <- format(.ncol, big.mark = \",\")\n if (verbosity > 0L) {\n pcat(\n name,\n paste(highlight(nrows), \"x\", highlight(ncols)),\n newline = newline\n )\n }\n invisible(c(.nrow, .ncol))\n } else {\n .nels <- length(x)\n nels <- format(.nels, big.mark = \",\")\n if (verbosity > 0L) {\n cat(\n # \"There\",\n # ngettext(.nels, \"is\", \"are\"),\n name,\n highlight(nels),\n # ngettext(.nels, \"element\", \"elements\"),\n if (newline) \"\\n\"\n )\n }\n invisible(.nels)\n }\n} # /rtemis::catsize\n\n\n#' @author EDG\n#' @keywords internal\n#' @noRd\nlist2text <- function(x, sep = \": \", line = \"\\n\") {\n .names <- names(x)\n sapply(seq_along(x), \\(i) {\n paste0(.names[i], sep, x[[i]], line)\n }) |>\n paste0(collapse = \"\")\n} # /rtemis::list2text\n\n\n#' List to HTML\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nlist2html <- function(\n x,\n sep = \": \",\n col = \"#16A0AC\",\n key_weight = 100,\n value_weight = 300,\n line = \"
\"\n) {\n .names <- names(x)\n sapply(seq_along(x), \\(i) {\n paste0(\n span(.names[i], style = paste0(\"font-weight:\", key_weight, \";\")),\n sep,\n span(\n x[[i]],\n style = paste0(\"color:\", col, \"; font-weight:\", value_weight, \";\")\n ),\n line\n )\n }) |>\n paste0(collapse = \"\") |>\n htmltools::HTML()\n} # /rtemis::list2html\n\n\n#' Helper function to build padded string equivalent of padcat\n#'\n#' @param text Character: Text to pad.\n#' @param pad Integer: Number of spaces to pad.\n#' @param newline_pre Logical: If TRUE, add newline before text.\n#' @param newline Logical: If TRUE, add newline after text.\n#'\n#' @return Character: Padded string.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nshow_padded <- function(\n text,\n pad = 2L,\n newline_pre = FALSE,\n newline = FALSE\n) {\n result <- \"\"\n if (newline_pre) {\n result <- paste0(result, \"\\n\")\n }\n result <- paste0(result, strrep(\" \", pad))\n result <- paste0(result, text)\n if (newline) {\n result <- paste0(result, \"\\n\")\n }\n result\n}\n\n\n#' Show list as formatted string\n#'\n#' Works exactly like printls, but instead of printing to console with cat,\n#' it outputs a single string, formatted using mformat, so that cat(repr_ls(x))\n#' looks identical to printls(x) for any list x\n#'\n#' @param x list or object that will be converted to a list.\n#' @param prefix Character: Optional prefix for names.\n#' @param pad Integer: Pad output with this many spaces.\n#' @param item_format Formatting function for items.\n#' @param maxlength Integer: Maximum length of items to show using `headdot()` before truncating with ellipsis.\n#' @param center_title Logical: If TRUE, autopad title for centering, if present.\n#' @param title Character: Title to print before list.\n#' @param title_newline Logical: If TRUE, print title on new line.\n#' @param newline_pre Logical: If TRUE, print newline before list.\n#' @param format_fn_rhs Formatting function for right-hand side of items.\n#' @param print_class Logical: If TRUE, print abbreviated class of object.\n#' @param abbrev_class_n Integer: Number of characters to abbreviate class names to.\n#' @param print_df Logical: If TRUE, print data frame contents, otherwise print n rows and columns.\n#' @param print_S4 Logical: If TRUE, print S4 object contents, otherwise print class name.\n#' @param limit Integer: Maximum number of items to show.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted string that can be printed with cat()\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nrepr_ls <- function(\n x,\n prefix = \"\",\n pad = 2L,\n item_format = bold,\n maxlength = 4L,\n center_title = TRUE,\n title = NULL,\n title_newline = TRUE,\n newline_pre = FALSE,\n format_fn_rhs = ddSci,\n print_class = TRUE,\n abbrev_class_n = 3L,\n print_df = FALSE,\n print_S4 = FALSE,\n limit = 12L,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n\n # Initialize output string\n result <- \"\"\n\n # Arguments ----\n if (newline_pre) {\n result <- paste0(result, \"\\n\")\n }\n\n if (is.null(x)) {\n if (!is.null(title)) {\n result <- paste0(\n result,\n show_padded(title, pad = pad, newline = title_newline)\n )\n }\n result <- paste0(result, strrep(\" \", pad), \"NULL\")\n } else if (length(x) == 0) {\n result <- paste0(result, class(x)[1], \" of length 0.\\n\")\n } else if (is.data.frame(x) && !print_df) {\n result <- paste0(\n result,\n show_padded(\"(data.frame with \", pad = pad),\n NROW(x),\n \" rows and \",\n NCOL(x),\n \" columns.)\\n\"\n )\n } else if (!is_common_struct(x)) {\n result <- paste0(\n result,\n \"object of class: \",\n paste(class(x), collapse = \", \"),\n \"\\n\"\n )\n } else {\n x <- as.list(x)\n # Get class of each element\n classes_ <- sapply(x, function(el) class(el)[[1L]])\n # Deparse closures that would cause error\n is_fn <- which(sapply(x, is.function))\n if (length(is_fn) > 0) {\n for (i in is_fn) {\n x[[i]] <- paste0(as.character(head(deparse(x[[i]]), n = 1L)), \"...\")\n }\n }\n # Set NULLs to \"NULL\"\n null_index <- sapply(x, is.null)\n x[null_index] <- \"NULL\"\n xnames <- names(x)\n lhs <- max(nchar(paste0(prefix, xnames))) + pad\n\n if (!is.null(title)) {\n title_pad <- if (center_title) {\n max(0, lhs - round((.5 * nchar(title))) - 3)\n } else {\n 0\n }\n result <- paste0(\n result,\n show_padded(title, pad = title_pad, newline = title_newline)\n )\n } # /title\n\n counter <- 0L\n # Print each item up to limit items\n if (limit != -1L && length(x) > limit) {\n limit_text <- paste0(\n italic(\n gray(\n paste0(\n \"Showing first \",\n limit,\n \" of \",\n length(x),\n \" items.\\n\"\n ),\n output_type = output_type\n ),\n output_type = output_type\n )\n )\n result <- paste0(result, show_padded(limit_text, pad = pad))\n }\n\n for (i in seq_along(x)) {\n counter <- counter + 1L\n if (limit != -1L && counter > limit) {\n more_text <- paste0(\n italic(\n gray(\n paste0(\n \"...\",\n length(x) - limit,\n \" more items not shown.\\n\"\n )\n ),\n output_type = output_type\n )\n )\n result <- paste0(result, show_padded(more_text, pad = pad))\n break\n }\n\n # Print item\n if (is.list(x[[i]])) {\n if (length(x[[i]]) == 0) {\n item_text <- paste0(\n item_format(\n format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n ),\n output_type = output_type\n ),\n \": \",\n format_fn_rhs(\"(empty list)\"),\n \"\\n\"\n )\n result <- paste0(result, item_text)\n } else {\n item_text <- paste0(\n item_format(\n format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n ),\n output_type = output_type\n ),\n \": \"\n )\n result <- paste0(result, item_text)\n\n if (is_common_struct(x[[i]])) {\n sub_result <- repr_ls(\n x[[i]],\n pad = lhs + 2,\n item_format = item_format,\n newline_pre = TRUE, # important\n format_fn_rhs = format_fn_rhs,\n print_class = print_class,\n limit = limit,\n output_type = output_type\n )\n result <- paste0(result, sub_result)\n } else {\n result <- paste0(\n result,\n italic(\n paste(\n \"object of class:\",\n paste(class(x[[i]]), collapse = \", \")\n ),\n output_type = output_type\n ),\n \"\\n\"\n )\n }\n }\n } else if (is.logical(x[[i]])) {\n item_text <- paste0(\n item_format(\n format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n ),\n output_type = output_type\n ),\n \": \",\n if (print_class) {\n gray(\n paste0(\"<\", abbreviate(\"logical\", abbrev_class_n), \"> \"),\n output_type = output_type\n )\n } else {\n \"\"\n },\n ifelse(isTRUE(x[[i]]), \"TRUE\", \"FALSE\"),\n \"\\n\"\n )\n result <- paste0(result, item_text)\n } else if (S7_inherits(x[[i]])) {\n item_text <- paste0(\n item_format(\n format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n ),\n output_type = output_type\n ),\n \":\\n\" # S7 show begin on next line, otherwise must have different pad for first line (S7name) and for rest\n )\n result <- paste0(result, item_text)\n # Show S7 object: repr() must return a character string of length 1\n s7_output <- tryCatch(\n {\n repr(x[[i]], pad = lhs + 2, output_type = output_type)\n },\n error = function(e) {\n paste0(\n \"(S7 object of class: '\",\n paste(class(x[[i]]), collapse = \", \"),\n \"')\\n\"\n )\n }\n )\n result <- paste0(result, s7_output)\n } else if (is.data.frame(x[[i]])) {\n item_text <- paste0(\n item_format(\n format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n ),\n output_type = output_type\n ),\n \": \",\n if (print_class) {\n gray(\n paste0(\"<\", abbreviate(classes_[[i]], abbrev_class_n), \"> \"),\n output_type = output_type\n )\n } else {\n \"\"\n },\n headdot(x[[i]], maxlength = maxlength, format_fn = format_fn_rhs),\n \"\\n\"\n )\n result <- paste0(result, item_text)\n } else if (isS4(x[[i]])) {\n item_text <- paste0(\n item_format(\n format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n ),\n output_type = output_type\n ),\n \": \"\n )\n result <- paste0(result, item_text)\n\n # Print S4 object\n if (print_S4) {\n result <- paste0(result, \"\\n\")\n # For S4 objects, we would need to capture their print output\n # This is complex, so for now we'll just show the class\n result <- paste0(\n result,\n \"(S4 object of class: '\",\n paste(class(x[[i]]), collapse = \", \"),\n \"')\\n\"\n )\n } else {\n result <- paste0(\n result,\n \"(S4 object of class: '\",\n paste(class(x[[i]]), collapse = \", \"),\n \"')\\n\"\n )\n }\n } else if (!is_common_struct(x[[i]])) {\n item_text <- paste0(\n item_format(\n format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n ),\n output_type = output_type\n ),\n \": \",\n if (print_class) {\n gray(\n paste0(\"<\", abbreviate(classes_[[i]], abbrev_class_n), \"> \"),\n output_type = output_type\n )\n } else {\n \"\"\n },\n italic(\n paste(\n \"object of class:\",\n paste(class(x[[i]]), collapse = \", \")\n ),\n output_type = output_type\n ),\n \"\\n\"\n )\n result <- paste0(result, item_text)\n } else {\n item_text <- paste0(\n item_format(\n format(\n paste0(prefix, xnames[i]),\n width = lhs,\n justify = \"right\"\n ),\n output_type = output_type\n ),\n \": \",\n if (print_class) {\n gray(\n paste0(\"<\", abbreviate(classes_[[i]], abbrev_class_n), \"> \"),\n output_type = output_type\n )\n } else {\n \"\"\n },\n headdot(x[[i]], maxlength = maxlength, format_fn = format_fn_rhs),\n \"\\n\"\n )\n result <- paste0(result, item_text)\n }\n }\n }\n\n result\n} # /rtemis::repr_ls\n\n\n# %% inspect.class_data.frame ----\nmethod(inspect, class_data.frame) <- function(x) {\n out <- paste0(\n fmt(\"<\", col = \"#808080\"),\n fmt(class(x)[[1L]], col = highlight_col, bold = TRUE),\n fmt(\">\", col = \"#808080\"),\n \" \",\n fmt(NROW(x), bold = TRUE),\n fmt(\" x \", col = \"#808080\"),\n fmt(NCOL(x), bold = TRUE),\n \"\\n\",\n repr_ls(x, pad = 0L, print_class = TRUE, print_df = TRUE)\n )\n cat(out)\n invisible(out)\n} # /rtemis::inspect.class_data.frame\n" }, { "path": "R/utils_rt.R", "content": "# info\n# ::rtemis::\n# 2016- EDG rtemis.org\n\n#' `rtemis-internals`: `intro`\n#'\n#' Intro\n#'\n#' Starts function execution timer and opens log file.\n#' Pairs with `outro`.\n#'\n#' @keywords internal\n#' @noRd\nintro <- function(\n .message = \"\\u25b6\",\n logfile = NULL,\n call_depth = 1,\n caller = NULL,\n newline_pre = FALSE,\n use_sink = FALSE,\n verbosity = 1L\n) {\n if (!is.null(logfile)) {\n logfile <- normalizePath(logfile, mustWork = FALSE)\n outdir <- dirname(logfile)\n if (!dir.exists(outdir)) {\n dir.create(outdir, showWarnings = FALSE, recursive = TRUE)\n }\n if (use_sink) {\n sink(logfile, append = TRUE, split = verbosity > 0L)\n }\n log_to_file(\"Started.\", logfile = logfile)\n }\n start_time <- proc.time()\n if (verbosity > 0L || !is.null(logfile)) {\n if (newline_pre) {\n cat(\"\\n\")\n }\n msg(\n .message,\n call_depth = call_depth,\n sep = \"\",\n caller_id = 2,\n caller = caller\n )\n }\n invisible(start_time)\n} # /rtemis::intro\n\n\n# Function to output seconds if seconds < 60, otherwise output minutes\n#' @keywords internal\n#' @noRd\nformat_seconds <- function(seconds) {\n if (seconds < 60) {\n paste0(bold(ddSci(seconds)), \" seconds\")\n } else {\n paste0(bold(ddSci(round(seconds / 60))), \" minutes\")\n }\n}\n\n\n#' `rtemis-internals`: `outro`\n#'\n#' Outro\n#'\n#' Stops function execution timer and closes log file.\n#'\n#' Second part to `intro`\n#'\n#' @keywords internal\n#' @noRd\noutro <- function(\n start_time,\n message = NULL,\n sink_off = FALSE,\n logfile = NULL,\n newline_pre = FALSE,\n real_user_system = FALSE,\n verbosity = 1L\n) {\n elapsed <- as.numeric(proc.time() - start_time)\n if (verbosity > 0L || sink_off) {\n if (newline_pre) {\n cat(\"\\n\")\n }\n if (real_user_system) {\n msg0(\n paste0(\n checkmark(),\n \" Done in \",\n format_seconds(elapsed[3]),\n \" (\",\n \"Real:\",\n ddSci(elapsed[3]),\n \"/User:\",\n ddSci(elapsed[1]),\n \"/System:\",\n ddSci(elapsed[2]),\n \").\"\n ),\n caller_id = 2\n )\n } else {\n msg0(\n paste0(\n checkmark(),\n \" Done in \",\n format_seconds(elapsed[3]),\n \".\"\n ),\n caller_id = 2\n )\n }\n }\n\n if (sink_off) {\n sink()\n }\n if (!is.null(logfile)) {\n log_to_file(\"Done.\", logfile = logfile)\n }\n invisible(elapsed)\n} # /rtemis::outro\n\n\n#' Summarize supervised inputs\n#'\n#' @param x tabular data: Training set data.\n#' @param dat_validation data.frame or similar: Validation set data.\n#' @param dat_test data.frame or similar: Test set data.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nsummarize_supervised <- function(\n x,\n dat_validation = NULL,\n dat_test = NULL\n) {\n # msg(\"Input data summary:\")\n msg0(\n if (!is.null(dat_validation)) \" \",\n \"Training set: \",\n highlight(NROW(x)),\n \" cases x \",\n highlight(NCOL(x) - 1),\n \" features.\"\n )\n if (!is.null(dat_validation)) {\n msg0(\n \"Validation set: \",\n highlight(NROW(dat_validation)),\n \" cases x \",\n highlight(NCOL(dat_validation) - 1),\n \" features.\"\n )\n }\n if (!is.null(dat_test)) {\n msg0(\n if (!is.null(dat_validation)) \" \",\n \" Test set: \",\n highlight(NROW(dat_test)),\n \" cases x \",\n highlight(NCOL(dat_test) - 1),\n \" features.\"\n )\n }\n} # /rtemis::summarize_supervised\n\n\n#' Summarize unsupervised inputs\n#'\n#' @param x tabular data: Training set data.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nsummarize_unsupervised <- function(x) {\n msg(\n \"Input:\",\n highlight(NROW(x)),\n \"cases x\",\n highlight(NCOL(x)),\n \"features.\"\n )\n} # /rtemis::summarize_unsupervised\n\n\n#' Log to file\n#'\n#' @param x Character: Message to log.\n#' @param logfile Character: Path to log file.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nlog_to_file <- function(x, logfile) {\n cat(\n paste0(\n datetime(),\n \" \",\n x,\n \"\\n\"\n ),\n file = logfile,\n append = TRUE\n )\n} # /rtemis::log_to_file\n" }, { "path": "R/utils_rules.R", "content": "# utils_rules.R\n# ::rtemis::\n# EDG rtemis.org\n\n#' Match Rules to Cases\n#'\n#' @param x Matrix / data frame: Input features\n#' @param rules Character vector: Rules\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return cases-by-rules matrix (binary; 1: match, 0: no match)\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nmatch_cases_by_rules <- function(x, rules, prefix = \"Rule_\", verbosity = 1L) {\n n_cases <- NROW(x)\n n_rules <- length(rules)\n if (!is.data.table(x)) {\n # {data.table}\n x <- data.table::as.data.table(x)\n } else {\n # Either make copy, or set ID to NULL before exit\n # x <- copy(x)\n on.exit(x[, ID := NULL])\n }\n # appease R CMD check\n ID <- NULL\n x[, ID := seq_len(n_cases)]\n cxr <- matrix(0, n_cases, n_rules)\n if (verbosity > 0L) {\n msgstart(\n \"Matching\",\n highlight(n_rules),\n \"rules to\",\n highlight(n_cases),\n \"cases...\"\n )\n }\n for (i in seq_along(rules)) {\n match <- x[eval(parse(text = rules[i])), ID]\n cxr[match, i] <- 1\n }\n if (!is.null(prefix)) {\n colnames(cxr) <- paste0(prefix, seq_len(n_rules))\n }\n if (verbosity > 0L) {\n msgdone()\n }\n cxr\n} # /rtemis::match_cases_by_rules\n\n\n#' Index cases by rules\n#'\n#' Get an index of which cases match which rule - meant for cases where each case matches one rule\n#' and one rule only\n#'\n#' @inheritParams match_cases_by_rules\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nindex_cases_by_rules <- function(x, rules, verbosity = 1L) {\n cxr <- match_cases_by_rules(x, rules, verbosity)\n apply(cxr, 1, \\(i) which(i == 1))\n}\n\n\n#' Prune a rule to a maximum length\n#'\n#' @param rule Character: A rule.\n#' @param max_length Integer: The maximum number of conditions to keep.\n#' @param sep Character: The separator between conditions.\n#'\n#' @return Character: The pruned rule.\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nsimple_prune_ <- function(rule, max_length, sep = \" & \") {\n conditions <- strsplit(rule, sep)[[1]]\n if (length(conditions) > max_length) {\n conditions <- conditions[1:max_length]\n paste(conditions, collapse = sep)\n } else {\n rule\n }\n} # /rtemis::simple_prune_\n\n\n#' Prune rules to a maximum length\n#'\n#' @param rule Character vector: Rules.\n#' @param max_length Integer: The maximum number of conditions to keep.\n#' @param sep Character: The separator between conditions.\n#'\n#' @return Character: The pruned rule.\n#'\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nsimple_prune <- function(rules, max_length, sep = \" & \") {\n rules <- sapply(\n rules,\n simple_prune_,\n max_length = max_length,\n sep = sep,\n USE.NAMES = FALSE\n )\n rules\n} # /rtemis::simple_prune\n\n\n#' Extract variable names from rules\n#'\n#' @param rules Character vector: Rules.\n#' @param unique Logical: If TRUE, return only unique variables.\n#'\n#' @return Character vector: Variable names.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nget_vars_from_rules <- function(rules, unique = FALSE) {\n # Extract variables from rules\n vars <- unique(unlist(strsplit(rules, \" & \")))\n # Get string up to first \"<\", \">\", \"=\", \"!\", or \"%in%\"\n vars <- gsub(\"(<|>|=|!|%in%).*\", \"\", vars)\n vars <- gsub(\" .*\", \"\", vars)\n if (unique) {\n vars <- unique(vars)\n }\n vars\n} # /rtemis::get_vars_from_rules\n\n#' Format rules\n#'\n#' Converts R-executable logical expressions to a more human-friendly format\n#'\n#' @param x Vector, string: Logical expressions\n#' @param space_after_comma Logical: If TRUE, place spaces after commas.\n#' @param decimal_places Integer: Limit all floats (numbers of the form 9.9) to this many\n#' decimal places\n#'\n#' @return Character vector: Formatted rules.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nformat_rules <- function(x, space_after_comma = FALSE, decimal_places = NULL) {\n x <- gsub(\"[&+]\", \"AND\", x)\n x <- gsub(\">\", \" > \", x)\n x <- gsub(\"<=\", \" <= \", x)\n x <- gsub(\"%in%\", \"IN\", x)\n x <- gsub(\"c\\\\(\", \"{\", x)\n x <- gsub(\"\\\\)\", \"}\", x)\n x <- gsub(\"'\", \"\", x)\n if (space_after_comma) {\n x <- gsub(\",\", \", \", x)\n }\n if (!is.null(decimal_places)) {\n x <- gsubfn::gsubfn(\n \"([0-9.]+[0-9])\",\n function(i) ddSci(i, decimal_places = decimal_places),\n x,\n engine = \"R\"\n )\n }\n x\n} # /rtemis::format_rules\n\n\n#' Format LightRuleFit rules\n#'\n#' Converts R-executable logical expressions to a more human-friendly format\n#'\n#' @param x Vector, string: Logical expressions\n#' @param space_after_comma Logical: If TRUE, place spaces after commas.\n#' @param decimal_places Integer: Limit all floats (numbers of the form 9.9) to this many\n#' decimal places\n#'\n#' @return Character vector: Formatted rules.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nformat_LightRuleFit_rules <- function(\n x,\n space_after_comma = FALSE,\n decimal_places = NULL\n) {\n x <- gsub(\"[&+]\", \"AND\", x)\n x <- gsub(\">\", \" > \", x)\n x <- gsub(\"<=\", \" <= \", x)\n x <- gsub(\"%in%\", \"IN\", x)\n x <- gsub(\"%notin%\", \"NOT IN\", x)\n x <- gsub(\"c\\\\(\", \"{\", x)\n x <- gsub(\"\\\\)\", \"}\", x)\n x <- gsub(\"'\", \"\", x)\n if (space_after_comma) {\n x <- gsub(\",\", \", \", x)\n }\n if (!is.null(decimal_places)) {\n x <- gsubfn::gsubfn(\n \"([0-9.]+[0-9])\",\n function(i) ddSci(i, decimal_places = decimal_places),\n x,\n engine = \"R\"\n )\n }\n gsub(\" \", \" \", x)\n} # /rtemis::format_LightRuleFit_rules\n\n\n# rules2medmod\n# ::rtemis::\n# 2018 EDG rtemis.org\n\n#' Convert rules from cutoffs to median/mode and range\n#'\n#' Convert rules from cutoffs to `median (range)` and `mode (range)` format\n#'\n#' @param rules Character, vector: Input rules\n#' @param x Data frame: Data to evaluate rules\n#' @param .ddSci Logical: If TRUE, format all continuous variables using\n#' [ddSci], which will give either 2 decimal places, or scientific\n#' notation if two decimal places result in 0.00\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return Character vector.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nrules2medmod <- function(rules, x, .ddSci = TRUE, verbosity = 1L) {\n cxr <- match_cases_by_rules(x, rules, verbosity = verbosity)\n nrules <- length(rules)\n rules_f <- vector(\"character\", nrules)\n frmt <- if (.ddSci) ddSci else I\n if (verbosity > 0L) {\n msg(\"Converting rules...\")\n }\n for (i in seq(rules)) {\n if (verbosity > 1L) {\n msg_info(\"#\", i, \"/\", nrules, \"...\")\n }\n dat <- x[cxr[, i] == 1, ]\n sub <- strsplit(rules[i], \"&\")[[1]]\n rule <- character()\n for (j in seq(sub)) {\n categorical <- grepl(\"%in%\", sub[j])\n if (categorical) {\n var <- gsub(\"\\\\s\", \"\", strsplit(sub[j], \"%in%\")[[1]][1])\n vals <- dat[[var]]\n value <- paste0(\n get_mode(vals),\n \" (\",\n paste(levels(droplevels(vals)), collapse = \", \"),\n \")\"\n )\n rule[j] <- paste0(var, \" = \", value)\n } else {\n sub[j] <- gsub(\">|>=|<|<=\", \"@\", sub[j])\n var <- gsub(\"\\\\s\", \"\", strsplit(sub[j], \"@\")[[1]][1])\n vals <- dat[[var]]\n value <- paste0(\n frmt(median(vals)),\n \" (\",\n frmt(min(vals)),\n \":\",\n frmt(max(vals)),\n \")\"\n )\n rule[j] <- paste0(var, \" = \", value)\n }\n } # /loop through each rule's conditions\n # This consolidates conditions like a > 3 & a > 5 to one\n rules_f[i] <- paste(unique(rule), collapse = \" & \")\n } # /loop through rules\n\n if (verbosity > 0L) {\n msg(\"Done\")\n }\n rules_f\n} # /rtemis::rules2medmod\n" }, { "path": "R/utils_strings.R", "content": "# strng.R\n# ::rtemis::\n# 2022 EDG rtemis.org\n\n# General hilite function output bold + any color.\nhilite <- function(\n ...,\n col = highlight_col,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n if (output_type == \"ansi\") {\n paste0(\"\\033[1;38;5;\", col, \"m\", paste(...), \"\\033[0m\")\n } else if (output_type == \"html\") {\n paste0(\n \"\",\n paste(...),\n \"\"\n )\n } else {\n paste0(...)\n }\n} # /rtemis::hilite\n\n\n#' @param x Numeric: Input\n#'\n#' @keywords internal\n#' @noRd\nhighlightbig <- function(x, output_type = c(\"ansi\", \"html\", \"plain\")) {\n highlight(\n format(x, scientific = FALSE, big.mark = \",\"),\n output_type = output_type\n )\n}\n\n\n#' Red\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nred <- function(..., bold = FALSE, output_type = c(\"ansi\", \"html\", \"plain\")) {\n fmt(\n paste(...),\n col = rt_red,\n bold = bold,\n output_type = output_type\n )\n}\n\n\n#' Green\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\ngreen <- function(..., bold = FALSE, output_type = c(\"ansi\", \"html\", \"plain\")) {\n fmt(\n paste(...),\n col = rt_green,\n bold = bold,\n output_type = output_type\n )\n}\n\n\n#' Blue\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nblue <- function(..., bold = FALSE, output_type = c(\"ansi\", \"html\", \"plain\")) {\n fmt(\n paste(...),\n col = rt_blue,\n bold = bold,\n output_type = output_type\n )\n}\n\n\n#' Orange\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\norange <- function(\n ...,\n bold = FALSE,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n fmt(\n paste(...),\n col = rt_orange,\n bold = bold,\n output_type = output_type\n )\n}\n\n\n#' Reset ANSI formatting\n#'\n#' @param ... Optional character: Text to be output to console.\n#'\n#' @return Character: Text with ANSI reset code prepended.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nreset <- function(...) {\n paste0(\"\\033[0m\", paste(...))\n}\n\n\n#' Get rtemis citation\n#'\n#' @return Character: Citation command.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nrtcitation <- paste0(\n \"> \",\n fmt(\"citation\", col = rt_blue),\n \"(\",\n fmt(\"rtemis\", col = rt_teal),\n \")\"\n)\n\n\ncheckmark <- function(\n col = rt_green,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n fmt(\"\\u2713\", col = col, bold = TRUE, output_type = output_type)\n}\n\ncrossmark <- function(output_type = c(\"ansi\", \"html\", \"plain\")) {\n fmt(\"\\u2715\", col = rt_red, bold = TRUE, output_type = output_type)\n}\n\n\n#' Success message\n#'\n#' @param ... Character: Message components.\n#' @param sep Character: Separator between message components.\n#' @param end Character: End character.\n#' @param pad Integer: Number of spaces to pad the message with.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nyay <- function(..., sep = \" \", end = \"\\n\", pad = 0) {\n message(\n strrep(\" \", pad),\n paste(checkmark(), ..., sep = sep),\n end,\n appendLF = FALSE\n )\n} # /rtemis::yay\n\n\n#' Failure message\n#'\n#' @param ... Character: Message components.\n#' @param sep Character: Separator between message components.\n#' @param end Character: End character.\n#' @param pad Integer: Number of spaces to pad the message with.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nnay <- function(..., sep = \" \", end = \"\\n\", pad = 0) {\n message(\n strrep(\" \", pad),\n paste(crossmark(), ..., sep = sep),\n end,\n appendLF = FALSE\n )\n} # /rtemis::nay\n\n\n#' Format text for label printing\n#'\n#' @param x Character: Input\n#' @param underscores_to_spaces Logical: If TRUE, convert underscores to spaces.\n#' @param dotsToSpaces Logical: If TRUE, convert dots to spaces.\n#' @param toLower Logical: If TRUE, convert to lowercase (precedes `toTitleCase`).\n#' Default = FALSE (Good for getting all-caps words converted to title case, bad for abbreviations\n#' you want to keep all-caps)\n#' @param toTitleCase Logical: If TRUE, convert to Title Case. Default = TRUE (This does not change\n#' all-caps words, set `toLower` to TRUE if desired)\n#' @param capitalize_strings Character, vector: Always capitalize these strings, if present. Default = `\"id\"`\n#' @param stringsToSpaces Character, vector: Replace these strings with spaces. Escape as needed for `gsub`.\n#' Default = `\"\\\\$\"`, which formats common input of the type `data.frame$variable`\n#'\n#' @return Character vector.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- c(\"county_name\", \"total.cost$\", \"age\", \"weight.kg\")\n#' labelify(x)\nlabelify <- function(\n x,\n underscores_to_spaces = TRUE,\n dotsToSpaces = TRUE,\n toLower = FALSE,\n toTitleCase = TRUE,\n capitalize_strings = c(\"id\"),\n stringsToSpaces = c(\"\\\\$\", \"`\")\n) {\n if (is.null(x)) {\n return(NULL)\n }\n xf <- x\n for (i in stringsToSpaces) {\n xf <- gsub(i, \" \", xf)\n }\n for (i in capitalize_strings) {\n xf <- gsub(paste0(\"^\", i, \"$\"), toupper(i), xf, ignore.case = TRUE)\n }\n if (underscores_to_spaces) {\n xf <- gsub(\"_\", \" \", xf)\n }\n if (dotsToSpaces) {\n xf <- gsub(\"\\\\.\", \" \", xf)\n }\n if (toLower) {\n xf <- tolower(xf)\n }\n if (toTitleCase) {\n xf <- tools::toTitleCase(xf)\n }\n xf <- gsub(\" {2,}\", \" \", xf)\n xf <- gsub(\" $\", \"\", xf)\n\n # Remove [[X]], where X is any length of characters or numbers\n gsub(\"\\\\[\\\\[.*\\\\]\\\\]\", \"\", xf)\n} # /rtemis::labelify\n\n\n#' Clean names\n#'\n#' Clean character vector by replacing all symbols and sequences of symbols with single\n#' underscores, ensuring no name begins or ends with a symbol\n#'\n#' @param x Character vector.\n#' @param sep Character: Separator to replace symbols with.\n#' @param prefix_digits Character: prefix to add to names beginning with a\n#' digit. Set to NA to skip.\n#'\n#' @return Character vector.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' x <- c(\"Patient ID\", \"_Date-of-Birth\", \"SBP (mmHg)\")\n#' x\n#' clean_names(x)\n#' clean_names(x, sep = \" \")\nclean_names <- function(x, sep = \"_\", prefix_digits = \"V_\") {\n xc <- gsub(\"[^[:alnum:]]{1,}\", sep, x)\n xc <- gsub(paste0(\"^\", sep, \"+|\", sep, \"+$\"), \"\", xc)\n if (!is.na(prefix_digits)) {\n sn_idi <- grep(\"^[0-9]\", xc)\n xc[sn_idi] <- paste0(prefix_digits, xc[sn_idi])\n }\n xc\n} # /rtemis::clean_names\n\n\n#' Clean column names\n#'\n#' Clean column names by replacing all spaces and punctuation with a single underscore\n#'\n#' @param x Character vector OR any object with `colnames()` method, like matrix, data.frame,\n#' data.table, tibble, etc.\n#' @param lowercase Logical: If TRUE, convert to lowercase.\n#' @param uppercase Logical: If TRUE, convert to uppercase.\n#' @param titlecase Logical: If TRUE, convert to Title Case.\n#'\n#' @return Character vector with cleaned names.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' clean_colnames(iris, lowercase = FALSE, uppercase = FALSE, titlecase = FALSE)\nclean_colnames <- function(\n x,\n lowercase = FALSE,\n uppercase = FALSE,\n titlecase = FALSE\n) {\n # Check arguments: only one of lowercase, uppercase, or titlecase can be TRUE\n if (sum(c(lowercase, uppercase, titlecase)) > 1) {\n cli::cli_abort(\n \"Only one of {.arg lowercase}, {.arg uppercase}, or {.arg titlecase} can be TRUE.\"\n )\n }\n if (!inherits(x, \"character\")) {\n x <- colnames(x)\n }\n if (lowercase) {\n clean_names(tolower(x))\n } else if (uppercase) {\n clean_names(toupper(x))\n } else if (titlecase) {\n gsub(\" \", \"_\", tools::toTitleCase(clean_names(x, sep = \" \")))\n } else {\n clean_names(x)\n }\n} # /rtemis::clean_colnames\n\n\n#' Force plain text when using `message()`\n#'\n#' @param x Character: Text to be output to console.\n#'\n#' @return Character: Text with ANSI escape codes removed.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nplain <- function(x) {\n paste0(\"\\033[0m\", x)\n}\n\n\n#' Oxford comma\n#'\n#' @param ... Character vector: Items to be combined.\n#' @param format_fn Function: Any function to be applied to each item.\n#'\n#' @return Character: Formatted string with oxford comma.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\noxfordcomma <- function(..., format_fn = identity) {\n x <- unlist(list(...))\n if (length(x) > 2) {\n paste0(\n paste(sapply(x[-length(x)], format_fn), collapse = \", \"),\n \", and \",\n format_fn(x[length(x)])\n )\n } else if (length(x) == 2) {\n paste(format_fn(x), collapse = \" and \")\n } else {\n format_fn(x)\n }\n} # /rtemis::oxfordcomma\n\n\n#' Show S7 class name\n#'\n#' @param x Character: S7 class name.\n#' @param col Color: Color code for the object name.\n#' @param pad Integer: Number of spaces to pad the message with.\n#' @param prefix Character: Prefix to add to the object name.\n#' @param output_type Character {\"ansi\", \"html\", or \"plain\"}: Output type.\n#'\n#' @return Character: Formatted string that can be printed with cat().\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' repr_S7name(\"Supervised\") |> cat()\nrepr_S7name <- function(\n x,\n col = col_object,\n bold = TRUE,\n underline = FALSE,\n pad = 0L,\n prefix = NULL,\n output_type = NULL\n) {\n output_type <- get_output_type(output_type)\n\n if (S7_inherits(x)) {\n x <- S7_class(x)@name\n }\n\n paste0(\n strrep(\" \", pad),\n fmt(\"<\", col = highlight_col, output_type = output_type),\n if (!is.null(prefix)) {\n fmt(\n prefix,\n col = col_object,\n bold = bold,\n underline = underline,\n output_type = output_type\n )\n },\n fmt(\n x,\n col = col,\n bold = bold,\n underline = underline,\n output_type = output_type\n ),\n fmt(\">\", col = highlight_col, output_type = output_type),\n \"\\n\"\n )\n} # /rtemis::repr_S7name\n\n\n#' Cat object\n#'\n#' @param x Character: Object description\n#' @param col Character: Color code for the object name\n#' @param pad Integer: Number of spaces to pad the message with.\n#' @param verbosity Integer: Verbosity level. If > 1, adds package name to the output.\n#' @param type Character: Output type (\"ansi\", \"html\", \"plain\")\n#'\n#' @return NULL: Prints the formatted object description to the console.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nobjcat <- function(\n x,\n col = col_object,\n pad = 0L,\n prefix = NULL,\n output_type = c(\"ansi\", \"html\", \"plain\")\n) {\n output_type <- match.arg(output_type)\n\n out <- repr_S7name(\n x,\n col = col,\n pad = pad,\n prefix = prefix,\n output_type = output_type\n )\n cat(out)\n} # /rtemis::objcat\n\n\n#' Function to label\n#'\n#' Create axis label from function definition and variable name\n#'\n#' @param fn Function.\n#' @param varname Character: Variable name.\n#'\n#' @return Character: Label.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nfn2label <- function(fn, varname) {\n # Get function body\n fn_body <- deparse(fn)[2]\n # Replace \"x\" with variable name\n sub(\"\\\\(x\\\\)\", paste0(\"(\", varname, \")\"), fn_body)\n} # /rtemis::fn2label\n\n\n#' Padded cat\n#'\n#' @param x Character: Text to be output to console.\n#' @param format_fn Function: Any function to be applied to `x`.\n#' @param col Color: Any color fn.\n#' @param newline_pre Logical: If TRUE, start with a new line.\n#' @param newline Logical: If TRUE, end with a new (empty) line.\n#' @param pad Integer: Pad message with this many spaces on the left.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\npadcat <- function(\n x,\n format_fn = I,\n col = NULL,\n newline_pre = FALSE,\n newline = FALSE,\n pad = 2L\n) {\n x <- as.character(x)\n if (!is.null(format_fn)) {\n x <- format_fn(x)\n }\n if (newline_pre) {\n cat(\"\\n\")\n }\n cat(strrep(\" \", pad))\n if (!is.null(col)) {\n cat(col(x, TRUE))\n } else {\n cat(bold(x))\n }\n if (newline) {\n cat(\"\\n\")\n }\n} # /rtemis::padcat\n\n\n#' Pad string to target length\n#'\n#' @param x Character: String to pad.\n#' @param target Integer: Target length.\n#' @param char Character: Padding character.\n#'\n#' @return Character: Padded string.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\npad_string <- function(x, target = 17L, char = \" \") {\n lpad <- max(0, target - max(0, nchar(x)))\n paste0(\n strrep(char, lpad),\n x\n )\n} # /rtemis::pad_string\n\n\n#' Pad left string to target length and print with right string\n#'\n#' @return Called for side effect: prints padded left string and right string.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' {\n#' pcat(\"super\", \"wow\")\n#' pcat(NULL, \"oooo\")\n#' }\npcat <- function(left, right, target = 17, newline = TRUE) {\n cat(pad_string(left, target = target), right)\n if (newline) cat(\"\\n\")\n}\n\n\n#' Paste tables\n#'\n#' Collapses the contents of two tables element-wise with a separator\n#' Table names are kept if same, otherwise also collapsed with separator\n#'\n#' @param left table: Left table.\n#' @param right table: Right table.\n#' @param sep Character: Separator between tables' values.\n#'\n#' @return table: Table with collapsed values and names.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\npaste_tables <- function(left, right, sep = \"=>\") {\n # Check inputs are tables\n if (!inherits(left, \"table\") || !inherits(right, \"table\")) {\n cli::cli_abort(c(\n \"x\" = \"Both {.arg left} and {.arg right} must be {.cls table} objects.\",\n \"i\" = \"Got: {.cls {class(left)}} and {.cls {class(right)}}.\"\n ))\n }\n\n # Check dimensions match\n if (!identical(dim(left), dim(right))) {\n cli::cli_abort(c(\n \"x\" = \"Tables must have matching dimensions.\",\n \"i\" = \"Got dimensions: {dim(left)} and {dim(right)}.\"\n ))\n }\n\n # Paste values element-wise\n values <- paste(as.vector(left), as.vector(right), sep = sep)\n\n # Handle dimnames\n left_names <- dimnames(left)\n right_names <- dimnames(right)\n\n if (identical(left_names, right_names)) {\n # Keep names if identical\n result_names <- left_names\n } else {\n # Paste names element-wise if different\n result_names <- mapply(\n function(l, r) {\n if (identical(l, r)) l else paste(l, r, sep = sep)\n },\n left_names,\n right_names,\n SIMPLIFY = FALSE\n )\n }\n\n # Create result table\n result <- array(values, dim = dim(left), dimnames = result_names)\n class(result) <- \"table\"\n result\n} # /rtemis::paste_tables\n\n\n#' Paste data frames\n#'\n#' Collapses the contents of two data frames element-wise with a separator\n#' Column names and row names are kept if same, otherwise also collapsed with separator\n#'\n#' @param left data.frame: Left data frame.\n#' @param right data.frame: Right data frame.\n#' @param sep Character: Separator between data frames' values.\n#'\n#' @return data.frame: Data frame with collapsed values and names.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\npaste_dfs <- function(left, right, sep = \"=>\", decimal_places = 2L) {\n # Check inputs are data frames\n if (!inherits(left, \"data.frame\") || !inherits(right, \"data.frame\")) {\n cli::cli_abort(c(\n \"x\" = \"Both {.arg left} and {.arg right} must be {.cls data.frame} objects.\",\n \"i\" = \"Got: {.cls {class(left)}} and {.cls {class(right)}}.\"\n ))\n }\n\n # Check dimensions match\n if (!identical(dim(left), dim(right))) {\n cli::cli_abort(c(\n \"x\" = \"Data frames must have matching dimensions.\",\n \"i\" = \"Got dimensions: {dim(left)} and {dim(right)}.\"\n ))\n }\n\n # Paste values element-wise for each column\n result <- mapply(\n function(l, r) {\n paste(\n ddSci(l, decimal_places = decimal_places),\n ddSci(r, decimal_places = decimal_places),\n sep = sep\n )\n },\n left,\n right,\n SIMPLIFY = FALSE\n )\n\n # Handle column names\n left_colnames <- colnames(left)\n right_colnames <- colnames(right)\n\n if (identical(left_colnames, right_colnames)) {\n result_colnames <- left_colnames\n } else {\n result_colnames <- paste(left_colnames, right_colnames, sep = sep)\n }\n\n # Handle row names\n left_rownames <- rownames(left)\n right_rownames <- rownames(right)\n\n if (identical(left_rownames, right_rownames)) {\n result_rownames <- left_rownames\n } else {\n result_rownames <- paste(left_rownames, right_rownames, sep = sep)\n }\n\n # Create result data frame\n result_df <- as.data.frame(result, stringsAsFactors = FALSE)\n colnames(result_df) <- result_colnames\n rownames(result_df) <- result_rownames\n result_df\n} # /rtemis::paste_dfs\n" }, { "path": "R/utils_supervised.R", "content": "# super_ops.R\n# ::rtemis::\n# 2024- EDG rtemis.org\n\nsupervised_type <- function(dat) {\n if (is.factor(outcome(dat))) {\n \"Classification\"\n } else {\n \"Regression\"\n }\n} # /rtemis::supervised_type\n\n#' Convert probabilities to categorical (factor)\n#'\n#' @param x Numeric vector: Probabilities\n#' @param levels Character vector: Class labels\n#' @param binclasspos Integer: Index of the positive class for binary classification\n#'\n#' @return Factor\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' # Binary classification where \"A\" is the positive class, so .1 => B, .5 & .9 => A\n#' prob2categorical(c(.1, .5, .9), c(\"A\", \"B\"), 1)\n#' # Binary classification where \"B\" is the positive class, so .1 => A, .5 & .9 => B\n#' prob2categorical(c(.1, .5, .9), c(\"A\", \"B\"), 2)\n#' # Multi-class classification\n#' prob <- matrix(c(.1, .3, .6, .05, .6, .35, .4, .3, .3), nrow = 3, byrow = TRUE)\n#' prob2categorical(prob, c(\"A\", \"B\", \"C\"))\nprob2categorical <- function(x, levels, binclasspos = 2L) {\n n_classes <- length(levels)\n if (n_classes == 2) {\n # Binary classification\n stopifnot(binclasspos %in% c(1, 2))\n if (binclasspos == 1L) {\n levels <- rev(levels)\n }\n fitted <- factor(\n ifelse(x >= .5, 1, 0),\n levels = c(0, 1),\n labels = levels\n )\n } else {\n # Multi-class classification\n stopifnot(length(levels) == ncol(x))\n fitted <- factor(\n apply(x, 1, which.max),\n levels = seq_len(n_classes),\n labels = levels\n )\n }\n fitted\n} # /rtemis::prob2categorical\n\n\n#' @keywords internal\n#' @noRd\ncheck_supervised_inputs <- function(x, y = NULL) {\n if (is.null(y) && NCOL(x) < 2) {\n cli::cli_abort(\"y is missing\")\n }\n}\n\n#' Move outcome to last column\n#'\n#' @param dat data.frame or similar.\n#' @param outcome_column Character: Name of outcome column.\n#'\n#' @return object of same class as `data`\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' ir <- set_outcome(iris, \"Sepal.Length\")\n#' head(ir)\nset_outcome <- function(dat, outcome_column) {\n # Get index of outcome column\n id <- grep(outcome_column, names(dat))\n # Check\n if (length(id) == 0) {\n cli::cli_abort('Column \"{outcome_column}\" not found in data.')\n }\n # Reorder columns\n # => Make S7 generic\n if (is.data.table(dat)) {\n dat[, c(setdiff(seq_len(NCOL(dat)), id), id), with = FALSE]\n } else {\n dat[, c(setdiff(seq_len(NCOL(dat)), id), id)]\n }\n} # /rtemis::set_outcome\n\n\n#' Make formula\n#'\n#' Makes a formula from a data.frame assuming the last column is the outcome\n#'\n#' @param x data.frame\n#'\n#' @return character\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\nmake_formula <- function(x, output = \"character\") {\n outcome <- names(x)[NCOL(x)]\n out <- paste(outcome, \"~ .\")\n if (output == \"formula\") {\n as.formula(out, env = parent.env(parent.frame()))\n } else {\n out\n }\n} # /rtemis::make_formula\n\n\n# glm2table.R\n# ::rtemis::\n# 2021 EDG rtemis.org\n\n#' Collect summary table from list of massGLMs with same predictors, different outcome\n#' (\"mass-y\")\n#'\n#' @param x list of [glm] models\n#' @param xnames Character, vector: names of models\n#' @param include_anova Integer vector {1, 2, 3}: Output ANOVA Type I, II, and/or III\n#' p-vals. Type I uses base R `anova()` (sequential); Types II and III use `car::Anova()`.\n#' NA to skip.\n#' @param info Logical: If TRUE, warn when values < than machine eps are replaced by\n#' machine eps\n#'\n#' @return `data.table` with glm summaries\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\n\nglm2table <- function(x, xnames = NULL, include_anova = NA, info = TRUE) {\n if (is.null(xnames)) {\n xnames <- if (!is.null(names(x))) {\n names(x)\n } else {\n paste0(\"Variable_\", seq_along(x))\n }\n }\n\n if (any(c(2L, 3L) %in% include_anova)) {\n check_dependencies(\"car\")\n }\n\n out <- data.table(\n Variable = xnames,\n do.call(\n rbind,\n c(lapply(x, function(l) {\n out <- t(coef(summary(l))[-1, , drop = FALSE])\n varnames <- gsub(\".*\\\\$\", \"\", colnames(out))\n parnames <- c(\"Coefficient_\", \"SE_\", \"t_value_\", \"p_value_\")\n out <- c(out)\n names(out) <- c(outer(parnames, varnames, paste0))\n out\n }))\n )\n )\n\n # Convert p-vals equal to 0 to machine double eps\n # eps <- .Machine[[\"double.eps\"]]\n # pvals_idc <- getnames(out, starts_with = \"p_value\")\n # # appease R CMD check:, use with = FALSE, not ..i\n # for (i in pvals_idc) {\n # lteps <- out[, i, with = FALSE] < eps\n # if (length(lteps) > 0) {\n # if (info) {\n # cli::cli_inform(\"Values < machine double eps converted to double eps\")\n # }\n # out[, i, with = FALSE][lteps] <- eps\n # }\n # }\n\n term_labels <- x[[1]] |> terms() |> attr(\"term.labels\")\n\n if (1 %in% include_anova) {\n pvals1 <- t(sapply(\n x,\n \\(i) anova(i, test = \"F\")[seq_along(term_labels), 5]\n ))\n colnames(pvals1) <- paste(\n \"p_value type I\",\n term_labels\n )\n out <- cbind(out, pvals1)\n }\n\n if (2 %in% include_anova) {\n pvals2 <- t(sapply(\n x,\n \\(i) car::Anova(i, type = 2)[seq_along(term_labels), 3]\n ))\n colnames(pvals2) <- paste(\n \"p_value type II\",\n term_labels\n )\n out <- cbind(out, pvals2)\n }\n\n if (3 %in% include_anova) {\n pvals3 <- t(sapply(\n x,\n \\(i) car::Anova(i, type = 3)[seq_along(term_labels) + 1, 3]\n ))\n colnames(pvals3) <- paste(\n \"p_value type III\",\n term_labels\n )\n out <- cbind(out, pvals3)\n }\n\n out\n} # /rtemis::glm2table\n\n\n#' Collect summary table (p-values) from list of massGAMs with same predictors,\n#' different outcome (\"massy\")\n#'\n#' @param mods list of [mgcv::gam] models.\n#' @param modnames Character, vector: names of models.\n#'\n#' @return `data.table` with GAM p-value summaries.\n#' @author EDG\n#'\n#' @keywords internal\n#' @noRd\ngam2table <- function(mods, modnames = NULL) {\n if (is.null(modnames)) {\n modnames <- if (!is.null(names(mods))) {\n names(mods)\n } else {\n paste0(\"Model_\", seq_along(mods))\n }\n }\n\n out <- data.table(\n Variable = modnames,\n do.call(\n rbind,\n c(lapply(mods, get_gam_pvals))\n )\n )\n setnames(out, names(out)[-1], paste(\"p_value\", names(out)[-1]))\n out\n} # /rtemis::gam2table\n\n\n#' Get GAM model's p-values for parametric and spline terms\n#'\n#' @keywords internal\n#' @noRd\nget_gam_pvals <- function(m, warn = TRUE) {\n eps <- .Machine[[\"double.eps\"]]\n ms <- summary(m)\n pvals <- cbind(\n # s terms\n as.data.frame(t(ms[[\"s.table\"]][, 4])),\n # p terms\n as.data.frame(t(ms[[\"p.table\"]][, 4]))[-1]\n )\n lteps <- pvals < eps\n if (any(lteps)) {\n if (warn) {\n warning(\"Values < machine double eps converted to double eps\")\n }\n pvals[lteps] <- eps\n }\n pvals\n} # rtemis::get_gam_pvals\n\n\n#' Class Imbalance\n#'\n#' Calculate class imbalance as given by:\n#' \\deqn{I = K\\cdot\\sum_{i=1}^K (n_i/N - 1/K)^2}{I = K * sum(n_i/N - 1/K)^2}\n#' where \\eqn{K} is the number of classes, and \\eqn{n_i} is the number of\n#' instances of class \\eqn{i}\n#'\n#' @param x Vector, factor: Outcome.\n#'\n#' @return Numeric.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' # iris is perfectly balanced\n#' class_imbalance(iris[[\"Species\"]])\n#' # Simulate imbalanced outcome\n#' x <- factor(sample(c(\"A\", \"B\"), size = 500L, replace = TRUE, prob = c(0.9, 0.1)))\n#' class_imbalance(x)\nclass_imbalance <- function(x) {\n if (!is.factor(x)) {\n cli::cli_abort(\"Input must be a factor\")\n }\n K <- nlevels(x)\n N <- length(x)\n freq <- as.data.frame(table(x))\n\n K * sum(sapply(seq(K), function(i) (freq[[\"Freq\"]][i] / N - 1 / K)^2))\n} # /rtemis::class_imbalance\n\n\n# expand_grid.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n#' Expand Grid\n#'\n#' Expand grid, converting NULL values to \"null\"\n#'\n#' Since the \"null\" characters in the resulting data.frame cannot be replaced to NULL,\n#' they have to be converted back to NULL as needed downstream.\n#' So make sure your data does not have cheeky character vector with \"null\" values in it that are\n#' not actually NULLs.\n#'\n#' @param x named list\n#'\n#' @return data.frame\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\n#'\n#' @examples\n#' x <- list(a = c(1, 2, 3), b = NULL, c = c(\"z\", \"v\"))\n#' expand_grid(x)\nexpand_grid <- function(x, stringsAsFactors = FALSE) {\n stopifnot(is.list(x))\n # Convert all NULL to \"null\"\n x <- lapply(x, function(e) if (is.null(e)) \"null\" else e)\n # Expand grid\n expand.grid(x, stringsAsFactors = stringsAsFactors)\n} # /expand_grid\n" }, { "path": "R/utils_uniprot.R", "content": "# uniprot_get.R\n# ::rtemis::\n# 2022 E.D. Gennatas lambdamd.org\n\n#' Get protein sequence from UniProt\n#'\n#' @param accession Character: UniProt Accession number - e.g. \"Q9UMX9\"\n#' @param baseURL Character: UniProt rest API base URL.\n#' Default = \"https://rest.uniprot.org/uniprotkb\"\n#' @param verbosity Integer: Verbosity level.\n#'\n#' @return List with three elements: Identifier, Annotation, and Sequence.\n#'\n#' @author E.D. Gennatas\n#' @export\n#'\n#' @examples\n#' \\dontrun{\n#' # This gets the sequence from uniprot.org by default\n#' mapt <- uniprot_get(\"Q9UMX9\")\n#' }\nuniprot_get <- function(\n accession,\n baseURL = \"https://rest.uniprot.org/uniprotkb\",\n verbosity = 1\n) {\n # Check types\n check_inherits(accession, \"character\")\n\n path <- paste0(baseURL, \"/\", accession, \".fasta\")\n dat <- seqinr::read.fasta(path, seqtype = \"AA\")\n Annotation <- attr(dat[[1]], \"Annot\")\n Identifier <- gsub(\" .*\", \"\", Annotation)\n if (verbosity > 0L) {\n msg(\"Got:\", highlight(Annotation))\n }\n\n list(\n Identifier = Identifier,\n Annotation = Annotation,\n Sequence = as.character(dat[[1]])\n )\n} # /rtemis::uniprot_get\n" }, { "path": "R/utils_xt.R", "content": "# xtdescribe.R\n# ::rtemis::\n# 2024 EDG\n\n#' Describe longitudinal dataset\n#'\n#' This function emulates the `xtdescribe` function in Stata.\n#'\n#' @param x data.frame: Longitudinal data with ID and time variables.\n#' @param id_col Integer: The column position of the ID variable.\n#' @param time_col Integer: The column position of the time variable.\n#' @param n_patterns Integer: The number of patterns to display.\n#'\n#' @return data.frame: Summary of participation patterns, returned invisibly.\n#'\n#' @author EDG\n#' @export\n#'\n#' @examples\n#' # Load example longitudinal dataset\n#' data(xt_example)\n#'\n#' # Describe the longitudinal structure\n#' xtdescribe(xt_example)\nxtdescribe <- function(\n x,\n id_col = 1,\n time_col = 2,\n n_patterns = 9\n) {\n id_name <- names(x)[id_col]\n time_name <- names(x)[time_col]\n # Print vec_describe of ID, with n = number of unique IDs\n id_us <- sort(unique(x[[id_name]]))\n n_ids <- length(id_us)\n time_us <- sort(unique(x[[time_name]]))\n time_min <- min(time_us)\n time_max <- max(time_us)\n leftwidth <- max(nchar(id_name), nchar(time_name))\n cat(\n pad_string(id_name, leftwidth),\n \": \",\n vec_describe(id_us),\n \" n = \",\n length(id_us),\n \"\\n\",\n sep = \"\"\n )\n cat(\n pad_string(time_name, leftwidth),\n \": \",\n vec_describe(time_us),\n \" T = \",\n length(time_us),\n \"\\n\",\n sep = \"\"\n )\n # Calculate delta for time variable\n # ?is this minimum delta?\n delta <- min(diff(time_us))\n cat(\n strrep(\" \", leftwidth),\n \" Delta (\",\n time_name,\n \") = \",\n delta,\n \" unit\\n\",\n sep = \"\"\n )\n span <- ((max(time_us) - min(time_us)) / delta) + 1\n cat(\n strrep(\" \", leftwidth),\n \" Span (\",\n time_name,\n \") = \",\n span,\n \" periods\\n\",\n sep = \"\"\n )\n # Does id * time have unique values?\n id_time_unique <- length(unique(interaction(x[[id_name]], x[[time_name]]))) ==\n nrow(x)\n uid <- if (id_time_unique) {\n \"uniquely identifies\"\n } else {\n \"does not uniquely identify\"\n }\n cat(\n strrep(\" \", leftwidth),\n \" (\",\n id_name,\n \"*\",\n time_name,\n \" \",\n uid,\n \" each observation)\\n\",\n sep = \"\"\n )\n # Distribution of T_i at min, 5%, 25%, 50%, 75%, 95%, max\n cat(\n \"\\nDistribution of T_i:\",\n \"\\tmin\\t5%\\t25%\\t50%\\t75%\\t95%\\tmax\\n\",\n sep = \"\"\n )\n id_freq <- table(x[[id_name]])\n id_freq_quant <- quantile(id_freq, c(0, 0.05, 0.25, 0.5, 0.75, 0.95, 1))\n cat(\n strrep(\" \", 20),\n \"\\t\",\n paste(id_freq_quant, collapse = \"\\t\"),\n \"\\n\",\n sep = \"\"\n )\n\n # Participation pattern by time\n # Get N IDs per time point, calculate pct of total IDs and rank\n id_time_freq <- table(x[[id_name]], x[[time_name]])\n # Insert columns of 0s for missing time points\n # id_time_freq <- cbind(id_time_freq, matrix(0, nrow = nrow(id_time_freq), ncol = span - ncol(id_time_freq)))\n # Add column names for missing time points\n missing_time_points <- setdiff(seq(time_min, time_max, by = delta), time_us)\n missing <- matrix(\n 0,\n nrow = nrow(id_time_freq),\n ncol = length(missing_time_points)\n )\n colnames(missing) <- missing_time_points\n id_time_freq <- cbind(id_time_freq, missing)\n # Re order columns by name\n id_time_freq <- id_time_freq[, order(as.numeric(colnames(id_time_freq)))]\n\n # Convert to pattern matrix by pasting all columns by row\n # id_time_freq_char <- as.matrix(id_time_freq)\n # id_time_freq_char[id_time_freq_char == 0] <- \".\"\n id_time_freq_char <- matrix(\n as.character(id_time_freq),\n nrow = nrow(id_time_freq)\n )\n id_time_freq_char[id_time_freq_char == \"0\"] <- \".\"\n id_time_freq_pattern <- apply(id_time_freq_char, 1, paste, collapse = \"\")\n id_time_freq_pattern_freq <- table(id_time_freq_pattern)\n id_time_freq_pattern_sorted <- sort(\n id_time_freq_pattern_freq,\n decreasing = TRUE\n )\n\n # Make data.frame with Frequency, Percent, Cumulative Percent of top n_patterns and rest\n pattern_summary <- data.frame(\n `Freq.` = as.numeric(id_time_freq_pattern_sorted)[seq_len(n_patterns)]\n )\n pattern_summary[[\"Percent\"]] <- round(\n (pattern_summary[[\"Freq.\"]] / n_ids) * 100,\n digits = 2\n )\n pattern_summary[[\"Cum.\"]] <- cumsum(pattern_summary[[\"Percent\"]])\n pattern_summary[[\"Pattern\"]] <- names(id_time_freq_pattern_sorted)[seq_len(\n n_patterns\n )]\n # Add Freq, Percent, Cumulative Percent of rest\n pattern_summary <- rbind(\n pattern_summary,\n data.frame(\n `Freq.` = sum(id_time_freq_pattern_sorted[-seq_len(n_patterns)]),\n Percent = round(\n (sum(id_time_freq_pattern_sorted[-seq_len(n_patterns)]) / n_ids) * 100,\n digits = 2\n ),\n `Cum.` = \"100.00\",\n Pattern = \"(other patterns)\"\n )\n )\n # Missing pattern is X for time points with data and . for time points with no data\n missing_pattern <- rep(\"X\", ncol(id_time_freq))\n missing_pattern[colSums(id_time_freq) == 0] <- \".\"\n missing_pattern <- paste(missing_pattern, collapse = \"\")\n # Add row with Total\n pattern_summary <- rbind(\n pattern_summary,\n data.frame(\n `Freq.` = n_ids,\n Percent = \"100.00\",\n `Cum.` = \"\",\n Pattern = missing_pattern\n )\n )\n\n print(pattern_summary, row.names = FALSE)\n invisible(pattern_summary)\n} # /rtemis::xtdescribe\n\n\n#' Describe vector\n#'\n#' Helper function to describe a vector by showing the first 2 and last value, separated by \"...\"\n#'\n#' @param x Vector to describe.\n#' @param sort_unique Logical: If TRUE, sort the unique values of the vector before describing.\n#'\n#' @return Character string describing the vector.\n#'\n#' @author EDG\n#' @keywords internal\n#' @noRd\nvec_describe <- function(x, sort_unique = FALSE) {\n # sort_unique defaults to FALSE since it needs to be computed already\n # within xtdescribe\n xs <- if (sort_unique) sort(unique(x)) else x\n paste(xs[1], xs[2], \"...\", xs[length(xs)], sep = \", \")\n}\n" }, { "path": "R/zzz.R", "content": "# ▄▄▄▄ ▄▄▄▄▄▄▄▄ .• ▌ ▄ ·. ▪ .▄▄ ·\n# ▀▄ █·•██ ▀▄.▀··██ ▐███▪██ ▐█ ▀.\n# ▐▀▀▀▄ ▐█.▪▐▀▀▪▄▐█ ▌▐▌▐█·▐█·▄▀▀▀█▄\n# ▐█• █ ▐█▌·▐█▄▄▌██ ██▌▐█▌▐█▌▐█▄▪▐█\n# .▀ ▀ ▀▀▀ ▀▀▀ ▀▀ █▪▀▀▀▀▀▀ ▀▀▀▀\n\n# zzz.R\n# ::rtemis::\n# 2016- EDG rtemis.org\n\n# rtemis internal environment\nlive <- new.env()\nlive[[\"parallelized_learners\"]] <- c(\n \"LightGBM\",\n \"LightRF\",\n \"LightRuleFit\",\n \"Ranger\"\n)\n# msg() sink. NULL = console output (default).\n# When set to a function, msg()/msg0()/msgstart()/msgdone() route their\n# structured output through it instead of writing to the console.\n# Used by rtemislive to forward training messages over a WebSocket.\n# See `set_msg_sink()`.\nlive[[\"msg_sink\"]] <- NULL\n\n# vars\nrtemis_version <- packageVersion(\"rtemis\")\ncores_available <- parallelly::availableCores()\ncores_to_use <- max(cores_available - 3L, 1L)\n\n# References\n# Unicode emojis: https://www.unicode.org/emoji/charts/full-emoji-list.html\n\n# Progress reporting\nsetup_progress <- function() {\n progressr::handlers(global = TRUE)\n progressr::handlers(\n progressr::handler_cli(\n format = \"{cli::pb_spin} [{pb_current}/{pb_total}] {pb_status}\",\n format_done = \"{cli::col_green(cli::symbol$tick)} Completed {pb_total} tasks\",\n show_after = 0,\n clear = FALSE\n )\n )\n}\n\n.onLoad <- function(libname, pkgname) {\n # S7\n S7::methods_register()\n # Set default options if not already set by user\n if (is.null(getOption(\"rtemis_theme\"))) {\n options(rtemis_theme = \"whitegrid\")\n }\n if (is.null(getOption(\"rtemis_palette\"))) {\n options(rtemis_palette = \"rtms\")\n }\n if (is.null(getOption(\"rtemis_font\"))) {\n options(rtemis_font = \"Helvetica\")\n }\n # setup_progress()\n}\n\n.onAttach <- function(libname, pkgname) {\n if (interactive()) {\n # setup_progress()\n vline <- paste0(\n \"\\n .:\",\n bold(pkgname),\n \" v.\",\n rtemis_version,\n \" \\U1F30A\",\n \" \",\n sessionInfo()[[2]],\n \" (\",\n cores_available,\n \" cores available)\\n \"\n )\n packageStartupMessage(paste0(\n pkglogo(),\n vline,\n fmt_gradient(\n paste0(rep(\"\\u2500\", nchar(vline) - 13L), collapse = \"\"),\n colors = c(rt_red, rt_orange, rt_red)\n ),\n bold(\"\\n Defaults\"),\n \"\\n \\u2502 \",\n gray(\"Theme: \"),\n getOption(\"rtemis_theme\", \"whitegrid\"),\n \"\\n \\u2502 \",\n gray(\"Font: \"),\n getOption(\"rtemis_font\", \"Helvetica\"),\n \"\\n \\u2514 \",\n gray(\"Palette: \"),\n getOption(\"rtemis_palette\", \"rtms\"),\n bold(\"\\n Resources\"),\n \"\\n \\u2502 \",\n gray(\"Docs:\"),\n \" https://docs.rtemis.org/r/ml\",\n \"\\n \\u2502 \",\n gray(\"Learn R:\"),\n \" https://pdsr.rtemis.org\",\n \"\\n \\u2514 \",\n gray(\"Cite: \"),\n rtcitation,\n \"\\n\\n \",\n fmt(\"PSA:\", col = rt_red, bold = TRUE),\n \" Do not throw data at algorithms. Compute responsibly!\"\n ))\n } else {\n packageStartupMessage(\n paste0(\n \" .:\",\n pkgname,\n \" \",\n rtemis_version,\n \" \\U1F30A\",\n \" \",\n sessionInfo()[[2]]\n )\n )\n }\n}\n" }, { "path": "README.md", "content": "[![CRAN status](https://www.r-pkg.org/badges/version/rtemis)](https://CRAN.R-project.org/package=rtemis)\n[![r-universe](https://rtemis-org.r-universe.dev/badges/rtemis)](https://rtemis-org.r-universe.dev/rtemis)\n[![R-CMD-check](https://github.com/rtemis-org/rtemis/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/rtemis-org/rtemis/actions/workflows/R-CMD-check.yaml)\n\n# rtemis: Advanced Machine Learning & Visualization.\n\n[![rtemis cover](https://www.rtemis.org/rtemis-cover.avif)](https://docs.rtemis.org/r/ml/)\n\nThis is the new version of the rtemis R package and remains under active development.\n\nThe new version (0.99+) features:\n\n- Backend: complete rewrite of the supervised and unsupervised learning backend using the new [**S7** class system](https://github.com/RConsortium/S7), replacing all previous use of R6 and S3 classes.\n- API: **Functional user-facing API**, to maintain a consistent, user-friendly interface.\n- Extended use of **`setup_()`** functions, to offer increased transparency of configuration options.\n- Strict **type checking** and **condition validation** throughout to minimize user error and provide highly focused error messages & suggestions.\n- Expanded transparent messaging through each step.\n\n![rtemis v1.0.0 console ascii](https://www.rtemis.org/rtemis-splash.webp)\n\n## Installation\n\n### From CRAN\n\n```{r}\npak::pak(\"rtemis\")\n```\n\nor\n\n```r\ninstall.packages(\"rtemis\")\n```\n\n### Latest version from GitHub\n\n```r\npak::pak(\"rtemis-org/rtemis\")\n```\n\n### Latest version from `r-universe`\n\n```r\npak::repo_add(myuniverse = \"https://rtemis-org.r-universe.dev\")\npak::pak(\"rtemis\")\n```\n\nor using `install.packages`:\n\n```r\ninstall.packages(\n 'rtemis',\n repos = c('https://rtemis-org.r-universe.dev', 'https://cloud.r-project.org')\n)\n```\n\n## Installation of dependencies\n\nEvery `rtemis` call that uses external packages includes a check for required dependencies and will print a message if any are missing.\n\n## Transparent messaging\n\nIt is essential to maintain transparency of operations at all times.\n`rtemis` functions often call multiple other functions, sometime recursively. The package uses a formatted messaging system to provide logging output which includes:\n\n- Timestamp\n- Message\n- Origin (function name)\n\nMost function include a `verbosity` argument to control the level of messaging output, with support for three levels:\n\n- `0`: silent\n- `1`: normal messaging\n- `2`: detailed messaging for debugging\n\n## Text formatting\n\n`rtemis` includes an automatic text formatting system, which supports:\n\n- plain text output (for output to log files)\n- ANSI colored output (for R console)\n- HTML formatted output (for Quarto documents, shiny apps, etc.)\n\n## `setup_` functions\n\nMachine learning workflows involve multiple steps, each with their own configuration options.\n\nIt is essential that a) the user has complete control over each step, while maintaining an intuitive, user-friendly interface, and b) the user input is validated immediately and before a potentially long-running operation is started.\n\nThe following `setup_` functions are available to configure each step of the workflow:\n\n- Supervised Learning: `setup_CART()`, `setup_GAM()`, etc.\n- Tuning: `setup_GridSearch()`\n- Clustering: `setup_CMeans()`, `setup_HardCL()`, etc.\n- Decomposition: `setup_NMF()`, `setup_ICA()`, etc.\n- Resampling: `setup_Resampler()`\n- Preprocessing: `setup_Preprocessor()`\n\n## Supervised Learning\n\nThe following will perform hyperparameter tuning and 10-fold cross-validation. \nIt will train `(3*3*2*5 + 1) * 25 = 2275` models total (!).\n\n```r\nmod <- train(\n dat,\n hyperparameters = setup_LightGBM(\n num_leaves = 2^(1:3),\n learning_rate = c(.001, .005, .01),\n subsample = c(.6, .9)\n ),\n outer_resampling_config = setup_Resampler(\n n_resamples = 25L,\n type = \"StratSub\"\n )\n)\n```\n\n## Clustering\n\n```r\nclust <- cluster(\n dat,\n config = setup_CMeans(k = 4L)\n)\n```\n\n## Decomposition\n\n```r\ndecomp <- decompose(\n dat,\n config = setup_ICA(k = 12L)\n)\n```\n\n## Changes from original implementation & Ongoing work\n\n### Algorithms\n\nThe original version included a long list of algorithms for supervised and unsupervised learning for testing and experimentation, many of which were rarely used.\nThe initial release of the new version focuses on a smaller set of core algorithms, that will keep growing.\n\n### Visualization\n\nThe original version included the `mplot3` family of visualization functions using base R graphics and the `dplot3` family using `plotly`.\nThe new release includes the `draw` family of functions, the evolution of the `dplot3` family.\n\n## Documentation\n\nThe documentation is available at [docs.rtemis.org/r/ml](https://docs.rtemis.org/r/ml), which includes\nwalkthroughs of main features and full API reference.\n\n## Ongoing work\n\nThere is a lot more coming - both within this package and the other packages in the rtemis framework.\n\n## rtemisalpha\n\nThe original, unmaintained version of rtemis remains available as `rtemisalpha` at [rtemis-org/rtemis-legacy](https://github.com/rtemis-org/rtemis-legacy).\n\n---\n\n© 2016–2026 E.D. Gennatas. Licensed under [GPL (>= 3)](https://www.gnu.org/licenses/gpl-3.0.html).\n\n" }, { "path": "data-raw/create_xt_example.R", "content": "# Create synthetic longitudinal dataset for xtdescribe() example\n# ::rtemis::\n# 2025 EDG\n\nset.seed(2025)\n\n# Create a small longitudinal dataset with various participation patterns\n# 10 participants measured at up to 5 time points (years 2020-2024)\n\npatient_id <- c(\n rep(1, 5), # Complete participation (all 5 time points)\n rep(2, 5), # Complete participation\n rep(3, 4), # Missing last time point\n rep(4, 4), # Missing first time point\n rep(5, 3), # Only first, middle, last\n rep(6, 2), # Only first two time points\n rep(7, 2), # Only last two time points\n rep(8, 3), # Missing 2nd and 4th time points\n rep(9, 1), # Only baseline\n rep(10, 1) # Only final time point\n)\n\nyear <- c(\n 2020:2024, # ID 1: all years\n 2020:2024, # ID 2: all years\n 2020:2023, # ID 3: missing 2024\n 2021:2024, # ID 4: missing 2020\n c(2020, 2022, 2024), # ID 5: intermittent\n 2020:2021, # ID 6: early dropout\n 2023:2024, # ID 7: late entry\n c(2020, 2022, 2024), # ID 8: intermittent\n 2020, # ID 9: baseline only\n 2024 # ID 10: final only\n)\n\n# Generate outcome variable (e.g., blood pressure)\nblood_pressure <- round(rnorm(length(patient_id), mean = 120, sd = 15), 1)\n\n# Generate treatment group\ntreatment <- rep(c(\"A\", \"B\"), length.out = length(patient_id))\n\n# Create data.frame\nxt_example <- data.frame(\n patient_id = patient_id,\n year = year,\n blood_pressure = blood_pressure,\n treatment = treatment\n)\n\n# Save to data/\nusethis::use_data(xt_example, overwrite = TRUE)\n" }, { "path": "inst/CITATION", "content": "utils::bibentry(\n header = \"To cite rtemis in publications, please use:\",\n\n # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\n # BibTeX:\n # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\n bibtype = \"PhdThesis\",\n title = \"Towards Precision Psychiatry: Gray Matter Development and Cognition in Adolescence\",\n author = \"Efstathios D. Gennatas\",\n year = \"2017\",\n school = \"University of Pennsylvania\",\n \n # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\n # Plain text:\n # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\n textVersion = \"Gennatas, E. D. (2017). Towards Precision Psychiatry: Gray Matter Development and Cognition in Adolescence (Doctoral dissertation, University of Pennsylvania).\"\n)\n" }, { "path": "inst/resources/rtemis.utf8", "content": "▄▄▄▄ ▄▄▄▄▄▄▄▄ .• ▌ ▄ ·. ▪ .▄▄ ·\n▀▄ █·•██ ▀▄.▀··██ ▐███▪██ ▐█ ▀.\n▐▀▀▀▄ ▐█.▪▐▀▀▪▄▐█ ▌▐▌▐█·▐█·▄▀▀▀█▄\n▐█• █ ▐█▌·▐█▄▄▌██ ██▌▐█▌▐█▌▐█▄▪▐█\n.▀ ▀ ▀▀▀ ▀▀▀ ▀▀ █▪▀▀▀▀▀▀ ▀▀▀▀\n" }, { "path": "inst/resources/rtemis2.utf8", "content": " ██▀███ ▄▄▄█████▓▓█████ ███▄ ▄███▓ ██▓ ██████ \n▓██ ▒ ██▒▓ ██▒ ▓▒▓█ ▀ ▓██▒▀█▀ ██▒▓██▒▒██ ▒ \n▓██ ░▄█ ▒▒ ▓██░ ▒░▒███ ▓██ █ ▓██░▒██▒░ ▓██▄ \n▒██▀▀█▄ ░ ▓██▓ ░ ▒▓█ ▄ ▒██ ░ ▒██ ░██░ ▒ ██▒\n░██▓ ▒██▒ ▒██▒ ░ ░▒████▒▒██▒ ░██▒░██░▒██████▒▒\n░ ▒▓ ░▒▓░ ▒ ░░ ░░ ▒░ ░░ ▒░ ░ ░ ░░▓ ▒ ▒▓▒ ▒ ░\n ░▒ ░ ▒░ ░ ░ ░ ░░ ░ ░ ▒ ░░ ░▒ ░ ░\n ░░ ░ ░ ░ ░ ░ ▒ ░░ ░ ░ \n ░ ░ ░ ░ ░ ░ \n" }, { "path": "man/available_algorithms.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/algorithmDB.R\n\\name{available_supervised}\n\\alias{available_supervised}\n\\alias{available_algorithms}\n\\alias{available_clustering}\n\\alias{available_decomposition}\n\\title{Available Algorithms}\n\\usage{\navailable_supervised(verbosity = 1L)\n\navailable_clustering(verbosity = 1L)\n\navailable_decomposition(verbosity = 1L)\n}\n\\arguments{\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\nNamed list of algorithm descriptions, invisibly.\n}\n\\description{\nPrint available algorithms for supervised learning, clustering, and decomposition.\n}\n\\examples{\navailable_supervised()\navailable_clustering()\navailable_decomposition()\n}\n\\author{\nEDG\n}\n" }, { "path": "man/available_draw.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/algorithmDB.R\n\\name{available_draw}\n\\alias{available_draw}\n\\title{Available Draw Functions}\n\\usage{\navailable_draw(verbosity = 1L)\n}\n\\arguments{\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\nNamed list of draw function descriptions, invisibly.\n}\n\\description{\nPrint available draw functions for visualization.\n}\n\\examples{\navailable_draw()\n}\n\\author{\nEDG\n}\n" }, { "path": "man/available_themes.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/theme.R\n\\name{available_themes}\n\\alias{available_themes}\n\\title{Print available \\pkg{rtemis} themes}\n\\usage{\navailable_themes()\n}\n\\value{\nCalled for its side effect of printing available themes.\n}\n\\description{\nPrint available \\pkg{rtemis} themes\n}\n\\examples{\navailable_themes()\n}\n\\author{\nEDG\n}\n" }, { "path": "man/calibrate.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{calibrate}\n\\alias{calibrate}\n\\title{Calibrate \\code{Classification} & \\code{ClassificationRes} Models}\n\\usage{\ncalibrate(\n x,\n algorithm = \"isotonic\",\n hyperparameters = NULL,\n verbosity = 1L,\n ...\n)\n}\n\\arguments{\n\\item{x}{\\code{Classification} or \\code{ClassificationRes} object to calibrate.}\n\n\\item{algorithm}{Character: Algorithm to use to train calibration model.}\n\n\\item{hyperparameters}{\\code{Hyperparameters} object: Setup using one of \\verb{setup_*} functions.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n\n\\item{...}{Additional arguments passed to specific methods.}\n}\n\\value{\nCalibrated model object.\n}\n\\description{\nGeneric function to calibrate binary classification models.\n}\n\\details{\nThe goal of calibration is to adjust the predicted probabilities of a binary classification\nmodel so that they better reflect the true probabilities (i.e. empirical risk) of the positive\nclass.\n}\n\\section{Method-specific parameters}{\n\n\n\\strong{For \\code{Classification} objects:}\n\\itemize{\n\\item \\code{predicted_probabilities}: Numeric vector of predicted probabilities\n\\item \\code{true_labels}: Factor of true class labels\n}\n\n\\strong{For \\code{ClassificationRes} objects:}\n\\itemize{\n\\item \\code{resampler_config}: \\code{ResamplerConfig} object for calibration training\n\\item \\code{train_verbosity}: Integer controlling calibration model training output\n}\n}\n\n\\examples{\n# --- Calibrate Classification ---\ndat <- iris[51:150, ]\nres <- resample(dat)\ndat$Species <- factor(dat$Species)\ndat_train <- dat[res[[1]], ]\ndat_test <- dat[-res[[1]], ]\n\n# Train GLM on a training/test split\nmod_c_glm <- train(\n x = dat_train,\n dat_test = dat_test,\n algorithm = \"glm\"\n)\n\n# Calibrate the `Classification` by defining `predicted_probabilities` and `true_labels`,\n# in this case using the training data, but it could be a separate calibration dataset.\nmod_c_glm_cal <- calibrate(\n mod_c_glm,\n predicted_probabilities = mod_c_glm$predicted_prob_training,\n true_labels = mod_c_glm$y_training\n)\nmod_c_glm_cal\n\n# --- Calibrate ClassificationRes ---\n\n# Train GLM with cross-validation\nresmod_c_glm <- train(\n x = dat,\n algorithm = \"glm\",\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\")\n)\n\n# Calibrate the `ClassificationRes` using the same resampling configuration as used for training.\nresmod_c_glm_cal <- calibrate(resmod_c_glm)\nresmod_c_glm_cal\n}\n\\author{\nEDG\n}\n" }, { "path": "man/check_data.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/check_data.R\n\\name{check_data}\n\\alias{check_data}\n\\title{Check Data}\n\\usage{\ncheck_data(\n x,\n name = NULL,\n get_duplicates = TRUE,\n get_na_case_pct = FALSE,\n get_na_feature_pct = FALSE\n)\n}\n\\arguments{\n\\item{x}{tabular data: Input to be checked.}\n\n\\item{name}{Character: Name of dataset.}\n\n\\item{get_duplicates}{Logical: If TRUE, check for duplicate cases.}\n\n\\item{get_na_case_pct}{Logical: If TRUE, calculate percent of NA values per\ncase.}\n\n\\item{get_na_feature_pct}{Logical: If TRUE, calculate percent of NA values\nper feature.}\n}\n\\value{\n\\code{CheckData} object.\n}\n\\description{\nCheck Data\n}\n\\examples{\nn <- 1000\nx <- rnormmat(n, 50, return_df = TRUE)\nx$char1 <- sample(letters, n, TRUE)\nx$char2 <- sample(letters, n, TRUE)\nx$fct <- factor(sample(letters, n, TRUE))\nx <- rbind(x, x[1, ])\nx$const <- 99L\nx[sample(nrow(x), 20), 3] <- NA\nx[sample(nrow(x), 20), 10] <- NA\nx$fct[30:35] <- NA\ncheck_data(x)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/choose_theme.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/theme.R\n\\name{choose_theme}\n\\alias{choose_theme}\n\\title{Select an rtemis theme}\n\\usage{\nchoose_theme(\n x = c(\"white\", \"whitegrid\", \"whiteigrid\", \"black\", \"blackgrid\", \"blackigrid\",\n \"darkgray\", \"darkgraygrid\", \"darkgrayigrid\", \"lightgraygrid\", \"mediumgraygrid\"),\n override = NULL\n)\n}\n\\arguments{\n\\item{x}{Character: Name of theme to select. If not defined, will use \\code{getOption(\"rtemis_theme\", \"whitegrid\")}.}\n\n\\item{override}{Optional List: Theme parameters to override defaults.}\n}\n\\value{\n\\code{Theme} object.\n}\n\\description{\nSelect an rtemis theme\n}\n\\details{\nIf \\code{x} is not defined, \\code{choose_theme()} will use \\code{getOption(\"rtemis_theme\", \"whitegrid\")} to\nselect the theme. This allows users to set a default theme for all rtemis plots by setting\n\\code{options(rtemis_theme = \"theme_name\")} at any point.\n}\n\\examples{\n# Get default theme set by options(rtemis_theme = \"theme_name\").\n# If not set, defaults to \"whitegrid\":\nchoose_theme()\n# Get darkgraygrid theme. Same as `theme_darkgraygrid()`:\nchoose_theme(\"darkgraygrid\")\n# This will use the default theme, and override the foreground color to red:\nchoose_theme(override = list(fg = \"#ff0000\"))\n}\n\\author{\nEDG\n}\n" }, { "path": "man/class_imbalance.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_supervised.R\n\\name{class_imbalance}\n\\alias{class_imbalance}\n\\title{Class Imbalance}\n\\usage{\nclass_imbalance(x)\n}\n\\arguments{\n\\item{x}{Vector, factor: Outcome.}\n}\n\\value{\nNumeric.\n}\n\\description{\nCalculate class imbalance as given by:\n\\deqn{I = K\\cdot\\sum_{i=1}^K (n_i/N - 1/K)^2}{I = K * sum(n_i/N - 1/K)^2}\nwhere \\eqn{K} is the number of classes, and \\eqn{n_i} is the number of\ninstances of class \\eqn{i}\n}\n\\examples{\n# iris is perfectly balanced\nclass_imbalance(iris[[\"Species\"]])\n# Simulate imbalanced outcome\nx <- factor(sample(c(\"A\", \"B\"), size = 500L, replace = TRUE, prob = c(0.9, 0.1)))\nclass_imbalance(x)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/classification_metrics.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/metrics.R\n\\name{classification_metrics}\n\\alias{classification_metrics}\n\\title{Classification Metrics}\n\\usage{\nclassification_metrics(\n true_labels,\n predicted_labels,\n predicted_prob = NULL,\n binclasspos = 2L,\n calc_auc = TRUE,\n calc_brier = TRUE,\n auc_method = \"lightAUC\",\n sample = character(),\n verbosity = 0L\n)\n}\n\\arguments{\n\\item{true_labels}{Factor: True labels.}\n\n\\item{predicted_labels}{Factor: predicted values.}\n\n\\item{predicted_prob}{Numeric vector: predicted probabilities.}\n\n\\item{binclasspos}{Integer: Factor level position of the positive class in binary classification.}\n\n\\item{calc_auc}{Logical: If TRUE, calculate AUC. May be slow in very large datasets.}\n\n\\item{calc_brier}{Logical: If TRUE, calculate Brier_Score.}\n\n\\item{auc_method}{Character: \"lightAUC\", \"pROC\", \"ROCR\".}\n\n\\item{sample}{Character: Sample name.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{ClassificationMetrics} object.\n}\n\\description{\nClassification Metrics\n}\n\\details{\nNote that auc_method = \"pROC\" is the only one that will output an AUC even if\none or more predicted probabilities are NA.\n}\n\\examples{\n# Assume positive class is \"b\"\ntrue_labels <- factor(c(\"a\", \"a\", \"a\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\"))\npredicted_labels <- factor(c(\"a\", \"b\", \"a\", \"b\", \"b\", \"a\", \"b\", \"b\", \"b\", \"a\"))\npredicted_prob <- c(0.3, 0.55, 0.45, 0.75, 0.57, 0.3, 0.8, 0.63, 0.62, 0.39)\n\nclassification_metrics(true_labels, predicted_labels, predicted_prob)\nclassification_metrics(true_labels, predicted_labels, 1 - predicted_prob, binclasspos = 1L)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/clean_colnames.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_strings.R\n\\name{clean_colnames}\n\\alias{clean_colnames}\n\\title{Clean column names}\n\\usage{\nclean_colnames(x, lowercase = FALSE, uppercase = FALSE, titlecase = FALSE)\n}\n\\arguments{\n\\item{x}{Character vector OR any object with \\code{colnames()} method, like matrix, data.frame,\ndata.table, tibble, etc.}\n\n\\item{lowercase}{Logical: If TRUE, convert to lowercase.}\n\n\\item{uppercase}{Logical: If TRUE, convert to uppercase.}\n\n\\item{titlecase}{Logical: If TRUE, convert to Title Case.}\n}\n\\value{\nCharacter vector with cleaned names.\n}\n\\description{\nClean column names by replacing all spaces and punctuation with a single underscore\n}\n\\examples{\nclean_colnames(iris, lowercase = FALSE, uppercase = FALSE, titlecase = FALSE)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/clean_names.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_strings.R\n\\name{clean_names}\n\\alias{clean_names}\n\\title{Clean names}\n\\usage{\nclean_names(x, sep = \"_\", prefix_digits = \"V_\")\n}\n\\arguments{\n\\item{x}{Character vector.}\n\n\\item{sep}{Character: Separator to replace symbols with.}\n\n\\item{prefix_digits}{Character: prefix to add to names beginning with a\ndigit. Set to NA to skip.}\n}\n\\value{\nCharacter vector.\n}\n\\description{\nClean character vector by replacing all symbols and sequences of symbols with single\nunderscores, ensuring no name begins or ends with a symbol\n}\n\\examples{\nx <- c(\"Patient ID\", \"_Date-of-Birth\", \"SBP (mmHg)\")\nx\nclean_names(x)\nclean_names(x, sep = \" \")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/cluster.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/cluster.R\n\\name{cluster}\n\\alias{cluster}\n\\title{Perform Clustering}\n\\usage{\ncluster(x, algorithm = \"KMeans\", config = NULL, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{Matrix or data.frame: Data to cluster. Rows are cases to be clustered.}\n\n\\item{algorithm}{Character: Clustering algorithm.}\n\n\\item{config}{List: Algorithm-specific config.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{Clustering} object.\n}\n\\description{\nPerform clustering on the rows (usually cases) of a dataset.\n}\n\\details{\nSee \\href{https://docs.rtemis.org/r/}{docs.rtemis.org/r} for detailed documentation.\n}\n\\examples{\niris_km <- cluster(exc(iris, \"Species\"), algorithm = \"KMeans\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/col2grayscale.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_color.R\n\\name{col2grayscale}\n\\alias{col2grayscale}\n\\title{Color to Grayscale}\n\\usage{\ncol2grayscale(x, what = c(\"color\", \"decimal\"))\n}\n\\arguments{\n\\item{x}{Color to convert to grayscale}\n\n\\item{what}{Character: \"color\" returns a hexadecimal color,\n\"decimal\" returns a decimal between 0 and 1}\n}\n\\value{\nCharacter: color hex code.\n}\n\\description{\nConvert a color to grayscale\n}\n\\details{\nUses the NTSC grayscale conversion:\n0.299 * R + 0.587 * G + 0.114 * B\n}\n\\examples{\ncol2grayscale(\"red\")\ncol2grayscale(\"red\", \"dec\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/color_adjust.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_color.R\n\\name{color_adjust}\n\\alias{color_adjust}\n\\title{Adjust HSV Color}\n\\usage{\ncolor_adjust(color, alpha = NULL, hue = 0, sat = 0, val = 0)\n}\n\\arguments{\n\\item{color}{Input color. Any format that grDevices::col2rgb() recognizes}\n\n\\item{alpha}{Numeric: Scale alpha by this amount. Future: replace with absolute setting}\n\n\\item{hue}{Float: How much hue to add to \\code{color}}\n\n\\item{sat}{Float: How much saturation to add to \\code{color}}\n\n\\item{val}{Float: How much to increase value of \\code{color} by}\n}\n\\value{\nAdjusted color\n}\n\\description{\nModify alpha, hue, saturation and value (HSV) of a color\n}\n\\examples{\npreviewcolor(c(teal = \"#00ffff\", teal50 = color_adjust(\"#00ffff\", alpha = 0.5)))\n}\n\\author{\nEDG\n}\n" }, { "path": "man/ddSci.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/ddSci.R\n\\name{ddSci}\n\\alias{ddSci}\n\\title{Format Numbers for Printing}\n\\usage{\nddSci(x, decimal_places = 2, hi = 1e+06, as_numeric = FALSE)\n}\n\\arguments{\n\\item{x}{Vector of numbers}\n\n\\item{decimal_places}{Integer: Return this many decimal places.}\n\n\\item{hi}{Float: Threshold at or above which scientific notation is used.}\n\n\\item{as_numeric}{Logical: If TRUE, convert to numeric before returning.\nThis will not force all numbers to print 2 decimal places. For example:\n1.2035 becomes \"1.20\" if \\code{as_numeric = FALSE}, but 1.2 otherwise\nThis can be helpful if you want to be able to use the output as numbers / not just for printing.}\n}\n\\value{\nFormatted number\n}\n\\description{\n2 Decimal places, otherwise scientific notation\n}\n\\details{\nNumbers will be formatted to 2 decimal places, unless this results in 0.00 (e.g. if input was .0032),\nin which case they will be converted to scientific notation with 2 significant figures.\n\\code{ddSci} will return \\code{0.00} if the input is exactly zero.\nThis function can be used to format numbers in plots, on the console, in logs, etc.\n}\n\\examples{\nx <- .34876549\nddSci(x)\n# \"0.35\"\nx <- .00000000457823\nddSci(x)\n# \"4.6e-09\"\n}\n\\author{\nEDG\n}\n" }, { "path": "man/ddb_collect.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/ddb.R\n\\name{ddb_collect}\n\\alias{ddb_collect}\n\\title{Collect a lazy-read duckdb table}\n\\usage{\nddb_collect(sql, progress = TRUE, returnobj = c(\"data.frame\", \"data.table\"))\n}\n\\arguments{\n\\item{sql}{Character: DuckDB SQL query, usually output of\n\\link{ddb_data} with \\code{collect = FALSE}}\n\n\\item{progress}{Logical: If TRUE, show progress bar}\n\n\\item{returnobj}{Character: data.frame or data.table: class of object to return}\n}\n\\value{\n\\code{data.frame} or \\code{data.table}.\n}\n\\description{\nCollect a table read with \\code{ddb_data(x, collect = FALSE)}\n}\n\\examples{\n\\dontrun{\n # Requires local CSV file; replace with your own path\n sql <- ddb_data(\"/Data/iris.csv\", collect = FALSE)\n ir <- ddb_collect(sql)\n}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/ddb_data.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/ddb.R\n\\name{ddb_data}\n\\alias{ddb_data}\n\\title{Read CSV using DuckDB}\n\\usage{\nddb_data(\n filename,\n datadir = NULL,\n sep = \",\",\n header = TRUE,\n quotechar = \"\",\n ignore_errors = TRUE,\n make_unique = TRUE,\n select_columns = NULL,\n filter_column = NULL,\n filter_vals = NULL,\n character2factor = FALSE,\n collect = TRUE,\n progress = TRUE,\n returnobj = c(\"data.table\", \"data.frame\"),\n data.table.key = NULL,\n clean_colnames = TRUE,\n verbosity = 1L\n)\n}\n\\arguments{\n\\item{filename}{Character: file name; either full path or just the file name,\nif \\code{datadir} is also provided.}\n\n\\item{datadir}{Character: Optional path if \\code{filename} is not full path.}\n\n\\item{sep}{Character: Field delimiter/separator.}\n\n\\item{header}{Logical: If TRUE, first line will be read as column names.}\n\n\\item{quotechar}{Character: Quote character.}\n\n\\item{ignore_errors}{Logical: If TRUE, ignore parsing errors (sometimes it's\neither this or no data, so).}\n\n\\item{make_unique}{Logical: If TRUE, keep only unique rows.}\n\n\\item{select_columns}{Character vector: Column names to select.}\n\n\\item{filter_column}{Character: Name of column to filter on, e.g. \"ID\".}\n\n\\item{filter_vals}{Numeric or Character vector: Values in \\code{filter_column} to keep.\n\\code{filter_column} to keep.}\n\n\\item{character2factor}{Logical: If TRUE, convert character columns to\nfactors.}\n\n\\item{collect}{Logical: If TRUE, collect data and return structure class\nas defined by \\code{returnobj}.}\n\n\\item{progress}{Logical: If TRUE, print progress (no indication this works).}\n\n\\item{returnobj}{Character: \"data.frame\" or \"data.table\" object class to\nreturn. If \"data.table\", data.frame object returned from\n\\code{DBI::dbGetQuery} is passed to \\code{data.table::setDT}; will add to\nexecution time if very large, but then that's when you need a data.table.}\n\n\\item{data.table.key}{Character: If set, this corresponds to a column name in the\ndataset. This column will be set as key in the data.table output.}\n\n\\item{clean_colnames}{Logical: If TRUE, clean colnames with\n\\link{clean_colnames}.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\ndata.frame or data.table if \\code{collect} is TRUE, otherwise a character with the SQL query\n}\n\\description{\nLazy-read a CSV file, optionally: filter rows, remove duplicates,\nclean column names, convert character to factor, collect.\n}\n\\examples{\n\\dontrun{\n # Requires local CSV file; replace with your own path\n ir <- ddb_data(\"/Data/massive_dataset.csv\",\n filter_column = \"ID\",\n filter_vals = 8001:9999\n )\n}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/decomp.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/decomp.R\n\\name{decomp}\n\\alias{decomp}\n\\title{Perform Data Decomposition}\n\\usage{\ndecomp(x, algorithm = \"ICA\", config = NULL, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{Matrix or data frame: Input data.}\n\n\\item{algorithm}{Character: Decomposition algorithm.}\n\n\\item{config}{DecompositionConfig: Algorithm-specific config.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{Decomposition} object.\n}\n\\description{\nPerform linear or non-linear decomposition of numeric data.\n}\n\\details{\nSee \\href{https://docs.rtemis.org/r/}{docs.rtemis.org/r} for detailed documentation.\n}\n\\examples{\niris_pca <- decomp(exc(iris, \"Species\"), algorithm = \"PCA\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/describe.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{describe}\n\\alias{describe}\n\\title{Describe object}\n\\usage{\ndescribe(x, ...)\n}\n\\arguments{\n\\item{x}{R object to describe. See method documentation for supported classes.}\n\n\\item{...}{Additional arguments passed to methods. See details.}\n}\n\\description{\nDescribe object\n}\n\\details{\nExtra arguments for \\code{factor} method:\n\\itemize{\n\\item \\code{max_n}: Integer: Return counts for up to this many levels.\n\\item \\code{return_ordered}: Logical: If TRUE, return levels ordered by count, otherwise return in level order.\n\\item \\code{verbosity}: Integer: Verbosity level.\n}\n}\n\\examples{\n# --- For `Supervised` objects ---\nspecies_lightrf <- train(iris, algorithm = \"lightrf\")\ndescribe(species_lightrf)\n\n# --- For `SupervisedRes` objects ---\nmod <- train(iris, algorithm = \"CART\", outer_resampling_config = setup_Resampler())\ndescribe(mod)\n\n# --- For factors ---\n# Small number of levels\ndescribe(iris[[\"Species\"]])\n\n# Large number of levels: show top n by count\nx <- factor(sample(letters, 1000, TRUE))\ndescribe(x)\ndescribe(x, 3)\ndescribe(x, 3, return_ordered = FALSE)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/df_movecolumn.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_df.R\n\\name{df_movecolumn}\n\\alias{df_movecolumn}\n\\title{Move data frame column}\n\\usage{\ndf_movecolumn(x, colname, to = ncol(x))\n}\n\\arguments{\n\\item{x}{data.frame.}\n\n\\item{colname}{Character: Name of column you want to move.}\n\n\\item{to}{Integer: Which column position to move the vector to.\nDefault = \\code{ncol(x)} i.e. the last column.}\n}\n\\value{\ndata.frame\n}\n\\description{\nMove data frame column\n}\n\\examples{\nir <- df_movecolumn(iris, colname = \"Species\", to = 1L)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/df_nunique_perfeat.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_df.R\n\\name{df_nunique_perfeat}\n\\alias{df_nunique_perfeat}\n\\title{Unique values per feature}\n\\usage{\ndf_nunique_perfeat(x, excludeNA = FALSE)\n}\n\\arguments{\n\\item{x}{matrix or data frame input}\n\n\\item{excludeNA}{Logical: If TRUE, exclude NA values from unique count.}\n}\n\\value{\nVector, integer of length \\code{NCOL(x)} with number of unique\nvalues per column/feature\n}\n\\description{\nGet number of unique values per features\n}\n\\examples{\ndf_nunique_perfeat(iris)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dot-list_to_Hyperparameters.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{.list_to_Hyperparameters}\n\\alias{.list_to_Hyperparameters}\n\\title{Convert a list to a Hyperparameters object}\n\\usage{\n.list_to_Hyperparameters(x)\n}\n\\arguments{\n\\item{x}{Named list with two elements:\n\\describe{\n\\item{\\code{algorithm}}{Character: algorithm name, e.g. \\code{\"GLM\"}, \\code{\"RF\"}.}\n\\item{\\code{hyperparameters}}{Named list of hyperparameter name-value pairs\npassed to the corresponding \\verb{setup_()} function.}\n}}\n}\n\\value{\nA \\code{Hyperparameters} object as returned by \\verb{setup_()}.\n}\n\\description{\nInternal function used by \\code{rtemis.server} to reconstruct a \\code{Hyperparameters}\nobject from a wire-format list. Not intended for direct use by end users.\n}\n\\author{\nEDG\n}\n\\keyword{internal}\n" }, { "path": "man/dot-list_to_ResamplerConfig.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/05_Resampler.R\n\\name{.list_to_ResamplerConfig}\n\\alias{.list_to_ResamplerConfig}\n\\title{Convert a list to a ResamplerConfig object}\n\\usage{\n.list_to_ResamplerConfig(x)\n}\n\\arguments{\n\\item{x}{Named list with the following elements:\n\\describe{\n\\item{\\code{type}}{Character: resampler type — one of \\code{\"KFold\"},\n\\code{\"StratSub\"}, \\code{\"StratBoot\"}, \\code{\"Bootstrap\"}, \\code{\"LOOCV\"}, \\code{\"Custom\"}.}\n\\item{\\code{n}}{Integer: number of resamples (not used for \\code{\"LOOCV\"}).}\n\\item{\\code{train_p}}{Numeric: training proportion (used by \\code{\"StratSub\"} and\n\\code{\"StratBoot\"}).}\n\\item{\\code{stratify_var}}{Character or \\code{NULL}: stratification variable name.}\n\\item{\\code{strat_n_bins}}{Integer: number of bins for stratification.}\n\\item{\\code{target_length}}{Integer or \\code{NULL}: target resample length\n(\\code{\"StratBoot\"} only).}\n\\item{\\code{id_strat}}{Character or \\code{NULL}: ID stratification variable.}\n\\item{\\code{seed}}{Integer or \\code{NULL}: random seed.}\n}}\n}\n\\value{\nA \\code{ResamplerConfig} object of the appropriate subtype.\n}\n\\description{\nInternal function used by \\code{rtemis.server} and \\code{SuperConfig} deserialization\nto reconstruct a \\code{ResamplerConfig} object from a named list. Not intended\nfor direct use by end users.\n}\n\\author{\nEDG\n}\n\\keyword{internal}\n" }, { "path": "man/dot-list_to_TunerConfig.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/06_Tuner.R\n\\name{.list_to_TunerConfig}\n\\alias{.list_to_TunerConfig}\n\\title{Convert a list to a TunerConfig object}\n\\usage{\n.list_to_TunerConfig(x)\n}\n\\arguments{\n\\item{x}{Named list with two elements:\n\\describe{\n\\item{\\code{type}}{Character: tuner type. Currently only \\code{\"GridSearch\"} is\nsupported.}\n\\item{\\code{config}}{Named list of tuner configuration fields. For\n\\code{\"GridSearch\"}: \\code{resampler_config} (a list accepted by\n\\code{\\link[=.list_to_ResamplerConfig]{.list_to_ResamplerConfig()}}), \\code{search_type}, \\code{randomize_p},\n\\code{metrics_aggregate_fn}, \\code{metric}, and \\code{maximize}.}\n}}\n}\n\\value{\nA \\code{TunerConfig} object (currently a \\code{GridSearchConfig}).\n}\n\\description{\nInternal function used by \\code{rtemis.server} and \\code{SuperConfig} deserialization\nto reconstruct a \\code{TunerConfig} object from a named list. Not intended for\ndirect use by end users.\n}\n\\author{\nEDG\n}\n\\keyword{internal}\n" }, { "path": "man/draw_3Dscatter.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_3Dscatter.R\n\\name{draw_3Dscatter}\n\\alias{draw_3Dscatter}\n\\title{Interactive 3D Scatter Plots}\n\\usage{\ndraw_3Dscatter(\n x,\n y = NULL,\n z = NULL,\n fit = NULL,\n cluster = NULL,\n cluster_config = NULL,\n group = NULL,\n formula = NULL,\n rsq = TRUE,\n mode = \"markers\",\n order_on_x = NULL,\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n zlab = NULL,\n alpha = 0.8,\n bg = NULL,\n plot_bg = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n axes_square = FALSE,\n group_names = NULL,\n font_size = 16,\n marker_col = NULL,\n marker_size = 8,\n fit_col = NULL,\n fit_alpha = 0.7,\n fit_lwd = 2.5,\n tick_font_size = 12,\n spike_col = NULL,\n legend = NULL,\n legend_xy = c(0, 1),\n legend_xanchor = \"left\",\n legend_yanchor = \"auto\",\n legend_orientation = \"v\",\n legend_col = NULL,\n legend_bg = \"#FFFFFF00\",\n legend_border_col = \"#FFFFFF00\",\n legend_borderwidth = 0,\n legend_group_gap = 0,\n margin = list(t = 30, b = 0, l = 0, r = 0),\n fit_params = NULL,\n width = NULL,\n height = NULL,\n padding = 0,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n verbosity = 0L,\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1\n)\n}\n\\arguments{\n\\item{x}{Numeric, vector/data.frame/list: x-axis data.}\n\n\\item{y}{Numeric, vector/data.frame/list: y-axis data.}\n\n\\item{z}{Numeric, vector/data.frame/list: z-axis data.}\n\n\\item{fit}{Character: Fit method.}\n\n\\item{cluster}{Character: Clustering method.}\n\n\\item{cluster_config}{List: Config for clustering.}\n\n\\item{group}{Factor: Grouping variable.}\n\n\\item{formula}{Formula: Formula for non-linear least squares fit.}\n\n\\item{rsq}{Logical: If TRUE, print R-squared values in legend if \\code{fit} is set.}\n\n\\item{mode}{Character, vector: \"markers\", \"lines\", \"markers+lines\".}\n\n\\item{order_on_x}{Logical: If TRUE, order \\code{x} and \\code{y} on \\code{x}.}\n\n\\item{main}{Character: Main title.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{zlab}{Character: z-axis label.}\n\n\\item{alpha}{Numeric: Alpha for markers.}\n\n\\item{bg}{Background color.}\n\n\\item{plot_bg}{Plot background color.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{palette}{Character vector: Colors to use.}\n\n\\item{axes_square}{Logical: If TRUE, draw a square plot.}\n\n\\item{group_names}{Character: Names for groups.}\n\n\\item{font_size}{Numeric: Font size.}\n\n\\item{marker_col}{Color for markers.}\n\n\\item{marker_size}{Numeric: Marker size.}\n\n\\item{fit_col}{Color for fit line.}\n\n\\item{fit_alpha}{Numeric: Alpha for fit line.}\n\n\\item{fit_lwd}{Numeric: Line width for fit line.}\n\n\\item{tick_font_size}{Numeric: Tick font size.}\n\n\\item{spike_col}{Spike lines color.}\n\n\\item{legend}{Logical: If TRUE, draw legend.}\n\n\\item{legend_xy}{Numeric: Position of legend.}\n\n\\item{legend_xanchor}{Character: X anchor for legend.}\n\n\\item{legend_yanchor}{Character: Y anchor for legend.}\n\n\\item{legend_orientation}{Character: Orientation of legend.}\n\n\\item{legend_col}{Color for legend text.}\n\n\\item{legend_bg}{Color for legend background.}\n\n\\item{legend_border_col}{Color for legend border.}\n\n\\item{legend_borderwidth}{Numeric: Border width for legend.}\n\n\\item{legend_group_gap}{Numeric: Gap between legend groups.}\n\n\\item{margin}{Numeric, named list: Margins for top, bottom, left, right.}\n\n\\item{fit_params}{\\code{Hyperparameters} for fit.}\n\n\\item{width}{Numeric: Width of plot.}\n\n\\item{height}{Numeric: Height of plot.}\n\n\\item{padding}{Numeric: Graph padding.}\n\n\\item{displayModeBar}{Logical: If TRUE, display mode bar.}\n\n\\item{modeBar_file_format}{Character: File format for mode bar.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n\n\\item{filename}{Character: Filename to save plot.}\n\n\\item{file_width}{Numeric: Width of saved file.}\n\n\\item{file_height}{Numeric: Height of saved file.}\n\n\\item{file_scale}{Numeric: Scale of saved file.}\n}\n\\value{\nA \\code{plotly} object.\n}\n\\description{\nDraw interactive 3D scatter plots using \\code{plotly}.\n}\n\\details{\nSee \\href{https://docs.rtemis.org/r/}{docs.rtemis.org/r} for detailed documentation.\n\nNote that \\code{draw_3Dscatter} uses the theme's \\code{plot_bg} as \\code{grid_col}.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\ndraw_3Dscatter(iris, group = iris$Species, theme = theme_darkgraygrid())\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_bar.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_bar.R\n\\name{draw_bar}\n\\alias{draw_bar}\n\\title{Interactive Barplots}\n\\usage{\ndraw_bar(\n x,\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n alpha = 1,\n horizontal = FALSE,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n barmode = c(\"group\", \"relative\", \"stack\", \"overlay\"),\n group_names = NULL,\n order_by_val = FALSE,\n ylim = NULL,\n hovernames = NULL,\n feature_names = NULL,\n font_size = 16,\n annotate = FALSE,\n annotate_col = theme[[\"labs_col\"]],\n legend = NULL,\n legend_col = NULL,\n legend_xy = c(1, 1),\n legend_orientation = \"v\",\n legend_xanchor = \"left\",\n legend_yanchor = \"auto\",\n hline = NULL,\n hline_col = NULL,\n hline_width = 1,\n hline_dash = \"solid\",\n hline_annotate = NULL,\n hline_annotation_x = 1,\n margin = list(b = 65, l = 65, t = 50, r = 10, pad = 0),\n automargin_x = TRUE,\n automargin_y = TRUE,\n padding = 0,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n verbosity = 0L\n)\n}\n\\arguments{\n\\item{x}{vector (possibly named), matrix, or data.frame: If matrix or\ndata.frame, rows are groups (can be 1 row), columns are features}\n\n\\item{main}{Character: Main plot title.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{alpha}{Float (0, 1]: Transparency for bar colors.}\n\n\\item{horizontal}{Logical: If TRUE, plot bars horizontally}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{palette}{Character vector: Colors to use.}\n\n\\item{barmode}{Character: Type of bar plot to make: \"group\", \"relative\",\n\"stack\", \"overlay\". Default = \"group\". Use\n\"relative\" for stacked bars, wich handles negative values correctly,\nunlike \"stack\", as of writing.}\n\n\\item{group_names}{Character, vector, length = NROW(x): Group names.\nDefault = NULL, which uses \\code{rownames(x)}}\n\n\\item{order_by_val}{Logical: If TRUE, order bars by increasing value.\nOnly use for single group data.}\n\n\\item{ylim}{Float, vector, length 2: y-axis limits.}\n\n\\item{hovernames}{Character, vector: Optional character vector to show on\nhover over each bar.}\n\n\\item{feature_names}{Character, vector, length = NCOL(x): Feature names.\nDefault = NULL, which uses \\code{colnames(x)}}\n\n\\item{font_size}{Float: Font size for all labels.}\n\n\\item{annotate}{Logical: If TRUE, annotate stacked bars}\n\n\\item{annotate_col}{Color for annotations}\n\n\\item{legend}{Logical: If TRUE, draw legend. Default = NULL, and will be\nturned on if there is more than one feature present}\n\n\\item{legend_col}{Color: Legend text color. Default = NULL, determined by\ntheme}\n\n\\item{legend_xy}{Numeric, vector, length 2: x and y for plotly's legend}\n\n\\item{legend_orientation}{\"v\" or \"h\" for vertical or horizontal}\n\n\\item{legend_xanchor}{Character: Legend's x anchor: \"left\", \"center\",\n\"right\", \"auto\"}\n\n\\item{legend_yanchor}{Character: Legend's y anchor: \"top\", \"middle\",\n\"bottom\", \"auto\"}\n\n\\item{hline}{Float: If defined, draw a horizontal line at this y value.}\n\n\\item{hline_col}{Color for \\code{hline}.}\n\n\\item{hline_width}{Float: Width for \\code{hline}.}\n\n\\item{hline_dash}{Character: Type of line to draw: \"solid\", \"dot\", \"dash\",\n\"longdash\", \"dashdot\",\nor \"longdashdot\"}\n\n\\item{hline_annotate}{Character: Text of horizontal line annotation if\n\\code{hline} is set}\n\n\\item{hline_annotation_x}{Numeric: x position to place annotation with paper\nas reference. 0: to the left of the plot area; 1: to the right of the plot area}\n\n\\item{margin}{Named list: plot margins.}\n\n\\item{automargin_x}{Logical: If TRUE, automatically set x-axis margins}\n\n\\item{automargin_y}{Logical: If TRUE, automatically set y-axis margins}\n\n\\item{padding}{Integer: N pixels to pad plot.}\n\n\\item{displayModeBar}{Logical: If TRUE, show plotly's modebar}\n\n\\item{modeBar_file_format}{Character: \"svg\", \"png\", \"jpeg\", \"pdf\" / any\noutput file type supported by plotly and your system}\n\n\\item{filename}{Character: Path to file to save static plot.}\n\n\\item{file_width}{Integer: File width in pixels for when \\code{filename} is\nset.}\n\n\\item{file_height}{Integer: File height in pixels for when \\code{filename}\nis set.}\n\n\\item{file_scale}{Numeric: If saving to file, scale plot by this number}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw interactive barplots using \\code{plotly}\n}\n\\details{\nSee \\href{https://docs.rtemis.org/r/}{docs.rtemis.org/r} for detailed documentation.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\ndraw_bar(VADeaths, legend_xy = c(0, 1))\ndraw_bar(VADeaths, legend_xy = c(1, 1), legend_xanchor = \"left\")\n# simple individual bars\na <- c(4, 7, 2)\ndraw_bar(a)\n# if input is a data.frame, each row is a group and each column is a feature\nb <- data.frame(x = c(3, 5, 7), y = c(2, 1, 8), z = c(4, 5, 2))\nrownames(b) <- c(\"Jen\", \"Ben\", \"Ren\")\ndraw_bar(b)\n# stacked\ndraw_bar(b, barmode = \"stack\")\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_box.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_box.R\n\\name{draw_box}\n\\alias{draw_box}\n\\title{Interactive Boxplots & Violin plots}\n\\usage{\ndraw_box(\n x,\n time = NULL,\n time_bin = c(\"year\", \"quarter\", \"month\", \"day\"),\n type = c(\"box\", \"violin\"),\n group = NULL,\n x_transform = c(\"none\", \"scale\", \"minmax\"),\n main = NULL,\n xlab = \"\",\n ylab = NULL,\n alpha = 0.6,\n bg = NULL,\n plot_bg = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n boxpoints = \"outliers\",\n quartilemethod = \"linear\",\n xlim = NULL,\n ylim = NULL,\n violin_box = TRUE,\n orientation = \"v\",\n annotate_n = FALSE,\n annotate_n_y = 1,\n annotate_mean = FALSE,\n annotate_meansd = FALSE,\n annotate_meansd_y = 1,\n annotate_col = theme[[\"labs_col\"]],\n xnames = NULL,\n group_lines = FALSE,\n group_lines_dash = \"dot\",\n group_lines_col = NULL,\n group_lines_alpha = 0.5,\n labelify = TRUE,\n order_by_fn = NULL,\n font_size = 16,\n ylab_standoff = 18,\n legend = NULL,\n legend_col = NULL,\n legend_xy = NULL,\n legend_orientation = \"v\",\n legend_xanchor = \"auto\",\n legend_yanchor = \"auto\",\n xaxis_type = \"category\",\n cataxis_tickangle = \"auto\",\n margin = list(b = 65, l = 65, t = 50, r = 12, pad = 0),\n automargin_x = TRUE,\n automargin_y = TRUE,\n boxgroupgap = NULL,\n hovertext = NULL,\n show_n = FALSE,\n pvals = NULL,\n htest = \"none\",\n htest_compare = 0,\n htest_y = NULL,\n htest_annotate = TRUE,\n htest_annotate_x = 0,\n htest_annotate_y = -0.065,\n htest_star_col = theme[[\"labs_col\"]],\n htest_bracket_col = theme[[\"labs_col\"]],\n starbracket_pad = c(0.04, 0.05, 0.09),\n use_plotly_group = FALSE,\n width = NULL,\n height = NULL,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n mathjax = NULL\n)\n}\n\\arguments{\n\\item{x}{Vector or List of vectors: Input}\n\n\\item{time}{Date or date-time vector}\n\n\\item{time_bin}{Character: \"year\", \"quarter\", \"month\", or \"day\". Period to\nbin by}\n\n\\item{type}{Character: \"box\" or \"violin\"}\n\n\\item{group}{Factor to group by}\n\n\\item{x_transform}{Character: \"none\", \"scale\", or \"minmax\" to use raw values,\nscaled and centered values or min-max normalized to 0-1, respectively.\nTransform is applied to each variable before grouping, so that groups are\ncomparable}\n\n\\item{main}{Character: Plot title.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{alpha}{Float (0, 1]: Transparency for box colors.}\n\n\\item{bg}{Color: Background color.}\n\n\\item{plot_bg}{Color: Background color for plot area.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{palette}{Character vector: Colors to use.}\n\n\\item{boxpoints}{Character or FALSE: \"all\", \"suspectedoutliers\", \"outliers\"\nSee \\url{https://plotly.com/r/box-plots/#choosing-the-algorithm-for-computing-quartiles}}\n\n\\item{quartilemethod}{Character: \"linear\", \"exclusive\", \"inclusive\"}\n\n\\item{xlim}{Numeric vector: x-axis limits}\n\n\\item{ylim}{Numeric vector: y-axis limits}\n\n\\item{violin_box}{Logical: If TRUE and type is \"violin\" show box within\nviolin plot}\n\n\\item{orientation}{Character: \"v\" or \"h\" for vertical, horizontal}\n\n\\item{annotate_n}{Logical: If TRUE, annotate with N in each box}\n\n\\item{annotate_n_y}{Numeric: y position for \\code{annotate_n}}\n\n\\item{annotate_mean}{Logical: If TRUE, annotate with mean of each box}\n\n\\item{annotate_meansd}{Logical: If TRUE, annotate with mean (SD) of each box}\n\n\\item{annotate_meansd_y}{Numeric: y position for \\code{annotate_meansd}}\n\n\\item{annotate_col}{Color for annotations}\n\n\\item{xnames}{Character, vector, length = NROW(x): x-axis names. Default = NULL, which\ntries to set names automatically.}\n\n\\item{group_lines}{Logical: If TRUE, add separating lines between groups of\nboxplots}\n\n\\item{group_lines_dash}{Character: \"solid\", \"dot\", \"dash\", \"longdash\",\n\"dashdot\", or \"longdashdot\"}\n\n\\item{group_lines_col}{Color for \\code{group_lines}}\n\n\\item{group_lines_alpha}{Numeric: transparency for \\code{group_lines_col}}\n\n\\item{labelify}{Logical: If TRUE, \\link{labelify} x names}\n\n\\item{order_by_fn}{Function: If defined, order boxes by increasing value of\nthis function (e.g. median).}\n\n\\item{font_size}{Float: Font size for all labels.}\n\n\\item{ylab_standoff}{Numeric: Standoff for y-axis label}\n\n\\item{legend}{Logical: If TRUE, draw legend.}\n\n\\item{legend_col}{Color: Legend text color. Default = NULL, determined by\nthe theme.}\n\n\\item{legend_xy}{Float, vector, length 2: Relative x, y position for legend.}\n\n\\item{legend_orientation}{\"v\" or \"h\" for vertical, horizontal}\n\n\\item{legend_xanchor}{Character: Legend's x anchor: \"left\", \"center\",\n\"right\", \"auto\"}\n\n\\item{legend_yanchor}{Character: Legend's y anchor: \"top\", \"middle\",\n\"bottom\", \"auto\"}\n\n\\item{xaxis_type}{Character: \"linear\", \"log\", \"date\", \"category\",\n\"multicategory\"}\n\n\\item{cataxis_tickangle}{Numeric: Angle for categorical axis tick labels}\n\n\\item{margin}{Named list: plot margins.}\n\n\\item{automargin_x}{Logical: If TRUE, automatically set x-axis margins}\n\n\\item{automargin_y}{Logical: If TRUE, automatically set y-axis margins}\n\n\\item{boxgroupgap}{Numeric: Sets the gap (in plot fraction) between boxes\nof the same location coordinate}\n\n\\item{hovertext}{Character vector: Text to show on hover for each data point}\n\n\\item{show_n}{Logical: If TRUE, show N in each box}\n\n\\item{pvals}{Numeric vector: Precomputed p-values. Should correspond to each box.\nBypasses \\code{htest} and \\code{htest_compare}. Requires \\code{group} to be set}\n\n\\item{htest}{Character: e.g. \"t.test\", \"wilcox.test\" to compare each box to\nthe \\emph{first} box. If grouped, compare within each group to the first box.\nIf p-value of test is less than \\code{htest.thresh}, add asterisk above/\nto the side of each box}\n\n\\item{htest_compare}{Integer: 0: Compare all distributions against the first one;\n2: Compare every second box to the one before it. Requires \\code{group} to\nbe set}\n\n\\item{htest_y}{Numeric: y coordinate for \\code{htest} annotation}\n\n\\item{htest_annotate}{Logical: if TRUE, include htest annotation}\n\n\\item{htest_annotate_x}{Numeric: x-axis paper coordinate for htest annotation}\n\n\\item{htest_annotate_y}{Numeric: y-axis paper coordinate for htest annotation}\n\n\\item{htest_star_col}{Color for htest annotation stars}\n\n\\item{htest_bracket_col}{Color for htest annotation brackets}\n\n\\item{starbracket_pad}{Numeric: Padding for htest annotation brackets}\n\n\\item{use_plotly_group}{If TRUE, use plotly's \\code{group} arg to group\nboxes.}\n\n\\item{width}{Numeric: Force plot size to this width. Default = NULL, i.e. fill\navailable space}\n\n\\item{height}{Numeric: Force plot size to this height. Default = NULL, i.e. fill\navailable space}\n\n\\item{displayModeBar}{Logical: If TRUE, show plotly's modebar}\n\n\\item{modeBar_file_format}{Character: \"svg\", \"png\", \"jpeg\", \"pdf\"}\n\n\\item{filename}{Character: Path to file to save static plot.}\n\n\\item{file_width}{Integer: File width in pixels for when \\code{filename} is\nset.}\n\n\\item{file_height}{Integer: File height in pixels for when \\code{filename}\nis set.}\n\n\\item{file_scale}{Numeric: If saving to file, scale plot by this number}\n\n\\item{mathjax}{Optional Character \\{\"local\", \"cdn\"\\}: Whether to use local or CDN version of\nMathJax for rendering mathematical annotations.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw interactive boxplots or violin plots using \\pkg{plotly}\n}\n\\details{\nSee \\href{https://docs.rtemis.org/r/}{docs.rtemis.org/r} for detailed documentation.\n\nFor multiple box plots, the recommendation is:\n\\itemize{\n\\item \\code{x=dat[, columnindex]} for multiple variables of a data.frame\n\\item \\code{x=list(a=..., b=..., etc.)} for multiple variables of potentially\ndifferent length\n\\item \\code{x=split(var, group)} for one variable with multiple groups: group names\nappear below boxplots\n\\item \\verb{x=dat[, columnindex], group = factor} for grouping multiple variables:\ngroup names appear in legend\n}\n\nIf \\code{orientation == \"h\"}, \\code{xlab} is applied to y-axis and vice versa.\nSimilarly, \\code{x.axist.type} applies to y-axis - this defaults to\n\"category\" and would not normally need changing.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\n# A.1 Box plot of 4 variables\ndraw_box(iris[, 1:4])\n# A.2 Grouped Box plot\ndraw_box(iris[, 1:4], group = iris[[\"Species\"]])\ndraw_box(iris[, 1:4], group = iris[[\"Species\"]], annotate_n = TRUE)\n# B. Boxplot binned by time periods\n# Synthetic data with an instantenous shift in distributions\nset.seed(2021)\ndat1 <- data.frame(alpha = rnorm(200, 0), beta = rnorm(200, 2), gamma = rnorm(200, 3))\ndat2 <- data.frame(alpha = rnorm(200, 5), beta = rnorm(200, 8), gamma = rnorm(200, -3))\nx <- rbind(dat1, dat2)\nstartDate <- as.Date(\"2019-12-04\")\nendDate <- as.Date(\"2021-03-31\")\ntime <- seq(startDate, endDate, length.out = 400)\ndraw_box(x[, 1], time, \"year\", ylab = \"alpha\")\ndraw_box(x, time, \"year\", legend.xy = c(0, 1))\ndraw_box(x, time, \"quarter\", legend.xy = c(0, 1))\ndraw_box(x, time, \"month\",\n legend.orientation = \"h\",\n legend.xy = c(0, 1),\n legend.yanchor = \"bottom\"\n)\n# (Note how the boxplots widen when the period includes data from both dat1 and dat2)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_calibration.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_calibration.R\n\\name{draw_calibration}\n\\alias{draw_calibration}\n\\title{Draw calibration plot}\n\\usage{\ndraw_calibration(\n true_labels,\n predicted_prob,\n n_bins = 10L,\n bin_method = c(\"quantile\", \"equidistant\"),\n binclasspos = 2L,\n main = NULL,\n subtitle = NULL,\n xlab = \"Mean predicted probability\",\n ylab = \"Empirical risk\",\n show_marginal_x = TRUE,\n marginal_x_y = -0.02,\n marginal_col = NULL,\n marginal_size = 10,\n mode = \"markers+lines\",\n show_brier = TRUE,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n filename = NULL,\n ...\n)\n}\n\\arguments{\n\\item{true_labels}{Factor or list of factors with true class labels}\n\n\\item{predicted_prob}{Numeric vector or list of numeric vectors with predicted probabilities}\n\n\\item{n_bins}{Integer: Number of windows to split the data into}\n\n\\item{bin_method}{Character: \"quantile\" or \"equidistant\": Method to bin the estimated\nprobabilities.}\n\n\\item{binclasspos}{Integer: Index of the positive class. The convention used in the package is\nthe second level is the positive class.}\n\n\\item{main}{Character: Main title}\n\n\\item{subtitle}{Character: Subtitle, placed bottom right of plot}\n\n\\item{xlab}{Character: x-axis label}\n\n\\item{ylab}{Character: y-axis label}\n\n\\item{show_marginal_x}{Logical: Add marginal plot of distribution of estimated probabilities}\n\n\\item{marginal_x_y}{Numeric: y position of marginal plot}\n\n\\item{marginal_col}{Character: Color of marginal plot}\n\n\\item{marginal_size}{Numeric: Size of marginal plot}\n\n\\item{mode}{Character: \"lines\", \"markers\", \"lines+markers\": How to plot.}\n\n\\item{show_brier}{Logical: If TRUE, add Brier scores to trace names.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{filename}{Character: Path to save output.}\n\n\\item{...}{Additional arguments passed to \\link{draw_scatter}}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw calibration plot\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\n# Synthetic data with n cases\nn <- 500L\ntrue_labels <- factor(sample(c(\"A\", \"B\"), n, replace = TRUE))\n# Synthetic probabilities where A has mean 0.25 and B has mean 0.75\npredicted_prob <- ifelse(true_labels == \"A\",\n rbeta(n, 2, 6),\n rbeta(n, 6, 2)\n)\ndraw_calibration(true_labels, predicted_prob)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_confusion.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_confusion.R\n\\name{draw_confusion}\n\\alias{draw_confusion}\n\\title{Plot confusion matrix}\n\\usage{\ndraw_confusion(\n x,\n xlab = \"Predicted\",\n ylab = \"Reference\",\n true_col = \"#43A4AC\",\n false_col = \"#FA9860\",\n font_size = 18,\n main = NULL,\n main_y = 1,\n main_yanchor = \"bottom\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n margin = list(l = 20, r = 5, b = 5, t = 20),\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1\n)\n}\n\\arguments{\n\\item{x}{\\code{ClassificationMetrics} object produced by \\link{classification_metrics} or confusion matrix\nwhere rows are the reference and columns are the estimated classes. For binary classification,\nthe first row and column are the positive class.}\n\n\\item{xlab}{Character: x-axis label. Default is \"Predicted\".}\n\n\\item{ylab}{Character: y-axis label. Default is \"Reference\".}\n\n\\item{true_col}{Color for true positives & true negatives.}\n\n\\item{false_col}{Color for false positives & false negatives.}\n\n\\item{font_size}{Integer: font size.}\n\n\\item{main}{Character: plot title.}\n\n\\item{main_y}{Numeric: y position of the title.}\n\n\\item{main_yanchor}{Character: y anchor of the title.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{margin}{List: Plot margins.}\n\n\\item{filename}{Character: file name to save the plot. Default is NULL.}\n\n\\item{file_width}{Numeric: width of the file. Default is 500.}\n\n\\item{file_height}{Numeric: height of the file. Default is 500.}\n\n\\item{file_scale}{Numeric: scale of the file. Default is 1.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nPlot confusion matrix\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\n# Assume positive class is \"b\"\ntrue_labels <- factor(c(\"a\", \"a\", \"a\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\"))\npredicted_labels <- factor(c(\"a\", \"b\", \"a\", \"b\", \"b\", \"a\", \"b\", \"b\", \"b\", \"a\"))\npredicted_prob <- c(0.3, 0.55, 0.45, 0.75, 0.57, 0.3, 0.8, 0.63, 0.62, 0.39)\nmetrics <- classification_metrics(true_labels, predicted_labels, predicted_prob)\ndraw_confusion(metrics)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_dist.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_dist.R\n\\name{draw_dist}\n\\alias{draw_dist}\n\\title{Draw Distributions using Histograms and Density Plots}\n\\usage{\ndraw_dist(\n x,\n type = c(\"density\", \"histogram\"),\n mode = c(\"overlap\", \"ridge\"),\n group = NULL,\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n col = NULL,\n alpha = 0.75,\n plot_bg = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = getOption(\"rtemis_palette\", \"rtms\"),\n axes_square = FALSE,\n group_names = NULL,\n font_size = 16,\n font_alpha = 0.8,\n legend = NULL,\n legend_xy = c(0, 1),\n legend_col = NULL,\n legend_bg = \"#FFFFFF00\",\n legend_border_col = \"#FFFFFF00\",\n bargap = 0.05,\n vline = NULL,\n vline_col = theme[[\"fg\"]],\n vline_width = 1,\n vline_dash = \"dot\",\n text = NULL,\n text_x = 1,\n text_xref = \"paper\",\n text_xanchor = \"left\",\n text_y = 1,\n text_yref = \"paper\",\n text_yanchor = \"top\",\n text_col = theme[[\"fg\"]],\n margin = list(b = 65, l = 65, t = 50, r = 10, pad = 0),\n automargin_x = TRUE,\n automargin_y = TRUE,\n zerolines = FALSE,\n density_kernel = \"gaussian\",\n density_bw = \"SJ\",\n histnorm = c(\"\", \"density\", \"percent\", \"probability\", \"probability density\"),\n histfunc = c(\"count\", \"sum\", \"avg\", \"min\", \"max\"),\n hist_n_bins = 20,\n barmode = \"overlay\",\n ridge_sharex = TRUE,\n ridge_y_labs = FALSE,\n ridge_order_on_mean = TRUE,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n width = NULL,\n height = NULL,\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1\n)\n}\n\\arguments{\n\\item{x}{Numeric vector / data.frame / list: Input. If not a vector, each column / each element is drawn.}\n\n\\item{type}{Character: \"density\" or \"histogram\".}\n\n\\item{mode}{Character: \"overlap\", \"ridge\". How to plot different groups; on the same axes (\"overlap\"), or on separate plots with the same x-axis (\"ridge\").}\n\n\\item{group}{Vector: Will be converted to factor; levels define group members.}\n\n\\item{main}{Character: Main title for the plot.}\n\n\\item{xlab}{Character: Label for the x-axis.}\n\n\\item{ylab}{Character: Label for the y-axis.}\n\n\\item{col}{Color: Colors for the plot.}\n\n\\item{alpha}{Numeric: Alpha transparency for plot elements.}\n\n\\item{plot_bg}{Color: Background color for plot area.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{palette}{Character: Color palette to use.}\n\n\\item{axes_square}{Logical: If TRUE, draw a square plot to fill the graphic device. Default = FALSE.}\n\n\\item{group_names}{Character: Names for the groups.}\n\n\\item{font_size}{Numeric: Font size for plot text.}\n\n\\item{font_alpha}{Numeric: Alpha transparency for font.}\n\n\\item{legend}{Logical: If TRUE, draw legend. Default = NULL, which will be set to TRUE if x is a list of more than 1 element.}\n\n\\item{legend_xy}{Numeric, vector, length 2: Relative x, y position for legend. Default = c(0, 1).}\n\n\\item{legend_col}{Color: Color for the legend text.}\n\n\\item{legend_bg}{Color: Background color for legend.}\n\n\\item{legend_border_col}{Color: Border color for legend.}\n\n\\item{bargap}{Numeric: The gap between adjacent histogram bars in plot fraction.}\n\n\\item{vline}{Numeric, vector: If defined, draw a vertical line at this x value(s).}\n\n\\item{vline_col}{Color: Color for \\code{vline}.}\n\n\\item{vline_width}{Numeric: Width for \\code{vline}.}\n\n\\item{vline_dash}{Character: Type of line to draw: \"solid\", \"dot\", \"dash\", \"longdash\", \"dashdot\", or \"longdashdot\".}\n\n\\item{text}{Character: If defined, add this text over the plot.}\n\n\\item{text_x}{Numeric: x-coordinate for \\code{text}.}\n\n\\item{text_xref}{Character: \"x\": \\code{text_x} refers to plot's x-axis; \"paper\": \\code{text_x} refers to plotting area from 0-1.}\n\n\\item{text_xanchor}{Character: \"auto\", \"left\", \"center\", \"right\".}\n\n\\item{text_y}{Numeric: y-coordinate for \\code{text}.}\n\n\\item{text_yref}{Character: \"y\": \\code{text_y} refers to plot's y-axis; \"paper\": \\code{text_y} refers to plotting area from 0-1.}\n\n\\item{text_yanchor}{Character: \"auto\", \"top\", \"middle\", \"bottom\".}\n\n\\item{text_col}{Color: Color for \\code{text}.}\n\n\\item{margin}{List: Margins for the plot.}\n\n\\item{automargin_x}{Logical: If TRUE, automatically adjust x-axis margins.}\n\n\\item{automargin_y}{Logical: If TRUE, automatically adjust y-axis margins.}\n\n\\item{zerolines}{Logical: If TRUE, draw lines at y = 0.}\n\n\\item{density_kernel}{Character: Kernel to use for density estimation.}\n\n\\item{density_bw}{Character: Bandwidth to use for density estimation.}\n\n\\item{histnorm}{Character: NULL, \"percent\", \"probability\", \"density\", \"probability density\".}\n\n\\item{histfunc}{Character: \"count\", \"sum\", \"avg\", \"min\", \"max\".}\n\n\\item{hist_n_bins}{Integer: Number of bins to use if type = \"histogram\".}\n\n\\item{barmode}{Character: Barmode for histogram. One of \"overlay\", \"stack\", \"relative\", \"group\".}\n\n\\item{ridge_sharex}{Logical: If TRUE, draw single x-axis when \\code{mode = \"ridge\"}.}\n\n\\item{ridge_y_labs}{Logical: If TRUE, show individual y labels when \\code{mode = \"ridge\"}.}\n\n\\item{ridge_order_on_mean}{Logical: If TRUE, order groups by mean value when \\code{mode = \"ridge\"}.}\n\n\\item{displayModeBar}{Logical: If TRUE, display the mode bar.}\n\n\\item{modeBar_file_format}{Character: File format for mode bar. Default = \"svg\".}\n\n\\item{width}{Numeric: Force plot size to this width. Default = NULL, i.e. fill available space.}\n\n\\item{height}{Numeric: Force plot size to this height. Default = NULL, i.e. fill available space.}\n\n\\item{filename}{Character: Path to file to save static plot.}\n\n\\item{file_width}{Integer: File width in pixels for when \\code{filename} is set.}\n\n\\item{file_height}{Integer: File height in pixels for when \\code{filename} is set.}\n\n\\item{file_scale}{Numeric: If saving to file, scale plot by this number.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw Distributions using Histograms and Density Plots using \\code{plotly}.\n}\n\\details{\nSee \\href{https://docs.rtemis.org/r/}{docs.rtemis.org/r} for detailed documentation.\n\nIf input is data.frame, non-numeric variables will be removed.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\n# Will automatically use only numeric columns\ndraw_dist(iris)\ndraw_dist(iris[[\"Sepal.Length\"]], group = iris[[\"Species\"]])\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_fit.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_scatter.R\n\\name{draw_fit}\n\\alias{draw_fit}\n\\title{True vs. Predicted Plot}\n\\usage{\ndraw_fit(\n x,\n y,\n xlab = \"True\",\n ylab = \"Predicted\",\n fit = \"glm\",\n se_fit = TRUE,\n axes_square = TRUE,\n axes_equal = TRUE,\n diagonal = TRUE,\n ...\n)\n}\n\\arguments{\n\\item{x}{Numeric, vector/data.frame/list: True values. If y is NULL and\n\\code{NCOL(x) > 1}, first two columns used as \\code{x} and \\code{y}, respectively}\n\n\\item{y}{Numeric, vector/data.frame/list: Predicted values}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{fit}{Character: Fit method.}\n\n\\item{se_fit}{Logical: If TRUE, include standard error of the fit.}\n\n\\item{axes_square}{Logical: If TRUE, draw a square plot.}\n\n\\item{axes_equal}{Logical: If TRUE, set equal scaling for axes.}\n\n\\item{diagonal}{Logical: If TRUE, add diagonal line.}\n\n\\item{...}{Additional arguments passed to \\link{draw_scatter}}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nA \\code{draw_scatter} wrapper for plotting true vs. predicted values\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\nx <- rnorm(500)\ny <- x + rnorm(500)\ndraw_fit(x, y)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_graphD3.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_graphd3.R\n\\name{draw_graphD3}\n\\alias{draw_graphD3}\n\\title{Plot graph using \\pkg{networkD3}}\n\\usage{\ndraw_graphD3(\n net,\n groups = NULL,\n color_scale = NULL,\n edge_col = NULL,\n node_col = NULL,\n node_alpha = 0.5,\n edge_alpha = 0.33,\n zoom = TRUE,\n legend = FALSE,\n palette = get_palette(getOption(\"rtemis_palette\")),\n theme = choose_theme(getOption(\"rtemis_theme\")),\n ...\n)\n}\n\\arguments{\n\\item{net}{\\pkg{igraph} network.}\n\n\\item{groups}{Vector, length n nodes indicating group/cluster/community membership of nodes in \\code{net}.}\n\n\\item{color_scale}{D3 colorscale (e.g. \\code{networkD3::JS(\"d3.scaleOrdinal(d3.schemeCategory20b);\")}).}\n\n\\item{edge_col}{Color for edges.}\n\n\\item{node_col}{Color for nodes.}\n\n\\item{node_alpha}{Float [0, 1]: Node opacity.}\n\n\\item{edge_alpha}{Float [0, 1]: Edge opacity.}\n\n\\item{zoom}{Logical: If TRUE, graph is zoomable.}\n\n\\item{legend}{Logical: If TRUE, display legend for groups.}\n\n\\item{palette}{Character vector: Colors to use.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{...}{Additional arguments to pass to \\code{networkD3}.}\n}\n\\value{\n\\code{forceNetwork} object.\n}\n\\description{\nPlot graph using \\pkg{networkD3}\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\nlibrary(igraph)\ng <- make_ring(10)\ndraw_graphD3(g)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_graphjs.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_graphjs.R\n\\name{draw_graphjs}\n\\alias{draw_graphjs}\n\\title{Plot network using \\pkg{threejs::graphjs}}\n\\usage{\ndraw_graphjs(\n net,\n vertex_size = 1,\n vertex_col = NULL,\n vertex_label_col = NULL,\n vertex_label_alpha = 0.66,\n vertex_frame_col = NA,\n vertex_label = NULL,\n vertex_shape = \"circle\",\n edge_col = NULL,\n edge_alpha = 0.5,\n edge_curved = 0.35,\n edge_width = 2,\n layout = c(\"fr\", \"dh\", \"drl\", \"gem\", \"graphopt\", \"kk\", \"lgl\", \"mds\", \"sugiyama\"),\n coords = NULL,\n layout_args = list(),\n cluster = NULL,\n groups = NULL,\n cluster_config = list(),\n cluster_mark_groups = TRUE,\n cluster_color_vertices = FALSE,\n main = \"\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = getOption(\"rtemis_palette\", \"rtms\"),\n mar = rep(0, 4),\n filename = NULL,\n verbosity = 1L,\n ...\n)\n}\n\\arguments{\n\\item{net}{\\pkg{igraph} network.}\n\n\\item{vertex_size}{Numeric: Vertex size.}\n\n\\item{vertex_col}{Color for vertices.}\n\n\\item{vertex_label_col}{Color for vertex labels.}\n\n\\item{vertex_label_alpha}{Numeric: Transparency for \\code{vertex_label_col}.}\n\n\\item{vertex_frame_col}{Color for vertex border (frame).}\n\n\\item{vertex_label}{Character vector: Vertex labels. Default = NULL, which will keep existing names in \\code{net} if any. Set to NA to avoid printing vertex labels.}\n\n\\item{vertex_shape}{Character, vector, length 1 or N nodes: Vertex shape. See \\code{graphjs(\"vertex_shape\")}.}\n\n\\item{edge_col}{Color for edges.}\n\n\\item{edge_alpha}{Numeric: Transparency for edges.}\n\n\\item{edge_curved}{Numeric: Curvature of edges.}\n\n\\item{edge_width}{Numeric: Edge thickness.}\n\n\\item{layout}{Character: one of: \"fr\", \"dh\", \"drl\", \"gem\", \"graphopt\", \"kk\", \"lgl\", \"mds\", \"sugiyama\", corresponding to all the available layouts in \\pkg{igraph}.}\n\n\\item{coords}{Output of precomputed \\pkg{igraph} layout. If provided, \\code{layout} is ignored.}\n\n\\item{layout_args}{List of arguments to pass to \\code{layout} function.}\n\n\\item{cluster}{Character: one of: \"edge_betweenness\", \"fast_greedy\", \"infomap\", \"label_prop\", \"leading_eigen\", \"louvain\", \"optimal\", \"spinglass\", \"walktrap\", corresponding to all the available \\pkg{igraph} clustering functions.}\n\n\\item{groups}{Output of precomputed \\pkg{igraph} clustering. If provided, \\code{cluster} is ignored.}\n\n\\item{cluster_config}{List of arguments to pass to \\code{cluster} function.}\n\n\\item{cluster_mark_groups}{Logical: If TRUE, draw polygons to indicate clusters, if \\code{groups} or \\code{cluster} are defined.}\n\n\\item{cluster_color_vertices}{Logical: If TRUE, color vertices by cluster membership.}\n\n\\item{main}{Character: Main title.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{palette}{Color vector or name of rtemis palette.}\n\n\\item{mar}{Numeric vector, length 4: \\code{par}'s margin argument.}\n\n\\item{filename}{Character: If provided, save plot to this filepath.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n\n\\item{...}{Extra arguments to pass to \\code{igraph::plot.igraph()}.}\n}\n\\value{\n\\code{scatterplotThree} object.\n}\n\\description{\nInteractive plotting of an \\pkg{igraph} net using \\pkg{threejs}.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\nlibrary(igraph)\ng <- make_ring(10)\ndraw_graphjs(g)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_heatmap.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_heatmap.R\n\\name{draw_heatmap}\n\\alias{draw_heatmap}\n\\title{Interactive Heatmaps}\n\\usage{\ndraw_heatmap(\n x,\n Rowv = TRUE,\n Colv = TRUE,\n cluster = FALSE,\n symm = FALSE,\n cellnote = NULL,\n colorgrad_n = 101,\n colors = NULL,\n space = \"rgb\",\n lo = \"#18A3AC\",\n lomid = NULL,\n mid = NULL,\n midhi = NULL,\n hi = \"#F48024\",\n k_row = 1,\n k_col = 1,\n grid_gap = 0,\n limits = NULL,\n margins = NULL,\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n key_title = NULL,\n showticklabels = NULL,\n colorbar_len = 0.7,\n plot_method = \"plotly\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n row_side_colors = NULL,\n row_side_palette = NULL,\n col_side_colors = NULL,\n col_side_palette = NULL,\n font_size = NULL,\n padding = 0,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n ...\n)\n}\n\\arguments{\n\\item{x}{Input matrix.}\n\n\\item{Rowv}{Logical or dendrogram. If Logical: Compute dendrogram and reorder rows. Defaults to FALSE. If dendrogram: use as is, without reordering. See more at \\code{heatmaply::heatmaply(\"Rowv\")}.}\n\n\\item{Colv}{Logical or dendrogram. If Logical: Compute dendrogram and reorder columns. Defaults to FALSE. If dendrogram: use as is, without reordering. See more at \\code{heatmaply::heatmaply(\"Colv\")}.}\n\n\\item{cluster}{Logical: If TRUE, set \\code{Rowv} and \\code{Colv} to TRUE.}\n\n\\item{symm}{Logical: If TRUE, treat \\code{x} symmetrically - \\code{x} must be a square matrix.}\n\n\\item{cellnote}{Matrix with values to be displayed on hover. Defaults to \\code{ddSci(x)}.}\n\n\\item{colorgrad_n}{Integer: Number of colors in gradient. Default = 101.}\n\n\\item{colors}{Character vector: Colors to use in gradient.}\n\n\\item{space}{Character: Color space to use. Default = \"rgb\".}\n\n\\item{lo}{Character: Color for low values. Default = \"#18A3AC\".}\n\n\\item{lomid}{Character: Color for low-mid values.}\n\n\\item{mid}{Character: Color for mid values.}\n\n\\item{midhi}{Character: Color for mid-high values.}\n\n\\item{hi}{Character: Color for high values. Default = \"#F48024\".}\n\n\\item{k_row}{Integer: Number of desired number of groups by which to color dendrogram branches in the rows. Default = 1.}\n\n\\item{k_col}{Integer: Number of desired number of groups by which to color dendrogram branches in the columns. Default = 1.}\n\n\\item{grid_gap}{Integer: Space between cells. Default = 0 (no space).}\n\n\\item{limits}{Float, length 2: Determine color range. Default = NULL, which automatically centers values around 0.}\n\n\\item{margins}{Float, length 4: Heatmap margins.}\n\n\\item{main}{Character: Main title.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{key_title}{Character: Title for the color key.}\n\n\\item{showticklabels}{Logical: If TRUE, show tick labels.}\n\n\\item{colorbar_len}{Numeric: Length of the colorbar.}\n\n\\item{plot_method}{Character: Plot method to use. Default = \"plotly\".}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{row_side_colors}{Data frame: Column names will be label names, cells should be label colors. See \\code{heatmaply::heatmaply(\"row_side_colors\")}.}\n\n\\item{row_side_palette}{Color palette function. See \\code{heatmaply::heatmaply(\"row_side_palette\")}.}\n\n\\item{col_side_colors}{Data frame: Column names will be label names, cells should be label colors. See \\code{heatmaply::heatmaply(\"col_side_colors\")}.}\n\n\\item{col_side_palette}{Color palette function. See \\code{heatmaply::heatmaply(\"col_side_palette\")}.}\n\n\\item{font_size}{Numeric: Font size.}\n\n\\item{padding}{Numeric: Padding between cells.}\n\n\\item{displayModeBar}{Logical: If TRUE, display the plotly mode bar.}\n\n\\item{modeBar_file_format}{Character: File format for image exports from the mode bar.}\n\n\\item{filename}{Character: File name to save the plot.}\n\n\\item{file_width}{Numeric: Width of exported image.}\n\n\\item{file_height}{Numeric: Height of exported image.}\n\n\\item{file_scale}{Numeric: Scale of exported image.}\n\n\\item{...}{Additional arguments to be passed to \\code{heatmaply::heatmaply}.}\n}\n\\value{\n\\code{plotly} object.`\n}\n\\description{\nDraw interactive heatmaps using \\code{heatmaply}.\n}\n\\details{\nSee \\href{https://docs.rtemis.org/r/}{docs.rtemis.org/r} for detailed documentation.\n'heatmaply' unfortunately forces loading of the 'colorspace' namespace.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\nx <- rnormmat(200, 20)\nxcor <- cor(x)\ndraw_heatmap(xcor)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_leaflet.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_leaflet.R\n\\name{draw_leaflet}\n\\alias{draw_leaflet}\n\\title{Plot interactive choropleth map using \\pkg{leaflet}}\n\\usage{\ndraw_leaflet(\n fips,\n values,\n names = NULL,\n fillOpacity = 1,\n color_mapping = c(\"Numeric\", \"Bin\"),\n col_lo = \"#0290EE\",\n col_hi = \"#FE4AA3\",\n col_na = \"#303030\",\n col_highlight = \"#FE8A4F\",\n col_interpolate = c(\"linear\", \"spline\"),\n col_bins = 21,\n domain = NULL,\n weight = 0.5,\n color = \"black\",\n alpha = 1,\n bg_tile_provider = leaflet::providers[[\"CartoDB.Positron\"]],\n bg_tile_alpha = 0.67,\n fg_tile_provider = leaflet::providers[[\"CartoDB.PositronOnlyLabels\"]],\n legend_position = c(\"topright\", \"bottomright\", \"bottomleft\", \"topleft\"),\n legend_alpha = 0.8,\n legend_title = NULL,\n init_lng = -98.5418083333333,\n init_lat = 39.2074138888889,\n init_zoom = 3,\n stroke = TRUE\n)\n}\n\\arguments{\n\\item{fips}{Character vector: FIPS codes. (If numeric, it will be appropriately zero-padded).}\n\n\\item{values}{Values to map to \\code{fips}.}\n\n\\item{names}{Character vector: Optional county names to appear on hover along \\code{values}.}\n\n\\item{fillOpacity}{Float: Opacity for fill colors.}\n\n\\item{color_mapping}{Character: \"Numeric\" or \"Bin\".}\n\n\\item{col_lo}{Overlay color mapped to lowest value.}\n\n\\item{col_hi}{Overlay color mapped to highest value.}\n\n\\item{col_na}{Color mapped to NA values.}\n\n\\item{col_highlight}{Hover border color.}\n\n\\item{col_interpolate}{Character: \"linear\" or \"spline\".}\n\n\\item{col_bins}{Integer: Number of color bins to create if \\code{color_mapping = \"Bin\"}.}\n\n\\item{domain}{Limits for mapping colors to values. Default = NULL and set to range.}\n\n\\item{weight}{Float: Weight of county border lines.}\n\n\\item{color}{Color of county border lines.}\n\n\\item{alpha}{Float: Overlay transparency.}\n\n\\item{bg_tile_provider}{Background tile (below overlay colors), one of \\code{leaflet::providers}.}\n\n\\item{bg_tile_alpha}{Float: Background tile transparency.}\n\n\\item{fg_tile_provider}{Foreground tile (above overlay colors), one of \\code{leaflet::providers}.}\n\n\\item{legend_position}{Character: One of: \"topright\", \"bottomright\", \"bottomleft\", \"topleft\".}\n\n\\item{legend_alpha}{Float: Legend box transparency.}\n\n\\item{legend_title}{Character: Defaults to name of \\code{values} variable.}\n\n\\item{init_lng}{Float: Center map around this longitude (in decimal form). Default = -98.54180833333334 (US geographic center).}\n\n\\item{init_lat}{Float: Center map around this latitude (in decimal form). Default = 39.207413888888894 (US geographic center).}\n\n\\item{init_zoom}{Integer: Initial zoom level (depends on device, i.e. window, size).}\n\n\\item{stroke}{Logical: If TRUE, draw polygon borders.}\n}\n\\value{\n\\code{leaflet} object.\n}\n\\description{\nPlot interactive choropleth map using \\pkg{leaflet}\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\nfips <- c(06075, 42101)\npopulation <- c(874961, 1579000)\nnames <- c(\"SF\", \"Philly\")\ndraw_leaflet(fips, population, names)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_pie.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_pie.R\n\\name{draw_pie}\n\\alias{draw_pie}\n\\title{Interactive Pie Chart}\n\\usage{\ndraw_pie(\n x,\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n alpha = 0.8,\n bg = NULL,\n plot_bg = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n category_names = NULL,\n textinfo = \"label+percent\",\n font_size = 16,\n labs_col = NULL,\n legend = TRUE,\n legend_col = NULL,\n sep_col = NULL,\n margin = list(b = 50, l = 50, t = 50, r = 20),\n padding = 0,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1\n)\n}\n\\arguments{\n\\item{x}{data.frame: Input: Either a) 1 numeric column with categories defined by rownames, or\nb) two columns, the first is category names, the second numeric or c) a numeric vector with categories defined using\nthe \\code{category.names} argument.}\n\n\\item{main}{Character: Plot title. Default = NULL, which results in \\code{colnames(x)[1]}.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{alpha}{Numeric: Alpha for the pie slices.}\n\n\\item{bg}{Character: Background color.}\n\n\\item{plot_bg}{Character: Plot background color.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{palette}{Character vector: Colors to use.}\n\n\\item{category_names}{Character, vector, length = NROW(x): Category names. Default = NULL, which uses\neither \\code{rownames(x)}, or the first column of \\code{x} if \\code{ncol(x) = 2}.}\n\n\\item{textinfo}{Character: Info to show over each slice: \"label\", \"percent\", \"label+percent\".}\n\n\\item{font_size}{Integer: Font size for labels.}\n\n\\item{labs_col}{Character: Color of labels.}\n\n\\item{legend}{Logical: If TRUE, show legend.}\n\n\\item{legend_col}{Character: Color for legend.}\n\n\\item{sep_col}{Character: Separator color.}\n\n\\item{margin}{List: Margin settings.}\n\n\\item{padding}{Numeric: Padding between cells.}\n\n\\item{displayModeBar}{Logical: If TRUE, display the plotly mode bar.}\n\n\\item{modeBar_file_format}{Character: File format for image exports from the mode bar.}\n\n\\item{filename}{Character: File name to save plot.}\n\n\\item{file_width}{Integer: Width for saved file.}\n\n\\item{file_height}{Integer: Height for saved file.}\n\n\\item{file_scale}{Numeric: Scale for saved file.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw interactive pie charts using \\code{plotly}.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\ndraw_pie(VADeaths[, 1, drop = FALSE])\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_protein.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_protein.R\n\\name{draw_protein}\n\\alias{draw_protein}\n\\title{Plot an amino acid sequence with annotations}\n\\usage{\ndraw_protein(\n x,\n site = NULL,\n region = NULL,\n ptm = NULL,\n cleavage_site = NULL,\n variant = NULL,\n disease_variants = NULL,\n n_per_row = NULL,\n main = NULL,\n main_xy = c(0.055, 0.975),\n main_xref = \"paper\",\n main_yref = \"paper\",\n main_xanchor = \"middle\",\n main_yanchor = \"top\",\n layout = c(\"simple\", \"grid\", \"1curve\", \"2curve\"),\n show_markers = TRUE,\n show_labels = TRUE,\n font_size = 18,\n label_col = NULL,\n scatter_mode = \"markers+lines\",\n marker_size = 28,\n marker_col = NULL,\n marker_alpha = 1,\n marker_symbol = \"circle\",\n line_col = NULL,\n line_alpha = 1,\n line_width = 2,\n show_full_names = TRUE,\n region_scatter_mode = \"markers+lines\",\n region_style = 3,\n region_marker_size = marker_size,\n region_marker_alpha = 0.6,\n region_marker_symbol = \"circle\",\n region_line_dash = \"solid\",\n region_line_shape = \"line\",\n region_line_smoothing = 1,\n region_line_width = 1,\n region_line_alpha = 0.6,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n region_palette = getOption(\"rtemis_palette\", \"rtms\"),\n region_outline_only = FALSE,\n region_outline_pad = 2,\n region_pad = 0.35,\n region_fill_alpha = 0.1666666,\n region_fill_shape = \"line\",\n region_fill_smoothing = 1,\n bpadcx = 0.5,\n bpadcy = 0.5,\n site_marker_size = marker_size,\n site_marker_symbol = marker_symbol,\n site_marker_alpha = 1,\n site_border_width = 1.5,\n site_palette = getOption(\"rtemis_palette\", \"rtms\"),\n variant_col = \"#FA6E1E\",\n disease_variant_col = \"#E266AE\",\n showlegend_ptm = TRUE,\n ptm_col = NULL,\n ptm_symbol = \"circle\",\n ptm_offset = 0.12,\n ptm_pad = 0.35,\n ptm_marker_size = marker_size/4.5,\n clv_col = NULL,\n clv_symbol = \"triangle-down\",\n clv_offset = 0.12,\n clv_pad = 0.35,\n clv_marker_size = marker_size/4,\n annotate_position_every = 10,\n annotate_position_alpha = 0.5,\n annotate_position_ay = -0.4 * marker_size,\n position_font_size = font_size - 6,\n legend_xy = c(0.97, 0.954),\n legend_xanchor = \"left\",\n legend_yanchor = \"top\",\n legend_orientation = \"v\",\n legend_col = NULL,\n legend_bg = \"#FFFFFF00\",\n legend_border_col = \"#FFFFFF00\",\n legend_borderwidth = 0,\n legend_group_gap = 0,\n margin = list(b = 0, l = 0, t = 0, r = 0, pad = 0),\n showgrid_x = FALSE,\n showgrid_y = FALSE,\n automargin_x = TRUE,\n automargin_y = TRUE,\n xaxis_autorange = TRUE,\n yaxis_autorange = \"reversed\",\n scaleanchor_y = \"x\",\n scaleratio_y = 1,\n hoverlabel_align = \"left\",\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n scrollZoom = TRUE,\n filename = NULL,\n file_width = 1320,\n file_height = 990,\n file_scale = 1,\n width = NULL,\n height = NULL,\n verbosity = 1L\n)\n}\n\\arguments{\n\\item{x}{Character vector: amino acid sequence (1-letter abbreviations) OR\n\\code{a3} object OR Character: path to JSON file OR Character: UniProt accession number.}\n\n\\item{site}{Named list of lists with indices of sites. These will be\nhighlighted by coloring the border of markers.}\n\n\\item{region}{Named list of lists with indices of regions. These will be\nhighlighted by coloring the markers and lines of regions using the\n\\code{palette} colors.}\n\n\\item{ptm}{List of post-translational modifications.}\n\n\\item{cleavage_site}{List of cleavage sites.}\n\n\\item{variant}{List of variant information.}\n\n\\item{disease_variants}{List of disease variant information.}\n\n\\item{n_per_row}{Integer: Number of amino acids to show per row.}\n\n\\item{main}{Character: Main title.}\n\n\\item{main_xy}{Numeric vector, length 2: x and y coordinates for title.\ne.g. if \\code{main_xref} and \\code{main_yref} are \\code{\"paper\"}:\n\\code{c(0.055, .975)} is top left, \\code{c(.5, .975)} is top and\nmiddle.}\n\n\\item{main_xref}{Character: xref for title.}\n\n\\item{main_yref}{Character: yref for title.}\n\n\\item{main_xanchor}{Character: xanchor for title.}\n\n\\item{main_yanchor}{Character: yanchor for title.}\n\n\\item{layout}{Character: \"1curve\", \"grid\": type of layout to use.}\n\n\\item{show_markers}{Logical: If TRUE, show amino acid markers.}\n\n\\item{show_labels}{Logical: If TRUE, annotate amino acids with elements.}\n\n\\item{font_size}{Integer: Font size for labels.}\n\n\\item{label_col}{Color for labels.}\n\n\\item{scatter_mode}{Character: Mode for scatter plot.}\n\n\\item{marker_size}{Integer: Size of markers.}\n\n\\item{marker_col}{Color for markers.}\n\n\\item{marker_alpha}{Numeric: Alpha for markers.}\n\n\\item{marker_symbol}{Character: Symbol for markers.}\n\n\\item{line_col}{Color for lines.}\n\n\\item{line_alpha}{Numeric: Alpha for lines.}\n\n\\item{line_width}{Numeric: Width for lines.}\n\n\\item{show_full_names}{Logical: If TRUE, show full names of amino acids.}\n\n\\item{region_scatter_mode}{Character: Mode for scatter plot.}\n\n\\item{region_style}{Integer: Style for regions.}\n\n\\item{region_marker_size}{Integer: Size of region markers.}\n\n\\item{region_marker_alpha}{Numeric: Alpha for region markers.}\n\n\\item{region_marker_symbol}{Character: Symbol for region markers.}\n\n\\item{region_line_dash}{Character: Dash for region lines.}\n\n\\item{region_line_shape}{Character: Shape for region lines.}\n\n\\item{region_line_smoothing}{Numeric: Smoothing for region lines.}\n\n\\item{region_line_width}{Numeric: Width for region lines.}\n\n\\item{region_line_alpha}{Numeric: Alpha for region lines.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{region_palette}{Named list of colors for regions.}\n\n\\item{region_outline_only}{Logical: If TRUE, only show outline of regions.}\n\n\\item{region_outline_pad}{Numeric: Padding for region outline.}\n\n\\item{region_pad}{Numeric: Padding for region.}\n\n\\item{region_fill_alpha}{Numeric: Alpha for region fill.}\n\n\\item{region_fill_shape}{Character: Shape for region fill.}\n\n\\item{region_fill_smoothing}{Numeric: Smoothing for region fill.}\n\n\\item{bpadcx}{Numeric: Padding for region border.}\n\n\\item{bpadcy}{Numeric: Padding for region border.}\n\n\\item{site_marker_size}{Integer: Size of site markers.}\n\n\\item{site_marker_symbol}{Character: Symbol for site markers.}\n\n\\item{site_marker_alpha}{Numeric: Alpha for site markers.}\n\n\\item{site_border_width}{Numeric: Width for site borders.}\n\n\\item{site_palette}{Named list of colors for sites.}\n\n\\item{variant_col}{Color for variants.}\n\n\\item{disease_variant_col}{Color for disease variants.}\n\n\\item{showlegend_ptm}{Logical: If TRUE, show legend for PTMs.}\n\n\\item{ptm_col}{Named list of colors for PTMs.}\n\n\\item{ptm_symbol}{Character: Symbol for PTMs.}\n\n\\item{ptm_offset}{Numeric: Offset for PTMs.}\n\n\\item{ptm_pad}{Numeric: Padding for PTMs.}\n\n\\item{ptm_marker_size}{Integer: Size of PTM markers.}\n\n\\item{clv_col}{Color for cleavage site annotations.}\n\n\\item{clv_symbol}{Character: Symbol for cleavage site annotations.}\n\n\\item{clv_offset}{Numeric: Offset for cleavage site annotations.}\n\n\\item{clv_pad}{Numeric: Padding for cleavage site annotations.}\n\n\\item{clv_marker_size}{Integer: Size of cleavage site annotation markers.}\n\n\\item{annotate_position_every}{Integer: Annotate every nth position.}\n\n\\item{annotate_position_alpha}{Numeric: Alpha for position annotations.}\n\n\\item{annotate_position_ay}{Numeric: Y offset for position annotations.}\n\n\\item{position_font_size}{Integer: Font size for position annotations.}\n\n\\item{legend_xy}{Numeric vector, length 2: x and y coordinates for legend.}\n\n\\item{legend_xanchor}{Character: xanchor for legend.}\n\n\\item{legend_yanchor}{Character: yanchor for legend.}\n\n\\item{legend_orientation}{Character: Orientation for legend.}\n\n\\item{legend_col}{Color for legend.}\n\n\\item{legend_bg}{Color for legend background.}\n\n\\item{legend_border_col}{Color for legend border.}\n\n\\item{legend_borderwidth}{Numeric: Width for legend border.}\n\n\\item{legend_group_gap}{Numeric: Gap between legend groups.}\n\n\\item{margin}{List: Margin settings.}\n\n\\item{showgrid_x}{Logical: If TRUE, show x grid.}\n\n\\item{showgrid_y}{Logical: If TRUE, show y grid.}\n\n\\item{automargin_x}{Logical: If TRUE, use automatic margin for x axis.}\n\n\\item{automargin_y}{Logical: If TRUE, use automatic margin for y axis.}\n\n\\item{xaxis_autorange}{Logical: If TRUE, use automatic range for x axis.}\n\n\\item{yaxis_autorange}{Character: If TRUE, use automatic range for y axis.}\n\n\\item{scaleanchor_y}{Character: Scale anchor for y axis.}\n\n\\item{scaleratio_y}{Numeric: Scale ratio for y axis.}\n\n\\item{hoverlabel_align}{Character: Alignment for hover label.}\n\n\\item{displayModeBar}{Logical: If TRUE, display mode bar.}\n\n\\item{modeBar_file_format}{Character: File format for mode bar.}\n\n\\item{scrollZoom}{Logical: If TRUE, enable scroll zoom.}\n\n\\item{filename}{Character: File name to save plot.}\n\n\\item{file_width}{Integer: Width for saved file.}\n\n\\item{file_height}{Integer: Height for saved file.}\n\n\\item{file_scale}{Numeric: Scale for saved file.}\n\n\\item{width}{Integer: Width for plot.}\n\n\\item{height}{Integer: Height for plot.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nPlot an amino acid sequence with multiple site and/or region annotations.\n}\n\\examples{\n\\dontrun{\n # Reads sequence from UniProt server\n tau <- seqinr::read.fasta(\"https://rest.uniprot.org/uniprotkb/P10636.fasta\",\n seqtype = \"AA\"\n )\n draw_protein(as.character(tau[[1]]))\n\n # or directly using the UniProt accession number:\n draw_protein(\"P10636\")\n}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_pvals.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_pvals.R\n\\name{draw_pvals}\n\\alias{draw_pvals}\n\\title{Barplot p-values using \\link{draw_bar}}\n\\usage{\ndraw_pvals(\n x,\n xnames = NULL,\n yname = NULL,\n p_adjust_method = \"none\",\n pval_hline = 0.05,\n hline_col = rt_red,\n hline_dash = \"dash\",\n ...\n)\n}\n\\arguments{\n\\item{x}{Float, vector: p-values.}\n\n\\item{xnames}{Character, vector: feature names.}\n\n\\item{yname}{Character: outcome name.}\n\n\\item{p_adjust_method}{Character: method for \\link{p.adjust}.}\n\n\\item{pval_hline}{Float: Significance level at which to plot horizontal line.}\n\n\\item{hline_col}{Color for \\code{pval_hline}.}\n\n\\item{hline_dash}{Character: type of line to draw.}\n\n\\item{...}{Additional arguments passed to \\link{draw_bar}.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nPlot 1 - p-values as a barplot\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\ndraw_pvals(c(0.01, 0.02, 0.03), xnames = c(\"Feature1\", \"Feature2\", \"Feature3\"))\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_roc.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_roc.R\n\\name{draw_roc}\n\\alias{draw_roc}\n\\title{Draw ROC curve}\n\\usage{\ndraw_roc(\n true_labels,\n predicted_prob,\n multiclass_fill_labels = TRUE,\n main = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n legend = TRUE,\n legend_title = \"Group (AUC)\",\n legend_xy = c(1, 0),\n legend_xanchor = \"right\",\n legend_yanchor = \"bottom\",\n auc_dp = 3L,\n xlim = c(-0.05, 1.05),\n ylim = c(-0.05, 1.05),\n diagonal = TRUE,\n diagonal_col = NULL,\n axes_square = TRUE,\n filename = NULL,\n ...\n)\n}\n\\arguments{\n\\item{true_labels}{Factor: True outcome labels.}\n\n\\item{predicted_prob}{Numeric vector [0, 1]: Predicted probabilities for the positive class (i.e. second level of outcome).\nOr, for multiclass, a matrix of predicted probabilities with one column per class.\nOr, a list of such vectors/matrices to draw multiple ROC curves on the same plot.}\n\n\\item{multiclass_fill_labels}{Logical: If TRUE, fill in labels for multiclass ROC curves.\nIf FALSE, column names of \\code{predicted_prob} must match levels of \\code{true_labels}.}\n\n\\item{main}{Character: Main title for the plot.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{palette}{Character vector: Colors to use.}\n\n\\item{legend}{Logical: If TRUE, draw legend.}\n\n\\item{legend_title}{Character: Title for the legend.}\n\n\\item{legend_xy}{Numeric vector: Position of the legend in the form c(x, y).}\n\n\\item{legend_xanchor}{Character: X anchor for the legend.}\n\n\\item{legend_yanchor}{Character: Y anchor for the legend.}\n\n\\item{auc_dp}{Integer: Number of decimal places for AUC values.}\n\n\\item{xlim}{Numeric vector: Limits for the x-axis.}\n\n\\item{ylim}{Numeric vector: Limits for the y-axis.}\n\n\\item{diagonal}{Logical: If TRUE, draw diagonal line.}\n\n\\item{diagonal_col}{Character: Color for the diagonal line.}\n\n\\item{axes_square}{Logical: If TRUE, make axes square.}\n\n\\item{filename}{Character: If provided, save the plot to this file.}\n\n\\item{...}{Additional arguments passed to \\link{draw_scatter}.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw ROC curve\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\n# Binary classification\ntrue_labels <- factor(c(\"A\", \"B\", \"A\", \"A\", \"B\", \"A\", \"B\", \"B\", \"A\", \"B\"))\npredicted_prob <- c(0.1, 0.4, 0.35, 0.8, 0.65, 0.2, 0.9, 0.55, 0.3, 0.7)\ndraw_roc(true_labels, predicted_prob)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_scatter.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_scatter.R\n\\name{draw_scatter}\n\\alias{draw_scatter}\n\\title{Interactive Scatter Plots}\n\\usage{\ndraw_scatter(\n x,\n y = NULL,\n fit = NULL,\n se_fit = FALSE,\n se_times = 1.96,\n include_fit_name = TRUE,\n cluster = NULL,\n cluster_config = list(k = 2),\n group = NULL,\n rsq = TRUE,\n mode = \"markers\",\n order_on_x = NULL,\n main = NULL,\n subtitle = NULL,\n xlab = NULL,\n ylab = NULL,\n alpha = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n axes_square = FALSE,\n group_names = NULL,\n font_size = 16,\n marker_col = NULL,\n marker_size = 8,\n symbol = \"circle\",\n fit_col = NULL,\n fit_alpha = 0.8,\n fit_lwd = 2.5,\n line_shape = \"linear\",\n se_col = NULL,\n se_alpha = 0.4,\n scatter_type = \"scatter\",\n show_marginal_x = FALSE,\n show_marginal_y = FALSE,\n marginal_x = x,\n marginal_y = y,\n marginal_x_y = NULL,\n marginal_y_x = NULL,\n marginal_col = NULL,\n marginal_alpha = 0.333,\n marginal_size = 10,\n legend = NULL,\n legend_title = NULL,\n legend_trace = TRUE,\n legend_xy = c(0, 0.98),\n legend_xanchor = \"left\",\n legend_yanchor = \"auto\",\n legend_orientation = \"v\",\n legend_col = NULL,\n legend_bg = \"#FFFFFF00\",\n legend_border_col = \"#FFFFFF00\",\n legend_borderwidth = 0,\n legend_group_gap = 0,\n x_showspikes = FALSE,\n y_showspikes = FALSE,\n spikedash = \"solid\",\n spikemode = \"across\",\n spikesnap = \"hovered data\",\n spikecolor = NULL,\n spikethickness = 1,\n margin = list(b = 65, l = 65, t = 50, r = 10, pad = 0),\n main_y = 1.01,\n main_yanchor = \"bottom\",\n subtitle_x = 0.02,\n subtitle_y = 0.99,\n subtitle_xref = \"paper\",\n subtitle_yref = \"paper\",\n subtitle_xanchor = \"left\",\n subtitle_yanchor = \"top\",\n automargin_x = TRUE,\n automargin_y = TRUE,\n xlim = NULL,\n ylim = NULL,\n axes_equal = FALSE,\n diagonal = FALSE,\n diagonal_col = NULL,\n diagonal_dash = \"dot\",\n diagonal_alpha = 0.66,\n fit_params = NULL,\n vline = NULL,\n vline_col = theme[[\"fg\"]],\n vline_width = 1,\n vline_dash = \"dot\",\n hline = NULL,\n hline_col = theme[[\"fg\"]],\n hline_width = 1,\n hline_dash = \"dot\",\n hovertext = NULL,\n width = NULL,\n height = NULL,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n scrollZoom = TRUE,\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n verbosity = 0L\n)\n}\n\\arguments{\n\\item{x}{Numeric, vector/data.frame/list: x-axis data. If y is NULL and \\code{NCOL(x) > 1}, first two columns used as \\code{x} and \\code{y}, respectively.}\n\n\\item{y}{Numeric, vector/data.frame/list: y-axis data.}\n\n\\item{fit}{Character: Fit method.}\n\n\\item{se_fit}{Logical: If TRUE, include standard error of the fit.}\n\n\\item{se_times}{Numeric: Multiplier for standard error.}\n\n\\item{include_fit_name}{Logical: If TRUE, include fit name in legend.}\n\n\\item{cluster}{Character: Clustering method.}\n\n\\item{cluster_config}{List: Config for clustering.}\n\n\\item{group}{Factor: Grouping variable.}\n\n\\item{rsq}{Logical: If TRUE, print R-squared values in legend if \\code{fit} is set.}\n\n\\item{mode}{Character, vector: \"markers\", \"lines\", \"markers+lines\".}\n\n\\item{order_on_x}{Logical: If TRUE, order \\code{x} and \\code{y} on \\code{x}.}\n\n\\item{main}{Character: Main title.}\n\n\\item{subtitle}{Character: Subtitle.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{alpha}{Numeric: Alpha for markers.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{palette}{Character vector: Colors to use.}\n\n\\item{axes_square}{Logical: If TRUE, draw a square plot.}\n\n\\item{group_names}{Character: Names for groups.}\n\n\\item{font_size}{Numeric: Font size.}\n\n\\item{marker_col}{Color for markers.}\n\n\\item{marker_size}{Numeric: Marker size.}\n\n\\item{symbol}{Character: Marker symbol.}\n\n\\item{fit_col}{Color for fit line.}\n\n\\item{fit_alpha}{Numeric: Alpha for fit line.}\n\n\\item{fit_lwd}{Numeric: Line width for fit line.}\n\n\\item{line_shape}{Character: Line shape for line plots. Options: \"linear\", \"hv\", \"vh\", \"hvh\", \"vhv\".}\n\n\\item{se_col}{Color for standard error band.}\n\n\\item{se_alpha}{Numeric: Alpha for standard error band.}\n\n\\item{scatter_type}{Character: Scatter plot type.}\n\n\\item{show_marginal_x}{Logical: If TRUE, add marginal distribution line markers on x-axis.}\n\n\\item{show_marginal_y}{Logical: If TRUE, add marginal distribution line markers on y-axis.}\n\n\\item{marginal_x}{Numeric: Data for marginal distribution on x-axis.}\n\n\\item{marginal_y}{Numeric: Data for marginal distribution on y-axis.}\n\n\\item{marginal_x_y}{Numeric: Y position of marginal markers on x-axis.}\n\n\\item{marginal_y_x}{Numeric: X position of marginal markers on y-axis.}\n\n\\item{marginal_col}{Color for marginal markers.}\n\n\\item{marginal_alpha}{Numeric: Alpha for marginal markers.}\n\n\\item{marginal_size}{Numeric: Size of marginal markers.}\n\n\\item{legend}{Logical: If TRUE, draw legend.}\n\n\\item{legend_title}{Character: Title for legend.}\n\n\\item{legend_trace}{Logical: If TRUE, draw legend trace. (For when you have \\code{fit} and don't want a trace for the markers.)}\n\n\\item{legend_xy}{Numeric: Position of legend.}\n\n\\item{legend_xanchor}{Character: X anchor for legend.}\n\n\\item{legend_yanchor}{Character: Y anchor for legend.}\n\n\\item{legend_orientation}{Character: Orientation of legend.}\n\n\\item{legend_col}{Color for legend text.}\n\n\\item{legend_bg}{Color for legend background.}\n\n\\item{legend_border_col}{Color for legend border.}\n\n\\item{legend_borderwidth}{Numeric: Border width for legend.}\n\n\\item{legend_group_gap}{Numeric: Gap between legend groups.}\n\n\\item{x_showspikes}{Logical: If TRUE, show spikes on x-axis.}\n\n\\item{y_showspikes}{Logical: If TRUE, show spikes on y-axis.}\n\n\\item{spikedash}{Character: Dash type for spikes.}\n\n\\item{spikemode}{Character: Spike mode.}\n\n\\item{spikesnap}{Character: Spike snap mode.}\n\n\\item{spikecolor}{Color for spikes.}\n\n\\item{spikethickness}{Numeric: Thickness of spikes.}\n\n\\item{margin}{List: Plot margins.}\n\n\\item{main_y}{Numeric: Y position of main title.}\n\n\\item{main_yanchor}{Character: Y anchor for main title.}\n\n\\item{subtitle_x}{Numeric: X position of subtitle.}\n\n\\item{subtitle_y}{Numeric: Y position of subtitle.}\n\n\\item{subtitle_xref}{Character: X reference for subtitle.}\n\n\\item{subtitle_yref}{Character: Y reference for subtitle.}\n\n\\item{subtitle_xanchor}{Character: X anchor for subtitle.}\n\n\\item{subtitle_yanchor}{Character: Y anchor for subtitle.}\n\n\\item{automargin_x}{Logical: If TRUE, automatically adjust x-axis margins.}\n\n\\item{automargin_y}{Logical: If TRUE, automatically adjust y-axis margins.}\n\n\\item{xlim}{Numeric: Limits for x-axis.}\n\n\\item{ylim}{Numeric: Limits for y-axis.}\n\n\\item{axes_equal}{Logical: If TRUE, set equal scaling for axes.}\n\n\\item{diagonal}{Logical: If TRUE, add diagonal line.}\n\n\\item{diagonal_col}{Color for diagonal line.}\n\n\\item{diagonal_dash}{Character: \"solid\", \"dash\", \"dot\", \"dashdot\", \"longdash\", \"longdashdot\". Dash type for diagonal line.}\n\n\\item{diagonal_alpha}{Numeric: Alpha for diagonal line.}\n\n\\item{fit_params}{\\code{Hyperparameters} for fit.}\n\n\\item{vline}{Numeric: X position for vertical line.}\n\n\\item{vline_col}{Color for vertical line.}\n\n\\item{vline_width}{Numeric: Width for vertical line.}\n\n\\item{vline_dash}{Character: Dash type for vertical line.}\n\n\\item{hline}{Numeric: Y position for horizontal line.}\n\n\\item{hline_col}{Color for horizontal line.}\n\n\\item{hline_width}{Numeric: Width for horizontal line.}\n\n\\item{hline_dash}{Character: Dash type for horizontal line.}\n\n\\item{hovertext}{List: Hover text for markers.}\n\n\\item{width}{Numeric: Width of plot.}\n\n\\item{height}{Numeric: Height of plot.}\n\n\\item{displayModeBar}{Logical: If TRUE, display mode bar.}\n\n\\item{modeBar_file_format}{Character: File format for mode bar.}\n\n\\item{scrollZoom}{Logical: If TRUE, enable scroll zoom.}\n\n\\item{filename}{Character: Filename to save plot.}\n\n\\item{file_width}{Numeric: Width of saved file.}\n\n\\item{file_height}{Numeric: Height of saved file.}\n\n\\item{file_scale}{Numeric: Scale of saved file.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw interactive scatter plots using \\code{plotly}.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\ndraw_scatter(iris$Sepal.Length, iris$Petal.Length,\n fit = \"gam\", se_fit = TRUE, group = iris$Species\n)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_spectrogram.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_spectrogram.R\n\\name{draw_spectrogram}\n\\alias{draw_spectrogram}\n\\title{Interactive Spectrogram}\n\\usage{\ndraw_spectrogram(\n x,\n y,\n z,\n colorgrad_n = 101,\n colors = NULL,\n xlab = \"Time\",\n ylab = \"Frequency\",\n zlab = \"Power\",\n hover_xlab = xlab,\n hover_ylab = ylab,\n hover_zlab = zlab,\n zmin = NULL,\n zmax = NULL,\n zauto = TRUE,\n hoverlabel_align = \"right\",\n colorscale = \"Jet\",\n colorbar_y = 0.5,\n colorbar_yanchor = \"middle\",\n colorbar_xpad = 0,\n colorbar_ypad = 0,\n colorbar_len = 0.75,\n colorbar_title_side = \"bottom\",\n showgrid = FALSE,\n space = \"rgb\",\n lo = \"#18A3AC\",\n lomid = NULL,\n mid = NULL,\n midhi = NULL,\n hi = \"#F48024\",\n grid_gap = 0,\n limits = NULL,\n main = NULL,\n key_title = NULL,\n showticklabels = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n font_size = NULL,\n padding = 0,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n ...\n)\n}\n\\arguments{\n\\item{x}{Numeric: Time.}\n\n\\item{y}{Numeric: Frequency.}\n\n\\item{z}{Numeric: Power.}\n\n\\item{colorgrad_n}{Integer: Number of colors in the gradient.}\n\n\\item{colors}{Character: Custom colors for the gradient.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{zlab}{Character: z-axis label.}\n\n\\item{hover_xlab}{Character: x-axis label for hover.}\n\n\\item{hover_ylab}{Character: y-axis label for hover.}\n\n\\item{hover_zlab}{Character: z-axis label for hover.}\n\n\\item{zmin}{Numeric: Minimum value for color scale.}\n\n\\item{zmax}{Numeric: Maximum value for color scale.}\n\n\\item{zauto}{Logical: If TRUE, automatically set zmin and zmax.}\n\n\\item{hoverlabel_align}{Character: Alignment of hover labels.}\n\n\\item{colorscale}{Character: Color scale.}\n\n\\item{colorbar_y}{Numeric: Y position of colorbar.}\n\n\\item{colorbar_yanchor}{Character: Y anchor of colorbar.}\n\n\\item{colorbar_xpad}{Numeric: X padding of colorbar.}\n\n\\item{colorbar_ypad}{Numeric: Y padding of colorbar.}\n\n\\item{colorbar_len}{Numeric: Length of colorbar.}\n\n\\item{colorbar_title_side}{Character: Side of colorbar title.}\n\n\\item{showgrid}{Logical: If TRUE, show grid.}\n\n\\item{space}{Character: Color space for gradient.}\n\n\\item{lo}{Character: Low color for gradient.}\n\n\\item{lomid}{Character: Low-mid color for gradient.}\n\n\\item{mid}{Character: Mid color for gradient.}\n\n\\item{midhi}{Character: Mid-high color for gradient.}\n\n\\item{hi}{Character: High color for gradient.}\n\n\\item{grid_gap}{Integer: Space between cells.}\n\n\\item{limits}{Numeric, length 2: Determine color range. Default = NULL, which automatically centers values around 0.}\n\n\\item{main}{Character: Main title.}\n\n\\item{key_title}{Character: Title of the key.}\n\n\\item{showticklabels}{Logical: If TRUE, show tick labels.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{font_size}{Numeric: Font size.}\n\n\\item{padding}{Numeric: Padding between cells.}\n\n\\item{displayModeBar}{Logical: If TRUE, display the plotly mode bar.}\n\n\\item{modeBar_file_format}{Character: File format for image exports from the mode bar.}\n\n\\item{filename}{Character: Filename to save the plot. Default is NULL.}\n\n\\item{file_width}{Numeric: Width of exported image.}\n\n\\item{file_height}{Numeric: Height of exported image.}\n\n\\item{file_scale}{Numeric: Scale of exported image.}\n\n\\item{...}{Additional arguments to be passed to \\code{heatmaply::heatmaply}.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw interactive spectrograms using \\code{plotly}\n}\n\\details{\nTo set custom colors, use a minimum of \\code{lo} and \\code{hi}, optionally also\n\\code{lomid}, \\code{mid}, \\code{midhi} colors and set \\code{colorscale = NULL}.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\n# Example data\ntime <- seq(0, 10, length.out = 100)\nfreq <- seq(1, 100, length.out = 100)\npower <- outer(time, freq, function(t, f) sin(t) * cos(f))\ndraw_spectrogram(\n x = time,\n y = freq,\n z = power\n)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_survfit.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_survfit.R\n\\name{draw_survfit}\n\\alias{draw_survfit}\n\\title{Draw a survfit object}\n\\usage{\ndraw_survfit(\n x,\n mode = \"lines\",\n symbol = \"cross\",\n line_shape = \"hv\",\n xlim = NULL,\n ylim = NULL,\n xlab = \"Time\",\n ylab = \"Survival\",\n main = NULL,\n legend_xy = c(1, 1),\n legend_xanchor = \"right\",\n legend_yanchor = \"top\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n nrisk_table = FALSE,\n filename = NULL,\n ...\n)\n}\n\\arguments{\n\\item{x}{\\code{survfit} object created by \\link[survival:survfit]{survival::survfit}.}\n\n\\item{mode}{Character, vector: \"markers\", \"lines\", \"markers+lines\".}\n\n\\item{symbol}{Character: Symbol to use for the points.}\n\n\\item{line_shape}{Character: Line shape for line plots. Options: \"linear\", \"hv\", \"vh\", \"hvh\", \"vhv\".}\n\n\\item{xlim}{Numeric vector of length 2: x-axis limits.}\n\n\\item{ylim}{Numeric vector of length 2: y-axis limits.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{main}{Character: Main title.}\n\n\\item{legend_xy}{Numeric: Position of legend.}\n\n\\item{legend_xanchor}{Character: X anchor for legend.}\n\n\\item{legend_yanchor}{Character: Y anchor for legend.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{nrisk_table}{Logical: If \\code{TRUE}, subplot a table of the number at risk at each time point.}\n\n\\item{filename}{Character: Filename to save plot.}\n\n\\item{...}{Additional arguments passed to \\link{draw_scatter}.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw a \\code{survfit} object using \\link{draw_scatter}.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\n# Get the lung dataset\ndata(cancer, package = \"survival\")\nsf1 <- survival::survfit(survival::Surv(time, status) ~ 1, data = lung)\ndraw_survfit(sf1)\nsf2 <- survival::survfit(survival::Surv(time, status) ~ sex, data = lung)\ndraw_survfit(sf2)\n# with N at risk table\ndraw_survfit(sf2)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_table.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_table.R\n\\name{draw_table}\n\\alias{draw_table}\n\\title{Simple HTML table}\n\\usage{\ndraw_table(\n x,\n .ddSci = TRUE,\n main = NULL,\n main_col = \"black\",\n main_x = 0,\n main_xanchor = \"auto\",\n fill_col = \"#18A3AC\",\n table_bg = \"white\",\n bg = \"white\",\n line_col = \"white\",\n lwd = 1,\n header_font_col = \"white\",\n table_font_col = \"gray20\",\n font_size = 14,\n font_family = \"Helvetica Neue\",\n margin = list(l = 0, r = 5, t = 30, b = 0, pad = 0)\n)\n}\n\\arguments{\n\\item{x}{data.frame: Table to draw}\n\n\\item{.ddSci}{Logical: If TRUE, apply \\link{ddSci} to numeric columns.}\n\n\\item{main}{Character: Table tile.}\n\n\\item{main_col}{Color: Title color.}\n\n\\item{main_x}{Float [0, 1]: Align title: 0: left, .5: center, 1: right.}\n\n\\item{main_xanchor}{Character: \"auto\", \"left\", \"right\": plotly's layout xanchor for\ntitle.}\n\n\\item{fill_col}{Color: Used to fill header with column names and first column with\nrow names.}\n\n\\item{table_bg}{Color: Table background.}\n\n\\item{bg}{Color: Background.}\n\n\\item{line_col}{Color: Line color.}\n\n\\item{lwd}{Float: Line width.}\n\n\\item{header_font_col}{Color: Header font color.}\n\n\\item{table_font_col}{Color: Table font color.}\n\n\\item{font_size}{Integer: Font size.}\n\n\\item{font_family}{Character: Font family.}\n\n\\item{margin}{List: plotly's margins.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw an html table using \\code{plotly}\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\n df <- data.frame(\n Name = c(\"Alice\", \"Bob\", \"Charlie\"),\n Age = c(25, 30, 35),\n Score = c(90.5, 85.0, 88.0)\n)\np <- draw_table(\n df,\n main = \"Sample Table\",\n main_col = \"#00b2b2\"\n)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_ts.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_ts.R\n\\name{draw_ts}\n\\alias{draw_ts}\n\\title{Interactive Timeseries Plots}\n\\usage{\ndraw_ts(\n x,\n time,\n window = 7L,\n group = NULL,\n roll_fn = c(\"mean\", \"median\", \"max\", \"none\"),\n roll_col = NULL,\n roll_alpha = 1,\n roll_lwd = 2,\n roll_name = NULL,\n alpha = NULL,\n align = \"center\",\n group_names = NULL,\n xlab = \"Time\",\n n_xticks = 12,\n scatter_type = \"scatter\",\n legend = TRUE,\n x_showspikes = TRUE,\n y_showspikes = FALSE,\n spikedash = \"solid\",\n spikemode = \"across\",\n spikesnap = \"hovered data\",\n spikecolor = NULL,\n spikethickness = 1,\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = getOption(\"rtemis_palette\", \"rtms\"),\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n ...\n)\n}\n\\arguments{\n\\item{x}{Numeric vector of values to plot or list of vectors}\n\n\\item{time}{Numeric or Date vector of time corresponding to values of \\code{x}}\n\n\\item{window}{Integer: apply \\code{roll_fn} over this many units of time}\n\n\\item{group}{Factor defining groups}\n\n\\item{roll_fn}{Character: \"mean\", \"median\", \"max\", or \"sum\": Function to apply on\nrolling windows of \\code{x}}\n\n\\item{roll_col}{Color for rolling line}\n\n\\item{roll_alpha}{Numeric: transparency for rolling line}\n\n\\item{roll_lwd}{Numeric: width of rolling line}\n\n\\item{roll_name}{Rolling function name (for annotation)}\n\n\\item{alpha}{Numeric [0, 1]: Transparency}\n\n\\item{align}{Character: \"center\", \"right\", or \"left\"}\n\n\\item{group_names}{Character vector of group names}\n\n\\item{xlab}{Character: x-axis label}\n\n\\item{n_xticks}{Integer: number of x-axis ticks to use (approximately)}\n\n\\item{scatter_type}{Character: \"scatter\" or \"lines\"}\n\n\\item{legend}{Logical: If TRUE, show legend}\n\n\\item{x_showspikes}{Logical: If TRUE, show x-axis spikes on hover}\n\n\\item{y_showspikes}{Logical: If TRUE, show y-axis spikes on hover}\n\n\\item{spikedash}{Character: dash type string (\"solid\", \"dot\", \"dash\",\n\"longdash\", \"dashdot\", or \"longdashdot\") or a dash length list in px\n(eg \"5px,10px,2px,2px\")}\n\n\\item{spikemode}{Character: If \"toaxis\", spike line is drawn from the data\npoint to the axis the series is plotted on. If \"across\", the line is drawn\nacross the entire plot area, and supercedes \"toaxis\". If \"marker\", then a\nmarker dot is drawn on the axis the series is plotted on}\n\n\\item{spikesnap}{Character: \"data\", \"cursor\", \"hovered data\". Determines\nwhether spikelines are stuck to the cursor or to the closest datapoints.}\n\n\\item{spikecolor}{Color for spike lines}\n\n\\item{spikethickness}{Numeric: spike line thickness}\n\n\\item{displayModeBar}{Logical: If TRUE, display plotly's modebar}\n\n\\item{modeBar_file_format}{Character: modeBar image export file format}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{palette}{Character: palette name, or list of colors}\n\n\\item{filename}{Character: Path to filename to save plot}\n\n\\item{file_width}{Numeric: image export width}\n\n\\item{file_height}{Numeric: image export height}\n\n\\item{file_scale}{Numeric: image export scale}\n\n\\item{...}{Additional arguments to be passed to \\link{draw_scatter}}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nDraw interactive timeseries plots using \\code{plotly}\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\ntime <- sample(seq(as.Date(\"2020-03-01\"), as.Date(\"2020-09-23\"), length.out = 140))\nx1 <- rnorm(140)\nx2 <- rnorm(140, 1, 1.2)\n# Single timeseries\ndraw_ts(x1, time)\n# Multiple timeseries input as list\ndraw_ts(list(Alpha = x1, Beta = x2), time)\n# Multiple timeseries grouped by group, different lengths\ntime1 <- sample(seq(as.Date(\"2020-03-01\"), as.Date(\"2020-07-23\"), length.out = 100))\ntime2 <- sample(seq(as.Date(\"2020-05-01\"), as.Date(\"2020-09-23\"), length.out = 140))\ntime <- c(time1, time2)\nx <- c(rnorm(100), rnorm(140, 1, 1.5))\ngroup <- c(rep(\"Alpha\", 100), rep(\"Beta\", 140))\ndraw_ts(x, time, 7, group)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_varimp.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_varimp.R\n\\name{draw_varimp}\n\\alias{draw_varimp}\n\\title{Interactive Variable Importance Plot}\n\\usage{\ndraw_varimp(\n x,\n names = NULL,\n main = NULL,\n type = c(\"bar\", \"line\"),\n xlab = NULL,\n ylab = NULL,\n plot_top = 1,\n orientation = \"v\",\n line_width = 12,\n labelify = TRUE,\n alpha = 1,\n palette = get_palette(getOption(\"rtemis_palette\")),\n mar = NULL,\n font_size = 16,\n axis_font_size = 14,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n showlegend = TRUE,\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1\n)\n}\n\\arguments{\n\\item{x}{Numeric vector (or coercible to numeric): Input.}\n\n\\item{names}{Vector, string: Names of features.}\n\n\\item{main}{Character: Main title.}\n\n\\item{type}{Character: \"bar\" or \"line\".}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{plot_top}{Integer: Plot this many top features.}\n\n\\item{orientation}{Character: \"h\" or \"v\".}\n\n\\item{line_width}{Numeric: Line width.}\n\n\\item{labelify}{Logical: If TRUE, labelify feature names.}\n\n\\item{alpha}{Numeric: Transparency.}\n\n\\item{palette}{Character vector: Colors to use.}\n\n\\item{mar}{Vector, numeric, length 4: Plot margins in pixels (NOT inches).}\n\n\\item{font_size}{Integer: Overall font size to use (essentially for the\ntitle at this point).}\n\n\\item{axis_font_size}{Integer: Font size to use for axis labels and tick labels.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{showlegend}{Logical: If TRUE, show legend.}\n\n\\item{filename}{Character: Path to save the plot image.}\n\n\\item{file_width}{Numeric: Width of the saved plot image.}\n\n\\item{file_height}{Numeric: Height of the saved plot image.}\n\n\\item{file_scale}{Numeric: Scale of the saved plot image.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nPlot variable importance using \\code{plotly}\n}\n\\details{\nA simple \\code{plotly} wrapper to plot horizontal barplots, sorted by value,\nwhich can be used to visualize variable importance, model coefficients, etc.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\n# synthetic data\nx <- rnorm(10)\nnames(x) <- paste0(\"Feature_\", seq(x))\ndraw_varimp(x)\ndraw_varimp(x, orientation = \"h\")\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_volcano.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_volcano.R\n\\name{draw_volcano}\n\\alias{draw_volcano}\n\\title{Volcano Plot}\n\\usage{\ndraw_volcano(\n x,\n pvals,\n xnames = NULL,\n group = NULL,\n x_thresh = 0,\n p_thresh = 0.05,\n p_adjust_method = c(\"holm\", \"hochberg\", \"hommel\", \"bonferroni\", \"BH\", \"BY\", \"fdr\",\n \"none\"),\n p_transform = function(x) -log10(x),\n legend = NULL,\n legend_lo = NULL,\n legend_hi = NULL,\n label_lo = \"Low\",\n label_hi = \"High\",\n main = NULL,\n xlab = NULL,\n ylab = NULL,\n margin = list(b = 65, l = 65, t = 50, r = 10, pad = 0),\n xlim = NULL,\n ylim = NULL,\n alpha = NULL,\n hline = NULL,\n hline_col = NULL,\n hline_width = 1,\n hline_dash = \"solid\",\n hline_annotate = NULL,\n hline_annotation_x = 1,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n annotate = TRUE,\n annotate_col = theme[[\"labs_col\"]],\n font_size = 16,\n palette = NULL,\n legend_x_lo = NULL,\n legend_x_hi = NULL,\n legend_y = 0.97,\n annotate_n = 7L,\n ax_lo = NULL,\n ay_lo = NULL,\n ax_hi = NULL,\n ay_hi = NULL,\n annotate_alpha = 0.7,\n hovertext = NULL,\n displayModeBar = \"hover\",\n filename = NULL,\n file_width = 500,\n file_height = 500,\n file_scale = 1,\n verbosity = 1L,\n ...\n)\n}\n\\arguments{\n\\item{x}{Numeric vector: Input values, e.g. log2 fold change, coefficients, etc.}\n\n\\item{pvals}{Numeric vector: p-values.}\n\n\\item{xnames}{Character vector: \\code{x} names.}\n\n\\item{group}{Optional factor: Used to color code points. If NULL, significant points\nbelow \\code{x_thresh}, non-significant points, and significant points\nabove \\code{x_thresh} will be plotted with the first, second and third\ncolor of \\code{palette}.}\n\n\\item{x_thresh}{Numeric x-axis threshold separating low from high.}\n\n\\item{p_thresh}{Numeric: p-value threshold of significance.}\n\n\\item{p_adjust_method}{Character: p-value adjustment method.\n\"holm\", \"hochberg\", \"hommel\", \"bonferroni\", \"BH\", \"BY\", \"fdr\", \"none\".\nDefault = \"holm\". Use \"none\" for raw p-values.}\n\n\\item{p_transform}{function.}\n\n\\item{legend}{Logical: If TRUE, show legend. Will default to FALSE, if\n\\code{group = NULL}, otherwise to TRUE.}\n\n\\item{legend_lo}{Character: Legend to annotate significant points below the\n\\code{x_thresh}.}\n\n\\item{legend_hi}{Character: Legend to annotate significant points above the\n\\code{x_thresh}.}\n\n\\item{label_lo}{Character: label for low values.}\n\n\\item{label_hi}{Character: label for high values.}\n\n\\item{main}{Character: Main title.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{margin}{Named list of plot margins.\nDefault = \\code{list(b = 65, l = 65, t = 50, r = 10, pad = 0)}.}\n\n\\item{xlim}{Numeric vector, length 2: x-axis limits.}\n\n\\item{ylim}{Numeric vector, length 2: y-axis limits.}\n\n\\item{alpha}{Numeric: point transparency.}\n\n\\item{hline}{Numeric: If defined, draw a horizontal line at this y value.}\n\n\\item{hline_col}{Color for \\code{hline}.}\n\n\\item{hline_width}{Numeric: Width for \\code{hline}.}\n\n\\item{hline_dash}{Character: Type of line to draw: \"solid\", \"dot\", \"dash\",\n\"longdash\", \"dashdot\", or \"longdashdot\".}\n\n\\item{hline_annotate}{Character: Text of horizontal line annotation if\n\\code{hline} is set.}\n\n\\item{hline_annotation_x}{Numeric: x position to place annotation with paper\nas reference. 0: to the left of the plot area; 1: to the right of the plot area.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{annotate}{Logical: If TRUE, annotate significant points.}\n\n\\item{annotate_col}{Color for annotations.}\n\n\\item{font_size}{Integer: Font size.}\n\n\\item{palette}{Character vector: Colors to use. If \\code{group} is NULL, the first, second and third\ncolors will be used for significant points with negative coefficients, non-significant points, and\nsignificant points with positive coefficients, respectively. If \\code{group} is not NULL, colors will\nbe assigned to groups, in order of appearance.}\n\n\\item{legend_x_lo}{Numeric: x position of \\code{legend_lo}.}\n\n\\item{legend_x_hi}{Numeric: x position of \\code{legend_hi}.}\n\n\\item{legend_y}{Numeric: y position for \\code{legend_lo} and \\code{legend_hi}.}\n\n\\item{annotate_n}{Integer: Number of significant points to annotate.}\n\n\\item{ax_lo}{Numeric: Sets the x component of the arrow tail about the arrow head for\nsignificant points below \\code{x_thresh}.}\n\n\\item{ay_lo}{Numeric: Sets the y component of the arrow tail about the arrow head for\nsignificant points below \\code{x_thresh}.}\n\n\\item{ax_hi}{Numeric: Sets the x component of the arrow tail about the arrow head for\nsignificant points above \\code{x_thresh}.}\n\n\\item{ay_hi}{Numeric: Sets the y component of the arrow tail about the arrow head for\nsignificant points above \\code{x_thresh}.}\n\n\\item{annotate_alpha}{Numeric: Transparency for annotations.}\n\n\\item{hovertext}{Character vector: Text to display on hover.}\n\n\\item{displayModeBar}{Logical: If TRUE, display plotly mode bar.}\n\n\\item{filename}{Character: Path to save the plot image.}\n\n\\item{file_width}{Numeric: Width of the saved plot image.}\n\n\\item{file_height}{Numeric: Height of the saved plot image.}\n\n\\item{file_scale}{Numeric: Scale of the saved plot image.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n\n\\item{...}{Additional arguments passed to \\link{draw_scatter}.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nVolcano Plot\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\nset.seed(2019)\ny <- rnormmat(500, 500, return_df = TRUE)\nx <- data.frame(x = y[, 3] + y[, 5] - y[, 9] + y[, 15] + rnorm(500))\nmod <- massGLM(x, y)\ndraw_volcano(summary(mod)[[\"Coefficient_x\"]], summary(mod)[[\"p_value_x\"]])\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/draw_xt.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/draw_xt.R\n\\name{draw_xt}\n\\alias{draw_xt}\n\\title{Plot timeseries data}\n\\usage{\ndraw_xt(\n x,\n y,\n x2 = NULL,\n y2 = NULL,\n which_xy = NULL,\n which_xy2 = NULL,\n shade_bin = NULL,\n shade_interval = NULL,\n shade_col = NULL,\n shade_x = NULL,\n shade_name = \"\",\n shade_showlegend = FALSE,\n ynames = NULL,\n y2names = NULL,\n xlab = NULL,\n ylab = NULL,\n y2lab = NULL,\n xunits = NULL,\n yunits = NULL,\n y2units = NULL,\n yunits_col = NULL,\n y2units_col = NULL,\n zt = NULL,\n show_zt = TRUE,\n show_zt_every = NULL,\n zt_nticks = 18L,\n main = NULL,\n main_y = 1,\n main_yanchor = \"bottom\",\n x_nticks = 0,\n y_nticks = 0,\n show_rangeslider = NULL,\n slider_start = NULL,\n slider_end = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n palette = get_palette(getOption(\"rtemis_palette\")),\n font_size = 16,\n yfill = \"none\",\n y2fill = \"none\",\n fill_alpha = 0.2,\n yline_width = 2,\n y2line_width = 2,\n x_showspikes = TRUE,\n spike_dash = \"solid\",\n spike_col = NULL,\n x_spike_thickness = -2,\n tickfont_size = 16,\n x_tickmode = \"auto\",\n x_tickvals = NULL,\n x_ticktext = NULL,\n x_tickangle = NULL,\n legend_x = 0,\n legend_y = 1.1,\n legend_xanchor = \"left\",\n legend_yanchor = \"top\",\n legend_orientation = \"h\",\n margin = list(l = 75, r = 75, b = 75, t = 75),\n x_standoff = 20L,\n y_standoff = 20L,\n y2_standoff = 20L,\n hovermode = \"x\",\n displayModeBar = TRUE,\n modeBar_file_format = \"svg\",\n scrollZoom = TRUE,\n filename = NULL,\n file_width = 960,\n file_height = 500,\n file_scale = 1\n)\n}\n\\arguments{\n\\item{x}{Datetime vector or list of vectors.}\n\n\\item{y}{Numeric vector or named list of vectors: y-axis data.}\n\n\\item{x2}{Datetime vector or list of vectors, optional: must be provided if \\code{y2} does not\ncorrespond to values in \\code{x}. A single x-axis will be drawn for all values in \\code{x} and \\code{x2}.}\n\n\\item{y2}{Numeric vector, optional: If provided, a second y-axis will be added to the right\nside of the plot.}\n\n\\item{which_xy}{Integer vector: Indices of \\code{x} and \\code{y} to plot.\nIf not provided, will select up to the first two x-y traces.}\n\n\\item{which_xy2}{Integer vector: Indices of \\code{x2} and \\code{y2} to plot.\nIf not provided, will select up to the first two x2-y2 traces.}\n\n\\item{shade_bin}{Integer vector \\{0, 1\\}: Time points in \\code{x} to shade on the plot. For example,\nif there are 10 time points in \\code{x}, and you want to shade time points 3 to 7,\n\\code{shade_bin = c(0, 0, 1, 1, 1, 1, 1, 0, 0, 0)}. Only set \\code{shade_bin} or \\code{shade_interval}, not\nboth.}\n\n\\item{shade_interval}{List of numeric vectors: Intervals to shade on the plot. Only set\n\\code{shade_bin} or \\code{shade_interval}, not both.}\n\n\\item{shade_col}{Color: Color to shade intervals.}\n\n\\item{shade_x}{Numeric vector: x-values to use for shading.}\n\n\\item{shade_name}{Character: Name for shaded intervals.}\n\n\\item{shade_showlegend}{Logical: If TRUE, show legend for shaded intervals.}\n\n\\item{ynames}{Character vector, optional: Names for each vector in \\code{y}.}\n\n\\item{y2names}{Character vector, optional: Names for each vector in \\code{y2}.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{y2lab}{Character: y2-axis label.}\n\n\\item{xunits}{Character: x-axis units.}\n\n\\item{yunits}{Character: y-axis units.}\n\n\\item{y2units}{Character: y2-axis units.}\n\n\\item{yunits_col}{Color for y-axis units.}\n\n\\item{y2units_col}{Color for y2-axis units.}\n\n\\item{zt}{Numeric vector: Zeitgeber time. If provided, will be shown on the x-axis instead of\n\\code{x}. To be used only with a single \\code{x} vector and no \\code{x2}.}\n\n\\item{show_zt}{Logical: If TRUE, show zt on x-axis, if zt is provided.}\n\n\\item{show_zt_every}{Optional integer: Show zt every \\code{show_zt_every} ticks. If NULL, will be\ncalculated to be \\code{x_nticks} +/- 1 if \\code{x_nticks} is not 0, otherwise 12 +/- 1.}\n\n\\item{zt_nticks}{Integer: Number of zt ticks to show. Only used if \\code{show_zt_every} is NULL.\nThe actual number of ticks shown will depend on the periodicity of zt, so that zt = 0 is always\nincluded.}\n\n\\item{main}{Character: Main title.}\n\n\\item{main_y}{Numeric: Y position of main title.}\n\n\\item{main_yanchor}{Character: \"top\", \"middle\", \"bottom\".}\n\n\\item{x_nticks}{Integer: Number of ticks on x-axis.}\n\n\\item{y_nticks}{Integer: Number of ticks on y-axis.}\n\n\\item{show_rangeslider}{Logical: If TRUE, show a range slider.}\n\n\\item{slider_start}{Numeric: Start of range slider.}\n\n\\item{slider_end}{Numeric: End of range slider.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{palette}{Character vector: Colors to be used to draw each vector in \\code{y} and \\code{y2}, in order.}\n\n\\item{font_size}{Numeric: Font size for text.}\n\n\\item{yfill}{Character: Fill type for y-axis: \"none\", \"tozeroy\", \"tonexty\".}\n\n\\item{y2fill}{Character: Fill type for y2-axis: \"none\", \"tozeroy\", \"tonexty\".}\n\n\\item{fill_alpha}{Numeric: Fill opacity for y-axis.}\n\n\\item{yline_width}{Numeric: Line width for y-axis lines.}\n\n\\item{y2line_width}{Numeric: Line width for y2-axis lines.}\n\n\\item{x_showspikes}{Logical: If TRUE, show spikes on x-axis.}\n\n\\item{spike_dash}{Character: Dash type for spikes: \"solid\", \"dot\", \"dash\", \"longdash\",\n\"dashdot\", \"longdashdot\".}\n\n\\item{spike_col}{Color for spikes.}\n\n\\item{x_spike_thickness}{Numeric: Thickness of spikes. \\code{-2} avoids drawing border around spikes.}\n\n\\item{tickfont_size}{Numeric: Font size for tick labels.}\n\n\\item{x_tickmode}{Character: \"auto\", \"linear\", \"array\".}\n\n\\item{x_tickvals}{Numeric vector: Tick positions.}\n\n\\item{x_ticktext}{Character vector: Tick labels.}\n\n\\item{x_tickangle}{Numeric: Angle of tick labels.}\n\n\\item{legend_x}{Numeric: X position of legend.}\n\n\\item{legend_y}{Numeric: Y position of legend.}\n\n\\item{legend_xanchor}{Character: \"left\", \"center\", \"right\".}\n\n\\item{legend_yanchor}{Character: \"top\", \"middle\", \"bottom\".}\n\n\\item{legend_orientation}{Character: \"v\" for vertical, \"h\" for horizontal.}\n\n\\item{margin}{Named list with 4 numeric values: \"l\", \"r\", \"t\", \"b\" for left, right, top, bottom\nmargins.}\n\n\\item{x_standoff}{Numeric: Distance from x-axis to x-axis label.}\n\n\\item{y_standoff}{Numeric: Distance from y-axis to y-axis label.}\n\n\\item{y2_standoff}{Numeric: Distance from y2-axis to y2-axis label.}\n\n\\item{hovermode}{Character: \"closest\", \"x\", \"x unified\".}\n\n\\item{displayModeBar}{Logical: If TRUE, display plotly mode bar.}\n\n\\item{modeBar_file_format}{Character: \"png\", \"svg\", \"jpeg\", \"webp\", \"pdf\": file format for mode\nbar image export.}\n\n\\item{scrollZoom}{Logical: If TRUE, enable zooming by scrolling.}\n\n\\item{filename}{Character: Path to save the plot image.}\n\n\\item{file_width}{Numeric: Width of the saved plot image.}\n\n\\item{file_height}{Numeric: Height of the saved plot image.}\n\n\\item{file_scale}{Numeric: Scale of the saved plot image.}\n}\n\\value{\n\\code{plotly} object.\n}\n\\description{\nPlot timeseries data\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\ndatetime <- seq(\n as.POSIXct(\"2020-01-01 00:00\"),\n as.POSIXct(\"2020-01-02 00:00\"),\n by = \"hour\"\n)\ndf <- data.frame(\n datetime = datetime,\n value1 = rnorm(length(datetime)),\n value2 = rnorm(length(datetime))\n)\ndraw_xt(df, x = df[, 1], y = df[, 2:3])\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_describe.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_describe}\n\\alias{dt_describe}\n\\title{Describe data.table}\n\\usage{\ndt_describe(x, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{data.table: Input data.table.}\n\n\\item{verbosity}{Integer: If > 0, print output to console.}\n}\n\\value{\nList with three data.tables: Numeric, Categorical, and Date.\n}\n\\description{\nDescribe data.table\n}\n\\examples{\nlibrary(data.table)\norigin <- as.POSIXct(\"2022-01-01 00:00:00\", tz = \"America/Los_Angeles\")\nx <- data.table(\n ID = paste0(\"ID\", 1:10),\n V1 = rnorm(10),\n V2 = rnorm(10, 20, 3),\n V1_datetime = as.POSIXct(\n seq(\n 1, 1e7,\n length.out = 10\n ),\n origin = origin\n ),\n V2_datetime = as.POSIXct(\n seq(\n 1, 1e7,\n length.out = 10\n ),\n origin = origin\n ),\n C1 = sample(c(\"alpha\", \"beta\", \"gamma\"), 10, TRUE),\n F1 = factor(sample(c(\"delta\", \"epsilon\", \"zeta\"), 10, TRUE))\n)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_inspect_types.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_inspect_types}\n\\alias{dt_inspect_types}\n\\title{Inspect column types}\n\\usage{\ndt_inspect_types(x, cols = NULL, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{data.table: Input data.table.}\n\n\\item{cols}{Character vector: columns to inspect.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\nCharacter vector.\n}\n\\description{\nWill attempt to identify columns that should be numeric but are either character or\nfactor by running \\link{inspect_type} on each column.\n}\n\\examples{\nlibrary(data.table)\nx <- data.table(\n id = 8001:8006,\n a = c(\"3\", \"5\", \"undefined\", \"21\", \"4\", NA),\n b = c(\"mango\", \"banana\", \"tangerine\", NA, \"apple\", \"kiwi\"),\n c = c(1, 2, 3, 4, 5, 6)\n)\ndt_inspect_types(x)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_keybin_reshape.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_keybin_reshape}\n\\alias{dt_keybin_reshape}\n\\title{Long to wide key-value reshaping}\n\\usage{\ndt_keybin_reshape(\n x,\n id_name,\n key_name,\n positive = 1,\n negative = 0,\n xname = NULL,\n verbosity = 1L\n)\n}\n\\arguments{\n\\item{x}{\\code{data.table} object.}\n\n\\item{id_name}{Character: Name of column in \\code{x} that defines the IDs\nidentifying individual rows.}\n\n\\item{key_name}{Character: Name of column in \\code{x} that holds the key.}\n\n\\item{positive}{Numeric or Character: Used to fill id ~ key combination\npresent in the long format input \\code{x}.}\n\n\\item{negative}{Numeric or Character: Used to fill id ~ key combination\nNOT present in the long format input \\code{x}.}\n\n\\item{xname}{Character: Name of \\code{x} to be used in messages.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{data.table} in wide format.\n}\n\\description{\nReshape a long format \\code{data.table} using key-value pairs with\n\\code{data.table::dcast}\n}\n\\examples{\nlibrary(data.table)\nx <- data.table(\n ID = rep(1:3, each = 2),\n Dx = c(\"A\", \"C\", \"B\", \"C\", \"D\", \"A\")\n)\ndt_keybin_reshape(x, id_name = \"ID\", key_name = \"Dx\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_merge.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_merge}\n\\alias{dt_merge}\n\\title{Merge data.tables}\n\\usage{\ndt_merge(\n left,\n right,\n on = NULL,\n left_on = NULL,\n right_on = NULL,\n how = \"left\",\n left_name = NULL,\n right_name = NULL,\n left_suffix = NULL,\n right_suffix = NULL,\n verbosity = 1L,\n ...\n)\n}\n\\arguments{\n\\item{left}{data.table}\n\n\\item{right}{data.table}\n\n\\item{on}{Character: Name of column to join on.}\n\n\\item{left_on}{Character: Name of column on left table.}\n\n\\item{right_on}{Character: Name of column on right table.}\n\n\\item{how}{Character: Type of join: \"inner\", \"left\", \"right\", \"outer\".}\n\n\\item{left_name}{Character: Name of left table.}\n\n\\item{right_name}{Character: Name of right table.}\n\n\\item{left_suffix}{Character: If provided, add this suffix to all left column names,\nexcluding on/left_on.}\n\n\\item{right_suffix}{Character: If provided, add this suffix to all right column names,\nexcluding on/right_on.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n\n\\item{...}{Additional arguments to be passed to \\code{data.table::merge}.}\n}\n\\value{\nMerged data.table.\n}\n\\description{\nMerge data.tables\n}\n\\examples{\nlibrary(data.table)\nxleft <- data.table(ID = 1:5, Alpha = letters[1:5])\nxright <- data.table(ID = c(3, 4, 5, 6), Beta = LETTERS[3:6])\nxlr_inner <- dt_merge(xleft, xright, on = \"ID\", how = \"inner\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_names_by_attr.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_names_by_attr}\n\\alias{dt_names_by_attr}\n\\title{List column names by attribute}\n\\usage{\ndt_names_by_attr(x, attribute, exact = TRUE, sorted = TRUE)\n}\n\\arguments{\n\\item{x}{data.table: Input data.table.}\n\n\\item{attribute}{Character: name of attribute.}\n\n\\item{exact}{Logical: If TRUE, use exact matching.}\n\n\\item{sorted}{Logical: If TRUE, sort the output.}\n}\n\\value{\nCharacter vector.\n}\n\\description{\nList column names by attribute\n}\n\\examples{\nlibrary(data.table)\nx <- data.table(\n id = 1:5,\n sbp = rnorm(5, 120, 15),\n dbp = rnorm(5, 80, 10),\n paO2 = rnorm(5, 90, 10),\n paCO2 = rnorm(5, 40, 5)\n)\nsetattr(x[[\"id\"]], \"source\", \"demographics\")\nsetattr(x[[\"sbp\"]], \"source\", \"outpatient\")\nsetattr(x[[\"dbp\"]], \"source\", \"outpatient\")\nsetattr(x[[\"paO2\"]], \"source\", \"icu\")\nsetattr(x[[\"paCO2\"]], \"source\", \"icu\")\n\ndt_names_by_attr(x, \"source\", \"outpatient\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_nunique_perfeat.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_nunique_perfeat}\n\\alias{dt_nunique_perfeat}\n\\title{Number of unique values per feature}\n\\usage{\ndt_nunique_perfeat(x, excludeNA = FALSE, limit = 20L, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{data.table: Input data.table.}\n\n\\item{excludeNA}{Logical: If TRUE, exclude NA values.}\n\n\\item{limit}{Integer: Print up to this many features. Set to -1L to print all.}\n\n\\item{verbosity}{Integer: If > 0, print output to console.}\n}\n\\value{\nNamed integer vector of length \\code{NCOL(x)} with number of unique values per column/feature, invisibly.\n}\n\\description{\nNumber of unique values per feature\n}\n\\examples{\nlibrary(data.table)\nir <- as.data.table(iris)\ndt_nunique_perfeat(ir)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_pctmatch.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_pctmatch}\n\\alias{dt_pctmatch}\n\\title{Get N and percent match of values between two columns of two data.tables}\n\\usage{\ndt_pctmatch(x, y, on = NULL, left_on = NULL, right_on = NULL, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{data.table: First input data.table.}\n\n\\item{y}{data.table: Second input data.table.}\n\n\\item{on}{Integer or character: column to read in \\code{x} and \\code{y}, if it is the\nsame}\n\n\\item{left_on}{Integer or character: column to read in \\code{x}}\n\n\\item{right_on}{Integer or character: column to read in \\code{y}}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\nlist.\n}\n\\description{\nGet N and percent match of values between two columns of two data.tables\n}\n\\examples{\nlibrary(data.table)\nx <- data.table(ID = 1:5, Alpha = letters[1:5])\ny <- data.table(ID = c(3, 4, 5, 6), Beta = LETTERS[3:6])\ndt_pctmatch(x, y, on = \"ID\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_pctmissing.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_pctmissing}\n\\alias{dt_pctmissing}\n\\title{Get percent of missing values from every column}\n\\usage{\ndt_pctmissing(x, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{data.frame or data.table}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\nlist\n}\n\\description{\nGet percent of missing values from every column\n}\n\\examples{\nlibrary(data.table)\nx <- data.table(a = c(1, 2, NA, 4), b = c(NA, NA, 3, 4), c = c(\"A\", \"B\", \"C\", NA))\ndt_pctmissing(x)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_set_autotypes.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_set_autotypes}\n\\alias{dt_set_autotypes}\n\\title{Set column types automatically}\n\\usage{\ndt_set_autotypes(x, cols = NULL, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{data.table: Input data.table. Will be modified \\emph{\\strong{in-place}}, if needed.}\n\n\\item{cols}{Character vector: columns to work on. If not defined, will work on all\ncolumns}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\ndata.table, invisibly.\n}\n\\description{\nThis function inspects a data.table and attempts to identify columns that should be\nnumeric but have been read in as character, and fixes their type \\emph{\\strong{in-place}}.\nThis can happen when one or more fields contain non-numeric characters, for example.\n}\n\\examples{\nlibrary(data.table)\nx <- data.table(\n id = 8001:8006,\n a = c(\"3\", \"5\", \"undefined\", \"21\", \"4\", NA),\n b = c(\"mango\", \"banana\", \"tangerine\", NA, \"apple\", \"kiwi\"),\n c = c(1, 2, 3, 4, 5, 6)\n)\nstr(x)\n# ***in-place*** operation means no assignment is needed\ndt_set_autotypes(x)\nstr(x)\n\n# Try excluding column 'a' from autotyping\nx <- data.table(\n id = 8001:8006,\n a = c(\"3\", \"5\", \"undefined\", \"21\", \"4\", NA),\n b = c(\"mango\", \"banana\", \"tangerine\", NA, \"apple\", \"kiwi\"),\n c = c(1, 2, 3, 4, 5, 6)\n)\nstr(x)\n# exclude column 'a' from autotyping\ndt_set_autotypes(x, cols = setdiff(names(x), \"a\"))\nstr(x)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_set_clean_all.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_set_clean_all}\n\\alias{dt_set_clean_all}\n\\title{Clean column names and factor levels \\emph{\\strong{in-place}}}\n\\usage{\ndt_set_clean_all(x, prefix_digits = NA)\n}\n\\arguments{\n\\item{x}{data.table: Input data.table. Will be modified \\emph{\\strong{in-place}}, if needed.}\n\n\\item{prefix_digits}{Character: prefix to add to names beginning with a\ndigit. Set to NA to skip}\n}\n\\value{\nNothing, modifies \\code{x} \\emph{\\strong{in-place}}.\n}\n\\description{\nClean column names and factor levels \\emph{\\strong{in-place}}\n}\n\\examples{\nlibrary(data.table)\nx <- as.data.table(iris)\nlevels(x[[\"Species\"]]) <- c(\"setosa:iris\", \"versicolor$iris\", \"virginica iris\")\nnames(x)\nlevels(x[[\"Species\"]])\n# ***in-place*** operation means no assignment is needed\ndt_set_clean_all(x)\nnames(x)\nlevels(x[[\"Species\"]])\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_set_cleanfactorlevels.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_set_cleanfactorlevels}\n\\alias{dt_set_cleanfactorlevels}\n\\title{Clean factor levels of data.table \\emph{\\strong{in-place}}}\n\\usage{\ndt_set_cleanfactorlevels(x, prefix_digits = NA)\n}\n\\arguments{\n\\item{x}{data.table: Input data.table. Will be modified \\emph{\\strong{in-place}}.}\n\n\\item{prefix_digits}{Character: If not NA, add this prefix to all factor levels that\nare numbers}\n}\n\\value{\nNothing, modifies \\code{x} \\emph{\\strong{in-place}}.\n}\n\\description{\nFinds all factors in a data.table and cleans factor levels to include\nonly underscore symbols\n}\n\\examples{\nlibrary(data.table)\nx <- as.data.table(iris)\nlevels(x[[\"Species\"]]) <- c(\"setosa:iris\", \"versicolor$iris\", \"virginica iris\")\nlevels(x[[\"Species\"]])\ndt_set_cleanfactorlevels(x)\nlevels(x[[\"Species\"]])\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_set_logical2factor.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.table.R\n\\name{dt_set_logical2factor}\n\\alias{dt_set_logical2factor}\n\\title{Convert data.table logical columns to factors}\n\\usage{\ndt_set_logical2factor(\n x,\n cols = NULL,\n labels = c(\"False\", \"True\"),\n maintain_attributes = TRUE,\n fillNA = NULL\n)\n}\n\\arguments{\n\\item{x}{data.table: Input data.table. Will be modified \\emph{\\strong{in-place}}.}\n\n\\item{cols}{Optional Integer or character: columns to convert. If NULL, operates on all\nlogical columns.}\n\n\\item{labels}{Character: labels for factor levels.}\n\n\\item{maintain_attributes}{Logical: If TRUE, maintain column attributes.}\n\n\\item{fillNA}{Optional Character: If not NULL, fill NA values with this constant.}\n}\n\\value{\ndata.table, invisibly.\n}\n\\description{\nConvert data.table logical columns to factors with custom labels \\emph{\\strong{in-place}}\n}\n\\examples{\nlibrary(data.table)\nx <- data.table(a = 1:5, b = c(TRUE, FALSE, FALSE, FALSE, TRUE))\nx\ndt_set_logical2factor(x)\nx\nz <- data.table(\n alpha = 1:5,\n beta = c(TRUE, FALSE, TRUE, NA, TRUE),\n gamma = c(FALSE, FALSE, TRUE, FALSE, NA)\n)\n# You can usee fillNA to fill NA values with a constant\ndt_set_logical2factor(z, cols = \"beta\", labels = c(\"No\", \"Yes\"), fillNA = \"No\")\nz\nw <- data.table(mango = 1:5, banana = c(FALSE, FALSE, TRUE, TRUE, FALSE))\nw\ndt_set_logical2factor(w, cols = 2, labels = c(\"Ugh\", \"Huh\"))\nw\n# Column attributes are maintained by default:\nz <- data.table(\n alpha = 1:5,\n beta = c(TRUE, FALSE, TRUE, NA, TRUE),\n gamma = c(FALSE, FALSE, TRUE, FALSE, NA)\n)\nfor (i in seq_along(z)) setattr(z[[i]], \"source\", \"Guava\")\nstr(z)\ndt_set_logical2factor(z, cols = \"beta\", labels = c(\"No\", \"Yes\"))\nstr(z)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/dt_set_one_hot.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/preprocess.R\n\\name{dt_set_one_hot}\n\\alias{dt_set_one_hot}\n\\title{Convert data.table's factor to one-hot encoding \\emph{\\strong{in-place}}}\n\\usage{\ndt_set_one_hot(x, xname = NULL, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{data.table: Input data.table. Will be modified \\emph{\\strong{in-place}}.}\n\n\\item{xname}{Character, optional: Dataset name.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\nThe input, invisibly, after it has been modified \\emph{\\strong{in-place}}.\n}\n\\description{\nConvert data.table's factor to one-hot encoding \\emph{\\strong{in-place}}\n}\n\\examples{\nir <- data.table::as.data.table(iris)\n# dt_set_one_hot operates ***in-place***; therefore no assignment is used:\ndt_set_one_hot(ir)\nir\n}\n\\author{\nEDG\n}\n" }, { "path": "man/exc.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{exc}\n\\alias{exc}\n\\title{Exclude columns by character or numeric vector.}\n\\usage{\nexc(x, idx)\n}\n\\arguments{\n\\item{x}{tabular data.}\n\n\\item{idx}{Character or numeric vector: Column names or indices to exclude.}\n}\n\\value{\ndata.frame, tibble, or data.table.\n}\n\\description{\nExclude columns by character or numeric vector.\n}\n\\examples{\nexc(iris, \"Species\") |> head()\nexc(iris, c(1, 3)) |> head()\n}\n\\author{\nEDG\n}\n" }, { "path": "man/feature_matrix.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/preprocess.R\n\\name{feature_matrix}\n\\alias{feature_matrix}\n\\title{Convert tabular data to feature matrix}\n\\usage{\nfeature_matrix(x)\n}\n\\arguments{\n\\item{x}{tabular data: Input data to convert to a feature matrix.}\n}\n\\value{\nMatrix with features. Factors are one-hot encoded, if present.\n}\n\\description{\nConvert a tabular dataset to a matrix, one-hot encoding factors, if present.\n}\n\\details{\nThis is a convenience function that uses \\code{\\link[=features]{features()}}, \\code{\\link[=preprocess]{preprocess()}}, \\code{as.matrix()}.\n}\n\\examples{\n# reorder columns so that we have a categorical feature\nx <- set_outcome(iris, \"Sepal.Length\")\nfeature_matrix(x) |> head()\n}\n\\author{\nEDG\n}\n" }, { "path": "man/feature_names.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{feature_names}\n\\alias{feature_names}\n\\title{Get feature names}\n\\usage{\nfeature_names(x)\n}\n\\arguments{\n\\item{x}{tabular data.}\n}\n\\value{\nCharacter vector of feature names.\n}\n\\description{\nReturns all column names except the last one\n}\n\\details{\nThis applied to tabular datasets used for supervised learning in rtemis,\nwhere, by convention, the last column is the outcome variable and all other columns\nare features.\n}\n\\examples{\nfeature_names(iris)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/features.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{features}\n\\alias{features}\n\\title{Get features from tabular data}\n\\usage{\nfeatures(x)\n}\n\\arguments{\n\\item{x}{tabular data: Input data to get features from.}\n}\n\\value{\nObject of the same class as the input, after removing the last column.\n}\n\\description{\nReturns all columns except the last one.\n}\n\\details{\nThis can be applied to tabular datasets used for supervised learning in \\pkg{rtemis},\nwhere, by convention, the last column is the outcome variable and all other columns\nare features.\n}\n\\examples{\nfeatures(iris) |> head()\n}\n\\author{\nEDG\n}\n" }, { "path": "man/get_factor_names.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{get_factor_names}\n\\alias{get_factor_names}\n\\title{Get factor names}\n\\usage{\nget_factor_names(x)\n}\n\\arguments{\n\\item{x}{tabular data.}\n}\n\\value{\nCharacter vector of factor names.\n}\n\\description{\nGet factor names\n}\n\\details{\nThis applied to tabular datasets used for supervised learning in rtemis,\nwhere, by convention, the last column is the outcome variable and all other columns\nare features.\n}\n\\examples{\nget_factor_names(iris)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/get_mode.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils.R\n\\name{get_mode}\n\\alias{get_mode}\n\\title{Get the mode of a factor or integer}\n\\usage{\nget_mode(x, na.rm = TRUE, getlast = TRUE, retain_class = TRUE)\n}\n\\arguments{\n\\item{x}{Vector, factor or integer: Input data.}\n\n\\item{na.rm}{Logical: If TRUE, exclude NAs (using \\code{na.exclude(x)}).}\n\n\\item{getlast}{Logical: If TRUE, get the last value in case of ties.}\n\n\\item{retain_class}{Logical: If TRUE, output is always same class as input.}\n}\n\\value{\nThe mode of \\code{x}\n}\n\\description{\nReturns the mode of a factor or integer\n}\n\\examples{\nx <- c(9, 3, 4, 4, 0, 2, 2, NA)\nget_mode(x)\nx <- c(9, 3, 2, 2, 0, 4, 4, NA)\nget_mode(x)\nget_mode(x, getlast = FALSE)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/get_msg_sink.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/msg.R\n\\name{get_msg_sink}\n\\alias{get_msg_sink}\n\\title{Get the current rtemis message sink}\n\\usage{\nget_msg_sink()\n}\n\\value{\nThe currently registered sink function, or \\code{NULL} if none is set.\n}\n\\description{\nGet the current rtemis message sink\n}\n\\seealso{\n\\code{\\link[=set_msg_sink]{set_msg_sink()}}, \\code{\\link[=with_msg_sink]{with_msg_sink()}}.\n}\n\\author{\nEDG\n}\n" }, { "path": "man/get_palette.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_palettes.R\n\\name{get_palette}\n\\alias{get_palette}\n\\title{Get Color Palette}\n\\usage{\nget_palette(palette = NULL, verbosity = 1L)\n}\n\\arguments{\n\\item{palette}{Character: Name of palette to return. Default = NULL: available palette\nnames are printed and no palette is returned.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\nCharacter vector of colors for the specified palette, or invisibly returns\nlist of available palettes if \\code{palette = NULL}.\n}\n\\description{\n\\code{get_palette()} returns a color palette (character vector of colors).\nWithout arguments, prints names of available color palettes.\nEach palette is a named list of hexadecimal color definitions which can be used with\nany graphics function.\n}\n\\examples{\n# Print available palettes\nget_palette()\n# Get the Imperial palette\nget_palette(\"imperial\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/getnames.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_df.R\n\\name{getnames}\n\\alias{getnames}\n\\alias{getfactornames}\n\\alias{getnumericnames}\n\\alias{getlogicalnames}\n\\alias{getcharacternames}\n\\alias{getdatenames}\n\\title{Get names by string matching or class}\n\\usage{\ngetnames(\n x,\n pattern = NULL,\n starts_with = NULL,\n ends_with = NULL,\n ignore_case = TRUE\n)\n\ngetfactornames(x)\n\ngetnumericnames(x)\n\ngetlogicalnames(x)\n\ngetcharacternames(x)\n\ngetdatenames(x)\n}\n\\arguments{\n\\item{x}{object with \\code{names()} method.}\n\n\\item{pattern}{Character: pattern to match anywhere in names of x.}\n\n\\item{starts_with}{Character: pattern to match in the beginning of names of x.}\n\n\\item{ends_with}{Character: pattern to match at the end of names of x.}\n\n\\item{ignore_case}{Logical: If TRUE, well, ignore case.}\n}\n\\value{\nCharacter vector of matched names.\n}\n\\description{\nGet names by string matching or class\n}\n\\details{\nFor \\code{getnames()} only:\n\\code{pattern}, \\code{starts_with}, and \\code{ends_with} are applied sequentially.\nIf more than one is provided, the result will be the intersection of all matches.\n}\n\\examples{\ngetnames(iris, starts_with = \"Sepal\")\ngetnames(iris, ends_with = \"Width\")\ngetfactornames(iris)\ngetnumericnames(iris)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/getnamesandtypes.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_df.R\n\\name{getnamesandtypes}\n\\alias{getnamesandtypes}\n\\title{Get data.frame names and types}\n\\usage{\ngetnamesandtypes(x)\n}\n\\arguments{\n\\item{x}{data.frame / data.table or similar}\n}\n\\value{\ncharacter vector of column names with attribute \"type\" holding the class of each\ncolumn\n}\n\\description{\nGet data.frame names and types\n}\n\\examples{\ngetnamesandtypes(iris)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/grapes-BC-grapes.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/preprocess.R\n\\name{\\%BC\\%}\n\\alias{\\%BC\\%}\n\\title{Binary matrix times character vector}\n\\usage{\nx \\%BC\\% labels\n}\n\\arguments{\n\\item{x}{A binary matrix or data.frame}\n\n\\item{labels}{Character vector length equal to \\code{ncol(x)}}\n}\n\\value{\na character vector\n}\n\\description{\nBinary matrix times character vector\n}\n\\author{\nEDG\n}\n" }, { "path": "man/inc.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{inc}\n\\alias{inc}\n\\title{Select (include) columns by character or numeric vector.}\n\\usage{\ninc(x, idx)\n}\n\\arguments{\n\\item{x}{tabular data.}\n\n\\item{idx}{Character or numeric vector: Column names or indices to include.}\n}\n\\value{\ndata.frame, tibble, or data.table.\n}\n\\description{\nSelect (include) columns by character or numeric vector.\n}\n\\examples{\ninc(iris, c(3, 4)) |> head()\ninc(iris, c(\"Sepal.Length\", \"Species\")) |> head()\n}\n\\author{\nEDG\n}\n" }, { "path": "man/index_col_by_attr.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.R\n\\name{index_col_by_attr}\n\\alias{index_col_by_attr}\n\\title{Index columns by attribute name & value}\n\\usage{\nindex_col_by_attr(x, name, value, exact = TRUE)\n}\n\\arguments{\n\\item{x}{tabular data.}\n\n\\item{name}{Character: Name of attribute.}\n\n\\item{value}{Character: Value of attribute.}\n\n\\item{exact}{Logical: Passed to \\code{attr} when retrieving attribute value. If \\code{TRUE}, attribute\nname must match \\code{name} exactly, otherwise, partial match is allowed.}\n}\n\\value{\nInteger vector.\n}\n\\description{\nIndex columns by attribute name & value\n}\n\\examples{\nlibrary(data.table)\nx <- data.table(\n id = 1:5,\n sbp = rnorm(5, 120, 15),\n dbp = rnorm(5, 80, 10),\n paO2 = rnorm(5, 90, 10),\n paCO2 = rnorm(5, 40, 5)\n)\nsetattr(x[[\"sbp\"]], \"source\", \"outpatient\")\nsetattr(x[[\"dbp\"]], \"source\", \"outpatient\")\nsetattr(x[[\"paO2\"]], \"source\", \"icu\")\nsetattr(x[[\"paCO2\"]], \"source\", \"icu\")\nindex_col_by_attr(x, \"source\", \"icu\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/init_project_dir.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils.R\n\\name{init_project_dir}\n\\alias{init_project_dir}\n\\title{Initialize Project Directory}\n\\usage{\ninit_project_dir(path, output_dir = \"Out\", verbosity = 1L)\n}\n\\arguments{\n\\item{path}{Character: Path to initialize project directory in.}\n\n\\item{output_dir}{Character: Name of output directory to create.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\nCharacter: the path where the project directory was initialized, invisibly.\n}\n\\description{\nInitializes Directory Structure: \"R\", \"Data\", \"Results\"\n}\n\\examples{\n\\dontrun{\n# Will create \"my_project\" directory with\ninit_project_dir(\"my_project\")\n}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/inspect.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{inspect}\n\\alias{inspect}\n\\title{Inspect rtemis object}\n\\usage{\ninspect(x)\n}\n\\arguments{\n\\item{x}{R object to inspect.}\n}\n\\value{\nCalled for side effect of printing information to console; returns character string\ninvisibly.\n}\n\\description{\nInspect rtemis object\n}\n\\examples{\ninspect(iris)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/inspect_type.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.R\n\\name{inspect_type}\n\\alias{inspect_type}\n\\title{Inspect character and factor vector}\n\\usage{\ninspect_type(x, xname = NULL, verbosity = 1L, thresh = 0.5, na.omit = TRUE)\n}\n\\arguments{\n\\item{x}{Character or factor vector.}\n\n\\item{xname}{Character: Name of input vector \\code{x}.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n\n\\item{thresh}{Numeric: Threshold for determining whether to convert to numeric.}\n\n\\item{na.omit}{Logical: If TRUE, remove NA values before checking.}\n}\n\\value{\nCharacter.\n}\n\\description{\nChecks character or factor vector to determine whether it might be best to convert to\nnumeric.\n}\n\\details{\nAll data can be represented as a character string. A numeric variable may be read as\na character variable if there are non-numeric characters in the data.\nIt is important to be able to automatically detect such variables and convert them,\nwhich would mean introducing NA values.\n}\n\\examples{\nx <- c(\"3\", \"5\", \"undefined\", \"21\", \"4\", NA)\ninspect_type(x)\nz <- c(\"mango\", \"banana\", \"tangerine\", NA)\ninspect_type(z)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/is_constant.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils.R\n\\name{is_constant}\n\\alias{is_constant}\n\\title{Check if vector is constant}\n\\usage{\nis_constant(x, skip_missing = FALSE)\n}\n\\arguments{\n\\item{x}{Vector: Input}\n\n\\item{skip_missing}{Logical: If TRUE, skip NA values before test}\n}\n\\value{\nLogical.\n}\n\\description{\nCheck if vector is constant\n}\n\\examples{\nx <- rep(9, 1000000)\nis_constant(x)\nx[10] <- NA\nis_constant(x)\nis_constant(x, skip_missing = TRUE)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/labelify.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_strings.R\n\\name{labelify}\n\\alias{labelify}\n\\title{Format text for label printing}\n\\usage{\nlabelify(\n x,\n underscores_to_spaces = TRUE,\n dotsToSpaces = TRUE,\n toLower = FALSE,\n toTitleCase = TRUE,\n capitalize_strings = c(\"id\"),\n stringsToSpaces = c(\"\\\\\\\\$\", \"`\")\n)\n}\n\\arguments{\n\\item{x}{Character: Input}\n\n\\item{underscores_to_spaces}{Logical: If TRUE, convert underscores to spaces.}\n\n\\item{dotsToSpaces}{Logical: If TRUE, convert dots to spaces.}\n\n\\item{toLower}{Logical: If TRUE, convert to lowercase (precedes \\code{toTitleCase}).\nDefault = FALSE (Good for getting all-caps words converted to title case, bad for abbreviations\nyou want to keep all-caps)}\n\n\\item{toTitleCase}{Logical: If TRUE, convert to Title Case. Default = TRUE (This does not change\nall-caps words, set \\code{toLower} to TRUE if desired)}\n\n\\item{capitalize_strings}{Character, vector: Always capitalize these strings, if present. Default = \\code{\"id\"}}\n\n\\item{stringsToSpaces}{Character, vector: Replace these strings with spaces. Escape as needed for \\code{gsub}.\nDefault = \\code{\"\\\\\\\\$\"}, which formats common input of the type \\code{data.frame$variable}}\n}\n\\value{\nCharacter vector.\n}\n\\description{\nFormat text for label printing\n}\n\\examples{\nx <- c(\"county_name\", \"total.cost$\", \"age\", \"weight.kg\")\nlabelify(x)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/massGLM.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/massGLM.R\n\\name{massGLM}\n\\alias{massGLM}\n\\title{Mass-univariate GLM Analysis}\n\\usage{\nmassGLM(x, y, scale_y = NULL, center_y = NULL, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{tabular data: Predictor variables. Usually a small number of covariates.}\n\n\\item{y}{data.frame or similar: Each column is a different outcome. The function will train one\nGLM for each column of \\code{y}. Usually a large number of features.}\n\n\\item{scale_y}{Logical: If TRUE, scale each column of \\code{y} to have mean 0 and sd 1. If \\code{NULL},\ndefaults to TRUE if \\code{y} is numeric, FALSE otherwise.}\n\n\\item{center_y}{Logical: If TRUE, center each column of \\code{y} to have mean 0. If \\code{NULL}, defaults\nto TRUE if \\code{scale_y} is TRUE, FALSE otherwise.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{MassGLM} object.\n}\n\\description{\nMass-univariate GLM Analysis\n}\n\\examples{\nset.seed(2022)\ny <- rnormmat(500, 40, return_df = TRUE)\nx <- data.frame(\n x1 = y[[3]] - y[[5]] + y[[14]] + rnorm(500),\n x2 = y[[21]] + rnorm(500)\n)\nmassmod <- massGLM(x, y)\n# Print table of coefficients, p-values, etc. for all models\nsummary(massmod)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/matchcases.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.R\n\\name{matchcases}\n\\alias{matchcases}\n\\title{Match cases by covariates}\n\\usage{\nmatchcases(\n target,\n pool,\n n_matches = 1,\n target_id = NULL,\n pool_id = NULL,\n exactmatch_factors = TRUE,\n exactmatch_cols = NULL,\n distmatch_cols = NULL,\n norepeats = TRUE,\n ignore_na = FALSE,\n verbosity = 1L\n)\n}\n\\arguments{\n\\item{target}{data.frame you are matching against.}\n\n\\item{pool}{data.frame you are looking for matches from.}\n\n\\item{n_matches}{Integer: Number of matches to return.}\n\n\\item{target_id}{Character: Column name in \\code{target} that holds unique\ncases IDs. Default = NULL, in which case integer case numbers will be used.}\n\n\\item{pool_id}{Character: Same as \\code{target_id} for \\code{pool}.}\n\n\\item{exactmatch_factors}{Logical: If TRUE, selected cases will have to\nexactly match factors available in \\code{target}.}\n\n\\item{exactmatch_cols}{Character: Names of columns that should be matched\nexactly.}\n\n\\item{distmatch_cols}{Character: Names of columns that should be\ndistance-matched.}\n\n\\item{norepeats}{Logical: If TRUE, cases in \\code{pool} can only be chosen\nonce.}\n\n\\item{ignore_na}{Logical: If TRUE, ignore NA values during exact matching.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\ndata.frame\n}\n\\description{\nFind one or more cases from a \\code{pool} data.frame that match cases in a target\ndata.frame. Match exactly and/or by distance (sum of squared distances).\n}\n\\examples{\nset.seed(2021)\ncases <- data.frame(\n PID = paste0(\"PID\", seq(4)),\n Sex = factor(c(1, 1, 0, 0)),\n Handedness = factor(c(1, 1, 0, 1)),\n Age = c(21, 27, 39, 24),\n Var = c(.7, .8, .9, .6),\n Varx = rnorm(4)\n)\ncontrols <- data.frame(\n CID = paste0(\"CID\", seq(50)),\n Sex = factor(sample(c(0, 1), 50, TRUE)),\n Handedness = factor(sample(c(0, 1), 50, TRUE, c(.1, .9))),\n Age = sample(16:42, 50, TRUE),\n Var = rnorm(50),\n Vary = rnorm(50)\n)\n\nmc <- matchcases(cases, controls, 2, \"PID\", \"CID\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/mgetnames.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_df.R\n\\name{mgetnames}\n\\alias{mgetnames}\n\\title{Get names by string matching multiple patterns}\n\\usage{\nmgetnames(\n x,\n pattern = NULL,\n starts_with = NULL,\n ends_with = NULL,\n ignore_case = TRUE,\n return_index = FALSE\n)\n}\n\\arguments{\n\\item{x}{Character vector or object with \\code{names()} method.}\n\n\\item{pattern}{Character vector: pattern(s) to match anywhere in names of x.}\n\n\\item{starts_with}{Character: pattern to match in the beginning of names of x.}\n\n\\item{ends_with}{Character: pattern to match at the end of names of x.}\n\n\\item{ignore_case}{Logical: If TRUE, well, ignore case.}\n\n\\item{return_index}{Logical: If TRUE, return integer index of matches instead of names.}\n}\n\\value{\nCharacter vector of matched names or integer index.\n}\n\\description{\nGet names by string matching multiple patterns\n}\n\\details{\n\\code{pattern}, \\code{starts_with}, and \\code{ends_with} are applied and the union of all matches is returned.\n\\code{pattern} can be a character vector of multiple patterns to match.\n}\n\\examples{\nmgetnames(iris, pattern = c(\"Sepal\", \"Petal\"))\nmgetnames(iris, starts_with = \"Sepal\")\nmgetnames(iris, ends_with = \"Width\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/names_by_class.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.R\n\\name{names_by_class}\n\\alias{names_by_class}\n\\title{List column names by class}\n\\usage{\nnames_by_class(x, sorted = TRUE, item_format = highlight, maxlength = 24)\n}\n\\arguments{\n\\item{x}{tabular data.}\n\n\\item{sorted}{Logical: If TRUE, sort the output}\n\n\\item{item_format}{Function: Function to format each item}\n\n\\item{maxlength}{Integer: Maximum number of items to print}\n}\n\\value{\n\\code{NULL}, invisibly.\n}\n\\description{\nList column names by class\n}\n\\examples{\nnames_by_class(iris)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/one_hot2factor.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/preprocess.R\n\\name{one_hot2factor}\n\\alias{one_hot2factor}\n\\title{Convert one-hot encoded matrix to factor}\n\\usage{\none_hot2factor(x, labels = colnames(x))\n}\n\\arguments{\n\\item{x}{one-hot encoded matrix or data.frame.}\n\n\\item{labels}{Character vector of level names.}\n}\n\\value{\nA factor.\n}\n\\description{\nConvert one-hot encoded matrix to factor\n}\n\\details{\nIf input has a single column, it will be converted to factor and\nreturned\n}\n\\examples{\nx <- data.frame(matrix(FALSE, 10, 3))\ncolnames(x) <- c(\"Dx1\", \"Dx2\", \"Dx3\")\nx$Dx1[1:3] <- x$Dx2[4:6] <- x$Dx3[7:10] <- TRUE\none_hot2factor(x)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/outcome.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{outcome}\n\\alias{outcome}\n\\title{Get the outcome as a vector}\n\\usage{\noutcome(x)\n}\n\\arguments{\n\\item{x}{tabular data.}\n}\n\\value{\nVector containing the last column of \\code{x}.\n}\n\\description{\nReturns the last column of \\code{x}, which is by convention the outcome variable.\n}\n\\details{\nThis applied to tabular datasets used for supervised learning in rtemis,\nwhere, by convention, the last column is the outcome variable and all other columns\nare features.\n}\n\\examples{\noutcome(iris)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/outcome_name.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{outcome_name}\n\\alias{outcome_name}\n\\title{Get the name of the last column}\n\\usage{\noutcome_name(x)\n}\n\\arguments{\n\\item{x}{tabular data.}\n}\n\\value{\nName of the last column.\n}\n\\description{\nGet the name of the last column\n}\n\\details{\nThis applied to tabular datasets used for supervised learning in rtemis,\nwhere, by convention, the last column is the outcome variable and all other columns\nare features.\n}\n\\examples{\noutcome_name(iris)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/plot.MassGLM.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/08_MassUni.R\n\\name{plot.MassGLM}\n\\alias{plot.MassGLM}\n\\title{Plot MassGLM using volcano plot}\n\\usage{\n\\method{plot}{MassGLM}(\n x,\n coefname = NULL,\n p_adjust_method = \"holm\",\n p_transform = function(x) -log10(x),\n xlab = \"Coefficient\",\n ylab = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n verbosity = 1L,\n ...\n)\n}\n\\arguments{\n\\item{x}{MassGLM object trained using \\link{massGLM}.}\n\n\\item{coefname}{Character: Name of coefficient to plot. If \\code{NULL}, the first coefficient is used.}\n\n\\item{p_adjust_method}{Character: \"holm\", \"hochberg\", \"hommel\", \"bonferroni\", \"BH\", \"BY\", \"fdr\", \"none\" -\np-value adjustment method.}\n\n\\item{p_transform}{Function to transform p-values for plotting. Default is \\code{function(x) -log10(x)}.}\n\n\\item{xlab}{Character: x-axis label.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{theme}{\\code{Theme} object. Create using one of the \\code{theme_} functions, e.g.\n\\code{theme_whitegrid()}.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n\n\\item{...}{Additional arguments passed to \\link{draw_volcano}.}\n}\n\\value{\nplotly object with volcano plot.\n}\n\\description{\nPlot MassGLM using volcano plot\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\nset.seed(2019)\ny <- rnormmat(500, 500, return_df = TRUE)\nx <- data.frame(x = y[, 3] + y[, 5] - y[, 9] + y[, 15] + rnorm(500))\nmod <- massGLM(x, y)\nplot(mod)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/plot_manhattan.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R, R/08_MassUni.R\n\\name{plot_manhattan}\n\\alias{plot_manhattan}\n\\alias{plot_manhattan.MassGLM}\n\\title{Manhattan plot}\n\\usage{\nplot_manhattan(x, ...)\n\nplot_manhattan.MassGLM(\n x,\n coefname = NULL,\n p_adjust_method = c(\"holm\", \"hochberg\", \"hommel\", \"bonferroni\", \"BH\", \"BY\", \"fdr\",\n \"none\"),\n p_transform = function(x) -log10(x),\n ylab = NULL,\n theme = choose_theme(getOption(\"rtemis_theme\")),\n col_pos = \"#43A4AC\",\n col_neg = \"#FA9860\",\n alpha = 0.8,\n ...\n)\n}\n\\arguments{\n\\item{x}{MassGLM object.}\n\n\\item{...}{Additional arguments passed to \\link{draw_bar}.}\n\n\\item{coefname}{Character: Name of coefficient to plot. If \\code{NULL}, the first coefficient is used.}\n\n\\item{p_adjust_method}{Character: \"holm\", \"hochberg\", \"hommel\", \"bonferroni\", \"BH\", \"BY\", \"fdr\", \"none\" -\np-value adjustment method.}\n\n\\item{p_transform}{Function to transform p-values for plotting. Default is \\code{function(x) -log10(x)}.}\n\n\\item{ylab}{Character: y-axis label.}\n\n\\item{theme}{\\code{Theme} object.}\n\n\\item{col_pos}{Character: Color for positive significant coefficients.}\n\n\\item{col_neg}{Character: Color for negative significant coefficients.}\n\n\\item{alpha}{Numeric: Transparency level for the bars.}\n}\n\\value{\nplotly object.\n}\n\\description{\nDraw a Manhattan plot for \\code{MassGLM} objects created with \\link{massGLM}.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\n# x: outcome of interest as first column, optional covariates in the other columns\n# y: features whose association with x we want to study\nset.seed(2022)\ny <- data.table(rnormmat(500, 40))\nx <- data.table(\n x1 = y[[3]] - y[[5]] + y[[14]] + rnorm(500),\n x2 = y[[21]] + rnorm(500)\n)\nmassmod <- massGLM(x, y)\nplot_manhattan(massmod)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/plot_roc.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{plot_roc}\n\\alias{plot_roc}\n\\title{Plot ROC curve}\n\\usage{\nplot_roc(x, ...)\n}\n\\arguments{\n\\item{x}{\\code{Classification} or \\code{ClassificationRes} object.}\n\n\\item{...}{Additional arguments passed to the plotting function.}\n}\n\\value{\nA plotly object containing the ROC curve.\n}\n\\description{\nThis generic is used to plot the ROC curve for a model.\n}\n\\examples{\nir <- iris[51:150, ]\nir[[\"Species\"]] <- factor(ir[[\"Species\"]])\nspecies_glm <- train(ir, algorithm = \"GLM\")\nplot_roc(species_glm)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/plot_true_pred.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{plot_true_pred}\n\\alias{plot_true_pred}\n\\title{Plot True vs. Predicted Values}\n\\usage{\nplot_true_pred(x, ...)\n}\n\\arguments{\n\\item{x}{\\code{Supervised} or \\code{SupervisedRes} object.}\n\n\\item{...}{Additional arguments passed to methods.}\n}\n\\value{\nplotly object.\n}\n\\description{\nPlot True vs. Predicted Values for Supervised objects.\nFor classification, it plots a confusion matrix.\nFor regression, it plots a scatter plot of true vs. predicted values.\n}\n\\examples{\nx <- set_outcome(iris, \"Sepal.Length\")\nsepallength_glm <- train(x, algorithm = \"GLM\")\nplot_true_pred(sepallength_glm)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/plot_varimp.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{plot_varimp}\n\\alias{plot_varimp}\n\\title{Plot Variable Importance}\n\\usage{\nplot_varimp(x, ...)\n}\n\\arguments{\n\\item{x}{\\code{Supervised} or \\code{SupervisedRes} object.}\n\n\\item{...}{Additional arguments passed to methods.}\n}\n\\value{\nplotly object or invisible NULL if no variable importance is available.\n}\n\\description{\nPlot Variable Importance for Supervised objects.\n}\n\\details{\nThis method calls \\link{draw_varimp} internally.\nIf you pass an integer to the \\code{plot_top} argument, the method will plot this many top features.\nIf you pass a number between 0 and 1 to the \\code{plot_top} argument, the method will plot this\nfraction of top features.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\nir <- set_outcome(iris, \"Sepal.Length\")\nseplen_cart <- train(ir, algorithm = \"CART\")\nplot_varimp(seplen_cart)\n# Plot horizontally\nplot_varimp(seplen_cart, orientation = \"h\")\nplot_varimp(seplen_cart, orientation = \"h\", plot_top = 3L)\nplot_varimp(seplen_cart, orientation = \"h\", plot_top = 0.5)\n\\dontshow{\\}) # examplesIf}\n}\n\\seealso{\n\\link{draw_varimp}, which is called by this method\n}\n\\author{\nEDG\n}\n" }, { "path": "man/preprocess.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R, R/preprocess.R\n\\name{preprocess}\n\\alias{preprocess}\n\\alias{preprocess.class_tabular.PreprocessorConfig}\n\\alias{preprocess.class_tabular.Preprocessor}\n\\title{Preprocess Data}\n\\usage{\npreprocess(x, config, ...)\n\npreprocess.class_tabular.PreprocessorConfig(\n x,\n config,\n dat_validation = NULL,\n dat_test = NULL,\n verbosity = 1L\n)\n\npreprocess.class_tabular.Preprocessor(x, config, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{data.frame, data.table, tbl_df (tabular data): Data to be preprocessed.}\n\n\\item{config}{\\code{PreprocessorConfig}: Setup using \\link{setup_Preprocessor} OR \\code{Preprocessor} object:\nOutput of previous run of \\code{preprocess}. This allows, for example, applying preprocessing to a\nvalidation or test set using the same parameters as were used for the training set. In\nparticular, the same scale centers and coefficients will be applied to the new data.}\n\n\\item{...}{Not used.}\n\n\\item{dat_validation}{tabular data: Validation set data.}\n\n\\item{dat_test}{tabular data: Test set data.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{Preprocessor} object.\n}\n\\description{\nPreprocess data for analysis and visualization.\n}\n\\details{\nMethods are provided for preprocessing training set data, which accepts a \\code{PreprocessorConfig}\nobject, and for preprocessing validation and test set data, which accept a \\code{Preprocessor}\nobject.\n}\n\\examples{\n# Setup a `Preprocessor`: this outputs a `PreprocessorConfig` object.\nprp <- setup_Preprocessor(remove_duplicates = TRUE, scale = TRUE, center = TRUE)\n\n# Includes a long list of parameters\nprp\n\n# Resample iris to get train and test data\nres <- resample(iris, setup_Resampler(seed = 2026))\niris_train <- iris[res[[1]], ]\niris_test <- iris[-res[[1]], ]\n\n# Preprocess training data\niris_pre <- preprocess(iris_train, prp)\n\n# Access preprocessd training data with `preprocessed()`\npreprocessed(iris_pre)\n\n# Apply the same preprocessing to test data\n# In this case, the scale and center values from training data will be used.\n# Note how `preprocess()` accepts either a `PreprocessorConfig` or `Preprocessor` object for\n# this reason.\niris_test_pre <- preprocess(iris_test, iris_pre)\n\n# Access preprocessed test data\npreprocessed(iris_test_pre)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/preprocessed.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{preprocessed}\n\\alias{preprocessed}\n\\title{Get preprocessed data from \\code{Preprocessor}.}\n\\usage{\npreprocessed(x)\n}\n\\arguments{\n\\item{x}{\\code{Preprocessor}: A \\code{Preprocessor} object.}\n}\n\\value{\ndata.frame: The preprocessed data.\n}\n\\description{\nReturns the preprocessed data from a \\code{Preprocessor} object.\n}\n\\examples{\nprp <- preprocess(iris, setup_Preprocessor(scale = TRUE, center = TRUE))\npreprocessed(prp)\n}\n" }, { "path": "man/present.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{present}\n\\alias{present}\n\\title{Present rtemis object}\n\\usage{\npresent(x, ...)\n}\n\\arguments{\n\\item{x}{\\code{Supervised} or \\code{SupervisedRes} object or list of such objects.}\n\n\\item{...}{Additional arguments passed to the plotting function.}\n}\n\\value{\nA plotly object.\n}\n\\description{\nThis generic is used to present an rtemis object by printing to console and drawing plots.\n}\n\\examples{\n\\dontshow{if (interactive()) withAutoprint(\\{ # examplesIf}\nir <- set_outcome(iris, \"Sepal.Length\")\nseplen_lightrf <- train(ir, algorithm = \"lightrf\")\npresent(seplen_lightrf)\n\\dontshow{\\}) # examplesIf}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/previewcolor.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_color.R\n\\name{previewcolor}\n\\alias{previewcolor}\n\\title{Preview color}\n\\usage{\npreviewcolor(\n x,\n main = NULL,\n bg = \"#333333\",\n main_col = \"#b3b3b3\",\n main_x = 0.7,\n main_y = 0.2,\n main_adj = 0,\n main_cex = 0.9,\n main_font = 2,\n width = NULL,\n xlim = NULL,\n ylim = c(0, 2.2),\n asp = 1,\n labels_y = 1.55,\n label_cex = NULL,\n mar = c(0, 0, 0, 1),\n filename = NULL,\n pdf_width = 8,\n pdf_height = 2.5\n)\n}\n\\arguments{\n\\item{x}{Color, vector: One or more colors that R understands}\n\n\\item{main}{Character: Title. Default = NULL, which results in\n\\code{deparse(substitute(x))}}\n\n\\item{bg}{Background color.}\n\n\\item{main_col}{Color: Title color}\n\n\\item{main_x}{Float: x coordinate for \\code{main}.}\n\n\\item{main_y}{Float: y coordinate for \\code{main}.}\n\n\\item{main_adj}{Float: \\code{adj} argument to mtext for \\code{main}.}\n\n\\item{main_cex}{Float: character expansion factor for \\code{main}.}\n\n\\item{main_font}{Integer, 1 or 2: Weight of \\code{main} 1: regular, 2: bold.}\n\n\\item{width}{Float: Plot width. Default = NULL, i.e. set automatically}\n\n\\item{xlim}{Vector, length 2: x-axis limits. Default = NULL, i.e. set automatically}\n\n\\item{ylim}{Vector, length 2: y-axis limits.}\n\n\\item{asp}{Float: Plot aspect ratio.}\n\n\\item{labels_y}{Float: y coord for labels. Default = 1.55 (rhombi are fixed and range y .5 - 1.5)}\n\n\\item{label_cex}{Float: Character expansion for labels. Default = NULL, and is\ncalculated automatically based on length of \\code{x}}\n\n\\item{mar}{Numeric vector, length 4: margin size.}\n\n\\item{filename}{Character: Path to save plot as PDF.}\n\n\\item{pdf_width}{Numeric: Width of PDF in inches.}\n\n\\item{pdf_height}{Numeric: Height of PDF in inches.}\n}\n\\value{\nNothing, prints plot.\n}\n\\description{\nPreview one or multiple colors using little rhombi with their little labels up top\n}\n\\examples{\npreviewcolor(get_palette(\"rtms\"))\n}\n\\author{\nEDG\n}\n" }, { "path": "man/read.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/read.R\n\\name{read}\n\\alias{read}\n\\title{Read tabular data from a variety of formats}\n\\usage{\nread(\n filename,\n datadir = NULL,\n make_unique = FALSE,\n character2factor = FALSE,\n clean_colnames = TRUE,\n delim_reader = c(\"data.table\", \"vroom\", \"duckdb\", \"arrow\"),\n xlsx_sheet = 1,\n sep = NULL,\n quote = \"\\\\\"\",\n na_strings = c(\"\"),\n output = c(\"data.table\", \"tibble\", \"data.frame\"),\n attr = NULL,\n value = NULL,\n verbosity = 1L,\n fread_verbosity = 0L,\n timed = verbosity > 0L,\n ...\n)\n}\n\\arguments{\n\\item{filename}{Character: filename or full path if \\code{datadir = NULL}.}\n\n\\item{datadir}{Character: Optional path to directory where \\code{filename}\nis located. If not specified, \\code{filename} must be the full path.}\n\n\\item{make_unique}{Logical: If TRUE, keep unique rows only.}\n\n\\item{character2factor}{Logical: If TRUE, convert character variables to\nfactors.}\n\n\\item{clean_colnames}{Logical: If TRUE, clean columns names using\n\\link{clean_colnames}.}\n\n\\item{delim_reader}{Character: package to use for reading delimited data.}\n\n\\item{xlsx_sheet}{Integer or character: Name or number of XLSX sheet to read.}\n\n\\item{sep}{Single character: field separator. If \\code{delim_reader = \"fread\"}\nand \\code{sep = NULL}, this defaults to \"auto\", otherwise defaults to \",\".}\n\n\\item{quote}{Single character: quote character.}\n\n\\item{na_strings}{Character vector: Strings to be interpreted as NA values.\nFor \\code{delim_reader = \"duckdb\"}, this must be a single string.}\n\n\\item{output}{Character: \"default\" or \"data.table\", If default, return the delim_reader's\ndefault data structure, otherwise convert to data.table.}\n\n\\item{attr}{Character: Attribute to set (Optional).}\n\n\\item{value}{Character: Value to set (if \\code{attr} is not NULL).}\n\n\\item{verbosity}{Integer: Verbosity level.}\n\n\\item{fread_verbosity}{Integer: Verbosity level. Passed to \\code{data.table::fread}}\n\n\\item{timed}{Logical: If TRUE, time the process and print to console}\n\n\\item{...}{Additional arguments to pass to \\code{data.table::fread},\n\\code{arrow::read_delim_arrow()}, \\code{vroom::vroom()},\nor \\code{readxl::read_excel()}.}\n}\n\\value{\ndata.frame, data.table, or tibble.\n}\n\\description{\nRead data and optionally clean column names, keep unique rows, and convert\ncharacters to factors\n}\n\\details{\n\\code{read} is a convenience function to read:\n\\itemize{\n\\item \\strong{Delimited} files using \\code{data.table:fread()}, \\code{arrow:read_delim_arrow()},\n\\code{vroom::vroom()}, or \\code{duckdb::duckdb_read_csv()}\n\\item \\strong{ARFF} files using \\code{farff::readARFF()}\n\\item \\strong{Parquet} files using \\code{arrow::read_parquet()}\n\\item \\strong{XLSX} files using \\code{readxl::read_excel()}\n\\item \\strong{DTA} files from Stata using \\code{haven::read_dta()}\n\\item \\strong{FASTA} files using \\code{seqinr::read.fasta()}\n\\item \\strong{RDS} files using \\code{readRDS()}\n}\n}\n\\examples{\n\\dontrun{\n# Replace with your own data directory and filename\ndatadir <- \"/Data\"\ndat <- read(\"iris.csv\", datadir)\n}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/read_config.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/14_SuperConfig.R\n\\name{read_config}\n\\alias{read_config}\n\\title{Read \\code{SuperConfig} from TOML file}\n\\usage{\nread_config(file)\n}\n\\arguments{\n\\item{file}{Character: Path to input TOML file.}\n}\n\\value{\n\\code{SuperConfig} object.\n}\n\\description{\nRead \\code{SuperConfig} object from TOML file that was written with \\code{write_toml()}.\n}\n\\examples{\n# Create a SuperConfig object\nx <- setup_SuperConfig(\n dat_training_path = \"~/Data/iris.csv\",\n algorithm = \"LightRF\",\n hyperparameters = setup_LightRF()\n)\n# Write TOML file\ntmpdir <- tempdir()\ntmpfile <- file.path(tmpdir, \"rtemis_test.toml\")\nwrite_toml(x, tmpfile)\n# Read config from TOML file\nx_read <- read_config(tmpfile)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/regression_metrics.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/metrics.R\n\\name{regression_metrics}\n\\alias{regression_metrics}\n\\title{Regression Metrics}\n\\usage{\nregression_metrics(true, predicted, na.rm = TRUE, sample = NULL)\n}\n\\arguments{\n\\item{true}{Numeric vector: True values.}\n\n\\item{predicted}{Numeric vector: Predicted values.}\n\n\\item{na.rm}{Logical: If TRUE, remove NA values before computation.}\n\n\\item{sample}{Character: Sample name (e.g. \"training\", \"test\").}\n}\n\\value{\n\\code{RegressionMetrics} object.\n}\n\\description{\nRegression Metrics\n}\n\\examples{\ntrue <- rnorm(100)\npredicted <- true + rnorm(100, sd = 0.5)\nregression_metrics(true, predicted)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/resample.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/resample.R\n\\name{resample}\n\\alias{resample}\n\\title{Resample data}\n\\usage{\nresample(x, config = setup_Resampler(), verbosity = 1L)\n}\n\\arguments{\n\\item{x}{Vector or data.frame: Usually the outcome; \\code{NROW(x)} defines the sample size.}\n\n\\item{config}{Resampler object created by \\link{setup_Resampler}.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{Resampler} object.\n}\n\\description{\nCreate resamples of your data, e.g. for model building or validation.\n\"KFold\" creates stratified folds, , \"StratSub\" creates stratified subsamples,\n\"Bootstrap\" gives the standard bootstrap, i.e. random sampling with replacement,\nwhile \"StratBoot\" uses StratSub and then randomly duplicates some of the training cases to\nreach original length of input (default) or length defined by \\code{target_length}.\n}\n\\details{\nNote that option 'KFold' may result in resamples of slightly different length. Avoid all\noperations which rely on equal-length vectors. For example, you can't place resamples in a\ndata.frame, but must use a list instead.\n}\n\\examples{\ny <- rnorm(200)\n# 10-fold (stratified)\ny_10fold <- resample(y, setup_Resampler(10L, \"kfold\"))\ny_10fold\n# 25 stratified subsamples\ny_25strat <- resample(y, setup_Resampler(25L, \"stratsub\"))\ny_25strat\n# 100 stratified bootstraps\ny_100strat <- resample(y, setup_Resampler(100L, \"stratboot\"))\ny_100strat\n# LOOCV\ny_loocv <- resample(y, setup_Resampler(type = \"LOOCV\"))\ny_loocv\n}\n\\author{\nEDG\n}\n" }, { "path": "man/rnormmat.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils.R\n\\name{rnormmat}\n\\alias{rnormmat}\n\\title{Random Normal Matrix}\n\\usage{\nrnormmat(\n nrow = 10,\n ncol = 10,\n mean = 0,\n sd = 1,\n return_df = FALSE,\n seed = NULL\n)\n}\n\\arguments{\n\\item{nrow}{Integer: Number of rows.}\n\n\\item{ncol}{Integer: Number of columns.}\n\n\\item{mean}{Float: Mean.}\n\n\\item{sd}{Float: Standard deviation.}\n\n\\item{return_df}{Logical: If TRUE, return data.frame, otherwise matrix.}\n\n\\item{seed}{Integer: Set seed for \\code{rnorm}.}\n}\n\\value{\n\\code{matrix} or \\code{data.frame}.\n}\n\\description{\nCreate a matrix or data frame of defined dimensions, whose columns are random normal vectors\n}\n\\examples{\nx <- rnormmat(20, 5, mean = 12, sd = 6, return_df = TRUE, seed = 2026)\nx\n}\n\\author{\nEDG\n}\n" }, { "path": "man/rtemis-package.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/rtemis-package.R\n\\docType{package}\n\\name{rtemis-package}\n\\alias{rtemis}\n\\alias{rtemis-package}\n\\title{\\pkg{rtemis}: Advanced Machine Learning and Visualization}\n\\description{\nAdvanced Machine Learning & Visualization made efficient, accessible, reproducible\n}\n\\section{Online Documentation and Vignettes}{\n\n\\url{https://docs.rtemis.org/r/ml}\n}\n\n\\section{System Setup}{\n\nThere are some options you can define in your .Rprofile (usually found in your home directory),\nso you do not have to define each time you execute a function.\n\\describe{\n\\item{rtemis_theme}{General plotting theme; set to e.g. \"whiteigrid\" or \"darkgraygrid\"}\n\\item{rtemis_font}{Font family to use in plots.}\n\\item{rtemis_palette}{Name of default palette to use in plots. See options by running \\code{get_palette()}}\n}\n}\n\n\\section{Visualization}{\n\nGraphics are handled using the \\code{draw} family, which produces interactive plots primarily using\n\\code{plotly} and other packages.\n}\n\n\\section{Supervised Learning}{\n\nBy convention, the last column of the data is the outcome variable, and all other columns are\npredictors. Convenience function \\link{set_outcome} can be used to move a specified column to the\nend of the data.\nRegression and Classification is performed using \\code{train()}.\nThis function allows you to preprocess, train, tune, and test models on multiple resamples.\nUse \\link{available_supervised} to get a list of available algorithms\n}\n\n\\section{Classification}{\n\nFor training of binary classification models, the outcome should be provided as a factor,\nwith the \\emph{second} level of the factor being the 'positive' class.\n}\n\n\\section{Clustering}{\n\nClustering is performed using \\code{cluster()}.\nUse \\link{available_clustering} to get a list of available algorithms.\n}\n\n\\section{Decomposition}{\n\nDecomposition is performed using \\code{decomp()}.\nUse \\link{available_decomposition} to get a list of available algorithms.\n}\n\n\\section{Type Documentation}{\n\nFunction documentation includes input type (e.g. \"Character\", \"Integer\",\n\"Float\"/\"Numeric\", etc).\nWhen applicable, value ranges are provided in interval notation. For example, Float: [0, 1)\nmeans floats between 0 and 1 including 0, but excluding 1.\nCategorical variables may include set of allowed values using curly braces.\nFor example, Character: \\{\"future\", \"mirai\", \"none\"\\}.\n}\n\n\\section{Tabular Data}{\n\n\\pkg{rtemis} internally uses methods for efficient handling of tabular data, with support for\n\\code{data.frame}, \\code{data.table}, and \\code{tibble}. If a function is documented as accepting\n\"tabular data\", it should work with any of these data structures. If a function is documented\nas accepting only one of these, then it should only be used with that structure.\nFor example, some optimized \\code{data.table} operations that perform in-place modifications only\nwork with \\code{data.table} objects.\n}\n\n\\seealso{\nUseful links:\n\\itemize{\n \\item \\url{https://www.rtemis.org}\n \\item \\url{https://docs.rtemis.org/r/ml}\n \\item \\url{https://docs.rtemis.org/r/ml-api/}\n \\item Report bugs at \\url{https://github.com/rtemis-org/rtemis/issues}\n}\n\n}\n\\author{\n\\strong{Maintainer}: E.D. Gennatas \\email{gennatas@gmail.com} (\\href{https://orcid.org/0000-0001-9280-3609}{ORCID}) [copyright holder]\n\nAuthors:\n\\itemize{\n \\item E.D. Gennatas \\email{gennatas@gmail.com} (\\href{https://orcid.org/0000-0001-9280-3609}{ORCID}) [copyright holder]\n}\n\n}\n" }, { "path": "man/rtemis_colors.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/rtemis_color_system.R\n\\name{rtemis_colors}\n\\alias{rtemis_colors}\n\\title{rtemis Color System}\n\\format{\nA named list with the following elements:\n\\describe{\n\\item{red}{\"kaimana red\"}\n\\item{blue}{\"kaimana light blue\"}\n\\item{green}{\"kaimana medium green\"}\n\\item{orange}{\"coastside orange\"}\n\\item{teal}{\"rtemis teal\"}\n\\item{purple}{\"rtemis purple\"}\n\\item{magenta}{\"rtemis magenta\"}\n\\item{highlight_col}{\"highlight color\"}\n\\item{object}{\"rtemis teal\"}\n\\item{info}{\"lmd burgundy\"}\n\\item{outer}{\"kaimana red\"}\n\\item{tuner}{\"coastside orange\"}\n}\n}\n\\usage{\nrtemis_colors\n}\n\\description{\nA named list of colors used consistently across all packages\nin the rtemis ecosystem.\n}\n\\details{\nColors are provided as hex strings.\n}\n\\examples{\nrtemis_colors[[\"orange\"]]\n\nrtemis_colors[[\"teal\"]]\n}\n\\author{\nEDG\n}\n" }, { "path": "man/rtversion.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils.R\n\\name{rtversion}\n\\alias{rtversion}\n\\title{Get rtemis version and system info}\n\\usage{\nrtversion()\n}\n\\value{\nList: rtemis version and system info, invisibly.\n}\n\\description{\nGet rtemis version and system info\n}\n\\examples{\nrtversion()\n}\n\\author{\nEDG\n}\n" }, { "path": "man/runifmat.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils.R\n\\name{runifmat}\n\\alias{runifmat}\n\\title{Random Uniform Matrix}\n\\usage{\nrunifmat(\n nrow = 10,\n ncol = 10,\n min = 0,\n max = 1,\n return_df = FALSE,\n seed = NULL\n)\n}\n\\arguments{\n\\item{nrow}{Integer: Number of rows.}\n\n\\item{ncol}{Integer: Number of columns.}\n\n\\item{min}{Float: Min.}\n\n\\item{max}{Float: Max.}\n\n\\item{return_df}{Logical: If TRUE, return data.frame, otherwise matrix.}\n\n\\item{seed}{Integer: Set seed for \\code{rnorm}.}\n}\n\\value{\n\\code{matrix} or \\code{data.frame}.\n}\n\\description{\nCreate a matrix or data frame of defined dimensions, whose columns are random uniform vectors\n}\n\\examples{\nx <- runifmat(20, 5, min = 12, max = 18, return_df = TRUE, seed = 2026)\nx\n}\n\\author{\nEDG\n}\n" }, { "path": "man/set_msg_sink.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/msg.R\n\\name{set_msg_sink}\n\\alias{set_msg_sink}\n\\title{Set the rtemis message sink}\n\\usage{\nset_msg_sink(sink)\n}\n\\arguments{\n\\item{sink}{Function or \\code{NULL}.}\n}\n\\value{\nPrevious sink (function or \\code{NULL}), invisibly.\n}\n\\description{\nWhen set, \\code{msg()}, \\code{msg0()}, \\code{msgstart()}, and \\code{msgdone()} forward their\nstructured output through \\code{sink} instead of writing to the R console. Used\nby \\code{rtemislive} to capture training-time messages and forward them over a\nWebSocket connection. Pass \\code{NULL} to restore default console output.\n}\n\\details{\nThe sink function is called once per message with a single argument: a list\nwith fields\n\\itemize{\n\\item \\code{text}: character. The formatted message body (no datetime prefix).\n\\item \\code{caller}: character or \\code{NA}. Calling function as identified by\n\\code{format_caller()}.\n\\item \\code{ts}: character. Formatted timestamp (\\code{\"\\%Y-\\%m-\\%d \\%H:\\%M:\\%S\"}).\n\\item \\code{level}: character. One of \\code{\"info\"} (\\code{msg}/\\code{msg0}), \\code{\"start\"}\n(\\code{msgstart}), or \\code{\"done\"} (\\code{msgdone}).\n}\n\nWhen a sink is set, the console output path is \\strong{skipped} for affected\ncalls. Errors thrown by the sink propagate to the caller of \\code{msg()}.\n}\n\\examples{\ncaptured <- list()\nset_msg_sink(function(m) captured[[length(captured) + 1L]] <<- m)\n# msg(\"hello world\") # would append to `captured`\nset_msg_sink(NULL) # restore console output\n}\n\\seealso{\n\\code{\\link[=get_msg_sink]{get_msg_sink()}}, \\code{\\link[=with_msg_sink]{with_msg_sink()}}.\n}\n\\author{\nEDG\n}\n" }, { "path": "man/set_outcome.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_supervised.R\n\\name{set_outcome}\n\\alias{set_outcome}\n\\title{Move outcome to last column}\n\\usage{\nset_outcome(dat, outcome_column)\n}\n\\arguments{\n\\item{dat}{data.frame or similar.}\n\n\\item{outcome_column}{Character: Name of outcome column.}\n}\n\\value{\nobject of same class as \\code{data}\n}\n\\description{\nMove outcome to last column\n}\n\\examples{\nir <- set_outcome(iris, \"Sepal.Length\")\nhead(ir)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setdiffsym.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils.R\n\\name{setdiffsym}\n\\alias{setdiffsym}\n\\title{Symmetric Set Difference}\n\\usage{\nsetdiffsym(x, y)\n}\n\\arguments{\n\\item{x}{vector}\n\n\\item{y}{vector of same type as \\code{x}}\n}\n\\value{\nVector.\n}\n\\description{\nSymmetric Set Difference\n}\n\\examples{\nsetdiff(1:10, 1:5)\nsetdiff(1:5, 1:10)\nsetdiffsym(1:10, 1:5)\nsetdiffsym(1:5, 1:10)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_CART.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_CART}\n\\alias{setup_CART}\n\\title{Setup CART Hyperparameters}\n\\usage{\nsetup_CART(\n cp = 0.01,\n maxdepth = 20L,\n minsplit = 2L,\n minbucket = 1L,\n prune_cp = NULL,\n method = \"auto\",\n model = TRUE,\n maxcompete = 4L,\n maxsurrogate = 5L,\n usesurrogate = 2L,\n surrogatestyle = 0L,\n xval = 0L,\n cost = NULL,\n ifw = FALSE\n)\n}\n\\arguments{\n\\item{cp}{(Tunable) Numeric: Complexity parameter.}\n\n\\item{maxdepth}{(Tunable) Integer: Maximum depth of tree.}\n\n\\item{minsplit}{(Tunable) Integer: Minimum number of observations in a node to split.}\n\n\\item{minbucket}{(Tunable) Integer: Minimum number of observations in a terminal node.}\n\n\\item{prune_cp}{(Tunable) Numeric: Complexity for cost-complexity pruning after tree is built}\n\n\\item{method}{String: Splitting method.}\n\n\\item{model}{Logical: If TRUE, return a model.}\n\n\\item{maxcompete}{Integer: Maximum number of competitive splits.}\n\n\\item{maxsurrogate}{Integer: Maximum number of surrogate splits.}\n\n\\item{usesurrogate}{Integer: Number of surrogate splits to use.}\n\n\\item{surrogatestyle}{Integer: Type of surrogate splits.}\n\n\\item{xval}{Integer: Number of cross-validation folds.}\n\n\\item{cost}{Numeric (>=0): One for each feature.}\n\n\\item{ifw}{Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n}\n\\value{\nCARTHyperparameters object.\n}\n\\description{\nSetup hyperparameters for CART training.\n}\n\\details{\nGet more information from \\link[rpart:rpart]{rpart::rpart} and \\link[rpart:rpart.control]{rpart::rpart.control}.\n}\n\\examples{\ncart_hyperparams <- setup_CART(cp = 0.01, maxdepth = 10L, ifw = TRUE)\ncart_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_CMeans.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/09_ClusteringConfig.R\n\\name{setup_CMeans}\n\\alias{setup_CMeans}\n\\title{Setup CMeansConfig}\n\\usage{\nsetup_CMeans(\n k = 2L,\n max_iter = 100L,\n dist = c(\"euclidean\", \"manhattan\"),\n method = c(\"cmeans\", \"ufcl\"),\n m = 2,\n rate_par = NULL,\n weights = 1,\n control = list()\n)\n}\n\\arguments{\n\\item{k}{Integer: Number of clusters.}\n\n\\item{max_iter}{Integer: Maximum number of iterations.}\n\n\\item{dist}{Character: Distance measure to use: 'euclidean' or 'manhattan'.}\n\n\\item{method}{Character: \"cmeans\" - fuzzy c-means clustering; \"ufcl\": on-line update.}\n\n\\item{m}{Float (>1): Degree of fuzzification.}\n\n\\item{rate_par}{Float (0, 1): Learning rate for the online variant.}\n\n\\item{weights}{Float (>0): Case weights.}\n\n\\item{control}{List: Control config for clustering algorithm.}\n}\n\\value{\nCMeansConfig object.\n}\n\\description{\nSetup CMeansConfig\n}\n\\examples{\ncmeans_config <- setup_CMeans(k = 4L, dist = \"euclidean\")\ncmeans_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_DBSCAN.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/09_ClusteringConfig.R\n\\name{setup_DBSCAN}\n\\alias{setup_DBSCAN}\n\\title{Setup DBSCANConfig}\n\\usage{\nsetup_DBSCAN(\n eps = 0.5,\n min_points = 5L,\n weights = NULL,\n border_points = TRUE,\n search = c(\"kdtree\", \"linear\", \"dist\"),\n bucket_size = 100L,\n split_rule = c(\"SUGGEST\", \"STD\", \"MIDPT\", \"FAIR\", \"SL_MIDPT\", \"SL_FAIR\"),\n approx = FALSE\n)\n}\n\\arguments{\n\\item{eps}{Float: Radius of neighborhood.}\n\n\\item{min_points}{Integer: Minimum number of points in a neighborhood to form a cluster.}\n\n\\item{weights}{Numeric vector: Weights for data points.}\n\n\\item{border_points}{Logical: If TRUE, assign border points to clusters.}\n\n\\item{search}{Character: Nearest neighbor search strategy: \"kdtree\", \"linear\", or \"dist\".}\n\n\\item{bucket_size}{Integer: Size of buckets for k-dtree search.}\n\n\\item{split_rule}{Character: Rule for splitting clusters: \"SUGGEST\", \"STD\", \"MIDPT\", \"FAIR\", \"SL_MIDPT\", \"SL_FAIR\".}\n\n\\item{approx}{Logical: If TRUE, use approximate nearest neighbor search.}\n}\n\\value{\nDBSCANConfig object.\n}\n\\description{\nSetup DBSCANConfig\n}\n\\examples{\ndbscan_config <- setup_DBSCAN(eps = 0.5, min_points = 5L)\ndbscan_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_ExecutionConfig.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/01_ExecutionConfig.R\n\\name{setup_ExecutionConfig}\n\\alias{setup_ExecutionConfig}\n\\title{Setup Execution Configuration}\n\\usage{\nsetup_ExecutionConfig(\n backend = c(\"future\", \"mirai\", \"none\"),\n n_workers = NULL,\n future_plan = NULL\n)\n}\n\\arguments{\n\\item{backend}{Character: Execution backend: \"future\", \"mirai\", or \"none\".}\n\n\\item{n_workers}{Integer: Number of workers for parallel execution. Only used if \\verb{backend is \"future\"} or \"mirai\". Do not rely on the default value, set to an appropriate number depending\non your system.}\n\n\\item{future_plan}{Character: Future plan to use if \\code{backend} is \"future\".}\n}\n\\value{\n\\code{ExecutionConfig} object.\n}\n\\description{\nSetup Execution Configuration\n}\n\\examples{\nsetup_ExecutionConfig(backend = \"future\", n_workers = 4L, future_plan = \"multisession\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_GAM.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_GAM}\n\\alias{setup_GAM}\n\\title{Setup GAM Hyperparameters}\n\\usage{\nsetup_GAM(k = 5L, ifw = FALSE)\n}\n\\arguments{\n\\item{k}{(Tunable) Integer: Number of knots.}\n\n\\item{ifw}{(Tunable) Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n}\n\\value{\nGAMHyperparameters object.\n}\n\\description{\nSetup hyperparameters for GAM training.\n}\n\\details{\nGet more information from \\link[mgcv:gam]{mgcv::gam}.\n}\n\\examples{\ngam_hyperparams <- setup_GAM(k = 5L, ifw = FALSE)\ngam_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_GLM.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_GLM}\n\\alias{setup_GLM}\n\\title{Setup GLM Hyperparameters}\n\\usage{\nsetup_GLM(ifw = FALSE)\n}\n\\arguments{\n\\item{ifw}{(Tunable) Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n}\n\\value{\nGLMHyperparameters object.\n}\n\\description{\nSetup hyperparameters for GLM training.\n}\n\\examples{\nglm_hyperparams <- setup_GLM(ifw = TRUE)\nglm_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_GLMNET.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_GLMNET}\n\\alias{setup_GLMNET}\n\\title{Setup GLMNET Hyperparameters}\n\\usage{\nsetup_GLMNET(\n alpha = 1,\n family = NULL,\n offset = NULL,\n which_lambda_cv = \"lambda.1se\",\n nlambda = 100L,\n lambda = NULL,\n penalty_factor = NULL,\n standardize = TRUE,\n intercept = TRUE,\n ifw = TRUE\n)\n}\n\\arguments{\n\\item{alpha}{(Tunable) Numeric: Mixing parameter.}\n\n\\item{family}{Character: Family for GLMNET.}\n\n\\item{offset}{Numeric: Offset for GLMNET.}\n\n\\item{which_lambda_cv}{Character: Which lambda to use for prediction:\n\"lambda.1se\" or \"lambda.min\"}\n\n\\item{nlambda}{Positive integer: Number of lambda values.}\n\n\\item{lambda}{Numeric: Lambda values.}\n\n\\item{penalty_factor}{Numeric: Penalty factor for each feature.}\n\n\\item{standardize}{Logical: If TRUE, standardize features.}\n\n\\item{intercept}{Logical: If TRUE, include intercept.}\n\n\\item{ifw}{Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n}\n\\value{\nGLMNETHyperparameters object.\n}\n\\description{\nSetup hyperparameters for GLMNET training.\n}\n\\details{\nGet more information from \\link[glmnet:glmnet]{glmnet::glmnet}.\n}\n\\examples{\nglm_hyperparams <- setup_GLMNET(alpha = 1, ifw = TRUE)\nglm_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_GridSearch.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/06_Tuner.R\n\\name{setup_GridSearch}\n\\alias{setup_GridSearch}\n\\title{Setup Grid Search Config}\n\\usage{\nsetup_GridSearch(\n resampler_config = setup_Resampler(n_resamples = 5L, type = \"KFold\"),\n search_type = \"exhaustive\",\n randomize_p = NULL,\n metrics_aggregate_fn = \"mean\",\n metric = NULL,\n maximize = NULL\n)\n}\n\\arguments{\n\\item{resampler_config}{\\code{ResamplerConfig} set by \\link{setup_Resampler}.}\n\n\\item{search_type}{Character: \"exhaustive\" or \"randomized\". Type of\ngrid search to use. Exhaustive search will try all combinations of\nconfig. Randomized will try a random sample of size\n\\code{randomize_p} * \\verb{N of total combinations}}\n\n\\item{randomize_p}{Float (0, 1): For \\code{search_type == \"randomized\"},\nrandomly test this proportion of combinations.}\n\n\\item{metrics_aggregate_fn}{Character: Name of function to use to aggregate error metrics.}\n\n\\item{metric}{Character: Metric to minimize or maximize.}\n\n\\item{maximize}{Logical: If TRUE, maximize \\code{metric}, otherwise minimize it.}\n}\n\\value{\nA \\code{GridSearchConfig} object.\n}\n\\description{\nCreate a \\code{GridSearchConfig} object that can be passed to \\link{train}.\n}\n\\examples{\ngridsearch_config <- setup_GridSearch(\n resampler_config = setup_Resampler(n_resamples = 5L, type = \"KFold\"),\n search_type = \"exhaustive\"\n)\ngridsearch_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_HardCL.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/09_ClusteringConfig.R\n\\name{setup_HardCL}\n\\alias{setup_HardCL}\n\\title{Setup HardCLConfig}\n\\usage{\nsetup_HardCL(k = 3L, dist = c(\"euclidean\", \"manhattan\"))\n}\n\\arguments{\n\\item{k}{Number of clusters.}\n\n\\item{dist}{Character: Distance measure to use: 'euclidean' or 'manhattan'.}\n}\n\\value{\nHardCLConfig object.\n}\n\\description{\nSetup HardCLConfig\n}\n\\examples{\nhardcl_config <- setup_HardCL(k = 4L, dist = \"euclidean\")\nhardcl_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_ICA.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/11_DecompositionConfig.R\n\\name{setup_ICA}\n\\alias{setup_ICA}\n\\title{setup_ICA}\n\\usage{\nsetup_ICA(\n k = 3L,\n type = c(\"parallel\", \"deflation\"),\n fun = c(\"logcosh\", \"exp\"),\n alpha = 1,\n row_norm = TRUE,\n maxit = 100L,\n tol = 1e-04\n)\n}\n\\arguments{\n\\item{k}{Integer: Number of components.}\n\n\\item{type}{Character: Type of ICA: \"parallel\" or \"deflation\".}\n\n\\item{fun}{Character: ICA function: \"logcosh\", \"exp\".}\n\n\\item{alpha}{Numeric [1, 2]: Used in approximation to neg-entropy with \\code{fun = \"logcosh\"}.}\n\n\\item{row_norm}{Logical: If TRUE, normalize rows of \\code{x} before ICA.}\n\n\\item{maxit}{Integer: Maximum number of iterations.}\n\n\\item{tol}{Numeric: Tolerance.}\n}\n\\value{\nICAConfig object.\n}\n\\description{\nSetup ICA config.\n}\n\\examples{\nica_config <- setup_ICA(k = 3L)\nica_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_Isomap.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/11_DecompositionConfig.R\n\\name{setup_Isomap}\n\\alias{setup_Isomap}\n\\title{Setup Isomap config.}\n\\usage{\nsetup_Isomap(\n k = 2L,\n dist_method = c(\"euclidean\", \"manhattan\"),\n nsd = 0L,\n path = c(\"shortest\", \"extended\")\n)\n}\n\\arguments{\n\\item{k}{Integer: Number of components.}\n\n\\item{dist_method}{Character: Distance method.}\n\n\\item{nsd}{Integer: Number of shortest dissimilarities retained.}\n\n\\item{path}{Character: Path argument for \\code{vegan::isomap}.}\n}\n\\value{\nIsomapConfig object.\n}\n\\description{\nSetup Isomap config.\n}\n\\examples{\nisomap_config <- setup_Isomap(k = 3L)\nisomap_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_Isotonic.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_Isotonic}\n\\alias{setup_Isotonic}\n\\title{Setup Isotonic Hyperparameters}\n\\usage{\nsetup_Isotonic(ifw = FALSE)\n}\n\\arguments{\n\\item{ifw}{Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n}\n\\value{\nIsotonicHyperparameters object.\n}\n\\description{\nSetup hyperparameters for Isotonic Regression.\n}\n\\details{\nThere are not hyperparameters for this algorithm at this moment.\n}\n\\examples{\nisotonic_hyperparams <- setup_Isotonic(ifw = TRUE)\nisotonic_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_KMeans.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/09_ClusteringConfig.R\n\\name{setup_KMeans}\n\\alias{setup_KMeans}\n\\title{Setup KMeansConfig}\n\\usage{\nsetup_KMeans(k = 3L, dist = c(\"euclidean\", \"manhattan\"))\n}\n\\arguments{\n\\item{k}{Number of clusters.}\n\n\\item{dist}{Character: Distance measure to use: 'euclidean' or 'manhattan'.}\n}\n\\value{\nKMeansConfig object.\n}\n\\description{\nSetup KMeansConfig\n}\n\\examples{\nkmeans_config <- setup_KMeans(k = 4L, dist = \"euclidean\")\nkmeans_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_LightCART.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_LightCART}\n\\alias{setup_LightCART}\n\\title{Setup LightCART Hyperparameters}\n\\usage{\nsetup_LightCART(\n num_leaves = 32L,\n max_depth = -1L,\n lambda_l1 = 0,\n lambda_l2 = 0,\n min_data_in_leaf = 20L,\n max_cat_threshold = 32L,\n min_data_per_group = 100L,\n linear_tree = FALSE,\n objective = NULL,\n ifw = FALSE\n)\n}\n\\arguments{\n\\item{num_leaves}{(Tunable) Positive integer: Maximum number of leaves in one tree.}\n\n\\item{max_depth}{(Tunable) Integer: Maximum depth of trees.}\n\n\\item{lambda_l1}{(Tunable) Numeric: L1 regularization.}\n\n\\item{lambda_l2}{(Tunable) Numeric: L2 regularization.}\n\n\\item{min_data_in_leaf}{(Tunable) Positive integer: Minimum number of data in a leaf.}\n\n\\item{max_cat_threshold}{(Tunable) Positive integer: Maximum number of categories for categorical features.}\n\n\\item{min_data_per_group}{(Tunable) Positive integer: Minimum number of observations per categorical group.}\n\n\\item{linear_tree}{(Tunable) Logical: If TRUE, use linear trees.}\n\n\\item{objective}{Character: Objective function.}\n\n\\item{ifw}{Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n}\n\\value{\nLightCARTHyperparameters object.\n}\n\\description{\nSetup hyperparameters for LightCART training.\n}\n\\details{\nGet more information from \\link[lightgbm:lgb.train]{lightgbm::lgb.train}.\n}\n\\examples{\nlightcart_hyperparams <- setup_LightCART(num_leaves = 32L, ifw = FALSE)\nlightcart_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_LightGBM.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_LightGBM}\n\\alias{setup_LightGBM}\n\\title{Setup LightGBM Hyperparameters}\n\\usage{\nsetup_LightGBM(\n max_nrounds = 1000L,\n force_nrounds = NULL,\n early_stopping_rounds = 10L,\n num_leaves = 8L,\n max_depth = -1L,\n learning_rate = 0.01,\n feature_fraction = 1,\n subsample = 1,\n subsample_freq = 1L,\n lambda_l1 = 0,\n lambda_l2 = 0,\n max_cat_threshold = 32L,\n min_data_per_group = 32L,\n linear_tree = FALSE,\n ifw = FALSE,\n objective = NULL,\n device_type = \"cpu\",\n tree_learner = \"serial\",\n force_col_wise = TRUE\n)\n}\n\\arguments{\n\\item{max_nrounds}{Positive integer: Maximum number of boosting rounds.}\n\n\\item{force_nrounds}{Positive integer: Use this many boosting rounds. Disable search for nrounds.}\n\n\\item{early_stopping_rounds}{Positive integer: Number of rounds without improvement to stop training.}\n\n\\item{num_leaves}{(Tunable) Positive integer: Maximum number of leaves in one tree.}\n\n\\item{max_depth}{(Tunable) Integer: Maximum depth of trees.}\n\n\\item{learning_rate}{(Tunable) Numeric: Learning rate.}\n\n\\item{feature_fraction}{(Tunable) Numeric: Fraction of features to use.}\n\n\\item{subsample}{(Tunable) Numeric: Fraction of data to use.}\n\n\\item{subsample_freq}{(Tunable) Positive integer: Frequency of subsample.}\n\n\\item{lambda_l1}{(Tunable) Numeric: L1 regularization.}\n\n\\item{lambda_l2}{(Tunable) Numeric: L2 regularization.}\n\n\\item{max_cat_threshold}{(Tunable) Positive integer: Maximum number of categories for categorical features.}\n\n\\item{min_data_per_group}{(Tunable) Positive integer: Minimum number of observations per categorical group.}\n\n\\item{linear_tree}{Logical: If TRUE, use linear trees.}\n\n\\item{ifw}{Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n\n\\item{objective}{Character: Objective function.}\n\n\\item{device_type}{Character: \"cpu\" or \"gpu\".}\n\n\\item{tree_learner}{Character: \"serial\", \"feature\", \"data\", or \"voting\".}\n\n\\item{force_col_wise}{Logical: Use only with CPU - If TRUE, force col-wise histogram building.}\n}\n\\value{\nLightGBMHyperparameters object.\n}\n\\description{\nSetup hyperparameters for LightGBM training.\n}\n\\details{\nGet more information from \\link[lightgbm:lgb.train]{lightgbm::lgb.train}.\n}\n\\examples{\nlightgbm_hyperparams <- setup_LightGBM(\n max_nrounds = 500L,\n learning_rate = c(0.001, 0.01, 0.05), ifw = TRUE\n)\nlightgbm_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_LightRF.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_LightRF}\n\\alias{setup_LightRF}\n\\title{Setup LightRF Hyperparameters}\n\\usage{\nsetup_LightRF(\n nrounds = 500L,\n num_leaves = 4096L,\n max_depth = -1L,\n feature_fraction = 0.7,\n subsample = 0.623,\n lambda_l1 = 0,\n lambda_l2 = 0,\n max_cat_threshold = 32L,\n min_data_per_group = 32L,\n linear_tree = FALSE,\n ifw = FALSE,\n objective = NULL,\n device_type = \"cpu\",\n tree_learner = \"serial\",\n force_col_wise = TRUE\n)\n}\n\\arguments{\n\\item{nrounds}{(Tunable) Positive integer: Number of boosting rounds.}\n\n\\item{num_leaves}{(Tunable) Positive integer: Maximum number of leaves in one tree.}\n\n\\item{max_depth}{(Tunable) Integer: Maximum depth of trees.}\n\n\\item{feature_fraction}{(Tunable) Numeric: Fraction of features to use.}\n\n\\item{subsample}{(Tunable) Numeric: Fraction of data to use.}\n\n\\item{lambda_l1}{(Tunable) Numeric: L1 regularization.}\n\n\\item{lambda_l2}{(Tunable) Numeric: L2 regularization.}\n\n\\item{max_cat_threshold}{(Tunable) Positive integer: Maximum number of categories for categorical features.}\n\n\\item{min_data_per_group}{(Tunable) Positive integer: Minimum number of observations per categorical group.}\n\n\\item{linear_tree}{Logical: If TRUE, use linear trees.}\n\n\\item{ifw}{Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n\n\\item{objective}{Character: Objective function.}\n\n\\item{device_type}{Character: \"cpu\" or \"gpu\".}\n\n\\item{tree_learner}{Character: \"serial\", \"feature\", \"data\", or \"voting\".}\n\n\\item{force_col_wise}{Logical: Use only with CPU - If TRUE, force col-wise histogram building.}\n}\n\\value{\nLightRFHyperparameters object.\n}\n\\description{\nSetup hyperparameters for LightRF training.\n}\n\\details{\nGet more information from \\link[lightgbm:lgb.train]{lightgbm::lgb.train}.\nNote that hyperparameters subsample_freq and early_stopping_rounds are fixed,\nand cannot be set because they are what makes \\code{lightgbm} train a random forest.\nThese can all be set when training gradient boosting with LightGBM.\n}\n\\examples{\nlightrf_hyperparams <- setup_LightRF(nrounds = 1000L, ifw = FALSE)\nlightrf_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_LightRuleFit.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_LightRuleFit}\n\\alias{setup_LightRuleFit}\n\\title{Setup LightRuleFit Hyperparameters}\n\\usage{\nsetup_LightRuleFit(\n nrounds = 200L,\n num_leaves = 32L,\n max_depth = 4L,\n learning_rate = 0.1,\n subsample = 0.666,\n subsample_freq = 1L,\n lambda_l1 = 0,\n lambda_l2 = 0,\n objective = NULL,\n ifw_lightgbm = FALSE,\n alpha = 1,\n lambda = NULL,\n ifw_glmnet = FALSE,\n ifw = FALSE\n)\n}\n\\arguments{\n\\item{nrounds}{(Tunable) Positive integer: Number of boosting rounds.}\n\n\\item{num_leaves}{(Tunable) Positive integer: Maximum number of leaves in one tree.}\n\n\\item{max_depth}{(Tunable) Integer: Maximum depth of trees.}\n\n\\item{learning_rate}{(Tunable) Numeric: Learning rate.}\n\n\\item{subsample}{(Tunable) Numeric: Fraction of data to use.}\n\n\\item{subsample_freq}{(Tunable) Positive integer: Frequency of subsample.}\n\n\\item{lambda_l1}{(Tunable) Numeric: L1 regularization.}\n\n\\item{lambda_l2}{(Tunable) Numeric: L2 regularization.}\n\n\\item{objective}{Character: Objective function.}\n\n\\item{ifw_lightgbm}{(Tunable) Logical: If TRUE, use Inverse Frequency Weighting in the LightGBM\nstep.}\n\n\\item{alpha}{(Tunable) Numeric: Alpha for GLMNET.}\n\n\\item{lambda}{Numeric: Lambda for GLMNET.}\n\n\\item{ifw_glmnet}{(Tunable) Logical: If TRUE, use Inverse Frequency Weighting in the GLMNET step.}\n\n\\item{ifw}{Logical: If TRUE, use Inverse Frequency Weighting in classification. This applies IFW\nto both LightGBM and GLMNET.}\n}\n\\value{\nLightRuleFitHyperparameters object.\n}\n\\description{\nSetup hyperparameters for LightRuleFit training.\n}\n\\details{\nGet more information from \\link[lightgbm:lgb.train]{lightgbm::lgb.train}.\n}\n\\examples{\nlightrulefit_hyperparams <- setup_LightRuleFit(nrounds = 300L, max_depth = 3L)\nlightrulefit_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_LinearSVM.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_LinearSVM}\n\\alias{setup_LinearSVM}\n\\title{Setup LinearSVM Hyperparameters}\n\\usage{\nsetup_LinearSVM(cost = 1, ifw = FALSE)\n}\n\\arguments{\n\\item{cost}{(Tunable) Numeric: Cost of constraints violation.}\n\n\\item{ifw}{Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n}\n\\value{\nLinearSVMHyperparameters object.\n}\n\\description{\nSetup hyperparameters for LinearSVM training.\n}\n\\details{\nGet more information from \\link[e1071:svm]{e1071::svm}.\n}\n\\examples{\nlinear_svm_hyperparams <- setup_LinearSVM(cost = 0.5, ifw = TRUE)\nlinear_svm_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_NMF.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/11_DecompositionConfig.R\n\\name{setup_NMF}\n\\alias{setup_NMF}\n\\title{Setup NMF config.}\n\\usage{\nsetup_NMF(k = 2L, method = \"brunet\", nrun = if (length(k) > 1L) 30L else 1L)\n}\n\\arguments{\n\\item{k}{Integer: Number of components.}\n\n\\item{method}{Character: NMF method. See \\code{NMF::nmf}.}\n\n\\item{nrun}{Integer: Number of runs to perform.}\n}\n\\value{\nNMFConfig object.\n}\n\\description{\nSetup NMF config.\n}\n\\examples{\nnmf_config <- setup_NMF(k = 3L)\nnmf_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_NeuralGas.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/09_ClusteringConfig.R\n\\name{setup_NeuralGas}\n\\alias{setup_NeuralGas}\n\\title{Setup NeuralGasConfig}\n\\usage{\nsetup_NeuralGas(k = 3L, dist = c(\"euclidean\", \"manhattan\"))\n}\n\\arguments{\n\\item{k}{Number of clusters.}\n\n\\item{dist}{Character: Distance measure to use: 'euclidean' or 'manhattan'.}\n}\n\\value{\nNeuralGasConfig object.\n}\n\\description{\nSetup NeuralGasConfig\n}\n\\examples{\nneuralgas_config <- setup_NeuralGas(k = 4L, dist = \"euclidean\")\nneuralgas_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_PCA.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/11_DecompositionConfig.R\n\\name{setup_PCA}\n\\alias{setup_PCA}\n\\title{Setup PCA config.}\n\\usage{\nsetup_PCA(k = 3L, center = TRUE, scale = TRUE, tol = NULL)\n}\n\\arguments{\n\\item{k}{Integer: Number of components. (passed to \\code{prcomp} \\code{rank.})}\n\n\\item{center}{Logical: If TRUE, center the data.}\n\n\\item{scale}{Logical: If TRUE, scale the data.}\n\n\\item{tol}{Numeric: Tolerance.}\n}\n\\value{\nPCAConfig object.\n}\n\\description{\nSetup PCA config.\n}\n\\examples{\npca_config <- setup_PCA(k = 3L)\npca_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_Preprocessor.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/04_Preprocessor.R\n\\name{setup_Preprocessor}\n\\alias{setup_Preprocessor}\n\\title{Setup Preprocessor}\n\\usage{\nsetup_Preprocessor(\n complete_cases = FALSE,\n remove_features_thres = NULL,\n remove_cases_thres = NULL,\n missingness = FALSE,\n impute = FALSE,\n impute_type = c(\"missRanger\", \"micePMM\", \"meanMode\"),\n impute_missRanger_params = list(pmm.k = 3, maxiter = 10, num.trees = 500),\n impute_discrete = \"get_mode\",\n impute_continuous = \"mean\",\n integer2factor = FALSE,\n integer2numeric = FALSE,\n logical2factor = FALSE,\n logical2numeric = FALSE,\n numeric2factor = FALSE,\n numeric2factor_levels = NULL,\n numeric_cut_n = 0,\n numeric_cut_labels = FALSE,\n numeric_quant_n = 0,\n numeric_quant_NAonly = FALSE,\n unique_len2factor = 0,\n character2factor = FALSE,\n factorNA2missing = FALSE,\n factorNA2missing_level = \"missing\",\n factor2integer = FALSE,\n factor2integer_startat0 = TRUE,\n scale = FALSE,\n center = scale,\n scale_centers = NULL,\n scale_coefficients = NULL,\n remove_constants = FALSE,\n remove_constants_skip_missing = TRUE,\n remove_features = NULL,\n remove_duplicates = FALSE,\n one_hot = FALSE,\n one_hot_levels = NULL,\n add_date_features = FALSE,\n date_features = c(\"weekday\", \"month\", \"year\"),\n add_holidays = FALSE,\n exclude = NULL\n)\n}\n\\arguments{\n\\item{complete_cases}{Logical: If TRUE, only retain complete cases (no missing data).}\n\n\\item{remove_features_thres}{Float (0, 1): Remove features with missing\nvalues in >= to this fraction of cases.}\n\n\\item{remove_cases_thres}{Float (0, 1): Remove cases with >= to this fraction\nof missing features.}\n\n\\item{missingness}{Logical: If TRUE, generate new boolean columns for each\nfeature with missing values, indicating which cases were missing data.}\n\n\\item{impute}{Logical: If TRUE, impute missing cases. See \\code{impute_discrete} and\n\\code{impute_continuous}.}\n\n\\item{impute_type}{Character: Package to use for imputation.}\n\n\\item{impute_missRanger_params}{Named list with elements \"pmm.k\" and\n\"maxiter\", which are passed to \\code{missRanger::missRanger}. \\code{pmm.k}\ngreater than 0 results in predictive mean matching. Default \\code{pmm.k = 3}\n\\code{maxiter = 10} \\code{num.trees = 500}. Reduce \\code{num.trees} for\nfaster imputation especially in large datasets. Set \\code{pmm.k = 0} to\ndisable predictive mean matching.}\n\n\\item{impute_discrete}{Character: Name of function that returns single value: How to impute\ndiscrete variables for \\code{impute_type = \"meanMode\"}.}\n\n\\item{impute_continuous}{Character: Name of function that returns single value: How to impute\ncontinuous variables for \\code{impute_type = \"meanMode\"}.}\n\n\\item{integer2factor}{Logical: If TRUE, convert all integers to factors. This includes\n\\code{bit64::integer64} columns.}\n\n\\item{integer2numeric}{Logical: If TRUE, convert all integers to numeric\n(will only work if \\code{integer2factor = FALSE}). This includes\n\\code{bit64::integer64} columns.}\n\n\\item{logical2factor}{Logical: If TRUE, convert all logical variables to\nfactors.}\n\n\\item{logical2numeric}{Logical: If TRUE, convert all logical variables to\nnumeric.}\n\n\\item{numeric2factor}{Logical: If TRUE, convert all numeric variables to\nfactors.}\n\n\\item{numeric2factor_levels}{Character vector: Optional - will be passed to\n\\code{levels} arg of \\code{factor()} if \\code{numeric2factor = TRUE}. For advanced/\nspecific use cases; need to know unique values of numeric vector(s) and given all\nnumeric vars have same unique values.}\n\n\\item{numeric_cut_n}{Integer: If > 0, convert all numeric variables to factors by\nbinning using \\code{base::cut} with \\code{breaks} equal to this number.}\n\n\\item{numeric_cut_labels}{Logical: The \\code{labels} argument of \\link[base:cut]{base::cut}.}\n\n\\item{numeric_quant_n}{Integer: If > 0, convert all numeric variables to factors by\nbinning using \\code{base::cut} with \\code{breaks} equal to this number of quantiles.\nproduced using \\code{stats::quantile}.}\n\n\\item{numeric_quant_NAonly}{Logical: If TRUE, only bin numeric variables with\nmissing values.}\n\n\\item{unique_len2factor}{Integer (>=2): Convert all variables with less\nthan or equal to this number of unique values to factors.\nFor example, if binary variables are encoded with 1, 2, you could use\n\\code{unique_len2factor = 2} to convert them to factors.}\n\n\\item{character2factor}{Logical: If TRUE, convert all character variables to\nfactors.}\n\n\\item{factorNA2missing}{Logical: If TRUE, make NA values in factors be of\nlevel \\code{factorNA2missing_level}. In many cases this is the preferred way\nto handle missing data in categorical variables. Note that since this step\nis performed before imputation, you can use this option to handle missing\ndata in categorical variables and impute numeric variables in the same\n\\code{preprocess} call.}\n\n\\item{factorNA2missing_level}{Character: Name of level if\n\\code{factorNA2missing = TRUE}.}\n\n\\item{factor2integer}{Logical: If TRUE, convert all factors to integers.}\n\n\\item{factor2integer_startat0}{Logical: If TRUE, start integer coding at 0.}\n\n\\item{scale}{Logical: If TRUE, scale columns of \\code{x}.}\n\n\\item{center}{Logical: If TRUE, center columns of \\code{x}. Note that by\ndefault it is the same as \\code{scale}.}\n\n\\item{scale_centers}{Named vector: Centering values for each feature.}\n\n\\item{scale_coefficients}{Named vector: Scaling values for each feature.}\n\n\\item{remove_constants}{Logical: If TRUE, remove constant columns.}\n\n\\item{remove_constants_skip_missing}{Logical: If TRUE, skip missing values, before\nchecking if feature is constant.}\n\n\\item{remove_features}{Character vector: Features to remove.}\n\n\\item{remove_duplicates}{Logical: If TRUE, remove duplicate cases.}\n\n\\item{one_hot}{Logical: If TRUE, convert all factors using one-hot encoding.}\n\n\\item{one_hot_levels}{List: Named list of the form \"feature_name\" = \"levels\". Used when applying\none-hot encoding to validation or test data using \\code{Preprocessor}.}\n\n\\item{add_date_features}{Logical: If TRUE, extract date features from date columns.}\n\n\\item{date_features}{Character vector: Features to extract from dates.}\n\n\\item{add_holidays}{Logical: If TRUE, extract holidays from date columns.}\n\n\\item{exclude}{Integer, vector: Exclude these columns from preprocessing.}\n}\n\\value{\n\\code{PreprocessorConfig} object.\n}\n\\description{\nCreates a \\code{PreprocessorConfig} object, which can be used in \\link{preprocess}.\n}\n\\section{Order of Operations}{\n\n\\itemize{\n\\item keep complete cases only\n\\item remove constants\n\\item remove duplicates\n\\item remove cases by missingness threshold\n\\item remove features by missingness threshold\n\\item integer to factor\n\\item integer to numeric\n\\item logical to factor\n\\item logical to numeric\n\\item numeric to factor\n\\item cut numeric to n bins\n\\item cut numeric to n quantiles\n\\item numeric with less than N unique values to factor\n\\item character to factor\n\\item factor NA to named level\n\\item add missingness column\n\\item impute\n\\item scale and/or center\n\\item one-hot encoding\n}\n}\n\n\\examples{\npreproc_config <- setup_Preprocessor(factorNA2missing = TRUE)\npreproc_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_RadialSVM.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_RadialSVM}\n\\alias{setup_RadialSVM}\n\\title{Setup RadialSVM Hyperparameters}\n\\usage{\nsetup_RadialSVM(cost = 1, gamma = 0.01, ifw = FALSE)\n}\n\\arguments{\n\\item{cost}{(Tunable) Numeric: Cost of constraints violation.}\n\n\\item{gamma}{(Tunable) Numeric: Kernel coefficient.}\n\n\\item{ifw}{Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n}\n\\value{\nRadialSVMHyperparameters object.\n}\n\\description{\nSetup hyperparameters for RadialSVM training.\n}\n\\details{\nGet more information from \\link[e1071:svm]{e1071::svm}.\n}\n\\examples{\nradial_svm_hyperparams <- setup_RadialSVM(cost = 10, gamma = 0.1, ifw = TRUE)\nradial_svm_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_Ranger.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_Ranger}\n\\alias{setup_Ranger}\n\\title{Setup Ranger Hyperparameters}\n\\usage{\nsetup_Ranger(\n num_trees = 500,\n mtry = NULL,\n importance = \"impurity\",\n write_forest = TRUE,\n probability = FALSE,\n min_node_size = NULL,\n min_bucket = NULL,\n max_depth = NULL,\n replace = TRUE,\n sample_fraction = ifelse(replace, 1, 0.632),\n case_weights = NULL,\n class_weights = NULL,\n splitrule = NULL,\n num_random_splits = 1,\n alpha = 0.5,\n minprop = 0.1,\n poisson_tau = 1,\n split_select_weights = NULL,\n always_split_variables = NULL,\n respect_unordered_factors = NULL,\n scale_permutation_importance = FALSE,\n local_importance = FALSE,\n regularization_factor = 1,\n regularization_usedepth = FALSE,\n keep_inbag = FALSE,\n inbag = NULL,\n holdout = FALSE,\n quantreg = FALSE,\n time_interest = NULL,\n oob_error = TRUE,\n save_memory = FALSE,\n verbose = TRUE,\n node_stats = FALSE,\n seed = NULL,\n na_action = \"na.learn\",\n ifw = FALSE\n)\n}\n\\arguments{\n\\item{num_trees}{(Tunable) Positive integer: Number of trees.}\n\n\\item{mtry}{(Tunable) Positive integer: Number of features to consider at each split.}\n\n\\item{importance}{Character: Variable importance mode. \"none\", \"impurity\", \"impurity_corrected\", \"permutation\".\nThe \"impurity\" measure is the Gini index for classification, the variance of the responses for regression.}\n\n\\item{write_forest}{Logical: Save ranger.forest object, required for prediction. Set to FALSE to reduce memory usage if no prediction intended.}\n\n\\item{probability}{Logical: Grow a probability forest as in Malley et al. (2012). For classification only.}\n\n\\item{min_node_size}{(Tunable) Positive integer: Minimal node size. Default 1 for classification, 5 for regression, 3 for survival, and 10 for probability.}\n\n\\item{min_bucket}{Positive integer: Minimal number of samples in a terminal node. Only for survival. Deprecated in favor of min_node_size.}\n\n\\item{max_depth}{(Tunable) Positive integer: Maximal tree depth. A value of NULL or 0 (the default) corresponds to unlimited depth, 1 to tree stumps (1 split per tree).}\n\n\\item{replace}{Logical: Sample with replacement.}\n\n\\item{sample_fraction}{(Tunable) Numeric: Fraction of observations to sample. Default is 1 for sampling with replacement and 0.632 for sampling without replacement.}\n\n\\item{case_weights}{Numeric vector: Weights for sampling of training observations. Observations with larger weights will be selected with higher probability in the bootstrap (or subsampled) samples for the trees.}\n\n\\item{class_weights}{Numeric vector: Weights for the outcome classes for classification. Vector of the same length as the number of classes, with names corresponding to the class labels.}\n\n\\item{splitrule}{(Tunable) Character: Splitting rule. For classification: \"gini\", \"extratrees\", \"hellinger\". For regression: \"variance\", \"extratrees\", \"maxstat\", \"beta\". For survival: \"logrank\", \"extratrees\", \"C\", \"maxstat\".}\n\n\\item{num_random_splits}{(Tunable) Positive integer: For \"extratrees\" splitrule: Number of random splits to consider for each candidate splitting variable.}\n\n\\item{alpha}{(Tunable) Numeric: For \"maxstat\" splitrule: significance threshold to allow splitting.}\n\n\\item{minprop}{(Tunable) Numeric: For \"maxstat\" splitrule: lower quantile of covariate distribution to be considered for splitting.}\n\n\\item{poisson_tau}{Numeric: For \"poisson\" regression splitrule: tau parameter for Poisson regression.}\n\n\\item{split_select_weights}{Numeric vector: Numeric vector with weights between 0 and 1, representing the probability to select variables for splitting. Alternatively, a list of size num_trees, with one weight vector per tree.}\n\n\\item{always_split_variables}{Character vector: Character vector with variable names to be always selected in addition to the mtry variables tried for splitting.}\n\n\\item{respect_unordered_factors}{Character or logical: Handling of unordered factor covariates. For \"partition\" all 2^(k-1)-1 possible partitions are considered for splitting, where k is the number of factor levels. For \"ignore\", all factor levels are ordered by their first occurrence in the data. For \"order\", all factor levels are ordered by their average response. TRUE corresponds to \"partition\" for the randomForest package compatibility.}\n\n\\item{scale_permutation_importance}{Logical: Scale permutation importance by standard error as in (Breiman 2001). Only applicable if permutation variable importance mode selected.}\n\n\\item{local_importance}{Logical: For permutation variable importance, use local importance as in Breiman (2001) and Liaw & Wiener (2002).}\n\n\\item{regularization_factor}{(Tunable) Numeric: Regularization factor. Penalize variables with many split points. Requires splitrule = \"variance\".}\n\n\\item{regularization_usedepth}{Logical: Use regularization factor with node depth. Requires regularization_factor.}\n\n\\item{keep_inbag}{Logical: Save how often observations are in-bag in each tree. These will be used for (local) variable importance if inbag.counts in predict() is NULL.}\n\n\\item{inbag}{List: Manually set observations per tree. List of size num_trees, containing inbag counts for each observation. Can be used for stratified sampling.}\n\n\\item{holdout}{Logical: Hold-out mode. Hold-out all samples with case weight 0 and use these for variable importance and prediction error.}\n\n\\item{quantreg}{Logical: Prepare quantile prediction as in quantile regression forests (Meinshausen 2006). For regression only. Set keep_inbag = TRUE to prepare out-of-bag quantile prediction.}\n\n\\item{time_interest}{Numeric: For GWAS data: SNP with this number will be used as time variable. Only for survival. Deprecated, use time.var in formula instead.}\n\n\\item{oob_error}{Logical: Compute OOB prediction error. Set to FALSE to save computation time if only the forest is needed.}\n\n\\item{save_memory}{Logical: Use memory saving (but slower) splitting mode. No effect for survival and GWAS data. Warning: This option slows down the tree growing, use only if you encounter memory problems.}\n\n\\item{verbose}{Logical: Show computation status and estimated runtime.}\n\n\\item{node_stats}{Logical: Save additional node statistics. Only terminal nodes for now.}\n\n\\item{seed}{Positive integer: Random seed. Default is NULL, which generates the seed from R. Set to 0 to ignore the R seed.}\n\n\\item{na_action}{Character: Action to take if the data contains missing values. \"na.learn\" uses observations with missing values in splitting, treating missing values as a separate category.}\n\n\\item{ifw}{Logical: Inverse Frequency Weighting for classification. If TRUE, class weights are set inversely proportional to the class frequencies.}\n}\n\\value{\nRangerHyperparameters object.\n}\n\\description{\nSetup hyperparameters for Ranger Random Forest training.\n}\n\\details{\nGet more information from \\link[ranger:ranger]{ranger::ranger}.\n}\n\\examples{\nranger_hyperparams <- setup_Ranger(num_trees = 1000L, ifw = FALSE)\nranger_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_Resampler.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/05_Resampler.R\n\\name{setup_Resampler}\n\\alias{setup_Resampler}\n\\title{Setup Resampler}\n\\usage{\nsetup_Resampler(\n n_resamples = 10L,\n type = c(\"KFold\", \"StratSub\", \"StratBoot\", \"Bootstrap\", \"LOOCV\"),\n stratify_var = NULL,\n train_p = 0.75,\n strat_n_bins = 4L,\n target_length = NULL,\n id_strat = NULL,\n seed = NULL,\n verbosity = 1L\n)\n}\n\\arguments{\n\\item{n_resamples}{Integer: Number of resamples to make.}\n\n\\item{type}{Character: Type of resampler: \"KFold\", \"StratSub\", \"StratBoot\", \"Bootstrap\", \"LOOCV\"}\n\n\\item{stratify_var}{Character: Variable to stratify by.}\n\n\\item{train_p}{Float: Training set percentage.}\n\n\\item{strat_n_bins}{Integer: Number of bins to stratify by.}\n\n\\item{target_length}{Integer: Target length for stratified bootstraps.}\n\n\\item{id_strat}{Integer: Vector of indices to stratify by. These may be, for example, case IDs\nif your dataset contains repeated measurements. By specifying this vector, you can ensure that\neach case can only be present in the training or test set, but not both.}\n\n\\item{seed}{Integer: Random seed.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\nResamplerConfig object.\n}\n\\description{\nSetup Resampler\n}\n\\examples{\ntenfold_resampler <- setup_Resampler(n_resamples = 10L, type = \"KFold\", seed = 2026L)\ntenfold_resampler\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_SuperConfig.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/14_SuperConfig.R\n\\name{setup_SuperConfig}\n\\alias{setup_SuperConfig}\n\\title{Setup SuperConfig}\n\\usage{\nsetup_SuperConfig(\n dat_training_path,\n dat_validation_path = NULL,\n dat_test_path = NULL,\n weights = NULL,\n preprocessor_config = NULL,\n algorithm = NULL,\n hyperparameters = NULL,\n tuner_config = NULL,\n outer_resampling_config = NULL,\n execution_config = setup_ExecutionConfig(),\n question = NULL,\n outdir = \"results/\",\n verbosity = 1L\n)\n}\n\\arguments{\n\\item{dat_training_path}{Character: Path to training data file.}\n\n\\item{dat_validation_path}{Character: Path to validation data file.}\n\n\\item{dat_test_path}{Character: Path to test data file.}\n\n\\item{weights}{Optional Character: Column name in training data to use as observation weights.\nIf NULL, no weights are used.}\n\n\\item{preprocessor_config}{\\code{PreprocessorConfig} object: Configuration for data preprocessing.}\n\n\\item{algorithm}{Character: Algorithm to use for training.}\n\n\\item{hyperparameters}{\\code{Hyperparameters} object: Configuration for model hyperparameters.}\n\n\\item{tuner_config}{\\code{TunerConfig} object: Configuration for hyperparameter tuning.}\n\n\\item{outer_resampling_config}{\\code{ResamplerConfig} object: Configuration for outer res\nresampling during model training.}\n\n\\item{execution_config}{\\code{ExecutionConfig} object: Configuration for execution settings. Setup\nwith \\link{setup_ExecutionConfig}.}\n\n\\item{question}{Character: Question to answer with the supervised learning analysis.}\n\n\\item{outdir}{Character: Output directory for results.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{SuperConfig} object.\n}\n\\description{\nSetup \\code{SuperConfig} object.\n}\n\\examples{\nsc <- setup_SuperConfig(\n dat_training_path = \"train.csv\",\n preprocessor_config = setup_Preprocessor(remove_duplicates = TRUE),\n algorithm = \"LightRF\",\n hyperparameters = setup_LightRF(),\n tuner_config = setup_GridSearch(),\n outer_resampling_config = setup_Resampler(),\n execution_config = setup_ExecutionConfig(),\n question = \"Can we tell iris species apart given their measurements?\",\n outdir = \"models/\"\n)\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_SuperConfigLive.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/14_SuperConfig.R\n\\name{setup_SuperConfigLive}\n\\alias{setup_SuperConfigLive}\n\\title{Setup SuperConfigLive}\n\\usage{\nsetup_SuperConfigLive(\n dat_training,\n dat_validation = NULL,\n dat_test = NULL,\n weights = NULL,\n preprocessor_config = NULL,\n algorithm = NULL,\n hyperparameters = NULL,\n tuner_config = NULL,\n outer_resampling_config = NULL,\n execution_config = setup_ExecutionConfig(),\n question = NULL,\n outdir = NULL,\n verbosity = 1L\n)\n}\n\\arguments{\n\\item{dat_training}{data.frame or data.table. Training data.}\n\n\\item{dat_validation}{data.frame, data.table, or \\code{NULL}.}\n\n\\item{dat_test}{data.frame, data.table, or \\code{NULL}.}\n\n\\item{weights}{Character or \\code{NULL}. Column name in \\code{dat_training} used\nas observation weights.}\n\n\\item{preprocessor_config, algorithm, hyperparameters, tuner_config, outer_resampling_config, execution_config, question, verbosity}{See \\link{setup_SuperConfig}.}\n\n\\item{outdir}{Character or \\code{NULL}. Output directory; \\code{NULL} (the\ndefault) means \"do not write to disk\" (the rtemislive case).}\n}\n\\value{\n\\code{SuperConfigLive} object.\n}\n\\description{\nBuild a \\code{SuperConfigLive} — same shape as \\link{setup_SuperConfig} but with\nin-memory tabular data instead of file paths.\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_TabNet.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/02_Hyperparameters.R\n\\name{setup_TabNet}\n\\alias{setup_TabNet}\n\\title{Setup TabNet Hyperparameters}\n\\usage{\nsetup_TabNet(\n batch_size = 1024^2,\n penalty = 0.001,\n clip_value = NULL,\n loss = \"auto\",\n epochs = 50L,\n drop_last = FALSE,\n decision_width = NULL,\n attention_width = NULL,\n num_steps = 3L,\n feature_reusage = 1.3,\n mask_type = \"sparsemax\",\n virtual_batch_size = 256^2,\n valid_split = 0,\n learn_rate = 0.02,\n optimizer = \"adam\",\n lr_scheduler = NULL,\n lr_decay = 0.1,\n step_size = 30,\n checkpoint_epochs = 10L,\n cat_emb_dim = 1L,\n num_independent = 2L,\n num_shared = 2L,\n num_independent_decoder = 1L,\n num_shared_decoder = 1L,\n momentum = 0.02,\n pretraining_ratio = 0.5,\n device = \"auto\",\n importance_sample_size = NULL,\n early_stopping_monitor = \"auto\",\n early_stopping_tolerance = 0,\n early_stopping_patience = 0,\n num_workers = 0L,\n skip_importance = FALSE,\n ifw = FALSE\n)\n}\n\\arguments{\n\\item{batch_size}{(Tunable) Positive integer: Batch size.}\n\n\\item{penalty}{(Tunable) Numeric: Regularization penalty.}\n\n\\item{clip_value}{Numeric: Clip value.}\n\n\\item{loss}{Character: Loss function.}\n\n\\item{epochs}{(Tunable) Positive integer: Number of epochs.}\n\n\\item{drop_last}{Logical: If TRUE, drop last batch.}\n\n\\item{decision_width}{(Tunable) Positive integer: Decision width.}\n\n\\item{attention_width}{(Tunable) Positive integer: Attention width.}\n\n\\item{num_steps}{(Tunable) Positive integer: Number of steps.}\n\n\\item{feature_reusage}{(Tunable) Numeric: Feature reusage.}\n\n\\item{mask_type}{Character: Mask type.}\n\n\\item{virtual_batch_size}{(Tunable) Positive integer: Virtual batch size.}\n\n\\item{valid_split}{Numeric: Validation split.}\n\n\\item{learn_rate}{(Tunable) Numeric: Learning rate.}\n\n\\item{optimizer}{Character or torch function: Optimizer.}\n\n\\item{lr_scheduler}{Character or torch function: \"step\", \"reduce_on_plateau\".}\n\n\\item{lr_decay}{Numeric: Learning rate decay.}\n\n\\item{step_size}{Positive integer: Step size.}\n\n\\item{checkpoint_epochs}{(Tunable) Positive integer: Checkpoint epochs.}\n\n\\item{cat_emb_dim}{(Tunable) Positive integer: Categorical embedding dimension.}\n\n\\item{num_independent}{(Tunable) Positive integer: Number of independent Gated Linear Units (GLU)\nat each step of the encoder.}\n\n\\item{num_shared}{(Tunable) Positive integer: Number of shared Gated Linear Units (GLU) at each\nstep of the encoder.}\n\n\\item{num_independent_decoder}{(Tunable) Positive integer: Number of independent GLU layers for\npretraining.}\n\n\\item{num_shared_decoder}{(Tunable) Positive integer: Number of shared GLU layers for\npretraining.}\n\n\\item{momentum}{(Tunable) Numeric: Momentum.}\n\n\\item{pretraining_ratio}{(Tunable) Numeric: Pretraining ratio.}\n\n\\item{device}{Character: Device \"cpu\" or \"cuda\".}\n\n\\item{importance_sample_size}{Positive integer: Importance sample size.}\n\n\\item{early_stopping_monitor}{Character: Early stopping monitor. \"valid_loss\", \"train_loss\",\n\"auto\".}\n\n\\item{early_stopping_tolerance}{Numeric: Minimum relative improvement to reset the patience\ncounter.}\n\n\\item{early_stopping_patience}{Positive integer: Number of epochs without improving before\nstopping.}\n\n\\item{num_workers}{Positive integer: Number of subprocesses for data loacding.}\n\n\\item{skip_importance}{Logical: If TRUE, skip importance calculation.}\n\n\\item{ifw}{Logical: If TRUE, use Inverse Frequency Weighting in classification.}\n}\n\\value{\nTabNetHyperparameters object.\n}\n\\description{\nSetup hyperparameters for TabNet training.\n}\n\\examples{\ntabnet_hyperparams <- setup_TabNet(epochs = 100L, learn_rate = 0.01)\ntabnet_hyperparams\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_UMAP.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/11_DecompositionConfig.R\n\\name{setup_UMAP}\n\\alias{setup_UMAP}\n\\title{Setup UMAP config.}\n\\usage{\nsetup_UMAP(\n k = 2L,\n n_neighbors = 15L,\n init = \"spectral\",\n metric = c(\"euclidean\", \"cosine\", \"manhattan\", \"hamming\", \"categorical\"),\n n_epochs = NULL,\n learning_rate = 1,\n scale = TRUE\n)\n}\n\\arguments{\n\\item{k}{Integer: Number of components.}\n\n\\item{n_neighbors}{Integer: Number of keighbors.}\n\n\\item{init}{Character: Initialization type. See \\verb{uwot::umap \"init\"}.}\n\n\\item{metric}{Character: Distance metric to use: \"euclidean\", \"cosine\",\n\"manhattan\", \"hamming\", \"categorical\".}\n\n\\item{n_epochs}{Integer: Number of epochs.}\n\n\\item{learning_rate}{Float: Learning rate.}\n\n\\item{scale}{Logical: If TRUE, scale input data before doing UMAP.}\n}\n\\value{\nUMAPConfig object.\n}\n\\description{\nSetup UMAP config.\n}\n\\details{\nA high \\code{n_neighbors} value may give error in some systems:\n\"Error in irlba::irlba(L, nv = n, nu = 0, maxit = iters) :\nfunction 'as_cholmod_sparse' not provided by package 'Matrix'\"\n}\n\\examples{\numap_config <- setup_UMAP(k = 3L)\numap_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/setup_tSNE.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/11_DecompositionConfig.R\n\\name{setup_tSNE}\n\\alias{setup_tSNE}\n\\title{Setup tSNE config.}\n\\usage{\nsetup_tSNE(\n k = 2L,\n initial_dims = 50L,\n perplexity = 30,\n theta = 0.5,\n check_duplicates = TRUE,\n pca = TRUE,\n partial_pca = FALSE,\n max_iter = 1000L,\n verbose = getOption(\"verbose\", FALSE),\n is_distance = FALSE,\n Y_init = NULL,\n pca_center = TRUE,\n pca_scale = FALSE,\n normalize = TRUE,\n stop_lying_iter = ifelse(is.null(Y_init), 250L, 0L),\n mom_switch_iter = ifelse(is.null(Y_init), 250L, 0L),\n momentum = 0.5,\n final_momentum = 0.8,\n eta = 200,\n exaggeration_factor = 12,\n num_threads = 1L\n)\n}\n\\arguments{\n\\item{k}{Integer: Number of components.}\n\n\\item{initial_dims}{Integer: Initial dimensions.}\n\n\\item{perplexity}{Integer: Perplexity.}\n\n\\item{theta}{Float: Theta.}\n\n\\item{check_duplicates}{Logical: If TRUE, check for duplicates.}\n\n\\item{pca}{Logical: If TRUE, perform PCA.}\n\n\\item{partial_pca}{Logical: If TRUE, perform partial PCA.}\n\n\\item{max_iter}{Integer: Maximum number of iterations.}\n\n\\item{verbose}{Logical: If TRUE, print messages.}\n\n\\item{is_distance}{Logical: If TRUE, \\code{x} is a distance matrix.}\n\n\\item{Y_init}{Matrix: Initial Y matrix.}\n\n\\item{pca_center}{Logical: If TRUE, center PCA.}\n\n\\item{pca_scale}{Logical: If TRUE, scale PCA.}\n\n\\item{normalize}{Logical: If TRUE, normalize.}\n\n\\item{stop_lying_iter}{Integer: Stop lying iterations.}\n\n\\item{mom_switch_iter}{Integer: Momentum switch iterations.}\n\n\\item{momentum}{Float: Momentum.}\n\n\\item{final_momentum}{Float: Final momentum.}\n\n\\item{eta}{Float: Eta.}\n\n\\item{exaggeration_factor}{Float: Exaggeration factor.}\n\n\\item{num_threads}{Integer: Number of threads.}\n}\n\\value{\ntSNEConfig object.\n}\n\\description{\nSetup tSNE config.\n}\n\\details{\nGet more information on the config by running \\code{?Rtsne::Rtsne}.\n}\n\\examples{\ntSNE_config <- setup_tSNE(k = 3L)\ntSNE_config\n}\n\\author{\nEDG\n}\n" }, { "path": "man/size.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils.R\n\\name{size}\n\\alias{size}\n\\title{Size of object}\n\\usage{\nsize(x, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{any object with \\code{length()} or \\code{dim()}.}\n\n\\item{verbosity}{Integer: Verbosity level. If > 0, print size to console}\n}\n\\value{\nInteger vector with length equal to the number of dimensions of \\code{x}, invisibly.\n}\n\\description{\nReturns the size of an object\n}\n\\details{\nIf \\code{dim(x)} is NULL, returns \\code{length(x)}.\n}\n\\examples{\nx <- rnorm(20)\nsize(x)\n# 20\nx <- matrix(rnorm(100), 20, 5)\nsize(x)\n# 20 5\n}\n\\author{\nEDG\n}\n" }, { "path": "man/table_column_attr.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_data.R\n\\name{table_column_attr}\n\\alias{table_column_attr}\n\\title{Tabulate column attributes}\n\\usage{\ntable_column_attr(x, attr = \"source\", useNA = \"always\")\n}\n\\arguments{\n\\item{x}{tabular data: Input data set.}\n\n\\item{attr}{Character: Attribute to get}\n\n\\item{useNA}{Character: Passed to \\code{table}}\n}\n\\value{\ntable.\n}\n\\description{\nTabulate column attributes\n}\n\\examples{\nlibrary(data.table)\nx <- data.table(\n id = 1:5,\n sbp = rnorm(5, 120, 15),\n dbp = rnorm(5, 80, 10),\n paO2 = rnorm(5, 90, 10),\n paCO2 = rnorm(5, 40, 5)\n)\nsetattr(x[[\"sbp\"]], \"source\", \"outpatient\")\nsetattr(x[[\"dbp\"]], \"source\", \"outpatient\")\nsetattr(x[[\"paO2\"]], \"source\", \"icu\")\nsetattr(x[[\"paCO2\"]], \"source\", \"icu\")\ntable_column_attr(x, \"source\")\n}\n\\author{\nEDG\n}\n" }, { "path": "man/theme.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/theme.R\n\\name{theme_black}\n\\alias{theme_black}\n\\alias{theme_blackgrid}\n\\alias{theme_blackigrid}\n\\alias{theme_darkgray}\n\\alias{theme_darkgraygrid}\n\\alias{theme_darkgrayigrid}\n\\alias{theme_white}\n\\alias{theme_whitegrid}\n\\alias{theme_whiteigrid}\n\\alias{theme_lightgraygrid}\n\\alias{theme_mediumgraygrid}\n\\title{Themes for \\verb{draw_*} functions}\n\\usage{\ntheme_black(\n bg = \"#000000\",\n plot_bg = \"transparent\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = FALSE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = fg,\n grid_alpha = 0.2,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = fg,\n tick_alpha = 0.5,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n\ntheme_blackgrid(\n bg = \"#000000\",\n plot_bg = \"transparent\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = fg,\n grid_alpha = 0.2,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = fg,\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n\ntheme_blackigrid(\n bg = \"#000000\",\n plot_bg = \"#1A1A1A\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = bg,\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = fg,\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n\ntheme_darkgray(\n bg = \"#121212\",\n plot_bg = \"transparent\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = FALSE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = fg,\n grid_alpha = 0.2,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = fg,\n tick_alpha = 0.5,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n\ntheme_darkgraygrid(\n bg = \"#121212\",\n plot_bg = \"transparent\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = \"#404040\",\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"#00000000\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n\ntheme_darkgrayigrid(\n bg = \"#121212\",\n plot_bg = \"#202020\",\n fg = \"#ffffff\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = bg,\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"transparent\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n\ntheme_white(\n bg = \"#ffffff\",\n plot_bg = \"transparent\",\n fg = \"#000000\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = FALSE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = fg,\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = fg,\n tick_alpha = 0.5,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n\ntheme_whitegrid(\n bg = \"#ffffff\",\n plot_bg = \"transparent\",\n fg = \"#000000\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = \"#c0c0c0\",\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"#00000000\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n\ntheme_whiteigrid(\n bg = \"#ffffff\",\n plot_bg = \"#E6E6E6\",\n fg = \"#000000\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = bg,\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"transparent\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n\ntheme_lightgraygrid(\n bg = \"#dfdfdf\",\n plot_bg = \"transparent\",\n fg = \"#000000\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = \"#c0c0c0\",\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"#00000000\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n\ntheme_mediumgraygrid(\n bg = \"#b3b3b3\",\n plot_bg = \"transparent\",\n fg = \"#000000\",\n pch = 16,\n cex = 1,\n lwd = 2,\n bty = \"n\",\n box_col = fg,\n box_alpha = 1,\n box_lty = 1,\n box_lwd = 0.5,\n grid = TRUE,\n grid_nx = NULL,\n grid_ny = NULL,\n grid_col = \"#d0d0d0\",\n grid_alpha = 1,\n grid_lty = 1,\n grid_lwd = 1,\n axes_visible = TRUE,\n axes_col = \"transparent\",\n tick_col = \"#00000000\",\n tick_alpha = 1,\n tick_labels_col = fg,\n tck = -0.01,\n tcl = NA,\n x_axis_side = 1,\n y_axis_side = 2,\n labs_col = fg,\n x_axis_line = 0,\n x_axis_las = 0,\n x_axis_padj = -1.1,\n x_axis_hadj = 0.5,\n y_axis_line = 0,\n y_axis_las = 1,\n y_axis_padj = 0.5,\n y_axis_hadj = 0.5,\n xlab_line = 1.4,\n ylab_line = 2,\n zerolines = TRUE,\n zerolines_col = fg,\n zerolines_alpha = 0.5,\n zerolines_lty = 1,\n zerolines_lwd = 1,\n main_line = 0.25,\n main_adj = 0,\n main_font = 2,\n main_col = fg,\n font_family = getOption(\"rtemis_font\", \"Helvetica\")\n)\n}\n\\arguments{\n\\item{bg}{Color: Figure background.}\n\n\\item{plot_bg}{Color: Plot region background.}\n\n\\item{fg}{Color: Foreground color used as default for multiple elements like\naxes and labels, which can be defined separately.}\n\n\\item{pch}{Integer: Point character.}\n\n\\item{cex}{Float: Character expansion factor.}\n\n\\item{lwd}{Float: Line width.}\n\n\\item{bty}{Character: Box type: \"o\", \"l\", \"7\", \"c\", \"u\", or \"]\", or \"n\".}\n\n\\item{box_col}{Box color if \\code{bty != \"n\"}.}\n\n\\item{box_alpha}{Float: Box alpha.}\n\n\\item{box_lty}{Integer: Box line type.}\n\n\\item{box_lwd}{Float: Box line width.}\n\n\\item{grid}{Logical: If TRUE, draw grid in plot regions.}\n\n\\item{grid_nx}{Integer: N of vertical grid lines.}\n\n\\item{grid_ny}{Integer: N of horizontal grid lines.}\n\n\\item{grid_col}{Grid color.}\n\n\\item{grid_alpha}{Float: Grid alpha.}\n\n\\item{grid_lty}{Integer: Grid line type.}\n\n\\item{grid_lwd}{Float: Grid line width.}\n\n\\item{axes_visible}{Logical: If TRUE, draw axes.}\n\n\\item{axes_col}{Axes colors.}\n\n\\item{tick_col}{Tick color.}\n\n\\item{tick_alpha}{Float: Tick alpha.}\n\n\\item{tick_labels_col}{Tick labels' color.}\n\n\\item{tck}{\\code{graphics::parr}'s tck argument: Tick length, can be negative.}\n\n\\item{tcl}{\\code{graphics::parr}'s tcl argument.}\n\n\\item{x_axis_side}{Integer: Side to place x-axis.}\n\n\\item{y_axis_side}{Integer: Side to place y-axis.}\n\n\\item{labs_col}{Labels' color.}\n\n\\item{x_axis_line}{Numeric: \\code{graphics::axis}'s \\code{line} argument for the x-axis.}\n\n\\item{x_axis_las}{Numeric: \\code{graphics::axis}'s \\code{las} argument for the x-axis.}\n\n\\item{x_axis_padj}{Numeric: x-axis' \\code{padj}: Adjustment for the x-axis\ntick labels' position.}\n\n\\item{x_axis_hadj}{Numeric: x-axis' \\code{hadj}.}\n\n\\item{y_axis_line}{Numeric: \\code{graphics::axis}'s \\code{line} argument for the y-axis.}\n\n\\item{y_axis_las}{Numeric: \\code{graphics::axis}'s \\code{las} argument for the y-axis.}\n\n\\item{y_axis_padj}{Numeric: y-axis' \\code{padj}.}\n\n\\item{y_axis_hadj}{Numeric: y-axis' \\code{hadj}.}\n\n\\item{xlab_line}{Numeric: Line to place \\code{xlab}.}\n\n\\item{ylab_line}{Numeric: Line to place \\code{ylab}.}\n\n\\item{zerolines}{Logical: If TRUE, draw lines on x = 0, y = 0, if within\nplot limits.}\n\n\\item{zerolines_col}{Zerolines color.}\n\n\\item{zerolines_alpha}{Float: Zerolines alpha.}\n\n\\item{zerolines_lty}{Integer: Zerolines line type.}\n\n\\item{zerolines_lwd}{Float: Zerolines line width.}\n\n\\item{main_line}{Float: How many lines away from the plot region to draw\ntitle.}\n\n\\item{main_adj}{Float: How to align title.}\n\n\\item{main_font}{Integer: 1: Regular, 2: Bold.}\n\n\\item{main_col}{Title color.}\n\n\\item{font_family}{Character: Font to be used throughout plot.}\n}\n\\value{\n\\code{Theme} object.\n}\n\\description{\nThemes for \\verb{draw_*} functions\n}\n\\examples{\ntheme <- theme_black(font_family = \"Geist\")\ntheme\n}\n" }, { "path": "man/to_json.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R\n\\name{to_json}\n\\alias{to_json}\n\\title{Convert to JSON-serializable list}\n\\usage{\nto_json(x, ...)\n}\n\\arguments{\n\\item{x}{rtemis S7 object.}\n\n\\item{...}{Additional arguments passed to method.}\n}\n\\value{\nNamed list. Pass through \\code{jsonlite::toJSON(auto_unbox = TRUE)}\nfor serialization.\n}\n\\description{\nConvert an rtemis S7 object to a named list suitable for\n\\code{jsonlite::toJSON(auto_unbox = TRUE)}. Used by the rtemislive backend\nto send structured results to the browser frontend without scraping\nR console output.\n}\n\\details{\nEach output list includes a \\code{.class} field equal to the most specific\nS7 class name, allowing the frontend to dispatch to a class-specific\nrenderer.\n\nThe default method walks \\code{props(x)}, recursing into S7-typed properties\nand passing through primitive properties as-is. Per-class methods\noverride where the default isn't appropriate (e.g. classes whose props\ninclude a \\code{data.table}, an opaque model fit, or where some props should\nbe excluded for size or relevance reasons).\n}\n\\author{\nEDG\n}\n\\keyword{internal}\n" }, { "path": "man/train.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/train.R\n\\name{train}\n\\alias{train}\n\\title{Train Supervised Learning Models}\n\\usage{\ntrain(\n x,\n dat_validation = NULL,\n dat_test = NULL,\n weights = NULL,\n algorithm = NULL,\n preprocessor_config = NULL,\n hyperparameters = NULL,\n tuner_config = NULL,\n outer_resampling_config = NULL,\n execution_config = setup_ExecutionConfig(),\n question = NULL,\n outdir = NULL,\n verbosity = 1L,\n ...\n)\n}\n\\arguments{\n\\item{x}{Tabular data, i.e. data.frame, data.table, or tbl_df (tibble): Training set data.}\n\n\\item{dat_validation}{Tabular data: Validation set data.}\n\n\\item{dat_test}{Tabular data: Test set data.}\n\n\\item{weights}{Optional vector of case weights.}\n\n\\item{algorithm}{Character: Algorithm to use. Can be left NULL, if \\code{hyperparameters} is defined.}\n\n\\item{preprocessor_config}{Optional PreprocessorConfig object: Setup using \\link{setup_Preprocessor}.}\n\n\\item{hyperparameters}{\\code{Hyperparameters} object: Setup using one of \\verb{setup_*} functions.}\n\n\\item{tuner_config}{TunerConfig object: Setup using \\link{setup_GridSearch}.}\n\n\\item{outer_resampling_config}{Optional ResamplerConfig object: Setup using \\link{setup_Resampler}.\nThis defines the outer resampling method, i.e. the splitting into training and test sets for the\npurpose of assessing model performance. If NULL, no outer resampling is performed, in which case\nyou might want to use a \\code{dat_test} dataset to assess model performance on a single test set.}\n\n\\item{execution_config}{\\code{ExecutionConfig} object: Setup using \\link{setup_ExecutionConfig}. This\nallows you to set backend (\"future\", \"mirai\", or \"none\"), number of workers, and future plan if\nusing \\code{backend = \"future\"}.}\n\n\\item{question}{Optional character string defining the question that the model is trying to\nanswer.}\n\n\\item{outdir}{Character, optional: String defining the output directory.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n\n\\item{...}{Not used.}\n}\n\\value{\nObject of class \\code{Regression(Supervised)}, \\code{RegressionRes(SupervisedRes)},\n\\code{Classification(Supervised)}, or \\code{ClassificationRes(SupervisedRes)}.\n}\n\\description{\nPreprocess, tune, train, and test supervised learning models using nested resampling in a single\ncall.\n}\n\\details{\n\\strong{Online book & documentation}\n\nSee \\href{https://docs.rtemis.org/r/}{docs.rtemis.org/r} for detailed documentation.\n\n\\strong{Preprocessing}\n\nThere are many different stages at which preprocessing could be applied, when running a\nsupervised learning pipeline with nested resampling. Some operations are best done before\npassing data to \\code{train()}:\n\\itemize{\n\\item Duplicate rows should be removed before resampling, so that duplicates don't end up in\ndifferent resamples, e.g. one in training and one in test.\n\\item Constant columns should be removed before resampling. A column may appear constant in a small\nresample, even if it is not constant in the full dataset. Removing it inconsistently will\nthrow an error during prediction.\n\\item All data-dependent preprocessing steps need to be performed on training data only and applied\non validation and test data, e.g. scaling, centering, imputation.\n}\n\nUser-defined preprocessing through \\code{preprocessor_config} is applied on training set data,\nthe learned parameters are stored in the returned Supervised or SupervisedRes object, and the\npreprocessing is applied on validation and test data.\n\n\\strong{Binary Classification}\n\nFor binary classification, the outcome should be a factor where \\emph{the 2nd level\ncorresponds to the positive class}.\n\n\\strong{Resampling}\n\nNote that you should not use an outer resampling method with\nreplacement if you will also be using an inner resampling (for tuning).\nThe duplicated cases from the outer resampling may appear both in the\ntraining and test sets of the inner resamples, leading to underestimated\ntest error.\n\n\\strong{Reproducibility}\n\nIf using \\emph{\\strong{outer resampling}}, you can set a seed when defining \\code{outer_resampling_config}, e.g.\n\n\\if{html}{\\out{
}}\\preformatted{outer_resampling_config = setup_Resampler(n_resamples = 10L, type = \"KFold\", seed = 2026L)\n}\\if{html}{\\out{
}}\n\nIf using \\emph{\\strong{tuning with inner resampling}}, you can set a seed when defining \\code{tuner_config},\ne.g.\n\n\\if{html}{\\out{
}}\\preformatted{tuner_config = setup_GridSearch(\n resampler_config = setup_Resampler(n_resamples = 5L, type = \"KFold\", seed = 2027L)\n)\n}\\if{html}{\\out{
}}\n\n\\strong{Parallelization}\n\nThere are three levels of parallelization that may be used during training:\n\\enumerate{\n\\item Algorithm training (e.g. a parallelized learner like LightGBM)\n\\item Tuning (inner resampling, where multiple resamples can be processed in parallel)\n\\item Outer resampling (where multiple outer resamples can be processed in parallel)\n}\n\nThe \\code{train()} function will automatically manage parallelization depending\non:\n\\itemize{\n\\item The number of workers specified by the user using \\code{n_workers}\n\\item Whether the training algorithm supports parallelization itself\n\\item Whether hyperparameter tuning is needed\n}\n}\n\\examples{\n\\donttest{\niris_c_lightRF <- train(\n iris,\n algorithm = \"LightRF\",\n outer_resampling_config = setup_Resampler(),\n)\n}\n}\n\\author{\nEDG\n}\n" }, { "path": "man/uniprot_get.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_uniprot.R\n\\name{uniprot_get}\n\\alias{uniprot_get}\n\\title{Get protein sequence from UniProt}\n\\usage{\nuniprot_get(\n accession,\n baseURL = \"https://rest.uniprot.org/uniprotkb\",\n verbosity = 1\n)\n}\n\\arguments{\n\\item{accession}{Character: UniProt Accession number - e.g. \"Q9UMX9\"}\n\n\\item{baseURL}{Character: UniProt rest API base URL.\nDefault = \"https://rest.uniprot.org/uniprotkb\"}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\nList with three elements: Identifier, Annotation, and Sequence.\n}\n\\description{\nGet protein sequence from UniProt\n}\n\\examples{\n\\dontrun{\n# This gets the sequence from uniprot.org by default\nmapt <- uniprot_get(\"Q9UMX9\")\n}\n}\n\\author{\nE.D. Gennatas\n}\n" }, { "path": "man/with_msg_sink.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/msg.R\n\\name{with_msg_sink}\n\\alias{with_msg_sink}\n\\title{Run code with a temporary message sink}\n\\usage{\nwith_msg_sink(sink, code)\n}\n\\arguments{\n\\item{sink}{Sink function or \\code{NULL}.}\n\n\\item{code}{Code to run.}\n}\n\\value{\nThe value returned by \\code{code}.\n}\n\\description{\nSets \\code{sink} for the duration of \\code{code}, restoring the previous sink on exit\n(including on error). Useful in tests and for short-lived capture.\n}\n\\examples{\ncaptured <- list()\nwith_msg_sink(\n function(m) captured[[length(captured) + 1L]] <<- m,\n {\n # any msg() / msg0() / msgstart() / msgdone() calls in here are captured\n }\n)\n}\n\\seealso{\n\\code{\\link[=set_msg_sink]{set_msg_sink()}}, \\code{\\link[=get_msg_sink]{get_msg_sink()}}.\n}\n\\author{\nEDG\n}\n" }, { "path": "man/write_toml.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/00_S7init.R, R/14_SuperConfig.R\n\\name{write_toml}\n\\alias{write_toml}\n\\title{Write to TOML file}\n\\usage{\nwrite_toml(x, file, overwrite = FALSE, verbosity = 1L)\n\n## S7 method for class \nwrite_toml(x, file, overwrite = FALSE, verbosity = 1L)\n}\n\\arguments{\n\\item{x}{\\code{SuperConfig} object.}\n\n\\item{file}{Character: Path to output TOML file.}\n\n\\item{overwrite}{Logical: If TRUE, overwrite existing file.}\n\n\\item{verbosity}{Integer: Verbosity level.}\n}\n\\value{\n\\code{SuperConfig} object, invisibly.\n}\n\\description{\nWrite to TOML file\n}\n\\examples{\nx <- setup_SuperConfig(\n dat_training_path = \"~/Data/iris.csv\",\n dat_validation_path = NULL,\n dat_test_path = NULL,\n weights = NULL,\n preprocessor_config = setup_Preprocessor(remove_duplicates = TRUE),\n algorithm = \"LightRF\",\n hyperparameters = setup_LightRF(),\n tuner_config = setup_GridSearch(),\n outer_resampling_config = setup_Resampler(),\n execution_config = setup_ExecutionConfig(),\n question = \"Can we tell iris species apart given their measurements?\",\n outdir = \"models/\",\n verbosity = 1L\n)\ntmpdir <- tempdir()\nwrite_toml(x, file.path(tmpdir, \"rtemis.toml\"))\n}\n\\author{\nEDG\n}\n" }, { "path": "man/xt_example.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/data_xt_example.R\n\\docType{data}\n\\name{xt_example}\n\\alias{xt_example}\n\\title{Example longitudinal dataset}\n\\format{\nA data frame with 30 rows and 4 variables:\n\\describe{\n\\item{patient_id}{Integer: Patient identifier (1-10).}\n\\item{year}{Integer: Year of measurement (2020-2024).}\n\\item{blood_pressure}{Numeric: Systolic blood pressure measurement.}\n\\item{treatment}{Character: Treatment group (\"A\" or \"B\").}\n}\n}\n\\usage{\nxt_example\n}\n\\description{\nA small synthetic dataset demonstrating various participation patterns\nin longitudinal data, suitable for examples with \\code{\\link{xtdescribe}}.\n}\n\\details{\nThis dataset includes 10 patients measured at up to 5 time points (years 2020-2024).\nThe dataset demonstrates various participation patterns typical in longitudinal studies:\n\\itemize{\n\\item Complete participation (all time points)\n\\item Early dropout\n\\item Late entry\n\\item Intermittent participation\n\\item Single time point participation\n}\n}\n\\examples{\ndata(xt_example)\nhead(xt_example)\nsummary(xt_example)\n\n}\n\\keyword{datasets}\n" }, { "path": "man/xtdescribe.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils_xt.R\n\\name{xtdescribe}\n\\alias{xtdescribe}\n\\title{Describe longitudinal dataset}\n\\usage{\nxtdescribe(x, id_col = 1, time_col = 2, n_patterns = 9)\n}\n\\arguments{\n\\item{x}{data.frame: Longitudinal data with ID and time variables.}\n\n\\item{id_col}{Integer: The column position of the ID variable.}\n\n\\item{time_col}{Integer: The column position of the time variable.}\n\n\\item{n_patterns}{Integer: The number of patterns to display.}\n}\n\\value{\ndata.frame: Summary of participation patterns, returned invisibly.\n}\n\\description{\nThis function emulates the \\code{xtdescribe} function in Stata.\n}\n\\examples{\n# Load example longitudinal dataset\ndata(xt_example)\n\n# Describe the longitudinal structure\nxtdescribe(xt_example)\n}\n\\author{\nEDG\n}\n" }, { "path": "tests/testthat/test_Calibration.R", "content": "# test_Calibration.R\n# ::rtemis::\n# EDG rtemis.org\n\n# Key\n# {Algorithm}[method] Further conditions\n\n# Setup ----\n# library(rtemis)\n# library(testthat)\nlibrary(data.table)\n\n# Data ----\n## Regression Data ----\nn <- 400\nx <- rnormmat(n, 5, seed = 2025)\ng <- factor(sample(c(\"A\", \"B\"), n, replace = TRUE))\ny <- x[, 3] + x[, 5] + ifelse(g == \"A\", 2, -1) + rnorm(n)\ndatr <- data.table(x, g, y)\nresr <- resample(datr)\ndatr_train <- datr[resr$Fold_1, ]\ndatr_test <- datr[-resr$Fold_1, ]\n\n## Classification Data ----\n### Binary ----\ndatc2 <- data.frame(\n gn = factor(sample(c(\"alpha\", \"beta\", \"gamma\"), 100, replace = TRUE)),\n iris[51:150, ]\n)\ndatc2$Species <- factor(datc2$Species)\nresc2 <- resample(datc2)\ndatc2_train <- datc2[resc2$Fold_1, ]\ndatc2_test <- datc2[-resc2$Fold_1, ]\n\n### 3-class ----\ndatc3 <- iris\nresc3 <- resample(datc3)\ndatc3_train <- datc3[resc3$Fold_1, ]\ndatc3_test <- datc3[-resc3$Fold_1, ]\n" }, { "path": "tests/testthat/test_CheckData.R", "content": "# test_CheckData.R\n# ::rtemis::\n# 2025- EDG rtemis.org\n\n# %% check_data() ----\ntest_that(\"check_data() succeeds\", {\n x <- data.frame(\n a = c(1, 2, 3, NA),\n b = c(\"A\", \"B\", \"C\", \"D\"),\n c = c(1.5, NA, 3.5, NA)\n )\n x_cd <- check_data(x, get_na_case_pct = TRUE, get_na_feature_pct = TRUE)\n expect_s7_class(x_cd, CheckData)\n expect_equal(x_cd$n_na, 3)\n expect_equal(x_cd$n_cols_anyna, 2)\n expect_equal(nrow(x_cd$na_feature_pct), 2)\n expect_equal(x_cd$na_feature_pct$Feature, c(\"a\", \"c\"))\n expect_equal(x_cd$na_feature_pct$Pct_NA, c(0.25, 0.5))\n expect_equal(nrow(x_cd$na_case_pct), 2)\n expect_equal(x_cd$na_case_pct$Case, c(2, 4))\n expect_equal(x_cd$na_case_pct$Pct_NA, c(1 / 3, 2 / 3))\n})\n" }, { "path": "tests/testthat/test_Clustering.R", "content": "# test_Clustering.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# Data ----\nx <- iris[, -5]\n\n# setup_KMeans ----\ntest_that(\"setup_KMeans() succeeds\", {\n expect_s7_class(setup_KMeans(), KMeansConfig)\n})\n\n# setup_KMeans throws error ----\ntest_that(\"setup_KMeans() throws error with bad values or wrong types\", {\n expect_error(setup_KMeans(k = -1L))\n expect_error(setup_KMeans(dist = \"foo\"))\n})\n\n# cluster KMeans ----\ntest_that(\"cluster_KMeans() succeeds\", {\n iris_kmeans <- cluster(\n x,\n algorithm = \"kmeans\",\n config = setup_KMeans(k = 3L)\n )\n expect_s7_class(iris_kmeans, Clustering)\n})\n\n# cluster KMeans with k = 10 ----\ntest_that(\"cluster_KMeans() with k = 10 succeeds\", {\n skip_if_not_installed(\"flexclust\")\n iris_kmeans10 <- cluster(\n x,\n algorithm = \"kmeans\",\n config = setup_KMeans(k = 10L)\n )\n expect_s7_class(iris_kmeans10, Clustering)\n})\n\n# setup_HardCL ----\ntest_that(\"setup_HardCL() succeeds\", {\n expect_s7_class(setup_HardCL(), HardCLConfig)\n})\n\n# cluster HardCL ----\ntest_that(\"cluster_HardCL() succeeds\", {\n skip_if_not_installed(\"flexclust\")\n iris_hardcl <- cluster(\n x,\n algorithm = \"HardCL\",\n config = setup_HardCL(k = 3L)\n )\n expect_s7_class(iris_hardcl, Clustering)\n})\n\n# setup_NeuralGas ----\ntest_that(\"setup_NeuralGas() succeeds\", {\n expect_s7_class(setup_NeuralGas(), NeuralGasConfig)\n})\n\n# cluster NeuralGas ----\ntest_that(\"cluster_NeuralGas() succeeds\", {\n skip_if_not_installed(\"flexclust\")\n iris_neuralgas <- cluster(\n x,\n algorithm = \"NeuralGas\",\n config = setup_NeuralGas(k = 3L)\n )\n expect_s7_class(iris_neuralgas, Clustering)\n})\n\n# setup_CMeans ----\ntest_that(\"setup_CMeans() succeeds\", {\n expect_s7_class(setup_CMeans(), CMeansConfig)\n})\n\n# cluster CMeans ----\ntest_that(\"cluster_CMeans() succeeds\", {\n skip_if_not_installed(\"e1071\")\n iris_cmeans <- cluster(\n x,\n algorithm = \"CMeans\",\n config = setup_CMeans(k = 3L)\n )\n expect_s7_class(iris_cmeans, Clustering)\n})\n\n# setup_DBSCAN ----\ntest_that(\"setup_DBSCAN() succeeds\", {\n expect_s7_class(setup_DBSCAN(), DBSCANConfig)\n})\n\n# cluster DBSCAN ----\ntest_that(\"cluster_DBSCAN() succeeds\", {\n skip_if_not_installed(\"dbscan\")\n iris_dbscan <- cluster(\n x,\n algorithm = \"DBSCAN\",\n config = setup_DBSCAN(eps = 0.5, min_points = 5L)\n )\n expect_s7_class(iris_dbscan, Clustering)\n})\n" }, { "path": "tests/testthat/test_Decomposition.R", "content": "# test_Decomposition.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# Data ----\nx <- iris[, -5]\n\n# PCA ----\ntest_that(\"setup_PCA() succeeds\", {\n config <- setup_PCA()\n expect_s7_class(config, PCAConfig)\n})\n\ntest_that(\"decomp() PCA succeeds\", {\n iris_pca <- decomp(x, algorithm = \"pca\", config = setup_PCA())\n iris_pca\n expect_s7_class(iris_pca, Decomposition)\n})\n\n# ICA ----\ntest_that(\"setup_ICA() succeeds\", {\n config <- setup_ICA()\n expect_s7_class(config, ICAConfig)\n})\n\ntest_that(\"decomp() ICA succeeds\", {\n skip_if_not_installed(\"fastICA\")\n iris_ica <- decomp(x, algorithm = \"ica\", config = setup_ICA())\n expect_s7_class(iris_ica, Decomposition)\n})\n\n# NMF ----\ntest_that(\"setup_NMF() succeeds\", {\n config <- setup_NMF()\n expect_s7_class(config, NMFConfig)\n})\n\ntest_that(\"decomp() NMF succeeds\", {\n skip_if_not_installed(\"NMF\")\n iris_nmf <- decomp(x, algorithm = \"nmf\", config = setup_NMF())\n expect_s7_class(iris_nmf, Decomposition)\n})\n\n# UMAP ----\ntest_that(\"setup_UMAP() succeeds\", {\n config <- setup_UMAP()\n expect_s7_class(config, UMAPConfig)\n})\n\ntest_that(\"decomp() UMAP succeeds\", {\n skip_if_not_installed(\"uwot\")\n iris_umap <- decomp(x, algorithm = \"umap\", config = setup_UMAP())\n iris_umap <- decomp(\n x,\n algorithm = \"umap\",\n config = setup_UMAP(n_neighbors = 20L)\n )\n expect_s7_class(iris_umap, Decomposition)\n})\n\n# t-SNE ----\ntest_that(\"setup_tSNE() succeeds\", {\n config <- setup_tSNE()\n expect_s7_class(config, tSNEConfig)\n})\n\n# Test that t-SNE fails with duplicates\ntest_that(\"decomp() t-SNE fails with duplicates\", {\n skip_if_not_installed(\"Rtsne\")\n expect_error(decomp(x, algorithm = \"tsne\"))\n})\n\n# Test that t-SNE works after removing duplicates\ntest_that(\"decomp() t-SNE succeeds after removing duplicates\", {\n skip_if_not_installed(\"Rtsne\")\n xp <- preprocess(x, setup_Preprocessor(remove_duplicates = TRUE))\n iris_tsne <- decomp(\n xp@preprocessed,\n algorithm = \"tsne\",\n config = setup_tSNE()\n )\n expect_s7_class(iris_tsne, Decomposition)\n})\n\n# Isomap ----\ntest_that(\"setup_Isomap() succeeds\", {\n config <- setup_Isomap()\n expect_s7_class(config, IsomapConfig)\n})\n\ntest_that(\"decomp() Isomap succeeds\", {\n skip_if_not_installed(\"vegan\")\n iris_isomap <- decomp(x, algorithm = \"isomap\", config = setup_Isomap())\n expect_s7_class(iris_isomap, Decomposition)\n})\n" }, { "path": "tests/testthat/test_ExecutionConfig.R", "content": "# test_ExecutionConfig.R\n# ::rtemis::\n# 2026- EDG rtemis.org\n\n# library(testthat)\n\n# %% ExecutionConfig ----\nec <- ExecutionConfig(\n backend = \"future\",\n n_workers = 4L,\n future_plan = \"multisession\"\n)\nec\ntestthat::test_that(\"ExecutionConfig() works\", {\n expect_s7_class(\n ec,\n ExecutionConfig\n )\n})\n\n# %% setup_ExecutionConfig() ----\nec <- setup_ExecutionConfig(\n backend = \"future\",\n n_workers = 4L,\n future_plan = \"multisession\"\n)\ntestthat::test_that(\"setup_ExecutionConfig() works\", {\n expect_s7_class(\n ec,\n ExecutionConfig\n )\n})\n" }, { "path": "tests/testthat/test_Hyperparameters.R", "content": "# test_Hyperparameters.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# Hyperparameters ----\nhpr <- Hyperparameters(\n algorithm = \"Custom\",\n hyperparameters = list(alpha = c(0, 1), beta = 2),\n tunable_hyperparameters = \"alpha\",\n fixed_hyperparameters = \"beta\"\n)\ntest_that(\"Hyperparameters succeeds\", {\n expect_s7_class(hpr, Hyperparameters)\n # test that tuned is set correctly\n expect_identical(hpr@tuned, 0L)\n})\n\n# CARTHyperparameters ----\ntest_that(\"CARTHyperparameters() errors\", {\n expect_error(CARTHyperparameters())\n})\n\n# get_hyperparams_need_tuning ----\ntest_that(\"get_hyperparams_need_tuning() succeeds\", {\n expect_type(get_hyperparams_need_tuning(hpr), \"list\")\n})\n\n# Check printing of hp that need tuning ----\n# CARTHyperparameters ----\n# setup_CART ----\ncart_hpr <- setup_CART(\n prune_cp = c(.001, .01, .1),\n minsplit = c(2L, 10L),\n minbucket = c(1L, 10L)\n)\ntest_that(\"setup_CART() succeeds\", {\n expect_s7_class(cart_hpr, CARTHyperparameters)\n})\n\n# needs_tuning ----\ntest_that(\"needs_tuning() succeeds\", {\n expect_type(needs_tuning(cart_hpr), \"logical\")\n})\n\n# GLMNETHyperparameters ----\ntest_that(\"GLMNETHyperparameters() errors\", {\n expect_error(GLMNETHyperparameters())\n})\n\n# setup_GLMNET ----\ntest_that(\"setup_GLMNET() succeeds\", {\n expect_s7_class(setup_GLMNET(), GLMNETHyperparameters)\n})\n\n# LightCARTHyperparameters ----\ntest_that(\"LightCARTHyperparameters() errors\", {\n expect_error(LightCARTHyperparameters())\n})\n\n# setup_LightCART ----\ntest_that(\"setup_LightCART() succeeds\", {\n expect_s7_class(setup_LightCART(), LightCARTHyperparameters)\n})\n\n# LightRFHyperparameters ----\ntest_that(\"LightRFHyperparameters() errors\", {\n expect_error(LightRFHyperparameters())\n})\n\n# setup_LightRF ----\ntest_that(\"setup_LightRF() succeeds\", {\n lrf_hpr <- setup_LightRF()\n lrf_hpr\n expect_s7_class(lrf_hpr, LightRFHyperparameters)\n})\n\n# LightGBMHyperparameters ----\ntest_that(\"LightGBMHyperparameters() errors\", {\n expect_error(LightGBMHyperparameters())\n})\n\n# setup_LightGBM ----\ntest_that(\"setup_LightGBM() succeeds\", {\n lgbm_hpr <- setup_LightGBM(\n num_leaves = c(4, 8, 16),\n learning_rate = c(.001, .01, .1)\n )\n expect_s7_class(setup_LightGBM(), LightGBMHyperparameters)\n})\n\n# LightRuleFitHyperparameters ----\ntest_that(\"LightRuleFitHyperparameters() errors\", {\n expect_error(LightRuleFitHyperparameters())\n})\n\n# setup_LightRuleFit ----\ntest_that(\"setup_LightRuleFit() succeeds\", {\n expect_s7_class(setup_LightRuleFit(), LightRuleFitHyperparameters)\n})\n\n# IsotonicHyperparameters ----\ntest_that(\"IsotonicHyperparameters() errors\", {\n expect_error(IsotonicHyperparameters())\n})\n\n# setup_Isotonic ----\ntest_that(\"setup_Isotonic() succeeds\", {\n expect_s7_class(setup_Isotonic(), IsotonicHyperparameters)\n})\n\n# RadialSVMHyperparameters ----\ntest_that(\"RadialSVMHyperparameters() errors\", {\n expect_error(RadialSVMHyperparameters())\n})\n\n# setup_LinearSVM ----\ntest_that(\"setup_LinearSVM() succeeds\", {\n expect_s7_class(setup_LinearSVM(), LinearSVMHyperparameters)\n})\n\n# setup_RadialSVM ----\ntest_that(\"setup_RadialSVM() succeeds\", {\n expect_s7_class(setup_RadialSVM(), RadialSVMHyperparameters)\n})\n\n# TabNetHyperparameters ----\ntest_that(\"TabNetHyperparameters() errors\", {\n expect_error(TabNetHyperparameters())\n})\n\n# setup_TabNet ----\ntest_that(\"setup_TabNet() succeeds\", {\n expect_s7_class(setup_TabNet(), TabNetHyperparameters)\n})\n\n# setup_Ranger ----\ntest_that(\"setup_Ranger() succeeds\", {\n expect_s7_class(setup_Ranger(), RangerHyperparameters)\n})\n" }, { "path": "tests/testthat/test_Metrics.R", "content": "# test_Metrics.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# Regression Data ----\nset.seed(2025)\ntrue <- rnorm(500)\npredicted <- true + rnorm(500) / 2\npredicted2 <- true + rnorm(500) / 2\n\n# RegressionMetrics ----\nreg_metrics <- regression_metrics(true, predicted, sample = \"Training\")\nreg_metrics\ntest_that(\"regression_metrics() succeeds\", {\n expect_s7_class(regression_metrics(true, predicted), RegressionMetrics)\n})\nreg_metrics2 <- regression_metrics(true, predicted2, sample = \"Test\")\n\n# Classification Data ----\ntrue_labels <- factor(c(\"a\", \"a\", \"a\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\"))\npredicted_labels <- factor(c(\"a\", \"b\", \"a\", \"b\", \"b\", \"a\", \"b\", \"b\", \"b\", \"a\"))\npredicted_prob <- c(0.3, 0.6, 0.45, 0.75, 0.57, 0.3, 0.8, 0.63, 0.62, 0.39)\npredicted_prob2 <- c(0.2, 0.52, 0.28, 0.85, 0.64, 0.45, 0.9, 0.78, 0.78, 0.47)\n\n# ClassificationMetrics ----\nclass_metrics1 <- classification_metrics(\n true_labels,\n predicted_labels,\n predicted_prob,\n sample = \"Training\"\n)\nclass_metrics2 <- classification_metrics(\n true_labels,\n predicted_labels,\n predicted_prob2,\n sample = \"Test\"\n)\n\ntest_that(\"classification_metrics() succeeds\", {\n expect_s7_class(class_metrics1, ClassificationMetrics)\n expect_s7_class(class_metrics2, ClassificationMetrics)\n})\n\n# Test that class_metrics2 has higher AUC and lower Brier score than class_metrics1\ntest_that(\"classification_metrics() returns correct metrics\", {\n expect_true(\n class_metrics2@metrics[[\"Overall\"]][[\"AUC\"]] >\n class_metrics1@metrics[[\"Overall\"]][[\"AUC\"]]\n )\n expect_true(\n class_metrics2@metrics[[\"Overall\"]][[\"Brier_Score\"]] <\n class_metrics1@metrics[[\"Overall\"]][[\"Brier_Score\"]]\n )\n})\n\n# RegressionMetricsRes ----\nres_metrics <- list(mod1 = reg_metrics, mod2 = reg_metrics2)\nrmcv <- RegressionMetricsRes(\n sample = \"Test\",\n res_metrics = res_metrics\n)\nrmcv\ntest_that(\"RegressionMetricsRes() succeeds\", {\n expect_s7_class(rmcv, RegressionMetricsRes)\n})\n\n# ClassificationMetricsRes ----\nres_metrics <- list(mod1 = class_metrics1, mod2 = class_metrics2)\ncmcv <- ClassificationMetricsRes(\n sample = \"Test\",\n res_metrics = res_metrics\n)\ncmcv\n\ntest_that(\"ClassificationMetricsRes() succeeds\", {\n expect_s7_class(cmcv, ClassificationMetricsRes)\n})\n" }, { "path": "tests/testthat/test_Preprocessor.R", "content": "# test_Preprocessor.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# library(testthat)\n\n# PreprocessorConfig ----\nprp <- setup_Preprocessor()\nprp\ntestthat::test_that(\"setup_Preprocessor() succeeds\", {\n expect_s7_class(setup_Preprocessor(), PreprocessorConfig)\n})\n\nprp <- setup_Preprocessor(\n remove_constants = TRUE,\n remove_duplicates = TRUE\n)\ntestthat::test_that(\"setup_Preprocessor() succeeds\", {\n expect_s7_class(prp, PreprocessorConfig)\n})\n\n# Preprocessor: preprocess(PreprocessorConfig) ----\nres <- resample(iris, setup_Resampler(seed = 2025))\niris_train <- iris[res$Fold_1, ]\niris_test <- iris[-res$Fold_1, ]\niris_Pre <- preprocess(\n iris_train,\n setup_Preprocessor(remove_duplicates = TRUE, scale = TRUE, center = TRUE)\n)\ntest_that(\"preprocess(x, PreprocessorConfig) succeeds\", {\n expect_s7_class(iris_Pre, Preprocessor)\n})\niris_Pre\niris_Pre@preprocessed\niris_Pre@values\n\niris_test_Pre <- preprocess(iris_test, iris_Pre)\ntest_that(\"preprocess(x, Preprocessor) succeeds\", {\n expect_s7_class(iris_test_Pre, Preprocessor)\n})\n\niris_Pre_too <- preprocess(\n iris_train,\n setup_Preprocessor(remove_duplicates = TRUE, scale = TRUE, center = TRUE),\n dat_test = iris_test\n)\ntest_that(\"preprocess(x, PreprocessorConfig) succeeds\", {\n expect_s7_class(iris_Pre_too, Preprocessor)\n})\n\ntest_that(\"preprocess(x, PreprocessorConfig) and preprocess(x, Preprocessor) give same test set\", {\n expect_equal(iris_Pre_too@preprocessed$test, iris_test_Pre@preprocessed)\n})\n\n# impute meanMode ----\nx <- iris\n# Continuous\nx[10:15, 1] <- NA\n# Categorical\nx[20:25, 5] <- NA\nxp <- preprocess(\n x,\n setup_Preprocessor(impute = TRUE, impute_type = \"meanMode\")\n)[[\"preprocessed\"]]\n\ntest_that(\"impute meanMode works\", {\n expect_false(anyNA(xp))\n})\n\n# Test one_hot ----\nn <- 10\nx <- rnormmat(n, 5, seed = 2025)\ng <- factor(sample(c(\"A\", \"B\"), n, replace = TRUE))\ny <- x[, 3] + x[, 5] + ifelse(g == \"A\", 2, -1) + rnorm(n)\ndatr <- data.frame(x, g, y)\ndatr_onehot <- preprocess(\n datr,\n setup_Preprocessor(one_hot = TRUE)\n)[[\"preprocessed\"]]\ntest_that(\"one_hot.data.frame works\", {\n expect_s3_class(datr_onehot, \"data.frame\")\n})\n" }, { "path": "tests/testthat/test_Resampler.R", "content": "# test_Resampler.R\n# ::rtemis::\n# EDG rtemis.org\n\n# library(testthat)\n\n# StratSubConfig ----\ntest_that(\"StratSubConfig succeeds\", {\n rsp <- StratSubConfig(\n n = 10L,\n stratify_var = NULL,\n train_p = .75,\n strat_n_bins = 4L,\n id_strat = NULL,\n seed = NULL\n )\n expect_s7_class(rsp, StratSubConfig)\n})\n\n# KFoldConfig ----\ntest_that(\"KFoldConfig succeeds\", {\n rsp <- KFoldConfig(\n n = 10L,\n stratify_var = NULL,\n strat_n_bins = 4L,\n id_strat = NULL,\n seed = NULL\n )\n expect_s7_class(rsp, KFoldConfig)\n})\n\n# BootstrapConfig ----\ntest_that(\"BootstrapConfig succeeds\", {\n rsp <- BootstrapConfig(\n n = 10L,\n id_strat = NULL,\n seed = NULL\n )\n expect_s7_class(rsp, BootstrapConfig)\n})\n\n# StratBootConfig ----\ntest_that(\"StratBootConfig succeeds\", {\n rsp <- StratBootConfig(\n n = 10L,\n stratify_var = NULL,\n train_p = .75,\n strat_n_bins = 4L,\n target_length = NULL,\n id_strat = NULL,\n seed = NULL\n )\n expect_s7_class(rsp, StratBootConfig)\n})\n\n# LOOCVConfig ----\ntest_that(\"LOOCVConfig succeeds\", {\n rsp <- LOOCVConfig(\n n = 10L\n )\n expect_s7_class(rsp, LOOCVConfig)\n})\n\n# CustomConfig ----\ntest_that(\"CustomConfig succeeds\", {\n rsp <- CustomConfig(\n n = 10L\n )\n expect_s7_class(rsp, CustomConfig)\n})\n\n# setup_Resampler() defaults ----\ntest_that(\"setup_Resampler() succeeds\", {\n rsp <- setup_Resampler()\n expect_s7_class(rsp, ResamplerConfig)\n})\n\n# setup_Resampler() kfold ----\ntest_that(\"setup_Resampler() kfold succeeds\", {\n rsp <- setup_Resampler(type = \"KFold\")\n expect_s7_class(rsp, KFoldConfig)\n})\n\n# setup_Resampler() strat_sub ----\ntest_that(\"setup_Resampler() strat_sub succeeds\", {\n rsp <- setup_Resampler(type = \"StratSub\")\n expect_s7_class(rsp, StratSubConfig)\n})\n\n# setup_Resampler() strat_boot ----\ntest_that(\"setup_Resampler() strat_boot succeeds\", {\n rsp <- setup_Resampler(type = \"StratBoot\")\n expect_s7_class(rsp, StratBootConfig)\n})\n\ntest_that(\"setup_Resampler() strat_boot fails with invalid train_p\", {\n expect_error(\n setup_Resampler(type = \"StratBoot\", train_p = 1)\n )\n})\n\n# setup_Resampler() bootstrap ----\ntest_that(\"setup_Resampler() bootstrap succeeds\", {\n rsp <- setup_Resampler(type = \"Bootstrap\")\n expect_s7_class(rsp, BootstrapConfig)\n})\n\n# setup_Resampler() loocv ----\ntest_that(\"setup_Resampler() loocv succeeds\", {\n rsp <- setup_Resampler(type = \"LOOCV\")\n expect_s7_class(rsp, LOOCVConfig)\n})\n\n# Resampler ----\ntest_that(\"Resampler() succeeds\", {\n res <- Resampler(\n type = \"Custom\",\n resamples = list(),\n config = setup_Resampler()\n )\n expect_s7_class(res, Resampler)\n})\n\n# resample() vector ----\n## KFold ----\ntest_that(\"resample() vector succeeds\", {\n res <- resample(iris[[1]], setup_Resampler(type = \"KFold\"))\n expect_s7_class(res, Resampler)\n})\n\n## StratSub ----\ntest_that(\"resample() vector succeeds with StratSub\", {\n res <- resample(iris[[1]], setup_Resampler(type = \"StratSub\"))\n expect_s7_class(res, Resampler)\n})\n\n## StratBoot ----\ntest_that(\"resample() vector succeeds with StratBoot\", {\n res <- resample(iris[[1]], setup_Resampler(type = \"StratBoot\"))\n expect_s7_class(res, Resampler)\n})\n\n## Bootstrap ----\ntest_that(\"resample() vector succeeds with Bootstrap\", {\n res <- resample(iris[[1]], setup_Resampler(type = \"Bootstrap\"))\n expect_s7_class(res, Resampler)\n})\n\n## LOOCV ----\ntest_that(\"resample() vector succeeds with LOOCV\", {\n res <- resample(iris[[1]], setup_Resampler(type = \"LOOCV\"))\n expect_s7_class(res, Resampler)\n})\n\n# resample() data.frame ----\ntest_that(\"resample() data.frame succeeds\", {\n res <- resample(iris, setup_Resampler())\n expect_s7_class(res, Resampler)\n})\n\n# resample() data.table ----\ntest_that(\"resample() data.table succeeds\", {\n res <- resample(as.data.table(iris), setup_Resampler())\n expect_s7_class(res, Resampler)\n})\n" }, { "path": "tests/testthat/test_SuperConfig.R", "content": "# test_SupervisedConfig.R\n# ::rtemis::\n# 2026- EDG rtemis.org\n\n# %% SuperConfig ----\ntest_that(\"SuperConfig() succeeds\", {\n sc <- SuperConfig(\n dat_training_path = \"train.csv\",\n dat_validation_path = \"validation.csv\",\n dat_test_path = \"test.csv\",\n weights = NULL,\n algorithm = \"GLMNET\",\n preprocessor_config = setup_Preprocessor(),\n hyperparameters = setup_GLMNET(),\n tuner_config = setup_GridSearch(),\n outer_resampling_config = setup_Resampler(),\n execution_config = setup_ExecutionConfig(),\n question = \"Can we predict the future from the past?\",\n outdir = \"results/\",\n verbosity = 1L\n )\n expect_s7_class(sc, SuperConfig)\n})\n\n# %% setup_SuperConfig() ----\ntest_that(\"setup_SuperConfig() succeeds\", {\n sc <- setup_SuperConfig(\n dat_training_path = \"train.csv\",\n dat_validation_path = \"validation.csv\",\n dat_test_path = \"test.csv\",\n weights = NULL,\n preprocessor_config = setup_Preprocessor(),\n algorithm = \"LightGBM\",\n hyperparameters = setup_LightGBM(),\n tuner_config = setup_GridSearch(),\n outer_resampling_config = setup_Resampler(),\n execution_config = setup_ExecutionConfig(),\n question = \"Can we predict the future from the past?\",\n outdir = \"models/\",\n verbosity = 1L\n )\n expect_s7_class(sc, SuperConfig)\n})\n\n\n# %% train SuperConfig ----\ntest_that(\"train() works with SuperConfig\", {\n testthat::skip(\"For local testing only; requires CSV file\")\n x <- setup_SuperConfig(\n dat_training_path = \"~/Data/iris.csv\",\n dat_validation_path = NULL,\n dat_test_path = NULL,\n weights = NULL,\n preprocessor_config = setup_Preprocessor(remove_duplicates = TRUE),\n algorithm = \"LightRF\",\n hyperparameters = setup_LightRF(),\n tuner_config = setup_GridSearch(),\n outer_resampling_config = setup_Resampler(),\n execution_config = setup_ExecutionConfig(),\n question = \"Can we tell iris species apart given their measurements?\",\n outdir = \"models/\",\n verbosity = 1L\n )\n mod <- train(x)\n expect_s7_class(mod, SupervisedRes)\n})\n\n\n# %% Test to_toml.SuperConfig ----\ntest_that(\"SuperConfig can be written to TOML\", {\n x <- setup_SuperConfig(\n dat_training_path = \"~/Data/iris.csv\",\n dat_validation_path = NULL,\n dat_test_path = NULL,\n weights = NULL,\n preprocessor_config = setup_Preprocessor(remove_duplicates = TRUE),\n algorithm = \"LightRF\",\n hyperparameters = setup_LightRF(),\n tuner_config = setup_GridSearch(),\n outer_resampling_config = setup_Resampler(),\n execution_config = setup_ExecutionConfig(),\n question = \"Can we tell iris species apart given their measurements?\",\n outdir = \"models/\",\n verbosity = 1L\n )\n toml_str <- to_toml(x)\n expect_type(toml_str, \"character\")\n})\n\n\n# %% write_toml.SuperConfig & read_config ----\ntest_that(\"SuperConfig can be written to TOML\", {\n x <- setup_SuperConfig(\n dat_training_path = \"~/Data/iris.csv\",\n dat_validation_path = NULL,\n dat_test_path = NULL,\n weights = NULL,\n preprocessor_config = setup_Preprocessor(remove_duplicates = TRUE),\n algorithm = \"LightRF\",\n hyperparameters = setup_LightRF(),\n tuner_config = setup_GridSearch(),\n outer_resampling_config = setup_Resampler(),\n execution_config = setup_ExecutionConfig(),\n question = \"Can we tell iris species apart given their measurements?\",\n outdir = \"models/\",\n verbosity = 1L\n )\n tmpdir <- tempdir()\n write_toml(x, file.path(tmpdir, \"rtemis.toml\"), overwrite = TRUE)\n testthat::expect_true(file.exists(file.path(tmpdir, \"rtemis.toml\")))\n xtoo <- read_config(file.path(tmpdir, \"rtemis.toml\"))\n expect_s7_class(xtoo, SuperConfig)\n})\n\n\n# %% Test to_yaml.SuperConfig ----\ntest_that(\"SuperConfig can be written to YAML\", {\n x <- setup_SuperConfig(\n dat_training_path = \"~/Data/iris.csv\",\n dat_validation_path = NULL,\n dat_test_path = NULL,\n weights = NULL,\n preprocessor_config = setup_Preprocessor(remove_duplicates = TRUE),\n algorithm = \"LightRF\",\n hyperparameters = setup_LightRF(),\n tuner_config = setup_GridSearch(),\n outer_resampling_config = setup_Resampler(),\n execution_config = setup_ExecutionConfig(),\n question = \"Can we tell iris species apart given their measurements?\",\n outdir = \"models/\",\n verbosity = 1L\n )\n yaml_str <- to_yaml(x)\n expect_type(yaml_str, \"character\")\n})\n" }, { "path": "tests/testthat/test_SuperConfigLive.R", "content": "# test_SuperConfigLive.R\n# ::rtemis::\n# 2026- EDG rtemis.org\n#\n# Tests for `SuperConfigLive` and its `train()` dispatch arm. The wire-\n# level integration (rtemislive train handler → SuperConfigLive) is\n# covered in test_rtemislive_dispatch_data_jobs.R / test_rtemislive_serial.R.\n\nlibrary(data.table)\n\n# Helpers --------------------------------------------------------------------\n\nsmall_regression_dt <- function(seed = 2030L, n = 60L) {\n set.seed(seed)\n dt <- data.table(\n a = rnorm(n),\n b = rnorm(n),\n c = rnorm(n),\n y = NA_real_\n )\n dt[, y := a + 0.5 * b + rnorm(n)]\n dt\n}\n\n\n# Constructor / props -------------------------------------------------------\n\ntest_that(\"setup_SuperConfigLive returns a SuperConfigLive with expected props\", {\n dt <- small_regression_dt()\n cfg <- setup_SuperConfigLive(\n dat_training = dt,\n algorithm = \"glm\"\n )\n expect_true(S7_inherits(cfg, SuperConfigLive))\n expect_identical(cfg@dat_training, dt)\n expect_null(cfg@dat_validation)\n expect_null(cfg@dat_test)\n expect_equal(cfg@algorithm, \"glm\")\n expect_null(cfg@outdir)\n})\n\ntest_that(\"setup_SuperConfigLive enforces tabular type on dat_training\", {\n expect_error(\n setup_SuperConfigLive(dat_training = \"not a data frame\"),\n regexp = \"(class_tabular|tabular|data.frame|data.table)\"\n )\n})\n\ntest_that(\"setup_SuperConfigLive accepts a data.frame (not just data.table)\", {\n df <- data.frame(x = 1:5, y = rnorm(5))\n cfg <- setup_SuperConfigLive(dat_training = df, algorithm = \"glm\")\n expect_s3_class(cfg@dat_training, \"data.frame\")\n})\n\n\n# train() SuperConfigLive dispatch ------------------------------------------\n\ntest_that(\"train(SuperConfigLive) runs end-to-end for a simple GLM regression\", {\n dt <- small_regression_dt(seed = 2031L)\n cfg <- setup_SuperConfigLive(\n dat_training = dt,\n algorithm = \"glm\",\n verbosity = 0L\n )\n mod <- train(cfg)\n expect_true(S7_inherits(mod, Supervised))\n expect_equal(mod@algorithm, \"GLM\")\n expect_length(mod@predicted_training, nrow(dt))\n})\n\ntest_that(\"train(SuperConfigLive) accepts an in-memory validation split\", {\n dt <- small_regression_dt(seed = 2032L)\n val <- small_regression_dt(seed = 2033L, n = 20L)\n cfg <- setup_SuperConfigLive(\n dat_training = dt,\n dat_validation = val,\n algorithm = \"glm\",\n verbosity = 0L\n )\n mod <- train(cfg)\n expect_true(S7_inherits(mod, Supervised))\n expect_length(mod@predicted_validation, nrow(val))\n})\n" }, { "path": "tests/testthat/test_Supervised.R", "content": "# test_Supervised.R\n# ::rtemis::\n# EDG rtemis.org\n\n# Key\n# {Algorithm}[method] Further conditions\n\n# Note\n# We are using very small and simple datasets to reduce runtime.\n# GLM models are expected to give warnings, including:\n# - \"glm.fit: fitted probabilities numerically 0 or 1 occurred\"\n# - \"glm.fit: algorithm did not converge\"\n\n# %% Packages ----\nlibrary(data.table)\n\n# Data ----\n## Regression Data ----\nn <- 400\nx <- rnormmat(n, 5, seed = 2025)\ng <- factor(sample(c(\"A\", \"B\"), n, replace = TRUE))\ny <- x[, 3] + x[, 5] + ifelse(g == \"A\", 2, -1) + rnorm(n)\ndatr <- data.table(x, g, y)\nresr <- resample(datr)\ndatr_train <- datr[resr$Fold_1, ]\ndatr_test <- datr[-resr$Fold_1, ]\n\n## Classification Data ----\n### Binary ----\ndatc2 <- data.frame(\n gn = factor(sample(c(\"alpha\", \"beta\", \"gamma\"), 100, replace = TRUE)),\n iris[51:150, ]\n)\ndatc2$Species <- factor(datc2$Species)\nresc2 <- resample(datc2)\ndatc2_train <- datc2[resc2$Fold_1, ]\ndatc2_test <- datc2[-resc2$Fold_1, ]\n\n### 3-class ----\ndatc3 <- iris\nresc3 <- resample(datc3)\ndatc3_train <- datc3[resc3$Fold_1, ]\ndatc3_test <- datc3[-resc3$Fold_1, ]\n\n### Synthetic binary data where positive class is 10% of the data ----\n# set.seed(2025)\n# n <- 500\n# datc2 <- data.frame(\n# x1 = rnorm(n),\n# x2 = rnorm(n),\n# x3 = rnorm(n),\n# g = factor(sample(c(\"A\", \"B\"), n, replace = TRUE, prob = c(.1, .9)))\n# )\n# Binary outcome dependent on x2 and g, with levels \"neg\" and \"pos\", where \"pos\" is 10% of the data\n# datc2$y <- factor(ifelse(datc2$x2 > 0 & datc2$g == \"A\", \"pos\", \"neg\"))\n# resc2 <- resample(datc2)\n# datc2_train <- datc2[resc2$Fold_1, ]\n# datc2_test <- datc2[-resc2$Fold_1, ]\n\n# Utils ----\ntest_that(\"class_imbalance() works\", {\n expect_type(class_imbalance(outcome(datc2)), \"double\")\n})\n\n# --- GLM ------------------------------------------------------------------------------------------\n## {GLM}[train] ----\nmod_r_glm <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"glm\"\n)\ntest_that(\"train() GLM Regression succeeds\", {\n expect_s7_class(mod_r_glm, Regression)\n})\ntest_that(\"train() GLM standard errors are available\", {\n expect_type(mod_r_glm@se_training, \"double\")\n expect_type(mod_r_glm@se_test, \"double\")\n})\n\n## {GLM}[train] Throw error with missing data ----\ndatr_train_na <- datr_train\ndatr_train_na[10:2, 1] <- NA\ntest_that(\"train() GLM Regression with missing data throws error\", {\n expect_error(\n train(x = datr_train_na, dat_test = datr_test, algorithm = \"glm\")\n )\n})\n\n## {GLM}[predict] ----\npredicted <- predict(mod_r_glm, features(datr_test))\ntest_that(\"predict() GLM Regression succeeds\", {\n expect_identical(mod_r_glm@predicted_test, predicted)\n expect_null(dim(predicted))\n})\n\n## {GLM}[train] ----\nresmod_r_glm <- train(\n x = datr,\n algorithm = \"glm\",\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\")\n)\ntest_that(\"train() Res GLM Regression succeeds\", {\n expect_s7_class(resmod_r_glm, RegressionRes)\n})\n\n## {GLM}[train] ----\nmod_c_glm <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"glm\"\n)\ntest_that(\"train() GLM Classification succeeds\", {\n expect_s7_class(mod_c_glm, Classification)\n})\n\n## {GLM}[train] IFW ----\nmod_c_glm_ifw <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"glm\",\n hyperparameters = setup_GLM(ifw = TRUE)\n)\ntest_that(\"train() GLM Classification with IFW succeeds\", {\n expect_s7_class(mod_c_glm_ifw, Classification)\n})\n\n## {GLM}[train] ----\nresmod_c_glm <- train(\n x = datc2,\n algorithm = \"glm\",\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\")\n)\ntest_that(\"train() GLM ClassificationRes succeeds\", {\n expect_s7_class(resmod_c_glm, ClassificationRes)\n})\n\n# --- GLMNET ---------------------------------------------------------------------------------------\n\n## {GLMNET}[train] ----\nmod_r_glmnet <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"glmnet\",\n hyperparameters = setup_GLMNET(lambda = 0.01)\n)\ntest_that(\"train() GLMNET Regression with fixed lambda succeeds\", {\n expect_s7_class(mod_r_glmnet, Regression)\n})\n\n## {GLMNET}[predict] ----\npredicted <- predict(mod_r_glmnet, features(datr_test))\ntest_that(\"predict() GLMNET Regression succeeds\", {\n expect_identical(mod_r_glmnet@predicted_test, predicted)\n expect_null(dim(predicted))\n})\n\n## {GLMNET}[train] auto-lambda grid search using future ----\ntest_that(\n paste(\n \"train > tune_GridSearch resets future plan after execution\",\n \"train() GLMNET Regression with auto-lambda grid search using future succeeds\"\n ),\n {\n # for local testing only, can't assume multisession or multicore are available\n skip_if_not_installed(\"futurize\")\n # Simulate user has set plan to multisession with 2 workers\n # with(future::plan(\"multisession\", workers = 2L), local = TRUE)\n # Simulate user has set plan to sequential\n with(future::plan(\"sequential\"), local = TRUE)\n # Run train with multicore and 4 workers\n modt_r_glmnet <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"glmnet\",\n hyperparameters = setup_GLMNET(alpha = 1),\n execution_config = setup_ExecutionConfig(\n backend = \"future\",\n n_workers = 2L, # Limit to 2 workers for CRAN\n future_plan = \"mirai_multisession\" # which gets converted to \"future.mirai::mirai_multisession\"\n ),\n verbosity = 2L\n )\n # Check that model trained correctly\n expect_s7_class(modt_r_glmnet, Regression)\n # Check that future plan has been reset to \"multisession\" with 2 workers\n # expect_equal(rtemis:::identify_plan(), \"multisession\")\n # Check that future plan has been reset to \"sequential\"\n expect_equal(rtemis:::identify_plan(), \"sequential\")\n expect_equal(future::nbrOfWorkers(), 1L)\n }\n)\n\n\n## {GLMNET}[train] /\\Error sequential with >1 worker ----\ntest_that(\"sequential with >1 worker throws error\", {\n skip_if_not_installed(\"futurize\")\n expect_error(\n modt_r_glmnet <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"glmnet\",\n hyperparameters = setup_GLMNET(alpha = 1),\n execution_config = setup_ExecutionConfig(\n backend = \"future\",\n future_plan = \"sequential\",\n n_workers = 2L\n )\n )\n )\n})\n\n## {GLMNET}[train] auto-lambda grid search using mirai ----\ntest_that(\"train() GLMNET Regression with auto-lambda grid search using mirai succeeds\", {\n skip_if_not_installed(\"mirai\")\n modt_r_glmnet <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"glmnet\",\n hyperparameters = setup_GLMNET(alpha = 1),\n execution_config = setup_ExecutionConfig(backend = \"mirai\", n_workers = 2L)\n )\n expect_s7_class(modt_r_glmnet, Regression)\n})\n\n## {GLMNET}[train] auto-lambda + alpha grid search ----\ntest_that(\"train() GLMNET Regression with auto-lambda + alpha grid search succeeds\", {\n modt_r_glmnet <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"glmnet\",\n hyperparameters = setup_GLMNET(alpha = c(0, 1)),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n )\n expect_s7_class(modt_r_glmnet, Regression)\n})\n\n## {GLMNET}[train] auto-lambda + alpha grid search ----\ntest_that(\"train() Res-GLMNET Regression with auto-lambda + alpha grid search succeeds\", {\n resmodt_r_glmnet <- train(\n x = datr_train,\n algorithm = \"glmnet\",\n hyperparameters = setup_GLMNET(alpha = c(0.5, 1)),\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n )\n expect_s7_class(resmodt_r_glmnet, RegressionRes)\n})\n\n## {GLMNET}[train] ----\nmodt_c_glmnet <- train(\n x = datc2_train,\n dat_test = datc2_test,\n hyperparameters = setup_GLMNET(alpha = 1, lambda = 0.01)\n)\ntest_that(\"train() GLMNET Classification succeeds\", {\n expect_s7_class(modt_c_glmnet, Classification)\n})\n\n## {GLMNET}[train] Multiclass ----\ntest_that(\"train() GLMNET Multiclass Classification succeeds\", {\n modt_c3_glmnet <- train(\n x = datc3_train,\n dat_test = datc3_test,\n hyperparameters = setup_GLMNET(alpha = 1),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n )\n expect_s7_class(modt_c3_glmnet, Classification)\n})\n\n# --- GAM ------------------------------------------------------------------------------------------\n## {GAM}[train] spline & parametric ----\nmod_r_gam <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"gam\"\n)\ntest_that(\"train() GAM Regression with spline + parametric terms succeeds.\", {\n expect_s7_class(mod_r_gam, Regression)\n})\n\n## {GAM}[train] spline only ----\nmod_r_gam <- train(\n x = datr_train[, -6],\n dat_test = datr_test[, -6],\n algorithm = \"gam\"\n)\ntest_that(\"train() GAM Regression with only spline terms succeeds.\", {\n expect_s7_class(mod_r_gam, Regression)\n})\n\n## {GAM}[train] parametric only ----\nmod_r_gam <- train(\n x = datr_train[, 6:7],\n dat_test = datr_test[, 6:7],\n algorithm = \"gam\"\n)\ntest_that(\"train() GAM Regression with only parametric terms succeeds.\", {\n expect_s7_class(mod_r_gam, Regression)\n})\n\n## {GAM}[train] grid search ----\nmodt_r_gam <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"gam\",\n hyperparameters = setup_GAM(k = c(3, 5, 7))\n)\ntest_that(\"train() GAM Regression with grid_search() succeeds\", {\n expect_s7_class(modt_r_gam, Regression)\n})\n\n## {GAM}[predict] ----\ntest_that(\"predict() GAM Regression works\", {\n expect_error(predicted <- predict(modt_r_gam, datr_test))\n predicted <- predict(modt_r_gam, features(datr_test))\n expect_identical(modt_r_gam@predicted_test, predicted)\n})\n\n## {GAM}[train] ----\nresmod_r_gam <- train(\n x = datr,\n algorithm = \"gam\",\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\")\n)\n\n## {GAM}[train] ----\nmod_c_gam <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"gam\"\n)\ntest_that(\"train() GAM Classification succeeds\", {\n expect_s7_class(mod_c_gam, Classification)\n})\n\n## {GAM}[train] IFW ----\nmod_c_gam_ifw <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"gam\",\n hyperparameters = setup_GAM(ifw = TRUE)\n)\ntest_that(\"train() GAM Classification with IFW succeeds\", {\n expect_s7_class(mod_c_gam_ifw, Classification)\n})\n\n# --- LinearSVM ------------------------------------------------------------------------------------\n## {LinearSVM}[train] ----\nmod_r_svml <- train(\n x = datr_train,\n dat_test = datr_test,\n hyperparameters = setup_LinearSVM()\n)\ntest_that(\"train() LinearSVM Regression succeeds\", {\n expect_s7_class(mod_r_svml, Regression)\n})\n\n## {LinearSVM}[train] Tuned ----\nmodt_r_svml <- train(\n x = datr_train,\n dat_test = datr_test,\n hyperparameters = setup_LinearSVM(cost = c(1, 10)),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() LinearSVM Regression with tuning succeeds\", {\n expect_s7_class(modt_r_svml, Regression)\n})\n\n## {LinearSVM}[train] ----\nresmod_r_svml <- train(\n x = datr,\n algorithm = \"linearsvm\",\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\")\n)\ntest_that(\"train() Res LinearSVM Regression succeeds\", {\n expect_s7_class(resmod_r_svml, RegressionRes)\n})\n\n## {LinearSVM}[train] ----\nmod_c_linearsvm <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"linearsvm\"\n)\ntest_that(\"train() LinearSVM Classification succeeds\", {\n expect_s7_class(mod_c_linearsvm, Classification)\n})\n\n## {LinearSVM}[train] Multiclass ----\nmod_c3_linearsvm <- train(\n x = datc3_train,\n dat_test = datc3_test,\n algorithm = \"linearsvm\"\n)\ntest_that(\"train() LinearSVM Multiclass Classification succeeds\", {\n expect_s7_class(mod_c3_linearsvm, Classification)\n})\n\n## {LinearSVM}[train] ----\nresmod_c_linearsvm <- train(\n x = datc2,\n algorithm = \"linearsvm\",\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Res LinearSVM Classification succeeds\", {\n expect_s7_class(resmod_c_linearsvm, ClassificationRes)\n})\n\n# --- RadialSVM ------------------------------------------------------------------------------------\n## {RadialSVM}[train] ----\nmod_r_svmr <- train(\n x = datr_train,\n dat_test = datr_test,\n hyperparameters = setup_RadialSVM()\n)\ntest_that(\"train() RadialSVM Regression succeeds\", {\n expect_s7_class(mod_r_svmr, Regression)\n})\n\n## {RadialSVM}[train] Tuned ----\nmodt_r_svmr <- train(\n x = datr_train,\n dat_test = datr_test,\n hyperparameters = setup_RadialSVM(cost = c(1, 10, 100))\n)\ntest_that(\"train() RadialSVM Regression with tuning succeeds\", {\n expect_s7_class(modt_r_svmr, Regression)\n})\n\n## {RadialSVM}[train] ----\nresmod_r_svmr <- train(\n x = datr,\n algorithm = \"radialsvm\",\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Res RadialSVM Regression succeeds\", {\n expect_s7_class(resmod_r_svmr, RegressionRes)\n})\n\n## {RadialSVM}[train] Tuned ----\nresmodt_r_svmr <- train(\n x = datr,\n hyperparameters = setup_RadialSVM(cost = c(1, 10)),\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Res RadialSVM Regression with tuning succeeds\", {\n expect_s7_class(resmodt_r_svmr, RegressionRes)\n})\n\n## {RadialSVM}[train] ----\nmod_c_radialsvm <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"radialsvm\"\n)\ntest_that(\"train() RadialSVM Classification succeeds\", {\n expect_s7_class(mod_c_radialsvm, Classification)\n})\n\n## {RadialSVM}[train] Tuned ----\nmodt_c_radialsvm <- train(\n x = datc2_train,\n dat_test = datc2_test,\n hyperparameters = setup_RadialSVM(cost = c(1, 10)),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() RadialSVM Classification with tuning succeeds\", {\n expect_s7_class(modt_c_radialsvm, Classification)\n})\n\n## {RadialSVM}[train] ----\nresmod_c_radialsvm <- train(\n x = datc2,\n algorithm = \"radialsvm\",\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Res RadialSVM Classification succeeds\", {\n expect_s7_class(resmod_c_radialsvm, ClassificationRes)\n})\n\n## {RadialSVM}[train] Tuned ----\nresmodt_c_radialsvm <- train(\n x = datc2,\n hyperparameters = setup_RadialSVM(cost = c(1, 10)),\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Res RadialSVM Classification with tuning succeeds\", {\n expect_s7_class(resmodt_c_radialsvm, ClassificationRes)\n})\n\n## {RadialSVM}[train] Multiclass ----\nmodt_c3_radialsvm <- train(\n x = datc3_train,\n dat_test = datc3_test,\n hyperparameters = setup_RadialSVM()\n)\ntest_that(\"train() RadialSVM Multiclass Classification succeeds\", {\n expect_s7_class(modt_c3_radialsvm, Classification)\n})\n\n# --- CART -----------------------------------------------------------------------------------------\n## {CART}[train] ----\nmod_r_cart <- train(\n datr_train,\n dat_test = datr_test,\n algorithm = \"cart\"\n)\ntest_that(\"train() Regression succeeds\", {\n expect_s7_class(mod_r_cart, Regression)\n})\n\n## {CART}[train] Grid search ----\n## {CART} Check tuned == 0----\nhyperparameters <- setup_CART(\n maxdepth = c(1, 2, 10),\n minbucket = c(1L, 4L)\n)\ntest_that(\"tuned field is set correctly\", {\n expect_identical(hyperparameters@tuned, 0L)\n})\n\nmodt_r_cart <- train(\n datr_train,\n dat_test = datr_test,\n hyperparameters = setup_CART(maxdepth = 2:3),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Regression with grid_search() succeeds\", {\n expect_s7_class(modt_r_cart, Regression)\n})\n\n## {CART} Check tuned == 1----\ntest_that(\"tuned is set correctly\", {\n expect_identical(modt_r_cart@hyperparameters@tuned, 1L)\n})\n\n## {CART}[train] ----\nresmod_r_cart <- train(\n x = datr,\n hyperparameters = setup_CART(),\n outer_resampling_config = setup_Resampler(3L),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() RegressionRes succeeds\", {\n expect_s7_class(resmod_r_cart, RegressionRes)\n})\n\n## {CART}[train] Tuned ----\nresmodt_r_cart <- train(\n x = datr,\n hyperparameters = setup_CART(maxdepth = 1:2, prune_cp = c(.001, .01)),\n outer_resampling_config = setup_Resampler(3),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() RegressionRes succeeds\", {\n expect_s7_class(resmodt_r_cart, RegressionRes)\n})\n\n## {CART}[train] prune_cp ----\nresmod_r_cart <- train(\n x = datr,\n hyperparameters = setup_CART(prune_cp = c(.001, .01)),\n outer_resampling_config = setup_Resampler(3L),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() RegressionRes succeeds\", {\n expect_s7_class(resmod_r_cart, RegressionRes)\n})\n\n## {CART}[train] ----\n# model <- train_CART(dat_training = datc2_train, dat_test = datc2_test)\n# model$method #\"class\"\nmodt_c_cart <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"cart\",\n hyperparameters = setup_CART(maxdepth = 1:2)\n)\ntest_that(\"train() CART Classification succeeds\", {\n expect_s7_class(modt_c_cart, Classification)\n})\n\n## {CART}[train] IFW ----\nmod_c_cart_ifw <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"cart\",\n hyperparameters = setup_CART(\n ifw = TRUE\n )\n)\ntest_that(\"train() CART Classification with IFW succeeds\", {\n expect_s7_class(mod_c_cart_ifw, Classification)\n})\n\n## {CART}[train] Grid search ----\nmodt_c_cart_tuned <- train(\n x = datc2_train,\n dat_test = datc2_test,\n hyperparameters = setup_CART(\n maxdepth = c(1L, 2L)\n ),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Classification with grid_search() succeeds\", {\n expect_s7_class(modt_c_cart_tuned, Classification)\n})\n\n## {CART}[train] ----\n# Can be used to test different parallelization methods during tuning\nresmodt_c_cart <- train(\n x = datc2,\n algorithm = \"cart\",\n hyperparameters = setup_CART(\n maxdepth = c(1L, 2L)\n ),\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() CART ClassificationRes succeeds\", {\n expect_s7_class(resmodt_c_cart, ClassificationRes)\n})\n\n## {CART}[train] Multiclass ----\nmodt_c3_cart <- train(\n x = datc3_train,\n dat_test = datc3_test,\n algorithm = \"cart\"\n)\ntest_that(\"train() CART Multiclass Classification succeeds\", {\n expect_s7_class(modt_c3_cart, Classification)\n})\n\n# --- LightCART ------------------------------------------------------------------------------------\n## {LightCART}[train] ----\nmod_r_lightcart <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"lightcart\"\n)\ntest_that(\"train() LightCART Regression succeeds\", {\n expect_s7_class(mod_r_lightcart, Regression)\n})\n\nmod_r_lightcartlin <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"lightcart\",\n hyperparameters = setup_LightCART(\n linear_tree = TRUE\n )\n)\ntest_that(\"train() LightCART Regression with linear_tree succeeds\", {\n expect_s7_class(mod_r_lightcartlin, Regression)\n expect_identical(\n mod_r_lightcartlin@hyperparameters$linear_tree,\n mod_r_lightcartlin@model$params$linear_tree\n )\n})\n\n## {LightCART}[train] ----\nmod_c_lightcart <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"lightcart\"\n)\ntest_that(\"train() LightCART Classification succeeds\", {\n expect_s7_class(mod_c_lightcart, Classification)\n})\n\n## {LightCART}[train] Multiclass ----\nmodt_c3_lightcart <- train(\n x = datc3_train,\n dat_test = datc3_test,\n algorithm = \"lightcart\"\n)\ntest_that(\"train() LightCART Multiclass Classification succeeds\", {\n expect_s7_class(modt_c3_lightcart, Classification)\n})\n\n# --- LightRF --------------------------------------------------------------------------------------\n## {LightRF}[train] ----\nmod_r_lightrf <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"lightrf\",\n hyperparameters = setup_LightRF(\n nrounds = 20L,\n lambda_l1 = .1,\n lambda_l2 = .1\n )\n)\ntest_that(\"train() LightRF Regression with l1, l2 succeeds\", {\n expect_s7_class(mod_r_lightrf, Regression)\n})\n\n## {LightRF}[predict] ----\npredicted <- predict(mod_r_lightrf, features(datr_test))\ntest_that(\"predict() LightRF Regression succeeds\", {\n expect_identical(mod_r_lightrf@predicted_test, predicted)\n expect_null(dim(predicted))\n})\n\n## {LightRF}[train] Grid search ----\nmodt_r_lightrf <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"lightrf\",\n hyperparameters = setup_LightRF(\n nrounds = 20L,\n lambda_l1 = c(0, .1)\n ),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() LightRF Regression with l1 tuning succeeds\", {\n expect_s7_class(modt_r_lightrf, Regression)\n})\n\n## {LightRF}[train] ----\nresmodt_r_lightrf <- train(\n x = datr,\n algorithm = \"lightrf\",\n hyperparameters = setup_LightRF(\n nrounds = 20L,\n lambda_l1 = c(0, 10)\n ),\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Res LightRF Regression with l1 tuning succeeds\", {\n expect_s7_class(resmodt_r_lightrf, RegressionRes)\n})\n\n## {LightRF}[train] ----\nmod_c_lightrf <- train(\n x = datc2_train,\n dat_test = datc2_test,\n hyperparameters = setup_LightRF(nrounds = 20L)\n)\ntest_that(\"train() LightRF Binary Classification succeeds\", {\n expect_s7_class(mod_c_lightrf, Classification)\n})\n\n## {LightRF}[predict] ----\npredicted_prob_test <- predict(mod_c_lightrf, features(datc2_test))\ntest_that(\"predict() LightRF Classification succeeds\", {\n expect_identical(mod_c_lightrf@predicted_prob_test, predicted_prob_test)\n})\n\n## {LightRF}[train] Tuned ----\nmodt_c_lightrf <- train(\n x = datc2_train,\n dat_test = datc2_test,\n hyperparameters = setup_LightRF(nrounds = 20L, max_depth = c(-1, 5))\n)\ntest_that(\"train() LightRF Binary Classification with tuning succeeds\", {\n expect_s7_class(modt_c_lightrf, Classification)\n})\n\n## {LightRF}[train] ----\nresmod_c_lightrf <- train(\n x = datc2,\n hyperparameters = setup_LightRF(nrounds = 20L),\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() LightRF ClassificationRes succeeds\", {\n expect_s7_class(resmod_c_lightrf, ClassificationRes)\n})\n\n## {LightRF}[train] Multiclass ----\nmodt_c3_lightrf <- train(\n x = datc3_train,\n dat_test = datc3_test,\n hyperparameters = setup_LightRF(nrounds = 20L)\n)\ntest_that(\"train() LightRF Multiclass Classification succeeds\", {\n expect_s7_class(modt_c3_lightrf, Classification)\n})\n\n## {LightGBM}[train] ----\nmod_r_lightgbm <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"lightgbm\",\n hyperparameters = setup_LightGBM(\n force_nrounds = 50\n )\n)\ntest_that(\"train() LightGBM Regression succeeds\", {\n expect_s7_class(mod_r_lightgbm, Regression)\n})\n\n## {LightGBM}[train] Autotune nrounds ----\nmodt_r_lightgbm <- train(\n x = datr_train,\n dat_test = datr_test,\n hyperparameters = setup_LightGBM()\n)\ntest_that(\"train() LightGBM Regression with autotune nrounds succeeds\", {\n expect_s7_class(modt_r_lightgbm, Regression)\n})\n\n## {LightGBM}[train] Autotune nrounds ----\nresmodt_r_lightgbm <- train(\n x = datr_train,\n hyperparameters = setup_LightGBM(max_nrounds = 50L),\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Res LightGBM Regression with autotune nrounds succeeds\", {\n expect_s7_class(resmodt_r_lightgbm, RegressionRes)\n})\n\n## {LightGBM}[train] ----\nmod_c_lightgbm <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"lightgbm\",\n # hyperparameters = setup_LightGBM(\n # force_nrounds = 100L\n # ),\n tuner_config = setup_GridSearch(\n resampler_config = setup_Resampler(\n n_resamples = 3L,\n type = \"KFold\"\n )\n ),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() LightGBM Classification succeeds\", {\n expect_s7_class(mod_c_lightgbm, Classification)\n})\n\n## {LightGBM}[train] Multiclass ----\nmodt_c3_lightgbm <- train(\n x = datc3_train,\n dat_test = datc3_test,\n hyperparameters = setup_LightGBM(\n force_nrounds = 20L\n )\n)\ntest_that(\"train() LightGBM Multiclass Classification succeeds\", {\n expect_s7_class(modt_c3_lightgbm, Classification)\n})\n\n## {LightRuleFit}[train] ----\nmod_r_lightrlft_l1l2 <- train(\n x = datr_train,\n dat_test = datr_test,\n hyperparameters = setup_LightRuleFit(\n nrounds = 50L,\n lambda_l1 = 10,\n lambda_l2 = 10,\n lambda = 0.01\n )\n)\n\ntest_that(\"train() LightRuleFit Regression with l1, l2 params passed\", {\n expect_s7_class(mod_r_lightrlft_l1l2, Regression)\n expect_identical(\n mod_r_lightrlft_l1l2@model@model_lightgbm@model$params$lambda_l1,\n 10\n )\n expect_identical(\n mod_r_lightrlft_l1l2@model@model_lightgbm@model$params$lambda_l2,\n 10\n )\n})\n\n## {LightRuleFit}[train] ----\nmod_c_lightrlft <- train(\n x = datc2_train,\n dat_test = datc2_test,\n hyperparameters = setup_LightRuleFit(nrounds = 50L),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() LightRuleFit Binary Classification succeeds\", {\n expect_s7_class(mod_c_lightrlft, Classification)\n})\n\n## {TabNet}[train] ----\n# Test if lantern is installed\nif (torch::torch_is_installed()) {\n mod_r_tabnet <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"tabnet\",\n hyperparameters = setup_TabNet(epochs = 3L, learn_rate = .01)\n )\n test_that(\"train() TabNet Regression succeeds\", {\n expect_s7_class(mod_r_tabnet, Regression)\n })\n}\n\n## {TabNet}[train] ----\nif (torch::torch_is_installed()) {\n mod_c_tabnet <- train(\n x = datc2_train,\n dat_test = datc2_test,\n hyperparameters = setup_TabNet(epochs = 3L, learn_rate = .01)\n )\n test_that(\"train() TabNet Classification succeeds\", {\n expect_s7_class(mod_c_tabnet, Classification)\n })\n}\n\n## {TabNet}[train] Multiclass ----\nif (torch::torch_is_installed()) {\n modt_c3_tabnet <- train(\n x = datc3_train,\n dat_test = datc3_test,\n hyperparameters = setup_TabNet(epochs = 3L, learn_rate = .01)\n )\n test_that(\"train() TabNet Multiclass Classification succeeds\", {\n expect_s7_class(modt_c3_tabnet, Classification)\n })\n}\n\n## {Isotonic}[train] ----\nx <- rnorm(50)\ny <- x^5 + rnorm(50)\ndat <- data.table(x, y)\nmod_iso <- train(dat, algorithm = \"Isotonic\")\ntest_that(\"train() Isotonic Regression succeeds\", {\n expect_s7_class(mod_iso, Regression)\n})\n\n## {Isotonic}[train] ----\nset.seed(2025)\nx <- rnorm(200)\ny <- factor(ifelse(x > mean(x), \"b\", \"a\"))\nx <- x + rnorm(200) / 3\ndat <- data.frame(x, y)\ncmod_iso <- train(dat, algorithm = \"Isotonic\")\ntest_that(\"train() Isotonic Classification succeeds\", {\n expect_s7_class(cmod_iso, Classification)\n})\n\n# --- Ranger ---------------------------------------------------------------------------------------\n## {Ranger}[train] ----\nmod_r_ranger <- train(\n x = datr_train,\n dat_test = datr_test,\n hyperparameters = setup_Ranger(num_trees = 50L)\n)\ntest_that(\"train() Ranger Regression succeeds\", {\n expect_s7_class(mod_r_ranger, Regression)\n})\n\n## {Ranger}[train] Grid search ----\nmodt_r_ranger <- train(\n x = datr_train,\n dat_test = datr_test,\n hyperparameters = setup_Ranger(num_trees = 50L, mtry = c(3, 6)),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Ranger Regression with grid search succeeds\", {\n expect_s7_class(modt_r_ranger, Regression)\n})\n\n## {Ranger}[train] ----\nresmod_r_ranger <- train(\n x = datr,\n hyperparameters = setup_Ranger(num_trees = 5000L),\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\")\n)\ntest_that(\"train() Res Ranger Regression succeeds\", {\n expect_s7_class(resmod_r_ranger, RegressionRes)\n})\n\n## {Ranger}[train] ----\nmod_c_ranger <- train(\n x = datc2_train,\n dat_test = datc2_test,\n hyperparameters = setup_Ranger(num_trees = 10L)\n)\ntest_that(\"train() Ranger Classification succeeds\", {\n expect_s7_class(mod_c_ranger, Classification)\n})\n\n## {Ranger}[train] Grid search ----\nmodt_c_ranger <- train(\n x = datc2_train,\n dat_test = datc2_test,\n hyperparameters = setup_Ranger(num_trees = 10L, mtry = c(2, 4)),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Ranger Classification with grid search succeeds\", {\n expect_s7_class(modt_c_ranger, Classification)\n})\n\n## {Ranger}[train] ----\nresmod_c_ranger <- train(\n x = datc2,\n hyperparameters = setup_Ranger(num_trees = 10L),\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n execution_config = setup_ExecutionConfig(backend = \"none\")\n)\ntest_that(\"train() Res Ranger Classification succeeds\", {\n expect_s7_class(resmod_c_ranger, ClassificationRes)\n})\n\n## {Ranger}[train] Multiclass ----\nmodt_c3_ranger <- train(\n x = datc3_train,\n dat_test = datc3_test,\n hyperparameters = setup_Ranger(num_trees = 10L)\n)\ntest_that(\"train() Ranger Multiclass Classification succeeds\", {\n expect_s7_class(modt_c3_ranger, Classification)\n})\n\n# --- Predict SupervisedRes ------------------------------------------------------------------------\n\n## {CART}[predict] ----\npredicted_mean <- predict(resmod_r_cart, newdata = features(datr_test))\ntest_that(\"predict() SupervisedRes succeeds\", {\n expect_true(length(predicted_mean) == nrow(datr_test))\n})\n\n\n# --- Calibration ----------------------------------------------------------------------------------\n## {LightRF}[calibrate] ----\n# Calibrate mod_c_lightrf trained above\nmodel <- mod_c_lightrf\npredicted_probabilities <- model$predicted_prob_training\ntrue_labels <- model$y_training\nmod_c_lightrf_cal <- calibrate(\n mod_c_lightrf,\n predicted_probabilities = mod_c_lightrf$predicted_prob_training,\n true_labels = mod_c_lightrf$y_training\n)\ntest_that(\"calibrate() succeeds on Classification\", {\n expect_s7_class(mod_c_lightrf_cal, CalibratedClassification)\n})\n\n## {LightRF}[predict] ----\nnewdata <- features(datc2_test)\npredicted_prob_test_cal <- predict(mod_c_lightrf_cal, newdata = newdata)\ntest_that(\"predict() CalibratedClassification succeeds\", {\n expect_identical(\n mod_c_lightrf_cal@predicted_prob_test_calibrated,\n predicted_prob_test_cal\n )\n})\n\n# --- CalibratedClassificationRes ------------------------------------------------------------------\n## {LightRF}[calibrate]\nresmod_c_lightrf_cal <- calibrate(resmod_c_lightrf)\ntest_that(\"calibrate() succeeds on ClassificationRes\", {\n expect_s7_class(resmod_c_lightrf_cal, CalibratedClassificationRes)\n})\n\n## {GLM}[describe] ----\ntest_that(\"describe.Regression returns character\", {\n desc <- describe(mod_r_glm)\n expect_type(desc, \"character\")\n})\n\n## {GLM}[plot_true_pred] ----\ntest_that(\"plot_true_pred.Supervised creates a plotly object\", {\n p <- plot_true_pred(mod_r_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[plot_true_pred] ----\ntest_that(\"plot_true_pred creates a plotly object\", {\n p <- plot_true_pred(mod_r_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[present] ----\ntest_that(\"present.Supervised creates a plotly object\", {\n p <- present(mod_r_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[describe] ----\ntest_that(\"describe.Classification returns character\", {\n desc <- describe(mod_c_glm)\n expect_type(desc, \"character\")\n})\n\n## {GLM}[plot_true_pred] ----\ntest_that(\"plot_true_pred.Classification creates a plotly object\", {\n p <- plot_true_pred(mod_c_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[plot_true_pred] ----\ntest_that(\"plot_true_pred creates a plotly object\", {\n p <- plot_true_pred(mod_c_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[draw_roc] ----\ntest_that(\"draw_roc creates a plotly object\", {\n p <- draw_roc(\n true_labels = list(\n Training = mod_c_glm@y_training,\n Test = mod_c_glm@y_test\n ),\n predicted_prob = list(\n Training = mod_c_glm@predicted_prob_training,\n Test = mod_c_glm@predicted_prob_test\n )\n )\n expect_s3_class(p, \"plotly\")\n})\ntest_that(\"plot_roc.Classification creates a plotly object\", {\n p <- plot_roc(mod_c_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {CART}[plot_roc] Tuned ----\ntest_that(\"plot_roc.ClassificationRes creates a plotly object\", {\n p <- plot_roc(resmodt_c_cart)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[plot_metric] ----\ntest_that(\"plot_metric.SupervisedRes creates a plotly object\", {\n p <- plot_metric(resmod_r_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[plot_metric] ----\ntest_that(\"plot_metric.SupervisedRes creates a plotly object\", {\n p <- plot_metric(resmod_c_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[plot_true_pred] ----\ntest_that(\"plot_true_pred RegressionRes creates a plotly object\", {\n p <- plot_true_pred(resmod_r_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[plot_true_pred] ----\ntest_that(\"plot_true_pred ClassificationRes creates a plotly object\", {\n p <- plot_true_pred(resmod_c_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[present] ----\ntest_that(\"present.Supervised creates a plotly object\", {\n p <- present(mod_r_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[present] ----\ntest_that(\"present.Supervised creates a plotly object\", {\n p <- present(mod_c_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[present] ----\ntest_that(\"present() RegressionRes object creates a plotly object\", {\n p <- present(resmod_r_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[present] ----\ntest_that(\"present() ClassificationRes object creates a plotly object\", {\n p <- present(resmod_c_glm)\n expect_s3_class(p, \"plotly\")\n})\n\n## {Multi}[present] ----\ntest_that(\"present() multiple RegressionRes objects creates a plotly object\", {\n p <- present(list(resmod_r_glm, resmod_r_cart))\n expect_s3_class(p, \"plotly\")\n})\n\n## {Multi}[present] ----\ntest_that(\"present() multiple ClassificationRes objects creates a plotly object\", {\n p <- present(list(resmod_c_glm, resmodt_c_cart))\n expect_s3_class(p, \"plotly\")\n})\n\n## {Multi}[present] ----\ntest_that(\"present() multiple Regression objects creates a plotly object\", {\n p <- present(list(mod_r_glm, mod_r_cart))\n expect_s3_class(p, \"plotly\")\n})\n\n## {CART}[plot_varimp] ----\ntest_that(\"plot_varimp RegressionRes creates a plotly object\", {\n p <- plot_varimp(resmod_r_cart)\n expect_s3_class(p, \"plotly\")\n})\n\n## {GLM}[train] Outdir ----\ntest_that(\"train saves model to rds successfully\", {\n temp_dir <- withr::local_tempdir()\n outdir <- file.path(temp_dir, \"mod_r_glm\")\n\n mod_r_glm <- train(\n x = datr_train,\n dat_test = datr_test,\n algorithm = \"glm\",\n outdir = outdir\n )\n expect_true(file.exists(file.path(outdir, \"train_GLM.rds\")))\n})\n\n## {GLM}[train] Outdir ----\ntest_that(\"train saves SupervisedRes model to rds successfully\", {\n temp_dir <- withr::local_tempdir()\n outdir <- file.path(temp_dir, \"resmod_r_glm\")\n resmod_r_glm <- train(\n x = datr,\n algorithm = \"glm\",\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\"),\n outdir = outdir\n )\n expect_true(file.exists(file.path(outdir, \"train_GLM.rds\")))\n})\n\n## {CART}[repr] Tuned ----\nmodt_c_cart_repr <- repr(modt_c_cart, output_type = \"ansi\")\ntest_that(\"repr() Tuned Classification succeeds\", {\n expect_type(modt_c_cart_repr, \"character\")\n})\n\n## {CART}[repr] Tuned ----\nresmodt_c_cart_repr <- repr(resmodt_c_cart, output_type = \"ansi\")\ntest_that(\"repr() Tuned ClassificationRes succeeds\", {\n expect_type(resmodt_c_cart_repr, \"character\")\n})\n\n## {CART}[repr] Tuned ----\nmodt_r_cart_repr <- repr(modt_r_cart, output_type = \"ansi\")\ntest_that(\"repr() Tuned Regression succeeds\", {\n expect_type(modt_r_cart_repr, \"character\")\n})\n\n## {CART}[repr] Tuned ----\nresmodt_r_cart_repr <- repr(resmodt_r_cart, output_type = \"ansi\")\ntest_that(\"repr() Tuned RegressionRes succeeds\", {\n expect_type(resmodt_r_cart_repr, \"character\")\n})\n\n# --- Describe & present list of Supervised --------------------------------------------------------\n## {Multi}[describe] List ----\nx <- list(\n modt_c_cart,\n mod_c_lightrf,\n mod_c_lightgbm\n)\nout <- describe(x)\ntest_that(\"describe() list of Classification objects returns character\", {\n expect_type(out, \"character\")\n})\n\n## {Multi}[present] List ----\nplt <- present(x)\ntest_that(\"present() list of Classification objects returns plotly object\", {\n expect_s3_class(plt, \"plotly\")\n})\n\n## {Multi}[describe] List ----\nx <- list(\n mod_r_glmnet,\n mod_r_svmr,\n mod_r_lightrf\n)\nout <- describe(x)\ntest_that(\"describe() list of Regression objects returns character\", {\n expect_type(out, \"character\")\n})\n\n## {Multi}[present] List ----\nplt <- present(x)\ntest_that(\"present() list of Regression objects returns plotly object\", {\n expect_s3_class(plt, \"plotly\")\n})\n\n# Describe & present list of SupervisedRes----\n\n## {Multi}[describe] List ----\nx <- list(\n resmod_c_glm,\n resmod_c_linearsvm,\n resmod_c_lightrf\n)\nout <- describe(x)\ntest_that(\"describe() list of ClassificationRes objects returns character\", {\n expect_type(out, \"character\")\n})\n\n## {Multi}[present] List ----\nplt <- present(x)\ntest_that(\"present() list of ClassificationRes objects returns plotly object\", {\n expect_s3_class(plt, \"plotly\")\n})\n\n## {Multi}[describe] List ----\nx <- list(\n resmod_r_glm,\n resmod_r_svml,\n resmodt_r_lightrf\n)\nout <- describe(x)\ntest_that(\"describe() list of RegressionRes objects returns character\", {\n expect_type(out, \"character\")\n})\n\n## {Multi}[present] List ----\nplt <- present(x)\ntest_that(\"present() list of RegressionRes objects returns plotly object\", {\n expect_s3_class(plt, \"plotly\")\n})\n\n# --- CalibratedClassificationRes ------------------------------------------------------------------\n## {GLM}[calibrate] ----\n# Using resmod_c_glm from above\nresmod_c_glm_cal <- calibrate(resmod_c_glm)\ntest_that(\"calibrate() GLM ClassificationRes succeeds\", {\n expect_s7_class(resmod_c_glm_cal, CalibratedClassificationRes)\n})\n\n## {GLM}[predict] ----\ntest_that(\"predict() GLM CalibratedClassificationRes succeeds\", {\n predicted_cal <- predict(resmod_c_glm_cal, features(datc2_test))\n expect_type(predicted_cal, \"double\")\n expect_length(predicted_cal, nrow(datc2_test))\n})\n\n## {CART}[calibrate] ----\n# Using resmodt_c_cart from above\nresmodt_c_cart_cal <- calibrate(resmodt_c_cart)\ntest_that(\"calibrate() CART ClassificationRes succeeds\", {\n expect_s7_class(resmodt_c_cart_cal, CalibratedClassificationRes)\n})\n\n## {CART}[predict] ----\ntest_that(\"predict() CART CalibratedClassificationRes succeeds\", {\n predicted_cal <- predict(resmodt_c_cart_cal, features(datc2_test))\n expect_type(predicted_cal, \"double\")\n expect_length(predicted_cal, nrow(datc2_test))\n})\n\n\n# %% Test preprocessing in train() is applied to test data in predict() ----\n## {GLM}[train] Preprocessing ----\nmod_c_glm_pp <- train(\n x = datc2_train,\n dat_test = datc2_test,\n algorithm = \"glm\",\n preprocessor = setup_Preprocessor(\n scale = TRUE,\n center = TRUE\n )\n)\ntest_that(\"train() with preprocessor creates a model with the preprocessor\", {\n expect_s7_class(mod_c_glm_pp, Classification)\n expect_true(!is.null(mod_c_glm_pp@preprocessor))\n})\n" }, { "path": "tests/testthat/test_Theme.R", "content": "# test_Theme.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# Theme ----\ntest_that(\"Theme succeeds\", {\n expect_s7_class(Theme(), Theme)\n})\n\n# theme_black ----\ntest_that(\"theme_black succeeds\", {\n expect_s7_class(theme_black(), Theme)\n})\n\n# theme_blackgrid\ntest_that(\"theme_blackgrid succeeds\", {\n expect_s7_class(theme_blackgrid(), Theme)\n})\n\n# theme_light ----\ntest_that(\"theme_light succeeds\", {\n expect_s7_class(theme_white(), Theme)\n})\n\n# Test `$` and `[[` methods ----\ntheme <- theme_darkgraygrid()\ntest_that(\"Theme$ and Theme[[ succeed\", {\n expect_equal(theme[[\"fg\"]], \"#ffffff\")\n expect_equal(theme[[\"fg\"]], theme[[\"fg\"]])\n})\n" }, { "path": "tests/testthat/test_Tuner.R", "content": "# test_Tuner.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# Note: Tuning is tested in test_Supervised.R with `train()`\n\n# TunerConfig ----\ntn_pr <- setup_GridSearch()\ntn_pr\ndesc(tn_pr)\ntest_that(\"TunerConfig succeeds\", {\n expect_s7_class(TunerConfig(), TunerConfig)\n})\n\n# setup_GridSearch() ----\ntest_that(\"setup_GridSearch() succeeds\", {\n expect_s7_class(setup_GridSearch(), GridSearchConfig)\n})\n" }, { "path": "tests/testthat/test_checks.R", "content": "# test_checks.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# Test do_call ----\ntest_that(\"do_call() succeeds\", {\n expect_equal(do_call(sum, list(1, 2, 3)), 6)\n})\n" }, { "path": "tests/testthat/test_colorsystem.R", "content": "# test_colorsystem.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# show_col ----\nx <- list(\n highlight_col = highlight_col,\n col_object = col_object,\n col_outer = col_outer,\n col_tuner = col_tuner,\n col_info = col_info\n)\n\nout <- show_col(x, title = \"rtemis Color System\")\ntest_that(\"show_col() works\", {\n expect_true(is.character(out))\n})\n\n# fmt_gradient ----\nout <- fmt_gradient(\n \"Supervised\",\n colors = c(rtemis_teal, rtemis_light_teal),\n bold = TRUE\n)\ntest_that(\"fmt_gradient() works\", {\n expect_true(is.character(out))\n})\n" }, { "path": "tests/testthat/test_draw.R", "content": "# test_draw.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# draw_3Dscatter ----\ntest_that(\"draw_3Dscatter creates a plotly object and saves file\", {\n # Check whether plotly and kaleido are available in reticulate\n temp_dir <- withr::local_tempdir()\n if (\n !requireNamespace(\"reticulate\", quietly = TRUE) ||\n !reticulate::py_module_available(\"plotly\") ||\n !reticulate::py_module_available(\"kaleido\")\n ) {\n temp_file <- NULL\n } else {\n temp_file <- file.path(temp_dir, \"draw_3Dscatter.pdf\")\n }\n\n # Create the plot with file output\n p <- draw_3Dscatter(\n iris,\n group = iris$Species,\n theme = theme_darkgraygrid(),\n filename = temp_file\n )\n\n # Test that plotly object is created\n expect_s3_class(p, \"plotly\")\n\n # Test that file was successfully created by plotly/kaleido (only if temp_file is not NULL)\n if (!is.null(temp_file)) {\n expect_true(file.exists(temp_file))\n\n # Test that the file has content (not empty)\n file_info <- file.info(temp_file)\n expect_true(file_info$size > 0)\n\n # Test that it's a valid PDF file (starts with PDF header)\n file_content <- readBin(temp_file, \"raw\", n = 4)\n expect_equal(rawToChar(file_content), \"%PDF\")\n }\n})\n\n# draw_bar ----\ntest_that(\"draw_bar creates a plotly object\", {\n p <- draw_bar(VADeaths, legend_xy = c(0, 1))\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_box ----\ntest_that(\"draw_box creates a plotly object\", {\n p <- draw_box(iris[, 1:4], group = iris[[\"Species\"]], annotate_n = TRUE)\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_calibration ----\ntest_that(\"draw_calibration creates a plotly object\", {\n # Create a simple binary classification example\n set.seed(123)\n true_labels <- factor(sample(c(\"A\", \"B\"), size = 100, replace = TRUE))\n predicted_prob <- runif(100)\n p <- draw_calibration(true_labels, predicted_prob)\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_confusion ----\ntest_that(\"draw_confusion creates a plotly object\", {\n true_labels <- factor(c(\"a\", \"a\", \"a\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\", \"b\"))\n predicted_labels <- factor(c(\n \"a\",\n \"b\",\n \"a\",\n \"b\",\n \"b\",\n \"a\",\n \"b\",\n \"b\",\n \"b\",\n \"a\"\n ))\n predicted_prob <- c(0.3, 0.55, 0.45, 0.75, 0.57, 0.3, 0.8, 0.63, 0.62, 0.39)\n metrics <- classification_metrics(\n true_labels,\n predicted_labels,\n predicted_prob\n )\n p <- draw_confusion(metrics)\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_dist ----\ntest_that(\"draw_dist creates a plotly object\", {\n p <- draw_dist(iris[[\"Sepal.Length\"]], group = iris[[\"Species\"]])\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_heatmap ----\ntest_that(\"draw_heatmap creates a plotly object\", {\n x <- rnormmat(200, 20)\n xcor <- cor(x)\n p <- draw_heatmap(xcor)\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_leaflet ----\ntest_that(\"draw_leaflet creates a leaflet object\", {\n fips <- c(06075, 42101)\n population <- c(874961, 1579000)\n names <- c(\"SF\", \"Philly\")\n p <- draw_leaflet(fips, population, names)\n expect_s3_class(p, \"leaflet\")\n})\n\n# draw_pie ----\ntest_that(\"draw_pie creates a plotly object\", {\n p <- draw_pie(VADeaths[, 1, drop = FALSE])\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_protein ----\ntest_that(\"draw_protein creates a plotly object\", {\n tau <- c(\n \"M\",\n \"A\",\n \"E\",\n \"P\",\n \"R\",\n \"Q\",\n \"E\",\n \"F\",\n \"E\",\n \"V\",\n \"M\",\n \"E\",\n \"D\",\n \"H\",\n \"A\",\n \"G\",\n \"T\",\n \"Y\",\n \"G\",\n \"L\"\n )\n p <- draw_protein(tau)\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_pvals ----\ntest_that(\"draw_pvals creates a plotly object\", {\n p <- draw_pvals(\n c(0.01, 0.02, 0.03),\n xnames = c(\"Feature1\", \"Feature2\", \"Feature3\")\n )\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_scatter ----\ntest_that(\"draw_scatter creates a plotly object\", {\n p <- draw_scatter(\n iris[[\"Sepal.Length\"]],\n iris[[\"Petal.Length\"]],\n group = iris[[\"Species\"]],\n fit = \"gam\",\n se_fit = TRUE\n )\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_spectrogram ----\ntest_that(\"draw_spectrogram creates a plotly object\", {\n time <- seq(0, 1, length.out = 100)\n freq <- seq(1, 100, length.out = 100)\n power <- outer(time, freq, function(t, f) sin(t) * cos(f))\n p <- draw_spectrogram(\n x = time,\n y = freq,\n z = power\n )\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_survfit ----\ntest_that(\"draw_survfit creates a plotly object\", {\n data(cancer, package = \"survival\")\n sf2 <- survival::survfit(survival::Surv(time, status) ~ sex, data = lung)\n p <- draw_survfit(sf2)\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_table ----\ntest_that(\"draw_table creates a plotly object\", {\n df <- data.frame(\n Name = c(\"Alice\", \"Bob\", \"Charlie\"),\n Age = c(25, 30, 35),\n Score = c(90.5, 85.0, 88.0)\n )\n p <- draw_table(\n df,\n main = \"Sample Table\",\n main_col = \"#00b2b2\"\n )\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_ts ----\ntest_that(\"draw_ts creates a plotly object\", {\n time1 <- sample(seq(\n as.Date(\"2020-03-01\"),\n as.Date(\"2020-07-23\"),\n length.out = 100\n ))\n time2 <- sample(seq(\n as.Date(\"2020-05-01\"),\n as.Date(\"2020-09-23\"),\n length.out = 140\n ))\n time <- c(time1, time2)\n x <- c(rnorm(100), rnorm(140, 1, 1.5))\n group <- c(rep(\"Alpha\", 100), rep(\"Beta\", 140))\n p <- draw_ts(x, time, 7, group)\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_varimp ----\ntest_that(\"draw_varimp creates a plotly object\", {\n x <- rnorm(10)\n names(x) <- paste0(\"Feature_\", seq(x))\n p <- draw_varimp(x)\n expect_s3_class(p, \"plotly\")\n p_h <- draw_varimp(x, orientation = \"h\")\n expect_s3_class(p_h, \"plotly\")\n})\n\n# draw_volcano ----\ntest_that(\"draw_volcano creates a plotly object\", {\n set.seed(2019)\n x <- rnorm(100, mean = 0.5, sd = 2)\n pvals <- runif(100, min = 0, max = 0.1)\n p <- draw_volcano(x, pvals)\n expect_s3_class(p, \"plotly\")\n})\n\n# draw_xt ----\ntest_that(\"draw_xt creates a plotly object\", {\n datetime <- seq(\n as.POSIXct(\"2020-01-01 00:00\"),\n as.POSIXct(\"2020-01-02 00:00\"),\n by = \"hour\"\n )\n df <- data.frame(\n datetime = datetime,\n value1 = rnorm(length(datetime)),\n value2 = rnorm(length(datetime))\n )\n p <- draw_xt(df, x = df[, 1], y = df[, 2:3])\n expect_s3_class(p, \"plotly\")\n})\n" }, { "path": "tests/testthat/test_idx.R", "content": "# test_idx.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# Packages ----\nlibrary(data.table)\n\n# Data ----\nxdf <- iris\nxdt <- as.data.table(iris)\nidx <- c(\"Sepal.Length\", \"Species\")\nidi <- c(1L, 5L)\n\n# Test inc(data.frame) ----\nxdf[, idx, drop = FALSE]\nxdf[, idi, drop = FALSE]\ninc(xdf, idx)\ninc(xdf, idi)\ntest_that(\"inc(data.frame) works\", {\n expect_equal(xdf[, idx, drop = FALSE], inc(xdf, idx))\n expect_equal(xdf[, idi, drop = FALSE], inc(xdf, idi))\n expect_equal(inc(xdf, idx), inc(xdf, idi))\n})\n\n# Test inc(data.table) ----\nxdt[, ..idx]\nxdt[, idx, with = FALSE]\nxdt[, ..idi]\nxdt[, idi, with = FALSE]\ninc(xdt, idx)\ninc(xdt, idi)\ntest_that(\"inc(data.table) works\", {\n expect_equal(xdt[, ..idx], inc(xdt, idx))\n expect_equal(xdt[, ..idi], inc(xdt, idi))\n expect_equal(inc(xdt, idx), inc(xdt, idi))\n})\n\n# Test exc(data.frame) ----\nxdf[, -which(names(xdf) %in% idx)]\nxdf[, -idi]\nexc(xdf, idx)\nexc(xdf, idi)\ntest_that(\"exc(data.frame) works\", {\n expect_equal(xdf[, -which(names(xdf) %in% idx)], exc(xdf, idx))\n expect_equal(xdf[, -idi], exc(xdf, idi))\n})\n\n# Test exc(data.table) ----\nxdt[, !..idx]\nxdt[, !idx, with = FALSE]\nxdt[, !..idi]\nxdt[, !idi, with = FALSE]\nexc(xdt, idx)\ntest_that(\"exc(data.table) works\", {\n expect_equal(xdt[, !..idx, with = FALSE], exc(xdt, idx))\n})\n" }, { "path": "tests/testthat/test_massGLM.R", "content": "# test_MassGLM.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# library(rtemis)\n# library(data.table)\n# library(testthat)\nset.seed(2022)\nn <- 40L\ny <- data.table(rnormmat(500, n))\nx <- data.table(\n x1 = y[[3]] - y[[5]] + y[[14]] + rnorm(500),\n x2 = y[[21]] + rnorm(500)\n)\n\n# massGLM ----\nmassmod <- massGLM(x, y)\ntest_that(\"massGLM creates MassGLM object\", {\n expect_s7_class(massmod, MassGLM)\n})\n\n# plot.MassGLM ----\ntest_that(\"plot.MassGLM creates plotly object\", {\n plt <- plot(massmod)\n expect_s3_class(plt, \"plotly\")\n})\n\n# plot_manhattan.MassGLM ----\ntest_that(\"plot_manhattan.MassGLM creates plotly object\", {\n plt <- plot_manhattan(massmod)\n expect_s3_class(plt, \"plotly\")\n})\n" }, { "path": "tests/testthat/test_msg_sink.R", "content": "# test_msg_sink.R\n# ::rtemis::\n# 2026- EDG rtemis.org\n\n# set_msg_sink ----\ntest_that(\"set_msg_sink() accepts a function\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n set_msg_sink(function(m) NULL)\n expect_true(is.function(get_msg_sink()))\n})\n\ntest_that(\"set_msg_sink() accepts NULL\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n set_msg_sink(function(m) NULL)\n set_msg_sink(NULL)\n expect_null(get_msg_sink())\n})\n\ntest_that(\"set_msg_sink() rejects non-function, non-NULL inputs\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n expect_error(set_msg_sink(\"a string\"))\n expect_error(set_msg_sink(123))\n expect_error(set_msg_sink(list()))\n})\n\ntest_that(\"set_msg_sink() returns previous sink invisibly\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n fn1 <- function(m) NULL\n fn2 <- function(m) NULL\n set_msg_sink(NULL)\n prev1 <- set_msg_sink(fn1)\n expect_null(prev1)\n prev2 <- set_msg_sink(fn2)\n expect_identical(prev2, fn1)\n})\n\n\n# get_msg_sink ----\ntest_that(\"get_msg_sink() returns NULL when no sink is set\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n set_msg_sink(NULL)\n expect_null(get_msg_sink())\n})\n\ntest_that(\"get_msg_sink() returns the current sink function\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n fn <- function(m) NULL\n set_msg_sink(fn)\n expect_identical(get_msg_sink(), fn)\n})\n\n\n# with_msg_sink ----\ntest_that(\"with_msg_sink() sets and restores\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n set_msg_sink(NULL)\n with_msg_sink(function(m) NULL, {\n expect_true(is.function(get_msg_sink()))\n })\n expect_null(get_msg_sink())\n})\n\ntest_that(\"with_msg_sink() restores even on error\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n set_msg_sink(NULL)\n expect_error(\n with_msg_sink(function(m) NULL, stop(\"boom\")),\n \"boom\"\n )\n expect_null(get_msg_sink())\n})\n\ntest_that(\"with_msg_sink() preserves a previously set outer sink\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n outer <- function(m) NULL\n inner <- function(m) NULL\n set_msg_sink(outer)\n with_msg_sink(inner, {\n expect_identical(get_msg_sink(), inner)\n })\n expect_identical(get_msg_sink(), outer)\n})\n\n\n# msg() / msg0() / msgstart() / msgdone() routing ----\ntest_that(\"msg() emits a console message when no sink is set\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n set_msg_sink(NULL)\n expect_message(msg(\"hello\"))\n})\n\ntest_that(\"msg() routes to the sink and suppresses console output\", {\n captured <- list()\n with_msg_sink(\n function(m) captured[[length(captured) + 1L]] <<- m,\n {\n expect_silent(msg(\"hello world\"))\n }\n )\n expect_length(captured, 1L)\n expect_equal(captured[[1L]][[\"text\"]], \"hello world\")\n expect_equal(captured[[1L]][[\"level\"]], \"info\")\n expect_true(is.character(captured[[1L]][[\"ts\"]]))\n})\n\ntest_that(\"msg0() routes to the sink with sep = ''\", {\n captured <- list()\n with_msg_sink(\n function(m) captured[[length(captured) + 1L]] <<- m,\n {\n expect_silent(msg0(\"hello\", \"world\"))\n }\n )\n expect_length(captured, 1L)\n expect_equal(captured[[1L]][[\"text\"]], \"helloworld\")\n expect_equal(captured[[1L]][[\"level\"]], \"info\")\n})\n\ntest_that(\"msgstart() routes to the sink with level = 'start'\", {\n captured <- list()\n with_msg_sink(\n function(m) captured[[length(captured) + 1L]] <<- m,\n {\n expect_silent(msgstart(\"Starting...\"))\n }\n )\n expect_length(captured, 1L)\n expect_equal(captured[[1L]][[\"text\"]], \"Starting...\")\n expect_equal(captured[[1L]][[\"level\"]], \"start\")\n})\n\ntest_that(\"msgdone() routes to the sink with level = 'done' and a caller\", {\n captured <- list()\n with_msg_sink(\n function(m) captured[[length(captured) + 1L]] <<- m,\n {\n expect_silent(msgdone())\n }\n )\n expect_length(captured, 1L)\n expect_equal(captured[[1L]][[\"level\"]], \"done\")\n # caller may be NA depending on test harness call stack — assert type only\n expect_true(\n is.character(captured[[1L]][[\"caller\"]]) ||\n is.na(captured[[1L]][[\"caller\"]])\n )\n})\n\ntest_that(\"multiple msg variants accumulate as separate sink events in order\", {\n captured <- list()\n with_msg_sink(\n function(m) captured[[length(captured) + 1L]] <<- m,\n {\n msg(\"one\")\n msg0(\"two\")\n msgstart(\"three\")\n msgdone()\n }\n )\n expect_length(captured, 4L)\n expect_equal(\n vapply(captured, `[[`, character(1L), \"level\"),\n c(\"info\", \"info\", \"start\", \"done\")\n )\n expect_equal(captured[[1L]][[\"text\"]], \"one\")\n expect_equal(captured[[2L]][[\"text\"]], \"two\")\n expect_equal(captured[[3L]][[\"text\"]], \"three\")\n})\n\ntest_that(\"verbosity = 0 short-circuits before reaching the sink\", {\n captured <- list()\n with_msg_sink(\n function(m) captured[[length(captured) + 1L]] <<- m,\n {\n msg(\"ignored\", verbosity = 0L)\n msg0(\"ignored\", verbosity = 0L)\n }\n )\n expect_length(captured, 0L)\n})\n\ntest_that(\"clearing the sink restores console output\", {\n on.exit(set_msg_sink(NULL), add = TRUE)\n set_msg_sink(function(m) NULL)\n expect_silent(msg(\"under sink\"))\n set_msg_sink(NULL)\n expect_message(msg(\"after clear\"))\n})\n" }, { "path": "tests/testthat/test_strings.R", "content": "# test_strings.R\n# ::rtemis::\n# 2025 EDG rtemis.org\n\n# repr_ls ----\nx <- list(\n a = 1:5,\n b = letters[1:5],\n c = rnorm(5)\n)\nout <- repr_ls(x, title = \"Test List\")\ntest_that(\"repr_ls() works\", {\n expect_true(is.character(out))\n})\n\n## Long list ----\nx <- list(\n a = 1:100,\n b = letters[1:100],\n c = iris,\n d = sample(letters, 100, replace = TRUE),\n e = runif(100),\n f = setup_Preprocessor(),\n g = rpois(100, 2),\n h = rbinom(100, 10, 0.5),\n i = setup_PCA(),\n j = rnorm(100),\n k = rnorm(100),\n l = setup_LightCART()\n)\n\ntest_that(\"repr_ls() handles long lists\", {\n expect_true(is.character(repr_ls(x, limit = 5L)))\n expect_true(is.character(repr_ls(x, limit = -1L)))\n})\n" }, { "path": "tests/testthat/test_to_json.R", "content": "# test_to_json.R\n# ::rtemis::\n# 2026- EDG rtemis.org\n\nskip_if_not_installed(\"jsonlite\")\n\nlibrary(data.table)\n\n\n# Data ----\nn <- 100L\nx <- rnormmat(n, 3L, seed = 2026L)\ny <- x[, 1L] + x[, 2L] + rnorm(n)\ndatr <- data.table(x, y)\n\n\n# Generic ----\ntest_that(\"to_json() is a registered S7 generic\", {\n expect_true(inherits(to_json, \"S7_generic\"))\n})\n\n\n# Supervised (Regression) ----\nmod_r_glm <- train(x = datr, algorithm = \"glm\")\n\ntest_that(\"to_json(Regression) returns a list with .class and core fields\", {\n j <- to_json(mod_r_glm)\n expect_type(j, \"list\")\n expect_equal(j[[\".class\"]], \"Regression\")\n expect_equal(j[[\"type\"]], \"Regression\")\n expect_true(is.character(j[[\"xnames\"]]))\n expect_equal(j[[\"n_features\"]], length(mod_r_glm@xnames))\n})\n\ntest_that(\"to_json(Regression) recurses into nested S7 props with .class tags\", {\n j <- to_json(mod_r_glm)\n expect_true(is.list(j[[\"metrics_training\"]]))\n expect_true(\".class\" %in% names(j[[\"metrics_training\"]]))\n expect_true(is.list(j[[\"execution_config\"]]))\n expect_equal(j[[\"execution_config\"]][[\".class\"]], \"ExecutionConfig\")\n})\n\ntest_that(\"to_json(Regression) is JSON-serializable and round-trips\", {\n j <- to_json(mod_r_glm)\n txt <- jsonlite::toJSON(j, auto_unbox = TRUE, na = \"null\", null = \"null\")\n expect_true(jsonlite::validate(txt))\n parsed <- jsonlite::fromJSON(txt, simplifyVector = FALSE)\n expect_equal(parsed[[\".class\"]], \"Regression\")\n expect_equal(parsed[[\"type\"]], \"Regression\")\n})\n\ntest_that(\"to_json(Regression) excludes model, raw vectors, session_info\", {\n j <- to_json(mod_r_glm)\n expect_false(\"model\" %in% names(j))\n expect_false(\"y_training\" %in% names(j))\n expect_false(\"predicted_training\" %in% names(j))\n expect_false(\"session_info\" %in% names(j))\n expect_false(\"extra\" %in% names(j))\n})\n\ntest_that(\"to_json(Regression) drops NULL fields cleanly\", {\n j <- to_json(mod_r_glm)\n expect_true(all(vapply(j, function(v) !is.null(v), logical(1L))))\n})\n\n\n# Supervised (Classification) ----\ndatc <- data.frame(iris[51:150, ])\ndatc$Species <- factor(datc$Species)\nmod_c_glm <- train(x = datc, algorithm = \"glm\")\n\ntest_that(\"to_json(Classification) tags class and includes binclasspos\", {\n j <- to_json(mod_c_glm)\n expect_equal(j[[\".class\"]], \"Classification\")\n expect_true(\"binclasspos\" %in% names(j))\n expect_true(is.integer(j[[\"binclasspos\"]]))\n})\n\n\n# SupervisedRes ----\nresmod <- train(\n x = datr,\n algorithm = \"glm\",\n outer_resampling_config = setup_Resampler(n_resamples = 3L, type = \"KFold\")\n)\n\ntest_that(\"to_json(RegressionRes) returns a list with .class and resample summary\", {\n j <- to_json(resmod)\n expect_type(j, \"list\")\n expect_equal(j[[\".class\"]], \"RegressionRes\")\n expect_equal(j[[\"n_resamples\"]], 3L)\n expect_true(is.list(j[[\"outer_resampler\"]]))\n expect_true(is.list(j[[\"metrics_training\"]]))\n expect_true(is.list(j[[\"metrics_test\"]]))\n})\n\ntest_that(\"to_json(RegressionRes) is JSON-serializable\", {\n j <- to_json(resmod)\n txt <- jsonlite::toJSON(j, auto_unbox = TRUE, na = \"null\", null = \"null\")\n expect_true(jsonlite::validate(txt))\n parsed <- jsonlite::fromJSON(txt, simplifyVector = FALSE)\n expect_equal(parsed[[\".class\"]], \"RegressionRes\")\n expect_equal(parsed[[\"n_resamples\"]], 3L)\n})\n\ntest_that(\"to_json(RegressionRes) excludes models list (only summary count)\", {\n j <- to_json(resmod)\n expect_false(\"models\" %in% names(j))\n})\n\n\n# Default method ----\ntest_that(\"default to_json walks props and tags .class for arbitrary S7 objects\", {\n exec <- setup_ExecutionConfig()\n j <- to_json(exec)\n expect_type(j, \"list\")\n expect_equal(j[[\".class\"]], \"ExecutionConfig\")\n})\n" }, { "path": "tests/testthat.R", "content": "library(rtemis)\nlibrary(testthat)\n\ntest_check(\"rtemis\")\n" } ]